Skip to content
Browse files

fix walker handling of LET* bindings shadowing symbol macros

  Don't remove variable bindings from lexenv, which would cause
  symbol-macros to be unshadowed.

  Also treat special bindings correctly -- this comes mostly down to
  processing declarations from the body before processing variable
  bindings.
  • Loading branch information...
1 parent 927c5a9 commit f67e042243c5adbb6c719c828dc1a7132cc81119 @nikodemus nikodemus committed
Showing with 59 additions and 18 deletions.
  1. +22 −0 contrib/sb-cltl2/tests.lisp
  2. +37 −18 src/pcl/walk.lisp
View
22 contrib/sb-cltl2/tests.lisp
@@ -694,3 +694,25 @@
'robot
lexenv))))))))
(emotional-state . happy))
+
+(deftest macroexpand-all.special-binding
+ (let ((form '(macrolet ((v (x &environment env)
+ (sb-cltl2:variable-information x env)))
+ (let* ((x :foo)
+ (y (v x)))
+ (declare (special x))
+ (list y (v x))))))
+ (list (eval form)
+ (eval (sb-cltl2:macroexpand-all form))))
+ ((:special :special) (:special :special)))
+
+(deftest macroexpand-all.symbol-macro-shadowed
+ (let ((form '(macrolet ((v (x &environment env)
+ (macroexpand x env)))
+ (symbol-macrolet ((x :bad))
+ (let* ((x :good)
+ (y (v x)))
+ y)))))
+ (list (eval form)
+ (eval (sb-cltl2:macroexpand-all form))))
+ (:good :good))
View
55 src/pcl/walk.lisp
@@ -149,13 +149,25 @@
;; 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 (member info '(:lexical-var :special-var))
+ (cons name
+ (if (eq :special-var info)
+ (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)))
@@ -268,8 +280,11 @@
(defun note-declaration (declaration env)
(push declaration (caddr (env-lock env))))
-(defun note-lexical-binding (thing env)
- (push (list thing :lexical-var) (cadddr (env-lock env))))
+(defun note-var-binding (thing env)
+ (push (list thing (if (var-special-p thing env)
+ :special-var
+ :lexical-var))
+ (cadddr (env-lock env))))
(defun var-lexical-p (var env)
(let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
@@ -679,7 +694,7 @@
(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)
@@ -697,11 +712,11 @@
(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))))
@@ -716,14 +731,18 @@
(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 nil)
(walked-body
- (walk-declarations body #'walk-repeat-eval new-env)))
+ (walk-declarations body
+ (lambda (form env)
+ (setf walked-bindings
+ (walk-bindings-1 bindings
+ old-env
+ new-env
+ context
+ sequentialp))
+ (walk-repeat-eval form env))
+ new-env)))
(relist*
form let/let* walked-bindings walked-body))))
@@ -784,7 +803,7 @@
(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)
@@ -796,7 +815,7 @@
;; 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

0 comments on commit f67e042

Please sign in to comment.
Something went wrong with that request. Please try again.