Changeset 14525 in project


Ignore:
Timestamp:
05/04/09 20:54:42 (10 years ago)
Author:
felix winkelmann
Message:

scrutinizer found first bug in eval.scm\!

Location:
chicken/branches/scrutiny
Files:
3 edited

Legend:

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

    r13965 r14525  
    13121312           ((number? x) (##sys#number->string x))
    13131313           (else (error "invalid extension version" x)) ) )
    1314    (if (and (list spec) (fx= 3 (length spec)))
     1314   (if (and (list? spec) (fx= 3 (length spec)))
    13151315       (let* ((info (extension-information (cadr spec)))
    13161316              (vv (and info (assq 'version info))) )
  • chicken/branches/scrutiny/scrutinizer.scm

    r14417 r14525  
    143143                   (else (list (cdr a))))))
    144144          (else (global-result id loc))))
     145  (define (always-true1 t)
     146    (cond ((and (pair? t) (eq? 'or (car t)))
     147           (every always-true1 (cdr t)))
     148          ((memq t '(* boolean undefined noreturn)) #f)
     149          (else #t)))
    145150  (define (always-true t loc x)
    146     (let ((f (cond ((and (pair? t) (eq? 'or (car t)))
    147                     (every (cut always-true <> loc x) (cdr t)))
    148                    ((memq t '(* boolean undefined noreturn)) #f)
    149                    (else #t))))
     151    (let ((f (always-true1 t)))
    150152      (when f
    151153        (report
     
    231233                           (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2))))))))
    232234             ((procedure)
    233               (let ((name (and (not (named? t)) (cadr t))))
     235              (let* ((name (and (named? t) (cadr t)))
     236                     (rtypes (if name (cdddr t) (cddr t))))
    234237                `(procedure
    235238                  ,@(if name (list name) '())
    236239                  ,(map simplify (if name (third t) (second t)))
    237                   ,@(map simplify (if name (cdddr t) (cddr t))))))
     240                  ,@(if (eq? '* rtypes)
     241                        '*
     242                        (map simplify rtypes)))))
    238243             (else t))
    239244           t))))
     
    417422    (let ((ptype (car args))
    418423          (nargs (length (cdr args))))
    419       (check
    420        `(procedure ,(make-list nargs '*) *)
    421        ptype
    422        loc "a procedure of type" (pname))
     424      (unless (procedure-type? ptype)
     425        (check
     426         `(procedure ,(make-list nargs '*) *)
     427         ptype
     428         loc "a procedure of type" (pname)))
    423429      (let ((atypes (procedure-argument-types ptype (length (cdr args)))))
    424430        (d "  argument-types: ~a" atypes)
     
    438444          (d  "  result-types: ~a" r)
    439445          r))))
     446  (define (procedure-type? t)
     447    (or (eq? 'procedure t)
     448        (and (pair? t) (eq? 'procedure (car t)))))
    440449  (define (procedure-argument-types t n)
    441450    (cond ((or (memq t '(* procedure))
     
    520529                              r)))))))
    521530               ((set!)
    522                 (let ((rt (single
    523                            (sprintf "in assignment to `~a'" (first params))
    524                            (walk (first subs) e loc (first params))
    525                            loc)))
     531                (let* ((var (first params))
     532                       (rt (single
     533                            (sprintf "in assignment to `~a'" var)
     534                            (walk (first subs) e loc var)
     535                            loc))
     536                       (b (assq var e)) )
     537                  (when (and b (eq? 'undefined (cdr b)))
     538                    (set-cdr! b rt))
    526539                  '(undefined)))
    527540               ((##core#primitive ##core#inline_ref) '*)
     
    530543                                   (single
    531544                                    "in procedure call argument"
    532                                     (walk n e loc #f) loc)) subs)))
     545                                    (walk n e loc #f) loc))
     546                                 subs)))
    533547                  (call-result args e loc (first subs) params)))
    534548               ((##core#switch ##core#cond)
  • chicken/branches/scrutiny/types.db

    r14417 r14525  
    350350(on-exit (procedure on-exit (procedure () . *) undefined))
    351351(open-input-string (procedure open-input-string (string #!rest) port))
    352 (open-output-string (procedure open-output-string (string #!rest) port))
     352(open-output-string (procedure open-output-string (#!rest) port))
    353353(parentheses-synonyms (procedure parentheses-synonyms (#!optional *) *))
    354354(port-name (procedure port-name (#!optional port) *))
Note: See TracChangeset for help on using the changeset viewer.