mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-22 12:33:39 -08:00
1200 lines
42 KiB
Common Lisp
1200 lines
42 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
|
||
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
||
|
||
;;;; Author: Juan Jose Garcia-Ripoll
|
||
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
|
||
;;;; Contains: Compiler regression tests
|
||
|
||
(in-package :cl-test)
|
||
|
||
(suite 'cmp)
|
||
|
||
|
||
;; cl-001
|
||
|
||
;;; Date: 09/05/2006
|
||
;;; From: Brian Spilsbury
|
||
;;; Fixed: 20/05/2006 (Brian Spilsbury)
|
||
;;; Description:
|
||
;;;
|
||
;;; (DEFPACKAGE "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T"))
|
||
;;; fails to import symbol NIL because IMPORT is invoked as
|
||
;;; (IMPORT NIL (find-package "CL")), which does not import
|
||
;;; any symbol.
|
||
;;;
|
||
(test cmp.0001.import
|
||
(defpackage "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T"))
|
||
(multiple-value-bind (symbol access)
|
||
(find-symbol "NIL" (find-package "FOO"))
|
||
(is (and (eql symbol NIL)
|
||
(eql access :INTERNAL))))
|
||
(delete-package "FOO"))
|
||
|
||
;;; Date: 09/05/2006
|
||
;;; From: Brian Spilsbury
|
||
;;; Fixed: 20/05/2006 (Brian Spilsbury)
|
||
;;; Description:
|
||
;;;
|
||
;;; Compiled FLET forms failed to shadow global macro definitions, if not
|
||
;;; for the compiler, at least for MACRO-FUNCTION and MACROEXPAND[-1]
|
||
;;;
|
||
(test cmp.0002.macro-shadow
|
||
(with-compiler ("aux-cl-0002.lsp" :load t)
|
||
'(defmacro foo () 2)
|
||
'(defmacro bar (symbol &environment env)
|
||
(and (macro-function symbol env) t))
|
||
'(defun doit () (flet ((foo () 1)) (bar foo))))
|
||
(delete-file "aux-cl-0002.lsp")
|
||
(delete-file (compile-file-pathname "aux-cl-0002" :type :fas))
|
||
(is-false (doit))
|
||
(fmakunbound 'doit)
|
||
(fmakunbound 'bar)
|
||
(fmakunbound 'foo))
|
||
|
||
;;;
|
||
;;; Fixed: 14/06/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; APROPOS, APROPOS-LIST and HELP* are case sensitive.
|
||
;;;
|
||
(test cmp.0003.apropos
|
||
(is (equal (apropos-list "bin")
|
||
(apropos-list "bin"))))
|
||
|
||
;;; Date: 08/07/2006 (Dave Roberts)
|
||
;;; Fixed: 02/08/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; SLIME traps when invoking DESCRIBE. Reason is that STREAMP breaks on
|
||
;;; Gray streams.
|
||
;;;
|
||
(test cmp.0004.streamp
|
||
(is-true (streamp (make-instance 'gray:fundamental-stream))))
|
||
|
||
;;; Date: 02/08/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; There is a problem with SUBTYPEP and type STREAM
|
||
;;;
|
||
(test cmp.0005.subtypep-stream
|
||
(is (equal (multiple-value-list
|
||
(subtypep (find-class 'gray:fundamental-stream) 'stream))
|
||
(list t t))))
|
||
|
||
;;; Date: 09/07/2006 (Tim S)
|
||
;;; Fixed: 09/07/2006 (Tim S)
|
||
;;; Description:
|
||
;;;
|
||
;;; ENOUGH-NAMESTRING provided too large pathnames even when the
|
||
;;; pathname was a subdirectory of the default pathname.
|
||
;;;
|
||
;;; Date: 31/12/2006 (Richard M. Kreuter)
|
||
;;; Fixed: 5/1/2007 (Juanjo)
|
||
;;; Description:
|
||
;;; ENOUGH-NAMESTRING does not simplify the pathname when the
|
||
;;; directory matches completely that of the default path.
|
||
;;;
|
||
|
||
|
||
(ext:with-clean-symbols (*enough-namestring_tests*)
|
||
(defvar *enough-namestring_tests*
|
||
`(("/A/b/C/"
|
||
("/A/b/C/drink-up.sot"
|
||
"/A/b/C/loozer/whiskey.sot"
|
||
"/A/b/C/loozer/whiskey"
|
||
"/A/b/whiskey.sot"
|
||
"/A/"
|
||
"whiskey.sot"
|
||
"loozer/whiskey.sot"
|
||
"C/loozer/whisky.sot"
|
||
""))
|
||
("A/b/C" ("A/b/C" "A/b/C/loozer" "b/C" "/A/b/C" "/A/" ""))
|
||
("/" ("/A/b/C/drink-up.sot" "/A/b/C/" "/A/" ""))
|
||
("" ("/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.sot"
|
||
"/A/b/C/loozer/whiskey" "/A/b/whiskey.sot"
|
||
"/A/" "whiskey.sot" "loozer/whiskey.sot" "C/loozer/whisky.sot"))
|
||
("/A/*/C/drink-up.sot"
|
||
("/A/*/C/drink-up.sot" "/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.*"
|
||
"/A/b/C/loozer/*.sot" "/A/**/whiskey.sot" ""))
|
||
("/A/b/../c/d.sot" ("/A/b/../c/d.sot" "/A/b/../c/D/e.sot"
|
||
"/A/c/d.sot" "../c/d.sot"
|
||
"c/e/d.sot"))))
|
||
|
||
(test cmp.0006.enough-namestring
|
||
(labels ((test-path (path defaults)
|
||
(let* ((e-ns (enough-namestring path defaults))
|
||
(d1 (pathname-directory path))
|
||
(d2 (pathname-directory defaults))
|
||
(d3 (pathname-directory e-ns)))
|
||
(and (equalp (merge-pathnames e-ns defaults)
|
||
(merge-pathnames (parse-namestring path nil defaults)
|
||
defaults))
|
||
;; If directories concide, the "enough-namestring"
|
||
;; removes the directory. But only if the pathname is
|
||
;; absolute.
|
||
(not (and (equal (first d1) ':absolute)
|
||
(equalp d1 d2)
|
||
d3)))))
|
||
(test-default+paths (default+paths)
|
||
(let ((defaults (first default+paths))
|
||
(paths (second default+paths)))
|
||
(every (lambda (path)
|
||
(handler-case (test-path path defaults)
|
||
(error (error) 'NIL)))
|
||
paths))))
|
||
(is-true
|
||
(every #'test-default+paths *enough-namestring_tests*)))))
|
||
|
||
;;; Date: 10/08/2006 (Lars Brinkhoff)
|
||
;;; Fixed: 1/09/2006 (juanjo)
|
||
;;; Details:
|
||
;;;
|
||
;;; ADJUST-ARRAY must signal a type error when the value of :FILL-POINTER is
|
||
;;; not NIL and the adjustable array does not have a fill pointer
|
||
;;;
|
||
(test cmp.0007.adjustable-array
|
||
(is (equal
|
||
(loop for fp in '(nil t) collect
|
||
(loop for i in '(t nil 0 1 2 3) collect
|
||
(and
|
||
(handler-case (adjust-array (make-array 3 :adjustable t :fill-pointer fp) 4
|
||
:fill-pointer i)
|
||
(type-error (c) nil)
|
||
(error (c) t))
|
||
t)))
|
||
'((nil t nil nil nil nil) (t t t t t t)))))
|
||
|
||
;;; Date: 09/10/2006 (Dustin Long)
|
||
;;; Fixed: 10/10/2006
|
||
;;; Description:
|
||
;;;
|
||
;;; The namestring "." is improperly parsed, getting a file type of ""
|
||
;;; Additionally we found it more convenient to have the _last_ dot mark
|
||
;;; the file type, so that (pathname-type "foo.mpq.txt") => "txt"
|
||
;;;
|
||
|
||
(test cmp.0008.parse-namestring
|
||
(is-false
|
||
(loop for (namestring name type) in
|
||
'(("." "." NIL) (".." "." "") (".foo" ".foo" NIL) (".foo.mpq.txt" ".foo.mpq" "txt")
|
||
("foo.txt" "foo" "txt") ("foo.mpq.txt" "foo.mpq" "txt"))
|
||
unless (let ((x (parse-namestring namestring)))
|
||
(and (equal name (pathname-name x))
|
||
(equal type (pathname-type x))
|
||
(equal '() (pathname-directory x))))
|
||
collect namestring)))
|
||
|
||
;;; Date: 28/09/2006
|
||
;;; Fixed: 10/10/2006
|
||
;;; Description:
|
||
;;;
|
||
;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized
|
||
;;; The following code tests that at least three objects are finalized.
|
||
;;;
|
||
;;; Note: this test fails in multithreaded mode. GC takes too long!
|
||
(test cmp.0009.finalization
|
||
(is-equal '(0 1 2 3 4)
|
||
(let ((all-tags))
|
||
(flet ((custom-finalizer (tag)
|
||
#'(lambda (o)
|
||
(declare (ignore o))
|
||
(push tag all-tags))))
|
||
(let ((a '()))
|
||
(dotimes (i 5)
|
||
(let ((x (cons i i)))
|
||
(si::set-finalizer x (custom-finalizer i))
|
||
(push x a))))
|
||
;; mitigate GC slowness
|
||
(sleep 1)
|
||
(dotimes (j 100)
|
||
(dotimes (i 10000)
|
||
(cons 1.0 1.0))
|
||
(ext:gc t)))
|
||
(sort all-tags #'<))))
|
||
|
||
;;; Date: 8/10/2006 (Dustin Long)
|
||
;;; Fixed: 10/10/2006 (Dustin Long)
|
||
;;; Description:
|
||
;;;
|
||
;;; Hash table iterators have to check that their argument is
|
||
;;; really a hash table.
|
||
;;;
|
||
(test cmp.0010.hash-iterator
|
||
(is-false
|
||
(loop for i in *mini-universe*
|
||
when (and (not (hash-table-p i))
|
||
(handler-case (progn (loop for k being the hash-keys of i) t)
|
||
(error (c) nil)))
|
||
collect (type-of i))))
|
||
|
||
;;; Date: 31/12/2006 (Richard M. Kreuter)
|
||
;;; Fixed: 5/1/2007 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; The keyword :BACK does not work as expected when creating pathnames
|
||
;;; and causes an error when at the beginning: (:RELATIVE :BACK)
|
||
;;;
|
||
(test cmp.0011.make-pathname-with-back
|
||
(is-false
|
||
(loop for i from 0 to 200
|
||
with l = (random 10)
|
||
with x = (if (zerop l) 0 (random (1+ l)))
|
||
with y = (if (= l x) 0 (random (- l x)))
|
||
nconc (let* ((l (loop for i from 0 below l collect (princ-to-string i)))
|
||
(l2 (append (subseq l 0 y) '("break" :back) (subseq l y nil)))
|
||
(d1 (list* :absolute (subseq l2 0 x)))
|
||
(d2 (list* :relative (subseq l2 x nil)))
|
||
(d3 (list* :absolute l2))
|
||
(d4 (list* :relative l2))
|
||
(p1 (handler-case (make-pathname :directory d1)
|
||
(error (c) nil)))
|
||
(p2 (handler-case (make-pathname :directory d2)
|
||
(error (c) nil)))
|
||
(p3 (handler-case (make-pathname :directory d3)
|
||
(error (c) nil)))
|
||
(p4 (handler-case (make-pathname :directory d4)
|
||
(error (c) nil))))
|
||
(if (and p1 p2 p3 p4
|
||
;; MERGE-PATHNAMES eliminates :BACK
|
||
(equalp l (rest (pathname-directory (merge-pathnames p2 p1))))
|
||
;; MAKE-PATHNAME does not eliminate :BACK
|
||
(not (equalp l (rest (pathname-directory (make-pathname :directory d3)))))
|
||
(not (equalp l (rest (pathname-directory (make-pathname :directory d4))))))
|
||
nil
|
||
(list (list l d1 d2 d3 d4 l2 x y)))))))
|
||
|
||
;;; Date: 11/03/2007 (Fare)
|
||
;;; Fixed: 23/03/2007 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; COPY-READTABLE did not copy the entries of the "from" table
|
||
;;; when a second argument, i.e. a "destination" table was supplied.
|
||
;;;
|
||
(test cmp.0012.copy-readtable
|
||
(is-false
|
||
(let ((from-readtable (copy-readtable))
|
||
(to-readtable (copy-readtable))
|
||
(char-list '()))
|
||
(dotimes (i 20)
|
||
(let* ((code (+ 32 (random 70)))
|
||
(c (code-char code)))
|
||
(push c char-list)
|
||
(set-macro-character c
|
||
(eval `(lambda (str ch) ,code))
|
||
nil
|
||
from-readtable)))
|
||
(copy-readtable from-readtable to-readtable)
|
||
(loop for c in char-list
|
||
unless (and (eql (char-code c)
|
||
(let ((*readtable* from-readtable))
|
||
(read-from-string (string c))))
|
||
(eq (get-macro-character c from-readtable)
|
||
(get-macro-character c to-readtable)))
|
||
collect c))))
|
||
|
||
;;; Date: 05/01/2008 (Anonymous, SF bug report)
|
||
;;; Fixed: 06/01/2008 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; For a file linked as follows "ln -s //usr/ /tmp/foo",
|
||
;;; (truename #p"/tmp/foo") signals an error because //usr is
|
||
;;; parsed as a hostname.
|
||
;;;
|
||
#-(or cygwin haiku windows)
|
||
(test cmp.0013.truename
|
||
(si:system "rm -rf foo; ln -sf //usr/ foo")
|
||
(is (equal (namestring (truename "./foo")) "/usr/"))
|
||
(si::system "rm foo"))
|
||
|
||
;;; Date: 30/08/2008 (Josh Elsasser)
|
||
;;; Fixed: 01/09/2008 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; Inside the form read by #., recursive definitions a la #n=
|
||
;;; and #n# were not properly expanded
|
||
;;;
|
||
(test cmp.0014.sharp-dot
|
||
(is
|
||
(equal (with-output-to-string (*standard-output*)
|
||
(let ((*print-circle* t))
|
||
(read-from-string "'#.(princ (list '#1=(1 2) '#1#))")))
|
||
"(#1=(1 2) #1#)")))
|
||
|
||
;;; Date: 30/08/2008 (Josh Elsasser)
|
||
;;; Fixed: 30/08/2008 (Josh Elsasser)
|
||
;;; Description:
|
||
;;;
|
||
;;; A setf expansion that produces a form with a macro that also has
|
||
;;; its own setf expansion does not giver rise to the right code.
|
||
;;;
|
||
(test cmp.0015.setf-expander
|
||
(define-setf-expander triple (place &environment env)
|
||
(multiple-value-bind (dummies vals newval setter getter)
|
||
(get-setf-expansion place env)
|
||
(let ((store (gensym)))
|
||
(values dummies
|
||
vals
|
||
`(,store)
|
||
`(let ((,(car newval) (/ ,store 3)))
|
||
(triple ,setter))
|
||
`(progn
|
||
(triple ,getter))))))
|
||
(defmacro hidden (val)
|
||
`(triple ,val))
|
||
(defmacro triple (val)
|
||
`(* 3 ,val))
|
||
(is-true (equalp
|
||
(eval '(let ((foo 5))
|
||
(list foo (triple foo) (setf (triple foo) 6) foo (triple foo))))
|
||
(eval '(let ((foo 5))
|
||
(list foo (hidden foo) (setf (hidden foo) 6) foo (hidden foo))))))
|
||
(fmakunbound 'hidden)
|
||
(fmakunbound 'triple))
|
||
|
||
;;; Date: 17/2/2009
|
||
;;; Fixed: 17/2/2009
|
||
;;; Description:
|
||
;;;
|
||
;;; The defstruct form fails with an :include field that overwrites
|
||
;;; a slot that is read only.
|
||
;;;
|
||
(defstruct compiler.0016-a (a 1 :read-only t))
|
||
(defstruct (compiler.0016-b (:include compiler.0016-a (a 2))))
|
||
(defstruct (compiler.0016-c (:include compiler.0016-a (a 3 :read-only t))))
|
||
(test cmp.0016.defstruct-include
|
||
(is-true
|
||
(handler-case
|
||
(eval '(defstruct (compiler.0016-d (:include compiler.0016-a (a 2 :read-only nil)))))
|
||
(error (c) t)))
|
||
(is (= (compiler.0016-a-a (make-compiler.0016-a)) 1))
|
||
(is (= (compiler.0016-b-a (make-compiler.0016-b)) 2))
|
||
(is (= (compiler.0016-c-a (make-compiler.0016-c)) 3))
|
||
(is-true
|
||
(handler-case
|
||
(eval '(setf (compiler.0016-c-a (make-compiler.0016-c)) 3))
|
||
(error (c) t))))
|
||
|
||
;;; Date: 9/11/2009
|
||
;;; Fixed: 9/11/2009
|
||
;;; Description:
|
||
;;;
|
||
;;; LOAD does not work with special files (/dev/null)
|
||
;;;
|
||
(test cmp.0017.load-special
|
||
(finishes
|
||
(load #+(or windows mingw32) "NUL"
|
||
#-(or windows mingw32) "/dev/null")))
|
||
|
||
;;; Date: 16/11/2009 (Gabriel)
|
||
;;; Fixed: 20/11/2009 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; #= and ## reader macros do not work well with #.
|
||
;;;
|
||
(test cmp.0018.sharp-eq
|
||
(is
|
||
(equal (handler-case (values (read-from-string "(#1=(0 1 2) #.(length '#1#))"))
|
||
(serious-condition (c) nil))
|
||
'((0 1 2) 3))))
|
||
|
||
;;; Date: 14/11/2009 (M. Mondor)
|
||
;;; Fixed: 20/11/2009 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; FDEFINITION and SYMBOL-FUNCTION cause SIGSEGV when acting on NIL.
|
||
;;;
|
||
(test cmp.0019.fdefinition
|
||
(is-true
|
||
(handler-case (fdefinition nil)
|
||
(undefined-function (c) t)
|
||
(serious-condition (c) nil)))
|
||
(is-true
|
||
(handler-case (symbol-function nil)
|
||
(undefined-function (c) t)
|
||
(serious-condition (c) nil))))
|
||
|
||
|
||
;;; Date: 29/11/2009 (P. Costanza)
|
||
;;; Fixed: 29/11/2009 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE.
|
||
;;;
|
||
(ext:with-clean-symbols (*update-guard* class-a class-a-b)
|
||
(test cmp.0020.make-instances-obsolete
|
||
(defparameter *update-guard* nil)
|
||
(defclass class-a () ((b :accessor class-a-b :initarg :b)))
|
||
(let ((*a* (make-instance 'class-a :b 2)))
|
||
(defmethod update-instance-for-redefined-class :before
|
||
((instance standard-object) added-slots discarded-slots property-list
|
||
&rest initargs)
|
||
(setf *update-guard* t))
|
||
(is-true
|
||
(and (null *update-guard*)
|
||
(progn (class-a-b *a*) (null *update-guard*))
|
||
(progn (make-instances-obsolete (find-class 'class-a))
|
||
(null *update-guard*))
|
||
(progn (class-a-b *a*) *update-guard*)
|
||
(progn (setf *update-guard* nil)
|
||
(defclass class-a () ((b :accessor class-a-b :initarg :b)))
|
||
(class-a-b *a*)
|
||
*update-guard*))))))
|
||
|
||
;;; Date: 25/03/2009 (R. Toy)
|
||
;;; Fixed: 4/12/2009 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; Conversion of rationals into floats is done by truncating, not by
|
||
;;; rounding, what implies a loss of accuracy.
|
||
;;;
|
||
(test cmp.0021.ratio-to-float
|
||
;; The test builds a ratio which is very close to 1 but which is below it
|
||
;; If we truncate instead of rounding the output will not be 1 coerced
|
||
;; to that floating point type.
|
||
(is-false
|
||
(loop for type in '(short-float single-float double-float long-float)
|
||
for bits = (float-precision (coerce 1 type))
|
||
do (loop for i from (+ bits 7) to (+ bits 13)
|
||
nconc (loop with value = (ash 1 i)
|
||
with expected = (coerce 1 type)
|
||
for j from 0 to 10
|
||
for x = (- value j)
|
||
for r = (/ (1- x) x)
|
||
for f1 = (coerce r type)
|
||
for f2 = (- (coerce (- r) type))
|
||
unless (and (= f1 expected) (= f2 expected))
|
||
collect (list type r))))))
|
||
|
||
;;; Date: 06/04/2010 (M. Kocic)
|
||
;;; Fixed: 4/12/2009
|
||
;;; Description:
|
||
;;;
|
||
;;; Inspection of structs is broken due to undefined inspect-indent
|
||
;;;
|
||
(ext:with-clean-symbols (st1)
|
||
(test cmp.0022.inspect-struct
|
||
(is-true
|
||
(let ((*query-io* (make-string-input-stream "q
|
||
")))
|
||
(defstruct st1 p1)
|
||
(let ((v1 (make-st1 :p1 "tttt")))
|
||
(handler-case (progn (inspect v1) t)
|
||
(error (c) nil)))))))
|
||
|
||
|
||
;; cmp-001
|
||
|
||
;;; Date: 12/03/2006
|
||
;;; From: Dan Corkill
|
||
;;; Fixed: 14/04/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; The inner RETURN form should return to the outer block.
|
||
;;; However, the closure (lambda (x) ...) is improperly translated
|
||
;;; by the compiler to (lambda (x) (block nil ...) and thus this
|
||
;;; form outputs '(1 2 3 4).
|
||
;;;
|
||
(test cmp.0023.block
|
||
(is
|
||
(= (funcall (compile nil
|
||
'(lambda ()
|
||
(block nil
|
||
(funcall 'mapcar
|
||
#'(lambda (x)
|
||
(when x (return x)))
|
||
'(1 2 3 4)))))))))
|
||
|
||
;;; Fixed: 12/01/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as
|
||
;;; synonyms.
|
||
;;;
|
||
;;;
|
||
(test cmp.0024.pathname
|
||
(is (equalp (compile-file-pathname "foo" :type :fas)
|
||
(compile-file-pathname "foo" :type :fasl))))
|
||
|
||
;;; Fixed: 21/12/2005 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; Compute the path of the intermediate files (*.c, *.h, etc)
|
||
;;; relative to that of the fasl or object file.
|
||
;;;
|
||
(ext:with-clean-symbols (foo)
|
||
(test cmp.0025.paths
|
||
(let* ((output (compile-file-pathname "tmp/ecl-aux" :type :fasl))
|
||
#-ecl-bytecmp
|
||
(h-file (compile-file-pathname output :type :h))
|
||
#-ecl-bytecmp
|
||
(c-file (compile-file-pathname output :type :c))
|
||
#-ecl-bytecmp
|
||
(data-file (compile-file-pathname output :type :data)))
|
||
(and
|
||
(zerop (si::system "rm -rf tmp; mkdir -p tmp"))
|
||
(null (nth-value 2 (ext:run-program "rm" '("-rf" "tmp"))))
|
||
(null (nth-value 2 (ext:run-program "mkdir" '("-p" "tmp"))))
|
||
(is (with-compiler ("aux-compiler.0103-paths.lsp"
|
||
:output-file output
|
||
:c-file t :h-file t :data-file t)
|
||
'(defun foo (x) (1+ x))))
|
||
(is (probe-file output))
|
||
#-ecl-bytecmp
|
||
(is (probe-file c-file))
|
||
#-ecl-bytecmp
|
||
(is (probe-file h-file))
|
||
#-ecl-bytecmp
|
||
(is (probe-file data-file))
|
||
(null (nth-value 2 (ext:run-program "rm" '("-rf" "tmp"))))
|
||
(null (nth-value 2 (ext:run-program "mkdir" '("-p" "tmp"))))
|
||
(delete-file "aux-compiler.0103-paths.lsp")))))
|
||
|
||
;;; Date: 08/03/2006
|
||
;;; From: Dan Corkill
|
||
;;; Fixed: 09/03/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; DEFCONSTANT does not declare the symbol as global and thus the
|
||
;;; compiler issues warnings when the symbol is referenced in the
|
||
;;; same file in which it is defined as constant.
|
||
;;;
|
||
#-ecl-bytecmp
|
||
(test cmp.0026.defconstant-warn
|
||
(is-false
|
||
(let ((warn nil))
|
||
(with-dflet ((c::cmpwarn (setf warn t)))
|
||
(with-compiler ("aux-compiler.0104.lsp")
|
||
'(defconstant foo (list 1 2 3))
|
||
'(print foo)))
|
||
(delete-file "aux-compiler.0104.lsp")
|
||
(delete-file (compile-file-pathname "aux-compiler.0104.lsp" :type :fas))
|
||
warn)))
|
||
|
||
;;; Date: 16/04/2006
|
||
;;; From: Juanjo
|
||
;;; Fixed: 16/04/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; Special declarations should only affect the variable bound and
|
||
;;; not their initialization forms. That, even if the variables are
|
||
;;; the arguments of a function.
|
||
;;;
|
||
(test cmp.0027.declaration
|
||
(let ((form '(lambda (y)
|
||
(flet ((faa (&key (x y))
|
||
(declare (special y))
|
||
x))
|
||
(let ((y 4))
|
||
(declare (special y))
|
||
(faa))))))
|
||
;; We must test that both the intepreted and the compiled form
|
||
;; output the same value.
|
||
(is (= (funcall (compile 'nil form) 3) 3))
|
||
(is (= (funcall (coerce form 'function) 3) 3))))
|
||
|
||
;;; Date: 26/04/2006
|
||
;;; From: Michael Goffioul
|
||
;;; Fixed: ----
|
||
;;; Description:
|
||
;;;
|
||
;;; Functions with more than 64 arguments have to be invoked using
|
||
;;; the lisp stack.
|
||
;;;
|
||
(test cmp.0028.call-arguments-limit
|
||
(let ((form '(lambda ()
|
||
(list (list
|
||
'a0 'b0 'c0 'd0 'e0 'f0 'g0 'h0 'i0
|
||
'j0 'k0 'l0 'm0 'n0 'o0 'p0 'q0
|
||
'r0 's0 't0 'u0 'v0 'w0 'x0 'y0 'z0
|
||
'a1 'b1 'c1 'd1 'e1 'f1 'g1 'h1 'i1
|
||
'j1 'k1 'l1 'm1 'n1 'o1 'p1 'q1
|
||
'r1 's1 't1 'u1 'v1 'w1 'x1 'y1 'z1
|
||
'a2 'b2 'c2 'd2 'e2 'f2 'g2 'h2 'i2
|
||
'j2 'k2 'l2 'm2 'n2 'o2 'p2 'q2
|
||
'r2 's2 't2 'u2 'v2 'w2 'x2 'y2 'z2
|
||
'a3 'b3 'c3 'd3 'e3 'f3 'g3 'h3 'i3
|
||
'j3 'k3 'l3 'm3 'n3 'o3 'p3 'q3
|
||
'r3 's3 't3 'u3 'v3 'w3 'x3 'y3 'z3
|
||
'a4 'b4 'c4 'd4 'e4 'f4 'g4 'h4 'i4
|
||
'j4 'k4 'l4 'm4 'n4 'o4 'p4 'q4
|
||
'r4 's4 't4 'u4 'v4 'w4 'x4 'y4 'z4
|
||
'a5 'b5 'c5 'd5 'e5 'f5 'g5 'h5 'i5
|
||
'j5 'k5 'l5 'm5 'n5 'o5 'p5 'q5
|
||
'r5 's5 't5 'u5 'v5 'w5 'x5 'y5 'z5
|
||
'a6 'b6 'c6 'd6 'e6 'f6 'g6 'h6 'i6
|
||
'j6 'k6 'l6 'm6 'n6 'o6 'p6 'q6
|
||
'r6 's6 't6 'u6 'v6 'w6 'x6 'y6 'z6)))))
|
||
(is (equal (funcall (compile 'foo form))
|
||
(funcall (coerce form 'function))))))
|
||
|
||
;;; Date: 16/05/2005
|
||
;;; Fixed: 18/05/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; The detection of when a lisp constant has to be externalized using MAKE-LOAD-FORM
|
||
;;; breaks down with some circular structures
|
||
;;;
|
||
(defclass compiler-test-class ()
|
||
((parent :accessor compiler-test-parent :initform nil)
|
||
(children :initarg :children :accessor compiler-test-children :initform nil)))
|
||
|
||
(defmethod make-load-form ((x compiler-test-class) &optional environment)
|
||
(declare (ignore environment))
|
||
(values
|
||
;; creation form
|
||
`(make-instance ',(class-of x) :children ',(slot-value x 'children))
|
||
;; initialization form
|
||
`(setf (compiler-test-parent ',x) ',(slot-value x 'parent))))
|
||
|
||
(test cmp.0029.circular-load-form
|
||
(is
|
||
(equal
|
||
(loop for object in
|
||
(let ((l (list 1 2 3)))
|
||
(list l
|
||
(subst 3 l l)
|
||
(make-instance 'compiler-test-class)
|
||
(subst (make-instance 'compiler-test-class) 3 l)))
|
||
collect (clos::need-to-make-load-form-p object nil))
|
||
'(nil nil t t))))
|
||
|
||
;;; Date: 18/05/2005
|
||
;;; Fixed: 17/05/2006 (Brian Spilsbury & juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; The compiler is not able to externalize constants that have no
|
||
;;; printed representation. In that case MAKE-LOAD-FORM should be
|
||
;;; used.
|
||
;;;
|
||
(test cmp.0030.make-load-form
|
||
(let ((output
|
||
(with-compiler ("make-load-form.lsp")
|
||
"(in-package cl-test)"
|
||
"(eval-when (:compile-toplevel)
|
||
(defvar s4 (make-instance 'compiler-test-class))
|
||
(defvar s5 (make-instance 'compiler-test-class))
|
||
(setf (compiler-test-parent s5) s4)
|
||
(setf (compiler-test-children s4) (list s5)))"
|
||
"(defvar a '#.s5)"
|
||
"(defvar b '#.s4)"
|
||
"(defvar c '#.s5)"
|
||
"(defun foo ()
|
||
(let ((*print-circle* t))
|
||
(with-output-to-string (s) (princ '#1=(1 2 3 #.s4 #1#) s))))")))
|
||
(load output)
|
||
(delete-file "make-load-form.lsp")
|
||
(delete-file output))
|
||
(is-equal "#1=(1 2 3 #<a CL-TEST::COMPILER-TEST-CLASS> #1#)" (foo)))
|
||
|
||
;;; Date: 9/06/2006 (Pascal Costanza)
|
||
;;; Fixed: 13/06/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; A MACROLET function creates a set of local macro definitions.
|
||
;;; The forms that expand these macros are themselves affected by
|
||
;;; enclosing MACROLET and SYMBOL-MACRO definitions:
|
||
;;; (defun bar ()
|
||
;;; (macrolet ((x () 2))
|
||
;;; (macrolet ((m () (x)))
|
||
;;; (m))))
|
||
;;; (compile 'bar)
|
||
;;; (bar) => 2
|
||
;;;
|
||
(ext:with-clean-symbols (bar)
|
||
(test cmp.0031.macrolet
|
||
(is (= 2 (progn
|
||
(defun bar ()
|
||
(macrolet ((x () 2))
|
||
(macrolet ((m () (x)))
|
||
(m))))
|
||
(compile 'bar)
|
||
(bar))))
|
||
(is (= 2 (progn
|
||
(defun bar ()
|
||
(symbol-macrolet ((x 2))
|
||
(macrolet ((m () x))
|
||
(m))))
|
||
(compile 'bar)
|
||
(bar))))))
|
||
|
||
;;; Fixed: 13/06/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; A MACROLET that references a local variable from the form in
|
||
;;; which it appears can cause corruption in the interpreter. We
|
||
;;; solve this by signalling errors whenever such reference
|
||
;;; happens.
|
||
;;;
|
||
;;; Additionally MACROLET forms should not see the other macro
|
||
;;; definitions on the same form, much like FLET functions cannot
|
||
;;; call their siblings.
|
||
;;;
|
||
(ext:with-clean-symbols (compiler-foo)
|
||
(test cmp.0032.macrolet-2
|
||
(is-equal '(error 1 error error 6 (7 8) error error)
|
||
(flet ((eval-with-error (form)
|
||
(handler-case (eval form)
|
||
(error (c) 'error))))
|
||
(let ((faa 1))
|
||
(declare (special faa))
|
||
(mapcar #'eval-with-error
|
||
'((let ((faa 2))
|
||
(macrolet ((m () faa))
|
||
(m)))
|
||
(let ((faa 4))
|
||
(declare (special faa))
|
||
(macrolet ((m () faa))
|
||
(m)))
|
||
(let ((faa 4))
|
||
(declare (special compiler-foo))
|
||
(macrolet ((m () compiler-foo))
|
||
(m)))
|
||
(let ((faa 5))
|
||
(macrolet ((m () compiler-foo))
|
||
(m)))
|
||
(macrolet ((compiler-foo () 6))
|
||
(macrolet ((m () (compiler-foo)))
|
||
(m)))
|
||
(macrolet ((f1 () 7)
|
||
(f2 () 8))
|
||
;; M should not see the new definitions F1 and F2
|
||
(macrolet ((f1 () 9)
|
||
(f2 () 10)
|
||
(m () (list 'quote (list (f1) (f2)))))
|
||
(m)))
|
||
(flet ((compiler-foo () 1))
|
||
(macrolet ((m () (compiler-foo)))
|
||
(m)))
|
||
(labels ((compiler-foo () 1))
|
||
(macrolet ((m () (compiler-foo)))
|
||
(m))))))))
|
||
(makunbound 'compiler-foo)
|
||
(fmakunbound 'compiler-foo)))
|
||
|
||
;;; Date: 22/06/2006 (juanjo)
|
||
;;; Fixed: 29/06/2006 (juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; ECL only accepted functions with less than 65 required
|
||
;;; arguments. Otherwise it refused to compile the function. The fix must
|
||
;;; respect the limit in the number of arguments passed in the C stack and
|
||
;;; use the lisp stack for the other required arguments.
|
||
;;;
|
||
#-ecl-bytecmp
|
||
(test cmp.0033.c-arguments-limit
|
||
(is (equal '((10 :ERROR :ERROR) (20 :ERROR :ERROR) (30 :ERROR :ERROR)
|
||
(40 :ERROR :ERROR) (50 :ERROR :ERROR) (63 :ERROR :ERROR)
|
||
(64 :ERROR :ERROR) (65 :ERROR :ERROR) (70 :ERROR :ERROR))
|
||
(mapcar
|
||
#'(lambda (nargs)
|
||
(let* ((arg-list (loop for i from 0 below nargs
|
||
collect (intern (format nil "arg~d" i))))
|
||
(data (loop for i from 0 below nargs collect i))
|
||
(lambda-form `(lambda ,arg-list
|
||
(and (equalp (list ,@arg-list) ',data)
|
||
,nargs)))
|
||
(c:*compile-verbose* nil)
|
||
(c:*compile-print* nil)
|
||
(function (compile 'foo lambda-form)))
|
||
(list (apply function (subseq data 0 nargs))
|
||
(handler-case (apply function (make-list (1+ nargs)))
|
||
(error (c) :error))
|
||
(handler-case (apply function (make-list (1- nargs)))
|
||
(error (c) :error)))))
|
||
'(10 20 30 40 50 63 64 65 70)))))
|
||
|
||
;;; Date: 12/07/2008 (Josh Elsasser)
|
||
;;; Fixed: 02/08/2008 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; ECL fails to properly compute the closure type of a function that
|
||
;;; returns a lambda that calls the function itself.
|
||
;;;
|
||
(test cmp.0034.compute-closure
|
||
(is
|
||
(with-compiler ("aux-compiler.0103-paths.lsp" :load t)
|
||
'(defun testfun (outer)
|
||
(labels ((testlabel (inner)
|
||
(if inner
|
||
(testfun-map
|
||
(lambda (x) (testlabel x))
|
||
inner))
|
||
(print outer)))
|
||
(testlabel outer))))))
|
||
|
||
;;; Date: 02/09/2008 (Josh Elsasser)
|
||
;;; Fixed: 12/09/2008 (Josh Elsasser)
|
||
;;; Description:
|
||
;;;
|
||
;;; FTYPE proclamations and declarations do not accept user defined
|
||
;;; function types.
|
||
;;;
|
||
(ext:with-clean-symbols (compiler.float-function
|
||
compiler.float)
|
||
(test cmp.0035.ftype-user-type
|
||
(progn
|
||
(deftype compiler.float-function () '(function (float) float))
|
||
(deftype compiler.float () 'float)
|
||
(loop for (type . fails) in
|
||
'(((function (float) float) . nil)
|
||
(cons . t)
|
||
(compiler.float-function . nil)
|
||
(compiler.float . t))
|
||
always (let ((form1 `(proclaim '(ftype ,type foo)))
|
||
(form2 `(compile nil '(lambda ()
|
||
(declare (ftype ,type foo))
|
||
(foo)))))
|
||
(cond (fails
|
||
(signals simple-error (eval form1))
|
||
(signals warning (eval form2)))
|
||
(:otherwise
|
||
(finishes (eval form1))
|
||
(finishes (eval form2)))))))))
|
||
|
||
;;; Date: 01/11/2008 (E. Marsden)
|
||
;;; Fixed: 02/11/2008 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; When compiled COERCE with type INTEGER may cause double
|
||
;;; evaluation of a form.
|
||
;;;
|
||
;;; ------------------------------------------------------------
|
||
;;; Date: 03/11/2008 (E. Marsden)
|
||
;;; Fixed: 08/11/2008 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; TYPEP, with a real type, produces strange results.
|
||
;;;
|
||
(test cmp.0036.coerce
|
||
(is-true (= 1
|
||
(funcall
|
||
(compile 'foo '(lambda (x)
|
||
(coerce (shiftf x 2) 'integer)))
|
||
1)))
|
||
(is-false (funcall
|
||
(compile 'foo '(lambda (x)
|
||
(typep (shiftf x 1) '(real 10 20))))
|
||
5)))
|
||
|
||
;;; Date: 20/07/2008 (Juanjo)
|
||
;;; Fixed: 20/07/2008 (Juanjo)
|
||
;;; Description:
|
||
;;;
|
||
;;; In the new compiler, when compiling LET forms with special variables
|
||
;;; the values of the variables are not saved to make the assignments
|
||
;;; really parallel.
|
||
;;;
|
||
(test cmp.0037.let-with-specials
|
||
(is
|
||
(=
|
||
7
|
||
(progn
|
||
(defvar *stak-x*)
|
||
(defvar *stak-y*)
|
||
(defvar *stak-z*)
|
||
(funcall
|
||
(compile
|
||
nil
|
||
'(lambda (*stak-x* *stak-y* *stak-z*)
|
||
(labels
|
||
((stak-aux ()
|
||
(if (not (< (the fixnum *stak-y*) (the fixnum *stak-x*)))
|
||
*stak-z*
|
||
(let ((*stak-x* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-x*))))
|
||
(*stak-y* *stak-y*)
|
||
(*stak-z* *stak-z*))
|
||
(stak-aux)))
|
||
(*stak-y* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-y*))))
|
||
(*stak-y* *stak-z*)
|
||
(*stak-z* *stak-x*))
|
||
(stak-aux)))
|
||
(*stak-z* (let ((*stak-x* (the fixnum (1- (the fixnum *stak-z*))))
|
||
(*stak-y* *stak-x*)
|
||
(*stak-z* *stak-y*))
|
||
(stak-aux))))
|
||
(stak-aux)))))
|
||
(stak-aux)))) 18 12 6)))))
|
||
|
||
;;; Date: 06/10/2009 (J. Pellegrini)
|
||
;;; Fixed: 06/10/2009 (Juanjo)
|
||
;;; Description:
|
||
;;; Extended strings were not accepted as documentation by the interpreter.
|
||
;;;
|
||
(ext:with-clean-symbols (foo)
|
||
(test cmp.0038.docstrings
|
||
(eval `(defun foo ()
|
||
,(make-array 10 :initial-element #\Space :element-type 'character)
|
||
2))
|
||
(is (= (eval (funcall 'foo)) 2))))
|
||
|
||
;;; Date: 07/11/2009 (A. Hefner)
|
||
;;; Fixed: 07/11/2009 (A. Hefner + Juanjo)
|
||
;;; Description:
|
||
;;; ECL ignores the IGNORABLE declaration
|
||
;;;
|
||
(test cmp.0039.ignorable
|
||
(let ((c::*suppress-compiler-messages* t))
|
||
;; Issue a warning for unused variables
|
||
(is-true
|
||
(handler-case (and (compile nil '(lambda (x y) (print x))) nil)
|
||
(warning (c) t)))
|
||
;; Do not issue a warning for unused variables declared IGNORE
|
||
(is-true
|
||
(handler-case (and (compile nil '(lambda (x y) (declare (ignore y))
|
||
(print x))) t)
|
||
(warning (c) nil)))
|
||
;; Do not issue a warning for unused variables declared IGNORABLE
|
||
(is-true
|
||
(handler-case (and (compile nil '(lambda (x y) (declare (ignorable y))
|
||
(print x))) t)
|
||
(warning (c) nil)))
|
||
;; Do not issue a warning for used variables declared IGNORABLE
|
||
(is-true
|
||
(handler-case (and (compile nil '(lambda (x y) (declare (ignorable x y))
|
||
(print x))) t)
|
||
(warning (c) nil)))))
|
||
|
||
;;; Date: 29/11/2009 (P. Costanza)
|
||
;;; Fixed: 29/11/2009 (Juanjo)
|
||
;;; Description:
|
||
;;; When calling a bytecodes (SETF ...) function from a compiled function
|
||
;;; an invalid memory access is produced. This is actually a consequence
|
||
;;; of a mismatch between the position of the fields bytecodes.entry
|
||
;;; and cfun.entry
|
||
;;;
|
||
#-ecl-bytecmp
|
||
(test cmp.0040.bytecodes-entry-position
|
||
(let ((indices (funcall (compile nil
|
||
'(lambda ()
|
||
(ffi:c-inline () () list "
|
||
union cl_lispunion x[0];
|
||
cl_index bytecodes = (char*)(&(x->bytecodes.entry)) - (char*)x;
|
||
cl_index bclosure = (char*)(&(x->bclosure.entry)) - (char*)x;
|
||
cl_index cfun = (char*)(&(x->cfun.entry)) - (char*)x;
|
||
cl_index cfunfixed = (char*)(&(x->cfunfixed.entry)) - (char*)x;
|
||
cl_index cclosure = (char*)(&(x->cclosure.entry)) - (char*)x;
|
||
@(return) = cl_list(5, MAKE_FIXNUM(bytecodes),
|
||
MAKE_FIXNUM(bclosure),
|
||
MAKE_FIXNUM(cfun),
|
||
MAKE_FIXNUM(cfunfixed),
|
||
MAKE_FIXNUM(cclosure));" :one-liner nil))))))
|
||
(is-true (apply #'= indices)) t))
|
||
|
||
;;; Date: 07/02/2010 (W. Hebich)
|
||
;;; Fixed: 07/02/2010 (Juanjo)
|
||
;;; Description:
|
||
;;; THE forms do not understand VALUES types
|
||
;;; (the (values t) (funcall sym))
|
||
;;;
|
||
(test cmp.0041.the-and-values
|
||
(is
|
||
(handler-case (compile nil '(lambda () (the (values t) (faa))))
|
||
(warning (c) nil))))
|
||
|
||
|
||
;;; Date: 28/03/2010 (M. Mondor)
|
||
;;; Fixed: 28/03/2010 (Juanjo)
|
||
;;; Description:
|
||
;;; ECL does not compile type declarations of a symbol macro
|
||
;;;
|
||
(test cmp.0042.symbol-macro-declaration
|
||
(is
|
||
(handler-case (compile 'nil
|
||
'(lambda (x)
|
||
(symbol-macrolet ((y x))
|
||
(declare (fixnum y))
|
||
(+ y x))))
|
||
(warning (c) nil))))
|
||
|
||
;;; Date: 24/04/2010 (Juanjo)
|
||
;;; Fixed 24/04/2010 (Juanjo)
|
||
;;; Description:
|
||
;;; New special form, WITH-BACKEND.
|
||
;;;
|
||
(ext:with-clean-symbols (*compiler.0122* compiler.0122a)
|
||
(defparameter *compiler.0122* nil)
|
||
(test cmp.0043.with-backend
|
||
;; we ensure compiler.0122a isn't compiled upfront
|
||
(eval '(defun compiler.0122a ()
|
||
(ext:with-backend
|
||
:bytecodes (setf *compiler.0122* :bytecodes)
|
||
:c/c++ (setf *compiler.0122* :c/c++))))
|
||
(is-eql :bytecodes
|
||
(progn (compiler.0122a)
|
||
*compiler.0122*))
|
||
(is-eql :bytecodes
|
||
(compiler.0122a))
|
||
#-ecl-bytecmp
|
||
(is-eql :c/c++
|
||
(progn (compile 'compiler.0122a)
|
||
(compiler.0122a)
|
||
*compiler.0122*))
|
||
#-ecl-bytecmp
|
||
(is-eql :c/c++
|
||
(compiler.0122a))))
|
||
|
||
|
||
|
||
;;; Date: 10/08/2008
|
||
;;; From: Juanjo
|
||
;;; Fixed: 10/08/2008
|
||
;;; Description:
|
||
;;;
|
||
;;; COS, SIN and TAN were expanded using a wrong C expression.
|
||
;;;
|
||
|
||
(test cmp.0044.inline-cos
|
||
(is-false
|
||
(loop with *compile-verbose* = nil
|
||
with *compile-print* = nil
|
||
for type in '(short-float single-float double-float long-float)
|
||
for sample = (coerce 1.0 type)
|
||
for epsilon in '(#.short-float-epsilon #.single-float-epsilon #.double-float-epsilon #.long-float-epsilon)
|
||
unless (loop for op in '(sin cos tan sinh cosh tanh)
|
||
for f = (compile 'nil `(lambda (x)
|
||
(declare (,type x)
|
||
(optimize (safety 0)
|
||
(speed 3)))
|
||
(+ ,sample (,op x))))
|
||
always (loop for x from (- pi) below pi by 0.05
|
||
for xf = (float x sample)
|
||
for error = (- (funcall f xf) (+ 1 (funcall op xf)))
|
||
always (< (abs error) epsilon)))
|
||
collect type)))
|
||
|
||
|
||
|
||
;;; Description:
|
||
;;;
|
||
;;; The interpreter selectively complains when assigning a variable
|
||
;;; that has not been declared as special and is not local.
|
||
;;;
|
||
;;; Fixed: 03/2006 (juanjo)
|
||
;;;
|
||
(test cmp.0045.global-setq
|
||
(is (equal
|
||
'(:no-error :error)
|
||
(mapcar
|
||
(lambda (ext:*action-on-undefined-variable*)
|
||
(handler-case
|
||
(progn (eval `(setq ,(gensym) 1)) :no-error)
|
||
(error (c) :error)))
|
||
'(nil ERROR)))))
|
||
|
||
;;; Date: 24/04/2010 (Juanjo)
|
||
;;; Fixed: 24/04/2010 (Juanjo)
|
||
;;; Description:
|
||
;;; The interpreter does not increase the lexical environment depth when
|
||
;;; optimizing certain forms (LIST, LIST*, CONS...) and thus causes some
|
||
;;; of the arguments to be eagerly evaluated.
|
||
;;;
|
||
(test cmp.0046.list-optimizer-error
|
||
(is (string-equal
|
||
(with-output-to-string (*standard-output*)
|
||
(eval '(list (print 1) (progn (print 2) (print 3)))))
|
||
"
|
||
1
|
||
2
|
||
3 ")))
|
||
|
||
|
||
|
||
;;; Date: 2015-09-04
|
||
;;; Fixed: Daniel Kochmański
|
||
;;; Description
|
||
;;; Compiler signalled arithmetic-error when producing C code for infinity
|
||
;;; and NaN float values (part of ieee floating point extensions).
|
||
|
||
#+ieee-floating-point
|
||
(test cmp.0047.infinity-test
|
||
(finishes
|
||
(compile nil
|
||
(lambda ()
|
||
(> 0.0 ext:single-float-negative-infinity))))
|
||
(is-true
|
||
(let ((ofile
|
||
(with-compiler ("aux-compiler-0048.infty-test.2.lsp" :load t)
|
||
'(defun doit () (> 0.0 ext:single-float-negative-infinity)))))
|
||
(delete-file "aux-compiler-0048.infty-test.2.lsp")
|
||
(delete-file ofile)
|
||
(doit))))
|
||
|
||
|
||
|
||
;;; Date: 2015-12-18
|
||
;;; Fixed: Daniel Kochmański
|
||
;;; Description
|
||
;;; Compiler expanded FIND incorrectly (ignored START and END arguments)
|
||
|
||
(ext:with-clean-symbols (check-single-wildcard)
|
||
(test cmp.0048.cmpopt-sequences
|
||
(defun check-single-wildcard (identifier wildcard-pos)
|
||
(not (find #\* identifier :start (1+ wildcard-pos))))
|
||
(is-true (check-single-wildcard "dan*" 3))))
|
||
|
||
;;; Date: 2016-02-10
|
||
;;; Fixed: Daniel Kochmański
|
||
;;; Description
|
||
;;; Aux closures created by C compiler weren't handled correctly
|
||
;;; in respect of the environment and declarations of the
|
||
;;; variables
|
||
(test cmp.0049.cmptop/call
|
||
(finishes
|
||
(funcall (compile nil '(lambda ()
|
||
(labels
|
||
((fun-2 () (fun-3 'cool))
|
||
(fun-3 (clause-var)
|
||
(flet ((fun-4 () clause-var))
|
||
(fun-4))))
|
||
(let ((fun-1 (lambda () (fun-2))))
|
||
(funcall fun-1))))))))
|
||
|
||
|
||
;;; Date 2016-04-21
|
||
;;; Fixed: Daniel Kochmański
|
||
;;; Description
|
||
;;; typep didn't recognize * as a t abberv
|
||
;;;
|
||
(test cmp.0050.ftype-args*
|
||
(declaim (ftype (function (*) (values T)) ce))
|
||
(defun ce (expression) expression)
|
||
(is-false (ce nil)))
|
||
|
||
|
||
;;; Date 2016-08-09 (jd)
|
||
;;; Description
|
||
;;; No adequate specialization of MAKE-LOAD-FORM for an object of
|
||
;;; type RANDOM-TYPE
|
||
(test cmp.0051.make-load-form.random-state
|
||
(finishes (make-load-form (make-random-state))))
|
||
|
||
|
||
;;; Date 2016-12-20
|
||
;;; Reported by Paul F. Dietz
|
||
;;; Description
|
||
;;;
|
||
;;; Order of VALUES evaluation in compiled code is wrong.
|
||
;;;
|
||
;;; Bug https://gitlab.com/embeddable-common-lisp/ecl/issues/330
|
||
(ext:with-clean-symbols (f2)
|
||
(test cmp.0052.values-evaluation-order
|
||
(defun f2 (a) (lcm (values a (setq a 1))))
|
||
(is-eql 10 (f2 10))
|
||
(compile 'f2)
|
||
(is-eql 10 (f2 10))))
|
||
|
||
;;; Date 2017-06-27
|
||
;;; Reported by Fabrizio Fabbri
|
||
;;; Description
|
||
;;;
|
||
;;; Compiled function drop argument type checkin
|
||
;;; on constant.
|
||
;;;
|
||
;;; Bug https://gitlab.com/embeddable-common-lisp/ecl/issues/353
|
||
(test cmp.0053.check-values-type-on-constant
|
||
(handler-case
|
||
(funcall (compile nil
|
||
'(lambda () (rplaca 'A 1))))
|
||
(simple-type-error () t)
|
||
(error () nil)
|
||
(:no-error (v) (declare (ignore v)) nil)))
|