1.0.9.51: SB-CLTL2: implement FUNCTION-INFORMATION, touch VARIABLE-INFORMATION

* Based on work done by Larry D'Anna.

* Rewire VARIABLE-INFORMATION in a similar manner. Add a FIXME
  note about lexically apparent special bindings, and document
  the current state of affairs. Improve the documentation string.

* Tests, and more tests for VARIABLE-INFORMATION as well.

diff --git a/NEWS b/NEWS
index 56b67a4..2b62557 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@ changes in sbcl-1.0.10 relative to sbcl-1.0.9:
     associates .lisp and .fasl files with the installed SBCL.
   * minor incompatible change: :UNIX is no longer present in *FEATURES*
     on Windows. (thanks to Luis Oliviera)
+  * new feature: SB-CLTL2 contrib module now implements
+    FUNCTION-INFORMATION. (thanks to Larry D'Anna)
   * optimization: scavenging weak pointers is now more efficient,
     requiring O(1) instead of O(N) per weak pointer to identify
     scanvenged vs. unscavenged pointers. (thanks to Paul Khuong)

diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp
index 905e9b6..9a0d2f4 100644 (file)
--- a/contrib/sb-cltl2/env.lisp
+++ b/contrib/sb-cltl2/env.lisp
@@ -1,56 +1,214 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; The software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
 (in-package :sb-cltl2)
 
 #| TODO:
-function-information
 declaration-information
 augment-environment
 define-declaration
 (map-environment)
 |#
 
+(declaim (ftype (sfunction (symbol &optional (or null lexenv))
+                           (values (member nil :function :macro :special-form)
+                                   boolean
+                                   list))
+                function-information))
+(defun function-information (name &optional env)
+  "Return information about the function NAME in the lexical environment ENV.
+Note that the global function binding may differ from the local one.
+
+This function returns three values. The first indicates the type of
+function definition or binding:
+
+  NIL
+    There is no apparent definition for NAME.
+
+  :FUNCTION
+    NAME refers to a function.
+
+  :MACRO
+    NAME refers to a macro.
+
+  :SPECIAL-FORM
+    NAME refers to a special operator. If the name refers to both a
+    macro and a special operator, the macro takes precedence.
+
+The second value is true if NAME is bound locally.
+
+The third value is an alist describing the declarations that apply to
+the function NAME. Standard declaration specifiers that may appear in
+CARS of the alist include:
+
+  DYNAMIC-EXTENT
+    If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
+    is NIL, the alist element may be omitted.
+
+  INLINE
+    The CDR is one of the symbols INLINE, NOTINLINE, or NIL, to
+    indicate if the function has been declared INLINE or NOTINLINE. If
+    the CDR is NIL the alist element may be omitted.
+
+  FTYPE
+    The CDR is the type specifier associated with NAME, or the symbol
+    FUNCTION if there is functional type declaration or proclamation
+    associated with NAME. If the CDR is FUNCTION the alist element may
+    be omitted."
+  (let* ((*lexenv* (or env (make-null-lexenv)))
+         (fun (lexenv-find name funs))
+         binding localp ftype dx inlinep)
+    (etypecase fun
+      (sb-c::leaf
+       (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)
+               dx (sb-c::leaf-dynamic-extent fun))
+         (etypecase fun
+           (sb-c::functional
+            (setf localp t
+                  inlinep (sb-c::functional-inlinep fun)))
+           (sb-c::defined-fun
+            ;; Inlined known functions.
+            (setf localp nil
+                  inlinep (sb-c::defined-fun-inlinep fun))))))
+      (cons
+       (setf binding :macro
+             localp t))
+      (null
+       (case (info :function :kind name)
+         (:macro
+          (setf binding :macro
+                localp nil))
+         (:special-form
+          (setf binding :special-form
+                localp nil))
+         (:function
+          (setf binding :function
+                localp nil
+                ftype (when (eq :declared (info :function :where-from name))
+                        (info :function :type name))
+                inlinep (info :function :inlinep name))))))
+    (values binding
+            localp
+            (let (alist)
+              (when (and ftype (neq *universal-fun-type* ftype))
+                (push (cons 'ftype (type-specifier ftype)) alist))
+              (ecase inlinep
+                ((:inline :maybe-inline) (push (cons 'inline 'inline) alist))
+                (:notinline (push (cons 'inline 'notinline) alist))
+                ((nil)))
+              (when dx (push (cons 'dynamic-extent t) alist))
+              alist))))
+
 (declaim (ftype (sfunction
                  (symbol &optional (or null lexenv))
                  (values (member nil :special :lexical :symbol-macro :constant)
                          boolean
                          list))
                 variable-information))
-(defun variable-information (var &optional env)
-  "Return three values. The first indicates a binding kind of VAR; the
-second is True if there is a local binding of VAR; the third is an
-alist of declarations that apply to the apparent binding of VAR."
+(defun variable-information (name &optional env)
+  "Return information about the variable name VAR in the lexical environment ENV.
+Note that the global binding may differ from the local one.
+
+This function returns three values. The first indicated the type of the variable
+binding:
+
+  NIL
+    There is no apparent binding for NAME.
+
+  :SPECIAL
+    NAME refers to a special variable.
+
+  :LEXICAL
+    NAME refers to a lexical variable.
+
+  :SYMBOL-MACRO
+    NAME refers to a symbol macro.
+
+  :CONSTANT
+    NAME refers to a named constant defined using DEFCONSTANT, or NAME
+    is a keyword.
+
+The second value is true if NAME is bound locally. This is currently
+always NIL for special variables, although arguably it should be T
+when there is a lexically apparent binding for the special variable.
+
+The third value is an alist describind the declarations that apply to
+the function NAME. Standard declaration specifiers that may appear in
+CARS of the alist include:
+
+  DYNAMIC-EXTENT
+    If the CDR is T, NAME has been declared DYNAMIC-EXTENT. If the CDR
+    is NIL, the alist element may be omitted.
+
+  IGNORE
+    If the CDR is T, NAME has been declared IGNORE. If the CDR is NIL,
+    the alist element may be omitted.
+
+  TYPE
+    The CDR is the type specifier associated with NAME, or the symbol
+    T if there is explicit type declaration or proclamation associated
+    with NAME. The type specifier may be equivalent to or a supertype
+    of the original declaration. If the CDR is T the alist element may
+    be omitted."
   (let* ((*lexenv* (or env (make-null-lexenv)))
-         (info (lexenv-find var vars)))
-    (etypecase info
-      (sb-c::leaf (let ((type (type-specifier
-                               (type-intersection
-                                (sb-c::leaf-type info)
-                                (or (lexenv-find info type-restrictions)
-                                    *universal-type*)))))
-                    (etypecase info
-                      (sb-c::lambda-var
-                       (values :lexical t
-                               `((ignore . ,(sb-c::lambda-var-ignorep info))
-                                 (type . ,type))))
-                      (sb-c::global-var
-                       (values :special t
-                               `((type . ,type)) ; XXX ignore
-                               ))
-                      (sb-c::constant
-                       (values :constant nil
-                               `((type . ,type)) ; XXX ignore
-                               )))))
-      (cons (values :symbol-macro t
-                    nil                 ; FIXME: also in the compiler
-                    ))
-      (null (values (ecase (info :variable :kind var)
-                      (:special :special)
-                      (:constant :constant)
-                      (:macro :symbol-macro)
-                      (:global nil))
-                    nil
-                    `(                  ; XXX ignore
-                      (type . ,(type-specifier ; XXX local type
-                                (info :variable :type var)))))))))
+         (var (lexenv-find name vars))
+         binding localp dx ignorep type)
+    (etypecase var
+      (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)
+               dx (sb-c::leaf-dynamic-extent var)))
+       (etypecase var
+         (sb-c::lambda-var
+          (setf binding :lexical
+                localp t
+                ignorep (sb-c::lambda-var-ignorep var)))
+         ;; FIXME: IGNORE doesn't make sense for specials or constants
+         ;; -- though it is _possible_ to declare them ignored, but
+         ;; we don't keep the information around.
+         (sb-c::global-var
+          (setf binding :special
+                ;; FIXME: Lexically apparent binding or not?
+                localp nil))
+         (sb-c::constant
+          (setf binding :constant
+                localp nil))))
+      (cons
+       (setf binding :symbol-macro
+             localp t))
+       (null
+        (let ((global-type (info :variable :type name))
+              (kind (info :variable :kind name)))
+          (setf binding (case kind
+                          (:macro :symbol-macro)
+                          (:global nil)
+                          (t kind))
+                type (if (eq *universal-type* global-type)
+                         nil
+                         global-type)
+                localp nil))))
+    (values binding
+            localp
+            (let (alist)
+              (when ignorep (push (cons 'ignore t) alist))
+              (when (and type (neq *universal-type* type))
+                (push (cons 'type (type-specifier type)) alist))
+              (when dx (push (cons 'dynamic-extent t) alist))
+              alist))))
 
 (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
                 declaration-information))

diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp
index ec09e72..ac775c9 100644 (file)
--- a/contrib/sb-cltl2/tests.lisp
+++ b/contrib/sb-cltl2/tests.lisp
@@ -1,5 +1,13 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; The software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
 (defpackage :sb-cltl2-tests
   (:use :sb-cltl2 :cl :sb-rt))
+
 (in-package :sb-cltl2-tests)
 
 (rem-all-tests)
@@ -98,3 +106,145 @@
           (and (subtypep dinfo '(and warning (not style-warning)))
                (subtypep '(and warning (not style-warning)) dinfo)))))))
   t)
+
+;;;; VARIABLE-INFORMATION
+
+(defvar *foo*)
+
+(defmacro var-info (var &environment env)
+  (list 'quote (multiple-value-list (variable-information var env))))
+
+(deftest variable-info.global-special/unbound
+    (var-info *foo*)
+  (:special nil nil))
+
+(deftest variable-info.global-special/unbound/extra-decl
+    (locally (declare (special *foo*))
+      (var-info *foo*))
+  (:special nil nil))
+
+(deftest variable-info.global-special/bound
+    (let ((*foo* t))
+      (var-info *foo*))
+  (:special nil nil))
+
+(deftest variable-info.global-special/bound/extra-decl
+    (let ((*foo* t))
+      (declare (special *foo*))
+      (var-info *foo*))
+  (:special nil nil))
+
+(deftest variable-info.local-special/unbound
+    (locally (declare (special x))
+      (var-info x))
+  (:special nil nil))
+
+(deftest variable-info.local-special/bound
+    (let ((x 13))
+      (declare (special x))
+      (var-info x))
+  (:special nil nil))
+
+(deftest variable-info.local-special/shadowed
+    (let ((x 3))
+      (declare (special x))
+      x
+      (let ((x 3))
+        x
+        (var-info x)))
+  (:lexical t nil))
+
+(deftest variable-info.local-special/shadows-lexical
+    (let ((x 3))
+      (let ((x 3))
+        (declare (special x))
+        (var-info x)))
+  (:special nil nil))
+
+(deftest variable-info.lexical
+    (let ((x 8))
+      (var-info x))
+  (:lexical t nil))
+
+(deftest variable-info.ignore
+    (let ((x 8))
+      (declare (ignore x))
+      (var-info x))
+  (:lexical t ((ignore . t))))
+
+(deftest variable-info.symbol-macro/local
+    (symbol-macrolet ((x 8))
+      (var-info x))
+  (:symbol-macro t nil))
+
+(define-symbol-macro my-symbol-macro t)
+
+(deftest variable-info.symbol-macro/global
+    (var-info my-symbol-macro)
+  (:symbol-macro nil nil))
+
+(deftest variable-info.undefined
+    (var-info #:undefined)
+  (nil nil nil))
+
+;;;; FUNCTION-INFORMATION
+
+(defmacro fun-info (var &environment env)
+  (list 'quote (multiple-value-list (function-information var env))))
+
+(defun my-global-fun (x) x)
+
+(deftest function-info.global/no-ftype
+    (fun-info my-global-fun)
+  (:function nil nil))
+
+(declaim (ftype (function (cons) (values t &optional)) my-global-fun-2))
+
+(defun my-global-fun-2 (x) x)
+
+(deftest function-info.global/ftype
+    (fun-info my-global-fun-2)
+  (:function nil ((ftype function (cons) (values t &optional)))))
+
+(defmacro my-macro (x) x)
+
+(deftest function-info.macro
+    (fun-info my-macro)
+  (:macro nil nil))
+
+(deftest function-info.macrolet
+    (macrolet ((thingy () nil))
+      (fun-info thingy))
+  (:macro t nil))
+
+(deftest function-info.special-form
+    (fun-info progn)
+  (:special-form  nil nil))
+
+(deftest function-info.notinline/local
+    (flet ((x (y) y))
+      (declare (notinline x))
+      (x 1)
+      (fun-info x))
+  (:function t ((inline . notinline))))
+
+(declaim (notinline my-notinline))
+(defun my-notinline (x) x)
+
+(deftest function-info.notinline/global
+    (fun-info my-notinline)
+  (:function nil ((inline . notinline))))
+
+(declaim (inline my-inline))
+(defun my-inline (x) x)
+
+(deftest function-info.inline/global
+    (fun-info my-inline)
+  (:function nil ((inline . inline))))
+
+(deftest function-information.known-inline
+    (locally (declare (inline identity))
+      (fun-info identity))
+  (:function nil ((inline . inline)
+                  (ftype function (t) (values t &optional)))))
+

diff --git a/version.lisp-expr b/version.lisp-expr
index ae6a471..09f7b3a 100644 (file)
--- 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.9.50"
+"1.0.9.51"