127 |
(unwind-exit (list 'make-dclosure (fun-cfun fun) *clink*)))) |
(unwind-exit (list 'make-dclosure (fun-cfun fun) *clink*)))) |
128 |
|
|
129 |
|
|
130 |
|
(defun decls-from-procls (ll procls body) |
131 |
|
(cond ((or (null procls) (eq (car procls) '*) |
132 |
|
(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)) |
134 |
|
(decls-from-procls (cdr ll) (cdr procls) body)) |
135 |
|
(t |
136 |
|
(cons (list (car procls) (or (if (atom (car ll)) (car ll) (caar ll)))) |
137 |
|
(decls-from-procls (cdr ll) (cdr procls) body))))) |
138 |
|
|
139 |
(defun c1lambda-expr (lambda-expr |
(defun c1lambda-expr (lambda-expr |
140 |
&optional (block-name nil block-it) |
&optional (block-name nil block-it) |
141 |
&aux (requireds nil) (optionals nil) (rest nil) |
&aux (requireds nil) (optionals nil) (rest nil) |
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*) |
148 |
|
(*decls* *decls*) |
149 |
(info (make-info)) |
(info (make-info)) |
150 |
(aux-info nil) |
(aux-info nil) |
151 |
(setjmps *setjmps*) |
(setjmps *setjmps*) |
152 |
) |
) |
153 |
|
|
154 |
(cmpck (endp lambda-expr) |
(cmpck (endp lambda-expr) |
155 |
"The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) |
"The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) |
156 |
|
|
157 |
|
(let ((decls (decls-from-procls |
158 |
|
(car lambda-expr) |
159 |
|
(and block-it (get block-name 'compiler::proclaimed-arg-types)) |
160 |
|
(cdr lambda-expr)))) |
161 |
|
(when decls |
162 |
|
(cmpnote "~S function args declared: ~S~%" block-name decls) |
163 |
|
(setq lambda-expr (cons (car lambda-expr) (cons (cons 'declare decls) (cdr lambda-expr)))))) |
164 |
|
|
165 |
(multiple-value-setq (body ss ts is other-decls doc) |
(multiple-value-setq (body ss ts is other-decls doc) |
166 |
(c1body (cdr lambda-expr) t)) |
(c1body (cdr lambda-expr) t)) |
167 |
|
|
722 |
|
|
723 |
|
|
724 |
(defun c1dm (macro-name vl body |
(defun c1dm (macro-name vl body |
725 |
&aux (*vs* *vs*) (whole nil) (env nil) |
&aux (*vs* *vs*) (whole nil) (env nil) (*decls* *decls*) |
726 |
(setjmps *setjmps*) |
(setjmps *setjmps*) |
727 |
(*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil) |
(*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil) |
728 |
doc ss is ts other-decls ppn) |
doc ss is ts other-decls ppn) |