From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sat, 1 Aug 2009 08:30:08 +0000 (+0000)
Subject: 1.0.30.28: SB-CLTL2:AUGMENT-ENVIRONMENT
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=002f475dadf4e8f5dceba3a7eee65c56f12f7cd0;p=sbcl.git

1.0.30.28: SB-CLTL2:AUGMENT-ENVIRONMENT

 * Patch by Larry D'Anna.
---

diff --git a/NEWS b/NEWS
index 4890f0f..c4ab3ec 100644
--- a/NEWS
+++ b/NEWS
@@ -29,6 +29,7 @@ changes relative to sbcl-1.0.30:
        documented.
     ** DECLARATION-INFORMATION now supports declaration name DECLARATION as
        well.
+    ** AUGMENT-ENVIRONMENT has been implemented.
   * improvement: improved address space layout on OpenBSD (thanks to Josh
     Elsasser)
   * improvement: pretty-printing of various Lisp forms has been improved
diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp
index 3ab4eb7..1b92345 100644
--- a/contrib/sb-cltl2/env.lisp
+++ b/contrib/sb-cltl2/env.lisp
@@ -8,11 +8,116 @@
 (in-package :sb-cltl2)
 
 #| TODO:
-augment-environment
 define-declaration
 (map-environment)
 |#
 
+
+(defvar *null-lexenv* (make-null-lexenv))
+
+(defun augment-environment
+    (env &key variable symbol-macro function macro declare)
+  "Create a new lexical environment by augmenting ENV with new information.
+
+   VARIABLE
+     is a list of symbols to introduce as new variable bindings.
+
+   SYMBOL-MACRO
+     is a list symbol macro bindings of the form (name definition).
+
+   MACRO
+     is a list of macro definitions of the form (name definition), where
+     definition is a function of two arguments (a form and an environment).
+
+   FUNCTION
+     is a list of symbols to introduce as new local function bindings.
+
+   DECLARE
+     is a list of declaration specifiers. Declaration specifiers attach to the
+     new variable or function bindings as if they appeared in let, let*, flet
+     or labels form. For example:
+
+      (augment-environment env :variable '(x) :declare '((special x)))
+
+     is like
+
+      (let (x) (declare (special x)) ....)
+
+     but
+
+      (augment-environment (augment-environment env :variable '(x))
+                           :declare '((special x)))
+
+     is like
+
+       (let (x) (locally (declare (special x))) ...)
+"
+  (collect ((lvars)
+            (clambdas))
+    (unless (or variable symbol-macro function macro declare)
+      (return-from augment-environment env))
+
+    (if (null env)
+        (setq env (make-null-lexenv))
+        (setq env (copy-structure env)))
+
+    ;; a null policy is used to identify a null lexenv
+    (when (sb-c::null-lexenv-p env)
+      (setf (sb-c::lexenv-%policy env) sb-c::*policy*))
+
+    (when macro
+      (setf (sb-c::lexenv-funs env)
+            (nconc
+             (loop for (name def) in macro
+                collect (cons name (cons 'sb-sys::macro def)))
+             (sb-c::lexenv-funs env))))
+
+    (when symbol-macro
+      (setf (sb-c::lexenv-vars env)
+            (nconc
+             (loop for (name def) in symbol-macro
+                collect (cons name (cons 'sb-sys::macro def)))
+             (sb-c::lexenv-vars env))))
+
+    (dolist (name variable)
+      (lvars (sb-c::make-lambda-var :%source-name name)))
+
+    (dolist (name function)
+      (clambdas
+       (sb-c::make-lambda
+        :lexenv *null-lexenv*
+        :%source-name name
+        :allow-instrumenting nil)))
+
+    (when declare
+      ;; process-decls looks in *lexenv* policy to decide what warnings to print
+      (let ((*lexenv* *null-lexenv*))
+        (setq env (sb-c::process-decls
+                   (list `(declare ,@declare))
+                   (lvars) (clambdas) :lexenv env :context nil))))
+
+    (when function
+      (setf (sb-c::lexenv-funs env)
+            (nconc
+             (loop for name in function for lambda in (clambdas)
+                  collect (cons name lambda))
+             (sb-c::lexenv-funs env))))
+
+    (when variable
+      (setf (sb-c::lexenv-vars env)
+            (nconc
+             (loop for name in variable for lvar in (lvars)
+                collect
+                (cons name
+                      ;; if one of the lvars is declared special then process-decls
+                      ;; will set it's specvar.
+                      (if (sb-c::lambda-var-specvar lvar)
+                          (sb-c::lambda-var-specvar lvar)
+                          lvar)))
+             (sb-c::lexenv-vars env))))
+
+    env))
+
 (declaim (ftype (sfunction (symbol &optional (or null lexenv))
                            (values (member nil :function :macro :special-form)
                                    boolean
@@ -66,10 +171,7 @@ CARS of the alist include:
        (let ((env-type (or (lexenv-find fun type-restrictions)
                            *universal-fun-type*)))
          (setf binding :function
-               ftype (if (eq :declared (sb-c::leaf-where-from fun))
-                         (type-intersection (sb-c::leaf-type fun)
-                                            env-type)
-                         env-type)
+               ftype (type-intersection (sb-c::leaf-type fun) env-type)
                dx (sb-c::leaf-dynamic-extent fun))
          (etypecase fun
            (sb-c::functional
@@ -173,10 +275,7 @@ appear with CDR as T if the variable has been declared always bound."
       (sb-c::leaf
        (let ((env-type (or (lexenv-find var type-restrictions)
                            *universal-type*)))
-         (setf type (if (eq :declared (sb-c::leaf-where-from var))
-                        (type-intersection (sb-c::leaf-type var)
-                                           env-type)
-                        env-type)
+         (setf type (type-intersection (sb-c::leaf-type var) env-type)
                dx (sb-c::leaf-dynamic-extent var)))
        (etypecase var
          (sb-c::lambda-var
diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp
index 01b6974..d710d17 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 :sb-ext))
+  (:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
 
 (in-package :sb-cltl2-tests)
 
@@ -286,3 +286,140 @@
       (fun-info identity))
   (: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))
+
+
diff --git a/version.lisp-expr b/version.lisp-expr
index 8736d0d..33f74dd 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.30.27"
+"1.0.30.28"