// THIS IS A SURFACE TRANSLATION INTO C. IT WILL NOT RUN. // MANY SYSTEM DEPENDENCIES, AND PERHAPS SOME TRANSLATION // ERRORS (such as precedence of >> different between IMP and C) // This is more of a macro translation than a proper recompilation. #include #include #include extern void selectinput (int stream); //============================================================================ void pop2 (char *popparm) { int event (int i); // POP2 INTERPRETER FOR EMAS const char *identification = "EMAS POP2: V1.1 08/01/78"; // extern void outfile (char *s, int p1, int p2, int p3, int *connect_address, int *rc); extern char *ssfmessage (void); extern void define (char *s); extern int exist (char *s); extern void clear (char *s); extern double cputime (void); extern void prompt (char *s); extern int testint (int c, char *str); extern void e (char *s); // // REPRESENTATION OF POP2 VALUES:- // ...000 : INTEGER (TRUE VALUE * 8) // ...100 : REAL (TRUE FP VALUE WITH LS BITS FORCED) // ....10 : COMPOUND (BYTE ADDRESS OF FIRST WORD MINUS TWO) // ....01 : FUNCTION // // ....00 MAY ALSO BE PRIVATE ADDRESS // // DISCRIMINATION OF COMPOUND VALUES:- // PAIR < WORDMIN (=NIL) // WORDMIN <= WORD < STRIPMIN // STRIPMIN <= STRIP, (FUNCTION BODY) // // REPRESENTATION OF PAIR:- // 2 FRONT // 6 BACK // // REPRESENTATION OF WORD:- // 2 VALUE // 6 C1(6):C2(6):C3(6):C4(6):C5(6):0(2) C IS SYMBOL+1 // 10 C6(6):C7(6):C8(6):HASHLINK(14) (ZERO FOR NULL) // 14 TYPE(8):MEANING(24) // // REPRESENTATION OF STRIP (RECORD):- // 2 NUMBER(16):SIZE(8):CLASS(8) // 6 FIRST COMPONENT WORD // ...... // // DISCRIMINATION OF FUNCTIONS:- // 0000 0000 ....01 : COMPILED FUNCTION BODY // (BYTE ADDRESS OF FIRST WORD MINUS THREE) // XXXX XXXX ....01 : BUILT-IN FUNCTION (EXECUTABLE FORM PLUS ONE) // // POP2 CHARACTER VALUES (NOMINAL VALUE * 8) // *SYM0 = 0* const int symsp = 128, symnl = 136, syma = 264, symz = 464; const int symlp = 192, symrp = 200, symlb = 472, symrb = 488, sympc = 168; const int symminus = 232, symdot = 240, symcolon = 80; const int symla = 96, symra = 112, sym9 = 72, symquote = 144; const int symopenq = 184, symcloseq = 256, symdollar = 480; const int symsubten = 120, symend = 152; const int symnlx = 0xC0000088; // IE SYMNL + FLAG + SIGNBIT // const unsigned char isotopop[128] = { 64, 64, 64, 64, 64, 64, 64, 64, 64, 16, 17, 17, 17, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 19, 64, 64, 64, 64, 64, 64, 16, 32, 18, 20, 60, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 64, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 64, 61, 62, 64, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 64, 61, 62, 64 }; // const unsigned char poptoiso[64] = { '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', ' ', 10, 34, 25, '#', '%', '&', '\'', '(', ')', '*', '+', ',', '-', '.', '/', '!', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '$', ']', '^', ' ' }; // const int unass = 12; // IMPOSSIBLE REAL VALUE // // STRUCTURE CLASS CONSTANTS const int cstripclass = 0x18, fullstripclass = 0x1C, refclass = 0x20; const int cstripinfo = 0x618, fullstripinfo = 0x1C; const int refheader = 0x00010020; // WORD TYPE MASKS const int typebits = 0xFF000000; const int synbit = 0x80000000, canbit = 0x40000000; // *SYN IS SIGN* const int macbit = 0x20000000, closerbit = 0x20000000; // *MAC=CLOSE* const int varbits = 0x3F000000, varbit = 0x10000000; const int precbits = 0x0F000000, sigbits = 0xBF000000; // POP-MACHINE INSTRUCTION MASKS const int opbits = 0xFF000000; // * OPBITS = TYPEBITS * const int fopbits = 0xFF000001; const int adbits = 0x00FFFFFF; // POP-MACHINE OP-CODES (& RELATED FUNCTIONS) REQUIRED EXPLICITLY const int apply = 0x74000000; const int subxfun = 0x8D000001, recreffun = 0x8E000001; const int recconsfun = 0x37000001; const int store = 0xB0000000; const int not = 0x55000000, pr = 0x6B000000; const int charinfun = 0x3B000001; const int jumpfals = 0xB4000000, jumptrue = 0xB6000000; const int initxfun = 0xB2000001, recdestfun = 0xB3000001; const int charoutfun = 0xB1000001; const int loadimm = 0x30000004, getfroz = 0x31000000; const int resume = 0x28800000; const int Return = 0x20000000; const int jump = 0x34000000, jumpback = 0x35000000; const int iteminfun = 0x32000001; const int startfun = 0x21800001; // PSEUDO-OPCODES const int savemask = 0xFC000000, varsave = 0x80000000; const int insave = 0x81000000, outsave = 0x82000000; const int insavebit = 0x01000000, outsavebit = 0x02000000; // POP WORDS REQUIRED EXPLICITLY (CONSTANT ADDRESSES) // * ORDER OF DECLARATION MUST MATCH SETUP ORDER * int nil, undef, termin, terminval, false; int nonmac, lp, lb, quote, lambda, rb, dot, arrow, semicolon, colon, parrow; int function, macro, operation, Exit, close, rp, end, goon; int compil, plus, minus, primlim; int syntax, cmpnd, intgr, strip, in, out, edit; int cucharin, cucharout, proglist, debug, debsp; // // STORE BOUNDARIES (CONSTANT ADDRESSES - IN ASCENDING ORDER) int storebase, stream0, streamlim, stackmin, stacklim; int wordmin, stripmin, storelim; // OTHER CONSTANT ADDRESSES int baseprog, wordbase, zero; // STACK AND LIMIT POINTERS int itemhi, classlo, asp, sp, spbar, csp, pairlo, wordhi, striphi; int pairfree, wordfree, syslim, baseitem; // INPUT/OUTPUT STATUS VARIABLES int sym, pos, pos1, error, errpos, mon; int streammax, inref, outref, outsym; int macstream, macend, nonmacflag, intflag; // // POP-MACHINE REGISTERS int a, b, inst, pc; // BASIC MACHINE CONTEXT float xa, xb; // WORKING REGISTERS FOR REALS int codebase, pvbase; // unsigned char Char[82]; // 1:81 - ignore elem at 0 int index[128]; // // auto void execute (int fun); // auto void announce (char *s) { // ENSURE OUTPUT 0 SELECTED AND PRINT STRING S if (outref != stream0) { outref = stream0; selectoutput (0); } *(int *) (cucharout + 2) = charoutfun + stream0; if (outsym != symnl) newline (); outsym = symnl; printstring (s); } auto void croak (char *s) { // REPORT DISASTROUS ERROR char *str = malloc (strlen (s) + 4); strcpy (str, "!!!"); strcat (str, s); announce (str); free (str); exit (0); } auto int interrupt (void) { /* This is an EMAS feature which allows an asynchronous user interrupt by typing "POP". On Unix it might test for ^C having been typed. */ if ((intflag == 0) && (testint (0, "POP") == 0)) intflag = 50; return (intflag); } auto void push (int v) { // ADD V TO AUXILIARY STACK asp += 4; if (asp >= sp) signal_event(4); *(int *)asp = v; } auto void plant (int v) { // ADD V TO COMPILER STACK csp += 4; if (csp >= pairlo) signal_event(4); *(int *)csp = v; } auto void save (int v) { // ADD V TO USER STACK sp -= 4; if (sp <= asp) signal_event(4); *(int *)sp = v; } auto int saved (void) { if (sp >= spbar) signal_event(3); sp += 4; return (*(int *) (sp - 4)); } auto void seal (void) { // CREATE FALSE BOTTOM ON USER STACK sp -= 4; if (sp <= asp) signal_event(4); *(int *)sp = spbar; spbar = sp; } auto void unseal (void) { if (sp != spbar) signal_event(19); spbar = *(int *)sp; sp += 4; } auto int newclass (int dataword) { classlo -= 4; if (classlo <= itemhi) croak ("NO CLASSES"); *(int *)classlo = dataword; return (stackmin - classlo); } auto int classno (int v) { if ((v & 7) == 0) return (4); // INTEGER if ((v & 3) == 0) return (8); // REAL if ((v & 2) == 0) return (12); // FUNCTION if (v < nil) return (16); // PAIR if (v < stripmin) return (20); // WORD return (*(unsigned char *) (v + 5)); } auto void putsym (int k) { int f; f = *(int *) (cucharout + 2); if ((f & fopbits) == charoutfun) { f -= charoutfun; if (f != outref) { outref = f; selectoutput ((outref - stream0) >> 3); } if (f == stream0) outsym = k; printsymbol (poptoiso[k >> 3]); } else { save (a); save (b); seal (); save (k); execute (f); unseal (); b = saved (); a = saved (); } } auto void putint (int v) { if (v >= 10) {putint (v / 10); v = v - ((int)( v / 10)) * 10;} putsym (v << 3); } auto int charword (int w, int i) { if ((i <= 0) || (i > (8 * 8))) return (63 * 8); i = ((int)(i / 8)) * 6; if (i <= 30) i = (*(unsigned int *) (w + 6)) >> (30 - i); else i = (*(unsigned int *) (w + 10)) >> (60 - i); return (((i << 1) - (1 * 8)) & (63 * 8)); } auto char *wordtostring (int w) { char s[9]; int k, l; l = 0; while (l < 8) { k = charword (w, (l + 1) << 3); if (k == (63 * 8)) break; // WARNING: Imp strings use a length byte in elem[0] // whereas C strings use a trailing NUL. Hence l-1 below. l += 1; s[l - 1] = poptoiso[k >> 3]; } s[l] = '\0'; return (strdup (s)); } auto void putstring (int v) { int i, l; i = 0; l = (*(unsigned int *) (v + 2)) >> 16; while (l != 0) { l -= 1; i -= 6; if (i < 0) {v += 4; i = 24;} putsym (((*(unsigned int *) (v + 2)) >> i << 1) & (63 * 8)); } } auto void putreal (double x, int p, int q) { // can probably be replaced with stdio formatting int sign, r; sign = 0; if (x < 0) {x = -x; sign = symminus;} x = x + ((double) (0.5) / (double) (iexp (10, q))); // ROUND // iexp is integer raised to power of another integer r = 1; while (x >= 10) {x = ((float) (x) / (float) (10)); r += 1;} while (p > r) {p -= 1; putsym (symsp);} if (sign != 0) putsym (sign); for (r = r - 1; r >= -q; r -= 1) { // hope I got that loop right! if (r == -1) putsym (symdot); putsym (intpt (x) << 3); x = fracpt (x) * 10; } } auto void putitem (int v) { int i, c; static void *s[7] = { &&s_default, &&s_1, &&s_2, &&s_3, &&s_4, &&s_5, &&s_6 }; intflag -= 1; if ((intflag <= 0) && (interrupt () <= 0)) return; c = classno (v); if (c > cstripclass) { putsym (symla); putitem (*(int *) (stackmin - c)); putsym (symra); return; } goto *s[c >> 2]; s_1: // INTEGER v = (int) (v / 8); if (v < 0) {v = -v; putsym (symminus);} putint (v); return; s_2: // REAL v = v & (~7); putreal ((float)v, 0, 3); return; s_3: // FUNCTION if ((v & opbits) != 0) { // BUILT-IN FUNCTION v = ((unsigned int)v >> 24 << 4) + wordmin; // FUNCTION NAME if (v >= primlim) { // UPDATER: DOWNDATE v = v ^ 0x300; if (v >= 0x900) v = v ^ 0x800; putitem (arrow); } } else { putsym (symdollar); v = *(int *) (v + 7); // FNPROPS if (((v & 2) != 0) && (v < nil)) v = *(int *) (v + 2); // FRONT IF PAIR if (!(((v & 2) != 0) && ((wordmin < v) && (v < stripmin)))) return; } s_5: // WORD for (i = 1 * 8; i <= 8 * 8; i += 1 * 8) { c = charword (v, i); if (c == (63 * 8)) break; putsym (c); } return; s_6: // CSTRIP putsym (symopenq); putstring (v); putsym (symcloseq); return; s_4: // PAIR putsym (symlb); for (;;) { putitem (*(int *) (v + 2)); // FRONT v = *(int *) (v + 6); // BACK if (!(((v & 2) != 0) && (v < nil))) break; putsym (symsp); } if (v != nil) {putsym (symdot); putitem (v);} putsym (symrb); return; s_default: // Need some sort of error message output here - // 'switch label not set' exit (1); } auto void print (int v) { // FOR ERRORS -- PRINT QUOTES ROUND WORD EXCEPT NIL, ETC if (((v & 2) != 0) && ((false < v) && (v < stripmin))) { putsym (symquote); putitem (v); putsym (symquote); } else putitem (v); } auto void comment (char *s, int w) { // REPORT MINOR COMPILATION ERROR if ((outsym == symnl) || (strcmp (s, " VARS "))) announce (s); putsym (symsp); putitem (w); if (strcmp (s, " VARS ")) putsym (symnl); } auto void monitor (int p) { // PRINT FUNCTION NAME AND VARIABLES SELECTED BY MON // P IS ADDRESS OF FIRST INSTRUCTION // INSAVEBIT: INPUT VARS, OUTSAVEBIT: OUTPUT VARS, VARSAVE: ALL VARS int q; putitem (p - 15); // FUNCTION while (((*(int *)p) & savemask) == varsave) { if (((*(int *)p) & mon) != 0) { b = (*(int *)p) & adbits; // 'WORD' ASSOCIATED WITH VAR q = *(int *) (b + 2); // VALUE if (q != unass) { spaces (2); putitem (b); printsymbol ('='); print (q); } } p += 4; } putsym (symnl); } auto void forcereturn (void) { // UNSTACK ONE LEVEL (EXECUTION OR COMPILATION) if (pc >= stripmin) { // IN USER FUNCTION while (((*(int *)pc) & opbits) != Return) { // FIND (FIRST) RETURN if (((*(int *)pc) & 0xFE000000) == 0x30000000) pc += ((*(int *)pc) & adbits); // LOADIMM, GETFROZ pc += 4; } pc += 4 - ((*(int *)pc) & adbits); // FIRST INST if (mon != 0) {printstring (" IN "); monitor (pc);} while (((*(int *)pc) & savemask) == varsave) { // RESTORE VARS *(int *) (((*(int *)pc) & adbits) + 2) = *(int *)asp; asp -= 4; pc += 4; } } else { if (pc == 0) { // COMPILING if ((mon != 0) && (codebase != 0)) { printstring (" COMPILING $"); putitem (*(int *) (codebase + 4)); putsym (symnl); } csp = pvbase - 16; pvbase = *(int *) (csp + 16); codebase = *(int *) (csp + 12); *(int *) (proglist + 2) = *(int *) (csp + 8); asp = *(int *) (csp + 4); } } pc = *(int *)asp; asp -= 4; } auto int paircell (int front, int back) { int p; p = pairfree; if (p != 0) { pairfree = *(int *) (p + 2); } else { if ((pairlo - 8) <= csp) croak ("NO LIST CELLS"); pairlo -= 8; p = pairlo; } *(int *) (p + 2) = front; *(int *) (p + 6) = back; return (p); } auto int wordcell (int w1, int w2) { int p; p = wordhi; wordhi += 16; if (wordhi > stripmin) croak ("NO WORD CELLS"); *(int *) (p + 2) = unass; *(int *) (p + 6) = w1; *(int *) (p + 10) = w2; *(int *) (p + 14) = undef; return (p); } auto int wordlook (int w1, int w2) { int hash, w, p; int *q; w = w1 ^ w2; hash = 0; while (w != 0) { hash = (hash << 1) + (w & 63); w = (unsigned int)w >> 6; } q = &index[hash & 127]; while (((*q) & 0x3FFF) != 0) { p = (((*q) & 0x3FFF) << 4) + wordbase; if (((*(int *) (p + 6)) == w1) && (((*(int *) (p + 10)) & (~(0x3FFF))) == w2)) return (p); q = (int *) (p + 10); } p = wordcell (w1, w2); q += ((unsigned int)(p - wordbase) >> 4); return (p); } auto int var (int v, int type) { int t, w; t = *(int *) (v + 14); // EXISTING TYPE+MEANING if ((t & sigbits) != 0) { // V IS ALREADY VAR if ((t & canbit) == 0) return (v); return ((((*(int *) (v + 10)) & 0x3FFF) << 4) + wordbase); } if (type == 0) return (v); *(int *) (v + 14) = t | type; // MARK V AS VAR if ((t & canbit) == 0) return (v); w = wordcell (*(int *) (v + 6), *(int *) (v + 10)); // CREATE NEW PSEUDO-WORD *(int *) (w + 14) = type; *(int *) (v + 10) = ((*(int *) (v + 10)) & (~(0x3FFF))) | ((unsigned int)(w - wordbase) >> 4); return (w); } auto int stripcell (int stripinfo) { // RESULT IS ALWAYS EXISTING STRIPHI // AFTER CALL, STRIPHI IS ALWAYS AT STRIP LIMIT int k, l; k = (unsigned int)stripinfo >> 16; // NO OF COMPONENTS l = ((unsigned int)stripinfo >> 8) & 31; // COMPONENT SIZE if (l != 0) k = (int)((k - 1) / ((int)( 32 / l) + 1)); k = (k << 2) + 4; // SIZE OF STRIP IN BYTES (+4 FOR HEADER) if ((striphi + k) > storelim) croak ("NO STRIP SPACE"); *(int *) (striphi + 2) = stripinfo; striphi += k; return (striphi - k); } auto int initstrip (int stripinfo) { int p, q; p = stripcell (stripinfo); q = striphi; for (;;) { q -= 4; if (q == p) return (p); if (sp == spbar) signal_event(3); *(int *) (q + 2) = *(int *)sp; sp += 4; } } auto void itemise (int repref) { // FORM UP ITEM USING REPEATER SPECIFIED BY REPREF // PENDING SYMBOL(S) STORED IN INTEGER(REPREF) // IF REPREF < STREAMLIM, REPEATER IS STREAM (REPREF-STREAM0)>>3 // OTHERWISE, REPEATER FUNCTION IS IN INTEGER(REPREF+4) int last, j, k, r, v1, v2; double x; // auto int symtype (int s) { const int signset1 = 0xac507400; const int signset2 = 0x50000000; if ((s <= sym9) || ((syma <= s) && (s <= symz))) return (2); s = (unsigned int)s >> 3; if (s < 32) return (((unsigned int)signset1 >> s) & 1); // I think >> binds tighter than & ? return (((unsigned int)signset2 >> (s - 32)) & 1); // ditto } auto void readsym (void) { last = sym; if ((sym & 0x1FF) == symnl) { pos = 0; } if (repref < streamlim) { if (repref != inref) { inref = repref; selectinput ((inref - stream0) >> 3); } do {readch (&sym); sym = isotopop[sym & 127];} while (sym == 64); sym = sym << 3; } else { seal (); execute (*(int *) (repref + 4)); sym = saved (); if ((sym & 0xFFFFF807) != 0) sym = symend; unseal (); } if (pos != 81) pos += 1; Char[pos] = sym >> 3; } j = 0; k = 0; r = 10; sym = *(int *)repref; if ((sym & 0x7E000) != 0) { // TWO SYMBOLS PENDING last = (unsigned int)sym >> 9; sym = sym & 0x1FF; pos1 = pos - 1; } else { while ((sym < 0) || (sym == symsp) || (sym == symnl)) readsym (); if (sym == symend) { sym += 0x80000000; // FAULT 9 NEXT TIME a = terminval; goto fin; } pos1 = pos; readsym (); } // NEXT TWO SYMBOLS NOW IN LAST AND SYM if (last <= sym9) { // DIGIT x = (unsigned int)last >> 3; if ((sym == symcolon) && ((x == 2) || (x == 8))) { // BINARY,OCTAL? readsym (); if (sym > sym9) goto hold; r = (int) (x); x = 0; } while (sym <= sym9) {x = (x * r) + ((unsigned int)sym >> 3); readsym ();} if (sym == symdot) { // REAL? readsym (); if (sym <= sym9) goto frac; hold: sym = (last << 9) + sym; } a = ((int)x) << 3; goto fin; } if ((last == symdot && sym <= sym9)) { // REAL WITHOUT INT PART x = 0; frac: do { j += 1; x = x + ((float) (((unsigned int)sym >> 3)) / (float) ((rexp (r, j)))); readsym (); } while (sym <= sym9); if (sym == symsubten) { // EXPONENT j = 0; readsym (); if (sym == symminus) {k = 1; readsym ();} while (sym <= sym9) {j = j * 10 + ((unsigned int)sym >> 3); readsym ();} if (k == 0) x = x * (rexp (r, j)); else x = ((float) (x) / (float) ((rexp (r, j)))); } a = (((int)x) & (~7)) + 4; // LOW-ORDER 3 BITS = 1 0 0 goto fin; } if (last == symopenq) { // STRING for (;;) { if (sym == symopenq) k -= 1000000; // NESTED STRING if (sym == symcloseq) { if (k >= 0) break; k += 1000000; } k += 1; j -= 6; if (j < 0) {j = 24; save (0);} // WORD BOUNDARY *(int *) (sp) = *(int *) (sp) + ((unsigned int)sym >> 1 << j); readsym (); } readsym (); a = initstrip ((k << 16) + cstripinfo); goto fin; } v1 = (last + 1 * 8) << 23; v2 = 0; // WORD j = 24; k = symtype (last); if (((last == symlp) || (last == symlb)) && (sym == sympc)) goto pack; if ((last == sympc) && ((sym == symrp) || (sym == symrb))) goto pack; while (((0 != k) && (k == symtype (sym)))) { pack: j -= 6; if (j >= 0) v1 |= ((unsigned int)(sym + 1 * 8) >> 1) << j; else { if (j >= -18) v2 |= (sym + 1 * 8) << (j + 29); } readsym (); } a = wordlook (v1, v2); fin:*(int *)repref = sym; } auto void readprogramitem (void) { int p, q; l1: p = *(int *) (proglist + 2); // VALUE OF PROGLIST if (!(((p & 2) != 0) && (p < nil))) signal_event(10); // MUST BE PAIR q = *(int *) (p + 6); // BACK if ((q & 1) == 0) { // NOT FUNCTION a = *(int *) (p + 2); // TAKE FRONT AS ITEM *(int *) (proglist + 2) = q; // SET PROGLIST TO BACK } else { if ((q & fopbits) == iteminfun) { // FUNCTION CREATED BY INCHARITEM itemise (q - iteminfun); } else { execute (q); a = saved (); } if (a == terminval) a = goon; } if (nonmacflag != 0) {nonmacflag = 0; return;} if (a == nonmac) {nonmacflag = 1; goto l1;} if ((((a & 2) != 0) && (((wordmin <= a) && (a < stripmin)) && ((*(int *) (a + 14) & sigbits) == macbit)))) { // MACRO seal (); execute (*(int *) (var (a, 0) + 2)); unseal (); *(int *) (macend + 6) = *(int *) (proglist + 2); *(int *) (proglist + 2) = macstream; macstream = nil; macend = (int)&macstream - 6; goto l1; } } auto void testreals (void) { // TEST OPERANDS NUMERIC, CONVERT INTEGER TO REAL if (((a | b) & 3) != 0) signal_event(11); *(int *) (&xa) = a & (~7); if ((a & 7) == 0) xa = (int) (a / 8); *(int *) (&xb) = b & (~7); if ((b & 7) == 0) xb = (int) (b / 8); } auto float realb (void) { if ((b & 3) != 0) signal_event(10); *(int *) (&xb) = b & (~7); if ((b & 7) == 0) xb = (int) (b / 8); return (xb); } auto void execute (int fun) { int i, j, k, p, q, w1, w2, savedinst; int cstate, opener, last, cspbar, saveop, vtype; int type, labpos; const int identstate = 0x2D3FFF01, conststate = 0x253FFF00; const int skipstate = 0xFFFFFF0F; const int lprpbits = 0x08001000, rpbit = 0x00001000; const int initstate = 0xFFFFFF00; static void *x[0xd0] = { &&x_0x00, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_0x09, &&x_default, &&x_0x0B, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_0x17, &&x_0x18, &&x_0x19, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_0x20, &&x_0x21, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_0x28, &&x_default, &&x_0x2A, &&x_0x2B, &&x_default, &&x_0x2D, &&x_default, &&x_0x2F, &&x_0x30, &&x_0x31, &&x_0x32, &&x_default, &&x_0x34, &&x_0x35, &&x_default, &&x_0x37, &&x_0x38, &&x_0x39, &&x_default, &&x_0x3B, &&x_0x3C, &&x_0x3D, &&x_0x3E, &&x_0x3F, &&x_0x40, &&x_0x41, &&x_0x42, &&x_0x43, &&x_0x44, &&x_0x45, &&x_0x46, &&x_0x47, &&x_0x48, &&x_0x49, &&x_0x4A, &&x_0x4B, &&x_0x4C, &&x_0x4D, &&x_0x4E, &&x_0x4F, &&x_0x50, &&x_0x51, &&x_0x52, &&x_0x53, &&x_0x54, &&x_0x55, &&x_0x56, &&x_0x57, &&x_0x58, &&x_0x59, &&x_0x5A, &&x_0x5B, &&x_0x5C, &&x_0x5D, &&x_0x5E, &&x_0x5F, &&x_0x60, &&x_0x61, &&x_0x62, &&x_0x63, &&x_0x64, &&x_0x65, &&x_0x66, &&x_0x67, &&x_0x68, &&x_0x69, &&x_0x6A, &&x_0x6B, &&x_0x6C, &&x_0x6D, &&x_0x6E, &&x_0x6F, &&x_default, &&x_default, &&x_default, &&x_default, &&x_0x74, &&x_0x75, &&x_0x76, &&x_0x77, &&x_0x78, &&x_0x79, &&x_0x7A, &&x_0x7B, &&x_0x7C, &&x_0x7D, &&x_0x7E, &&x_0x7F, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_0x88, &&x_0x89, &&x_0x8A, &&x_0x8B, &&x_default, &&x_0x8D, &&x_0x8E, &&x_default, &&x_0x90, &&x_0x91, &&x_0x92, &&x_0x93, &&x_0x94, &&x_0x95, &&x_0x96, &&x_0x97, &&x_0x98, &&x_0x99, &&x_0x9A, &&x_0x9B, &&x_0x9C, &&x_0x9D, &&x_0x9E, &&x_0x9F, &&x_0xA0, &&x_0xA1, &&x_0xA2, &&x_0xA3, &&x_0xA4, &&x_0xA5, &&x_0xA6, &&x_0xA7, &&x_default, &&x_0xA9, &&x_0xAA, &&x_0xAB, &&x_default, &&x_default, &&x_0xAE, &&x_0xAF, &&x_0xB0, &&x_0xB1, &&x_0xB2, &&x_0xB3, &&x_0xB4, &&x_0xB5, &&x_0xB6, &&x_0xB7, &&x_0xB8, &&x_0xB9, &&x_0xBA, &&x_0xBB, &&x_default, &&x_0xBD, &&x_0xBE, &&x_default, &&x_default, &&x_default, &&x_default, &&x_default, &&x_0xC4, &&x_0xC5, &&x_0xC6, &&x_0xC7, &&x_0xC8, &&x_0xC9, &&x_0xCA, &&x_0xCB, &&x_0xCC, &&x_0xCD, &&x_0xCE, &&x_0xCF, }; static void *c[48] = { &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_6, &&c_7, &&c_8, &&c_9, &&c_10, &&c_11, &&c_12, &&c_13, &&c_14, &&c_15, &&c_16, &&c_17, &&c_18, &&c_default, &&c_20, &&c_21, &&c_22, &&c_23, &&c_24, &&c_25, &&c_26, &&c_27, &&c_28, &&c_29, &&c_30, &&c_31, &&c_32, &&c_33, &&c_34, &&c_35, &&c_36, &&c_37, &&c_38, &&c_39, &&c_40, &&c_41, &&c_42, &&c_43, &&c_44, &&c_45, &&c_46, &&c_47, }; static void *d[16] = { &&d_default, &&d_1, &&d_2, &&d_3, &&d_4, &&d_5, &&d_6, &&d_7, &&d_8, &&d_9, &&d_default, &&d_11, &&d_12, &&d_default, &&d_14, &&d_15, }; asp += 4; if (asp >= sp) goto er31; *(int *) (asp) = pc; pc = stackmin; // ADDRESS OF 'RESUME' INST savedinst = inst; inst = apply; b = fun; goto call; // er30: signal_event(3); er31: signal_event(4); er20: signal_event(10); er21: signal_event(11); er22: if (b == unass) b = terminval; error = 22; signal_event(16); // x_0x74: // APPLY call: if ((b & 1) == 0) goto er20; // NOT FUNCTION -> if ((b & opbits) != 0) {inst = b - 1; goto x00;} // BUILT-IN -> asp += 4; if (asp >= sp) goto er31; *(int *)asp = pc; pc = b + 15; // FIRST INST (PURE WORD ADDRESS) if (((*(int *)pc) & savemask) == varsave) { do pc += 4; while (!(((*(int *)pc) & savemask) != varsave)); i = pc; do { // SAVE IN REVERSE ORDER i -= 4; j = *(int *) (i) & adbits; asp += 4; if (asp >= sp) goto er31; *(int *) (asp) = *(int *) (j + 2); if (((*(int *)i) & insavebit) == 0) { // NOT INPUT VAR *(int *) (j + 2) = unass; // INITIALISE TO UNASS } else { if (sp == spbar) goto er30x; // STACK EMPTY -> *(int *) (j + 2) = *(int *) (sp); sp += 4; } } while (i != b + 15); } if ((((*(int *) (debug + 2)) != 0) && (((*(int *) (b + 3)) & 4) != 0))) { i = *(int *) (debsp + 2); if ((i & 0xFFFFFF07) != 0) i = 0; *(int *) (debsp + 2) = i + 8; announce (" "); spaces (i >> 3); printsymbol ('>'); mon = insavebit; monitor (b + 15); } goto x0; er30x: // MUST COMPLETE SOMEHOW for (;;) { *(int *) (j + 2) = unass; if (i == (b + 15)) break; i -= 4; j = (*(int *)i) & adbits; asp += 4; if (asp >= sp) goto er31; *(int *)asp = *(int *) (j + 2); } goto er30; x_0xC4: // APPLY UPDATER if ((0x70000001 != (b & 0x70000001)) && ((b & 0x70000001) != 1)) goto er20; // NOT 'UPDATABLE' if ((b & opbits) != 0) {inst = (b & 0x7FFFFFFF) ^ 0xB0000001; goto x10;} save (a); b = *(int *) (b + 11); goto call; // x_0xB8: // ->DUP-> ((DEFIES DESCRIPTION)) a = saved (); x_0xB0: // -> (STORE) *(int *) ((inst & adbits) + 2) = a; // *STORE HAS IMMEDIATE OPERAND* x_0xB5: // "ERASE" // EXECUTION POINT WHEN A FREE x0: inst = *(int *)pc; pc += 4; x00:b = inst & adbits; if (b == 0){ // NO OPERAND SPECIFIED - POP STACK if (sp == spbar) goto er30; b = *(int *)sp; sp += 4; } else { if ((b & 3) == 3) { // VARIABLE REFERENCE b = *(int *) (b + 1); if (b == unass) goto er22; } } // OTHERWISE B AS IMMEDIATE OPERAND if (inst < 0) { // BINARY OPERATOR if (sp == spbar) goto er30; a = *(int *)sp; sp += 4; } goto *x[(unsigned int)inst >> 24]; // x_0x88: // DUP-> (DUPLICATE & STORE) *(int *) ((inst & adbits) + 2) = a; goto x1; x_0x30: // LOAD IMMEDIATE - FROM WORD AFTER INST b = *(int *)pc; pc += 4; x_0x00: // <- (LOAD) loadb: a = b; x_0xB7: // "IDENTFN" // EXECUTION POINT WHEN A OCCUPIED x1:inst = *(int *)pc; pc += 4; x10:b = inst & adbits; if (b == 0) { b = a; if (inst < 0) { if (sp == spbar) goto er30; a = *(int *) (sp); sp += 4; } } else { if ((b & 3) == 3) { b = *(int *) (b + 1); if (b == unass) goto er22; } if (inst >= 0) { sp -= 4; if (sp <= asp) goto er31; *(int *)sp = a; } } goto *x[(unsigned int)inst >> 24]; // x_0x20: // RETURN pc -= b; // FIRST INST if ((((*(int *) (debug + 2)) != 0) && (((*(int *) (pc - 12)) & 4) != 0))) { i = (*(int *) (debsp + 2)) - 8; if ((i & 0xFFFFFF07) != 0) i = 0; *(int *) (debsp + 2) = i; announce (" "); spaces (i >> 3); printsymbol ('<'); mon = outsavebit; monitor (pc); } while (((*(int *)pc) & savemask) == varsave) { a = (*(int *)pc) & adbits; if (((*(int *)pc) & outsavebit) != 0) { sp -= 4; *(int *) (sp) = *(int *) (a + 2); } *(int *) (a + 2) = *(int *)asp; asp -= 4; pc += 4; } pc = *(int *)asp; asp -= 4; goto x0; x_0xA9: // "QBUG" if ((a & fopbits) != 1) goto er20; // USE CLASS SLOT OF HEADER FOR FLAG (OK?) if (b != 0) *(int *) (a + 3) = (*(int *) (a + 3)) | 4; else *(int *) (a + 3) = (*(int *) (a + 3)) & (~4); goto x0; x_0x34: // JUMP pc += b; goto x0; x_0x35: // JUMP BACK pc -= b; intflag -= 1; if ((intflag > 0) || (interrupt () > 0)) goto x0; goto poprdy; x_0xB4: // JUMP FALSE if (a == 0) pc += b; goto x0; x_0xB6: // JUMP TRUE if (a != 0) pc += b; goto x0; // x_0x90: // "=" if (a == b) goto tru; fals: a = 0; goto x1; x_0x91: // "\=" if (a == b) goto fals; tru: a = 1 * 8; goto x1; x_0x92: // "<=" if (((((a ^ b) & (~4)) == 0) && ((a & 3) == 0))) goto tru; x_0x93: // "<" if (((a | b) & 7) == 0) { if (a < b) goto tru; goto fals; } testreals (); if (xa < xb) goto tru; goto fals; x_0x95: // ">=" if (((((a ^ b) & (~4)) == 0) && ((a & 3) == 0))) goto tru; x_0x94: // ">" if (((a | b) & 7) == 0) { if (a > b) goto tru; goto fals; } testreals (); if (xa > xb) goto tru; goto fals; x_0x96: // "+" if (((a | b) & 7) == 0) {a += b; goto x1;} testreals (); xa += xb; rset: a = (((int)xa) & (~7)) + 4; goto x1; x_0x97: // "-" if (((a | b) & 7) == 0) {a -= b; goto x1;} testreals (); xa -= xb; goto rset; x_0x51: // "INTOF" a = intpt (realb ()) * 8; goto x1; x_0x52: // "REALOF" if ((b & 7) != 0) goto er20; xa = (int) (b / 8); goto rset; x_0x53: // "SIGN" if ((b & 3) != 0) goto er20; if ((b & (~4)) == 0) goto fals; if (b > 0) goto tru; a = -1 * 8; goto x1; x_0x98: // "*" if (((a | b) & 7) == 0) {a = ((int)(a / 8) * b); goto x1;} // a = a//8*b - check precedence ... testreals (); xa *= xb; goto rset; x_0x99: // "/" testreals (); xa /= xb; goto rset; x_0x9A: // "//" if (((a | b) & 7) != 0) goto er20; i = (int) (a / b); b = a - (i * b); a = i * 8; pushb: sp -= 4; if (sp <= asp) goto er31; *(int *)sp = b; goto x1; x_0x9B: // "^" if ((b & 7) != 0) goto er20; testreals (); xa = rexp (xa, (int) (b / 8)); // real no raised to integer power goto rset; x_0x62: // "SIN" xa = sin (realb ()); goto rset; x_0x63: // "COS" xa = cos (realb ()); goto rset; x_0x64: // "TAN" xa = tan (realb ()); goto rset; x_0x65: // "ARCTAN" xa = arctan (1, realb ()); goto rset; x_0x66: // "SQRT" xa = sqrt (realb ()); goto rset; x_0x67: // "LOG" xa = log (realb ()); goto rset; x_0x68: // "EXP" xa = exp (realb ()); goto rset; x_0x3F: // "POPTIME" xa = cputime (); goto rset; x_0x3E: // "COREUSED" a = (wordhi - pairlo + striphi - stripmin + 10000) << 3; goto x1; x_0xA0: // "LOGAND" if (((a | b) & 7) != 0) goto er20; a = a & b; goto x1; x_0xA1: // "LOGOR" if (((a | b) & 7) != 0) goto er20; a = a | b; goto x1; x_0x5F: // "LOGNOT" if ((b & 7) != 0) goto er20; a = b ^ (~7); goto x1; x_0xA2: // "LOGSHIFT" if (((a | b) & 7) != 0) goto er20; i = (int) (b / 8); if (i >= 0) a = a << i; else a = ((unsigned int)a >> (-i)) & (~7); goto x1; x_0x55: // "NOT" if (b == 0) goto tru; goto fals; x_0xA3: // "BOOLAND" if (b == 0) goto fals; goto x1; x_0xA4: // "BOOLOR" if (b != 0) goto tru; goto x1; x_0xA6: // "SAMEDATA" if (classno (a) == classno (b)) goto tru; goto fals; x_0x56: // "ISCOMPND" if ((b & 3) != 0) goto tru; goto fals; x_0x57: // "ISINTEGER" if ((b & 7) == 0) goto tru; goto fals; x_0x58: // "ISREAL" if ((b & 7) == 4) goto tru; goto fals; x_0x59: // "ISWORD" if (((b & 2) != 0) && ((wordmin <= b) && (b < stripmin))) goto tru; goto fals; x_0x5A: // "ISFUNC" if ((b & 1) != 0) goto tru; goto fals; x_0x5B: // "ATOM" if (!(((b & 2) != 0) && (b < nil))) goto tru; goto fals; x_0x5C: // "ISLIST" if (b == nil) goto tru; x_0x5D: // "ISLINK" if (!(((b & 2) != 0) && (b < nil))) goto fals; a = *(int *) (b + 6); // BACK if (((a & 2) != 0) && (a <= nil)) goto tru; if ((a & 1) == 0) goto fals; a = *(int *) (b + 2); // FRONT (FALSE,NOT) goto x1; // auto void solidify (void) { // SOLIDIFY LIST B WHEN BACK DISCOVERED TO BE FUNCTION int i; if (*(int *) (b + 2) == 0) {b = nil; return;} save (a); save (b); seal (); execute (*(int *) (b + 6)); i = saved (); unseal (); b = *(int *)(sp); a = *(int *) (sp + 4); sp += 8; if (i != terminval) { *(int *) (b + 2) = i; *(int *) (b + 6) = paircell (1 * 8, *(int *) (b + 6)); } else { *(int *) (b + 2) = 0; b = nil; } } auto void listtostack (void) { if (!(((b & 2) != 0) && (b <= nil))) assert (__LINE__ == 0); seal (); while (((b & 2) != 0) && (b < nil)) { if (((*(int *) (b + 6)) & 1) != 0) { solidify (); if (b == nil) break; } sp -= 4; if (sp <= asp) assert (__LINE__ == 0); *(int *)sp = *(int *) (b + 2); b = *(int *) (b + 6); } } x_0x5E: /* 0x5E */ // "NULL" if (!(((b & 2) != 0) && (b <= nil))) goto er20; if (b == nil) goto tru; if (((*(int *) (b + 6)) & 1) == 0) goto fals; solidify (); if (b == nil) goto tru; goto fals; x_0x9C: /* 0x9C */ // "::" x_0x9E: /* 0x9E */ // "CONS" if (!(((b & 2) != 0) && (b <= nil))) goto er20; x_0x9F: /* 0x9F */ // "CONSPAIR" cp: a = paircell (a, b); goto x1; x_0x42: /* 0x42 */ // "FNTOLIST" if ((b & 1) == 0) goto er20; a = 1 * 8; goto cp; x_0x76: /* 0x76 */ // "HD" if (!(((b & 2) != 0) && (b < nil))) goto er20; if (((*(int *) (b + 6)) & 1) != 0) { solidify (); x_0x77: /* 0x77 */ // "FRONT" frn: if (!(((b & 2) != 0) && (b < nil))) goto er20; } a = *(int *) (b + 2); goto x1; x_0xC6: /* 0xC6 */ // ->"HD" if (!(((b & 2) != 0) && (b < nil))) goto er20; if (((*(int *) (b + 6)) & 1) != 0) { solidify (); x_0xC7: /* 0xC7 */ // ->"FRONT" if (!(((b & 2) != 0) && (b < nil))) goto er20; } *(int *) (b + 2) = a; goto x0; x_0x78: /* 0x78 */ // "TL" if (!(((b & 2) != 0) && (b < nil))) goto er20; a = *(int *) (b + 6); if ((a & 1) == 0) goto x1; solidify (); x_0x79: /* 0x79 */ // "BACK" bac: if (!(((b & 2) != 0) && (b < nil))) goto er20; a = *(int *) (b + 6); goto x1; x_0xC8: /* 0xC8 */ // ->"TL" if (!(((b & 2) != 0) && (b < nil))) goto er20; if (((*(int *) (b + 6)) & 1) != 0) { solidify (); x_0xC9: /* 0xC9 */ // ->"BACK" if (!(((b & 2) != 0) && (b < nil))) goto er20; } *(int *) (b + 6) = a; goto x0; x_0x43: /* 0x43 */ // "DEST" if (!(((b & 2) != 0) && (b < nil))) goto er20; a = *(int *) (b + 6); if ((a & 1) != 0) { solidify (); x_0x44: /* 0x44 */ // "DESTPAIR" if (!(((b & 2) != 0) && (b < nil))) goto er20; a = *(int *) (b + 6); // BACK } b = *(int *) (b + 2); // FRONT goto pushb; x_0x4B: /* 0x4B */ // "COPYLIST" listtostack (); x_0x2A: /* 0x2A */ // "%]" (DECORATED RB) if (*(int *)pc == 0x69000000) { pc += 4; goto mr1; } // MACRESULTS -> a = nil; stacktolist: while (sp != spbar) { a = paircell (*(int *)sp, a); sp += 4; } unseal (); goto x1; x_0x9D: /* 0x9D */ // "<>" if (!(((a & 2) != 0) && (a <= nil))) goto er20; i = b; b = a; a = i; listtostack (); goto stacktolist; x_0x54: /* 0x54 */ // "REV" listtostack (); i = spbar; a = nil; while (i != sp) { i -= 4; a = paircell (*(int *)i, a); } r1: sp = spbar; unseal (); goto x1; x_0x61: /* 0x61 */ // "LENGTH" listtostack (); a = (spbar - sp) << 1; // >>2<<3 goto r1; x_0x69: /* 0x69 */ // "MACRESULTS" listtostack (); mr1: i = spbar; while (i != sp) { i -= 4; *(int *) (macend + 6) = paircell (*(int *)i, nil); macend = *(int *) (macend + 6); } sp = spbar; unseal (); goto x0; x_0x40: /* 0x40 */ // "CONSREF" a = stripcell (refheader); *(int *) (a + 6) = b; goto x1; x_0x41: /* 0x41 */ // "DESTREF" x_0x7A: /* 0x7A */ // "CONT" if (!(classno (b) == refclass)) goto er20; a = *(int *) (b + 6); goto x1; x_0xCA: /* 0xCA */ // ->"CONT" if (!(classno (b) == refclass)) goto er20; *(int *) (b + 6) = a; goto x0; x_0x48: /* 0x48 */ // "CONSWORD" if (((b & 7) != 0) || (b <= 0)) goto er20; w1 = 0; w2 = 0; i = 30 - ((unsigned int)b >> 3) * 6; while (i != 30) { a = saved (); if (((a & 0xFFFFF807) != 0) || (a == 63 * 8)) goto er21; if (i >= 0) w1 |= (unsigned int)(a + 1 * 8) >> 1 << i; else { if (i > -18) w2 |= (a + 1 * 8) << (i + 29); } i += 6; } a = wordlook (w1, w2); goto x1; x_0xA5: /* 0xA5 */ // "CHARWORD" if (!((((a & 2) != 0) && ((wordmin <= a) && (a < stripmin))))) goto er20; if (!((b & 7) == 0)) goto er20; i = charword (a, b); cw: if (i == 63 * 8) goto er20; a = i; goto x1; x_0x45: /* 0x45 */ // "DESTWORD" if (!((((b & 2) != 0) && ((wordmin <= b) && (b < stripmin))))) goto er20; a = 0; for (;;) { i = charword (b, a + 1 * 8); if (i == 63 * 8) break; save (i); a = a + 1 * 8; } goto x1; x_0x46: /* 0x46 */ // "IDENTPROPS" if (!((((b & 2) != 0) && ((wordmin <= b) && (b < stripmin))))) goto er20; b = (*(int *) (b + 14)) & sigbits; a = undef; if (b == 0) goto x1; a = syntax; if (b < 0) goto x1; a = macro; if (b == macbit) goto x1; a = (unsigned int)(b & precbits) >> 21; // >>24<<3 goto x1; x_0x7C: /* 0x7C */ // "DATAWORD" a = *(int *) (stackmin - classno (b)); goto x1; x_0xCC: /* 0xCC */ // ->"DATAWORD" i = classno (b); if (((i <= refclass) || (((a & 2) != 0) && (a >= stripmin)))) goto er20; *(int *) (stackmin - i) = a; goto x0; x_0x3D: /* 0x3D */ // "STACKLENGTH" a = (spbar - sp) << 1; // >>2<<3 goto x1; x_0x09: /* 0x09 */ // "(%" save (undef); // WILL BECOME UPDATER // SEAL WILL BECOME GETFROZ x_0x0B: /* 0x0B */ // "[%" (DECORATED LB) seal (); goto x0; x_0xA7: /* 0xA7 */ // "PARTAPPLY" save (a); save (undef); listtostack (); x_0x2B: /* 0x2B */ // "%)" // 7 FNPROPS // 11 UPDATER // 15 'GETFROZ' // FROZ VALS // 19+ FUN // 23+ RETURN b = *(int *) (spbar + 8); if ((b & 1) == 0) goto er20; save (b); save (Return + spbar - sp + 8); j = spbar + 12; spbar = *(int *)spbar; *(int *) (j - 12) = getfroz + j - sp - 16; // FROZVAL BYTES + 4 i = j - sp; // CREATE FUNCTION CELL a = initstrip (i << 14) - 1; // >>2<<16 if ((0x70000000 != (b & 0x70000000)) && ((b & 0x70000000) != 0)) goto x1; if ((b & opbits) == 0) b = *(int *) (b + 11); else b = (b & 0x7FFFFFFF) ^ 0xB0000000; // check precedence if (b != undef) { sp = j - i; *(int *) (sp + 4) = b; *(int *) (a + 11) = initstrip (i << 14) - 1; } goto x1; x_0x31: /* 0x31 */ // GETFROZ while (b > 4) { sp -= 4; if (sp <= asp) goto er31; *(int *)sp = *(int *)pc; pc += 4; b -= 4; } b = *(int *)pc; pc += 4; inst = apply; goto call; x_0x75: /* 0x75 */ // "VALOF" if (!((((b & 2) != 0) && ((wordmin <= b) && (b < stripmin))))) goto er20; b = var (b, varbit); if ((*(int *) (b + 14)) < 0) goto er20; // SYNTAX -> a = *(int *) (b + 2); if (a == unass) a = undef; goto x1; x_0xC5: /* 0xC5 */ // ->"VALOF" if (!((((b & 2) != 0) && ((wordmin <= b) && (b < stripmin))))) goto er20; b = var (b, varbit); if (b < syslim) goto er20; // PROTECTED -> *(int *) (b + 2) = a; goto x0; x_0x7B: /* 0x7B */ // "MEANING" if (!((((b & 2) != 0) && ((wordmin <= b) && (b < stripmin))))) goto er20; a = *(int *) (b + 14) & adbits; goto x1; x_0xCB: /* 0xCB */ // ->"MEANING" if (!((((b & 2) != 0) && ((wordmin <= b) && (b < stripmin))))) goto er20; if (!((a & typebits) == 0)) goto er20; // (RESTRICTION) *(int *) (b + 14) = ((*(int *) (b + 14)) & typebits) + a; goto x0; x_0x7D: /* 0x7D */ // "FNPROPS" if ((b & 1) == 0) goto er20; if ((b & opbits) != 0) goto loadb; // B ITSELF IF BUILT-IN a = *(int *) (b + 7); goto x1; x_0xCD: /* 0xCD */ // ->"FNPROPS" if ((b & fopbits) != 1) goto er20; *(int *) (b + 7) = a; goto x0; x_0x7E: /* 0x7E */ // "UPDATER" if ((0x70000001 != (b & 0x70000001)) && ((b & 0x70000001) != 1)) goto er20; if ((b & opbits) == 0) a = *(int *) (b + 11); else a = (b & 0x7FFFFFFF) ^ 0xB0000000; // check precedence goto x1; x_0xCE: /* 0xCE */ // ->"UPDATER" if (((b & fopbits) != 1) || ((a & 1) == 0)) goto er20; *(int *) (b + 11) = a; goto x0; x_0x7F: /* 0x7F */ // "FNPART" if ((b & fopbits) != 1) goto er20; i = (*(int *) (b + 15)) ^ getfroz; if ((i & opbits) != 0) goto er20; a = *(int *) (b + i + 15); goto x1; x_0xCF: /* 0xCF */ // ->"FNPART" if (((b & fopbits) != 1) || ((a & 1) == 0)) goto er20; i = (*(int *) (b + 15)) ^ getfroz; if ((i & opbits) != 0) goto er20; *(int *) (b + i + 15) = a; goto x0; x_0x47: /* 0x47 */ // "BOUNDSLIST" a = 1 * 8; x_0x8B: /* 0x8B */ // "FROZVAL" fv: if ((b & fopbits) != 1) goto er20; i = (*(int *) (b + 15)) ^ getfroz; if ((i & opbits) != 0) goto er20; if (!((((a & 7) == 0) && ((a > 0) && (((unsigned int)a >> 1) < i))))) goto er20; a = *(int *) (b + ((unsigned int)a >> 1) + 15); goto x1; x_0xBB: /* 0xBB */ // ->"FROZVAL" if ((b & fopbits) != 1) goto er20; i = (*(int *) (b + 15)) ^ getfroz; if ((i & opbits) != 0) goto er20; if (!((((a & 7) == 0) && ((a > 0) && (((unsigned int)a >> 1) < i))))) goto er20; *(int *) (b + ((unsigned int)a >> 1) + 15) = saved (); goto x0; x_0x49: /* 0x49 */ // "COPY" if ((b & 2) == 0) goto loadb; if (b < wordmin) b = paircell (*(int *) (b + 2), *(int *) (b + 6)); if (b < stripmin) goto loadb; a = stripcell (*(int *) (b + 2)); p = a; q = b; for (;;) { p += 4; q += 4; if (p == striphi) break; *(int *) (p + 2) = *(int *) (q + 2); } goto x1; x_0xAE: /* 0xAE */ // "STRIPFNS" if (b == cmpnd) b = 0; if ((b & 0xFFFFFF07) != 0) goto er20; i = newclass (a); b = initxfun + (b << 5) + i; // >>3<<8 a = subxfun + i; goto pushb; x_0x4E: /* 0x4E */ // "INIT" j = fullstripinfo; goto in1; x_0x4F: /* 0x4F */ // "INITC" j = cstripinfo; goto in1; x_0xB2: /* 0xB2 */ // INITX j = b; b = a; in1: if ((b & 0xFFF80007) != 0) goto er20; a = stripcell ((b << 13) + j); // >>3<<16 p = a; for (;;) { p += 4; if (p == striphi) break; *(int *) (p + 2) = unass; } goto x1; x_0x4A: /* 0x4A */ // "DATALENGTH" if ((b & 2) == 0) { if ((b & 3) == 0) goto tru; // SIMPLE (1) if ((b & opbits) != 0) goto fals; // BUILT-IN FUNCTION (0) i = (*(int *) (b + 15)) ^ getfroz; if ((i & opbits) != 0) goto fals; a = (i << 1) - (1 * 8); goto x1; } if (b >= stripmin) { a = (*(unsigned int *) (b + 2)) >> 13; goto x1; } // >>16<<3 if (b == nil) goto fals; // (0) if (b < nil) { a = 2 * 8; goto x1; } for (a = 8 * 8; a > 1 * 8; a -= 1 * 8) // CHECK CAREFULLY { if (charword (b, a) != 63 * 8) break; } goto x1; x_0xAA: /* 0xAA */ // "SUBANY" if (!(((a & 7) == 0) && (a > 0))) goto er20; if ((b & 2) == 0) { if ((b & 1) != 0) goto fv; if (a == 1 * 8) goto loadb; goto er20; } if (b >= stripmin) { q = 1; goto sb3; } if (b <= nil) { if (a == 1 * 8) goto frn; if (a == 2 * 8) goto bac; goto er20; } i = charword (b, a); goto cw; x_0x89: /* 0x89 */ // "SUBSCR" j = fullstripclass; goto sb1; x_0x8A: /* 0x8A */ // "SUBSCRC" j = cstripclass; goto sb1; x_0x8D: /* 0x8D */ // SUBX j = b; b = a; a = saved (); sb1: q = 1; sb2: if (!(((b & 2) != 0) && (b >= stripmin))) goto er20; if (!(*(unsigned char *) (b + 5) == j)) goto er20; // TEST CORRECT CLASS if (!((a & 7) == 0)) goto er20; sb3: if (!(((0 < a) && (a <= ((*(unsigned int *) (b + 2)) >> 13))))) goto er20; // >>16<<3 j = *(unsigned char *) (b + 4); // COMPONENT SIZE if (j == 0) { // FULL WORD if (q != 0) { k = *(int *) (b + ((unsigned int)a >> 1) + 2); if (k == unass) goto er22; a = k; goto x1; } *(int *) (b + ((unsigned int)a >> 1) + 2) = *(int *)sp; sp += 4; goto x0; } i = (unsigned int)a >> 3; k = (int) (32 / j); // NUM PER WORD p = (int) ((i - 1) / k); // WORD DISPLACEMENT i = 32 - (i - p * k) * j; // SHIFT FACTOR p = (p << 2) + b; k = (((*(unsigned int *) (p + 6)) >> i) & ((1 << j) - 1)); if (q != 0) { a = k << 3; goto x1; } b = *(int *) (sp); sp += 4; if ((b & 7) != 0) goto er20; q = (unsigned int)b >> 3; if ((unsigned int)q >> j != 0) goto er20; *(int *) (p + 6) = (*(int *) (p + 6)) ^ ((q ^ k) << i); goto x0; x_0xB9: /* 0xB9 */ // ->"SUBSCR" j = fullstripclass; goto ts1; x_0xBA: /* 0xBA */ // ->"SUBSCRC" j = cstripclass; goto ts1; x_0xBD: /* 0xBD */ // ->SUBX j = b; b = a; a = saved (); ts1: q = 0; if (sp == spbar) goto er30; goto sb2; x_0xAF: /* 0xAF */ // "RECORDFNS" listtostack (); i = 0; while (sp != spbar) { b = *(int *)sp; if (((b != cmpnd) && ((b & 0xFFFFFF07) != 0))) goto er20; sp += 4; i += 0x10000; if ((i & opbits) != 0) goto er20; } unseal (); b = newclass (a); save (recconsfun + i + b); a = recdestfun + b; j = 0; while (j < i) { j += 0x10000; save (a); a = recreffun + j + b; } goto x1; x_0x37: /* 0x37 */ // RECCONS a = initstrip (b); goto x1; x_0xB3: /* 0xB3 */ // RECDEST if (!(((a & 2) != 0) && (a >= stripmin))) goto er20; if (!((*(unsigned char *) (a + 5)) == b)) goto er20; p = a; q = sp - ((*(unsigned int *) (a + 2)) >> 14); if (q <= asp) goto er31; while (sp != q) { sp -= 4; p += 4; *(int *)sp = *(int *) (p + 2); } goto x0; x_0x8E: /* 0x8E */ // RECREF if (!(((a & 2) != 0) && (a >= stripmin))) goto er20; if (!((*(unsigned char *) (a + 5)) == (b & 0xFF))) goto er20; a = *(int *) (a + ((unsigned int)b >> 14) + 2); goto x1; x_0xBE: /* 0xBE */ // ->RECREF if (!(((a & 2) != 0) && (a >= stripmin))) goto er20; if (!((*(unsigned char *) (a + 5)) == (b & 0xFF))) goto er20; *(int *) (a + ((unsigned int)b >> 14) + 2) = saved (); goto x0; x_0x3B: /* 0x3B */ // "CHARIN" a = *(int *)b; if (a < 0) { if (b != inref) { inref = b; selectinput ((unsigned int)(b - stream0) >> 3); } do { { readch (&k); k = isotopop[k]; } } while (k == 64); a = k << 3; } *(int *)b = a | 0x80000000; if (a != symend) goto x1; a = terminval; goto x1; x_0xB1: /* 0xB1 */ // "CHAROUT" if ((a & 0xFFFFFE07) == 0) { if (b != outref) { outref = b; selectoutput ((unsigned int)(b - stream0) >> 3); } if (b == stream0) outsym = a; printsymbol (poptoiso[(unsigned int)a >> 3]); goto x0; } if (a != terminval) goto er20; if (b == stream0) goto x0; outref = stream0; selectoutput (0); closestream ((unsigned int)(b - stream0) >> 3); goto x0; x_0x32: /* 0x32 */ // ITEMIN itemise (b); goto x1; x_0x3C: /* 0x3C */ // "ITEMREAD" readprogramitem (); goto x1; x_0x6C: /* 0x6C */ // "PRINT" save (b); x_0x6B: /* 0x6B */ // "PR" if ((b & 0x80000003) == 0) putsym (symsp); // NON-NEGATIVE NUMBER putitem (b); goto x0; x_0x6F: /* 0x6F */ // "PRSTRING" if (!(classno (b) == cstripclass)) goto er20; putstring (b); goto x0; x_0xAB: /* 0xAB */ // "PRREAL" if (((a | b) & 0xFFFFFC07) != 0) goto er20; i = b; b = saved (); putreal (realb (), (unsigned int)a >> 3, (unsigned int)i >> 3); goto x0; x_0x6D: /* 0x6D */ // "NL" if ((b & 0xFFFFFC07) != 0) goto er20; while (b > 0) { putsym (symnl); b = b - 1 * 8; } goto x0; x_0x6E: /* 0x6E */ // "SP" if ((b & 0xFFFFFC07) != 0) goto er20; while (b > 0) { putsym (symsp); b = b - 1 * 8; } goto x0; x_0x4C: /* 0x4C */ // "SHOW" if ((b & fopbits) != 1) goto prdict; p = b + 7; k = (*(unsigned int *) (b + 3)) >> 14; i = 0x30000008; // FOR FNPROPS,UPDATER while (k > 0) { if (((i & 0xFE000000) == 0x30000000) && ((i & adbits) != 0)) { // LOADIMM AND GETFROZ -- FOLLOWED BY VALUES j = *(int *)p; i -= 4; } else { i = *(int *)p; if ((i & opbits) != 0) putitem ((i & opbits) + 1); else { putsym (symla); putsym (symminus); } j = i & adbits; if ((i & 3) == 3) j -= 1; if (j == stream0) j = 0; if ((i & 0x70000003) == 0x30000000) j = j << 1; // ROUGH TEST } putsym (symsp); putitem (j); putsym (symnl); p += 4; k -= 4; } putsym (symnl); goto x0; prdict: for (i = 0; i <= 127; i += 1) { write (i, 3); j = index[i]; while (j != 0) { k = (j << 4) + wordbase; putsym (symsp); putitem (k); j = (*(int *) (k + 10)) & 0x3FFF; } putsym (symnl); } putsym (symnl); goto x0; x_0x38: /* 0x38 */ // "SETPOP" mon = 0; x_0x2F: /* 0x2F */ // "GOON" pc = 0; mon = 0; forcereturn (); goto x0; x_0x18: /* 0x18 */ // ":" x_0x19: /* 0x19 */ // "=>" announce ("**"); j = spbar; while (j != sp) { j -= 4; putsym (symsp); print (*(int *) (j)); if (j != sp) printsymbol (','); } putsym (symnl); sp = spbar; goto x0; x_0x6A: /* 0x6A */ // "POPMESS" listtostack (); a = nil; while (sp != spbar) { k = a; a = b; b = saved (); } unseal (); if (b == Exit) { exit (0); } if ((b != in && (b != out && (b != compil && b != edit)))) goto er20; if (!((((a & 2) != 0) && ((wordmin < a) && (a < stripmin))))) goto er21; j = streammax + 8; *(int *)j = symnlx; *(int *) (j + 4) = a; i = stream0; do { i += 8; } while (!(*(int *) (i + 4) == a)); if ((*(int *)i != symnlx) && (b != out)) { *(int *)i = symnlx; if (inref != stream0) { inref = stream0; selectinput (0); } closestream ((unsigned int)(i - stream0) >> 3); } if (b == edit) { if (k == nil) { if (exist (wordtostring (a)) == 0) /* invoke editor *//*e (concat (".NULL/", wordtostring (a))) */ ; else /* invoke editor *//*e (wordtostring (a)) */ ; } else /* invoke editor *//*e (concat (wordtostring (a), concat ("/", wordtostring (k)))) */ ; goto x0; } if (i == j) { if (i == streamlim) croak ("NO STREAMS"); streammax = i; j = '0'; k = ((unsigned int)(i - stream0) >> 3) + '0'; if (k > '9') { j += 1; k -= 10; } /* set up stream *//*define (concat ("ST", concat (tostring (j), concat (tostring (k), concat (",", wordtostring (a)))))) */ ; } a = charoutfun; if (b != out) a = charinfun; a += i; if (b != compil) goto x1; b = a; x_0x4D: /* 0x4D */ // "INCHARITEM" x_0x50: /* 0x50 */ // "COMPILE" if ((b & 1) == 0) goto er20; a = b ^ charinfun; if ((a & opbits) != 0) { // REPEATER NOT CHARIN(STREAM) a = streamlim; do { a += 8; } while (!((a == itemhi) || (*(int *) (a + 4) == b))); if (a == itemhi) { itemhi += 8; if (itemhi >= classlo) croak ("NO ITEMS"); *(int *) (a) = symnlx; *(int *) (a + 4) = b; } } a += iteminfun; if ((inst & opbits) == 0x4D000000) goto x1; // INCHARITEM *(int *) (cucharin + 2) = b; // SET CUCHARIN b = paircell (1 * 8, a); // FNTOLIST goto pv; x_0x39: /* 0x39 */ // "POPREADY" intflag = 50; poprdy: announce ("\nPOPREADY\n"); x_0x21: /* 0x21 */ // START b = baseprog; *(int *) (b + 2) = 1 * 8; *(int *) (b + 6) = iteminfun + baseitem; if (baseitem == stream0) { // EXCEPT AT OUTSET if (inref != stream0) { inref = stream0; selectinput (0); } if (((*(int *)inref) & 0x1FF) != symnl) { do { readch (&k); } while (k != '\n'); } } *(int *)baseitem = symnlx; goto pv; // // C O M P I L A T I O N S E C T I O N // auto void plantinst (int op) { if ((((op & adbits) == 0) && ((csp != cspbar) && (((*(int *)csp) & opbits) == 0)))) { *(int *)csp += op; } else { plant (op); } } auto void lookuplabel (int l) { labpos = spbar; for (;;) { labpos -= 8; if (labpos < sp) break; if (*(int *) (labpos + 4) == l) return; } if (labpos <= asp) assert (__LINE__ == 0); sp = labpos; *(int *)labpos = 0; *(int *) (labpos + 4) = l; } auto void plantjump (int j, int p) { int q; q = *(int *)p; if (q > 0) { // LABEL DEFINED plant (jumpback + csp + 4 - q); // ALWAYS UNCONDITIONAL } else { if (((j < 0) && ((csp != cspbar) && (*(int *)csp == not)))) { j ^= 0x02000000; csp -= 4; } plant (j + (q & adbits)); *(int *)p = 0x80000000 + csp; } } auto void unchain (int p) { int next; int q; cspbar = csp; q = (*(int *)p) & adbits; *(int *)p = 0; while (q != 0) { next = (*(int *)q) & adbits; *(int *)q = ((*(int *)q) & opbits) + csp - q; q = next; } } x_0x60: /* 0x60 */ // "POPVAL" pv: if (!(((b & 2) != 0) && (b < nil))) goto er20; pos = 0; pos1 = 0; push (pc); plant (asp); plant (*(int *) (proglist + 2)); *(int *) (proglist + 2) = b; plant (codebase); plant (pvbase); pvbase = csp; codebase = 0; x_0x17: /* 0x17 */ // STOP (SEMICOLON) x_0x2D: /* 0x2D */ // STOP (END) push (terminval); // SOLE NON-NEG OPENER start: csp = pvbase; cspbar = csp; pc = 0; inst = 0; announce (""); prompt ("\n:"); get0: cstate = initstate; opener = terminval; a = terminval; c_22: /* 22 */ // "," c_31: /* 31 */ // "CANCEL" c_18: /* 18 */ // "COMMENT" c_6: /* 6 */ // "NONOP" c_7: /* 7 */ // "NONMAC" (SHOULDN'T GET HERE) get: last = a; readprogramitem (); prompt (":"); if ((((a & 2) != 0) && ((wordmin <= a) && (a < stripmin)))) { // WORD type = (*(int *) (a + 14)) & typebits; if (type >= 0) { // NOT SYNTAX if ((type & precbits) == 0) { // ORDINARY IDENT if ((cstate << 1) >= 0) goto err; } else { // OPERATOR if ((cstate << 2) >= 0) goto err; } } else { // SYNTAX if ((cstate << (((unsigned int)type >> 24) & 31)) >= 0) goto err; } } else { // CONST if (cstate >= 0) goto err; if ((cstate & 15) == 0) goto Const; } if ((cstate & 15) != 0) goto *d[cstate & 15]; // CONTEXT-CONTROLLED -> next: if ((type >= 0) && ((type & precbits) == 0)) goto ident; // ORDINARY IDENT -> for (;;) { // POP LOWER PRECEDENCE OPERATORS p = *(int *)asp; if (((p & typebits) <= 0) || ((p & typebits) > (type & varbits))) break; p = p & adbits; asp -= 4; q = 0; if (csp != cspbar) q = *(int *)csp; if (p == arrow) { if ((0x70000000 != (q & 0x70000000)) && ((q & 0x70000000) != 0)) goto aerr; // NOT UPDATABLE -> if ((q & opbits) == 0) { // LOAD: MUST BE VAR, NOT PROTECTED if (((q & 3) != 3) || (q < syslim)) goto aerr; q -= 1; // IMMEDIATE OPERAND FOR STORE } // MAP INST TO 'UPDATE' *(int *)csp = (q & 0x7FFFFFFF) ^ 0xB0000000; } else { if (p != dot) { q = p + 1; plant (q); } p = apply; if ((((q & 0xFF000003) == 3) && ((zero < q) && (q < primlim)))) { p = (*(int *) (q + 1)) - 1; csp -= 4; } plantinst (p); } } if (type >= 0) goto operator; if ((a >= function) && (((*(int *) ((p & adbits) + 2)) << (((unsigned int)type >> 24) & 31) >= 0)) ) goto gerr; lpnext: cstate = *(int *) (a + 2); goto *c[(unsigned int)(a - wordmin) >> 4]; d_6: /* 6 */ // WORD AFTER "NONOP" ident: cstate = identstate; goto get; d_1: /* 1 */ // WORD AFTER IDENT if (((a == colon) && (codebase != 0))) { lookuplabel (last); if (*(int *)labpos <= 0) unchain (labpos); else comment (" DUP ", last); *(int *)labpos = csp; goto get0; } if (((*(int *) (last + 14)) & sigbits) == 0) comment (" VARS ", last); last = var (last, varbit); if (a == lp) { push (varbit + last); goto lpnext; } if ((csp != cspbar) && (*(int *)csp == store + last)) { *(int *)csp -= 0x28000000; // ->(B0) => DUP->(88) } else { plant (last + 1); // LOAD VAR } goto next; operator: if ((((a == plus) || (a == minus)) && (cstate < 0))) plant (zero); a = var (a, 0); cstate = initstate; c_20: /* 20 */ // "." c_21: /* 21 */ // "->" type = type & 0x7FFFFFFF; // NO SYNTAX BIT c_8: /* 8 */ // "(" pushop: asp += 4; if (asp >= sp) assert (__LINE__ == 0); setop: *(int *)asp = type + a; goto get; d_2: /* 2 */ // WORD AFTER QUOTE cstate += 1; // ADVANCE STATE goto get; d_3: /* 3 */ // ITEM AFTER QUOTED WORD if (a != quote) goto err; a = last; Const: if ((a & opbits) != 0) { plant (loadimm); cspbar = csp + 4; } p = a; if (a == 0) p = zero; plant (p); cstate = conststate; goto get; c_10: /* 10 */ // "[" (LB) seal (); d_4: /* 4 */ // & AFTER LB if (a == rb) { a = nil; while (*(int *)sp != lb) { a = paircell (*(int *)sp, a); sp += 4; } sp += 4; if (sp == spbar) { unseal (); goto Const; } } save (a); c_12: /* 12 */ // QUOTE nmget: nonmacflag = 1; goto get; c_9: /* 9 */ // "(%" c_11: /* 11 */ // "[%" plant (((a - wordmin) << 20) + 0x800000); goto pushop; c_43: /* 43 */ // "%)" c_42: /* 42 */ // "%]" plant (((a - wordmin) << 20) + 0x800000); c_44: /* 44 */ // ")" asp -= 4; goto get; c_14: /* 14 */ // "IF" p = 0; if1: if (codebase == 0) goto lerr; push (p); push (0); push (0); goto pushop; c_15: /* 15 */ // "LOOPIF" p = csp; cspbar = csp; goto if1; c_36: /* 36 */ // "AND" plantjump (jumpfals, asp - 4); goto setop; c_37: /* 37 */ // "OR" plantjump (jumptrue, asp - 8); goto setop; c_38: /* 38 */ // "THEN" plantjump (jumpfals, asp - 4); unchain (asp - 8); goto setop; c_35: /* 35 */ // "ELSEIF" c_34: /* 34 */ // "ELSE" plantjump (jump, asp - 12); unchain (asp - 4); goto setop; c_40: /* 40 */ // "EXIT" plant (Return + csp - codebase - 4); c_41: /* 41 */ // "CLOSE" if (*(int *) (asp - 12) <= 0) unchain (asp - 12); else plantjump (jump, asp - 12); // IF/LOOPIF unchain (asp - 4); asp -= 16; goto get; c_32: /* 32 */ // "RETURN" plant (Return + csp - codebase - 4); c_33: /* 33 */ // "GOTO" if (codebase == 0) goto lerr; goto get; d_5: /* 5 */ // WORD AFTER "GOTO" lookuplabel (a); plantjump (jump, labpos); goto get0; d_7: /* 7 */ // WORDS AFTER "CANCEL" if (a == semicolon) goto get0; *(int *) (a + 14) = ((*(int *) (a + 14)) & adbits) | canbit; goto get; d_14: /* 14 */ // ITEMS AFTER "COMMENT" if (a == semicolon) goto get0; goto nmget; // auto void declare (void) { int p; int q; a = var (a, vtype); if (((a < syslim) || (((*(int *) (a + 14)) & typebits) != vtype))) { comment (" CLASH ", a); return; } if (codebase == 0) return; p = codebase + 12; // FIRST INSTRUCTION OF FUNCTION while ((p <= csp) && (((*(int *)p) & savemask) == varsave)) { if (((*(int *)p) & adbits) == a) comment (" DUP ", a); p += 4; } q = csp; csp += 4; if (csp >= pairlo) assert (__LINE__ == 0); while (q >= p) { *(int *) (q + 4) = *(int *)q; q -= 4; } *(int *)p = saveop + a; } c_28: /* 28 */ // "OPERATION" opener = type + a; getp: cstate += 0x80000003; // ADVANCE STATE, INCLUDE CONST goto get; d_11: /* 11 */ d_12: /* 12 */ // ITEM AFTER "OPERATION" if (!(((a & 7) == 0) && ((0 < a) && (a <= 9 * 8)))) goto err; vtype = (a << 21) + varbit; // >>3<<24 cstate -= 0x80000003; // RESTORE STATE goto get; c_27: /* 27 */ // "MACRO" opener = type + a; getm: vtype = macbit; goto nmget; c_26: /* 26 */ // "FUNCTION" opener = type + a; c_29: /* 29 */ // "VARS" saveop = varsave; getv: if ((cstate & rpbit) == 0) vtype = varbit; goto get; d_8: /* 8 */ // WORD AFTER "FUNCTION" ETC if (type < 0) goto err; saveop = varsave; declare (); cstate += 1; goto funstart; c_13: /* 13 */ // "LAMBDA" opener = type + a; funstart: push (codebase); push (opener); codebase = csp; plant (a); plant (undef); // FNPROPS, UPDATER seal (); // SEAL MAIN STACK saveop = insave; goto getv; d_9: /* 9 */ // PROCESSING VARS if (type >= 0) { declare (); goto getv; } if (a == semicolon) goto c9; if ((a == parrow && saveop == insave)) { saveop = outsave; goto get; } if ((a == lp || a == rp)) { cstate = cstate ^ lprpbits; goto get; } if (a == macro) goto getm; if (a == operation) goto getp; goto verr; // c_45: /* 45 */ // "END" // CHECK LABELS while (sp < spbar) { if (*(int *) (sp) < 0) { // LABEL NOT DEFINED unchain (sp); comment (" LAB ", *(int *) (sp + 4)); } sp += 8; } unseal (); // CREATE FUNCTION plant (Return + csp - codebase - 4); a = stripcell ((csp - codebase) << 14) - 1; // >>2<<16 q = striphi; while (csp != codebase) { q -= 4; *(int *) (q + 2) = *(int *) (csp); csp -= 4; } asp -= 8; codebase = *(int *) (asp + 4); q = *(int *) (a + 7); // FNPROPS (FUNCTION NAME) if (q == lambda) goto Const; plant (a); plant (store + q); // c_23: /* 23 */ // ; c9: a = semicolon; if (!(*(int *) (asp) >= 0)) goto get0; c_47: /* 47 */ // "GOON" plant (((a - wordmin) << 20) + 0x800000); pc = pvbase + 4; asp = *(int *) (pvbase - 12); prompt (">"); goto x0; c_24: /* 24 */ // ":" c_25: /* 25 */ // "=>" if (codebase == 0) { plant (((a - wordmin) << 20) + 0x800000); goto c9; } plantinst (pr); goto get0; c_39: /* 39 */ // "SWITCH" c_16: /* 16 */ // "]" (RB) c_17: /* 17 */ // "$" c_30: /* 30 */ // "SECTION" c_46: /* 46 */ // "ENDSECTION" error = 1; goto report; verr: last = opener & adbits; err: error = 2; goto report; gerr: last = *(int *) (asp) & adbits; error = 3; goto report; aerr: error = 4; goto report; lerr: error = 5; goto report; report: p = a; announce (" ERROR"); write (error, 1); if (last != terminval) { spaces (2); putitem (last); } if (error != 4) { spaces (2); putitem (p); } putsym (symnl); if (pos == 0) goto c99; errpos = pos1; cstate = skipstate; d_15: /* 15 */ // SKIPPING if (!((a == end || (a == goon || (sym == symnl || pos == 81))))) goto nmget; if (pos != 0) { announce ("*"); for (p = 1; p <= pos; p += 1) { if ((p == errpos && error != 4)) printsymbol ('!'); printsymbol (poptoiso[Char[p]]); } } if (codebase == 0) goto start; c99: mon = varsave; // x_0x28: /* 0x28 */ // RESUME inst = savedinst; pc = *(int *) (asp); asp -= 4; return; x_default: assert (((unsigned int)inst >> 24) == -1); return; d_default: assert ((cstate & 15) == -1); return; c_default: assert (((unsigned int)(a - wordmin) >> 4) == -1); return; } // E X E C U T E // // MAIN PROGRAM // int i; int j; int k; int p; // // %FAULT 1,2,5,6,17,21,22,23,24,25,27 ->ER20 if (event (1) == 0) goto er20; if (event (2) == 0) goto er20; if (event (5) == 0) goto er20; if (event (17) == 0) goto er20; if (event (21) == 0) goto er20; if (event (22) == 0) goto er20; if (event (23) == 0) goto er20; if (event (24) == 0) goto er20; if (event (25) == 0) goto er20; if (event (27) == 0) goto er20; if (event (6) == 0) goto er20; // %FAULT 10->ER20, 11->ER21, 16->ER0 if (event (10) == 0) goto er20; if (event (11) == 0) goto er21; if (event (16) == 0) goto er0; // %FAULT 3->ER30, 4->ER31 if (event (3) == 0) goto er30; if (event (4) == 0) goto er31; // %FAULT 7->ER39, 9->ER29, 19->ER32 if (event (7) == 0) goto er39; if (event (9) == 0) goto er29; if (event (19) == 0) goto er32; // %FAULT 32 ->ER5 if (event (32) == 0) goto er5; // // // auto void setup (void) { int i; int j; int k; int q; int w1; int w2; w1 = 0; w2 = 0; do { readch (&k); } while (!((k != ' ' && k != '\n'))); i = 26; while ((k != '_' && k != '!')) { k = isotopop[k] + 1; if (i >= 0) w1 = w1 | (k << i); else { if (i >= (-(16))) w2 = w2 | (k << (30 + i)); } readch (&k); i -= 6; } if (k == '!') { *(int *) (p) = wordhi; p += 4; } i = 0; j = 0; for (;;) { readch (&k); if (k == '_') { i = j << 24; j = 0; readch (&k); } if (!(('0' <= k && k <= 'F'))) break; if (k >= 'A') k -= ('A' - '0' - 10); j = (j << 4) + (k - '0'); } if (k != 'P') q = wordlook (w1, w2); else q = wordcell (w1, w2); // VISIBLE/PRIVATE if (k >= 'R') { if (k == 'R') j += q; // SELF-REF (EG NIL) if (k == 'T') j += stream0; if ((k == 'S') || (k == 'T')) j = j + ((q - wordmin) << 20) + 1; // SYS FUNCTION if (i == 0) i = varbit; } *(int *) (q + 2) = j; *(int *) (q + 14) = i; } // INITIAL ENTRY newline (); printstring (identification); newline (); outfile ("POPTEMP", (-(262144)), 262144, 0x40000000, &storebase, &i); if (i != 0) { printstring (ssfmessage ()); exit (0); } stream0 = storebase + 16; // ALLOW FOR EMAS HEADER streamlim = stream0 + 128; stackmin = streamlim + 256; // ITEM INFO -> <- CLASS INFO stacklim = stackmin + 6000; // AUX STACK -> <- MAIN STACK (1500 SLOTS) wordmin = stacklim + 150002; // COMP STACK -> <- PAIRS (C 18000 PAIRS) stripmin = wordmin + 16000; // 1000 'WORDS' -> // STRIPS (C 90000 BYTES) -> storelim = storebase + 262146; wordbase = wordmin - 16; // FOR RELATIVISING HASH LINKS streammax = stream0; restart: pairfree = 0; wordfree = 0; itemhi = streamlim; classlo = stackmin; pairlo = wordmin - 40; baseprog = pairlo; wordhi = wordmin; striphi = stripmin; for (i = 0; i <= 127; i += 1) { index[i] = 0; } if (strcmp (popparm, "")) { /* set up external streams *//*define (concat ("ST15,ECMI05.POPSET11+", popparm)) */ ; } else define ("ST15,ECMI05.POPSET11"); baseitem = stream0 + 15 * 8; // FOR READING POPSET FILE selectinput (15); inref = baseitem; outref = stream0; p = (int)&nil; undef = wordmin + 16; // *USED BY WORDCELL* for (i = 1; i <= 214; i += 1) { setup (); } zero = false + 1; *(int *) (stream0) = symnlx; outsym = symnl; for (i = 0; i <= 7 * 16; i += 16) { classlo -= 4; *(int *) (classlo) = intgr + i; } *(int *) (stackmin - 12) = function; // DATAWORD NOT IN SEQUENCE syslim = primlim; // *WHILE COMPILING SYSLIB* again: intflag = 50; nonmacflag = 0; macstream = nil; macend = (int)&macstream - 6; inst = 0; pc = 0; codebase = 0; pvbase = 0; asp = stackmin; *(int *) (stackmin) = resume; sp = stacklim; spbar = sp; csp = stacklim; execute (startfun); reset: syslim = syntax; baseitem = stream0; announce ("\nSETPOP\n"); goto again; // // er21: error = 20; j = 1; goto er1; // OPERANDS ERROR er20: error = 20; // OPERAND(S) ERROR er0: j = 0; er1: p = nil - 8; k = (inst & adbits) - 1; if (((k & 3) != 2) || (k < syslim)) { k = b; b = nil; } *(int *) (p + 2) = k; *(int *) (p + 6) = b; if ((inst < 0 || j != 0)) { p -= 8; *(int *) (p + 2) = a; *(int *) (p + 6) = p + 8; } goto err; er29: error = 29; goto er2; // INPUT ENDED er30: error = 30; goto er2; // STACK UNDERFLOW er31: error = 31; goto er2; // STACK OVERFLOW er32: error = 32; goto er2; // GARBAGE ON STACK er39: error = 39; // SWITCH LABEL NOT SET er2: p = nil; err: if ((inst & opbits) != 0) { p -= 8; *(int *) (p + 2) = (inst & opbits) + 1; *(int *) (p + 6) = p + 8; } // announce (" ERROR"); write (error, 1); if (p != nil) { spaces (2); putitem (p); } putsym (symnl); // if (error == 31) goto reset; mon = varsave; // er5: while (pvbase != 0) forcereturn (); goto reset; } void logopop (char *s) { if (strcmp (s, "")) /*pop2 (concat (s, "+ECMI05.LOGSET11")) */ ; else pop2 ("ECMI05.LOGSET11"); } int event (int n) { #ifdef ICL475 asm ("L 1,N"); asm ("LR 10,8"); asm ("BAL 15,80(12)"); asm ("LA 8,0(10)"); asm ("LA 10,0"); asm ("ST 11,44(8)"); asm ("LR 1,10"); asm ("LM 4,15,16(8)"); asm ("BCR 15,15"); #endif return (1); }