~ chicken-core (chicken-5) 122524c3e6a205b66ca4ef1175ff6d93a349c04d
commit 122524c3e6a205b66ca4ef1175ff6d93a349c04d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jun 11 15:36:32 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Jun 11 15:36:32 2011 +0200
removed escape decl; no more typecheck generation; initial types only with strict-types; added assume; ffi forms are the-wrapped
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index b8e9a0d7..dddfa762 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -166,9 +166,15 @@
,(caddr form)
,(cond ((string? code) code)
((symbol? code) (symbol->string code))
- (else (syntax-error 'foreign-value "bad argument type - not a string or symbol" code))))
- ,tmp ;XXX (##core#the ',(foreign-type->scrutiny-type (caddr form) 'result) ,tmp)
- ) ) ) ) )
+ (else
+ (syntax-error
+ 'foreign-value
+ "bad argument type - not a string or symbol"
+ code))))
+ (##core#the ',(##compiler#foreign-type->scrutiny-type
+ (##sys#strip-syntax (caddr form))
+ 'result)
+ ,tmp) ) ) ) ) )
;;; Include foreign code fragments
@@ -203,40 +209,67 @@
'()
(##sys#er-transformer
(lambda (form r c)
- ;;XXX check syntax and wrap in "##core#the"
- `(##core#foreign-primitive ,@(cdr form)))))
+ (##sys#check-syntax 'foreign-primitive form '(_ _ . _))
+ (let* ((hasrtype (and (pair? (cddr form)) (not (string? (caddr form)))))
+ (rtype (or (and hasrtype (##sys#strip-syntax (cadr form))) 'void))
+ (args (##sys#strip-syntax (if hasrtype (caddr form) (cadr form))))
+ (argtypes (map car args)))
+ `(##core#the '(procedure
+ ,(map (cut ##compiler#foreign-type->scrutiny-type <> 'arg) argtypes)
+ ,(##compiler#foreign-type->scrutiny-type rtype 'result))
+ (##core#foreign-primitive ,@(cdr form)))))))
(##sys#extend-macro-environment
'foreign-lambda
'()
(##sys#er-transformer
(lambda (form r c)
- ;;XXX check syntax and wrap in "##core#the"
- `(##core#foreign-lambda ,@(cdr form)))))
+ (##sys#check-syntax 'foreign-lambda form '(_ _ _ . _))
+ `(##core#the
+ '(procedure ,(map (cut ##compiler#foreign-type->scrutiny-type <> 'arg)
+ (##sys#strip-syntax (cdddr form)))
+ ,(##compiler#foreign-type->scrutiny-type
+ (##sys#strip-syntax (cadr form)) 'result))
+ (##core#foreign-lambda ,@(cdr form))))))
(##sys#extend-macro-environment
'foreign-lambda*
'()
(##sys#er-transformer
(lambda (form r c)
- ;;XXX check syntax and wrap in "##core#the"
- `(##core#foreign-lambda* ,@(cdr form)))))
+ (##sys#check-syntax 'foreign-lambda* form '(_ _ _ _ . _))
+ `(##core#the
+ '(procedure ,(map (lambda (a) (##compiler#foreign-type->scrutiny-type (car a) 'arg))
+ (##sys#strip-syntax (caddr form)))
+ ,(##compiler#foreign-type->scrutiny-type
+ (##sys#strip-syntax (cadr form)) 'result))
+ (##core#foreign-lambda* ,@(cdr form))))))
(##sys#extend-macro-environment
'foreign-safe-lambda
'()
(##sys#er-transformer
(lambda (form r c)
- ;;XXX check syntax and wrap in "##core#the"
- `(##core#foreign-safe-lambda ,@(cdr form)))))
+ (##sys#check-syntax 'foreign-safe-lambda form '(_ _ _ . _))
+ `(##core#the
+ '(procedure ,(map (cut ##compiler#foreign-type->scrutiny-type <> 'arg)
+ (##sys#strip-syntax (cdddr form)))
+ ,(##compiler#foreign-type->scrutiny-type
+ (##sys#strip-syntax (cadr form)) 'result))
+ (##core#foreign-safe-lambda ,@(cdr form))))))
(##sys#extend-macro-environment
'foreign-safe-lambda*
'()
(##sys#er-transformer
(lambda (form r c)
- ;;XXX check syntax and wrap in "##core#the"
- `(##core#foreign-safe-lambda* ,@(cdr form)))))
+ (##sys#check-syntax 'foreign-safe-lambda* form '(_ _ _ _ . _))
+ `(##core#the
+ '(procedure ,(map (lambda (a) (##compiler#foreign-type->scrutiny-type (car a) 'arg))
+ (##sys#strip-syntax (caddr form)))
+ ,(##compiler#foreign-type->scrutiny-type
+ (##sys#strip-syntax (cadr form)) 'result))
+ (##core#foreign-safe-lambda* ,@(cdr form))))))
(##sys#extend-macro-environment
'foreign-type-size
@@ -252,8 +285,7 @@
(##compiler#foreign-type-declaration t ""))))
`(##core#begin
(##core#define-foreign-variable ,tmp size_t ,(string-append "sizeof(" decl ")"))
- ,tmp ;XXX (##core#the 'fixnum ,tmp)
- )))))
+ (##core#the 'fixnum ,tmp))))))
(##sys#macro-subset me0)))
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index baaf9b5a..c5604db6 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1195,6 +1195,13 @@
(##sys#check-syntax 'the x '(_ _ _))
`(##core#the ',(##sys#strip-syntax (cadr x)) ,(caddr x)))))
+(##sys#extend-macro-environment
+ 'assume '()
+ (##sys#er-transformer
+ (syntax-rules ()
+ ((_ ((var type) ...) body ...)
+ (let ((var (##core#the 'type var)) ...) body ...)))))
+
;; capture current macro env
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 4a304e1d..47657b54 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -205,7 +205,6 @@
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 3ae927ec..b2f32fec 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -72,7 +72,6 @@
; (uses {<unitname>})
; (strict-types)
; (specialize)
-; ([not] escape [<symbol> ...])
; (enforce-argument-types [<symbol> ...])
;
; <type> = fixnum | generic
@@ -340,7 +339,6 @@
(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:
@@ -1380,12 +1378,6 @@
((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)
@@ -1425,12 +1417,6 @@
(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 4a305197..74d4d5d9 100644
--- a/manual/Declarations
+++ b/manual/Declarations
@@ -78,14 +78,6 @@ Declares that the toplevel procedures listed check the type of their arguments
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 IDENTIFIER ...)
diff --git a/manual/Types b/manual/Types
index 89554858..1efae0c8 100644
--- a/manual/Types
+++ b/manual/Types
@@ -51,12 +51,6 @@ the {{(declare (type ...))}} or {{:}} syntax.
Declares that the global variable {{IDENTIFIER}} is of the given type.
-If {{IDENTIFIER}} names a {{define}}d toplevel procedure, then all
-required arguments are checked at runtime on procedure-entry whether
-they have the correct types (type for optional or "rest" arguments are
-currently not checked). {{(declare (not escape IDENTIFIER))}}
-compiling the code in unsafe mode will not generate type-checks.
-
===== the
@@ -69,6 +63,19 @@ should be a subtype of the type inferred for {{EXPRESSION}}, the compiler
will issue a warning if this should not be the case.
+===== assume
+
+<syntax>(assume ((VARIABLE TYPE) ...) BODY ...)</syntax>
+
+Declares that during execution of {{BODY ..}}, the variables will
+be of the given types. This is equivalent to
+
+<enscript hightlight=scheme>
+(let ((VARIABLE (the TYPE VARIABLE)) ...)
+ BODY ...)
+</enscript>
+
+
==== Type syntax
Types declared with the {{type}} declaration (see [[Declarations]])
@@ -159,8 +166,8 @@ for library definitions.
Note that procedure-definitions in dynamically loaded code that was
compiled with {{-strict-types}} will not check the types of their
arguments which will result in unsafe code. Invoking such procedures
-with incorrectly typed arguments will crash the program or produce
-random results.
+with incorrectly typed arguments will result in undefined program
+behaviour.
==== Optimizations done by specialization
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 8e247cb1..e0100271 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -691,7 +691,8 @@
(if rest (alist-cons rest 'list e2) e2)
(add-loc dest loc)
#f #t (list initial-tag) #f)))
- (when (and specialize
+ ;; Disabled
+ #;(when (and specialize
dest
(not
(eq? 'no
@@ -1241,7 +1242,9 @@
(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))
+ (if (and dest
+ strict-variable-types
+ (variable-mark dest '##compiler#declared-type))
(let ((ptype (variable-mark dest '##compiler#type)))
(if (procedure-type? ptype)
(nth-value 0 (procedure-argument-types ptype argc #t))
Trap