Changeset 14778 in project
 Timestamp:
 05/25/09 10:00:13 (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

chicken/branches/scrutiny/scrutinizer.scm
r14744 r14778 510 510 (values (makelist n '*) #f)) 511 511 ((eq? 'procedure (car t)) 512 (let loop ((at (if (or (string? (second t)) (symbol? (second t))) 513 (third t) 514 (second t))) 515 (m n) 516 (opt #f)) 517 (cond ((null? at) '()) 518 ((eq? '#!optional (car at)) 519 (loop (cdr at) m #t) ) 520 ((eq? '#!rest (car at)) 521 (values 522 (makelist m (resttype (cdr at))) 523 (and (pair? (cdr at)) 524 (eq? 'values (cadr at))))) 525 ((and opt (<= m 0)) (values '() #f)) 526 (else (cons (car at) (loop (cdr at) (sub1 m) opt)))))) 512 (let* ((vf #f) 513 (llist 514 (let loop ((at (if (or (string? (second t)) (symbol? (second t))) 515 (third t) 516 (second t))) 517 (m n) 518 (opt #f)) 519 (cond ((null? at) '()) 520 ((eq? '#!optional (car at)) 521 (loop (cdr at) m #t) ) 522 ((eq? '#!rest (car at)) 523 (set! vf (and (pair? (cdr at)) (eq? 'values (cadr at)))) 524 (makelist m (resttype (cdr at)))) 525 ((and opt (<= m 0)) '()) 526 (else (cons (car at) (loop (cdr at) (sub1 m) opt))))))) 527 (values llist vf))) 527 528 (else (bomb "not a procedure type" t)))) 528 529 (define (procedureresulttypes t valuesrest? args) … … 561 562 (report1 562 563 loc 563 "branches in conditional expression differ in the number of results")) 564 (sprintf 565 "branches in conditional expression `~s' differ in the number of results" 566 (fragment n)))) 564 567 (map (lambda (t1 t2) (simplify `(or ,t1 ,t2))) 565 568 r1 r2)) … … 575 578 (first params) 576 579 (lambda (vars argc rest) 577 `((procedure 578 ,@(if dest (list dest) '()) 579 ,(append (makelist argc '*) (if rest '(#!rest) '())) 580 ,@(let* ((e2 (append (map (lambda (v) (cons v '*)) 581 (if rest (butlast vars) vars)) 582 e)) 583 (r (walk (first subs) 584 (if rest (alistcons rest 'list e2) e2) 585 (addloc dest loc) 586 #f))) 587 (if (eq? r '*) 588 '* 589 r))))))) 580 (let* ((name (if dest (list dest) '())) 581 (args (append (makelist argc '*) (if rest '(#!rest) '()))) 582 (e2 (append (map (lambda (v) (cons v '*)) 583 (if rest (butlast vars) vars)) 584 e)) 585 (r (walk (first subs) 586 (if rest (alistcons rest 'list e2) e2) 587 (addloc dest loc) 588 #f))) 589 (list 590 (append 591 '(procedure) 592 name 593 (list args) 594 r)))))) 590 595 ((set! ##core#set!) 591 596 (let* ((var (first params))
Note: See TracChangeset
for help on using the changeset viewer.