#include <perms.h>
const int No = 0;
const int Yes = 1;
const int Setup = 1;
const int Instream = 2;
const int Outstream = 3;
const int Ssdatafiletype = 4;
const int Marker = 'LISP';
const int Defaultlinelength = 80;
const int Maxlevel = 15;
const int Longbase = 256;
const int Longtail = 511;
const int Namebase = 512;
const int Nametail = 2047;
const int Stackbase = 1024;
const int Stacktail = 2047;
const int Shortbase = 2048;
const int Shorttail = 4095;
const int Listbase = 4096;
const int Listtail = 0x7fff;
const int Atombase = 256;
const int Charbase = 1919;
const int Zerobase = 3072;
const int Pnamemax = 8191;
const int T = 2003;
const int Percent = 1956;
const int Nil = 512;
const int Quote = 513;
const int Label = 514;
const int Lambda = 515;
const int Apval = 516;
const int Subr = 517;
const int Fsubr = 518;
const int Expr = 519;
const int Fexpr = 520;
const int Exit = 521;
const int Evln = 0x8000 | 522;
const int Stars = 523;
const int Error = 0;
const int Error1 = 1;
const int Error2 = 2;
const int Error3 = 3;
const int Escape = 0x88;
const int Eof = 0x89;
const unsigned char Mask[5 /*516:520*/] = {3, 6, 2, 5, 1};
const unsigned char Code[128 /*0:127*/] = {
0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,
0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,
0x80, 0x89, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x21, 0x22, 0x23,
0x88, 0x25, 0x26, 0x84, 0x81, 0x83, 0x2a, 0x2b, 0x2c, 0x2d, 0x82, 0x88,
0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b,
0x3c, 0x3d, 0x3e, 0x3f, 0x84, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,
0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52, 0x53,
0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0x85, 0x5c, 0x87, 0x5e, 0x5f,
0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b,
0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77,
0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f};
const _imp_string Snl = _imp_str_literal("\n");
const _imp_string Charx[8 /*0:7*/] = {
_imp_str_literal(" "), _imp_str_literal("("), _imp_str_literal("."),
_imp_str_literal(")"), _imp_str_literal("'"), _imp_str_literal("["),
_imp_str_literal(" "), _imp_str_literal("]")};
typedef struct Atomcell {
unsigned short Bind;
unsigned short Prop;
unsigned short Func;
unsigned char Form;
_imp_string *Pname;
} Atomcell;
typedef struct Lispcell {
unsigned short Car;
unsigned short Cdr;
} Lispcell;
typedef struct Lispinfo {
int Dataend;
int Datastart;
int Filesize;
int Filetype;
int Sum;
int Datetime;
int Format;
int Records;
int Marker;
int Const;
int Longhead;
int Pnamespace;
int Pnamebase;
int Pnamehead;
int Name;
int Namehead;
int Stack;
int Global;
int List;
int Listhead;
int Listcount;
int Linelength;
} Lispinfo;
typedef struct Rf {
int Conad;
int Filetype;
int Datastart;
int Dataend;
} Rf;
typedef struct Stackframe {
unsigned short Back;
unsigned short Bind;
unsigned short Link;
} Stackframe;
static int Constf[256 /*256:511*/];
static Stackframe Stackf[1024 /*1024:2047*/];
static Lispcell Listf[32768 /*0:32767*/];
static Atomcell Namef[1536 /*512:2047*/];
static unsigned char Pnamef[8192 /*0:8191*/];
extern void Connect(_imp_string File, int Mode, int Hole, int Prot, Rf *R,
int *Flag);
extern void Define(int Chan, _imp_string Iden, int *Afd, int *Flag);
extern _imp_string Failuremessage(int Mess);
extern _imp_string Itos(int N);
extern void Outfile(_imp_string File, int Size, int Hole, int Prot, int *Conad,
int *Flag);
void Prompt(_imp_string S);
extern void Setfname(_imp_string S);
void Setreturncode(int I);
static int Auxp;
static int Errval;
static int Infile;
static int Outf;
static int Char;
static int Reset;
static int Front;
static int Pnametail;
static int Progflag;
static int Local;
static int Nillist;
static int *Listcount;
static int *Listhead;
static int *Longhead;
static int *Pnamehead;
static int *Global;
static int *Namehead;
static int *Linelength;
static _imp_string Pmpt;
static _imp_string Plabel;
static _imp_string Line;
static _imp_string Clause;
static _imp_string Pspaces;
static int Const;
static Lispinfo *Lispfile;
static Atomcell Name;
static Lispcell List;
static Stackframe Stack;
static int Auxs[1024 /*0:1023*/];
static unsigned char Blanks[256 /*0:255*/] = {[0 ... 255] = ' '};
static _imp_string Errors = _imp_str_literal("Error");
static int Eval(int Form);
static int Func(Atomcell *Atom, int Args);
static void Loop(_imp_string Pmpt, int Term);
static int Push(int Index) {
Auxs[Auxp] = Index;
Auxp++;
return (Index);
}
static int Pop(int Index) {
Auxp--;
return (Index);
}
static _imp_string Pname(int Index) {
if (Index >= Longbase)
if (Index >= Namebase) {
if (Index >= Shortbase) return (Itos(Index - Zerobase));
if (Index >= Charbase) return (Tostring(Index - Charbase));
return (Name(Index));
} else
return (Itos(Const(Index)));
else
return (Errors);
}
static _imp_string Pack(int Index) {
int Car;
_imp_string Packed;
Packed = _imp_str_literal("");
while (Index >= Listbase) {
Car = List(Index);
Index = List(Index);
if (Car >= Listbase)
Packed = _imp_join(Packed, Pack(Car));
else
Packed = _imp_join(Packed, Pname(Car));
}
if (Index != Nil) Packed = _imp_join(Packed, Pname(Index));
return (Packed);
}
static int Numberp(int *Value) {
if (Longbase <= Value && Value <= Longtail) {
Value = Const(Value);
return (T);
}
if (Shortbase <= Value && Value <= Shorttail) {
Value -= Zerobase;
return (T);
}
return (Nil);
}
static int Equal(int Arg1, int Arg2) {
if (Arg1 == Arg2 ||
(Numberp(Arg1) == T && T == Numberp(Arg2) && Arg1 == Arg2) ||
(Arg1 >= Listbase && Arg2 >= Listbase &&
Equal(List(Arg1), List(Arg2)) == T &&
Equal(List(Arg1), List(Arg2)) == T))
return (T);
return (Nil);
}
static int Mnumb(int Value) {
int Index;
if (-1024 <= Value && Value <= 1023) return (Value + Zerobase);
if (Longbase > *Longhead || *Longhead > Longtail) {
Printstring(_imp_join(
Snl, _imp_join(_imp_str_literal(
"Atom error: No more room for long constants"),
Snl)));
return (Error);
}
Index = Longbase;
while (Index != *Longhead) {
if (Const(Index) == Value) return (Index);
Index++;
}
*Longhead = *Longhead + 1;
Const(Index) = Value;
return (Index);
}
static int Matom(_imp_string Pname) {
int Index;
Atomcell *Atom;
if (*Length(Pname) == 1) return (Charbase + (*Charno(Pname, 1) & 0x7f));
for (Index = Namebase; Index <= *Namehead - 1; Index++)
if (Pname == Name(Index)) return (Index);
if (*Namehead >= Charbase || *Pnamehead + *Length(Pname) + 1 >= Pnametail) {
Printstring(_imp_join(
Snl,
_imp_join(_imp_str_literal("Atom error: No more space for names"),
Snl)));
return (Error);
}
Atom = Name;
Atom = String(*Pnamehead);
*Pnamehead = *Pnamehead + *Length(Pname) + 1;
Atom = Pname;
Index = *Namehead;
*Namehead = *Namehead + 1;
return (Index);
}
static int Ratom(void) {
int Type;
int Sign;
int Value;
int Tsign;
_imp_string Pname;
Type = 0;
Value = 0;
Sign = +1;
Tsign = +1;
Pname = _imp_str_literal("");
for (;;) {
if (Char & 0x80) {
if (Pname != _imp_str_literal("")) {
if (Type < 2) return (Matom(Pname));
return (Mnumb(Value));
}
Value = Char & 0x7f;
if (Char != 0x80) {
Char = 0x80;
return (Value);
}
} else {
if (0 <= Type && Type <= 2)
if ('0' <= Char && Char <= '9') {
Type = 2;
if (Sign == -1) {
Value = -Value;
Sign = +1;
}
Value = Value * 10 + (Char - '0') * Tsign;
} else {
if (Type == 0 && (Char == '+' || Char == '-')) {
Type = 1;
if (Char == '-') {
Sign = -1;
Tsign = -1;
}
} else
Type = -1;
}
Pname = _imp_join(Pname, Tostring(Char));
}
do {
Readch(Char);
Char = Code[Char & 0x7f];
if (Char == Eof) Selectinput(0);
} while (Char != Eof);
if (Char == Escape) {
Readch(Char);
Type = -1;
}
}
}
static void Printchars(_imp_string Phrase) {
int Adjustment;
if (Plabel != _imp_str_literal("")) {
Phrase = _imp_join(Plabel, Phrase);
Plabel = _imp_str_literal("");
}
if (Phrase == _imp_str_literal("")) {
if (*Length(Line) + *Length(Clause) < *Linelength)
Printstring(_imp_join(Line, _imp_join(Clause, Snl)));
else
Printstring(_imp_join(
Line, _imp_join(Snl, _imp_join(Pspaces, _imp_join(Clause, Snl)))));
Line = _imp_str_literal("");
Clause = _imp_str_literal("");
}
if (*Length(Pspaces) + *Length(Clause) + *Length(Phrase) >= *Linelength) {
Adjustment = *Length(Pspaces) - *Length(Phrase);
if (Adjustment < 0) {
if (Line != _imp_str_literal("")) Printstring(_imp_join(Line, Snl));
Printstring(_imp_join(Pspaces, _imp_join(Clause, Snl)));
Line = _imp_str_literal("");
Clause = _imp_str_literal("");
} else
*Length(Pspaces) = Adjustment;
}
Clause = _imp_join(Clause, Phrase);
}
static void Print(int Index) {
int Level;
int Clevel;
int Adjustment;
int I;
unsigned char Rflag;
unsigned char Ccount;
unsigned char Rcount;
unsigned char Line1;
int Linepos[16 /*0:15*/];
_imp_string Padding(void) {
int Index;
int Count;
if (Level < Maxlevel + 1)
Index = Level;
else
Index = Maxlevel;
Count = Linepos[Index] - *Length(Plabel);
if (Count > *Linelength) Count = *Linelength;
if (Count < 0) Count = 0;
Blanks[0] = Count;
return (*String(Addr(Blanks[0])));
}
void Lparen(void) {
int I;
if (Level <= Maxlevel && Linepos[Level] == 0)
Linepos[Level] = *Length(Line) + *Length(Clause);
if (50 < *Length(Line) && *Length(Line) > Linepos[Level] ||
*Length(Clause) > 30 || (*Length(Clause) > 20 && *Length(Line) > 20))
Ccount = 10;
if (Rflag > 0 || Ccount >= 10) {
if (*Length(Line) + *Length(Clause) > *Linelength ||
*Length(Line) - *Length(Pspaces) > 25 || Ccount >= 2) {
if (Level > Clevel) {
Adjustment = *Length(Line) - *Length(Pspaces);
for (I = Clevel + 1; I <= Level; I++)
Linepos[I] = Linepos[I] - Adjustment;
}
if (Line != _imp_str_literal("")) Printstring(_imp_join(Line, Snl));
Line = _imp_join(Pspaces, Clause);
Line1 = 0;
} else
Line = _imp_join(Line, Clause);
Ccount = Rcount;
Clause = _imp_str_literal("");
Clevel = Level;
Pspaces = Padding();
}
if (!Line1) Level++;
Rflag = 0;
Rcount = 0;
Printchars(_imp_str_literal("("));
}
void Rparen(void) {
Printchars(_imp_str_literal(")"));
if (0 < Level && Level <= Maxlevel) Linepos[Level] = 0;
if (Level > 0) Level--;
Rflag = 1;
Rcount++;
}
void Printsexp(int Index) {
int Car;
int Cdr;
Lispcell *Cell;
if (Index >= Listbase) {
Cell = List;
Car = Cell;
Cdr = Cell;
Lparen();
Printsexp(Car);
if (Cdr >= Listbase) {
for (;;) {
Index = Cdr;
Cell = List;
Car = Cell;
Cdr = Cell;
if (Plabel == _imp_str_literal("")) Printchars(_imp_str_literal(" "));
if (Cdr < Listbase) break;
if (Car == Nil) {
Lparen();
Printchars(_imp_str_literal(" "));
Rparen();
} else
Printsexp(Car);
}
Printsexp(Car);
}
if (Cdr != Nil) {
Printchars(_imp_str_literal(" . "));
Printchars(Pname(Cdr));
Rflag = 0;
}
Rparen();
} else if (Rflag == 1) {
Rflag = 2;
Plabel = _imp_join(Pname(Index), _imp_str_literal(" "));
} else {
Printchars(Pname(Index));
Rflag = 0;
}
}
Line1 = 1;
Rflag = 0;
Ccount = 0;
Rcount = 0;
Pspaces = _imp_str_literal("");
Level = 0;
Clevel = 0;
Linepos[0] = 4;
for (I = 1; I <= Maxlevel; I++) Linepos[I] = 0;
Printsexp(Index);
}
static void Mark(int Index) {
unsigned short *Car;
while (Index >= Listbase && List(Index) >= 0) {
Car = List;
Index = List(Index);
*Car = *Car | 0x8000;
if ((*Car & 0x7fff) >= Listbase) Mark(*Car & 0x7fff);
}
}
static void Garbagecollect(void) {
Lispcell *Cell;
int I;
for (I = Namebase; I <= *Namehead - 1; I++) Mark(Name(I));
for (I = Charbase; I <= Nametail; I++) Mark(Name(I));
for (I = Stackbase; I <= Front; I++) Mark(Stack(I));
for (I = *Global; I <= Stacktail; I++) Mark(Stack(I));
if (Auxp > 0)
for (I = 0; I <= Auxp - 1; I++) Mark(Auxs[I]);
*Listcount = 0;
*Listhead = 0;
for (I = Listbase; I <= Listtail; I++) {
Cell = List;
if (Cell < 0)
Cell = Cell & 0x7fff;
else {
*Listcount = *Listcount + 1;
Cell = *Listhead;
*Listhead = I;
}
}
}
static int Cons(int Car, int Cdr) {
int Index;
int Dummy;
Lispcell *Cell;
if (*Listcount <= 100 || *Listhead < Listbase) {
Dummy = Push(Car);
Dummy = Push(Cdr);
Auxp += 2;
Garbagecollect();
Auxp -= 2;
if (*Listcount <= 1000) {
Printstring(_imp_join(
Snl, _imp_join(_imp_str_literal("Lisp note: Less than 1000 free "
"cells remaining - free something"),
Snl)));
Loop(_imp_str_literal("Free:"), Percent);
}
}
if (*Listhead < Listbase) {
Printstring(_imp_join(
Snl,
_imp_join(_imp_str_literal("Lisp error: No more free space left"),
Snl)));
return (Error);
}
*Listcount = *Listcount - 1;
Index = *Listhead;
Cell = List;
*Listhead = Cell;
Cell = Car;
Cell = Cdr;
return (Index);
}
static int Reverse(int Curr) {
int Last;
Lispcell *Cell;
Last = Nil;
while (Curr >= Listbase) {
Cell = List;
Last = Cons(Cell, Last);
Curr = Cell;
}
return (Last);
}
static int Readsexp(_imp_string Pmpt) {
auto int Cell(int Car);
auto int Head(void);
auto int Tail(void);
int Colapse;
int Cell(int Car) {
int Cdr;
if (Car >= Atombase) {
Auxs[Auxp] = Car;
Auxp++;
Cdr = Tail();
Auxp--;
if (Cdr >= Atombase) return (Cons(Car, Cdr));
}
return (Error);
}
int Head(void) {
int Temp;
int Res;
static int Sw_sw;
static void *Sw[4 /*0:3*/] = {
&&Sw_0,
&&Sw_1,
&&Sw_2,
&&Sw_3,
};
Temp = Ratom();
if (Temp >= Atombase) return (Temp);
goto *Sw[Sw_sw = Temp & 3];
Sw_0:;
return (Cons(Quote, Cons(Head(), Nil)));
Sw_1:;
Res = Tail();
if (Temp >= 4) Colapse = No;
return (Res);
Sw_2:;
Sw_3:;
Printstring(_imp_join(
Snl,
_imp_join(_imp_str_literal("Read error: S-expression begins with a "),
_imp_join(Charx[Temp], Snl))));
return (Error);
}
int Tail(void) {
int Temp;
int Res;
static int Sw_sw;
static void *Sw[4 /*0:3*/] = {
&&Sw_0,
&&Sw_1,
&&Sw_2,
&&Sw_3,
};
if (Colapse == Yes) return (Nil);
Temp = Ratom();
if (Temp >= Atombase) return (Cell(Temp));
goto *Sw[Sw_sw = Temp & 3];
Sw_0:;
return (Cell(Cons(Quote, Cons(Head(), Nil))));
Sw_1:;
Res = Tail();
if (Temp >= 4) Colapse = No;
return (Cell(Res));
Sw_2:;
Temp = Head();
if (Tail() == Nil) return (Temp);
Printstring(_imp_join(
Snl,
_imp_join(_imp_str_literal(
"Read error: Dotted pair not enclosed in brackets"),
Snl)));
return (Error);
Sw_3:;
if (Temp >= 4) Colapse = Yes;
return (Nil);
}
Colapse = No;
Prompt(Pmpt);
return (Head());
}
static void Loop(_imp_string Pmpt, int Term) {
int Value;
for (;;) {
Reset = 0;
Value = Eval(Readsexp(Pmpt));
if (Value == Term) break;
if (!Reset) {
Print(Value);
Printchars(_imp_str_literal(""));
}
}
}
static int Pcons(int Car, int Cdr) {
Auxp--;
return (Cons(Car, Cdr));
}
static void Xprint(_imp_string Mess, int Form) {
_imp_string Save;
Save = Line;
Line = Mess;
Print(Form);
Printchars(_imp_str_literal(""));
Line = Save;
}
static void Bind(int Symb, int Entry, int Bind) {
Atomcell *Atom;
Stackframe *Frame;
if (Namebase > Symb || Symb >= Listbase) {
Printstring(_imp_join(
Snl,
_imp_str_literal(
"Bind error: Element of name list not an atom, element = ")));
Xprint(_imp_str_literal(""), Symb);
return;
}
if (Name(Symb) == 3) {
Xprint(
_imp_join(
Snl,
_imp_str_literal(
"Bind error: Name list entry has constant binding, name=")),
Symb);
return;
}
if (*Global <= Front) {
Printstring(_imp_join(
Snl, _imp_join(_imp_str_literal("Bind error: Stack overflow"), Snl)));
return;
}
Frame = Stack;
Atom = Name;
if (Bind < Atombase) {
Printstring(
_imp_join(Snl, _imp_str_literal("Bind error: Unassigned argument ")));
Xprint(_imp_str_literal(""), Symb);
Bind = Error;
}
Frame = Bind;
Frame = Symb;
Frame = Atom;
Atom = Entry;
}
static void Bindlist(int *Names, int *Args) {
Lispcell *Cell;
Lispcell *Argc;
Stack(Front) = Local;
Stack(Front) = 0;
Local = Front;
Front++;
while (Names >= Listbase) {
Cell = List;
Argc = List;
Bind(Cell, Front, Argc);
Front++;
Names = Cell;
Args = Argc;
}
}
static int Unbind(int Result) {
Stackframe *Frame;
while (Front > Local) {
Front--;
Frame = Stack;
if (Frame > 0) Name(Frame) = Frame;
}
Front = Local;
Local = Stack(Front);
return (Result);
}
static int Prog(int Names, int Body) {
int Proglist;
int Result;
Lispcell *Cell;
Bindlist(Names, Nillist);
Progflag += 4;
Proglist = Body;
while (Body >= Listbase) {
Cell = List;
if (Cell >= Listbase) {
Result = Eval(Cell);
if (Progflag & 3) {
if (Progflag & 1) {
Progflag = (Progflag & (~3)) - 4;
return (Unbind(Result));
}
Cell = List;
Progflag = Progflag & (~3);
while (Cell != Result) {
if (Cell < Listbase) {
Progflag -= 4;
return (Unbind(Error));
}
Cell = List;
}
}
}
Body = Cell;
}
Progflag -= 4;
return (Unbind(Result));
}
static int Evlist(int Args) {
Lispcell *Cell;
if (Args < Listbase) return (Args);
Cell = List;
return (Pcons(Push(Eval(Cell)), Evlist(Cell)));
}
static int Apply(int Function, int Args) {
int Car;
int Cadr;
int Caddr;
Lispcell *Cell;
if (Function >= Listbase) {
Cell = List;
Car = Cell;
Cell = List;
Cadr = Cell;
Cell = List;
Caddr = Cell;
if (Car == Label) {
Bind(Cadr, Front, Caddr);
Front++;
return (Apply(Caddr, Args));
}
if (Car == Lambda) {
Bindlist(Cadr, Args);
if (Cadr != Nil) {
Bind(Cadr, Front, Args);
Front++;
}
return (Unbind(Eval(Caddr)));
}
return (Apply(Eval(Function), Args));
}
if (Namebase <= Function && Function <= Nametail)
return (Func(Name(Function), Args));
return (Error);
}
static int Put(int Atom, int Bind, int Prop) {
int Id;
unsigned short *Hole;
Lispcell *Propcell;
Lispcell *Bindcell;
if (Namebase > Atom || Atom > Nametail || Namebase > Prop || Prop > Nametail)
return (Error3);
Hole = Name;
for (;;) {
if (*Hole < Listbase) {
*Hole = Cons(Prop, Cons(Bind, Nil));
break;
}
Propcell = List;
Bindcell = List;
if (Propcell == Prop) {
Bindcell = Bind;
break;
}
Hole = Bindcell;
}
if (Apval <= Prop && Prop <= Fexpr) {
Name(Atom) = Mask[Prop];
if (Subr <= Prop && Prop <= Fsubr) {
Id = Bind;
if (Numberp(Id) != T) return (Error3);
Name(Atom) = Id;
} else
Name(Atom) = Bind;
}
return (Bind);
}
static int Func(Atomcell *Atom, int Args) {
int Arg1;
int Arg2;
int Arg3;
int Symb;
int Afd;
int Flag;
_imp_string Line;
unsigned short *Hole;
Lispcell *Cell;
Stackframe *Frame;
static int Type_sw;
static void *Type[4 /*0:3*/] = {
&&Type_0,
&&Type_1,
&&Type_2,
&&Type_3,
};
static int Func_sw;
static void *Func[87 /*0:86*/] = {
&&Func_0, &&Func_1, &&Func_2, &&Func_3, &&Func_4,
&&Func_5, &&Func_6, &&Func_7, &&Func_8, &&Func_9,
&&Func_10, &&Func_11, &&Func_12, &&Func_13, &&Func_14,
&&Func_15, &&Func_16, &&Func_17, &&Func_18, &&Func_19,
&&Func_20, &&Func_21, &&Func_22, &&Func_23, &&Func_24,
&&Func_25, &&Func_26, &&Func_27, &&Func_28, &&Func_29,
&&Func_30, &&Func_31, &&Func_32, &&Func_33, &&Func_34,
&&Func_35, &&Func_36, &&Func_37, &&Func_38, &&Func_39,
&&Func_40, &&Func_41, &&Func_42, &&Func_43, &&Func_44,
&&Func_45, &&Func_46, &&Func_47, &&Func_48, &&Func_49,
&&Func_50, &&Func_51, &&Func_52, &&Func_53, &&Func_54,
&&Func_55, &&Func_56, &&Func_default, &&Func_default, &&Func_default,
&&Func_60, &&Func_61, &&Func_62, &&Func_63, &&Func_64,
&&Func_65, &&Func_66, &&Func_67, &&Func_68, &&Func_69,
&&Func_70, &&Func_71, &&Func_72, &&Func_73, &&Func_74,
&&Func_75, &&Func_76, &&Func_77, &&Func_78, &&Func_79,
&&Func_80, &&Func_81, &&Func_82, &&Func_83, &&Func_84,
&&Func_85, &&Func_86,
};
goto *Type[Type_sw = Atom & 3];
Type_3:;
Type_0:;
if (Atom >= *Global) return (Error2);
Front++;
Args = Evlist(Args);
Front--;
return (Apply(Stack(Atom), Args));
Type_1:;
return (Apply(Atom, Args));
Type_2:;
Cell = List;
Arg1 = Cell;
Cell = List;
Arg2 = Cell;
Cell = List;
Arg3 = Cell;
goto *Func[Func_sw = Atom];
Func_0:;
return (Arg1);
Func_1:;
return (List(Arg1));
Func_2:;
return (List(Arg1));
Func_3:;
return (List(List(Arg1)));
Func_4:;
return (List(List(Arg1)));
Func_5:;
return (List(List(Arg1)));
Func_6:;
return (List(List(Arg1)));
Func_7:;
return (Cons(Arg1, Arg2));
Func_8:;
return (Args);
Func_9:;
while (Args >= Listbase) {
Cell = List;
Arg1 = Eval(Cell);
if (Arg1 != Nil) {
while (Cell >= Listbase) {
Cell = List;
Arg1 = Eval(Cell);
}
return (Arg1);
}
Args = List(Args);
}
return (Nil);
Func_10:;
while (Args >= Listbase) {
Cell = List;
if (Eval(Cell) == Nil) return (Nil);
Args = Cell;
}
return (T);
Func_11:;
while (Args >= Listbase) {
Cell = List;
if (Eval(Cell) != Nil) return (T);
Args = Cell;
}
return (Nil);
Func_12:;
if (Arg1 == Nil)
return (T);
else
return (Nil);
Func_13:;
if (Atombase <= Arg1 && Arg1 < Listbase)
return (T);
else
return (Nil);
Func_14:;
return (Numberp(Arg1));
Func_56:;
if (Numberp(Arg1) == T && (Arg1 & 1) == 0) return (T);
return (Nil);
Func_55:;
Arg1--;
Func_15:;
if (Arg1 == Zerobase)
return (T);
else
return (Nil);
Func_16:;
if (Arg1 == Arg2)
return (T);
else
return (Nil);
Func_17:;
return (Equal(Arg1, Arg2));
Func_18:;
if (Numberp(Arg1) == T && T == Numberp(Arg2) && Arg1 < Arg2)
return (T);
else
return (Nil);
Func_19:;
if (Numberp(Arg1) == T && T == Numberp(Arg2) && Arg1 > Arg2)
return (T);
else
return (Nil);
Func_20:;
while (Arg2 >= Listbase) {
Cell = List;
if (Arg1 == Cell) return (T);
Arg2 = Cell;
}
return (Nil);
Func_21:;
while (Arg2 >= Listbase) {
Cell = List;
if (Equal(Arg1, Cell) == T) return (T);
Arg2 = Cell;
}
return (Nil);
Func_22:;
while (Arg2 >= Listbase) {
Cell = List;
if (Equal(Arg1, List(Cell)) == T) return (Cell);
Arg2 = Cell;
}
return (Nil);
Func_23:;
Arg1 = 0;
while (Args >= Listbase) {
Cell = List;
Arg2 = Cell;
if (Numberp(Arg2) == T)
Arg1 += Arg2;
else
return (Error3);
Args = Cell;
}
return (Mnumb(Arg1));
Func_24:;
if (Numberp(Arg1) != T) return (Error3);
while (Args >= Listbase) {
Cell = List;
Arg2 = Cell;
if (Numberp(Arg2) == T)
Arg1 -= Arg2;
else
return (Error3);
Args = Cell;
}
return (Mnumb(Arg1));
Func_25:;
Arg1 = 1;
while (Args >= Listbase) {
Cell = List;
Arg2 = Cell;
if (Numberp(Arg2) == T)
Arg1 = Arg1 * Arg2;
else
return (Error3);
Args = Cell;
}
return (Mnumb(Arg1));
Func_26:;
if (Numberp(Arg1) != T) return (Error3);
while (Args >= Listbase) {
Cell = List;
Arg2 = Cell;
if (Numberp(Arg2) == T)
Arg1 = Arg1 / Arg2;
else
return (Error3);
Args = Cell;
}
return (Mnumb(Arg1));
Func_27:;
if (Numberp(Arg1) == T) return (Mnumb(Arg1 + 1));
return (Error3);
Func_28:;
if (Numberp(Arg1) == T) return (Mnumb(Arg1 - 1));
return (Error3);
Func_29:;
if (Numberp(Arg1) == T) return (Mnumb(Imod(Arg1)));
return (Error3);
Func_30:;
Arg1 = Eval(Arg1);
Args = List(Args);
for (;;) {
Arg3 = Args;
Args = List(Arg3);
if (Args < Listbase) break;
Cell = List;
Arg2 = Cell;
Arg3 = Cell;
while (Arg2 >= Listbase) {
Cell = List;
if (Cell == Arg1) goto Exit;
Arg2 = Cell;
}
if (Arg2 == Arg1) break;
}
Exit:;
while (Arg3 >= Listbase) {
Cell = List;
Arg1 = Eval(Cell);
Arg3 = Cell;
}
return (Arg1);
Func_31:;
return (Put(Arg1, Arg3, Arg2));
Func_32:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
return (Name(Arg1));
Func_33:;
if (Namebase > Arg1 || Arg1 > Nametail || Namebase > Arg2 || Arg2 > Nametail)
return (Error3);
*Atom = Name;
Hole = &Atom;
while (*Hole >= Listbase) {
Cell = List;
if (Cell == Arg2) {
Cell = List;
if (Cell == Atom) Atom = 0;
*Hole = Cell;
return (T);
}
Hole = List;
}
return (Nil);
Func_34:;
if (Namebase > Arg1 || Arg1 > Nametail || Namebase > Arg2 || Arg2 > Nametail)
return (Error3);
Args = Name(Arg1);
while (Args >= Listbase) {
Cell = List;
if (Cell == Arg2) return (List(Cell));
Args = List(Cell);
}
return (Nil);
Func_35:;
return (Put(Arg1, Arg2, Arg3));
Func_36:;
return (Eval(Arg1));
Func_37:;
return (Evlist(Args));
Func_38:;
return (Apply(Arg1, Arg2));
Func_39:;
Arg1 = Cons(Eval(Arg1), Nil);
if (Reset == 2) {
Arg1 = Errval;
Reset = 0;
}
return (Arg1);
Func_40:;
if (Arg1 < Listbase) return (Error3);
List(Arg1) = Arg2;
return (Arg2);
Func_41:;
if (Arg1 < Listbase) return (Error3);
List(Arg1) = Arg2;
return (Arg2);
Func_42:;
if (Arg1 == Nil) return (Arg2);
if (Arg1 < Listbase) return (Error3);
Args = Arg1;
while (List(Arg1) >= Listbase) Arg1 = List(Arg1);
List(Arg1) = Arg2;
return (Args);
Func_43:;
if (Numberp(Arg1) == T && Arg1 < 0) return (T);
return (Nil);
Func_44:;
Arg2 = Eval(Arg2);
Func_45:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
Arg3 = Name(Arg1);
if (Arg3 < Stacktail)
Stack(Arg3) = Arg2;
else {
*Global = *Global - 1;
Bind(Arg1, *Global, Arg2);
}
return (Arg2);
Func_46:;
if (Atombase > Arg1 || Arg1 >= Listbase) return (Error3);
Line = Pname(Arg1);
Arg2 = Nil;
for (Arg1 = Addr(Line) + *Length(Line); Arg1 >= Addr(Line) + 1; Arg1--) {
Symb = *Byteinteger(Arg1);
if ('0' <= Symb && Symb <= '9')
Symb = Zerobase + Symb - '0';
else
Symb += Charbase;
Arg2 = Cons(Symb, Arg2);
}
return (Arg2);
Func_47:;
return (Matom(Pack(Arg1)));
Func_48:;
return (Arg2);
Func_49:;
while (Args >= Listbase) {
Cell = List;
Arg1 = Eval(Cell);
Args = Cell;
}
return (Arg1);
Func_50:;
return (Prog(Arg1, List(Args)));
Func_51:;
if (Numberp(Arg1) == T) return (Mnumb(-Arg1));
return (Error3);
Func_52:;
Progflag = Progflag | 1;
return (Arg1);
Func_53:;
Progflag = Progflag | 2;
return (Arg1);
Func_54:;
return (Reverse(Arg1));
Func_60:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
Pmpt = Pname(Arg1);
return (Arg1);
Func_61:;
if (Atombase <= Arg1 && Arg1 < Listbase)
Prompt(Pname(Arg1));
else
Prompt(Pmpt);
Readch(Symb);
if ('0' <= Symb && Symb <= '9')
return (Mnumb(Symb - '0'));
else
return (Matom(Tostring(Symb)));
Func_62:;
if (Atombase <= Arg1 && Arg1 < Listbase) return (Readsexp(Pname(Arg1)));
return (Readsexp(Pmpt));
Func_63:;
Print(Arg1);
return (Arg1);
Func_64:;
Print(Arg1);
Printchars(_imp_str_literal(""));
return (Arg1);
Func_65:;
Printchars(_imp_str_literal(""));
if (Arg1 < Atombase) Arg1 = Nil;
return (Arg1);
Func_66:;
if (Numberp(Arg1) == T) {
Selectinput(Arg1);
return (Mnumb(Arg1));
}
return (Error3);
Func_67:;
if (Numberp(Arg1) == T) {
Selectoutput(Arg1);
return (Mnumb(Arg1));
}
return (Error3);
Func_68:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
Selectinput(0);
Closestream;
Arg2 = Infile;
Infile = Arg1;
Define(Instream(), Name(Infile), Afd, Flag);
Selectinput(Instream());
return (Arg2);
Func_69:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
Selectoutput(0);
Closestream;
Arg2 = Outf;
Outf = Arg1;
Define(Outstream(), Name(Outf), Afd, Flag);
Selectoutput(Outstream());
return (Arg2);
Func_70:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
*Atom = Name;
Atom = Atom | 8;
return (Arg1);
Func_71:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
*Atom = Name;
Atom = Atom & (~8);
return (Arg1);
Func_72:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
Name(Arg1) = Name(Arg1) | 16;
return (Arg1);
Func_73:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
Name(Arg1) = Name(Arg1) & (~16);
return (Arg1);
Func_74:;
if (Namebase > Arg1 || Arg1 > Nametail) return (Error3);
*Atom = Name;
Atom = Stacktail;
Atom = Nil;
Atom = 0;
Atom = 0;
return (Arg1);
Func_75:;
if (Numberp(Arg1) == T && Front - Arg1 > Stackbase)
Arg1 -= Front;
else
Arg1 = Stackbase;
if (Front != Arg1)
for (Arg1 = Front - 1; Arg1 >= Arg1; Arg1--) {
Frame = Stack;
Line = _imp_join(Pname(Frame & 0xfff), _imp_str_literal(" "));
*Length(Line) = 9;
if (Frame & 0x8000)
Line = _imp_join(Line, _imp_str_literal("* "));
else
Line = _imp_join(Line, _imp_str_literal("= "));
Xprint(Line, Frame);
}
return (Stars);
Func_76:;
if (Zerobase + 40 > Arg1 || Arg1 > Zerobase + 255) return (Error3);
*Linelength = Arg1 - Zerobase;
return (Arg1);
Func_77:;
Garbagecollect();
return (Mnumb(*Listcount));
Func_78:;
Pmpt = _imp_str_literal("Read:");
Reset = 1;
Errval = Nil;
return (Percent);
Func_79:;
Errval = Arg1;
Reset = 2;
return (Percent);
Func_80:;
Arg2 = Nil;
for (Arg1 = *Namehead - 1; Arg1 >= Namebase; Arg1--) Arg2 = Cons(Arg1, Arg2);
return (Arg2);
Func_81:;
Arg2 = Nil;
Arg3 = Nil;
for (Arg1 = Stackbase; Arg1 <= Front - 1; Arg1++) {
Frame = Stack;
if (Namebase <= Frame && Frame <= Nametail)
Arg2 = Cons(Cons(Frame, Frame), Arg2);
}
for (Arg1 = Stacktail - 1; Arg1 >= *Global; Arg1--) {
Frame = Stack;
Arg3 = Cons(Cons(Frame, Frame), Arg3);
}
return (Cons(Arg2, Arg3));
Func_82:;
if (Numberp(Arg1) != T || 0 > Arg1 || Arg1 > 127) return (Error3);
return (Matom(Tostring(Arg1)));
Func_83:;
if (Numberp(Arg1) != T) return (Error3);
while (Args >= Listbase) {
Cell = List;
Arg2 = Cell;
if (Numberp(Arg2) != T) return (Error3);
if (Arg1 < Arg2) Arg1 = Arg2;
Args = Cell;
}
return (Mnumb(Arg1));
Func_84:;
if (Numberp(Arg1) != T) return (Error3);
while (Args >= Listbase) {
Cell = List;
Arg2 = Cell;
if (Numberp(Arg2) != T) return (Error3);
if (Arg2 < Arg1) Arg1 = Arg2;
Args = Cell;
}
return (Mnumb(Arg1));
Func_85:;
if (Numberp(Arg1) != T) return (Error3);
return (Int(Sqrt(Arg1)));
Func_86:;
if (Numberp(Arg1) != T || T != Numberp(Arg2)) return (Error3);
return (Mnumb(IEXP(Arg1, Arg2)));
goto Func_skip;
Func_default:
fprintf(stderr, "Switch label 'Func(%d):' not set in %s", Func_sw,
__PRETTY_FUNCTION__);
exit(1) /* or %signal ... */;
Func_skip:;
}
static int Trace(_imp_string Mess, int Form) {
Xprint(Mess, Form);
return (Form);
}
static int Eval(int Form) {
int Car;
int Cdr;
Lispcell *Cell;
Atomcell *Atom;
Stackframe *Frame;
int Break(int Result) {
int Sexp;
static int Error_sw;
static void *Error[4 /*0:3*/] = {
&&Error_0,
&&Error_1,
&&Error_2,
&&Error_3,
};
if (Result >= Atombase || Reset != 0) return (Result);
Selectinput(0);
Selectoutput(0);
Xprint(_imp_str_literal("Eval error: "), Form);
goto *Error[Error_sw = Result];
Error_1:;
Printstring(
_imp_join(_imp_str_literal(" Atom is not bound to a value"), Snl));
goto *Error[Error_sw = 0];
Error_2:;
Xprint(_imp_str_literal(" Function not defined: "), Car);
goto *Error[Error_sw = 0];
Error_3:;
Xprint(_imp_str_literal(" Argument not of the correct form in "), Cdr);
Error_0:;
Loop(_imp_str_literal(" %:"), Percent);
if (Reset) return (Percent);
Sexp = Readsexp(_imp_str_literal("Eval:"));
if (Sexp == Percent) Sexp = Form;
return (Eval(Sexp));
}
if (Reset) return (Percent);
Frame = Stack;
Frame = Evln;
Frame = Form;
if (Form >= Listbase) {
Cell = List;
Car = Cell;
Cdr = Cell;
if (Namebase <= Car && Car <= Nametail) {
Atom = Name;
if (Atom & 4) {
Front++;
Cdr = Evlist(Cdr);
Front--;
}
Form = Push(Form);
Frame = Car | 0x8000;
Frame = Cdr;
if (Atom & 16) {
Selectinput(0);
Selectoutput(0);
Xprint(_imp_str_literal("Lisp Break: "), Form);
Front++;
Loop(_imp_str_literal(" %:"), Percent);
Front--;
}
if (Atom & 8)
return (Pop(Break(Trace(
_imp_join(_imp_str_literal("<--- "),
_imp_join(Pname(Car), _imp_str_literal(" "))),
Func(*Atom,
Trace(_imp_join(_imp_str_literal("---> "),
_imp_join(Pname(Car), _imp_str_literal(" "))),
Cdr))))));
return (Pop(Break(Func(*Atom, Cdr))));
}
Front++;
Cdr = Evlist(Cdr);
Front--;
return (Break(Apply(Car, Cdr)));
}
if (Namebase <= Form && Form <= Nametail) {
Atom = Name;
if ((Atom & 0x7) == 3) return (Atom);
return (Break(Stack(Atom)));
}
return (Form);
}
static void Initlisp(void) {
int I;
int Sexp;
Atomcell *Atom;
Lispcell *Cell;
Stackframe *Frame;
for (I = Namebase; I <= Nametail; I++) {
Atom = Name;
Atom = Stacktail;
Atom = Nil;
Atom = 0;
Atom = 0;
Atom = &Errors;
}
Selectinput(Setup);
Reset = 0;
for (I = Nil; I <= Stars; I++) Sexp = Ratom();
for (I = 0; I <= Listbase - 1; I++) {
Cell = List;
Cell = Error3;
Cell = Error3;
}
*Listhead = Listbase;
*Listcount = Listtail - *Listhead;
for (I = Listbase; I <= Listtail - 1; I++) List(I) = I + 1;
List(Listtail) = 0;
do
Sexp = Put(Ratom(), Ratom(), Ratom());
while (Sexp != Nil);
Stack(Front) = Error;
Frame = Stack;
Frame = *Global;
Frame = Error1;
Auxs[Auxp] = Error;
do
Sexp = Eval(Readsexp(_imp_str_literal("")));
while (Sexp != Nil);
Selectinput(0);
}
void Lisp(_imp_string Parms) {
int Flag;
int Conad;
int Initmode;
int I;
int Fixup;
_imp_string Work;
Rf Rr;
unsigned char Pnamespace;
Atomcell *Atom;
Local = Stackbase;
Front = Stackbase;
Auxp = 0;
Pmpt = _imp_str_literal("Read:");
Char = 0x80;
if (_imp_cond_resolve(Parms, Work, _imp_str_literal("/"), Parms) &&
Work == _imp_str_literal("")) {
if (Parms == _imp_str_literal("")) Parms = _imp_str_literal("T#LSPMACH");
Outfile(Parms, 196608, 0, 0, Conad, Flag);
if (Flag) goto Err;
Initmode = Yes;
} else {
Initmode = No;
Connect(Parms, 3, 0, 0, Rr, Flag);
if (Flag) goto Err;
Conad = Rr;
}
Lispfile = Record(Conad);
if (Initmode == Yes) {
Lispfile = Lispfile;
Lispfile = Ssdatafiletype;
Lispfile = 3;
Lispfile = Marker;
Lispfile = 0x1000;
Lispfile = Longbase;
Lispfile += 4 * (Longtail - Longbase + 1);
Lispfile = Lispfile;
Lispfile = Lispfile;
Lispfile = 0x4000;
Lispfile = Namebase;
Lispfile = 0xA000;
Lispfile = Stacktail;
Lispfile = 0x10000;
Lispfile = Defaultlinelength;
} else if (Lispfile != Marker) {
Flag = 311;
Setfname(Parms);
goto Err;
}
*Const = &Array;
Longhead = Lispfile;
*Pnamespace = &Array;
Pnamehead = Lispfile;
Pnametail = Addr(Pnamespace(Pnamemax));
*Name = &Array;
Namehead = Lispfile;
Global = Lispfile;
Linelength = Lispfile;
Fixup = Addr(Pnamespace(0)) - Lispfile;
Lispfile += Fixup;
Lispfile += Fixup;
for (I = Namebase; I <= *Namehead - 1; I++) {
Atom = Name;
Atom = String(Addr(Atom) + Fixup);
if (*Global > Atom || Atom > Stacktail) Atom = Stacktail;
}
for (I = Charbase; I <= Nametail; I++) {
Atom = Name;
if (*Global > Atom || Atom > Stacktail) Atom = Stacktail;
}
*List = &Array;
Listhead = Lispfile;
Listcount = Lispfile;
*Stack = &Array;
Pspaces = _imp_str_literal("");
Plabel = _imp_str_literal("");
Line = _imp_str_literal("");
Clause = _imp_str_literal("");
Progflag = 0;
Flag = 0;
if (Initmode == Yes) Initlisp();
Nillist = Cons(Nil, Nil);
List(Nillist) = Push(Nillist);
Infile = Matom(_imp_str_literal(".IN"));
Outf = Matom(_imp_str_literal(".OUT"));
Loop(_imp_str_literal("Lisp:"), Exit);
Setreturncode(0);
exit(0);
Err:;
Selectoutput(0);
Printstring(_imp_join(
Snl, _imp_join(_imp_str_literal("LISP fails -"), Failuremessage(Flag))));
Setreturncode(Flag);
exit(0);
}