~ chicken-core (chicken-5) d5e975fcc8faf822645feba2d943646b00b6ae68
commit d5e975fcc8faf822645feba2d943646b00b6ae68
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Aug 11 08:10:00 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Aug 11 08:10:00 2011 +0200
some tweaks for complex types
diff --git a/manual/Types b/manual/Types
index 17d58a09..d663d057 100644
--- a/manual/Types
+++ b/manual/Types
@@ -83,7 +83,6 @@ or {{:}} should follow the syntax given below:
<table>
<tr><th>TYPE</th><th>meaning</th></tr>
-<tr><td>{{*}}</td><td>any value</td></tr>
<tr><td>{{deprecated}}</td><td>any use of this variable will generate a warning</td></tr>
<tr><td>VALUETYPE</td><td></td></tr>
</table>
@@ -95,6 +94,7 @@ or {{:}} should follow the syntax given below:
<tr><td>{{(procedure [NAME] (VALUETYPE ... [#!optional VALUETYPE ...] [#!rest [VALUETYPE]]) . RESULTS)}}</td><td>procedure type, optionally with name</td></tr>
<tr><td>{{(VALUETYPE ... [#!optional VALUETYPE ...] [#!rest [VALUETYPE]] -> . RESULTS)}}</td><td>alternative procedure type syntax</td></tr>
<tr><td>{{(VALUETYPE -> VALUETYPE : VALUETYPE)}}</td><td>predicate procedure type</td></tr>
+<tr><td>COMPLEXTYPE</td><td></td></tr>
<tr><td>BASICTYPE</td><td></td></tr>
</table>
@@ -121,6 +121,12 @@ or {{:}} should follow the syntax given below:
<tr><td>{{number}}</td><td>fixnum or float</td></tr>
</table>
+<table>
+<tr><th>COMPLEXTYPE</th><th>meaning</th></tr>
+<tr><td>{{(pair TYPE1 TYPE2)}</td><td>pair with given component types</td></tr>
+<tr><td>{{(list TYPE)}</td><td>proper list with given element type</td></tr>
+<tr><td>{{(vector TYPE)}</td><td>vector with given element types</td></tr>
+
<table>
<tr><th>RESULTS</th><th>meaning</th></tr>
<tr><td>{{*}}</td><td>any number of unspecific results</td></tr>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 9428daa6..970504f2 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -28,7 +28,7 @@
(unit scrutinizer)
(hide match-specialization specialize-node! specialization-statistics
procedure-type? named? procedure-result-types procedure-argument-types
- noreturn-type? rest-type procedure-name d-depth generate-type-checks!
+ noreturn-type? rest-type procedure-name d-depth
noreturn-procedure-type?
compatible-types? type<=? initial-argument-types))
@@ -651,21 +651,6 @@
(if rest (alist-cons rest 'list e2) e2)
(add-loc dest loc)
#f #t (list initial-tag) #f)))
- ;; Disabled
- #;(when (and specialize
- dest
- (not
- (eq? 'no
- (variable-mark dest '##compiler#escape)))
- (variable-mark dest '##compiler#declared-type)
- escaping-procedures
- (not unsafe))
- (debugging 'x "checks argument-types" dest) ;XXX
- ;; [1] this is subtle: we don't want argtype-checks to be
- ;; generated for toplevel defs other than user-declared ones.
- ;; But since the ##compiler#declared-type mark is set AFTER
- ;; the lambda has been walked (see below, [2]), nothing is added.
- (generate-type-checks! n dest vars inits))
(list
(append
'(procedure)
@@ -914,6 +899,21 @@
(dd " or-simplify: ~a" ts2)
(simplify
`(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) )
+ ((pair)
+ (let ((tcar (simplify (second t)))
+ (tcdr (simplify (third t))))
+ (if (and (eq? '* tcar) (eq? '* tcdr))
+ 'pair
+ (let rec ((tr tcdr) (ts (list tcar)))
+ (cond ((eq? tr 'null) `(list (or ,@(reverse ts))))
+ ((and (pair? tr) (eq? 'pair (first tr)))
+ (rec (third tr) (cons (second tr) ts)))
+ (else `(pair ,tcar ,tcdr)))))))
+ ((vector list)
+ (let ((t2 (simplify (second t))))
+ (if (eq? ts '*)
+ (car t)
+ `(,(car t) ,t2))))
((procedure)
(let* ((name (and (named? t) (cadr t)))
(rtypes (if name (cdddr t) (cddr t))))
@@ -1382,104 +1382,6 @@
(make-list argc '*)))
-;;; generate type-checks for formal variables
-
-#;(define (generate-type-checks! node loc vars inits)
- ;; assumes type is validated
- (define (test t v)
- (case t
- ((null) `(##core#inline "C_eqp" ,v '()))
- ((eof) `(##core#inline "C_eofp" ,v))
- ((string) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_stringp" ,v)
- '#f))
- ((float) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_flonump" ,v)
- '#f))
- ((char) `(##core#inline "C_charp" ,v))
- ((fixnum) `(##core#inline "C_fixnump" ,v))
- ((number) `(##core#inline "C_i_numberp" ,v))
- ((list) `(##core#inline "C_i_listp" ,v))
- ((symbol) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_symbolp" ,v)
- '#f))
- ((pair) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_pairp" ,v)
- '#f))
- ((boolean) `(##core#inline "C_booleanp" ,v))
- ((procedure) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_closurep" ,v)
- '#f))
- ((vector) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_vectorp" ,v)
- '#f))
- ((pointer) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_pointerp" ,v)
- '#f))
- ((blob) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_byteblockp" ,v)
- '#f))
- ((pointer-vector) `(##core#inline "C_i_structurep" ,v 'pointer-vector))
- ((port) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_portp" ,v)
- '#f))
- ((locative) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_locativep" ,v)
- '#f))
- (else
- (case (car t)
- ((procedure) `(if (##core#inline "C_blockp" ,v)
- (##core#inline "C_closurep" ,v)
- '#f))
- ((or)
- (cond ((null? (cdr t)) '(##core#undefined))
- ((null? (cddr t)) (test (cadr t) v))
- (else
- `(if ,(test (cadr t) v)
- '#t
- ,(test `(or ,@(cddr t)) v)))))
- ((and)
- (cond ((null? (cdr t)) '(##core#undefined))
- ((null? (cddr t)) (test (cadr t) v))
- (else
- `(if ,(test (cadr t) v)
- ,(test `(and ,@(cddr t)) v)
- '#f))))
- ((not)
- `(not ,(test (cadr t) v)))
- (else (bomb "invalid type" t v))))))
- (let ((body (first (node-subexpressions node))))
- (let loop ((vars (reverse vars)) (inits (reverse inits)) (b body))
- (cond ((null? inits)
- (if (eq? b body)
- body
- (copy-node!
- (make-node
- (node-class node) ; lambda
- (node-parameters node)
- (list b))
- node)))
- ((eq? '* (car inits))
- (loop (cdr vars) (cdr inits) b))
- (else
- (loop
- (cdr vars) (cdr inits)
- (make-node
- 'let (list (gensym))
- (list
- (build-node-graph
- (let ((t (car inits))
- (v (car vars)))
- `(if ,(test t v)
- (##core#undefined)
- (##core#app
- ##sys#error ',loc
- ',(sprintf "expected argument `~a' to be of type `~s'"
- v t)
- ,v))))
- b))))))))
-
-
;;; hardcoded result types for certain primitives
(define-syntax define-special-case
Trap