* Patch by Larry D'Anna.
* improvements to SB-CLTL2 (thanks to Larry D'Anna):
** functions DECLARATION-INFORMATION, PARSE-MACRO, and ENCLOSE have been
documented.
+ ** AUGMENT-ENVIRONMENT and DEFINE-DECLARATION have been implemented.
** DECLARATION-INFORMATION now supports declaration name DECLARATION as
- well.
- ** AUGMENT-ENVIRONMENT has been implemented.
+ well as user defined declaration names.
* improvement: improved address space layout on OpenBSD (thanks to Josh
Elsasser)
* improvement: pretty-printing of various Lisp forms has been improved
(in-package :sb-cltl2)
#| TODO:
-define-declaration
(map-environment)
|#
(loop for name in variable for lvar in (lvars)
collect
(cons name
- ;; if one of the lvars is declared special then process-decls
- ;; will set it's specvar.
+ ;; If one of the lvars is declared special then
+ ;; process-decls will set it's specvar.
(if (sb-c::lambda-var-specvar lvar)
(sb-c::lambda-var-specvar lvar)
lvar)))
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
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."
+ be omitted.
+
+In addition to these declarations defined using DEFINE-DECLARATION may
+appear."
(let* ((*lexenv* (or env (make-null-lexenv)))
(fun (lexenv-find name funs))
binding localp ftype dx inlinep)
(: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))
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."
+ SB-EXT:ALWAYS-BOUND
+ If CDR is T, NAME has been declared as SB-EXT:ALWAYS-BOUND \(SBCL
+ specific.)
+
+In addition to these declarations defined using DEFINE-DECLARATION may
+appear."
(let* ((*lexenv* (or env (make-null-lexenv)))
(kind (info :variable :kind name))
(var (lexenv-find name vars))
(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))
If DECLARATION-NAME is DECLARATION return a list of declaration names that
have been proclaimed as valid.
+If DECLARATION-NAME is a name that has defined via DEFINE-DECLARATION return a
+user defined 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))))
(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 DEFMACRO form
(sb-c::make-restricted-lexenv environment)
(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 starting with 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)))))))
: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))
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"
(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))
(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
(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
(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
(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
nil
(lexenv-handled-conditions lexenv)
(lexenv-disabled-package-locks lexenv)
- (lexenv-policy lexenv))))
+ (lexenv-policy lexenv)
+ (lexenv-user-data lexenv))))
\f
;;;; flow/DFO/component hackery
(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
;; 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*))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.30.28"
+"1.0.30.29"
projects / sbcl.git / commitdiff