projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
1.0.24.20: misc HPPA & HPUX updates
[sbcl.git]
/
src
/
pcl
/
walk.lisp
diff --git
a/src/pcl/walk.lisp
b/src/pcl/walk.lisp
index
30906c7
..
3f6d209
100644
(file)
--- a/
src/pcl/walk.lisp
+++ b/
src/pcl/walk.lisp
@@
-257,6
+257,11
@@
(defun env-declarations (env)
(caddr (env-lock env)))
(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 env-lexical-variables (env)
(cadddr (env-lock env)))
@@
-267,12
+272,12
@@
(push (list thing :lexical-var) (cadddr (env-lock env))))
(defun var-lexical-p (var 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)
(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)))
(when (eq (cadar entry) 'sb!sys:macro)
entry)))
@@
-465,12
+470,17
@@
((not (consp newform))
(let ((symmac (car (variable-symbol-macro-p newform env))))
(if symmac
((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))
newform)))
(t
(let* ((fn (car newform))
@@
-633,7
+643,7
@@
,(or (var-lexical-p name env) name)
,.args)
env)
,(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
(push declaration declarations)))
(recons body
form
@@
-668,7
+678,7
@@
&aux arg)
(cond ((null arglist) ())
((symbolp (setq arg (car arglist)))
&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
(note-lexical-binding arg env))
(recons arglist
arg
@@
-676,8
+686,7
@@
context
env
(and destructuringp
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
((consp arg)
(prog1 (recons arglist
(if destructuringp
@@
-854,7
+863,10
@@
(val (caddr form))
(symmac (car (variable-symbol-macro-p var env))))
(if symmac
(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
(walked (walk-form-internal expanded context env)))
(if (eq expanded walked)
form