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

Diff of /gcl/cmpnew/gcl_cmpeval.lsp

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

revision 1.18 by camm, Fri Dec 17 21:29:29 2004 UTC revision 1.19 by camm, Tue Dec 21 04:49:47 2004 UTC
# Line 191  Line 191 
191    
192  (defun result-type-from-args (f args &aux tem)  (defun result-type-from-args (f args &aux tem)
193    (when (and (setq tem (get f 'return-type))    (when (and (setq tem (get f 'return-type))
194               (not (eq tem '*))               (not (eq tem '*)))
195               (not (consp tem)))  ;            (not (consp tem))) ;; propagate multiple-value types, CM 20041221
196      (let* ((be (and (not (cddr args)) (get f 'result-type-from-bounded-args)))      (let* ((be (and (not (cddr args)) (get f 'result-type-from-bounded-args)))
197             (ba (and be             (ba (and be (funcall be f (car args) (cadr args)))))
                     (or (atom be)  
                         (and (type>= (nil-to-t (car be)) (car args))  
                              (type>= (nil-to-t (cadr be)) (cadr args))))  
                     (super-range f (car args) (cadr args)))))  
198        (when ba        (when ba
199          (return-from result-type-from-args ba)))          (return-from result-type-from-args ba)))
200      (dolist (v '(inline-always inline-unsafe))      (dolist (v '(inline-always inline-unsafe))
# Line 482  Line 478 
478          ((eq fname 'si:|#,|)          ((eq fname 'si:|#,|)
479           (cmperr "Sharp-comma-macro was found in a bad place."))           (cmperr "Sharp-comma-macro was found in a bad place."))
480          (t (let* ((info (make-info          (t (let* ((info (make-info
481                          :sp-change (null (get fname 'no-sp-change))))                           :sp-change (null (get fname 'no-sp-change))))
482                    (forms (c1args args info))) ;; info updated by args here                    (forms (c1args args info))) ;; info updated by args here
483               (let ((return-type (get-return-type fname)))               (let ((return-type (get-return-type fname)))
484                    (when return-type                 (when return-type
485                          (if (equal return-type '(*))                   (if (equal return-type '(*))
486                              (setf return-type nil)                       (setf return-type nil)
487                          (setf (info-type info) return-type))))                     (setf (info-type info) return-type))))
488                  (let ((arg-types (get-arg-types fname)))               (let ((arg-types (get-arg-types fname)))
489                       ;;; Add type information to the arguments.                       ;;; Add type information to the arguments.
490                       (when arg-types                 (when arg-types
491                         (do ((fl forms (cdr fl))                   (do ((fl forms (cdr fl))
492                              (fl1 nil)                        (fl1 nil)
493                              (al args (cdr al)))                        (al args (cdr al)))
494                             ((endp fl)                       ((endp fl)
495                              (setq forms (reverse fl1)))                        (setq forms (reverse fl1)))
496                             (cond ((endp arg-types) (push (car fl) fl1))                     (cond ((endp arg-types) (push (car fl) fl1))
497                                   (t (push (and-form-type (car arg-types)                           (t (push (and-form-type (car arg-types)
498                                                           (car fl)                                                   (car fl)
499                                                           (car al))                                                   (car al))
500                                            fl1)                                    fl1)
501                                      (pop arg-types))))))                              (pop arg-types))))))
502                  (let ((arg-types (get fname 'arg-types)))               (let ((arg-types (get fname 'arg-types)))
503                       ;;; Check argument types.                       ;;; Check argument types.
504                       (when arg-types                 (when arg-types
505                             (do ((fl forms (cdr fl))                   (do ((fl forms (cdr fl))
506                                  (al args (cdr al)))                        (al args (cdr al)))
507                                 ((or (endp arg-types) (endp fl)))                       ((or (endp arg-types) (endp fl)))
508                                 (check-form-type (car arg-types)                     (check-form-type (car arg-types)
509                                                  (car fl) (car al))                                      (car fl) (car al))
510                                 (pop arg-types))))                     (pop arg-types))))
511                  (case fname               (case fname
512                        (aref                 (aref
513                         (let ((etype (info-type (cadar forms))))                  (let ((etype (info-type (cadar forms))))
514                              (when (or (and (eq etype 'string)                    (when (or (and (eq etype 'string)
515                                             (setq etype 'character))                                   (setq etype 'character))
516                                        (and (consp etype)                              (and (consp etype)
517                                             (or (eq (car etype) 'array)                                   (or (eq (car etype) 'array)
518                                                 (eq (car etype) 'vector))                                       (eq (car etype) 'vector))
519                                             (setq etype (cadr etype))))                                   (setq etype (cadr etype))))
520                                    (setq etype                      (setq etype
521                                          (type-and (info-type info) etype))                            (type-and (info-type info) etype))
522                                    (when (null etype)                      (when (null etype)
523                                      (cmpwarn                        (cmpwarn
524                                           "Type mismatch was found in ~s."                         "Type mismatch was found in ~s."
525                                           (cons fname args)))                         (cons fname args)))
526                                    (setf (info-type info) etype))))                      (setf (info-type info) etype))))
527                        (si:aset                 (si:aset
528                         (let ((etype (info-type (cadar forms))))                  (let ((etype (info-type (cadar forms))))
529                              (when (or (and (eq etype 'string)                    (when (or (and (eq etype 'string)
530                                             (setq etype 'character))                                   (setq etype 'character))
531                                        (and (consp etype)                              (and (consp etype)
532                                             (or (eq (car etype) 'array)                                   (or (eq (car etype) 'array)
533                                                 (eq (car etype) 'vector))                                       (eq (car etype) 'vector))
534                                             (setq etype (cadr etype))))                                   (setq etype (cadr etype))))
535                                    (setq etype                      (setq etype
536                                          (type-and (info-type info)                            (type-and (info-type info)
537                                            (type-and (info-type                                      (type-and (info-type
538                                                       (cadar (last forms)))                                                 (cadar (last forms)))
539                                                      etype)))                                                etype)))
540                                    (when (null etype)                      (when (null etype)
541                                          (cmpwarn                        (cmpwarn
542                                           "Type mismatch was found in ~s."                         "Type mismatch was found in ~s."
543                                           (cons fname args)))                         (cons fname args)))
544                                    (setf (info-type info) etype)                      (setf (info-type info) etype)
545                                    (setf (info-type (cadar (last forms)))                      (setf (info-type (cadar (last forms)))
546                                          etype)                            etype)
547                                    ))))                      ))))
548                  ;; some functions can have result type deduced from               ;; some functions can have result type deduced from
549                  ;; arg types.               ;; arg types.
550                
551                  (let ((tem (result-type-from-args fname               (let ((tem (result-type-from-args fname
552                                                    (mapcar #'(lambda (x) (info-type (cadr x)))                                                 (mapcar #'(lambda (x) (info-type (cadr x)))
553                                                            forms))))                                                         forms))))
554                            (when tem                 (when tem
555                              (setq tem (type-and tem (info-type info)))                   (setq tem (type-and tem (info-type info)))
556                              (setf (info-type info) tem)))                   (setf (info-type info) tem)))
557                  (list 'call-global info fname forms)))               (list 'call-global info fname forms)))
558          )          )
559    )    )
560    

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.19

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