~ chicken-core (chicken-5) 2a2abf7b7ed667a411860da0c91d1082b678fdf3
commit 2a2abf7b7ed667a411860da0c91d1082b678fdf3
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Aug 10 15:33:21 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Aug 10 15:33:21 2011 +0200
complex list/vector/pair types - untested and incomplete
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 700deaf8..5672d3ed 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -58,11 +58,13 @@
; | (struct NAME)
; | (procedure [NAME] (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL | values]]) . RESULTS)
; | BASIC
+; | COMPLEX
; | deprecated
; BASIC = * | string | symbol | char | number | boolean | list | pair |
; procedure | vector | null | eof | undefined | port |
; blob | noreturn | pointer | locative | fixnum | float |
; pointer-vector
+; COMPLEX = (pair VAL VAL) | (vector VAL) | (list VAL)
; RESULTS = *
; | (VAL1 ...)
;
@@ -115,10 +117,16 @@
(else 'number))) ; in case...
((boolean? lit) 'boolean)
((null? lit) 'null)
- ((pair? lit) 'pair)
- ((list? lit) 'list)
+ ((list? lit)
+ (simplify-type
+ `(list (or ,@(map constant-result lit)))))
+ ((pair? lit)
+ (simplify-type
+ `(pair ,(constant-result (car lit)) ,(constant-result (cdr lit)))))
((eof-object? lit) 'eof)
- ((vector? lit) 'vector)
+ ((vector? lit)
+ (simplify-type
+ `(vector (or ,@(map constant-result lit)))))
((and (not (##sys#immediate? lit)) (##sys#generic-structure? lit))
`(struct ,(##sys#slot lit 0)))
((char? lit) 'char)
@@ -253,9 +261,18 @@
((eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))))
((and (pair? t1) (eq? 'or (car t1))) (any (cut match <> t2) (cdr t1)))
((and (pair? t2) (eq? 'or (car t2))) (any (cut match t1 <>) (cdr t2)))
- ((eq? t1 'pair) (memq t2 '(pair list)))
- ((eq? t1 'list) (memq t2 '(pair list null)))
- ((eq? t1 'null) (memq t2 '(null list)))
+ ((eq? t1 'pair) (match1 '(pair * *) t2))
+ ((eq? t2 'pair) (match1 t1 '(pair * *)))
+ ((eq? t1 'list) (match1 '(list *) t2))
+ ((eq? t2 'list) (match1 t1 '(list *)))
+ ((eq? t1 'vector) (match1 '(vector *) t2))
+ ((eq? t2 'vector) (match1 t1 '(vector *)))
+ ((eq? t1 'null)
+ (or (memq t2 '(null list))
+ (and (pair? t2) (eq? 'list (car t2)))))
+ ((eq? t2 'null)
+ (or (memq t1 '(null list))
+ (and (pair? t1) (eq? 'list (car t1)))))
((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))
(case (car t1)
((procedure)
@@ -266,7 +283,31 @@
(and (match-args args1 args2)
(match-results results1 results2))))
((struct) (equal? t1 t2))
+ ((pair) (every match1 (cdr t1) (cdr t2)))
+ ((list vector) (match1 (second t1) (second t2)))
(else #f) ) )
+ ((and (pair? t1) (eq? 'pair (car t1)))
+ (and (pair? t2)
+ (eq? 'list (car t2))
+ (match1 (second t1) (second t2))
+ (match1 (third t1) t2)))
+ ((and (pair? t2) (eq? 'pair (car t2)))
+ (and (pair? t1)
+ (eq? 'list (car t1))
+ (match1 (second t1) (second t2))
+ (match1 t1 (third t2))))
+ ((and (pair? t1) (eq? 'list (car t1)))
+ (or (eq? 'null t2)
+ (and (pair? t2)
+ (eq? 'pair? (car t2))
+ (match1 (second t1) (second t2))
+ (match1 t1 (third t2)))))
+ ((and (pair? t2) (eq? 'list (car t2)))
+ (or (eq? 'null t1)
+ (and (pair? t1)
+ (eq? 'pair? (car t1))
+ (match1 (second t1) (second t2))
+ (match1 (third t1) t2))))
(else #f)))
(define (match-args args1 args2)
@@ -929,69 +970,87 @@
(type<=? t2 t1)))
(define (type<=? t1 t2)
- (or (eq? t1 t2)
- (memq t2 '(* undefined))
- (case t2
- ((list) (memq t1 '(null pair)))
- ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
- ((number) (memq t1 '(fixnum float)))
+ (cond ((eq? t1 t2))
+ ((memq t2 '(* undefined)))
+ ((eq? 'pair t1) (type<=? '(pair * *) t2))
+ ((memq t1 '(vector list)) (type<=? `(,(car t1) *) t2))
+ ((and (eq? 'null t1)
+ (pair? t2)
+ (memq (car t1) '(pair list))))
(else
- (and (pair? t1) (pair? t2)
- (case (car t1)
- ((or) (every (cut type<=? <> t2) (cdr t1)))
- ((procedure)
- (let ((args1 (if (named? t1) (caddr t1) (cadr t1)))
- (args2 (if (named? t2) (caddr t2) (cadr t2)))
- (res1 (if (named? t1) (cdddr t1) (cddr t1)))
- (res2 (if (named? t2) (cdddr t2) (cddr t2))) )
- (let loop1 ((args1 args1)
- (args2 args2)
- (rtype1 #f)
- (rtype2 #f)
- (m1 0)
- (m2 0))
- (cond ((null? args1)
- (and (cond ((null? args2)
- (if rtype1
- (if rtype2
- (type<=? rtype1 rtype2)
- #f)
- #t))
- ((eq? '#!optional (car args2))
- (not rtype1))
- ((eq? '#!rest (car args2))
- (or (null? (cdr args2))
- rtype1
- (type<=? rtype1 (cadr args2))))
- (else (>= m2 m1)))
- (let loop2 ((res1 res1) (res2 res2))
- (cond ((eq? '* res2) #t)
- ((null? res2) (null? res1))
- ((eq? '* res1) #f)
- ((type<=? (car res1) (car res2))
- (loop2 (cdr res1) (cdr res2)))
- (else #f)))))
- ((eq? (car args1) '#!optional)
- (loop1 (cdr args1) args2 #f rtype2 1 m2))
- ((eq? (car args1) '#!rest)
- (if (null? (cdr args1))
- (loop1 '() args2 '* rtype2 2 m2)
- (loop1 '() args2 (cadr args1) rtype2 2 m2)))
- ((null? args2)
- (and rtype2
- (type<=? (car args1) rtype2)
- (loop1 (cdr args1) '() rtype1 rtype2 m1 m2)))
- ((eq? (car args2) '#!optional)
- (loop1 args1 (cdr args2) rtype1 #f m1 1))
- ((eq? (car args2) '#!rest)
- (if (null? (cdr args2))
- (loop1 args1 '() rtype1 '* m1 2)
- (loop1 args1 '() rtype1 (cadr args2) m1 2)))
- ((type<=?
- (or rtype1 (car args1))
- (or rtype2 (car args2)))
- (loop1 (cdr args1) (cdr args2) rtype1 rtype2 m1 m2))
- (else #f)))))))))))
+ (case t2
+ ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
+ ((number) (memq t1 '(fixnum float)))
+ ((vector list) (type<=? t1 `(,(car t2) *)))
+ ((pair) (type<=? t1 '(pair * *)))
+ (else
+ (and (pair? t1) (pair? t2)
+ (case (car t1)
+ ((or) (every (cut type<=? <> t2) (cdr t1)))
+ ((vector) (type<=? (second t1) (second t2)))
+ ((list)
+ (case (car t2)
+ ((list) (type<=? (second t1) (second t2)))
+ ((pair)
+ (and (type<=? (second t1) (second t2))
+ (type<=? t1 (third t2))))
+ (else #f)))
+ ((pair) (every type<=? (cdr t1) (cdr t2)))
+ ((procedure)
+ (let ((args1 (if (named? t1) (caddr t1) (cadr t1)))
+ (args2 (if (named? t2) (caddr t2) (cadr t2)))
+ (res1 (if (named? t1) (cdddr t1) (cddr t1)))
+ (res2 (if (named? t2) (cdddr t2) (cddr t2))) )
+ (let loop1 ((args1 args1)
+ (args2 args2)
+ (rtype1 #f)
+ (rtype2 #f)
+ (m1 0)
+ (m2 0))
+ (cond ((null? args1)
+ (and (cond ((null? args2)
+ (if rtype1
+ (if rtype2
+ (type<=? rtype1 rtype2)
+ #f)
+ #t))
+ ((eq? '#!optional (car args2))
+ (not rtype1))
+ ((eq? '#!rest (car args2))
+ (or (null? (cdr args2))
+ rtype1
+ (type<=? rtype1 (cadr args2))))
+ (else (>= m2 m1)))
+ (let loop2 ((res1 res1) (res2 res2))
+ (cond ((eq? '* res2) #t)
+ ((null? res2) (null? res1))
+ ((eq? '* res1) #f)
+ ((type<=? (car res1) (car res2))
+ (loop2 (cdr res1) (cdr res2)))
+ (else #f)))))
+ ((eq? (car args1) '#!optional)
+ (loop1 (cdr args1) args2 #f rtype2 1 m2))
+ ((eq? (car args1) '#!rest)
+ (if (null? (cdr args1))
+ (loop1 '() args2 '* rtype2 2 m2)
+ (loop1 '() args2 (cadr args1) rtype2 2 m2)))
+ ((null? args2)
+ (and rtype2
+ (type<=? (car args1) rtype2)
+ (loop1 (cdr args1) '() rtype1 rtype2 m1 m2)))
+ ((eq? (car args2) '#!optional)
+ (loop1 args1 (cdr args2) rtype1 #f m1 1))
+ ((eq? (car args2) '#!rest)
+ (if (null? (cdr args2))
+ (loop1 args1 '() rtype1 '* m1 2)
+ (loop1 args1 '() rtype1 (cadr args2) m1 2)))
+ ((type<=?
+ (or rtype1 (car args1))
+ (or rtype2 (car args2)))
+ (loop1 (cdr args1) (cdr args2) rtype1 rtype2 m1 m2))
+ (else #f)))))
+ (else #f))))))))
+
(define (procedure-type? t)
(or (eq? 'procedure t)
@@ -1138,6 +1197,7 @@
(define (match-specialization typelist atypes exact)
;; - does not accept complex procedure types in typelist!
;; - "exact" means: "or"-type in atypes is not allowed
+ ;;XXX doesn't handle complex "list", "pair" and "vector" types
(define (match st t)
(cond ((eq? st t))
((pair? st)
@@ -1253,6 +1313,14 @@
(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 (car t) '(vector list))
+ (and (= 2 (length t))
+ (let ((t2 (validate (second t))))
+ (and t2 `(,(car t) ,t2)))))
((eq? 'procedure (car t))
(and (pair? (cdr t))
(let* ((name (if (symbol? (cadr t))
Trap