~ chicken-core (chicken-5) 2817709c1d58e220fa2e29fc265ece3547c2597a
commit 2817709c1d58e220fa2e29fc265ece3547c2597a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Aug 19 13:27:06 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Aug 19 13:27:06 2011 +0200
countless tests and fixes
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 47d597ac..284b6ddb 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1267,7 +1267,7 @@
'compiler-typecase '()
(##sys#er-transformer
(lambda (x r c)
- (##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 0)))
+ (##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1)))
(let ((var (gensym)))
`(##core#let ((,var ,(cadr x)))
(##core#typecase
diff --git a/eval.scm b/eval.scm
index b47228b3..35a45f8f 100644
--- a/eval.scm
+++ b/eval.scm
@@ -50,6 +50,9 @@
(include "common-declarations.scm")
+(define-syntax d (syntax-rules () ((_ . _) (void))))
+
+
(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
(define-foreign-variable binary-version int "C_BINARY_VERSION")
diff --git a/scrutinizer.scm b/scrutinizer.scm
index d63e42ba..02229131 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -398,9 +398,9 @@
(and (pair? specs)
(let* ((spec (car specs))
(stype (first spec))
- (tenv2 (append (type-typeenv stype) typeenv)))
+ (tenv2 (append (append-map type-typeenv stype) typeenv)))
(cond ((match-argument-types
- (first (car specs)) (cdr args) tenv2
+ stype (cdr args) tenv2
#t)
(set! op (cons pn (car spec)))
(set! typeenv tenv2)
@@ -1387,7 +1387,12 @@
(let resolve ((t t))
(cond ((not t) '*) ; unbound type-variable
((assq t typeenv) => (lambda (a) (resolve (cdr a))))
- ((not (pair? t)) t)
+ ((not (pair? t))
+ (if (memq t '(* fixnum eof char string symbol float number list vector pair
+ undefined blob port pointer locative boolean pointer-vector
+ null procedure noreturn))
+ t
+ (bomb "can't resolve unknown type-variable" t)))
(else
(case (car t)
((or) `(or ,@(map resolve (cdr t))))
@@ -1403,7 +1408,11 @@
,(let loop ((args argtypes))
(cond ((null? args) '())
((eq? '#!rest (car args))
- (cons '#!rest (loop (cdr args))))
+ (if (equal? '(values) (cdr args))
+ args
+ (cons (car args) (loop (cdr args)))))
+ ((eq? '#!optional (car args))
+ (cons (car args) (loop (cdr args))))
(else (cons (resolve (car args)) (loop (cdr args))))))
,@(if (eq? '* rtypes)
'*
@@ -1563,16 +1572,17 @@
deprecated noreturn values))
t)
((not (pair? t))
- (when (memq t typevars)
- (set! usedvars (cons t usedvars)))
- t)
+ (cond ((memq t typevars)
+ (set! usedvars (cons t usedvars))
+ t)
+ (else #f)))
((eq? 'forall (car t))
(and (= 3 (length t))
(list? (second t))
(every symbol? (second t))
(begin
(set! typevars (append (second t) typevars))
- (validate (third t)))))
+ (validate (third t) rec))))
((eq? 'or (car t))
(and (list? t)
(let ((ts (map validate (cdr t))))
@@ -1582,14 +1592,30 @@
(and (= 2 (length t))
(symbol? (cadr t))
t))
- ((eq? 'pair (car t))
- (and (= 3 (length t))
- (let ((ts (map validate (cdr t))))
- (and ts `(pair ,@ts)))))
+ ((memq '-> t) =>
+ (lambda (p)
+ (let ((cp (memq ': (cdr p))))
+ (cond ((not cp)
+ (validate
+ `(procedure ,(upto t p) ,@(cdr p))
+ rec))
+ ((and (= 5 (length t))
+ (eq? p (cdr t))
+ (eq? cp (cdddr t)))
+ (set! t (validate `(procedure (,(first t)) ,(third t)) rec))
+ ;; we do it this way to distinguish the "outermost" predicate
+ ;; procedure type
+ (set! ptype (cons t (validate (cadr cp))))
+ t)
+ (else #f)))))
((memq (car t) '(vector list))
(and (= 2 (length t))
(let ((t2 (validate (second t))))
(and t2 `(,(car t) ,t2)))))
+ ((eq? 'pair (car t))
+ (and (= 3 (length t))
+ (let ((ts (map validate (cdr t))))
+ (and ts `(pair ,@ts)))))
((eq? 'procedure (car t))
(and (pair? (cdr t))
(let* ((name (if (symbol? (cadr t))
@@ -1613,32 +1639,18 @@
,@(if (and name (not rec)) (list name) '())
,ts
,@rt)))))))))
- ((and (pair? (cdr t)) (memq '-> (cdr t))) =>
- (lambda (p)
- (let ((cp (memq ': (cdr t))))
- (cond ((not cp)
- (validate
- `(procedure ,(upto t p) ,@(cdr p))
- rec))
- ((and (= 5 (length t))
- (eq? p (cdr t))
- (eq? cp (cdddr t)))
- (set! t (validate `(procedure (,(first t)) ,(third t)) rec))
- ;; we do it this way to distinguish the "outermost" predicate
- ;; procedure type
- (set! ptype (cons t (validate (cadr cp))))
- t)
- (else #f)))))
(else #f)))
- (let ((type (validate type #f)))
- (when (pair? typevars)
- (set! type
- `(forall ,(filter-map
- (lambda (v) (and (memq v usedvars) v))
- (delete-duplicates typevars eq?))
- ,type)))
- (let ((type (simplify-type type)))
- (values type (and ptype (eq? (car ptype) type) (cdr ptype)))))))
+ (cond ((validate type #f) =>
+ (lambda (type)
+ (when (pair? typevars)
+ (set! type
+ `(forall ,(filter-map
+ (lambda (v) (and (memq v usedvars) v))
+ (delete-duplicates typevars eq?))
+ ,type)))
+ (let ((type (simplify-type type)))
+ (values type (and ptype (eq? (car ptype) type) (cdr ptype))))))
+ (else (values #f #f)))))
;;; hardcoded result types for certain primitives
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 05532ae9..4f1304f6 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -70,8 +70,9 @@ $compile inlining-tests.scm -optimize-level 3
./a.out
echo "======================================== scrutiny tests ..."
-$compile typematch-tests.scm -scrutinize -analyze-only
-$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out -verbose
+$compile typematch-tests.scm -scrutinize
+./a.out
+$compile scrutiny-tests.scm -scrutinize -ignore-repository -types ../types.db 2>scrutiny.out -verbose
if test -n "$MSYSTEM"; then
dos2unix scrutiny.out
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index e735bbde..d05af2de 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -8,7 +8,8 @@
(compiler-typecase x
(t 'ok))
(compiler-typecase not-x
- ((not t) 'ok))))))
+ ((not t) 'ok))
+ (ms t x not-x)))))
(define-syntax checkp
(syntax-rules ()
@@ -20,6 +21,70 @@
(compiler-typecase (##sys#make-structure 'foo)
((not t) 'ok))))))
+(define (bar) 42)
+
+(define-syntax m
+ (er-macro-transformer
+ (lambda (x r c)
+ (let ((t1 (cadr x))
+ (t2 (caddr x))
+ (foo1 (gensym 'foo1))
+ (foo2 (gensym 'foo2)))
+ `(begin
+ (print t1 " = " t2)
+ (: ,foo1 (-> ,t1))
+ (: ,foo2 (-> ,t2))
+ (define (,foo1) (bar))
+ (define (,foo2) (bar))
+ (compiler-typecase (,foo1)
+ (,t2 'ok))
+ (print t2 " = " t1)
+ (compiler-typecase (,foo2)
+ (,t1 'ok)))))))
+
+(define-syntax mn
+ (er-macro-transformer
+ (lambda (x r c)
+ (let ((t1 (cadr x))
+ (t2 (caddr x))
+ (foo1 (gensym 'foo1))
+ (foo2 (gensym 'foo2)))
+ `(begin
+ (print t1 " != " t2)
+ (: ,foo1 (-> ,t1))
+ (: ,foo2 (-> ,t2))
+ (define (,foo1) (bar))
+ (define (,foo2) (bar))
+ (compiler-typecase (,foo1)
+ (,t2 (bomb))
+ (else 'ok))
+ (print t2 " != " t1)
+ (compiler-typecase (,foo2)
+ (,t1 (bomb))
+ (else 'ok)))))))
+
+(define-syntax ms
+ (er-macro-transformer
+ (lambda (x r c)
+ (let ((fname (gensym))
+ (fname2 (gensym))
+ (type (cadr x))
+ (val (caddr x))
+ (nval (cadddr x)))
+ `(begin
+ (print "specialize " type)
+ (: ,fname (,type -> *)
+ ((,type) 'ok)
+ (((not ,type)) 'ok-too))
+ (define (,fname x) (bomb))
+ (assert (eq? 'ok (,fname ,val)))
+ (assert (eq? 'ok-too (,fname ,nval)))
+ (: ,fname2 (* -> *)
+ (((not ,type)) (bomb)))
+ (define (,fname2 x) 'ok)
+ (print "specialize not " type)
+ (,fname2 ,val))))))
+
;;;
@@ -73,3 +138,12 @@
(checkp pointer-vector? (make-pointer-vector 1) pointer-vector)
(checkp pointer? (address->pointer 1) pointer)
+(m number fixnum)
+(m number float)
+(m list null)
+(mn list pair)
+(m pair (pair number string))
+(m procedure (procedure () *))
+(mn (procedure (*) *) (procedure () *))
+(m (procedure (#!rest) . *) (procedure (*) . *))
+(mn (procedure () *) (procedure () * *))
Trap