Changeset 13966 in project


Ignore:
Timestamp:
03/27/09 13:49:43 (11 years ago)
Author:
felix winkelmann
Message:

scrutiny work - currently broken

File:
1 edited

Legend:

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

    r13964 r13966  
    191191               (simplify (second t))
    192192               (let* ((ts (append-map
    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)))
    199199                     (ts2 (let loop ((ts ts))
    200200                            (cond ((null? ts) '())
     
    293293      (sprintf ", but where given ~a" given))))
    294294  (define (location-name 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")
    296300          ((null? (cdr loc))
    297            (conc "in toplevel procedure `" (car loc) "':\n"))
     301           (sprintf "in ~a" (lname (car loc)) ":\n"))
    298302          (else
    299303           (let rec ((loc loc))
    300304             (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                 (location-name loc)
     306                 (sprintf "in local ~a:\n  ~a" (lname (car loc)) (rec (cdr loc))))))))
     307  (define add-loc cons)
    305308  (define (fragment x)
    306309    (let ((x (build-expression-tree x)))
     
    400403                (let ((t (single (walk (first subs) e loc (first params)) loc)))
    401404                  (walk (second subs) (alist-cons (first params) t e) loc dest)))
    402                ((##core#lambda)
     405               ((##core#lambda lambda)
    403406                (decompose-lambda-list
    404                  (third params)
     407                 (first params)
    405408                 (lambda (vars argc rest)
    406                    '((procedure
     409                   `((procedure
    407410                      ,@(if dest (list dest) '())
    408411                      ,(append (make-list argc '*) (if rest '(#!rest) '()))
     
    413416                                   (append (map (lambda (v) (cons v '*))
    414417                                                (if rest (butlast vars) vars))
    415                                            e)))
    416                               (cons dest loc)
     418                                           e))
     419                                  e)
     420                              (add-loc dest loc)
    417421                              #f))))))
    418422               ((set!)
     
    430434        (d "  -> ~a" results)
    431435        results)))
    432   (walk node '() #f #f))
     436  (walk (first (node-subexpressions node)) '() '() #f))
    433437
    434438(define (load-type-database name)
Note: See TracChangeset for help on using the changeset viewer.