// IMP15 syntax checker // cc -o imp15chk imp15chk.c // Started off as imp15 compiler but removed all I/O except stderr error reporting. // Quite fast now! /* EPC Imp to C Translation Release 4 Version Apr 95 */ //#include "imptoc.h" #include #include #include #include #include #define nl '\n' static char *prims_and_perms = "%INTEGER A,B,C,D,E,F,G; !W1,W2,W3,MONI,NEST,LE,GE\n" "%INTEGER H,I,J,K,L,M,N,O; !AREF,ADEC,SHIFT,OR,MULT,DIV,IDIV,EXP\n" "%INTEGER P,Q,R,S,T,U,V; !ENT,FLT,DA,SPARE,BAREF,BGET,BPUT\n" "%INTEGER W,X,Y,Z; !SPARE,SPARE,UNKNOWN,UNKNOWN\n" "%ENDOFPRIM\n" "%CONSTINTEGER NL=10\n" "%INTEGERFNSPEC ADDR(%INTEGERNAME V); !TAG NO 28\n" "%INTEGERMAPSPEC INTEGER(%INTEGER A); !TAG NO 29\n" "%ROUTINESPEC SELECTINPUT(%INTEGER I)\n" "%ROUTINESPEC SELECTOUTPUT(%INTEGER I)\n" "%ROUTINESPEC READCH(%INTEGERNAME I)\n" "%ROUTINESPEC PRINTCH(%INTEGER I)\n" "%INTEGERFNSPEC NEXTSYMBOL\n" "%ROUTINESPEC READSYMBOL(%INTEGERNAME I)\n" "%ROUTINESPEC SKIPSYMBOL\n" "%ROUTINESPEC PRINTSYMBOL(%INTEGER I)\n" "%ROUTINESPEC PRINTTEXT; !TAG NO 38\n" "%ROUTINESPEC NEWLINE\n" "%ROUTINESPEC NEWLINES(%INTEGER I)\n" "%ROUTINESPEC SPACE\n" "%ROUTINESPEC SPACES(%INTEGER I)\n" "%ROUTINESPEC READ(%INTEGERNAME P)\n" "%ROUTINESPEC WRITE(%INTEGER N, I)\n" "%ROUTINESPEC CLOSEINPUT\n" "%ROUTINESPEC CLOSEOUTPUT\n" "%ROUTINESPEC READDA(%INTEGER U,B,%INTEGERNAME S,L)\n" "%ROUTINESPEC WRITEDA(%INTEGER U,B,%INTEGERNAME S,L)\n" "%INTEGERFNSPEC INSTREAM\n" "%INTEGERFNSPEC OUTSTREAM\n" "%INTEGERFNSPEC INDEV\n" "%INTEGERFNSPEC OUTDEV\n" "%INTEGERFNSPEC INPUT\n" "%ROUTINESPEC PROMPT(%INTEGER I)\n" "%INTEGERFNSPEC FREESTORE\n" "%INTEGERFNSPEC TINT\n" "%ENDOFPERM\n"; /* input streams */ #define prim 2 #define prog 1 static int current_input = prim; static int statements = 0; static FILE *source_file = NULL; int myfgetc(void) { static int ch; if (current_input == prim) { if (ch == EOF) { fprintf(stderr, "reading prim past EOF\n"); } ch = *prims_and_perms; if (ch == '\0') { ch = EOF; } else { prims_and_perms += 1; //fputc(ch, stderr); } return ch; } else { if (ch == EOF) fprintf(stderr, "reading source past EOF\n"); ch = fgetc(source_file); //fputc(ch, stderr); if (ch == '\n') statements += 1; return ch; } } int myungetc(int c) { //fputc(8, stderr); if (current_input == prim) { prims_and_perms -= 1; return *prims_and_perms; } else return ungetc(c, source_file); } int main(int argc, char **argv) { /* IMP15 SYNTAX CHECKER 26/09/22 */ /*PRIMITIVE ROUTINE TAGS */ static const int moni = 4; /* MONITOR */ static const int nst = 5; /* NEST */ static const int le = 6; /* TEST LESS-THAN OR EQUAL */ static const int ge = 7; /* TEST GREATER-THAN OR EQUAL */ static const int ar = 8; /* ARRAY REFERENCE */ static const int adec = 9; /* ARRAY DECLARATION */ static const int sh = 10; /* SHIFT */ static const int ent = 16; /* PROCEDURE ENTRY/EXIT */ static const int flt = 17; /* FAULT TRAP */ static const int bar = 20; /* BYTE ARRAY-REF */ static const int bget = 21; /* BYTE FETCH */ static const int bput = 22; /* BYTE STORE */ static const int adr = 28; /* ADDR */ static const int Int = 29; /* INTEGER */ static const int ptxt = 38; /* PRINT TEXT */ /*DECLARATION CODES */ static const int beg = 108; /* BEGIN */ static const int ext = 128; static const int own = 64; static const int body = 64; static const int ref = 32; static const int array = 8; static const int proc = 4; static int line = 1; /* LINE NUMBER */ static int lines = 0; /* LINE COUNT */ static int sym = 0; /* CURRENT INPUT SYMBOL */ static int symtype = 0; /*-2:LET, -1:DIG, 0:TERM*/ /* 1:OTHER, 2:KEYLET */ static int decl = 0; /* DECLARATOR TYPE */ static int sstype = 1; /* STATEMENT TYPE */ static int section = 0; /* 0:INSTR, 1:DATA */ static int ownc = 0; /* OWN COUNT */ static int faulty = 0; /* FAULT INDICATOR */ /*CURRENT INPUT LINE */ static int pos1 = 0; /* START-OF-ATOM POSITION */ static int pos = 0; /* CURRENT CHAR POSITION */ int Char[73 + 1]; /*NAME DICTIONARY */ static int dmax = 0; /* NAME DICT MAX */ static const int dbound = 500; /* UPPER BOUND (CHANGED FROM 350) */ int dict[dbound + 1]; /*TAG INFO */ static int global = 0; /* ZERO OR ENDOFPRIM TAG */ static int tmax = 0; /* TAG MAX */ int x; /* CURRENT TAG (WHEN RELEVANT) */ static int lmin = 253; /* COMP LAB MIN */ int *tt0, *ttx; /*==TAGTYPE(0),TAGTYPE(X)*/ int tagtype[223 + 1]; int index[223 + 1]; /* SIGNIFICANCE OF TAGTYPE VALUES: */ /* VAL256+ VAL128 VAL64 VAL32 VAL0:15 */ /* 0 0 SET 0 0 0 0 0 LABEL */ /* 0 EXT OWN REF 0 0 0 1 INTEGER (EXT+OWN=CONST) */ /* 0 0 OWN REF 0 0 1 0 BYTE */ /* GRAM AD SAFE/EXT BODY REF 0 1 0 0 PRED */ /* GRAM AD SAFE/EXT BODY REF 0 1 T T FN */ /* 0 0 0 0 0 1 1 1 STRING */ /* BOUNDS AD 0 1 0 1 0 0 0 SWITCH */ /* 0 0 OWN REF 1 0 T T ARRAY */ /* GRAM AD SAFE/EXT BODY REF 1 1 0 0 ROUTINE */ /* GRAM AD SAFE/EXT BODY REF 1 1 T T MAP */ /* 0 0 1 1 1 1 0 0 BEGIN */ /* NEVER STORED IN TAGTYPE */ /* 0 0 0 1 0 1 0 0 SPEC */ /*ANALYSIS RECORD */ int ss; /* START OF SS */ static const int nodebound = 70; int refco[nodebound + 1]; int sub[nodebound + 1]; /** GRAMMAR AND KEYDICT GENERATED BY TAKEON PROGRAM*/ static int gmax1 = 196; static int gmax = 196; static int phrase[127 - 111] = { 194, 69 , 72, 77, 81, 115, 125, 147, 153, 156, 159, 168, 173, 176, 188, 0 }; static int atomic[111 - 79] = { 64, 70, 72, 77, 68, 69, 73, 67, 73, 73, 74, 77, 76, 77, 78, 78, 65, 65, 66, 66, 74, 78, 74, 12, 18, 15, 15, 65, 10, 15, 9, 42 }; static int initial[79] = { 36225, 35842, 33923, 3332, 68741, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -118767, 0, 0, 3604, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -131041, 0, 0, -117854, -117981, 3876, -117595, -117722, 0, 2088, 4009, 0, 0, 0, 0, 33838, 33071, 0, 0, 1842, 1075, 1460, 3765, 0, 66615, 99384, 33849, 33850, 98363, 0, 0, 0, 0, 35664, -118944, -118429, 0, 0, 0, 0, 0, 35794, -118058, -118044, 0, -118196, -118061, -118043, 0 }; static int gram[255 + 1] = { 0, 756, -129612, -129999, 1140, -94156, -94155, -129132, 9, -126846, 4996, 1653, -128746, 1073, -131063, 33918, -129978, 1095, -129999, 2676, -130640, 9, 10, 5134, 1137, 5329, 5745, 6129, 6526, 6517, 39367, 33913, 33909, 4465, -126452, 110, 37625, -126739, 110, 6726, 40441, 5376, -123378, 9, 38642, -127729, 9, 39027, -127601, 9, 1074, 7825, 39667, -124020, 110, -123127, 7417, -123923, 110, 2832, 8070, 1088, 7040, 8262, -122481, -123002, 1040, -122810, 8070, 9030, -122225, 0, 9358, 9594, 9610, 9850, 16, 9998, 10233, 10348, 9849, -118944, -118767, -118196, -118058, -118061, -131041, -117981, -117854, -118429, -118044, -118043, -117722, 13477, -117492, 46494, -131008, 46664, -117492, 46750, 46960, 47216, 32890, 32887, 46915, 32839, 46970, 79735, 65648, 79736, -116497, 0, 80231, 116, 112506, -115978, 15482, -82774, -82645, 0, 32768, 15862, 15222, -82774, 0, -114546, -114004, -113852, 16890, -121227, 17402, -112979, 32768, 118, 32880, 17424, -112870, -112741, -112612, -112979, 32768, 51450, 50301, 50428, 50555, -117971, 0, -111775, -113832, 17243, -78819, 0, 65658, -111774, -113818, 17247, -117608, -117607, 32839, -110439, -109800, 53629, -110438, -109669, -109796, 0, 53883, 53756, 54525, -109542, -109029, 0, 54652, 55165, -108902, 0, -131007, -131001, -131006, -113847, -113851, -113843, -113846, -113842, -121458, 23826, 24061, 104, 24299, 24332, 57338, 24681, 57594, 13162, 24974, 25210, 16, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; static int kdict[425 - 31] = { 0, 387, 131, 403, 131, 131, 407, 131, 411, 415, 419, 431, 447, 451, 131, 475, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 487, 490, 495, 523, 539, 131, 131, 556, 628, 656, 708, 752, 904, 128, 128, 972, 1152, 128, 1188, 1232, 1248, 1256, 1284, 128, 1348, 1440, 1552, 1604, 128, 1636, 1648, 128, 128, 131, 1695, 131, 131, 131, -118367, -64814, 66268, 66204, 106541, 65947, 65550, 65552, -117462, 66331, 66522, -116949, -65448, 65628, 66013, 65551, -116051, -116162, -65384, 65692, 65553, 66077, -115665, 66459, 66395, 65546, 65545, -114500, -114627, -114754, 69677, 65818, 77869, 65818, -113987, -57332, 73773, 66142, -113347, -113474, 110637, 65882, 102445, -112188, 8782, -112349, -112470, -60760, 65578, 71336, 68265, -111039, -111676, 82, 70696, -111197, -111318, 70056, 71080, 68009, 71592, -110395, 10841, 69, 65728, 9415, 78, 65591, -108534, -109361, 8665, 8908, 65586, -108851, 10702, 84, 77827, 8909, 10830, 65547, 65536, -107711, 9946, -107862, 69864, 70888, -107325, 68, 71528, -107094, 69736, 70760, -102452, -105010, 88, -105271, 84, -105659, 9426, 10702, 8649, 73731, 10066, 9793, 73728, 84, 66847, 68, -104625, 65592, 70, -102842, 80, -103099, 82, -103351, 9167, 8402, 77, 65595, 77, 65593, 9938, 65594, 9801, 69, 65595, 8915, -65489, 65584, -100671, -101559, 10575, 65556, 9422, 9299, -101051, 65582, 10700, 69, 65583, -100148, 9813, 84, 65572, 8915, 66719, -94266, -98738, -98993, 11603, -99158, 70248, 71272, 84, 70568, 8916, 8903, 82, -95295, -96186, -97075, -97586, -65470, 65606, 9921, 69, -63422, 67654, 10305, -96557, -60603, 70470, 8912, 67, 66373, 78, -95661, -61115, 69958, 8912, 67, 65861, 10578, 11457, -94770, 66116, 9921, 69, -62910, 68166, 66356, 77, -93360, 83, -93526, 69800, 70824, -93142, 70440, 71464, -92607, 10825, 67817, -92221, 68, 71656, -91741, -91862, 69928, 70952, 67881, 10063, 10825, 10575, 65573, 10831, 65580, -90160, -90286, 10071, 69635, 65579, 82, 70632, 82, -89019, 10057, 10836, 11333, 84, 65574, 9412, 8387, 8916, -88237, -61179, 69894, 8912, 67, 65797, -86587, 10959, 9428, 8910, -86957, -60667, 70406, 8912, 67, 66309, -85296, -85933, 10964, 10066, 66591, 9813, 7892, -85443, 65571, 65570, 8389, 84, 65587, -82111, -82488, -82736, -83884, 9431, 8660, 72, 70145, -83007, -83249, 9426, 9166, 65990, 80, 66783, 10834, 65585, 8645, 67845, 10575, 84, 65536, 68, -81501, -81622, 70376, 71400, 68329, -80447, -80696, 10962, 69, 66655, 10053, 65558, 68, -79837, -79958, 70120, 71144, 68073, 78, -79028, 9428, 76, 67061, 10693, 83, 66484, 9416, 8908, 66869, -77373, 10575, -77533, -77654, 69992, 71016, 67945, 84, -77014, 70184, 71208, -76611, 65753, 106541 }; /*!END OF GENERATED SECTION */ int *app; /*== PHRASE(112)*/ int bapp; /* BASIC APP IE LB EXP RB */ int *mref; /*== MAP RESULT REF*/ void compileblock (int level, int btag, int *btype, int *gd) { /* void printss (int s); int gapp (void); void fault (int n); void analyse (void); void compile (void); */ static int ac = ~255; static int aclit = 0; int tbase, dbase, lstack, estack, pmax, atag, danger, access, extind; void printss (void) { int k, p; fprintf (stderr, "%4d ", line); p = 1; for (;;) { if (p == pos1) fprintf (stderr, "^"); if (p == pos) break; k = Char[p]; p++; if (k == nl || (k == '%' && p == pos)) break; fprintf (stderr, "%c", k); } fprintf (stderr, "\n"); } int gapp (void) { /* GRAMMAR FOR APP */ static const int comma = 15; static const int lb = 14; int i, l; int class (int k) { if ((k & (array + proc)) != 0) return (k & 15) + 80; /* PROC AND ARRAY PARAMS */ if ((k & ref) == 0) return 122; /* INTEGER->EXP(122) */ if ((k & 2) == 0) return 119; /* INTEGERNAME->REF(119) */ return 120; /* BYTEINTEGERNAME->BREF(120) */ } void setgcell (int c) { c += l << 7; /* LINK + CLASS */ while (l != gmax) { l++; if (gram[l] == c) return; } gmax++; l = gmax; gram[l] = c; } i = tmax; if (i == tbase) return 255; /* NULL APP (FOR NOW) */ l = gmax1; /* ')' CELL */ for (;;) { setgcell (class (tagtype[i])); i--; if (i == tbase) break; setgcell (comma); /* ',' CELL */ } setgcell (lb); /* '(' CELL */ return l; } void fault (int n) { if (n > 2) pos1 = 0; if (pos != 0) printss (); fprintf (stderr, "*"); switch (n) { case 0: fprintf (stderr, "FORM"); goto f; case 1: fprintf (stderr, "ATOM"); goto f; case 2: fprintf (stderr, "NAME"); goto f; case 3: fprintf (stderr, "SIZE"); goto f; case 4: fprintf (stderr, "DUPLICATE"); goto f; case 5: fprintf (stderr, "%%BEGIN"); goto m; case 6: fprintf (stderr, "%%CYCLE"); goto m; case 7: fprintf (stderr, "%%START"); goto m; case 8: fprintf (stderr, "%%END"); goto m; case 9: fprintf (stderr, "%%REPEAT"); goto m; case 10: fprintf (stderr, "%%FINISH"); goto m; case 11: fprintf (stderr, "%%RESULT"); goto m; case 12: fprintf (stderr, "''"); m: fprintf (stderr, " MISSING"); goto f; case 13: fprintf (stderr, "BOUNDS"); goto f; case 14: fprintf (stderr, "INDEX"); goto f; case 15: fprintf (stderr, "CONTEXT"); goto e; case 16: fprintf (stderr, "ACCESS"); goto a; case 17: fprintf (stderr, "ORDER"); goto f; case 18: fprintf (stderr, "MATCH"); f: faulty += 1; a: access = -1; e: fprintf (stderr, "\n"); if (symtype == 0) pos = 0; return; default: fprintf(stderr, "* switch label not set - s(%d):\n", n); exit (faulty+1); } } // end fault void analyse (void) { static const int comma = 15; int atom1, atom2, subatom, last, head, max, dup, text, lim, index0; int k, n, s, g, class, nmin, nmax; int *z; static int quote = 0; static int key = 0; static int gg = 0; void readsym (void) { if (sym != nl) goto z2; pos = 0; pos1 = 0; z1: symtype = 1; z2: sym = myfgetc (); if (pos != 73) pos++; Char[pos] = sym; if (sym != nl) { if (quote != 0) return; if (sym == ' ') goto z1; if (sym == '%') { symtype = 2; goto z2; } /*KDICT(33:95) := LINK<9>:CODE<2> */ if (sym >= 96) sym -= 32; key = kdict[sym - 32]; if ((key & 3) != 0 || symtype != 2) symtype = (key & 3) - 2; } else { lines++; symtype = quote; /* 0,>0 */ } } /* READ SYM */ void codeatom (int target) { /*TARGET (IF SPECIFIED) IS FIRST ATOM CLASS FROM GRAMMAR */ int i, j, k; void lookup (int d) { static int i; /* OWN FOR OPTIMISATION */ int j, k, l, m; i = (index0 + tmax) + 1; l = index0 + lim; rep: i--; if (i == l) goto new; if ((index[i] & (~511)) != head) goto rep; j = index[i] & 511; k = max; while (k != dmax) { m = dict[k]; if (dict[j] != m) goto rep; j--; k--; } subatom = i - index0; ttx = &tagtype[subatom]; atom1 = (*ttx & 15) + 64; /*SET UP GRAM FOR PARAMETERS */ if ((*ttx & proc) != 0) *app = (unsigned) *ttx >> 8; else *app = bapp; /*NON-DECLARATIVE CONTEXT */ if ((d & 255) == 0) return; /*SPEC FOR PROC PARAMETER */ if (d == 36 && *app == 0) return; /*LABEL AFTER JUMP, PROC AFTER SPEC */ if (((*ttx & 255) + body) == d) { *ttx += body; return; } dup = 1; new: if (d == 0) return; tmax++; subatom = tmax; ttx = &tagtype[subatom]; *ttx = d; atom1 = (*ttx & 15) + 64; index[tmax] = head + max; dmax = max; } /* LOOKUP */ z1: pos1 = pos; atom1 = 9; atom2 = 0; subatom = 0; if (symtype == 0) return; /* NL OR SEMI-COLON */ if (symtype == -2) goto name; /* LETTER -> */ if (symtype < 0) goto number; /* DIGIT -> */ if (quote != 0) goto quoted; /* QUOTED SYMBOL -> */ if (sym == '\'') goto quotemark; if (sym == '"') goto string; /*LOCATE ATOM IN FIXED DICT */ /*KDICT(96:KMAX) := MORE<1>:0<1>:LINK<9>:SYM<7> */ /* OR MORE<1>:1<1>:SUBCLASS<10>:CLASS<6> */ i = (unsigned) key >> 2; readsym (); for (;;) { j = kdict[i - 32]; if ((j & 65536) != 0) break; if ((j & 127) != sym || symtype < 0) { if (j >= 0) goto err; i++; } else { k = ((unsigned) j >> 7) & 511; readsym (); if (j > 0) { if (k != 0) { if (k != sym || symtype < 0) goto err; readsym (); } k = i + 1; } i = k; } } atom1 = j & 63; /* ATOM CLASS */ subatom = ((unsigned) j >> 6) & 1023; if (atom1 == 0 && subatom == 0) goto z1; /* C NL, (SHORT) */ if (j < 0) atom2 = kdict[i + 1 - 32] & 63; /* VARIANT ATOM CLASS */ if (atom1 >= 8) return; /* DECLARATOR */ if (last >= 8) decl = 0; /*CUMULATE SUBATOM INFO IN DECL (FOR MULTI-WORD KEYWORDS) */ decl ^= subatom; /*ADJUST PROCEDURE-TYPE PARAMETERS */ if (last != 0 && (decl & proc) != 0) decl = (decl - body) + ref; /* PROC PAR */ if (atom1 != 0) return; /*EXTERNAL, BYTE */ if (symtype > 0) goto z1; err: atom1 = -1; return; quoted: if (last != comma) { atom1 = comma; return; } /* INFILTRATE COMMA */ quotemark: if (last == 38) goto string; /* PRINTTEXT */ quote = sym; readsym (); atom1 = 71; subatom = sym; /* SCONST */ if (sym == quote && myungetc (myfgetc ()) == quote) readsym (); if (myungetc (myfgetc ()) != quote) return; readsym (); goto endquote; string: quote = sym; readsym (); atom1 = 67; subatom = text; /* STRING */ j = 0; while (sym != quote || myungetc (myfgetc ()) == quote) { if (sym == quote) readsym (); if ((j & (~127)) != 0) { dict[text] = j; text--; if (text == dmax) { /*TOO LONG */ atom1 = -3; text++; } j = 0; } j = (j << 7) + sym; readsym (); } dict[text] = j - 131072; text--; endquote: quote = 0; readsym (); return; number: if (last == 17 || (last == 0 && section == 0)) goto name; /* JUMP OR LAB */ atom1 = 71; /* SCONST */ i = 10; /* DECIMAL */ for (;;) { subatom = 0; for (;;) { if (symtype == -1) k = sym - '0'; else k = (sym - 'A') + 10; if (k >= i) goto err; subatom += k; readsym (); if (symtype >= 0) break; j = i; k = subatom; subatom = 0; /* MULTIPLY BY RADIX */ while (j != 0) { if ((j & 1) != 0) subatom += k; k = k << 1; j = (unsigned) j >> 1; } } if (sym != '_') return; i = subatom; readsym (); if (symtype >= 0) goto err; } name: head = (sym - 32) << 12; max = dmax; for (;;) { readsym (); if (symtype >= 0) goto z25; head += 512; max++; j = sym - 32; readsym (); if (symtype >= 0) break; j = ((j << 6) + sym) - 32; readsym (); if (symtype >= 0) break; j = ((j << 6) + sym) - 32; dict[max] = j; } dict[max] = j; z25: atom1 = -2; atom2 = 70; /* IDENT */ lim = tbase; /* LOCAL */ if (last == 0 && sym == ':') { lookup (64); return; } /* LABEL */ if (last == 17) { lookup (256); return; } /* JUMP */ if (target == 70 && decl != 0) { lookup (decl); return; } /* IDENT */ lim = global; if (last == 40) lookup (256); else lookup (0); /* MCODE,NORMAL */ if (atom1 != 65 || (*ttx & (~255)) == 0) return; atom1 = 71; subatom = dict[(unsigned) *ttx >> 8]; /* CONSTINTEGER */ } /* CODE ATOM */ /* GRAM LAYOUT: MORE<1> ORDER<2> LINK<8> CLASS<7> */ ss = 0; sstype = 1; decl = 0; atom1 = 0; last = 0; dup = 0; text = dbound; index0 = 0; *mref = (*mref & (~127)) + 119; if ((*btype & 2) != 0) *mref += 1; nmax = 0; nmin = nodebound + 1; n = 0; if (gg == 0 || section != 0) { if (symtype == 0) readsym (); if (symtype == 0 || sym == '!') goto skp; codeatom (0); if (atom1 == 11) goto skp; /* COMMENT */ } if (gg != 0) goto l4; if (atom1 <= 0) goto z91; gg = initial[atom1 - 1]; if (gg == 0) goto z91; sstype = (gg << 1) & 0x30000; if (gg < 0) { /*INIT ATOM FOR IMP */ nmax = 1; refco[nmax] = 0; sub[nmax] = 1; } l1: last = atom1; atom1 = 0; s = subatom; l2: class = gg & 127; if (class >= 24) { /*NOT TRANSPARENT */ nmin--; if (nmin == nmax) goto z90; sub[nmin] = s; l3: z = &n; for (;;) { /*INSERT CELL IN ORDER */ k = *z & 127; if (k == 0 || (gg & 98304) == 0) break; gg -= 32768; z = &refco[k]; } refco[nmin] = (class << 7) + k; *z = (*z ^ k) + nmin; } l4: g = ((unsigned) gg >> 7) & 255; for (;;) { gg = gram[g]; class = gg & 127; if (class == 0) break; if (class < 112) { if (class >= 80) class = atomic[class - 80]; if (atom1 == 0) codeatom (class); if (class == atom1 || class == atom2) goto l1; if (gg >= 0) goto z91; g++; } else { nmax++; if (nmax == nmin) goto z90; refco[nmax] = n; sub[nmax] = g; n = 0; g = phrase[class - 112]; } } s = 0; while (n != 0) { /*REVERSE LINKS */ z = &refco[n]; k = *z & 127; *z = (*z ^ k) + s; s = n; n = k; } if (nmax == 0) goto l5; n = refco[nmax]; g = sub[nmax]; nmax--; k = gg; /* EXIT-POINT CODE */ for (;;) { gg = gram[g]; if (k == 0) break; if (gg >= 0) goto z91; k -= 32768; g++; } if (s == 0 || (*z & 127) != 0) goto l2; /* SINGLETON */ class = (unsigned) *z >> 7; /* DON'T BOTHER WITH NEW NODE */ goto l3; l5: ss = s; if (dup != 0) fault (4); return; /*ERROR */ z90: atom1 = -3; z91: while (sym != nl) readsym (); if (atom1 < 0) fault (-atom1); else fault (0); quote = 0; symtype = 0; decl = 0; section = 0; gg = 0; return; skp: while (symtype != 0) readsym (); } /* ANALYSE */ void compile (void) { //static const int lac = 68; //static const int lad = 95; static const int tad = 71; //static const int ada = 64; //static const int dac = 65; int i, j, k, next, link, class, bown = 0; int pend, pend1, pendopr, labcode, Else, lmain, ltag, lnest, final; int control=0x80808080, inc=0x80808080, end, ilit=0x80808080, elit; static int lit = 0; static int lit1 = 0; int c_value; void unass(int x) { if (x == 0x80808080) { fprintf(stderr, "? Warning: unassigned variable!\n"); } } void swop (void) { /* SWITCH SECTIONS */ section ^= 1; } void def (int t) { /* DEFINE TAG */ if (section != 0) return; access = 1; ac = ~255; } void print (int x) { if (pendopr >= 0) { if (next != link) final = 0; pendopr ^= final; /* INVERT SKIP IF FINAL */ if (final == 0) { labcode = lmain; } if ((lnest & 1) != 0) def (ltag - 1); pendopr = -1; access = 1; } } void nest (void) { print (nst); ac = ~ac; /* JMS NST (PRESERVES AC) */ } void pop (void) { ac = 255; /* LAC* T0 */ } void expend (void) { /* DISCHARGE PENDING LAC */ if (pend < 0) return; if (ac >= 0) nest (); if (~ac != pend) { if (pend == 0) { /*CONSTANT */ print (lit); } else { if (lit != 0) { print (lit); } print (pend & 255); } } else { if (aclit != lit) { if (pend == 0) { print (lit); } else { print (lit - aclit); } } } ac = pend; aclit = lit; pend = -1; } void load (int t) { /* LOAD AC */ expend (); pend = t; lit = 0; } void Do (int c) { /* (ADD),TAD,AND,XOR,SAD */ if (pend >= 0) { if (pend == 0) { /*CONSTANT */ print (lit); } else { if (lit != 0) { if (c == tad) { print (lit); } else { expend (); goto z1; } } print (pend); } } z1: pend = -1; if (c != 75) ac = 255; /* SAD */ } void store (int t) { /* DEPOSIT AC */ if (pend == 0 && lit == 0) { pend = -1; if (~ac == t) ac = ~255; final = 512; print (t); } else { if (pend == t && lit == 1 && ~ac != t) { pend = -1; final = 512; print (t); } else { expend (); if (pendopr < 0) { ac = t; aclit = 0; } ac = ~ac; /* ?? */ final = 512; print (t); } } } void opr (int x) { if ((x & 4125) != 0) ac = 255; } void not (void) { /* COMPLEMENT AC */ if (pend != 0) opr (1); else lit = ~lit; } void neg (void) { /* NEGATE */ if (pend < 0) { print (-1); } else lit--; not (); } void call (int t) { /* SUBROUTINE JUMP */ expend (); print (t); ac = 255; /* JMS T */ } void jmsx (int t) { /* SPECIAL JMS */ if (pend >= 0) { /*SECOND PARAM SIMPLE */ print (2); ac = ~ac; } else { store (1); pop (); store (2); load (1); } call (t); } void jump (int t) { /* JUMP */ print (t); } void mon (int n) { /* MONITOR */ print (moni); ac = ~255; access = 0; } void aref (void) { /* ARRAY REF */ call (ar); print (x); } void baref (void) { call (bar); print (x); } void plantown (void) { ownc--; if ((ownc & bown) == 0) { if (bown != 0) lit = (lit << 9) + lit1; } else lit1 = lit; } void compileend (void) { int i, j, k; while (lstack != 3) { fault ((lstack & 1) + 9); lmin += 2; lstack = (unsigned) lstack >> 2; } x = tmax; swop (); /* SELECT DATA SECTION */ if (danger != 0) i = -1; while (x != tbase) { ttx = &tagtype[x]; k = *ttx & 255; if (k == (own + array)) { /*SWITCH */ j = (unsigned) *ttx >> 8; if (j != 0) { swop (); def (x); j = dict[j]; while (j > 0) { j--; } /* NOP (JMP SET BY LOAD) */ swop (); } } if ((k & (ext + own)) == 0) { if (k == 0 || (k & (proc + ref)) == proc) fault (12); else { if ((k & ((ref + array) + proc)) == 0 && danger == 0) { def (x); /* DEFINE TAG DIRECT */ } else { def (-x); /* DEFINE TAG INDIRECT */ } i--; } } x--; } if (btag != 0) { def (btag); if (danger == 0) { if (pmax != tbase) { for (;;) { print (pmax); pmax--; if (pmax == tbase) break; pop (); } } } else { j = pmax - tbase; if (j != 0) j--; call (ent); /* JMS ENTRY/EXIT */ /*-SLOTS:-NEST*/ } if ((btag != danger) && (danger > 0)) *gd = btag; else *btype += ext; } swop (); /* REVERT TO INSTR SECTION */ } /*PROCESS ANALYSIS RECORD */ void save (int v) { dmax++; dict[dmax] = v; } int size (void) { int i; i = (lit - lit1) + 1; if (i <= 0 || i > 4095) { fault (13); i = 200; } return i; } void poplabel (int ind) { if (lstack == 3 || (lstack & 1) != ind) { fault (ind + 6); return; } labcode = lstack & 3; Else = estack & 1; lstack = (unsigned) lstack >> 2; estack = (unsigned) estack >> 1; lmin += 2; } void set (int *w) { if (pend != 0) { tmax++; *w = tmax; tagtype[*w] = 1; index[*w] = 0; /* DECLARE WL (INTEGER=1) */ store (*w); lit = 0; } else { *w = 0; pend = -1; } } void push (int andor) { if ((lnest & 2) != andor) { andor += 4; lnest |= 1; } if ((lnest & 1) != 0) ltag--; lnest = (lnest << 3) + andor; } void pcall (void) { /*PROCEDURE CALL */ call (x); if (danger != 0 && danger != btag) return; if ((*ttx & ext) == 0 && x <= pmax) danger = x; /* NOT SAFE */ } void mcall (void) { /*MAP CALL */ if (x == Int && pend > 0 && lit == 0 && (tagtype[pend] & (own + ref)) == own) { i = pend; pend = -1; } else { pcall (); i = 3; } } void restore (void) { if (pend1 >= 0) { pend = pend1; lit = lit1; ac = ~255; expend (); } else { pop (); } } /* end of restore */ void getnext () { int i; /*COMPILE DECLARATIONS */ if (next == 0) { next = refco[link] & 127; link = sub[link]; } for (;;) { x = sub[next]; ttx = &tagtype[x]; i = refco[next]; class = (unsigned) i >> 7; if (class < 112 || x == 0) break; /* ATOM OR NULL PHRASE */ if ((i & 127) != 0) { sub[next] = link; link = next; } next = x; } next = i & 127; } pend = -1; lit = 0; labcode = 0; Else = 0; pendopr = -1; if (ac >= 0) exit (0); next = ss; link = 0; if (sstype == 0 && access == 0) fault (16); z1: getnext (); z2: if (class <= 31) { c_value = x; } /* OPERATORS,SIMP */ else { c_value = class; } switch (c_value) { case 70: /* IDENT */ if ((*ttx & own) == 0) { if ((*ttx & ext) != 0) goto z811; if ((*ttx & (ref + array)) != array) break; /* SCALAR */ if ((*ttx & 2) != 0) { /*BYTE */ print (3); } if (ac >= 0) { /*FIRST IN GROUP */ if (lstack != 3) fault (17); jmsx (adec); /* JMS ADEC */ } else { /*BOUNDS ALREADY SET */ load (1); call (adec); /* LAC T1:JMS ADEC */ } atag = x; print (atag); ac = ~255; break; } ownc = 0; pend = -1; if ((*ttx & 3) == 0) { /*SWITCH */ save (-lit); save (size ()); z701: *ttx += dmax << 8; break; } if ((*ttx & ext) != 0) { /*CONST */ save (lit); goto z701; } if (section == 0) swop (); if ((*ttx & ref) != 0) x = -x; def (x); if ((*ttx & (ref + array)) != array) { if (level < 0) swop (); break; } ownc = size (); lit = 0; bown = 0; if ((*ttx & 2) == 0) break; bown = 1; ownc += ownc & 1; break; case 108: /* CONST BOUND SEP (COLON) */ lit1 = lit; pend = -1; break; case 109: /* OWNSEP (COMMA) */ if (ownc > 0) plantown (); lit = 0; pend = -1; break; case 110: /* OWNT (T) */ while (ownc > 0) { plantown (); lit = 0; } if (section != 0) swop (); /* REVERT TO INSTR SECTION */ return; case 81: /* PROCEDURE IDENT */ if ((*ttx & (ext + body)) == 0) { /*INTERNAL SPEC */ if (global == 0) *ttx += ext; /* PERM */ return; } z811: if ((*ttx & body) != 0) break; /* BODY */ print (x); break; /*COMPILE BEGIN,END */ case 57: /* ENDOFPRIM */ tbase = tmax; return; case 58: /* ENDOFPERM */ global = tbase; tbase = tmax; line = 1; lines = 0; current_input = prog; return; case 55: /* BEGIN */ if (level < 0) { /* MAIN BEGIN */ if (global == 0) { if (tmax == 0) tmax = 1; tbase = tmax; global = tbase; } sstype = 0; access = 1; level = 0; } else { tmax++; x = tmax; /* TREAT AS ROUTINE */ tagtype[x] = beg; index[x] = 0; call (x); ac = ~255; } return; case 56: /* END */ if (btag == 0) { /*MAIN PROGRAM */ fault (5); sstype = 0; return; } if (access != 0) { if (access > 0 && (*btype & 15) != 12 && global !=0) fault (11); print (btag); } if (danger == 0) danger = -atag; compileend (); print (tbase); if (extind == 0) return; if (level != 0) fault (15); return; case 59: /* ENDOFPROGRAM, ENDOFFILE */ if (access != 0) mon (0); danger = 0; if (level >= 0) compileend (); if (btag == 0) return; fault (8); /* MISSING END */ //assert (_IMP_MONITOR_); if (faulty == 0) { fprintf(stderr, "%d lines OK %d\n", statements, __LINE__); } exit (faulty); /*COMPILE LOOPS AND CONDITIONS */ /*LSTACK, ESTACK AND LNEST ARE SINGLE-WORD NESTS */ /*LSTACK (2 BITS) KEEPS TRACK OF STATEMENT BRACKETS */ /*ESTACK (1 BIT) KEEPS TRACK OF ELSE JUMPS */ /*LNEST (3 BITS) DEALS WITH INTERNAL STRUCTURE OF COND STATEMENTS */ /*SIGNIFICANCE OF LSTACK VALUES: */ /* 00 CYCLE */ /* 01 IF,UNLESS */ /* 10 FOR,WHILE,UNTIL */ /* 11 ELSE */ /*SIGNIFICANCE OF LNEST VALUES: */ /* 000 AND AFTER AND,IF */ /* 001 AS ABOVE + DISCONTINUITY */ /* 010 OR AFTER OR,UNLESS */ /* 011 AS ABOVE + DISCONTINUITY */ /* 100 IF / WHILE / AND AFTER OR,UNLESS */ /* 101 AS ABOVE + DISCONTINUITY */ /* 110 UNLESS / OR AFTER AND,IF */ /* 111 UNTIL / AS ABOVE + DISCONTINUITY */ /*COMPILE FOR LOOP */ /* ORDER = (START) CONTROL (INC) CSEP1 (END) CSEP2 (CYCLE,IMP) */ case 107: /* CONTROL VARIABLE */ control = x; pend1 = pend; lit1 = lit; /* START VALUE */ pend = -1; break; case 105: /* CSEP1 */ set (&inc); ilit = lit; break; case 106: /* CSEP2 */ set (&end); elit = lit; /* END VALUE */ unass(inc); load (inc); unass(ilit); lit = ilit; /* LAC INC */ neg (); if (pend1 < 0) { if (ac < 0) pop (); Do (tad); } else { if (pend != 0) { load (pend1); lit = lit1; Do (tad); } else { pend = pend1; lit += lit1; } } unass(control); store (control); /*= START-INC*/ def (lmin + 1); /* LAB FOR JUMP BACK */ load (control); /* LAC CONTROL */ load (end); lit = elit; Do (75); /* SAD END */ jump (lmin); /* JMP (NEXT INSTR) */ unass(inc); load (inc); lit = ilit; Do (tad); /* TAD INC */ store (control); /* DAC CONTROL */ labcode = 2; break; case 51: /* REPEAT */ poplabel (0); goto z11; /*COMPILE CONDITIONS */ /*STAT ORDER = CWORD COND IMP, CWORD COND START' */ /* CWORD COND IMP ELSE IMP, CWORD COND IMP ELSE START */ /*COND ORDER = AND C1 C2, OR C1 C2, NOT C1 */ /*SCOND ORDER = EXP1 EXP2 COP, EXP1 EXP2 COP EXP3 COP */ case 53: /* LWORD: WHILE(20), UNTIL(23) */ if ((x & 1) != 0) jump (lmin - 1); /* UNTIL - JUMP OVER TEST */ def (lmin + 1); /* LABEL FOR LOOPING */ case 52: /* CWORD: IF(12), UNLESS(14) */ labcode = 0; lmain = (unsigned) x >> 3; lnest = x & 7; ltag = lmin; break; case 42: /* AND */ push (0); break; case 43: /* OR */ push (2); break; case 44: /* NOT */ lnest ^= 2; break; case 45: /* COP: <(64), =(128), <=(192), >=(576), #(640), >(704) */ if (next != 0) push (0); /* DOUBLE-SIDED */ if (pend == 0 && lit == 0) { /*COMPARISON WITH ZERO */ pend = -1; if (next != 0) x += 4096; /* +CLA IF DOUBLE */ } else { k = pend; if ((x & 64) != 0) { /*<,<=,>=,> */ if (pend == 0 && lit > 0 && next == 0) { print (64); neg (); Do (tad); } else { if ((x & 128) != 0) { /*<=,> */ jmsx (le); x ^= 448; /* SZL,SNL */ } else { jmsx (ge); x ^= 832; /* SZL,SNL */ } if (k >= 0) ac = k; /* ACLIT STILL SET */ } } else { /*=,#*/ Do (75); /* SAD */ if (x == 640) { /*# */ if (k >= 0 && next != 0) { pend = k; ac = ~255; } x = 0; } else x = 512; /* SKP */ } } condskip: if ((lnest & 2) != 0) x ^= 512; /* INVERT */ if ((lnest & (~7)) != 0 || lmain == 2) { if (x != 0) opr (x); if (next == 0) ac = ~ac; i = ltag; j = lnest; while ((j & 4) == 0) { j = (unsigned) j >> 3; i += j & 1; } jump (i); if (i == lmin) labcode = lmain; if ((lnest & 1) != 0) def (ltag - 1); lnest = (unsigned) lnest >> 3; ltag += lnest & 1; } else { pendopr = x; final = 0; ac = ~ac; if ((lnest & 1) != 0) ac = ~255; } break; /*COMPILE START, FINISH, ELSE, EXIT */ case 49: case 50: /* START, CYCLE */ if (pendopr >= 0) print (0); /* DISCHARGE PENDING SKIP */ if (labcode == 0) def (lmin + 1); /* INDEFINITE CYCLE */ if (lstack < 0) { //assert (_IMP_MONITOR_); if (faulty == 0) { fprintf(stderr, "%d lines OK %d\n", statements, __LINE__); } exit (faulty); } lstack = (lstack << 2) + labcode; estack = (estack << 1) + Else; lmin -= 2; return; case 46: /* FINISH */ poplabel (1); break; case 47: /* FINISH ELSE */ poplabel (1); if (labcode == 3) fault (15); case 48: /* ELSE */ if (access != 0) { jump (lmin + 1); Else = 1; } labcode = 3; def (lmin); break; case 20: /* EXIT */ j = lmin + 2; k = 1; while ((k & lstack) != 0) { j += 2; k = k << 2; } if ((((-k) & lstack)) == 0) { fault (15); k = 0; } access = 0; final = 512; jump (j); lstack |= k << 1; break; /*COMPILE LABELS AND JUMPS */ case 80: /* LAB */ if (x < atag) fault (17); def (x); return; case 64: /* L */ access = 0; final = 512; jump (x); break; case 82: /* SLAB */ i = (unsigned) *ttx >> 8; if (i == 0) return; /* POINTER TO BOUNDS */ lit += dict[i - 1]; /* INDEX - UPPER */ if (lit <= 0) { lit += dict[i]; /* + NUMBER */ if (lit > 0) { print (lit + 1); def (x); return; } } fault (14); return; case 72: /* SNAME */ aref (); print (3); mon (135); /* XCT* T3:MON 7+128 */ goto z10; /*COMPILE PROCEDURE EXITS */ case 16: /* RETURN */ i = 12; /* SHOULD BE ROUTINE */ pex: if ((*btype & 15) != i) fault (15); access = 0; final = 512; print (btag); break; case 17: /* TRUE */ opr (2050); z171: i = 4; /* SHOULD BE PRED */ goto pex; case 18: /* FALSE */ opr (2048); goto z171; case 35: /* FRESULT */ i = (*btype & 3) + 4; /* SHOULD BE FN */ j = ac; k = aclit; expend (); ac = j; if (ac >= 0) ac = ~255; aclit = k; goto pex; case 34: /* MRESULT */ i = (*btype & 3) + 12; /* SHOULD BE MAP */ store (3); goto pex; /*COMPILE STOP, FAULT, MONITOR, ETC */ case 19: /* STOP */ mon (64); break; case 36: /* FAULT */ if (btag != 0) fault (15); /* SHOULD BE MAIN PROG */ call (flt); ac = ~255; getnext (); jump (x); break; case 37: /* MONITOR */ pend = -1; mon (lit); break; case 40: /* MCODE (OPERAND AFTER) */ lit = sub[next]; case 41: /* LMCODE (CONST BEFORE) */ print (lit); ac = ~255; return; case 67: case 87: /* STRING (PRINTTEXT) */ call (ptxt); /* PTEXT SR (TEXT FOLLOWS) */ do { i = dict[x]; x--; } while (i >= 0); ac = ~255; getnext (); /* IGNORE CALL */ break; /*COMPILE OPERANDS */ case 71: /* SCONST */ i = x; getnext (); if (pend >= 0 && class == 28 && x <= 2) { /*EXP +- LIST */ if (x != 1) i = -i; lit += i; break; } load (0); lit = i; goto z2; case 103: /* ASSA: = (EXP = APP (A,M)) */ pend1 = pend; lit1 = lit; pend = -1; break; case 65: /* V */ load (x); break; case 73: /* ARRAY ELEMENT (VAL) */ aref (); i = 3; vg: print (i); break; case 77: /* MAP ELEMENT (VAL) */ mcall (); if (i == 3) goto vg; if (ac >= 0) nest (); ac = 255; goto vg; case 66: /* BV */ load (256 + x); bg: call (bget); break; case 74: /* BYTE ARRAY ELEMENT (VAL) */ baref (); goto bg; case 78: /* BYTE MAP ELEMENT (VAL) */ pcall (); goto bg; case 96: /* VDEST: V */ store (x); break; case 86: /* ARRAY ELEMENT (DEST) */ aref (); i = 3; vp: restore (); vp1: print (i); ac = ~ac; break; case 83: /* MAP ELEMENT (DEST) */ mcall (); if (i == 3 || ac < 0) goto vp; goto vp1; case 99: /* BVDEST: BV */ call (bput); print (x); ac = ~255; break; case 100: /* BADEST: BA */ baref (); bp: restore (); call (bput); print (3); ac = ~255; break; case 101: /* BMDEST: BM */ pcall (); goto bp; case 112: /* APP (NULL) */ expend (); if (ac >= 0) nest (); break; case 84: case 85: case 89: case 90: case 92: /* PPAR,FPAR,APAR,BAPAR,RPAR */ case 93: case 94: case 97: case 98: /* MPAR,BMPAR,VREF,BVREF */ load (256 + x); /* LAD X */ break; case 88: /* ARRAY ELEMENT (REF) */ aref (); break; case 102: /* BYTE AREF */ baref (); break; case 91: case 95: /* MAP ELEMENT (REF,BREF) */ if (x != Int) pcall (); break; case 69: /* F (CALL) */ if (x != adr) pcall (); break; case 68: /* P (CALL) */ pcall (); x = 256; /* FOR SNL */ goto condskip; case 76: /* R (CALL) */ expend (); final = 512; pcall (); ac = ~255; break; case 111: break; /* SEP */ /*COMPILE OPERATORS */ case 104: /* MOD */ opr (65); opr (513); print (1); break; case 1: /* PLUS-SIGN */ if (class != 24) Do (tad); /* TAD (UNLESS UNARY) */ break; case 2: /* MINUS-SIGN */ if (class != 24) { if (pend > 0) { print (1); Do (tad); not (); /* TAD: CMA */ } else { neg (); Do (tad); } } else { neg (); } break; case 3: /* UOP: \ NOT */ not (); break; case 4: case 5: /* LEFT-SHIFT, RIGHT-SHIFT */ if (pend == 0 && (lit & (~7)) == 0) { pend = -1; while (lit != 0) { if (x != 5) opr (2056); else opr (2064); /* RCL,RCR */ lit--; } } else { if (x == 5) neg (); jmsx (sh); } break; case 6: /* AND */ Do (74); break; case 10: /* XOR */ Do (69); break; case 11: case 12: case 13: case 14: case 15: /* OR,MULT,IDIV,DIV,EXP */ jmsx (x); break; case 8: /* REFOP -- (DISP -- REF) */ neg (); case 7: /* REFOP ++ (DISP ++ REF) */ getnext (); if (pend == 0) { pend = 256 + x; /* AD OF X PLUS LIT */ } else { expend (); print (x); ac = 255; } break; case 9: /* REFASS: == */ getnext (); if ((*ttx & ref) == 0) fault (15); if ((pend - 256) == x && lit == 1) { print (x); if (((~ac) & 255) == x) ac = ~255; } else { if (pend > 0) { ttx = &tagtype[pend & 255]; expend (); if ((*ttx & (own + ref)) == 0) { print (-65537); } } print (x); ac = ~(x + 256); aclit = 0; } break; } // switch if (next != link) goto z1; z10: if (labcode == 0) return; z11: if ((labcode & 1) == 0) { jump (-(lmin + 1)); access = 0; } /* JUMP BACK FOR LOOPS */ if (labcode == 0) return; if (labcode != 3) def (lmin); if (Else != 0) def (lmin + 1); /* PICKUP POINT FOR ELSE */ return; } /* COMPILE SS */ tbase = tmax; dbase = dmax; lstack = 3; estack = 0; if (*btype != beg) { /*PROCEDURE (NOT BEGIN) */ analyse (); /* FORMAL PARAMETERS */ x = gapp () << 8; if ((*btype & (~255)) != 0) { if ((*btype & (~255)) != x && global !=0) fault (18); } else { *btype += x; } if ((*btype & body) == 0) goto fin; /* SPEC -> */ } access = btag; /* NON-ZERO EXCEPT AT OUTSET */ extind = *btype & ext; *btype ^= extind; atag = 0; danger = 0; pmax = tmax; if ((pmax - 1) == tbase && (tagtype[pmax] & 62) == 0) { ac = ~pmax; aclit = 0; } for (;;) { line += lines; lines = 0; analyse (); if (ss != 0) compile (); if ((sstype & 0x20000) != 0) { /*START OR END OF BLOCK */ ac = ~255; if ((sstype & 0x10000) != 0) break; /* END */ compileblock (level + 3, x, &tagtype[x], &danger); } } fin: tmax = tbase; dmax = dbase; return; } /* COMPILE BLOCK */ // Might add a '-q' option to suppress all output - only exit code would be wanted if (argc != 2) { fprintf(stderr, "syntax: imp15chk file.imp\n"); exit (faulty+1); } source_file = fopen(argv[1], "r"); if (source_file == NULL) { fprintf(stderr, "imp15chk: %s - %s\n", argv[1], strerror(errno)); exit (faulty+1); } current_input = prim; app = &phrase[112 - 112]; bapp = *app; tt0 = &tagtype[0]; *tt0 = beg; mref = &gram[((unsigned) initial[34 - 1] >> 7) & 255]; compileblock (-3, 0, tt0, tt0); /*assert(faulty == 0);*/ if (faulty == 0) { fprintf(stderr, "%d lines OK\n", statements); } exit (faulty); return faulty; } /* end of automatic translation */