Changeset 14823 in project


Ignore:
Timestamp:
05/29/09 09:52:52 (10 years ago)
Author:
felix winkelmann
Message:

cleaned up reporting, added test file

Location:
chicken/branches/scrutiny
Files:
1 added
2 edited

Legend:

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

    r14805 r14823  
    121121    (cond ((##sys#get id '##core#type) =>
    122122           (lambda (a)
    123              (cond #;((and (get db id 'assigned)
     123             (cond #;((and (get db id 'assigned)      ; remove assigned global from type db
    124124                         (not (##sys#get id '##core#declared-type)))
    125125                    (##sys#put! id '##core#type #f)
    126126                    '*)
    127127                   ((eq? a 'deprecated)
    128                     (report1
     128                    (report
    129129                     loc
    130130                     (sprintf "use of deprecated toplevel identifier `~a'" id) )
     
    139139           (lambda (a)
    140140             (cond ((eq? 'undefined (cdr a))
    141                     (report1
     141                    (report
    142142                     loc
    143143                     (sprintf "access to variable `~a' which has an undefined value"
     
    155155      (when f
    156156        (report
    157          loc "of type boolean"
    158          (sprintf
    159           "a result that is of type `~a' and thus always true"
    160           t)
    161          "value"
    162          (sprintf "in conditional:~%~%~a~%," (pp-fragment x))))
     157         loc
     158         (sprintf
     159          "expected value of type boolean in conditional but were given a value of type `~a' which is always true:~%~%~a"
     160          t
     161          (pp-fragment x))))
    163162      f))
    164163  (define (typename t)
     
    409408                              (loop1 (cdr args1) (cdr args2) m1 m2))
    410409                             (else #f)))))))))))
    411   (define (check expected given loc what #!optional desc)
    412     (d "check: ~a <-> ~a (~a)" expected given loc)
    413     (if (match expected given)
    414         given
    415         (report loc expected given what desc)))
    416410  (define (multiples n)
    417411    (if (= n 1) "" "s"))
     
    422416          (cond ((= 1 n) (car tv))
    423417                ((zero? n)
    424                  (report loc "a single result" "zero results" what)
     418                 (report
     419                  loc
     420                  (sprintf "expected ~a a single result, but were given zero results" what))
    425421                 'undefined)
    426422                (else
    427                  (report loc "a single result" (sprintf "~a result~a" n (multiples n)) what)
     423                 (report
     424                  loc
     425                  (sprintf "expected ~a a single result, but were given ~a result~a"
     426                           what n (multiples n)))
    428427                 (first tv))))))
    429   (define (report1 loc desc)
     428  (define (report loc desc)
    430429    (compiler-warning
    431430     'scrutiny
    432431     "~a~a"
    433432     (location-name loc) desc))
    434   (define (report loc expected given what #!optional desc)
    435     (report1
    436      loc
    437      (sprintf
    438       "~a~a~a~a"
    439       (or desc "")
    440       (if desc " " "")
    441       (if expected
    442           (sprintf "expected ~a~a~a" (or what "") (if what " " "") expected)
    443           "")
    444       (sprintf ", but where given ~a" given))))
    445433  (define (location-name loc)
    446434    (define (lname loc1)
     
    466454              (else x)))))
    467455  (define (pp-fragment x)
    468     (with-output-to-string
    469       (lambda ()
    470         (pp (fragment x)))))
     456    (string-chomp
     457     (with-output-to-string
     458       (lambda ()
     459         (pp (fragment x))))))
    471460  (define (call-result args e loc x params)
    472461    (define (pname)
     
    478467           "")))
    479468    (d "call-result: ~a (~a)" args loc)
    480     (let ((ptype (car args))
    481           (nargs (length (cdr args))))
    482       (unless (procedure-type? ptype)
    483         (check
    484          `(procedure ,(make-list nargs '*) *)
    485          ptype
    486          loc "a procedure of type" (pname)))
     469    (let* ((ptype (car args))
     470           (nargs (length (cdr args)))
     471           (xptype `(procedure ,(make-list nargs '*) *)))
     472      (when (and (not (procedure-type? ptype))
     473                 (not (match xptype ptype)))
     474        (report
     475         loc
     476         (sprintf
     477          "expected ~a a value of type `~a', but were given a value of type `~a'"
     478          (pname)
     479          xptype
     480          ptype)))
    487481      (let-values (((atypes values-rest) (procedure-argument-types ptype (length (cdr args)))))
    488482        (d "  argument-types: ~a (~a)" atypes values-rest)
     
    491485            (report
    492486             loc
    493              (sprintf "~a argument~a" alen (multiples alen))
    494              (sprintf "~a argument~a" nargs (multiples nargs))
    495              (pname))))
     487             (sprintf
     488              "expected ~a ~a argument~a, but where given ~a argument~a"
     489              (pname) alen (multiples alen)
     490              nargs (multiples nargs)))))
    496491        (do ((args (cdr args) (cdr args))
    497492             (atypes atypes (cdr atypes))
    498493             (i 1 (add1 i)))
    499494            ((or (null? args) (null? atypes)))
    500           (check (car atypes) (car args) loc (sprintf "argument #~a of type" i) (pname)))
     495          (unless (match (car atypes) (car args))
     496            (report
     497             loc
     498             (sprintf
     499              "expected argument #~a of type `~a' ~a, but where given an argument of type `~a'"
     500              i (car atypes) (pname) (car args)))))
    501501        (let ((r (procedure-result-types ptype values-rest (cdr args))))
    502502          (d  "  result-types: ~a" r)
     
    553553             (case class
    554554               ((quote) (list (constant-result (first params))))
    555                ((##core#undefined) '(*))
     555               ((##core#undefined) '(undefined))
    556556               ((##core#proc) '(procedure))
    557557               ((##core#global-ref) (global-result (first params) loc))
     
    563563                         (cond ((and (not (eq? r1 '*)) (not (eq? '* r2)))
    564564                                (when (not (= (length r1) (length r2)))
    565                                   (report1
     565                                  (report
    566566                                   loc
    567567                                   (sprintf
     
    606606                  (when (and type (not b)
    607607                             (not (match type rt)))
    608                     (report1
     608                    (report
    609609                     loc
    610610                     (sprintf
     
    616616               ((##core#primitive ##core#inline_ref) '*)
    617617               ((##core#call)
    618                 (let ((args (map (lambda (n)
    619                                    (single
    620                                     "in procedure call argument"
    621                                     (walk n e loc #f) loc))
    622                                  subs)))
     618                (let* ((f (fragment n))
     619                       (args (map (lambda (n i)
     620                                    (single
     621                                     (sprintf
     622                                      "in ~a of procedure call `~s'"
     623                                      (if (zero? i)
     624                                          "operator position"
     625                                          (sprintf "argument #~a" i))
     626                                      f)
     627                                     (walk n e loc #f) loc))
     628                                  subs (iota (length subs)))))
    623629                  (call-result args e loc (first subs) params)))
    624630               ((##core#switch ##core#cond)
  • chicken/branches/scrutiny/tests/runtests.sh

    r13965 r14823  
    2222echo "======================================== compiler tests (2) ..."
    2323$compile compiler-tests.scm -lambda-lift && ./a.out
     24
     25echo "======================================== scrutiny tests ..."
     26$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db >scrutiny.out 2>&1
     27diff -u scrutiny.out scrutiny.expected || exit 1
    2428
    2529echo "======================================== runtime tests ..."
Note: See TracChangeset for help on using the changeset viewer.