0.9.15.27: compiler-macro expansion for FUNCALL forms & bugfixes

[sbcl.git] / tests / compiler.impure.lisp

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 33af05f..0f6da5e 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1229,9 +1229,9 @@
     (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
+;;; 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)))
@@ -1239,4 +1239,83 @@
       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)))))
+
 ;;; success