~ chicken-core (chicken-5) 73ee51ffa0467d8b7116fb478f293dc5867bd66d
commit 73ee51ffa0467d8b7116fb478f293dc5867bd66d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 29 04:28:04 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 29 04:28:04 2011 +0200
repaired define-specialization; various bugfixes; will this ever end?
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 9cb1f655..c9ba3428 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1103,29 +1103,6 @@
(##core#let-compiler-syntax (binding ...) body ...))))
-;;; type-declaration syntax
-
-(##sys#extend-macro-environment
- ': '()
- (##sys#er-transformer
- (lambda (x r c)
- (##sys#check-syntax ': x '(_ symbol _ . _))
- (if (memq #:csi ##sys#features)
- '(##core#undefined)
- (let* ((type1 (##sys#strip-syntax (caddr x)))
- (name1 (cadr x)))
- (let-values (((type pred pure)
- (##compiler#validate-type type1 (##sys#strip-syntax name1))))
- (cond ((not type)
- (syntax-error ': "invalid type syntax" name1 type1))
- (else
- `(##core#declare
- (type (,name1 ,type ,@(cdddr x)))
- ,@(if pure `((pure ,name1)) '())
- (enforce-argument-types ,name1)
- ,@(if pred `((predicate (,name1 ,pred))) '()))))))))))
-
-
;;; interface definition
(##sys#extend-macro-environment
@@ -1180,7 +1157,27 @@
(begin-for-syntax ,registration))))))
-;;; inline type declaration
+;;; type-related syntax
+
+(##sys#extend-macro-environment
+ ': '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax ': x '(_ symbol _ . _))
+ (if (memq #:csi ##sys#features)
+ '(##core#undefined)
+ (let* ((type1 (##sys#strip-syntax (caddr x)))
+ (name1 (cadr x)))
+ (let-values (((type pred pure)
+ (##compiler#validate-type type1 (##sys#strip-syntax name1))))
+ (cond ((not type)
+ (syntax-error ': "invalid type syntax" name1 type1))
+ (else
+ `(##core#declare
+ (type (,name1 ,type1 ,@(cdddr x)))
+ ,@(if pure `((pure ,name1)) '())
+ (enforce-argument-types ,name1)
+ ,@(if pred `((predicate (,name1 ,pred))) '()))))))))))
(##sys#extend-macro-environment
'the '()
@@ -1202,14 +1199,14 @@
(lambda (x r c)
(cond ((memq #:csi ##sys#features) '(##core#undefined))
(else
- (##sys#check-syntax 'define-specialization x '(_ (symbol . #(_ 0)) _ . #(_ 0 1)))
+ (##sys#check-syntax 'define-specialization x '(_ (variable . #(_ 0)) _ . #(_ 0 1)))
(let* ((head (cadr x))
(name (car head))
(gname (##sys#globalize name '())) ;XXX correct?
(args (cdr head))
(alias (gensym name))
(galias (##sys#globalize alias '())) ;XXX and this?
- (rtypes (and (pair? (cdddr x)) (caddr x)))
+ (rtypes (and (pair? (cdddr x)) (##sys#strip-syntax (caddr x))))
(%define (r 'define))
(body (if rtypes (cadddr x) (caddr x))))
(let loop ((args args) (anames '()) (atypes '()))
@@ -1256,7 +1253,9 @@
(loop (cdr args) (cons arg anames) (cons '* atypes)))
((and (list? arg) (fx= 2 (length arg)) (symbol? (car arg)))
(let-values (((t pred pure)
- (##compiler#validate-type (cadr arg) #f)))
+ (##compiler#validate-type
+ (##sys#strip-syntax (cadr arg))
+ #f)))
(if t
(loop
(cdr args)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 027fecbf..eabd2b4d 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -315,16 +315,16 @@
(resolve ptype typeenv)))
(values '* #f))
(else
- (let-values (((atypes values-rest)
+ (let-values (((atypes values-rest ok alen)
(procedure-argument-types ptype nargs typeenv)))
- (unless (= (length atypes) nargs)
- (let ((alen (length atypes)))
- (report
- loc
- (sprintf
- "~aexpected ~a argument~a, but was given ~a argument~a"
- (pname) alen (multiples alen)
- nargs (multiples nargs)))))
+ (unless ok
+ (report
+ loc
+ (sprintf
+ "~aexpected ~a argument~a, but was given ~a argument~a"
+ (pname)
+ alen (multiples alen)
+ nargs (multiples nargs))))
(do ((args (cdr args) (cdr args))
(atypes atypes (cdr atypes))
(i 1 (add1 i)))
@@ -661,6 +661,8 @@
(smash-component-types! e "env")
(smash-component-types! blist "blist")))
(cond (specialized?
+ ;;XXX this will walk the arguments again, resulting in
+ ;; duplicate warnings
(walk n e loc dest tail flow ctags)
(smash)
;; keep type, as the specialization may contain icky stuff
@@ -1386,17 +1388,22 @@
(else (bomb "procedure-results: not a procedure type" t)))))
(define (procedure-argument-types t n typeenv #!optional norest)
- (let loop1 ((t t) (done '())
+ (let loop1 ((t t) (done '()))
(cond ((and (pair? t)
(eq? 'procedure (car t)))
(let* ((vf #f)
+ (ok #t)
+ (alen 0)
(llist
+ ;; quite a mess
(let loop ((at (if (or (string? (second t)) (symbol? (second t)))
(third t)
(second t)))
(m n)
(opt #f))
- (cond ((null? at) '())
+ (cond ((null? at)
+ (set! ok (or opt (zero? m)))
+ '())
((eq? '#!optional (car at))
(if norest
'()
@@ -1407,18 +1414,20 @@
(set! vf (and (pair? (cdr at)) (eq? 'values (cadr at))))
(make-list m (rest-type (cdr at))))))
((and opt (<= m 0)) '())
- (else (cons (car at) (loop (cdr at) (sub1 m) opt)))))))
- (values llist vf)))
- ((and (pair? t)
- (eq? 'forall (car t)))
+ (else
+ (set! ok (positive? m))
+ (set! alen (add1 alen))
+ (cons (car at) (loop (cdr at) (sub1 m) opt)))))))
+ (values llist vf ok alen)))
+ ((and (pair? t) (eq? 'forall (car t)))
(loop1 (third t) done)) ; assumes typeenv has already been extracted
((assq t typeenv) =>
(lambda (e)
(let ((t2 (cdr e)))
(if (memq t2 done)
(loop1 '* done) ; circularity
- (loop1 t2 (cons t done)))))))))))
- (else (values (make-list n '*) #f)))))
+ (loop1 t2 (cons t done))))))
+ (else (values (make-list n '*) #f #t n)))))
(define (procedure-result-types t values-rest? args typeenv)
(define (loop1 t)
@@ -1690,6 +1699,7 @@
;; - returns converted type or #f
;; - also converts "(... -> ...)" types
;; - converts some typenames to struct types (u32vector, etc.)
+ ;; - handles some type aliases
;; - drops "#!key ..." args by converting to #!rest
;; - handles "(T1 -> T2 : T3)" (predicate)
;; - handles "(T1 --> T2 [: T3])" (clean)
@@ -1735,6 +1745,8 @@
`(struct ,t))
((eq? t 'immediate)
'(or eof null fixnum char boolean))
+ ((eq? t 'any) '*)
+ ((eq? t 'void) 'undefined)
((not (pair? t))
(cond ((memq t typevars)
(set! usedvars (cons t usedvars))
@@ -1773,8 +1785,8 @@
`(procedure ,(upto t p) ,@(cdr p))
rec)))
((and (= 5 (length t))
- (eq? p (cdr t))
- (eq? cp (cdddr t)))
+ (eq? p (cdr t)) ; one argument?
+ (eq? cp (cdddr t))) ; 4th item is ":"?
(set! t (validate `(procedure (,(first t)) ,(third t)) rec))
;; we do it this way to distinguish the "outermost" predicate
;; procedure type
@@ -1821,9 +1833,9 @@
(lambda (v) (and (memq v usedvars) v))
(delete-duplicates typevars eq?))
,type)))
- (let ((type (simplify-type type)))
+ (let ((type2 (simplify-type type)))
(values
- type
+ type2
(and ptype (eq? (car ptype) type) (cdr ptype))
clean))))
(else (values #f #f #f)))))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index f60ccdbe..d3d2bbd9 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -60,6 +60,9 @@ Warning: in toplevel procedure `foo5':
Warning: in toplevel procedure `foo6':
scrutiny-tests.scm:82: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+Warning: at toplevel:
+ scrutiny-tests.scm:89: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+
Warning: in toplevel procedure `foo9':
scrutiny-tests.scm:97: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 5faaf120..9d380fcc 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -24,9 +24,16 @@ return n;}
(print "bar: " i)
0)
-(handle-exceptions ex #f (foo 1.0)) ; failed type-check
(assert (zero? (foo 1)))
(assert (zero? (bar 1.0)))
(assert (= 1 (bar 1)))
+(: spec (* -> *))
+(define (spec x) x)
+
+(define-specialization (spec (x fixnum)) fixnum
+ (+ x 1))
+
+(assert (= 2 (spec 1)))
+
)
diff --git a/types.db b/types.db
index 426fc319..eec0045a 100644
--- a/types.db
+++ b/types.db
@@ -1135,7 +1135,12 @@
(rassoc (#(procedure #:clean #:enforce) rassoc (* (list pair) #!optional (procedure (* *) *)) *))
(reverse-string-append (#(procedure #:clean #:enforce) reverse-string-append ((list string)) string))
(shuffle deprecated)
+
+;; really should be
+;; (: sort (forall (e (s (or (vector e) (list e)))) (s (e e -> *) -> s)))
+;; if we had contraints for "forall"
(sort (#(procedure #:enforce) sort ((or list vector) (procedure (* *) *)) (or list vector)))
+
(sort! (#(procedure #:enforce) sort! ((or list vector) (procedure (* *) *)) (or list vector)))
(sorted? (#(procedure #:enforce) sorted? ((or list vector) (procedure (* *) *)) boolean))
(topological-sort (#(procedure #:enforce) topological-sort ((list list) (procedure (* *) *)) list))
Trap