From: Daniel Kochmański Date: Tue, 1 Sep 2015 15:32:03 +0000 (+0200) Subject: tests: merge compiler tests to compiler.lsp X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=a36d40d863278b0d3ff8df020b8f43a91bd5ef88;p=ecl.git tests: merge compiler tests to compiler.lsp Signed-off-by: Daniel Kochmański --- diff --git a/src/tests/bugs/cl-001.lsp b/src/tests/bugs/cl-001.lsp deleted file mode 100755 index a26a9e6..0000000 --- a/src/tests/bugs/cl-001.lsp +++ /dev/null @@ -1,489 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Juan Jose Garcia-Ripoll -;;;; Created: Fri Apr 14 11:13:17 CEST 2006 -;;;; Contains: Compiler regression tests - -(in-package :cl-test) - -;;; 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. -;;; - -(deftest cl-0001-import - (progn - (defpackage "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) - (prog1 (multiple-value-list (find-symbol "NIL" (find-package "FOO"))) - (delete-package "FOO"))) - (NIL :INTERNAL)) - -;;; 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] -;;; - -(deftest cl-0002-macro-shadow - (progn - (with-compiler ("aux-cl-0002.lsp") - '(defmacro foo () 2) - '(defmacro test (symbol &environment env) - (and (macro-function symbol env) t)) - '(defun doit () (flet ((foo () 1)) (test foo)))) - (load "aux-cl-0002") - (delete-file "aux-cl-0002.lsp") - (delete-file (compile-file-pathname "aux-cl-0002" :type :fas)) - (prog1 - (doit) - (fmakunbound 'doit) - (fmakunbound 'test) - (fmakunbound 'foo))) - NIL) - -;;; -;;; Fixed: 14/06/2006 (juanjo) -;;; Description: -;;; -;;; APROPOS, APROPOS-LIST and HELP* are case sensitive. -;;; - -(deftest cl-0003-apropos - (and (equal (apropos-list "bin") - (apropos-list "bin")) - t) - t) - -;;; 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. -;;; - -(deftest cl-0004-streamp - (streamp (make-instance 'gray:fundamental-stream)) - t) - -;;; Date: 02/08/2006 (juanjo) -;;; Description: -;;; -;;; There is a problem with SUBTYPEP and type STREAM -;;; - -(deftest cl-0005-subtypep-stream - (subtypep (find-class 'gray:fundamental-stream) 'stream) - 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. -;;; - -(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")))) - -(deftest cl-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)))) - (every #'test-default+paths *enough-namestring_tests*)) - t) - -;;; 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 -;;; - -(deftest cl-0007-adjustable-array - (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" -;;; - -(deftest cl-0008-parse-namestring - (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! -#-ecl -(deftest cl-0009-finalization - (let ((*all-tags* '())) - (declare (special *all-tags*)) - (flet ((custom-finalizer (tag) - #'(lambda (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)))) - (dotimes (j 100) - (dotimes (i 10000) - (cons 1.0 1.0)) - (si::gc t))) - (sort *all-tags* #'<)) - (0 1 2 3 4)) - - -;;; 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. -;;; - -(deftest cl-0010-hash-iterator - (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)) - nil) - -;;; 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) -;;; - -(deftest cl-0011-make-pathname-with-back - (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))))) - nil) - -;;; 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. -;;; - -(deftest cl-0012-copy-readtable - (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)) - nil) - -;;; 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. -;;; - -#-windows -(deftest cl-0013-truename - (progn - (si:system "rm -rf foo; ln -sf //usr/ foo") - (prog1 (namestring (truename "./foo")) - (si::system "rm foo"))) - "/usr/") - -;;; 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 -;;; -(deftest cl-0014-sharp-dot - (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. -;;; -(deftest cl-0015-setf-expander - (progn - (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)) - (prog1 - (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))) - T) - -;;; 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. -;;; -(deftest cl-0016-defstruct-include - (progn - (eval '(progn - (defstruct cl-0016-a (a 1 :read-only t)) - (defstruct (cl-0016-b (:include cl-0016-a (a 2)))) - (defstruct (cl-0016-c (:include cl-0016-a (a 3 :read-only t)))))) - (values - (handler-case (eval '(defstruct (cl-0016-d (:include cl-0016-a (a 2 :read-only nil))))) - (error (c) t)) - (cl-0016-a-a (make-cl-0016-a)) - (cl-0016-b-a (make-cl-0016-b)) - (cl-0016-c-a (make-cl-0016-c)) - (handler-case (eval '(setf (cl-0016-c-a (make-cl-0016-c)) 3)) - (error (c) t)))) - t 1 2 3 t) - -;;; Date: 9/11/2009 -;;; Fixed: 9/11/2009 -;;; Description: -;;; -;;; LOAD does not work with special files (/dev/null) -;;; -(deftest cl-0017-load-special - (handler-case (and (load #+(or windows mingw32) "NULL" - #-(or windows mingw32) "/dev/null") - t) - (serious-condition (c) nil)) - t) - -;;; Date: 16/11/2009 (Gabriel) -;;; Fixed: 20/11/2009 (Juanjo) -;;; Description: -;;; -;;; #= and ## reader macros do not work well with #. -;;; -(deftest cl-0018-sharp-eq - (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. -;;; -(deftest cl-0019-fdefinition - (and (handler-case (fdefinition nil) - (undefined-function (c) t) - (serious-condition (c) nil)) - (handler-case (symbol-function nil) - (undefined-function (c) t) - (serious-condition (c) nil))) - t) - - -;;; Date: 29/11/2009 (P. Costanza) -;;; Fixed: 29/11/2009 (Juanjo) -;;; Description: -;;; -;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE. -;;; -(deftest cl-0020-make-instances-obsolete - (progn - (defparameter *update-guard* nil) - (defclass cl-0020-a () ((b :accessor cl-0020-a-b :initarg :b))) - (let ((*a* (make-instance 'cl-0020-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)) - (and (null *update-guard*) - (progn (cl-0020-a-b *a*) (null *update-guard*)) - (progn (make-instances-obsolete (find-class 'cl-0020-a)) - (null *update-guard*)) - (progn (cl-0020-a-b *a*) *update-guard*) - (progn (setf *update-guard* nil) - (defclass cl-0020-a () ((b :accessor cl-0020-a-b :initarg :b))) - (cl-0020-a-b *a*) - *update-guard*) - t))) - t) - -;;; 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. -;;; -(deftest cl-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. - (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)))) - nil) - -;;; Date: 06/04/2010 (M. Kocic) -;;; Fixed: 4/12/2009 -;;; Description: -;;; -;;; Inspection of structs is broken due to undefined inspect-indent -;;; -(deftest cl-0022-inspect-struct - (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)))) - t) diff --git a/src/tests/bugs/cmp-001.lsp b/src/tests/bugs/cmp-001.lsp deleted file mode 100644 index cc685ab..0000000 --- a/src/tests/bugs/cmp-001.lsp +++ /dev/null @@ -1,557 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Juan Jose Garcia-Ripoll -;;;; Created: Fri Apr 14 11:13:17 CEST 2006 -;;;; Contains: Compiler regression tests - -(in-package :cl-test) - -;;; 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). -;;; -(deftest cmp-0001-block - (funcall (compile nil - '(lambda () - (block nil - (funcall 'mapcar - #'(lambda (x) - (when x (return x))) - '(1 2 3 4)))) - )) - 1) - -;;; Fixed: 12/01/2006 (juanjo) -;;; Description: -;;; -;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as -;;; synonyms. -;;; -;;; -(deftest cmp-0002-pathname - (and (equalp (compile-file-pathname "foo" :type :fas) - (compile-file-pathname "foo" :type :fasl)) - t) - t) - -;;; 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. -;;; - -(deftest cmp-0003-paths - (let* ((output (compile-file-pathname "tmp/aux" :type :fasl)) - (h-file (compile-file-pathname output :type :h)) - (c-file (compile-file-pathname output :type :c)) - (data-file (compile-file-pathname output :type :data))) - (and - (zerop (si::system "rm -rf tmp; mkdir tmp")) - (with-compiler ("aux-cmp-0003-paths.lsp" :output-file output :c-file t - :h-file t :data-file t) - '(defun foo (x) (1+ x))) - (probe-file output) - (probe-file c-file) - (probe-file h-file) - (probe-file data-file) - (delete-file "aux-cmp-0003-paths.lsp") - t)) - t) - -;;; 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 -(deftest cmp-0004-defconstant-warn - (let ((warn nil)) - (with-dflet ((c::cmpwarn (setf warn t))) - (with-compiler ("aux-cmp-0004.lsp") - '(defconstant foo (list 1 2 3)) - '(print foo))) - (delete-file "aux-cmp-0004.lsp") - (delete-file (compile-file-pathname "aux-cmp-0004.lsp" :type :fas)) - warn) - nil) - -;;; 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. -;;; - -(deftest cmp-0005-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. - (list (funcall (compile 'nil form) 3) - (funcall (coerce form 'function) 3))) - (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. -;;; - -(deftest cmp-0006-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))))) - (equal (funcall (compile 'foo form)) - (funcall (coerce form 'function)))) - t) - -;;; 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 cmp-007-class () - ((parent :accessor cmp-007-parent :initform nil) - (children :initarg :children :accessor cmp-007-children :initform nil))) - -(defmethod make-load-form ((x cmp-007-class) &optional environment) - (declare (ignore environment)) - (values - ;; creation form - `(make-instance ',(class-of x) :children ',(slot-value x 'children)) - ;; initialization form - `(setf (cmp-007-parent ',x) ',(slot-value x 'parent)) - )) - -(deftest cmp-0007-circular-load-form - (loop for object in - (let ((l (list 1 2 3))) - (list l - (subst 3 l l) - (make-instance 'cmp-007-class) - (subst (make-instance 'cmp-007-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. -;;; - -(deftest cmp-0008-make-load-form - (let ((output (compile-file-pathname "aux-cmp-0008.lsp" :type :fasl))) - (with-open-file (s "aux-cmp-0008.lsp" :if-exists :supersede :if-does-not-exist :create :direction :output) - (princ " -(eval-when (:compile-toplevel) - (defvar s4 (make-instance 'cmp-007-class)) - (defvar s5 (make-instance 'cmp-007-class)) - (setf (cmp-007-parent s5) s4) - (setf (cmp-007-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)))) -" s)) - (compile-file "aux-cmp-0008.lsp") - (load output) - (prog1 (foo) - (delete-file output) - (delete-file "aux-cmp-0008.lsp"))) - "#1=(1 2 3 # #1#)") - -;;; 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 -;;; -(deftest cmp-0009-macrolet - (list - (progn - (defun bar () - (macrolet ((x () 2)) - (macrolet ((m () (x))) - (m)))) - (compile 'bar) - (bar)) - (progn - (defun bar () - (symbol-macrolet ((x 2)) - (macrolet ((m () x)) - (m)))) - (compile 'bar) - (bar))) - (2 2)) - -;;; 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. -;;; -(deftest cmp-0010-macrolet - (flet ((eval-with-error (form) - (handler-case (eval form) - (error (c) 'error)))) - (makunbound 'cmp-0010-foo) - (fmakunbound 'cmp-0010-foo) - (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 cmp-0010-foo)) - (macrolet ((m () cmp-0010-foo)) - (m))) - (let ((faa 5)) - (macrolet ((m () cmp-0010-foo)) - (m))) - (macrolet ((cmp-0010-foo () 6)) - (macrolet ((m () (cmp-0010-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 ((cmp-0010-foo () 1)) - (macrolet ((m () (cmp-0010-foo))) - (m))) - (labels ((cmp-0010-foo () 1)) - (macrolet ((m () (cmp-0010-foo))) - (m))))))) - (error 1 error error 6 (7 8) error error )) - -;;; 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 -(deftest cmp-0011-c-arguments-limit - (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)) - ((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))) - -(let* ((nargs 10) - (arg-list (loop for i from 0 below nargs - collect (intern (format nil "arg~d" i)))) - (arguments (make-list nargs))) - (apply (compile 'foo `(lambda ,arg-list - (length (list ,@arg-list)))) - arguments)) - -;;; 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. -;;; -(deftest cmp-0012-compute-closure - (and (with-compiler ("aux-cmp-0003-paths.lsp" :load t) - (defun testfun (outer) - (labels ((testlabel (inner) - (if inner - (testfun-map - (lambda (x) (testlabel x)) - inner)) - (print outer))) - (testlabel outer)))) - t) - t) - -;;; Date: 02/09/2008 (Josh Elsasser) -;;; Fixed: 12/09/2008 (Josh Elsasser) -;;; Description: -;;; -;;; FTYPE proclamations and declarations do not accept user defined -;;; function types. -;;; -(deftest cmp-0013-ftype-user-type - (progn - (deftype cmp-0013-float-function () '(function (float) float)) - (deftype cmp-0013-float () 'float) - (loop for (type . fails) in - '(((function (float) float) . nil) - (cons . t) - (cmp-0013-float-function . nil) - (cmp-0013-float . t)) - always (let ((form1 `(proclaim '(ftype ,type foo))) - (form2 `(compile nil '(lambda () - (declare (ftype ,type foo)) - (foo))))) - (if fails - (and (signals-error (eval form1) error) - (signals-error (eval form2) error) - t) - (progn - (eval form1) - (eval form2) - t))))) - t) - -;;; 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. -(deftest cmp-0014-coerce - (funcall - (compile 'foo '(lambda (x) (coerce (shiftf x 2) 'integer))) - 1) - 1) - -;;; Date: 03/11/2008 (E. Marsden) -;;; Fixed: 08/11/2008 (Juanjo) -;;; Description: -;;; -;;; TYPEP, with a real type, produces strange results. -;;; -(deftest cmp-0015-coerce - (funcall - (compile 'foo '(lambda (x) (typep (shiftf x 1) '(real 10 20)))) - 5) - NIL) - -;;; 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. -;;; -(deftest cmp-0016-let-with-specials - (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)) - 7) - -;;; Date: 06/10/2009 (J. Pellegrini) -;;; Fixed: 06/10/2009 (Juanjo) -;;; Description: -;;; Extended strings were not accepted as documentation by the interpreter. -;;; -(deftest cmp-0017-docstrings - (handler-case - (progn - (eval `(defun foo () ,(make-array 10 :initial-element #\Space :element-type 'character) 2)) - (eval (funcall 'foo))) - (serious-condition (c) nil)) - 2) - -;;; Date: 07/11/2009 (A. Hefner) -;;; Fixed: 07/11/2009 (A. Hefner + Juanjo) -;;; Description: -;;; ECL ignores the IGNORABLE declaration -;;; -(deftest cmp-0018-ignorable - (let ((c::*suppress-compiler-messages* t)) - (and - ;; Issue a warning for unused variables - (handler-case (and (compile nil '(lambda (x y) (print x))) nil) - (warning (c) t)) - ;; Do not issue a warning for unused variables declared IGNORE - (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 - (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 - (handler-case (and (compile nil '(lambda (x y) (declare (ignorable x y)) - (print x))) t) - (warning (c) nil)))) - t) - -;;; 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 -;;; -(deftest cmp-0019-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)))))) - (and (apply #'= indices) t)) - 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)) -;;; -(deftest cmp-0020-the-and-values - (handler-case (and (compile 'foo '(lambda () (the (values t) (faa)))) - t) - (warning (c) nil)) - t) - - -;;; Date: 28/03/2010 (M. Mondor) -;;; Fixed: 28/03/2010 (Juanjo) -;;; Description: -;;; ECL does not compile type declarations of a symbol macro -;;; -(deftest cmp-0021-symbol-macro-declaration - (handler-case (and (compile 'nil - '(lambda (x) - (symbol-macrolet ((y x)) - (declare (fixnum y)) - (+ y x)))) - nil) - (warning (c) t)) - nil) - -;;; Date: 24/04/2010 (Juanjo) -;;; Fixed 24/04/2010 (Juanjo) -;;; Description: -;;; New special form, WITH-BACKEND. -;;; -(deftest cmp-0022-with-backend - (progn - (defparameter *cmp-0022* nil) - (defun cmp-0022a () - (ext:with-backend - :bytecodes (setf *cmp-0022* :bytecodes) - :c/c++ (setf *cmp-0022* :c/c++))) - (list - (progn (cmp-0022a) *cmp-0022*) - (cmp-0022a) - (progn (compile 'cmp-0022a) (cmp-0022a) *cmp-0022*) - (cmp-0022a))) - (:bytecodes :bytecodes :c/c++ :c/c++)) diff --git a/src/tests/bugs/compiler.lsp b/src/tests/bugs/compiler.lsp new file mode 100644 index 0000000..77e6fd4 --- /dev/null +++ b/src/tests/bugs/compiler.lsp @@ -0,0 +1,1047 @@ +;-*- Mode: Lisp -*- +;;;; Author: Juan Jose Garcia-Ripoll +;;;; Created: Fri Apr 14 11:13:17 CEST 2006 +;;;; Contains: Compiler regression tests + +(in-package :cl-test) + + +;; 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. +;;; + +(deftest compiler.0001.import + (progn + (defpackage "FOO" (:USE) (:IMPORT-FROM "CL" "NIL" "T")) + (prog1 (multiple-value-list (find-symbol "NIL" (find-package "FOO"))) + (delete-package "FOO"))) + (NIL :INTERNAL)) + +;;; 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] +;;; + +(deftest compiler.0002.macro-shadow + (progn + (with-compiler ("aux-cl-0002.lsp") + '(defmacro foo () 2) + '(defmacro test (symbol &environment env) + (and (macro-function symbol env) t)) + '(defun doit () (flet ((foo () 1)) (test foo)))) + (load "aux-cl-0002") + (delete-file "aux-cl-0002.lsp") + (delete-file (compile-file-pathname "aux-cl-0002" :type :fas)) + (prog1 + (doit) + (fmakunbound 'doit) + (fmakunbound 'test) + (fmakunbound 'foo))) + NIL) + +;;; +;;; Fixed: 14/06/2006 (juanjo) +;;; Description: +;;; +;;; APROPOS, APROPOS-LIST and HELP* are case sensitive. +;;; + +(deftest compiler.0003.apropos + (and (equal (apropos-list "bin") + (apropos-list "bin")) + t) + t) + +;;; 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. +;;; + +(deftest compiler.0004.streamp + (streamp (make-instance 'gray:fundamental-stream)) + t) + +;;; Date: 02/08/2006 (juanjo) +;;; Description: +;;; +;;; There is a problem with SUBTYPEP and type STREAM +;;; + +(deftest compiler.0005.subtypep-stream + (subtypep (find-class 'gray:fundamental-stream) 'stream) + 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. +;;; + +(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")))) + +(deftest compiler.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)))) + (every #'test-default+paths *enough-namestring_tests*)) + t) + +;;; 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 +;;; + +(deftest compiler.0007.adjustable-array + (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" +;;; + +(deftest compiler.0008.parse-namestring + (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! +(deftest compiler.0009.finalization + (let ((*all-tags* '())) + (declare (special *all-tags*)) + (flet ((custom-finalizer (tag) + #'(lambda (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)))) + (dotimes (j 100) + (dotimes (i 10000) + (cons 1.0 1.0)) + (si::gc t))) + (sort *all-tags* #'<)) + (0 1 2 3 4)) + + +;;; 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. +;;; + +(deftest compiler.0010.hash-iterator + (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)) + nil) + +;;; 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) +;;; + +(deftest compiler.0011.make-pathname-with-back + (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))))) + nil) + +;;; 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. +;;; + +(deftest compiler.0012.copy-readtable + (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)) + nil) + +;;; 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. +;;; + +#-windows +(deftest compiler.0013.truename + (progn + (si:system "rm -rf foo; ln -sf //usr/ foo") + (prog1 (namestring (truename "./foo")) + (si::system "rm foo"))) + "/usr/") + +;;; 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 +;;; +(deftest compiler.0014.sharp-dot + (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. +;;; +(deftest compiler.0015-setf-expander + (progn + (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)) + (prog1 + (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))) + T) + +;;; 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. +;;; +(deftest compiler.0016.defstruct-include + (progn + (eval '(progn + (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)))))) + (values + (handler-case (eval '(defstruct (compiler.0016-d (:include compiler.0016-a (a 2 :read-only nil))))) + (error (c) t)) + (compiler.0016-a-a (make-compiler.0016-a)) + (compiler.0016-b-a (make-compiler.0016-b)) + (compiler.0016-c-a (make-compiler.0016-c)) + (handler-case (eval '(setf (compiler.0016-c-a (make-compiler.0016-c)) 3)) + (error (c) t)))) + t 1 2 3 t) + +;;; Date: 9/11/2009 +;;; Fixed: 9/11/2009 +;;; Description: +;;; +;;; LOAD does not work with special files (/dev/null) +;;; +(deftest compiler.0017.load-special + (handler-case (and (load #+(or windows mingw32) "NULL" + #-(or windows mingw32) "/dev/null") + t) + (serious-condition (c) nil)) + t) + +;;; Date: 16/11/2009 (Gabriel) +;;; Fixed: 20/11/2009 (Juanjo) +;;; Description: +;;; +;;; #= and ## reader macros do not work well with #. +;;; +(deftest compiler.0018.sharp-eq + (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. +;;; +(deftest compiler.0019.fdefinition + (and (handler-case (fdefinition nil) + (undefined-function (c) t) + (serious-condition (c) nil)) + (handler-case (symbol-function nil) + (undefined-function (c) t) + (serious-condition (c) nil))) + t) + + +;;; Date: 29/11/2009 (P. Costanza) +;;; Fixed: 29/11/2009 (Juanjo) +;;; Description: +;;; +;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE. +;;; +(deftest compiler.0020.make-instances-obsolete + (progn + (defparameter *update-guard* nil) + (defclass compiler.0020-a () ((b :accessor compiler.0020-a-b :initarg :b))) + (let ((*a* (make-instance 'compiler.0020-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)) + (and (null *update-guard*) + (progn (compiler.0020-a-b *a*) (null *update-guard*)) + (progn (make-instances-obsolete (find-class 'compiler.0020-a)) + (null *update-guard*)) + (progn (compiler.0020-a-b *a*) *update-guard*) + (progn (setf *update-guard* nil) + (defclass compiler.0020-a () ((b :accessor compiler.0020-a-b :initarg :b))) + (compiler.0020-a-b *a*) + *update-guard*) + t))) + t) + +;;; 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. +;;; +(deftest compiler.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. + (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)))) + nil) + +;;; Date: 06/04/2010 (M. Kocic) +;;; Fixed: 4/12/2009 +;;; Description: +;;; +;;; Inspection of structs is broken due to undefined inspect-indent +;;; +(deftest compiler.0022.inspect-struct + (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)))) + t) + + +;; 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). +;;; +(deftest compiler.0101-block + (funcall (compile nil + '(lambda () + (block nil + (funcall 'mapcar + #'(lambda (x) + (when x (return x))) + '(1 2 3 4)))) + )) + 1) + +;;; Fixed: 12/01/2006 (juanjo) +;;; Description: +;;; +;;; COMPILE-FILE-PATHNAME now accepts both :FAS and :FASL as +;;; synonyms. +;;; +;;; +(deftest compiler.0102-pathname + (and (equalp (compile-file-pathname "foo" :type :fas) + (compile-file-pathname "foo" :type :fasl)) + t) + t) + +;;; 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. +;;; + +(deftest compiler.0103-paths + (let* ((output (compile-file-pathname "tmp/aux" :type :fasl)) + (h-file (compile-file-pathname output :type :h)) + (c-file (compile-file-pathname output :type :c)) + (data-file (compile-file-pathname output :type :data))) + (and + (zerop (si::system "rm -rf tmp; mkdir tmp")) + (with-compiler ("aux-compiler.0103-paths.lsp" :output-file output :c-file t + :h-file t :data-file t) + '(defun foo (x) (1+ x))) + (probe-file output) + (probe-file c-file) + (probe-file h-file) + (probe-file data-file) + (delete-file "aux-compiler.0103-paths.lsp") + t)) + t) + +;;; 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 +(deftest compiler.0104-defconstant-warn + (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) + nil) + +;;; 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. +;;; + +(deftest compiler.0105-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. + (list (funcall (compile 'nil form) 3) + (funcall (coerce form 'function) 3))) + (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. +;;; + +(deftest compiler.0106-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))))) + (equal (funcall (compile 'foo form)) + (funcall (coerce form 'function)))) + t) + +;;; 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.017-class () + ((parent :accessor compiler.017-parent :initform nil) + (children :initarg :children :accessor compiler.017-children :initform nil))) + +(defmethod make-load-form ((x compiler.017-class) &optional environment) + (declare (ignore environment)) + (values + ;; creation form + `(make-instance ',(class-of x) :children ',(slot-value x 'children)) + ;; initialization form + `(setf (compiler.017-parent ',x) ',(slot-value x 'parent)) + )) + +(deftest compiler.0107-circular-load-form + (loop for object in + (let ((l (list 1 2 3))) + (list l + (subst 3 l l) + (make-instance 'compiler.017-class) + (subst (make-instance 'compiler.017-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. +;;; + +(deftest compiler.0108-make-load-form + (let ((output (compile-file-pathname "aux-compiler.0108.lsp" :type :fasl))) + (with-open-file (s "aux-compiler.0108.lsp" :if-exists :supersede :if-does-not-exist :create :direction :output) + (princ " +(eval-when (:compile-toplevel) + (defvar s4 (make-instance 'compiler.017-class)) + (defvar s5 (make-instance 'compiler.017-class)) + (setf (compiler.017-parent s5) s4) + (setf (compiler.017-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)))) +" s)) + (compile-file "aux-compiler.0108.lsp") + (load output) + (prog1 (foo) + (delete-file output) + (delete-file "aux-compiler.0108.lsp"))) + "#1=(1 2 3 # #1#)") + +;;; 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 +;;; +(deftest compiler.0109-macrolet + (list + (progn + (defun bar () + (macrolet ((x () 2)) + (macrolet ((m () (x))) + (m)))) + (compile 'bar) + (bar)) + (progn + (defun bar () + (symbol-macrolet ((x 2)) + (macrolet ((m () x)) + (m)))) + (compile 'bar) + (bar))) + (2 2)) + +;;; 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. +;;; +(deftest compiler.0110-macrolet + (flet ((eval-with-error (form) + (handler-case (eval form) + (error (c) 'error)))) + (makunbound 'compiler.0110-foo) + (fmakunbound 'compiler.0110-foo) + (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.0110-foo)) + (macrolet ((m () compiler.0110-foo)) + (m))) + (let ((faa 5)) + (macrolet ((m () compiler.0110-foo)) + (m))) + (macrolet ((compiler.0110-foo () 6)) + (macrolet ((m () (compiler.0110-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.0110-foo () 1)) + (macrolet ((m () (compiler.0110-foo))) + (m))) + (labels ((compiler.0110-foo () 1)) + (macrolet ((m () (compiler.0110-foo))) + (m))))))) + (error 1 error error 6 (7 8) error error )) + +;;; 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 +(deftest compiler.0111-c-arguments-limit + (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)) + ((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))) + +(let* ((nargs 10) + (arg-list (loop for i from 0 below nargs + collect (intern (format nil "arg~d" i)))) + (arguments (make-list nargs))) + (apply (compile 'foo `(lambda ,arg-list + (length (list ,@arg-list)))) + arguments)) + +;;; 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. +;;; +(deftest compiler.0112-compute-closure + (and (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)))) + t) + t) + +;;; Date: 02/09/2008 (Josh Elsasser) +;;; Fixed: 12/09/2008 (Josh Elsasser) +;;; Description: +;;; +;;; FTYPE proclamations and declarations do not accept user defined +;;; function types. +;;; +(deftest compiler.0113-ftype-user-type + (progn + (deftype compiler.0113-float-function () '(function (float) float)) + (deftype compiler.0113-float () 'float) + (loop for (type . fails) in + '(((function (float) float) . nil) + (cons . t) + (compiler.0113-float-function . nil) + (compiler.0113-float . t)) + always (let ((form1 `(proclaim '(ftype ,type foo))) + (form2 `(compile nil '(lambda () + (declare (ftype ,type foo)) + (foo))))) + (if fails + (and (signals-error (eval form1) error) + (signals-error (eval form2) error) + t) + (progn + (eval form1) + (eval form2) + t))))) + t) + +;;; 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. +(deftest compiler.0114-coerce + (funcall + (compile 'foo '(lambda (x) (coerce (shiftf x 2) 'integer))) + 1) + 1) + +;;; Date: 03/11/2008 (E. Marsden) +;;; Fixed: 08/11/2008 (Juanjo) +;;; Description: +;;; +;;; TYPEP, with a real type, produces strange results. +;;; +(deftest compiler.0115-coerce + (funcall + (compile 'foo '(lambda (x) (typep (shiftf x 1) '(real 10 20)))) + 5) + NIL) + +;;; 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. +;;; +(deftest compiler.0116-let-with-specials + (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)) + 7) + +;;; Date: 06/10/2009 (J. Pellegrini) +;;; Fixed: 06/10/2009 (Juanjo) +;;; Description: +;;; Extended strings were not accepted as documentation by the interpreter. +;;; +(deftest compiler.0117-docstrings + (handler-case + (progn + (eval `(defun foo () ,(make-array 10 :initial-element #\Space :element-type 'character) 2)) + (eval (funcall 'foo))) + (serious-condition (c) nil)) + 2) + +;;; Date: 07/11/2009 (A. Hefner) +;;; Fixed: 07/11/2009 (A. Hefner + Juanjo) +;;; Description: +;;; ECL ignores the IGNORABLE declaration +;;; +(deftest compiler.0118-ignorable + (let ((c::*suppress-compiler-messages* t)) + (and + ;; Issue a warning for unused variables + (handler-case (and (compile nil '(lambda (x y) (print x))) nil) + (warning (c) t)) + ;; Do not issue a warning for unused variables declared IGNORE + (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 + (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 + (handler-case (and (compile nil '(lambda (x y) (declare (ignorable x y)) + (print x))) t) + (warning (c) nil)))) + t) + +;;; 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 +;;; +(deftest compiler.0119-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)))))) + (and (apply #'= indices) t)) + 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)) +;;; +(deftest compiler.0120-the-and-values + (handler-case (and (compile 'foo '(lambda () (the (values t) (faa)))) + t) + (warning (c) nil)) + t) + + +;;; Date: 28/03/2010 (M. Mondor) +;;; Fixed: 28/03/2010 (Juanjo) +;;; Description: +;;; ECL does not compile type declarations of a symbol macro +;;; +(deftest compiler.0121-symbol-macro-declaration + (handler-case (and (compile 'nil + '(lambda (x) + (symbol-macrolet ((y x)) + (declare (fixnum y)) + (+ y x)))) + nil) + (warning (c) t)) + nil) + +;;; Date: 24/04/2010 (Juanjo) +;;; Fixed 24/04/2010 (Juanjo) +;;; Description: +;;; New special form, WITH-BACKEND. +;;; +(deftest compiler.0122-with-backend + (progn + (defparameter *compiler.0122* nil) + (defun compiler.0122a () + (ext:with-backend + :bytecodes (setf *compiler.0122* :bytecodes) + :c/c++ (setf *compiler.0122* :c/c++))) + (list + (progn (compiler.0122a) *compiler.0122*) + (compiler.0122a) + (progn (compile 'compiler.0122a) (compiler.0122a) *compiler.0122*) + (compiler.0122a))) + (:bytecodes :bytecodes :c/c++ :c/c++)) + +