/[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.5 by camm, Sat Mar 20 17:42:13 2004 UTC revision 1.6 by camm, Thu Sep 16 21:08:18 2004 UTC
# Line 175  Line 175 
175                  (cmpwarn "~A was proclaimed to have only one return value. ~%;But you appear to want multiple values." fname))))))                  (cmpwarn "~A was proclaimed to have only one return value. ~%;But you appear to want multiple values." fname))))))
176                                    
177  (defun c2multiple-value-setq (vrefs form &aux top-data)  (defun c2multiple-value-setq (vrefs form &aux top-data)
178      (multiple-value-check vrefs form)  
179    (let ((*value-to-go* 'top)*top-data*)    (multiple-value-check vrefs form)
180      (c2expr* form) (setq top-data *top-data*))  
181    (and *record-call-info* (record-call-info nil (car top-data)))    (let ((exit-label (next-label)))
182    (do ((vs vrefs (cdr vs)))      (let ((*multiple-value-exit-label* exit-label)
183        ((endp vs))            (*value-to-go* (or (mapcar (lambda (x) (list 'var (car x) nil)) vrefs) 'trash))
184              *top-data*)
185          (c2expr* form) (setq top-data *top-data*))
186        (and *record-call-info* (record-call-info nil (car top-data)))
187        (do ((vs vrefs (cdr vs)))
188            ((endp vs))
189        (declare (object vs))        (declare (object vs))
190        (let ((vref (car vs)))        (let ((vref (car vs)))
191             (declare (object vref))          (declare (object vref))
192             (wt-nl "if(vs_base<vs_top){")          (wt-nl "if(vs_base<vs_top){")
193             (set-var 'fun-val (car vref) (cadr vref))          (set-var 'fun-val (car vref) (cadr vref))
194             (unless (endp (cdr vs)) (wt-nl "vs_base++;"))          (unless (endp (cdr vs)) (wt-nl "vs_base++;"))
195             (wt-nl "}else{") (set-var nil (car vref) (cadr vref))          (wt-nl "}else{") (set-var nil (car vref) (cadr vref))
196             (wt "}"))          (wt "}")))
197        )    
198        (wt-label exit-label))
199    
200    (cond ((null vrefs)    (cond ((null vrefs)
201           (wt-nl "if(vs_base=vs_top){vs_base[0]=Cnil;vs_top=vs_base+1;}")           (wt-nl "if(vs_base==vs_top){vs_base[0]=Cnil;vs_top=vs_base+1;}")
202           (unwind-exit 'fun-val))           (unwind-exit 'fun-val))
203          (t (unless (eq *exit* 'return) (wt-nl) (reset-top))          (t (unless (eq *exit* 'return) (wt-nl) (reset-top))
204             (unwind-exit (cons 'var (car vrefs)))))             (unwind-exit (cons 'var (car vrefs))))))
   )  
205    
206  (defun c1multiple-value-bind (args &aux (info (make-info))  (defun c1multiple-value-bind (args &aux (info (make-info))
207                                     (vars nil) (vnames nil) init-form                                     (vars nil) (vnames nil) init-form
# Line 251  Line 257 
257              )              )
258            (setf (var-ref var) (vs-push)))))            (setf (var-ref var) (vs-push)))))
259    
260    (let ((*value-to-go* 'top) *top-data*)    (dotimes (i (1+ (length vars))) (push (next-label) labels))
261      
262      (let* ((*multiple-value-exit-label* (car labels))
263             (*value-to-go* (or (mapcar (lambda (x) (list 'var x nil)) vars) 'trash))
264             *top-data*)
265      (c2expr* init-form) (setq top-data *top-data*))      (c2expr* init-form) (setq top-data *top-data*))
266    (and *record-call-info* (record-call-info nil (car top-data)))    (and *record-call-info* (record-call-info nil (car top-data)))
267    
268      (setq labels (reverse labels))
269    
270    (let ((*clink* *clink*)    (let ((*clink* *clink*)
271          (*unwind-exit* *unwind-exit*)          (*unwind-exit* *unwind-exit*)
272          (*ccb-vs* *ccb-vs*))          (*ccb-vs* *ccb-vs*))
273      (do ((vs vars (cdr vs)))      (do ((vs vars (cdr vs)) (labels labels (cdr labels)))
274          ((endp vs))          ((endp vs)(wt-nl)(reset-top)(wt-go (car labels)))
275          (declare (object vs))        (declare (object vs))
       (push (next-label) labels)  
276        (wt-nl "if(vs_base>=vs_top){")        (wt-nl "if(vs_base>=vs_top){")
277        (reset-top)        (reset-top)
278        (wt-go (car labels)) (wt "}")        (wt-go (car labels)) (wt "}")
279        (c2bind-loc (car vs) '(vs-base 0))        (c2bind-loc (car vs) '(vs-base 0))
280        (unless (endp (cdr vs)) (wt-nl "vs_base++;"))))        (unless (endp (cdr vs)) (wt-nl "vs_base++;"))))
281      
282    (wt-nl) (reset-top)    (dolist** (v vars)
283                (wt-label (car labels))
284    (let ((label (next-label)))              (pop labels)
285      (wt-nl) (wt-go label)              (c2bind-loc v nil))
286      
287      (setq labels (reverse labels))    (wt-label (car labels))
288      
     (dolist** (v vars)  
       (wt-label (car labels))  
       (pop labels)  
       (c2bind-loc v nil))  
   
     (wt-label label))  
   
289    (c2expr body)    (c2expr body)
290    (when block-p (wt "}"))    (when block-p (wt "}")))
   )  

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

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