X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=ebd0b727f83a47f1707515c6175f9101abcde055;hb=b822fdd53a4dcfda0df39dcdfd73967921ddf5ad;hp=5fd88288c087a3d3015e6e87552e09f33f3a72a6;hpb=4e0ff6bb79908436adea8375d4eea46d10079cec;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 5fd8828..ebd0b72 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -15,6 +15,9 @@ ;;;; 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 "assertoid.lisp") (use-package "TEST-UTIL") @@ -1229,4 +1232,220 @@ (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 &optional b &rest c &key d) + (list whole a b c d)) + +(macrolet ((test (form a b c d) + `(let ((form ',form)) + (destructuring-bind (whole a b c d) + (funcall (compiler-macro-function 'test-cmacro-1) form nil) + (assert (equal whole form)) + (assert (eql a ,a)) + (assert (eql b ,b)) + (assert (equal c ,c)) + (assert (eql d ,d))))) ) + (test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3) + (test (test-cmacro-1 11 12 :d 13) 11 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)) + ;;; success