Changeset 13964 in project


Ignore:
Timestamp:
03/27/09 12:06:24 (11 years ago)
Author:
felix winkelmann
Message:

scrutiny work (reporting, fixes)

Location:
chicken/branches/scrutiny
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/TODO

    r13945 r13964  
    109109
    110110** scrutiny
    111 *** document `type' declaration and type specifiers
     111*** document type-specifiers
     112*** handle #!optional in procedure type signatures
     113*** allow giving toplevel procedure names to `scrutinize' option?
    112114
    113115
  • chicken/branches/scrutiny/batch-driver.scm

    r13911 r13964  
    6464  default-declarations units-used-by-default words-per-flonum default-debugging-declarations
    6565  default-profiling-declarations default-optimization-passes
    66   file-requirements import-libraries inline-globally scrutinize
     66  file-requirements import-libraries inline-globally scrutinize do-scrutinize
    6767  foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6868  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
     
    133133        [start-time #f]
    134134        (upap #f)
    135         (do-scrutinize #f)
    136135        [ssize (or (memq 'nursery options) (memq 'stack-size options))] )
    137136
  • chicken/branches/scrutiny/compiler.scm

    r13911 r13964  
    7474; (unused <symbol> ...)
    7575; (uses {<unitname>})
     76; (scrutinize)
    7677;
    7778;   <type> = fixnum | generic
     
    296297  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
    297298  location-pointer-map literal-rewrite-hook inline-globally
    298   local-definitions export-variable variable-mark intrinsic?
     299  local-definitions export-variable variable-mark intrinsic? do-scrutinize
    299300  undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    300301  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
     
    369370(define inline-locally #f)
    370371(define inline-output-file #f)
     372(define do-scrutinize #f)
    371373
    372374
     
    14721474                  (compiler-warning 'syntax "illegal `type' declaration item `~s'" spec))))
    14731475         (cdr spec)))
     1476       ((scrutinize)
     1477        (set! do-scrutinize #t))
    14741478       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
    14751479     '(##core#undefined) ) ) )
  • chicken/branches/scrutiny/manual/Declarations

    r12595 r13964  
    250250
    251251
     252=== scrutinize
     253
     254 [declaration specifier] (scrutinize)
     255
     256Enables scrutiny. This is equivalent to passing the {{-scrutinize}} option to the compiler.
     257
     258
    252259=== standard-bindings
    253260
     
    259266then all but the given standard bindings are assumed to be never
    260267redefined.
     268
     269
     270=== type
     271
     272  [declaration specifier] (type (SYMBOL TYPESPEC) ...)
     273
     274Declares toplevel procedures to have a specific type for scrutiny.
    261275
    262276
  • chicken/branches/scrutiny/manual/Using the compiler

    r13755 r13964  
    170170; -require-extension NAME : Loads the extension {{NAME}} before the compilation process commences. This is identical to adding {{(require-extension NAME)}} at the start of the compiled program. If {{-uses NAME}} is also given on the command line, then any occurrences of {{-require-extension NAME}} are replaced with {{(declare (uses NAME))}}. Multiple names may be given and should be separated by {{,}}.
    171171
    172 ; -scrutinize : Enable simple flow-analysis to catch common type errors and argument/result mismatches
     172; -scrutinize : Enable simple flow-analysis to catch common type errors and argument/result mismatches. You can also use the {{scrutinize}} declaration to enable scrutiny.
    173173
    174174; -static-extension NAME : similar to {{-require-extension NAME}}, but links extension statically (also applies for an explicit {{(require-extension NAME)}}).
  • chicken/branches/scrutiny/scrutinizer.scm

    r13945 r13964  
    9494;   ##core#declared-type  ->  <bool>
    9595
     96(define-constant +fragment-max-length+ 5)
     97
    9698(define (scrutinize node db)
    9799  (define (constant-result lit)
     
    125127           (lambda (a) (list (cdr a))))
    126128          (else (global-result id))))
    127   (define (always-true t loc)
     129  (define (always-true t loc x)
    128130    (let ((f (cond ((and (pair? t) (eq? 'or (car t)))
    129                     (every (cut always-true <> loc) (cdr t)))
     131                    (every (cut always-true <> loc x) (cdr t)))
    130132                   ((memq t '(* boolean undefined)) #f)
    131133                   (else #t))))
    132134      (when f
    133         (report loc "a boolean" "a non-false" "value" "conditional"))
     135        (report
     136         loc "of type boolean" "a result that is always true"
     137         "value"
     138         (sprintf "in conditional `~s', " (fragment x))))
    134139      f))
    135140  (define (typename t)
     
    175180               len m m
    176181               (map typename results))))))
    177   (define (report loc expected given what #!optional desc)
    178     (compiler-warning
    179      'scrutiny
    180      "~a~a~a~a"
    181      (location-name loc) (or desc "")
    182      (if expected
    183          (sprintf "expected ~a~a~a" what (and what " ") expected)
    184          "")
    185      (sprintf ", but where given ~a" given)))
    186   (define (location-name loc)
    187     (cond ((not loc) "at toplevel:\n")
    188           ((null? (cdr loc))
    189            (conc "in toplevel procedure `" (car loc) "':\n"))
    190           (else
    191            (let rec ((loc loc))
    192              (if (null? (cdr loc))
    193                  (conc "in toplevel procedure `" (car loc) "':\n")
    194                  (conc
    195                   "in local procedure `" (car loc) "',\n"
    196                   (rec (cdr loc))))))))
    197182  (define (simplify t)
    198183    (let ((t2 (simplify1 t)))
     
    205190           (if (= 2 (length t))
    206191               (simplify (second t))
    207                (let ((ts (append-map
     192               (let* ((ts (append-map
    208193                          (lambda (t)
    209194                            (let ((t (simplify t)))
     
    211196                                  (cdr t)
    212197                                  (list t))))
    213                           (cdr t))))
    214                  (simplify `(or ,@(if (any (cut eq? <> '*) ts) '(*) ts))))))
     198                          (cdr t)))
     199                     (ts2 (let loop ((ts ts))
     200                            (cond ((null? ts) '())
     201                                  ((any (cut match (car ts) <>) (cdr ts))
     202                                   (loop (cdr ts)))
     203                                  (else (cons (car ts) (loop (cdr ts))))))))
     204                 (d "  or-simplify: ~a" ts2)
     205                 (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2))))))
    215206          ((procedure)
    216207           (let ((name (and (not (list? (cadr t))) (cadr t))))
     
    286277                 (report loc "a single result" (sprintf "~a result~a" n (multiples n)) #f)
    287278                 (first tv))))))
    288   (define (call-result args e loc)
     279  (define (report1 loc desc)
     280    (compiler-warning
     281     'scrutiny
     282     "~a~a"
     283     (location-name loc) desc))
     284  (define (report loc expected given what #!optional desc)
     285    (report1
     286     loc
     287     (sprintf
     288      "~a~a~a"
     289      (or desc "")
     290      (if expected
     291          (sprintf "expected ~a~a~a" what (and what " ") expected)
     292          "")
     293      (sprintf ", but where given ~a" given))))
     294  (define (location-name loc)
     295    (cond ((not loc) "at toplevel:\n")
     296          ((null? (cdr loc))
     297           (conc "in toplevel procedure `" (car loc) "':\n"))
     298          (else
     299           (let rec ((loc loc))
     300             (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  (define (fragment x)
     306    (let ((x (build-expression-tree x)))
     307      (cond ((atom? x) x)
     308            ((list? x)
     309             (let ((x1 (if (> (length x) +fragment-max-length+)
     310                           (append (take x +fragment-max-length+) '(...))
     311                           x)))
     312               (map (lambda (x)
     313                      (if (and (list? x) (any pair? x))
     314                          '...
     315                          x))
     316                    x1)))
     317            (else x))))
     318  (define (call-result args e loc x)
     319    (define (pname)
     320      (sprintf "in procedure call to `~s' " (fragment x)))
    289321    (d "call-result: ~a (~a)" args loc)
    290322    (let ((ptype (car args))
     
    293325       `(procedure ,(make-list nargs '*) *)
    294326       ptype
    295        loc "a procedure of type")
     327       loc "a procedure of type" (pname))
    296328      (let ((atypes (procedure-argument-types ptype (length (cdr args)))))
    297329        (d "  argument-types: ~a" atypes)
    298330        (unless (= (length atypes) nargs)
    299           (report
    300            loc
    301            (sprintf "~a arguments" nargs)
    302            (sprintf "~a arguments" (length atypes))
    303            "procedure call"))
    304         (for-each
    305          (lambda (arg argt)
    306            (check argt arg loc "a procedure argument of type") )
    307          atypes
    308          (cdr args))
     331          (let ((alen (length atypes)))
     332            (report
     333             loc
     334             (sprintf "~a argument~a" nargs (multiples nargs))
     335             (sprintf "~a argument~a" alen (multiples alen))
     336             (pname))))
     337        (do ((args (cdr args) (cdr args))
     338             (atypes atypes (cdr atypes))
     339             (i 1 (add1 i)))
     340            ((or (null? args) (null? atypes)))
     341          (check (car atypes) (car args) loc (sprintf "procedure #~a argument of type" i) (pname)))
    309342        (let ((r (procedure-result-type ptype)))
    310343          (d  "  result-type: ~a" r)
     
    353386               ((##core#variable) (variable-result (first params) e))
    354387               ((if) (let ((rt (single (walk (first subs) e loc dest) loc)))
    355                        (when (always-true rt loc)
    356                          (report loc #f rt "`if'" "condition is always true"))
    357                        (simplify `(or ,(walk (second subs) e loc dest)
    358                                       ,(walk (third subs) e loc dest)))))
     388                       (when (always-true rt loc n)
     389                         (report1 loc (sprintf "conditional `~s' is always true" (fragment (first subs)))))
     390                       (let ((r1 (walk (second subs) e loc dest))
     391                             (r2 (walk (third subs) e loc dest)))
     392                         (when (and (not (eq? r1 '*)) (not (eq? '* r2))
     393                                    (not (= (length r1) (length r2))))
     394                           (report1
     395                            loc
     396                            "branches in conditional expression differ in the number of results"))
     397                         (map (lambda (t1 t2) (simplify `(or ,t1 ,t2)))
     398                              r1 r2))))
    359399               ((let)
    360400                (let ((t (single (walk (first subs) e loc (first params)) loc)))
     
    382422               ((##core#call)
    383423                (let ((args (map (lambda (n) (single (walk n e loc #f) loc)) subs)))
    384                   (call-result args e loc)))
     424                  (call-result args e loc (first subs))))
    385425               ((##core#switch ##core#cond)
    386426                (bomb "unexpected node class: ~a" class))
Note: See TracChangeset for help on using the changeset viewer.