Menu
▾
▴
[Sbcl-devel] [PATCH 4/5] sb-cltl2: implemnt define-declaration
|
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
|