/[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.10 by camm, Tue Dec 28 22:24:18 2004 UTC revision 1.11 by camm, Fri Jan 7 17:58:33 2005 UTC
# Line 123  Line 123 
123               ;; so if we know there's one value only:               ;; so if we know there's one value only:
124               (c1expr (car args)))               (c1expr (car args)))
125              (t  (setq args (c1args args info))              (t  (setq args (c1args args info))
126                (list 'values info args))))                  (setf (info-type info) (cons 'values (mapcar (lambda (x) (info-type (cadr x))) args)))
127                    (list 'values info args))))
128    
129  (defun c2values (forms &aux (base *vs*) (*vs* *vs*))  (defun c2values (forms &aux (base *vs*) (*vs* *vs*))
130       (cond ((and (eq *value-to-go* 'return-object)       (cond ((and (eq *value-to-go* 'return-object)
# Line 205  Line 206 
206          (t (unless (eq *exit* 'return) (wt-nl) (reset-top))          (t (unless (eq *exit* 'return) (wt-nl) (reset-top))
207             (unwind-exit (cons 'var (car vrefs))))))             (unwind-exit (cons 'var (car vrefs))))))
208    
209  (defun form-to-values-type (form)  ;(defun form-to-values-type (form)
210    (if (and (consp form) (eq (car form) 'values)) form  ;  (if (and (consp form) (eq (car form) 'values)) form
211      (let ((frt (info-type (cadr (c1symbol-fun (car form) (cdr form))))))  ;    (let ((frt (info-type (cadr (c1symbol-fun (car form) (cdr form))))))
212        (if (and (consp frt) (eq (car frt) 'values)) frt  ;      (if (and (consp frt) (eq (car frt) 'values)) frt
213          (list 'values frt)))))  ;       (list 'values frt)))))
   
 (defun multiple-binding-decls (vars mv-form body &optional expn vls)  
   (cond ((and (not expn) (not vls) (not (eq (car mv-form) 'values)) (symbolp (car mv-form)))  
          (let ((mv-form (form-to-values-type mv-form)))  
            (multiple-binding-decls vars mv-form body t vls)))  
         ((eq (car mv-form) 'values)  
          (multiple-binding-decls vars (cdr mv-form) body expn t))  
         ((or (null vars) (null mv-form)) nil)  
         (t  
          (let ((var (car vars)))  
            (let ((outer (and (not expn) (symbolp (car mv-form)) (cdr (assoc (car mv-form) *decls*))))  
                  (inf (t-to-nil (var-is-inferred var body)))  
                  (exp (and (not expn) (consp (car mv-form)) (eq (caar mv-form) 'the) (cadar mv-form)))  
                  (typ (and expn (t-to-nil (car mv-form))))  
                  (frt (and (not expn) (consp (car mv-form))  
                            (symbolp (caar mv-form))  
                            (t-to-nil  
                             (coerce-to-one-value  
                              (info-type  
                               (cadr  
                                (c1symbol-fun (caar mv-form) (cdar mv-form))))))))  
                  (dec (var-is-declared var body))  
                  (chb (var-is-changed var body)))  
              (let ((type (or exp typ frt inf outer))  
                    (ublk (not (or chb))))  
                (if type  
                    (progn  
                      (cmpnote "var ~S is type ~S from ~a, ~a~%"  
                               var type (cond (exp "explicit declaration")  
                                              (typ "deduced multiple-value function return type")  
                                              (frt "deduced function return type")  
                                              (inf "argument inference")  
                                              (outer "outer scope"))  
                               (cond (dec "is already declared, but amending declaration")  
                                     (chb "but is changed in body")  
                                     (t "declaring")))  
                      (if ublk  
                          (cons (list type var)  
                                (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))  
                        (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)))  
                  (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))))))))  
   
     
214    
215    
216    ;;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)
218    (let ((decls (multiple-binding-decls    (let ((info (make-info))
219                  (car args)          (newvars *vars*))
220                  (recursively-cmp-macroexpand (cadr args))      (dolist (var (car args))
221                  (recursively-cmp-macroexpand (cddr args)))))        (push (c1make-var var nil nil nil) newvars))
222      (if decls      (let ((*vars* newvars))
223          (progn (cmpnote "multiple-value bindings ~S ~S declared ~S~%" (car args) (cadr args) decls)        (c1args (c1body (cddr args) nil) info))
224                 (cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args)))))      (let ((expt (info-type (cadr (c1expr (cadr args))))))
225        args)))        (let ((decls (remove-if-not #'t-to-nil
226                                      (if (and (consp expt) (eq (car expt) 'values))
227                                          (mapcar #'list (cdr expt) (car args))
228                                        (list (list expt (caar args)))) :key #'car)))
229            (let ((decls (remove-if
230                          (lambda (x)
231                            (let ((nv (car (member x newvars :key #'var-name :test #'eq))))
232                              (when (is-changed nv info)
233                                (cmpnote "Multiple-value-binding ~S is changed and cannot be declared~%" x)
234                                t))) decls :key #'cadr)))
235              (if decls
236                  (progn (cmpnote "Multiple-value bindings ~S of type ~S~%" (car args) decls )
237                         (cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args)))))
238                args))))))
239    
240    ;(defun multiple-binding-decls (vars mv-form body &optional expn vls)
241    ;  (cond ((and (not expn) (not vls) (not (eq (car mv-form) 'values)) (symbolp (car mv-form)))
242    ;        (let ((mv-form (form-to-values-type mv-form)))
243    ;          (multiple-binding-decls vars mv-form body t vls)))
244    ;       ((eq (car mv-form) 'values)
245    ;        (multiple-binding-decls vars (cdr mv-form) body expn t))
246    ;       ((or (null vars) (null mv-form)) nil)
247    ;       (t
248    ;        (let ((var (car vars)))
249    ;          (let ((outer (var-type-from-symbol-name (car mv-form)))
250    ;                (inf (t-to-nil (var-is-inferred var body)))
251    ;                (exp (and (not expn) (consp (car mv-form)) (eq (caar mv-form) 'the) (cadar mv-form)))
252    ;                (typ (and expn (t-to-nil (car mv-form))))
253    ;                (frt (and (not expn) (consp (car mv-form))
254    ;                          (symbolp (caar mv-form))
255    ;                          (t-to-nil
256    ;                           (coerce-to-one-value
257    ;                            (info-type
258    ;                             (cadr
259    ;                              (c1symbol-fun (caar mv-form) (cdar mv-form))))))))
260    ;                (dec (var-is-declared var body))
261    ;                (chb (var-is-changed var body)))
262    ;            (let ((type (or exp typ frt inf outer))
263    ;                  (ublk (not (or chb))))
264    ;              (if type
265    ;                  (progn
266    ;                    (cmpnote "var ~S is type ~S from ~a, ~a~%"
267    ;                             var type (cond (exp "explicit declaration")
268    ;                                            (typ "deduced multiple-value function return type")
269    ;                                            (frt "deduced function return type")
270    ;                                            (inf "argument inference")
271    ;                                            (outer "outer scope"))
272    ;                             (cond (dec "is already declared, but amending declaration")
273    ;                                   (chb "but is changed in body")
274    ;                                   (t "declaring")))
275    ;                    (if ublk
276    ;                        (cons (list type var)
277    ;                              (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))
278    ;                      (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls)))
279    ;                (multiple-binding-decls (cdr vars) (cdr mv-form) body expn vls))))))))
280    
281    
282    ;(defun declare-multiple-value-bindings (args)
283    ;  (let ((decls (multiple-binding-decls
284    ;               (car args)
285    ;               (recursively-cmp-macroexpand (cadr args))
286    ;               (recursively-cmp-macroexpand (cddr args)))))
287    ;    (if decls
288    ;       (progn (cmpnote "multiple-value bindings ~S ~S declared ~S~%" (car args) (cadr args) decls)
289    ;              (cons (car args) (cons (cadr args) (cons (cons 'declare decls) (cddr args)))))
290    ;      args)))
291    
292    
293  (defun c1multiple-value-bind (args &aux (info (make-info))  (defun c1multiple-value-bind (args &aux (info (make-info))
294                                     (vars nil) (vnames nil) init-form                                     (vars nil) (vnames nil) init-form
295                                     ss is ts body other-decls                                     ss is ts body other-decls
296                                     (*vars* *vars*) (*decls* *decls*))                                     (*vars* *vars*))
297    (when (or (endp args) (endp (cdr args)))    (when (or (endp args) (endp (cdr args)))
298      (too-few-args 'multiple-value-bind 2 (length args)))      (too-few-args 'multiple-value-bind 2 (length args)))
299    

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

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