From 6256e8428635bbbca648ed3ff59e810bd1d792ad Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 10 Sep 2007 12:14:42 +0000 Subject: [PATCH] 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. --- NEWS | 2 + contrib/sb-cltl2/env.lisp | 232 +++++++++++++++++++++++++++++++++++++------- contrib/sb-cltl2/tests.lisp | 150 ++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 348 insertions(+), 38 deletions(-) diff --git a/NEWS b/NEWS index 56b67a493..2b6255742 100644 --- 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 905e9b6f3..9a0d2f405 100644 --- 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 ec09e7295..ac775c9c0 100644 --- 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 ae6a4713b..09f7b3a8d 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.9.50" +"1.0.9.51" -- 2.11.4.GIT