X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-cltl2%2Fenv.lisp;h=8c35440da8af8c2542c20781a7156c01d441e51b;hb=9af8ab0a80bbd4d579ed4a12d2a2819a7490901a;hp=905e9b6f33a910956a5020d6b7db6d99739e85f6;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 905e9b6..8c35440 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -1,60 +1,235 @@ +;;;; 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) + (values (member nil :special :lexical :symbol-macro :constant :global) 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. + + :GLOBAL + NAME refers to a global variable. (SBCL specific extension.) + +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. + +Additionally, the SBCL specific SB-EXT:ALWAYS-BOUND declaration will +appear with CDR as T if the variable has been declared always bound." (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))))))))) + (kind (info :variable :kind name)) + (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 (if (eq :global kind) + :global + :special) + ;; FIXME: Lexically apparent binding or not for specials? + 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))) + (setf binding (case kind + (:macro :symbol-macro) + (:unknown 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)) + (when (info :variable :always-bound name) + (push (cons 'sb-ext:always-bound t) alist)) + alist)))) (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t) declaration-information)) (defun declaration-information (declaration-name &optional env) + "Return information about declarations named by DECLARATION-NAME. + +If DECLARATION-NAME is optimize return a list who's entries are of the +form (quality value). + +If DECLARATION-NAME is SB-EXT:MUFFLE-CONDITIONS return a type specifier for +the condition types that have been muffled." (let ((env (or env (make-null-lexenv)))) (case declaration-name (optimize @@ -71,6 +246,11 @@ alist of declarations that apply to the apparent binding of VAR." (t (error "Unsupported declaration ~S." declaration-name))))) (defun parse-macro (name lambda-list body &optional env) + "Process a macro definition of the kind that might appear in a DEFMACRO form +into a lambda expression of two variables: a form and an environment. The +lambda edxpression will parse its form argument, binding the variables in +LAMBDA-LIST appropriately, and then excute BODY with those bindings in +effect." (declare (ignore env)) (with-unique-names (whole environment) (multiple-value-bind (body decls) @@ -81,8 +261,13 @@ alist of declarations that apply to the apparent binding of VAR." ,@decls ,body)))) -(defun enclose (lambda-expression &optional env) - (let ((env (if env - (sb-c::make-restricted-lexenv env) +(defun enclose (lambda-expression &optional environment) + "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the +lambda expression is allowed to reference the declarations and macro +definitions in ENVIRONMENT, but consequences are undefined if lexical +variables, functions, tags or any other run-time entity defined in ENVIRONMENT +is referred to by the expression." + (let ((env (if environment + (sb-c::make-restricted-lexenv environment) (make-null-lexenv)))) (compile-in-lexenv nil lambda-expression env)))