#!/bin/sh
echo 'Start of kamin, part 05 of 06:'
echo 'x - chap2.cc'
sed 's/^X//' > chap2.cc << '/'
X# include <std.h>
X
X# include "list.h"
X# include "environment.h"
X# include "lisp.h"
X
Xextern ReaderClass * reader;
X
Xextern Env globalEnvironment;
Xextern Env commands;
Xextern Env valueOps;
Xextern List emptyList;
X
Xextern Expr true;
Xextern Expr false;
X
Xint isTrue(Expression * cond)
X{
X	// the only thing false is nil
X	ListNode *nval = cond->isList();
X	if (nval && nval->isNil())
X		return 0;
X	return 1;
X}
X
Xinitialize()
X{
X
X	// create the reader/parser 
X	reader = new LispReader;
X
X	// initialize the global environment
X	Symbol * truesym = new Symbol("T");
X	true = truesym;
X	false = emptyList();
X	Environment * genv = globalEnvironment;
X	// make T evaluate to T always
X	genv->add(truesym, truesym);
X	genv->add(new Symbol("nil"), emptyList());
X
X	// initialize the commands environment
X	Environment * cmds = commands;
X	cmds->add(new Symbol("define"), new DefineStatement);
X
X	// initialize the value-ops environment
X	Environment * vo = valueOps;
X	vo->add(new Symbol("if"), new IfStatement);
X	vo->add(new Symbol("while"), new WhileStatement);
X	vo->add(new Symbol("set"), new SetStatement);
X	vo->add(new Symbol("begin"), new BeginStatement);
X	vo->add(new Symbol("+"), new IntegerBinaryFunction(PlusFunction));
X	vo->add(new Symbol("-"), new IntegerBinaryFunction(MinusFunction));
X	vo->add(new Symbol("*"), new IntegerBinaryFunction(TimesFunction));
X	vo->add(new Symbol("/"), new IntegerBinaryFunction(DivideFunction));
X	vo->add(new Symbol("="), new BinaryFunction(EqualFunction));
X	vo->add(new Symbol("<"), new BooleanBinaryFunction(LessThanFunction));
X	vo->add(new Symbol(">"), new BooleanBinaryFunction(GreaterThanFunction));
X	vo->add(new Symbol("cons"), new BinaryFunction(ConsFunction));
X	vo->add(new Symbol("car"), new UnaryFunction(CarFunction));
X	vo->add(new Symbol("cdr"), new UnaryFunction(CdrFunction));
X	vo->add(new Symbol("number?"), new BooleanUnary(NumberpFunction));
X	vo->add(new Symbol("symbol?"), new BooleanUnary(SymbolpFunction));
X	vo->add(new Symbol("list?"), new BooleanUnary(ListpFunction));
X	vo->add(new Symbol("null?"), new BooleanUnary(NullpFunction));
X	vo->add(new Symbol("print"), new UnaryFunction(PrintFunction));
X}
/
echo 'x - chap4.cc'
sed 's/^X//' > chap4.cc << '/'
X# include "environment.h"
X# include "lisp.h"
X
Xextern ReaderClass * reader;
Xextern Env globalEnvironment;
Xextern Env commands;
Xextern Env valueOps;
Xextern List emptyList;
X
Xextern Expr true;
Xextern Expr false;
X
Xint isTrue(Expression * cond)
X{
X	// the only thing false is nil
X	ListNode *nval = cond->isList();
X	if (nval && nval->isNil())
X		return 0;
X	return 1;
X}
X
X
X//
X//	Lambda functions - 
X//
X
Xclass LambdaFunction : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xvoid LambdaFunction::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	if (args->length() != 2) {
X		target = error("lambda requires two arguments");
X		return;
X		}
X
X	ListNode * argNames = args->head()->isList();
X	if (! argNames) {
X		target = error("lambda requires list of argument names");
X		return;
X		}
X
X	target = new UserFunction(argNames, args->at(1), rho);
X}
X
Xinitialize()
X{
X
X	// initialize global variables
X	reader = new LispReader;
X
X	// initialize the value of true
X	Symbol * truesym = new Symbol("T");
X	true = truesym;
X	false = emptyList();
X
X	// initialize the command environment
X	// there are no command or value-ops as such in scheme
X
X	// initialize the global environment
X	Environment * ge = globalEnvironment;
X	ge->add(new Symbol("if"), new IfStatement);
X	ge->add(new Symbol("while"), new WhileStatement);
X	ge->add(new Symbol("set"), new SetStatement);
X	ge->add(new Symbol("begin"), new BeginStatement);
X	ge->add(new Symbol("+"), new IntegerBinaryFunction(PlusFunction));
X	ge->add(new Symbol("-"), new IntegerBinaryFunction(MinusFunction));
X	ge->add(new Symbol("*"), new IntegerBinaryFunction(TimesFunction));
X	ge->add(new Symbol("/"), new IntegerBinaryFunction(DivideFunction));
X	ge->add(new Symbol("="), new BinaryFunction(EqualFunction));
X	ge->add(new Symbol("<"), new BooleanBinaryFunction(LessThanFunction));
X	ge->add(new Symbol(">"), new BooleanBinaryFunction(GreaterThanFunction));
X	ge->add(new Symbol("cons"), new BinaryFunction(ConsFunction));
X	ge->add(new Symbol("car"), new UnaryFunction(CarFunction));
X	ge->add(new Symbol("cdr"), new UnaryFunction(CdrFunction));
X	ge->add(new Symbol("number?"), new BooleanUnary(NumberpFunction));
X	ge->add(new Symbol("symbol?"), new BooleanUnary(SymbolpFunction));
X	ge->add(new Symbol("list?"), new BooleanUnary(ListpFunction));
X	ge->add(new Symbol("null?"), new BooleanUnary(NullpFunction));
X	ge->add(new Symbol("primop?"), new BooleanUnary(PrimoppFunction));
X	ge->add(new Symbol("closure?"), new BooleanUnary(ClosurepFunction));
X	ge->add(new Symbol("print"), new UnaryFunction(PrintFunction));
X	ge->add(new Symbol("lambda"), new LambdaFunction);
X	ge->add(truesym, truesym);
X	ge->add(new Symbol("nil"), emptyList());
X}
X
/
echo 'x - chap4.tex'
sed 's/^X//' > chap4.tex << '/'
X\chapter{The Scheme Interpreter}
X
XAfter all the code required to generate the APL interpreter of Chapter 3,
Xthe Scheme interpreter is simplicity in itself.  Of course, this has more
Xto do with the similarity of Scheme to the basic Lisp interpreter of
XChapter 2 than with any differences between APL and Scheme.
X
XTo implement Scheme it is only necessary to provide an implementation of
Xthe lambda function.  This is accomplished by the class {\sf Lambda}, shown
Xin Figure~\ref{lambda}.  The actual implementation of lambda uses the same
Xclass UserFunction we have seen in previous chapters.
X
X\begin{figure}
X\begin{cprog}
Xclass LambdaFunction : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xvoid LambdaFunction::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	if (args->length() != 2) {
X		target = error("lambda requires two arguments");
X		return;
X		}
X
X	ListNode * argNames = args->head()->isList();
X	if (! argNames) {
X		target = error("lambda requires list of argument names");
X		return;
X		}
X
X	target = new UserFunction(argNames, args->at(1), rho);
X}
X\end{cprog}
X\caption{The class Lambda}\label{lambda}
X\end{figure}
X
XInitialization of the Scheme interpreter differs slightly from the code
Xused to initialize the Lisp interpreter (Figure~\ref{schemeinit}).  The 
X{\sf define} command is no longer recognized, having been replaced by the
X{\sf set}/{\sf lambda} pair.  The built-in arithmetic functions are now
Xconsidred to be global symbols, and not value-ops.  Indeed, there are no
Xcomands or value-ops in this language.
X
X\begin{figure}
X\begin{cprog}
Xinitialize()
X{
X
X	// initialize global variables
X	reader = new LispReader;
X
X	// initialize the value of true
X	Symbol * truesym = new Symbol("T");
X	true = truesym;
X	false = emptyList();
X
X	// initialize the command environment
X	// there are no command or value-ops as such in scheme
X
X	// initialize the global environment
X	Environment * ge = globalEnvironment;
X	ge->add(new Symbol("if"), new IfStatement);
X	ge->add(new Symbol("while"), new WhileStatement);
X	ge->add(new Symbol("set"), new SetStatement);
X	ge->add(new Symbol("begin"), new BeginStatement);
X	ge->add(new Symbol("+"), new IntegerBinaryFunction(PlusFunction));
X	ge->add(new Symbol("-"), new IntegerBinaryFunction(MinusFunction));
X	ge->add(new Symbol("*"), new IntegerBinaryFunction(TimesFunction));
X	ge->add(new Symbol("/"), new IntegerBinaryFunction(DivideFunction));
X	ge->add(new Symbol("="), new BinaryFunction(EqualFunction));
X	ge->add(new Symbol("<"), new BooleanBinaryFunction(LessThanFunction));
X	ge->add(new Symbol(">"), new BooleanBinaryFunction(GreaterThanFunction));
X	ge->add(new Symbol("cons"), new BinaryFunction(ConsFunction));
X	ge->add(new Symbol("car"), new UnaryFunction(CarFunction));
X	ge->add(new Symbol("cdr"), new UnaryFunction(CdrFunction));
X	ge->add(new Symbol("number?"), new BooleanUnary(NumberpFunction));
X	ge->add(new Symbol("symbol?"), new BooleanUnary(SymbolpFunction));
X	ge->add(new Symbol("list?"), new BooleanUnary(ListpFunction));
X	ge->add(new Symbol("null?"), new BooleanUnary(NullpFunction));
X	ge->add(new Symbol("primop?"), new BooleanUnary(PrimoppFunction));
X	ge->add(new Symbol("closure?"), new BooleanUnary(ClosurepFunction));
X	ge->add(new Symbol("print"), new UnaryFunction(PrintFunction));
X	ge->add(new Symbol("lambda"), new LambdaFunction);
X	ge->add(truesym, truesym);
X	ge->add(new Symbol("nil"), emptyList());
X}
X\end{cprog}
X\caption{Initialization of the Scheme Interpreter}\label{schemeinit}
X\end{figure}
X
/
echo 'x - chap5.cc'
sed 's/^X//' > chap5.cc << '/'
X# include <stdio.h>
X# include "lisp.h"
X# include "environment.h"
X
Xextern ReaderClass * reader;
Xextern Env globalEnvironment;
Xextern Env commands;
Xextern Env valueOps;
Xextern List emptyList;
Xextern Expr true;
Xextern Expr false;
X
Xint isTrue(Expression * cond)
X{
X	// the only thing false is nil
X	ListNode *nval = cond->isList();
X	if (nval && nval->isNil())
X		return 0;
X	return 1;
X}
X
X//
X//	Thunks are unevaluated expressions
X//
X
Xclass Thunk : public Expression {
Xprivate:
X	int evaluated;
X	Expr value;
X	Env context;
Xpublic:
X	Thunk(Expression *, Environment *);
X
X	virtual void free();
X	virtual void print();
X	virtual Expression * touch();
X	virtual void eval(Expr &, Environment *, Environment *);
X
X	virtual IntegerExpression * isInteger();
X	virtual Symbol * isSymbol();
X	virtual Function * isFunction();
X	virtual ListNode * isList();
X};
X
XThunk::Thunk(Expression * base, Environment *ctx) 
X{
X	evaluated = 0;
X	value = base;
X	context = ctx;
X}
X
Xvoid Thunk::free()
X{
X	context = 0;
X	value = 0;
X}
X
Xvoid Thunk::print()
X{
X	if (evaluated)
X		value()->print();
X	else
X		printf("...");
X}
X
XListNode * Thunk::isList()
X{
X	// if its evaluated try it out
X	if (evaluated) return value()->isList();
X
X	// else it's not
X	return 0;
X}
X
XSymbol * Thunk::isSymbol()
X{
X	if (evaluated) return value()->isSymbol();
X	return 0;
X}
X
XFunction * Thunk::isFunction()
X{
X	if (evaluated) return value()->isFunction();
X	return 0;
X}
X
XIntegerExpression * Thunk::isInteger()
X{
X	if (evaluated) return value()->isInteger();
X	return 0;
X}
X
XExpression * Thunk::touch()
X{
X	// if we haven't already evaluated, do it now
X	if (! evaluated) {
X		evaluated = 1;
X		Expression * start = value();
X		if (start)
X			start->eval(value, valueOps, context);
X		}
X	Expression * val = value();
X	if (val)
X		return val->touch();
X	return val;
X}
X
Xvoid Thunk::eval(Expr & target, Environment * valusops, Environment * rho)
X{
X	touch();
X	value()->eval(target, valusops, rho);
X}
X
X//
X//	Cons is changed to that it produces a pair of thunks 
X//	instead of evaluating its argument
X//		
X
Xclass SaslConsFunction : public Function {
Xpublic:
X	virtual void apply(Expr & target, ListNode * args, Environment *);
X};
X
Xvoid SaslConsFunction::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	// check length
X	if (args->length() != 2) {
X		target = error("cons requires two arguments");
X		return;
X		}
X
X	// make thunks for car and cdr
X	target = new ListNode(new Thunk(args->at(0), rho), 
X		new Thunk(args->at(1), rho));
X}
X
X//
X//	User functions now need not evaluate their arguments
X//
X
Xclass LazyFunction : public UserFunction {
Xpublic:
X	LazyFunction(ListNode * n, Expression * b, Environment * c)
X		: UserFunction(n, b, c) {}
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
X//	convert arguments into thunks
Xstatic ListNode * makeThunks(ListNode * args, Environment * rho)
X{
X	if ((! args) || (args->isNil()))
X		return emptyList;
X	Expression * newcar = new Thunk(args->head(), rho);
X	return new ListNode(newcar, makeThunks(args->tail(), rho));
X}
X
Xvoid LazyFunction::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	// number of args should match definition
X	ListNode * anames = argNames;
X	if (anames->length() != args->length()) {
X		error("argument length mismatch");
X		return;
X		}
X
X	// convert arguments into thunks
X	ListNode * newargs = makeThunks(args, rho);
X
X	// make new environment
X	Env newrho = new Environment(anames, newargs, context);
X
X	// evaluate body in new environment
X	if (body())
X		body()->eval(target, valueOps, newrho);
X	else
X		target = 0;
X
X	newrho = 0;
X}
X
X//
X//	Lambdas are redefined so as to produce lazy functions
X//
X
Xclass LambdaFunction : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xvoid LambdaFunction::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	if (args->length() != 2) {
X		target = error("lambda requires two arguments");
X		return;
X		}
X
X	ListNode * argNames = args->head()->isList();
X
X	if (! argNames) {
X		target = error("lambda requires list of argument names");
X		return;
X		}
X
X	target = new LazyFunction(argNames, args->at(1), rho);
X}
X
Xinitialize()
X{
X
X	// initialize global variables
X	reader = new LispReader;
X
X	// initialize the value of true
X	Symbol * truesym = new Symbol("T");
X	true = truesym;
X	false = emptyList();
X
X	// initialize the commands environment
X	Environment * cmds = commands;
X	cmds->add(new Symbol("set"), new SetStatement);
X
X	// initialize the global environment
X	Environment * ge = globalEnvironment;
X	ge->add(new Symbol("if"), new IfStatement);
X	ge->add(new Symbol("+"), new IntegerBinaryFunction(PlusFunction));
X	ge->add(new Symbol("-"), new IntegerBinaryFunction(MinusFunction));
X	ge->add(new Symbol("*"), new IntegerBinaryFunction(TimesFunction));
X	ge->add(new Symbol("/"), new IntegerBinaryFunction(DivideFunction));
X	ge->add(new Symbol("="), new BinaryFunction(EqualFunction));
X	ge->add(new Symbol("<"), new BooleanBinaryFunction(LessThanFunction));
X	ge->add(new Symbol(">"), new BooleanBinaryFunction(GreaterThanFunction));
X	ge->add(new Symbol("cons"), new SaslConsFunction);
X	ge->add(new Symbol("car"), new UnaryFunction(CarFunction));
X	ge->add(new Symbol("cdr"), new UnaryFunction(CdrFunction));
X	ge->add(new Symbol("number?"), new BooleanUnary(NumberpFunction));
X	ge->add(new Symbol("symbol?"), new BooleanUnary(SymbolpFunction));
X	ge->add(new Symbol("list?"), new BooleanUnary(ListpFunction));
X	ge->add(new Symbol("null?"), new BooleanUnary(NullpFunction));
X	ge->add(new Symbol("primop?"), new BooleanUnary(PrimoppFunction));
X	ge->add(new Symbol("closure?"), new BooleanUnary(ClosurepFunction));
X	ge->add(new Symbol("print"), new UnaryFunction(PrintFunction));
X	ge->add(new Symbol("lambda"), new LambdaFunction);
X	ge->add(truesym, truesym);
X	ge->add(new Symbol("nil"), emptyList());
X}
X
/
echo 'x - chap5.tex'
sed 's/^X//' > chap5.tex << '/'
X\chapter{The SASL interpreter}\label{sasl}
X
XThe SASL interpreter is largely constructed by removing features from the
XScheme interpreter, such as while loops and so on, and changing the 
Ximplementation of the {\sf cons} function to add delayed evaluation.
XFigure~\ref{saslhier} shows the class hierarchy for the classes added in
Xthis chapter.
X
X\setlength{\unitlength}{5mm}
X\begin{figure}
X\begin{picture}(25,10)(-4,-5)
X\put(-3.5,0){\sf Expression}
X\put(0,0.2){\line(1,0){1}}
X\put(1,0){\sf Function}
X\put(0,0.2){\line(1,-2){1}}
X\put(1,-2){\sf Thunk}
X\put(4,0.2){\line(1,-2){1}}
X\put(5,-2){\sf UserFunction}
X\put(9.5,-1.8){\line(1,0){1}}
X\put(10.5,-2){\sf LazyFunction}
X\put(4,0.2){\line(1,2){1}}
X\put(5,2){\sf SaslConsFunction}
X\put(4,0.2){\line(1,0){1}}
X\put(5,0){\sf LambdaFunction}
X\end{picture}
X\caption{Class Hierarchy for expressions in the SASL interpreter}\label{saslhier}
X\end{figure}
X
X\subsection{Thunks}
X
XDelayed evaluation is provided by adding a new expression type, called the
X{\em thunk}.  Figure~\ref{thunk} shows the data structure used to represent
Xthis type of value.  Every thunk maintains a boolean value indicating
Xwhether the thunk has been evaluated yet, an expression (representing
Xeither the unevaluated or evaluated expression, depending upon the state of
Xthe boolean flag), and a context in which the expression is to be
Xevaluated.  Thunks print either as three dots, if they have not yet been
Xevaluated, or as the printed representation of their value, if they have.
X
X\begin{figure}
X\begin{cprog}
Xclass Thunk : public Expression {
Xprivate:
X	int evaluated;
X	Expr value;
X	Env context;
Xpublic:
X	Thunk(Expression *, Environment *);
X
X	virtual void free();
X	virtual void print();
X	virtual Expression * touch();
X	virtual void eval(Expr &, Environment *, Environment *);
X
X	virtual IntegerExpression * isInteger();
X	virtual Symbol * isSymbol();
X	virtual Function * isFunction();
X	virtual ListNode * isList();
X};
X
Xvoid Thunk::print()
X{
X	if (evaluated)
X		value()->print();
X	else
X		printf("...");
X}
X
XExpression * Thunk::touch()
X{
X	// if we haven't already evaluated, do it now
X	if (! evaluated) {
X		evaluated = 1;
X		Expression * start = value();
X		if (start)
X			start->eval(value, valueOps, context);
X		}
X	Expression * val = value();
X	if (val)
X		return val->touch();
X	return val;
X}
X\end{cprog}
X\caption{Definition of Thunks}\label{thunk}
X\end{figure}
X
XHere we finally see an overridden definition for the method {\em touch}.
XYou will recall that this method was defined in Chapter 1, and that all
Xother expressions merely return their value as the result of this
Xexpression.  Thunks, on the other hand, will evaluate themselves if
Xtouched, and then return their new evaluated result.  With the addition of
Xthis feature many of the definitions we have presented in earlier chapters,
Xsuch as the definitions of {\sf car} and {\sf cdr}, hold equally well 
Xwhen given thunks as arguments.
X
XSince thunks can represent lists, symbols, integers and so on, the
Xpredicate methods {\sf isSymbol} and the like must be redefined as well.
XIf the thunk represents an evaluated value, these simply return the result
Xof testing that value (Figure~\ref{thunkpred}).
X
X\begin{figure}
X\begin{cprog}
Xvoid Thunk::eval(Expr & target, Environment * valusops, Environment * rho)
X{
X	touch();
X	value()->eval(target, valusops, rho);
X}
X
XListNode * Thunk::isList()
X{
X	// if its evaluated try it out
X	if (evaluated) return value()->isList();
X
X	// else it's not
X	return 0;
X}
X
XSymbol * Thunk::isSymbol()
X{
X	if (evaluated) return value()->isSymbol();
X	return 0;
X}
X
XFunction * Thunk::isFunction()
X{
X	if (evaluated) return value()->isFunction();
X	return 0;
X}
X
XIntegerExpression * Thunk::isInteger()
X{
X	if (evaluated) return value()->isInteger();
X	return 0;
X}
X\end{cprog}
X\caption{Thunk predicates}\label{thunkpred}
X\end{figure}
X
X\section{Lazy Cons}
X
XThe SASL cons function differs from the Scheme version in producing
Xa list node containing a pair of thunks, rather than a pair of values
X(Figure~\ref{saslcons}).  Class {\sf SaslConsFunction} must now be a
Xsubclass of {\sf Function} and not {\sf BinaryFunction}, because it must
Xgrab its arguments before they are evaluated.  Thus it must itself check to
Xsee that only two arguments are passed to the function.
X
X\begin{figure}
X\begin{cprog}
Xclass SaslConsFunction : public Function {
Xpublic:
X	virtual void apply(Expr & target, ListNode * args, Environment *);
X};
X
Xvoid SaslConsFunction::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	// check length
X	if (args->length() != 2) {
X		target = error("cons requires two arguments");
X		return;
X		}
X
X	// make thunks for car and cdr
X	target = new ListNode(new Thunk(args->at(0), rho), 
X		new Thunk(args->at(1), rho));
X}
X\end{cprog}
X\caption{The Sasl Lazy Cons function}\label{saslcons}
X\end{figure}
X
X\section{Lazy User Functions}
X
XUser defined functions must be provided with lazy evaluation semantics as
Xwell.  This is accomplished by defining a new class {\sf LazyFunction}
X(Figure~\ref{lazyfunction}).  Lazy functions act just like user functions
Xfrom previous chapters, only they do not evaluate their arguments.   Thus
Xthe function body is evaluated by the method {\sf apply}, rather than
Xpassing the evaluated arguments on to the method {\sf applyWithArgs}.
XThe lambda function from the previous chapter is modified to produce
Xan instance of {\sf LazyFunction}, rather than {\sf UserFunction}.
X
X\begin{figure}
X\begin{cprog}
Xclass LazyFunction : public UserFunction {
Xpublic:
X	LazyFunction(ListNode * n, Expression * b, Environment * c)
X		: UserFunction(n, b, c) {}
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
X//	convert arguments into thunks
Xstatic ListNode * makeThunks(ListNode * args, Environment * rho)
X{
X	if ((! args) || (args->isNil()))
X		return emptyList;
X	Expression * newcar = new Thunk(args->head(), rho);
X	return new ListNode(newcar, makeThunks(args->tail(), rho));
X}
X
Xvoid LazyFunction::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	// number of args should match definition
X	ListNode * anames = argNames;
X	if (anames->length() != args->length()) {
X		error("argument length mismatch");
X		return;
X		}
X
X	// convert arguments into thunks
X	ListNode * newargs = makeThunks(args, rho);
X
X	// make new environment
X	Env newrho = new Environment(anames, newargs, context);
X
X	// evaluate body in new environment
X	if (body())
X		body()->eval(target, valueOps, newrho);
X	else
X		target = 0;
X
X	newrho = 0;
X}
X\end{cprog}
X\caption{The implementation of lazy functions}\label{lazyfunction}
X\end{figure}
/
echo 'x - chap6.cc'
sed 's/^X//' > chap6.cc << '/'
X# include <std.h>
X# include "lisp.h"
X# include "environment.h"
X
Xextern ReaderClass * reader;
Xextern Env globalEnvironment;
Xextern Env commands;
Xextern Env valueOps;
Xextern List emptyList;
X
Xextern Expr true;
Xextern Expr false;
X
X//	isTrue reverts back to the old case where 0 is false and non-0 true
Xint isTrue(Expression * cond)
X{
X	IntegerExpression *ival = cond->isInteger();
X	if (ival && ival->val() == 0)
X		return 0;
X	return 1;
X}
X
X//
X//	a Cluster is a new statement type
X//		it also uses selector and modifier functions
X//
X
Xclass Cluster : public Expression {
Xprivate:
X	Env data;
Xpublic:
X	Cluster(ListNode * names, ListNode * values)
X		{ data = new Environment(names, values, 0); }
X	virtual void free()
X		{ data = 0; }
X	virtual void print()
X		{ printf("<userval>"); }
X	virtual Environment * isCluster()
X		{ return data; }
X};
X
Xclass Constructor : public Function {
Xprivate:
X	List names;
Xpublic:
X	Constructor(ListNode * n) 
X		{ names = n; }
X	virtual void free()
X		{ names = 0; }
X	virtual void applyWithArgs(Expr &, ListNode *, Environment *);
X};
X
Xvoid Constructor::applyWithArgs(Expr &target, ListNode *args, Environment *rho)
X{
X	ListNode * nmes = names;
X	if (args->length() != nmes->length()) {
X		target = error("wrong number of args passed to constructor");
X		return;
X		}
X	target = new Cluster(nmes, args);
X}
X
Xclass Selector : public UnaryFunction {
Xprivate:
X	Expr fieldName;
Xpublic:
X	Selector(Symbol * name) { fieldName = name; }
X	virtual void free() { fieldName = 0; }
X	virtual void applyWithArgs(Expr &, ListNode *, Environment *);
X};
X
Xvoid Selector::applyWithArgs(Expr & target, ListNode * args, Environment * rho)
X{
X	Environment * x = args->head()->isCluster();
X	if (! x) {
X		target = error("selector given non-cluster");
X		return;
X		}
X	Symbol *s = fieldName()->isSymbol();
X	if (!s)
X		error("impossible case in selector, no symbol");
X	target = x->lookup(s);
X	if (! target())
X		error("selector cannot find symbol:", s->chars());
X}
X
Xclass Modifier : public BinaryFunction {
Xprivate:
X	Expr fieldName;
Xpublic:
X	Modifier(Symbol * name) { fieldName = name; }
X	virtual void free() { fieldName = 0; }
X	virtual void applyWithArgs(Expr &, ListNode *, Environment *);
X};
X
Xvoid Modifier::applyWithArgs(Expr & target, ListNode * args, Environment * rho)
X{
X	Environment * x = args->head()->isCluster();
X	if (! x) {
X		target = error("selector given non-cluster");
X		return;
X		}
X
X	// set the result to the value
X	target = args->at(1);
X	x->set(fieldName()->isSymbol(), target());
X}
X
Xclass ClusterDef : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xstatic void catset(Environment * rho, Symbol * left, char * mid, 
X		Symbol * right, Expression * val)
X{	char buffer[120];
X
X	// catenate the two symbols
X	strcpy(buffer, left->chars());
X	strcat(buffer, mid);
X	strcat(buffer, right->chars());
X
X	// now put the new value into rho
X	rho->add(new Symbol(buffer), val);
X}
X
Xvoid ClusterDef::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	Expr setprefix = new Symbol("set-");
X
X	// must have at least name, rep and one def
X	if (args->length() < 3) {
X		target = error("cluster ill formed");
X		return;
X		}
X
X	// get name
X	Symbol * name = args->head()->isSymbol();
X	args = args->tail();
X	if (! name) {
X		target = error("cluster missing name");
X		return;
X		}
X
X	// now make the environment in which cluster will execute
X	Environment * inEnv = new Environment(emptyList, emptyList, rho);
X
X	// next part should be representation
X	ListNode * rep = args->head()->isList();
X	args = args->tail();
X	if (! rep) {
X		target = error("cluster missing rep");
X		return;
X		}
X	Symbol *s = rep->at(0)->isSymbol();
X	if (! (s && (*s == "rep"))) {
X		target = error("cluster missing rep");
X		return;
X		}
X	rep = rep->tail();
X
X	// make the name into a constructor with the representation
X	inEnv->add(name, new Constructor(rep));
X
X	// now run dow the rep list, making accessor functions
X	while (! rep->isNil()) {
X		s = rep->head()->isSymbol();
X		if (! s) {
X			target = error("ill formed rep in cluster");
X			return;
X			}
X		inEnv->add(s, new Selector(s));
X		catset(inEnv, setprefix()->isSymbol(), "",
X			s, new Modifier(s));
X		rep = rep->tail();
X		}
X	
X	// remainder should be define commands
X	while (! args->isNil()) {
X		ListNode * body = args->head()->isList();
X		if (! body) {
X			target = error("ill formed cluster");
X			return;
X			}
X		s = body->at(0)->isSymbol();
X		if (! (s && (*s == "define"))) {
X			target = error("missing define in cluster");
X			return;
X			}
X		s = body->at(1)->isSymbol();
X		if (! s) {
X			target = error("missing name in define");
X			return;
X			}
X
X		// evaluate body to define new function
X		Expr temp;
X		body->eval(temp, commands, inEnv);
X		// make outside form
X		catset(rho, name, "$", s, inEnv->lookup(s));
X		temp = 0;
X
X		// get next function
X		args = args->tail();
X		}
X
X	// what do we return?
X	target = 0;
X	setprefix = 0;
X}
X
Xinitialize()
X{
X	// initialize global variables
X	reader = new ReaderClass;
X	true = new IntegerExpression(1);
X	false = new IntegerExpression(0);
X
X	// initialize the statement environment
X	Environment * cmds = commands;
X	cmds->add(new Symbol("define"), new DefineStatement);
X	cmds->add(new Symbol("cluster"), new ClusterDef);
X
X	// initialize the value ops environment
X	Environment * vo = valueOps;
X	vo->add(new Symbol("if"), new IfStatement);
X	vo->add(new Symbol("while"), new WhileStatement);
X	vo->add(new Symbol("set"), new SetStatement);
X	vo->add(new Symbol("begin"), new BeginStatement);
X	vo->add(new Symbol("+"), new IntegerBinaryFunction(PlusFunction));
X	vo->add(new Symbol("-"), new IntegerBinaryFunction(MinusFunction));
X	vo->add(new Symbol("*"), new IntegerBinaryFunction(TimesFunction));
X	vo->add(new Symbol("/"), new IntegerBinaryFunction(DivideFunction));
X	vo->add(new Symbol("="), new BinaryFunction(EqualFunction));
X	vo->add(new Symbol("<"), new IntegerBinaryFunction(LessThanFunction));
X	vo->add(new Symbol(">"), new IntegerBinaryFunction(GreaterThanFunction));
X	vo->add(new Symbol("print"), new UnaryFunction(PrintFunction));
X}
/
echo 'x - environment.cc'
sed 's/^X//' > environment.cc << '/'
X# include <std.h>
X
X# include "environment.h"
X
X//
X//	Environment - an environment is built out of two parallel lists
X//
X
XEnvironment::Environment(ListNode* names, ListNode* values, Environment* link)
X{
X	theNames = names;
X	theValues = values;
X	theLink = link;
X}
X
Xvoid Environment::free()
X{
X	theNames = 0;
X	theValues = 0;
X	theLink = 0;
X}
X
XEnvironment * Environment::isEnvironment()
X{	
X	return this; 
X}
X
Xvoid Environment::set(Symbol * sym, Expression * value)
X{
X	ListNode * nameit = theNames;
X	ListNode * valueit = theValues;
X
X	while (! nameit->isNil()) {
X		if (*sym == nameit->head()) {
X			valueit->head(value);
X			return;
X			}
X		nameit = nameit->tail();
X		valueit = valueit->tail();
X		}
X
X	// otherwise see if we can find it on somebody elses list
X	Environment * link = theLink;
X	if (link) {
X		link->set(sym, value);
X		return;
X		}
X
X	// not found and we're the end of the line, just add
X	add(sym, value);
X}
X
XExpression * Environment::lookup(Symbol * sym)
X{
X	ListNode * nameit = theNames;
X	ListNode * valueit = theValues;
X
X	while (! nameit->isNil()) {
X		if (*sym == nameit->head())
X			return valueit->head();
X		nameit = nameit->tail();
X		valueit = valueit->tail();
X		}
X
X	// otherwise see if we can find it on somebody elses list
X	Environment * link = theLink;
X	if (link) return link->lookup(sym);
X
X	// not found, return nil value
X	return 0;
X}
X
Xvoid Environment::add(Symbol * s, Expression * v)
X{
X	theNames = new ListNode(s, (ListNode *) theNames);
X	theValues = new ListNode(v, (ListNode *) theValues);
X}
/
echo 'x - expression.cc'
sed 's/^X//' > expression.cc << '/'
X# include "expression.h"
X# include <std.h>
X
X//
X//	class Expr - expression holders
X//
X
XExpr::Expr(Expression * val)
X{
X	value = val;
X	if (val) value->referenceCount++;
X}
X
Xvoid Expr::operator = (Expression * newvalue)
X{
X	// increment right hand side of assignment
X	if (newvalue) {
X		newvalue->referenceCount++;
X		}
X
X	// decrement left hand side of assignment 
X	if (value) {
X		value->referenceCount--;
X		if (value->referenceCount = 0) {
X			value->free();
X			delete value;
X			}
X		}
X
X	// then do the assignment
X	value = newvalue;
X}
X
Xvoid Expr::evalAndPrint(Environment * valueops, Environment * rho)
X{
X	Expr target = 0;
X
X	// if we have a valid expression, evaluate it
X	if (value)
X		value->eval(target, valueops, rho);
X
X	// Now if we have an expression, print it out
X	if (target())
X		target()->print();
X	
X	// force memory management
X	target = 0;
X}
X
X# if 0
Xvoid Expr::print()
X{
X	if (value)
X		value->print();
X	printf("\n");
X}
X# endif
X
X//
X//	Expression - internal representation for expressions
X//
X
XExpression::Expression()
X{
X	referenceCount = 0;
X}
X
Xvoid Expression::free()
X{
X	// do nothing
X}
X
Xvoid Expression::eval(Expr & target, Environment * valueops, Environment * rho)
X{
X	// default is to do nothing
X	target = this;
X}
X
Xvoid Expression::print()
X{
X	fprintf(stderr,"in expression::print - should be subclassed\n");
X}
X
X// conversions
X
XExpression * Expression::touch() { return this; }
XIntegerExpression * Expression::isInteger() { return 0; }
XSymbol * Expression::isSymbol() { return 0; }
XListNode * Expression::isList() { return 0; }
XEnvironment * Expression::isEnvironment() { return 0; }
XFunction * Expression::isFunction() { return 0; }
XAPLValue * Expression::isAPLValue() { return 0; }
XMethod * Expression::isMethod() { return 0; }
XEnvironment * Expression::isCluster() { return 0; }
XPrologValue * Expression::isPrologValue() { return 0; }
XContinuation * Expression::isContinuation() { return 0; }
X
X//
X//	basic objects - integers and symbols
X//
X
X# include "environment.h"
X
X//
X//	integers
X//
X
Xvoid IntegerExpression::print()
X{
X	printf("%d", value);
X}
X
XIntegerExpression * IntegerExpression::isInteger()
X{
X	return this;
X}
X
X//
X//	symbols
X//
X
XSymbol::Symbol(char * t)
X{
X	// make a new copy of text
X	text = new char[strlen(t) + 1];
X	if (! text) {
X		error("allocation failure for symbol ", t);
X		exit(1);
X		}
X	strcpy(text, t);
X}
X
Xvoid Symbol::free()
X{
X	delete text;
X}
X
Xvoid Symbol::eval(Expr & target, Environment * valueops, Environment * rho)
X{
X	Expression * result = rho->lookup(this);
X	if (result)
X		result = result->touch();
X	else
X		result = error("evaluation of unknown symbol: ", text);
X	target = result;
X}
X
Xvoid Symbol::print()
X{
X	printf("%s", text);
X}
X
XSymbol * Symbol::isSymbol()
X{	return this; }
X
Xint Symbol::operator == (Expression *sym)
X{	
X	if (! sym) return 0;
X	Symbol * s = sym->isSymbol();
X	if (s)
X		return 0 == strcmp(text, s->text); 
X	return 0;
X}
X
Xint Symbol::operator == (char *t)
X{	
X	return 0 == strcmp(text, t); 
X}
/
echo 'x - expression.h'
sed 's/^X//' > expression.h << '/'
X# ifndef expressionh
X# define expressionh
X
X//	forward references
Xclass Environment;
Xclass Expression;
X
Xclass Expr {
Xprivate:
X	Expression * value;
X
Xprotected:
X	Expression * val()
X		{ return value; }
X
Xpublic:
X	Expr(Expression * = 0);
X
X	Expression * operator ()()
X		{ return val(); }
X
X	void operator = (Expression *);
X
X	void evalAndPrint(Environment *, Environment *);
X};
X
X// more forward declarations
Xclass IntegerExpression;
Xclass Symbol;
Xclass ListNode;
Xclass Function;
Xclass Environment;
Xclass APLValue;
Xclass Method;
Xclass PrologValue;
Xclass Continuation;
X
Xclass Expression {
Xprivate:
X	friend class Expr;
X	int referenceCount;
Xpublic:
X	Expression();
X
X	virtual void free();
X
X	// basic object protocol
X	virtual void eval(Expr &, Environment *, Environment *);
X	virtual void print();
X
X	// conversion tests
X	virtual Expression * touch();
X	virtual IntegerExpression * isInteger();
X	virtual Symbol * isSymbol();
X	virtual Function * isFunction();
X	virtual ListNode * isList();
X	virtual Environment * isEnvironment();
X	virtual APLValue * isAPLValue();
X	virtual Method * isMethod();
X	virtual Environment * isCluster();
X	virtual PrologValue * isPrologValue();
X	virtual Continuation * isContinuation();
X};
X
Xclass IntegerExpression : public Expression {
Xprivate:
X	int value;
Xpublic:
X	IntegerExpression(int v) 
X		{ value = v; }
X
X	virtual void print();
X	virtual IntegerExpression * isInteger();
X
X	int val()
X		{ return value; }
X};
X
Xclass Symbol : public Expression {
Xprivate:
X	char * text;
X
Xpublic:
X	Symbol(char *);
X
X	virtual void free();
X	virtual void eval(Expr &, Environment *, Environment *);
X	virtual void print();
X	virtual Symbol * isSymbol();
X
X	int operator == (Expression *);
X	int operator == (char *);
X	char * chars() { return text; }
X};
X
XExpression * error(char *, char * x = 0);
X
X# endif
/
echo 'x - foo.cc'
sed 's/^X//' > foo.cc << '/'
X# include <std.h>
X# include "environment.h"
X# include "intsym.h"
X# include "list.h"
X
XEnvironment * Environment::isEnvironment()
X{	return this; }
X
Xvoid Environment::add(Symbol *, Expression *)
X{
X	error("Environment::add should be subclassed");
X}
X
XExpression * Environment::lookup(Symbol *)
X{
X	return error("Environment::lookup should be subclassed");
X}
X
Xvoid Environment::set(Symbol *, Expression *)
X{
X	error("Environment::set should be subclassed");
X}
X
Xvoid Environment::print()
X{
X	error("Environment::print should be subclassed");
X}
X
X//
X//	Envlist - an environment built out of two parallel lists
X//
X
XEnvironment::Environment(ListNode * names, ListNode * values, Environment * link)
X{
X	theNames = names;
X	theValues = values;
X	theLink = link;
X}
X
Xvoid Environment::free()
X{
X	theNames = 0;
X	theValues = 0;
X	theLink = 0;
X}
X
Xvoid Environment::print()
X{
X	if (theNames()) theNames()->print(); printf("\n");
X	if (theValues()) theValues()->print(); printf("\n");
X	if (theLink()) theLink()->print();
X}
X
Xvoid Environment::set(Symbol * sym, Expression * value)
X{
X	ListNode * nameit = theNames();
X	ListNode * valueit = theValues();
X
X	while (! nameit->isNil()) {
X		if (sym->match(nameit->car()->isSymbol())) {
X			valueit->car(value);
X			return;
X			}
X		nameit = nameit->tail();
X		valueit = valueit->tail();
X		}
X
X	// otherwise see if we can find it on somebody elses list
X	if (theLink()) {
X		theLink()->set(sym, value);
X		return;
X		}
X
X	// not found and we're the end of the line, just add
X	add(sym, value);
X}
X
XExpression * Environment::lookup(Symbol * sym)
X{
X	ListNode * nameit = theNames();
X	ListNode * valueit = theValues();
X
X	while (! nameit->isNil()) {
X		if (sym->match(nameit->car()->isSymbol()))
X			return valueit->car();
X		nameit = nameit->tail();
X		valueit = valueit->tail();
X		}
X
X	// otherwise see if we can find it on somebody elses list
X	if (theLink()) return theLink()->lookup(sym);
X
X	// not found, return nil value
X	return 0;
X	
X}
X
Xvoid Environment::add(Symbol * s, Expression * v)
X{
X	theNames = new ListNode(s, theNames());
X	theValues = new ListNode(v, theValues());
X}
X
/
echo 'x - lisp.cc'
sed 's/^X//' > lisp.cc << '/'
X# include <std.h>
X# include "lisp.h"
X
Xextern Expr true;
Xextern Expr false;
Xextern Env valueOps;
X
X//
X//	The bodies of the common lisp stuff
X//
X
X//
X//	Quoted Constants
X//
X
Xvoid QuotedConst::free()
X{	theValue = 0; }
X
Xvoid QuotedConst::eval(Expr &target, Environment *, Environment *)
X{
X	target = theValue();
X}
X
Xvoid QuotedConst::print()
X{
X	printf("'"); theValue()->print();
X}
X
XExpression * LispReader::readExpression()
X{
X	// if quoted constant, return it,
X	if ((*p == '\'') || (*p == '`')) {
X		p++;
X		return new QuotedConst(readExpression());
X		}
X	// otherwise simply return what we had before
X	return ReaderClass::readExpression();
X}
X
X//
X//	the Arithmetic functions
X//
X
Xint PlusFunction(int a, int b) { return a + b; }
Xint MinusFunction(int a, int b) { return a - b; }
Xint TimesFunction(int a, int b) { return a * b; }
Xint DivideFunction(int a, int b)
X{
X	if (b != 0)
X		return a / b;
X	error("division by zero");
X	return 0;
X}
X
X//
X//	Relational functions
X//
X
Xvoid EqualFunction(Expr & target, Expression * one, Expression * two)
X{
X
X	// true if both numbers and same number
X	IntegerExpression * ione = one->isInteger();
X	IntegerExpression * itwo = two->isInteger();
X	if (ione && itwo && (ione->val() == itwo->val())) {
X		target = true();
X		return;
X		}
X
X	// or both symbols and same symbol
X	Symbol * sone = one->isSymbol();
X	Symbol * stwo = two->isSymbol();
X	if (sone && stwo && (*sone == stwo)) {
X		target = true();
X		return;
X		}
X
X	// or both lists and both nil
X	ListNode * lone = one->isList();
X	ListNode * ltwo = two->isList();
X	if (lone && ltwo && lone->isNil() && ltwo->isNil()) {
X		target = true();
X		return;
X		}
X
X	// false otherwise
X	target = false();
X}
X
Xint IntEqualFunction(int a, int b) { return a == b; }
Xint LessThanFunction(int a, int b) { return a < b; }
Xint GreaterThanFunction(int a, int b) { return a > b; }
X
X//
X//	Car and Cdr
X//
X
Xvoid CarFunction(Expr & target, Expression * arg)
X{
X	ListNode * thelist = arg->isList();
X	if (! thelist) {
X		target = error("car applied to non list");
X		return;
X		}
X	target = thelist->head()->touch();
X}
X
Xvoid CdrFunction(Expr & target, Expression * arg)
X{
X	ListNode * thelist = arg->isList();
X	if (! thelist) {
X		target = error("car applied to non list");
X		return;
X		}
X	target = thelist->tail()->touch();
X}
X
Xvoid ConsFunction(Expr & target, Expression * left, Expression * right)
X{
X	target = new ListNode(left, right);
X}
X
X//
X//	predicates
X//
X
Xvoid BooleanUnary::applyWithArgs(Expr & target, ListNode * args, Environment *)
X{
X	if (fun(args->head()))
X		target = true();
X	else
X		target = false();
X}
X
Xint NumberpFunction(Expression * arg)
X{
X	return 0 != arg->isInteger();
X}
X
Xint SymbolpFunction(Expression * arg)
X{
X	return 0 != arg->isSymbol();
X}
X
Xint ListpFunction(Expression * arg)
X{
X	ListNode * x = arg->isList();
X	// list? doesn't return true on nil
X	if (x && x->isNil()) return 0;
X	if (x) return 1;
X	return 0;
X}
X
Xint NullpFunction(Expression * arg)
X{
X	ListNode * x = arg->isList();
X	return x && x->isNil();
X}
X
Xint PrimoppFunction(Expression * arg)
X{
X	Function * funValue = arg->isFunction();
X	if (funValue)	// if not closure then primitive
X		if (funValue->isClosure())
X			return 0;
X		return 1;
X	return 0;
X}
X
Xint ClosurepFunction(Expression * arg)
X{
X	Function * funValue = arg->isFunction();
X	if (funValue)
X		if (funValue->isClosure())
X			return 1;
X	return 0;
X}
X
Xvoid PrintFunction(Expr & target, Expression * arg)
X{	
X	target = arg; 
X	if (target()) target()->print(); 
X	printf("\n");
X}
X
X//
X//	commands
X//
X
Xvoid DefineStatement::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	if (args->length() != 3) {
X		target = error("define requires three arguments");
X		return;
X		}
X	Symbol * name = args->at(0)->isSymbol();
X	if (! name) {
X		target = error("define missing name");
X		return;
X		}
X
X	ListNode * argNames = args->at(1)->isList();
X	if (! argNames) {
X		target = error("define missing arg names");
X		return;
X		}
X
X	rho->add(name, new UserFunction(argNames, args->at(2), rho));
X
X	// yield as value the name of the function
X	target = name;
X};
X
X
Xextern int isTrue(Expression *);
X
Xvoid IfStatement::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	if (args->length() != 3) {
X		target = error("if statement requires three arguments");
X		return;
X		}
X
X	Expr cond;
X	args->head()->eval(cond, valueOps, rho);
X	if (isTrue(cond()))
X		args->at(1)->eval(target, valueOps, rho);
X	else
X		args->at(2)->eval(target, valueOps, rho);
X	cond = 0;
X}
X
Xvoid WhileStatement::apply(Expr & target, ListNode * args, Environment * rho)
X{	Expr stmt;
X
X	if (args->length() != 2) {
X		target = error("while statement requires two arguments");
X		return;
X		}
X
X	// grab the two pieces of the statement
X	Expression * condexp = args->at(0);
X	Expression * stexp = args->at(1);
X
X	// then start the execution loop
X	condexp->eval(target, valueOps, rho);
X	while (isTrue(target())) {
X		// evaluate body
X		stexp->eval(stmt, valueOps, rho);
X		// but ignore it
X		stmt = 0;
X		// then reevaluate condition
X		condexp->eval(target, valueOps, rho);
X		}
X}
X
Xvoid SetStatement::apply(Expr & target, ListNode * args, Environment * rho)
X{
X	if (args->length() != 2) {
X		target = error("set statement requires two arguments");
X		return;
X		}
X
X	// get the two parts
X	Symbol * sym = args->at(0)->isSymbol();
X	if (! sym) {
X		target = error("set commands requires symbol for first arg");
X		return;
X		}
X
X	// set target to value of second argument
X	args->at(1)->eval(target, valueOps, rho);
X
X	// set it in the environment
X	rho->set(sym, target());
X}
X
Xvoid BeginStatement::applyWithArgs(Expr& target, ListNode* args, 
X		Environment* rho)
X{
X	int len = args->length();
X
X	// yield as value the last expression
X	if (len < 1)
X		target = error("begin needs at least one statement");
X	else
X		target = args->at(len - 1);
X}
X
X
/
echo 'x - lisp.h'
sed 's/^X//' > lisp.h << '/'
X//
X//	The core classes for the basic lisp functions
X//
X# include "reader.h"
X# include "function.h"
X
X//
X//	the Lisp reader adds quoted constants
X//
X
Xclass QuotedConst : public Expression {
Xprivate:
X	Expr theValue;
Xpublic:
X	QuotedConst(Expression * val)
X		{ theValue = val; }
X
X	virtual void free();
X	virtual void eval(Expr &, Environment *, Environment *);
X	virtual void print();
X};
X
Xclass LispReader : public ReaderClass {
Xprotected:
X	virtual Expression * readExpression();
X};
X
X//
X//	The arithmetic functions
X//
X
Xint PlusFunction(int, int);
Xint MinusFunction(int, int);
Xint TimesFunction(int, int);
Xint DivideFunction(int, int);
X
X//
X//	Relational functions
X//
X
Xvoid EqualFunction(Expr &, Expression *, Expression *);
Xint IntEqualFunction(int, int);
Xint LessThanFunction(int, int);
Xint GreaterThanFunction(int, int);
X
X//
X//	We can do Car and Cdr because they all evaluate their arguments
X//	But we can't include cons because in chap5 is ceases to evaluate
X//	its arguments
X//
X
X
Xvoid CarFunction(Expr &, Expression *);
Xvoid CdrFunction(Expr &, Expression *);
Xvoid ConsFunction(Expr &, Expression *, Expression *);
X
X//
X//	predicates
X//
X
Xclass BooleanUnary : public UnaryFunction {
Xprivate:
X	int (*fun)(Expression *);
Xpublic:
X	BooleanUnary(int (*thefun)(Expression *))
X		{fun = thefun; }
X	virtual void applyWithArgs(Expr& target, ListNode* args, Environment*);
X};
X
Xint NumberpFunction(Expression *);
Xint SymbolpFunction(Expression *);
Xint ListpFunction(Expression *);
Xint NullpFunction(Expression *);
Xint PrimoppFunction(Expression *);
Xint ClosurepFunction(Expression *);
X
Xvoid PrintFunction(Expr &, Expression *);
X
X//
X//	commands
X//
X
Xclass DefineStatement : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xclass IfStatement : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xclass WhileStatement : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xclass SetStatement : public Function {
Xpublic:
X	virtual void apply(Expr &, ListNode *, Environment *);
X};
X
Xclass BeginStatement : public Function {
Xpublic:
X	virtual void applyWithArgs(Expr &, ListNode *, Environment *);
X};
X
X
/
echo 'x - reader.cc'
sed 's/^X//' > reader.cc << '/'
X# include <std.h>
X# include <ctype.h>
X
X# include "expression.h"
X# include "list.h"
X# include "reader.h"
X
Xextern List emptyList;
X
XExpression * error(char *a, char *b)
X{
X	fprintf(stderr,"Error: %s%s\n", a, b);
X	return 0;
X}
X
Xvoid ReaderClass::printPrimaryPrompt()
X{
X	printf("\n-> ");
X	fflush(stdout);
X}
X
Xvoid ReaderClass::printSecondaryPrompt()
X{
X	printf("> ");
X	fflush(stdout);
X}
X
X
Xvoid ReaderClass::fillInputBuffer()
X{
X	// if the user indicates end of file make it a quit
X	if (gets(buffer) == NULL)
X		strcpy(buffer,"quit");
X
X	// initialize the current pointer
X	p = buffer;
X	skipSpaces();
X}
X
Xint ReaderClass::isSeparator(int c)
X{
X	switch(c) {
X	case ' ': case '\t': case '\n':
X	case EOF: case '\0': case '\'':
X	case ';': case ')': case '(':
X
X		return 1;
X	}
X	return 0;
X}
X
Xvoid ReaderClass::skipSpaces()
X{
X	while ((*p == ' ') || (*p == '\t')) p++;
X	if (*p == ';')	// comment
X		while (*p) p++;	// read until end of line
X}
X
Xvoid ReaderClass::skipNewlines()
X{
X	skipSpaces();
X	while (*p == '\0') {	// end of line
X		printSecondaryPrompt();
X		fillInputBuffer();
X		}
X}
X
XExpression * ReaderClass::promptAndRead()
X{
X	// loop until the user types something
X	do {
X		printPrimaryPrompt();
X		fillInputBuffer();
X		} while (! *p);
X
X	// now that we have something, break it apart
X	Expression * val = readExpression();
X
X	// make sure we are at and of line
X	skipSpaces();
X	if (*p) {
X		error("unexpected characters at end of line:", p);
X		}
X	return val;
X}
X
XExpression * ReaderClass::readExpression()
X{
X	// see if it's an integer
X	if (isdigit(*p))
X		return new IntegerExpression(readInteger());
X
X	// might be a signed integer
X	if ((*p == '-') && isdigit(*(p+1))) {
X		p++;
X		return new IntegerExpression(- readInteger());
X		}
X
X	// or it might be a list
X	if (*p == '(') {
X		p++;
X		return readList();
X		}
X	
X	// otherwise it must be a symbol
X	return readSymbol();
X}
X
Xint ReaderClass::readInteger()
X{
X	int val = 0;
X	while (isdigit(*p)) {
X		val = val * 10 + (*p - '0');
X		p++;
X		}
X	return val;
X}
X
XListNode * ReaderClass::readList()
X{
X	// skipNewlines will issue secondary prompt
X	// until a valid character is typed
X	skipNewlines();
X
X	// if end of list, return empty list
X	if (*p == ')') {
X		p++;
X		return emptyList;
X		}
X
X	// now we have a non-empty character
X	Expression * val = readExpression();
X	return new ListNode(val, readList());
X}
X
XSymbol * ReaderClass::readSymbol()
X{	char token[80], *q;
X
X	for (q = token; ! isSeparator(*p); )
X		*q++ = *p++;
X	*q = '\0';
X	return new Symbol(token);
X}
/
echo 'Part 05 of kamin complete.'
exit