 Timestamp:
 03/27/09 14:03:18 (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

chicken/branches/scrutiny/scrutinizer.scm
r13966 r13967 299 299 (cond ((null? loc) "at toplevel:\n") 300 300 ((null? (cdr loc)) 301 (sprintf "in ~a" (lname (car loc)) ":\n"))301 (sprintf "in toplevel ~a" (lname (car loc)) ":\n")) 302 302 (else 303 303 (let rec ((loc loc)) 304 304 (if (null? (cdr loc)) 305 ( locationname loc)306 (sprintf "in local ~a :\n ~a" (lname (car loc)) (rec (cdr loc))))))))305 (stringappend (locationname loc) ":\n") 306 (sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr loc)))))))) 307 307 (define addloc cons) 308 308 (define (fragment x) … … 342 342 (i 1 (add1 i))) 343 343 ((or (null? args) (null? atypes))) 344 (check (car atypes) (car args) loc (sprintf " procedure #~a argumentof type" i) (pname)))345 (let ((r (procedureresulttype ptype)))346 (d " resulttype : ~a" r)344 (check (car atypes) (car args) loc (sprintf "argument #~a of type" i) (pname))) 345 (let ((r (procedureresulttypes ptype))) 346 (d " resulttypes: ~a" r) 347 347 r)))) 348 348 (define (procedureargumenttypes t n) … … 362 362 (else (cons (car at) (loop (cdr at) (sub1 m))))))) 363 363 (else (bomb "not a procedure type: ~a" t)))) 364 (define (procedureresulttype t)364 (define (procedureresulttypes t) 365 365 (cond ((or (memq t '(* procedure)) 366 366 (notpair? t) ) … … 389 389 ((##core#variable) (variableresult (first params) e)) 390 390 ((if) (let ((rt (single (walk (first subs) e loc dest) loc))) 391 (when (alwaystrue rt loc n) 392 (report1 loc (sprintf "conditional `~s' is always true" (fragment (first subs))))) 391 (alwaystrue rt loc n) 393 392 (let ((r1 (walk (second subs) e loc dest)) 394 393 (r2 (walk (third subs) e loc dest))) … … 410 409 ,@(if dest (list dest) '()) 411 410 ,(append (makelist argc '*) (if rest '(#!rest) '())) 412 ,@(walk (first subs) 413 (if rest 414 (alistcons 415 rest 'list 416 (append (map (lambda (v) (cons v '*)) 417 (if rest (butlast vars) vars)) 418 e)) 419 e) 420 (addloc dest loc) 421 #f)))))) 411 ,@(let ((r (walk (first subs) 412 (if rest 413 (alistcons 414 rest 'list 415 (append (map (lambda (v) (cons v '*)) 416 (if rest (butlast vars) vars)) 417 e)) 418 e) 419 (addloc dest loc) 420 #f))) 421 (if (eq? r '*) 422 '(*) 423 r))))))) 422 424 ((set!) 423 425 (let ((rt (single (walk (first subs) e loc (first params)) loc)))
Note: See TracChangeset
for help on using the changeset viewer.