common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

sb-walker: shadow symbol-macrolet with SPECIAL.

Browse source 
Like the compiler does.

Fixes lp#1053198
This commit is contained in:
Stas Boukarev 2024-11-12 09:02:52 +03:00
parent 55c0a64954
commit a1725ee23b
2 changed files with 39 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
src/pcl/walk.lisp
View file

@ -800,25 +800,35 @@ instead of
(let ((type (car declaration))
(name (cadr declaration))
(args (cddr declaration)))
(if (walked-var-declaration-p type)
(note-declaration `(,type
,(or (var-lexical-p name env) name)
,.args)
env)
(let ((canonical (sb-c::canonized-decl-spec declaration)))
(typecase canonical
((cons (eql type) cons)
(destructuring-bind (type &rest vars) (cdr canonical)
(loop for name in vars
for symbol-macro = (and (symbolp name)
(car (variable-symbol-macro-p name env)))
do (if symbol-macro
(push (list* name 'sb-sys:macro
`(the ,type ,(cddr symbol-macro)))
(cadddr (env-lock env)))
(note-declaration canonical env)))))
(t
(note-declaration canonical env)))))
(cond ((eq type 'special)
(loop for name in (cdr declaration)
for var = (or (var-lexical-p name env)
name)
do
(note-declaration `(special ,(or var name)) env)
;; Shadow
(when (variable-symbol-macro-p name env)
(note-var-binding name env))))
((walked-var-declaration-p type)
(note-declaration `(,type
,(or (var-lexical-p name env) name)
,.args)
env))
(t
(let ((canonical (sb-c::canonized-decl-spec declaration)))
(typecase canonical
((cons (eql type) cons)
(destructuring-bind (type &rest vars) (cdr canonical)
(loop for name in vars
for symbol-macro = (and (symbolp name)
(car (variable-symbol-macro-p name env)))
do (if symbol-macro
(push (list* name 'sb-sys:macro
`(the ,type ,(cddr symbol-macro)))
(cadddr (env-lock env)))
(note-declaration canonical env)))))
(t
(note-declaration canonical env))))))
(push declaration declarations)))
(recons body
form

10
tests/walk.impure.lisp
View file

@ -1063,3 +1063,13 @@ Form: C Context: EVAL; lexically bound
(declare (fixnum x))
(incf x 1))))
:allow-notes nil))
(defmethod symbol-macrolet-special (s)
(declare (special s))
(symbol-macrolet ((s (slot-value x 'x)))
(let ()
(declare (special s))
s)))
(test-util:with-test (:name :symbol-macrolet-declarations)
(assert (eql (symbol-macrolet-special 10) 10)))