;;;; 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")
(use-package "ASSERTOID")
;;; Old CMU CL code assumed that the names of "keyword" arguments are
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 "<br>"))
+ ((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 &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))))
+
;;; success
projects / sbcl.git / blobdiff