 Timestamp:
 03/27/09 13:49:43 (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

chicken/branches/scrutiny/scrutinizer.scm
r13964 r13966 191 191 (simplify (second t)) 192 192 (let* ((ts (appendmap 193 (lambda (t)194 (let ((t (simplify t)))195 (if (and (pair? t) (eq? 'or (car t)))196 (cdr t)197 (list t))))198 (cdr t)))193 (lambda (t) 194 (let ((t (simplify t))) 195 (if (and (pair? t) (eq? 'or (car t))) 196 (cdr t) 197 (list t)))) 198 (cdr t))) 199 199 (ts2 (let loop ((ts ts)) 200 200 (cond ((null? ts) '()) … … 293 293 (sprintf ", but where given ~a" given)))) 294 294 (define (locationname loc) 295 (cond ((not loc) "at toplevel:\n") 295 (define (lname loc1) 296 (if loc1 297 (sprintf "procedure `~s'" loc1) 298 "unknown procedure")) 299 (cond ((null? loc) "at toplevel:\n") 296 300 ((null? (cdr loc)) 297 ( conc "in toplevel procedure `" (car loc) "':\n"))301 (sprintf "in ~a" (lname (car loc)) ":\n")) 298 302 (else 299 303 (let rec ((loc loc)) 300 304 (if (null? (cdr loc)) 301 (conc "in toplevel procedure `" (car loc) "':\n") 302 (conc 303 "in local procedure `" (car loc) "',\n" 304 (rec (cdr loc)))))))) 305 (locationname loc) 306 (sprintf "in local ~a:\n ~a" (lname (car loc)) (rec (cdr loc)))))))) 307 (define addloc cons) 305 308 (define (fragment x) 306 309 (let ((x (buildexpressiontree x))) … … 400 403 (let ((t (single (walk (first subs) e loc (first params)) loc))) 401 404 (walk (second subs) (alistcons (first params) t e) loc dest))) 402 ((##core#lambda )405 ((##core#lambda lambda) 403 406 (decomposelambdalist 404 ( thirdparams)407 (first params) 405 408 (lambda (vars argc rest) 406 '((procedure409 `((procedure 407 410 ,@(if dest (list dest) '()) 408 411 ,(append (makelist argc '*) (if rest '(#!rest) '())) … … 413 416 (append (map (lambda (v) (cons v '*)) 414 417 (if rest (butlast vars) vars)) 415 e))) 416 (cons dest loc) 418 e)) 419 e) 420 (addloc dest loc) 417 421 #f)))))) 418 422 ((set!) … … 430 434 (d " > ~a" results) 431 435 results))) 432 (walk node '() #f#f))436 (walk (first (nodesubexpressions node)) '() '() #f)) 433 437 434 438 (define (loadtypedatabase name)
Note: See TracChangeset
for help on using the changeset viewer.