X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=1affc4059f1debb52d897a1a7217caafc08414f5;hb=796873d7b696e1079d2319844444040d18e0e2b1;hp=45d030b7cb539d719ad11041c48c232e09c2d309;hpb=dc47746daf73c65126a80b723ad52b8327b06960;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 45d030b..1affc40 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -15,7 +15,13 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(when (eq sb-ext:*evaluator-mode* :interpret) + (sb-ext:quit :unix-status 104)) + +(load "test-util.lisp") +(load "compiler-test-util.lisp") (load "assertoid.lisp") +(use-package "TEST-UTIL") (use-package "ASSERTOID") ;;; Old CMU CL code assumed that the names of "keyword" arguments are @@ -613,7 +619,7 @@ (assert (equal (check-embedded-thes 3 0 2 :a) '(2 :a))) (assert (typep (check-embedded-thes 3 0 4 2.5f0) 'type-error)) -(assert (equal (check-embedded-thes 1 0 4 :b) '(4 :b))) +(assert (equal (check-embedded-thes 1 0 3 :b) '(3 :b))) (assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error)) @@ -923,6 +929,236 @@ (eval '(labels ((%f (&key x) x)) (%f nil nil))) (error (c) :good) (:no-error (val) (error "no error: ~S" val))) + +;;; PROGV must not bind constants, or violate declared types -- ditto for SET. +(assert (raises-error? (set pi 3))) +(assert (raises-error? (progv '(pi s) '(3 pi) (symbol-value x)))) +(declaim (cons *special-cons*)) +(assert (raises-error? (set '*special-cons* "nope") type-error)) +(assert (raises-error? (progv '(*special-cons*) '("no hope") (car *special-cons*)) type-error)) + +;;; No bogus warnings for calls to functions with complex lambda-lists. +(defun complex-function-signature (&optional x &rest y &key z1 z2) + (cons x y)) +(with-test (:name :complex-call-doesnt-warn) + (handler-bind ((warning #'error)) + (compile nil '(lambda (x) (complex-function-signature x :z1 1 :z2 2))))) + +(with-test (:name :non-required-args-update-info) + (let ((name (gensym "NON-REQUIRE-ARGS-TEST")) + (*evaluator-mode* :compile)) + (eval `(defun ,name (x) x)) + (assert (equal '(function (t) (values t &optional)) + (sb-kernel:type-specifier (sb-int:info :function :type name)))) + (eval `(defun ,name (x &optional y) (or x y))) + (assert (equal '(function (t &optional t) (values t &optional)) + (sb-kernel:type-specifier (sb-int:info :function :type name)))))) + +;;;; inline & maybe inline nested calls + +(defun quux-marker (x) x) +(declaim (inline foo-inline)) +(defun foo-inline (x) (quux-marker x)) +(declaim (maybe-inline foo-maybe-inline)) +(defun foo-maybe-inline (x) (quux-marker x)) +;; Pretty horrible, but does the job +(defun count-full-calls (name function) + (let ((code (with-output-to-string (s) + (disassemble function :stream s))) + (n 0)) + (with-input-from-string (s code) + (loop for line = (read-line s nil nil) + while line + when (search name line) + do (incf n))) + n)) + +(with-test (:name :nested-inline-calls) + (let ((fun (compile nil `(lambda (x) + (foo-inline (foo-inline (foo-inline x))))))) + (assert (= 0 (count-full-calls "FOO-INLINE" fun))) + (assert (= 3 (count-full-calls "QUUX-MARKER" fun))))) + +(with-test (:name :nested-maybe-inline-calls) + (let ((fun (compile nil `(lambda (x) + (declare (optimize (space 0))) + (foo-maybe-inline (foo-maybe-inline (foo-maybe-inline x))))))) + (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun))) + (assert (= 1 (count-full-calls "QUUX-MARKER" fun))))) + +(with-test (:name :inline-calls) + (let ((fun (compile nil `(lambda (x) + (list (foo-inline x) + (foo-inline x) + (foo-inline x)))))) + (assert (= 0 (count-full-calls "FOO-INLINE" fun))) + (assert (= 3 (count-full-calls "QUUX-MARKER" fun))))) + +(with-test (:name :maybe-inline-calls) + (let ((fun (compile nil `(lambda (x) + (declare (optimize (space 0))) + (list (foo-maybe-inline x) + (foo-maybe-inline x) + (foo-maybe-inline x)))))) + (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun))) + (assert (= 1 (count-full-calls "QUUX-MARKER" fun))))) + +(defun file-compile (toplevel-forms &key load) + (let* ((lisp "compile-impure-tmp.lisp") + (fasl (compile-file-pathname lisp))) + (unwind-protect + (progn + (with-open-file (f lisp :direction :output) + (dolist (form toplevel-forms) + (prin1 form f))) + (multiple-value-bind (fasl warn fail) (compile-file lisp) + (when load + (load fasl)) + (values warn fail))) + (ignore-errors (delete-file lisp)) + (ignore-errors (delete-file fasl))))) + +(with-test (:name :bug-405) + ;; These used to break with a TYPE-ERROR + ;; The value NIL is not of type SB-C::PHYSENV. + ;; in MERGE-LETS. + (file-compile + '((LET (outer-let-var) + (lambda () + (print outer-let-var) + (MULTIPLE-VALUE-CALL 'some-function + (MULTIPLE-VALUE-CALL (LAMBDA (a) 'foo) + 1)))))) + (file-compile + '((declaim (optimize (debug 3))) + (defstruct bug-405-foo bar) + (let () + (flet ((i (x) (frob x (bug-405-foo-bar foo)))) + (i :five)))))) + +;;; bug 235a +(declaim (ftype (function (cons) number) bug-235a-aux)) +(declaim (inline bug-235a-aux)) +(defun bug-235a-aux (c) + (the number (car c))) +(with-test (:name :bug-235a) + (let ((fun (compile nil + `(lambda (x y) + (values (locally (declare (optimize (safety 0))) + (bug-235a-aux x)) + (locally (declare (optimize (safety 3))) + (bug-235a-aux y))))))) + (assert + (eq :error + (handler-case + (funcall fun '(:one) '(:two)) + (type-error (e) + (assert (eq :two (type-error-datum e))) + (assert (eq 'number (type-error-expected-type e))) + :error)))))) + +(with-test (:name :compiled-debug-funs-leak) + (sb-ext:gc :full t) + (let ((usage-before (sb-kernel::dynamic-usage))) + (dotimes (x 10000) + (let ((f (compile nil '(lambda () + (error "X"))))) + (handler-case + (funcall f) + (error () nil)))) + (sb-ext:gc :full t) + (let ((usage-after (sb-kernel::dynamic-usage))) + (when (< (+ usage-before 2000000) usage-after) + (error "Leak"))))) + +;;; PROGV compilation and type checking when the declared type +;;; includes a FUNCTION subtype. +(declaim (type (or (function (t) (values boolean &optional)) string) + *hairy-progv-var*)) +(defvar *hairy-progv-var* #'null) +(with-test (:name :hairy-progv-type-checking) + (assert (eq :error + (handler-case + (progv '(*hairy-progv-var*) (list (eval 42)) + *hairy-progv-var*) + (type-error () :error)))) + (assert (equal "GOOD!" + (progv '(*hairy-progv-var*) (list (eval "GOOD!")) + *hairy-progv-var*)))) + +(with-test (:name :fill-complex-single-float) + (assert (every (lambda (x) (eql x #c(-1.0 -2.0))) + (funcall + (lambda () + (make-array 2 + :element-type '(complex single-float) + :initial-element #c(-1.0 -2.0))))))) + +(with-test (:name :make-array-symbol-as-initial-element) + (assert (every (lambda (x) (eq x 'a)) + (funcall + (compile nil + `(lambda () + (make-array 12 :initial-element 'a))))))) + +;;; This non-minimal test-case catches a nasty error when loading +;;; inline constants. +(deftype matrix () + `(simple-array single-float (16))) +(declaim (ftype (sb-int:sfunction (single-float single-float single-float single-float + single-float single-float single-float single-float + single-float single-float single-float single-float + single-float single-float single-float single-float) + matrix) + matrix) + (inline matrix)) +(defun matrix (m11 m12 m13 m14 + m21 m22 m23 m24 + m31 m32 m33 m34 + m41 m42 m43 m44) + (make-array 16 + :element-type 'single-float + :initial-contents (list m11 m21 m31 m41 + m12 m22 m32 m42 + m13 m23 m33 m43 + m14 m24 m34 m44))) +(declaim (ftype (sb-int:sfunction ((simple-array single-float (3)) single-float) matrix) + rotate-around)) +(defun rotate-around (a radians) + (let ((c (cos radians)) + (s (sin radians)) + ;; The 1.0 here was misloaded on x86-64. + (g (- 1.0 (cos radians)))) + (let* ((x (aref a 0)) + (y (aref a 1)) + (z (aref a 2)) + (gxx (* g x x)) (gxy (* g x y)) (gxz (* g x z)) + (gyy (* g y y)) (gyz (* g y z)) (gzz (* g z z))) + (matrix + (+ gxx c) (- gxy (* s z)) (+ gxz (* s y)) 0.0 + (+ gxy (* s z)) (+ gyy c) (- gyz (* s x)) 0.0 + (- gxz (* s y)) (+ gyz (* s x)) (+ gzz c) 0.0 + 0.0 0.0 0.0 1.0)))) +(with-test (:name :regression-1.0.29.54) + (assert (every #'= + '(-1.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 1.0) + (rotate-around + (make-array 3 :element-type 'single-float) (coerce pi 'single-float)))) + ;; Same bug manifests in COMPLEX-ATANH as well. + (assert (= (atanh #C(-0.7d0 1.1d0)) #C(-0.28715567731069275d0 0.9394245539093365d0)))) + +(with-test (:name :slot-value-on-structure) + (let ((f (compile nil `(lambda (x a b) + (declare (something-known-to-be-a-struct x)) + (setf (slot-value x 'x) a + (slot-value x 'y) b) + (list (slot-value x 'x) + (slot-value x 'y)))))) + (assert (equal '(#\x #\y) + (funcall f + (make-something-known-to-be-a-struct :x "X" :y "Y") + #\x #\y))) + (assert (not (ctu:find-named-callees f))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -1123,4 +1359,555 @@ ans))))))) (if (and (minusp nn) (oddp nn)) (- besn) besn)))) + +;;; bug 233b: lvar lambda-var equality in constraint propagation + +;; Put this in a separate function. +(defun test-constraint-propagation/ref () + (let ((x nil)) + (if (multiple-value-prog1 x (setq x t)) + 1 + x))) + +(test-util:with-test (:name (:compiler :constraint-propagation :ref)) + (assert (eq t (test-constraint-propagation/ref)))) + +;; Put this in a separate function. +(defun test-constraint-propagation/typep (x y) + (if (typep (multiple-value-prog1 x (setq x y)) + 'double-float) + (+ x 1d0) + (+ x 2))) + +(test-util:with-test (:name (:compiler :constraint-propagation :typep)) + (assert (= 6.0d0 (test-constraint-propagation/typep 1d0 5)))) + +(test-util:with-test (:name (:compiler :constraint-propagation :eq/eql)) + (assert (eq :right (let ((c :wrong)) + (if (eq (let ((x c)) + (setq c :right) + x) + :wrong) + c + 0))))) + +;;; Put this in a separate function. +(defun test-constraint-propagation/cast (x) + (when (the double-float (multiple-value-prog1 + x + (setq x (1+ x)))) + x)) + +(test-util:with-test (:name (:compiler :constraint-propagation :cast)) + (assert (assertoid:raises-error? + (test-constraint-propagation/cast 1) type-error))) + +;;; bug #399 +(let ((result (make-array 50000 :fill-pointer 0 :adjustable t))) + (defun string->html (string &optional (max-length nil)) + (when (and (numberp max-length) + (> max-length (array-dimension result 0))) + (setf result (make-array max-length :fill-pointer 0 :adjustable t))) + (let ((index 0) + (left-quote? t)) + (labels ((add-char (it) + (setf (aref result index) it) + (incf index)) + (add-string (it) + (loop for ch across it do + (add-char ch)))) + (loop for char across string do + (cond ((char= char #\<) + (add-string "<")) + ((char= char #\>) + (add-string ">")) + ((char= char #\&) + (add-string "&")) + ((char= char #\') + (add-string "'")) + ((char= char #\newline) + (add-string "
")) + ((char= char #\") + (if left-quote? (add-string "“") (add-string "”")) + (setf left-quote? (not left-quote?))) + (t + (add-char char)))) + (setf (fill-pointer result) index) + (coerce result 'string))))) + +;;; Callign thru constant symbols +(require :sb-introspect) + +(declaim (inline target-fun)) +(defun target-fun (arg0 arg1) + (+ arg0 arg1)) +(declaim (notinline target-fun)) + +(defun test-target-fun-called (fun res) + (assert (member #'target-fun + (sb-introspect:find-function-callees #'caller-fun-1))) + (assert (equal (funcall fun) res))) + +(defun caller-fun-1 () + (funcall 'target-fun 1 2)) +(test-target-fun-called #'caller-fun-1 3) + +(defun caller-fun-2 () + (declare (inline target-fun)) + (apply 'target-fun 1 '(3))) +(test-target-fun-called #'caller-fun-2 4) + +(defun caller-fun-3 () + (flet ((target-fun (a b) + (- a b))) + (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4)))) +(test-target-fun-called #'caller-fun-3 (list -3 5)) + +;;; Reported by NIIMI Satoshi +;;; Subject: [Sbcl-devel] compilation error with optimization +;;; Date: Sun, 09 Apr 2006 17:36:05 +0900 +(defun test-minimal-debug-info-for-unstored-but-used-parameter (n a) + (declare (optimize (speed 3) + (debug 1))) + (if (= n 0) + 0 + (test-minimal-debug-info-for-unstored-but-used-parameter (1- n) a))) + +;;; &KEY arguments with non-constant defaults. +(declaim (notinline opaque-identity)) +(defun opaque-identity (x) x) +(defstruct tricky-defaults + (fun #'identity :type function) + (num (opaque-identity 3) :type fixnum)) +(macrolet ((frob (form expected-expected-type) + `(handler-case ,form + (type-error (c) (assert (eq (type-error-expected-type c) + ',expected-expected-type))) + (:no-error (&rest vals) (error "~S returned values: ~S" ',form vals))))) + (frob (make-tricky-defaults :fun 3) function) + (frob (make-tricky-defaults :num #'identity) fixnum)) + +(let ((fun (compile nil '(lambda (&key (key (opaque-identity 3))) + (declare (optimize safety) (type integer key)) + key)))) + (assert (= (funcall fun) 3)) + (assert (= (funcall fun :key 17) 17)) + (handler-case (funcall fun :key t) + (type-error (c) (assert (eq (type-error-expected-type c) 'integer))) + (:no-error (&rest vals) (error "no error")))) + +;;; Basic compiler-macro expansion +(define-compiler-macro test-cmacro-0 () ''expanded) + +(assert (eq 'expanded (funcall (lambda () (test-cmacro-0))))) + +;;; FUNCALL forms in compiler macros, lambda-list parsing +(define-compiler-macro test-cmacro-1 + (&whole whole a (a2) &optional b &rest c &key d) + (list whole a a2 b c d)) + +(macrolet ((test (form a a2 b c d) + `(let ((form ',form)) + (destructuring-bind (whole a a2 b c d) + (funcall (compiler-macro-function 'test-cmacro-1) form nil) + (assert (equal whole form)) + (assert (eql a ,a)) + (assert (eql a2 ,a2)) + (assert (eql b ,b)) + (assert (equal c ,c)) + (assert (eql d ,d))))) ) + (test (funcall 'test-cmacro-1 1 (x) 2 :d 3) 1 'x 2 '(:d 3) 3) + (test (test-cmacro-1 11 (y) 12 :d 13) 11 'y 12 '(:d 13) 13)) + +;;; FUNCALL forms in compiler macros, expansions +(define-compiler-macro test-cmacro-2 () ''ok) + +(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2))))) +(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2))))) + +;;; Shadowing of compiler-macros by local functions +(define-compiler-macro test-cmacro-3 () ''global) + +(defmacro find-cmacro-3 (&environment env) + (compiler-macro-function 'test-cmacro-3 env)) + +(assert (funcall (lambda () (find-cmacro-3)))) +(assert (not (funcall (lambda () (flet ((test-cmacro-3 ())) + (find-cmacro-3)))))) +(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local)) + (test-cmacro-3)))))) +(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local)) + (funcall #'test-cmacro-3)))))) +(assert (eq 'global (funcall (lambda () (flet ((test-cmacro-3 () 'local)) + (funcall 'test-cmacro-3)))))) + +;;; Local NOTINLINE & INLINE +(defun test-cmacro-4 () 'fun) +(define-compiler-macro test-cmacro-4 () ''macro) + +(assert (eq 'fun (funcall (lambda () + (declare (notinline test-cmacro-4)) + (test-cmacro-4))))) + +(assert (eq 'macro (funcall (lambda () + (declare (inline test-cmacro-4)) + (test-cmacro-4))))) + +;;; SETF function compiler macros +(define-compiler-macro (setf test-cmacro-4) (&whole form value) ''ok) + +(assert (eq 'ok (funcall (lambda () (setf (test-cmacro-4) 'zot))))) +(assert (eq 'ok (funcall (lambda () (funcall #'(setf test-cmacro-4) 'zot))))) + +;;; Step instrumentation breaking type-inference +(handler-bind ((warning #'error)) + (assert (= 42 (funcall (compile nil '(lambda (v x) + (declare (optimize sb-c:insert-step-conditions)) + (if (typep (the function x) 'fixnum) + (svref v (the function x)) + (funcall x)))) + nil (constantly 42))))) + +;;; bug 368: array type intersections in the compiler +(defstruct e368) +(defstruct i368) +(defstruct g368 + (i368s (make-array 0 :fill-pointer t) :type (or (vector i368) null))) +(defstruct s368 + (g368 (error "missing :G368") :type g368 :read-only t)) +(declaim (ftype (function (fixnum (vector i368) e368) t) r368)) +(declaim (ftype (function (fixnum (vector e368)) t) h368)) +(defparameter *h368-was-called-p* nil) +(defun nsu (vertices e368) + (let ((i368s (g368-i368s (make-g368)))) + (let ((fuis (r368 0 i368s e368))) + (format t "~&FUIS=~S~%" fuis) + (or fuis (h368 0 i368s))))) +(defun r368 (w x y) + (declare (ignore w x y)) + nil) +(defun h368 (w x) + (declare (ignore w x)) + (setf *h368-was-called-p* t) + (make-s368 :g368 (make-g368))) +(let ((nsu (nsu #() (make-e368)))) + (format t "~&NSU returned ~S~%" nsu) + (format t "~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p*) + (assert (s368-p nsu)) + (assert *h368-was-called-p*)) + +;;; bug 367: array type intersections in the compiler +(defstruct e367) +(defstruct i367) +(defstruct g367 + (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null))) +(defstruct s367 + (g367 (error "missing :G367") :type g367 :read-only t)) +(declaim (ftype (function ((vector i367) e367) (or s367 null)) r367)) +(declaim (ftype (function ((vector e367)) (values)) h367)) +(defun frob-367 (v w) + (let ((x (g367-i367s (make-g367)))) + (let* ((y (or (r367 x w) + (h367 x))) + (z (s367-g367 y))) + (format t "~&Y=~S Z=~S~%" y z) + (g367-i367s z)))) +(defun r367 (x y) (declare (ignore x y)) nil) +(defun h367 (x) (declare (ignore x)) (values)) +(multiple-value-bind (res err) (ignore-errors (frob-367 0 (make-e367))) + (assert (not res)) + (assert (typep err 'type-error))) + +(handler-case + (delete-file (compile-file "circ-tree-test.lisp")) + (storage-condition (e) + (error e))) + +;;; warnings due to step-insturmentation +(defclass debug-test-class () ()) +(handler-case + (compile nil '(lambda () + (declare (optimize (debug 3))) + (defmethod print-object ((x debug-test-class) s) + (call-next-method)))) + ((and (not style-warning) warning) (e) + (error e))) + +;;; program-error from bad lambda-list keyword +(assert (eq :ok + (handler-case + (funcall (lambda (&whole x) + (list &whole x))) + (program-error () + :ok)))) +(assert (eq :ok + (handler-case + (let ((*evaluator-mode* :interpret)) + (funcall (eval '(lambda (&whole x) + (list &whole x))))) + (program-error () + :ok)))) + +;;; ignore &environment +(handler-bind ((style-warning #'error)) + (compile nil '(lambda () + (defmacro macro-ignore-env (&environment env) + (declare (ignore env)) + :foo))) + (compile nil '(lambda () + (defmacro macro-no-env () + :foo)))) + +(dolist (*evaluator-mode* '(:interpret :compile)) + (disassemble (eval '(defun disassemble-source-form-bug (x y z) + (declare (optimize debug)) + (list x y z))))) + +;;; long-standing bug in defaulting unknown values on the x86-64, +;;; since changing the calling convention (test case by Christopher +;;; Laux sbcl-help 30-06-2007) + +(defun default-values-bug-demo-sub () + (format t "test") + nil) +(compile 'default-values-bug-demo-sub) + +(defun default-values-bug-demo-main () + (multiple-value-bind (a b c d e f g h) + (default-values-bug-demo-sub) + (if a (+ a b c d e f g h) t))) +(compile 'default-values-bug-demo-main) + +(assert (default-values-bug-demo-main)) + +;;; copy propagation bug reported by Paul Khuong + +(defun local-copy-prop-bug-with-move-arg (x) + (labels ((inner () + (values 1 0))) + (if x + (inner) + (multiple-value-bind (a b) + (inner) + (values b a))))) + +(assert (equal '(0 1) (multiple-value-list (local-copy-prop-bug-with-move-arg nil)))) +(assert (equal '(1 0) (multiple-value-list (local-copy-prop-bug-with-move-arg t)))) + +;;;; with-pinned-objects & unwind-protect, using all non-tail conventions + +(defun wpo-quux () (list 1 2 3)) +(defvar *wpo-quux* #'wpo-quux) + +(defun wpo-call () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (values (funcall *wpo-quux*))))) +(assert (equal '(1 2 3) (wpo-call))) + +(defun wpo-multiple-call () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (funcall *wpo-quux*)))) +(assert (equal '(1 2 3) (wpo-multiple-call))) + +(defun wpo-call-named () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (values (wpo-quux))))) +(assert (equal '(1 2 3) (wpo-call-named))) + +(defun wpo-multiple-call-named () + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (wpo-quux)))) +(assert (equal '(1 2 3) (wpo-multiple-call-named))) + +(defun wpo-call-variable (&rest args) + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (values (apply *wpo-quux* args))))) +(assert (equal '(1 2 3) (wpo-call-variable))) + +(defun wpo-multiple-call-variable (&rest args) + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (apply #'wpo-quux args)))) +(assert (equal '(1 2 3) (wpo-multiple-call-named))) + +(defun wpo-multiple-call-local () + (flet ((quux () + (wpo-quux))) + (unwind-protect + (sb-sys:with-pinned-objects (*wpo-quux*) + (quux))))) +(assert (equal '(1 2 3) (wpo-multiple-call-local))) + +;;; bug 417: toplevel NIL confusing source path logic +(handler-case + (delete-file (compile-file "bug-417.lisp")) + (sb-ext:code-deletion-note (e) + (error e))) + +;;; unknown values return convention getting disproportionate +;;; amounts of values. +(declaim (notinline one-value two-values)) +(defun one-value (x) + (not x)) +(defun two-values (x y) + (values y x)) +(defun wants-many-values (x y) + (multiple-value-bind (a b c d e f) + (one-value y) + (assert (and (eql (not y) a) + (not (or b c d e f))))) + (multiple-value-bind (a b c d e f) + (two-values y x) + (assert (and (eql a x) (eql b y) + (not (or c d e f))))) + (multiple-value-bind (a b c d e f g h i) + (one-value y) + (assert (and (eql (not y) a) + (not (or b c d e f g h i))))) + (multiple-value-bind (a b c d e f g h i) + (two-values y x) + (assert (and (eql a x) (eql b y) + (not (or c d e f g h i))))) + (multiple-value-bind (a b c d e f g h i j k l m n o p q r s) + (one-value y) + (assert (and (eql (not y) a) + (not (or b c d e f g h i j k l m n o p q r s))))) + (multiple-value-bind (a b c d e f g h i j k l m n o p q r s) + (two-values y x) + (assert (and (eql a x) (eql b y) + (not (or c d e f g h i j k l m n o p q r s)))))) +(wants-many-values 1 42) + +;;; constant coalescing + +(defun count-code-constants (x f) + (let ((code (sb-kernel:fun-code-header f)) + (n 0)) + (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) + do (when (equal x (sb-kernel:code-header-ref code i)) + (incf n))) + n)) + +(defvar *lambda*) + +(defun compile2 (lambda) + (let* ((lisp "compiler-impure-tmp.lisp") + (fasl (compile-file-pathname lisp))) + (unwind-protect + (progn + (with-open-file (f lisp :direction :output) + (prin1 `(setf *lambda* ,lambda) f)) + (multiple-value-bind (fasl warn fail) (compile-file lisp) + (declare (ignore warn)) + (when fail + (error "File-compiling ~S failed." lambda)) + (let ((*lambda* nil)) + (load fasl) + (values *lambda* (compile nil lambda))))) + (ignore-errors (delete-file lisp)) + (ignore-errors (delete-file fasl))))) + +;; named and unnamed +(defconstant +born-to-coalesce+ '.born-to-coalesce.) +(multiple-value-bind (file-fun core-fun) + (compile2 '(lambda () + (let ((x (cons +born-to-coalesce+ nil)) + (y (cons '.born-to-coalesce. nil))) + (list x y)))) + (assert (= 1 (count-code-constants '.born-to-coalesce. file-fun))) + (assert (= 1 (count-code-constants '.born-to-coalesce. core-fun)))) + +;; some things must retain identity under COMPILE, but we want to coalesce them under COMPILE-FILE +(defun assert-coalescing (constant) + (let ((value (copy-seq (symbol-value constant)))) + (multiple-value-bind (file-fun core-fun) + (compile2 `(lambda () + (let ((x (cons ,constant nil)) + (y (cons ',value nil))) + (list x y)))) + (assert (= 1 (count-code-constants value file-fun))) + (assert (= 2 (count-code-constants value core-fun))) + (let* ((l (funcall file-fun)) + (a (car (first l))) + (b (car (second l)))) + (assert (and (equal value a) + (equal a b) + (eq a b)))) + (let* ((l (funcall core-fun)) + (a (car (first l))) + (b (car (second l)))) + (assert (and (equal value a) + (equal a b) + (not (eq a b)))))))) + +(defconstant +born-to-coalesce2+ "maybe coalesce me!") +(assert-coalescing '+born-to-coalesce2+) + +(defconstant +born-to-coalesce3+ #*01101001011101110100011) +(assert-coalescing '+born-to-coalesce3+) + +(defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010)) +(assert-coalescing '+born-to-coalesce4+) + +(defclass some-constant-thing () ()) + +;;; correct handling of nested things loaded via SYMBOL-VALUE +(defvar *sneaky-nested-thing* (list (make-instance 'some-constant-thing))) +(defconstant +sneaky-nested-thing+ *sneaky-nested-thing*) +(multiple-value-bind (file-fun core-fun) (compile2 '(lambda () +sneaky-nested-thing+)) + (assert (equal *sneaky-nested-thing* (funcall file-fun))) + (assert (equal *sneaky-nested-thing* (funcall core-fun)))) + +;;; catch constant modifications thru undefined variables +(defun sneak-set-dont-set-me (x) + (ignore-errors (setq dont-set-me x))) +(defconstant dont-set-me 42) +(assert (not (sneak-set-dont-set-me 13))) +(assert (= 42 dont-set-me)) +(defun sneak-set-dont-set-me2 (x) + (ignore-errors (setq dont-set-me2 x))) +(defconstant dont-set-me2 (make-instance 'some-constant-thing)) +(assert (not (sneak-set-dont-set-me2 13))) +(assert (typep dont-set-me2 'some-constant-thing)) + +;;; check that non-trivial constants are EQ across different files: this is +;;; not something ANSI either guarantees or requires, but we want to do it +;;; anyways. +(defconstant +share-me-1+ #-inline-constants 123.456d0 #+inline-constants nil) +(defconstant +share-me-2+ "a string to share") +(defconstant +share-me-3+ (vector 1 2 3)) +(defconstant +share-me-4+ (* 2 most-positive-fixnum)) +(multiple-value-bind (f1 c1) (compile2 '(lambda () (values +share-me-1+ + +share-me-2+ + +share-me-3+ + +share-me-4+ + #-inline-constants pi))) + (multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+ + +share-me-2+ + +share-me-3+ + +share-me-4+ + #-inline-constants pi))) + (flet ((test (fa fb) + (mapc (lambda (a b) + (assert (eq a b))) + (multiple-value-list (funcall fa)) + (multiple-value-list (funcall fb))))) + (test f1 c1) + (test f1 f2) + (test f1 c2)))) + +;;; user-defined satisfies-types cannot be folded +(deftype mystery () '(satisfies mysteryp)) +(defvar *mystery* nil) +(defun mysteryp (x) (eq x *mystery*)) +(defstruct thing (slot (error "missing") :type mystery)) +(defun test-mystery (m) (when (eq :mystery (thing-slot m)) :ok)) +(setf *mystery* :mystery) +(assert (eq :ok (test-mystery (make-thing :slot :mystery)))) + ;;; success