Changeset 14417 in project
 Timestamp:
 04/24/09 16:15:46 (11 years ago)
 Location:
 chicken/branches/scrutiny
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

chicken/branches/scrutiny/scrutinizer.scm
r14416 r14417 231 231 (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) 232 232 ((procedure) 233 (let ((name (and (not ( pair? (cadr t))) (cadr t))))233 (let ((name (and (not (named? t)) (cadr t)))) 234 234 `(procedure 235 235 ,@(if name (list name) '()) … … 238 238 (else t)) 239 239 t)))) 240 (define (named? t) 241 (and (pair? t) 242 (eq? 'procedure (car t)) 243 (not (or (null? (cadr t)) (pair? (cadr t)))))) 240 244 (define (match t1 t2) 241 245 (let ((m (match1 t1 t2))) … … 250 254 ((eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2)))) 251 255 ((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))) 252 258 ((memq t1 '(pair list)) (memq t2 '(pair list))) 253 259 ((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 (matchargs 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 (matchargs args1 args2) 268 (matchresults results1 results2)))) 269 ((struct) (equal? t1 t2)))))) 270 270 (define (matchargs args1 args2) 271 271 (d "matchargs: ~s <> ~s" args1 args2) … … 281 281 (memq a '(#!rest #!optional))) 282 282 (let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f)) 283 (d " args ~a ~a ~a ~a" args1 args2 opt1 opt2) 283 284 (cond ((null? args1) 284 285 (or opt2 285 286 (null? args2) 286 287 (optargs (car args2)))) 287 ((null? args2) (or opt1 (optargs (car args2)))) 288 ((null? args2) 289 (or opt1 290 (optargs (car args1)))) 288 291 ((eq? '#!optional (car args1)) 289 292 (loop (cdr args1) args2 #t opt2)) … … 296 299 ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2)) 297 300 (else #f)))) 301 (define (matchresults results1 results2) 302 (cond ((null? results1) (atom? results2)) 303 ((atom? results2)) 304 ((match (car results1) (car results2)) 305 (matchresults (cdr results1) (cdr results2))) 306 (else #f))) 298 307 (define (type<=? t1 t2) 299 308 (or (eq? t1 t2) … … 467 476 (params (nodeparameters n)) 468 477 (class (nodeclass 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) 470 479 (let ((results 471 480 (case class 
chicken/branches/scrutiny/types.db
r14416 r14417 129 129 (atan (procedure atan (number number) number)) 130 130 (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))) 132 132 (char? (procedure char? (*) boolean)) 133 133 (char=? (procedure char=? (char char) boolean))
Note: See TracChangeset
for help on using the changeset viewer.