summaryrefslogtreecommitdiff
path: root/module/language/cps.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-03 17:17:23 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-03 17:32:43 +0100
commitee15ca1455806b04f4785655ec8a2fd9dda6c01c (patch)
tree532b7604609085928a652af8330a333c360ca240 /module/language/cps.scm
parent29fee39c2aafc13245fb5fd48bcf6db195251282 (diff)
downloadguile-ee15ca1455806b04f4785655ec8a2fd9dda6c01c.tar.gz
$prompt is now its own kind of CPS term.
* module/language/cps.scm ($prompt): Rework to be its own term kind. Now $continue always continues to a single continuation. Adapt callers.
Diffstat (limited to 'module/language/cps.scm')
-rw-r--r--module/language/cps.scm24
1 files changed, 12 insertions, 12 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm
index ddd4102ab..771d65649 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -127,11 +127,11 @@
$kreceive $kargs $kfun $ktail $kclause
;; Terms.
- $continue $branch
+ $continue $branch $prompt
;; Expressions.
$const $prim $fun $rec $closure
- $call $callk $primcall $values $prompt
+ $call $callk $primcall $values
;; Building macros.
build-cont build-term build-exp
@@ -180,6 +180,7 @@
;; Terms.
(define-cps-type $continue k src exp)
(define-cps-type $branch kf kt src op param args)
+(define-cps-type $prompt k kh src escape? tag)
;; Expressions.
(define-cps-type $const val)
@@ -191,7 +192,6 @@
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name param args)
(define-cps-type $values args)
-(define-cps-type $prompt escape? tag handler)
(define-syntax build-arity
(syntax-rules (unquote)
@@ -229,12 +229,14 @@
((_ ($branch kf kt src op param (arg ...)))
(make-$branch kf kt src op param (list arg ...)))
((_ ($branch kf kt src op param args))
- (make-$branch kf kt src op param args))))
+ (make-$branch kf kt src op param args))
+ ((_ ($prompt k kh src escape? tag))
+ (make-$prompt k kh src escape? tag))))
(define-syntax build-exp
(syntax-rules (unquote
$const $prim $fun $rec $closure
- $call $callk $primcall $values $prompt)
+ $call $callk $primcall $values)
((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
@@ -252,9 +254,7 @@
((_ ($primcall name param args)) (make-$primcall name param args))
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
- ((_ ($values args)) (make-$values args))
- ((_ ($prompt escape? tag handler))
- (make-$prompt escape? tag handler))))
+ ((_ ($values args)) (make-$values args))))
(define-syntax-rule (rewrite-cont x (pat cont) ...)
(match x
@@ -290,6 +290,8 @@
(build-term ($continue k (src exp) ,(parse-cps exp))))
(('branch kf kt op param arg ...)
(build-term ($branch kf kt (src exp) op param arg)))
+ (('prompt k kh escape? tag)
+ (build-term ($prompt k kh (src exp) escape? tag)))
;; Expressions.
(('unspecified)
@@ -312,8 +314,6 @@
(build-exp ($primcall name param arg)))
(('values arg ...)
(build-exp ($values arg)))
- (('prompt escape? tag handler)
- (build-exp ($prompt escape? tag handler)))
(_
(error "unexpected cps" exp))))
@@ -337,6 +337,8 @@
`(continue ,k ,(unparse-cps exp)))
(($ $branch kf kt src op param args)
`(branch ,kf ,kt ,op ,param ,@args))
+ (($ $prompt k kh src escape? tag)
+ `(prompt ,k ,kh ,escape? ,tag))
;; Expressions.
(($ $const val)
@@ -361,7 +363,5 @@
`(primcall ,name ,param ,@args))
(($ $values args)
`(values ,@args))
- (($ $prompt escape? tag handler)
- `(prompt ,escape? ,tag ,handler))
(_
(error "unexpected cps" exp))))