Ignore:
Timestamp:
05/06/09 00:00:08 (11 years ago)
Author:
felix winkelmann
Message:

more types; scrutiny bugfixes; integrated scrutiny of core libs into build; -types option

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/scrutinizer.scm

    r14525 r14529  
    7373  (printf "[debug] ~?~%" fstr args))
    7474
    75 ;(define-syntax d (syntax-rules () ((_ . _) (void))))
     75(define-syntax d (syntax-rules () ((_ . _) (void))))
    7676
    7777
     
    211211           (case (car t)
    212212             ((or)
    213               (if (= 2 (length t))
    214                   (simplify (second t))
    215                   (let* ((ts (append-map
    216                               (lambda (t)
    217                                 (let ((t (simplify t)))
    218                                   (cond ((and (pair? t) (eq? 'or (car t)))
    219                                          (cdr t))
    220                                         ((eq? 'noreturn t) '())
    221                                         ((eq? t 'undefined) (return 'undefined))
    222                                         (else (list t)))))
    223                               (cdr t)))
    224                          (ts2 (let loop ((ts ts))
    225                                 (cond ((null? ts) '())
    226                                       ((eq? '* (car ts)) (return '*))
    227                                       ((any (cut type<=? (car ts) <>) (cdr ts))
    228                                        (loop (cdr ts)))
    229                                       (else (cons (car ts) (loop (cdr ts))))))))
    230                     (cond ((equal? ts2 (cdr t)) t)
    231                           (else
    232                            (d "  or-simplify: ~a" ts2)
    233                            (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2))))))))
     213              (cond ((= 2 (length t)) (simplify (second t)))
     214                    ((every procedure-type? (cdr t))
     215                     (if (any (cut eq? 'procedure <>) (cdr t))
     216                         'procedure
     217                         (reduce
     218                          (lambda (t pt)
     219                            (let* ((name1 (and (named? t) (cadr t)))
     220                                   (atypes1 (if name1 (third t) (second t)))
     221                                   (rtypes1 (if name1 (cdddr t) (cddr t)))
     222                                   (name2 (and (named? pt) (cadr pt)))
     223                                   (atypes2 (if name1 (third pt) (second pt)))
     224                                   (rtypes2 (if name1 (cdddr pt) (cddr pt))))
     225                              `(procedure
     226                                ,@(if (eq? name1 name2) (list name1) '())
     227                                ,(merge-argument-types atypes1 atypes2)
     228                                ,@(merge-result-types rtypes1 rtypes2))))
     229                          #f
     230                          (cdr t))))
     231                    (else
     232                     (let* ((ts (append-map
     233                                 (lambda (t)
     234                                   (let ((t (simplify t)))
     235                                     (cond ((and (pair? t) (eq? 'or (car t)))
     236                                            (cdr t))
     237                                           ((eq? 'noreturn t) '())
     238                                           ((eq? t 'undefined) (return 'undefined))
     239                                           (else (list t)))))
     240                                 (cdr t)))
     241                            (ts2 (let loop ((ts ts))
     242                                   (cond ((null? ts) '())
     243                                         ((eq? '* (car ts)) (return '*))
     244                                         ((any (cut type<=? (car ts) <>) (cdr ts))
     245                                          (loop (cdr ts)))
     246                                         (else (cons (car ts) (loop (cdr ts))))))))
     247                       (cond ((equal? ts2 (cdr t)) t)
     248                             (else
     249                              (d "  or-simplify: ~a" ts2)
     250                              (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) )
    234251             ((procedure)
    235252              (let* ((name (and (named? t) (cadr t)))
     
    247264         (eq? 'procedure (car t))
    248265         (not (or (null? (cadr t)) (pair? (cadr t))))))
     266  (define (merge-argument-types ts1 ts2)
     267    (cond ((null? ts1)
     268           (cond ((null? ts2) '())
     269                 ((memq (car ts2) '(#!rest #!optional)) ts2)
     270                 (else '(#!rest))))
     271          ((eq? '#!rest (car ts1))
     272           (cond ((eq? '#!rest (car ts2))
     273                  `(#!rest
     274                    ,(simplify
     275                      `(or ,(if (pair? (cdr ts1)) (cadr ts1) '*)
     276                           ,(if (pair? (cdr ts2)) (cadr ts2) '*)))))
     277                 (else '(#!rest))))             ;XXX giving up
     278          ((eq? '#!optional (car ts1))
     279           (cond ((eq? '#!optional (car ts2))
     280                  `(#!optional
     281                    ,(simplify `(or ,(cadr ts1) ,(cadr ts2)))
     282                    ,@(merge-argument-types (cddr ts1) (cddr ts2))))
     283                 (else '(#!rest))))     ;XXX
     284          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
     285                      (merge-argument-types (cdr ts1) (cdr ts2))))))
     286  (define (merge-result-types ts1 ts2)  ;XXX possibly overly conservative
     287    (cond ((null? ts1) ts2)
     288          ((null? ts2) ts1)
     289          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
     290                      (merge-result-types (cdr ts1) (cdr ts2))))))
    249291  (define (match t1 t2)
    250292    (let ((m (match1 t1 t2)))
     
    446488  (define (procedure-type? t)
    447489    (or (eq? 'procedure t)
    448         (and (pair? t) (eq? 'procedure (car t)))))
     490        (and (pair? t)
     491             (or (eq? 'procedure (car t))
     492                 (and (eq? 'or (car t))
     493                      (every procedure-type? (cdr t)))))))
    449494  (define (procedure-argument-types t n)
    450495    (cond ((or (memq t '(* procedure))
     
    466511                   ((and opt (<= m 0)) '())
    467512                   (else (cons (car at) (loop (cdr at) (sub1 m) opt))))))
    468           (else (bomb "not a procedure type: ~a" t))))
     513          (else (bomb "not a procedure type" t))))
    469514  (define (procedure-result-types t)
    470515    (cond ((or (memq t '(* procedure))
     
    555600  (walk (first (node-subexpressions node)) '() '() #f))
    556601
    557 (define (load-type-database name)
    558   (and-let* ((rp (repository-path))
    559              (dbfile (file-exists? (make-pathname rp name))))
     602(define (load-type-database name #!optional (path (repository-path)))
     603  (and-let* ((dbfile (file-exists? (make-pathname path name))))
    560604    (when verbose-mode
    561605      (printf "loading type database ~a ...~%" dbfile))
    562606    (for-each
    563607     (lambda (e)
    564        (##sys#put! (car e) '##core#type (cadr e)))
     608       (let* ((name (car e))
     609              (old (##sys#get name '##core#type))
     610              (new (cadr e)))
     611         (when (and old (not (equal? old new)))
     612           (compiler-warning
     613            'scrutiny
     614            "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
     615            name new old))
     616         (##sys#put! name '##core#type new)))
    565617     (read-file dbfile))))
    566618
Note: See TracChangeset for help on using the changeset viewer.