/[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.7 by camm, Sat Dec 11 00:34:35 2004 UTC revision 1.8 by camm, Tue Dec 21 04:49:47 2004 UTC
# Line 157  Line 157 
157            (push var vrefs)            (push var vrefs)
158            (push-changed (car var) info)            (push-changed (car var) info)
159            )            )
160      (setf (info-type info) (type-and (info-type (cadar (c1args (car args) info)))
161                                       (info-type (cadar (c1args (cdr args) info)))))
162    (list 'multiple-value-setq info (reverse vrefs) (c1expr* (cadr args) info))    (list 'multiple-value-setq info (reverse vrefs) (c1expr* (cadr args) info))
163    )    )
164    
# Line 203  Line 205 
205          (t (unless (eq *exit* 'return) (wt-nl) (reset-top))          (t (unless (eq *exit* 'return) (wt-nl) (reset-top))
206             (unwind-exit (cons 'var (car vrefs))))))             (unwind-exit (cons 'var (car vrefs))))))
207    
208    (defun form-to-values-type (form)
209      (if (and (consp form) (eq (car form) 'values)) form
210        (let ((frt (fun-ret-type form)))
211          (if (and (consp frt) (eq (car frt) 'values)) frt
212            (list 'values frt)))))
213    
214    (defun multiple-binding-decls (vars mv-form body &optional expn vls)
215      (cond ((and (not expn) (not vls) (not (eq (car mv-form) 'values)) (symbolp (car mv-form)))
216             (let ((mv-form (form-to-values-type mv-form)))
217               (multiple-binding-decls vars mv-form body t vls)))
218            ((eq (car mv-form) 'values)
219             (multiple-binding-decls vars (cdr mv-form) body expn t))
220            ((or (null vars) (null mv-form)) nil)
221            (t
222             (let ((var (car vars)))
223               (let ((outer (and (symbolp (car mv-form)) (cdr (assoc (car mv-form) *decls*))))
224                     (inf (t-to-nil (var-is-inferred var body)))
225                     (exp (and (consp (car mv-form)) (eq (caar mv-form) 'the) (cadar mv-form)))
226                     (typ (and expn (t-to-nil (car mv-form))))
227                     (frt (and (consp (car mv-form))
228                               (symbolp (caar mv-form))
229                               (t-to-nil (coerce-to-one-value (fun-ret-type (car mv-form))))))
230                     (dec (var-is-declared var body))
231                     (chb (var-is-changed var body)))
232                 (let ((type (or exp typ frt inf outer))
233                       (ublk (not (or dec chb))))
234                   (if type
235                       (progn
236                         (cmpnote "var ~S is type ~S from ~a, ~a~%"
237                                  var type (cond (exp "explicit declaration")
238                                                 (typ "deduced multiple-value function return type")
239                                                 (frt "deduced function return type")
240                                                 (inf "argument inference")
241                                                 (outer "outer scope"))
242                                  (cond (dec "but is already declared")
243                                        (chb "but is changed in body")
244                                        (t "declaring")))
245                         (if ublk
246                             (cons (list type var)
247                                   (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))
248                           (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)))
249                     (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))))))))
250    
251      
252    
253    
254    (defun declare-multiple-value-bindings (args)
255      (let ((decls (multiple-binding-decls
256                    (car args)
257                    (recursively-cmp-macroexpand (cadr args))
258                    (recursively-cmp-macroexpand (cddr args)))))
259        (if decls
260            (progn (cmpnote "multiple-value bindings ~S ~S declared ~S~%" (car args) (cadr args) decls)
261                   (cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args)))))
262          args)))
263    
264    
265  (defun c1multiple-value-bind (args &aux (info (make-info))  (defun c1multiple-value-bind (args &aux (info (make-info))
266                                     (vars nil) (vnames nil) init-form                                     (vars nil) (vnames nil) init-form
267                                     ss is ts body other-decls                                     ss is ts body other-decls
# Line 210  Line 269 
269    (when (or (endp args) (endp (cdr args)))    (when (or (endp args) (endp (cdr args)))
270      (too-few-args 'multiple-value-bind 2 (length args)))      (too-few-args 'multiple-value-bind 2 (length args)))
271    
272      (setq args (declare-multiple-value-bindings args))
273    
274    (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))
275    
276    (c1add-globals ss)    (c1add-globals ss)

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

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