/[gcl]/gcl/cmpnew/gcl_cmplam.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmplam.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by camm, Wed Jul 14 18:35:33 2004 UTC revision 1.7 by camm, Sat Dec 11 00:34:35 2004 UTC
# Line 127  Line 127 
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)
# Line 137  Line 145 
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        
# Line 704  Line 722 
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)

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26