From: Larry D'A. <la...@el...> - 2009-06-26 09:20:46
|
A while ago I implemented some improvements to sb-cltl2, but they never got merged. I've split cleaned up the changes, and split them into the following patch series. [PATCH 1/5] add docstrings to some functions in sb-cltl2 [PATCH 2/5] implement sb-cltl2:augment-environment [PATCH 3/5] sb-cltl2: add support for (declaration-information 'declaration) [PATCH 4/5] sb-cltl2: implemnt define-declaration [PATCH 5/5] make sb-cltl2:variable-information treat alien variables like globals I'd really love to get these changes merged, so if there's anything you don't like about them just tell me and I'll try and fix it. Thanks! --larry |
From: Larry D'A. <la...@el...> - 2009-06-26 09:20:38
|
(declaration-information 'declaration) returns a list of declaration names that have been proclaimed as valid. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 12 +++++++++++- contrib/sb-cltl2/tests.lisp | 7 +++++++ 2 files changed, 18 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 652a72f..469d567 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -8,7 +8,6 @@ (in-package :sb-cltl2) #| TODO: -declaration-information augment-environment define-declaration (map-environment) @@ -228,6 +227,9 @@ appear with CDR as T if the variable has been declared always bound." If DECLARATION-NAME is optimize return a list who's entries are of the form (quality value). + If DECLARATION-NAME is declaration returns a list of declaration names + that have been proclaimed as valid. + If DECLARATION-NAME is sb-ext:muffle-conditions return a type specifier for the condition types that have been muffled. @@ -245,6 +247,14 @@ appear with CDR as T if the variable has been declared always bound." (sb-ext:muffle-conditions (car (rassoc 'muffle-warning (sb-c::lexenv-handled-conditions env)))) + (declaration + (let ((type (sb-c::type-info-number (sb-c::type-info-or-lose :declaration :recognized))) + (ret nil)) + (dolist (env *info-environment*) + (do-info (env :name name :type-number num :value value) + (when (and (= num type) value) + (push name ret)))) + ret)) (t (error "Unsupported declaration ~S." declaration-name))))) (defun parse-macro (name lambda-list body &optional env) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index ec5e8c9..87e133e 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -109,6 +109,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*) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 09:20:43
|
define-declaration lets the user define handlers for their own declarations types. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 92 +++++++++++++++++++++++++++++++++++++++++-- contrib/sb-cltl2/tests.lisp | 76 +++++++++++++++++++++++++++++++++++ src/code/full-eval.lisp | 6 ++- src/compiler/globaldb.lisp | 4 ++ src/compiler/ir1tran.lisp | 5 ++- src/compiler/ir1util.lisp | 12 ++++-- src/compiler/lexenv.lisp | 8 +++- 7 files changed, 190 insertions(+), 13 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 0935e91..c0badea 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -8,7 +8,6 @@ (in-package :sb-cltl2) #| TODO: -define-declaration (map-environment) |# @@ -76,6 +75,31 @@ define-declaration env) *captured-environment*)))) +(defun extra-pairs (keyword var env) + "Retrieve the user-supplied (from define-declaration) pairs for a + function or a variable from a lexical environment. + + KEYWORD should be :function or :variable, VAR should be a + function or variable name, respectively. " + (when env + (let ((ret nil)) + (dolist (entry (sb-c::lexenv-user-data env)) + (when (and (eq keyword (car entry)) + (eq var (cadr entry))) + (push (cddr entry) ret))) + (nreverse ret)))) + +(defun extra-decl-info (name env) + "Retrieve the user-supplied (from define-declaration) value for + the declaration with the given NAME" + (when env + (dolist (entry (sb-c::lexenv-user-data env)) + (when (and (eq :declare (car entry)) + (eq name (cadr entry))) + (return-from extra-decl-info (cddr entry)))) + nil)) + + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) (values (member nil :function :macro :special-form) boolean @@ -169,7 +193,9 @@ CARS of the alist include: (:notinline (push (cons 'inline 'notinline) alist)) ((nil))) (when dx (push (cons 'dynamic-extent t) alist)) - alist)))) + (append alist (extra-pairs :function name *lexenv*)))))) + + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) @@ -177,6 +203,7 @@ CARS of the alist include: boolean list)) variable-information)) + (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. @@ -280,7 +307,7 @@ appear with CDR as T if the variable has been declared always bound." (when dx (push (cons 'dynamic-extent t) alist)) (when (info :variable :always-bound name) (push (cons 'sb-ext:always-bound t) alist)) - alist)))) + (append alist (extra-pairs :variable name *lexenv*)))))) (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t) declaration-information)) @@ -296,6 +323,9 @@ appear with CDR as T if the variable has been declared always bound." If DECLARATION-NAME is sb-ext:muffle-conditions return a type specifier for the condition types that have been muffled. + If DECLARATION-NAME is a name that has defined via DEFINE-DECLARATION return + a user defined value. + " (let ((env (or env (make-null-lexenv)))) (case declaration-name @@ -318,7 +348,10 @@ appear with CDR as T if the variable has been declared always bound." (when (and (= num type) value) (push name ret)))) ret)) - (t (error "Unsupported declaration ~S." declaration-name))))) + (t (if (info :declaration :handler declaration-name) + (extra-decl-info declaration-name env) + (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 @@ -345,3 +378,54 @@ appear with CDR as T if the variable has been declared always bound." (sb-c::make-restricted-lexenv env) (make-null-lexenv)))) (compile-in-lexenv nil lambda-expression env))) + +(defun update-lexenv-user-data (env kind data) + "Add a bit of user-data to a lexenv. + + If KIND is :declare then DATA should be of the form + (declaration-name . value) + + If KIND is :variable then DATA should be of the form + (variable-name key value) + + If KIND is :function then DATA shoudl be of the form + (function-name key value) " + (let ((user-data (sb-c::lexenv-user-data env))) + ;; user-data looks like this: + ;; ((:declare d . value) + ;; (:variable var key . value) + ;; (:function var key . value)) + (ecase kind + ((:function :variable) + (loop for (var key value) in data + do (push (list* kind var key value) user-data))) + (:declare + (destructuring-bind (decl-name . value) data + (push (list* :declare decl-name value) user-data)))) + (sb-c::make-lexenv :default env :user-data user-data))) + +(defmacro define-declaration (decl-name lambda-list &body body) + "Define a handler for declaration specifiers who's car is DECL-NAME. + + The function defined by this macro is called with two arguments: + a declaration specifier and a environment. It must return two + values. The first value must be :variable, :function, or :declare + + If the first value is :variable or :function then the second value + should be a list of elements of the form (BINDING-NAME KEY VALUE). + conses (KEY . VALUE) will be added to the alist returned by + (function-information BINDING-NAME env) or + (variable-information BINDING-NAME env). + + If the first value is :declare then the second value should be a + cons (DECL-NAME . VALUE). VALUE will be returned by + (declaration-information 'DECL-NAME env). " + `(eval-when (:compile-toplevel :load-toplevel :execute) + (proclaim '(declaration ,decl-name)) + (flet ((func ,lambda-list + ,@body)) + (setf + (info :declaration :handler ',decl-name) + (lambda (lexenv spec) + (multiple-value-bind (kind data) (func spec lexenv) + (update-lexenv-user-data lexenv kind data))))))) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index 8a3a866..627ddb6 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -463,3 +463,79 @@ ((= 1 1) 'bar)) (augment-environment nil :macro (list (list 'newcond (macro-function 'cond)))))) bar) + + + +;;;;; 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.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.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)) diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index 00e4e33..5079abc 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -104,7 +104,8 @@ nil nil nil nil nil (sb!c::lexenv-handled-conditions old-lexenv) (sb!c::lexenv-disabled-package-locks old-lexenv) - (sb!c::lexenv-policy old-lexenv)))) + (sb!c::lexenv-policy old-lexenv) + (sb!c::lexenv-user-data old-lexenv)))) (dolist (declaration declarations) (unless (consp declaration) (ip-error "malformed declaration specifier ~S in ~S" @@ -175,7 +176,8 @@ (sb!c::internal-make-lexenv nil nil nil nil nil nil nil nil nil - sb!c::*policy*))) + sb!c::*policy* + nil))) ;;; Augment ENV with a special or lexical variable binding (declaim (inline push-var)) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index d20e894..394e020 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1200,6 +1200,10 @@ (when (info :type :kind name) (error 'declaration-type-conflict-error :format-arguments (list name))))) +(define-info-type + :class :declaration + :type :handler + :type-spec (or function null)) (define-info-class :alien-type) (define-info-type diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ac16a1d..9db8370 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1461,7 +1461,10 @@ (t (unless (info :declaration :recognized (first spec)) (compiler-warn "unrecognized declaration ~S" raw-spec)) - res)) + (let ((fn (info :declaration :handler (first spec)))) + (if fn + (funcall fn res spec) + res)))) result-type))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 046c7bf..31fdb6b 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -765,7 +765,8 @@ (handled-conditions (lexenv-handled-conditions default)) (disabled-package-locks (lexenv-disabled-package-locks default)) - (policy (lexenv-policy default))) + (policy (lexenv-policy default)) + (user-data (lexenv-user-data default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) (if ,var @@ -777,8 +778,10 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup handled-conditions - disabled-package-locks policy))) + lambda + cleanup handled-conditions disabled-package-locks + policy + user-data))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -812,7 +815,8 @@ nil (lexenv-handled-conditions lexenv) (lexenv-disabled-package-locks lexenv) - (lexenv-policy lexenv)))) + (lexenv-policy lexenv) + (lexenv-user-data lexenv)))) ;;;; flow/DFO/component hackery diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 54ef200..7e3e34e 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -21,7 +21,7 @@ (funs vars blocks tags type-restrictions lambda cleanup handled-conditions - disabled-package-locks %policy))) + disabled-package-locks %policy user-data))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an ;; INLINE/NOTINLINE declaration, or a list (MACRO . <function>) (a @@ -64,7 +64,11 @@ ;; and the global policy is stored in *POLICY*. (Because we want to ;; be able to affect it from :WITH-COMPILATION-UNIT.) NIL here also ;; works as a convenient null-lexenv identifier. - (%policy nil :type policy)) + (%policy nil :type policy) + ;; A list associating extra user info to symbols. The entries + ;; are of the form (:declare name . value), + ;; (:variable name key . value), or (:function name key . value) + (user-data nil :type list)) (defun lexenv-policy (lexenv) (or (lexenv-%policy lexenv) *policy*)) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 09:20:46
|
This patch implements sb-cltl2:augment-environment, a function that the user can call from a macro to add information to a lexical environment. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 65 ++++++++++++++++- contrib/sb-cltl2/tests.lisp | 177 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 241 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index dd9efd5..829b9ed 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -9,11 +9,74 @@ #| TODO: declaration-information -augment-environment define-declaration (map-environment) |# + +(declaim (ftype (function (&rest t) t) mystery)) +(defun mystery (&rest r) + (declare (ignore r))) + +(defvar *captured-environment* nil) +(defmacro capture-environment (&environment env) + (setq *captured-environment* env) + nil) + +(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))) ...) " + (when (null env) + (setq env (make-null-lexenv))) + (when (or macro symbol-macro) + (setq env (copy-structure env))) + (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)))) + (if (not (or variable function declare)) + env + (handler-bind (((or style-warning + sb-ext:compiler-note) + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'muffle-warning)))) + (let (*captured-environment*) + (compile-in-lexenv + nil + `(lambda () + (labels ,(loop for fn in function collect `(,fn ())) + (declare ,@(loop for d in declare + if (member (car d) '(ftype inline notinline)) + collect d)) + (let ,(loop for v in variable collect `(,v (mystery))) + (declare ,@declare) + (capture-environment)))) + env) + *captured-environment*)))) + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) (values (member nil :function :macro :special-form) boolean diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index ec5e8c9..703c1f4 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -279,3 +279,180 @@ (fun-info identity)) (:function nil ((inline . inline) (ftype function (t) (values t &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*)))) + :special) + +(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.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 sfunction (integer) integer))) + + +(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) +(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*)))) + :special) + +(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.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 sfunction (integer) integer))) + + +(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) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 09:20:46
|
Adds docstrings for declaration-information, parse-macro and enclose. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 18 ++++++++++++++++++ 1 files changed, 18 insertions(+), 0 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index dd9efd5..652a72f 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -223,6 +223,15 @@ appear with CDR as T if the variable has been declared always bound." (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 @@ -239,6 +248,10 @@ appear with CDR as T if the variable has been declared always bound." (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 expression will parse-and-bind + the form as per the lambda-list and then call body." (declare (ignore env)) (with-unique-names (whole environment) (multiple-value-bind (body decls) @@ -250,6 +263,11 @@ appear with CDR as T if the variable has been declared always bound." ,body)))) (defun enclose (lambda-expression &optional env) + "Evaluate a lambda expression in a lexical environment and return + a function. The lambda expression is only allowed to reference + the declarations and macro definitions of ENV. It is not allowed + to reference lexical variables, functions, tags or any other run-time + entity defined in ENV" (let ((env (if env (sb-c::make-restricted-lexenv env) (make-null-lexenv)))) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 09:21:08
|
variable-information will return :global for variables defined with sb-alien:define-alien-variable. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 1 + contrib/sb-cltl2/tests.lisp | 5 +++++ 2 files changed, 6 insertions(+), 0 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index c0badea..9b82937 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -291,6 +291,7 @@ appear with CDR as T if the variable has been declared always bound." (null (let ((global-type (info :variable :type name))) (setf binding (case kind + (:alien :global) (:macro :symbol-macro) (:unknown nil) (t kind)) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index 627ddb6..3a404f4 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -226,6 +226,11 @@ (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) + (:global nil nil)) + ;;;; FUNCTION-INFORMATION (defmacro fun-info (var &environment env) -- 1.6.0.4 |
From: Nikodemus S. <nik...@ra...> - 2009-06-26 16:05:28
|
2009/6/26 Larry D'Anna <la...@el...>: > A while ago I implemented some improvements to sb-cltl2, but they never got > merged. I've split cleaned up the changes, and split them into the following > patch series. > > [PATCH 1/5] add docstrings to some functions in sb-cltl2 > [PATCH 2/5] implement sb-cltl2:augment-environment > [PATCH 3/5] sb-cltl2: add support for (declaration-information 'declaration) > [PATCH 4/5] sb-cltl2: implemnt define-declaration > [PATCH 5/5] make sb-cltl2:variable-information treat alien variables like globals > > I'd really love to get these changes merged, so if there's anything you don't > like about them just tell me and I'll try and fix it. Thanks! Thank you! I haven't looked at these in any depth yet, but quick impressions: * We generally prefer no docsstrings for non-exported functions. These would be better as comments. * AUGMENT-ENVIRONMENT looks dodgy. I need to read CLTL2 again to see what it does, but since the environment is stale by the time it is returned I don't think this is the way to do it. I'm not really sure what :VARIABLE or :FUNCTION is supposed to do there in the first place. Others seem sane in principle. * DEFINE-DECLARATION and DECLARATION-INFORMATION look good in principle -- haven't looked at the details. * VARIABLE-INFORMATION... I don't think so. Since you can't access the alien value with SYMBOL-VALUE calling it :GLOBAL is lying. Either is should be :ALIEN, or we should re-implement alien variables as symbol-macros. Cheers, -- Nikodemus |
From: Larry D'A. <la...@el...> - 2009-06-26 20:03:21
|
* Nikodemus Siivola (nik...@ra...) [090626 12:05]: > * We generally prefer no docsstrings for non-exported functions. These > would be better as comments. OK fixed. > * AUGMENT-ENVIRONMENT looks dodgy. I need to read CLTL2 again to see > what it does, but since the environment is stale by the time it is > returned I don't think this is the way to do it. I'm not really sure > what :VARIABLE or :FUNCTION is supposed to do there in the first > place. Others seem sane in principle. It's my understanding that AUGMENT-ENVIRONMENT is pertty much strictly for use with macroexpansion. The only thing you should be allowed to do with an augmented environment is pass it to VARIABLE-INFORMATION, FUNCTION-INFORMATION, DECLARATION-INFORMATION or MACROEXPAND. The point of :VARIABLE and :FUNCTION is only that you might use the environment to expand a macro that calls VARIABLE-INFORMATION or FUNCTION-INFORMATION and you want to controll what it sees. I think you're right about it being dodgy to call a whole compile and then use a stale lexenv. I've changed the implementation so it only does source-to-ir1, (by calling make-functional-from-toplevel-lambda) and aborts as soon as it's got zthe lexenv it needs. > * DEFINE-DECLARATION and DECLARATION-INFORMATION look good in > principle -- haven't looked at the details. > > * VARIABLE-INFORMATION... I don't think so. Since you can't access the > alien value with SYMBOL-VALUE calling it :GLOBAL is lying. Either is > should be :ALIEN, or we should re-implement alien variables as > symbol-macros. OK I've fixed this so it returns :ALIEN. I'll post the revised patchset as replies to this message. --larry |
From: Larry D'A. <la...@el...> - 2009-06-26 20:09:45
|
define-declaration lets the user define handlers for their own declarations types. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 90 +++++++++++++++++++++++++++++++++++++++++-- contrib/sb-cltl2/tests.lisp | 76 ++++++++++++++++++++++++++++++++++++ src/code/full-eval.lisp | 6 ++- src/compiler/globaldb.lisp | 4 ++ src/compiler/ir1tran.lisp | 5 ++- src/compiler/ir1util.lisp | 12 ++++-- src/compiler/lexenv.lisp | 8 +++- 7 files changed, 188 insertions(+), 13 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index ea71801..d1305d2 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -8,7 +8,6 @@ (in-package :sb-cltl2) #| TODO: -define-declaration (map-environment) |# @@ -70,6 +69,31 @@ define-declaration :name nil :path '(original-source-start 0 0))))))) +(defun extra-pairs (keyword var env) + ;; Retrieve the user-supplied (from define-declaration) pairs for a + ;; function or a variable from a lexical environment. + ;; + ;; KEYWORD should be :function or :variable, VAR should be a + ;; function or variable name, respectively. + (when env + (let ((ret nil)) + (dolist (entry (sb-c::lexenv-user-data env)) + (when (and (eq keyword (car entry)) + (eq var (cadr entry))) + (push (cddr entry) ret))) + (nreverse ret)))) + +(defun extra-decl-info (name env) + ;; Retrieve the user-supplied (from define-declaration) value for + ;; the declaration with the given NAME + (when env + (dolist (entry (sb-c::lexenv-user-data env)) + (when (and (eq :declare (car entry)) + (eq name (cadr entry))) + (return-from extra-decl-info (cddr entry)))) + nil)) + + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) (values (member nil :function :macro :special-form) boolean @@ -163,7 +187,9 @@ CARS of the alist include: (:notinline (push (cons 'inline 'notinline) alist)) ((nil))) (when dx (push (cons 'dynamic-extent t) alist)) - alist)))) + (append alist (extra-pairs :function name *lexenv*)))))) + + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) @@ -171,6 +197,7 @@ CARS of the alist include: boolean list)) variable-information)) + (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. @@ -274,7 +301,7 @@ appear with CDR as T if the variable has been declared always bound." (when dx (push (cons 'dynamic-extent t) alist)) (when (info :variable :always-bound name) (push (cons 'sb-ext:always-bound t) alist)) - alist)))) + (append alist (extra-pairs :variable name *lexenv*)))))) (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t) declaration-information)) @@ -290,6 +317,9 @@ appear with CDR as T if the variable has been declared always bound." If DECLARATION-NAME is sb-ext:muffle-conditions return a type specifier for the condition types that have been muffled. + If DECLARATION-NAME is a name that has defined via DEFINE-DECLARATION return + a user defined value. + " (let ((env (or env (make-null-lexenv)))) (case declaration-name @@ -312,7 +342,10 @@ appear with CDR as T if the variable has been declared always bound." (when (and (= num type) value) (push name ret)))) ret)) - (t (error "Unsupported declaration ~S." declaration-name))))) + (t (if (info :declaration :handler declaration-name) + (extra-decl-info declaration-name env) + (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 @@ -339,3 +372,52 @@ appear with CDR as T if the variable has been declared always bound." (sb-c::make-restricted-lexenv env) (make-null-lexenv)))) (compile-in-lexenv nil lambda-expression env))) + +(defun update-lexenv-user-data (env kind data) + ;; Add a bit of user-data to a lexenv. + ;; + ;; If KIND is :declare then DATA should be of the form + ;; (declaration-name . value) + ;; If KIND is :variable then DATA should be of the form + ;; (variable-name key value) + ;; If KIND is :function then DATA shoudl be of the form + ;; (function-name key value) + (let ((user-data (sb-c::lexenv-user-data env))) + ;; user-data looks like this: + ;; ((:declare d . value) + ;; (:variable var key . value) + ;; (:function var key . value)) + (ecase kind + ((:function :variable) + (loop for (var key value) in data + do (push (list* kind var key value) user-data))) + (:declare + (destructuring-bind (decl-name . value) data + (push (list* :declare decl-name value) user-data)))) + (sb-c::make-lexenv :default env :user-data user-data))) + +(defmacro define-declaration (decl-name lambda-list &body body) + "Define a handler for declaration specifiers who's car is DECL-NAME. + + The function defined by this macro is called with two arguments: + a declaration specifier and a environment. It must return two + values. The first value must be :variable, :function, or :declare + + If the first value is :variable or :function then the second value + should be a list of elements of the form (BINDING-NAME KEY VALUE). + conses (KEY . VALUE) will be added to the alist returned by + (function-information BINDING-NAME env) or + (variable-information BINDING-NAME env). + + If the first value is :declare then the second value should be a + cons (DECL-NAME . VALUE). VALUE will be returned by + (declaration-information 'DECL-NAME env). " + `(eval-when (:compile-toplevel :load-toplevel :execute) + (proclaim '(declaration ,decl-name)) + (flet ((func ,lambda-list + ,@body)) + (setf + (info :declaration :handler ',decl-name) + (lambda (lexenv spec) + (multiple-value-bind (kind data) (func spec lexenv) + (update-lexenv-user-data lexenv kind data))))))) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index d3f49ea..6266644 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -492,3 +492,79 @@ ((= 1 1) 'bar)) (augment-environment nil :macro (list (list 'newcond (macro-function 'cond)))))) bar) + + + +;;;;; 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.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.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)) diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index 00e4e33..5079abc 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -104,7 +104,8 @@ nil nil nil nil nil (sb!c::lexenv-handled-conditions old-lexenv) (sb!c::lexenv-disabled-package-locks old-lexenv) - (sb!c::lexenv-policy old-lexenv)))) + (sb!c::lexenv-policy old-lexenv) + (sb!c::lexenv-user-data old-lexenv)))) (dolist (declaration declarations) (unless (consp declaration) (ip-error "malformed declaration specifier ~S in ~S" @@ -175,7 +176,8 @@ (sb!c::internal-make-lexenv nil nil nil nil nil nil nil nil nil - sb!c::*policy*))) + sb!c::*policy* + nil))) ;;; Augment ENV with a special or lexical variable binding (declaim (inline push-var)) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index d20e894..394e020 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1200,6 +1200,10 @@ (when (info :type :kind name) (error 'declaration-type-conflict-error :format-arguments (list name))))) +(define-info-type + :class :declaration + :type :handler + :type-spec (or function null)) (define-info-class :alien-type) (define-info-type diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ac16a1d..9db8370 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1461,7 +1461,10 @@ (t (unless (info :declaration :recognized (first spec)) (compiler-warn "unrecognized declaration ~S" raw-spec)) - res)) + (let ((fn (info :declaration :handler (first spec)))) + (if fn + (funcall fn res spec) + res)))) result-type))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 046c7bf..31fdb6b 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -765,7 +765,8 @@ (handled-conditions (lexenv-handled-conditions default)) (disabled-package-locks (lexenv-disabled-package-locks default)) - (policy (lexenv-policy default))) + (policy (lexenv-policy default)) + (user-data (lexenv-user-data default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) (if ,var @@ -777,8 +778,10 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup handled-conditions - disabled-package-locks policy))) + lambda + cleanup handled-conditions disabled-package-locks + policy + user-data))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -812,7 +815,8 @@ nil (lexenv-handled-conditions lexenv) (lexenv-disabled-package-locks lexenv) - (lexenv-policy lexenv)))) + (lexenv-policy lexenv) + (lexenv-user-data lexenv)))) ;;;; flow/DFO/component hackery diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 54ef200..7e3e34e 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -21,7 +21,7 @@ (funs vars blocks tags type-restrictions lambda cleanup handled-conditions - disabled-package-locks %policy))) + disabled-package-locks %policy user-data))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an ;; INLINE/NOTINLINE declaration, or a list (MACRO . <function>) (a @@ -64,7 +64,11 @@ ;; and the global policy is stored in *POLICY*. (Because we want to ;; be able to affect it from :WITH-COMPILATION-UNIT.) NIL here also ;; works as a convenient null-lexenv identifier. - (%policy nil :type policy)) + (%policy nil :type policy) + ;; A list associating extra user info to symbols. The entries + ;; are of the form (:declare name . value), + ;; (:variable name key . value), or (:function name key . value) + (user-data nil :type list)) (defun lexenv-policy (lexenv) (or (lexenv-%policy lexenv) *policy*)) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 20:09:54
|
(declaration-information 'declaration) returns a list of declaration names that have been proclaimed as valid. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 12 +++++++++++- contrib/sb-cltl2/tests.lisp | 7 +++++++ 2 files changed, 18 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 652a72f..469d567 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -8,7 +8,6 @@ (in-package :sb-cltl2) #| TODO: -declaration-information augment-environment define-declaration (map-environment) @@ -228,6 +227,9 @@ appear with CDR as T if the variable has been declared always bound." If DECLARATION-NAME is optimize return a list who's entries are of the form (quality value). + If DECLARATION-NAME is declaration returns a list of declaration names + that have been proclaimed as valid. + If DECLARATION-NAME is sb-ext:muffle-conditions return a type specifier for the condition types that have been muffled. @@ -245,6 +247,14 @@ appear with CDR as T if the variable has been declared always bound." (sb-ext:muffle-conditions (car (rassoc 'muffle-warning (sb-c::lexenv-handled-conditions env)))) + (declaration + (let ((type (sb-c::type-info-number (sb-c::type-info-or-lose :declaration :recognized))) + (ret nil)) + (dolist (env *info-environment*) + (do-info (env :name name :type-number num :value value) + (when (and (= num type) value) + (push name ret)))) + ret)) (t (error "Unsupported declaration ~S." declaration-name))))) (defun parse-macro (name lambda-list body &optional env) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index ec5e8c9..87e133e 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -109,6 +109,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*) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 20:09:57
|
Adds docstrings for declaration-information, parse-macro and enclose. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 18 ++++++++++++++++++ 1 files changed, 18 insertions(+), 0 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index dd9efd5..652a72f 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -223,6 +223,15 @@ appear with CDR as T if the variable has been declared always bound." (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 @@ -239,6 +248,10 @@ appear with CDR as T if the variable has been declared always bound." (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 expression will parse-and-bind + the form as per the lambda-list and then call body." (declare (ignore env)) (with-unique-names (whole environment) (multiple-value-bind (body decls) @@ -250,6 +263,11 @@ appear with CDR as T if the variable has been declared always bound." ,body)))) (defun enclose (lambda-expression &optional env) + "Evaluate a lambda expression in a lexical environment and return + a function. The lambda expression is only allowed to reference + the declarations and macro definitions of ENV. It is not allowed + to reference lexical variables, functions, tags or any other run-time + entity defined in ENV" (let ((env (if env (sb-c::make-restricted-lexenv env) (make-null-lexenv)))) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 20:10:00
|
This patch implements sb-cltl2:augment-environment, a function that the user can call from a macro to add information to a lexical environment. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 59 ++++++++++++- contrib/sb-cltl2/tests.lisp | 206 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 264 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index dd9efd5..620660a 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -9,11 +9,68 @@ #| TODO: declaration-information -augment-environment define-declaration (map-environment) |# + +(declaim (ftype (function (&rest t) t) mystery)) +(defun mystery (&rest r) + (declare (ignore r))) + +(defmacro capture-environment (&environment env) + (throw 'capture-environment env)) + +(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))) ...) " + (when (null env) + (setq env (make-null-lexenv))) + (when (or macro symbol-macro) + (setq env (copy-structure env))) + (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)))) + (if (not (or variable function declare)) + env + (catch 'capture-environment + (sb-c::with-compilation-values + (let ((sb-c::*lexenv* env)) + (sb-c::make-functional-from-toplevel-lambda + `(lambda () + (labels ,(loop for fn in function collect `(,fn ())) + (declare ,@(loop for d in declare + if (member (car d) '(ftype inline notinline)) + collect d)) + (let ,(loop for v in variable collect `(,v (mystery))) + (declare ,@declare) + (capture-environment)))) + :name nil + :path '(original-source-start 0 0))))))) + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) (values (member nil :function :macro :special-form) boolean diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index ec5e8c9..6d81ea3 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -279,3 +279,209 @@ (fun-info identity)) (:function nil ((inline . inline) (ftype function (t) (values t &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*)))) + :special) + +(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.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 sfunction (integer) integer))) + + +(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) +(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*)))) + :special) + +(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.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.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.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 sfunction (integer) integer))) + + +(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.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)) + +(deftest augment-environment.macro2 + (eval (macroexpand '(newcond + ((= 1 2) 'foo) + ((= 1 1) 'bar)) + (augment-environment nil :macro (list (list 'newcond (macro-function 'cond)))))) + bar) -- 1.6.0.4 |
From: Larry D'A. <la...@el...> - 2009-06-26 20:10:02
|
variable-information will return :alien for variables defined with sb-alien:define-alien-variable. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 5 ++++- contrib/sb-cltl2/tests.lisp | 5 +++++ 2 files changed, 9 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index d1305d2..ea60bdf 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -193,7 +193,7 @@ CARS of the alist include: (declaim (ftype (sfunction (symbol &optional (or null lexenv)) - (values (member nil :special :lexical :symbol-macro :constant :global) + (values (member nil :special :lexical :symbol-macro :constant :global :alien) boolean list)) variable-information)) @@ -224,6 +224,9 @@ binding: :GLOBAL NAME refers to a global variable. (SBCL specific extension.) + :ALIEN + NAME refers to an alien 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. diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index 6266644..e40b707 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -226,6 +226,11 @@ (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) -- 1.6.0.4 |
From: Nikodemus S. <nik...@ra...> - 2009-06-29 10:22:45
|
2009/6/26 Larry D'Anna <la...@el...>: > + (catch 'capture-environment > + (sb-c::with-compilation-values > + (let ((sb-c::*lexenv* env)) > + (sb-c::make-functional-from-toplevel-lambda > + `(lambda () > + (labels ,(loop for fn in function collect `(,fn ())) > + (declare ,@(loop for d in declare > + if (member (car d) '(ftype inline notinline)) > + collect d)) > + (let ,(loop for v in variable collect `(,v (mystery))) > + (declare ,@declare) > + (capture-environment)))) > + :name nil > + :path '(original-source-start 0 0))))))) I don't this is an improvement, unfortunately: this is just as dodgy in the sense that it lets the environment escape into places it is not supposed to, and digs a bit too deep into the compiler for comfort. I would be more comfortable constructing an environment with the appropriate bindings manually -- and making them such that one cannot accidentally to use them like one would real bindings, limiting them to use with SB-CLTL2 environment access functions. ...or so I think. I haven't yet looked at the potential use-cases really, and have a hard time understanding what practical problems :VARIABLES and :FUNCTIONS solve. Unless the bindings are sufficiently real that one can use them to implement an eg. an interpreter I'm somewhat at a loss. Cheers, -- Nikodemus |
From: Nikodemus S. <nik...@ra...> - 2009-06-29 10:28:52
|
2009/6/26 Larry D'Anna <la...@el...>: >> * We generally prefer no docsstrings for non-exported functions. These >> would be better as comments. > > OK fixed. Sorry to nitpick, but I meant ;;; Frob the bar. (defun frob (bar) ...) not (defun frob (bar) ;; Frob the bar. ...) as the latter style is more "internal" to the function it should be about internal details, not the public API. Not that this is an ironclad rule -- the inverse certainly isn't true: SBCL has several function with leading comment blocks that go into the internals of what is going on. Otherwise, except for the AUGMENT-ENVIRONMENT being IMO still dodgy things look good. It might be a good idea to implement A-E initially without :VARIABLES and :FUNCTIONS unless there are use-cases for them that allow us to understand what they should actually do. Cheers, -- Nikodemus |
From: Larry D'A. <la...@el...> - 2009-06-29 16:41:48
|
* Nikodemus Siivola (nik...@ra...) [090629 06:25]: > 2009/6/26 Larry D'Anna <la...@el...>: > > > + (catch 'capture-environment > > + (sb-c::with-compilation-values > > + (let ((sb-c::*lexenv* env)) > > + (sb-c::make-functional-from-toplevel-lambda > > + `(lambda () > > + (labels ,(loop for fn in function collect `(,fn ())) > > + (declare ,@(loop for d in declare > > + if (member (car d) '(ftype inline notinline)) > > + collect d)) > > + (let ,(loop for v in variable collect `(,v (mystery))) > > + (declare ,@declare) > > + (capture-environment)))) > > + :name nil > > + :path '(original-source-start 0 0))))))) > > I don't this is an improvement, unfortunately: this is just as dodgy > in the sense that it lets the environment escape into places it is not > supposed to, and digs a bit too deep into the compiler for comfort. > > I would be more comfortable constructing an environment with the > appropriate bindings manually -- and making them such that one cannot > accidentally to use them like one would real bindings, limiting them > to use with SB-CLTL2 environment access functions. > > ...or so I think. I haven't yet looked at the potential use-cases > really, and have a hard time understanding what practical problems > :VARIABLES and :FUNCTIONS solve. Unless the bindings are sufficiently > real that one can use them to implement an eg. an interpreter I'm > somewhat at a loss. Lets say you have two macros munge and frobnicate. (munge (let ((x something)) (frobnicate ... (foobar x) ... ))) And lets say that munge wants to look past the let and macroexpand frobnicate, and frobnicate is going to call (variable-information 'x lexenv). Without (augment-environment :variable) munge can't pass a correct lexenv to frobnicate, and frobnicate will think x is unbound. I totally agree that constructing the bindings manually is better. That's the way I initially tried to write it, but I hit a snag: to do it that way I had to re-implement the declaration parsing logic. And that's a bit more involved than just adding a variable to a lexenv. Not only would it be a lot of extra code that would have to go into sb-cltl2, but anytime the real declaration parser in ir1tran.lisp got updated, the sb-cltl2 declaration parser would lag behind it. How about this: augment-environment manually creates the variable and function bindings like you said, but then it calls sb-c::process-decls to handle the declarations. --larry |
From: Nikodemus S. <nik...@ra...> - 2009-06-29 18:26:12
|
2009/6/29 Larry D'Anna <la...@el...>: > (munge > (let ((x something)) > (frobnicate > ... > (foobar x) > ... > ))) > > And lets say that munge wants to look past the let and macroexpand frobnicate, > and frobnicate is going to call (variable-information 'x lexenv). Without > (augment-environment :variable) munge can't pass a correct lexenv to frobnicate, > and frobnicate will think x is unbound. Aha! I see now, yes. This is sensible, more or less. > How about this: augment-environment manually creates the variable and function > bindings like you said, but then it calls sb-c::process-decls to handle the > declarations. That sounds about right. If it turns out that PROCESS-DECLS is currently not up to task, it can be refactored to do better. Cheers, -- Nikodemus |
From: Larry D'A. <la...@el...> - 2009-07-01 08:09:33
|
Differences since the last version: * comments fixed * augment-environment now calls process-decls to deal with decls and handles everything else itself. * variable-information and function-information made a little more liberal with types (see the commit message for the augment-environment patch) * added a few more tests * define-declaration now attaches declarations to bindings, not names. So if (mydecl x) is a user-defined variable declaration on x, then in (let (x) (declare (mydecl x)) (let (x) ....)) (mydecl x) will only attach to the outer binding. |
From: Larry D'A. <la...@el...> - 2009-07-01 08:11:28
|
Adds docstrings for declaration-information, parse-macro and enclose. Renames a test for variable-information that had the same name as another. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 18 ++++++++++++++++++ contrib/sb-cltl2/tests.lisp | 2 +- 2 files changed, 19 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index dd9efd5..652a72f 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -223,6 +223,15 @@ appear with CDR as T if the variable has been declared always bound." (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 @@ -239,6 +248,10 @@ appear with CDR as T if the variable has been declared always bound." (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 expression will parse-and-bind + the form as per the lambda-list and then call body." (declare (ignore env)) (with-unique-names (whole environment) (multiple-value-bind (body decls) @@ -250,6 +263,11 @@ appear with CDR as T if the variable has been declared always bound." ,body)))) (defun enclose (lambda-expression &optional env) + "Evaluate a lambda expression in a lexical environment and return + a function. The lambda expression is only allowed to reference + the declarations and macro definitions of ENV. It is not allowed + to reference lexical variables, functions, tags or any other run-time + entity defined in ENV" (let ((env (if env (sb-c::make-restricted-lexenv env) (make-null-lexenv)))) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index ec5e8c9..a314d8d 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -182,7 +182,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))) -- 1.6.3.3.363.g364f.dirty |
From: Nikodemus S. <nik...@ra...> - 2009-07-29 16:01:41
|
2009/7/1 Larry D'Anna <la...@el...>: > Adds docstrings for declaration-information, parse-macro and enclose. > Renames a test for variable-information that had the same name as another. Thank you! Merged as 1.0.30.14. I tweaked the prose and indetation somewhat. Two guidelines of note: * Docstring paragraphs should not have leading whitespace unless they are part of a definition list, etc. * Variable names should be capitalized. While SB-CLTL2 is not currently in the manual, the texinfo generator we use does a much better job if these are can care of. I'm looking into the other patches in the series shortly. Cheers, -- Nikodemus |
From: Larry D'A. <la...@el...> - 2009-07-01 08:11:28
|
define-declaration lets the user define handlers for their own declarations types. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 113 +++++++++++++++++++- contrib/sb-cltl2/tests.lisp | 243 +++++++++++++++++++++++++++++++++++++++++++ src/code/full-eval.lisp | 6 +- src/compiler/globaldb.lisp | 4 + src/compiler/ir1tran.lisp | 5 +- src/compiler/ir1util.lisp | 12 ++- src/compiler/lexenv.lisp | 8 +- 7 files changed, 378 insertions(+), 13 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 93ee72e..07cd926 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -8,7 +8,6 @@ (in-package :sb-cltl2) #| TODO: -define-declaration (map-environment) |# @@ -98,6 +97,42 @@ define-declaration env)) +;;; Retrieve the user-supplied (from define-declaration) pairs for a +;;; function or a variable from a lexical environment. +;;; +;;; KEYWORD should be :function or :variable, VAR should be a +;;; function or variable name, respectively. +(defun extra-pairs (keyword var binding env) + (when env + (let ((ret nil)) + (dolist (entry (sb-c::lexenv-user-data env)) + (destructuring-bind (entry-keyword entry-var entry-binding &rest entry-cons) + entry + (when (and (eq keyword entry-keyword) + (typecase binding + (sb-c::global-var + (and (eq var entry-var) + (typecase entry-binding + (sb-c::global-var t) + (sb-c::lambda-var (sb-c::lambda-var-specvar entry-binding)) + (null t) + (t nil)))) + (t + (eq binding entry-binding)))) + (push entry-cons ret)))) + (nreverse ret)))) + +;;; Retrieve the user-supplied (from define-declaration) value for +;;; the declaration with the given NAME +(defun extra-decl-info (name env) + (when env + (dolist (entry (sb-c::lexenv-user-data env)) + (when (and (eq :declare (car entry)) + (eq name (cadr entry))) + (return-from extra-decl-info (cddr entry)))) + nil)) + + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) (values (member nil :function :macro :special-form) boolean @@ -188,7 +223,9 @@ CARS of the alist include: (:notinline (push (cons 'inline 'notinline) alist)) ((nil))) (when dx (push (cons 'dynamic-extent t) alist)) - alist)))) + (append alist (extra-pairs :function name fun *lexenv*)))))) + + (declaim (ftype (sfunction (symbol &optional (or null lexenv)) @@ -296,7 +333,7 @@ appear with CDR as T if the variable has been declared always bound." (when dx (push (cons 'dynamic-extent t) alist)) (when (info :variable :always-bound name) (push (cons 'sb-ext:always-bound t) alist)) - alist)))) + (append alist (extra-pairs :variable name var *lexenv*)))))) (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t) declaration-information)) @@ -312,6 +349,9 @@ appear with CDR as T if the variable has been declared always bound." If DECLARATION-NAME is sb-ext:muffle-conditions return a type specifier for the condition types that have been muffled. + If DECLARATION-NAME is a name that has defined via DEFINE-DECLARATION return + a user defined value. + " (let ((env (or env (make-null-lexenv)))) (case declaration-name @@ -334,7 +374,10 @@ appear with CDR as T if the variable has been declared always bound." (when (and (= num type) value) (push name ret)))) ret)) - (t (error "Unsupported declaration ~S." declaration-name))))) + (t (if (info :declaration :handler declaration-name) + (extra-decl-info declaration-name env) + (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 @@ -361,3 +404,65 @@ appear with CDR as T if the variable has been declared always bound." (sb-c::make-restricted-lexenv env) (make-null-lexenv)))) (compile-in-lexenv nil lambda-expression env))) + +;;; Add a bit of user-data to a lexenv. +;;; +;;; If KIND is :declare then DATA should be of the form +;;; (declaration-name . value) +;;; If KIND is :variable then DATA should be of the form +;;; (variable-name key value) +;;; If KIND is :function then DATA should be of the form +;;; (function-name key value) +;;; +;;; PD-VARS and PD-FVARS are are the vars and fvars arguments +;;; of the process-decls call that called this function. +(defun update-lexenv-user-data (env kind data pd-vars pd-fvars) + (let ((user-data (sb-c::lexenv-user-data env))) + ;; user-data looks like this: + ;; ((:declare d . value) + ;; (:variable var binding key . value) + ;; (:function var binding key . value)) + (let ((*lexenv* env)) + (ecase kind + (:variable + (loop + for (name key value) in data + for binding1 = (sb-c::find-in-bindings pd-vars name) + for binding = (if binding1 binding1 (lexenv-find name vars)) + do (push (list* :variable name binding key value) user-data))) + (:function + (loop + for (name key value) in data + for binding1 = (find name pd-fvars :key #'sb-c::leaf-source-name :test #'equal) + for binding = (if binding1 binding1 (lexenv-find name funs)) + do (push (list* :function name binding key value) user-data))) + (:declare + (destructuring-bind (decl-name . value) data + (push (list* :declare decl-name value) user-data))))) + (sb-c::make-lexenv :default env :user-data user-data))) + +(defmacro define-declaration (decl-name lambda-list &body body) + "Define a handler for declaration specifiers who's car is DECL-NAME. + + The function defined by this macro is called with two arguments: + a declaration specifier and a environment. It must return two + values. The first value must be :variable, :function, or :declare + + If the first value is :variable or :function then the second value + should be a list of elements of the form (BINDING-NAME KEY VALUE). + conses (KEY . VALUE) will be added to the alist returned by + (function-information BINDING-NAME env) or + (variable-information BINDING-NAME env). + + If the first value is :declare then the second value should be a + cons (DECL-NAME . VALUE). VALUE will be returned by + (declaration-information 'DECL-NAME env). " + `(eval-when (:compile-toplevel :load-toplevel :execute) + (proclaim '(declaration ,decl-name)) + (flet ((func ,lambda-list + ,@body)) + (setf + (info :declaration :handler ',decl-name) + (lambda (lexenv spec pd-vars pd-fvars) + (multiple-value-bind (kind data) (func spec lexenv) + (update-lexenv-user-data lexenv kind data pd-vars pd-fvars))))))) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index d710d17..3ae20d2 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -423,3 +423,246 @@ :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)) diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index 00e4e33..5079abc 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -104,7 +104,8 @@ nil nil nil nil nil (sb!c::lexenv-handled-conditions old-lexenv) (sb!c::lexenv-disabled-package-locks old-lexenv) - (sb!c::lexenv-policy old-lexenv)))) + (sb!c::lexenv-policy old-lexenv) + (sb!c::lexenv-user-data old-lexenv)))) (dolist (declaration declarations) (unless (consp declaration) (ip-error "malformed declaration specifier ~S in ~S" @@ -175,7 +176,8 @@ (sb!c::internal-make-lexenv nil nil nil nil nil nil nil nil nil - sb!c::*policy*))) + sb!c::*policy* + nil))) ;;; Augment ENV with a special or lexical variable binding (declaim (inline push-var)) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index d20e894..394e020 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1200,6 +1200,10 @@ (when (info :type :kind name) (error 'declaration-type-conflict-error :format-arguments (list name))))) +(define-info-type + :class :declaration + :type :handler + :type-spec (or function null)) (define-info-class :alien-type) (define-info-type diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ac16a1d..3b8f1af 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1461,7 +1461,10 @@ (t (unless (info :declaration :recognized (first spec)) (compiler-warn "unrecognized declaration ~S" raw-spec)) - res)) + (let ((fn (info :declaration :handler (first spec)))) + (if fn + (funcall fn res spec vars fvars) + res)))) result-type))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 046c7bf..31fdb6b 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -765,7 +765,8 @@ (handled-conditions (lexenv-handled-conditions default)) (disabled-package-locks (lexenv-disabled-package-locks default)) - (policy (lexenv-policy default))) + (policy (lexenv-policy default)) + (user-data (lexenv-user-data default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) (if ,var @@ -777,8 +778,10 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup handled-conditions - disabled-package-locks policy))) + lambda + cleanup handled-conditions disabled-package-locks + policy + user-data))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -812,7 +815,8 @@ nil (lexenv-handled-conditions lexenv) (lexenv-disabled-package-locks lexenv) - (lexenv-policy lexenv)))) + (lexenv-policy lexenv) + (lexenv-user-data lexenv)))) ;;;; flow/DFO/component hackery diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 54ef200..7e3e34e 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -21,7 +21,7 @@ (funs vars blocks tags type-restrictions lambda cleanup handled-conditions - disabled-package-locks %policy))) + disabled-package-locks %policy user-data))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an ;; INLINE/NOTINLINE declaration, or a list (MACRO . <function>) (a @@ -64,7 +64,11 @@ ;; and the global policy is stored in *POLICY*. (Because we want to ;; be able to affect it from :WITH-COMPILATION-UNIT.) NIL here also ;; works as a convenient null-lexenv identifier. - (%policy nil :type policy)) + (%policy nil :type policy) + ;; A list associating extra user info to symbols. The entries + ;; are of the form (:declare name . value), + ;; (:variable name key . value), or (:function name key . value) + (user-data nil :type list)) (defun lexenv-policy (lexenv) (or (lexenv-%policy lexenv) *policy*)) -- 1.6.3.3.363.g364f.dirty |
From: Nikodemus S. <nik...@ra...> - 2009-08-01 09:05:57
|
2009/7/1 Larry D'Anna <la...@el...>: > define-declaration lets the user define handlers for their own declarations > types. Merged as 1.0.30.29, thank you! Cheers, -- Nikodemus |
From: Larry D'A. <la...@el...> - 2009-07-01 08:11:48
|
variable-information will return :alien for variables defined with sb-alien:define-alien-variable. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 5 ++++- contrib/sb-cltl2/tests.lisp | 5 +++++ 2 files changed, 9 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 07cd926..8504fff 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -229,7 +229,7 @@ CARS of the alist include: (declaim (ftype (sfunction (symbol &optional (or null lexenv)) - (values (member nil :special :lexical :symbol-macro :constant :global) + (values (member nil :special :lexical :symbol-macro :constant :global :alien) boolean list)) variable-information)) @@ -259,6 +259,9 @@ binding: :GLOBAL NAME refers to a global variable. (SBCL specific extension.) + :ALIEN + NAME refers to an alien 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. diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index 3ae20d2..f813117 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -226,6 +226,11 @@ (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) -- 1.6.3.3.363.g364f.dirty |
From: Nikodemus S. <nik...@ra...> - 2009-08-01 09:14:30
|
2009/7/1 Larry D'Anna <la...@el...>: > variable-information will return :alien for variables > defined with sb-alien:define-alien-variable. Thank you! Merged as 1.0.30.30. Cheers, -- Nikodemus |
From: Larry D'A. <la...@el...> - 2009-07-01 08:11:49
|
(declaration-information 'declaration) returns a list of declaration names that have been proclaimed as valid. Signed-off-by: Larry D'Anna <la...@el...> --- contrib/sb-cltl2/env.lisp | 12 +++++++++++- contrib/sb-cltl2/tests.lisp | 7 +++++++ 2 files changed, 18 insertions(+), 1 deletions(-) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 652a72f..469d567 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -8,7 +8,6 @@ (in-package :sb-cltl2) #| TODO: -declaration-information augment-environment define-declaration (map-environment) @@ -228,6 +227,9 @@ appear with CDR as T if the variable has been declared always bound." If DECLARATION-NAME is optimize return a list who's entries are of the form (quality value). + If DECLARATION-NAME is declaration returns a list of declaration names + that have been proclaimed as valid. + If DECLARATION-NAME is sb-ext:muffle-conditions return a type specifier for the condition types that have been muffled. @@ -245,6 +247,14 @@ appear with CDR as T if the variable has been declared always bound." (sb-ext:muffle-conditions (car (rassoc 'muffle-warning (sb-c::lexenv-handled-conditions env)))) + (declaration + (let ((type (sb-c::type-info-number (sb-c::type-info-or-lose :declaration :recognized))) + (ret nil)) + (dolist (env *info-environment*) + (do-info (env :name name :type-number num :value value) + (when (and (= num type) value) + (push name ret)))) + ret)) (t (error "Unsupported declaration ~S." declaration-name))))) (defun parse-macro (name lambda-list body &optional env) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index a314d8d..01b6974 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -109,6 +109,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*) -- 1.6.3.3.363.g364f.dirty |