;; FLET and LABELS, so we have no idea what to use for the
;; environment. So we just blow it off, 'cause anything real we do
;; would be wrong. But we still have to make an entry so we can tell
- ;; functions from macros.
+ ;; functions from macros -- same for telling variables apart from
+ ;; symbol macros.
(let ((lexenv (sb!kernel::coerce-to-lexenv env)))
(sb!c::make-lexenv
:default lexenv
:vars (when (eql (caar macros) *key-to-walker-environment*)
- (copy-tree (remove :lexical-var (fourth (cadar macros))
- :key #'cadr)))
+ (copy-tree (mapcar (lambda (b)
+ (let ((name (car b))
+ (info (cadr b)))
+ (if (eq info :lexical-var)
+ (cons name
+ (if (var-special-p name env)
+ (sb!c::make-global-var
+ :kind :special
+ :%source-name name)
+ (sb!c::make-lambda-var
+ :%source-name name)))
+ b)))
+ (fourth (cadar macros)))))
:funs (append (mapcar (lambda (f)
(cons (car f)
(sb!c::make-functional :lexenv lexenv)))
(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)))
(defun note-declaration (declaration env)
(push declaration (caddr (env-lock env))))
-(defun note-lexical-binding (thing env)
+(defun note-var-binding (thing env)
(push (list thing :lexical-var) (cadddr (env-lock env))))
(defun var-lexical-p (var env)
(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)))))
+ (if (eq 'special declaration)
+ (dolist (decl (env-declarations env))
+ (when (and (eq (car decl) declaration)
+ (or (member var (cdr decl))
+ (and id (member id (cdr decl)))))
+ (return decl)))
+ (dolist (decl (env-declarations env))
+ (when (and (eq (car decl) declaration)
+ (eq (cadr decl) id))
+ (return decl))))))
(defun var-declaration (declaration var env)
(if (walked-var-declaration-p declaration)
((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))
(multiple-value-bind (newnewform macrop)
(walker-environment-bind
(new-env env :walk-form newform)
- (sb-xc:macroexpand-1 newform new-env))
+ (%macroexpand-1 newform new-env))
(cond
(macrop
(let ((newnewnewform (walk-form-internal newnewform
,(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
(null (get-walker-template (car form) form))
(progn
(multiple-value-setq (new-form macrop)
- (sb-xc:macroexpand-1 form env))
+ (%macroexpand-1 form env))
macrop))
;; This form was a call to a macro. Maybe it expanded
;; into a declare? Recurse to find out.
(cond ((null arglist) ())
((symbolp (setq arg (car arglist)))
(or (member arg sb!xc:lambda-list-keywords :test #'eq)
- (note-lexical-binding arg env))
+ (note-var-binding arg env))
(recons arglist
arg
(walk-arglist (cdr arglist)
(cddr arg)))
(walk-arglist (cdr arglist) context env nil))
(if (symbolp (car arg))
- (note-lexical-binding (car arg) env)
- (note-lexical-binding (cadar arg) env))
+ (note-var-binding (car arg) env)
+ (note-var-binding (cadar arg) env))
(or (null (cddr arg))
(not (symbolp (caddr arg)))
- (note-lexical-binding (caddr arg) env))))
+ (note-var-binding (caddr arg) env))))
(t
(error "can't understand something in the arglist ~S" arglist))))
(let* ((let/let* (car form))
(bindings (cadr form))
(body (cddr form))
- (walked-bindings
- (walk-bindings-1 bindings
- old-env
- new-env
- context
- sequentialp))
+ walked-bindings
(walked-body
- (walk-declarations body #'walk-repeat-eval new-env)))
+ (walk-declarations
+ body
+ (lambda (real-body real-env)
+ (setf walked-bindings
+ (walk-bindings-1 bindings
+ old-env
+ new-env
+ context
+ sequentialp))
+ (walk-repeat-eval real-body real-env))
+ new-env)))
(relist*
- form let/let* walked-bindings walked-body))))
+ form let/let* walked-bindings walked-body))))
(defun walk-locally (form context old-env)
(declare (ignore context))
(recons bindings
(if (symbolp binding)
(prog1 binding
- (note-lexical-binding binding new-env))
+ (note-var-binding binding new-env))
(prog1 (relist* binding
(car binding)
(walk-form-internal (cadr binding)
;; the next value form. Don't
;; walk it now, though.
(cddr binding))
- (note-lexical-binding (car binding) new-env)))
+ (note-var-binding (car binding) new-env)))
(walk-bindings-1 (cdr bindings)
old-env
new-env
(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
projects / sbcl.git / blobdiff