* Patch by Larry D'Anna.
documented.
** DECLARATION-INFORMATION now supports declaration name DECLARATION as
well.
+ ** AUGMENT-ENVIRONMENT has been implemented.
* 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:
-augment-environment
define-declaration
(map-environment)
|#
+
+(defvar *null-lexenv* (make-null-lexenv))
+
+(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))) ...)
+"
+ (collect ((lvars)
+ (clambdas))
+ (unless (or variable symbol-macro function macro declare)
+ (return-from augment-environment env))
+
+ (if (null env)
+ (setq env (make-null-lexenv))
+ (setq env (copy-structure env)))
+
+ ;; a null policy is used to identify a null lexenv
+ (when (sb-c::null-lexenv-p env)
+ (setf (sb-c::lexenv-%policy env) sb-c::*policy*))
+
+ (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))))
+
+ (dolist (name variable)
+ (lvars (sb-c::make-lambda-var :%source-name name)))
+
+ (dolist (name function)
+ (clambdas
+ (sb-c::make-lambda
+ :lexenv *null-lexenv*
+ :%source-name name
+ :allow-instrumenting nil)))
+
+ (when declare
+ ;; process-decls looks in *lexenv* policy to decide what warnings to print
+ (let ((*lexenv* *null-lexenv*))
+ (setq env (sb-c::process-decls
+ (list `(declare ,@declare))
+ (lvars) (clambdas) :lexenv env :context nil))))
+
+ (when function
+ (setf (sb-c::lexenv-funs env)
+ (nconc
+ (loop for name in function for lambda in (clambdas)
+ collect (cons name lambda))
+ (sb-c::lexenv-funs env))))
+
+ (when variable
+ (setf (sb-c::lexenv-vars env)
+ (nconc
+ (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 (sb-c::lambda-var-specvar lvar)
+ (sb-c::lambda-var-specvar lvar)
+ lvar)))
+ (sb-c::lexenv-vars env))))
+
+ env))
+
(declaim (ftype (sfunction (symbol &optional (or null lexenv))
(values (member nil :function :macro :special-form)
boolean
(let ((env-type (or (lexenv-find fun type-restrictions)
*universal-fun-type*)))
(setf binding :function
- ftype (if (eq :declared (sb-c::leaf-where-from fun))
- (type-intersection (sb-c::leaf-type fun)
- env-type)
- env-type)
+ ftype (type-intersection (sb-c::leaf-type fun) env-type)
dx (sb-c::leaf-dynamic-extent fun))
(etypecase fun
(sb-c::functional
(sb-c::leaf
(let ((env-type (or (lexenv-find var type-restrictions)
*universal-type*)))
- (setf type (if (eq :declared (sb-c::leaf-where-from var))
- (type-intersection (sb-c::leaf-type var)
- env-type)
- env-type)
+ (setf type (type-intersection (sb-c::leaf-type var) env-type)
dx (sb-c::leaf-dynamic-extent var)))
(etypecase var
(sb-c::lambda-var
;;;; more information.
(defpackage :sb-cltl2-tests
- (:use :sb-cltl2 :cl :sb-rt :sb-ext))
+ (:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
(in-package :sb-cltl2-tests)
(fun-info identity))
(:function nil ((inline . inline)
(ftype function (t) (values t &optional)))))
+
+(deftest function-information.ftype
+ (flet ((foo (x) x))
+ (declare (ftype (sfunction (integer) integer) foo))
+ (fun-info foo))
+ (:function
+ t
+ ((ftype function (integer) (values integer &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*))))
+ :lexical)
+
+(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.special.mask
+ (let* ((e1 (augment-environment nil :variable '(x) :declare '((ignore x))))
+ (e2 (augment-environment e1 :variable '(x))))
+ (assoc 'ignore
+ (nth 2 (multiple-value-list
+ (variable-information 'x e2)))))
+ nil)
+
+(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 function (integer) (values integer &optional))))
+
+
+(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)
+
+
+(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.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))
+
+
;;; 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.27"
+"1.0.30.28"
projects / sbcl.git / commitdiff