(defun env-declarations (env)
(caddr (env-lock env)))
+(defun env-var-type (var env)
+ (dolist (decl (env-declarations env) t)
+ (when (and (eq 'type (car decl)) (member var (cddr decl) :test 'eq))
+ (return (cadr decl)))))
+
(defun env-lexical-variables (env)
(cadddr (env-lock env)))
(push (list thing :lexical-var) (cadddr (env-lock env))))
(defun var-lexical-p (var env)
- (let ((entry (member var (env-lexical-variables env) :key #'car)))
+ (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
(when (eq (cadar entry) :lexical-var)
entry)))
(defun variable-symbol-macro-p (var env)
- (let ((entry (member var (env-lexical-variables env) :key #'car)))
+ (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
(when (eq (cadar entry) 'sb!sys:macro)
entry)))
-(defvar *var-declarations* '(special))
+(defun walked-var-declaration-p (declaration)
+ (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special)))
+
+(defun %var-declaration (declaration var env)
+ (let ((id (or (var-lexical-p var env) var)))
+ (dolist (decl (env-declarations env))
+ (when (and (eq (car decl) declaration)
+ (eq (cadr decl) id))
+ (return decl)))))
(defun var-declaration (declaration var env)
- (if (not (member declaration *var-declarations*))
- (error "~S is not a recognized variable declaration." declaration)
- (let ((id (or (var-lexical-p var env) var)))
- (dolist (decl (env-declarations env))
- (when (and (eq (car decl) declaration)
- (eq (cadr decl) id))
- (return decl))))))
+ (if (walked-var-declaration-p declaration)
+ (%var-declaration declaration var env)
+ (error "Not a variable declaration the walker cares about: ~S" declaration)))
+
+#-sb-xc-host
+(define-compiler-macro var-declaration (&whole form declaration var env
+ &environment lexenv)
+ (if (sb!xc:constantp declaration lexenv)
+ (let ((decl (constant-form-value declaration lexenv)))
+ (if (walked-var-declaration-p decl)
+ `(%var-declaration ,declaration ,var ,env)
+ form))
+ form))
(defun var-special-p (var env)
- (or (not (null (var-declaration 'special var env)))
- (var-globally-special-p var)))
+ (and (or (var-declaration 'special var env)
+ (var-globally-special-p var))
+ t))
(defun var-globally-special-p (symbol)
(eq (info :variable :kind symbol) :special))
((not (consp newform))
(let ((symmac (car (variable-symbol-macro-p newform env))))
(if symmac
- (let ((newnewform (walk-form-internal (cddr symmac)
- context
- env)))
- (if (eq newnewform (cddr symmac))
- (if *walk-form-expand-macros-p* newnewform newform)
- newnewform))
+ (let* ((newnewform (walk-form-internal (cddr symmac)
+ context
+ env))
+ (resultform
+ (if (eq newnewform (cddr symmac))
+ (if *walk-form-expand-macros-p* newnewform newform)
+ newnewform))
+ (type (env-var-type newform env)))
+ (if (eq t type)
+ resultform
+ `(the ,type ,resultform)))
newform)))
(t
(let* ((fn (car newform))
(let ((type (car declaration))
(name (cadr declaration))
(args (cddr declaration)))
- (if (member type *var-declarations*)
+ (if (walked-var-declaration-p type)
(note-declaration `(,type
,(or (var-lexical-p name env) name)
,.args)
env)
- (note-declaration declaration env))
+ (note-declaration (sb!c::canonized-decl-spec declaration) env))
(push declaration declarations)))
(recons body
form
&aux arg)
(cond ((null arglist) ())
((symbolp (setq arg (car arglist)))
- (or (member arg lambda-list-keywords)
+ (or (member arg sb!xc:lambda-list-keywords :test #'eq)
(note-lexical-binding arg env))
(recons arglist
arg
context
env
(and destructuringp
- (not (member arg
- lambda-list-keywords))))))
+ (not (member arg sb!xc:lambda-list-keywords))))))
((consp arg)
(prog1 (recons arglist
(if destructuringp
(val (caddr form))
(symmac (car (variable-symbol-macro-p var env))))
(if symmac
- (let* ((expanded `(setf ,(cddr symmac) ,val))
+ (let* ((type (env-var-type var env))
+ (expanded (if (eq t type)
+ `(setf ,(cddr symmac) ,val)
+ `(setf ,(cddr symmac) `(the ,type ,val))))
(walked (walk-form-internal expanded context env)))
(if (eq expanded walked)
form