123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385 |
- (define-module (language cps)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-11)
- #:export (
- $arity
- make-$arity
-
- $kreceive $kargs $kfun $ktail $kclause
-
- $continue $branch $prompt $throw
-
- $const $prim $fun $rec $const-fun $code
- $call $callk $primcall $values
-
- build-cont build-term build-exp
- rewrite-cont rewrite-term rewrite-exp
-
- parse-cps unparse-cps))
- (define-syntax define-record-type*
- (lambda (x)
- (define (id-append ctx . syms)
- (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
- (syntax-case x ()
- ((_ name field ...)
- (and (identifier? #'name) (and-map identifier? #'(field ...)))
- (with-syntax ((cons (id-append #'name #'make- #'name))
- (pred (id-append #'name #'name #'?))
- ((getter ...) (map (lambda (f)
- (id-append f #'name #'- f))
- #'(field ...))))
- #'(define-record-type name
- (cons field ...)
- pred
- (field getter)
- ...))))))
- (define-syntax-rule (define-cps-type name field ...)
- (begin
- (define-record-type* name field ...)
- (set-record-type-printer! name print-cps)))
- (define (print-cps exp port)
- (format port "#<cps ~S>" (unparse-cps exp)))
- (define-record-type* $arity req opt rest kw allow-other-keys?)
- (define-cps-type $kreceive arity kbody)
- (define-cps-type $kargs names syms term)
- (define-cps-type $kfun src meta self ktail kclause)
- (define-cps-type $ktail)
- (define-cps-type $kclause arity kbody kalternate)
- (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)
- (define-cps-type $throw src op param args)
- (define-cps-type $const val)
- (define-cps-type $prim name)
- (define-cps-type $fun body)
- (define-cps-type $rec names syms funs)
- (define-cps-type $const-fun label)
- (define-cps-type $code label)
- (define-cps-type $call proc args)
- (define-cps-type $callk k proc args)
- (define-cps-type $primcall name param args)
- (define-cps-type $values args)
- (define-syntax build-arity
- (syntax-rules (unquote)
- ((_ (unquote exp)) exp)
- ((_ (req opt rest kw allow-other-keys?))
- (make-$arity req opt rest kw allow-other-keys?))))
- (define-syntax build-cont
- (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
- ((_ (unquote exp))
- exp)
- ((_ ($kreceive req rest kargs))
- (make-$kreceive (make-$arity req '() rest '() #f) kargs))
- ((_ ($kargs (name ...) (unquote syms) body))
- (make-$kargs (list name ...) syms (build-term body)))
- ((_ ($kargs (name ...) (sym ...) body))
- (make-$kargs (list name ...) (list sym ...) (build-term body)))
- ((_ ($kargs names syms body))
- (make-$kargs names syms (build-term body)))
- ((_ ($kfun src meta self ktail kclause))
- (make-$kfun src meta self ktail kclause))
- ((_ ($ktail))
- (make-$ktail))
- ((_ ($kclause arity kbody kalternate))
- (make-$kclause (build-arity arity) kbody kalternate))))
- (define-syntax build-term
- (syntax-rules (unquote $rec $continue)
- ((_ (unquote exp))
- exp)
- ((_ ($continue k src exp))
- (make-$continue k src (build-exp exp)))
- ((_ ($branch kf kt src op param (unquote args)))
- (make-$branch kf kt src op param args))
- ((_ ($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))
- ((_ ($prompt k kh src escape? tag))
- (make-$prompt k kh src escape? tag))
- ((_ ($throw src op param (unquote args)))
- (make-$throw src op param args))
- ((_ ($throw src op param (arg ...)))
- (make-$throw src op param (list arg ...)))
- ((_ ($throw src op param args))
- (make-$throw src op param args))))
- (define-syntax build-exp
- (syntax-rules (unquote
- $const $prim $fun $rec $const-fun $code
- $call $callk $primcall $values)
- ((_ (unquote exp)) exp)
- ((_ ($const val)) (make-$const val))
- ((_ ($prim name)) (make-$prim name))
- ((_ ($fun kentry)) (make-$fun kentry))
- ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
- ((_ ($const-fun k)) (make-$const-fun k))
- ((_ ($code k)) (make-$code k))
- ((_ ($call proc (unquote args))) (make-$call proc args))
- ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
- ((_ ($call proc args)) (make-$call proc args))
- ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
- ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
- ((_ ($callk k proc args)) (make-$callk k proc args))
- ((_ ($primcall name param (unquote args))) (make-$primcall name param args))
- ((_ ($primcall name param (arg ...))) (make-$primcall name param (list arg ...)))
- ((_ ($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))))
- (define-syntax-rule (rewrite-cont x (pat cont) ...)
- (match x
- (pat (build-cont cont)) ...))
- (define-syntax-rule (rewrite-term x (pat term) ...)
- (match x
- (pat (build-term term)) ...))
- (define-syntax-rule (rewrite-exp x (pat body) ...)
- (match x
- (pat (build-exp body)) ...))
- (define (parse-cps exp)
- (define (src exp)
- (let ((props (source-properties exp)))
- (and (pair? props) props)))
- (match exp
-
- (('kreceive req rest k)
- (build-cont ($kreceive req rest k)))
- (('kargs names syms body)
- (build-cont ($kargs names syms ,(parse-cps body))))
- (('kfun meta self ktail kclause)
- (build-cont ($kfun (src exp) meta self ktail kclause)))
- (('ktail)
- (build-cont ($ktail)))
- (('kclause (req opt rest kw allow-other-keys?) kbody)
- (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f)))
- (('kclause (req opt rest kw allow-other-keys?) kbody kalt)
- (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
-
- (('continue k exp)
- (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)))
- (('throw op param arg ...)
- (build-term ($throw (src exp) op param arg)))
-
- (('unspecified)
- (build-exp ($const *unspecified*)))
- (('const exp)
- (build-exp ($const exp)))
- (('prim name)
- (build-exp ($prim name)))
- (('fun kbody)
- (build-exp ($fun kbody)))
- (('const-fun k)
- (build-exp ($const-fun k)))
- (('code k)
- (build-exp ($code k)))
- (('rec (name sym fun) ...)
- (build-exp ($rec name sym (map parse-cps fun))))
- (('call proc arg ...)
- (build-exp ($call proc arg)))
- (('callk k proc arg ...)
- (build-exp ($callk k proc arg)))
- (('primcall name param arg ...)
- (build-exp ($primcall name param arg)))
- (('values arg ...)
- (build-exp ($values arg)))
- (_
- (error "unexpected cps" exp))))
- (define (unparse-cps exp)
- (match exp
-
- (($ $kreceive ($ $arity req () rest () #f) k)
- `(kreceive ,req ,rest ,k))
- (($ $kargs names syms body)
- `(kargs ,names ,syms ,(unparse-cps body)))
- (($ $kfun src meta self ktail kclause)
- `(kfun ,meta ,self ,ktail ,kclause))
- (($ $ktail)
- `(ktail))
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
- `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
- . ,(if kalternate (list kalternate) '())))
-
- (($ $continue k src exp)
- `(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))
- (($ $throw src op param args)
- `(throw ,op ,param ,@args))
-
- (($ $const val)
- (if (unspecified? val)
- '(unspecified)
- `(const ,val)))
- (($ $prim name)
- `(prim ,name))
- (($ $fun kbody)
- `(fun ,kbody))
- (($ $const-fun k)
- `(const-fun ,k))
- (($ $code k)
- `(code ,k))
- (($ $rec names syms funs)
- `(rec ,@(map (lambda (name sym fun)
- (list name sym (unparse-cps fun)))
- names syms funs)))
- (($ $call proc args)
- `(call ,proc ,@args))
- (($ $callk k proc args)
- `(callk ,k ,proc ,@args))
- (($ $primcall name param args)
- `(primcall ,name ,param ,@args))
- (($ $values args)
- `(values ,@args))
- (_
- (error "unexpected cps" exp))))
|