Changeset 14778 in project for chicken


Ignore:
Timestamp:
05/25/09 10:00:13 (10 years ago)
Author:
felix winkelmann
Message:

argument-handling bug fixes

File:
1 edited

Legend:

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

    r14744 r14778  
    510510           (values (make-list n '*) #f))
    511511          ((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                      (make-list m (rest-type (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                            (make-list m (rest-type (cdr at))))
     525                           ((and opt (<= m 0)) '())
     526                           (else (cons (car at) (loop (cdr at) (sub1 m) opt)))))))
     527             (values llist vf)))
    527528          (else (bomb "not a procedure type" t))))
    528529  (define (procedure-result-types t values-rest? args)
     
    561562                                  (report1
    562563                                   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))))
    564567                                (map (lambda (t1 t2) (simplify `(or ,t1 ,t2)))
    565568                                     r1 r2))
     
    575578                 (first params)
    576579                 (lambda (vars argc rest)
    577                    `((procedure
    578                       ,@(if dest (list dest) '())
    579                       ,(append (make-list 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 (alist-cons rest 'list e2) e2)
    585                                         (add-loc dest loc)
    586                                         #f)))
    587                           (if (eq? r '*)
    588                               '*
    589                               r)))))))
     580                   (let* ((name (if dest (list dest) '()))
     581                          (args (append (make-list 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 (alist-cons rest 'list e2) e2)
     587                                   (add-loc dest loc)
     588                                   #f)))
     589                     (list
     590                      (append
     591                       '(procedure)
     592                       name
     593                       (list args)
     594                       r))))))
    590595               ((set! ##core#set!)
    591596                (let* ((var (first params))
Note: See TracChangeset for help on using the changeset viewer.