/* Edinburgh IMP77 Compiler - Version 8.4 */ const char *snl; extern int rem(int p, int q); extern void readsymbol(int typeof_P, void *p); extern real float(int n); extern char * tostring(int p); extern char * substring(char *s, int f, int t); extern int freespace(); extern void svc(int n, struct (null) *r); extern int addr(int typeof_P, void *p); extern int *integer(int n); extern short *shortinteger(int n); extern char *byteinteger(int n); extern char * *string(int n); extern struct (null) record ; (/*should not get here any more*/ int n; /*or here*/) extern real *real(int n); extern long real *longreal(int n); extern char *length(char *s); extern char *charno(char *s, int n); extern int int(real x); extern int intpt(real x); extern void iocp(int n); extern int typeof(int typeof_N, void *n); extern int sizeof(int typeof_N, void *n); extern real fracpt(real x); extern void prompt(char *s); extern int nextsymbol(); extern void skipsymbol(); extern void printsymbol(int sym); extern void printstring(char *s); extern void write(int v, int p); extern void selectinput(int n); extern void selectoutput(int n); extern void openinput(int n, char *fd); extern void openoutput(int n, char *fd); extern void closeinput(); extern void closeoutput(); extern void resetinput(); extern void resetoutput(); extern char * time(); extern char * date(); extern int cputime(); extern int *comreg(int n); extern void read(int typeof_X, void *x); extern void print(real val, int before, int after); extern void printfl(real val, int places); extern void space(); extern void spaces(int n); extern void newline(); extern void newlines(int n); typedef struct FILEFM{int unit; int owner; int n1; int n2;} filefm; typedef struct PARMFM{short dsno; short dact; short ssno; short sact; ; ; char *text; ; ; ; ; struct FILEFM file; ; ; int p1; int p2; int p3; int p4; ; ; int p5; int p6; ; ;} parmfm; typedef struct EVENTFM{int event; int sub; int extra; char *message; int pc; int x;} eventfm; extern struct EVENTFM event; #line 4 // 1 !Graham Toal - new development version of SKIMPD 13/02/80 13.27 // 2 // 3 %const %string (1) snl = " // 4 " const char *snl; #line 7 // 5 // 6 %const %integer true = 0, false = 1 // 7 #line 9 // 8 %external %integer %array %spec a(1 : 500) // 9 // bounds [1 : 500] // do it now: extern int */*spec*/ a {NO INIT} #line 11 // 10 %external %byte %integer %array %spec named(1 : 1024) // 11 // bounds [1 : 1024] // do it now: extern char */*spec*/ named {NO INIT} #line 13 // 12 %external %integer %array %spec namedlink(0 : 255) // 13 // bounds [0 : 255] // do it now: extern int */*spec*/ namedlink {NO INIT} #line 15 // 14 %external %integer %array %spec taglink(0 : 255) // 15 // bounds [0 : 255] // do it now: extern int */*spec*/ taglink {NO INIT} #line 17 // 16 %external %integer %array %spec tag(1 : 512) // 17 // bounds [1 : 512] // do it now: extern int */*spec*/ tag {NO INIT} #line 19 // 18 %external %integer %array %spec link(1 : 512) // 19 // bounds [1 : 512] // do it now: extern int */*spec*/ link {NO INIT} #line 21 // 20 %external %integer %array %spec nextrad(0 : 15) // 21 // bounds [0 : 15] // do it now: extern int */*spec*/ nextrad {NO INIT} #line 23 // 22 %external %integer %array %spec rt(0 : 15) // 23 // bounds [0 : 15] // do it now: extern int */*spec*/ rt {NO INIT} #line 25 // 24 %external %integer %array %spec parms(0 : 15) // 25 // bounds [0 : 15] // do it now: extern int */*spec*/ parms {NO INIT} #line 27 // 26 %external %string (5) %array %spec display(0 : 15) // 27 // bounds [0 : 15] // do it now: extern char * */*spec*/ display {NO INIT} #line 29 // 28 %external %integer faults = 0 // 29 %external %integer %spec tagasl, level, tagsopt, nextcad, namedp, %c extern int faults; #line 30 // 30 traceopt, aopt, pstr extern int /*spec*/ tagasl; extern int /*spec*/ level; extern int /*spec*/ tagsopt; extern int /*spec*/ nextcad; extern int /*spec*/ namedp; extern int /*spec*/ traceopt; extern int /*spec*/ aopt; extern int /*spec*/ pstr; #line 33 // 31 !----------------------------------------------------------------------- // 32 %external %integer %fn %spec intstr(%string (6) val) // 33 %external %routine %spec expr(%integer exprp) extern int intstr(char *val); #line 34 // 34 %routine %spec popitem(%integer %name f, l) extern void expr(int exprp); #line 35 // 35 ! Local void popitem(int *f, int *l); #line 37 // 36 %external %integer %fn %spec outstream // 37 !----------------------------------------------------------------------- extern int outstream(); #line 39 // 38 %own %integer %array used(0 : 15) = 0(*) // 39 // bounds [0 : 15] // do it now: static int *used {NO INIT} #line 41 // 40 %own %integer %array worklist(0 : 15) = 0(16) // 41 // bounds [0 : 15] // do it now: static int *worklist {NO INIT} #line 43 // 42 %own %integer %array namelist(0 : 15) = 0(16) // 43 // bounds [0 : 15] // do it now: static int *namelist {NO INIT} #line 45 // 44 %own %integer %array branchlist(0 : 15) = 0(16) // 45 // bounds [0 : 15] // do it now: static int *branchlist {NO INIT} #line 47 // 46 %own %integer %array startlist(0 : 15) = 0(16) // 47 // bounds [0 : 15] // do it now: static int *startlist {NO INIT} #line 49 // 48 %own %integer %array cot(0 : 127) // 49 // bounds [0 : 127] // do it now: static int *cot; /* uninitialised */ #line 51 // 50 %own %integer cotp, params // 51 !----------------------------------------------------------------------- static int cotp; static int params; #line 53 // 52 %external %string (255) %fn strint(%integer n, p) // 53 %string (255) r extern char * strint(int n, int p) { #line 54 // 54 %string (1) s char *r; #line 55 // 55 %if n < 0 %then s = "-" %and n = -n %else s = "" char *s; #line 56 // 56 r = "" if (n >= 0) goto L_0001; strncpy(s,"-",1+1); n = (-n); goto L_0002; L_0001: strncpy(s,"",1+1); L_0002: #line 57 // 57 r = tostring(n - n // 10 * 10 + '0') . r %and n = n // 10 %until n = 0 strncpy(r,"",255+1); #line 58 // 58 r = s . r for (;;) { L_0003: strncpy(r,tostring(((n - ((n / 10) * 10)) + 48)),255+1); n = (n / 10); if (n == 0) goto L_0004; } L_0004: #line 59 // 59 r = " " . r %while length(r) < p strncpy(r,s,255+1); #line 60 // 60 %result = r for (;;) { L_0005: if (*length(r) >= p) goto L_0006; strncpy(r," ",255+1); } L_0006: #line 61 // 61 %end return(r); #line 62 // 62 !----------------------------------------------------------------------- #line 64 // 63 %external %string (7) %fn s(%integer i) // 64 %result = strint(i, 0) extern char * s(int i) { #line 65 // 65 %end return(strint(i, 0)); #line 66 // 66 !----------------------------------------------------------------------- #line 68 // 67 %external %string (8) %fn strhex(%integer n) // 68 %const %string (1) %array h(0 : 15) = %c extern char * strhex(int n) { #line 69 // 69 "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F" // bounds [0 : 15] // do it now: const char * *h {NO INIT} #line 72 // 70 // 71 %integer i // 72 %string (8) sh int i; #line 73 // 73 sh = "" char *sh; #line 74 // 74 %for i = 1, 1, 8 %cycle strncpy(sh,"",8+1); #line 75 // 75 sh = h(n & 16_F) . sh for (i = 1; i += 1; i != 8) { #line 76 // 76 n = n >> 4 strncpy(sh,h[(n & 15)],8+1); #line 77 // 77 %repeat n = (n >> 4); #line 78 // 78 %result = sh } L_000a: #line 79 // 79 %end return(sh); #line 80 // 80 !----------------------------------------------------------------------- #line 82 // 81 %external %routine fault(%string (63) mess) // 82 %integer st extern void fault(char *mess) { #line 83 // 83 printstring("? " . mess . " int st; #line 84 // 84 printstring("? "); #line 87 // 85 ") // 86 st = outstream // 87 selectoutput(0) st = outstream(); #line 88 // 88 printstring("*" . mess . snl) selectoutput(0); #line 89 // 89 selectoutput(st) printstring("*"); #line 90 // 90 faults = faults + 1 selectoutput(st); #line 91 // 91 %end faults = (faults + 1); #line 92 // 92 !----------------------------------------------------------------------- #line 94 // 93 %external %routine dump(%string (7) lab, op, reg, addr) // 94 %own %string (7) label = "" extern void dump(char *lab, char *op, char *reg, char *addr) { #line 95 // 95 %routine %spec codeout(%string (7) l, o, r, a) static char *label; #line 96 // 96 %if label # "" %start void codeout(char *l, char *o, char *r, char *a); #line 97 // 97 %if lab = "" %then lab = label %else %start if (label == "") goto L_000b; #line 98 // 98 codeout(label, "EQU", "", "*") if (lab != "") goto L_000c; strncpy(lab,label,7+1); goto L_000d; L_000c: #line 99 // 99 label = "" codeout(label, "EQU", "", "*"); #line 100 // 100 %finish strncpy(label,"",7+1); #line 101 // 101 %finish L_000d: #line 102 // 102 %if (op = "ADD" %or op = "SUB" %or op = "EOR" %or op = "OR") %and addr = "#0" %then %return L_000b: #line 103 // 103 %if (op = "AND" %or op = "LD") %and reg # "D" %and addr = "#0" %then op = "CLR" %and addr = "" if (op == "ADD") goto L_000e; if (op == "SUB") goto L_000e; if (op == "EOR") goto L_000e; if (op != "OR") goto L_000f; L_000e: if (addr != "#0") goto L_000f; return; L_000f: #line 104 // 104 %if op = "ADD" %and addr = "#1" %and reg # "D" %then %start if (op == "AND") goto L_0010; if (op != "LD") goto L_0011; L_0010: if (reg == "D") goto L_0011; if (addr != "#0") goto L_0011; strncpy(op,"CLR",7+1); strncpy(addr,"",7+1); L_0011: #line 105 // 105 op = "INC" if (op != "ADD") goto L_0012; if (addr != "#1") goto L_0012; if (reg == "D") goto L_0012; #line 106 // 106 addr = "" strncpy(op,"INC",7+1); #line 107 // 107 %finish strncpy(addr,"",7+1); #line 108 // 108 %if op = "SUB" %and addr = "#1" %and reg # "D" %then %start L_0012: #line 109 // 109 op = "DEC" if (op != "SUB") goto L_0013; if (addr != "#1") goto L_0013; if (reg == "D") goto L_0013; #line 110 // 110 addr = "" strncpy(op,"DEC",7+1); #line 111 // 111 %finish strncpy(addr,"",7+1); #line 112 // 112 %if op = "CMP" %and addr = "#0" %and reg # "D" %then op = "TST" %and addr = "" L_0013: #line 113 // 113 %if op = "EQU" %and addr = "*" %then label = lab %c if (op != "CMP") goto L_0014; if (addr != "#0") goto L_0014; if (reg == "D") goto L_0014; strncpy(op,"TST",7+1); strncpy(addr,"",7+1); L_0014: #line 114 // 114 %else label = "" %and codeout(lab, op, reg, addr) if (op != "EQU") goto L_0015; if (addr != "*") goto L_0015; strncpy(label,lab,7+1); goto L_0016; L_0015: strncpy(label,"",7+1); codeout(lab, op, reg, addr); L_0016: #line 117 // 115 // 116 %routine codeout(%string (7) lab, op, reg, addr) // 117 %string (6) nums goto L_0017; void codeout(char *lab, char *op, char *reg, char *addr) { #line 118 // 118 %integer i char *nums; #line 119 // 119 %routine dump2(%string (7) lab, op, reg, addr) int i; #line 120 // 120 %own %string (7) lastop = "silly" goto L_0017; void dump2(char *lab, char *op, char *reg, char *addr) { #line 121 // 121 %own %integer inhibit = 0 static char *lastop; #line 122 // 122 %if reg = "B" %and op = "LD" %and addr -> ("#") . nums %c static int inhibit; #line 123 // 123 %and (%not nums -> ("-") . nums) %and intstr(nums) > 255 %then reg = "D" if (reg != "B") goto L_0018; if (op != "LD") goto L_0018; /* TODO */ RESOLVE 00 ? <5> if (!(nums)) goto L_0018; /* TODO */ RESOLVE 00 ? <5> if (nums) goto L_0018; if (intstr(nums) <= 255) goto L_0018; strncpy(reg,"D",7+1); L_0018: #line 125 // 124 %if lab # "" %then %start // 125 %if op = "EQU" %and addr = "*" %then inhibit = 0 if (lab == "") goto L_0019; #line 126 // 126 %if op # "EQU" %then inhibit = 0 if (op != "EQU") goto L_001a; if (addr != "*") goto L_001a; inhibit = 0; L_001a: #line 127 // 127 %finish if (op == "EQU") goto L_001b; inhibit = 0; L_001b: #line 128 // 128 %if inhibit = 0 %or op = "EQU" %then %start L_0019: #line 129 // 129 lastop = op if (inhibit == 0) goto L_001c; if (op != "EQU") goto L_001d; L_001c: #line 130 // 130 %return %if op = "TST" %and reg = "B" %and lab = "" strncpy(lastop,op,7+1); #line 131 // 131 ! ****FRIG**** if (op != "TST") goto L_001e; if (reg != "B") goto L_001e; if (lab != "") goto L_001e; return; L_001e: #line 133 // 132 %if op = "CMP" %and addr = "#1" %then addr = "" %and op = "DEC" // 133 printstring(lab) if (op != "CMP") goto L_001f; if (addr != "#1") goto L_001f; strncpy(addr,"",7+1); strncpy(op,"DEC",7+1); L_001f: #line 134 // 134 spaces(10 - length(lab)) printstring(lab); #line 135 // 135 op = op . reg spaces((10 - *length(lab))); #line 136 // 136 printstring(op) strncpy(op,op,7+1); #line 137 // 137 spaces(10 - length(op)) printstring(op); #line 138 // 138 printstring(addr) spaces((10 - *length(op))); #line 139 // 139 newline printstring(addr); #line 140 // 140 nextcad = nextcad + 1 newline(); #line 141 // 141 %finish %spec nextcad = (nextcad + 1); #line 142 // 142 %if op = "LBRA" %or op = "SWI2" %or (op = "SWI" %and reg = "2") %c L_001d: #line 143 // 143 %then inhibit = 1 if (op == "LBRA") goto L_0020; if (op == "SWI2") goto L_0020; if (op != "SWI") goto L_0021; if (reg != "2") goto L_0021; L_0020: inhibit = 1; L_0021: #line 145 // 144 %return %unless op = "LBSR" // 145 %if addr = "SHL" %then used(12) = 1 if (op == "LBSR") goto L_0022; return; L_0022: #line 146 // 146 %if addr = "SHR" %then used(13) = 1 if (addr != "SHL") goto L_0023; used[12] = 1; L_0023: #line 147 // 147 %if addr = "EXP" %then used(14) = 1 if (addr != "SHR") goto L_0024; used[13] = 1; L_0024: #line 148 // 148 %if addr = "DIV" %then used(15) = 1 if (addr != "EXP") goto L_0025; used[14] = 1; L_0025: #line 149 // 149 %end if (addr != "DIV") goto L_0026; used[15] = 1; L_0026: #line 150 // 150 %own %string (7) %array l(1 : 2) = ""(2) L_0017: #line 151 // 151 // bounds [1 : 2] // do it now: static char * *l {NO INIT} #line 153 // 152 %own %string (7) %array o(1 : 2) = ""(2) // 153 // bounds [1 : 2] // do it now: static char * *o {NO INIT} #line 155 // 154 %own %string (7) %array r(1 : 2) = ""(2) // 155 // bounds [1 : 2] // do it now: static char * *r {NO INIT} #line 157 // 156 %own %string (7) %array a(1 : 2) = ""(2) // 157 // bounds [1 : 2] // do it now: static char * *a {NO INIT} #line 159 // 158 %own %integer buffptr = 0 // 159 %switch load(0:2) static int buffptr; #line 160 // 160 %switch store(0:2) // bounds [0 : 2] /*todo: gcc jump table extension*/ void **load; #line 161 // 161 %routine flushbuffer // bounds [0 : 2] /*todo: gcc jump table extension*/ void **store; #line 162 // 162 %integer i goto L_0027; void flushbuffer() { #line 163 // 163 %for i = 1, 1, buffptr %cycle int i; #line 164 // 164 dump2(l(i), o(i), r(i), a(i)) for (i = 1; i += 1; i != buffptr) { #line 165 // 165 %repeat dump2(l[i], o[i], r[i], a[i]); #line 166 // 166 buffptr = 0 } L_002b: #line 167 // 167 %end buffptr = 0; #line 168 // 168 %routine checklabel(%integer buff) L_0027: #line 169 // 169 %if buff = 3 %then %start goto L_002c; void checklabel(int buff) { #line 170 // 170 %if lab # "" %then dump2(lab, "EQU", "", "*") if (buff != 3) goto L_002d; #line 171 // 171 %return if (lab == "") goto L_002e; dump2(lab, "EQU", "", "*"); L_002e: #line 172 // 172 %finish return; #line 173 // 173 %if l(buff) # "" %then dump2(l(buff), "EQU", "", "*") L_002d: #line 174 // 174 %end if (l[buff] == "") goto L_002f; dump2(l[buff], "EQU", "", "*"); L_002f: #line 175 // 175 %routine savethisinstr L_002c: #line 176 // 176 buffptr = buffptr + 1 goto L_0030; void savethisinstr() { #line 177 // 177 %if buffptr > 2 %then %start buffptr = (buffptr + 1); #line 178 // 178 printstring("*?????Buffer full..." . snl) if (buffptr <= 2) goto L_0031; #line 179 // 179 flushbuffer printstring("*?????Buffer full..."); #line 180 // 180 %finish flushbuffer(); #line 181 // 181 l(buffptr) = lab L_0031: #line 182 // 182 o(buffptr) = op l[buffptr] = lab; #line 183 // 183 r(buffptr) = reg o[buffptr] = op; #line 184 // 184 a(buffptr) = addr r[buffptr] = reg; #line 185 // 185 %end a[buffptr] = addr; #line 186 // 186 %if op = "SEX" %and buffptr # 0 %and o(buffptr) = "LD" %c L_0030: #line 187 // 187 %and a(buffptr) -> ("#") . nums %and (%not nums -> ("-") . nums) %c if (op != "SEX") goto L_0032; if (buffptr == 0) goto L_0032; if (o[buffptr] != "LD") goto L_0032; /* TODO */ RESOLVE 00 ? <5> if (!(nums)) goto L_0032; /* TODO */ RESOLVE 00 ? <5> if (nums) goto L_0032; if (intstr(nums) <= 255) goto L_0032; return; L_0032: #line 190 // 188 %and intstr(nums) > 255 %then %return // 189 %if reg # "B" %then %start // 190 flushbuffer if (reg == "B") goto L_0033; #line 191 // 191 dump2(lab, op, reg, addr) flushbuffer(); #line 192 // 192 %return dump2(lab, op, reg, addr); #line 193 // 193 %finish return; #line 194 // 194 %if op = "LD" %then %start L_0033: #line 195 // 195 -> load(buffptr) if (op != "LD") goto L_0034; #line 196 // 196 load(0): goto *load[buffptr]; #line 197 // 197 savethisinstr load_0: #line 198 // 198 %return savethisinstr(); #line 199 // 199 load(1): return; #line 200 // 200 %if o(1) = "LD" %then checklabel(1) %and buffptr = 0 %else %start load_1: #line 201 // 201 %if o(1) = "ST" %and a(1) = addr %then %start if (o[1] != "LD") goto L_0035; checklabel(1); buffptr = 0; goto L_0036; L_0035: #line 202 // 202 %if lab # "" %then %start if (o[1] != "ST") goto L_0037; if (a[1] != addr) goto L_0037; #line 203 // 203 flushbuffer if (lab == "") goto L_0038; #line 204 // 204 savethisinstr flushbuffer(); #line 205 // 205 %return savethisinstr(); #line 206 // 206 %finish %else %return return; #line 207 // 207 %finish L_0038: return; #line 208 // 208 %finish L_0037: #line 209 // 209 savethisinstr L_0036: #line 210 // 210 %return savethisinstr(); #line 211 // 211 load(2): return; #line 212 // 212 dump2(l(1), o(1), r(1), a(1)) load_2: #line 213 // 213 l(1) = l(2) dump2(l[1], o[1], r[1], a[1]); #line 214 // 214 r(1) = r(2) l[1] = l[2]; #line 215 // 215 o(1) = o(2) r[1] = r[2]; #line 216 // 216 a(1) = a(2) o[1] = o[2]; #line 217 // 217 buffptr = 1 a[1] = a[2]; #line 218 // 218 printstring("?***** Unexpected third el = load" . snl) buffptr = 1; #line 219 // 219 -> load(1) printstring("?***** Unexpected third el = load"); #line 220 // 220 %finish goto *load[1]; #line 221 // 221 %if op = "ST" %then %start L_0034: #line 222 // 222 -> store(buffptr) if (op != "ST") goto L_0039; #line 223 // 223 store(0): goto *store[buffptr]; #line 224 // 224 savethisinstr store_0: #line 225 // 225 %return savethisinstr(); #line 226 // 226 store(1): return; #line 227 // 227 %if o(1) = "LD" %or o(1) = "ST" %then %start store_1: #line 228 // 228 %if a(1) = addr %then %start if (o[1] == "LD") goto L_003a; if (o[1] != "ST") goto L_003b; L_003a: #line 229 // 229 %if lab # "" %then %start if (a[1] != addr) goto L_003c; #line 230 // 230 flushbuffer if (lab == "") goto L_003d; #line 231 // 231 savethisinstr flushbuffer(); #line 232 // 232 %return savethisinstr(); #line 233 // 233 %finish %else %return return; #line 234 // 234 %finish %else %start L_003d: return; #line 235 // 235 flushbuffer L_003c: #line 236 // 236 savethisinstr flushbuffer(); #line 237 // 237 %return savethisinstr(); #line 238 // 238 %finish return; #line 239 // 239 %finish #line 240 // 240 %if o(1) = "CLR" %then %start L_003b: #line 241 // 241 checklabel(1) if (o[1] != "CLR") goto L_003e; #line 242 // 242 buffptr = 0 checklabel(1); #line 243 // 243 dump2(lab, "CLR", "", addr) buffptr = 0; #line 244 // 244 %return dump2(lab, "CLR", "", addr); #line 245 // 245 %finish return; #line 246 // 246 flushbuffer L_003e: #line 247 // 247 savethisinstr flushbuffer(); #line 248 // 248 %return savethisinstr(); #line 249 // 249 store(2): return; #line 250 // 250 %if o(1) = "LD" %and a(1) = addr %and (o(2) = "INC" %or o(2) = "DEC" %c store_2: #line 251 // 251 %or o(2) = "NEG" %or o(2) = "COM") %then %start if (o[1] != "LD") goto L_003f; if (a[1] != addr) goto L_003f; if (o[2] == "INC") goto L_0040; if (o[2] == "DEC") goto L_0040; if (o[2] == "NEG") goto L_0040; if (o[2] != "COM") goto L_003f; L_0040: #line 253 // 252 checklabel(2) // 253 checklabel(3) checklabel(2); #line 254 // 254 dump2(l(1), o(2), "", addr) checklabel(3); #line 255 // 255 buffptr = 0 dump2(l[1], o[2], "", addr); #line 256 // 256 %return buffptr = 0; #line 257 // 257 %finish return; #line 258 // 258 dump2(l(1), o(1), r(1), a(1)) L_003f: #line 259 // 259 l(1) = l(2) dump2(l[1], o[1], r[1], a[1]); #line 260 // 260 o(1) = o(2) l[1] = l[2]; #line 261 // 261 r(1) = r(2) o[1] = o[2]; #line 262 // 262 a(1) = a(2) r[1] = r[2]; #line 263 // 263 buffptr = 1 a[1] = a[2]; #line 264 // 264 -> store(1) buffptr = 1; #line 265 // 265 %finish goto *store[1]; #line 266 // 266 %if op = "TST" %then %start L_0039: #line 267 // 267 %if buffptr # 0 %then %start if (op != "TST") goto L_0041; #line 268 // 268 %if o(buffptr) = "LD" %then %start if (buffptr == 0) goto L_0042; #line 269 // 269 dump2(l(buffptr), op, "", a(buffptr)) if (o[buffptr] != "LD") goto L_0043; #line 270 // 270 checklabel(3) dump2(l[buffptr], op, "", a[buffptr]); #line 271 // 271 buffptr = buffptr - 1 checklabel(3); #line 272 // 272 %return buffptr = (buffptr - 1); #line 273 // 273 %finish return; #line 274 // 274 %finish L_0043: #line 275 // 275 flushbuffer L_0042: #line 276 // 276 dump2(lab, op, reg, addr) flushbuffer(); #line 277 // 277 %return dump2(lab, op, reg, addr); #line 278 // 278 %finish return; #line 279 // 279 %if op = "INC" %or op = "DEC" %or op = "CLR" %or op = "NEG" %c L_0041: #line 280 // 280 %or op = "COM" %then %start if (op == "INC") goto L_0044; if (op == "DEC") goto L_0044; if (op == "CLR") goto L_0044; if (op == "NEG") goto L_0044; if (op != "COM") goto L_0045; L_0044: #line 282 // 281 %if buffptr = 2 %then %start // 282 dump2(l(1), o(1), r(1), a(1)) if (buffptr != 2) goto L_0046; #line 283 // 283 l(1) = l(2) dump2(l[1], o[1], r[1], a[1]); #line 284 // 284 o(1) = o(2) l[1] = l[2]; #line 285 // 285 r(1) = r(2) o[1] = o[2]; #line 286 // 286 a(1) = a(2) r[1] = r[2]; #line 287 // 287 l(2) = lab a[1] = a[2]; #line 288 // 288 o(2) = op l[2] = lab; #line 289 // 289 r(2) = reg o[2] = op; #line 290 // 290 a(2) = addr r[2] = reg; #line 291 // 291 buffptr = 2 a[2] = addr; #line 292 // 292 %return buffptr = 2; #line 293 // 293 %finish return; #line 294 // 294 savethisinstr L_0046: #line 295 // 295 %return savethisinstr(); #line 296 // 296 %finish return; #line 297 // 297 flushbuffer L_0045: #line 298 // 298 dump2(lab, op, reg, addr) flushbuffer(); #line 299 // 299 %end dump2(lab, op, reg, addr); #line 300 // 300 %end for (;;) { L_0047: #line 301 // 301 !----------------------------------------------------------------------- #line 303 // 302 %external %string (255) %fn name(%integer ident) // 303 %unless 0 <= ident <= 255 %and namedlink(ident) # 0 %then %result = "" extern char * name(int ident) { #line 304 // 304 %result = string(addr(named(namedlink(ident)))) if (0 > ident) goto L_0048; if (ident > 255) goto L_0048; if (namedlink[ident] != 0) goto L_0049; L_0048: return(""); L_0049: #line 305 // 305 %end return(string(addr(named[namedlink[ident]]))); #line 306 // 306 !----------------------------------------------------------------------- #line 308 // 307 %external %integer %fn newtag // 308 %integer i extern int newtag() { #line 309 // 309 %if tagasl = 0 %then fault("TAG SPACE FULL") %and %stop int i; #line 310 // 310 i = tagasl if (tagasl != 0) goto L_004a; fault("TAG SPACE FULL"); exit(0); L_004a: #line 311 // 311 tagasl = link(tagasl) i = tagasl; #line 312 // 312 %result = i %spec tagasl = link[tagasl]; #line 313 // 313 %end return(i); #line 314 // 314 !----------------------------------------------------------------------- #line 316 // 315 %external %integer %fn returntag(%integer tagi) // 316 %integer l extern int returntag(int tagi) { #line 317 // 317 l = link(tagi) int l; #line 318 // 318 link(tagi) = tagasl l = link[tagi]; #line 319 // 319 tagasl = tagi link[tagi] = tagasl; #line 320 // 320 %result = l %spec tagasl = tagi; #line 321 // 321 %end return(l); #line 322 // 322 !----------------------------------------------------------------------- #line 324 // 323 %external %integer %fn getwork // 324 !%integername cell extern int getwork() { #line 336 // 325 ! cell==worklist(level) // 326 ! %while cell#0 %cycle // 327 ! %if tag(cell)<0 %then tag(cell)=-tag(cell) %and %result=tag(cell) // 328 ! cell==link(cell) // 329 ! %repeat // 330 ! cell=newtag // 331 ! tag(cell)=nextrad(level) // 332 ! nextrad(level)=nextrad(level)+1 // 333 ! link(cell)=0 // 334 ! %result=tag(cell) // 335 %result = 0 // 336 %end return(0); #line 337 // 337 !----------------------------------------------------------------------- #line 339 // 338 %external %routine returnwork(%integer work) // 339 !%integer cell extern void returnwork(int work) { #line 346 // 340 ! cell=worklist(level) // 341 ! %while cell#0 %cycle // 342 ! %if tag(cell)=work %then tag(cell)=-work %and %return // 343 ! cell=link(cell) // 344 ! %repeat // 345 %end // 346 !----------------------------------------------------------------------- #line 348 // 347 %external %routine clearwork // 348 %integer cell extern void clearwork() { #line 349 // 349 cell = worklist(level) int cell; #line 350 // 350 cell = returntag(cell) %while cell # 0 cell = worklist[level]; #line 351 // 351 worklist(level) = 0 for (;;) { L_004b: if (cell == 0) goto L_004c; cell = returntag(cell); } L_004c: #line 352 // 352 %end worklist[level] = 0; #line 353 // 353 !----------------------------------------------------------------------- #line 355 // 354 %external %integer %fn getcoti(%integer const) // 355 %integer coti extern int getcoti(int const) { #line 356 // 356 %if cotp > 0 %then %start int coti; #line 357 // 357 %for coti = 0, 1, cotp - 1 %cycle if (cotp <= 0) goto L_004d; #line 358 // 358 %if cot(coti) = const %then %result = coti for (coti = 0; coti += 1; coti != (cotp - 1)) { #line 359 // 359 %repeat if (cot[coti] != const) goto L_0052; return(coti); L_0052: #line 360 // 360 %finish } L_0051: #line 361 // 361 %if cotp = 128 %then fault("CONSTANT TABLE FULL") %and %stop L_004d: #line 362 // 362 cot(cotp) = const if (cotp != 128) goto L_0053; fault("CONSTANT TABLE FULL"); exit(0); L_0053: #line 363 // 363 cotp = cotp + 1 cot[cotp] = const; #line 364 // 364 %result = cotp - 1 cotp = (cotp + 1); #line 365 // 365 %end return((cotp - 1)); #line 366 // 366 !----------------------------------------------------------------------- #line 368 // 367 %external %routine pushtag(%integer ident, form, type, dim, level, rad) // 368 %integer tagi extern void pushtag(int ident, int form, int type, int dim, int level, int rad) { #line 369 // 369 %if taglink(ident) # 0 %and tag(taglink(ident)) >> 16 & 16_F = level %c int tagi; #line 370 // 370 %then fault("NAME " . name(ident) . " DECLARED TWICE") if (taglink[ident] == 0) goto L_0054; if (((tag[taglink[ident]] >> 16) & 15) != level) goto L_0054; fault("NAME "); L_0054: #line 372 // 371 tagi = newtag // 372 tag(tagi) = form << 28 ! type << 24 ! dim << 20 ! level << 16 ! rad tagi = newtag(); #line 373 // 373 link(tagi) = taglink(ident) tag[tagi] = (((((form << 28) | (type << 24)) | (dim << 20)) | (level << 16)) | rad); #line 374 // 374 taglink(ident) = tagi link[tagi] = taglink[ident]; #line 375 // 375 tagi = newtag taglink[ident] = tagi; #line 376 // 376 tag(tagi) = ident tagi = newtag(); #line 377 // 377 link(tagi) = namelist(level) tag[tagi] = ident; #line 378 // 378 namelist(level) = tagi link[tagi] = namelist[level]; #line 379 // 379 %end namelist[level] = tagi; #line 380 // 380 !----------------------------------------------------------------------- #line 382 // 381 %external %routine poptags // 382 %integer cell, ident, nametag, params extern void poptags() { #line 383 // 383 %string (63) s int cell; int ident; int nametag; int params; #line 384 // 384 %if tagsopt = 1 %then newline char *s; #line 385 // 385 cell = namelist(level) if (tagsopt != 1) goto L_0055; newline(); L_0055: #line 386 // 386 %while cell # 0 %cycle cell = namelist[level]; #line 387 // 387 ident = tag(cell) for (;;) { L_0056: if (cell == 0) goto L_0057; #line 388 // 388 cell = returntag(cell) ident = tag[cell]; #line 389 // 389 nametag = tag(taglink(ident)) cell = returntag(cell); #line 390 // 390 taglink(ident) = returntag(taglink(ident)) nametag = tag[taglink[ident]]; #line 391 // 391 %if tagsopt = 1 %then %start taglink[ident] = returntag(taglink[ident]); #line 392 // 392 s = name(ident) if (tagsopt != 1) goto L_0058; #line 393 // 393 printstring(strint(ident, 3) . " " . s) strncpy(s,name(ident),63+1); #line 394 // 394 spaces(10 - length(s)) printstring(strint(ident, 3)); #line 395 // 395 printstring(strhex(nametag)) spaces((10 - *length(s))); #line 396 // 396 %finish printstring(strhex(nametag)); #line 397 // 397 %if nametag >> 28 = 4 %then %start L_0058: #line 398 // 398 ! procedure type if ((nametag >> 28) != 4) goto L_0059; #line 400 // 399 params = nametag >> 20 & 16_F // 400 %while params # 0 %cycle params = ((nametag >> 20) & 15); #line 401 // 401 %if tagsopt = 1 %then printstring(" for (;;) { L_005a: if (params == 0) goto L_005b; #line 402 // 402 " . strhex(tag(taglink(ident)))) if (tagsopt != 1) goto L_005c; printstring(" "); L_005c: #line 404 // 403 taglink(ident) = returntag(taglink(ident)) // 404 params = params - 1 taglink[ident] = returntag(taglink[ident]); #line 405 // 405 ! pop up parameter tags params = (params - 1); #line 407 // 406 %repeat // 407 %finish } L_005b: #line 408 // 408 %if tagsopt = 1 %then newline L_0059: #line 409 // 409 %if taglink(ident) = 0 %then namedp = namedlink(ident) %and namedlink(ident) = 0 if (tagsopt != 1) goto L_005d; newline(); L_005d: #line 410 // 410 ! backtrack name dictionary if (taglink[ident] != 0) goto L_005e; %spec namedp = namedlink[ident]; namedlink[ident] = 0; L_005e: #line 412 // 411 %repeat // 412 %if tagsopt = 1 %then newline } L_0057: #line 413 // 413 namelist(level) = 0 if (tagsopt != 1) goto L_005f; newline(); L_005f: #line 414 // 414 %end namelist[level] = 0; #line 415 // 415 !----------------------------------------------------------------------- #line 417 // 416 %external %integer %fn getlabel(%integer constp) // 417 %integer label extern int getlabel(int constp) { #line 418 // 418 label = a(constp + 1) int label; #line 419 // 419 %if label > 9999 %then fault("LABEL " . strint(label, 1) . " TOO LARGE") %c label = a[(constp + 1)]; #line 420 // 420 %and %result = -1 %else %result = label if (label <= 9999) goto L_0060; fault("LABEL "); return((-1)); L_0060: return(label); #line 422 // 421 %end // 422 !----------------------------------------------------------------------- #line 424 // 423 %external %routine filllabel(%integer label) // 424 !%integer cell extern void filllabel(int label) { #line 426 // 425 %return %if label < 0 // 426 ! for conditional statements if (label >= 0) goto L_0061; return; L_0061: #line 432 // 427 ! cell=branchlist(level) // 428 ! %while cell#0 %cycle // 429 ! %if tag(cell)>>16=label %then %start // 430 ! %if tag(cell)&16_8000=0 %then fault("DUPLICATE LABEL ". ! strint(label,1)) %else %start // 431 dump("L" . s(label), "EQU", "", "*") // 432 ! tag(cell)=label<<16!nextcad dump("L", "EQU", "", "*"); #line 443 // 433 ! %finish // 434 ! %return // 435 ! %finish // 436 ! cell=link(cell) // 437 ! %repeat // 438 ! cell=newtag // 439 ! link(cell)=branchlist(level) // 440 ! branchlist(level)=cell // 441 ! tag(cell)=label<<16!nextcad // 442 %end // 443 !----------------------------------------------------------------------- #line 445 // 444 %external %integer %fn fillbranch(%integer label) // 445 %integer cell, cad extern int fillbranch(int label) { #line 446 // 446 %result = 0 %if label < 0 int cell; int cad; #line 447 // 447 cell = branchlist(level) if (label >= 0) goto L_0062; return(0); L_0062: #line 448 // 448 %while cell # 0 %cycle cell = branchlist[level]; #line 449 // 449 %if tag(cell) >> 16 = label %then %start for (;;) { L_0063: if (cell == 0) goto L_0064; #line 450 // 450 cad = tag(cell) & 16_7FFF if ((tag[cell] >> 16) != label) goto L_0065; #line 451 // 451 %if tag(cell) & 16_8000 # 0 %then tag(cell) = label << 16 ! 16_8000 ! nextcad cad = (tag[cell] & 32767); #line 452 // 452 %result = cad if ((tag[cell] & 32768) == 0) goto L_0066; tag[cell] = (((label << 16) | 32768) | nextcad); L_0066: #line 453 // 453 %finish return(cad); #line 454 // 454 cell = link(cell) L_0065: #line 455 // 455 %repeat cell = link[cell]; #line 456 // 456 cell = newtag } L_0064: #line 457 // 457 link(cell) = branchlist(level) cell = newtag(); #line 458 // 458 branchlist(level) = cell link[cell] = branchlist[level]; #line 459 // 459 tag(cell) = label << 16 ! 16_8000 ! nextcad branchlist[level] = cell; #line 460 // 460 %result = 0 tag[cell] = (((label << 16) | 32768) | nextcad); #line 461 // 461 %end return(0); #line 462 // 462 !----------------------------------------------------------------------- #line 464 // 463 %external %routine poplabels // 464 %integer cell extern void poplabels() { #line 465 // 465 cell = branchlist(level) int cell; #line 466 // 466 %while cell # 0 %cycle cell = branchlist[level]; #line 467 // 467 %if tag(cell) & 16_8000 # 0 %then fault("LABEL " . strint(tag(cell) >> 16, 1) . %c for (;;) { L_0067: if (cell == 0) goto L_0068; #line 468 // 468 " NOT SET (BRANCH LIST " . strint(tag(cell) & 16_7FFF, 1) . ")") if ((tag[cell] & 32768) == 0) goto L_0069; fault("LABEL "); L_0069: #line 470 // 469 cell = returntag(cell) // 470 %repeat cell = returntag(cell); #line 471 // 471 branchlist(level) = 0 } L_0068: #line 472 // 472 %end branchlist[level] = 0; #line 473 // 473 !----------------------------------------------------------------------- #line 475 // 474 %external %integer %fn nextplabel // 475 %own %integer plabel = 9999 extern int nextplabel() { #line 476 // 476 plabel = plabel + 1 static int plabel; #line 477 // 477 %result = plabel plabel = (plabel + 1); #line 478 // 478 %end return(plabel); #line 479 // 479 !----------------------------------------------------------------------- #line 481 // 480 %external %routine pushstart(%integer flag, plab) // 481 %integer cell extern void pushstart(int flag, int plab) { #line 482 // 482 cell = newtag int cell; #line 483 // 483 tag(cell) = flag << 16 ! plab & 16_FFFF cell = newtag(); #line 484 // 484 ! plab may be -1 tag[cell] = ((flag << 16) | (plab & 65535)); #line 486 // 485 link(cell) = startlist(level) // 486 startlist(level) = cell link[cell] = startlist[level]; #line 487 // 487 %end startlist[level] = cell; #line 488 // 488 %external %integer %fn find(%integer type, %integer %name t, lab) #line 489 // 489 %integer cell extern int find(int type, int *t, int *lab) { #line 490 // 490 cell = startlist(level) int cell; #line 491 // 491 %while cell # 0 %cycle cell = startlist[level]; #line 492 // 492 t = tag(cell) >> 16 for (;;) { L_006a: if (cell == 0) goto L_006b; #line 493 // 493 %if t & 2 = type %then %start *t = (tag[cell] >> 16); #line 494 // 494 lab = tag(cell) & 16_FFFF if ((*t & 2) != type) goto L_006c; #line 495 // 495 %result = true *lab = (tag[cell] & 65535); #line 496 // 496 %finish return(0); #line 497 // 497 cell = link(cell) L_006c: #line 498 // 498 %repeat cell = link[cell]; #line 499 // 499 t = 0 } L_006b: #line 500 // 500 lab = 0 *t = 0; #line 501 // 501 %result = false *lab = 0; #line 502 // 502 %end return(1); #line 503 // 503 %external %routine findcontinue(%integer %name type, lab) #line 504 // 504 %if find(2, type, lab) = true %then lab = lab + 1 %c extern void findcontinue(int *type, int *lab) { #line 505 // 505 %else type = 0 %and lab = 0 %and fault("%CYCLE MISSING") if (find(2, *type, *lab) != 0) goto L_006d; *lab = (*lab + 1); goto L_006e; L_006d: *type = 0; *lab = 0; fault("%CYCLE MISSING"); L_006e: #line 507 // 506 %end // 507 %external %routine findexit(%integer %name type, lab) #line 508 // 508 %if find(2, type, lab) = true %then lab = lab + 2 %c extern void findexit(int *type, int *lab) { #line 509 // 509 %else type = 0 %and lab = 0 %and fault("%CYCLE MISSING") if (find(2, *type, *lab) != 0) goto L_006f; *lab = (*lab + 2); goto L_0070; L_006f: *type = 0; *lab = 0; fault("%CYCLE MISSING"); L_0070: #line 511 // 510 %end // 511 %integer %fn findcycle #line 512 // 512 %integer t, l int findcycle() { #line 513 // 513 %if find(2, t, l) = true %then %result = true int t; int l; #line 514 // 514 %result = false if (find(2, t, l) != 0) goto L_0071; return(0); L_0071: #line 515 // 515 %end return(1); #line 516 // 516 %integer %fn findstart #line 517 // 517 %integer t, l int findstart() { #line 518 // 518 %if find(0, t, l) = true %then %result = true int t; int l; #line 519 // 519 %result = false if (find(0, t, l) != 0) goto L_0072; return(0); L_0072: #line 520 // 520 %end return(1); #line 521 // 521 %external %routine popcycle(%integer %name type, lab) #line 522 // 522 popitem(type, lab) extern void popcycle(int *type, int *lab) { #line 523 // 523 %if type & 2 = 0 %then %start popitem(*type, *lab); #line 524 // 524 %if findcycle = true %then %start if ((*type & 2) != 0) goto L_0073; #line 525 // 525 fault("%FINISH MISSING {Or spurious %REPEAT??}") if (findcycle() != 0) goto L_0074; #line 526 // 526 %finish %else %start fault("%FINISH MISSING {Or spurious %REPEAT??}"); #line 527 // 527 fault("SPURIOUS %REPEAT") goto L_0075; L_0074: #line 528 // 528 pushstart(type, lab) %if lab # 0 fault("SPURIOUS %REPEAT"); #line 529 // 529 %finish if (*lab == 0) goto L_0076; pushstart(*type, *lab); L_0076: #line 530 // 530 lab = 0 L_0075: #line 531 // 531 type = 3 *lab = 0; #line 532 // 532 %finish *type = 3; #line 533 // 533 %end L_0073: #line 534 // 534 %external %routine popstart(%integer %name type, lab) #line 535 // 535 popitem(type, lab) extern void popstart(int *type, int *lab) { #line 536 // 536 %if type & 2 = 2 %or lab = 0 %then %start popitem(*type, *lab); #line 537 // 537 %if findstart = true %then %start if ((*type & 2) == 2) goto L_0077; if (*lab != 0) goto L_0078; L_0077: #line 538 // 538 fault("%REPEAT MISSING {Or spurious %FINISH??}") if (findstart() != 0) goto L_0079; #line 539 // 539 %finish %else %start fault("%REPEAT MISSING {Or spurious %FINISH??}"); #line 540 // 540 fault("SPURIOUS %FINISH") goto L_007a; L_0079: #line 541 // 541 pushstart(type, lab) %if lab # 0 fault("SPURIOUS %FINISH"); #line 542 // 542 %finish if (*lab == 0) goto L_007b; pushstart(*type, *lab); L_007b: #line 543 // 543 lab = 0 L_007a: #line 544 // 544 type = 0 *lab = 0; #line 545 // 545 %finish *type = 0; #line 546 // 546 %end L_0078: #line 547 // 547 !----------------------------------------------------------------------- #line 549 // 548 %routine popitem(%integer %name flag, plab) // 549 %integer cell void popitem(int *flag, int *plab) { #line 550 // 550 cell = startlist(level) int cell; #line 551 // 551 %if cell = 0 %then %start cell = startlist[level]; #line 552 // 552 flag = 0 if (cell != 0) goto L_007c; #line 553 // 553 plab = 0 *flag = 0; #line 554 // 554 %finish %else %start *plab = 0; #line 555 // 555 flag = tag(cell) >> 16 goto L_007d; L_007c: #line 556 // 556 plab = tag(cell) & 16_FFFF *flag = (tag[cell] >> 16); #line 557 // 557 %if plab = 16_FFFF %then plab = -1 *plab = (tag[cell] & 65535); #line 558 // 558 startlist(level) = returntag(cell) if (*plab != 65535) goto L_007e; *plab = (-1); L_007e: #line 559 // 559 %finish startlist[level] = returntag(cell); #line 560 // 560 %end L_007d: #line 561 // 561 !----------------------------------------------------------------------- #line 563 // 562 %external %routine clearstart // 563 %integer cell extern void clearstart() { #line 564 // 564 %const %string (7) %array what(0 : 1) = "%FINISH", "%REPEAT" int cell; #line 565 // 565 // bounds [0 : 1] // do it now: const char * *what {NO INIT} #line 567 // 566 cell = startlist(level) // 567 %while cell # 0 %cycle cell = startlist[level]; #line 568 // 568 fault(what(tag(cell) >> 17) . " MISSING") for (;;) { L_007f: if (cell == 0) goto L_0080; #line 569 // 569 cell = returntag(cell) fault(what[(tag[cell] >> 17)]); #line 570 // 570 %repeat cell = returntag(cell); #line 571 // 571 startlist(level) = 0 } L_0080: #line 572 // 572 %end startlist[level] = 0; #line 573 // 573 !----------------------------------------------------------------------- #line 575 // 574 %external %integer %fn enter // 575 %own %string (4) %array regs(1 : 2) = "A", "A,B" extern int enter() { #line 576 // 576 // bounds [1 : 2] // do it now: static char * *regs {NO INIT} #line 578 // 577 %string (4) base // 578 %integer alloc, dim char *base; #line 579 // 579 %if level = 1 %then %start int alloc; int dim; #line 580 // 580 %if nextcad # 1 %then fault("%BEGIN NOT FIRST STATEMENT") if (level != 1) goto L_0081; #line 581 // 581 dump("", "ORG", "", "$F800") if (nextcad == 1) goto L_0082; fault("%BEGIN NOT FIRST STATEMENT"); L_0082: #line 582 // 582 dump("START", "EQU", "", "*") dump("", "ORG", "", "$F800"); #line 583 // 583 dump("", "SWI", "3", "") %if traceopt = 1 dump("START", "EQU", "", "*"); #line 584 // 584 dump("", "LD", "U", "#STACK") if (traceopt != 1) goto L_0083; dump("", "SWI", "3", ""); L_0083: #line 585 // 585 dump("", "LEA", "X", "-USTK,U") dump("", "LD", "U", "#STACK"); #line 586 // 586 base = ",X" dump("", "LEA", "X", "-USTK,U"); #line 587 // 587 alloc = 34 strncpy(base,",X",4+1); #line 588 // 588 ! Already set up by calling program alloc = 34; #line 591 // 589 ! Rest for I/O buffers and perm locations. // 590 %finish %else %start // 591 ! STORE STP (=Y) IF NECCESARY goto L_0084; L_0081: #line 593 // 592 %if level > 2 %start // 593 dump("", "ST", "Y", display(level - 1)) if (level <= 2) goto L_0085; #line 594 // 594 %finish dump("", "ST", "Y", display[(level - 1)]); #line 595 // 595 dump("", "PSH", "S", "Y") L_0085: #line 596 // 596 dump("", "TFR", "", "S,Y") dump("", "PSH", "S", "Y"); #line 597 // 597 alloc = 0 dump("", "TFR", "", "S,Y"); #line 598 // 598 base = ",Y" alloc = 0; #line 599 // 599 %finish strncpy(base,",Y",4+1); #line 600 // 600 ! cad=nextcad L_0084: #line 602 // 601 %if level # 1 %then %start // 602 ! REMOVED TO 'SKIMPB' if (level == 1) goto L_0086; #line 604 // 603 %finish %else %start // 604 dump("", "LEA", "S", "-A" . s(rt(level)) . ",X") goto L_0087; L_0086: #line 605 // 605 %finish dump("", "LEA", "S", "-A"); #line 606 // 606 nextrad(level) = alloc L_0087: #line 607 // 607 %result = alloc nextrad[level] = alloc; #line 608 // 608 %end return(alloc); #line 609 // 609 !----------------------------------------------------------------------- #line 611 // 610 %external %routine dumpreturn // 611 dump("", "TFR", "", "Y,S") extern void dumpreturn() { #line 612 // 612 dump("", "PUL", "S", "Y,PC") dump("", "TFR", "", "Y,S"); #line 613 // 613 %end dump("", "PUL", "S", "Y,PC"); #line 614 // 614 !----------------------------------------------------------------------- #line 616 // 615 %external %routine array(%integer arrayp) // 616 %integer namep, actualp, exprp, exprsp, ident, nametag, basep, disp extern void array(int arrayp) { #line 617 // 617 %string (4) base int namep; int actualp; int exprp; int exprsp; int ident; int nametag; int basep; int disp; #line 618 // 618 namep = a(arrayp + 1) char *base; #line 619 // 619 actualp = a(arrayp + 2) namep = a[(arrayp + 1)]; #line 620 // 620 ident = a(namep + 1) actualp = a[(arrayp + 2)]; #line 621 // 621 %if a(actualp) = 1 %then %start ident = a[(namep + 1)]; #line 622 // 622 dump(" ", "CLR", "A", "") if (a[actualp] != 1) goto L_0088; #line 623 // 623 dump("", "ANDCC", "", "0") dump(" ", "CLR", "A", ""); #line 624 // 624 exprp = a(actualp + 1) dump("", "ANDCC", "", "0"); #line 625 // 625 exprsp = a(actualp + 2) exprp = a[(actualp + 1)]; #line 626 // 626 expr(exprp) exprsp = a[(actualp + 2)]; #line 627 // 627 nametag = tag(taglink(ident)) expr(exprp); #line 628 // 628 basep = nametag >> 16 & 16_F nametag = tag[taglink[ident]]; #line 629 // 629 base = display(basep) basep = ((nametag >> 16) & 15); #line 630 // 630 base = ",Y" %if basep = level strncpy(base,display[basep],4+1); #line 631 // 631 base = ",X" %if basep = 1 if (basep != level) goto L_0089; strncpy(base,",Y",4+1); L_0089: #line 632 // 632 disp = nametag & 16_FFFF if (basep != 1) goto L_008a; strncpy(base,",X",4+1); L_008a: #line 633 // 633 dump("", "BCC", "", "*+3") disp = (nametag & 65535); #line 634 // 634 dump("", "INC", "A", "") dump("", "BCC", "", "*+3"); #line 635 // 635 %if basep = 1 %or basep = level %start dump("", "INC", "A", ""); #line 636 // 636 dump("", "ADD", "D", "-" . s(disp) . base) if (basep == 1) goto L_008b; if (basep != level) goto L_008c; L_008b: #line 637 // 637 %finish %else %start dump("", "ADD", "D", "-"); #line 638 // 638 dump("", "PSH", "U", "A,B") goto L_008d; L_008c: #line 639 // 639 dump("", "LD", "D", display(basep)) dump("", "PSH", "U", "A,B"); #line 640 // 640 dump("", "SUB", "D", "#" . s(disp)) dump("", "LD", "D", display[basep]); #line 641 // 641 dump("", "ST", "D", "0,X") dump("", "SUB", "D", "#"); #line 642 // 642 dump("", "LD", "D", "[0,X]") dump("", "ST", "D", "0,X"); #line 643 // 643 dump("", "ADD", "D", ",U++") dump("", "LD", "D", "[0,X]"); #line 644 // 644 %finish dump("", "ADD", "D", ",U++"); #line 645 // 645 dump("", "ST", "D", "0,X") %if aopt = 0 L_008d: #line 646 // 646 aopt = 0 if (aopt != 0) goto L_008e; dump("", "ST", "D", "0,X"); L_008e: #line 647 // 647 ! dump("ADD","ACC",display(nametag>>16&16_f),nametag&16_ffff) %spec aopt = 0; #line 649 // 648 %if a(exprsp) = 1 %then fault("ARRAY " . name(ident) . " HAS EXTRA INDEX") // 649 %finish %else fault("ARRAY " . name(ident) . " HAS NO INDEX") if (a[exprsp] != 1) goto L_008f; fault("ARRAY "); L_008f: #line 650 // 650 %end goto L_0090; L_0088: fault("ARRAY "); L_0090: #line 651 // 651 !----------------------------------------------------------------------- #line 653 // 652 %external %routine proc(%integer procp) // 653 %string (4) opn, base, reg extern void proc(int procp) { #line 654 // 654 %integer namep, ident, nametag, ptagl, l, actualp, exprp, unaryp, operandp, %c char *opn; char *base; char *reg; #line 655 // 655 npars, ptag, pnamep, pident, pnametag, pactualp, disp, exprrestp, exprsp, %c int namep; int ident; int nametag; int ptagl; int l; int actualp; int exprp; int unaryp; int operandp; int npars; int ptag; int pnamep; int pident; int pnametag; int pactualp; int disp; int exprrestp; int exprsp; int oldparams; int basep; int size; #line 660 // 656 oldparams, basep, size // 657 ! %if params>2 %then dump("LDA","STP","STP",params) // 658 !***! hack !***! // 659 %if params >= 2 %then dump("", "LEA", "S", "-" . s(params + 1) . ",S") // 660 !***! hack !***! if (params < 2) goto L_0091; dump("", "LEA", "S", "-"); L_0091: #line 662 // 661 oldparams = params // 662 params = 4 oldparams = params; #line 663 // 663 namep = a(procp + 1) params = 4; #line 664 // 664 actualp = a(procp + 2) namep = a[(procp + 1)]; #line 665 // 665 ident = a(namep + 1) actualp = a[(procp + 2)]; #line 666 // 666 l = taglink(ident) ident = a[(namep + 1)]; #line 667 // 667 nametag = tag(l) l = taglink[ident]; #line 668 // 668 ptagl = link(l) nametag = tag[l]; #line 669 // 669 npars = nametag >> 20 & 16_F ptagl = link[l]; #line 670 // 670 %if npars = 0 %then %start npars = ((nametag >> 20) & 15); #line 671 // 671 %if a(actualp) = 1 %then fault(name(ident) . " HAS PARAMETERS") %and %return if (npars != 0) goto L_0092; #line 672 // 672 %finish %else %start if (a[actualp] != 1) goto L_0093; fault(name(ident)); return; L_0093: #line 673 // 673 %if a(actualp) = 2 %then fault(name(ident) . " MISSING PARAMETERS") %and %return goto L_0094; L_0092: #line 674 // 674 exprp = a(actualp + 1) if (a[actualp] != 2) goto L_0095; fault(name(ident)); return; L_0095: #line 675 // 675 exprsp = a(actualp + 2) exprp = a[(actualp + 1)]; #line 676 // 676 %cycle exprsp = a[(actualp + 2)]; #line 677 // 677 ! for each parameter for (;;) { L_0096: #line 679 // 678 ptag = tag(ptagl) // 679 %if ptag >> 28 = 0 %then expr(exprp) %and reg = "B" %else %start ptag = tag[ptagl]; #line 680 // 680 reg = "D" if ((ptag >> 28) != 0) goto L_0097; expr(exprp); strncpy(reg,"B",4+1); goto L_0098; L_0097: #line 681 // 681 unaryp = a(exprp + 1) strncpy(reg,"D",4+1); #line 682 // 682 operandp = a(exprp + 2) unaryp = a[(exprp + 1)]; #line 683 // 683 exprrestp = a(exprp + 3) operandp = a[(exprp + 2)]; #line 684 // 684 %unless a(unaryp) = 4 %and a(operandp) = 1 %and a(exprrestp) = 2 %c exprrestp = a[(exprp + 3)]; #line 685 // 685 %then fault("NOT A %NAME PARAMETER") %else %start if (a[unaryp] != 4) goto L_0099; if (a[operandp] != 1) goto L_0099; if (a[exprrestp] == 2) goto L_009a; L_0099: fault("NOT A %NAME PARAMETER"); goto L_009b; L_009a: #line 687 // 686 pnamep = a(operandp + 1) // 687 pactualp = a(operandp + 2) pnamep = a[(operandp + 1)]; #line 688 // 688 pident = a(pnamep + 1) pactualp = a[(operandp + 2)]; #line 689 // 689 !? %if taglink(pident)=0 %then fault(name(pident). !? " NOT DECLARED") %else %start pident = a[(pnamep + 1)]; #line 691 // 690 %if taglink(pident) = 0 %then %start // 691 dump("", "LD", "B", name(pident)) if (taglink[pident] != 0) goto L_009c; #line 692 // 692 %finish %else %start dump("", "LD", "B", name(pident)); #line 693 // 693 pnametag = tag(taglink(pident)) goto L_009d; L_009c: #line 694 // 694 %if pnametag >> 28 = 4 %then fault(name(pident) . " NOT A %NAME") %else %start pnametag = tag[taglink[pident]]; #line 695 // 695 basep = pnametag >> 16 & 16_F if ((pnametag >> 28) != 4) goto L_009e; fault(name(pident)); goto L_009f; L_009e: #line 696 // 696 base = display(basep) basep = ((pnametag >> 16) & 15); #line 697 // 697 disp = pnametag & 16_FFFF strncpy(base,display[basep],4+1); #line 698 // 698 base = "Y" %if basep = level disp = (pnametag & 65535); #line 699 // 699 base = "X" %if basep = 1 if (basep != level) goto L_00a0; strncpy(base,"Y",4+1); L_00a0: #line 700 // 700 %if ptag >> 28 = 1 %then %start if (basep != 1) goto L_00a1; strncpy(base,"X",4+1); L_00a1: #line 701 // 701 ! %name if ((ptag >> 28) != 1) goto L_00a2; #line 703 // 702 %if pnametag >> 28 >= 2 %then aopt = 1 %and array(operandp) %else %start // 703 %if pnametag >> 28 = 1 %then %start if ((pnametag >> 28) < 2) goto L_00a3; %spec aopt = 1; array(operandp); goto L_00a4; L_00a3: #line 704 // 704 %if 1 < basep < level %start if ((pnametag >> 28) != 1) goto L_00a5; #line 705 // 705 dump("", "LD", reg, base) if (1 >= basep) goto L_00a6; if (basep >= level) goto L_00a6; #line 706 // 706 dump("", "SUB", reg, "#" . s(disp)) dump("", "LD", reg, base); #line 707 // 707 dump("", "ST", reg, "0,X") dump("", "SUB", reg, "#"); #line 708 // 708 dump("", "LD", reg, "[0,X]") dump("", "ST", reg, "0,X"); #line 709 // 709 %finish %else %start dump("", "LD", reg, "[0,X]"); #line 710 // 710 dump("", "LD", reg, "-" . s(disp) . "," . base) goto L_00a7; L_00a6: #line 711 // 711 %finish dump("", "LD", reg, "-"); #line 712 // 712 %finish %else %start L_00a7: #line 713 // 713 %if 1 < basep < level %start goto L_00a8; L_00a5: #line 714 // 714 dump("", "LD", reg, base) if (1 >= basep) goto L_00a9; if (basep >= level) goto L_00a9; #line 715 // 715 dump("", "SUB", reg, "#" . s(disp)) dump("", "LD", reg, base); #line 716 // 716 %finish %else %start dump("", "SUB", reg, "#"); #line 717 // 717 %if basep = 1 = level %then %start goto L_00aa; L_00a9: #line 718 // 718 dump("", "LEA", "Y", "-" . s(disp) . ",X") if (basep != 1) goto L_00ab; if (1 != level) goto L_00ab; #line 719 // 719 reg = "Y" dump("", "LEA", "Y", "-"); #line 720 // 720 %finish %else %start strncpy(reg,"Y",4+1); #line 721 // 721 dump("", "TFR", "", base . ",D") goto L_00ac; L_00ab: #line 722 // 722 dump("", "SUB", reg, "#" . s(disp)) dump("", "TFR", "", base); #line 723 // 723 %finish dump("", "SUB", reg, "#"); #line 724 // 724 ! GET ADDRESS OF A %NAME INTO B L_00ac: #line 726 // 725 %finish // 726 %finish L_00aa: #line 727 // 727 ! CHECK FOR SILLY BASE REGISTER L_00a8: #line 730 // 728 ! dump(opn,"ACC",base,disp) // 729 %if a(pactualp) = 1 %then fault(name(pident) . " DECLARED AS SCALAR") // 730 %finish if (a[pactualp] != 1) goto L_00ad; fault(name(pident)); L_00ad: #line 731 // 731 %finish %else %start L_00a4: #line 732 // 732 ! dump("LOAD","ACC",base,disp) ;! %array goto L_00ae; L_00a2: #line 734 // 733 %if base = "Y" %or base = "X" %start // 734 dump("", "LD", reg, "-" . s(disp) . "," . base) if (base == "Y") goto L_00af; if (base != "X") goto L_00b0; L_00af: #line 735 // 735 %finish %else %start dump("", "LD", reg, "-"); #line 736 // 736 dump("", "LD", reg, base) goto L_00b1; L_00b0: #line 737 // 737 dump("", "SUB", reg, "#" . s(disp)) dump("", "LD", reg, base); #line 738 // 738 dump("", "ST", reg, "0,X") dump("", "SUB", reg, "#"); #line 739 // 739 dump("", "LD", reg, "[0,X]") dump("", "ST", reg, "0,X"); #line 740 // 740 %finish dump("", "LD", reg, "[0,X]"); #line 741 // 741 ! CHECK SILLY BASE REGISTER L_00b1: #line 743 // 742 %if a(pactualp) = 1 %then fault("%ARRAYNAME " . name(pident) . " HAS INDEX") // 743 %finish if (a[pactualp] != 1) goto L_00b2; fault("%ARRAYNAME "); L_00b2: #line 744 // 744 %finish L_00ae: #line 745 // 745 %finish L_009f: #line 746 // 746 %finish L_009d: #line 747 // 747 %finish L_009b: #line 748 // 748 ! dump("STR","ACC","STP",params) L_0098: #line 750 // 749 %if reg = "D" %or reg = "Y" %then size = 2 %else size = 1 // 750 params = params + size if (reg == "D") goto L_00b3; if (reg != "Y") goto L_00b4; L_00b3: size = 2; goto L_00b5; L_00b4: size = 1; L_00b5: #line 751 // 751 dump("", "ST", reg, "-" . s(params) . ",S") params = (params + size); #line 752 // 752 npars = npars - 1 dump("", "ST", reg, "-"); #line 753 // 753 %if npars = 0 %then %start npars = (npars - 1); #line 754 // 754 %if a(exprsp) = 1 %then fault(name(ident) . " HAS EXTRA PARAMETERS") if (npars != 0) goto L_00b6; #line 755 // 755 %exit if (a[exprsp] != 1) goto L_00b7; fault(name(ident)); L_00b7: #line 756 // 756 %finish goto L_00b8; #line 757 // 757 ptagl = link(ptagl) L_00b6: #line 758 // 758 %if a(exprsp) = 2 %then fault(name(ident) . " IS MISSING PARAMETERS") %and %exit ptagl = link[ptagl]; #line 759 // 759 exprp = a(exprsp + 1) if (a[exprsp] != 2) goto L_00b9; fault(name(ident)); goto L_00b8; L_00b9: #line 760 // 760 exprsp = a(exprsp + 2) exprp = a[(exprsp + 1)]; #line 761 // 761 %repeat exprsp = a[(exprsp + 2)]; #line 762 // 762 %finish } L_00b8: #line 763 // 763 ! external i/o routines at level 0 L_0094: #line 765 // 764 %if nametag >> 16 & 16_F = 0 %then base = "EXT" %else base = "E" // 765 %if nametag >> 16 & 16_F = 0 %then %start if (((nametag >> 16) & 15) != 0) goto L_00ba; strncpy(base,"EXT",4+1); goto L_00bb; L_00ba: strncpy(base,"E",4+1); L_00bb: #line 766 // 766 used(nametag & 16_F) = 1 if (((nametag >> 16) & 15) != 0) goto L_00bc; #line 767 // 767 %finish used[(nametag & 15)] = 1; #line 768 // 768 dump("", "LBSR", "", base . s(nametag & 16_FFFF)) L_00bc: #line 769 // 769 params = oldparams dump("", "LBSR", "", base); #line 770 // 770 ! EH?????? params = oldparams; #line 773 // 771 !***! frig !***! // 772 %if params >= 2 %then dump("", "LEA", "S", s(params + 1) . ",S") // 773 ! %if params>2 %then dump("SUB","STP","COT",getcoti(params)) if (params < 2) goto L_00bd; dump("", "LEA", "S", s((params + 1))); L_00bd: #line 775 // 774 %end // 775 !----------------------------------------------------------------------- #line 777 // 776 %external %routine endofprog // 777 %integer i extern void endofprog() { #line 778 // 778 dump("", "SWI", "2", "") int i; #line 779 // 779 dump("STACK", "EQU", "", "$0800-1") dump("", "SWI", "2", ""); #line 780 // 780 dump("USTK", "EQU", "", "$20") dump("STACK", "EQU", "", "$0800-1"); #line 781 // 781 ! DUMP("EXT1","EQU","","") %IF USED(1)=1 dump("USTK", "EQU", "", "$20"); #line 794 // 782 ! DUMP("EXT2","EQU","","") %IF USED(2)=1 // 783 ! DUMP("EXT3","EQU","","") %IF USED(3)=1 // 784 ! DUMP("EXT4","EQU","","") %IF USED(4)=1 // 785 ! DUMP("EXT5","EQU","","") %IF USED(5)=1 // 786 ! DUMP("EXT6","EQU","","") %IF USED(6)=1 // 787 ! DUMP("EXT7","EQU","","") %IF USED(7)=1 // 788 ! DUMP("EXT8","EQU","","") %IF USED(8)=1 // 789 ! DUMP("EXT9","EQU","","") %IF USED(9)=1 // 790 ! DUMP("EXT10","EQU","","") %IF USED(10)=1 // 791 !! READSYMBOL POSING AS READ // 792 ! DUMP("EXT11","EQU","","") %AND USED(15)=1 %IF USED(11)=1 // 793 %if used(12) = 1 %then %start // 794 dump("DOSHL", "LSL", "B", "") if (used[12] != 1) goto L_00be; #line 795 // 795 dump("", "SUB", "A", "#1") dump("DOSHL", "LSL", "B", ""); #line 796 // 796 dump("SHL", "CMP", "A", "#0") dump("", "SUB", "A", "#1"); #line 797 // 797 dump("", "BGT", "", "DOSHL") dump("SHL", "CMP", "A", "#0"); #line 798 // 798 dump("", "RTS", "", "") dump("", "BGT", "", "DOSHL"); #line 799 // 799 %finish dump("", "RTS", "", ""); #line 800 // 800 %if used(13) = 1 %then %start L_00be: #line 801 // 801 dump("DOSHR", "LSR", "B", "") if (used[13] != 1) goto L_00bf; #line 802 // 802 dump("", "SUB", "A", "#1") dump("DOSHR", "LSR", "B", ""); #line 803 // 803 dump("SHR", "CMP", "A", "#0") dump("", "SUB", "A", "#1"); #line 804 // 804 dump("", "BGT", "", "DOSHR") dump("SHR", "CMP", "A", "#0"); #line 805 // 805 dump("", "RTS", "", "") dump("", "BGT", "", "DOSHR"); #line 806 // 806 %finish dump("", "RTS", "", ""); #line 807 // 807 %if used(14) = 1 %then %start L_00bf: #line 808 // 808 dump("EXP", "PSH", "S", "B") if (used[14] != 1) goto L_00c0; #line 809 // 809 dump("EXP2", "CMP", "A", "#1") dump("EXP", "PSH", "S", "B"); #line 810 // 810 dump("", "BGT", "", "DOEXP") dump("EXP2", "CMP", "A", "#1"); #line 811 // 811 dump("", "LEA", "S", "1,S") dump("", "BGT", "", "DOEXP"); #line 812 // 812 dump("", "RTS", "", "") dump("", "LEA", "S", "1,S"); #line 813 // 813 dump("DOEXP", "PSH", "U", "A") dump("", "RTS", "", ""); #line 814 // 814 dump("", "LDA", "", "0,S") dump("DOEXP", "PSH", "U", "A"); #line 815 // 815 dump("", "MUL", "", "") dump("", "LDA", "", "0,S"); #line 816 // 816 dump("", "PUL", "U", "A") dump("", "MUL", "", ""); #line 817 // 817 dump("", "SUB", "A", "#1") dump("", "PUL", "U", "A"); #line 818 // 818 dump("", "BRA", "", "EXP2") dump("", "SUB", "A", "#1"); #line 819 // 819 %finish dump("", "BRA", "", "EXP2"); #line 820 // 820 %if used(15) = 1 %then %start L_00c0: #line 821 // 821 ! 'B'//'A' if (used[15] != 1) goto L_00c1; #line 823 // 822 dump("DIV", "EQU", "", "*") // 823 dump("", "CLR", "", "-1,S") dump("DIV", "EQU", "", "*"); #line 824 // 824 dump("", "CLR", "", "-2,S") dump("", "CLR", "", "-1,S"); #line 825 // 825 dump("", "INC", "", "-2,S") dump("", "CLR", "", "-2,S"); #line 826 // 826 dump("", "TST", "B", "") dump("", "INC", "", "-2,S"); #line 827 // 827 dump("", "BGE", "", "TRYA") dump("", "TST", "B", ""); #line 828 // 828 dump("", "NEG", "B", "") dump("", "BGE", "", "TRYA"); #line 829 // 829 dump("", "CLR", "", "-2,S") dump("", "NEG", "B", ""); #line 830 // 830 dump("TRYA", "TST", "A", "") dump("", "CLR", "", "-2,S"); #line 831 // 831 dump("", "BGE", "", "OK") dump("TRYA", "TST", "A", ""); #line 832 // 832 dump("", "NEG", "A", "") dump("", "BGE", "", "OK"); #line 833 // 833 dump("", "TST", "", "-2,S") dump("", "NEG", "A", ""); #line 834 // 834 dump("", "BNE", "", "OK") dump("", "TST", "", "-2,S"); #line 835 // 835 dump("", "INC", "", "-2,S") dump("", "BNE", "", "OK"); #line 836 // 836 dump("OK", "TST", "B", "") dump("", "INC", "", "-2,S"); #line 837 // 837 dump("", "BLT", "", "DONE") dump("OK", "TST", "B", ""); #line 838 // 838 dump("", "INC", "", "-1,S") dump("", "BLT", "", "DONE"); #line 839 // 839 dump("", "PSH", "U", "A") dump("", "INC", "", "-1,S"); #line 840 // 840 dump("", "SUB", "B", ",U+") dump("", "PSH", "U", "A"); #line 841 // 841 dump("", "BRA", "", "OK") dump("", "SUB", "B", ",U+"); #line 842 // 842 dump("DONE", "DEC", "", "-1,S") dump("", "BRA", "", "OK"); #line 843 // 843 dump("", "TST", "", "-2,S") dump("DONE", "DEC", "", "-1,S"); #line 844 // 844 dump("", "BNE", "", "RET") dump("", "TST", "", "-2,S"); #line 845 // 845 dump("", "NEG", "", "-1,S") dump("", "BNE", "", "RET"); #lin