[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 1/9] Add CPS language
|
From: |
Andy Wingo |
|
Subject: |
[PATCH 1/9] Add CPS language |
|
Date: |
Thu, 29 Aug 2013 09:49:31 +0200 |
* module/Makefile.am:
* module/language/cps.scm:
* module/language/cps/verify.scm: Add CPS language.
* .dir-locals.el: Add indentation rules for some CPS forms.
---
.dir-locals.el | 27 ++-
module/Makefile.am | 5 +
module/language/cps.scm | 469 +++++++++++++++++++++++++++++++++++++++++
module/language/cps/verify.scm | 165 +++++++++++++++
4 files changed, 660 insertions(+), 6 deletions(-)
create mode 100644 module/language/cps.scm
create mode 100644 module/language/cps/verify.scm
diff --git a/.dir-locals.el b/.dir-locals.el
index a24e860..94a2126 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -5,12 +5,27 @@
(c-mode . ((c-file-style . "gnu")))
(scheme-mode
. ((indent-tabs-mode . nil)
- (eval . (put 'pass-if 'scheme-indent-function 1))
- (eval . (put 'pass-if-exception 'scheme-indent-function 2))
- (eval . (put 'pass-if-equal 'scheme-indent-function 2))
- (eval . (put 'with-test-prefix 'scheme-indent-function 1))
- (eval . (put 'with-code-coverage 'scheme-indent-function 1))
- (eval . (put 'with-statprof 'scheme-indent-function 1))))
+ (eval . (put 'pass-if 'scheme-indent-function 1))
+ (eval . (put 'pass-if-exception 'scheme-indent-function 2))
+ (eval . (put 'pass-if-equal 'scheme-indent-function 2))
+ (eval . (put 'with-test-prefix 'scheme-indent-function 1))
+ (eval . (put 'with-code-coverage 'scheme-indent-function 1))
+ (eval . (put 'with-statprof 'scheme-indent-function 1))
+ (eval . (put 'let-gensyms 'scheme-indent-function 1))
+ (eval . (put 'build-cps-term 'scheme-indent-function 0))
+ (eval . (put 'build-cps-exp 'scheme-indent-function 0))
+ (eval . (put 'build-cps-cont 'scheme-indent-function 0))
+ (eval . (put 'rewrite-cps-term 'scheme-indent-function 1))
+ (eval . (put 'rewrite-cps-cont 'scheme-indent-function 1))
+ (eval . (put 'rewrite-cps-exp 'scheme-indent-function 1))
+ (eval . (put '$letk 'scheme-indent-function 1))
+ (eval . (put '$letk* 'scheme-indent-function 1))
+ (eval . (put '$letconst 'scheme-indent-function 1))
+ (eval . (put '$continue 'scheme-indent-function 1))
+ (eval . (put '$kargs 'scheme-indent-function 2))
+ (eval . (put '$kentry 'scheme-indent-function 2))
+ (eval . (put '$kclause 'scheme-indent-function 1))
+ (eval . (put '$fun 'scheme-indent-function 2))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))
diff --git a/module/Makefile.am b/module/Makefile.am
index dc7d058..1f66ac4 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -53,6 +53,7 @@ SOURCES = \
language/glil.scm \
language/assembly.scm \
$(TREE_IL_LANG_SOURCES) \
+ $(CPS_LANG_SOURCES) \
$(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
@@ -115,6 +116,10 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/debug.scm \
language/tree-il/spec.scm
+CPS_LANG_SOURCES = \
+ language/cps.scm \
+ language/cps/verify.scm
+
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm
diff --git a/module/language/cps.scm b/module/language/cps.scm
new file mode 100644
index 0000000..ac5642a
--- /dev/null
+++ b/module/language/cps.scm
@@ -0,0 +1,469 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; This is the continuation-passing style (CPS) intermediate language
+;;; (IL) for Guile.
+;;;
+;;; There are two kinds of terms in CPS: terms that bind continuations,
+;;; and terms that call continuations.
+;;;
+;;; $letk binds a set of mutually recursive continuations, each one an
+;;; instance of $cont. A $cont declares the name and source of a
+;;; continuation, and then contains as a subterm the particular
+;;; continuation instance: $kif for test continuations, $kargs for
+;;; continuations that bind values, etc.
+;;;
+;;; $continue nodes call continuations. The expression contained in the
+;;; $continue node determines the value or values that are passed to the
+;;; target continuation: $const to pass a constant value, $values to
+;;; pass multiple named values, etc.
+;;;
+;;; Additionally there is $letrec, a term that binds mutually recursive
+;;; functions. The contification pass will turn $letrec into $letk if
+;;; it can do so. Otherwise, the closure conversion pass will desugar
+;;; $letrec into an equivalent sequence of make-closure primcalls and
+;;; subsequent initializations of the captured variables of the
+;;; closures. You can think of $letrec as pertaining to "high CPS",
+;;; whereas later passes will only see "low CPS", which does not have
+;;; $letrec.
+;;;
+;;; This particular formulation of CPS was inspired by Andrew Kennedy's
+;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
+;;; hackers should read that excellent paper! As in Kennedy's paper,
+;;; continuations are second-class, and may be thought of as basic block
+;;; labels. All values are bound to variables using continuation calls:
+;;; even constants!
+;;;
+;;; There are some Guile-specific quirks as well:
+;;;
+;;; - $ktrunc represents a continuation that receives multiple values,
+;;; but which truncates them to some number of required values,
+;;; possibly with a rest list.
+;;;
+;;; - $kentry labels an entry point for a $fun (a function), and
+;;; contains a $ktail representing the formal argument which is the
+;;; function's continuation.
+;;;
+;;; - $kentry also contains $kclause continuations, corresponding to
+;;; the case-lambda clauses of the function. $kclause actually
+;;; contains the clause body. This is because the $kclause
+;;; logically matches or doesn't match a given set of actual
+;;; arguments against a formal arity, then proceeds to a "body"
+;;; continuation (which is a $kargs).
+;;;
+;;; That's to say that a $fun can be matched like this:
+;;;
+;;; (match f
+;;; (($ $fun meta free
+;;; ($ $cont kentry src
+;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
+;;; (($ $kclause arity
+;;; ($ $cont kbody _ ($ $kargs names syms body)))
+;;; ...))))
+;;; #t))
+;;;
+;;; A $continue to ktail is in tail position. $kentry, $kclause,
+;;; and $ktail will never be seen elsewhere in a CPS term.
+;;;
+;;; - $prompt continues to the body of the prompt, having pushed on a
+;;; prompt whose handler will continue at its "handler"
+;;; continuation. The continuation of the prompt is responsible for
+;;; popping the prompt.
+;;;
+;;; In summary:
+;;;
+;;; - $letk, $letrec, and $continue are terms.
+;;;
+;;; - $cont is a continuation, containing a continuation body ($kargs,
+;;; $kif, etc).
+;;;
+;;; - $continue terms contain an expression ($call, $const, $fun,
+;;; etc).
+;;;
+;;; See (language tree-il compile-cps) for details on how Tree-IL
+;;; converts to CPS.
+;;;
+;;; Code:
+
+(define-module (language cps)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (;; Helper.
+ $arity
+ make-$arity
+
+ ;; Terms.
+ $letk $continue $letrec
+
+ ;; Continuations.
+ $cont
+
+ ;; Continuation bodies.
+ $kif $ktrunc $kargs $kentry $ktail $kclause
+
+ ;; Expressions.
+ $var $void $const $prim $fun $call $primcall $values $prompt
+
+ ;; Building macros.
+ let-gensyms
+ build-cps-term build-cps-cont build-cps-exp
+ rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
+
+ ;; Misc.
+ parse-cps unparse-cps
+ fold-conts fold-local-conts))
+
+;; FIXME: Use SRFI-99, when Guile adds it.
+(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)))
+
+;; Helper.
+(define-record-type* $arity req opt rest kw allow-other-keys?)
+
+;; Terms.
+(define-cps-type $letk conts body)
+(define-cps-type $continue k exp)
+(define-cps-type $letrec names syms funs body)
+
+;; Continuations
+(define-cps-type $cont k src cont)
+(define-cps-type $kif kt kf)
+(define-cps-type $ktrunc arity k)
+(define-cps-type $kargs names syms body)
+(define-cps-type $kentry self tail clauses)
+(define-cps-type $ktail)
+(define-cps-type $kclause arity cont)
+
+;; Expressions.
+(define-cps-type $var sym)
+(define-cps-type $void)
+(define-cps-type $const val)
+(define-cps-type $prim name)
+(define-cps-type $fun meta free body)
+(define-cps-type $call proc args)
+(define-cps-type $primcall name args)
+(define-cps-type $values args)
+(define-cps-type $prompt escape? tag handler)
+
+(define-syntax let-gensyms
+ (syntax-rules ()
+ ((_ (sym ...) body body* ...)
+ (let ((sym (gensym (symbol->string 'sym))) ...)
+ body body* ...))))
+
+(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-body
+ (syntax-rules (unquote $kif $ktrunc $kargs $kentry $ktail $kclause)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($kif kt kf))
+ (make-$kif kt kf))
+ ((_ ($ktrunc req rest kargs))
+ (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
+ ((_ ($kargs (name ...) (sym ...) body))
+ (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
+ ((_ ($kargs names syms body))
+ (make-$kargs names syms (build-cps-term body)))
+ ((_ ($kentry self tail (unquote clauses)))
+ (make-$kentry self (build-cps-cont tail) clauses))
+ ((_ ($kentry self tail (clause ...)))
+ (make-$kentry self (build-cps-cont tail) (list (build-cps-cont clause)
...)))
+ ((_ ($ktail))
+ (make-$ktail))
+ ((_ ($kclause arity cont))
+ (make-$kclause (build-arity arity) (build-cps-cont cont)))))
+
+(define-syntax build-cps-cont
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
+
+(define-syntax build-cps-exp
+ (syntax-rules (unquote
+ $var $void $const $prim $fun $call $primcall $values $prompt)
+ ((_ (unquote exp)) exp)
+ ((_ ($var sym)) (make-$var sym))
+ ((_ ($void)) (make-$void))
+ ((_ ($const val)) (make-$const val))
+ ((_ ($prim name)) (make-$prim name))
+ ((_ ($fun meta free body)) (make-$fun meta free (build-cps-cont body)))
+ ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
+ ((_ ($call proc args)) (make-$call proc args))
+ ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
+ ((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($values (arg ...))) (make-$values (list arg ...)))
+ ((_ ($values args)) (make-$values args))
+ ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
+
+(define-syntax build-cps-term
+ (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($letk (unquote conts) body))
+ (make-$letk conts (build-cps-term body)))
+ ((_ ($letk (cont ...) body))
+ (make-$letk (list (build-cps-cont cont) ...)
+ (build-cps-term body)))
+ ((_ ($letk* () body))
+ (build-cps-term body))
+ ((_ ($letk* (cont conts ...) body))
+ (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
+ ((_ ($letconst () body))
+ (build-cps-term body))
+ ((_ ($letconst ((name sym val) tail ...) body))
+ (let-gensyms (kconst)
+ (build-cps-term
+ ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
+ ($continue kconst ($const val))))))
+ ((_ ($letrec names gensyms funs body))
+ (make-$letrec names gensyms funs (build-cps-term body)))
+ ((_ ($continue k exp))
+ (make-$continue k (build-cps-exp exp)))))
+
+(define-syntax-rule (rewrite-cps-term x (pat body) ...)
+ (match x
+ (pat (build-cps-term body)) ...))
+(define-syntax-rule (rewrite-cps-cont x (pat body) ...)
+ (match x
+ (pat (build-cps-cont body)) ...))
+(define-syntax-rule (rewrite-cps-exp x (pat body) ...)
+ (match x
+ (pat (build-cps-exp body)) ...))
+
+(define (parse-cps exp)
+ (define (src exp)
+ (let ((props (source-properties exp)))
+ (and (pair? props) props)))
+ (match exp
+ ;; Continuations.
+ (('letconst k (name sym c) body)
+ (build-cps-term
+ ($letk ((k (src exp) ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ($continue k ($const c)))))
+ (('let k (name sym val) body)
+ (build-cps-term
+ ($letk ((k (src exp) ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ,(parse-cps val))))
+ (('letk (cont ...) body)
+ (build-cps-term
+ ($letk ,(map parse-cps cont) ,(parse-cps body))))
+ (('k sym body)
+ (build-cps-cont
+ (sym (src exp) ,(parse-cps body))))
+ (('kif kt kf)
+ (build-cont-body ($kif kt kf)))
+ (('ktrunc req rest k)
+ (build-cont-body ($ktrunc req rest k)))
+ (('kargs names syms body)
+ (build-cont-body ($kargs names syms ,(parse-cps body))))
+ (('kentry self tail clauses)
+ (build-cont-body
+ ($kentry self ,(parse-cps tail) ,(map parse-cps clauses))))
+ (('ktail)
+ (build-cont-body
+ ($ktail)))
+ (('kclause (req opt rest kw allow-other-keys?) body)
+ (build-cont-body
+ ($kclause (req opt rest kw allow-other-keys?)
+ ,(parse-cps body))))
+ (('kseq body)
+ (build-cont-body ($kargs () () ,(parse-cps body))))
+
+ ;; Calls.
+ (('continue k exp)
+ (build-cps-term ($continue k ,(parse-cps exp))))
+ (('var sym)
+ (build-cps-exp ($var sym)))
+ (('void)
+ (build-cps-exp ($void)))
+ (('const exp)
+ (build-cps-exp ($const exp)))
+ (('prim name)
+ (build-cps-exp ($prim name)))
+ (('fun meta free body)
+ (build-cps-exp ($fun meta free ,(parse-cps body))))
+ (('letrec ((name sym fun) ...) body)
+ (build-cps-term
+ ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+ (('call proc arg ...)
+ (build-cps-exp ($call proc arg)))
+ (('primcall name arg ...)
+ (build-cps-exp ($primcall name arg)))
+ (('values arg ...)
+ (build-cps-exp ($values arg)))
+ (('prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? tag handler)))
+ (_
+ (error "unexpected cps" exp))))
+
+(define (unparse-cps exp)
+ (match exp
+ ;; Continuations.
+ (($ $letk (($ $cont k src ($ $kargs (name) (sym) body)))
+ ($ $continue k ($ $const c)))
+ `(letconst ,k (,name ,sym ,c)
+ ,(unparse-cps body)))
+ (($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
+ `(let ,k (,name ,sym ,(unparse-cps val))
+ ,(unparse-cps body)))
+ (($ $letk conts body)
+ `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
+ (($ $cont sym src body)
+ `(k ,sym ,(unparse-cps body)))
+ (($ $kif kt kf)
+ `(kif ,kt ,kf))
+ (($ $ktrunc ($ $arity req () rest '() #f) k)
+ `(ktrunc ,req ,rest ,k))
+ (($ $kargs () () body)
+ `(kseq ,(unparse-cps body)))
+ (($ $kargs names syms body)
+ `(kargs ,names ,syms ,(unparse-cps body)))
+ (($ $kentry self tail clauses)
+ `(kentry ,self ,(unparse-cps tail) ,(map unparse-cps clauses)))
+ (($ $ktail)
+ `(ktail))
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body)
+ `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
+
+ ;; Calls.
+ (($ $continue k exp)
+ `(continue ,k ,(unparse-cps exp)))
+ (($ $var sym)
+ `(var ,sym))
+ (($ $void)
+ `(void))
+ (($ $const val)
+ `(const ,val))
+ (($ $prim name)
+ `(prim ,name))
+ (($ $fun meta free body)
+ `(fun ,meta ,free ,(unparse-cps body)))
+ (($ $letrec names syms funs body)
+ `(letrec ,(map (lambda (name sym fun)
+ (list name sym (unparse-cps fun)))
+ names syms funs)
+ ,(unparse-cps body)))
+ (($ $call proc args)
+ `(call ,proc ,@args))
+ (($ $primcall name args)
+ `(primcall ,name ,@args))
+ (($ $values args)
+ `(values ,@args))
+ (($ $prompt escape? tag handler)
+ `(prompt ,escape? ,tag ,handler))
+ (_
+ (error "unexpected cps" exp))))
+
+(define (fold-conts proc seed fun)
+ (define (cont-folder cont seed)
+ (match cont
+ (($ $cont k src cont)
+ (let ((seed (proc k src cont seed)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed))
+
+ (($ $kentry self tail clauses)
+ (fold cont-folder (cont-folder tail seed) clauses))
+
+ (($ $kclause arity body)
+ (cont-folder body seed))
+
+ (_ seed))))))
+
+ (define (fun-folder fun seed)
+ (match fun
+ (($ $fun meta free body)
+ (cont-folder body seed))))
+
+ (define (term-folder term seed)
+ (match term
+ (($ $letk conts body)
+ (fold cont-folder (term-folder body seed) conts))
+
+ (($ $continue k exp)
+ (match exp
+ (($ $fun) (fun-folder exp seed))
+ (_ seed)))
+
+ (($ $letrec names syms funs body)
+ (fold fun-folder (term-folder body seed) funs))))
+
+ (fun-folder fun seed))
+
+(define (fold-local-conts proc seed cont)
+ (define (cont-folder cont seed)
+ (match cont
+ (($ $cont k src cont)
+ (let ((seed (proc k src cont seed)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed))
+
+ (($ $kentry self tail clauses)
+ (fold cont-folder (cont-folder tail seed) clauses))
+
+ (($ $kclause arity body)
+ (cont-folder body seed))
+
+ (_ seed))))))
+
+ (define (term-folder term seed)
+ (match term
+ (($ $letk conts body)
+ (fold cont-folder (term-folder body seed) conts))
+
+ (($ $continue) seed)
+
+ (($ $letrec names syms funs body) (term-folder body seed))))
+
+ (cont-folder cont seed))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
new file mode 100644
index 0000000..0276d1d
--- /dev/null
+++ b/module/language/cps/verify.scm
@@ -0,0 +1,165 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;;
+;;; Code:
+
+(define-module (language cps verify)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (verify-cps))
+
+(define (verify-cps fun)
+ (define seen-gensyms (make-hash-table))
+
+ (define (add sym env)
+ (if (hashq-ref seen-gensyms sym)
+ (error "duplicate gensym" sym)
+ (begin
+ (hashq-set! seen-gensyms sym #t)
+ (cons sym env))))
+
+ (define (add-env new env)
+ (if (null? new)
+ env
+ (add-env (cdr new) (add (car new) env))))
+
+ (define (check-var sym env)
+ (cond
+ ((not (hashq-ref seen-gensyms sym))
+ (error "unbound lexical" sym))
+ ((not (memq sym env))
+ (error "displaced lexical" sym))))
+
+ (define (check-src src)
+ (if (and src (not (and (list? src) (and-map pair? src)
+ (and-map symbol? (map car src)))))
+ (error "bad src")))
+
+ (define (visit-cont-body cont k-env v-env)
+ (match cont
+ (($ $kif kt kf)
+ (check-var kt k-env)
+ (check-var kf k-env))
+ (($ $ktrunc ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
+ (check-var k k-env))
+ (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
+ (unless (= (length name) (length sym))
+ (error "name and sym lengths don't match" name sym))
+ (visit-term body k-env (add-env sym v-env)))
+ (_
+ ;; $kclause, $kentry, and $ktail are only ever seen in $fun.
+ (error "unexpected cont body" cont))))
+
+ (define (visit-clause clause k-env v-env)
+ (match clause
+ (($ $cont kclause src*
+ ($ $kclause
+ ($ $arity
+ ((? symbol? req) ...)
+ ((? symbol? opt) ...)
+ (and rest (or #f (? symbol?)))
+ (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
+ (or #f #t))
+ ($ $cont kbody src (and body ($ $kargs names syms _)))))
+ (check-src src*)
+ (check-src src)
+ (for-each (lambda (sym)
+ (unless (memq sym syms)
+ (error "bad keyword sym" sym)))
+ kwsym)
+ ;; FIXME: It is technically possible for kw syms to alias other
+ ;; syms.
+ (unless (equal? (append req opt (if rest (list rest) '()) kwname)
+ names)
+ (error "clause body names do not match arity names" exp))
+ (let ((k-env (add-env (list kclause kbody) k-env)))
+ (visit-cont-body body k-env v-env)))
+ (_
+ (error "unexpected clause" clause))))
+
+ (define (visit-fun fun k-env v-env)
+ (match fun
+ (($ $fun meta ((? symbol? free) ...)
+ ($ $cont kbody src
+ ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail))
clauses)))
+ (when (and meta (not (and (list? meta) (and-map pair? meta))))
+ (error "meta should be alist" meta))
+ (for-each (cut check-var <> v-env) free)
+ (check-src src)
+ ;; Reset the continuation environment, because Guile's
+ ;; continuations are local.
+ (let ((v-env (add-env (list self) v-env))
+ (k-env (add-env (list ktail) '())))
+ (for-each (cut visit-clause <> k-env v-env) clauses)))
+ (_
+ (error "unexpected $fun" fun))))
+
+ (define (visit-expression exp k-env v-env)
+ (match exp
+ (($ $var sym)
+ (check-var sym v-env))
+ (($ $void)
+ #t)
+ (($ $const val)
+ #t)
+ (($ $prim (? symbol? name))
+ #t)
+ (($ $fun)
+ (visit-fun fun k-env v-env))
+ (($ $call (? symbol? proc) ((? symbol? arg) ...))
+ (check-var proc v-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $primcall (? symbol? name) ((? symbol? arg) ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $values ((? symbol? arg) ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $prompt escape? tag handler)
+ (unless (boolean? escape?) (error "escape? should be boolean" escape?))
+ (check-var tag v-env)
+ (check-var handler k-env))
+ (_
+ (error "unexpected expression" exp))))
+
+ (define (visit-term term k-env v-env)
+ (match term
+ (($ $letk (($ $cont (? symbol? k) src cont) ...) body)
+ (let ((k-env (add-env k k-env)))
+ (for-each check-src src)
+ (for-each (cut visit-cont-body <> k-env v-env) cont)
+ (visit-term body k-env v-env)))
+
+ (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body)
+ (unless (= (length name) (length sym) (length fun))
+ (error "letrec syms, names, and funs not same length" term))
+ (let ((v-env (add-env sym v-env)))
+ (for-each (cut visit-fun <> k-env v-env) fun)
+ (visit-term body k-env v-env)))
+
+ (($ $continue k exp)
+ (check-var k k-env)
+ (visit-expression exp k-env v-env))
+
+ (_
+ (error "unexpected term" term))))
+
+ (visit-fun fun '() '())
+ fun)
--
1.8.3.2