Changeset 13990 in project for chicken


Ignore:
Timestamp:
03/29/09 01:36:18 (11 years ago)
Author:
felix winkelmann
Message:

scrutiny fixes, report layout improvements, correct handling of let nodes

Location:
chicken/branches/scrutiny
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/defaults.make

    r13965 r13990  
    280280# Scheme compiler flags
    281281
    282 #CHICKEN_OPTIONS = -no-trace -optimize-level 2 -optimize-level 2 -include-path . -include-path $(SRCDIR)
    283 CHICKEN_OPTIONS = -optimize-level 2 -optimize-level 2 -include-path . -include-path $(SRCDIR)
     282CHICKEN_OPTIONS = -no-trace -optimize-level 2 -include-path . -include-path $(SRCDIR)
     283#CHICKEN_OPTIONS = -optimize-level 2 -include-path . -include-path $(SRCDIR)
    284284ifdef DEBUGBUILD
    285285CHICKEN_OPTIONS += -feature debugbuild
  • chicken/branches/scrutiny/scrutinizer.scm

    r13968 r13990  
    4646  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
    4747  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
    48   reorganize-recursive-bindings substitution-table simplify-named-call compiler-warning
     48  reorganize-recursive-bindings substitution-table simplify-named-call compiler-warning real-name
    4949  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
    5050  transform-direct-lambdas! expand-foreign-callback-lambda* debug-lambda-list debug-variable-list debugging
     
    222222        (and (eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2)))
    223223             (eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))) )
     224        (and (memq t1 '(pair list))
     225             (memq t2 '(pair list)))
    224226        (and (pair? t1) (pair? t2)
    225227             (or (and (eq? (car t1) 'or)
     
    239241                          (equal? t1 t2)))))))
    240242  (define (match-args args1 args2)
     243    (d "match-args: ~s <-> ~s" args1 args2)
    241244    (define (match-rest rtype args)
    242245      (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
     
    247250                  (cadr tail)
    248251                  '*) ) ) ) )
     252    (define (optargs a)
     253      (memq a '(#!rest #!optional)))
    249254    (let loop ((args1 args1) (args2 args2))
    250255      (cond ((null? args1)
    251256             (or (null? args2)
    252                  (eq? '#!rest (car args2))))
    253             ((null? args2)
    254              (eq? '#!rest (car args2)))
     257                 (optargs (car args2))))
     258            ((null? args2) (optargs (car args2)))
    255259            ((eq? '#!rest (car args1))
    256260             (match-rest (if (pair? (cdr args1)) (cadr args1) '*) args2))
     
    296300    (define (lname loc1)
    297301      (if loc1
    298           (sprintf "procedure `~s'" loc1)
     302          (sprintf "procedure `~a'" (real-name loc1))
    299303          "unknown procedure"))
    300     (cond ((null? loc) "at toplevel:\n")
     304    (cond ((null? loc) "at toplevel:\n  ")
    301305          ((null? (cdr loc))
    302            (sprintf "in toplevel ~a" (lname (car loc)) ":\n"))
     306           (sprintf "in toplevel ~a:\n  " (lname (car loc))))
    303307          (else
    304308           (let rec ((loc loc))
    305309             (if (null? (cdr loc))
    306                  (string-append (location-name loc) ":\n")
     310                 (location-name loc)
    307311                 (sprintf "in local ~a,\n  ~a" (lname (car loc)) (rec (cdr loc))))))))
    308312  (define add-loc cons)
     
    402406                               (else '*)))))
    403407               ((let)
    404                 (let ((t (single (walk (first subs) e loc (first params)) loc)))
    405                   (walk (second subs) (alist-cons (first params) t e) loc dest)))
     408                (let loop ((vars params) (body subs) (e2 '()))
     409                  (if (null? vars)
     410                      (walk (car body) (append e2 e) loc dest)
     411                      (let ((t (single (walk (car body) e loc (car vars)) loc)))
     412                        (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))
    406413               ((##core#lambda lambda)
    407414                (decompose-lambda-list
Note: See TracChangeset for help on using the changeset viewer.