X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-cltl2%2Ftests.lisp;h=e32a20a846f812b75d026c023afdb612d1846999;hb=760de025ce5437902c8a289bc831c6f6dc92fd16;hp=07882601b1534a5759932814e7d10a6a2d463b50;hpb=30b24d582dd8620b91c798e38a8aa9a6b999b4be;p=sbcl.git

diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp
index 0788260..e32a20a 100644
--- a/contrib/sb-cltl2/tests.lisp
+++ b/contrib/sb-cltl2/tests.lisp
@@ -6,7 +6,7 @@
 ;;;; more information.
 
 (defpackage :sb-cltl2-tests
-  (:use :sb-cltl2 :cl :sb-rt))
+  (:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
 
 (in-package :sb-cltl2-tests)
 
@@ -65,6 +65,8 @@
     (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
   (symbol-macrolet ((srlt '(nil zool))) 'zool))
 
+;;;; DECLARATION-INFORMATION
+
 (defmacro dinfo (thing &environment env)
   `',(declaration-information thing env))
 
@@ -90,6 +92,27 @@
   (def compilation-speed)
   (def space))
 
+
+(deftest declaration-information.restrict-compiler-policy.1
+    (with-compilation-unit (:policy '(optimize) :override t)
+      (restrict-compiler-policy 'speed 3)
+      (eval '(cadr (assoc 'speed (dinfo optimize)))))
+  3)
+
+(deftest declaration-information.restrict-compiler-policy.2
+    (with-compilation-unit (:policy '(optimize) :override t)
+      (restrict-compiler-policy 'speed 3)
+      (locally (declare (optimize (speed 2)))
+        (cadr (assoc 'speed (dinfo optimize)))))
+  2)
+
+(deftest declaration-information.restrict-compiler-policy.3
+    (locally (declare (optimize (speed 2)))
+      (with-compilation-unit (:policy '(optimize) :override t)
+        (restrict-compiler-policy 'speed 3)
+        (cadr (assoc 'speed (dinfo optimize)))))
+  2)
+
 (deftest declaration-information.muffle-conditions.default
   (dinfo sb-ext:muffle-conditions)
   nil)
@@ -109,6 +132,13 @@
                (subtypep '(and warning (not style-warning)) dinfo)))))))
   t)
 
+
+(declaim (declaration fubar))
+
+(deftest declaration-information.declaration
+    (if (member 'fubar (declaration-information 'declaration)) 'yay)
+  yay)
+
 ;;;; VARIABLE-INFORMATION
 
 (defvar *foo*)
@@ -182,7 +212,7 @@
           (assert (plusp x)))))
   (:lexical t nil))
 
-(deftest variable-info.lexical.type.2
+(deftest variable-info.lexical.type.3
     (let ((x 42))
       (locally (declare (fixnum x))
         (var-info x)))
@@ -209,6 +239,21 @@
     (var-info #:undefined)
   (nil nil nil))
 
+(declaim (global this-is-global))
+(deftest global-variable
+    (var-info this-is-global)
+  (:global nil nil))
+
+(defglobal this-is-global-too 42)
+(deftest global-variable.2
+    (var-info this-is-global-too)
+  (:global nil ((always-bound . t))))
+
+(sb-alien:define-alien-variable "errno" sb-alien:int)
+(deftest alien-variable
+    (var-info errno)
+  (:alien nil nil))
+
 ;;;; FUNCTION-INFORMATION
 
 (defmacro fun-info (var &environment env)
@@ -270,3 +315,382 @@
   (:function nil ((inline . inline)
                   (ftype function (t) (values t &optional)))))
 
+(deftest function-information.ftype
+    (flet ((foo (x) x))
+      (declare (ftype (sfunction (integer) integer) foo))
+      (fun-info foo))
+  (:function
+   t
+   ((ftype function (integer) (values integer &optional)))))
+
+;;;;; AUGMENT-ENVIRONMENT
+
+(defmacro ct (form &environment env)
+  (let ((toeval `(let ((lexenv (quote ,env)))
+                   ,form)))
+    `(quote ,(eval toeval))))
+
+
+(deftest augment-environment.variable1
+    (multiple-value-bind (kind local alist)
+        (variable-information
+         'x
+         (augment-environment nil :variable (list 'x) :declare '((type integer x))))
+      (list kind local (cdr (assoc 'type alist))))
+  (:lexical t integer))
+
+(defvar *foo*)
+
+(deftest augment-environment.variable2
+    (identity (variable-information '*foo* (augment-environment nil :variable '(*foo*))))
+  :lexical)
+
+(deftest augment-environment.variable3
+    (identity (variable-information 'foo (augment-environment nil :variable '(foo))))
+  :lexical)
+
+(deftest augment-environment.variable.special1
+    (identity (variable-information 'x (augment-environment nil :variable '(x) :declare '((special x)))))
+  :special)
+
+(deftest augment-environment.variable.special12
+    (locally (declare (special x))
+      (ct
+       (variable-information
+        'x
+        (identity (augment-environment lexenv :variable '(x))))))
+  :lexical)
+
+(deftest augment-environment.variable.special13
+    (let* ((e1 (augment-environment nil :variable '(x) :declare '((special x))))
+           (e2 (augment-environment e1  :variable '(x))))
+      (identity (variable-information 'x e2)))
+  :lexical)
+
+(deftest augment-environment.variable.special.mask
+    (let* ((e1 (augment-environment nil :variable '(x) :declare '((ignore x))))
+           (e2 (augment-environment e1  :variable '(x))))
+      (assoc 'ignore
+             (nth 2 (multiple-value-list
+                     (variable-information 'x e2)))))
+  nil)
+
+(deftest augment-environment.variable.ignore
+    (variable-information
+     'x
+     (augment-environment nil
+                          :variable '(x)
+                          :declare  '((ignore x))))
+  :lexical
+  t
+  ((ignore . t)))
+
+(deftest augment-environment.function
+    (function-information
+     'foo
+     (augment-environment nil
+                          :function '(foo)
+                          :declare  '((ftype (sfunction (integer) integer) foo))))
+  :function
+  t
+  ((ftype function (integer) (values integer &optional))))
+
+
+(deftest augment-environment.macro
+    (macroexpand '(mac feh)
+                 (augment-environment
+                  nil
+                  :macro (list (list 'mac #'(lambda (form benv)
+                                              (declare (ignore env))
+                                              `(quote ,form ,form ,form))))))
+  (quote (mac feh) (mac feh) (mac feh))
+  t)
+
+(deftest augment-environment.symbol-macro
+    (macroexpand 'sym
+                 (augment-environment
+                  nil
+                  :symbol-macro (list (list 'sym '(foo bar baz)))))
+  (foo bar baz)
+  t)
+
+(deftest augment-environment.macro2
+    (eval (macroexpand '(newcond
+                         ((= 1 2) 'foo)
+                         ((= 1 1) 'bar))
+                       (augment-environment nil :macro (list (list 'newcond (macro-function 'cond))))))
+  bar)
+
+
+(deftest augment-environment.nest
+    (let ((x 1))
+      (ct
+       (let* ((e (augment-environment lexenv :variable '(y))))
+         (list
+          (variable-information 'x e)
+          (variable-information 'y e)))))
+  (:lexical :lexical))
+
+(deftest augment-environment.nest2
+    (symbol-macrolet ((x "x"))
+      (ct
+       (let* ((e (augment-environment lexenv :variable '(y))))
+         (list
+          (macroexpand 'x e)
+          (variable-information 'y e)))))
+  ("x" :lexical))
+
+(deftest augment-environment.symbol-macro-var
+    (let ((e (augment-environment
+              nil
+              :symbol-macro (list (list 'sym '(foo bar baz)))
+              :variable '(x))))
+      (list (macroexpand 'sym e)
+            (variable-information 'x e)))
+  ((foo bar baz)
+   :lexical))
+
+
+
+;;;;; DEFINE-DECLARATION
+
+(defmacro third-value (form)
+  (sb-int::with-unique-names (a b c)
+    `(multiple-value-bind (,a ,b ,c) ,form
+       (declare (ignore ,a ,b))
+       ,c)))
+
+(deftest define-declaration.declare
+    (progn
+      (define-declaration zaphod (spec env)
+        (declare (ignore env))
+        (values :declare (cons 'zaphod spec)))
+      (locally (declare (zaphod beblebrox))
+         (locally (declare (zaphod and ford))
+           (ct (declaration-information 'zaphod lexenv)))))
+  (zaphod and ford))
+
+
+(deftest define-declaration.declare2
+    (progn
+      (define-declaration zaphod (spec env)
+        (declare (ignore env))
+        (values :declare (cons 'zaphod spec)))
+      (locally
+           (declare (zaphod beblebrox)
+                    (special x))
+         (ct (declaration-information 'zaphod lexenv))))
+  (zaphod beblebrox))
+
+(deftest define-declaration.variable
+    (progn
+      (define-declaration vogon (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key vogon-value))))
+      (locally (declare (vogon poetry))
+        (ct
+         (assoc 'vogon-key
+                (third-value
+                 (variable-information
+                  'poetry
+                  lexenv))))))
+  (vogon-key . vogon-value))
+
+
+(deftest define-declaration.variable.special
+    (progn
+      (define-declaration vogon (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key vogon-value))))
+      (let (x)
+        (declare (vogon x))
+        (declare (special x))
+        (ct
+         (assoc 'vogon-key
+                (third-value
+                 (variable-information 'x lexenv))))))
+  (vogon-key . vogon-value))
+
+(deftest define-declaration.variable.special2
+    (progn
+      (define-declaration vogon (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key vogon-value))))
+      (let (x)
+        (declare (special x))
+        (declare (vogon x))
+        (ct
+         (assoc 'vogon-key
+                (third-value
+                 (variable-information 'x lexenv))))))
+  (vogon-key . vogon-value))
+
+(deftest define-declaration.variable.mask
+    (progn
+      (define-declaration vogon (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key vogon-value))))
+      (let (x)
+        (declare (vogon x))
+        (let (x)
+          (ct
+           (assoc
+            'vogon-key
+            (third (multiple-value-list (variable-information 'x lexenv))))))))
+  nil)
+
+(deftest define-declaration.variable.macromask
+    (progn
+      (define-declaration vogon (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key vogon-value))))
+      (let (x)
+        (declare (vogon x))
+        (symbol-macrolet ((x 42))
+          (ct
+           (assoc
+            'vogon-key
+            (third (multiple-value-list (variable-information 'x lexenv))))))))
+  nil)
+
+(deftest define-declaration.variable.macromask2
+    (progn
+      (define-declaration vogon (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key vogon-value))))
+      (symbol-macrolet ((x 42))
+        (declare (vogon x))
+        (list
+         (let (x)
+           (ct
+            (assoc
+             'vogon-key
+             (third (multiple-value-list (variable-information 'x lexenv))))))
+         (ct
+          (assoc
+           'vogon-key
+           (third (multiple-value-list (variable-information 'x lexenv))))))))
+  (nil (vogon-key . vogon-value)))
+
+(deftest define-declaration.variable.mask2
+    (progn
+      (define-declaration vogon-a (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key a))))
+      (define-declaration vogon-b (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key b))))
+      (let (x)
+        (declare (vogon-a x))
+        (let (x)
+          (declare (vogon-b x)))
+        (ct
+         (assoc
+          'vogon-key
+          (third (multiple-value-list (variable-information 'x lexenv)))))))
+  (vogon-key . a))
+
+(deftest define-declaration.variable.specialmask
+    (progn
+      (define-declaration vogon (spec env)
+        (declare (ignore env))
+        (values :variable `((,(cadr spec) vogon-key vogon-value))))
+      (locally
+          (declare (vogon *foo*))
+        (let (*foo*)
+          (ct
+           (assoc
+            'vogon-key
+            (third (multiple-value-list (variable-information '*foo* lexenv))))))))
+  (vogon-key . vogon-value))
+
+
+
+(deftest define-declaration.function
+    (progn
+      (define-declaration sad (spec env)
+        (declare (ignore env))
+        (values :function `((,(cadr spec) emotional-state sad))))
+      (locally (declare (zaphod beblebrox))
+        (locally (declare (sad robot))
+          (ct
+           (assoc 'emotional-state
+                  (third-value (function-information
+                                'robot
+                                lexenv)))))))
+  (emotional-state . sad))
+
+(deftest define-declaration.function.lexical
+    (progn
+      (define-declaration sad (spec env)
+        (declare (ignore env))
+        (values :function `((,(cadr spec) emotional-state sad))))
+      (flet ((robot nil))
+        (locally (declare (sad robot))
+          (ct
+           (assoc 'emotional-state
+                  (third-value (function-information
+                                'robot
+                                lexenv)))))))
+  (emotional-state . sad))
+
+
+(deftest define-declaration.function.lexical2
+    (progn
+      (define-declaration sad (spec env)
+        (declare (ignore env))
+        (values :function `((,(cadr spec) emotional-state sad))))
+      (labels ((robot nil))
+        (declare (sad robot))
+        (ct
+         (assoc 'emotional-state
+                (third-value (function-information
+                              'robot
+                              lexenv))))))
+  (emotional-state . sad))
+
+(deftest define-declaration.function.mask
+    (progn
+      (define-declaration sad (spec env)
+        (declare (ignore env))
+        (values :function `((,(cadr spec) emotional-state sad))))
+      (labels ((robot nil))
+        (declare (sad robot))
+        (labels ((robot nil))
+          (ct
+           (assoc 'emotional-state
+                  (third-value (function-information
+                                'robot
+                                lexenv)))))))
+  nil)
+
+
+(deftest define-declaration.function.mask2
+    (progn
+      (define-declaration sad (spec env)
+        (declare (ignore env))
+        (values :function `((,(cadr spec) emotional-state sad))))
+      (locally
+          (declare (sad robot))
+        (labels ((robot nil))
+          (ct
+           (assoc 'emotional-state
+                  (third-value (function-information
+                                'robot
+                                lexenv)))))))
+  nil)
+
+(deftest define-declaration.function2
+    (progn
+      (define-declaration happy (spec env)
+        (declare (ignore env))
+        (values :function `((,(cadr spec) emotional-state happy))))
+      (locally (declare (zaphod beblebrox))
+        (locally (declare (sad robot))
+          (locally (declare (happy robot))
+            (ct
+             (assoc 'emotional-state
+                    (third-value (function-information
+                                  'robot
+                                  lexenv))))))))
+  (emotional-state . happy))