~ chicken-core (chicken-5) 614611f75f68b98c6f616f82804e46ba18d8e2b7
commit 614611f75f68b98c6f616f82804e46ba18d8e2b7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Aug 17 10:17:09 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Aug 17 10:17:09 2011 +0200
added (undocumented) compiler-typecase
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index e568af0e..47d597ac 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1263,6 +1263,19 @@
'define-specialization
"invalid argument syntax" arg head)))))))))))))
+(##sys#extend-macro-environment
+ 'compiler-typecase '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 0)))
+ (let ((var (gensym)))
+ `(##core#let ((,var ,(cadr x)))
+ (##core#typecase
+ ,var ; must be variable (see: CPS transform)
+ ,@(map (lambda (clause)
+ (list (car clause) `(##core#begin ,@(cdr clause))))
+ (cddr x))))))))
+
;; capture current macro env
diff --git a/compiler.scm b/compiler.scm
index b7ca7b03..57cf95eb 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -144,6 +144,7 @@
; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
; (##core#let-module-alias ((<alias> <name>) ...) <body>)
; (##core#the <type> <exp>)
+; (##core#typecase <exp> (<type> <body>) ... [(else <body>)])
; (<exp> {<exp>})
; - Core language:
@@ -171,6 +172,7 @@
; [##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>]
+; [##core#typecase {(<type> ...)} <exp> <body1> ... [<elsebody>]]
; - Closure converted/prepared language:
;
@@ -547,9 +549,17 @@
((##core#the)
`(##core#the
- ,(cadr x)
+ ,(##sys#strip-syntax (cadr x))
,(walk (caddr x) e se dest ldest h)))
+ ((##core#typecase)
+ `(##core#typecase
+ ,(walk (cadr x) e se #f #f h)
+ ,@(map (lambda (cl)
+ (list (##sys#strip-syntax (car cl))
+ (walk (cadr cl) e se dest ldest h)))
+ (cddr x))))
+
((##core#immutable)
(let ((c (cadadr x)))
(cond [(assoc c immutable-constants) => cdr]
@@ -1692,6 +1702,9 @@
((##core#the)
;; remove "the" nodes, as they are not used after scrutiny
(walk (car subs) k))
+ ((##core#typecase)
+ ;; same here, the last clause is chosen, exp is dropped
+ (walk (last subs) k))
(else (bomb "bad node (cps)")) ) ) )
(define (walk-call fn args params k)
diff --git a/eval.scm b/eval.scm
index f31c52d4..b47228b3 100644
--- a/eval.scm
+++ b/eval.scm
@@ -721,6 +721,17 @@
((##core#the)
(compile (caddr x) e h tf cntr se))
+
+ ((##core#typecase)
+ ;; drops exp and requires "else" clause
+ (cond ((assq 'else (##sys#strip-syntax (cddr x))) =>
+ (lambda (cl)
+ (compile (cadr cl) e h tf cntr se)))
+ (else
+ (##sys#syntax-error-hook
+ 'compiler-typecase
+ "no `else-clause' in unresolved `compiler-typecase' form"
+ x))))
(else
(fluid-let ((##sys#syntax-context (cons head ##sys#syntax-context)))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 573de2e7..ee4add57 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -106,6 +106,7 @@
(aliased '())
(noreturn #f)
(dropped-branches 0)
+ (typecases 0)
(safe-calls 0))
(define (constant-result lit)
@@ -882,8 +883,7 @@
loc
(sprintf
"expression returns ~a values but is declared to have a single result"
- (length rt)))
- (set! rt (list (first rt))))
+ (length rt))))
(unless (type<=? t (first rt))
(report-notice
loc
@@ -891,6 +891,18 @@
"expression returns a result of type `~a', but is declared to return `~a', which is not a subtype"
(first rt) t)))))
(list t))))
+ ((##core#typecase)
+ (let ((ts (walk (first subs) e loc #f #f flow ctags)))
+ ;; first exp is always a variable so ts must be of length 1
+ (let loop ((types params) (subs (cdr subs)))
+ (cond ((null? types) (bomb "no more clauses in `compiler-typecase'" types))
+ ((match-specialization (list (car types)) ts '() #f)
+ ;; drops exp
+ (set! typecases (add1 typecases))
+ (copy-node! (car subs) n)
+ (walk n e loc dest tail flow ctags))
+ (else
+ (loop (cdr types) (cdr subs)))))))
((##core#switch ##core#cond)
(bomb "unexpected node class" class))
(else
@@ -911,6 +923,8 @@
(debugging 'x "safe calls" safe-calls)) ;XXX
(when (positive? dropped-branches)
(debugging 'x "dropped branches" dropped-branches)) ;XXX
+ (when (positive? typecases)
+ (debugging 'x "expanded typecases" typecases)) ;XXX
rn)))
diff --git a/support.scm b/support.scm
index ca0aef72..9c0fca14 100644
--- a/support.scm
+++ b/support.scm
@@ -506,8 +506,25 @@
(make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
((##core#the)
(make-node '##core#the (list (cadr x)) (list (walk (caddr x)))))
+ ((##core#typecase)
+ ;; clause-head is already stripped
+ (let loop ((cls (cddr x)) (types '()) (exps (list (walk (cadr x)))))
+ (cond ((null? cls) ; no "else" clause given
+ (make-node
+ '##core#typecase
+ (reverse types)
+ (reverse
+ (cons (make-node '##core#undefined '() '()) exps))))
+ ((eq? 'else (caar cls))
+ (make-node
+ '##core#typecase
+ (reverse (cons '* types))
+ (reverse (cons (walk (cadar cls)) exps))))
+ (else (loop (cdr cls)
+ (cons (caar cls) types)
+ (cons (walk (cadar cls)) exps))))))
((##core#primitive)
- (let ([arg (cadr x)])
+ (let ((arg (cadr x)))
(make-node
(car x)
(list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))
@@ -573,6 +590,14 @@
(walk (car subs)) ) )
((##core#the)
`(the ,(first params) ,(walk (first subs))))
+ ((##core#typecase)
+ `(compiler-typecase
+ ,(walk (first subs))
+ ,@(let loop ((types params) (bodies (cdr subs)))
+ (if (null? types)
+ `((else ,(walk (car bodies))))
+ (cons (list (car types) (walk (car bodies)))
+ (loop (cdr types) (cdr bodies)))))))
((##core#call)
(map walk subs))
((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))
Trap