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

Diff of /gcl/cmpnew/gcl_cmpmulti.lsp

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

revision 1.11 by camm, Fri Jan 7 17:58:33 2005 UTC revision 1.12 by camm, Wed Jun 29 04:19:11 2005 UTC
# Line 47  Line 47 
47           (let ((*value-to-go* 'top)) (c2expr* (car forms)))           (let ((*value-to-go* 'top)) (c2expr* (car forms)))
48           (c2funcall funob 'args-pushed loc))           (c2funcall funob 'args-pushed loc))
49          (t          (t
50           (setq top (next-cvar))           (setq top (cs-push t t))
51           (setq sup (next-cvar))           (setq sup (cs-push t t))
52           (setq loc (save-funob funob))           (setq loc (save-funob funob))
53           (base-used)           (base-used)
54           ;; Add (sup .var) handling in unwind-exit -- in           ;; Add (sup .var) handling in unwind-exit -- in
# Line 81  Line 81 
81  ;; We may record information here when *value-to-go* = 'top  ;; We may record information here when *value-to-go* = 'top
82  (defvar *top-data* nil)  (defvar *top-data* nil)
83    
84  (defun c2multiple-value-prog1 (form forms &aux (base (next-cvar))  (defun c2multiple-value-prog1 (form forms &aux (base (cs-push t t))
85                                                 (top (next-cvar))                                                 (top (cs-push t t))
86                                                 (sup (next-cvar))                                                 (sup (cs-push t t))
87                                                 top-data)                                                 top-data)
88    (let ((*value-to-go* 'top)    (let ((*value-to-go* 'top)
89          *top-data* )          *top-data* )
# Line 214  Line 214 
214    
215    
216  ;;FIXME -- this still uses pass1, while let for performance reasons uses custom change-detection code.  ;;FIXME -- this still uses pass1, while let for performance reasons uses custom change-detection code.
217  (defun declare-multiple-value-bindings (args)  (defun declare-multiple-value-bindings (args specials)
218    (let ((info (make-info))    (let ((info (make-info))
219          (newvars *vars*))          (newvars *vars*))
220      (dolist (var (car args))      (dolist (var (car args))
# Line 228  Line 228 
228                                      (list (list expt (caar args)))) :key #'car)))                                      (list (list expt (caar args)))) :key #'car)))
229          (let ((decls (remove-if          (let ((decls (remove-if
230                        (lambda (x)                        (lambda (x)
231                          (let ((nv (car (member x newvars :key #'var-name :test #'eq))))                          (or (si::specialp x) (member x specials)
232                            (when (is-changed nv info)                              (let ((nv (car (member x newvars :key #'var-name :test #'eq))))
233                              (cmpnote "Multiple-value-binding ~S is changed and cannot be declared~%" x)                                (when (is-changed nv info)
234                              t))) decls :key #'cadr)))                                  (cmpnote "Multiple-value-binding ~S is changed and cannot be declared~%" x)
235                                    t)))) decls :key #'cadr)))
236            (if decls            (if decls
237                (progn (cmpnote "Multiple-value bindings ~S of type ~S~%" (car args) decls )                (progn (cmpnote "Multiple-value bindings ~S of type ~S~%" (car args) decls )
238                       (cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args)))))                       (cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args)))))
# Line 297  Line 298 
298    (when (or (endp args) (endp (cdr args)))    (when (or (endp args) (endp (cdr args)))
299      (too-few-args 'multiple-value-bind 2 (length args)))      (too-few-args 'multiple-value-bind 2 (length args)))
300    
301    (setq args (declare-multiple-value-bindings args))    (setq args (declare-multiple-value-bindings args ss))
302    
303    (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil))    (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil))
304    
# Line 337  Line 338 
338      (let ((kind (c2var-kind var)))      (let ((kind (c2var-kind var)))
339           (declare (object kind))           (declare (object kind))
340        (if kind        (if kind
341            (let ((cvar (next-cvar)))            (let ((cvar (cs-push (var-type var) t)))
342              (setf (var-kind var) kind)              (setf (var-kind var) kind)
343              (setf (var-loc var) cvar)              (setf (var-loc var) cvar)
344              (wt-nl)              (wt-nl)

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

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