X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=caf24e7c5cc7861937b5d42e77c76175f1ab1c4d;hb=41d822d26e0ffee4be348ebf35e19caff0c858e1;hp=dd6a23b2be64cc2d9b0ab0771b05ad875d15e42e;hpb=175c318c892b0627b36fa3c4db66f59680242204;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index dd6a23b..caf24e7 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -15,7 +15,9 @@
 ;;;; 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
@@ -1067,4 +1069,262 @@
           (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 "&lt;"))
+                    ((char= char #\>)
+                     (add-string "&gt;"))
+                    ((char= char #\&)
+                     (add-string "&amp;"))
+                    ((char= char #\')
+                     (add-string "&#39;"))
+                    ((char= char #\newline)
+                     (add-string "<br>"))
+                    ((char= char #\")
+                     (if left-quote? (add-string "&#147;") (add-string "&#148;"))
+                     (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