~ chicken-core (chicken-5) 6b3fd9c0cf8af748e20c5af0f133eec2240b528e
commit 6b3fd9c0cf8af748e20c5af0f133eec2240b528e
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri May 27 09:03:57 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri May 27 09:03:57 2011 +0200
escape declaration; tests; doc
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 9e222e96..8bb9861f 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1112,7 +1112,7 @@
;;; type-declaration syntax
-(##sys#extend-macro-environment ;XXX not documented yet
+(##sys#extend-macro-environment
': '()
(##sys#er-transformer
(lambda (x r c)
@@ -1128,6 +1128,7 @@
(else
`(##core#declare
(type (,name1 ,type ,@(cdddr x)))
+ (enforce-argument-types ,name1)
,@(if pred `((predicate (,name1 ,pred))) '()))))))))))
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index b30ac0c4..c965f728 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -204,6 +204,7 @@
membership-unfold-limit
no-argc-checks
no-bound-checks
+ escaping-procedures
no-global-procedure-checks
enable-module-registration
no-procedure-checks
diff --git a/compiler.scm b/compiler.scm
index ae06a679..95ae5dec 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -62,7 +62,6 @@
; (no-procedure-checks)
; (no-procedure-checks-for-usual-bindings)
; (no-procedure-checks-for-toplevel-bindings)
-; (post-process <string> ...)
; (profile <symbol> ...)
; (safe-globals)
; (separate)
@@ -73,6 +72,8 @@
; (uses {<unitname>})
; (strict-types)
; (specialize)
+; ([not] escape [<symbol> ...])
+; (enforce-argument-types [<symbol> ...])
;
; <type> = fixnum | generic
@@ -337,6 +338,7 @@
(define bootstrap-mode #f)
(define strict-variable-types #f)
(define enable-specialization #f)
+(define escaping-procedures #t)
;;; These are here so that the backend can access them:
@@ -1371,6 +1373,16 @@
((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
((unused)
(for-each (cut mark-variable <> '##compiler#unused) (globalize-all (cdr spec))))
+ ((escape)
+ (if (null (cdr spec))
+ (set! escaping-procedures #t)
+ (for-each
+ (cut mark-variable <> '##compiler#escape 'yes)
+ (globalize-all (cdr spec)))))
+ ((enforce-argument-types)
+ (for-each
+ (cut mark-variable <> '##compiler#enforce)
+ (globalize-all (cdr spec))))
((not)
(check-decl spec 1)
(case (##sys#strip-syntax (second spec)) ; strip all
@@ -1406,6 +1418,12 @@
(for-each
(cut mark-variable <> '##compiler#inline-global 'no)
(globalize-all (cddr spec)))))
+ ((escape)
+ (if (null? (cddr spec))
+ (set! escaping-procedures #f)
+ (for-each
+ (cut mark-variable <> '##compiler#escape 'no)
+ (globalize-all (cddr spec)))))
[else
(check-decl spec 1 1)
(let ((id (strip (cadr spec))))
diff --git a/manual/Declarations b/manual/Declarations
index 6ebc8268..579465a5 100644
--- a/manual/Declarations
+++ b/manual/Declarations
@@ -69,6 +69,23 @@ Declares the procedures with the names {{SYMBOL ...}} as constant, that is, as n
side effects. This can help the compiler to remove non-side-effecting expressions.
+=== enforce-argument-types
+
+ [declaration-specifier] (enforce-argument-types IDENTIFIER ...)
+
+Declares that the toplevel procedures listed check the type of their arguments
+(either explicitly or by calling other enforcing procedures) and so a successfull
+invocation will indicate the the arguments are of the types declared.
+
+
+=== escape
+
+ [declaration specifier] ([not] escape [IDENTIFIER ...])
+
+Declares the toplevel procedures of this compilation unit do not escape, i.e. are not
+returned or passed to code outside of the current compilation unit.
+
+
=== export
[declaration specifier] (export SYMBOL ...)
@@ -208,16 +225,11 @@ Disables checking of procedures for calls to procedures referenced via a topleve
(calls to explicitly named procedures).
-=== post-process
+=== predicate
- [declaration specifier] (post-process STRING ...)
+ [declaration specifier] (predicate (IDENTIFIER TYPE) ...)
-Arranges for the shell commands {{STRING ...}} to be invoked after the current
-file has been translated to C. Any occurrences of the substring {{$@@}} in the
-strings given for this declaration will be replaced by the pathname of the currently
-compiled file, without the file-extension.
-This declaration will only work if the source file is compiled
-with the {{csc}} compiler driver.
+Marks the global procedure {{IDENTIFIER}} as a predicate on {{TYPE}}.
=== profile
diff --git a/manual/Types b/manual/Types
index eae61b2e..08af910d 100644
--- a/manual/Types
+++ b/manual/Types
@@ -32,7 +32,7 @@ with faster type-specific operations.
{{-strict-types}} makes type-analysis more optimistic and gives
more opportunities for specialization, but may result in unsafe
-code.
+code if type-declarations are violated.
Note that the interpreter will always ignore type-declarations
and will not perform any flow-analysis of interpreted code.
@@ -77,6 +77,7 @@ or {{:}} should follow the syntax given below:
<tr><td>{{(struct STRUCTURENAME)}}</td><td>record structure of given kind</td></tr>
<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>BASICTYPE</td><td></td></tr>
</table>
@@ -117,6 +118,14 @@ or {{:}} should follow the syntax given below:
</table>
+==== Predicates
+
+Procedure-types of the form {{(DOM -> RNG : TYPE)}} specify that the declared
+procedure will be a predicate, i.e. it accepts a single argument of type
+{{DOM}}, returns a result of type {{RNG}} (usually a boolean) and returns
+a true value if the argument is of type {{TYPE}} and false otherwise.
+
+
==== Using type information in extensions
Type information of declared toplevel variables can be used in client
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 7044057c..52b5751e 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -72,8 +72,9 @@
; ##compiler#declared-type -> BOOL
; ##compiler#predicate -> TYPESPEC
; ##compiler#specializations -> (SPECIALIZATION ...)
-; ##compiler#enforce-argument-types -> BOOL
+; ##compiler#enforce -> BOOL
; ##compiler#special-result-type -> PROCEDURE
+; ##compiler#escape -> #f | 'yes | 'no
;
; specialization specifiers:
;
@@ -687,7 +688,10 @@
#f #t (list initial-tag) #f)))
(when (and specialize
dest
- (not strict-variable-types)
+ (not
+ (eq? 'no
+ (variable-mark dest '##compiler#escape)))
+ escaping-procedures
(not unsafe))
(generate-type-checks! n dest vars inits))
(list
@@ -776,7 +780,8 @@
(iota len)))
(fn (car args))
(pn (procedure-name fn))
- (enforces (and pn (variable-mark pn '##compiler#enforce-argument-types)))
+ (enforces
+ (and pn (variable-mark pn '##compiler#enforce)))
(pt (and pn (variable-mark pn '##compiler#predicate))))
(let ((r (call-result n args e loc params)))
(for-each
@@ -857,10 +862,22 @@
(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 (or (null? args2) (> m2 0))
+ (cond ((null? args1)
+ (and (cond ((null? args2)
+ (or (and rtype2 (not rtype1))
+ (and rtype1 rtype2
+ (type<=? rtype1 rtype2))))
+ ((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))
@@ -868,17 +885,26 @@
((type<=? (car res1) (car res2))
(loop2 (cdr res1) (cdr res2)))
(else #f)))))
- ((null? args2) #f)
((eq? (car args1) '#!optional)
- (loop1 (cdr args1) args2 1 m2))
- ((eq? (car args2) '#!optional)
- (loop1 args1 (cdr args2) m1 1))
+ (loop1 (cdr args1) args2 #f rtype2 1 m2))
((eq? (car args1) '#!rest)
- (loop1 (cdr args1) args2 2 m2))
+ (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)
- (loop1 args1 (cdr args2) m1 2))
- ((type<=? (car args1) (car args2))
- (loop1 (cdr args1) (cdr args2) m1 m2))
+ (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)))))))))))
(define (procedure-type? t)
@@ -972,7 +998,7 @@
(new (cadr e))
(specs (and (pair? (cddr e)) (cddr e))))
(when (and (pair? new) (eq? 'procedure! (car new)))
- (mark-variable name '##compiler#enforce-argument-types #t)
+ (mark-variable name '##compiler#enforce #t)
(set-car! new 'procedure))
(cond-expand
(debugbuild
@@ -980,7 +1006,7 @@
(unless t
(warning "invalid type specification" name new))))
(else))
- (when (and old (not (equal? old new)))
+ (when (and old (not (compatible-types? old new)))
(##sys#notice
(sprintf
"type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 786c5d84..25216f39 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -87,3 +87,11 @@
(when (foo7 x)
(+ x 1)) ; will warn about "x" being a string
+
+;; declared procedure types are enforcing
+(: foo8 (string -> symbol))
+(define (foo8 x) (string->symbol x))
+
+(define (foo9 x)
+ (foo8 x)
+ (+ x 1)) ; foo8 enforces x
Trap