~ chicken-core (chicken-5) 6ac34c65c951379e4f4dea252f4e796958e99fed
commit 6ac34c65c951379e4f4dea252f4e796958e99fed
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 22 12:59:11 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 22 12:59:11 2011 +0200
more bugfixes; found some bugs in core libs
diff --git a/TODO b/TODO
index 48e41113..00e9c199 100644
--- a/TODO
+++ b/TODO
@@ -13,3 +13,58 @@ TODO -*- Outline -*-
* test self-build
* run mini-salmonella
+
+* bugs found:
+
+** irregex-core:
+
+Note: in local procedure `lp',
+ in local procedure `collect/terms',
+ in local procedure `lp',
+ in toplevel procedure `string->sre':
+ irregex-core.scm:806: in procedure call to `pair?', the predicate is called with an argument of type
+ `(pair * *)' and will always return true
+
+> `(if ,(cadr res)
+> ,(if (pair? (cdr res))
+
+Note: in local procedure `lp',
+ in local procedure `collect/terms',
+ in local procedure `lp',
+ in toplevel procedure `string->sre':
+ irregex-core.scm:811: in procedure call to `pair?', the predicate is called with an argument of type
+ `(pair (pair * (pair * *)) *)' and will always return true
+
+> `(if ,(cadadr res)
+> ,(if (pair? (cdr res))
+
+Note: in local procedure `lp',
+ in local procedure `collect/terms',
+ in local procedure `lp',
+ in toplevel procedure `string->sre':
+ irregex-core.scm:815: in procedure call to `pair?', the predicate is called with an argument of type
+ `(pair (pair * (pair * *)) *)' and will always return true
+
+ `(if ,(cadadr res)
+ ,(if (pair? (cdr res))
+ (sre-sequence (cddadr res))
+ 'epsilon)
+ ,(sre-alternate
+ (if (pair? (cdr res)) (cddr res) '())))))
+
+** compiler-syntax.scm
+
+Note: in toplevel procedure `##compiler#r-c-s':
+ compiler-syntax.scm:53: in procedure call to `symbol?', the predicate is called with an argument of type
+ `(pair * *)' and will always return false
+
+(define (r-c-s names transformer #!optional (se '()))
+ (let ((t (cons (##sys#ensure-transformer
+ (##sys#er-transformer transformer)
+ (car names))
+ se)))
+ (for-each
+ (lambda (name)
+ (##sys#put! name '##compiler#compiler-syntax t) )
+ names) ) )
+ (if (symbol? names) (list names) names) ) ) ) ; <-
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 290acf3b..337d35e9 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -50,7 +50,7 @@
(for-each
(lambda (name)
(##sys#put! name '##compiler#compiler-syntax t) )
- (if (symbol? names) (list names) names) ) ) )
+ names) ) )
(define-syntax define-internal-compiler-syntax
(syntax-rules ()
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 2978cc00..5a2629c8 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -30,7 +30,7 @@
procedure-type? named? procedure-result-types procedure-argument-types
noreturn-type? rest-type procedure-name d-depth
noreturn-procedure-type? trail trail-restore
- typename multiples
+ typename multiples procedure-arguments procedure-results
compatible-types? type<=? match-types resolve match-argument-types))
@@ -452,8 +452,10 @@
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
- (dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, e: ~a)"
- class params loc dest tail flow blist e)
+ (dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a)"
+ class params loc dest tail flow blist)
+ ;;(dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, e: ~a)"
+ ;; class params loc dest tail flow blist e)
(set! d-depth (add1 d-depth))
(let ((results
(case class
@@ -513,6 +515,7 @@
(cond (nor1 r2)
(nor2 r1)
(else
+ (dd "merge branch results: ~s + ~s" r1 r2)
(map (lambda (t1 t2)
(simplify-type `(or ,t1 ,t2)))
r1 r2))))
@@ -548,6 +551,7 @@
(when dest
(d "~a: initial-argument types: ~a" dest inits))
(fluid-let ((blist '())
+ (noreturn #f)
(aliased '()))
(let* ((initial-tag (tag))
(r (walk (first subs)
@@ -584,10 +588,13 @@
(sprintf "in assignment to `~a'" var)
(walk (first subs) e loc var #f flow #f)
loc))
+ (typeenv (append
+ (if type (type-typeenv type) '())
+ (type-typeenv rt)))
(b (assq var e)) )
(when (and type (not b)
(not (eq? type 'deprecated))
- (not (match-types type rt '())))
+ (not (match-types type rt typeenv)))
;;XXX make this an error with strict-types?
(report
loc
@@ -653,7 +660,9 @@
(walk n e loc dest tail flow ctags)
;; keep type, as the specialization may contain icky stuff
;; like "##core#inline", etc.
- (resolve r typeenv))
+ (if (eq? '* r)
+ r
+ (map (cut resolve <> typeenv) r)))
(else
(for-each
(lambda (arg argr)
@@ -757,7 +766,7 @@
(for-each (lambda (n) (walk n e loc #f #f flow #f)) subs)
'*))))
(set! d-depth (sub1 d-depth))
- (dd " -> ~a" results)
+ (dd " ~a -> ~a" class results)
results)))
(let ((rn (walk (first (node-subexpressions node)) '() '() #f #f (list (tag)) #f)))
@@ -895,17 +904,24 @@
(define (match1 t1 t2)
;; note: the order of determining the type is important
- ;(dd " match1: ~s <-> ~s" t1 t2)
+ (dd " match1: ~s <-> ~s" t1 t2)
(cond ((eq? t1 t2))
((and (symbol? t1) (assq t1 typeenv)) =>
(lambda (e)
- (if (cdr e)
- (match1 (cdr e) t2)
- (begin
- (dd " unify ~a = ~a" t1 t2)
- (set! trail (cons t1 trail))
- (set-cdr! e t2)
- #t))))
+ (cond ((cdr e) (match1 (cdr e) t2))
+ ;; special case for two unbound typevars
+ ((and (symbol? t2) (assq t2 typeenv)) =>
+ (lambda (e2)
+ ;;XXX probably not fully right, consider:
+ ;; (forall (a b) ((a a b) ->)) + (forall (c d) ((c d d) ->))
+ ;; or is this not a problem? I don't know right now...
+ (or (not (cdr e2))
+ (match1 t1 (cdr e2)))))
+ (else
+ (dd " unify ~a = ~a" t1 t2)
+ (set! trail (cons t1 trail))
+ (set-cdr! e t2)
+ #t))))
((and (symbol? t2) (assq t2 typeenv)) =>
(lambda (e)
(if (cdr e)
@@ -970,10 +986,10 @@
((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))
(case (car t1)
((procedure)
- (let ((args1 (if (named? t1) (third t1) (second t1)))
- (args2 (if (named? t2) (third t2) (second t2)))
- (results1 (if (named? t1) (cdddr t1) (cddr t1)))
- (results2 (if (named? t2) (cdddr t2) (cddr t2))) )
+ (let ((args1 (procedure-arguments t1))
+ (args2 (procedure-arguments t2))
+ (results1 (procedure-results t1))
+ (results2 (procedure-results t2)))
(and (match-args args1 args2)
(match-results results1 results2))))
((struct) (equal? t1 t2))
@@ -1459,9 +1475,8 @@
((pair list vector)
(cons (car t) (map resolve (cdr t))))
((procedure)
- (let* ((n (named? t))
- (argtypes ((if n third second) t))
- (rtypes ((if n cdddr cddr) t)))
+ (let* ((argtypes (procedure-arguments t))
+ (rtypes (procedure-results t)))
`(procedure
,(let loop ((args argtypes))
(cond ((null? args) '())
diff --git a/setup-api.scm b/setup-api.scm
index 72738573..a61a4bbf 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -381,8 +381,8 @@
((string? reason)
(string-append " because " reason " changed"))
(else
- (string-append (sprintf " just because (reason: ~a date: ~a)"
- reason date)))) ) )
+ (sprintf " just because (reason: ~a date: ~a)"
+ reason date)))) )
(handle-exceptions exn
(begin
(printf "make: Failed to make ~a: ~a~%"
diff --git a/types.db.new b/types.db.new
index 2870bfe7..db17f7f6 100644
--- a/types.db.new
+++ b/types.db.new
@@ -505,7 +505,8 @@
(vector? (procedure? vector vector? (*) boolean))
-(make-vector (forall (a) (procedure! make-vector (fixnum #!optional a) (vector a))))
+;; not result type "(vector a)", since it may be mutated!
+(make-vector (forall (a) (procedure! make-vector (fixnum #!optional a) vector)))
(vector-ref (forall (a) (procedure! vector-ref ((vector a) fixnum) a)))
(##sys#vector-ref (forall (a) (procedure! ##sys#vector-ref ((vector a) fixnum) a)))
@@ -1079,7 +1080,7 @@
(binary-search (forall (a) (procedure! binary-search ((vector a) (procedure (a) *)) *)))
(butlast (forall (a) (procedure! butlast ((pair a *)) (list a))))
(chop (forall (a) (procedure! chop ((list a) fixnum) (list a))))
-(complement (procedure! complement ((procedure (#!rest) *) (procedure (#!rest) boolean))))
+(complement (procedure! complement ((procedure (#!rest) *)) (procedure (#!rest) boolean)))
(compose (procedure! compose (#!rest procedure) procedure))
(compress (forall (a) (procedure! compress (list (list a)) (list a))))
(conc (procedure conc (#!rest) string))
@@ -1452,7 +1453,10 @@
(create-pipe (procedure create-pipe () fixnum fixnum))
(create-session (procedure create-session () fixnum))
(create-symbolic-link (procedure! create-symbolic-link (string string) undefined))
-(current-directory (procedure! current-directory (#!optional string) string))
+
+;; extra arg for "parameterize" - ugh, what a hack...
+(current-directory (procedure! current-directory (#!optional string *) string))
+
(current-effective-group-id (procedure current-effective-group-id () fixnum))
(current-effective-user-id (procedure current-effective-user-id () fixnum))
(current-effective-user-name (procedure current-effective-user-name () string))
@@ -1799,11 +1803,16 @@
(lset=
(forall (a) (procedure! lset= ((procedure (a a) *) (list a) #!rest (list a)) boolean)))
-(make-list (forall (a) (procedure! make-list (fixnum #!optional a) (list a))))
-(map! (forall (a b) (procedure! map! ((procedure (a #!rest) b) (list a) #!rest list) (list b))))
+;; see note about "make-vector", above
+(make-list (forall (a) (procedure! make-list (fixnum #!optional a) list)))
+
+(map!
+ (forall (a b) (procedure! map! ((procedure (a #!rest) b) (list a) #!rest list) (list b))))
(map-in-order
- (forall (a b) (procedure! map-in-order ((procedure (a #!rest) b) (list a) #!rest list) (list b))))
+ (forall
+ (a b)
+ (procedure! map-in-order ((procedure (a #!rest) b) (list a) #!rest list) (list b))))
(ninth (procedure! ninth (pair) *))
Trap