/[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.8 by camm, Tue Dec 28 22:24:18 2004 UTC revision 1.9 by camm, Fri Jan 7 17:58:33 2005 UTC
# Line 130  Line 130 
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))))
# Line 145  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*)
                            (*decls* *decls*)  
148                             (info (make-info))                             (info (make-info))
149                             (aux-info nil)                             (aux-info nil)
150                             (setjmps *setjmps*)                             (setjmps *setjmps*)
# Line 154  Line 153 
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))
# Line 354  Line 357 
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))
# Line 722  Line 729 
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    

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

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