Changeset 14417 in project for chicken


Ignore:
Timestamp:
04/24/09 16:15:46 (10 years ago)
Author:
felix winkelmann
Message:

blargl

Location:
chicken/branches/scrutiny
Files:
2 edited

Legend:

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

    r14416 r14417  
    231231                           (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2))))))))
    232232             ((procedure)
    233               (let ((name (and (not (pair? (cadr t))) (cadr t))))
     233              (let ((name (and (not (named? t)) (cadr t))))
    234234                `(procedure
    235235                  ,@(if name (list name) '())
     
    238238             (else t))
    239239           t))))
     240  (define (named? t)
     241    (and (pair? t)
     242         (eq? 'procedure (car t))
     243         (not (or (null? (cadr t)) (pair? (cadr t))))))
    240244  (define (match t1 t2)
    241245    (let ((m (match1 t1 t2)))
     
    250254          ((eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2))))
    251255          ((eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))))
     256          ((and (pair? t1) (eq? 'or (car t1))) (any (cut match <> t2) (cdr t1)))
     257          ((and (pair? t2) (eq? 'or (car t2))) (any (cut match t1 <>) (cdr t2)))
    252258          ((memq t1 '(pair list)) (memq t2 '(pair list)))
    253259          ((memq t1 '(null list)) (memq t2 '(null list)))
    254           (else
    255            (and (pair? t1) (pair? t2)
    256                 (cond ((and (eq? (car t1) 'or) (any (cut match <> t2))))
    257                       ((and (eq? (car t2) 'or) (any (cut match <> t2))))
    258                       (else
    259                        (or (eq? (car t1) (car t2))
    260                            (and (eq? 'procedure (car t1))
    261                                 (let ((args1 (if (pair? (second t1)) (second t1) (third t1)))
    262                                       (args2 (if (pair? (second t2)) (second t2) (third t2)))
    263                                       (results1 (if (pair? (second t2)) (cdddr t2) (cddr t2)))
    264                                       (results2 (if (pair? (second t2)) (cdddr t2) (cddr t2))) )
    265                                   (and (match-args args1 args2)
    266                                        (= (length results1) (length results2))
    267                                        (every match results1 results2))))
    268                            (and (eq? 'struct (car t1))
    269                                 (equal? t1 t2)))))))))
     260          ((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))
     261           (case (car t1)
     262             ((procedure)
     263              (let ((args1 (if (named? t1) (third t1) (second t1)))
     264                    (args2 (if (named? t2) (third t2) (second t2)))
     265                    (results1 (if (named? t1) (cdddr t1) (cddr t1)))
     266                    (results2 (if (named? t2) (cdddr t2) (cddr t2))) )
     267                (and (match-args args1 args2)
     268                     (match-results results1 results2))))
     269             ((struct) (equal? t1 t2))))))
    270270  (define (match-args args1 args2)
    271271    (d "match-args: ~s <-> ~s" args1 args2)
     
    281281      (memq a '(#!rest #!optional)))
    282282    (let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
     283      (d "  args ~a ~a ~a ~a" args1 args2 opt1 opt2)
    283284      (cond ((null? args1)
    284285             (or opt2
    285286                 (null? args2)
    286287                 (optargs (car args2))))
    287             ((null? args2) (or opt1 (optargs (car args2))))
     288            ((null? args2)
     289             (or opt1
     290                 (optargs (car args1))))
    288291            ((eq? '#!optional (car args1))
    289292             (loop (cdr args1) args2 #t opt2))
     
    296299            ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
    297300            (else #f))))
     301  (define (match-results results1 results2)
     302    (cond ((null? results1) (atom? results2))
     303          ((atom? results2))
     304          ((match (car results1) (car results2))
     305           (match-results (cdr results1) (cdr results2)))
     306          (else #f)))
    298307  (define (type<=? t1 t2)
    299308    (or (eq? t1 t2)
     
    467476          (params (node-parameters n))
    468477          (class (node-class n)) )
    469       (d "walk: ~a ~a (loc: ~a, dest: ~a, env: ~a)" class params loc dest e)
     478      (d "walk: ~a ~a (loc: ~a, dest: ~a)" class params loc dest)
    470479      (let ((results
    471480             (case class
  • chicken/branches/scrutiny/types.db

    r14416 r14417  
    129129(atan (procedure atan (number number) number))
    130130(number->string (procedure number->string (number #!optional number) string))
    131 (string->number (procedure string->number (string #!optional number) number))
     131(string->number (procedure string->number (string #!optional number) (or number boolean)))
    132132(char? (procedure char? (*) boolean))
    133133(char=? (procedure char=? (char char) boolean))
Note: See TracChangeset for help on using the changeset viewer.