Changeset 14416 in project


Ignore:
Timestamp:
04/24/09 10:42:17 (11 years ago)
Author:
felix winkelmann
Message:

scrutinizer fixes

Location:
chicken/branches/scrutiny
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/TODO

    r14399 r14416  
    113113*** allow giving toplevel procedure names to `scrutinize' option?
    114114*** write test file trigger every type of warning (diff with result file in test-suite)
    115 *** `(or ...)' simplification must check for subtype-relationship
    116 *** use of `(and <flag> <value>)' idiom results in many non-matching `(or <type> boolean)' mismatches
    117115
    118116
  • chicken/branches/scrutiny/defaults.make

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

    r14399 r14416  
    8585;       | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL]]) . RESULTS)
    8686;       | BASIC
     87;       | deprecated
    8788;   BASIC = * | string | symbol | char | number | boolean | list | pair |
    8889;           procedure | vector | null | eof | undefined | port |
    89 ;           blob | deprecated
     90;           blob | noreturn
    9091;   RESULTS = *
    9192;           | (VAL1 ...)
     
    133134          ((assq id e) =>
    134135           (lambda (a)
    135              (when (eq? 'undefined (cdr a))
    136                (report1
    137                 loc
    138                 (sprintf "access to variable `~a' which has an undefined value"
    139                          (real-name id db))))
    140              (list (cdr a))))
     136             (cond ((eq? 'undefined (cdr a))
     137                    (pp (list a loc) (current-error-port))
     138                    (report1
     139                     loc
     140                     (sprintf "access to variable `~a' which has an undefined value"
     141                              (real-name id db)))
     142                    '*)
     143                   (else (list (cdr a))))))
    141144          (else (global-result id loc))))
    142145  (define (always-true t loc x)
    143146    (let ((f (cond ((and (pair? t) (eq? 'or (car t)))
    144147                    (every (cut always-true <> loc x) (cdr t)))
    145                    ((memq t '(* boolean undefined)) #f)
     148                   ((memq t '(* boolean undefined noreturn)) #f)
    146149                   (else #t))))
    147150      (when f
     
    211214                              (lambda (t)
    212215                                (let ((t (simplify t)))
    213                                   (if (and (pair? t) (eq? 'or (car t)))
    214                                       (cdr t)
    215                                       (list t))))
     216                                  (cond ((and (pair? t) (eq? 'or (car t)))
     217                                         (cdr t))
     218                                        ((eq? 'noreturn t) '())
     219                                        ((eq? t 'undefined) (return 'undefined))
     220                                        (else (list t)))))
    216221                              (cdr t)))
    217222                         (ts2 (let loop ((ts ts))
    218223                                (cond ((null? ts) '())
    219224                                      ((eq? '* (car ts)) (return '*))
    220                                       ((any (cut match (car ts) <>) (cdr ts)) ;XXX broken for subtype-relationship
     225                                      ((any (cut type<=? (car ts) <>) (cdr ts))
    221226                                       (loop (cdr ts)))
    222227                                      (else (cons (car ts) (loop (cdr ts))))))))
     
    226231                           (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2))))))))
    227232             ((procedure)
    228               (let ((name (and (not (list? (cadr t))) (cadr t))))
     233              (let ((name (and (not (pair? (cadr t))) (cadr t))))
    229234                `(procedure
    230235                  ,@(if name (list name) '())
    231                   ,(map simplify (second t))
    232                   ,@(map simplify (cddr t)))))
     236                  ,(map simplify (if name (third t) (second t)))
     237                  ,@(map simplify (if name (cdddr t) (cddr t))))))
    233238             (else t))
    234239           t))))
     
    241246          ((eq? t1 '*))
    242247          ((eq? t2 '*))
     248          ((eq? t1 'noreturn))
     249          ((eq? t2 'noreturn))
    243250          ((eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2))))
    244251          ((eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))))
     
    289296            ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
    290297            (else #f))))
     298  (define (type<=? t1 t2)
     299    (or (eq? t1 t2)
     300        (memq t2 '(* undefined))
     301        (case t2
     302          ((list) (memq t1 '(null pair)))
     303          ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
     304          (else
     305           (and (pair? t1) (pair? t2)
     306                (case (car t1)
     307                  ((or) (every (cut type<=? <> t2) (cdr t1)))
     308                  ((procedure)
     309                   (let ((args1 (if (pair? (cadr t1)) (cadr t1) (caddr t1)))
     310                         (args2 (if (pair? (cadr t2)) (cadr t2) (caddr t2)))
     311                         (res1 (if (pair? (cadr t1)) (cddr t1) (cdddr t1)))
     312                         (res2 (if (pair? (cadr t2)) (cddr t2) (cdddr t2))) )
     313                     (let loop1 ((args1 args1)
     314                                 (args2 args2)
     315                                 (m1 0)
     316                                 (m2 0))
     317                       (cond ((null? args1)
     318                              (and (or (null? args2) (> m2 0))
     319                                   (let loop2 ((res1 res1) (res2 res2))
     320                                     (cond ((eq? '* res2) #t)
     321                                           ((null? res2) (null? res1))
     322                                           ((eq? '* res1) #f)
     323                                           ((type<=? (car res1) (car res2))
     324                                            (loop2 (cdr res1) (cdr res2)))
     325                                           (else #f)))))
     326                             ((null? args2) #f)
     327                             ((eq? (car args1) '#!optional)
     328                              (loop1 (cdr args1) args2 1 m2))
     329                             ((eq? (car args2) '#!optional)
     330                              (loop1 args1 (cdr args2) m1 1))
     331                             ((eq? (car args1) '#!rest)
     332                              (loop1 (cdr args1) args2 2 m2))
     333                             ((eq? (car args2) '#!rest)
     334                              (loop1 args1 (cdr args2) m1 2))
     335                             ((type<=? (car args1) (car args2))
     336                              (loop1 (cdr args1) (cdr args2) m1 m2))
     337                             (else #f)))))))))))
    291338  (define (check expected given loc what #!optional desc)
    292339    (d "check: ~a <-> ~a (~a)" expected given loc)
     
    296343  (define (multiples n)
    297344    (if (= n 1) "" "s"))
    298   (define (single tv loc)
     345  (define (single what tv loc)
    299346    (if (eq? '* tv)
    300347        '*
     
    302349          (cond ((= 1 n) (car tv))
    303350                ((zero? n)
    304                  (report loc "a single result" "zero results" #f)
     351                 (report loc "a single result" "zero results" what)
    305352                 'undefined)
    306353                (else
    307                  (report loc "a single result" (sprintf "~a result~a" n (multiples n)) #f)
     354                 (report loc "a single result" (sprintf "~a result~a" n (multiples n)) what)
    308355                 (first tv))))))
    309356  (define (report1 loc desc)
     
    420467          (params (node-parameters n))
    421468          (class (node-class n)) )
    422       (d "walk: ~a ~a (loc: ~a, dest: ~a)" class params loc dest)
     469      (d "walk: ~a ~a (loc: ~a, dest: ~a, env: ~a)" class params loc dest e)
    423470      (let ((results
    424471             (case class
    425472               ((quote) (list (constant-result (first params))))
    426                ((##core#undefined) '(undefined))
     473               ((##core#undefined) '(*))
    427474               ((##core#proc) '(procedure))
    428475               ((##core#global-ref) (global-result (first params) loc))
    429476               ((##core#variable) (variable-result (first params) e loc))
    430                ((if) (let ((rt (single (walk (first subs) e loc dest) loc)))
     477               ((if) (let ((rt (single "in conditional" (walk (first subs) e loc dest) loc)))
    431478                       (always-true rt loc n)
    432479                       (let ((r1 (walk (second subs) e loc dest))
     
    444491                  (if (null? vars)
    445492                      (walk (car body) (append e2 e) loc dest)
    446                       (let ((t (single (walk (car body) e loc (car vars)) loc)))
     493                      (let ((t (single "in `let' binding" (walk (car body) e loc (car vars)) loc)))
    447494                        (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))
    448495               ((##core#lambda lambda)
     
    453500                      ,@(if dest (list dest) '())
    454501                      ,(append (make-list argc '*) (if rest '(#!rest) '()))
    455                       ,@(let ((r (walk (first subs)
    456                                        (if rest
    457                                            (alist-cons
    458                                             rest 'list
    459                                             (append (map (lambda (v) (cons v '*))
    460                                                          (if rest (butlast vars) vars))
    461                                                     e))
    462                                            e)
    463                                        (add-loc dest loc)
    464                                        #f)))
     502                      ,@(let* ((e2 (append (map (lambda (v) (cons v '*))
     503                                                (if rest (butlast vars) vars))
     504                                           e))
     505                               (r (walk (first subs)
     506                                        (if rest (alist-cons rest 'list e2) e2)
     507                                        (add-loc dest loc)
     508                                        #f)))
    465509                          (if (eq? r '*)
    466510                              '(*)
    467511                              r)))))))
    468512               ((set!)
    469                 (let ((rt (single (walk (first subs) e loc (first params)) loc)))
     513                (let ((rt (single
     514                           (sprintf "in assignment to `~a'" (first params))
     515                           (walk (first subs) e loc (first params))
     516                           loc)))
    470517                  '(undefined)))
    471518               ((##core#primitive ##core#inline_ref) '*)
    472519               ((##core#call)
    473                 (let ((args (map (lambda (n) (single (walk n e loc #f) loc)) subs)))
     520                (let ((args (map (lambda (n)
     521                                   (single
     522                                    "in procedure call argument"
     523                                    (walk n e loc #f) loc)) subs)))
    474524                  (call-result args e loc (first subs) params)))
    475525               ((##core#switch ##core#cond)
  • chicken/branches/scrutiny/types.db

    r14399 r14416  
    224224;; chicken
    225225
    226 (abort (procedure abort (*) undefined))
     226(abort (procedure abort (*) noreturn))
    227227(add1 (procedure add1 (number) number))
    228228(argc+argv (procedure argc+argv () number list))
     
    266266(enable-warnings (procedure enable-warnings (#!optional *) *))
    267267(errno (procedure errno () number))
    268 (error (procedure error (#!rest) undefined))
    269 (exit (procedure exit (#!optional number) undefined))
     268(error (procedure error (#!rest) noreturn))
     269(exit (procedure exit (#!optional number) noreturn))
    270270(exit-handler (procedure exit-handler (#!optional procedure) procedure))
    271271(expand (procedure expand (* #!optional *) *))
     
    328328(get-output-string (procedure get-output-string (port) string))
    329329(get-properties (procedure get-properties (symbol list) symbol * list))
    330 (getenv (procedure getenv (string) string))
     330(getenv (procedure getenv (string) (or string boolean)))
    331331(getter-with-setter (procedure getter-with-setter (procedure procedure) procedure))
    332332(implicit-exit-handler (procedure implicit-exit-handler (#!optional procedure) procedure))
     
    357357(print (procedure print (#!rest *) undefined))
    358358(print-call-chain (procedure print-call-chain (#!optional port number * string) undefined))
    359 (print-error-message (procedure print-error-message (* port string) undefined))
     359(print-error-message (procedure print-error-message (* #!optional port string) undefined))
    360360(print* (procedure print* (#!rest) undefined))
    361361(procedure-information (procedure procedure-information (procedure) *))
     
    393393(symbol-escape (procedure symbol-escape (#!optional *) *))
    394394(symbol-plist (procedure symbol-plist (symbol) list))
    395 (syntax-error (procedure syntax-error (#!rest) undefined))
     395(syntax-error (procedure syntax-error (#!rest) noreturn))
    396396(system (procedure system (string) number))
    397397(unregister-feature! (procedure unregister-feature! (#!rest symbol) undefined))
Note: See TracChangeset for help on using the changeset viewer.