%======================================================================
% rcomp.tex - The R Language Compiler
%======================================================================

\chapter{The R language compiler}
\label{ch:rcomp}

\def\draftid{$\ $Id: rcomp.tex,v 1.3.2.3.2.1 1999/05/11 19:54:59 mpf Exp $\ $}
This appendix gives the documentation and complete code for {\Rcomp},
the compiler for the R programming language.

\section{R Compiler User's Guide}

Currently the R compiler does not have a very convenient user interface.
But this section describes the interface, such as it is.

The R compiler resides in the files {\url ~mpf/rcomp/*.lisp} at the MIT AI
Lab.  The files are also listed in~\S\ref{sec:rcsrc} below, and can be
downloaded from the web via the URL {\url
http://www.ai.mit.edu/~mpf/rc/rcomp}.  To use {\Rcomp}, start a Common Lisp
interpreter, change to a directory containing the source files, and type
{\tt (load "loader")}.  This will load up the system.

Write your R program in a file such as {\tt program.r}.  Then type at Lisp,
{\tt (rcompile-{\db}file "program.r")}.  First, the source will be printed
with comments stripped out, and then, after a delay, the entire Pendulum
assembly code for the compiled program will be printed.  The example
program {\tt sch.r} takes about 15 seconds to compile on a Sparc 20.

Alternatively, one can type {\tt (rcompile-file "program.r" :debug t)}, and
the full program will be printed out after every tiny little step in the
compilation process.  The output from this is voluminous, but by doing an
incremental search ({\tt \char'136S}/{\tt \char'136R}) in Emacs for the
characters ``{\tt ==>}'' in this output, one can easily scroll through it
to see what is going on at each compilation step.  However, it is not
recommended to try this option with very large programs.

When there are compilation problems, it is helpful to try compiling
individual subroutines and statements in isolation, using the calls {\tt
(rc {\em source\/})} and {\tt (rcd {\em source\/})}, where {\em source\/}
is a Lisp expression that evaluates to the list representing the fragment
of source code to be compiled.  {\tt Rc} prints out the compiled assembly
code, and {\tt rcd} prints out the complete appearance of the program after
each compilation step.  For example, {\tt (rc '(a += b))} outputs the
single Pendulum assembly language instruction ``{\tt ADD \$2 \$3}.''

\section{Compilation technique}

The {\Rcomp} compiler was written in Common Lisp, which provides a portable
and well-defined language base that runs on many hardware platforms, and a
comprehensive standard set of built-in list-manipulation functions, that
allow very easy manipulation of program code fragments represented in a
Lisp-like (s-expression) format.

The basic principle of {\Rcomp} operation is essentially macro expansion.
A high-level language construct is interpreted like a macro; it is expanded
in-place to a sequence of compiler-internal constructs, which are in turn
expanded to even lower-level constructs until the whole process bottoms out
with expressions representing assembly language instructions in the target
architecture.

In fact, the earlier versions of {\Rcomp}, which were very limited in
their capabilities, actually used Common Lisp's built-in macro expansion
facility to do all the work.  The entire compiler was implemented as just a
set of macro definitions.

However, this raw approach was not capable of performing important compiler
functions such as register assignment, since each statement was compiled
separately without knowledge of its context.  So we replaced the reliance
on built-in macro expansion with our own custom macro-like facility which
carried an {\defn{environment}} structure along through the code expansion
process.  The environment keeps track of the current variable assignments,
mapping the lexical variables to registers and stack locations.

Unfortunately, the macro-expansion type of approach is also not capable of
performing certain types of code optimizations, in particular optimizations
that might operate across statement boundaries, such as peephole
optimizations.  So the code produced by {\Rcomp} is not particularly
well-minimized.  The situation could be improved somewhat by adding a
post-processing phase to the compilation in which the sequence of assembly
instructions is scanned for known patterns that can be simplified.  But a
more aggressive and thorough approach to optimization would probably
benefit from some higher-level knowledge, and this would probably require a
different overall compiler architecture than our macro-expansion-based
approach.

However, {\Rcomp} was not intended to be a study in advanced compiler
techniques.  Rather, for us the imperative was to make the compiler
particularly simple to modify and extend, in order to easily handle new
constructs, implement existing ones differently, or port the entire
compiler to a different target reversible instruction set.  All these
things are easy in our current design.

The reason for having such flexibility is simply that reversible
programming languages are still very much experimental and in flux.  It is
desirable at this point to be able to very rapidly experiment with
different high-level constructs and different machine instructions.

Another advantage of the macro-based design is that it was very simple to
program, and the compiler code is fairly easy to read.  The definition of
most language constructs is just a literal expression (using the backtick
operator) showing exactly what that construct expands into.

\section{Internal compiler constructs}

We now document a selection of most of the important internal language
constructs currently used internally in the R compiler.  These constructs
are not meant to be used by the end-user in {\Rcomp} programs.  However,
when testing and debugging the compiler, or for understanding how it works,
it may be useful to try compiling code containing these lower-level
constructs.  Also, for writing standard libraries, direct use of
lower-level constructs may enable better-optimized code than the compiler
is currently capable of generating given only the highest-level constructs.

Generally, there is nothing in the current {\Rcomp} architecture that
actually prevents user programs from being written using any desired
mixture of user-level constructs, intermediate- to low-level internal
constructs, and target assembly code.  However, users should be aware that
if they do not stick to the user-level constructs, then their programs may
not be portable across changes in the compiler internals and/or the target
architecture.

%======================================================================
%======================================================================

\subsection{Intermediate-level internal constructs}

Of the internal compiler constructs, the following are still relatively
high-level.

%----------------------------------------------------------------------
\subsubsection{Mid-level variable manipulation}

\construct{<-}{Bind.}{
({\em var} <- {\em val})
}{
\item[\em var ---] Variable to bind.
\item[\em val ---] Expression whose value to bind it to.
}

Assuming the variable {\em var} is initially clear, bind the variable to
the value obtained by evaluating the expression {\em val}.

\construct{->}{Unbind.}{
({\em var} -> {\em val})
}{
\item[\em var ---] Variable to unbind.
\item[\em val ---] Expression whose value to unbind it to.
}

Assuming the variable {\em var} initially contains the value that the
expression {\em val} evaluates to, restore {\em var} to 0.

\construct{with-regvars}{Declare register variables.}{
(wit\=h-regvars {\em var-or-vars}\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em var-or-vars ---] A variable or list of variables to declare.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
within the context of this declaration.
}

This mid-level construct declares a list of variables and forces them into
registers, for greater efficiency of the body statements that refer to
those variables.  The variables are ensured to be declared only within the
lexical body of this statement.  They are not guaranteed to remain in
registers throughout the entire body, only to be in registers intially.

\construct{register}{Advise register allocation.}{
(register {\em var-or-vars})
}{
\item[\em var-or-vars ---] A variable or list of variables.
}

Advise the compiler to move the listed variables into registers now, rather
than later.  This is considered to be advice to the compiler, intended to
aid optimization.  The compiler need not obey the advice, although the
current implementation always does.

\construct{scope}{Declare a variable around a body.}{
(sco\=pe {\em var-or-vars}\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em var-or-vars ---] A variable or list of variables to declare.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
within the context of this declaration.
}

Declares the given list of variables around a body.  The variables are
created at the start of the body and destroyed at the end.  Values of all
variables are intially 0.  The body is assumed to restore the values of all
variables to 0 before it completes.  If it does not, further program
behavior will not obey the intended semantics!  It is currently an error if
any of the named variables already exist in the environment (currently
there is no compiler support for multiple lexical nestings of scopes for
variables with the same name).

%----------------------------------------------------------------------
\subsubsection{Mid-level environment manipulation}

\construct{ensure-green}{Ensure that a body leaves the environment
unchanged.}{
(ens\=ure-green\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
within the context of this declaration.
}

Leaves the environment after executing the given body exactly the same as
it was before the body.  (At least, with regards to its location map.)
This may generate code to move variables back to their original locations
if they happened to be moved during the course of the body.

\construct{with-location-map}{Enforce a location map around a body.}{
(wit\=h-location-map {\em locmapdesc}\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em locmapdesc ---] Description of a location map.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
within the context of this declaration.
}

A declaration that ensures that the environment at the start and end of the
body maps variables to locations exactly as described by the given location
map.  This may trigger relocating variables around to be in the appropriate
locations.  If the set of variables in the current environment is not the
same as that in the location map, currently a compiler error is generated.

\construct{with-environment}{Enforce an environment around a body.}{
(wit\=h-environment {\em envdesc}\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em envdesc ---] Description of an environment.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
within the context of this declaration.
}

Just like {\tt with-location-map}, except it takes an entire environment
description (currently this is the same as an environment object) as its
input, rather than just a location map description.  Only affects the
location map of the current environment, and not other properties of the
environment.

\construct{environment}{Enforce an environment.}{
(environment {\em envdesc})
}{
\item[\em envdesc ---] Description of an environment.
}

Ensure that the environment immediately following this statement is
equivalent to the given environment---that is, has the same location map.
This may involve moving variables around to be in the appropriate
locations.  If the set of variables in the current environment is not the
same as the set in the given environment, currently a compiler error is
signaled.

\construct{locmap}{Enforce a location map.}{
(locmap {\em locamapdesc})
}{
\item[\em locmapdesc ---] Description of a location map.
}

Just like {\tt environment}, but takes a location map description instead
of a full environment.

%----------------------------------------------------------------------
\subsubsection{Mid-level control-flow constructs}

\construct{infloop}{Infinite loop.}{
(inf\=loop \\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
inside the loop.
}

Generates an ``infinite loop'' segment of code---if processing inside the
loop runs sequentially off the end, it comes back to the beginning.  If the
infinite loop is encountered from the outside, we skip over it.

Actually, the present compilation of this construct does not actually
enforce that the loop is infinite; entry/exit points could be inserted into
the middle of the loop body.

\construct{skip}{Unexecutable code segment.}{
(ski\=p \\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
in the skipped section. 
}

Generates a segment of code that should be skipped over if encountered; it
should not be executed.  This is primarily only useful for preventing
static data objects from being executed.  Really this is implemented
exactly like {\tt infloop}.  But the connotation is different.  In {\tt
infloop} we are trying to keep the PC on the {\emph{inside}}, in {\tt skip}
we are trying to keep it on the {\emph{outside}}.  But in both cases, the
PC actually just stays on whichever side it was originally.  (Unless we
cheat and construct brach-pairs connecting inside and outside.)

%----------------------------------------------------------------------
\subsubsection{Mid-level branching constructs}

\construct{bcs-branch-pair}{Pair of binary conditional switching
branches.}{
(bcs\=-branch\=-pair \\
    \=	   \>{\em toplabel} ({\em vara1} {\em opa} {\em vara2}) \\
    \=	   \>{\em botlabel} ({\em varb1} {\em opb} {\em varb2}) \\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em toplabel ---] Label of the upper branch in the pair.
\item[\em vara1, vara2 ---] Variables to compare at the top of the branch.
\item[\em opa ---] Operation to compare with at the top of the branch.
\item[\em botlabel ---] Label of the lower branch in the pair.
\item[\em varb1, varb2 ---] Variables to compare at the bottom of the
branch.
\item[\em opb ---] Operation to compare with at the bottom of the branch.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
in between the two branches.
}

This construct implements the common low-level reversible control-flow
situation in which one has a pair of switching (that is, paired)
conditional branches pointing to each other, at the top and bottom of a
block of code, and the condition being tested is a binary (two-operand)
function of two given variables.  The operation may be any of the
relational operators {\tt =}, {\tt <}, {\tt >}, {\tt <=}, {\tt >=}, {\tt
!=} which have the expected C-like meanings of signed integer comparison.

Depending on how {\tt bcs-branch-pair} is used, it can be used to implement
either reversible {\tt if} statements or loops.  The code is potentially a
loop if the second condition can succeed even if the first condition does
not.

An important feature of {\tt bcs-branch-pair} is that it ensures that the
environment is conserved by the body, despite whatever juggling of
registers is done inside the body.  This is important because otherwise, we
could not at compile time predict what the environment would be after the
branch, because we would not know whether the branch would be taken or not.

\construct{twin-us-branch}{Pair of unconditional switching branches.}{
(twi\=n-us-branch {\em toplabel} {\em botlabel}\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em toplabel ---] Label of the upper branch in the pair.
\item[\em botlabel ---] Label of the lower branch in the pair.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
in between the two branches.
}

This construct implements the common low-level reversible control-flow
situation in which one has a pair of switching (paired) unconditional
branches pointing to each other, at the top and bottom of a block of code.
Such a structure may surround a infinite loop, or the body of a subroutine
whose entry/exit point is somewhere in its middle.  If the structure is
encountered from outside, we just jump over it.  This construct knows that
the environment after the branch pair is the same as the one before it.

\subsubsection{Miscellaneous mid-level constructs}

\construct{with}{Execute body under some temporary condition.}{
(wit\=h {\em tmp-statement} \\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em tmp-statement ---] Temporary statement to do before the body and
undo after the body.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to do after
doing and before undoing the given statement.
}

Given any statement {\em tmp-statement} that the compiler knows how to
invert, performs that statement, then performs the body statements {\em
statement}$_i$, then performs the inverse operation of the statement to
undo its effects.  Does not yet handle all possible varieties of {\em
tmp-statement}.

\construct{undo}{Undo a given statement.}{
(undo {\em statement})
}{
\item[\em statement ---] Statement to undo.
}

Execute a given statement in reverse, thereby undoing its effects.

%======================================================================
%======================================================================
\subsection{Low-level constructs}

\subsubsection{Low-level manipulation of variables}

\construct{relocate}{Relocate a variable in the environment.}{
(relocate {\em var} {\em loc})
}{
\item[\em var ---] The variable to relocate.
\item[\em loc ---] Specifier for the register or stack location to relocate to.
}

This construct relocates the given variable to a specific register or stack
location.  The {\em loc} is currently represented as a list, with either
the form {\tt (reg {\em regno})}, where {\em regno} is the register number,
0--31, or {\tt (stock {\em offset})}, where {\em offset} is the stack
offset, which should be a negative integer specifying the location relative
to the current value of the stack pointer (which currently is register 1).

The relocation of a variable involves both changing its location assignment
in the environment, and generating code that actually moves the variable's
value from the old location to the new location.

If a different variable is already assigned to the given location, {\tt
relocate} moves it out of the way.  (By exchanging it with the old location
of {\em var} if there was one, or by moving it to a fresh location.)

\construct{new-var-at}{Create a new variable at a given location.}{
(new-var-at {\em varname} {\em location})
}{
\item[\em varname ---] The name of the variable to create.
\item[\em location ---] Location specifier to create the new variable at.
}

Create a new variable named {\em varname} in the current environment, and
assign it to location {\em location}.  If another variable was assigned to
{\em location}, move that variable to some other location.

\construct{vacate}{Ensure that a given location is unassigned.}{
(vacate {\em loc})
}{
\item[\em loc ---] Specifier of location to vacate.
}

If a variable is assigned to the given location, move it to somewhere else.
If there are any free registers, the variable is moved to one of them,
otherwise it is moved to the next available location on the stack.

\construct{get-in-register}{Force a variable into a register.}{
(get-in-register {\em var})
}{
\item[\em var ---] The variable to registerify.
}

Force the given variable to relocate to a register if it isn't in one
already.  Picks an arbitrary free register for it to live in, or if no
registers are free, boots the least-recently-moved register variable back
out to the stack, and moves our variable there.

\construct{add-to-env}{Add a variable to the environment.}{
(add-to-env {\em varname})
}{
\item[\em varname ---] Name of variable to create.
}

Explicitly creates a variable of the given name in the current environment,
initially unassigned to any particular location.  It is currently an error
if a variable with the given name already exists.

\construct{tell-loc}{Set the raw location of a variable.}{
(tell-loc {\em var} {\em loc})
}{
\item[\em var ---] The variable whose location to set.
\item[\em loc ---] The location to set it to.
}

Explicitly sets the location of the given variable in the current
environment to the one given.  Does not move the variable's contents.

\construct{remove-var}{Remove a variable from the environment.}{
(remove-var {\em var})
}{
\item[\em var ---] The variable to remove.
}

Explicitly removes a variable from the current environment.  Dangerous to
subsequent program correctness if the contents of {\em var} are non-zero.

\subsubsection{Raw manipulation of environments}

\construct{declare-green}{Explicitly restore the environment after a body.}{
(dec\=lare-green\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
within the context of this declaration.
}

Explicitly set the environment after the body completes back to what it was
before the body.  Does not move variables appropriately.  This is a very
low-level operation.

\construct{declare-locmap}{Explicitly set the current location map.}{
(declare-locmap {\em locmapdesc})
}{
\item[\em locmapdesc ---] Location map description.
}

Explicitly set the entire variable-location map of the current environment
to the one given.  Does not move contents of variables' locations
appropriately.  This is a very low-level operation.

\construct{declare-environment}{Explicitly set the current environment.}{
(declare-environment {\em envdesc})
}{
\item[\em envdesc ---] Environment description.
}

Explicitly set the entire current environment to the one given.  Does not
move contents of variables' locations appropriately.  This is a very
low-level operation.

%----------------------------------------------------------------------

\subsubsection{Raw register/stack manipuation}

This section describes constructs for direct manipulation (moving and
exchanging contents) of register and stack locations.

\construct{swaploc}{Swaps the contents of two register/stack locations.}{
(swaploc {\em loc}$_1$ {\em loc}$_2$)
}{
\item[{\em loc}$_1$ {\em loc}$_2$ --- ] Specifiers for the two locations to swap.
}

Swaps the contents of the two specified locations.  See {\tt relocate} for
the format of a location specifier.  Note this function does not change
variable location assignments, only the values of the specified locations.

\construct{moveloc}{Move the contents of one location to another.}{
(moveloc {\em loc}$_1$ {\em loc}$_2$)
}{
\item[{\em loc}$_1$ ---] Source location.
\item[{\em loc}$_2$ ---] Destination location.
}

Assuming {\em loc}$_2$ is empty, moves the contents of {\em loc}$_1$ to it,
leaving {\em loc}$_1$ empty.  If {\em loc}$_2$ is not empty, the effect
will be different.

\construct{exregstack}{Exchange register with stack location.}{
(exregstack {\em reg} {\em stackloc})
}{
\item[{\em reg} ---] A register location specifier.
\item[{\em stackloc} ---] A stack location specifier.
}

Exchanges the contents of a given register location with those of a stack
location.  Does not change the environment.  The current implementation
works fine but leads to some suboptimization.  (See the code comment.)

\construct{swapregs}{Exchange the contents of two registers.}{
(swapregs {\em r1} {\em r2})
}{
\item[{\em r1}, {\em r2}] --- Specifiers of register locations to swap.
}

Swaps the contents of two registers.  Despite the absence of direct
hardware support for this operation in the current PISA spec, the current
implementation cleverly swaps the two registers in-place anyway by
performing a sequence of three XOR's of one register into another.  I
learned this particular trick from Charles Isbell's hand-written
assembly-language programs for early versions of Pendulum.

\construct{movereg}{Moves one register to another.}{
(movereg {\em r1} {\em r2})
}{
\item[{\em r1} ---] Source register.
\item[{\em r2} ---] Destination register.
}

Assuming {\em r2} is initially empty, moves {\em r1} to {\em r2}, leaving
{\em r1} empty.  Implemented like {\tt swapregs}, but takes advantage of
the assumption that {\em r2} is empty to eliminate one of the 3 XORs.  If
{\em r2} is not empty, the outcome will not fit the intended semantics.

\construct{with-stack-top}{Temporarily go to top of stack.}{
(wit\=h-stack-top \\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots)
}{
\item[{\em statement$_1$, statement$_2$, \ldots} ---] Statements to execute
in the context of the adjusted stack pointer.}

Execute the given body within a context where the stack pointer is reset to
the top of the stack, that is, beyond all currently-allocated variables.
This is used in the implementation of subroutine calls.  The environment is
not adjusted, so any entries in the environment that might have been
referring to stack-allocated variables will be present but invalid in the
body.  Higher-level constructs that use {\tt with-stack-top} need to cope
with this.

\construct{with-SP-adjustment}{Temporarily adjust stack pointer.}{
(wit\=h-SP-adjustment {\em amt} \\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots)
}{
\item[{\em amt} ---] Literal amount by which to adjust stack pointer.
\item[{\em statement$_1$, statement$_2$, \ldots} ---] Statements to execute
in the context of the adjusted stack pointer.
}

Execute the body within a context where the stack pointer is temporarily
adjusted by the explicit amount {\em amt}.  The stack grows downwards in
memory, so negative amounts correspond to moving towards the ``top'' (most
short-lived) part of the stack.

%----------------------------------------------------------------------
\subsubsection{Low-level control flow constructs}

\construct{\us if}{Specialized if statement.}{
({\us}if\=\ ({\em reg1} {\em op} {\em reg2}) then\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots)
}{
\item[\em reg1, reg2 ---] Registers to compare.
\item[\em op ---] Binary relation to use for comparison.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to execute
	if the condition is true.
}

Like {\tt if}, but the condition must be a simple binary relation (with no
nested subexpressions) between two explicit registers {\em reg1} and {\em
reg2}.

\construct{{\us}ifelse}{Specialized if/else statement.}{
({\us}ifelse \=({\em reg1} {\em op} {\rm reg2}) then\\
    \>(\={\em if-statement$_1$}\\
    \> \>{\em if-statement$_2$} \ldots)\\
    \>(\={\em else-statement$_1$}\\
    \> \>{\em else-statement$_2$} \ldots))
}{
\item[{\em reg1, reg2} ---] Registers to compare.
\item[{\em op} ---] Binary relation to use for comparison.
\item[{\em if-statement$_1$, if-statement$_2$, \ldots} ---] Statements to
execute if the condition is true.
\item[{\em else-statement$_1$, else-statement$_2$, \ldots} ---] Statements to
execute if the\\
condition is false.
}

Like {\tt {\us}if}, but there is a second ``else'' body that will be executed
if the condition fails.

\construct{gosub}{Low-level subroutine call.}{
(gosub {\em subname})
}{
\item[\em subname ---] Name of subroutine to call.
}

Calls the subroutine of the given name.  This is a low-level operation that
doesn't know anything about stacks, arguments, or calling conventions.  It
just transfers control.

\construct{rgosub}{Low-level reverse subroutine call.}{
(rgosub {\em subname})
}{
\item[\em subname ---] Name of subroutine to call.
}

Like {\tt gosub}, but runs the subroutine in reverse.

\construct{portal}{Subroutine entry/exit point.}{
(portal {\em label})
}{
\item[\em label ---] Name to give this portal.
}

Declares a subroutine entry/exit point to exist at this point in the
program, with the name {\em label}.  A caller can call {\em label} and have
control transferred to this point.  Then, if control loops back around to
this point again, the portal will switch control back to the caller.

The portal currently works by using register 2 to store the information
needed to return to the caller.  So the value in this register needs to be
preserved during the body of the subroutine.

%----------------------------------------------------------------------
\subsubsection{Low-level branching constructs}

\construct{sbra-pair}{Low-level pair of switching unconditional branches.}{
(sbr\=a-pair {\em toplabel} {\em botlabel}\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em toplabel ---] Label of the upper branch in the pair.
\item[\em botlabel ---] Label of the lower branch in the pair.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to compile
in between the two branches.
}

Lower-level analogue of {\tt twin-us-branch} that does not worry about
maintaining the environment across all the branching.

\construct{sbra}{Switching branch.}{
(sbra {\em thislabel} {\em otherlabel})
}{
\item[\em thislabel ---] Label for this branch.
\item[\em otherlabel ---] Label for the other branch that we switch to.
}

Unconditional switching branch labeled {\em thislabel} that exchanges
control between here and another such branch labeled {\em otherlabel}.

The semantics is: If we arrive at this statement from {\em otherlabel},
then continue in normal sequential execution.  If we arrive at this
statement sequentially, then branch to {\em otherlabel}.  If we arrive at
this statement some other way, the behavior is some other, nonsensical
thing.  So you can see that these ``switching'' branches have to come in
pairs.

\construct{sbez}{Switching branch on equal to zero.}{
(sbez {\em thislabel} {\em var} {\em otherlabel})
}{
\item[\em thislabel ---] Label for this branch.
\item[\em var ---] Variable to test.
\item[\em otherlabel ---] Label for the other branch that we switch to.
}

This is an example of a {\emph{conditional}} switching branch.  It tests
{\em var} and if it is zero, it behaves like {\tt sbra}, otherwise it is a
no-op.  If we branch into this statement but its condition does not
succeed, the resulting behavior will be nonsensical.

\construct{sbne}{Switching branch on not equal to zero.}{
(sbne {\em thislabel} {\em var} {\em otherlabel})
}{
\item[\em thislabel ---] Label for this branch.
\item[\em var ---] Variable to test.
\item[\em otherlabel ---] Label for the other branch that we switch to.
}

This is an example of a {\emph{conditional}} switching branch.  It tests
{\em var} and if it is nonzero, it behaves like {\tt sbra}, otherwise it is
a no-op.  If we branch into this statement but its condition does not
succeed, the resulting behavior will be nonsensical.

\construct{bcs-branch}{Binary conditional switching branch.}{
(bcs-branch ({\em var1} {\em op} {\em var2}) {\em thislabel} {\em otherlabel})
}{
\item[\em var1, var2 ---] Variables to compare.
\item[\em op ---] Operation to compare with.
\item[\em thislabel ---] Label for this branch.
\item[\em otherlabel ---] Label for the other branch that we switch to.
}

This is a general two-operand conditional switching branch.  It compares
the two variables using the operation {\em op}, which may be any of the
relational operators {\tt =}, {\tt <}, {\tt >}, {\tt <=}, {\tt >=}, {\tt
!=}, which have the expected C-like meanings of signed integer comparison.
If the comparison succeeds, it behaves like {\tt sbra}, otherwise it is a
no-op.  If we branch into this statement but its condition does not
succeed, the resulting behavior will be nonsensical.

\construct{bc-branch}{Non-switching binary conditional branch.}{
(bc-branch ({\em var1} {\em op} {\em var2}) {\em destlabel})
}{
\item[\em var1, var2 ---] Variables to compare.
\item[\em op ---] Operation to compare with.
\item[\em destlabel ---] Label of destination.
}

This is like {\tt bcs-branch} except that it is not a switching branch;
that is, it does not branch to a location that explicitly refers back to
it.  Instead, the desination will probably be a subroutine entry/exit point
which will save away the branch register to allow returning to this
location later.

\construct{rbc-branch}{Register binary conditional branch.}{
(rbc-branch ({\em r1} {\em op} {\em r2}) {\em destlabel})
}{
\item[\em r1, r2 ---] Registers to compare.
\item[\em op ---] Operation to compare with.
\item[\em destlabel ---] Label of destination.
}

Like {\tt bc-branch} except that its arguments must be explicit registers,
not variables.

%----------------------------------------------------------------------
\subsubsection{Miscellaneous low-level constructs}

\construct{{\us}with}{Specialized version of {\tt with}.}{
({\us}wit\=h ({\em var} <- {\em val}) \\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em var --- ] Variable name to bind.
\item[\em val --- ] Expression whose value to bind it to.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to do after
doing and before undoing the given statement.
}

A version of {\tt with} in which the ``statement'' to be done before the
body (and undone after it) must be a variable-binding.  The {\tt {\us}with}
construct is more efficient than the general version of {\tt with} for this
case, because the {\em val} expression is not evaluated as many times.
However, {\tt {\us}with} may use an amount of temporary space linear in the
length of the {\em val} expression during the course of the body, whereas
{\tt with} does not.

\construct{withargs}{Prepare arguments as for a subroutine call.}{
(wit\=hargs {\em arg-list}\\
    \>{\em statement$_1$}\\
    \>{\em statement$_2$} \ldots )
}{
\item[\em arg-list --- ] List of expressions for the arguments.
\item[\em statement$_1$, statement$_2$, \ldots ---] Statements to do in the
context of having prepared the arguments.
}

Given a list of ``argument'' expressions, temporarily places the values of
those expressions in the canonical locations where the arguments to a
subroutine should go, and compiles the body in that context.  This is part
of the caller side of the current subroutine calling convention.

%======================================================================
%======================================================================


\section{Compiler LISP source code}
\label{sec:rcsrc}

In this section, we give a verbatim listing of the most recent version of
the {\Rcomp} source.  This is composed of the following files:

\begin{description}
\item[{\tt loader.lisp} ---] \S\ref{sec:loader}, p.~\pageref{sec:loader}.
This loads up all the parts of the {\Rcomp} program in an appropriate
order.
\item[{\tt util.lisp} ---] \S\ref{sec:util}, p.~\pageref{sec:util}.
Defines general-purpose utilty functions and macros that we use.
\item[{\tt infrastructure.lisp} ---] \S\ref{sec:infrastructure}, p.~\pageref{sec:infrastructure}.
Defines our macro-expansion like facility for defining how to compile
language constructs.
\item[{\tt location.lisp} ---] \S\ref{sec:location}, p.~\pageref{sec:location}.
Defines some functions for working with objects that describe a variable's
location in the register file or stack.
\item[{\tt environment.lisp} ---] \S\ref{sec:environment},
p.~\pageref{sec:environment}.  Defines the environment objects which map
variables to their locations.
\item[Files defining construct-expansion ``macros'':] \ 

\begin{description}
\item[{\tt regstack.lisp} ---] \S\ref{sec:regstack},
p.~\pageref{sec:regstack}.  Defines low-level constructs for direct
manipulation of registers and the stack.
\item[{\tt variables.lisp} ---] \S\ref{sec:variables},
p.~\pageref{sec:variables}.  Defines high- to low-level constructs for
manipulation of variables in variable assignments (environments).
\item[{\tt branches.lisp} ---] \S\ref{sec:branches},
p.~\pageref{sec:branches}.  Constructs providing intermediate- and
low-level support for various kinds of branch structures for control-flow.
\item[{\tt expression.lisp} ---] \S\ref{sec:expression},
p.~\pageref{sec:expression}.  Constructs and low-level functions for
expanding nested expressions.
\item[{\tt clike.lisp} ---] \S\ref{sec:clike}, p.~\pageref{sec:clike}.
Defines constructs for various user-level user-level C-like operators.
\item[{\tt print.lisp} --- ] \S\ref{sec:print}, p.~\pageref{sec:print}.
Defines a few very simple constructs for producing output.
\item[{\tt controlflow.lisp} --- ] \S\ref{sec:controlflow},
p.~\pageref{sec:controlflow}.  Defines user-level to intermediate-level
control flow constructs such as conditionals and looping.
\item[{\tt subroutines.lisp} --- ] \S\ref{sec:subroutines},
p.~\pageref{sec:subroutines}.  Provides high and low level support for
subroutines.
\item[{\tt staticdata.lisp} --- ] \S\ref{sec:staticdata},
p.~\pageref{sec:staticdata}.  Defines constructs for defining static data
objects.  Currently this is the only way to provide input to a program.
\item[{\tt program.lisp} --- ] \S\ref{sec:program},
p.~\pageref{sec:program}.  Defines very high-level constructs for wrapping
around the entire program.
\item[{\tt library.lisp} --- ] \S\ref{sec:library},
p.~\pageref{sec:library}.  Defines constructs that expand into code for
standard subroutine libraries.  Currently the library is very minimal.
\end{description}
\item[{\tt files.lisp} --- ] \S\ref{sec:files},
p.~\pageref{sec:files}.  Provides support for reading the source code to
compile from a file.
\item[{\tt test.lisp} --- ] \S\ref{sec:test}, p.~\pageref{sec:test}.
Miscellaneous functions and R code fragments for exercising the compiler.
Some of these may be obsolete.
\end{description}

Let us now present the code.

\vspace{0.5in}
{\scriptsize
\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule\vspace{0.25in}

\subsection{{\tt loader.lisp}}
\label{sec:loader}

{\normalsize
This very simple file just loads up all the Common Lisp files that make up
{\Rcomp}.  It is completely devoid of any sophisticated options.
Perhaps someday we should use one of the popular CL system-definition
facilities instead.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;;----------------------------------------------------------------------
;;; This is the loader for the reversible compiler system.  Currently all
;;; files are just in the USER package.

;; Load up the system.
(load "util")            ; General-purpose utilities.
(load "infrastructure")  ; Mechanism for defining and compiling constructs.
(load "location")        ; Describing locations where variables are stored.
(load "environment")     ; Mapping variables to their locations.
(load "regstack")        ; Direct manipulation of registers and the stack.
(load "variables")       ; Creating, destroying, moving variables.
(load "branches")        ; Branches, branch pairs, labels.
(load "expression")      ; Binding variables to multiply-nested expressions.
(load "clike")           ; C-like assignment-operator statements.
(load "print")           ; Data output.
(load "controlflow")     ; High-level conditionals & loops.
(load "subroutines")     ; Support for subroutine calls.
(load "staticdata")      ; Static data definitions.
(load "program")         ; Highest-level constructs.
(load "library")         ; Standard library of R routines.
(load "files")           ; File compiler.

(load "test")            ; Example programs.

;; Command to reload the system.
(defun l () (load "loader"))                    
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt util.lisp}} 
\label{sec:util}

{\normalsize Defines some completely non-application-specific Lisp functions and macros
that we use in {\Rcomp}.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")
;;;----------------------------------------------------------------------
;;; General utilities.

;;;----------------------------------------------------------------------
;;; Some abbreviations for Common Lisp entities.

;; Don't you agree that MULTIPLE-VALUE-BIND's name is too long?
(defmacro mvbind (&rest args)
  `(multiple-value-bind . ,args))

;; Same here.
(defmacro dbind (&rest args)
  `(destructuring-bind . ,args))

;;;----------------------------------------------------------------------
;;; Boolean shtuff.  Silly, but hey.

(defconstant true t)
(defconstant false nil)

(defmacro true! (&rest places)
  `(setf . ,(mapcan #'(lambda (place) (list place true)) places)))
(defmacro false! (&rest places)
  `(setf . ,(mapcan #'(lambda (place) (list place false)) places)))

;; Convert an arbitrary object to a true-false value.
(defun true? (obj) (if obj true false))
(defun false? (obj) (eq obj false))

;;;----------------------------------------------------------------------
;;; List manipulation.

;; REPL - Replace first occurrence.  FUNC is called on each item of LIST in
;; succession until it returns non-NIL, at which point a new list is
;; returned in which the guilty item is replaced by the value which was
;; returned by FUNC.  The new list shares its tail with the old.  If FUNC
;; never returns non-nil then a copy of LIST is returned.
(defun repl (list func)
  (if list
      (let ((v (funcall func (car list))))
        (if v (cons v (cdr list))
          (cons (car list) (repl (cdr list) func))))))

;; In this version of REPL, FUNC is passed not only each item of LIST,
;; but also the item's index (as per NTH or ELT).
(defun repl2 (list func &optional (firstindex 0))
  (labels
      ((helper (list index func)
          (if list
              (let ((v (funcall func (car list) index)))
                (if v (cons v (cdr list))
                  (cons (car list) (helper (cdr list) (1+ index) func)))))))
    (helper list firstindex func)))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt infrastructure.lisp}}
\label{sec:infrastructure}

{\normalsize
This file is the core of our macro-style compilation architecture.  The
expansion of any given language construct is defined using the {\tt
defconstruct} macro, defined below.

The core function that does the work of compilation is {\tt rcomp}.  It
recursively expands the macro definitions, while keeping track of the
environment, until the process bottoms out in statements that cannot be
further expanded.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")
;;;----------------------------------------------------------------------
;;; Compilation infrastructure.

;; Given an object, return non-nil IFF it could possibly be an
;; infix-operator statement.
(defun infix-form? (form)
  (and (listp form)
       (>= (length form) 2)
       (symbolp (second form))
       (get (second form) 'is-infix)))

;; Given a form, get it into the canonical form where the operator is
;; first.
(defun canonicalize (form)
  (if (infix-form? form)
      `(,(second form) ,(first form) . ,(cddr form))
    form))

;; Given an object, if it's an operator (construct) symbol, return
;; its definition.
(defun definition (operator)
  (and (symbolp operator)
       (get operator 'construct-definition)))

;; Given an operator (construct symbol), return the opposite operator.
;; (Which will undo the effect of the given operator.)
(defun opposite (operator)
  (get operator 'opposite))

;; Given an object, return non-NIL iff it may potentially be a
;; single form statement (not a label atom) with a definition.
(defun statement? (form)
  (and (listp form)
       (not (null form))
       (or (definition (car form))
           (infix-form? form))))

;; Guess whether an object may be a list of statements/primitives.
(defun list-of-statements? (obj)
  (and (listp obj)
       (not (statement? obj))
       (not (null obj))
       (statement? (car obj))))

;; DEFCONSTRUCT - Define how a particular construct is to be compiled.
;; Given a construct name symbol CNAME, lambda list LAMBDA-LIST, and body
;; statements BODY, define CNAME to be a reversible language construct with
;; structure given by LAMBDA-LIST and compilation generated by the BODY.
;; During compilation the BODY gets executed with the variables mentioned
;; in the LAMBDA-LIST bound to corresponding parts of the item to be
;; compiled, and with the variable ENV bound to the variable-location
;; environment in effect at the start of the statement.  The body should
;; return 2 values: the first is a list of statements to which this
;; statement is equivalent.  The second value indicates the environment in
;; effect after the given statement(s).  It may be NIL meaning that the
;; source as a high-level statement does not affect the environment after
;; the statement, although the compiled lower-level statements might.

(defmacro defconstruct (cname lambda-list &body body)
  (let ((opposite
         (if (eq (car body) :opposite)
             (prog1
               (cadr body)
               (setf body (cddr body)))
           cname)))
    `(setf (get ',cname 'opposite) ',opposite
           (get ',cname 'construct-definition)
           #'(lambda (args env)
               (let ((form (cons ',cname args)))
                 (destructuring-bind ,lambda-list args
                   . ,body))))))

(defmacro definfix ((leftarg opname &rest rightargs) &body body)
  `(progn
     (defconstruct ,opname (,leftarg . ,rightargs)
       . ,body)
     (true! (get ',opname 'is-infix))))

;; Given a statement or a list of statements to compile and an optional
;; initial environment (which defaults to the empty environment), return an
;; equivalent list of compiled statements and the environment in effect
;; after them.
(defun rcomp (source &optional startenv)
  (when (null startenv) (setf startenv (empty-env)))
  (setf source (canonicalize source))
  (cond
   ((null source)
    (values source startenv))
   ((statement? source)
    ;; Source is a single non-label statement with a definition.
    (let ((def (definition (first source))))
      (mvbind (compiled endenv)
              ;; Compile it once.
              (funcall def (cdr source) startenv)
         (mvbind (recomp reenv)
                 ;; Try compiling it further.
                 (rcomp compiled startenv)
            (values recomp
                    (or endenv reenv))))))
   ((form-list? source)
    ;; Source is a list of statements.
    (mvbind (firstcomp firstendenv)
            ;; Compile first statement.
            (rcomp (first source) startenv)
       (mvbind (restcomp restendenv)
               ;; Compile remaining statements in environment from
               ;; first statement.
               (rcomp (rest source) firstendenv)
          (values (if (listp firstcomp)
                      (append firstcomp restcomp)
                    (cons firstcomp restcomp))
                  restendenv))))
   (t
    ;; In all other cases just compile the source to itself
    ;; and leave the environment unchanged.
    (values (list source) startenv))))

;; 
;; This version of RCOMP, for debugging purposes, prints out the entire
;; state of the partially-compiled program after each individual code
;; transformation.
;; 
;; WHOLE represents the entire current state of the compilation,
;; represented as a cons cell whose CDR is the current partially-compiled
;; source, which MUST be a LIST of statements, not a single statement.
;; POINTER is a pointer to the cons cell whose CDR is the part of the
;; source that remains to be compiled.  In general, the CAR of this CDR
;; will be an ENV statement giving the current environment.
;; 
(defun rcomp-repl (whole &optional (pointer whole))
  (myprint (cdr whole)
           (if (eq (caadr pointer) 'env)
               (cddr pointer)
             (cdr pointer)))            ;Print thuh whole shebang.
  (format t "~&Ready: ")
  ;; (clear-input) (finish-output) ;These don't seem to work right.
  ;; (read-line)
  (let ((source (cdr pointer))          ;Remaining source to compile.
        startenv)
    (if (and (listp source)             ;List of statements.
             (listp (car source))       ;Non-label statement.
             (eq (caar source) 'env))   ;Special (ENV <env>) statement.
        (setf startenv (cadar source))  ;Get the <env>.
      (progn 
        ;; Invent an ENV statement and insert it.
        (format t "~&Default environment.~%")
        (setf startenv (empty-env))
        (setf (cdr pointer)             ;Alter our object as follows.
              `((env ,startenv)
                . ,source))
        (myprint (cdr whole) (cddr pointer))))
    ;; Now STARTENV is the current env, and current source obj is just
    ;; after the initial env statement.
    (setf source (cddr pointer))
    ;; If no statements left to compile, we're done.
    (when (null source)
      (return-from rcomp-repl whole))
    (let ((form (car source)))
      ;; From here on we approximately mirror structure of RCOMP.
      ;; If first form is an infix form, canonicalize it.
      (when (infix-form? form)
        ;(format t "~&Canonicalize.~%")
        (setf form (canonicalize form)
              (car source) form)
        ;(myprint (cdr whole))
        )
      (cond
       ;; If first item is label: do nothing with it.
       ((atom form)
        (format t "~&Label.~%")
        (setf (cdr pointer) `(,form
                              (env ,startenv)
                              . ,(cdr source)))
        (rcomp-repl whole (cdr pointer)))
       (t ;; Else first item is a non-label STATEMENT.
        (let ((first (first form)))
          (if (symbolp first)
              ;; Assume source code is a single statement, FIRST is the symbol
              ;; naming the statement type, for dispatching.
              (if (eq first 'env)
                  (progn
                    (format t "~&Environment override.~%")
                    (setf (cdr pointer) source)
                    (rcomp-repl whole pointer))
                (let ((def (definition first)))
                  (if (null def)
                      ;; No definition for this.  Assume it's a final
                      ;; assembly instruction and doesn't change the
                      ;; environment.
                      (progn
                        (format t "~&Final.~%")
                        (setf (cdr pointer) `(,form
                                              (env ,startenv)
                                              . ,(cdr source)))
                        (rcomp-repl whole (cdr pointer)))
                    ;; OK, we do have a definition for it.
                    (mvbind (compiled endenv)
                            ;; Call the transformer function.
                            (funcall def (cdr form) startenv)
                            ;; Insert result.
                            (format t "~&Expand ~s.~%" first)
                            (if (and endenv (null compiled))
                                (setf (cdr pointer)
                                      `((env ,endenv)
                                        . ,(cdr source)))
                              (setf (cddr pointer)
                                    (if endenv
                                        `(,@(if compiled
                                                (if (not (form-list? compiled))
                                                    (list compiled)
                                                  compiled))
                                            (env ,endenv)
                                            . ,(cdr source))
                                      `(,@(if compiled
                                              (if (not (form-list? compiled))
                                                  (list compiled)
                                                compiled))
                                          . ,(cdr source)))))
                            ;; Try compiling same thing again.
                            (rcomp-repl whole pointer)))))
            ;; The first item isn't a symbol so assume it's a statement
            ;; and treat the form as a list of statements.
            (progn
              (setf source (append form (cdr source))
                    (cddr pointer) source)
              (format t "~&Insert statement list.~%")
              (rcomp-repl whole pointer)))))))))

;; The user-level compiler-debugging routine.
(defun rcomp-debug (source)
  (rcomp-repl (cons nil (list source))))

(defun rcd (source)
  (rcomp-debug source))

;; non-nil iff obj could be a list of forms (not incl. label syms)
(defun form-list? (obj)
  (and (listp obj)
       (not (and (car obj) (symbolp (car obj))))
       (not (and (cadr obj) (symbolp (cadr obj))))))

;; Expand the source code to its compilation once, but not
;; recursively.  This is for debugging.
(defun expand1 (source &optional env)
  (let ((def (get (first source) 'construct-definition)))
    (if (null def)
        (values (list source) env)
      (funcall def (cdr source) env))))

;; For testing.
(defun myprint (code &optional pointer)
  #|(format t "~&~@
             --------~@
             Program:~@
             --------~%")|#
  (format t "~&~%")
  (if (list (car code))
      (dolist (s code)
        (if (eq s (car pointer)) (format t "==>"))
        (cond
         ((atom s) ;Interpret atoms as labels.
          (format t "~s:~15T" s))
         ((and (symbolp (car s))
               (not (get (car s) 'construct-definition))
               (not (eq (car s) 'env))
               (not (and (symbolp (cadr s))
                         (get (cadr s) 'construct-definition))))
          (format t "~16T")
          (dolist (w s)
            (if (register? w)
                (format t "$~s " (cadr w))
              (format t "~:w " w)))
          (format t "~%"))
         (t
          (format t "~16T~:w~%" s))))
    (pprint code))
  (format t "~&~%")
  (values))

(defun rc (source &optional startenv)
  (mvbind (prog env)
          (rcomp source startenv)
          (myprint prog)
          (format t "~&~%Final environment:")
          (print env))
  (values))

\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt location.lisp}}
\label{sec:location}

{\normalsize
Functions for working with ``location'' objects which give the locations of
variables.  Currently these are just implemented as simple list structures.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")
;;; ---------------------------------------------------------------------
;;; A LOCATION object indicates where a variable is stored.
;;;
;;; The current implementation uses list structures.  If a <LOCATION> is
;;; NIL, then the variable exists in the environment but has no storage
;;; location (and is therefore also unbound).  If a <LOCATION> is (REG
;;; <regno>) then the variable is located in register number <REGNO>.  If
;;; <LOCATION> is (STACK <offset>) then the variable is located on the
;;; stack at the address SP+<OFFSET>, where SP is the current value of the
;;; stack pointer register.
;;; ----------------------------------------------------------------------

;; Return non-nil iff the object OBJ is a register location.
(defun register? (obj)
  (and (listp obj) (cdr obj) (null (cddr obj))
       (eq (car obj) 'reg)))

(defun stackloc? (obj)
  (and (listp obj) (cdr obj) (null (cddr obj))
       (eq (car obj) 'stack)))

;; Return non-nil iff the object OBJ is a null location (meaning the
;; location of a variable that is not located anywhere).
(defun null-loc? (obj)
  (null obj))

;; Return the given stack location's offset from the current stack
;; pointer.
(defun offset (stackloc)
  (cadr stackloc))

(defun location? (obj)
  (or (register? obj) (stackloc? obj)))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt environment.lisp}}
\label{sec:environment}

{\normalsize Defines environment objects, which keep track of variables' location
assignments.  This is currently implemented as a full-fleged CLOS object.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")
;;; ======================================================================
;;; This file defines the interface to and implementation of ENVIRONMENT
;;; objects.  An environment object determines what variables are present
;;; in the R environment at a given point in the program, and where they
;;; are stored.  The environment also maintains identifiers for static
;;; objects.  This file provides the programmer's interface to environment
;;; objects, and should be used in lieu of manipulating the underlying
;;; structures directly.  This is intended to reduce errors and allow
;;; environments to be reimplemented at a later time.
;;; ======================================================================

(defun empty-locmap () '())

(defclass environment ()
  ((variable-locations
    :type list ;More specifically an ALIST from identifiers to locations.
    :initform (empty-locmap)
    :initarg :locmap
    :accessor locmap
    :documentation "An ALIST of the form ((<var1> . <location1>) ...).
       Each VAR is a symbol, and only appears once in the alist.  The
       variables that have most recently been created or moved appear at
       the front of the alist.")
   (static-value-identifiers
    :type list
    :initform nil
    :initarg :staticvals
    :accessor staticvals
    :documentation "A list of identifier symbols that denote static
       data values permanently located in memory.")
   (static-array-identifiers
    :type list
    :initform nil
    :initarg :staticarrays
    :accessor staticarrays
    :documentation "A list of identifier symbols denoting static arrays.")
   )
  (:documentation "An environment specifies the meanings of identifiers at
     a given point during the compilation of a program."))

(defmacro make-environment (&rest args)
  `(make-instance 'environment . ,args))

(defun empty-env ()
  (make-environment))

(defun copy-environment (env)
  (make-environment :locmap (copy-alist (locmap env))
                    :staticvals (copy-list (staticvals env))
                    :staticarrays (copy-list (staticarrays env))))

(defmethod env-to-list ((env environment))
  `(:locmap ,(locmap env)
    :staticvals ,(staticvals env)
    :staticarrays ,(staticarrays env)))

(defmethod print-object ((env environment) stream)
  (write (env-to-list env) :stream stream))

;; Return an environment like ENV, but with VAR bound to location LOC
;; in the location map.
(defmethod set-loc (var loc (env environment))
  (setf env (copy-environment env)
        (locmap env) `((,var .,loc).,(remove (assoc var (locmap env))
                                             (locmap env))))
  env)

;; Return an environment that is just like the given environment ENV but
;; with the variable VAR removed from the location map.
(defmethod remove-var (var (env environment))
  (setf env (copy-environment env) 
        (locmap env) (remove (assoc var (locmap env)) (locmap env)))
  env)

;; Return non-nil iff the variable VAR exists in the environment ENV.
(defmethod defined-in-env? (var (env environment))
  (assoc var (locmap env)))

;; Return the location of variable VAR in environment ENV, or nil if VAR
;; does not exist in the environment.  This is not guaranteed to be
;; distinct from the null location.  (The DEFINED-IN-ENV function can be
;; used to distinguish the two cases.)
(defmethod location (var (env environment))
  (cdr (assoc var (locmap env))))

;; Return the variable stored at the given location in the given
;; environment, or nil if none.
(defmethod var-at-loc (loc (env environment))
  (car (rassoc loc (locmap env) :test #'equal)))

;; Return non-nil iff the two environments E1 and E2 contain the exact same
;; set of variables.
(defmethod equal-vars? ((e1 environment) (e2 environment))
  (let ((answer t))
    (dolist (v (append (mapcar #'car (locmap e1)) (mapcar #'car (locmap e2))))
        (if (not (and (assoc v (locmap e1)) (assoc v (locmap e2))))
            (setf answer nil)))
    answer))

;; Return non-nil iff the two environments E1 and E2 are equivalent, in the
;; sense that they have the same variables and assign them to the same
;; locations.
(defmethod equal-env? ((e1 environment) (e2 environment))
  (let ((answer t))
    (dolist (v (append (mapcar #'car (locmap e1)) (mapcar #'car (locmap e2))))
      (if (not (equal (assoc v (locmap e1)) (assoc v (locmap e2))))
          (setf answer nil)))
    answer))

;; Return the first variable in environment E1 that is not located in the
;; same place in environment E2.
(defmethod first-misloc ((e1 environment) (e2 environment))
  (dolist (v (mapcar #'car (locmap e1)))
    (if (not (equal (cdr (assoc v (locmap e1))) (cdr (assoc v (locmap e2)))))
        (return v))))

;; Return the lowest-numbered available register location in the given
;; environment.  Available means not containing any variable.  Registers 0
;; and 1 are never available because 0 is reserved to contain 0 and 1 is
;; reserved to be the stack pointer.  Returns nil if no registers are
;; available.
(defmethod next-avail-reg ((env environment))
  (let ((i 2))
    (loop
     (if (not (rassoc `(reg ,i) (locmap env) :test #'equal))
         (return `(reg ,i)))
     (incf i)
     (if (= i 32) (return)))))

;; Return the first stack location ABOVE THE CURRENT STACK
;; POINTER that is available (doesn't contain a variable) in the given
;; environment.  The stack grows down, so ABOVE means MORE NEGATIVE THAN.
(defmethod next-avail-stack ((env environment))
  (let ((i -1))
    (loop
     (if (not (rassoc `(stack ,i) (locmap env) :test #'equal))
         (return `(stack ,i)))
     (decf i))))

;; Return a variable in the given environment that was least recently
;; created or moved.
(defmethod least-recently-moved ((env environment))
  ;; Currently this information is maintained by putting newly-created or
  ;; moved variables on the front of the alist, so we just return the last
  ;; variable on the list.
  (car (nth (1- (length (locmap env))) (locmap env))))

;; Return non-nil if VAR is located in a register in environment ENV.
(defmethod in-register? (var (env environment))
  (register? (location var env)))

;; Return the index of the topmost stack location at SP or below that
;; has a variable in it.  In other words, where is
;; the top of the stack in relation to the current stack pointer.
(defmethod top-of-stack ((env environment))
  (let ((h 0))
    (dolist (loc (locmap env))
      (if (eq (cadr loc) 'stack)
          (if (< (caddr loc) h)
              (setf h (caddr loc)))))
    h))

(defmethod add-staticval (name (env environment))
  (setf env (copy-environment env)
        (staticvals env) (cons name (staticvals env)))
  env)

(defmethod add-staticarray (name (env environment))
  (setf env (copy-environment env)
        (staticarrays env) (cons name (staticarrays env)))
  env)

(defmethod static-id? (obj (env environment))
  (and (symbolp obj)
       (or (member obj (staticvals env))
           (member obj (staticarrays env)))))

(defmethod dynamic-var? (obj (env environment))
  (and (symbolp obj)
       (not (static-id? obj env))))

(defmethod static-array? (obj (env environment))
  (member obj (staticarrays env)))

(defun negated-sym? (obj)
  (and (symbolp obj)
       (eq #\- (elt (symbol-name obj) 0))))

(defun positive-of (negsym)
  (intern (subseq (symbol-name negsym) 1)))

(defmethod literal? (obj (env environment))
  (or (numberp obj)
      ;; Static array identifiers are literals because they stand for their
      ;; addresses, and are left in the form of symbols which are processed
      ;; directly by the assembler. 
      (static-array? obj env)
      ;; If FOO is a static array, -FOO is a literal also.
      (and (negated-sym? obj)
           (static-array? (positive-of obj) env))
      ;; Expression is the address of a static-val.
      (static-val-addr? obj env)))

(defmethod static-val? (obj (env environment))
  (member obj (staticvals env)))

(defmethod static-val-addr? (obj (env environment))
  (and (listp obj)
       (eq (car obj) '&)
       (null (cddr obj))
       (static-val? (second obj) env)))\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt regstack.lisp}}
\label{sec:regstack}

{\normalsize This file defines low-level constructs for directly manipulating registers
and the stack.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;;----------------------------------------------------------------------
;;; Register/stack manipulation.

(defconstruct relocate (var loc)
  (let ((oldloc (location var env)))
    (if (not (equal oldloc loc))        ;If not already there.
        (if (null oldloc)
            `((vacate ,loc)
              (tell-loc ,var ,loc))
          (if (null loc)
              `(tell-loc ,var ,loc)
            (let ((oldv (var-at-loc loc env)))
              (if oldv
                  ;; If new location occupied, swap.
                  `((swaploc ,oldloc ,loc)
                    (tell-loc ,var ,loc)
                    (tell-loc ,oldv ,oldloc))
                ;; Not occupied, just move.
                (if (null-loc? oldloc)
                    `(tell-loc ,var ,loc)
                  `((moveloc ,oldloc ,loc)
                    (tell-loc ,var ,loc))))))))))

;;; loc1 and loc2 should be register or stack locations.
(defconstruct swaploc (loc1 loc2)
  (if (and (register? loc1)
           (register? loc2))
      `(swapregs ,loc1 ,loc2)
    (if (register? loc1)
        `(exregstack ,loc1 ,loc2)
      (if (register? loc2)
          `(exregstack ,loc2 ,loc1)
        ;; We need a temporary register to facilitate the stack exchange;
        ;; we choose reg. 31 for no particular reason.  The net change to
        ;; it is nil.  This all works but could probably be made
        ;; considerably more efficient.
        `((exregstack (reg 31) ,loc1)
          (exregstack (reg 31) ,loc2)
          (exregstack (reg 31) ,loc1))))))

;; Assuming loc2 is clear, move loc1 to it.
(defconstruct moveloc (loc1 loc2)
  (if (and (register? loc1)
           (register? loc2))
      `(movereg ,loc1 ,loc2)
    (if (register? loc1)
        `(exregstack ,loc1 ,loc2)
      (if (register? loc2)
          `(exregstack ,loc2 ,loc1)
        ;; We need a temporary register to facilitate the stack exchange;
        ;; we choose reg. 31 for no particular reason.  The net change to
        ;; it is nil.  This all works but could probably be made
        ;; considerably more efficient.
        `((exregstack (reg 31) ,loc1)
          (exregstack (reg 31) ,loc2)
          (exregstack (reg 31) ,loc1))))))

;; Would save a lot of ADDI instructions if I changed this to modify the
;; stack pointer before but not after; and instead change the environment
;; to reflect correct new variable locations and amount of stack adjustment
;; from original.  But perhaps it would be better to leave the stack
;; pointer alone and get rid of adjacent ADDIs via a later peephole
;; optimization or something.
(defconstruct exregstack (reg stackloc)
  `(with-SP-adjustment ,(offset stackloc)
        (exch ,reg (reg 1))))

;; Given a register, push its contents onto the stack.  Not currently used.
(defconstruct push (reg)
  `((exch ,reg (reg 1)) ;; <-- Convention: r1 is stack pointer.
    (++ (reg 1)))

;;;----------------------------------------------------------------------
;;; Pure register manipulation.

;; swapregs R1 R2 - Given two registers, swap their contents.
(defconstruct swapregs (r1 r2)
  ;; Implementation for architectures that support XOR'ing regs, but not
  ;; swapping regs directly.  Another way uses +=, -=, and NEG but takes 4
  ;; instructions.
  `((,r1 ^= ,r2)
    (,r2 ^= ,r1)
    (,r1 ^= ,r2)))

;; Fast way to move r1 to r2 when r2 is known to be empty!  Otherwise
;; behavior is "undefined" (actually in this implementation r1 gets r2, but
;; r2 ends up with r2^r1).
(defconstruct movereg (r1 r2)
  `((,r2 ^= ,r1)
    (,r1 ^= ,r2)))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt variables.lisp}}
\label{sec:variables}

{\normalsize Defines high- to low-level constructs for
manipulation of variables in variable assignments (environments).}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")
;;; ----------------------------------------------------------------------
;;; Constructs for variable-environment manipulation (creating/destroying
;;; variables, changing their locations, etc.)
;;; ----------------------------------------------------------------------

;;;----------------------------------------------------------------------
;;; User-level constructs.

;; Create a new variable VAR, bind it to VAL, execute the BODY, and then
;; unbind it from VAL and get rid of it.  VAL may be an expression, but it
;; must evaluate to whatever value VAR actually has at the end of the BODY,
;; or else all bets are off!
;;
;; 6/3/97 - Now LET is slightly more general---VAR can be put into a
;; relationship with VAL in any of a number of ways... <-, <->, ^=, +=...
;; <-, ^=, += are all equivalent given that SCOPE forces VAR to initially
;; be zero, but <-> is different... It sets VAR by swapping it with VAL,
;; which obviously must be a location of some sort.  Afterwards VAR is
;; restored to zero by swapping it back.  Note that in this case, if VAR is
;; not left at zero by the BODY, this is fine and results in VAL being
;; side-effected.  In other words, this kind of LET is effectively
;; temporarily giving VAL a new name which pulls it into a register if say
;; it was originally an array entry.  Another kind of operation (not yet
;; defined) would have VAL be a variable and assign VAR to be truly a
;; synonym for that exact same variable.

(defconstruct let ((var ~ val) &body body)
  (if (eq ~ '<-)
      `(scope ,var
          (_with (,var <- ,val)
                 . ,body))
    `(scope ,var
        (with (,var ,~ ,val)
              . ,body))))

;; Declare some vars that should be allocated register locations as soon
;; as they are created.
(defconstruct with-regvars (var-or-vars &body body)
  `(scope ,var-or-vars
     (register ,var-or-vars)
     . ,body))

;; User-level hint to compiler: put the following variables in registers
;; now rather than later.
(defconstruct register (var-or-vars)
  (let ((varlist (if (listp var-or-vars) var-or-vars (list var-or-vars))))
    (mapcar #'(lambda (var) `(get-in-register ,var)) varlist)))

;;;----------------------------------------------------------------------
;;; Intermediate-level constructs.  Not recommended for casual users.

(defconstruct with-location-map (locmapdesc &body body)
  `((locmap ,locmapdesc)
    ,@body
    (locmap ,locmapdesc)))

;; WITH-ENVIRONMENT envdesc body - Ensure that the environment, as far as
;; location maps go, is equivalent to the one specified by environment
;; description ENVDESC, both at the beginning and at the end of the body.
(defconstruct with-environment (envdesc &body body)
  `((environment ,envdesc)
    ,@body
    (environment ,envdesc)))

;; ENVIRONMENT envdesc - Ensure that the environment is equivalent to the
;; one specified by environment description ENVDESC.  ENVDESC must describe
;; an environment object.  Currently the only supported kind of description
;; is an environment object itself.  Environments are equivalent if they
;; have the same variables in the same locations.  ENVIRONMENT will move
;; variables around as necessary to make the environments match, but it
;; will not create or destroy any variables.  If the environments cannot be
;; made to match, currently a compiler error is generated.
(defconstruct environment (envdesc)
  (if (equal-env? env envdesc)
      (values '() envdesc)  ;Tell RCOMP the requested form of the description.
    (if (equal-vars? env envdesc)       ;Do the envs have the same variables?
        ;; Relocate the first mis-located variable, and try again.
        (let ((v (first-misloc env envdesc)))
          (if (null (location v envdesc))
              `(environment ,(set-loc v (location v env) envdesc))
            `((relocate ,v ,(location v envdesc))
              (environment ,envdesc))))
      (error "Environments ~s and ~s don't match." env envdesc))))

(defconstruct locmap (locmapdesc)
  (setf env2 (copy-environment env)
        (locmap env2) locmapdesc)
  `(environment ,env2))

(defconstruct declare-locmap (locmapdesc)
  (setf env (copy-environment env)
        (locmap env) locmapdesc)
  (values nil env))

(defconstruct declare-environment (envdesc)
  (setf env (copy-environment envdesc))
  (values nil env))

;; The given variable should exist throughout the body of the scope, no
;; more, no less.  The body must leave the variable clear, or else!
(defconstruct scope (var &body body)
  (let ((vlist (if (listp var) var (list var))))
    `(with ,(mapcar #'(lambda (var) `(add-to-env ,var)) vlist)
           ,@body))
  ;; Note danger if var is not actually clear at end of BODY!
  )

;; ENSURE-GREEN enforces environmental correctness -- it leaves the
;; environment just the way it found it. (With regards to its location map.)
(defconstruct ensure-green (&body body)
  `(,@body
    (locmap ,(locmap env))))

;; DECLARE-GREEN declares that the environment in effect when the body
;; is entered will necessarily be in effect when it ends.  Don't use this
;; when it isn't true!
(defconstruct declare-green (&body body)
  (values body env))

;; Make the LOCATION be clear, and associate it with a new variable VARNAME.
(defconstruct new-var-at (varname location)
  (if (defined-in-env? varname env)
      (error "Variable ~s is already in the environment!" varname)
    `((vacate ,location)
      (tell-loc ,varname ,location))))

;; Make a particular location LOC become available (empty, and no variable
;; assigned to it).
(defconstruct vacate (loc)
  (let ((v (var-at-loc loc env)))
    (if v
        ;; Location is occupied by variable V.
        (let ((reg (next-avail-reg env)))
          ;; If any registers are available, move V there.
          (if reg `(relocate ,v ,reg)
            ;; Else move V to the next available stack location.
            (let ((s (next-avail-stack env)))
              (if s `(relocate ,v ,s))))))))

;; Arrange for the given variable, which should already be present in the
;; environment, to be located in a register (instead of on the stack).
(defconstruct get-in-register (var)
  (if (symbolp var)
      (let ((l (location var env)))
        (if (not (register? l))         ;If it's not already in a register,
            (let ((reg (next-avail-reg env)))
              (if reg       ;If there is a register avaiable, put it there.
                  (if (null-loc? l)
                      `(tell-loc ,var ,reg)
                    `(relocate ,var ,reg))
                ;; Else boot out the least-recently moved variable.
                (let* ((victim (least-recently-moved env))
                       (loc (location victim env)))
                  (if (null-loc? l)
                      `((vacate ,loc)
                        (tell-loc ,var ,loc))
                    `(relocate ,var ,loc)))))))))

;;;----------------------------------------------------------------------
;;; Primitive environment-manipulation constructs.

;; Create the given variable in the environment, but don't give it a
;; location quite yet.
(defconstruct add-to-env (var) :opposite remove-var
  (if (defined-in-env? var env)
      (error "Variable ~s already exists!" var)
    (values '() (set-loc var nil env))))

;; Change the current environment to have the location of variable VAR as
;; being LOC.  Generates no code.  This construct is dangerous if the old
;; location of VAR has a non-zero runtime value, and is not associated with
;; any other variable.
(defconstruct tell-loc (var loc)
  (values '() (set-loc var loc env)))

;; Assuming that a variable is empty, remove it from the environment!
;; (Danger, Will Robinson!)  This causes grave problems if the runtime
;; value of the variable is not zero.  But currently we generate no runtime
;; code to notice that condition, so watch out!
(defconstruct remove-var (varname) :opposite add-to-env
  (values '() (remove-var varname env)))

\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt branches.lisp}}
\label{sec:branches}

{\normalsize Constructs providing intermediate- and
low-level support for various kinds of branch structures for control-flow.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")
;;;----------------------------------------------------------------------
;;; Support for various kinds of branches.
;;; These constructs are not intended to appear in source code,
;;; but are rather used to implement higher-level control-flow
;;; constructs.
;;;----------------------------------------------------------------------

;;;----------------------------------------------------------------------
;;; Relatively high-level branch constructs.

;; paired binary conditional switching branches.  The body in between the
;; two branches must conserve the environment or else we won't have a
;; definite compile-time idea of the environment after the branch pair
;; because we don't know whether the branch succeeds or fails at run-time
;; or not.  Note the vars must really be variables and not literals or
;; registers.
(defconstruct bcs-branch-pair (toplab (vara1 ~a vara2)
                               botlab (varb1 ~b varb2)
                               &body body)
  `(;; All the variables involved need to be in registers before we start.
    (get-in-register ,vara1)
    (get-in-register ,vara2)
    (get-in-register ,varb1)
    (get-in-register ,varb2)
    (bcs-branch (,vara1 ,~a ,vara2) ,toplab ,botlab)
    ;; Since the vars were already in registers, BCS-BRANCH will not have
    ;; modified the environment after the branch point.
    (ensure-green ;Complain if the body doesn't clean up after itself. 
     ,@body)
    ;; Due to the above GET-IN-REGISTERs and the ENSURE-GREEN, the b
    ;; variables will already be in registers here, so this BCS-BRANCH will
    ;; not need to modify the environment at all from the current one,
    ;; which is identical to the one just before the branch point.
    (bcs-branch (,varb1 ,~b ,varb2) ,botlab ,toplab)))
    
;; (The following construct is currently not used.)  Twin (meaning with
;; identical tests and variables) binary-operator conditional switching
;; branches.  The body in between the two branches must conserve the
;; environment or else we won't have a definite compile-time idea of the
;; environment after the branch pair because we don't know whether the
;; branch succeeds or fails at run-time or not.
(defconstruct twin-bcs-branch ((var1 ~ var2) toplab botlab &body body)
  `((get-in-register ,var1)
    (get-in-register ,var2)
    (bcs-branch (,var1 ,~ ,var2) ,toplab ,botlab)
    ;; bcs-branch had better not itself change the environment
    ;; after it branches!
    (ensure-green
     ,@body)
    (bcs-branch (,var1 ,~ ,var2) ,botlab ,toplab)))

;; Twin unconditional switching branches.
;; Now that the environment contains information other than
;; the locations of run-time variables, does it make
;; sense for it to be completely green?  Declaring static variables
;; inside the body might be expected to be able to affect the
;; outside world.  Or, maybe it shouldn't.  Haven't decided yet.
(defconstruct twin-us-branch (toplab botlab &body body)
  ;; TWIN-US-BRANCH is GREEN on the outside because encountering it from
  ;; the outside you just jump over it, and the environment doesn't change.
  `(declare-green
    (sbra-pair ,toplab ,botlab . ,body))
  ;; We have no idea what the environment is inside the first bra, though
  ;; (cuz we might slip into the middle as a subroutine call), so we can't
  ;; put an ensure-green or anything in there.  The environment in effect
  ;; at this point, which just leeches in from above, is usually wrong.
  ;; Still, the body needs to be careful that whatever environment is in
  ;; effect at its end is the same as the one it assumes at its top.  But
  ;; this is a job for a higher level to worry about.
  )

;;;----------------------------------------------------------------------
;;; lower-level branch constructs.

;;; Note to self: I think that the way branches and environments
;;; interact may be incorrect.  If the variables mentioned in the
;;; branch are not in registers, then the environment needs to change
;;; to allow the branch to be done---so the environment declared
;;; at the place we're branching to may be wrong.  Need to go thru
;;; and fix carefully.  Really, need a more sophisticated approach
;;; to how environments are kept track of during compilation of
;;; complex control-flow structures.

;; This low-level thing doesn't worry about environments at all.
;; That's a job for higher-level dudes that use it.
(defconstruct sbra-pair (toplab botlab &body body)
  `((sbra ,toplab ,botlab)
    ,@body
    (sbra ,botlab ,toplab)))

;; 
;; SBRA: Switching branch (unconditional).  Branch is
;; from label thislab to otherlab.
;;
;; Semantics is: if we branch to this statement from
;; otherlab, then continue forwards normally.  If we
;; arrive at this statement normally, then branch to
;; otherlab.  If we arrive at this statement some other
;; way, results are undefined.
;; 
(defconstruct sbra (thislab otherlab)
  `((label ,thislab)  ;Convention: label precedes labeled statement.
    (bra ,otherlab))) ;Assume that the hardware gives the semantics we want.

(defconstruct sbez (thislab var lab)
  ;; There's no built-in BEZ, so we reserve reg $0 to be zero
  ;; so we can just use BEQ instead.
  `(bcs-branch (,var = (reg 0)) ,thislab ,lab))

(defconstruct sbnz (thislab var lab)
  ;; There's no built-in BNZ, so we reserve reg $0 to be zero
  ;; so we can just use BNE instead.
  `(bcs-branch (,var != (reg 0)) ,thislab ,lab))

(defconstruct bcs-branch ((var1 ~ var2) thislab otherlab)
  (cond
   ;; If the variables aren't in registers, get them there.  The only thing
   ;; is, I'm not sure it makes sense to do any environment manipulation at
   ;; this level because it makes it difficult for the higher level stuff
   ;; to ensure thtat the environment is consistent at both ends of the
   ;; actual branch point.
   ((and (member ~ '(= !=)) (numberp var2) (zerop var2))
    ;; To compare for equality with zero, compare with $0 (reserved for 0).
    `(bcs-branch (,var1 ,~ (reg 0)) ,thislab ,otherlab))
   ((and (or (register? var1)
             (in-register? var1 env)
             (eql var1 0))
         (or (register? var2)
             (in-register? var2 env)
             (eql var2 0)))
    `((label ,thislab)
      ;; This assumes that BC-BRANCH has the right switching sort of
      ;; semantics, and that it doesn't insert any instructions before the
      ;; actual branch.
      (bc-branch (,var1 ,~ ,var2) ,otherlab)))
   ;; Does this make sense?
   ((and (symbolp var1) (defined-in-env? var1 env)
         (not (in-register? var1 env)))
    `((get-in-register ,var1)
      (bcs-branch (,var1 ,~ ,var2) ,thislab ,otherlab)))
   ((and (symbolp var2) (defined-in-env? var2 env)
         (not (in-register? var2 env)))
    `((get-in-register ,var2)
      (bcs-branch (,var1 ,~ ,var2) ,thislab ,otherlab)))
   ((and (symbolp var1) (not (defined-in-env? var1 env)))
    `((add-to-env ,var1)
      (bcs-branch (,var1 ,~ ,var2) ,thislab ,otherlab)))
   ((and (symbolp var2) (not (defined-in-env? var2 env)))
    `((add-to-env ,var2)
      (bcs-branch (,var1 ,~ ,var2) ,thislab ,otherlab)))
   ;; I could go on and handle expressions and literals as well, but again
   ;; I'm concerned that this isn't the right level.
   ))
   
;; binary conditional branch
(defconstruct bc-branch ((var1 ~ var2) destlab)
  (cond
   ((and (or (register? var1) (eql var1 0))
         (or (register? var2) (eql var2 0)))
    `(rbc-branch (,var1 ,~ ,var2) ,destlab))
   ;; If the variables are in registers, just look at the registers.
   ((and (symbolp var1) (in-register? var1 env))
    `(bc-branch (,(location var1 env) ,~ ,var2) ,destlab))
   ((and (symbolp var2) (in-register? var2 env))
    `(bc-branch (,var1 ,~ ,(location var2 env)) ,destlab))
   ;; We can't really do any environment manipulation at this level
   ;; because the instructions manipulated will come between us and the
   ;; label inserted by BCS-BRANCH.
   (t
    (error "BC-BRANCH can only cope with variables residing in registers!")
    )))

;;;----------------------------------------------------------------------
;;; Branching primitives.

;; A label is a tag that gives an address in code that is a target
;; for branching.
(defconstruct label (labname)
  labname)

(defconstruct bez (reg lab)
  ;; There's no built-in BEZ, so we reserve reg $0 to be zero
  ;; so we can just use BEQ instead.
  `(rbc-branch (,reg = (reg 0)) ,lab))

(defconstruct bnz (reg lab)
  ;; Similar, use BNE.
  `(rbc-branch (,reg != (reg 0)) ,lab))

(defparameter *bc-branch-instructions*
  '((!= . bne) (= . beq)))

(defparameter *zerocmp-branch-instructions*
  '((>= . bgez) (<= . blez) (> . bgtz) (< . bltz)))

;; "register binary conditional branch"
;; tests whether two registers satisfy some relation ~ and if so
;; branch to DESTLAB.
(defconstruct rbc-branch ((reg1 ~ reg2) destlab)
  (cond
   ((assoc ~ *bc-branch-instructions*)
    `(,(cdr (assoc ~ *bc-branch-instructions*))
      ,reg1 ,reg2 ,destlab))
   ((and (eql reg2 0)
         (assoc ~ *zerocmp-branch-instructions*))
    `(,(cdr (assoc ~ *zerocmp-branch-instructions*))
      ,reg1 ,destlab))))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt expression.lisp}}
\label{sec:expression}

{\normalsize Constructs and low-level functions for
expanding nested expressions.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;; This version of WITH allows any temporary effect, not just
;; variable binding, to be done and undone around the body.
(defconstruct with (statement &body body)
  `(,statement
    ,@body
    (undo ,statement)))

;; Given any statements, do their reverse (undoing their effects).  Don't
;; depend too much on this always working yet.
(defconstruct undo (&rest statements)
  (unless (null statements)
    (dbind (first . rest) statements
      (if (list-of-statements? first)
          `(undo ,@first . ,rest)
        (let ((statement (canonicalize first)))
          `((undo . ,rest)
            (,(opposite (first statement)) . ,(rest statement))))))))

;; Maps "expanding" binary operators to their do/undo statements. 
(defparameter *expanding*
  '((& ^=&) (<< ^=<<) (>> ^=>>) (* +=* -=*) (*/ +=*/ -=*/) (_ <-_ ->_)))
(defun forw (binop)
  (cadr (assoc binop *expanding*)))
(defun revers (binop)
  (or (caddr (assoc binop *expanding*))
      (cadr (assoc binop *expanding*))))

(defun expression? (obj)
  (and (listp obj)
       (not (location? obj))
       (not (statement? obj))))

;; This version of with doesn't evaluate expressions as many times.
;; but uses up linear space during body.  It only handles <- (bind) type
;; statements though.
(defconstruct _with ((var <- val) &body body)
  (cond
   ((or (not (expression? val))
        (literal? val env))
    `(with (,var <- ,val)
           . ,body))
   ((null (cddr val)) ; No more than 2 words in value expression.
    (cond
     ((eq (first val) '*)
      ;; These expansions are a bit questionable because what if the body
      ;; tries to look at the dereferenced value also?  It will see 0 (or
      ;; whatever was in VAR) instead.  But the alternative, of introducing
      ;; yet another temporary and swapping the contents back before doing
      ;; the body, seems too inefficient.
      (if (or (register? (second val))
              (dynamic-var? (second val) env))
          `((,var <->* ,(second val))
            ,@body
            (,var <->* ,(second val)))
        (let ((tv (gentemp)))
          `(_with (,tv <- ,(second val))
              `((,var <->* ,tv)
                ,@body
                (,var <->* ,tv))))))))
   (t
    (dbind (a1 ~ a2) val  ;But what about other expressions?
      (let ((rb (revers ~))
            (fb (forw ~)))
        (cond
         ((and (numberp a1) (numberp a2))
          `((,var <- ,(funcall ~ a1 a2)) ;Warning: this is too simplistic.
            ,@body
            (,var -> ,(funcall ~ a1 a2))))
         ((eq ~ '+)
          `(with ((,var += ,a1)
                  (,var += ,a2))
            ,@body))
         ((and (eq ~ '+) (not (expression? a1)))
          `(_with (,var <- ,a2)
              (with (,var += a1)
                 ,@body)))
         ((and (eq ~ '+) (not (expression? a2)))
          `(_with (,var <- ,a1)
              (with (,var += ,a2)
                 ,@body)))
         ((and (eq ~ '-) (not (expression? a2)))
          `(_with (,var <- ,a1)
              (with (,var -= ,a2)
                 ,@body)))
         ((and (expression? a1) (expression? a2))
          (let ((tv1 (gentemp))
                (tv2 (gentemp)))
            `(let (,tv1 <- ,a1)
               (let (,tv2 <- ,a2)
                 (,var ,fb ,tv1 ,tv2)
                 ,@body
                 (,var ,rb ,tv1 ,tv2)))))
         ((expression? a1)
          (let ((tv (gentemp)))
            `(let (,tv <- ,a1)
               (,var ,fb ,tv ,a2)
               ,@body
               (,var ,rb ,tv ,a2))))
         ((expression? a2)
          (let ((tv (gentemp)))
            `(let (,tv <- ,a2)
               (,var ,fb ,a1 ,tv)
               ,@body
               (,var ,rb ,a1 ,tv))))
         (t
          `((,var ,fb ,a1 ,a2)
            ,@body
            (,var ,rb ,a1 ,a2)))))))))

;;;----------------------------------------------------------------------
;;; Variable binding and unbinding.  For most purposes this takes the
;;; place of assignment.

;; Semantics of BIND: assuming that VAR is already clear,
;; set it to VAL.  
(definfix (var <- val) :opposite ->
  ;; Implemented using +=, but ^= would also work.
  (cond
   ((or (symbolp val) (numberp val) (register? val) (literal? val env))
    `(,var += ,val))
   ((expression? val)
    ;; Binary expression.
    (destructuring-bind (a1 ~ a2) val   ;What about other syntaxes?
      (cond
       ((and (numberp a1) (numberp a2))
        `(,var += ,(funcall ~ a1 a2)))  ; Really too simplistic.
       ((eq ~ '+)
        `((,var += ,a1)
          (,var += ,a2)))
       ((eq ~ '-)
        `((,var += ,a1)
          (,var -= ,a2)))
       ((eq ~ '^)
        `((,var ^= ,a1)
          (,var ^= ,a2)))
       ((eq ~ '*)
        `(,var +=* ,a1 ,a2))
       ((assoc ~ *expanding*)
        `(,var ,(forw ~) ,a1 ,a2))
       ((extract form env :lvalues 1))
       (t
        (error "Don't know how to compile ~s." form)))))))

;; Assuming that VAR=VAL, restore it to zero.
(definfix (var -> val) :opposite <-
  (cond
   ((or (symbolp val) (numberp val) (register? val) (literal? val env))
    `(,var -= ,val))
   ((expression? val)
    ;; Binary expression.
    (destructuring-bind (a1 ~ a2) val
      (cond
       ((and (numberp a1) (numberp a2))
        `(,var -= ,(funcall ~ a1 a2)))  ; Really too simplistic.
       ((eq ~ '+)
        `((,var -= ,a1)
          (,var -= ,a2)))
       ((eq ~ '-)
        `((,var -= ,a1)
          (,var += ,a2)))
       ((eq ~ '^)
        `((,var ^= ,a1)
          (,var ^= ,a2)))
       ((eq ~ '*)
        `(,var -=* ,a1 ,a2))
       ((assoc ~ *expanding*)
        ;; Use the appropriate reverse op if different from forward one.
        `(,(revers ~) ,var ,a1 ,a2))
       ((extract form env :lvalues 1))
       (t
        (error "Don't know how to compile ~s." form)))))))
       

;;; ----------------------------------------------------------------------
;;; New thingy.  constructs all use this same function EXTRACT to
;;; automatically replace located variables with their locations, move
;;; stack variables into registers before operating on them, create
;;; temporary variables for subexpressions and compute their values.

;; EXTRACT - you give it a form, and it returns code that
;; creates appropriate temporary stuff around it and gets variables
;; in registers together with a reduced version of the original
;; form.
;;    RELEVANT-TERMS is a list of the indices (as per NTH or ELT) of those
;; terms that are candidates for expanding.  If not provided, all terms are
;; considered fair game.
;;    LVALUES is similarly the index of or a list of the indices of
;; a term or terms that are considered to be "lvalues", that is,
;; "destinations" where the value of the term is changed by the
;; statement.  Anything in LVALUES is automatically also a candidate
;; for expanding.
;;    The indices in both RELEVANT-TERMS and LVALUES refer to the
;; indices the terms have *after* any canonicalization.
;;    NIL is returned if EXTRACT can't do anything.

(defun extract (form env &key lvalues (relevant-terms
                                       (labels ((countlist (n)
                                                 (if (>= n 0)
                                                     (cons n
                                                       (countlist
                                                        (1- n))))))
                                         (countlist (length form)))))
  (setf form (canonicalize form));So we can forget about infix.
  (labels ((lvalue? (index)
             "Return non-NIL if the given index is the index of
              a term that is an LVALUE (modifiable term)."
             (or (eql index lvalues)
                 (and (listp lvalues)
                      (member index lvalues))))
           (candidate? (index)
             "Return non-NIL if the given index is the index of a
              term that is a candidate for expansion."
             (or (member index relevant-terms)
                 (lvalue? index))))
    ;; First we locate the first term that is an expression or
    ;; a literal, and convert it into a temporary variable.
    (let (before)
      (setf (cdr form)
            (repl2 (cdr form)
                  #'(lambda (term index)
                      (if (and (candidate? index)
                               (or (expression? term)
                                   (literal? term env)))
                          (let ((tv (gentemp)))
                            (if (lvalue? index)
                                (setf before `(,tv <-> ,term))
                              (setf before `(,tv <- ,term)))
                            tv)))
                  1))
      (when before
        (return-from extract `(let ,before ,form))))
    ;; If any term is a static value identifier, wrap the statement in
    ;; a binding of a temporary to the value's address and replace the
    ;; term with a dereferencing expression.
    (let (before)
      (setf (cdr form)
            (repl2 (cdr form)
                  #'(lambda (term index)
                      (if (and (candidate? index)
                               (static-val? term env))
                          (let ((tv (gentemp)))
                            (setf before `(,tv <- (& ,term)))
                            `(* ,tv))))
                  1))
      (when before
        (return-from extract `(let ,before ,form))))
    ;; Now look for variables and make sure they are in the environment.
    ;; If not, add them, but don't remove them afterwards.  This lets
    ;; user refrain from explicitly adding variables although he will
    ;; still have to get rid of them manually.
    (let ((index 1))
      (dolist (term (cdr form))
        (when (and (dynamic-var? term env)
                   (candidate? index)
                   (not (defined-in-env? term env)))
          (return-from extract
            `((add-to-env ,term)
              ,form)))
        (incf index)))
    ;; Next, get any mentioned variables into registers.
    (let ((index 1))
      (dolist (term (cdr form))
        (when (and (dynamic-var? term env)
                   (candidate? index)
                   (not (in-register? term env)))
          (return-from extract
            `((get-in-register ,term)
              ,form)))
        (incf index)))
    ;; Finally, replace variables with the registers they're in.
    (let (found?)
      (setf (cdr form)
            (repl2 (cdr form)
                  #'(lambda (term index)
                      (when (and (dynamic-var? term env)
                                 (candidate? index)
                                 (in-register? term env))
                        (true! found?)
                        (location term env)))
                  1))
      (if found? form))))               ;End function EXTRACT.

\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt clike.lisp}}
\label{sec:clike}

{\normalsize Defines constructs for various user-level user-level C-like operators.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;;----------------------------------------------------------------------
;;; C-like assignment statements.

(definfix (var ++)
  `(,var += +1))

;; "-" statement: negate the given lvalue in place.
(defconstruct - (var)
  (cond
   ((register? var)
    `(neg ,var))
   (t
    (extract form env :lvalues 1))))

(definfix (var <=< val)
  (cond
   ((and (numberp val) (zerop val))
    '())
   ((and (register? var) (static-val-addr? val env))
    `(rl ,var ,(second val)))
   ((and (register? var) (literal? val env))
    `(rl ,var ,val))
   ((and (register? var) (register? val))
    `(rlv ,var ,val))
   (t
    (extract form env
             :relevant-terms (if (not (literal? val env)) '(2))
             :lvalues 1))))

(definfix (var >=> val)
  (cond
   ((and (numberp val) (zerop val))
    '())
   ((and (register? var) (static-val-addr? val env))
    `(rr ,var ,(second val)))
   ((and (register? var) (literal? val env))
    `(rr ,var ,val))
   ((and (register? var) (register? val))
    `(rrv ,var ,val))
   (t
    (extract form env
             :relevant-terms (if (not (literal? val env)) '(2))
             :lvalues 1))))

(definfix (var += val) :opposite -=
  (cond
   ((and (numberp val) (zerop val))
    '()) ;Optimization: don't add 0
   ((and (register? var) (static-val-addr? val env))
    `(addi ,var ,(second val)))
   ((and (register? var) (literal? val env))
    `(addi ,var ,val))
   ((and (register? var) (register? val))
    `(add ,var ,val))
   (t
    (extract form env
             :relevant-terms (if (not (literal? val env)) '(2))
             :lvalues 1))))
    
(definfix (var -= val) :opposite +=
  (cond
   ((and (register? var) (numberp val))
    `(,var += ,(- val)))                ;No SUBI instruction.
   ((and (register? var) (static-array? val env))
    `(,var += ,(intern (concatenate 'string "-" (symbol-name val)))))
   ((and (register? var) (static-val-addr? val env))
    `(addi ,var ,(intern (concatenate 'string "-"
                                      (symbol-name (second val))))))
   ((and (register? var)
         (literal? val env)
         (negated-sym? val))
    `(,var += ,(positive-of val)))
   ((and (register? var) (register? val))
    `(sub ,var ,val))
   (t
    (extract form env
             :relevant-terms (if (not (literal? val env)) '(2))
             :lvalues 1))))

;; Very much like +=.  More abstraction?
(definfix (var ^= val)
  (cond
   ((and (numberp val) (zerop val))
    '()) ;Optimization: don't add 0
   ((and (register? var) (numberp val))
    `(xori ,var ,val))
   ((and (register? var) (register? val))
    `(xor ,var ,val))
   (t
    (extract form env
             :relevant-terms (if (not (numberp val)) '(2))
             :lvalues 1))))

(definfix (dest ^=& src1 src2)
  (cond
   ((and (register? dest) (register? src1) (register? src2))
    `(andx ,dest ,src1 ,src2))
   (t
    (extract form env :lvalues 1))))

(definfix (dest ^=<< src1 src2)
  (cond
   ((and (register? dest) (register? src1) (register? src2))
    `(sllvx ,dest ,src1 ,src2))
   (t
    (extract form env :lvalues 1))))

;; This is a logical shift right.
(definfix (dest ^=>> src1 src2)
  (cond
   ((and (register? dest) (register? src1) (register? src2))
    `(srlvx ,dest ,src1 ,src2))
   (t
    (extract form env :lvalues 1))))

;; (base _ offset) gets transformed into this, where dest is
;; some temporary register.
(definfix (dest <->_ base offset)
  ;; THIS IS WRONG!  Extracting before expanding runs the danger
  ;; that the variable assignments used during the extraction
  ;; could be invalidated during the body of the WITH, I think 6/3/97
  (or (extract form env :lvalues 1)
      `(with (,base += ,offset)
          (,dest <->* ,base))))
    
(definfix (dest <-_ base offset) :opposite ->_
  `(,dest <-* (,base + ,offset)))

(definfix (dest ->_ base offset) :opposite <-_
  `(,dest ->* (,base + ,offset)))

(definfix (dest <-* ptr)
  ;; THIS IS WRONG!  Extracting before expanding runs the danger
  ;; that the variable assignments used during the extraction
  ;; could be invalidated during the header of the LET.
  (or
   (extract form env :lvalues 1)
   (let ((tv (gentemp)))
     `(let (,tv <->* ,ptr)
        (,dest <- ,tv)))))
         
(definfix (dest ->* ptr)
  (or
   (extract form env :lvalues 1)
   (let ((tv (gentemp)))
     `(let (,tv <->* ,ptr)
        (,dest -> ,tv)))))
         
(definfix (left <->* rightptr)
  (cond
   ((extract form env :lvalues 1))
   ((and (register? left) (register? rightptr))
    `(exch ,left ,rightptr))))

(definfix (var +=* val1 val2) :opposite -=*
  `(call mult ,var ,val1 ,val2))

(definfix (var -=* val1 val2) :opposite +=*
  `(rcall mult ,var ,val1 ,val2))

(definfix (var +=*/ val1 val2) :opposite -=*/
  `(call _smf ,val1 ,val2 ,var)) ;Note dest is last.

(definfix (var -=*/ val1 val2) :opposite +=*/
  `(rcall _smf ,val1 ,val2 ,var))

(definfix (left <-> right)
  (cond
   ((and (location? left) (location? right))
    `(swaploc ,left ,right))
   ((and (listp right)
         (>= (length right) 3)
         (dbind (base ~ offset) right
           (if (eq ~ '_)
               `(,left <->_ ,base ,offset)))))
   ((and (listp left)
         (>= (length left) 3)
         (dbind (base ~ offset) left
           (if (eq ~ '_)
               `(,right <->_ ,base ,offset)))))
   ((extract form env :lvalues '(1 2)))))

(defun << (a b)
  (ash a b))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt print.lisp}}
\label{sec:print}

{\normalsize Defines a few very simple constructs for producing output.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

(defconstruct printword (val)
  `((rawprint 0)
    (rawprint ,val)))

(defconstruct println ()
  `((rawprint 1)))

(defconstruct rawprint (val)
  (cond
   ((register? val)
    `(output ,val))
   (t
    (extract form env))))

\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt controlflow.lisp}}
\label{sec:controlflow}

{\normalsize Defines user-level to intermediate-level control flow constructs such as
conditionals and looping.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;; ----------------------------------------------------------------------
;;; High-level control flow constructs suitable for user use.

;; if CONDEXPR then
;;    BODY...
;; [else BODY2...]
;;
;; CONDEXPR is evaluated; if result is nonzero body is executed.  In either
;; case, CONDEXPR is then evaluated in reverse.  The value should be the
;; same whether or not BODY was executed, or else behavior undefined.

;; NOTE 6/26/97: IF and all its subsidiary branching constructs need to be
;; completely cleaned up and reorganized.  One big thing is that code for
;; computing EXPR in a condition expression of a form like (EXPR > 0) needs
;; to be wrapped around the entire IF.  And things like (EXPR1 > EXPR2)
;; need to be transformed into ((EXPR1 - EXPR2) > 0).

(defconstruct if (condexpr then &body body)
  (cond
   ((member 'else body)
    (let ((ifpart (subseq body 0 (position 'else body)))
          (elsepart (subseq body (1+ (position 'else body)))))
      `(ifelse ,condexpr ,ifpart ,elsepart)))
   ((and (listp condexpr)
         (null (cdddr condexpr))
         (member (second condexpr) '(= != > <= < >=)))
    `(_if ,condexpr then . ,body))
   (t
    ;; The current version is appropriate only for testing an arbitrary
    ;; value to see if it is non-zero.  For other kinds of conditions,
    ;; other implementations would be more appropriate.
    (if (symbolp condexpr)
        `(_if (,condexpr != 0) then . ,body)
      (let ((tv (gentemp)))
        `(let (,tv <- ,condexpr)
           (_if (,tv != 0) then . ,body)))))))

;; for VAR = START to END
;;    BODY...
;;
;; Semantics: START and END are expressions.  They are each evaluated once
;; forwards at the beginning of the loop, and once in reverse at the end of
;; the loop.  They should return the same value both times.
;;
;; VAR is a fresh variable whose scope is the BODY.  It is set to START,
;; and then the BODY is executed.  If VAR is ever END after executing the
;; body, then the construct immediately terminates.  Otherwise, VAR is
;; incremented by 1 and the BODY is executed again.  START may be equal to
;; END, in which case the BODY is executed exactly once.  If the values of
;; START and END ever change during evaluation, or if BODY ever sets VAR to
;; START-1, the behavior of the entire program becomes undefined.

(defconstruct for (var = start wordto end &body body)
  (let ((top (gentemp "_FORTOP"))       ;Loop entry point.
        (bot (gentemp "_FORBOT"))       ;Bottom of loop.
        (stvar (gentemp "_FORSTART"))
        (endvar (gentemp "_FOREND")))   ;Loop boundary values.
    `(let (,stvar <- ,start)
          (let (,endvar <- (,end + 1))
               (scope ,var
                      (,var <- ,stvar)
                      ;; The loop itself.
                      (bcs-branch-pair ,top (,var != ,stvar)
                                       ,bot (,var != ,endvar)
                        ,@body
                        (,var ++))
                      (,var -> ,endvar))))))

;;;----------------------------------------------------------------------
;;; Medium-level control flow constructs not intended
;;; for direct user use.

;; InfLoop: Unconditional branch from bottom of body back to top.
;; Also, if we hit it from outside we jump over it.
(defconstruct infloop (&body body)
  `(twin-us-branch ,(gentemp "_LOOPTOP") ,(gentemp "_LOOPBOT")
                   . ,body))

(setf (get '=  'opposite) '!=
      (get '!= 'opposite) '=
      (get '>  'opposite) '<=
      (get '<= 'opposite) '>
      (get '<  'opposite) '>=
      (get '>= 'opposite) '<
      )

;;; _if (VAR ~ VAL) then BODY
(defconstruct _if ((reg1 ~ reg2) then &body body)
  (let ((l1 (gentemp "_IFTOP"))
        (l2 (gentemp "_IFBOT")))
    `(twin-bcs-branch (,reg1 ,(opposite ~) ,reg2) ,l1 ,l2
        ;; The body sure better not change whether var=0.
        ,@body)))

(defconstruct _ifelse ((reg1 ~ reg2) ifstuff elsestuff)
  (let ((iftop (gentemp "_IFTOP"))
        (ifbot (gentemp "_IFBOT"))
        (elsetop (gentemp "_ELSETOP"))
        (elsetop (gentemp "_ELSEBOT")))
    `((bcs-branch (,reg1 ,(opposite ~) ,reg2) ,iftop ,elsetop)
      (ensure-green . ,ifstuff)
      (sbra ,ifbot ,elsebot)
      (sbra ,elsetop ,iftop)
      (ensure-green . ,elsestuff)
      (bcs-branch (,reg1 ,~ ,reg2) ,elsebot ,ifbot))
    ))
      \end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt subroutines.lisp}}
\label{sec:subroutines}

{\normalsize Provides high and low level support for subroutines.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;;----------------------------------------------------------------------
;;; Subroutine calling support.
;;;----------------------------------------------------------------------

;;;----------------------------------------------------------------------
;;; User-level constructs.

;; Defsub: Implements subroutine entry/return conventions.
(defconstruct defsub (subname arglist &body body)
  (let ((bodyenv (entryenv arglist env)))
  ;; We wrap it in a branch pair so that if we encounter it from the
  ;; outside we jump over it, and if it runs off its end it comes back to
  ;; the beginning.  This latter behavior facilitates calling a subroutine
  ;; with a single switching-branch to its entry/exit point.
  `((twin-us-branch ,(gentemp "_SUBTOP") ,(gentemp "_SUBBOT")           
      ;; At start and end of body, environment is as according
      ;; to subroutine calling convention.
      (declare-environment ,bodyenv)
      (portal ,subname) ;Entry/exit point.
      ,@body
      (environment ,bodyenv)))))

;;;----------------------------------------------------------------------
;;; Subroutine calling convention support.

;; NOTE: Currently this does not work right for more than 29 arguments
;; (i.e. when some args need to go on the top of the stack instead of
;; in registers!).
(defconstruct call (subname &rest actualargs)
  `(withargs ,actualargs
     (with-stack-top
        (gosub ,subname))))

(defconstruct rcall (subname &rest actualargs)
  `(withargs ,actualargs
     (with-stack-top
        (rgosub ,subname))))

(defconstruct with-stack-top (&body body)
  (let ((offset (top-of-stack env)))
    `(with-sp-adjustment ,offset
        . ,body)))

(defconstruct with-SP-adjustment (amt &body body)
  ;; AMT must be a literal number.
  `(((reg 1) += ,amt)
    ,@body
    ((reg 1) -= ,amt)))

;; Call a subroutine at a low level with no mention of arguments.
(defconstruct gosub (subname) :opposite rgosub
  ;; A switching branch to the SWAPBRN in the portal should do the trick.
  `(bra ,subname))

(defconstruct rgosub (subname) :opposite gosub
  `(rbra ,subname))

;; Portal: Entry/exit point of a subroutine.
(defconstruct portal (label)
  `((label ,label)
    ;; We always use register $2 for storing our subroutine offsets, by
    ;; convention.
    (swapbr (reg 2))  ;retvar<->BR
    (neg (reg 2))     ;retvar = -retvar
    ))

;;; WITHARGS below needs some work.  It currently can only prepare the 29
;;; arguments that we can fit into registers.  I was intending that if
;;; there are more arguments they should be passed on the stack.  This is
;;; not too hard, but I'm not sure it's worth it.

;; Prepare arguments in conventional locations as for a subroutine call.
(defconstruct withargs (actualargs &body body)
  (let ((result `((vacate (reg 2))
                  . ,body))
        (r 1))
    (dolist (a actualargs)
      (if (and (symbolp a) (not (static-id? a env)))
          (if (defined-in-env? a env)
              (push `(relocate ,a ,(argno-to-location r)) result)
            (setf result
                  `((new-var-at ,a ,(argno-to-location r))
                    ,@result
                    (remove-var ,a))))
        (setf result
              (let ((tv (gentemp)))
                `((new-var-at ,tv ,(argno-to-location r))
                  ;; This prevents evaluating A from causing
                  ;; earlier-placed registers to change their locations.
                  ;; 6/3/97- But ENSURE-GREEN really enforces more than
                  ;; just this, unfortunately.
                  (ensure-green
                   (,tv <- ,a))
                  ,@result
                  (,tv -> ,a)
                  ;;^-DANGER! Assumes subroutine didn't change value of A.
                  (remove-var ,tv)))))
      (incf r))
    result))
                       
;; On subroutine entry/exit, the environment contains:
;; A return-address variable located in register 2.
;; All the arguments in registers 3,4,... until we run out,
;; and then stack locations -1,-2,... (below top of stack).
;; If not all the registers were used for arguments, then
;; there is a variable for each unused one (above 2), used
;; to ensure that all these other registers are restored to
;; their original state upon exit.
(defun entryenv (arglist origenv)
  (let (locmap (r 0))
    (dolist (a (cons '_RET arglist))
      (push
       `(,a . ,(argno-to-location r))
       locmap)
      (incf r))
    (setf r (+ r 2))
    (if (<= r 31)
        (loop
         (push `(,(intern (concatenate 'string "_R" (princ-to-string r)))
                 reg ,r) locmap)
         (incf r)
         (if (> r 31) (return))))
    (setf locmap (reverse locmap))
    (let ((env (copy-environment origenv)))
      (labels
          ((is-arg? (name) (member name arglist)))
        (setf (locmap env) locmap
              (staticvals env) (remove-if #'is-arg? (staticvals env))
              (staticarrays env) (remove-if #'is-arg? (staticarrays env))))
      env)))

;; Convert an argument number (0 and up) to a location (reg <regno>)
;; or (stack <offset>).  Argument 0 is the return address.
(defun argno-to-location (argno)
  (if (<= argno 29)
      `(reg ,(+ argno 2))
    `(stack ,(- 29 argno))))

\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt staticdata.lisp}}
\label{sec:staticdata}

{\normalsize Defines constructs for defining static data objects.  Currently this is the
only way to provide input to a program.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;;----------------------------------------------------------------------
;;; Constructs for declaring static data.

;; Define NAME to refer to a static word of data in memory
;; of value VALUE.
(defconstruct defword (name value)
  `(skip
    (staticval ,name)
    (label ,name)
    (dataword ,value)))

(defconstruct defarray (name &rest elements)
  `(skip
    (staticarray ,name)
    (label ,name)
    . ,(mapcar #'(lambda (elem) `(dataword ,elem)) elements)))

;;;----------------------------------------------------------------------

;; VALUE is a word of data that should be included at
;; this point in the program in literal form.
(defconstruct dataword (value)
  `(data ,value))

(defconstruct staticval (name)
  (values nil (add-staticval name env)))

(defconstruct staticarray (name)
  (values nil (add-staticarray name env)))

;; If the flow of control gets to code surrounded by SKIP it will skip over
;; the contents without executing them.
(defconstruct skip (&body body)
  ;; Implemented by an unconditional branch pair around the body.
  `(sbra-pair ,(gentemp "_PRESKIP") ,(gentemp "_POSTSKIP")
             . ,body))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt program.lisp}}
\label{sec:program}

{\normalsize Defines very high-level constructs for wrapping
around the entire program.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;----------------------------------------------------------------------
;;; Highest-level constructs.

(defconstruct defmain (progname &body body)
  `(;; Always include the standard library of subroutines.
    (standard-library)
    ;; We surround the whole program with a branch pair because I don't
    ;; think that our current idea of START/FINISH boundary instructions
    ;; can be non-noops on the real machine without dissipation. This
    ;; also skips over main if control somehow comes down from above.
    (twin-us-branch _MAINTOP _MAINBOT
      ;; Execution starts and ends with exactly 0 dynamic variables.
      (with-location-map ,(empty-locmap)
        (declare-startpoint ,progname)
        ;; To begin execution, the PC should initally be set to this label.
        (label ,progname)
        (start)
        ,@body
        (finish)))))

;;----------------------------------------------------------------------

;; Defprog: a whole program with subroutines and a main routine.
;; Now deprecated in favor of defsub + defmain (6/26/97).
(defconstruct defprog (progname subs &body main)
  `(;; Always include the standard library of subroutines.
    (standard-library)
    ;; Include user subroutines.
    ,@subs
    ;; We surround the whole program with a branch pair because I don't
    ;; think that our current idea of START/FINISH boundary instructions
    ;; can be implemented without dissipation.
    (twin-us-branch _MAINTOP _MAINBOT
     ;; Execution starts and ends with exactly nothing in the environment.
     (with-location-map ,(empty-locmap)
       (declare-startpoint ,progname)
       ;; To begin execution, the PC should initally be set to this label.
       (label ,progname)
       (start)
       ,@main
       (finish)))))

;;----------------------------------------------------------------------

(defconstruct declare-startpoint (labname)
  `(.start ,labname))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt library.lisp}}
\label{sec:library}

{\normalsize Defines constructs that expand into code for
standard subroutine libraries.  Currently the library is very minimal.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

(defconstruct standard-library ()
  ;; List of standardly available subroutines.
  '((def-smf)))

;; Define the simplest normal integer multiplication function.
;; This adds the low word of the product of unsigned integers
;; M1 and M2 into PROD.

(defconstruct def-mult ()
  '(defsub mult (m1 m2 prod)
    ;; Use grade-school algorithm.
    (for pos = 0 to 31                  ; For each of the 32 bit-positions,
       (if (m1 & (1 << pos)) then       ;   if that bit of m1 is 1, then
         (prod += (m2 << pos))))))      ;     add m2, shifted over to that
                                        ;       position, into p.

;; Define the signed multiplication-by-fraction function, which takes
;; two signed integers M1 and M2, and adds the high word of their true
;; integer product into PROD.  This is like multiplying M1 by M2 when
;; M2 is considered to represent a fraction with numerator explicit and
;; denominator 2^31.
;;
;; This version of the function was tested in C and seemed to work
;; satisfactorily, although more testing is needed.  Need to compare
;; with upper bits of true (64-bit-wide) product. 6/26/97

(defconstruct def-smf ()
  '(defsub _smf (m1 m2 prod)
     (with-regvars (m1p m2p mask shifted bit p)
       (with ((mask <- 1)
              (m1p <- m1) (if (m1 < 0) then (- m1p))
              (m2p <- m2) (if (m2 < 0) then (- m2p)))
          (mask <=< 31)
          (for position = 1 to 31
             (mask >=> 1)
             (with (bit <- (m1p & mask))
                (if bit then
                  (with (shifted <- (m2p >> position))
                     (p += shifted)))))
          (if (m1 < 0) then (- p))
          (if (m2 < 0) then (- p))
          (prod += p)))))

\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt files.lisp}}
\label{sec:files}

{\normalsize Provides support for reading the source code to
compile from a file.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")

;;;----------------------------------------------------------------------
;;; File compilation code.

(defun rcompile-file (filename &key debug)
  (let (source)
    (with-open-file (stream filename)
       (loop
        (let ((next-form
               (read stream nil :eof)))
          (cond
           ((eq next-form :eof)
            (setf source (reverse source))
            (return))
           (t
            (push next-form source))))))
    (format t "~&Source:~%")
    (myprint source)
    (if debug
        (rcomp-debug source)
      (rc source))))
\end{verbatim}

\hrule\vspace{1pt}\hrule\vspace{1pt}\hrule
\subsection{{\tt test.lisp}}
\label{sec:test}

{\normalsize Miscellaneous functions and program fragments for exercising the compiler.
Some of these may be obsolete.}

\begin{verbatim}
;;; -*- Package: user -*-
(in-package "USER")
;;;----------------------------------------------------------------------
;;; Testing code.

(defun test-sch ()
  (rcompile-file "sch.r"))

(defun test-sch-debug ()
  (rcompile-file "sch.r" :debug t))

(defparameter *test*
  '(defprog example1
     ()
     (let p = (3 * 5))))

(defparameter *test2*
  '(defprog example-program-2 ()
     (call mult 3 5 p)))

(defun test ()
  (rc *test*))

;; My original very simple MULT routine.
(defparameter *mult-orig*
  '(defsub mult (m1 m2 prod)
      ;; Use grade-school algorithm.
      (for pos = 0 to 31               ; For each of the 32 bit-positions,
         (if (m1 & (1 << pos)) then    ;   if that bit of m1 is 1, then
            (prod += (m2 << pos))))))  ;     add m2, shifted over to that
                                       ;       position, into p.

;; I'd like this code to compile to produce exactly my hand-compiled-
;; and -optimized version of the MULT routine.  Currently, it won't though.
(defparameter *mult-opt*
  '(defsub mult-opt (m1 m2 product)
     (with-register-vars ((limit = 32) (mask = 1) shifted bit position)
        (for position = 0 until limit
           (with (bit <- (m1 & mask))
              (if bit then
                 (with (shifted <- (m2 << position))
                    (product += shifted))))
           (mask <=< 1))))
  )

;; Hand-compiled, optimized multiply routine.  We could actually
;; include this in programs if we want.
(defparameter *mult-hand*
  '(alloctop
    (bra   allocbot)
    alloc4
    (swbrn $2)     ; This sub-subroutine frees
    (addi  $1  +1) ; 4 registers for use in the
    (exch  $31 $1) ; MULT subroutine.  It leaves
    (addi  $1  +1) ; the stack pointer pushed
    (exch  $30 $1) ; above, but we don't mind.
    (addi  $1  +1)
    (exch  $29 $1)
    (addi  $1  +1)
    (exch  $28 $1)
    allocbot
    (bra   alloctop)
    ;; This subroutine's arguments are in registers $3, $4, and $5.
    subtop
    (bra   subbot)              ; MULT top.
    mult
    (swbrn $2)                  ; Subroutine entry/exit point.
    (exch  $2 $1)               ; Push return address.
    (bra   alloc4)              ; Allocate 4 registers ($28-$31).
    (addi  $31 32)              ; limit <- 32
    (addi  $2 1)                ; mask <- 1
    fortop
    (bne   $30 $0 forbot)       ; unless (position != 0) do
    (andx  $28 $3 $2)           ;     bit <- m1&mask
    iftop
    (beq   $28 $0 ifbot)        ;     if (bit != 0) then
    (sllvx $29 $4 $30)          ;        shifted <- m2<<position
    (add   $5 $29)              ;        product += shifted
    (sllvx $29 $4 $30)          ;        shifted -> m2<<position
    ifbot
    (beq   $28 $0 iftop)        ;     end if
    (andx  $28 $3 $2)           ;     bit -> m1&mask
    (rl    $2 1)                ;     mask <=< 1 (rotate left by 1)
    (addi  $30 +1)              ;     i++
    forbot
    (bne   $30 $31 fortop)      ; and repeat while (position != limit).
    (sub   $30 $31)             ; position -> limit
    (addi  $2 -1)               ; mask -> 1
    (addi  $31 -32)             ; limit -> 32
    (rbra  alloc4)              ; Deallocate 4 registers ($28-$31).
    (exch  $2 $1)               ; Pop return address.
    subbot
    (bra   subtop)              ; MULT bottom.
    ))

(defparameter *mult-frac*
  ;; Like mult, but interprets the multiplier (1st arg) to be a
  ;; number between 1 and -1, on a scale where 2^31 = 1, -2^31 = -1.
  '(defsub mult-frac (m1 m2 prod)
      (for pos = 0 to 31
         (if (m1 & (1 << pos)) then
            (prod += (m2 >> (31 - pos)))))))

;;; Interesting question: does MULT-FRAC yield the same result
;;; independently of the order of m1 and m2?  I know the original
;;; MULT did.  I think it does.

;; This optimized version the same number of instructions as mult-opt.
;; Put this in the standard library?
(defparameter *mult-frac-opt*
  '(defsub mult-frac-opt (m1 m2 product)
     (with-registers ((limit = 32) (mask = 1) shifted bit position)
        (for position = 0 until limit
           (mask >=> 1)
           (with (bit <- (m1 & mask))
              (if bit then
                 (with (shifted <- (m2 >> position))
                    (product += shifted))))
           )))
  )

;;; Now, what to do if integers are signed?
;;; What to do: for actual multiplication, only look at bits
;;; 30-0 of multiplier.  Branch on bit 31.  If 1, then
;;; subtract shifted multiplicand from product instead of
;;; adding it.

(defparameter *signed-mult-frac-opt*
  '(defsub signed-mult-frac-opt (m1 m2 product)
     (with-registers ((limit = 32) mask shifted bit position)
        (mask <- (1 << 31))
        (for position = 1 until limit
           (mask >=> 1)
           (with (bit = (m1 & mask))
              (if bit then
                 (with (shifted = (m2 >> position))
                    (if (m2 > 0)
                        (product += shifted)
                      else
                        (product -= shifted))))))
        (mask -> 1))))


;; This will be the first version of SIGNED-MULT-FRAC to actually
;; be compilable. (NOT. -6/26)
(defparameter *smf-first*
  '(defsub smf-first (m1 m2 prod)
     (with-regvars (mask shifted bit)
       (with (mask <- 1)
          (mask <=< 31)
          (for position = 1 to 31
             (mask >=> 1)               ;Rotate right by 1 bit
             (with (bit <- (m1 & mask))
                (if bit then
                  (with (shifted <- (m2 >> position))
                     (if (m2 > 0)
                         (prod += shifted)
                       else
                         (prod -= shifted))))))))))

;; OK, now THIS version is the new target. 6/26
(defparameter *smf-new*
  '(defsub smf-new (m1 m2 prod)
     (with-regvars (m1p m2p mask shifted bit p)
       (with ((mask <- 1)
              (m1p <- m1) (if (m1 < 0) then (- m1p))
              (m2p <- m2) (if (m2 < 0) then (- m2p)))
          (mask <=< 31)
          (for position = 1 to 31
             (mask >=> 1)               ;Rotate right by 1 bit
             (with (bit <- (m1 & mask))
                (if bit then
                  (with (shifted <- (m2 >> position))
                     (p += shifted)))))
          (if (m1 < 0) then (- p))
          (if (m2 < 0) then (- p))
          (prod += p)))))
  
;;; Stuff for Schroedinger program.
;; Point function.
(defparameter *pfunc*
  '(defsub pfunc (dest src i alphas epsilon)
      ((dest _ i) += (((alphas _ i) << 1) */ (src _ i)))
      ((dest _ i) -= (epsilon */ (src _ ((i + 1) & 127))))
      ((dest _ i) -= (epsilon */ (src _ ((i - 1) & 127)))))
  )

;; Wavefunction step.
(defparameter *schstep*
  '(defsub schstep (psiR psiI alphas epsilon)
      (for i = 0 until 128              ;For each point i,
         (call pfunc psiR psiI i))      ; psiR[i] += func(psiI,i)
      (for i = 0 until 128              ;For each point i,
         (rcall pfunc psiI psiR i)))    ; psiI[i] -= func(psiR,i)
  )

;; Data for the schroedinger simulation:
;; Epsilon, alphas, and psis.
(defparameter *schdata*
  '((array epsilon 203667001)
    (array alphas
           458243442 456664951 455111319 453582544 452078627 450599569
           449145369 447716027 446311542 444931917 443577149 442247239
           440942188 439661994 438406659 437176182 435970563 434789802
           433633899 432502854 431396668 430315339 429258869 428227257
           427220503 426238607 425281569 424349389 423442068 422559605
           421701999 420869252 420061363 419278332 418520159 417786845
           417078388 416394790 415736049 415102167 414493143 413908977
           413349669 412815220 412305628 411820895 411361019 410926002
           410515843 410130542 409770099 409434515 409123788 408837920
           408576909 408340757 408129463 407943027 407781450 407644730
           407532868 407445865 407383720 407346432 407334003 407346432
           407383720 407445865 407532868 407644730 407781450 407943027
           408129463 408340757 408576909 408837920 409123788 409434515
           409770099 410130542 410515843 410926002 411361019 411820895
           412305628 412815220 413349669 413908977 414493143 415102167
           415736049 416394790 417078388 417786845 418520159 419278332
           420061363 420869252 421701999 422559605 423442068 424349389
           425281569 426238607 427220503 428227257 429258869 430315339
           431396668 432502854 433633899 434789802 435970563 437176182
           438406659 439661994 440942188 442247239 443577149 444931917
           446311542 447716027 449145369 450599569 452078627 453582544
           455111319 456664951)
    ;; This is the shape of the initial wavefunction.
    (array psis
           2072809 3044772 4418237 6333469 8968770 12546502 17338479
           23669980 31921503 42527251 55969298 72766411 93456735 118573819
           148615999 184009768 225068513 271948808 324607187 382760978
           445857149 513053161 583213481 654924586 726530060 796185813
           861933650 921789572 973841548 1016350163 1047844835 1067208183
           1073741824 1067208183 1047844835 1016350163 973841548 921789572
           861933650 796185813 726530060 654924586 583213481 513053161
           445857149 382760978 324607187 271948808 225068513 184009768
           148615999 118573819 93456735 72766411 55969298 42527251 31921503
           23669980 17338479 12546502 8968770 6333469 4418237 3044772
           2072809 1393998 926112 607804 394060 252382 159681 99804 61622
           37586 22647 13480 7926 4604 2642 1497 838 463 253 136 73 38 20
           10 5 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
           0 0 0 0 0 0 0 0 0))
  )


(defparameter *sch*
  '((DEFWORD EPSILON 203667001)
    (DEFARRAY ALPHAS 458243442 456664951 455111319 453582544
      452078627 450599569 449145369 447716027 446311542 444931917
      443577149 442247239 440942188 439661994 438406659 437176182
      435970563 434789802 433633899 432502854 431396668 430315339
      429258869 428227257 427220503 426238607 425281569 424349389
      423442068 422559605 421701999 420869252 420061363 419278332
      418520159 417786845 417078388 416394790 415736049 415102167
      414493143 413908977 413349669 412815220 412305628 411820895
      411361019 410926002 410515843 410130542 409770099 409434515
      409123788 408837920 408576909 408340757 408129463 407943027
      407781450 407644730 407532868 407445865 407383720 407346432
      407334003 407346432 407383720 407445865 407532868 407644730
      407781450 407943027 408129463 408340757 408576909 408837920
      409123788 409434515 409770099 410130542 410515843 410926002
      411361019 411820895 412305628 412815220 413349669 413908977
      414493143 415102167 415736049 416394790 417078388 417786845
      418520159 419278332 420061363 420869252 421701999 422559605
      423442068 424349389 425281569 426238607 427220503 428227257
      429258869 430315339 431396668 432502854 433633899 434789802
      435970563 437176182 438406659 439661994 440942188 442247239
      443577149 444931917 446311542 447716027 449145369 450599569
      452078627 453582544 455111319 456664951)
    (DEFARRAY PSIR 2072809 3044772 4418237 6333469 8968770 12546502
      17338479 23669980 31921503 42527251 55969298 72766411 93456735
      118573819 148615999 184009768 225068513 271948808 324607187
      382760978 445857149 513053161 583213481 654924586 726530060
      796185813 861933650 921789572 973841548 1016350163 1047844835
      1067208183 1073741824 1067208183 1047844835 1016350163
      973841548 921789572 861933650 796185813 726530060 654924586
      583213481 513053161 445857149 382760978 324607187 271948808
      225068513 184009768 148615999 118573819 93456735 72766411
      55969298 42527251 31921503 23669980 17338479 12546502 8968770
      6333469 4418237 3044772 2072809 1393998 926112 607804 394060
      252382 159681 99804 61622 37586 22647 13480 7926 4604 2642
      1497 838 463 253 136 73 38 20 10 5 2 1 0 0 0 0 0 0 0 0 0 0 0 0
      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (DEFARRAY PSII 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      0 0 0 0 0 0 0 0 0 0 0)
    (DEFSUB PFUNC (DEST SRC I ALPHAS EPSILON)
      ((DEST _ I) += ((ALPHAS _ I) */ (SRC _ I)))
      ((DEST _ I) -= (EPSILON */ (SRC _ ((I + 1) & 127))))
      ((DEST _ I) -= (EPSILON */ (SRC _ ((I - 1) & 127)))))
    (DEFSUB SCHSTEP (PSIR PSII ALPHAS EPSILON)
      (FOR I = 0 TO 127 (CALL PFUNC PSIR PSII I))
      (FOR I = 0 TO 127 (RCALL PFUNC PSII PSIR I)))
    (DEFSUB PRINTWAVE (WAVE)
      (FOR I = 0 TO 127 (PRINTWORD (WAVE _ I))) (PRINTLN))
    (DEFMAIN SCHROED
      (FOR I = 1 TO 50
           (FOR J = 1 TO 20 (CALL SCHSTEP PSIR PSII ALPHAS EPSILON))
           (CALL PRINTWAVE PSIR) (CALL PRINTWAVE PSII)))))

(defparameter *sch-frag1*
  '((DEFWORD EPSILON 203667001)
    (DEFARRAY ALPHAS 458243442 456664951)
    (DEFARRAY PSIR 2072809 3044772)
    (DEFARRAY PSII 0 0)
    (DEFSUB PFUNC (DEST SRC I ALPHAS EPSILON)
      ((DEST _ I) += ((ALPHAS _ I) */ (SRC _ I)))
      ((DEST _ I) -= (EPSILON */ (SRC _ ((I + 1) & 127))))
      ((DEST _ I) -= (EPSILON */ (SRC _ ((I - 1) & 127)))))
    (DEFSUB SCHSTEP (PSIR PSII ALPHAS EPSILON)
      (FOR I = 0 TO 127 (CALL PFUNC PSIR PSII I))
      (FOR I = 0 TO 127 (RCALL PFUNC PSII PSIR I)))
    (DEFSUB PRINTWAVE (WAVE)
      (FOR I = 0 TO 127 (PRINTWORD (WAVE _ I))) (PRINTLN))
    (DEFMAIN SCHROED
      (FOR I = 1 TO 50
           (FOR J = 1 TO 20 (CALL SCHSTEP PSIR PSII ALPHAS EPSILON))
           (CALL PRINTWAVE PSIR) (CALL PRINTWAVE PSII)))))

(defparameter *sch-frag2*
  '((DEFWORD EPSILON 203667001)
    (DEFARRAY ALPHAS 458243442)
    (DEFARRAY PSIR 2072809)
    (DEFARRAY PSII 0)
    (CALL SCHSTEP PSIR PSII ALPHAS EPSILON)))

(defparameter *sch-frag3*
  '((DEFWORD EPSILON 203667001)
    (DEFARRAY ALPHAS 458243442)
    (CALL SCHSTEP ALPHAS EPSILON)))
\end{verbatim}
}

% End chapter.
\cleardoublepage

