????
Your IP : 3.12.160.196
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Guile's CPS language is a label->cont mapping, which seems simple
;;; enough. However it's often cumbersome to thread around the output
;;; CPS program when doing non-trivial transformations, or when building
;;; a CPS program from scratch. For example, when visiting an
;;; expression during CPS conversion, we usually already know the label
;;; and the $kargs wrapper for the cont, and just need to know the body
;;; of that cont. However when building the body of that possibly
;;; nested Tree-IL expression we will also need to add conts to the
;;; result, so really it's a process that takes an incoming program,
;;; adds conts to that program, and returns the result program and the
;;; result term.
;;;
;;; It's a bit treacherous to do in a functional style as once you start
;;; adding to a program, you shouldn't add to previous versions of that
;;; program. Getting that right in the context of this program seed
;;; that is threaded through the conversion requires the use of a
;;; pattern, with-cps.
;;;
;;; with-cps goes like this:
;;;
;;; (with-cps cps clause ... tail-clause)
;;;
;;; Valid clause kinds are:
;;;
;;; (letk LABEL CONT)
;;; (setk LABEL CONT)
;;; (letv VAR ...)
;;; (let$ X (PROC ARG ...))
;;;
;;; letk and letv create fresh CPS labels and variable names,
;;; respectively. Labels and vars bound by letk and letv are in scope
;;; from their point of definition onward. letv just creates fresh
;;; variable names for use in other parts of with-cps, while letk binds
;;; fresh labels to values and adds them to the resulting program. The
;;; right-hand-side of letk, CONT, is passed to build-cont, so it should
;;; be a valid production of that language. setk is like letk but it
;;; doesn't create a fresh label name.
;;;
;;; let$ delegates processing to a sub-computation. The form (PROC ARG
;;; ...) is syntactically altered to be (PROC CPS ARG ...), where CPS is
;;; the value of the program being built, at that point in the
;;; left-to-right with-cps execution. That form is is expected to
;;; evaluate to two values: the new CPS term, and the value to bind to
;;; X. X is in scope for the following with-cps clauses. The name was
;;; chosen because the $ is reminiscent of the $ in CPS data types.
;;;
;;; The result of the with-cps form is determined by the tail clause,
;;; which may be of these kinds:
;;;
;;; ($ (PROC ARG ...))
;;; (setk LABEL CONT)
;;; EXP
;;;
;;; $ is like let$, but in tail position. If the tail clause is setk,
;;; then only one value is returned, the resulting CPS program.
;;; Otherwise EXP is any kind of expression, which should not add to the
;;; resulting program. Ending the with-cps with EXP is equivalant to
;;; returning (values CPS EXP).
;;;
;;; It's a bit of a monad, innit? Don't tell anyone though!
;;;
;;; Sometimes you need to just bind some constants to CPS values.
;;; with-cps-constants is there for you. For example:
;;;
;;; (with-cps-constants cps ((foo 34))
;;; (build-term ($values (foo))))
;;;
;;; The body of with-cps-constants is a with-cps clause, or a sequence
;;; of such clauses. But usually you will want with-cps-constants
;;; inside a with-cps, so it usually looks like this:
;;;
;;; (with-cps cps
;;; ...
;;; ($ (with-cps-constants ((foo 34))
;;; (build-term ($values (foo))))))
;;;
;;; which is to say that the $ or the let$ adds the CPS argument for us.
;;;
;;; Code:
(define-module (language cps with-cps)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:export (with-cps with-cps-constants))
(define-syntax with-cps
(syntax-rules (letk setk letv let$ $)
((_ (exp ...) clause ...)
(let ((cps (exp ...)))
(with-cps cps clause ...)))
((_ cps (letk label cont) clause ...)
(let-fresh (label) ()
(with-cps (intmap-add! cps label (build-cont cont))
clause ...)))
((_ cps (setk label cont))
(intmap-add! cps label (build-cont cont)
(lambda (old new) new)))
((_ cps (setk label cont) clause ...)
(with-cps (with-cps cps (setk label cont))
clause ...))
((_ cps (letv v ...) clause ...)
(let-fresh () (v ...)
(with-cps cps clause ...)))
((_ cps (let$ var (proc arg ...)) clause ...)
(call-with-values (lambda () (proc cps arg ...))
(lambda (cps var)
(with-cps cps clause ...))))
((_ cps ($ (proc arg ...)))
(proc cps arg ...))
((_ cps exp)
(values cps exp))))
(define-syntax with-cps-constants
(syntax-rules ()
((_ cps () clause ...)
(with-cps cps clause ...))
((_ cps ((var val) (var* val*) ...) clause ...)
(let ((x val))
(with-cps cps
(letv var)
(let$ body (with-cps-constants ((var* val*) ...)
clause ...))
(letk label ($kargs ('var) (var) ,body))
(build-term ($continue label #f ($const x))))))))