130 |
(defun decls-from-procls (ll procls body) |
(defun decls-from-procls (ll procls body) |
131 |
(cond ((or (null procls) (eq (car procls) '*) |
(cond ((or (null procls) (eq (car procls) '*) |
132 |
(null ll) (member (car ll) '(&whole &optional &rest &key &environment) :test #'eq)) nil) |
(null ll) (member (car ll) '(&whole &optional &rest &key &environment) :test #'eq)) nil) |
133 |
((or (var-is-declared (car ll) body) (eq (car procls) t)) |
((eq (car procls) t) |
134 |
(decls-from-procls (cdr ll) (cdr procls) body)) |
(decls-from-procls (cdr ll) (cdr procls) body)) |
135 |
(t |
(t |
136 |
(cons (list (car procls) (or (if (atom (car ll)) (car ll) (caar ll)))) |
(cons (list (car procls) (or (if (atom (car ll)) (car ll) (caar ll)))) |
145 |
(aux-inits nil) doc vl spec body ss is ts |
(aux-inits nil) doc vl spec body ss is ts |
146 |
other-decls vnames |
other-decls vnames |
147 |
(*vars* *vars*) |
(*vars* *vars*) |
|
(*decls* *decls*) |
|
148 |
(info (make-info)) |
(info (make-info)) |
149 |
(aux-info nil) |
(aux-info nil) |
150 |
(setjmps *setjmps*) |
(setjmps *setjmps*) |
153 |
(cmpck (endp lambda-expr) |
(cmpck (endp lambda-expr) |
154 |
"The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) |
"The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) |
155 |
|
|
156 |
|
|
157 |
|
;;FIXME -- this is backwards, as the proclamations should be |
158 |
|
;;generated from the declarations. What we need here and in the let |
159 |
|
;;code is reverse type propagation. CM 20050106 |
160 |
(let ((decls (decls-from-procls |
(let ((decls (decls-from-procls |
161 |
(car lambda-expr) |
(car lambda-expr) |
162 |
(and block-it (get block-name 'compiler::proclaimed-arg-types)) |
(and block-it (get block-name 'compiler::proclaimed-arg-types)) |
357 |
(add-info aux-info (cadr body)) |
(add-info aux-info (cadr body)) |
358 |
(setq body (list 'let* aux-info aux-vars aux-inits body)) |
(setq body (list 'let* aux-info aux-vars aux-inits body)) |
359 |
(or (eql setjmps *setjmps*) (setf (info-volatile aux-info) t))) |
(or (eql setjmps *setjmps*) (setf (info-volatile aux-info) t))) |
360 |
|
|
361 |
|
;;FIXME -- is above for aux needed too? |
362 |
|
(when (or optionals keywords) |
363 |
|
(or (eql setjmps *setjmps*) (setf (info-volatile info) t))) |
364 |
|
|
365 |
(setq body (fix-down-args requireds body block-name)) |
(setq body (fix-down-args requireds body block-name)) |
366 |
(setq lambda-list |
(setq lambda-list |
367 |
(list requireds optionals rest key-flag keywords allow-other-keys)) |
(list requireds optionals rest key-flag keywords allow-other-keys)) |
729 |
|
|
730 |
|
|
731 |
(defun c1dm (macro-name vl body |
(defun c1dm (macro-name vl body |
732 |
&aux (*vs* *vs*) (whole nil) (env nil) (*decls* *decls*) |
&aux (*vs* *vs*) (whole nil) (env nil) |
733 |
(setjmps *setjmps*) |
(setjmps *setjmps*) |
734 |
(*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil) |
(*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil) |
735 |
doc ss is ts other-decls ppn) |
doc ss is ts other-decls ppn) |
736 |
|
|