;;;; 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
(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 "<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)))))
+
+;;; 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)))))
+
;;; success
projects / sbcl.git / blobdiff