X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=5fd88288c087a3d3015e6e87552e09f33f3a72a6;hb=02a50d510572990c2b836e37ec1c0b23dac41b1a;hp=4f44164e6451f70a715c520e90f8a892e9585ee3;hpb=efb7317381c54e1a28f6c1c179a4fb8d58fdc7eb;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 4f44164..5fd8828 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -10,12 +10,14 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(load "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 @@ -46,9 +48,9 @@ (let (num x) (flet ((digs () (setq num index)) - (z () - (let () - (setq x nil)))) + (z () + (let () + (setq x nil)))) (when (and (digs) (digs)) x)))) ;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH @@ -68,8 +70,8 @@ (flet ((wufn () (glorp table1 4.9))) (gleep *uustk* #'wufn "#1" (list))) (if (eql (lo foomax 3.2)) - (values) - (error "not ~S" '(eql (lo foomax 3.2)))) + (values) + (error "not ~S" '(eql (lo foomax 3.2)))) (values))) ;;; A simpler test case for bug 150: The compiler died with the ;;; same type error when trying to compile this. @@ -84,9 +86,9 @@ (defun bug147 (string ind) (flet ((digs () (let (old-index) - (if (and (< ind ind) - (typep (char string ind) '(member #\1))) - nil)))))) + (if (and (< ind ind) + (typep (char string ind) '(member #\1))) + nil)))))) ;;; bug reported and fixed by Matthias Hoelzl sbcl-devel 2002-05-13 (defmacro foo-2002-05-13 () ''x) @@ -120,24 +122,24 @@ (defstruct something-known-to-be-a-struct x y) (multiple-value-bind (fun warnings-p failure-p) (compile nil - '(lambda () - (labels ((a1 (a2 a3) - (cond (t (a4 a2 a3)))) - (a4 (a2 a3 a5 a6) - (declare (type (or simple-vector null) a5 a6)) - (something-known-to-be-a-struct-x a5)) - (a8 (a2 a3) - (a9 #'a1 a10 a2 a3)) - (a11 (a2 a3) - (cond ((and (funcall a12 a2) - (funcall a12 a3)) - (funcall a13 a2 a3)) - (t - (when a14 - (let ((a15 (a1 a2 a3))) - )) - a16)))) - (values #'a17 #'a11)))) + '(lambda () + (labels ((a1 (a2 a3) + (cond (t (a4 a2 a3)))) + (a4 (a2 a3 a5 a6) + (declare (type (or simple-vector null) a5 a6)) + (something-known-to-be-a-struct-x a5)) + (a8 (a2 a3) + (a9 #'a1 a10 a2 a3)) + (a11 (a2 a3) + (cond ((and (funcall a12 a2) + (funcall a12 a3)) + (funcall a13 a2 a3)) + (t + (when a14 + (let ((a15 (a1 a2 a3))) + )) + a16)))) + (values #'a17 #'a11)))) ;; Python sees the structure accessor on the known-not-to-be-a-struct ;; A5 value and is very, very disappointed in you. (But it doesn't ;; signal BUG any more.) @@ -149,10 +151,10 @@ ;;; spotted and fixed by Raymond Toy for CMUCL) (defun logand-sparc-bogons (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) (declare (type (unsigned-byte 32) a0) - (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) - ;; to ensure that the call is a candidate for - ;; transformation - (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0))) + (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + ;; to ensure that the call is a candidate for + ;; transformation + (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0))) (values ;; the call that fails compilation (logand a0 a10) @@ -165,7 +167,7 @@ ;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so ;;; it would fail. (defun bug192 () - (funcall + (funcall (LAMBDA (TEXT I L ) (LABELS ((G908 (I) (LET ((INDEX @@ -208,65 +210,65 @@ (labels ((alpha-equal-bound-term-lists (listx listy) (or (and (null listx) (null listy)) - (and listx listy - (let ((bindings-x (bindings-of-bound-term (car listx))) - (bindings-y (bindings-of-bound-term (car listy)))) - (if (and (null bindings-x) (null bindings-y)) - (alpha-equal-terms (term-of-bound-term (car listx)) - (term-of-bound-term (car listy))) - (and (= (length bindings-x) (length bindings-y)) - (prog2 - (enter-binding-pairs (bindings-of-bound-term (car listx)) - (bindings-of-bound-term (car listy))) - (alpha-equal-terms (term-of-bound-term (car listx)) - (term-of-bound-term (car listy))) - (exit-binding-pairs (bindings-of-bound-term (car listx)) - (bindings-of-bound-term (car listy))))))) - (alpha-equal-bound-term-lists (cdr listx) (cdr listy))))) + (and listx listy + (let ((bindings-x (bindings-of-bound-term (car listx))) + (bindings-y (bindings-of-bound-term (car listy)))) + (if (and (null bindings-x) (null bindings-y)) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (and (= (length bindings-x) (length bindings-y)) + (prog2 + (enter-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (exit-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))))))) + (alpha-equal-bound-term-lists (cdr listx) (cdr listy))))) (alpha-equal-terms (termx termy) (if (and (variable-p termx) - (variable-p termy)) - (equal-bindings (id-of-variable-term termx) - (id-of-variable-term termy)) - (and (equal-operators-p (operator-of-term termx) (operator-of-term termy)) - (alpha-equal-bound-term-lists (bound-terms-of-term termx) - (bound-terms-of-term termy)))))) + (variable-p termy)) + (equal-bindings (id-of-variable-term termx) + (id-of-variable-term termy)) + (and (equal-operators-p (operator-of-term termx) (operator-of-term termy)) + (alpha-equal-bound-term-lists (bound-terms-of-term termx) + (bound-terms-of-term termy)))))) (or (eq termx termy) - (and termx termy - (with-variable-invocation (alpha-equal-terms termx termy)))))) + (and termx termy + (with-variable-invocation (alpha-equal-terms termx termy)))))) (defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28 ;; Given an FSSP alignment file named by the argument . . . (labels ((get-fssp-char () - (get-fssp-char)) - (read-fssp-char () - (get-fssp-char))) + (get-fssp-char)) + (read-fssp-char () + (get-fssp-char))) ;; Stub body, enough to tickle the bug. (list (read-fssp-char) - (read-fssp-char)))) + (read-fssp-char)))) (defun bug70 ; from David Young cmucl-help 30 Nov 2000 (item sequence &key (test #'eql)) (labels ((find-item (obj seq test &optional (val nil)) - (let ((item (first seq))) - (cond ((null seq) - (values nil nil)) - ((funcall test obj item) - (values val seq)) - (t - (find-item obj - (rest seq) - test - (nconc val `(,item)))))))) + (let ((item (first seq))) + (cond ((null seq) + (values nil nil)) + ((funcall test obj item) + (values val seq)) + (t + (find-item obj + (rest seq) + test + (nconc val `(,item)))))))) (find-item item sequence test))) (defun bug109 () ; originally from CMU CL bugs collection, reported as ; SBCL bug by MNA 2001-06-25 - (labels + (labels ((eff (&key trouble) - (eff) - ;; nil - ;; Uncomment and it works - )) + (eff) + ;; nil + ;; Uncomment and it works + )) (eff))) ;;; bug 192a, fixed by APD "more strict type checking" patch @@ -308,14 +310,19 @@ ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18. (multiple-value-bind (function warnings-p failure-p) - (compile nil '(lambda () (symbol-macrolet ((t nil)) t))) + (compile nil '(lambda () + ;; not interested in the package lock violation here + (declare (sb-ext:disable-package-locks t)) + (symbol-macrolet ((t nil)) t))) (assert failure-p) (assert (raises-error? (funcall function) program-error))) (multiple-value-bind (function warnings-p failure-p) (compile nil - '(lambda () - (symbol-macrolet ((*standard-input* nil)) - *standard-input*))) + '(lambda () + ;; not interested in the package lock violation here + (declare (sb-ext:disable-package-locks *standard-input*)) + (symbol-macrolet ((*standard-input* nil)) + *standard-input*))) (assert failure-p) (assert (raises-error? (funcall function) program-error))) (multiple-value-bind (function warnings-p failure-p) @@ -337,7 +344,7 @@ (declare (optimize (speed 3) (safety 1) (debug 1))) (if x t (if y t (dont-constrain-if-too-much x y)))) -(assert (null (dont-constrain-if-too-much-aux nil nil))) +(assert (null (dont-constrain-if-too-much-aux nil nil))) ;;; TYPE-ERROR confusion ca. sbcl-0.7.7.24, reported and fixed by ;;; APD sbcl-devel 2002-09-14 @@ -580,7 +587,7 @@ ;;; bug 172: macro lambda lists were too permissive until 0.7.9.28 ;;; (fix provided by Matthew Danish) on sbcl-devel (assert (null (ignore-errors - (defmacro bug172 (&rest rest foo) `(list ,rest ,foo))))) + (defmacro bug172 (&rest rest foo) `(list ,rest ,foo))))) ;;; embedded THEs (defun check-embedded-thes (policy1 policy2 x y) @@ -589,9 +596,9 @@ `(lambda (f) (declare (optimize (speed 2) (safety ,policy1))) (multiple-value-list - (the (values (integer 2 3) t) + (the (values (integer 2 3) t &optional) (locally (declare (optimize (safety ,policy2))) - (the (values t (single-float 2f0 3f0)) + (the (values t (single-float 2f0 3f0) &optional) (funcall f))))))) (lambda () (values x y))) (type-error (error) @@ -627,9 +634,9 @@ (defun to-be-inlined (y) (frob y))) (assert (= (call-inlined 3) - ;; we should have inlined the previous definition, so the - ;; new one won't show up yet. - 4)) + ;; we should have inlined the previous definition, so the + ;; new one won't show up yet. + 4)) (defun call-inlined (z) (to-be-inlined z)) (assert (= (call-inlined 3) 6)) @@ -650,7 +657,7 @@ (defun bug219-a-aux () (bug219-a 2)) (assert (= (bug219-a-aux) - (if *bug219-a-expanded-p* 4 3))) + (if *bug219-a-expanded-p* 4 3))) (defvar *bug219-a-temp* 3) (assert (= (bug219-a *bug219-a-temp*) 4)) @@ -670,7 +677,7 @@ (defun bug219-b (x) x) (assert (= (bug219-b-aux2 1) - (if *bug219-b-expanded-p* 3 1))) + (if *bug219-b-expanded-p* 3 1))) ;;; bug 224: failure in unreachable code deletion (defmacro do-optimizations (&body body) @@ -725,10 +732,14 @@ ;;; COERCE got its own DEFOPTIMIZER which has to reimplement most of ;;; SPECIFIER-TYPE-NTH-ARG. For a while, an illegal type would throw ;;; you into the debugger on compilation. -(defun coerce-defopt (x) +(defun coerce-defopt1 (x) ;; illegal, but should be compilable. (coerce x '(values t))) -(assert (null (ignore-errors (coerce-defopt 3)))) +(defun coerce-defopt2 (x) + ;; illegal, but should be compilable. + (coerce x '(values t &optional))) +(assert (null (ignore-errors (coerce-defopt1 3)))) +(assert (null (ignore-errors (coerce-defopt2 3)))) ;;; Oops. In part of the (CATCH ..) implementation of DEBUG-RETURN, ;;; it was possible to confuse the type deriver of the compiler @@ -738,11 +749,11 @@ ;;; WHN's original report (defun debug-return-catch-break1 () (with-open-file (s "/tmp/foo" - :direction :output - :element-type (list - 'signed-byte - (1+ - (integer-length most-positive-fixnum)))) + :direction :output + :element-type (list + 'signed-byte + (1+ + (integer-length most-positive-fixnum)))) (read-byte s) (read-byte s) (read-byte s) @@ -757,8 +768,8 @@ ;;; can understand. Here's a simple test for that on a function ;;; that's likely to return a hairier list than just a lambda: (macrolet ((def (fn) `(progn - (declaim (inline ,fn)) - (defun ,fn (x) (1+ x))))) + (declaim (inline ,fn)) + (defun ,fn (x) (1+ x))))) (def bug228)) (let ((x (function-lambda-expression #'bug228))) (when x @@ -809,9 +820,9 @@ (+ x y)) (defun baz8alpha04 (this kids) (flet ((n-i (&rest rest) - ;; Removing the #+NIL here makes the bug go away. - #+nil (format t "~&in N-I REST=~S~%" rest) - (apply #'frob8alpha04 this rest))) + ;; Removing the #+NIL here makes the bug go away. + #+nil (format t "~&in N-I REST=~S~%" rest) + (apply #'frob8alpha04 this rest))) (n-i kids))) ;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST." (assert (= (baz8alpha04 12 13) 25)) @@ -835,6 +846,85 @@ (list (bar x) (bar x) (bar x)))) (assert (raises-error? (bug249 1.0) type-error)) + +;;; bug reported by ohler on #lisp 2003-07-10 +(defun bug-ohler-2003-07-10 (a b) + (declare (optimize (speed 0) (safety 3) (space 0) + (debug 1) (compilation-speed 0))) + (adjoin a b)) + +;;; bug reported by Doug McNaught on sbcl-devel 2003-09-14: +;;; COMPILE-FILE did not bind *READTABLE* +(let* ((source "bug-doug-mcnaught-20030914.lisp") + (fasl (compile-file-pathname source))) + (labels ((check () + (assert (null (get-macro-character #\])))) + (full-check () + (check) + (assert (typep *bug-doug-mcnaught-20030914* + '(simple-array (unsigned-byte 4) (*)))) + (assert (equalp *bug-doug-mcnaught-20030914* #(1 2 3))) + (makunbound '*bug-doug-mcnaught-20030914*))) + (compile-file source) + (check) + (load fasl) + (full-check) + (load source) + (full-check) + (delete-file fasl))) + +(defun expt-derive-type-bug (a b) + (unless (< a b) + (truncate (expt a b)))) +(assert (equal (multiple-value-list (expt-derive-type-bug 1 1)) + '(1 0))) + +;;; Problems with type checking in functions with EXPLICIT-CHECK +;;; attribute (reported by Peter Graves) +(loop for (fun . args) in '((= a) (/= a) + (< a) (<= a) (> a) (>= a)) + do (assert (raises-error? (apply fun args) type-error))) + +(defclass broken-input-stream (sb-gray:fundamental-input-stream) ()) +(defmethod sb-gray:stream-read-char ((stream broken-input-stream)) + (throw 'break :broken)) +(assert (eql (block return + (handler-case + (catch 'break + (funcall (eval ''peek-char) + 1 (make-instance 'broken-input-stream)) + :test-broken) + (type-error (c) + (return-from return :good)))) + :good)) + +;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual) +(defvar *compiler-note-count* 0) +#-(or alpha x86-64) ; FIXME: make a better test! +(handler-bind ((sb-ext:compiler-note (lambda (c) + (declare (ignore c)) + (incf *compiler-note-count*)))) + (let ((fun + (compile nil + '(lambda (x) + (declare (optimize speed) (fixnum x)) + (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (values (* x 5) ; no compiler note from this + (locally + (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + ;; this one gives a compiler note + (* x -5))))))) + (assert (= *compiler-note-count* 1)) + (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5))))) + +(handler-case + (eval '(flet ((%f (&key) nil)) (%f nil nil))) + (error (c) :good) + (:no-error (val) (error "no error: ~S" val))) +(handler-case + (eval '(labels ((%f (&key x) x)) (%f nil nil))) + (error (c) :good) + (:no-error (val) (error "no error: ~S" val))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -852,55 +942,291 @@ (dolist (template (fun-info-templates (info :function :info function))) (when (template-more-results-type template) (format t "~&Template ~A has :MORE results, and translates ~A.~%" - (template-name template) - function) + (template-name template) + function) (return nil)) (when (eq (template-result-types template) :conditional) ;; dunno. (return t)) (let ((types (template-result-types template)) - (result-type (fun-type-returns (info :function :type function)))) + (result-type (fun-type-returns (info :function :type function)))) (cond - ((values-type-p result-type) - (do ((ltypes (append (args-type-required result-type) - (args-type-optional result-type)) - (rest ltypes)) - (types types (rest types))) - ((null ltypes) - (unless (null types) - (format t "~&More types than ltypes in ~A, translating ~A.~%" - (template-name template) - function) - (return nil))) - (when (null types) - (unless (null ltypes) - (format t "~&More ltypes than types in ~A, translating ~A.~%" - (template-name template) - function) - (return nil))))) - ((eq result-type (specifier-type nil)) - (unless (null types) - (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%" - (template-name template) - function) - (return nil))) - ((/= (length types) 1) - (format t "~&Template ~A isn't returning 1 value for ~A.~%" - (template-name template) - function) - (return nil)) - (t t))))) + ((values-type-p result-type) + (do ((ltypes (append (args-type-required result-type) + (args-type-optional result-type)) + (rest ltypes)) + (types types (rest types))) + ((null ltypes) + (unless (null types) + (format t "~&More types than ltypes in ~A, translating ~A.~%" + (template-name template) + function) + (return nil))) + (when (null types) + (unless (null ltypes) + (format t "~&More ltypes than types in ~A, translating ~A.~%" + (template-name template) + function) + (return nil))))) + ((eq result-type (specifier-type nil)) + (unless (null types) + (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%" + (template-name template) + function) + (return nil))) + ((/= (length types) 1) + (format t "~&Template ~A isn't returning 1 value for ~A.~%" + (template-name template) + function) + (return nil)) + (t t))))) (defun identify-suspect-vops (&optional (env (first - (last *info-environment*)))) + (last *info-environment*)))) (do-info (env :class class :type type :name name :value value) (when (and (eq class :function) (eq type :type)) ;; OK, so we have an entry in the INFO database. Now, if ... (let* ((info (info :function :info name)) - (templates (and info (fun-info-templates info)))) - (when templates - ;; ... it has translators - (grovel-results name)))))) + (templates (and info (fun-info-templates info)))) + (when templates + ;; ... it has translators + (grovel-results name)))))) (identify-suspect-vops) +;;;; tests for compiler output +(let* ((*error-output* (make-broadcast-stream)) + (output (with-output-to-string (*standard-output*) + (compile-file "compiler-output-test.lisp" + :print nil :verbose nil)))) + (print output) + (assert (zerop (length output)))) + +;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost + +(define-condition optimization-error (error) ()) + +(labels ((compile-lambda (type sense) + (handler-bind ((compiler-note (lambda (_) + (declare (ignore _)) + (error 'optimization-error)))) + (values + (compile + nil + `(lambda () + (declare + ,@(when type '((ftype (function () (integer 0 10)) bug-305))) + (,sense bug-305) + (optimize speed)) + (1+ (bug-305)))) + nil))) + (expect-error (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda nil sense)) + (assert (not f)) + (assert (typep e 'optimization-error)))) + (expect-pass (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda t sense)) + (assert f) + (assert (not e))))) + (expect-error 'inline) + (expect-error 'notinline) + (expect-pass 'inline) + (expect-pass 'notinline)) + +;;; bug 211e: bogus style warning from duplicated keyword argument to +;;; a local function. +(handler-bind ((style-warning #'error)) + (let ((f (compile nil '(lambda () + (flet ((foo (&key y) (list y))) + (list (foo :y 1 :y 2))))))) + (assert (equal '((1)) (funcall f))))) + +;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM). +(handler-bind ((compiler-note #'error)) + (let ((f1 (compile nil '(lambda (x1 y1) + (declare (type (or symbol fixnum) x1) + (optimize speed)) + (eql x1 y1)))) + (f2 (compile nil '(lambda (x2 y2) + (declare (type (or symbol fixnum) y2) + (optimize speed)) + (eql x2 y2))))) + (let ((fix (random most-positive-fixnum)) + (sym (gensym)) + (e-count 0)) + (assert (funcall f1 fix fix)) + (assert (funcall f2 fix fix)) + (assert (funcall f1 sym sym)) + (assert (funcall f2 sym sym)) + (handler-bind ((type-error (lambda (c) + (incf e-count) + (continue c)))) + (flet ((test (f x y) + (with-simple-restart (continue "continue with next test") + (funcall f x y) + (error "fell through with (~S ~S ~S)" f x y)))) + (test f1 "oops" 42) + (test f1 (1+ most-positive-fixnum) 42) + (test f2 42 "oops") + (test f2 42 (1+ most-positive-fixnum)))) + (assert (= e-count 4))))) + +;;; bug #389 (Rick Taube sbcl-devel) +(defun bes-jn (unn ux) + (let ((nn unn) (x ux)) + (let* ((n (floor (abs nn))) + (besn + (if (= n 0) + (bes-j0 x) + (if (= n 1) + (bes-j1 x) + (if (zerop x) + 0.0 + (let ((iacc 40) + (ans 0.0) + (bigno 1.0e+10) + (bigni 1.0e-10)) + (if (> (abs x) n) + (do ((tox (/ 2.0 (abs x))) + (bjm (bes-j0 (abs x))) + (bj (bes-j1 (abs x))) + (j 1 (+ j 1)) + (bjp 0.0)) + ((= j n) (setf ans bj)) + (setf bjp (- (* j tox bj) bjm)) + (setf bjm bj) + (setf bj bjp)) + (let ((tox (/ 2.0 (abs x))) + (m + (* 2 + (floor + (/ (+ n (sqrt (* iacc n))) + 2)))) + (jsum 0.0) + (bjm 0.0) + (sum 0.0) + (bjp 0.0) + (bj 1.0)) + (do ((j m (- j 1))) + ((= j 0)) + (setf bjm (- (* j tox bj) bjp)) + (setf bjp bj) + (setf bj bjm) + (when (> (abs bj) bigno) + (setf bj (* bj bigni)) + (setf bjp (* bjp bigni)) + (setf ans (* ans bigni)) + (setf sum (* sum bigni))) + (if (not (= 0 jsum)) (incf sum bj)) + (setf jsum (- 1 jsum)) + (if (= j n) (setf ans bjp))) + (setf sum (- (* 2.0 sum) bj)) + (setf ans (/ ans sum)))) + (if (and (minusp x) (oddp n)) + (- ans) + 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)) + ;;; success -(quit :unix-status 104)