~ chicken-core (chicken-5) 325ac17d21e2961e2abdc5ac19f329af78c0685d
commit 325ac17d21e2961e2abdc5ac19f329af78c0685d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jun 8 03:58:57 2011 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jun 8 03:58:57 2011 -0400
added ##core#the
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 8bb9861f..baaf9b5a 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1186,6 +1186,16 @@
(begin-for-syntax ,registration))))))
+;;; inline type declaration
+
+(##sys#extend-macro-environment
+ 'the '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'the x '(_ _ _))
+ `(##core#the ',(##sys#strip-syntax (cadr x)) ,(caddr x)))))
+
+
;; capture current macro env
(##sys#macro-subset me0 ##sys#default-macro-environment)))
diff --git a/compiler.scm b/compiler.scm
index 95ae5dec..3ae927ec 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -145,6 +145,7 @@
; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
; (##core#let-module-alias ((<alias> <name>) ...) <body>)
+; (##core#the <type> <exp>)
; (<exp> {<exp>})
; - Core language:
@@ -172,6 +173,7 @@
; [##core#return <exp>]
; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
+; [##core#the {<type>} <exp>]
; - Closure converted/prepared language:
;
@@ -566,6 +568,11 @@
''#t
(walk (cadr x) e se dest ldest h) ) )
+ ((##core#the)
+ `(##core#the
+ ,(cadr x)
+ ,(walk (caddr x) e se dest ldest h)))
+
((##core#immutable)
(let ((c (cadadr x)))
(cond [(assoc c immutable-constants) => cdr]
@@ -1709,6 +1716,9 @@
(walk-inline-call class params subs k) )
((##core#call) (walk-call (car subs) (cdr subs) params k))
((##core#callunit) (walk-call-unit (first params) k))
+ ((##core#the)
+ ;; remove "the" nodes, as they are not used after scrutiny
+ (walk (car subs) k))
(else (bomb "bad node (cps)")) ) ) )
(define (walk-call fn args params k)
diff --git a/manual/Types b/manual/Types
index 038c1a5e..23479d3a 100644
--- a/manual/Types
+++ b/manual/Types
@@ -58,6 +58,15 @@ currently not checked). {{(declare (not escape IDENTIFIER))}}
compiling the code in unsafe mode will not generate type-checks.
+===== the
+
+<syntax>(the TYPE EXPRESSION)</syntax>
+
+Equivalent to {{EXPRESSION}}, but declares that the result will be of the
+given type. Note that this form always declares the type of a single result,
+{{the}} can not be used to declare types for multiple result values.
+
+
==== Type syntax
Types declared with the {{type}} declaration (see [[Declarations]])
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 1d6fda9e..76c03929 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -820,6 +820,31 @@
subs
(cons fn (nth-value 0 (procedure-argument-types fn (sub1 len)))))
r)))
+ ((##core#the)
+ (let* ((t (first params))
+ (rt (walk (first subs) e loc dest tail flow ctags)))
+ (cond ((eq? rt '*))
+ ((null? rt)
+ (report
+ loc
+ (sprintf
+ "expression returns zero values but is declared to be of type `~a'"
+ t)))
+ (else
+ (when (> (length rt) 1)
+ (report
+ loc
+ (sprintf
+ "expression returns ~a values but is declared to have a single result"
+ (length rt)))
+ (set! rt (list (first rt))))
+ (unless (type<=? t (first rt))
+ (report
+ loc
+ (sprintf
+ "expression returns a result of type `~a', but is declared to return `~a', which is not a subtype"
+ t (first rt))))))
+ (list t)))
((##core#switch ##core#cond)
(bomb "unexpected node class" class))
(else
diff --git a/support.scm b/support.scm
index fc90f22d..9e9d9b06 100644
--- a/support.scm
+++ b/support.scm
@@ -504,6 +504,9 @@
(list (walk body)) ) ) ) ) )
((lambda ##core#lambda)
(make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
+ ((##core#the)
+ ;; first arg will be quoted
+ (make-node '##core#the (list (cadadr x)) (list (walk (caddr x)))))
((##core#primitive)
(let ([arg (cadr x)])
(make-node
@@ -569,6 +572,8 @@
'##core#lambda)
(third params)
(walk (car subs)) ) )
+ ((##core#the)
+ `(the ,(first params) ,(walk (first subs))))
((##core#call)
(map walk subs))
((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))
Trap