Using ParentheC To Transform Scheme Programs To C or How To Write Interesting Recursive Programs in A Spartan Host
Using ParentheC To Transform Scheme Programs To C or How To Write Interesting Recursive Programs in A Spartan Host
1 Introduction
The ParentheC/PC language, which contains only seven simple forms, is one
approach to avoiding the tedious translation from trampolined Scheme to C. Man-
ually converting Scheme to ParentheC/PC is easy and the rest of the work has been
automated.
The problem, of course, would be much simpler if C did not blowup when cas-
cading many recursive function calls. This is a situation that occurs when running
an interpreter, for example. More importantly, even if the code is in first-order
tail form, we still have to contend with cascading tail calls. Of course, these tail
calls can be eliminated by either using trampolining, by using gotos with global
register assignments, or by using a special program-counter register along with the
trampolining strategy. Here, we choose the program-counter approach.
The structure of the paper is in four sections. First, we introduce the language
ParentheC/PC, which is a subset of Scheme plus seven simple macros. Second, we
work through a simple example starting with a recursive definition and taking it
all the way to C. This process entails making the code be in first-order tail form.
That means that all calls are tail calls to global functions and there are no lambda
expressions. Once we have reached this stage, we registerize and then trampoline the
program. Then we feed the ParentheC/PC file to pc2c, which creates a C program
(in two files). We end this section by showing how the C code coresponds to the
ParentheC/PC code. Next, we describe the operation of the seven ParentheC/PC
macros. In the last section, we offer some conclusions.
Tutorial 3
For example, the code for add would be defined (assuming that it has been
registerized and trampolined) in ParentheC/PC as
(define-label add (+ x y))
This is equivalent to the standard Scheme version
(define add (lambda () (+ x y)))
In fact, the ParentheC/PC macro package for Scheme expands define-label
into precisely this format.
2.2 Unions
ParentheC/PC unions express those portions of a Scheme program represented
using records. Making a set of Scheme program objects, such as continuations,
be representation independent involves two transformations. First, the expressions
that construct each variant are replaced with calls to constructor functions. Free
variables become parameters to each constructor function, and the expression as a
whole becomes its body. Then the locations in the source code where these objects
are consumed are replaced with calls to an apply function, a function that knows
what to do with these variants. If the variants in question are procedures, for
example, the function applies the procedure to its other parameters.
To transform this form to a record-based format, each of the trivial construc-
tor functions is modified to return a tagged list containing a type tag, its variant
tag, and the parameters to the function. Then the apply function is modified to
compare against each possible tagged list form. The action clause for each tagged
list corresponds to the actions performed by the procedural form. The following
Scheme code defines three constructor functions. The body of each constructor
function returns a tagged list. The name of the constructor function is formed by
concatenating the type to the variant separated by .
(define record_a
(lambda (item1 item2)
‘(record a ,item1 ,item2)))
(define record_b
(lambda (item1)
‘(record b ,item1)))
(define record_c
(lambda (v)
‘(record c ,v)))
Tutorial 5
These definitions are built using define-union. It creates trivial definitions like
those given above.
(define-union record
(a item1 item2)
(b item1)
(c v))
There are a couple restrictions not directly imposed by this definition. First, the
tags must form a set of symbols, and second the variables must form a set of lexical
variables represented with symbols. These restrictions will lead to an error if they
are violated.
ParentheC/PC unions created with constructors built from define-union are
consumed using union-case. Using union-case on a particular type before the
associated type has been defined is strictly forbidden, the initial <var> position
must be a lexical variable, the <tag>s from each clause must form a set of symbols,
the <var>s must form a set of lexical variables, and the bodies must be legitimate
expressions.
Consider this usage of union-case for this example.
(define-label process_record
(union-case r record
[(a item1 item2) (+ item1 item2)]
[(b item1) (sub1 item1)]
[(c v) (* v 7)]))
2.3 Registers
ParentheC/PC requires a construct define-registers to define the global registers
used by the registerized functions. Its use is straightforward:
(define-program-counter pc)
2.5 Trampolining
The remaining two forms of ParentheC/PC are mount-trampoline and dismount-trampoline.
They control the trampolining strategy used to execute ParentheC/PC programs.
In order to begin execution, mount-trampoline is used:
(mount-trampoline empty-continuation-constructor reg pc)
mount-trampoline takes a constructor for a union representing an empty continua-
tion, a register in which to place the empty continuation created by the trampoline,
and the name of the program counter used in the program. mount-trampoline cre-
ates an empty continuation using the constructor it is passed, places it in the register
it is passed, and then begins execution of the program. In order to finish execution,
a ParentheC/PC program must call dismount-trampoline:
(dismount-trampoline dismount-var)
The variable dismount-var is placed into the empty continuation union by
mount-trampoline; it must be extracted by the program using union-case. When
it is called, dismount-trampoline stops execution and jumps back to the point at
which dismount-var was created by mount-trampoline.
2.6 Properties
As characterized in the language grammar above, ParentheC/PC supports a limited
subset of the Scheme language. There are a number of important properties that
may not be obvious.
1. The program must be tail recursive and it must have been registerized and
trampolined.
2. All functions consume no arguments except for union constructors. This
restriction is a function of the registerization of the program. Union construc-
tors are created by define-union and may take zero or more arguments.
3. A function main of no arguments must be defined. This is where execution
will start in the C program.
4. Certain Scheme functionality may only be used in certain contexts. This is
characterized by the “Simple” and “Complex” contexts in the grammar above.
5. ParentheC/PC places no restrictions on variable and label names. Any valid
Scheme symbol may be used. Symbols with special characters will be renamed
in the C code.
3 A fully-worked example
The following example illustrates how to use ParentheC/PC to transform Scheme
programs to C programs. Along the way, we demonstrate how to registerize and
trampoline while expressing the result as a ParentheC/PC program. Then we show
the resulting C code. We use factorial below as our example program. These
transformations are overkill for such a program. When a program is complicated,
Tutorial 7
however, these manual transformations are a good way to maintain control over the
host (in this case C) language’s underlying runtime architecture.
Finally, we show how to execute ParentheC/PC programs in Scheme and illus-
trate the conversion from ParentheC/PC to C.
(define main
(lambda ()
(factorial 5)))
> (main)
120
The function main encapsulates the start of our computation. It begins program
execution in the resulting C program. In order for ParentheC/PC programs to be
translated to C, there must be a global definition of main.
Because factorial is not even in tail form, we transform it into continuation-
passing style. Any approach that would transform it to tail form would suffice, and
we are just using one such technique.
(define factorial
(lambda (n)
(factorial_cps n (lambda (v) v))))
(define factorial_cps
(lambda (n k)
(cond
[(zero? n) (k 1)]
[else (factorial_cps (sub1 n) (lambda (v) (k (* n v))))])))
Our next goal is to remove the higher-order attributes from these two defini-
tions. Our eventual host is C, which only supports first-order global representa-
tions. Therefore, we use a two-step process to enforce this restriction. First we
make these two definitions first-order, which makes them representation indepen-
dent with respect to the introduced continuations. The code still uses higher-order
values, but they are hidden in apply k and its associated constructors.
8 Garcia et al.
(define factorial
(lambda (n)
(factorial_cps n (kt_empty_k))))
(define factorial_cps
(lambda (n k)
(cond
[(zero? n) (apply_k k 1)]
[else (factorial_cps (sub1 n) (kt_extend n k))])))
(define apply_k
(lambda (k^ v)
(k^ v)))
(define kt_empty_k
(lambda ()
(lambda (v) v)))
(define kt_extend
(lambda (n k)
(lambda (v)
(apply_k k (* n v)))))
Now that the representation dependency is only in the apply k function and its
associated constructors, we can choose a different representation for the continua-
tion values. Once the new representation is chosen, however, we must also change
the definition of apply k.
(define-union kt
(empty_k)
(extend n k))
(define apply_k
(lambda (k^ v)
(union-case k^ kt
[(empty_k) v]
[(extend n k) (apply_k k (* n v))])))
At this point, we know that our program is in first-order tail form. That is,
there are no function values and all calls are tail calls. (Another example would be
factorial written in accumulator-passing style.) Any time we have this property
we can either turn tail calls into gotos while passing arguments through global
registers or we can trampoline the program. Here, we choose to registerize it; instead
of using gotos, however, we will show how it is possible to use the program counter
register and a trampolining technique to transform factorial to C.
We begin by registerizing the calls to factorial and factorial cps.
Tutorial 9
(define factorial
(lambda ()
(begin
(set! n n)
(set! k (kt_empty_k))
(factorial_cps))))
(define factorial_cps
(lambda ()
(cond
[(zero? n) (apply_k k 1)]
[else (begin
(set! k (kt_extend n k))
(set! n (sub1 n))
(factorial_cps))])))
(define main
(lambda ()
(begin
(set! n 5)
(factorial))))
The ordering of set! statements in each call is critical. For example, in the “else”
clause of the cond statement, k must be set before n. Otherwise, n would get its
new value and k would be assigned to the new value rather than the old (correct)
one.
We finish this process by registerizing apply k. We don’t registerize the union
constructors because they are all trivial functions that are guaranteed to terminate.
(define-union kt
(empty_k)
(extend n k))
(define apply_k
(lambda ()
(union-case k^ kt
[(empty_k) v]
[(extend n k) (begin
(set! k^ k)
(set! v (* n v))
(apply_k))])))
10 Garcia et al.
(define factorial
(lambda ()
(begin
(set! n n)
(set! k (kt_empty_k))
(factorial_cps))))
(define factorial_cps
(lambda ()
(cond
[(zero? n) (begin
(set! k^ k)
(set! v 1)
(apply_k))]
[else (begin
(set! k (kt_extend n k))
(set! n (sub1 n))
(factorial_cps))])))
(define main
(lambda ()
(begin
(set! n 5)
(factorial))))
Now, we are nearly ready to translate this code into ParentheC/PC. We replace
function definitions–which now have no arguments–with define-label and add
the define-registers construct. Additionally, we will introduce a new register:
the program counter. The sole purpose of this register is to tell the program where
to go to continue execution. Once we have transformed the program to use this
program counter, we will introduce a trampolining technique that will use the pro-
gram counter to execute factorial. With the computation being performed by
the trampoline, we can remove the need for the factorial function and place the
setup operations in main.
(define-registers n k k^ v)
(define-program-counter pc)
(define-union kt
(empty_k)
(extend n k))
Tutorial 11
(define-label apply_k
(union-case k^ kt
[(empty_k) v]
[(extend n k) (begin
(set! k^ k)
(set! v (* n v))
(set! pc apply_k))]))
(define-label factorial_cps
(cond
[(zero? n) (begin
(set! k^ k)
(set! v 1)
(set! pc apply_k))]
[else (begin
(set! k (kt_extend n k))
(set! n (sub1 n))
(set! pc factorial_cps))]))
(define-label main
(begin
(set! n 5)
(set! k (kt_empty_k))
(set! pc factorial_cps)))
Finally, we must introduce the technology for actually completing the computation–
trampolining–and then a method for escaping from that situation when the program
is completed. To accomplish this, we use the remaining two special forms of Paren-
theC/PC, mount-trampoline and dismount-trampoline, to modify several of our
functions:
(define-registers n k k^ v)
(define-program-counter pc)
(define-union kt
(empty_k dismount)
(extend n k))
(define-label apply_k
(union-case k^ kt
[(empty_k dismount) (dismount-trampoline dismount)]
[(extend n k) (begin
(set! k^ k)
(set! v (* n v))
(set! pc apply_k))]))
12 Garcia et al.
(define-label factorial_cps
(cond
[(zero? n) (begin
(set! k^ k)
(set! v 1)
(set! pc apply_k))]
[else (begin
(set! k (kt_extend n k))
(set! n (sub1 n))
(set! pc factorial_cps))]))
(define-label main
(begin
(set! n 5)
(set! pc factorial_cps)
(mount-trampoline kt_empty_k k pc)
(printf "Factorial of 5: ~d\n" v)))
By CPSing, registerizing, and using the seven ParentheC/PC constructs, we have
produced a ParentheC/PC program ready to be transformed into C.
Tutorial 13
3.4 Factorial in C
The resulting C code for factorial is significantly longer and more verbose than
the ParentheC/PC implementation. This code growth alone suggests that Paren-
theC/PC can save much effort when transforming Scheme to C.
The C source generated by pc2c is not easy to read. On Unix systems, there
exists a pretty printing tool for C called indent that reformats C files. By running
this indenting tool over the C source, browsing the code becomes possible. The
following command line formats the fact5.c file.
% indent fact5.c
We need to say just a few words about the header file below. The first line of
declarations defines the global registers that were created with define-registers.
Notice that the register k^ has been replaced with kr ex because C does not
support the ^ character. The second line defines the program counter to be a pointer
to a function of no arguments–exactly the kind of functions we will use.
Tutorial 15
The next declarations are for the two union types. Let’s look closely at building
the union type kt. We can see that the number of lines in the union is the same as
the number of lines in the enum (enumeration). This just separates the tags from
the field names of the record. The entire record kt, itself, contains the enum, which
is accessed through the name tag and the union, which is accessed through the
name u. The most important thing to notice, however, is that every field within a
union has type void*. This is a pointer to a type of void. This particular type in
C allows us to pass an integer value or a pointer to a union type.
Finally, the header file declares the functions that our program will use, includ-
ing the constructors for our union types, the functions we have created using
define-label, and one more: mount tram. This last function implements the tram-
poline technology used to execute our program. The final declaration deals with
the trampolining technology. The trstr struct is designed to hold a destination
to which the program can jump, which allows our program to jump out of the
trampoline once it has finished computation.
Here is the header file, fact5.h, generated by pc2c from fact5.pc.
struct kt;
typedef struct kt kt;
struct kt {
enum {
_empty_k_kt,
_extend_kt
} tag;
union {
struct { void *_dismount; } _empty_k;
struct { void *_n; void *_k; } _extend;
} u; };
void applyr_k();
void factorialr_cps();
int main();
int mount_tram();
struct _trstr;
typedef struct _trstr _trstr;
struct _trstr {
jmp_buf *jmpbuf;
int value; };
16 Garcia et al.
void applyr_k ()
{
kt *_c = (kt *) kr__ex__;
switch (_c->tag)
{
case _empty_k_kt:
{
void *dismount = _c->u._empty_k._dismount;
_trstr *trstr = (_trstr *) dismount;
longjmp (*trstr->jmpbuf, 1);
}
case _extend_kt:
{
void *n = _c->u._extend._n;
void *k = _c->u._extend._k;
kr__ex__ = (void *) k;
v = (void *) (void *) ((int) n * (int) v);
pc = &applyr_k;
}
}
}
void factorialr_cps () {
if ((n == 0))
{
kr__ex__ = (void *) k;
v = (void *) (void *) 1;
pc = &applyr_k;
}
else
{
k = (void *) ktr_extend (n, k);
n = (void *) (void *) ((int) n - 1);
pc = &factorialr_cps;
}
}
int main () {
n = (void *) (void *) 5;
pc = &factorialr_cps;
mount_tram ();
printf ("Factorial of 5: %d\n", (int) v);
}
18 Garcia et al.
int mount_tram () {
srand (time (NULL));
jmp_buf jb;
_trstr trstr;
void *dismount;
int _status = setjmp (jb);
trstr.jmpbuf = &jb;
dismount = &trstr;
if (!_status)
{
k = (void *) ktr_empty_k (dismount);
for (;;)
{
pc ();
}
}
return 0;
}
Tutorial 19
We return to our example of the usage of define-label above and again expand
the syntax with expand-only.
> (expand-only ’(define-label)
’(define-label add (+ x y)))
4.4 Unions
As discussed above, unions allow us to use a record structure within our Paren-
theC/PC programs, since lists are not permitted. In general, records have construc-
tors and functions that apply their results, such as apply k. The macro define-union
generates the constructors. syntax-rules* does not exist as an actual method of
building macros, but it gives the flavor of what we are defining here. In the appendix,
we present the syntax-case variant of the define-union macro.
(define-syntax define-union
(syntax-rules* ()
[(_ type-name [tag f* ...] ...)
(begin
(define type-name_tag
(lambda (f* ...)
‘(,type-name ,tag ,f* ...)))
...)]))
This creates trivial definitions of record constructors. Again, we expand a simple
example.
> (expand-only ’(define-union)
’(define-union record
(a item1 item2)
(b item1)
(c v)))
(begin
(define record_a
(lambda (item1 item2)
‘(record a ,item1 ,item2)))
(define record_b
(lambda (item1)
‘(record b ,item1)))
(define record_c
(lambda (v)
‘(record c ,v))))
These constructor definitions and the record types created by define-union are
consumed by the macro union-case, defined here.
Tutorial 21
(define-syntax union-case
(syntax-rules ()
[(_ var type-name [(tag f* ...) body] ...)
(if (not (union-type? ’type-name))
(error ’union-case "~s is not a union type." type-name)
(case (cadr var)
[(tag) (apply (lambda (f* ...) body) (cddr var))]
...)
(define-label process_record
(if (not (valid-variant? ’record r))
(error ’union-case "~s is not a union type ~s." r ’record)
(case (cadr r)
[(a) (apply (lambda (item1 item2) (+ item1 item2)) (cddr r))]
[(b) (apply (lambda (item1) (sub1 item1)) (cddr r))]
[(c) (apply (lambda (v) (* v 7)) (cddr r))])))
4.5 Trampolining
As we have seen earlier, the trampolining technique is based on two forms: mount-trampoline
and dismount-trampoline. The macro for mount-trampoline is defined as follows:
(define-syntax mount-trampoline
(syntax-rules ()
[(_ constructor reg pc)
(call/cc
(lambda (dismount)
(set! reg (constructor dismount))
(let trampoline ()
(pc)
(trampoline))))]))
This macro implements a simple trampolining technique. Next, we will see the
macro for dismount-trampoline:
(define-syntax dismount-trampoline
(syntax-rules ()
[(_ dismount-var) (dismount-var 0)]))
22 Garcia et al.
(call/cc
(lambda (dismount)
(set! k_r (construct-k dismount))
(let trampoline ()
(pc_r)
(trampoline))))
(dismount 0)
5 Conclusion
There have been three goals in this tutorial. First, we have demonstrated a technique
for writing interesting programs in a Spartan host. Second, we have presented a
small enough example that should encourage the study of the Spartan host, itself.
In our example, the host has been C, but any language, including even assembly
language or Java, might be considered a Spartan host. Third, we have shown how
to write a few interesting macros to support this system.
We have observed this technology in action. This example should give a feel for
how the header file declarations work with the other code. Studying this example
thoroughly should clarify how to implement complicated programs, for example
interpreters, in a stack-based, imperative language like C.
6 Acknowledgements
We would like to thank Oleg Kiselyov for commenting on and critiquing our approach,
as well as for developing the pmatch matching technology used in ParentheC. His
observations resulted in important improvements to the system.
Tutorial 23
7 Appendix
We redefine the macros but this time writing them in a nearly bullet-proof way.
Most of these are easy to understand if there is focus on the input pattern and the
last expression. Everything between those points are either to extend global data
structures or to check for invalid input. It is nearly impossible to check for every
possible syntactic error, so as an exercise try to come up with such errors.
The first definition is define-label below. It maintains a global list of function
names **pc-label-name-table** that it has built, and it forces an error if the
same function name is redefined. This error occurs at macro-expansion time through
calls to pc-error-check:---. Otherwise, it has the same semantics as the previous
version.
(define **pc-func-name-table** ’())
(define pc-add-func-name!
(lambda (func-name)
(set! **pc-func-name-table**
(cons func-name **pc-func-name-table**))))
(define pc-func-name-exists?
(lambda (fn)
(memv fn **pc-func-name-table**)))
(define-syntax define-label
(lambda (x)
(pc-error-check:define-label (syntax-object->datum x))
(syntax-case x ()
[(_ fn body ...)
(pc-add-func-name! (syntax-object->datum #’fn))
#’(define fn (lambda () body ...))])))
(define pc-error-check:define-label
(lambda (code)
(pmatch code
[(define-label ,fn)
(pc-err ’define-label code ("must have at least one body"))]
[(define-label (,fn . ,p*) ,body)
(pc-err ’define-label code ("cannot have any parameters"))]
[(define-label ,fn ,body . ,body*)
(if (pc-func-name-exists? fn)
(pc-err ’define-label code
("function name ~s already exists" fn)))]
[else (pc-err ’define-label code ("invalid syntax"))])))
24 Garcia et al.
(define pc-check-set-of-vars
(letrec
([set-of-vars?
(lambda (ls)
(or (null? ls)
(and (not (memv (car ls) (cdr ls))) (set-of-vars? (cdr ls)))))])
(lambda (who code vars)
(if (not (set-of-vars? vars))
(pc-err who code ("duplicate variable used: ~s" vars))))))
In define-union, in addition to the naive macro-expansion-time checks, we
also have some subtle ones. Specifically, we have to make sure that we are not
recreating the same type. We do this by maintaining a global association list
**pc-union-type-table** with each list entry list being of the form: [union-type
([tag . arity-of-constructor] ...)]. Then we can determine if we are recre-
ating a type with pc-union-type-exists? below. We also need to create run-time
tests to make sure that the right number of arguments are being passed to its
constructors.
(define **pc-union-type-table** ‘())
(define pc-add-union-type!
(lambda (union-type sub-tn* arg-count*)
(set! **pc-union-type-table**
(cons ‘(,union-type ,(map cons sub-tn* arg-count*)) **pc-union-type-table**))))
(define pc-union-type-exists?
(lambda (union-type)
(assv union-type **pc-union-type-table**)))
(define pc-error-check:define-union
(lambda (code)
(pmatch code
[(define-union ,union-type)
(pc-err ’define-union code
("must have at least one sub-type in union-type: ~s" union-type))]
[(define-union ,union-type . ,c*)
(let ((sub-tn* (map car c*)) (arg** (map cdr c*)))
(pc-check-set-of-vars ’define-union code sub-tn*)
(for-each
(lambda (arg*)
(pc-check-set-of-vars ’define-union code arg*))
arg**)
(if (pc-union-type-exists? union-type)
(pc-err ’define-union code
("union-type ~s already exists" union-type))))]
[else (pc-err ’define-union code ("invalid syntax"))])))
Tutorial 25
(define-syntax define-union
(lambda (x)
(pc-error-check:define-union (syntax-object->datum x))
(syntax-case x ()
[(_ union-type [sub-tn arg* ...] ...)
(let ([ut-val (syntax-object->datum #’union-type)]
[st*-val (syntax-object->datum #’(sub-tn ...))]
[arg-count*-val (map length (syntax-object->datum #’((arg* ...) ...)))])
(with-syntax
([(constructor-fn* ...)
(datum->syntax-object #’_
(map (lambda (st-val)
(string->symbol (format "~s_~s" ut-val st-val)))
st*-val))]
[(arg-count* ...)
(datum->syntax-object #’_ arg-count*-val)])
(pc-add-union-type! ut-val st*-val arg-count*-val)
#’(begin
(define constructor-fn*
(lambda n-arg
(if (eq? (length n-arg) arg-count*)
‘(union-type sub-tn ,@n-arg)
(pc-err ’constructor-fn* ‘(constructor-fn* ,@n-arg)
("wrong number of arguments to constructor: expected ~s"
arg-count*)))))
...)))])))
The next macro union-case requires even more expansion-time tests. Most
important of these tests, however, is that the order of clauses in a union-case
corresponds to the order in the associated define-union. When the message ‘no
matching union-type exists’ appears either there are too few or too many claus-
es in the union-case expression. In addition, there is a run-time test using pc-valid-variant?
that guarantees that the argument passed to the union-case is appropriate.
(define-syntax union-case
(lambda (x)
(syntax-case x ()
[(_ exp union-type [(sub-tn arg* ...) body] ...)
#’(general-union-case union-case exp union-type
[(sub-tn arg* ...) body] ...)])))
26 Garcia et al.
(define-syntax union-case/free
(lambda (x)
(syntax-case x ()
[(_ exp union-type [(sub-tn arg* ...) body* ...] ...)
#’(general-union-case union-case/free exp union-type
[(sub-tn arg* ...) body* ...] ...)])))
(define-syntax general-union-case
(lambda (x)
(let ([code (syntax-object->datum x)])
(pc-error-check:general-union-case code (cadr code)))
(syntax-case x ()
[(_ label var union-type [(sub-tn arg* ...) body] ...)
#’(let ([code ’(label exp union-type [(sub-tn arg* ...) body] ...)])
(if (not (pc-valid-variant? ’union-type var))
(pc-err ’label code
("invalid datum for union-type \"~s\": ~s" ’union-type var)))
(case (cadr var)
[sub-tn (apply (lambda (arg* ...) body) (cddr var))]
...
[else (pc-err
’label code
("It should never come here: ~s, ~s" var ’union-type))]))])))
(define pc-valid-variant?
(lambda (union-type variant)
(and
(list? variant)
(>= (length variant) 2)
(let ([ut (car variant)]
[st (cadr variant)]
[arg-count (length (cddr variant))])
(and
(eqv? union-type ut)
(let ([type (assoc union-type **pc-union-type-table**)])
(and type
(member ‘(,st . ,arg-count) (cadr type)))))))))
Tutorial 27
(define pc-error-check:general-union-case
(lambda (code who)
(pmatch code
[(general-union-case ,label ,var ,union-type)
(pc-err who code ("all union-type must have at least one sub-type"))]
[(general-union-case ,label ,var ,union-type . ,c*)
(let* ((test* (map car c*)) (sub-tn* (map car test*))
(arg** (map cdr test*)) (body** (map cdr c*)))
(pc-check-set-of-vars who code ‘(,var ,union-type))
(pc-check-set-of-vars who code sub-tn*)
(for-each
(lambda (arg*)
(pc-check-set-of-vars who code arg*))
arg**)
(if (ormap null? body**)
(pc-err who code
("all union-case clause must contain at least one body")))
(pc-union-type-does-not-exist? who var union-type
sub-tn* arg** body**))]
[else (pc-err who code ("invalid syntax"))])))
(define pc-union-type-does-not-exist?
(lambda (who var ut st* arg** body**)
(let* ([arg-count* (map length arg**)]
[sub-type* (map cons st* arg-count*)]
[type ‘(,ut ,sub-type*)])
(if (not (member type **pc-union-type-table**))
(begin
(printf "\nParentheC Error - In Expression:\n\n")
(pretty-print
‘(,who ,var ,ut
,(map (lambda (st arg* body*)
(cons (cons st arg*) body*))
st* arg** body**)))
(error who "no matching union-type exists"))))))
Finally, we define define-registers, define-program-counter, mount-trampoline
and dismount-trampoline.
(define-syntax define-registers
(syntax-rules ()
((_ reg1 reg2 ...)
(begin
(define reg1 0)
(define reg2 0)
...))))
28 Garcia et al.
(define-syntax define-program-counter
(syntax-rules ()
((_ pc)
(define-registers pc))))
(define-syntax mount-trampoline
(lambda (x)
(syntax-case x ()
[(_ construct reg pc)
#’(if (not (procedure? construct))
(error ’mount-trampoline
"~s must evaluate to 1 arity #<procedure>" ’trampfn-var)
(call/cc
(lambda (dismount-var)
(set! reg (construct dismount-var))
(let trampoline ()
(pc)
(trampoline)))))])))
(define-syntax dismount-trampoline
(lambda (x)
(syntax-case x ()
[(_ var)
#’(if (not (procedure? var))
(error ’dismount-trampoline
"~s must evaluate to 1 arity #<procedure>" ’var)
(var 0))])))
Although these tests may seem rather expensive, there are two issues that we
should consider. First, given that our goal is to create C programs, it hardly matters
how expensive ParentheC/PC code is. Second, the expansion-time tests potentially
save a lot of time for users of ParentheC/PC.
Tutorial 29
(define-syntax ppat
(syntax-rules (_ quote unquote)
((_ v _ kt kf) kt)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf))
((_ v (unquote var) kt kf) (let ((var v)) kt))
((_ v (x . y) kt kf)
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(ppat vx x (ppat vy y kt kf) kf))
kf))
((_ v lit kt kf) (if (equal? v (quote lit)) kt kf))))