#ifdef __BCPLUSPLUS__// old-style C++// There are some expected warnings under the Borland C++ compiler;// these pragmas turn them off.#pragma warn -ext#pragma warn -sig// Also, the default stack isn't nearly big enough.unsigned _stklen=32768U;// header files have a .h#include <stdio.h>#include <iostream.h>#include <stdlib.h>#include <ctype.h>#include <string.h>#include <cstring.h>#include <except.h>#define exception xmsg#else// new-style C++#include <cstdio>#include <iostream>#include <cstdlib>#include <cctype>#include <cstring>#include <string>#include <exception># ifdef __DJGPP__// This is a bug in my version of DJGPP. This doesn't do anything but suppress// a fatal linker error; it's correct standard-compliant C++ anyway so it won't// be a problem even when the bug is fixed.int finite;# endifusing namespace std; //define the old-style xmsgclass xmsg : public exception{ string w;public: virtual const char* what() const throw () { return w.c_str(); } const char* why() const throw() { // backwards compatibility return what(); } xmsg(string s) : exception() { w=s; } xmsg(const char* a) : exception() { w=string(a); } ~xmsg() throw () {};};#endif#define MYHEAPSIZE 32766// My computer runs out of memory before hitting this heap size limit in an// Overload program.// wmw-dependent#define NORMALNUMCHAR1 ':'#define NORMALNUMCHAR2 '*'#define DEBUGOV debugov#define ITOS ((*su)->car)#define TOS (su->car)#define OVCMD(a) InsBefore(&ITOS, new TListEl("(" #a ")",1),1); goto eval#define OVCMD2(a) InsBefore(&ITOS, new TListEl("(" a ")",1),1); goto eval// A list may or may not have a listend element;// any element with no cdr is automatically end-of-list.enum TLEType {nonquoting=0, quoting=1, pointer=2, listend=3};enum TCompress {notcompressed=0, normalint=1};class TListEl;TListEl** ListElList;int debugov=1;// Debug levels:// 3: Display memory allocation and 2// 2: Display program state every step, pressing [Return]// 1: Display program state every step, not pausing// 0: Don't debugclass TListEl{public: // Data TListEl* car; //first child TListEl* cdr; //next sibling TListEl* uncar; //parent if first child; either parent or 0 if younger child TListEl* uncdr; //previous sibling TListEl* pointsto; //target of pointer here TLEType LEType; //quoting, nonquoting, pointer, listend TCompress compressed; //what compression scheme is used here? unsigned long compressedto; //data used by compressor // Memory management int gcstatus; size_t lelpos; TListEl* copiedto; // Helper functions void ClearPointers(void) { car=cdr=uncar=uncdr=pointsto=copiedto=0; }; void MarkGC(int m, int p); void PointerUpdate(int m); void Decompress(void); void EnsureCar(void); void EnsureCdr(void); void EnsureUncar(void); void Collapse(void); // Output string ToString(int,TListEl*,TListEl*); // Construction, destruction, and allocation TListEl(void) { ClearPointers(); compressed=normalint; compressedto=1; gcstatus=0; LEType=nonquoting; }; TListEl(TListEl* copyfrom,int); TListEl(TListEl* pointsto); TListEl(const char*,int); TListEl(const unsigned long,TLEType); void* operator new(size_t sz); void operator delete(void* p); operator unsigned long(void);};TListEl::operator unsigned long(void){ if(compressed==normalint) return compressedto; else if(car) { unsigned long pbil[200]; int pbilloc=1; pbil[0]=1; TListEl* t=car; while(t&&t->LEType!=listend) { switch(((unsigned long)*t)-1) { case ':': pbil[pbilloc]=pbil[pbilloc-1]; pbilloc++; break; case '*': pbilloc--; pbil[pbilloc-1]+=pbil[pbilloc]; break; case 0: //assume this is () not <> for now pbil[pbilloc++]=0; break; case '!': pbilloc--; break; default: throw xmsg("ID:Number representation is too complex to work out " "its value"); } if(pbilloc>=199) throw xmsg("ID:Out of stack translating numeric value"); t=t->cdr; if(!pbilloc) throw xmsg("Err:That function can't be a number " "because it takes 2+ arguments"); } if(pbilloc==1) return pbil[0]; throw xmsg("Err:That function can't be a number because it " "returns 2+ results"); } else if(LEType==listend) {EnsureCdr(); return 1;} else throw xmsg("Err:Pointers don't have a numeric value");}void TListEl::MarkGC(int m, int p){ TListEl* tailrec=this; //optimize tail-recursion by hand TListEl* t; while(tailrec) { t=tailrec; tailrec=0; if(!(t->gcstatus&m)) //prevent garbage-collection loop { t->gcstatus|=m; if(t->car) tailrec=t->car; if(t->cdr) {if(tailrec) tailrec->MarkGC(m,p); tailrec=t->cdr;} } if(p&&t->pointsto&&t->LEType==pointer) { if(tailrec) tailrec->MarkGC(m,p); t->pointsto->gcstatus|=p; tailrec=t->pointsto; while(tailrec->uncar||tailrec->uncdr) { if(tailrec->uncar) tailrec=tailrec->uncar; if(tailrec->uncdr) tailrec=tailrec->uncdr; } } }}void TListEl::Collapse(void){ TListEl* t=this; int instars=1; unsigned long starcount=0; while(t) { if(t->car) t->car->Collapse(); //recurse if(instars==2) { //can't collapse this, look for sublists to collapse t=t->cdr; continue; } if(t->gcstatus&8) instars=2; // there's something pointing here; can't collapse it else if(t->LEType==pointer||t->LEType==listend) instars=2; // not a list else if(t->compressed==normalint&&t->compressedto==NORMALNUMCHAR1+1&& instars) starcount++; else if(t->compressed==normalint&&t->compressedto==NORMALNUMCHAR2+1&& starcount) { instars=0; starcount--; if(!starcount&&(!t->cdr||t->cdr->LEType==listend)) { // identified a number while(t->compressedto==NORMALNUMCHAR2+1) { t=t->uncdr; if(!t) throw xmsg("IE:Notational collapser has got confused"); starcount++; } //uncar will be the list that contains this element //(which is getting collapsed); this element will be destroyed //in the next garbage collection uncar->compressedto=starcount+1; uncar->compressed=normalint; uncar->car=0; if(debugov>=3) cerr << "Collapsing list to number $" << hex << starcount+1 << "; "; return; // this list no longer exists } else if(!starcount) instars=2; } else instars=2; t=t->cdr; }}void TListEl::PointerUpdate(int m){ TListEl* tailrec=this; //optimize tail-recursion by hand TListEl* t; while(tailrec) { t=tailrec; tailrec=0; if(t->pointsto&&(t->pointsto->gcstatus&m)&&t->copiedto&&t->pointsto->copiedto) { if(debugov>=3) { cerr << "Updating pointer: [_0" << hex << t->lelpos << "] pointing to ]_0" << t->pointsto->lelpos << "[ which was copied to [_0" << t->pointsto->copiedto->lelpos << "]; original copied to [_0" << t->copiedto->lelpos << "]. "; } t->copiedto->pointsto=t->pointsto->copiedto; } if(t->car) tailrec=t->car; if(t->cdr) {if(tailrec) tailrec->PointerUpdate(m); tailrec=t->cdr;} }}void TListEl::Decompress(void){ if(compressed!=normalint||(LEType!=nonquoting&&LEType!=quoting)) return; compressed=notcompressed; if(!compressedto) { // wmw-dependent car=new TListEl('!'+1,nonquoting); car->uncar=this; car->cdr=new TListEl(1,quoting); car->cdr->uncdr=car; car->cdr->uncar=this; return; } compressedto--; if(!compressedto) { car=new TListEl; car->LEType=listend; car->uncar=this; return; } string s; unsigned long ul=compressedto; while(ul--) s+=NORMALNUMCHAR1; while(compressedto--) s+=NORMALNUMCHAR2; car=new TListEl(s.c_str(),0); TListEl* e=car; while(e) {e->uncar=this; e=e->cdr;}}void TListEl::EnsureCar(void){ Decompress(); if(!car) { if(LEType==pointer) { LEType=nonquoting; car=new TListEl; car->LEType=pointer; car->pointsto=pointsto; car->uncar=this; pointsto=0; } else if(LEType==listend) { LEType=nonquoting; compressed=normalint; compressedto=1; Decompress(); } else throw xmsg("IE:car pointer has gone missing in EnsureCar"); }}void TListEl::EnsureCdr(void){ if(cdr) return; if(LEType==listend) { LEType=nonquoting; compressed=normalint; compressedto=1; } cdr=new TListEl; cdr->uncdr=this; cdr->LEType=listend; cdr->uncar=this->uncar;}void TListEl::EnsureUncar(void){ TListEl* temp=this; while(temp->uncdr) temp=temp->uncdr; if(!(temp->uncar)) { temp->uncar=new TListEl(1,quoting); temp->uncar->car=temp; temp->uncar->compressed=notcompressed; } uncar=temp->uncar;}void* TListEl::operator new(size_t sz){ void* a=malloc(sz); if(!a) throw xmsg("ID:Out of memory"); size_t i=MYHEAPSIZE; while(i--) {if(!ListElList[i]) break;} if(i==((size_t)0-(size_t)1)) throw xmsg("ID:Too many TListEls allocated"); ((TListEl*)a)->lelpos=i; ListElList[i]=(TListEl*)a; if(DEBUGOV>=3) cerr << "Allocate [_0" << hex << i << "]; "; return a;}void TListEl::operator delete(void* p){ if(!p) return; if(DEBUGOV>=3) cerr << "Free [_0" << hex << ((TListEl*)p)->lelpos << "]; "; ListElList[((TListEl*)p)->lelpos]=0; free(p);}void ClearGC(void);// Creates a pointer TListEl.TListEl::TListEl(TListEl* newtarget){ ClearPointers(); LEType=pointer; compressed=notcompressed; pointsto=newtarget; gcstatus=0;}// Copy constructor. Make a duplicate of the list with internal// pointers updated. This uses pointers rather than references, to// simplify things (in this situation, pointers are simpler than// references).TListEl::TListEl(TListEl* copyfrom, int dogcstatus){ ClearPointers(); if(dogcstatus) {ClearGC(); copyfrom->MarkGC(4,0);} copyfrom->copiedto=this; if(copyfrom->car) car=new TListEl(copyfrom->car,0); if(copyfrom->cdr&&!dogcstatus) cdr=new TListEl(copyfrom->cdr,0); if(debugov>=3) cerr << "Copied [_0" << hex << copyfrom->lelpos << "] to [_0" << lelpos << "]; "; LEType=copyfrom->LEType; compressed=copyfrom->compressed; compressedto=copyfrom->compressedto; if(car) car->uncar=this; if(cdr) cdr->uncdr=this; pointsto=copyfrom->pointsto; if(dogcstatus) { copyfrom->PointerUpdate(4); if(dogcstatus!=2) ClearGC(); } gcstatus=0;}//Create a ListEl, not connected to anything, that represents an integer/char.TListEl::TListEl(const unsigned long i, TLEType q){ ClearPointers(); compressed=normalint; compressedto=i; gcstatus=0; LEType=q;}//Translate a string into a set of ListEls. Parsed syntax://Most characters represent a nonquoting integer of their character code plus 1.//A double-quote is an instruction to take the next character literally.//Quoting sublists are in parentheses, nonquoting sublists are between angle brackets.//Square brackets are used for various abbreviations:// ]pointer[ points to [pointer target]// [(comment)] is ignored altogether// [#44] represents the string for a number; so ([#56]) is quoting 56, and// <[#92]> is nonquoting 92.// [$1b] represents the string for a number, but in hexadecimal.// The value of parse determines whether these characters are parsed or not.// If it's 0, a ListEl representing the input string (rather than one represented by// the input string) is returned.TListEl::TListEl(const char* s, int parse){ TListEl* temp; ClearPointers(); LEType=nonquoting; if(parse) { if(*s=='\"') s++; else if(*s==')'||*s=='>'||!*s) {LEType=listend; gcstatus=0; return;} else if(*s=='('||*s=='<') { int brackmatch=1; if(*s=='(') LEType=quoting; car=new TListEl(s+1,parse); temp=car; while(temp) {temp->uncar=this; temp=temp->cdr;} compressed=notcompressed; while(brackmatch) { s++; if(*s=='\"') {s++; if(*s) continue;} if(*s=='('||*s=='<') brackmatch++; if(*s==')'||*s=='>') brackmatch--; if(*s=='[') while(*s!=']'&&*s) s++; if(!*s) throw xmsg("Err:Unexpected end of string when parsing " "(check brackets are matched)"); } } else if(*s=='[') { if(!s[1]) throw xmsg("Err: Unmatched '[' at end of program"); else if(s[1]=='(') { int brackmatch=1; while(brackmatch) { s++; if(*s=='\"') {s++; if(*s) continue;} if(*s=='('||*s=='<'||*s=='[') brackmatch++; if(*s==')'||*s=='>'||*s==']') brackmatch--; if(!*s) throw xmsg("Err:Unexpected end of string in comment " "(check brackets are matched)"); } s++; } else throw xmsg("ID:Unimplemented '[' directive"); } } if(!car) { compressed=normalint; compressedto=*s+1; } else compressed=notcompressed; gcstatus=0; if(*(s+1)) cdr=new TListEl(s+1,parse); if(cdr) {cdr->uncdr=this; cdr->uncar=uncar;}}// The opposite. If parsed is 0, the ListEl is forced to represent a string;// if it's 1, a string representing the ListEl is returned.string TListEl::ToString(int parsed, TListEl* ip, TListEl* su){ string s; TListEl* curel=this; static char buf[50]; //easily enough to hold a decimal 64-bit number while(curel) //this would be better done with recursion but most compilers { //don't optimize tail-recursion, so it's done by hand if(parsed) { if(curel->gcstatus&8) { sprintf(buf+1,"%lx",(unsigned long)(curel->lelpos)); *buf='0'; s+=string("[_")+string(buf)+string("]"); } if(curel==ip) s+=string("[_ip]"); if(curel==su) s+=string("[_stack]"); if(curel->LEType==nonquoting&&curel->car) s+=string("<")+curel->car->ToString(1,ip,su)+string(">"); else if(curel->LEType==quoting&&curel->car) s+=string("(")+curel->car->ToString(1,ip,su)+string(")"); else if(curel->LEType==listend) ; //do nothing, listends are invisible else if(curel->compressed==normalint&&(curel->LEType==quoting|| curel->LEType==nonquoting)) { // If it's printable and nonquoting, just output it as a character, // otherwise as a number representation if(curel->LEType==nonquoting&&isprint(curel->compressedto-1)) { switch(curel->compressedto-1) { case '<':case '>':case '(':case ')':case '[':case ']':case '\"': s+=(char)'\"'; break; } s+=(char)(curel->compressedto-1); } else if(curel->compressedto==1) { if(curel->LEType==nonquoting) s+=string("<>"); else if(curel->LEType==quoting) s+=string("()"); else throw xmsg("IE:Impossible compression to 1 in a ListEl"); } else { sprintf(buf,"%lx",curel->compressedto); if(curel->LEType==nonquoting) s+=string("<[$")+string(buf)+string("]>"); else if(curel->LEType==quoting) s+=string("([$")+string(buf)+string("])"); else throw xmsg("IE:Impossible compression method in a ListEl"); } } else if(curel->LEType==pointer) { sprintf(buf+1,"%lx",(unsigned long)(curel->pointsto->lelpos)); *buf='0'; s+=string("]_")+string(buf)+string("["); } else throw xmsg(string("IE:car pointer has gone missing")); } else { if(curel->LEType==pointer) { //output what's at the other end of the pointer as a string curel->pointsto->EnsureCar(); s+=curel->pointsto->car->ToString(0,0,0); } else if(curel->LEType==listend) ; //do nothing in this situation else s+=(char)(((unsigned long)*curel)-1); } curel=curel->cdr; } return s;}void ClearGC(void){ size_t ul; ul=MYHEAPSIZE; while(ul--) if(ListElList[ul]) { ListElList[ul]->gcstatus=0; ListElList[ul]->copiedto=0; }}void GCollect(TListEl* su, TListEl* ip){ size_t ul; ul=MYHEAPSIZE; //Find the outermost containing list of the ip while(ip&&(ip->uncdr||ip->uncar)) { if(ip->uncdr) ip=ip->uncdr; if(ip->uncar) ip=ip->uncar; } while(su&&(su->uncdr||su->uncar)) { if(su->uncdr) su=su->uncdr; if(su->uncar) su=su->uncar; } su->EnsureCar(); ClearGC(); if(ip) ip->MarkGC(1,8); su->MarkGC(2,8); while(ul--) if(ListElList[ul]&&!ListElList[ul]->gcstatus) delete ListElList[ul];}void CollapseNumbers(void){ size_t ul; ul=MYHEAPSIZE; while(ul--) { if(ListElList[ul]&&!ListElList[ul]->uncar&&!ListElList[ul]->uncdr) ListElList[ul]->Collapse(); }}void InsBefore(TListEl** before, TListEl* source, int repoint){ TListEl* newcopy=new TListEl(source,1); TListEl* temp; if(newcopy->LEType==listend) { newcopy->LEType=nonquoting; newcopy->compressed=normalint; newcopy->compressedto=1; } newcopy->uncdr=(*before)->uncdr; newcopy->cdr=*before; (*before)->uncdr=newcopy; if(newcopy->uncdr) newcopy->uncdr->cdr=newcopy; newcopy->uncar=(*before)->uncar; if(newcopy->uncar) if(newcopy->uncar->car==*before) newcopy->uncar->car=newcopy; temp=newcopy; while(temp) {temp->uncar=newcopy->uncar; temp=temp->cdr;} if(repoint) *before=newcopy;}void Detach(TListEl* target){ if(target->uncdr) target->uncdr->cdr=target->cdr; if(target->cdr) target->cdr->uncdr=target->uncdr; if(target->uncar) if(target->uncar->car==target) { target->uncar->car=target->cdr; target->cdr->uncar=target->uncar; if(!target->cdr) { target->uncar->car=new TListEl; target->uncar->car->LEType=listend; //must be something in a list } } target->uncar=target->uncdr=target->cdr=0;}TListEl* NextIp(TListEl** /*su*/, TListEl** ip){ if(!*ip) return 0; if((*ip)->LEType==listend) return 0; (*ip)->EnsureCdr(); return (*ip)->cdr;}static int pointerfrozen=0;void RunCommand(unsigned long cmd, TListEl** su, TListEl** ip){ TListEl* temp, *temp2, *temp3, *temp4; unsigned long tempul; int tempch; if(cmd==0) throw xmsg("Err:Executing nonquoting list with value 0"); switch(cmd-1) //wmw-dependent { // Intrinsic commands case 'A': //move pointer to its car, or replace list with its car if(ITOS->LEType==pointer&&!pointerfrozen) { ITOS->pointsto->EnsureCar(); ITOS->pointsto=ITOS->pointsto->car; } else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) { ITOS->car->pointsto->EnsureCar(); ITOS->car->pointsto=ITOS->car->pointsto->car; } else { ITOS->EnsureCar(); temp=ITOS; Detach(ITOS); InsBefore(&ITOS,temp->car,1); } break; case 'D': //move pointer to its cdr, or replace list with its cdr if(ITOS->LEType==pointer&&!pointerfrozen) { ITOS->pointsto->EnsureCdr(); ITOS->pointsto=ITOS->pointsto->cdr; } else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) { ITOS->car->pointsto->EnsureCdr(); ITOS->car->pointsto=ITOS->car->pointsto->cdr; } else { ITOS->EnsureCar(); ITOS->car->EnsureCdr(); Detach(ITOS->car); //leaving only the cdr behind } break; case 'd': //move pointer to its uncdr, or to end if it's at the start if(ITOS->LEType==pointer&&!pointerfrozen) { if(ITOS->pointsto->uncdr) ITOS->pointsto=ITOS->pointsto->uncdr; else while(ITOS->pointsto->LEType!=listend) { ITOS->pointsto->EnsureCdr(); ITOS->pointsto=ITOS->pointsto->cdr; } } else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) { if(ITOS->car->pointsto->uncdr) ITOS->car->pointsto=ITOS->car->pointsto->uncdr; else while(ITOS->car->pointsto->LEType!=listend) { ITOS->car->pointsto->EnsureCdr(); ITOS->car->pointsto=ITOS->car->pointsto->cdr; } } else throw xmsg("Err:Attempted 'd' on a nonpointer or frozen pointer"); break; case 'a': //move pointer to its uncar, or quote a list if(ITOS->LEType==pointer&&!pointerfrozen) { ITOS->pointsto->EnsureUncar(); ITOS->pointsto=ITOS->pointsto->uncar; } else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) { ITOS->car->pointsto->EnsureUncar(); ITOS->car->pointsto=ITOS->car->pointsto->uncar; } else { temp=ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(1,quoting),1); ITOS->EnsureCar(); ITOS->car=temp; temp->uncar=ITOS; temp->cdr=0; } break; case ',': //return a pointer to the IP temp=new TListEl; temp->LEType=pointer; temp->pointsto=*ip; temp2=new TListEl; temp2->compressed=notcompressed; temp2->LEType=quoting; temp2->car=temp; temp->uncar=temp2; InsBefore(&ITOS,temp2,1); break; case '.': //return a pointer to the SP if(!pointerfrozen) { temp=new TListEl; temp->LEType=pointer; temp->pointsto=ITOS; temp2=new TListEl; temp2->compressed=notcompressed; temp2->LEType=quoting; temp2->car=temp; temp->uncar=temp2; InsBefore(&ITOS,temp2,1); } else { temp=ITOS; if(temp->LEType!=pointer&&temp->car&& (!temp->car->cdr||temp->car->cdr->LEType==listend)) temp=temp->car; if(temp->LEType!=pointer||!(temp->pointsto)) throw xmsg("Err:Attempted '.' on a nonpointer with frozen pointers"); temp=temp->pointsto; Detach(ITOS); temp->EnsureUncar(); *su=temp->uncar; //change the stack } break; case '*': //concat second element before first ITOS->EnsureCdr(); ITOS->cdr->EnsureCdr(); ITOS->EnsureCar(); ITOS->cdr->EnsureCar(); temp=ITOS->cdr->car; if(temp->LEType==listend) { Detach(ITOS->cdr); //destroy the second element of the stack, and we're done break; } while(temp->cdr) temp=temp->cdr; if(temp->LEType==listend) {temp=temp->uncdr; Detach(temp->cdr);} temp->cdr=ITOS->car; Detach(ITOS); temp->cdr->uncdr=temp; while(temp) {temp->uncar=ITOS; temp=temp->cdr;} break; case '^': //eval eval: ITOS->EnsureCar(); temp=ITOS->car; while(temp->cdr) temp=temp->cdr; if(temp->LEType!=listend) {temp->EnsureCdr(); temp=temp->cdr;} temp->LEType=pointer; temp->pointsto=NextIp(su,ip); if(temp->pointsto->LEType==pointer) temp->pointsto=temp->pointsto->pointsto; *ip=ITOS->car; Detach(ITOS); return; case '~': //swap ITOS->EnsureCdr(); ITOS->cdr->EnsureCdr(); if(ITOS->cdr->cdr) ITOS->cdr->cdr->uncdr=ITOS; temp=ITOS->cdr->cdr; temp2=ITOS->cdr; temp2->cdr=ITOS; ITOS->cdr=temp; temp2->uncdr=0; ITOS->uncdr=temp2; temp2->uncar=*su; ITOS=temp2; break; case '@': //deep swap ITOS->EnsureCdr(); ITOS->cdr->EnsureCdr(); ITOS->cdr->cdr->EnsureCdr(); temp=ITOS->cdr; temp2=ITOS->cdr->cdr; if(temp2->cdr) temp2->cdr->uncdr=temp; temp->cdr=temp2->cdr; temp->uncdr=temp2; temp2->cdr=temp; temp2->uncdr=ITOS; ITOS->cdr=temp2; break; case '?': //read via pointer if(ITOS->LEType==pointer&&!pointerfrozen) { temp=ITOS->pointsto; Detach(ITOS); InsBefore(&ITOS,temp,1); } else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) { temp=ITOS->car->pointsto; Detach(ITOS); InsBefore(&ITOS,temp,1); } else { throw xmsg("Err:Non-pointer input to '?'"); } break; case '=': //write via pointer temp=0; if(ITOS->LEType==pointer&&!pointerfrozen) temp=ITOS->pointsto; else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) temp=ITOS->car->pointsto; if(!temp) throw xmsg("Err:Non-pointer input to '='"); Detach(ITOS); temp->EnsureCdr(); temp2=temp->cdr; Detach(temp); InsBefore(&temp2,ITOS,1); Detach(ITOS); break; case '/': //insert SE2 before TOS's target temp=0; if(ITOS->LEType==pointer&&!pointerfrozen) temp=ITOS->pointsto; else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) temp=ITOS->car->pointsto; if(!temp) throw xmsg("Err:Non-pointer input to '/'"); Detach(ITOS); InsBefore(&temp,ITOS,1); Detach(ITOS); break; case '\\': //detach TOS's target temp=0; if(ITOS->LEType==pointer&&!pointerfrozen) temp=ITOS->pointsto; else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) temp=ITOS->car->pointsto; if(!temp) throw xmsg("Err:Non-pointer input to '\\'"); Detach(ITOS); Detach(temp); break; case 'z': // modify next instruction (freeze pointers) pointerfrozen = 2; break; case 'i': // input one character tempch=getchar(); if(tempch==EOF) tempul=0; else tempul=(unsigned long)((unsigned char)(tempch))+1; InsBefore(&ITOS,new TListEl(tempul,nonquoting),1); break; case 'o': // output one character tempul=(unsigned long)*ITOS; if(!tempul) { *ip=0; return; } putchar(tempul-1); fflush(stdout); //for slow programs without newlines Detach(ITOS); break; case 'c': // call/cc tempul=MYHEAPSIZE; temp2=0; // The purpose of this loop is to link all top-level lists together // into one mega-list that contains all information about the program. GCollect(*su,*ip); temp3=NextIp(su,ip); while(tempul--) { if(ListElList[tempul]&&!(ListElList[tempul]->gcstatus&128)&& (!ListElList[tempul]->uncar)&&(!ListElList[tempul]->uncdr)) { temp=new TListEl(1,quoting); temp->car=ListElList[tempul]; ListElList[tempul]->uncar=temp; temp->compressed=notcompressed; //we need to quote each list temp->gcstatus=128; //prevent an infinite loop if(temp2) { temp2->uncdr=temp; temp->cdr=temp2; } temp2=temp; } } temp=new TListEl(1,quoting); temp->car=temp2; temp->compressed=notcompressed; temp2->uncar=temp; GCollect(temp,*ip); //include temp (which contains the stack) in this temp2=new TListEl(temp,2); //Copy, updating pointers, keeping GC info temp->car->uncar=0; temp=temp->car; //the old temp's getting garbage-collected //Dequote and delink all the temporarily-linked lists while(temp) { temp->car->uncar=0; temp->car=0; temp=temp->cdr; } //To make the copied state into a continuation, we need to append a //copy of the IP at the end, prepend each list with z and follow it //with z!, and before the IP put code to set the stack pointer to what //we want. The copiedto info is still valid and will let us know what //the old stack and IP correspond to in the new list. Code is also //included to retain TOS through the call, so the continuation can //return a value. temp=(*su)->copiedto; temp3=temp3->copiedto; ClearGC(); //GC clear delayed to this point temp4=temp2->car; //Append a z! to every list while(temp4->LEType!=listend) { temp4->EnsureCdr(); InsBefore(&temp4,new TListEl('z'+1,nonquoting),0); temp4=temp4->cdr; InsBefore(&temp4,new TListEl('z'+1,nonquoting),0); InsBefore(&temp4,new TListEl('!'+1,nonquoting),0); } InsBefore(&temp4,new TListEl(1,quoting),1); temp4->EnsureCar(); InsBefore(&(temp4->car), new TListEl(temp), 1); temp4=temp4->cdr; InsBefore(&temp4, new TListEl(':'+1,nonquoting),0); InsBefore(&temp4, new TListEl('A'+1,nonquoting),0); InsBefore(&temp4, new TListEl('@'+1,nonquoting),0); InsBefore(&temp4, new TListEl('='+1,nonquoting),0); InsBefore(&temp4, new TListEl('A'+1,nonquoting),0); InsBefore(&temp4, new TListEl('z'+1,nonquoting),0); InsBefore(&temp4, new TListEl('.'+1,nonquoting),0); InsBefore(&temp4, new TListEl(temp3),0); // Move the most-of-a-continuation created rather than the usual copy // (we know nothing outside the continuation is pointing to it) ITOS->uncdr=temp2; temp2->cdr=ITOS; ITOS=temp2; temp2->uncar=*su; // and finally, eval the old TOS. OVCMD(~^); // break; implied by OVCMD case 'C': // capture the state of the program InsBefore(&ITOS,new TListEl(1,quoting),1); ITOS->EnsureCar(); tempul=MYHEAPSIZE; while(tempul--) { if(ListElList[tempul]&& (!ListElList[tempul]->uncar)&&(!ListElList[tempul]->uncdr)) { temp=new TListEl(1,quoting); InsBefore(&(ITOS->car),temp,1); delete temp; // We can't rely on auto-garbage-collect for this, because // we're messing with the garbage collector to compile the list. ITOS->car->LEType=pointer; ITOS->car->compressed=notcompressed; ITOS->car->pointsto=ListElList[tempul]; } } break; // Debug commands case 27: debugov=(unsigned long)*ITOS; Detach(ITOS); break; // Commands with multiple functions, some of which are intrinsic, // or where intrinsic code is used to tell between them case 'L': temp=0; if(ITOS->LEType==pointer&&!pointerfrozen) temp=ITOS->pointsto; else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) temp=ITOS->car->pointsto; if(!temp) temp=ITOS; temp->EnsureCar(); temp=temp->car; tempul=0; while(temp&&temp->LEType!=listend) { temp=temp->cdr; tempul++; } Detach(ITOS); InsBefore(&ITOS,new TListEl(tempul,quoting),1); break; case '-': // numeric subtraction or pointer difference temp=0; if(ITOS->LEType==pointer&&!pointerfrozen) temp=ITOS->pointsto; else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) temp=ITOS->car->pointsto; if(!temp) { //numeric subtraction ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); ITOS->EnsureCdr(); if((unsigned long)*ITOS<=tempul) tempul=0; else tempul=(unsigned long)*ITOS-tempul; Detach(ITOS); InsBefore(&ITOS,new TListEl(tempul,quoting),1); break; } Detach(ITOS); //pointer difference if(ITOS->LEType==pointer&&!pointerfrozen) temp2=ITOS->pointsto; else if((ITOS->LEType==quoting||ITOS->LEType==nonquoting)&& ITOS->car&&ITOS->car->LEType==pointer&&!pointerfrozen) temp2=ITOS->car->pointsto; else throw xmsg("Err:Top two stack elements must be both pointers or " "both not pointers in '-'"); Detach(ITOS); tempul=0; while(temp!=temp2) { if(!(temp->cdr)||temp->LEType==listend) { tempul=0; break; } tempul++; temp=temp->cdr; } InsBefore(&ITOS,new TListEl(tempul,quoting),1); break; // Optimized non-intrinsic commands case '\'': // quote one element *ip=NextIp(su,ip); InsBefore(&ITOS,new TListEl(1,quoting),1); ITOS->EnsureCar(); InsBefore(&(ITOS->car),*ip,1); break; case ':': // duplicate ITOS->EnsureCdr(); InsBefore(&ITOS,ITOS,1); break; case '!': // pop ITOS->EnsureCdr(); temp=ITOS; Detach(ITOS); if(pointerfrozen&&temp->LEType==quoting||temp->LEType==nonquoting) { //Undelimit the list temp->EnsureCar(); temp2=temp->car; while(temp2) { temp2->uncar=0; temp2=temp2->cdr; } temp->car=0; temp->compressed=normalint; temp->compressedto=1; } break; case '0': InsBefore(&ITOS,new TListEl(0,quoting),1); break; //push a 0 case '1': InsBefore(&ITOS,new TListEl(1,quoting),1); break; //push a 1 case '2': InsBefore(&ITOS,new TListEl(2,quoting),1); break; //push a 2 case '3': InsBefore(&ITOS,new TListEl(3,quoting),1); break; //push a 3 case '4': InsBefore(&ITOS,new TListEl(4,quoting),1); break; //push a 4 case '5': InsBefore(&ITOS,new TListEl(5,quoting),1); break; //push a 5 case '6': InsBefore(&ITOS,new TListEl(6,quoting),1); break; //push a 6 case '7': InsBefore(&ITOS,new TListEl(7,quoting),1); break; //push a 7 case '8': InsBefore(&ITOS,new TListEl(8,quoting),1); break; //push an 8 case '9': InsBefore(&ITOS,new TListEl(9,quoting),1); break; //push a 9 case 'S': //output ITOS as a string ITOS->EnsureCar(); cout << ITOS->car->ToString(0,0,0); Detach(ITOS); break; case 'n': cout << (char)'\n'; break; //output a newline case 'p': //deparse a list into a string. Doesn't include the //delimiters of the list itself. ITOS->EnsureCar(); temp=ITOS->car; Detach(ITOS); temp=new TListEl(temp->ToString(1,0,0).c_str(),0); temp2=new TListEl; temp2->compressed=notcompressed; temp2->LEType=quoting; temp2->car=temp; temp->uncar=temp2; InsBefore(&ITOS,temp2,1); break; case 'P': //parse a string into a list ITOS->EnsureCar(); temp=ITOS->car; Detach(ITOS); temp=new TListEl(temp->ToString(0,0,0).c_str(),1); temp->EnsureUncar(); InsBefore(&ITOS,temp->uncar,1); break; case 'V': //input a number tempul=0; tempch='0'; while(isdigit(tempch)) { tempul*=10; tempul+=tempch-'0'; tempch=getchar(); } ungetc(tempch,stdin); InsBefore(&ITOS,new TListEl(tempul,quoting),1); break; case 'v': //output a number ITOS->EnsureCdr(); cout << dec << (unsigned long)*ITOS; Detach(ITOS); break; case 'O': // x 10 ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(tempul*10,quoting),1); break; case '}': // increment ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(tempul+1,quoting),1); break; case '{': // decrement ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(tempul?tempul-1:0,quoting),1); break; case 'g': // negate ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(!tempul,quoting),1); break; case '+': // numeric addition ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); ITOS->EnsureCdr(); tempul+=(unsigned long)*ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(tempul,quoting),1); break; case 'U': // upto (based at 1) ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(1,quoting),1); ITOS->EnsureCar(); tempul++; while(--tempul) InsBefore(&(ITOS->car), new TListEl(tempul,quoting),1); break; case 'u': // upto (based at 0) ITOS->EnsureCdr(); tempul=(unsigned long)*ITOS; Detach(ITOS); InsBefore(&ITOS,new TListEl(1,quoting),1); ITOS->EnsureCar(); tempul++; while(tempul--) InsBefore(&(ITOS->car), new TListEl(tempul,quoting),1); break; case 't': // totalling loop, doesn't quote ITOS->EnsureCdr(); ITOS->cdr->EnsureCar(); ITOS->cdr->EnsureCdr(); temp=ITOS->cdr; ITOS->cdr=temp->car; temp2=temp->car; temp2->uncdr=ITOS; tempul=0; while(temp2->LEType!=listend) { temp2->uncar=ITOS->uncar; temp2->EnsureCdr(); temp2=temp2->cdr; tempul++; } if(tempul) tempul--; temp2->uncdr->cdr=temp->cdr; temp->cdr->uncdr=temp2->uncdr; temp->car=temp->cdr=temp->uncar=temp->uncdr=0; temp->compressed=normalint; temp->compressedto=1; temp2->car=temp2->cdr=temp2->uncar=temp2->uncdr=0; temp2->compressed=normalint; temp2->compressedto=1; InsBefore(&ITOS,new TListEl(tempul,quoting),1); InsBefore(&ITOS,new TListEl("(^^)",1),1); goto eval; case 'T': // totalling loop, quotes ITOS->EnsureCdr(); ITOS->cdr->EnsureCar(); temp=ITOS->cdr->car; temp2=ITOS->cdr; tempul=0; while(temp&&temp->LEType!=listend) { InsBefore(&temp2,new TListEl(1,quoting),0); temp2->uncdr->car=temp; temp2->uncdr->compressed=notcompressed; temp->uncar=temp2->uncdr; temp->uncdr=0; tempul++; temp=temp->cdr; if(temp) temp->uncdr->cdr=0; } temp2->car=0; temp2->compressed=normalint; temp2->compressedto=1; Detach(temp2); if(tempul) tempul--; InsBefore(&ITOS,new TListEl(tempul,quoting),1); InsBefore(&ITOS,new TListEl("(^^)",1),1); goto eval; case ';': //numeric wimpmode temp=ITOS; while(temp->LEType!=pointer&&!(temp->car&&temp->car->LEType==pointer)) { temp=temp->cdr; //Note: cdr isn't ensured here if(!temp) throw xmsg("Err: No pointers on stack in ; command"); } tempul=0; while(temp->uncdr) { temp=temp->uncdr; Detach(temp->cdr); tempul*=10; tempul+=(unsigned long)*temp; } Detach(temp); InsBefore(&ITOS,new TListEl(tempul,quoting),1); break; // Non-optimized non-intrinsic commands case '`': OVCMD(~^); //apply case '&': OVCMD(~*); //swapconcat case 'l': OVCMD(.A*^); // infinite loop the TOS case 'w': OVCMD(.Aza*(~:@^^!)*^); // do-while-loop the TOS, normal case 'W': OVCMD(.Aza*(`^)*^); //do-while-loop the TOS, popping case 'f': OVCMD(`^); // repeat the TOS SE2 times case 'N': OVCMD(0+); //normalize case 'e': //each-loop (C++ \\ is Overload \) OVCMD2("1.~!za*(zA)&(Ad/')*:a'~&(&*)*@T''&&.Add:d\\\\(:@/a?)*^"); case 's': OVCMD2("':&'~*a(&'`*)*"); //curried substituted application case 'k': OVCMD2("a'!&"); //constant-function generator case '_': OVCMD2("~zaza'z&'A**^"); //dip case 'I': OVCMD2("g'~~^^"); //swap-if case 'x': OVCMD2("H.aDA~'Df?"); //read variable case 'X': OVCMD2("H.aDA~'Df="); //write variable#if 0 case 'O': OVCMD(25**); // times 10 case '}': OVCMD((:)~*(*)*); // increment case '{': OVCMD(:(:)`(!!()())*~(*)`*); //decrement case '+': OVCMD2("(})f"); // addition#endif } if(pointerfrozen>0) pointerfrozen--; *ip=NextIp(su,ip);}int main(int argc, char** argv){ size_t ul; ListElList=new TListEl*[MYHEAPSIZE]; ul=MYHEAPSIZE; while(ul--) ListElList[ul]=0; // End of initialisation try { TListEl* su=new TListEl; //starts empty string prgf; FILE* in; if(argc>1&&(*argv[1]!='-'||argv[1][1])) in=fopen(argv[1],"r"); else in=stdin; { int c; if(!in) throw xmsg(string("Err:Can't open '")+string(argv[1])+ string("'")); while((c=getc(in))>0) prgf+=(char)c; fclose(in); } if(in!=stdin) fclose(in); if(argc>2) sscanf(argv[2],"%d",&debugov); TListEl* program=new TListEl(prgf.c_str(),1); TListEl* ip=program; TListEl* temp; GCollect(su,ip); while(ip&&ip->LEType!=listend) { if(ip->LEType==quoting) { if(pointerfrozen) { temp=ip; ip=NextIp(&su,&ip); temp->EnsureCdr(); if(temp->uncdr) temp->uncdr->cdr=temp->cdr; else if(temp->uncar) { temp->uncar->car=temp->cdr; temp->cdr->uncar=temp->uncar; } temp->cdr->uncdr=temp->uncdr; su->car->uncdr=temp; temp->cdr=su->car; su->car=temp; temp->uncar=su; temp->uncdr=0; pointerfrozen=0; } else { InsBefore(&TOS,ip,1); ip=NextIp(&su,&ip); } } else if(ip->LEType==pointer) { ip=ip->pointsto; } else { RunCommand((unsigned long)*ip,&su,&ip); if(!ip) break; } GCollect(su,ip); ul=ip->gcstatus; ip->gcstatus&=8; //don't want this to be collapsed CollapseNumbers(); GCollect(su,ip); //second collection after collapse if(debugov>=1) { ul=MYHEAPSIZE; while(ul--) { program=ListElList[ul]; if(!program) continue; while(program->uncdr||program->uncar) { if(program->uncdr) program=program->uncdr; if(program->uncar) program=program->uncar; } if(!(program->gcstatus&16)) cerr << program->ToString(1,ip,su) << (char)'\n'; program->MarkGC(16,0); } cerr << (char)'\n'; } if(debugov>=2&&ip) getchar(); } } catch(xmsg a) { cerr << a.why() << (char)'\n'; } catch(...) { cerr << "IE:Unhandled exception (unknown type).\n"; } // Start of uninitialisation ul=MYHEAPSIZE; while(ul--) if(ListElList[ul]) delete ListElList[ul]; delete ListElList; return 0;}