Changeset 13967 in project


Ignore:
Timestamp:
03/27/09 14:03:18 (11 years ago)
Author:
felix winkelmann
Message:

fixes

File:
1 edited

Legend:

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

    r13966 r13967  
    299299    (cond ((null? loc) "at toplevel:\n")
    300300          ((null? (cdr loc))
    301            (sprintf "in ~a" (lname (car loc)) ":\n"))
     301           (sprintf "in toplevel ~a" (lname (car loc)) ":\n"))
    302302          (else
    303303           (let rec ((loc loc))
    304304             (if (null? (cdr loc))
    305                  (location-name loc)
    306                  (sprintf "in local ~a:\n  ~a" (lname (car loc)) (rec (cdr loc))))))))
     305                 (string-append (location-name loc) ":\n")
     306                 (sprintf "in local ~a,\n  ~a" (lname (car loc)) (rec (cdr loc))))))))
    307307  (define add-loc cons)
    308308  (define (fragment x)
     
    342342             (i 1 (add1 i)))
    343343            ((or (null? args) (null? atypes)))
    344           (check (car atypes) (car args) loc (sprintf "procedure #~a argument of type" i) (pname)))
    345         (let ((r (procedure-result-type ptype)))
    346           (d  "  result-type: ~a" r)
     344          (check (car atypes) (car args) loc (sprintf "argument #~a of type" i) (pname)))
     345        (let ((r (procedure-result-types ptype)))
     346          (d  "  result-types: ~a" r)
    347347          r))))
    348348  (define (procedure-argument-types t n)
     
    362362                   (else (cons (car at) (loop (cdr at) (sub1 m)))))))
    363363          (else (bomb "not a procedure type: ~a" t))))
    364   (define (procedure-result-type t)
     364  (define (procedure-result-types t)
    365365    (cond ((or (memq t '(* procedure))
    366366               (not-pair? t) )
     
    389389               ((##core#variable) (variable-result (first params) e))
    390390               ((if) (let ((rt (single (walk (first subs) e loc dest) loc)))
    391                        (when (always-true rt loc n)
    392                          (report1 loc (sprintf "conditional `~s' is always true" (fragment (first subs)))))
     391                       (always-true rt loc n)
    393392                       (let ((r1 (walk (second subs) e loc dest))
    394393                             (r2 (walk (third subs) e loc dest)))
     
    410409                      ,@(if dest (list dest) '())
    411410                      ,(append (make-list argc '*) (if rest '(#!rest) '()))
    412                       ,@(walk (first subs)
    413                               (if rest
    414                                   (alist-cons
    415                                    rest 'list
    416                                    (append (map (lambda (v) (cons v '*))
    417                                                 (if rest (butlast vars) vars))
    418                                            e))
    419                                   e)
    420                               (add-loc dest loc)
    421                               #f))))))
     411                      ,@(let ((r (walk (first subs)
     412                                       (if rest
     413                                           (alist-cons
     414                                            rest 'list
     415                                            (append (map (lambda (v) (cons v '*))
     416                                                         (if rest (butlast vars) vars))
     417                                                    e))
     418                                           e)
     419                                       (add-loc dest loc)
     420                                       #f)))
     421                          (if (eq? r '*)
     422                              '(*)
     423                              r)))))))
    422424               ((set!)
    423425                (let ((rt (single (walk (first subs) e loc (first params)) loc)))
Note: See TracChangeset for help on using the changeset viewer.