Add CPS language

* 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.

4 files changed, 660 insertions, 6 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index a24e860ca..94a21263b 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 dc7d058da..1f66ac4f8 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 000000000..ac5642ab6
--- /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 000000000..0276d1d8a
--- /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)