~ chicken-core (chicken-5) fbd01232468c6b939a82bb543169862a9ce4e3af
commit fbd01232468c6b939a82bb543169862a9ce4e3af
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu May 26 09:28:27 2011 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu May 26 09:28:27 2011 -0400
predicate syntax for procedure types (as in typed sports equipment)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index ef8f9292..9e222e96 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1120,13 +1120,15 @@
(if (memq #:csi ##sys#features)
'(##core#undefined)
(let* ((type1 (##sys#strip-syntax (caddr x)))
- (name1 (cadr x))
- (type (##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)))))))))))
+ (name1 (cadr x)))
+ (let-values (((type pred)
+ (##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 pred `((predicate (,name1 ,pred))) '()))))))))))
;;; interface definition
diff --git a/compiler.scm b/compiler.scm
index 163d0e6f..ae06a679 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1493,8 +1493,8 @@
(warning "illegal type declaration" (##sys#strip-syntax spec))
(let ((name (##sys#globalize (car spec) se))
(type (##sys#strip-syntax (cadr spec))))
- (cond ((validate-type type name) =>
- (lambda (type)
+ (let-values (((type pred) (validate-type type name)))
+ (cond (type
;; HACK: since `:' doesn't have access to the SE, we
;; fixup the procedure name if type is a named procedure type
;; (We only have access to the SE for ##sys#globalize in here).
@@ -1505,14 +1505,16 @@
(set-car! (cdr type) name))
(mark-variable name '##compiler#type type)
(mark-variable name '##compiler#declared-type)
+ (when pred
+ (mark-variable name '##compiler#predicate pred))
(when (pair? (cddr spec))
(mark-variable
name '##compiler#specializations
(##sys#strip-syntax (cddr spec)))))
- (else
- (warning
- "illegal `type' declaration"
- (##sys#strip-syntax spec))))))))
+ (else
+ (warning
+ "illegal `type' declaration"
+ (##sys#strip-syntax spec))))))))
(cdr spec)))
((predicate)
(for-each
@@ -1520,11 +1522,10 @@
(cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
(let ((name (##sys#globalize (car spec) se))
(type (##sys#strip-syntax (cadr spec))))
- (cond ((validate-type type name) =>
- (lambda (type)
- (##sys#put! name '##compiler#predicate type)))
- (else
- (warning "illegal `predicate' declaration" spec)))))
+ (let-values (((type pred) (validate-type type name)))
+ (if (and type (not pred))
+ (mark-variable name '##compiler#predicate type)
+ (warning "illegal `predicate' declaration" spec)))))
(else
(warning "illegal `type' declaration item" spec))))
(globalize-all (cdr spec))))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index f81f9270..7044057c 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -321,14 +321,17 @@
(else (cons (simplify `(or ,(car ts1) ,(car ts2)))
(merge-argument-types (cdr ts1) (cdr ts2))))))
- (define (merge-result-types ts1 ts2) ;XXX possibly overly conservative
- (cond ((null? ts1) ts2)
- ((null? ts2) ts1)
- ((or (atom? ts1) (atom? ts2)) '*)
- ((eq? 'noreturn (car ts1)) ts2)
- ((eq? 'noreturn (car ts2)) ts1)
- (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
- (merge-result-types (cdr ts1) (cdr ts2))))))
+ (define (merge-result-types ts11 ts21) ;XXX possibly overly conservative
+ (call/cc
+ (lambda (return)
+ (let loop ((ts1 ts11) (ts2 ts21))
+ (cond ((null? ts1) ts2)
+ ((null? ts2) ts1)
+ ((or (atom? ts1) (atom? ts2)) (return '*))
+ ((eq? 'noreturn (car ts1)) (loop (cdr ts1) ts2))
+ ((eq? 'noreturn (car ts2)) (loop ts1 (cdr ts2)))
+ (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
+ (loop (cdr ts1) (cdr ts2)))))))))
(define (match t1 t2)
(let ((m (match1 t1 t2)))
@@ -973,8 +976,9 @@
(set-car! new 'procedure))
(cond-expand
(debugbuild
- (unless (validate-type new name)
- (warning "invalid type specification" name new)))
+ (let-values (((t _) (validate-type new name)))
+ (unless t
+ (warning "invalid type specification" name new))))
(else))
(when (and old (not (equal? old new)))
(##sys#notice
@@ -1054,73 +1058,87 @@
;; - returns converted type or #f
;; - also converts "(... -> ...)" types
;; - drops "#!key ..." args by converting to #!rest
- (define (upto lst p)
- (let loop ((lst lst))
- (cond ((eq? lst p) '())
- (else (cons (car lst) (loop (cdr lst)))))))
- (define (validate-llist llist)
- (cond ((null? llist) '())
- ((symbol? llist) '(#!rest *))
- ((not (pair? llist)) #f)
- ((eq? '#!optional (car llist))
- (let ((l1 (validate-llist (cdr llist))))
- (and l1 (cons '#!optional l1))))
- ((eq? '#!rest (car llist))
- (cond ((null? (cdr llist)) '(#!rest *))
- ((not (pair? (cdr llist))) #f)
- (else
- (let ((l1 (validate (cadr llist))))
- (and l1 `(#!rest ,l1))))))
- ((eq? '#!key (car llist)) '(#!rest *))
- (else
- (let* ((l1 (validate (car llist)))
- (l2 (validate-llist (cdr llist))))
- (and l1 l2 (cons l1 l2))))))
- (define (validate t)
- (cond ((memq t '(* string symbol char number boolean list pair
- procedure vector null eof undefined port blob
- pointer locative fixnum float pointer-vector
- deprecated))
- t)
- ((not (pair? t)) t)
- ((eq? 'or (car t))
- (and (list? t)
- (let ((ts (map validate (cdr t))))
- (and (every identity ts)
- `(or ,@ts)))))
- ((eq? 'struct (car t))
- (and (= 2 (length t))
- (symbol? (cadr t))
- t))
- ((eq? 'procedure (car t))
- (and (pair? (cdr t))
- (let* ((name (if (symbol? (cadr t))
- (cadr t)
- name))
- (t2 (if (symbol? (cadr t)) (cddr t) (cdr t))))
- (and (pair? t2)
- (list? (car t2))
- (let ((ts (validate-llist (car t2))))
- (and ts
- (every identity ts)
- (let* ((rt2 (cdr t2))
- (rt (if (eq? '* rt2)
- rt2
- (and (list? rt2)
- (let ((rts (map validate rt2)))
- (and (every identity rts)
- rts))))))
- (and rt
- `(procedure
- ,@(if name (list name) '())
- ,ts
- ,@rt)))))))))
- ((and (pair? (cdr t)) (memq '-> (cdr t))) =>
- (lambda (p)
- (validate
- `(procedure ,(upto t p) ,@(cdr p)))))
- (else #f)))
- (validate type))
+ ;; - handles "(T1 -> T2 : T3)" (predicate)
+ (let ((ptype #f)) ; (T . PT) | #f
+ (define (upto lst p)
+ (let loop ((lst lst))
+ (cond ((eq? lst p) '())
+ (else (cons (car lst) (loop (cdr lst)))))))
+ (define (validate-llist llist)
+ (cond ((null? llist) '())
+ ((symbol? llist) '(#!rest *))
+ ((not (pair? llist)) #f)
+ ((eq? '#!optional (car llist))
+ (let ((l1 (validate-llist (cdr llist))))
+ (and l1 (cons '#!optional l1))))
+ ((eq? '#!rest (car llist))
+ (cond ((null? (cdr llist)) '(#!rest *))
+ ((not (pair? (cdr llist))) #f)
+ (else
+ (let ((l1 (validate (cadr llist))))
+ (and l1 `(#!rest ,l1))))))
+ ((eq? '#!key (car llist)) '(#!rest *))
+ (else
+ (let* ((l1 (validate (car llist)))
+ (l2 (validate-llist (cdr llist))))
+ (and l1 l2 (cons l1 l2))))))
+ (define (validate t)
+ (cond ((memq t '(* string symbol char number boolean list pair
+ procedure vector null eof undefined port blob
+ pointer locative fixnum float pointer-vector
+ deprecated))
+ t)
+ ((not (pair? t)) t)
+ ((eq? 'or (car t))
+ (and (list? t)
+ (let ((ts (map validate (cdr t))))
+ (and (every identity ts)
+ `(or ,@ts)))))
+ ((eq? 'struct (car t))
+ (and (= 2 (length t))
+ (symbol? (cadr t))
+ t))
+ ((eq? 'procedure (car t))
+ (and (pair? (cdr t))
+ (let* ((name (if (symbol? (cadr t))
+ (cadr t)
+ name))
+ (t2 (if (symbol? (cadr t)) (cddr t) (cdr t))))
+ (and (pair? t2)
+ (list? (car t2))
+ (let ((ts (validate-llist (car t2))))
+ (and ts
+ (every identity ts)
+ (let* ((rt2 (cdr t2))
+ (rt (if (eq? '* rt2)
+ rt2
+ (and (list? rt2)
+ (let ((rts (map validate rt2)))
+ (and (every identity rts)
+ rts))))))
+ (and rt
+ `(procedure
+ ,@(if name (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))))
+ ((and (= 5 (length t))
+ (eq? p (cdr t))
+ (eq? cp (cdddr t)))
+ (set! t (validate `(procedure (,(first t)) ,(third t))))
+ ;; 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)))
+ (values type (and ptype (eq? (car ptype) type) (cdr ptype))))))
(define (initial-argument-types dest vars argc)
(if (and dest (variable-mark dest '##compiler#declared-type))
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index c4fd9ea8..786c5d84 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -80,3 +80,10 @@
(let ((y x))
(string-append x "abc")
(+ x 3))) ;XXX (+ y 3) does not work yet
+
+;; user-defined predicate
+(: foo7 (* -> bool : string))
+(define (foo7 x) (string x))
+
+(when (foo7 x)
+ (+ x 1)) ; will warn about "x" being a string
Trap