#include <perms.h>
// Edinburgh IMP77 Compiler - Version 8.4
//
// 1 ! Intel 8086 IMP77 compiler second pass
// 2
// 3 ! Copyright 2002 NB Information Limited. From an original
// 4 ! version probably Copyright The University of Edinburgh and
// 5 ! various contributions Copyright many other individuals, but
// 6 ! most particularly Copyright 1977-1980 Peter Robertson
// 7
// 8 %begin
int main(int argc, char **argv) { /*%begin*/
_imp_initialise(argc, argv);
// 9
// 10 !SIZE CONSTANTS
// 11 %constinteger max vars = 600
// 12 %constinteger max stack = 16
// 13 %constinteger max labs = 50
// 14 %constinteger max level = 16
// 15 %constinteger Max GP = 100
// 16
// 17 ! SOME WEE ENVIRONMENTAL THINGS
// 18 %conststring(8) program ep = "__impmain"; ! Main program external name
const _imp_string8 PROGRAMEP = _imp_str_init("__impmain");
// 19 %conststring(5) system prefix = "_imp_"; ! prefixed to %system routine idents
const _imp_string5 SYSTEMPREFIX = _imp_str_init("_imp_");
// 20
// 21 ! I/O file handles
// 22 %constinteger icode = 1
// 23 %constinteger source = 2
// 24 %constinteger report = 0
// 25 %constinteger objout = 1
// 26 %constinteger listout = 2
// 27
// 28 !CONTROL BITS
// 29 %constinteger check capacity = 1
// 30 %constinteger check unass = 2
// 31 %constinteger check array = 4
// 32 %constinteger check bits = check array; ! The only one that does anything so far
// 33
// 34 !REGISTERS - basic register number = actual value + 1
// 35 %constinteger AX = 1
// 36 %constinteger CX = 2
// 37 %constinteger DX = 3
// 38 %constinteger BX = 4
// 39 %constinteger SP = 5
// 40 %constinteger BP = 6
// 41 %constinteger SI = 7
// 42 %constinteger DI = 8
// 43
// 44 ! Floating point coprocessor stack registers
// 45 %constinteger FR0 = 9
// 46 !%constinteger FR1 = 10
// 47 !%constinteger FR2 = 11
// 48 !%constinteger FR3 = 12
// 49 !%constinteger FR4 = 13
// 50 !%constinteger FR5 = 14
// 51 !%constinteger FR6 = 15
// 52 %constinteger FR7 = 16
// 53
// 54 ! 8 bit registers - actual value + 17
// 55 %constinteger AL = 17
// 56 %constinteger CL = 18
// 57 %constinteger DL = 19
// 58 %constinteger BL = 20
// 59 %constinteger AH = 21
// 60 %constinteger CH = 22
// 61 %constinteger DH = 23
// 62 %constinteger BH = 24
// 63
// 64
// 65 ! Pseudo Registers
// 66 %constinteger any = 25 ; ! Truly any 16 bit register
// 67 %constinteger anyg = 26 ; ! A "General Purpose" byte accessible register (AX, BX, CX, DX)
// 68 %constinteger anyp = 27 ; ! A 16 bit pointing register (BX, SI, DI)
// 69 %constinteger anyf = 28 ; ! Generally means the top of the 8087 stack
// 70
// 71 !DATA FORMS
// 72
// 73 ! EXTERNAL
// 74 %constinteger recordformat = 4
// 75 %constinteger switch = 6
// 76 %constinteger array = 11
// 77 %constinteger arrayname = 12
// 78 %constinteger namearray = 13
// 79 %constinteger namearrayname = 14
// 80
// 81 ! INTERNAL
// 82 %constinteger constant = 0
// 83 %constinteger v in r = 1
// 84 %constinteger av in r = 2
// 85 %constinteger a in r = 3
// 86 %constinteger v in s = 4
// 87 %constinteger av in s = 5
// 88 %constinteger a in s = 6
// 89 %constinteger v in rec = 7
// 90 %constinteger av in rec = 8
// 91 %constinteger a in rec = 9
// 92 %constinteger pgm label = 10
// 93
// 94 !DATA TYPES
// 95 %constinteger general = 0
// 96 %constinteger integer = 1
// 97 %constinteger real = 2
// 98 %constinteger string = 3
// 99 %constinteger record = 4
// 100 ! Private internal derived types
// 101 %constinteger byte = 5
// 102 %constinteger lreal = 6
// 103
// 104 ! SIZE OF EACH OF THOSE TYPES IN BYTES
// 105 %constbyteintegerarray vsize(0:6) = 0,2,4,0,0,1,8
const unsigned char VSIZE[7] = {0, 2, 4, 0, 0, 1, 8};
// 106
// 107 ! GENERIC STORE ALIGNMENT - ASSUME 8086
// 108 %constinteger align = 1
// 109 %constinteger wordsize = 2; ! in bytes
// 110
// 111 !OWN INFO
// 112 %constinteger own = 1
// 113 %constinteger con = 2
// 114 %constinteger external = 3
// 115 %constinteger system = 4
// 116 %constinteger dynamic = 5
// 117 %constinteger primrt = 6
// 118 %constinteger permrt = 7
// 119
// 120 ! Define type codes known externally (to pass 3 and user):
// 121 %constbyteintegerarray gen map(general:lreal) =
const unsigned char GENMAP[7] = {0, 1, 2, 3, 4, 6, 8};
// 122+ 0, 1, 2, 3, 4, 6, 8
// 123
// 124 ! PERM ROUTINE INDEXES
// 125 %constinteger iexp=1; ! Integer Exponent
// 126 %constinteger fexp=2; ! floating exponent
// 127 %constinteger smove=3; ! string copy (length checked)
// 128 %constinteger sjam=4; ! string copy (whatever fits)
// 129 %constinteger sconc=5; ! string concatenate (length checked)
// 130 %constinteger sjconc=6; ! concatenate whatever fits
// 131 %constinteger sresln=7; ! string resolution
// 132 %constinteger scomp=8; ! string compare
// 133 %constinteger aref=9; ! array access
// 134 %constinteger adef=10; ! array definition
// 135 %constinteger signal=11; ! %signal
// 136 %constinteger lastperm=signal
// 137
// 138 ! and the corresponding linkage names for the perms
// 139 %const %string(12)%array permname(1:lastperm)=
const _imp_string12 PERMNAME[11] = {
_imp_str_init("__impiexp"), _imp_str_init("__impfexp"), _imp_str_init("__impstrcpy"),
_imp_str_init("__impstrjam"), _imp_str_init("__impstrcat"), _imp_str_init("__impstrjcat"),
_imp_str_init("__impstrres"), _imp_str_init("__impstrcmp"), _imp_str_init("__imparef"),
_imp_str_init("__impadef"), _imp_str_init("__impsignal")};
// 140+ "__impiexp",
// 141+ "__impfexp",
// 142+ "__impstrcpy",
// 143+ "__impstrjam",
// 144+ "__impstrcat",
// 145+ "__impstrjcat",
// 146+ "__impstrres",
// 147+ "__impstrcmp",
// 148+ "__imparef",
// 149+ "__impadef",
// 150+ "__impsignal"
// 151
// 152 ! COMPILER OPERATIONS (not to be confused with OpCodes)
// 153 %constinteger op add = 1
// 154 %constinteger op sub = 2
// 155 %constinteger op mul = 3
// 156 %constinteger op div = 4
// 157 %constinteger op conc = 5
// 158 %constinteger op and = 6
// 159 %constinteger op or = 7
// 160 %constinteger op xor = 8
// 161 %constinteger op lsh = 9
// 162 %constinteger op rsh = 10
// 163 %constinteger op rem = 11
// 164 %constinteger op exp = 12
// 165 %constinteger op rexp = 13
// 166 %constinteger op rdiv = 14
// 167 %constinteger op not = 15
// 168 %constinteger op neg = 16
// 169 %constinteger op abs = 17
// 170 %constinteger unaries = 15
// 171
// 172 ! opcode indexes...
// 173
// 174 ! simple (no operand) ones first
// 175 %constinteger NOP = 0
// 176 %constinteger CWD = 1
// 177 %constinteger RET = 2
// 178 %constinteger SAHF = 3
// 179
// 180 ! simple unary math functions
// 181 %constinteger DEC = 4
// 182 %constinteger INC = 5
// 183 %constinteger NEG = 6
// 184 %constinteger NOT = 7
// 185
// 186 ! simple unary moves
// 187 %constinteger POP = 8
// 188 %constinteger PUSH = 9
// 189
// 190 ! two operand moves
// 191 %constinteger LEA = 10
// 192 %constinteger MOV = 11
// 193 %constinteger XCHG = 12
// 194
// 195 ! simple two operand math functions
// 196 %constinteger ADC = 13
// 197 %constinteger ADD = 14
// 198 %constinteger AND = 15
// 199 %constinteger CMP = 16
// 200 %constinteger OR = 17
// 201 %constinteger SUB = 18
// 202 %constinteger XOR = 19
// 203 ! slightly more complicated two operand math
// 204 %constinteger SHL = 20
// 205 %constinteger SHR = 21
// 206 %constinteger IDIV = 22
// 207 %constinteger IMUL = 23
// 208
// 209 ! calls and jumps
// 210 %constinteger CALL = 24
// 211 %constinteger JE = 25
// 212 %constinteger JNE = 26
// 213 %constinteger JG = 27
// 214 %constinteger JGE = 28
// 215 %constinteger JL = 29
// 216 %constinteger JLE = 30
// 217 %constinteger JA = 31
// 218 %constinteger JAE = 32
// 219 %constinteger JB = 33
// 220 %constinteger JBE = 34
// 221 %constinteger JMP = 35
// 222
// 223 ! Floating point instructions - note that these map directly onto
// 224 ! 8087 sequences, unlike the generic MOV, ADD style of the base
// 225 ! operations for the 8086
// 226 %constinteger FILD = 36
// 227 %constinteger FLDD = 37
// 228 %constinteger FLDQ = 38
// 229 %constinteger FSTI = 39
// 230 %constinteger FSTD = 40
// 231 %constinteger FSTQ = 41
// 232 %constinteger FADD = 42
// 233 %constinteger FSUB = 43
// 234 %constinteger FSUBR = 44
// 235 %constinteger FMUL = 45
// 236 %constinteger FDIV = 46
// 237 %constinteger FDIVR = 47
// 238 %constinteger FCMP = 48
// 239 %constinteger FCHS = 49
// 240 %constinteger FABS = 50
// 241 ! Special floating point things
// 242 %constinteger FSTSW = 51
// 243 %constinteger FLDZ = 52
// 244 %constinteger FLDPI = 53
// 245
// 246 ! modifiers to memory base for accessing global memory
// 247 %constinteger DATA = 16_10
// 248 %constinteger COT = 16_20
// 249 %constinteger BSS = 16_30
// 250 %constinteger DISPLAY = 16_40
// 251 %constinteger EXT = 16_50
// 252 %constinteger SWT = 16_60
// 253 %constinteger CODE = 16_70
// 254
// 255 ! Standard IMPish data structures
// 256
// 257 ! Variables are declared here
// 258 %recordformat varfm(%byteinteger type, form, level, scope, dim, %c
struct VARFM {
union {
struct {
unsigned char TYPE;
unsigned char FORM;
unsigned char LEVEL;
unsigned char SCOPE;
unsigned char DIM;
int DISP;
int FORMAT;
int SIZE;
int PBASE;
int EXTRA;
};
};
};
// 259+ %integer disp, format, size, pbase, extra)
// 260 %record(varfm)%array var(0:max vars)
struct VARFM VAR[601];
// 261 %record(varfm)%name decvar
struct VARFM *DECVAR;
// 262 %record(varfm) begin
struct VARFM BEGIN;
// 263
// 264 ! The compiler is stack based
// 265 %recordformat stackfm(%byteinteger type, form, aform, base, scope, dim, %c
struct STACKFM {
union {
struct {
unsigned char TYPE;
unsigned char FORM;
unsigned char AFORM;
unsigned char BASE;
unsigned char SCOPE;
unsigned char DIM;
int DISP;
int FORMAT;
int SIZE;
int PBASE;
int EXTRA;
int VARNO;
};
};
};
// 266+ %integer disp, format, size, pbase, extra, %c
// 267+ %integer var no)
// 268 %record(stackfm)%array stack(1:max stack)
struct STACKFM STACK[16];
// 269 %record(stackfm) null
struct STACKFM NULL;
// 270 %record(stackfm)%name top
struct STACKFM *TOP;
// 271
// 272 ! Pass 1 uses a lame label redefinition that forces us to map
// 273 ! label ID's into unique labels for pass 3, using this database
// 274 %recordformat LabelFm(%integer id, tag)
struct LABELFM {
union {
struct {
int ID;
int TAG;
};
};
};
// 275 %record(LabelFm)%array Labels(1:Max Labs)
struct LABELFM LABELS[50];
// 276
// 277 ! Status of registers
// 278 %ownintegerarray activity(0:fr7) = 0, 0, 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
static int ACTIVITY[17] = {0, 0, 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
// 279 %owninteger claimed = 0
static int CLAIMED = 0;
// 280
// 281 ! Pointer registers may be pointing to non-local display - we remember
// 282 ! them for future use
// 283 %ownintegerarray displayhint(AX:DI) = 0, 0, 0, 0, 0, 0, 0, 0
static int DISPLAYHINT[8] = {0, 0, 0, 0, 0, 0, 0, 0};
// 284
// 285 ! Math Co-processor uses a stack - we remember where it should be
// 286 ! with this pointer
// 287 %owninteger fpustack = 0
static int FPUSTACK = 0;
// 288
// 289 ! A general purpose workspace resource
// 290 %recordformat gp tag(%integer info, addr, flags, link)
struct GPTAG {
union {
struct {
int INFO;
int ADDR;
int FLAGS;
int LINK;
};
};
};
// 291 %record(gptag)%array gptags(0:Max GP)
struct GPTAG GPTAGS[101];
// 292 %integer gp asl;
int GPASL;
// 293
// 294 %owninteger control = check bits; ! Current compiler flags (set by %control statement)
static int CONTROL = 4;
// 295 %owninteger diagnose = 0; ! Current diagnostic flags (set by %diagnose statement)
static int DIAGNOSE = 0;
// 296
// 297 %owninteger nextcad = 0; ! notional code address (not real - pass3 shuffles stuff)
static int NEXTCAD = 0;
// 298 %owninteger level = 0; ! current contextual level
static int LEVEL = 0;
// 299 %integer sym, next sym; ! CODE SYMBOL, NEXT SYMBOL
int SYM;
int NEXTSYM;
// 300 %integer vlb,vub; ! VECTOR LOWER/UPPER BOUND
int VLB;
int VUB;
// 301 %owninteger current line = 0; ! SOURCE LINE NUMBER
static int CURRENTLINE = 0;
// 302 %owninteger stp = 0; ! STACK POINTER
static int STP = 0;
// 303 %integer data size; ! CURRENT DATA ITEM SIZE
int DATASIZE;
// 304 %owninteger frame = 0; ! LOCAL STACK FRAME EXTENT
static int FRAME = 0;
// 305 %integer parms; ! START OF PARAMETER STACK
int PARMS;
// 306 %owninteger invert = 0; ! CONDITION INVERSION FLAG
static int INVERT = 0;
// 307 %owninteger compare unsign = 0; ! CONDITION WAS NON-STANDARD (GENERALLY FPU COMPARE)
static int COMPAREUNSIGN = 0;
// 308 %owninteger uncond jump = 0; ! ADDRESS OF CODE HOLE
static int UNCONDJUMP = 0;
// 309 %owninteger block type = 1; ! -1 = RECORDS, 1 = PROCEDURE, 2 = SPEC
static int BLOCKTYPE = 1;
// 310 %owninteger in params = 0; ! NON-ZERO INSIDE PARAMETER LISTS
static int INPARAMS = 0;
// 311 %integer decl; ! LAST-DEFINED DESCRIPTOR
int DECL;
// 312 %integer otype, owntype, ownform; ! Information about OWNs currently being declared
int OTYPE;
int OWNTYPE;
int OWNFORM;
// 313 %integer spec, frozen, potype; ! More about current declaration
int SPEC;
int FROZEN;
int POTYPE;
// 314 %integer dim; ! Dimensions
int DIM;
// 315 %integer i, j; ! used in the initialisation loops only
int I;
int J;
// 316 %owninteger Fp Result Loc = -1; ! Place to store Real and LReal function results
static int FPRESULTLOC = -1;
// 317
// 318 %constinteger max dataseg = 12000; ! Size in bytes of data segment table
// 319 %byteintegerarray datat(0:max dataseg)
unsigned char DATAT[12001];
// 320 %owninteger datatp = 0; ! pointer to next data segment byte
static int DATATP = 0;
// 321
// 322 %constinteger max switch = 1000; ! Size in WORDS of switch segment table
// 323 %integerarray swtab(0:max switch)
int SWTAB[1001];
// 324 %owninteger swtp = 0; ! pointer to next switch segment entry
static int SWTP = 0;
// 325
// 326 %ownstring(255) external id = "", alias = ""
static _imp_string255 EXTERNALID = _imp_str_init("");
static _imp_string255 ALIAS = _imp_str_init("");
// 327 %ownstring(255) internal id = ""
static _imp_string255 INTERNALID = _imp_str_init("");
// 328
// 329 %byteintegername cslen
unsigned char *CSLEN;
// 330 %byteintegerarray current string(0:255); ! current string literal
unsigned char CURRENTSTRING[256];
// 331
// 332 %integer xlen
int XLEN;
// 333 %byteintegerarray xsymbuff(0:255); ! current external string name
unsigned char XSYMBUFF[256];
// 334
// 335 ! WORK List - used to optimise use of temporary storage
// 336 ! There is a head of list for each contextual level
// 337 %ownintegerarray worklist(1:max level) =
static int WORKLIST[16] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
// 338+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
// 339
// 340 %longreal rvalue; ! floating point value for constants and initialisers
double RVALUE;
// 341
// 342 %owninteger ownval = 0; ! value to use when initialising OWNs
static int OWNVAL = 0;
// 343
// 344 !-----------------------------------------------------------
// 345 ! Start with machine independent utility functions and stack
// 346 ! manipulation and debug
// 347 !-----------------------------------------------------------
// 348
// 349 ! >> SHOW <<
// 350 %routine show(%record(stackfm)%name v)
void SHOW(struct STACKFM * V) {
// 351 write(v_varno,3);
_imp_WRITE(V->VARNO, 3);
// 352 print string(" : Typ="); write(v_type,1)
_imp_PRINTSTRING(_imp_str_literal(" : Typ="));
_imp_WRITE(V->TYPE, 1);
// 353 print string(" Frm="); write(v_form,1)
_imp_PRINTSTRING(_imp_str_literal(" Frm="));
_imp_WRITE(V->FORM, 1);
// 354 print string(" Bse="); write(v_base,1);
_imp_PRINTSTRING(_imp_str_literal(" Bse="));
_imp_WRITE(V->BASE, 1);
// 355 print string(" Dsp="); write(v_disp,4)
_imp_PRINTSTRING(_imp_str_literal(" Dsp="));
_imp_WRITE(V->DISP, 4);
// 356 print string(" Siz="); write(v_size,1)
_imp_PRINTSTRING(_imp_str_literal(" Siz="));
_imp_WRITE(V->SIZE, 1);
// 357 print string(" Xtr="); write(v_extra,1)
_imp_PRINTSTRING(_imp_str_literal(" Xtr="));
_imp_WRITE(V->EXTRA, 1);
// 358 print string(" Fmt="); write(v_format,1)
_imp_PRINTSTRING(_imp_str_literal(" Fmt="));
_imp_WRITE(V->FORMAT, 1);
// 359 print string(" Dim="); write(v_dim,1)
_imp_PRINTSTRING(_imp_str_literal(" Dim="));
_imp_WRITE(V->DIM, 1);
// 360 print string(" Pba="); write(v_pbase,1)
_imp_PRINTSTRING(_imp_str_literal(" Pba="));
_imp_WRITE(V->PBASE, 1);
// 361 newline
_imp_NEWLINE();
// 362 %end
return;
} /* end of SHOW */
// 363
// 364 ! Simple ABORT routine
// 365 %routine abort(%string(255) message)
void ABORT(_imp_string255 MESSAGE) {
// 366 %integer j
int J;
// 367
// 368 select output(report)
_imp_SELECTOUTPUT(0);
// 369 printstring("Pass 2 abandoned at line ");
_imp_PRINTSTRING(_imp_str_literal("Pass 2 abandoned at line "));
// 370 write(current line, 1);
_imp_WRITE(CURRENTLINE, 1);
// 371 printstring(" : ");
_imp_PRINTSTRING(_imp_str_literal(" : "));
// 372 printstring(message)
_imp_PRINTSTRING(
*({
__typeof__(_imp_string255) tmp = MESSAGE /*q*/;
(_imp_string255 *)&tmp;
})
);
// 373 newline
_imp_NEWLINE();
// 374 %if stp # 0 %start
if (STP == 0) goto L_0001;
// 375 print string("STACK:"); newline
_imp_PRINTSTRING(_imp_str_literal("STACK:"));
_imp_NEWLINE();
// 376 show(stack(j)) %for j = 1,1,stp
// %for J = 1, 1, STP %cycle
{
int _final = STP;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, STP");
J = 0;
L_0002:
if (J == _final) goto L_0003;
J += 1;
SHOW(/*?*/ &STACK[J - 1]);
goto L_0002;
}
L_0003:;
// 377 %finish
L_0001:;
// 378 %stop
_imp_stop(0);
// 379 %end
} /* end of ABORT */
// 380
// 381 ! >> WARN <<
// 382 %routine warn(%integer n)
void WARN(int N) {
// 383 %switch w(1:8)
int W_index;
int W_line;
char *W_file;
static const void *W[8] = {&&case_W_missing, &&case_W_missing, &&case_W_missing, &&case_W_missing,
&&case_W_missing, &&case_W_missing, &&case_W_missing, &&case_W_missing};
// 384 select output(report)
_imp_SELECTOUTPUT(0);
// 385 print string("*WARNING: line")
_imp_PRINTSTRING(_imp_str_literal("*WARNING: line"));
// 386 write(current line, 1); print string(": ")
_imp_WRITE(CURRENTLINE, 1);
_imp_PRINTSTRING(_imp_str_literal(": "));
// 387 -> w(n)
W_line = __LINE__;
W_file = __FILE__;
W_index = N;
goto case_W_dispatch;
// 388 w(1): print string("division by zero"); -> at
case_W_1:;
_imp_PRINTSTRING(_imp_str_literal("division by zero"));
goto U_1000;
// 389 w(2): print string("Illegal FOR"); -> at
case_W_2:;
_imp_PRINTSTRING(_imp_str_literal("Illegal FOR"));
goto U_1000;
// 390 w(3): print string("Non-local control variable?"); -> at
case_W_3:;
_imp_PRINTSTRING(_imp_str_literal("Non-local control variable?"));
goto U_1000;
// 391 w(4): print string("Invalid parameter for READ SYMBOL"); -> at
case_W_4:;
_imp_PRINTSTRING(_imp_str_literal("Invalid parameter for READ SYMBOL"));
goto U_1000;
// 392 w(5): print string("String constant too long"); -> at
case_W_5:;
_imp_PRINTSTRING(_imp_str_literal("String constant too long"));
goto U_1000;
// 393 w(6): print string("No. of shifts outwith 0..31"); -> at
case_W_6:;
_imp_PRINTSTRING(_imp_str_literal("No. of shifts outwith 0..31"));
goto U_1000;
// 394 w(7): print string("Illegal constant exponent"); -> at
case_W_7:;
_imp_PRINTSTRING(_imp_str_literal("Illegal constant exponent"));
goto U_1000;
// 395 w(8): print string("Numerical constant too big"); -> at
case_W_8:;
_imp_PRINTSTRING(_imp_str_literal("Numerical constant too big"));
goto U_1000;
// 396 at: newline
U_1000:;
_imp_NEWLINE();
// 397 select output(objout)
_imp_SELECTOUTPUT(1);
// 398 %end
return;
case_W_dispatch:
if (W_index < 1 || W_index > 8)
_imp_signalf(6, 3, W_index, "->W(%d) out of bounds at %s line %d", W_index, W_file, W_line);
goto *W[W_index - 1];
case_W_missing:
_imp_signalf(8, 2, W_index, "switch jump to undefined label W(%d): at %s line %d", W_index, W_file, W_line);
} /* end of WARN */
// 399
// 400 ! >> MONITOR <<
// 401 %routine monitor(%record(stackfm)%name v, %string(15) text)
void MONITOR(struct STACKFM * V, _imp_string15 TEXT) {
// 402 select output(report)
_imp_SELECTOUTPUT(0);
// 403 print string(text); print symbol(':')
_imp_PRINTSTRING(
*({
__typeof__(_imp_string15) tmp = TEXT /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_PRINTSYMBOL(58);
// 404 spaces(10-length(text))
_imp_SPACES(10 - *_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &TEXT));
// 405 show(v)
SHOW(V);
// 406 select output(objout)
_imp_SELECTOUTPUT(1);
// 407 %end
return;
} /* end of MONITOR */
// 408
// 409 ! >> GET GP TAG <<
// 410 %integerfn get gp tag
int GETGPTAG(void) {
// 411 %integer l
int L;
// 412
// 413 %if gp asl = 0 %then abort("GP Tags")
if (GPASL != 0) goto L_0006;
ABORT(_imp_str_literal("GP Tags"));
L_0006:;
// 414 l = gp asl
L = GPASL;
// 415 gp asl = gp tags(l)_link
GPASL = GPTAGS[L].LINK;
// 416 %result = l
return L;
// 417 %end
} /* end of GETGPTAG */
// 418
// 419 ! >> RET GP TAG <<
// 420 %routine ret gp tag(%integer index)
void RETGPTAG(int INDEX) {
// 421
// 422 gp tags(index)_link = gp asl
GPTAGS[INDEX].LINK = GPASL;
// 423 gp asl = index
GPASL = INDEX;
// 424 %end
return;
} /* end of RETGPTAG */
// 425
// 426 !------------------------------------------------------
// 427 ! Machine dependent utility routines
// 428 !------------------------------------------------------
// 429
// 430 ! Routines to write the intermediate file
// 431 ! Record format is:
// 432 ! <type><length><data>
// 433 ! For debug purposes, the elements are all written as ascii
// 434 ! characters, where <type> is a single letter, <length> is a single
// 435 ! hex digit, length refers to the number of bytes (2 chars) of data.
// 436
// 437 ! Intermediate file types:
// 438 %constinteger IF OBJ = 0; ! A - plain object code
// 439 %constinteger IF DATA = 1; ! B - dataseg offset code word
// 440 %constinteger IF CONST = 2; ! C - const seg offset code word
// 441 %constinteger IF DISPLAY = 3; ! D - display seg offset code word
// 442 %constinteger IF JUMP = 4; ! E - unconditional jump to label
// 443 %constinteger IF JCOND = 5; ! F - cond jump to label JE, JNE, JLE, JL, JGE, JG
// 444 %constinteger IF CALL = 6; ! G - call a label
// 445 %constinteger IF LABEL = 7; ! H - define a label
// 446 %constinteger IF FIXUP = 8; ! I - define location for stack fixup instruction
// 447 %constinteger IF SETFIX = 9; ! J - stack fixup <location> <amount>
// 448 %constinteger IF REQEXT = 10; ! K - external name spec
// 449 %constinteger IF REFEXT = 12; ! M - external name relative offset code word
// 450 %constinteger IF BSS = 13; ! N - BSS segment offset code word
// 451 %constinteger IF COTWORD = 14; ! O - Constant table word
// 452 %constinteger IF DATWORD = 15; ! P - Data segment word
// 453 %constinteger IF SWTWORD = 16; ! Q - switch table entry - actually a label ID
// 454 %constinteger IF SOURCE = 17; ! R - name of the source file
// 455 %constinteger IF DEFEXTCODE = 18; ! S - define a code label that is external
// 456 %constinteger IF DEFEXTDATA = 19; ! T - define a data label that is external
// 457 %constinteger IF SWT = 20; ! U - switch table offset code word
// 458 %constinteger IF LINE = 21; ! V - line number info for debugger
// 459
// 460 %routine writenibble(%integer n)
void WRITENIBBLE(int N) {
// 461 n = n & 16_f;
N = N & 15;
// 462 %if 0 <= n %and n <= 9 %start
if (0 > N) goto L_0007;
if (N > 9) goto L_0007;
// 463 printsymbol(n + '0');
_imp_PRINTSYMBOL(N + 48);
// 464 %else
goto L_0008;
L_0007:;
// 465 printsymbol(n + ('A' - 10));
_imp_PRINTSYMBOL(N + (65 - 10));
// 466 %finish
L_0008:;
// 467 %end
return;
} /* end of WRITENIBBLE */
// 468
// 469 ! print a number in hexadecimal, to "places" size
// 470 %routine write hex(%integer n, places)
void WRITEHEX(int N, int PLACES) {
// 471 %integer p, shift
int P;
int SHIFT;
// 472
// 473 shift = (places - 1) * 4
SHIFT = (PLACES - 1) * 4;
// 474 %while shift > 0 %cycle
L_0009:;
if (SHIFT <= 0) goto L_000A;
// 475 p = n >> shift
P = (unsigned int)N >> SHIFT;
// 476 writenibble(p)
WRITENIBBLE(P);
// 477 shift = shift - 4
SHIFT = SHIFT - 4;
// 478 %repeat
goto L_0009;
L_000A:;
// 479 writenibble(n)
WRITENIBBLE(N);
// 480 %end
return;
} /* end of WRITEHEX */
// 481
// 482 %routine writeifrecord(%integer type, %integer length, %byteintegerarrayname buffer)
void WRITEIFRECORD(int TYPE, int LENGTH, unsigned char *BUFFER) {
// 483 %integer c1, c2, i;
int C1;
int C2;
int I;
// 484
// 485 select output(objout)
_imp_SELECTOUTPUT(1);
// 486 printsymbol('A'+type);
_imp_PRINTSYMBOL(65 + TYPE);
// 487 %if (length > 255) %then abort("Intermediate file record too long");
if (LENGTH <= 255) goto L_000B;
ABORT(_imp_str_literal("Intermediate file record too long"));
L_000B:;
// 488 writenibble(length>>4);
WRITENIBBLE((unsigned int)LENGTH >> 4);
// 489 writenibble(length&15);
WRITENIBBLE(LENGTH & 15);
// 490
// 491 i = 0;
I = 0;
// 492 %while (length > 0) %cycle
L_000C:;
if (LENGTH <= 0) goto L_000D;
// 493 c1 = buffer(i) >> 4;
C1 = (unsigned int)[/*BUG*/ 0] >> 4;
// 494 c2 = buffer(i) & 15;
C2 = [/*BUG*/ 0] & 15;
// 495 writenibble(c1);
WRITENIBBLE(C1);
// 496 writenibble(c2);
WRITENIBBLE(C2);
// 497 i = i + 1;
I = I + 1;
// 498 length = length - 1;
LENGTH = LENGTH - 1;
// 499 %repeat
goto L_000C;
L_000D:;
// 500 newline
_imp_NEWLINE();
// 501 %end
return;
} /* end of WRITEIFRECORD */
// 502
// 503 ! Simple buffered output of code bytes...
// 504 %own %integer objectptr = 0;
static int OBJECTPTR = 0;
// 505 %own %byte %integer %array objectbytes(0:7);
static unsigned char OBJECTBYTES[8];
// 506 ! And corresponding bytes for the listing (not always the same for fudged opcodes)
// 507 %own %integer listptr = 0;
static int LISTPTR = 0;
// 508 %own %byte %integer %array listbytes(0:7);
static unsigned char LISTBYTES[8];
// 509
// 510 ! Routine to provide the address and hex opcode listing in the
// 511 ! diagnostic output
// 512 %routine listpreamble
void LISTPREAMBLE(void) {
// 513 %integer i;
int I;
// 514
// 515 select output(listout)
_imp_SELECTOUTPUT(2);
// 516 space; writehex(nextcad, 4); space;
_imp_SPACE();
WRITEHEX(NEXTCAD, 4);
_imp_SPACE();
// 517 %for i = 0, 1, 7 %cycle
// %for I = 0, 1, 7 %cycle
{
I = -1;
L_000E:
if (I == 7) goto L_000F;
I += 1;
// 518 %if i < listptr %start
if (I >= LISTPTR) goto L_0011;
// 519 writehex(listbytes(i), 2)
WRITEHEX(LISTBYTES[I], 2);
// 520 space
_imp_SPACE();
// 521 %else
goto L_0012;
L_0011:;
// 522 spaces(3)
_imp_SPACES(3);
// 523 %finish
L_0012:;
// 524 %repeat
goto L_000E;
}
L_000F:;
// 525 spaces(8)
_imp_SPACES(8);
// 526 nextcad = nextcad + listptr;
NEXTCAD = NEXTCAD + LISTPTR;
// 527 listptr = 0;
LISTPTR = 0;
// 528 %end
return;
} /* end of LISTPREAMBLE */
// 529
// 530 ! flush the code buffer
// 531 %routine flushcode
void FLUSHCODE(void) {
// 532 %if objectptr # 0 %start
if (OBJECTPTR == 0) goto L_0013;
// 533 writeifrecord(IF OBJ, objectptr, objectbytes);
WRITEIFRECORD(0, OBJECTPTR, OBJECTBYTES);
// 534 objectptr = 0; ! reset the output pipe
OBJECTPTR = 0;
// 535 %finish
L_0013:;
// 536 %end
return;
} /* end of FLUSHCODE */
// 537
// 538 ! puts a normal code byte into the listing and code pipes
// 539 %routine putbyte(%integer b)
void PUTBYTE(int B) {
// 540 listbytes(listptr) = b;
LISTBYTES[LISTPTR] = B;
// 541 listptr = listptr + 1;
LISTPTR = LISTPTR + 1;
// 542 objectbytes(objectptr) = b;
OBJECTBYTES[OBJECTPTR] = B;
// 543 objectptr = objectptr + 1;
OBJECTPTR = OBJECTPTR + 1;
// 544 %end
return;
} /* end of PUTBYTE */
// 545
// 546 ! A very handy little boolean function, used for instructions
// 547 ! with variable size immediate operands
// 548 %integerfn issmall(%integer i)
int ISSMALL(int I) {
// 549 %result = 1 %if i < 128 %and i > -128
if (I >= 128) goto L_0014;
if (I <= -128) goto L_0014;
return 1;
L_0014:;
// 550 %result = 0;
return 0;
// 551 %end
} /* end of ISSMALL */
// 552
// 553 ! And aide-memoire of intel 8086 address modes...
// 554 ! DS:[BX+SI]
// 555 ! DS:[BX+DI]
// 556 ! SS:[BP+SI]
// 557 ! SS:[BP+DI]
// 558 ! DS:[SI];
// 559 ! DS:[DI];
// 560 ! DS: [offset16]
// 561 ! DS: [BX]
// 562 ! DS:[BX + SI + offset8]
// 563 ! DS:[BX + DI + offset8]
// 564 ! SS:[BP + SI + offset8]
// 565 ! SS:[BP + DI + offset8]
// 566 ! DS:[SI + offset8]
// 567 ! DS:[DI + offset8]
// 568 ! SS:[BP + offset8]
// 569 ! DS:[BX + offset8]
// 570 ! DS:[BX + SI + offset16]
// 571 ! DS:[BX + DI + offset16]
// 572 ! SS:[BP + SI + offset16]
// 573 ! SS:[BP + DI + offset16]
// 574 ! DS:[SI + offset16]
// 575 ! DS:[DI + offset16]
// 576 ! SS:[BP + offset16]
// 577 ! DS:[BX + offset16]
// 578
// 579 ! mod r/m format is:
// 580 ! mod LHREG R/M
// 581 ! where mod = 11 for rh registers
// 582
// 583 ! plant a modrm reference where the rh operand is a register
// 584 ! Both parameters are actual register numbers, not internal ID's
// 585 %routine modrmreg(%integer reg1, %integer reg2)
void MODRMREG(int REG1, int REG2) {
// 586 putbyte(16_C0 ! (reg1 << 3) ! (reg2));
PUTBYTE(192 | REG1 << 3 | REG2);
// 587 %end
return;
} /* end of MODRMREG */
// 588
// 589 ! tags corresponding to linker directives...
// 590 %const %integer %array reltag(0:6) =
const int RELTAG[7] = {0, 1, 2, 13, 3, 12, 20};
// 591+ 0, ;! no relocation
// 592+ 1, ;! dataseg offset code word
// 593+ 2, ;! const seg offset code word
// 594+ 13, ;! BSS relative code word
// 595+ 3, ;! display seg offset code word
// 596+ 12, ;! external name relative offset code word
// 597+ 20 ;! switch table offset code word
// 598
// 599 ! plant code for a relocated (DATA/BSS/DISPLAY/EXTERNAL) code word
// 600 %routine relocateoffset(%integer reloc, %integer offset)
void RELOCATEOFFSET(int RELOC, int OFFSET) {
// 601 %integer tag;
int TAG;
// 602
// 603 flushcode %if reloc # 0; ! so that only the offset is going into the queue
if (RELOC == 0) goto L_0015;
FLUSHCODE();
L_0015:;
// 604
// 605 putbyte(offset & 255);
PUTBYTE(OFFSET & 255);
// 606 putbyte(offset >> 8);
PUTBYTE((unsigned int)OFFSET >> 8);
// 607
// 608 %if reloc # 0 %start
if (RELOC == 0) goto L_0016;
// 609 tag = reltag(reloc);
TAG = RELTAG[RELOC];
// 610 writeifrecord(tag, 2, objectbytes);
WRITEIFRECORD(TAG, 2, OBJECTBYTES);
// 611 objectptr = 0; ! clear the queue
OBJECTPTR = 0;
// 612 %finish
L_0016:;
// 613 %end
return;
} /* end of RELOCATEOFFSET */
// 614
// 615 ! plant a modrm reference where the rh operand is in memory
// 616 ! Parameter REG1 is an actual register number, but BASE is an internal ID
// 617 %routine modrmmem(%integer reg1, %integer base, %integer disp)
void MODRMMEM(int REG1, int BASE, int DISP) {
// 618 %integer mod, rm, reloc;
int MOD;
int RM;
int RELOC;
// 619
// 620 reloc = base>>4;
RELOC = (unsigned int)BASE >> 4;
// 621 base = base & 15;
BASE = BASE & 15;
// 622
// 623 %if base = 0 %start; ! no register, just a displacement
if (BASE != 0) goto L_0017;
// 624 ! mod = 000, rm = 110
// 625 putbyte((reg1 << 3) ! 6);
PUTBYTE(REG1 << 3 | 6);
// 626 relocateoffset(reloc, disp);
RELOCATEOFFSET(RELOC, DISP);
// 627 %else
goto L_0018;
L_0017:;
// 628 %if disp = 0 %start
if (DISP != 0) goto L_0019;
// 629 mod = 0
MOD = 0;
// 630 %else
goto L_001A;
L_0019:;
// 631 %if issmall(disp) # 0 %start; ! fits in one byte
if (ISSMALL(DISP) == 0) goto L_001B;
// 632 mod = 1
MOD = 1;
// 633 %else
goto L_001C;
L_001B:;
// 634 mod = 2
MOD = 2;
// 635 %finish
L_001C:;
// 636 %finish
L_001A:;
// 637
// 638 ! unfortunately displacement (even zero) must be output in full if
// 639 ! the offset is relocatable
// 640 %if reloc # 0 %then mod = 2;
if (RELOC == 0) goto L_001D;
MOD = 2;
L_001D:;
// 641
// 642 %if base = BP %start
if (BASE != 6) goto L_001E;
// 643 rm = 6;
RM = 6;
// 644 %else
goto L_001F;
L_001E:;
// 645 %if base = BX %start
if (BASE != 4) goto L_0020;
// 646 rm = 7;
RM = 7;
// 647 %else
goto L_0021;
L_0020:;
// 648 %if base = DI %start
if (BASE != 8) goto L_0022;
// 649 rm = 5;
RM = 5;
// 650 %else
goto L_0023;
L_0022:;
// 651 %if base = SI %start
if (BASE != 7) goto L_0024;
// 652 rm = 4;
RM = 4;
// 653 %else
goto L_0025;
L_0024:;
// 654 abort("Internal address mode error");
ABORT(_imp_str_literal("Internal address mode error"));
// 655 %finish
L_0025:;
// 656 %finish
L_0023:;
// 657 %finish
L_0021:;
// 658 %finish
L_001F:;
// 659
// 660 putbyte((mod << 6)!(reg1 << 3)!rm);
PUTBYTE(MOD << 6 | REG1 << 3 | RM);
// 661
// 662 %if mod = 1 %start
if (MOD != 1) goto L_0026;
// 663 putbyte(disp);
PUTBYTE(DISP);
// 664 %else
goto L_0027;
L_0026:;
// 665 %if mod = 2 %then relocateoffset(reloc, disp)
if (MOD != 2) goto L_0028;
RELOCATEOFFSET(RELOC, DISP);
L_0028:;
// 666 %finish
L_0027:;
// 667 %finish
L_0018:;
// 668 %end
return;
} /* end of MODRMMEM */
// 669
// 670 %const %string(2) %array regname(AX:DI) =
const _imp_string2 REGNAME[8] = {_imp_str_init("AX"), _imp_str_init("CX"), _imp_str_init("DX"), _imp_str_init("BX"),
_imp_str_init("SP"), _imp_str_init("BP"), _imp_str_init("SI"), _imp_str_init("DI")};
// 671+ "AX", "CX", "DX", "BX", "SP", "BP", "SI", "DI"
// 672
// 673 %const %string(2) %array reg8name(AL:BH) =
const _imp_string2 REG8NAME[8] = {_imp_str_init("AL"), _imp_str_init("CL"), _imp_str_init("DL"), _imp_str_init("BL"),
_imp_str_init("AH"), _imp_str_init("CH"), _imp_str_init("DH"), _imp_str_init("BH")};
// 674+ "AL", "CL", "DL", "BL", "AH", "CH", "DH", "BH"
// 675
// 676 %const %string(7) %array relocname(0:6) =
const _imp_string7 RELOCNAME[7] = {_imp_str_init(""), _imp_str_init("DATA"), _imp_str_init("COT"),
_imp_str_init("BSS"), _imp_str_init("DISPLAY"), _imp_str_init("EXTERN"),
_imp_str_init("SWTAB")};
// 677+ "", "DATA", "COT", "BSS", "DISPLAY", "EXTERN", "SWTAB"
// 678
// 679 ! Print the corresponding memory access string
// 680 ! BASE is an internal ID, not an actual register number
// 681 %routine printmemref(%integer base, %integer disp)
void PRINTMEMREF(int BASE, int DISP) {
// 682 %integer reloc;
int RELOC;
// 683
// 684 reloc = base >> 4;
RELOC = (unsigned int)BASE >> 4;
// 685 base = base & 15;
BASE = BASE & 15;
// 686 selectoutput(listout)
_imp_SELECTOUTPUT(2);
// 687 printsymbol('[');
_imp_PRINTSYMBOL(91);
// 688 %if base # 0 %start
if (BASE == 0) goto L_0029;
// 689 printstring(regname(base));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REGNAME[BASE - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 690 %if reloc # 0 %start
if (RELOC == 0) goto L_002A;
// 691 printsymbol('+'); printstring(relocname(reloc));
_imp_PRINTSYMBOL(43);
_imp_PRINTSTRING(
*({
__typeof__(_imp_string7) tmp = RELOCNAME[RELOC] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 692 %finish
L_002A:;
// 693 %if disp # 0 %then %start
if (DISP == 0) goto L_002B;
// 694 printsymbol('+') %if disp > 0
if (DISP <= 0) goto L_002C;
_imp_PRINTSYMBOL(43);
L_002C:;
// 695 write(disp,1)
_imp_WRITE(DISP, 1);
// 696 %finish
L_002B:;
// 697 %else
goto L_002D;
L_0029:;
// 698 %if reloc # 0 %start
if (RELOC == 0) goto L_002E;
// 699 printstring(relocname(reloc)); printsymbol('+')
_imp_PRINTSTRING(
*({
__typeof__(_imp_string7) tmp = RELOCNAME[RELOC] /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_PRINTSYMBOL(43);
// 700 %finish
L_002E:;
// 701 writehex(disp, 4)
WRITEHEX(DISP, 4);
// 702 %finish
L_002D:;
// 703 printsymbol(']');
_imp_PRINTSYMBOL(93);
// 704 %end
return;
} /* end of PRINTMEMREF */
// 705
// 706 ! opcodes
// 707 %const %string(4) %array opname(NOP:JMP) =
const _imp_string4 OPNAME[36] = {
_imp_str_init("NOP"), _imp_str_init("CWD"), _imp_str_init("RET"), _imp_str_init("SAHF"), _imp_str_init("DEC"),
_imp_str_init("INC"), _imp_str_init("NEG"), _imp_str_init("NOT"), _imp_str_init("POP"), _imp_str_init("PUSH"),
_imp_str_init("LEA"), _imp_str_init("MOV"), _imp_str_init("XCHG"), _imp_str_init("ADC"), _imp_str_init("ADD"),
_imp_str_init("AND"), _imp_str_init("CMP"), _imp_str_init("OR"), _imp_str_init("SUB"), _imp_str_init("XOR"),
_imp_str_init("SHL"), _imp_str_init("SHR"), _imp_str_init("IDIV"), _imp_str_init("IMUL"), _imp_str_init("CALL"),
_imp_str_init("JE"), _imp_str_init("JNE"), _imp_str_init("JG"), _imp_str_init("JGE"), _imp_str_init("JL"),
_imp_str_init("JLE"), _imp_str_init("JA"), _imp_str_init("JAE"), _imp_str_init("JB"), _imp_str_init("JBE"),
_imp_str_init("JMP")};
// 708+ "NOP", "CWD", "RET", "SAHF",
// 709+ "DEC", "INC", "NEG", "NOT",
// 710+ "POP", "PUSH",
// 711+ "LEA", "MOV", "XCHG",
// 712+ "ADC", "ADD", "AND", "CMP", "OR", "SUB", "XOR",
// 713+ "SHL", "SHR", "IDIV", "IMUL",
// 714+ "CALL", "JE", "JNE",
// 715+ "JG", "JGE", "JL", "JLE",
// 716+ "JA", "JAE", "JB", "JBE", "JMP"
// 717
// 718
// 719 %const %byte %integer %array opvalue(NOP:JMP) =
const unsigned char OPVALUE[36] = {144, 153, 195, 158, 255, 255, 247, 247, 143, 255, 139, 137,
135, 17, 1, 33, 57, 9, 41, 49, 209, 209, 247, 247,
232, 116, 117, 127, 125, 124, 126, 119, 115, 114, 118, 235};
// 720+ 16_90, 16_99, 16_C3, 16_9E,
// 721+ 16_FF, 16_FF, 16_F7, 16_F7,
// 722+ 16_8F, 16_FF,
// 723+ 16_8B, 16_89, 16_87, ;! LEA is fudged as if it were m <- r, to allow the flip
// 724+ 16_11, 16_01, 16_21, 16_39, 16_09, 16_29, 16_31,
// 725+ 16_D1, 16_D1, 16_F7, 16_F7,
// 726+ 16_E8, 16_74, 16_75,
// 727+ 16_7F, 16_7D, 16_7C, 16_7E,
// 728+ 16_77, 16_73, 16_72, 16_76, 16_EB
// 729
// 730 ! 8 bit equivalent opcodes
// 731 %const %byte %integer %array op8value(NOP:JMP) =
const unsigned char OP8VALUE[36] = {144, 153, 195, 158, 254, 254, 246, 246, 143, 255, 139, 136,
134, 16, 0, 32, 56, 8, 40, 48, 208, 208, 246, 246,
232, 116, 117, 127, 125, 124, 126, 119, 115, 114, 118, 235};
// 732+ 16_90, 16_99, 16_C3, 16_9E, ;! not 8 bit, included for completeness
// 733+ 16_FE, 16_FE, 16_F6, 16_F6,
// 734+ 16_8F, 16_FF, ;! not 8 bit, included for completeness
// 735+ 16_8B, 16_88, 16_86, ;! LEA is not applicable for 8 bit
// 736+ 16_10, 16_00, 16_20, 16_38, 16_08, 16_28, 16_30,
// 737+ 16_D0, 16_D0, 16_F6, 16_F6,
// 738+ 16_E8, 16_74, 16_75,
// 739+ 16_7F, 16_7D, 16_7C, 16_7E,
// 740+ 16_77, 16_73, 16_72, 16_76, 16_EB ;! not 8 bit, included for completeness
// 741
// 742 ! An opcode with no operands (eg RET)
// 743 %routine dumpsimple(%integer opn)
void DUMPSIMPLE(int OPN) {
// 744
// 745 putbyte(opvalue(opn));
PUTBYTE(OPVALUE[OPN]);
// 746
// 747 listpreamble;
LISTPREAMBLE();
// 748 printstring(opname(opn));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 749 newline
_imp_NEWLINE();
// 750 flushcode;
FLUSHCODE();
// 751 %end
return;
} /* end of DUMPSIMPLE */
// 752
// 753 ! A special bit of magic, used in record assignment
// 754 %routine dumprepmovsb
void DUMPREPMOVSB(void) {
// 755 putbyte(16_f3); ! rep
PUTBYTE(243);
// 756 putbyte(16_a4); ! movsb
PUTBYTE(164);
// 757
// 758 listpreamble;
LISTPREAMBLE();
// 759 printstring("REP MOVSB");
_imp_PRINTSTRING(_imp_str_literal("REP MOVSB"));
// 760 newline
_imp_NEWLINE();
// 761 flushcode;
FLUSHCODE();
// 762 %end
return;
} /* end of DUMPREPMOVSB */
// 763
// 764 ! Used in record = 0 assignment
// 765 %routine dumprepstosb
void DUMPREPSTOSB(void) {
// 766 putbyte(16_f3); ! rep
PUTBYTE(243);
// 767 putbyte(16_aa); ! stosb
PUTBYTE(170);
// 768
// 769 listpreamble;
LISTPREAMBLE();
// 770 printstring("REP STOSB");
_imp_PRINTSTRING(_imp_str_literal("REP STOSB"));
// 771 newline
_imp_NEWLINE();
// 772 flushcode;
FLUSHCODE();
// 773 %end
return;
} /* end of DUMPREPSTOSB */
// 774
// 775 ! unary register operation - DEC, INC, NEG, NOT, POP, PUSH, IDIV, IMUL
// 776 ! REG is an internal ID, not an actual register number
// 777 %routine dumpur(%integer opn, %integer reg)
void DUMPUR(int OPN, int REG) {
// 778 %switch ops(DEC:IMUL)
int OPS_index;
int OPS_line;
char *OPS_file;
static const void *OPS[20] = {&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing};
// 779
// 780 displayhint(reg) = 0;
DISPLAYHINT[REG - 1] = 0;
// 781
// 782 ->ops(opn)
OPS_line = __LINE__;
OPS_file = __FILE__;
OPS_index = OPN;
goto case_OPS_dispatch;
// 783
// 784 ops(DEC):
case_OPS_4:;
// 785 putbyte(16_48 + reg - AX);
PUTBYTE(72 + REG - 1);
// 786 ->break;
goto U_1001;
// 787
// 788 ops(INC):
case_OPS_5:;
// 789 putbyte(16_40 + reg - AX);
PUTBYTE(64 + REG - 1);
// 790 ->break;
goto U_1001;
// 791
// 792 ops(NEG):
case_OPS_6:;
// 793 putbyte(16_F7);
PUTBYTE(247);
// 794 modrmreg(3, reg - AX);
MODRMREG(3, REG - 1);
// 795 ->break;
goto U_1001;
// 796
// 797 ops(NOT):
case_OPS_7:;
// 798 putbyte(16_F7);
PUTBYTE(247);
// 799 modrmreg(2, reg - AX);
MODRMREG(2, REG - 1);
// 800 ->break;
goto U_1001;
// 801
// 802 ops(POP):
case_OPS_8:;
// 803 putbyte(16_58 + reg - AX);
PUTBYTE(88 + REG - 1);
// 804 ->break;
goto U_1001;
// 805
// 806 ops(PUSH):
case_OPS_9:;
// 807 putbyte(16_50 + reg - AX);
PUTBYTE(80 + REG - 1);
// 808 ->break;
goto U_1001;
// 809
// 810 ops(IDIV):
case_OPS_22:;
// 811 putbyte(16_F7);
PUTBYTE(247);
// 812 modrmreg(7, reg - AX);
MODRMREG(7, REG - 1);
// 813 ->break;
goto U_1001;
// 814
// 815 ops(IMUL):
case_OPS_23:;
// 816 putbyte(16_F7);
PUTBYTE(247);
// 817 modrmreg(5, reg - AX);
MODRMREG(5, REG - 1);
// 818
// 819 break:
U_1001:;
// 820 listpreamble;
LISTPREAMBLE();
// 821 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 822 space
_imp_SPACE();
// 823 printstring(regname(reg));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REGNAME[REG - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 824 newline
_imp_NEWLINE();
// 825 flushcode
FLUSHCODE();
// 826
// 827 %end
return;
case_OPS_dispatch:
if (OPS_index < 4 || OPS_index > 23)
_imp_signalf(6, 3, OPS_index, "->OPS(%d) out of bounds at %s line %d", OPS_index, OPS_file, OPS_line);
goto *OPS[OPS_index - 4];
case_OPS_missing:
_imp_signalf(8, 2, OPS_index, "switch jump to undefined label OPS(%d): at %s line %d", OPS_index, OPS_file,
OPS_line);
} /* end of DUMPUR */
// 828
// 829 ! Plant code for a unary operation on memory
// 830 ! BASE is an internal ID, not the actual register number
// 831 %routine dumpum(%integer opn, %integer base, %integer disp)
void DUMPUM(int OPN, int BASE, int DISP) {
// 832 %switch ops(DEC:JMP)
int OPS_index;
int OPS_line;
char *OPS_file;
static const void *OPS[32] = {&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing};
// 833
// 834 ->ops(opn)
OPS_line = __LINE__;
OPS_file = __FILE__;
OPS_index = OPN;
goto case_OPS_dispatch;
// 835
// 836 ops(DEC):
case_OPS_4:;
// 837 putbyte(16_FF);
PUTBYTE(255);
// 838 modrmmem(1, base, disp);
MODRMMEM(1, BASE, DISP);
// 839 ->break;
goto U_1002;
// 840
// 841 ops(INC):
case_OPS_5:;
// 842 putbyte(16_FF);
PUTBYTE(255);
// 843 modrmmem(0, base, disp);
MODRMMEM(0, BASE, DISP);
// 844 ->break;
goto U_1002;
// 845
// 846 ops(NEG):
case_OPS_6:;
// 847 putbyte(16_F7);
PUTBYTE(247);
// 848 modrmmem(3, base, disp);
MODRMMEM(3, BASE, DISP);
// 849 ->break;
goto U_1002;
// 850
// 851 ops(NOT):
case_OPS_7:;
// 852 putbyte(16_F7);
PUTBYTE(247);
// 853 modrmmem(2, base, disp);
MODRMMEM(2, BASE, DISP);
// 854 ->break;
goto U_1002;
// 855
// 856 ops(POP):
case_OPS_8:;
// 857 putbyte(16_8F);
PUTBYTE(143);
// 858 modrmmem(0, base, disp);
MODRMMEM(0, BASE, DISP);
// 859 ->break;
goto U_1002;
// 860
// 861 ops(PUSH):
case_OPS_9:;
// 862 putbyte(16_FF);
PUTBYTE(255);
// 863 modrmmem(6, base, disp);
MODRMMEM(6, BASE, DISP);
// 864 ->break;
goto U_1002;
// 865
// 866 ops(IDIV):
case_OPS_22:;
// 867 putbyte(16_F7);
PUTBYTE(247);
// 868 modrmmem(7, base, disp);
MODRMMEM(7, BASE, DISP);
// 869 ->break;
goto U_1002;
// 870
// 871 ops(IMUL):
case_OPS_23:;
// 872 putbyte(16_F7);
PUTBYTE(247);
// 873 modrmmem(5, base, disp);
MODRMMEM(5, BASE, DISP);
// 874 ->break;
goto U_1002;
// 875
// 876 ops(JMP):
case_OPS_35:;
// 877 putbyte(16_FF);
PUTBYTE(255);
// 878 modrmmem(4, base, disp);
MODRMMEM(4, BASE, DISP);
// 879
// 880 ops(CALL):
case_OPS_24:;
// 881 putbyte(16_FF);
PUTBYTE(255);
// 882 modrmmem(2, base, disp);
MODRMMEM(2, BASE, DISP);
// 883
// 884 break:
U_1002:;
// 885 listpreamble;
LISTPREAMBLE();
// 886 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 887 printstring(" WORD "); ! otherwise it's ambiguous for the reader
_imp_PRINTSTRING(_imp_str_literal(" WORD "));
// 888 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 889 newline
_imp_NEWLINE();
// 890 flushcode;
FLUSHCODE();
// 891 %end
return;
case_OPS_dispatch:
if (OPS_index < 4 || OPS_index > 35)
_imp_signalf(6, 3, OPS_index, "->OPS(%d) out of bounds at %s line %d", OPS_index, OPS_file, OPS_line);
goto *OPS[OPS_index - 4];
case_OPS_missing:
_imp_signalf(8, 2, OPS_index, "switch jump to undefined label OPS(%d): at %s line %d", OPS_index, OPS_file,
OPS_line);
} /* end of DUMPUM */
// 892
// 893 ! Plant code for a unary operation on an 8 bit memory location
// 894 ! Not all of the possible unary ops make sense as 8 bit destinations
// 895 ! BASE is an internal ID, not the actual register number
// 896 %routine dumpum8(%integer opn, %integer base, %integer disp)
void DUMPUM8(int OPN, int BASE, int DISP) {
// 897 %integer base op, index
int BASEOP;
int INDEX;
// 898
// 899 %if opn = DEC %or opn = INC %start
if (OPN == 4) goto L_0010;
if (OPN != 5) goto L_0031;
L_0010:;
// 900 base op = 16_FE
BASEOP = 254;
// 901 %if opn = DEC %then index = 1 %else index = 0
if (OPN != 4) goto L_0032;
INDEX = 1;
goto L_0033;
L_0032:;
INDEX = 0;
L_0033:;
// 902 %else
goto L_0034;
L_0031:;
// 903 %if opn = NOT %or opn = NEG %start
if (OPN == 7) goto L_0004;
if (OPN != 6) goto L_0035;
L_0004:;
// 904 base op = 16_F6
BASEOP = 246;
// 905 %if opn = NOT %then index = 2 %else index = 3
if (OPN != 7) goto L_0036;
INDEX = 2;
goto L_0037;
L_0036:;
INDEX = 3;
L_0037:;
// 906 %else
goto L_0038;
L_0035:;
// 907 Abort("Invalid UM8")
ABORT(_imp_str_literal("Invalid UM8"));
// 908 %finish
L_0038:;
// 909 %finish
L_0034:;
// 910
// 911 putbyte(base op)
PUTBYTE(BASEOP);
// 912 modrmmem(index, base, disp)
MODRMMEM(INDEX, BASE, DISP);
// 913
// 914 listpreamble;
LISTPREAMBLE();
// 915 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 916 printstring(" BYTE "); ! otherwise it's ambiguous for the reader
_imp_PRINTSTRING(_imp_str_literal(" BYTE "));
// 917 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 918 newline
_imp_NEWLINE();
// 919 flushcode;
FLUSHCODE();
// 920 %end
return;
} /* end of DUMPUM8 */
// 921
// 922 ! Plant a Memory <- Reg operation
// 923 ! Both BASE and REG are internal ID's, not actual register numbers
// 924 %routine dumpmr(%integer opn, %integer base, %integer disp, %integer reg)
void DUMPMR(int OPN, int BASE, int DISP, int REG) {
// 925
// 926 %if opn = SHL %start; ! special "shift by CL"
if (OPN != 20) goto L_0039;
// 927 putbyte(16_D3);
PUTBYTE(211);
// 928 modrmmem(4, base, disp);
MODRMMEM(4, BASE, DISP);
// 929 %else
goto L_003A;
L_0039:;
// 930 %if opn = SHR %start
if (OPN != 21) goto L_003B;
// 931 putbyte(16_D3);
PUTBYTE(211);
// 932 modrmmem(5, base, disp);
MODRMMEM(5, BASE, DISP);
// 933 %else; ! normal stuff
goto L_003C;
L_003B:;
// 934 putbyte(opvalue(opn));
PUTBYTE(OPVALUE[OPN]);
// 935 modrmmem(reg - AX, base, disp);
MODRMMEM(REG - 1, BASE, DISP);
// 936 %finish
L_003C:;
// 937 %finish
L_003A:;
// 938
// 939 listpreamble;
LISTPREAMBLE();
// 940 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 941 space
_imp_SPACE();
// 942 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 943 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 944 printstring(regname(reg));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REGNAME[REG - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 945 newline
_imp_NEWLINE();
// 946 flushcode;
FLUSHCODE();
// 947 %end
return;
} /* end of DUMPMR */
// 948
// 949 ! Plant an 8 bit Memory <- Reg operation
// 950 ! Both BASE and REG are internal ID's, not actual register numbers
// 951 %routine dumpmr8(%integer opn, %integer base, %integer disp, %integer reg)
void DUMPMR8(int OPN, int BASE, int DISP, int REG) {
// 952
// 953 %if opn = SHL %start; ! special "shift by CL"
if (OPN != 20) goto L_003D;
// 954 putbyte(16_D2);
PUTBYTE(210);
// 955 modrmmem(4, base, disp);
MODRMMEM(4, BASE, DISP);
// 956 %else
goto L_003E;
L_003D:;
// 957 %if opn = SHR %start
if (OPN != 21) goto L_003F;
// 958 putbyte(16_D2);
PUTBYTE(210);
// 959 modrmmem(5, base, disp);
MODRMMEM(5, BASE, DISP);
// 960 %else; ! normal stuff
goto L_0040;
L_003F:;
// 961 putbyte(op8value(opn));
PUTBYTE(OP8VALUE[OPN]);
// 962 modrmmem(reg - AL, base, disp);
MODRMMEM(REG - 17, BASE, DISP);
// 963 %finish
L_0040:;
// 964 %finish
L_003E:;
// 965
// 966 listpreamble;
LISTPREAMBLE();
// 967 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 968 space
_imp_SPACE();
// 969 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 970 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 971 printstring(reg8name(reg));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REG8NAME[REG - 17] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 972 newline
_imp_NEWLINE();
// 973 flushcode;
FLUSHCODE();
// 974 %end
return;
} /* end of DUMPMR8 */
// 975
// 976 ! Plant a 16 bit Reg <- Memory operation
// 977 ! Both BASE and REG are internal ID's, not actual register numbers
// 978 %routine dumprm(%integer opn, %integer reg, %integer base, %integer disp)
void DUMPRM(int OPN, int REG, int BASE, int DISP) {
// 979
// 980 ! We optimise the fairly common instruction MOV AX,[disp] with
// 981 ! the special short-form quirk of the 8086...
// 982
// 983 %if reg = AX %and opn = MOV %and base & 15 = 0 %start
if (REG != 1) goto L_0041;
if (OPN != 11) goto L_0041;
if (BASE & 15 != 0) goto L_0041;
// 984 putbyte(16_A1)
PUTBYTE(161);
// 985 relocateoffset(base>>4, disp)
RELOCATEOFFSET((unsigned int)BASE >> 4, DISP);
// 986 %else
goto L_0042;
L_0041:;
// 987 displayhint(reg) = 0;
DISPLAYHINT[REG - 1] = 0;
// 988
// 989 putbyte(opvalue(opn)+2);
PUTBYTE(OPVALUE[OPN] + 2);
// 990 modrmmem(reg - AX, base, disp);
MODRMMEM(REG - 1, BASE, DISP);
// 991 %finish
L_0042:;
// 992
// 993 listpreamble;
LISTPREAMBLE();
// 994 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 995 space
_imp_SPACE();
// 996 printstring(regname(reg));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REGNAME[REG - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 997 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 998 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 999 newline
_imp_NEWLINE();
// 1000 flushcode;
FLUSHCODE();
// 1001 %end
return;
} /* end of DUMPRM */
// 1002
// 1003 ! Plant an 8 bit Reg <- Memory operation
// 1004 ! Both BASE and REG are internal ID's, not actual register numbers
// 1005 %routine dumprm8(%integer opn, %integer reg, %integer base, %integer disp)
void DUMPRM8(int OPN, int REG, int BASE, int DISP) {
// 1006
// 1007 putbyte(op8value(opn)+2);
PUTBYTE(OP8VALUE[OPN] + 2);
// 1008 modrmmem(reg - AL, base, disp);
MODRMMEM(REG - 17, BASE, DISP);
// 1009
// 1010 listpreamble;
LISTPREAMBLE();
// 1011 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1012 space
_imp_SPACE();
// 1013 printstring(reg8name(reg));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REG8NAME[REG - 17] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1014 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 1015 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 1016 newline
_imp_NEWLINE();
// 1017 flushcode;
FLUSHCODE();
// 1018 %end
return;
} /* end of DUMPRM8 */
// 1019
// 1020 ! Plant a 16 bit Reg <- Reg operation
// 1021 ! Both register parameters are internal ID's
// 1022 %routine dumprr(%integer opn, %integer reg1, %integer reg2)
void DUMPRR(int OPN, int REG1, int REG2) {
// 1023
// 1024 displayhint(reg1) = 0;
DISPLAYHINT[REG1 - 1] = 0;
// 1025
// 1026 %if opn = SHL %start; ! special "shift by CL"
if (OPN != 20) goto L_0043;
// 1027 putbyte(16_D3);
PUTBYTE(211);
// 1028 modrmreg(4, reg1 - AX);
MODRMREG(4, REG1 - 1);
// 1029 %else
goto L_0044;
L_0043:;
// 1030 %if opn = SHR %start
if (OPN != 21) goto L_0045;
// 1031 putbyte(16_D3);
PUTBYTE(211);
// 1032 modrmreg(5, reg1 - AX);
MODRMREG(5, REG1 - 1);
// 1033 %else; ! normal stuff
goto L_0046;
L_0045:;
// 1034 putbyte(opvalue(opn));
PUTBYTE(OPVALUE[OPN]);
// 1035 modrmreg(reg2 - AX, reg1 - AX);
MODRMREG(REG2 - 1, REG1 - 1);
// 1036 %finish
L_0046:;
// 1037 %finish
L_0044:;
// 1038
// 1039 listpreamble;
LISTPREAMBLE();
// 1040 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1041 space
_imp_SPACE();
// 1042 printstring(regname(reg1));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REGNAME[REG1 - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1043 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 1044 printstring(regname(reg2));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REGNAME[REG2 - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1045 newline
_imp_NEWLINE();
// 1046 flushcode;
FLUSHCODE();
// 1047 %end
return;
} /* end of DUMPRR */
// 1048
// 1049 %routine dumprr8(%integer opn, %integer reg1, %integer reg2)
void DUMPRR8(int OPN, int REG1, int REG2) {
// 1050
// 1051 %if opn = SHL %start; ! special "shift by CL"
if (OPN != 20) goto L_0047;
// 1052 putbyte(16_D2);
PUTBYTE(210);
// 1053 modrmreg(4, reg1 - AL);
MODRMREG(4, REG1 - 17);
// 1054 %else
goto L_0048;
L_0047:;
// 1055 %if opn = SHR %start
if (OPN != 21) goto L_0049;
// 1056 putbyte(16_D2);
PUTBYTE(210);
// 1057 modrmreg(5, reg1 - AL);
MODRMREG(5, REG1 - 17);
// 1058 %else
goto L_004A;
L_0049:;
// 1059 putbyte(op8value(opn));
PUTBYTE(OP8VALUE[OPN]);
// 1060 modrmreg(reg2 - AL, reg1 - AL);
MODRMREG(REG2 - 17, REG1 - 17);
// 1061 %finish
L_004A:;
// 1062 %finish
L_0048:;
// 1063
// 1064 listpreamble;
LISTPREAMBLE();
// 1065 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1066 space
_imp_SPACE();
// 1067 printstring(reg8name(reg1));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REG8NAME[REG1 - 17] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1068 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 1069 printstring(reg8name(reg2));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REG8NAME[REG2 - 17] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1070 newline
_imp_NEWLINE();
// 1071 flushcode;
FLUSHCODE();
// 1072 %end
return;
} /* end of DUMPRR8 */
// 1073
// 1074 %const %byte %integer %array aximmediatevalue(NOP:XOR) =
const unsigned char AXIMMEDIATEVALUE[20] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 184, 0, 21, 5, 37, 61, 13, 45, 53};
// 1075+ 0, 0, 0, 0,
// 1076+ 0, 0, 0, 0,
// 1077+ 0, 0,
// 1078+ 0, 16_B8, 0,
// 1079+ 16_15, 16_05, 16_25, 16_3D, 16_0D, 16_2D, 16_35
// 1080
// 1081 ! Register immediate operations - can be MOV, Math, or Shift
// 1082 ! The immediate operand may be a relocated offset as part of
// 1083 ! an address calculation
// 1084 %routine dumprioffset(%integer opn, %integer reg, %integer reloc, %integer immed)
void DUMPRIOFFSET(int OPN, int REG, int RELOC, int IMMED) {
// 1085 %integer subop;
int SUBOP;
// 1086 %switch ops(MOV:SHR)
int OPS_index;
int OPS_line;
char *OPS_file;
static const void *OPS[11] = {&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing};
// 1087
// 1088 displayhint(reg) = 0;
DISPLAYHINT[REG - 1] = 0;
// 1089 reloc = reloc >> 4; ! because we pass around the or-able version
RELOC = (unsigned int)RELOC >> 4;
// 1090
// 1091 %if reg = AX %and opn <= XOR %start
if (REG != 1) goto L_004B;
if (OPN > 19) goto L_004B;
// 1092 putbyte(aximmediatevalue(opn));
PUTBYTE(AXIMMEDIATEVALUE[OPN]);
// 1093 relocateoffset(reloc, immed);
RELOCATEOFFSET(RELOC, IMMED);
// 1094 ->break
goto U_1003;
// 1095 %else
L_004B:;
// 1096 ->ops(opn)
OPS_line = __LINE__;
OPS_file = __FILE__;
OPS_index = OPN;
goto case_OPS_dispatch;
// 1097 %finish
// 1098
// 1099 ops(MOV):
case_OPS_11:;
// 1100 putbyte(16_B8 + reg - AX);
PUTBYTE(184 + REG - 1);
// 1101 relocateoffset(reloc, immed);
RELOCATEOFFSET(RELOC, IMMED);
// 1102 ->break;
goto U_1003;
// 1103
// 1104 ops(ADD): subop = 0; ->addsub
case_OPS_14:;
SUBOP = 0;
goto U_1004;
// 1105 ops(ADC): subop = 2; ->addsub
case_OPS_13:;
SUBOP = 2;
goto U_1004;
// 1106 ops(CMP): subop = 7; ->addsub
case_OPS_16:;
SUBOP = 7;
goto U_1004;
// 1107 ops(SUB): subop = 5
case_OPS_18:;
SUBOP = 5;
// 1108 addsub:
U_1004:;
// 1109 %if issmall(immed) # 0 %and reloc = 0 %start
if (ISSMALL(IMMED) == 0) goto L_004D;
if (RELOC != 0) goto L_004D;
// 1110 putbyte(16_83);
PUTBYTE(131);
// 1111 modrmreg(subop, reg - AX);
MODRMREG(SUBOP, REG - 1);
// 1112 putbyte(immed & 255);
PUTBYTE(IMMED & 255);
// 1113 %else
goto L_004E;
L_004D:;
// 1114 putbyte(16_81);
PUTBYTE(129);
// 1115 modrmreg(subop, reg - AX);
MODRMREG(SUBOP, REG - 1);
// 1116 relocateoffset(reloc, immed);
RELOCATEOFFSET(RELOC, IMMED);
// 1117 %finish
L_004E:;
// 1118 ->break;
goto U_1003;
// 1119
// 1120 ops(AND): subop = 4; ->logical
case_OPS_15:;
SUBOP = 4;
goto U_1005;
// 1121 ops(OR): subop = 1; ->logical
case_OPS_17:;
SUBOP = 1;
goto U_1005;
// 1122 ops(XOR): subop = 6
case_OPS_19:;
SUBOP = 6;
// 1123 logical:
U_1005:;
// 1124 putbyte(16_81);
PUTBYTE(129);
// 1125 modrmreg(subop, reg - AX);
MODRMREG(SUBOP, REG - 1);
// 1126 relocateoffset(reloc, immed);
RELOCATEOFFSET(RELOC, IMMED);
// 1127 ->break;
goto U_1003;
// 1128
// 1129 ops(SHL):
case_OPS_20:;
// 1130 putbyte(16_D1);
PUTBYTE(209);
// 1131 modrmreg(4, reg - AX);
MODRMREG(4, REG - 1);
// 1132 ->break;
goto U_1003;
// 1133
// 1134 ops(SHR):
case_OPS_21:;
// 1135 putbyte(16_D1);
PUTBYTE(209);
// 1136 modrmreg(5, reg - AX);
MODRMREG(5, REG - 1);
// 1137
// 1138 break:
U_1003:;
// 1139 listpreamble;
LISTPREAMBLE();
// 1140 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1141 space
_imp_SPACE();
// 1142 printstring(regname(reg));
_imp_PRINTSTRING(
*({
__typeof__(_imp_string2) tmp = REGNAME[REG - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1143 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 1144 %if reloc # 0 %start
if (RELOC == 0) goto L_004F;
// 1145 printstring(relocname(reloc)); printsymbol('+')
_imp_PRINTSTRING(
*({
__typeof__(_imp_string7) tmp = RELOCNAME[RELOC] /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_PRINTSYMBOL(43);
// 1146 %finish
L_004F:;
// 1147 write(immed, 1)
_imp_WRITE(IMMED, 1);
// 1148 newline
_imp_NEWLINE();
// 1149 flushcode;
FLUSHCODE();
// 1150 %end
return;
case_OPS_dispatch:
if (OPS_index < 11 || OPS_index > 21)
_imp_signalf(6, 3, OPS_index, "->OPS(%d) out of bounds at %s line %d", OPS_index, OPS_file, OPS_line);
goto *OPS[OPS_index - 11];
case_OPS_missing:
_imp_signalf(8, 2, OPS_index, "switch jump to undefined label OPS(%d): at %s line %d", OPS_index, OPS_file,
OPS_line);
} /* end of DUMPRIOFFSET */
// 1151
// 1152 ! Since many math operations don't involve relocated addresses
// 1153 ! we provide a chep version of dumprioffset
// 1154 %routine dumpri(%integer opn, %integer reg, %integer immed)
void DUMPRI(int OPN, int REG, int IMMED) {
// 1155 dumprioffset(opn, reg, 0, immed)
DUMPRIOFFSET(OPN, REG, 0, IMMED);
// 1156 %end
return;
} /* end of DUMPRI */
// 1157
// 1158 ! Memory (16 bit) immediate operations - can be MOV, Math, or Shift
// 1159 %routine dumpmi(%integer opn, %integer base, disp, %integer immed)
void DUMPMI(int OPN, int BASE, int DISP, int IMMED) {
// 1160 %integer subop;
int SUBOP;
// 1161 %switch ops(MOV:SHR)
int OPS_index;
int OPS_line;
char *OPS_file;
static const void *OPS[11] = {&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing};
// 1162
// 1163 ->ops(opn)
OPS_line = __LINE__;
OPS_file = __FILE__;
OPS_index = OPN;
goto case_OPS_dispatch;
// 1164
// 1165 ops(MOV):
case_OPS_11:;
// 1166 putbyte(16_C7)
PUTBYTE(199);
// 1167 modrmmem(0, base, disp)
MODRMMEM(0, BASE, DISP);
// 1168 putbyte(immed & 255)
PUTBYTE(IMMED & 255);
// 1169 putbyte(immed >> 8)
PUTBYTE((unsigned int)IMMED >> 8);
// 1170 ->break;
goto U_1005;
// 1171
// 1172 ops(ADD): subop = 0; ->addsub
case_OPS_14:;
SUBOP = 0;
goto U_1006;
// 1173 ops(ADC): subop = 2; ->addsub
case_OPS_13:;
SUBOP = 2;
goto U_1006;
// 1174 ops(CMP): subop = 7; ->addsub
case_OPS_16:;
SUBOP = 7;
goto U_1006;
// 1175 ops(SUB): subop = 5
case_OPS_18:;
SUBOP = 5;
// 1176 addsub:
U_1006:;
// 1177 %if issmall(immed) # 0 %start
if (ISSMALL(IMMED) == 0) goto L_0051;
// 1178 putbyte(16_83);
PUTBYTE(131);
// 1179 modrmmem(subop, base, disp)
MODRMMEM(SUBOP, BASE, DISP);
// 1180 putbyte(immed & 255);
PUTBYTE(IMMED & 255);
// 1181 %else
goto L_0052;
L_0051:;
// 1182 putbyte(16_81);
PUTBYTE(129);
// 1183 modrmmem(subop, base, disp)
MODRMMEM(SUBOP, BASE, DISP);
// 1184 putbyte(immed & 255);
PUTBYTE(IMMED & 255);
// 1185 putbyte(immed >> 8);
PUTBYTE((unsigned int)IMMED >> 8);
// 1186 %finish
L_0052:;
// 1187 ->break;
goto U_1005;
// 1188
// 1189 ops(AND): subop = 4; ->logical
case_OPS_15:;
SUBOP = 4;
goto U_1007;
// 1190 ops(OR): subop = 1; ->logical
case_OPS_17:;
SUBOP = 1;
goto U_1007;
// 1191 ops(XOR): subop = 6
case_OPS_19:;
SUBOP = 6;
// 1192 logical:
U_1007:;
// 1193 putbyte(16_81);
PUTBYTE(129);
// 1194 modrmmem(subop, base, disp)
MODRMMEM(SUBOP, BASE, DISP);
// 1195 putbyte(immed & 255);
PUTBYTE(IMMED & 255);
// 1196 putbyte(immed >> 8);
PUTBYTE((unsigned int)IMMED >> 8);
// 1197 ->break;
goto U_1005;
// 1198
// 1199 ops(SHL):
case_OPS_20:;
// 1200 putbyte(16_D1);
PUTBYTE(209);
// 1201 modrmmem(4, base, disp)
MODRMMEM(4, BASE, DISP);
// 1202 ->break;
goto U_1005;
// 1203
// 1204 ops(SHR):
case_OPS_21:;
// 1205 putbyte(16_D1);
PUTBYTE(209);
// 1206 modrmmem(5, base, disp)
MODRMMEM(5, BASE, DISP);
// 1207
// 1208 break:
U_1005:;
// 1209 listpreamble;
LISTPREAMBLE();
// 1210 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1211 printstring(" WORD "); ! otherwise it's ambiguous for the reader
_imp_PRINTSTRING(_imp_str_literal(" WORD "));
// 1212 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 1213 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 1214 write(immed, 1)
_imp_WRITE(IMMED, 1);
// 1215 newline
_imp_NEWLINE();
// 1216 flushcode;
FLUSHCODE();
// 1217 %end
return;
case_OPS_dispatch:
if (OPS_index < 11 || OPS_index > 21)
_imp_signalf(6, 3, OPS_index, "->OPS(%d) out of bounds at %s line %d", OPS_index, OPS_file, OPS_line);
goto *OPS[OPS_index - 11];
case_OPS_missing:
_imp_signalf(8, 2, OPS_index, "switch jump to undefined label OPS(%d): at %s line %d", OPS_index, OPS_file,
OPS_line);
} /* end of DUMPMI */
// 1218
// 1219 ! Memory (8 bit) immediate operations - can be MOV, Math, or Shift
// 1220 %routine dumpmi8(%integer opn, %integer base, disp, %integer immed)
void DUMPMI8(int OPN, int BASE, int DISP, int IMMED) {
// 1221 %integer subop;
int SUBOP;
// 1222 %switch ops(MOV:SHR)
int OPS_index;
int OPS_line;
char *OPS_file;
static const void *OPS[11] = {&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing,
&&case_OPS_missing, &&case_OPS_missing, &&case_OPS_missing};
// 1223
// 1224 ->ops(opn)
OPS_line = __LINE__;
OPS_file = __FILE__;
OPS_index = OPN;
goto case_OPS_dispatch;
// 1225
// 1226 ops(MOV):
case_OPS_11:;
// 1227 putbyte(16_C6)
PUTBYTE(198);
// 1228 modrmmem(0, base, disp)
MODRMMEM(0, BASE, DISP);
// 1229 putbyte(immed & 255)
PUTBYTE(IMMED & 255);
// 1230 ->break;
goto U_1006;
// 1231
// 1232 ops(ADD): subop = 0; ->op80
case_OPS_14:;
SUBOP = 0;
goto U_1007;
// 1233 ops(ADC): subop = 2; ->op80
case_OPS_13:;
SUBOP = 2;
goto U_1007;
// 1234 ops(CMP): subop = 7; ->op80
case_OPS_16:;
SUBOP = 7;
goto U_1007;
// 1235 ops(SUB): subop = 5; ->op80
case_OPS_18:;
SUBOP = 5;
goto U_1007;
// 1236 ops(AND): subop = 4; ->op80
case_OPS_15:;
SUBOP = 4;
goto U_1007;
// 1237 ops(OR): subop = 1; ->op80
case_OPS_17:;
SUBOP = 1;
goto U_1007;
// 1238 ops(XOR): subop = 6
case_OPS_19:;
SUBOP = 6;
// 1239 op80:
U_1007:;
// 1240 putbyte(16_80);
PUTBYTE(128);
// 1241 modrmmem(subop, base, disp)
MODRMMEM(SUBOP, BASE, DISP);
// 1242 putbyte(immed & 255);
PUTBYTE(IMMED & 255);
// 1243 ->break;
goto U_1006;
// 1244
// 1245 ops(SHL):
case_OPS_20:;
// 1246 putbyte(16_D0);
PUTBYTE(208);
// 1247 modrmmem(4, base, disp)
MODRMMEM(4, BASE, DISP);
// 1248 ->break;
goto U_1006;
// 1249
// 1250 ops(SHR):
case_OPS_21:;
// 1251 putbyte(16_D0);
PUTBYTE(208);
// 1252 modrmmem(5, base, disp)
MODRMMEM(5, BASE, DISP);
// 1253
// 1254 break:
U_1006:;
// 1255 listpreamble;
LISTPREAMBLE();
// 1256 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1257 printstring(" BYTE "); ! otherwise it's ambiguous for the reader
_imp_PRINTSTRING(_imp_str_literal(" BYTE "));
// 1258 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 1259 printsymbol(',')
_imp_PRINTSYMBOL(44);
// 1260 write(immed, 1)
_imp_WRITE(IMMED, 1);
// 1261 newline
_imp_NEWLINE();
// 1262 flushcode;
FLUSHCODE();
// 1263 %end
return;
case_OPS_dispatch:
if (OPS_index < 11 || OPS_index > 21)
_imp_signalf(6, 3, OPS_index, "->OPS(%d) out of bounds at %s line %d", OPS_index, OPS_file, OPS_line);
goto *OPS[OPS_index - 11];
case_OPS_missing:
_imp_signalf(8, 2, OPS_index, "switch jump to undefined label OPS(%d): at %s line %d", OPS_index, OPS_file,
OPS_line);
} /* end of DUMPMI8 */
// 1264
// 1265 ! Finally, a catch-all that recasts operations using generic
// 1266 ! Var Stack structures
// 1267 ! Plant a 16 bit Reg <- Var operation
// 1268 %routine dumprv(%integer opn, %integer reg, %record(stackfm)%name v)
void DUMPRV(int OPN, int REG, struct STACKFM *V) {
// 1269
// 1270 %if v_form = V in R %start
if (V->FORM != 1) goto L_0054;
// 1271 dumprr(opn, reg, v_base)
DUMPRR(OPN, REG, V->BASE);
// 1272 %else
goto L_0055;
L_0054:;
// 1273 %if v_form = V in S %start
if (V->FORM != 4) goto L_0056;
// 1274 dumprm(opn, reg, v_base!v_scope, v_disp)
DUMPRM(OPN, REG, V->BASE | V->SCOPE, V->DISP);
// 1275 %else
goto L_0057;
L_0056:;
// 1276 %if v_form = constant %start
if (V->FORM != 0) goto L_0058;
// 1277 dumprioffset(opn, reg, v_scope, v_disp)
DUMPRIOFFSET(OPN, REG, V->SCOPE, V->DISP);
// 1278 %else
goto L_0059;
L_0058:;
// 1279 abort("Address Mode")
ABORT(_imp_str_literal("Address Mode"));
// 1280 %finish
L_0059:;
// 1281 %finish
L_0057:;
// 1282 %finish
L_0055:;
// 1283 %end
return;
} /* end of DUMPRV */
// 1284
// 1285 ! Another special dumper - the only "Unary" operation that
// 1286 ! takes an immediate operand is PUSH
// 1287 %routine dumppushi(%integer reloc, %integer immed)
void DUMPPUSHI(int RELOC, int IMMED) {
// 1288
// 1289 reloc = reloc >> 4; ! because we pass around the or-able version
RELOC = (unsigned int)RELOC >> 4;
// 1290
// 1291 %if reloc = 0 %and is small(immed) # 0 %start
if (RELOC != 0) goto L_005A;
if (ISSMALL(IMMED) == 0) goto L_005A;
// 1292 putbyte(16_6A);
PUTBYTE(106);
// 1293 putbyte(immed & 255);
PUTBYTE(IMMED & 255);
// 1294 %else
goto L_005B;
L_005A:;
// 1295 putbyte(16_68);
PUTBYTE(104);
// 1296 relocateoffset(reloc, immed);
RELOCATEOFFSET(RELOC, IMMED);
// 1297 %finish
L_005B:;
// 1298
// 1299 listpreamble;
LISTPREAMBLE();
// 1300 printstring("PUSH")
_imp_PRINTSTRING(_imp_str_literal("PUSH"));
// 1301 space
_imp_SPACE();
// 1302 %if reloc # 0 %start
if (RELOC == 0) goto L_005C;
// 1303 printstring(relocname(reloc)); printsymbol('+')
_imp_PRINTSTRING(
*({
__typeof__(_imp_string7) tmp = RELOCNAME[RELOC] /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_PRINTSYMBOL(43);
// 1304 %finish
L_005C:;
// 1305 write(immed, 1)
_imp_WRITE(IMMED, 1);
// 1306 newline
_imp_NEWLINE();
// 1307 flushcode
FLUSHCODE();
// 1308 %end
return;
} /* end of DUMPPUSHI */
// 1309
// 1310 %routine dumpvpush(%record(stackfm)%name v)
void DUMPVPUSH(struct STACKFM * V) {
// 1311
// 1312 %if v_form = V in R %start
if (V->FORM != 1) goto L_005D;
// 1313 dumpur(PUSH, v_base)
DUMPUR(9, V->BASE);
// 1314 %else
goto L_005E;
L_005D:;
// 1315 %if v_form = V in S %start
if (V->FORM != 4) goto L_005F;
// 1316 dumpum(PUSH, v_base!v_scope, v_disp)
DUMPUM(9, V->BASE | V->SCOPE, V->DISP);
// 1317 %else
goto L_0060;
L_005F:;
// 1318 %if v_form = constant %start
if (V->FORM != 0) goto L_0061;
// 1319 dumppushi(v_scope, v_disp)
DUMPPUSHI(V->SCOPE, V->DISP);
// 1320 %else
goto L_0062;
L_0061:;
// 1321 abort("Push Mode")
ABORT(_imp_str_literal("Push Mode"));
// 1322 %finish
L_0062:;
// 1323 %finish
L_0060:;
// 1324 %finish
L_005E:;
// 1325 %end
return;
} /* end of DUMPVPUSH */
// 1326
// 1327 !----------------------------------------------------------
// 1328 ! Floating point instructions - much simpler since there are
// 1329 ! only two forms - RR and RM
// 1330
// 1331 %conststring(10)%array flopname(FILD:FLDPI) =
const _imp_string10 FLOPNAME[18] = {
_imp_str_init("FILD"), _imp_str_init("FLD DWORD"), _imp_str_init("FLD QWORD"), _imp_str_init("FISTP"),
_imp_str_init("FSTP DWORD"), _imp_str_init("FSTP QWORD"), _imp_str_init("FADDP"), _imp_str_init("FSUBP"),
_imp_str_init("FSUBRP"), _imp_str_init("FMULP"), _imp_str_init("FDIVP"), _imp_str_init("FDIVRP"),
_imp_str_init("FCOMPP"), _imp_str_init("FCHS"), _imp_str_init("FABS"), _imp_str_init("FSTSW AX"),
_imp_str_init("FLDZ"), _imp_str_init("FLDPI")};
// 1332+ "FILD", "FLD DWORD", "FLD QWORD", "FISTP",
// 1333+ "FSTP DWORD", "FSTP QWORD", "FADDP", "FSUBP",
// 1334+ "FSUBRP", "FMULP", "FDIVP", "FDIVRP",
// 1335+ "FCOMPP", "FCHS", "FABS",
// 1336+ "FSTSW AX", "FLDZ", "FLDPI"
// 1337
// 1338 ! The prefix opcode
// 1339 %constbyteintegerarray flprefix(FILD:FLDPI) =
const unsigned char FLPREFIX[18] = {223, 217, 221, 223, 217, 221, 222, 222, 222,
222, 222, 222, 222, 217, 217, 223, 217, 217};
// 1340+ 16_DF, 16_D9, 16_DD, 16_DF,
// 1341+ 16_D9, 16_DD, 16_DE, 16_DE,
// 1342+ 16_DE, 16_DE, 16_DE, 16_DE,
// 1343+ 16_DE, 16_D9, 16_D9,
// 1344+ 16_DF, 16_D9, 16_D9
// 1345
// 1346 ! The function selector to put in the field in the second byte
// 1347 ! (or the second byte)
// 1348 %constbyteintegerarray flindex(FILD:FLDPI) =
const unsigned char FLINDEX[18] = {0, 0, 0, 3, 3, 3, 192, 232, 224, 200, 248, 240, 216, 224, 225, 224, 238, 235};
// 1349+ 16_00, 16_00, 16_00, 16_03,
// 1350+ 16_03, 16_03, 16_C0, 16_E8,
// 1351+ 16_E0, 16_C8, 16_F8, 16_F0,
// 1352+ 16_D8, 16_E0, 16_E1,
// 1353+ 16_E0, 16_EE, 16_EB
// 1354
// 1355 ! Plant a Floating Point Reg <- Memory operation
// 1356 ! BASE is an internal ID, not actual register number
// 1357 ! Destination regsiter is implicitly the stack top
// 1358 %routine dumpfloprm(%integer opn, %integer base, %integer disp)
void DUMPFLOPRM(int OPN, int BASE, int DISP) {
// 1359
// 1360 %if opn <= FLDQ %start; ! a load type
if (OPN > 38) goto L_0063;
// 1361 fpu stack = fpu stack + 1
FPUSTACK = FPUSTACK + 1;
// 1362 %if fpu stack > 8 %then abort("FPU Stack Overflow")
if (FPUSTACK <= 8) goto L_0064;
ABORT(_imp_str_literal("FPU Stack Overflow"));
L_0064:;
// 1363 %else
goto L_0065;
L_0063:;
// 1364 fpu stack = fpu stack - 1
FPUSTACK = FPUSTACK - 1;
// 1365 %if fpu stack < 0 %then abort("FPU Stack Underflow")
if (FPUSTACK >= 0) goto L_0066;
ABORT(_imp_str_literal("FPU Stack Underflow"));
L_0066:;
// 1366 %finish
L_0065:;
// 1367
// 1368 putbyte(16_9B); ! we prepend a WAIT to everything
PUTBYTE(155);
// 1369 putbyte(flprefix(opn));
PUTBYTE(FLPREFIX[OPN - 36]);
// 1370 modrmmem(flindex(opn), base, disp);
MODRMMEM(FLINDEX[OPN - 36], BASE, DISP);
// 1371
// 1372 listpreamble;
LISTPREAMBLE();
// 1373 printstring(flopname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string10) tmp = FLOPNAME[OPN - 36] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1374 space
_imp_SPACE();
// 1375 printmemref(base, disp);
PRINTMEMREF(BASE, DISP);
// 1376 newline
_imp_NEWLINE();
// 1377 flushcode;
FLUSHCODE();
// 1378 %end
return;
} /* end of DUMPFLOPRM */
// 1379
// 1380 ! Plant a Floating Point Reg <- Reg operation
// 1381 ! Both register parameters are internal ID's that we
// 1382 ! convert to stack offsets
// 1383 %routine dumpfloprr(%integer opn, %integer reg1, %integer reg2)
void DUMPFLOPRR(int OPN, int REG1, int REG2) {
// 1384 %integer top
int TOP;
// 1385
// 1386 top = fpustack + (FR0 - 1)
TOP = FPUSTACK + (9 - 1);
// 1387
// 1388 %if reg2 # top %then abort("FPU Stack Address")
if (REG2 == TOP) goto L_0067;
ABORT(_imp_str_literal("FPU Stack Address"));
L_0067:;
// 1389
// 1390 %if opn < FCHS %start; ! two operands - will pop one
if (OPN >= 49) goto L_0068;
// 1391 fpu stack = fpu stack - 1
FPUSTACK = FPUSTACK - 1;
// 1392 %if opn = FCMP %then fpu stack = fpu stack - 1; ! COMPP pops both registers
if (OPN != 48) goto L_0069;
FPUSTACK = FPUSTACK - 1;
L_0069:;
// 1393 %if fpu stack < 0 %then abort("FPU Stack Underflow")
if (FPUSTACK >= 0) goto L_006A;
ABORT(_imp_str_literal("FPU Stack Underflow"));
L_006A:;
// 1394 %finish
L_0068:;
// 1395
// 1396 putbyte(16_9B); ! we prepend a WAIT to everything
PUTBYTE(155);
// 1397 putbyte(flprefix(opn));
PUTBYTE(FLPREFIX[OPN - 36]);
// 1398 putbyte(flindex(opn)!(top - reg1))
PUTBYTE(FLINDEX[OPN - 36] | TOP - REG1);
// 1399
// 1400 listpreamble;
LISTPREAMBLE();
// 1401 printstring(flopname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string10) tmp = FLOPNAME[OPN - 36] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1402 space
_imp_SPACE();
// 1403 printstring("ST(");
_imp_PRINTSTRING(_imp_str_literal("ST("));
// 1404 write(top-reg1, 1)
_imp_WRITE(TOP - REG1, 1);
// 1405 printstring("),ST")
_imp_PRINTSTRING(_imp_str_literal("),ST"));
// 1406 newline
_imp_NEWLINE();
// 1407 flushcode;
FLUSHCODE();
// 1408 %end
return;
} /* end of DUMPFLOPRR */
// 1409
// 1410 ! Plant a "special" floating point operation
// 1411 %routine dumpflopspec(%integer opn)
void DUMPFLOPSPEC(int OPN) {
// 1412
// 1413 %if opn >= FLDZ %start; ! load a constant
if (OPN < 52) goto L_006B;
// 1414 fpu stack = fpu stack + 1
FPUSTACK = FPUSTACK + 1;
// 1415 %if fpu stack > 8 %then abort("FPU Stack Overflow")
if (FPUSTACK <= 8) goto L_006C;
ABORT(_imp_str_literal("FPU Stack Overflow"));
L_006C:;
// 1416 %finish
L_006B:;
// 1417
// 1418 putbyte(16_9B); ! we prepend a WAIT to everything
PUTBYTE(155);
// 1419 putbyte(flprefix(opn));
PUTBYTE(FLPREFIX[OPN - 36]);
// 1420 putbyte(flindex(opn))
PUTBYTE(FLINDEX[OPN - 36]);
// 1421
// 1422 listpreamble
LISTPREAMBLE();
// 1423 printstring(flopname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string10) tmp = FLOPNAME[OPN - 36] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1424 newline
_imp_NEWLINE();
// 1425 flushcode
FLUSHCODE();
// 1426 %end
return;
} /* end of DUMPFLOPSPEC */
// 1427
// 1428 %routine dumpjump(%integer opn, %integer labelid)
void DUMPJUMP(int OPN, int LABELID) {
// 1429 %integer jtype, count;
int JTYPE;
int COUNT;
// 1430
// 1431 ! we put conventional assembler into the pipe for the listing
// 1432 ! (with a zero jump offset) but then re-use the pipe for the
// 1433 ! pseudo-code for the jump
// 1434 putbyte(opvalue(opn));
PUTBYTE(OPVALUE[OPN]);
// 1435 putbyte(0);
PUTBYTE(0);
// 1436 %if opn = CALL %then putbyte(0);
if (OPN != 24) goto L_006D;
PUTBYTE(0);
L_006D:;
// 1437
// 1438 listpreamble;
LISTPREAMBLE();
// 1439 printstring(opname(opn))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPN] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1440 space
_imp_SPACE();
// 1441 printsymbol('L');
_imp_PRINTSYMBOL(76);
// 1442 write(labelid,1)
_imp_WRITE(LABELID, 1);
// 1443 newline
_imp_NEWLINE();
// 1444
// 1445 objectptr = 0; ! zap the current contents of the pipe
OBJECTPTR = 0;
// 1446 count = 0;
COUNT = 0;
// 1447 %if opn = JMP %start
if (OPN != 35) goto L_006E;
// 1448 jtype = IF JUMP;
JTYPE = 4;
// 1449 %else
goto L_006F;
L_006E:;
// 1450 %if opn = CALL %start
if (OPN != 24) goto L_0070;
// 1451 jtype = IF CALL;
JTYPE = 6;
// 1452 %else
goto L_0071;
L_0070:;
// 1453 jtype = IF JCOND;
JTYPE = 5;
// 1454 objectbytes(0) = (opn - JE);
OBJECTBYTES[0] = OPN - 25;
// 1455 count = 1;
COUNT = 1;
// 1456 %finish
L_0071:;
// 1457 %finish
L_006F:;
// 1458
// 1459 objectbytes(count) = (labelid & 255);
OBJECTBYTES[COUNT] = LABELID & 255;
// 1460 objectbytes(count+1) = (labelid >> 8);
OBJECTBYTES[COUNT + 1] = (unsigned int)LABELID >> 8;
// 1461
// 1462 writeifrecord(jtype, count+2, objectbytes);
WRITEIFRECORD(JTYPE, COUNT + 2, OBJECTBYTES);
// 1463
// 1464 ! finally, calls may trash registers...
// 1465 %if opn = CALL %start
if (OPN != 24) goto L_0072;
// 1466 displayhint(BX) = 0
DISPLAYHINT[3] = 0;
// 1467 displayhint(SI) = 0
DISPLAYHINT[6] = 0;
// 1468 displayhint(DI) = 0
DISPLAYHINT[7] = 0;
// 1469 %finish
L_0072:;
// 1470 %end
return;
} /* end of DUMPJUMP */
// 1471
// 1472 ! call the n'th external routine we've spec'ed
// 1473 %routine dumpextcall(%integer labelid)
void DUMPEXTCALL(int LABELID) {
// 1474
// 1475 displayhint(BX) = 0
DISPLAYHINT[3] = 0;
// 1476 displayhint(SI) = 0
DISPLAYHINT[6] = 0;
// 1477 displayhint(DI) = 0
DISPLAYHINT[7] = 0;
// 1478
// 1479 putbyte(opvalue(CALL));
PUTBYTE(OPVALUE[24]);
// 1480 flushcode; ! plant the "CALL" instruction
FLUSHCODE();
// 1481 putbyte(labelid & 255);
PUTBYTE(LABELID & 255);
// 1482 putbyte(labelid >> 8);
PUTBYTE((unsigned int)LABELID >> 8);
// 1483 listpreamble;
LISTPREAMBLE();
// 1484 printstring("CALL EXTERN")
_imp_PRINTSTRING(_imp_str_literal("CALL EXTERN"));
// 1485 write(labelid, 1);
_imp_WRITE(LABELID, 1);
// 1486 newline
_imp_NEWLINE();
// 1487
// 1488 writeifrecord(IF REFEXT, 2, objectbytes);
WRITEIFRECORD(12, 2, OBJECTBYTES);
// 1489 objectptr = 0; ! zap the current contents of the pipe
OBJECTPTR = 0;
// 1490 %end
return;
} /* end of DUMPEXTCALL */
// 1491
// 1492 %routine dumplabel(%integer labelid)
void DUMPLABEL(int LABELID) {
// 1493
// 1494 select output(listout)
_imp_SELECTOUTPUT(2);
// 1495 space; writehex(nextcad, 4); spaces(22);
_imp_SPACE();
WRITEHEX(NEXTCAD, 4);
_imp_SPACES(22);
// 1496 printsymbol('L');
_imp_PRINTSYMBOL(76);
// 1497 write(labelid, 1);
_imp_WRITE(LABELID, 1);
// 1498 printstring(" EQU $")
_imp_PRINTSTRING(_imp_str_literal(" EQU $"));
// 1499 newline
_imp_NEWLINE();
// 1500
// 1501 objectbytes(0) = labelid & 255;
OBJECTBYTES[0] = LABELID & 255;
// 1502 objectbytes(1) = labelid >> 8;
OBJECTBYTES[1] = (unsigned int)LABELID >> 8;
// 1503 writeifrecord(IF LABEL, 2, objectbytes);
WRITEIFRECORD(7, 2, OBJECTBYTES);
// 1504
// 1505 displayhint(BX) = 0
DISPLAYHINT[3] = 0;
// 1506 displayhint(SI) = 0
DISPLAYHINT[6] = 0;
// 1507 displayhint(DI) = 0
DISPLAYHINT[7] = 0;
// 1508 %end
return;
} /* end of DUMPLABEL */
// 1509
// 1510 %routine dumpstaticalloc(%integer which)
void DUMPSTATICALLOC(int WHICH) {
// 1511
// 1512 ! we pretend to dump "83 ec 00 SUB SP,0000" but we actually plant a special pass 2 directive
// 1513 putbyte(16_83);
PUTBYTE(131);
// 1514 putbyte(16_ec);
PUTBYTE(236);
// 1515 putbyte(16_00);
PUTBYTE(0);
// 1516 listpreamble;
LISTPREAMBLE();
// 1517 printstring("SUB SP,00");
_imp_PRINTSTRING(_imp_str_literal("SUB SP,00"));
// 1518 newline
_imp_NEWLINE();
// 1519 objectptr = 0; ! zap the current contents of the pipe
OBJECTPTR = 0;
// 1520
// 1521 objectbytes(0) = which & 255;
OBJECTBYTES[0] = WHICH & 255;
// 1522 objectbytes(1) = which >> 8;
OBJECTBYTES[1] = (unsigned int)WHICH >> 8;
// 1523 writeifrecord(IF FIXUP, 2, objectbytes);
WRITEIFRECORD(8, 2, OBJECTBYTES);
// 1524 %end
return;
} /* end of DUMPSTATICALLOC */
// 1525
// 1526 ! Pass 3 goes back and plants the correct preamble code for
// 1527 ! the static allocation based on this directive
// 1528 %routine dumpstaticfill(%integer which, %integer size)
void DUMPSTATICFILL(int WHICH, int SIZE) {
// 1529
// 1530 objectptr = 0; ! zap the current contents of the pipe
OBJECTPTR = 0;
// 1531
// 1532 objectbytes(0) = which & 255;
OBJECTBYTES[0] = WHICH & 255;
// 1533 objectbytes(1) = which >> 8;
OBJECTBYTES[1] = (unsigned int)WHICH >> 8;
// 1534 objectbytes(2) = size & 255;
OBJECTBYTES[2] = SIZE & 255;
// 1535 objectbytes(3) = size >> 8;
OBJECTBYTES[3] = (unsigned int)SIZE >> 8;
// 1536 writeifrecord(IF SETFIX, 4, objectbytes);
WRITEIFRECORD(9, 4, OBJECTBYTES);
// 1537 %end
return;
} /* end of DUMPSTATICFILL */
// 1538
// 1539 ! dump words for the constant segment or the data segment
// 1540 ! Adjusts CAD so that the diagnostic listing looks sensible
// 1541 %routine dumpcdword(%integer word, %integer which)
void DUMPCDWORD(int WORD, int WHICH) {
// 1542
// 1543 %integer tag, tmpcad, hi, lo
int TAG;
int TMPCAD;
int HI;
int LO;
// 1544 %owninteger cptr = 0
static int CPTR = 0;
// 1545 %owninteger dptr = 0
static int DPTR = 0;
// 1546 %owninteger sptr = 0
static int SPTR = 0;
// 1547
// 1548 tmpcad = next cad
TMPCAD = NEXTCAD;
// 1549 %if which = 2 %start
if (WHICH != 2) goto L_0073;
// 1550 tag = IF SWTWORD;
TAG = 16;
// 1551 next cad = sptr; sptr = sptr + 2
NEXTCAD = SPTR;
SPTR = SPTR + 2;
// 1552 %else
goto L_0074;
L_0073:;
// 1553 %if which = 1 %start
if (WHICH != 1) goto L_0075;
// 1554 tag = IF COTWORD;
TAG = 14;
// 1555 next cad = cptr; cptr = cptr + 2
NEXTCAD = CPTR;
CPTR = CPTR + 2;
// 1556 %else
goto L_0076;
L_0075:;
// 1557 tag = IF DATWORD;
TAG = 15;
// 1558 next cad = dptr; dptr = dptr + 2
NEXTCAD = DPTR;
DPTR = DPTR + 2;
// 1559 %finish
L_0076:;
// 1560 %finish
L_0074:;
// 1561
// 1562 hi = word >> 8
HI = (unsigned int)WORD >> 8;
// 1563 lo = word & 255
LO = WORD & 255;
// 1564 putbyte(lo);
PUTBYTE(LO);
// 1565 putbyte(hi);
PUTBYTE(HI);
// 1566 listpreamble;
LISTPREAMBLE();
// 1567 printstring("db ")
_imp_PRINTSTRING(_imp_str_literal("db "));
// 1568 writehex(lo, 2); printsymbol(','); writehex(hi, 2);
WRITEHEX(LO, 2);
_imp_PRINTSYMBOL(44);
WRITEHEX(HI, 2);
// 1569 printstring(" ; ")
_imp_PRINTSTRING(_imp_str_literal(" ; "));
// 1570 %if lo > 32 %and lo < 127 %then printsymbol(lo) %else printsymbol('.')
if (LO <= 32) goto L_0077;
if (LO >= 127) goto L_0077;
_imp_PRINTSYMBOL(LO);
goto L_0078;
L_0077:;
_imp_PRINTSYMBOL(46);
L_0078:;
// 1571 %if hi > 32 %and hi < 127 %then printsymbol(hi) %else printsymbol('.')
if (HI <= 32) goto L_0079;
if (HI >= 127) goto L_0079;
_imp_PRINTSYMBOL(HI);
goto L_007A;
L_0079:;
_imp_PRINTSYMBOL(46);
L_007A:;
// 1572 newline
_imp_NEWLINE();
// 1573 writeifrecord(tag, 2, objectbytes);
WRITEIFRECORD(TAG, 2, OBJECTBYTES);
// 1574 objectptr = 0; ! clear the pipe
OBJECTPTR = 0;
// 1575 nextcad = tmp cad; ! restore the real CAD
NEXTCAD = TMPCAD;
// 1576 %end
return;
} /* end of DUMPCDWORD */
// 1577
// 1578 ! tell the object file maker what source line we are on
// 1579 %routine dumplinenumber(%integer line)
void DUMPLINENUMBER(int LINE) {
// 1580
// 1581 %byteintegerarray buffer(0:1);
unsigned char BUFFER[2];
// 1582 %own %integer lastcad = 0; ! code address last time we did this
static int LASTCAD = 0;
// 1583
// 1584 %if nextcad # lastcad %start
if (NEXTCAD == LASTCAD) goto L_007B;
// 1585 buffer(0) = (line & 255);
BUFFER[0] = LINE & 255;
// 1586 buffer(1) = (line >> 8);
BUFFER[1] = (unsigned int)LINE >> 8;
// 1587 writeifrecord(IF LINE, 2, buffer);
WRITEIFRECORD(21, 2, BUFFER);
// 1588 lastcad = nextcad;
LASTCAD = NEXTCAD;
// 1589 %finish
L_007B:;
// 1590 %end
return;
} /* end of DUMPLINENUMBER */
// 1591
// 1592 ! utility to copy an IMP string into a simple buffer to
// 1593 ! pass to the IF Record routine
// 1594 %routine str to xsym(%string(255)%name s)
void STRTOXSYM(_imp_string255 * S) {
// 1595 %integer l
int L;
// 1596
// 1597 l = length(s)
L = *_imp_LENGTH((_imp_string255 *)/*p*/ S);
// 1598 xlen = 0
XLEN = 0;
// 1599 %while xlen < l %cycle
L_007C:;
if (XLEN >= L) goto L_007D;
// 1600 x sym buff(xlen) = charno(s, xlen+1)
XSYMBUFF[XLEN] = *_imp_CHARNO((_imp_string255 *)/*p*/ S, XLEN + 1);
// 1601 xlen = xlen + 1
XLEN = XLEN + 1;
// 1602 %repeat
goto L_007C;
L_007D:;
// 1603 %end
return;
} /* end of STRTOXSYM */
// 1604
// 1605 ! tell the object maker the source file name
// 1606 %routine dumpsourcename(%string(255) filename)
void DUMPSOURCENAME(_imp_string255 FILENAME) {
// 1607
// 1608 str to xsym(filename)
STRTOXSYM((_imp_string255 *)/*p*/ /*?*/ &FILENAME);
// 1609 writeifrecord(IF SOURCE, xlen, x sym buff);
WRITEIFRECORD(17, XLEN, XSYMBUFF);
// 1610
// 1611 %end
return;
} /* end of DUMPSOURCENAME */
// 1612
// 1613 ! tell the linker about an external definition
// 1614 %routine fill external(%integer seg, offset, %string(255) extname)
void FILLEXTERNAL(int SEG, int OFFSET, _imp_string255 EXTNAME) {
// 1615
// 1616 str to xsym(extname)
STRTOXSYM((_imp_string255 *)/*p*/ /*?*/ &EXTNAME);
// 1617 %if seg = CODE %start
if (SEG != 112) goto L_007E;
// 1618 writeifrecord(IF DEFEXTCODE, xlen, x sym buff);
WRITEIFRECORD(18, XLEN, XSYMBUFF);
// 1619 %else
goto L_007F;
L_007E:;
// 1620 writeifrecord(IF DEFEXTDATA, xlen, x sym buff);
WRITEIFRECORD(19, XLEN, XSYMBUFF);
// 1621 ! er, this doesn't actually work yet!
// 1622 %finish
L_007F:;
// 1623 %end
return;
} /* end of FILLEXTERNAL */
// ?OFFSET unused
// 1624
// 1625 ! Plant a request to the linker for the external name, and
// 1626 ! return an index number to refer to it with in future
// 1627 %integerfn externalref(%string(255) extname)
int EXTERNALREF(_imp_string255 EXTNAME) {
// 1628 %owninteger nextextref=1
static int NEXTEXTREF = 1;
// 1629
// 1630 str to xsym(extname)
STRTOXSYM((_imp_string255 *)/*p*/ /*?*/ &EXTNAME);
// 1631 writeifrecord(IF REQEXT, xlen, x sym buff);
WRITEIFRECORD(10, XLEN, XSYMBUFF);
// 1632 nextextref = nextextref + 1
NEXTEXTREF = NEXTEXTREF + 1;
// 1633 %result = nextextref - 1;
return NEXTEXTREF - 1;
// 1634 %end
} /* end of EXTERNALREF */
// 1635
// 1636 !------------------------------------------------------
// 1637 ! Constant table utility routines
// 1638 !
// 1639 ! Rather than dump literal constants as they occur, we
// 1640 ! collect them in a table. Whenever the compiler wants
// 1641 ! any kind of literal, we look to see if we already
// 1642 ! have it. Note this automatically solves re-use of
// 1643 ! things like floating point constants, string newline,
// 1644 ! and fixed array dope vectors. When the table starts
// 1645 ! to get fairly full, we flush it. Obviously that means
// 1646 ! in a large program we might not actually get full re-use
// 1647 ! of constants after we've flushed, but the idea is sound.
// 1648 !
// 1649 ! For the convenience of the caller, several versions of
// 1650 ! pretty much the same thing are provided.
// 1651 !------------------------------------------------------
// 1652 %constinteger cot size = 2000
// 1653 %ownbyteintegerarray contable(0:cot size)
static unsigned char CONTABLE[2001];
// 1654 %owninteger cotp = 0
static int COTP = 0;
// 1655 %owninteger cotoffset = 0; ! updated on a flush
static int COTOFFSET = 0;
// 1656
// 1657 %routine flushcot
void FLUSHCOT(void) {
// 1658 %integer i
int I;
// 1659
// 1660 ! We output a position hint to the diagnostic stream
// 1661 ! Note that although this is intended to look like
// 1662 ! 8086 assembly directives the real work is done by
// 1663 ! pass 3 - this is only to guide the human reader as
// 1664 ! to what is going on
// 1665
// 1666 selectoutput(listout)
_imp_SELECTOUTPUT(2);
// 1667 printstring(" _TEXT ENDS
_imp_PRINTSTRING(_imp_str_literal(" _TEXT ENDS\n CONST SEGMENT WORD PUBLIC 'CONST'\n"));
// 1668+ CONST SEGMENT WORD PUBLIC 'CONST'
// 1669+ ")
// 1670 i = 0
I = 0;
// 1671 %while i < cotp %cycle
L_0080:;
if (I >= COTP) goto L_0081;
// 1672 dumpcdword((contable(i+1) << 8) ! contable(i), 1)
DUMPCDWORD(CONTABLE[I + 1] << 8 | CONTABLE[I], 1);
// 1673 i = i + 2;
I = I + 2;
// 1674 %repeat
goto L_0080;
L_0081:;
// 1675
// 1676 ! Update the pointers
// 1677 cotp = 0
COTP = 0;
// 1678 cotoffset = cotoffset + i
COTOFFSET = COTOFFSET + I;
// 1679
// 1680 ! and send another hint
// 1681 selectoutput(listout)
_imp_SELECTOUTPUT(2);
// 1682 printstring(" CONST ENDS
_imp_PRINTSTRING(_imp_str_literal(" CONST ENDS\n _TEXT SEGMENT WORD PUBLIC 'CODE'\n"));
// 1683+ _TEXT SEGMENT WORD PUBLIC 'CODE'
// 1684+ ")
// 1685
// 1686 %end
return;
} /* end of FLUSHCOT */
// 1687
// 1688 ! return the offset in the const segment of a byte
// 1689 ! with value b
// 1690 %integerfn getcotb(%byteinteger b)
int GETCOTB(unsigned char B) {
// 1691 %integer i
int I;
// 1692
// 1693 i = 0
I = 0;
// 1694 %while i < cotp %cycle
L_0082:;
if (I >= COTP) goto L_0083;
// 1695 %if contable(i) = b %then %result = i + cotoffset
if (CONTABLE[I] != B) goto L_0084;
return I + COTOFFSET;
L_0084:;
// 1696 i = i + 1
I = I + 1;
// 1697 %repeat
goto L_0082;
L_0083:;
// 1698
// 1699 ! value wasn't there
// 1700 %if cotp = cotsize %then flushcot
if (COTP != 2000) goto L_0085;
FLUSHCOT();
L_0085:;
// 1701
// 1702 contable(cotp) = b
CONTABLE[COTP] = B;
// 1703 cotp = cotp + 1
COTP = COTP + 1;
// 1704 %result = (cotp - 1) + cotoffset
return COTP - 1 + COTOFFSET;
// 1705 %end
} /* end of GETCOTB */
// 1706
// 1707 ! return the offset in the const segment of a word
// 1708 ! with value w
// 1709 %integerfn getcotw(%integer w)
int GETCOTW(int W) {
// 1710 %integer i, cw
int I;
int CW;
// 1711
// 1712 i = 0
I = 0;
// 1713 %while i < cotp-1 %cycle
L_0086:;
if (I >= COTP - 1) goto L_0087;
// 1714 cw = contable(i)!(contable(i+1)<<8)
CW = CONTABLE[I] | CONTABLE[I + 1] << 8;
// 1715 %if cw = w %then %result = i + cotoffset
if (CW != W) goto L_0088;
return I + COTOFFSET;
L_0088:;
// 1716 i = i + 2
I = I + 2;
// 1717 %repeat
goto L_0086;
L_0087:;
// 1718
// 1719 ! value wasn't there - first make sure there is space
// 1720 %if cotp > cotsize-2 %then flushcot
if (COTP <= 2000 - 2) goto L_0089;
FLUSHCOT();
L_0089:;
// 1721
// 1722 ! now round off the COT
// 1723 cotp = (cotp + 1) & (\1)
COTP = COTP + 1 & (~1);
// 1724 contable(cotp) = w & 255
CONTABLE[COTP] = W & 255;
// 1725 contable(cotp+1) = w >> 8
CONTABLE[COTP + 1] = (unsigned int)W >> 8;
// 1726 cotp = cotp + 2
COTP = COTP + 2;
// 1727 %result = (cotp - 2) + cotoffset
return COTP - 2 + COTOFFSET;
// 1728 %end
} /* end of GETCOTW */
// 1729
// 1730 ! return the offset in the const segment of a double word
// 1731 ! with value dl:dh
// 1732 %integerfn getcot2(%integer dl, dh)
int GETCOT2(int DL, int DH) {
// 1733 %integer i, cwl, cwh
int I;
int CWL;
int CWH;
// 1734
// 1735 i = 0
I = 0;
// 1736 cwl = contable(i)!(contable(i+1)<<8)
CWL = CONTABLE[I] | CONTABLE[I + 1] << 8;
// 1737 %while i < cotp-3 %cycle
L_008A:;
if (I >= COTP - 3) goto L_008B;
// 1738 cwh = contable(i+2)!(contable(i+3)<<8)
CWH = CONTABLE[I + 2] | CONTABLE[I + 3] << 8;
// 1739 %if cwl = dl %and cwh = dh %then %result = i + cotoffset
if (CWL != DL) goto L_008C;
if (CWH != DH) goto L_008C;
return I + COTOFFSET;
L_008C:;
// 1740 i = i + 2
I = I + 2;
// 1741 cwl = cwh
CWL = CWH;
// 1742 %repeat
goto L_008A;
L_008B:;
// 1743
// 1744 ! value wasn't there - first make sure there is space
// 1745 %if cotp > cotsize-4 %then flushcot
if (COTP <= 2000 - 4) goto L_008D;
FLUSHCOT();
L_008D:;
// 1746
// 1747 ! now round off the COT
// 1748 cotp = (cotp + 1) & (\1)
COTP = COTP + 1 & (~1);
// 1749
// 1750 contable(cotp) = dl & 255
CONTABLE[COTP] = DL & 255;
// 1751 contable(cotp+1) = dl >> 8
CONTABLE[COTP + 1] = (unsigned int)DL >> 8;
// 1752 contable(cotp+2) = dh & 255
CONTABLE[COTP + 2] = DH & 255;
// 1753 contable(cotp+3) = dh >> 8
CONTABLE[COTP + 3] = (unsigned int)DH >> 8;
// 1754 cotp = cotp + 4
COTP = COTP + 4;
// 1755 %result = (cotp - 4) + cotoffset
return COTP - 4 + COTOFFSET;
// 1756 %end
} /* end of GETCOT2 */
// 1757
// 1758 ! return the offset in the const segment of a quad word
// 1759 ! with value q0:q1:q2:q3 (lo to hi)
// 1760 %integerfn getcot4(%integer q0, q1, q2, q3)
int GETCOT4(int Q0, int Q1, int Q2, int Q3) {
// 1761 %integer i, cw0, cw1, cw2, cw3
int I;
int CW0;
int CW1;
int CW2;
int CW3;
// 1762
// 1763 i = 0
I = 0;
// 1764 cw0 = contable(i)!(contable(i+1)<<8)
CW0 = CONTABLE[I] | CONTABLE[I + 1] << 8;
// 1765 cw1 = contable(i+2)!(contable(i+3)<<8)
CW1 = CONTABLE[I + 2] | CONTABLE[I + 3] << 8;
// 1766 cw2 = contable(i+4)!(contable(i+5)<<8)
CW2 = CONTABLE[I + 4] | CONTABLE[I + 5] << 8;
// 1767 %while i < cotp-3 %cycle
L_008E:;
if (I >= COTP - 3) goto L_008F;
// 1768 cw3 = contable(i+6)!(contable(i+7)<<8)
CW3 = CONTABLE[I + 6] | CONTABLE[I + 7] << 8;
// 1769 %if cw0 = q0 %and cw1 = q1 %and cw2 = q2 %and cw3 = q3 %then %result = i + cotoffset
if (CW0 != Q0) goto L_0090;
if (CW1 != Q1) goto L_0090;
if (CW2 != Q2) goto L_0090;
if (CW3 != Q3) goto L_0090;
return I + COTOFFSET;
L_0090:;
// 1770 i = i + 2
I = I + 2;
// 1771 cw0 = cw1
CW0 = CW1;
// 1772 cw1 = cw2
CW1 = CW2;
// 1773 cw2 = cw3
CW2 = CW3;
// 1774 %repeat
goto L_008E;
L_008F:;
// 1775
// 1776 ! value wasn't there - first make sure there is space
// 1777 %if cotp > cotsize-8 %then flushcot
if (COTP <= 2000 - 8) goto L_0091;
FLUSHCOT();
L_0091:;
// 1778
// 1779 ! now round off the COT
// 1780 cotp = (cotp + 1) & (\1)
COTP = COTP + 1 & (~1);
// 1781
// 1782 contable(cotp) = q0 & 255
CONTABLE[COTP] = Q0 & 255;
// 1783 contable(cotp+1) = q0 >> 8
CONTABLE[COTP + 1] = (unsigned int)Q0 >> 8;
// 1784 contable(cotp+2) = q1 & 255
CONTABLE[COTP + 2] = Q1 & 255;
// 1785 contable(cotp+3) = q1 >> 8
CONTABLE[COTP + 3] = (unsigned int)Q1 >> 8;
// 1786 contable(cotp+4) = q2 & 255
CONTABLE[COTP + 4] = Q2 & 255;
// 1787 contable(cotp+5) = q2 >> 8
CONTABLE[COTP + 5] = (unsigned int)Q2 >> 8;
// 1788 contable(cotp+6) = q3 & 255
CONTABLE[COTP + 6] = Q3 & 255;
// 1789 contable(cotp+7) = q3 >> 8
CONTABLE[COTP + 7] = (unsigned int)Q3 >> 8;
// 1790 cotp = cotp + 8
COTP = COTP + 8;
// 1791 %result = (cotp - 8) + cotoffset
return COTP - 8 + COTOFFSET;
// 1792 %end
} /* end of GETCOT4 */
// 1793
// 1794 %owninteger null string = -1
static int NULLSTRING = -1;
// 1795
// 1796 ! get an index into the constant table for the string literal
// 1797 ! in the array s
// 1798 %integerfn getcots(%byteintegerarrayname s)
int GETCOTS(unsigned char *S) {
// 1799 %integer i, first, len, match;
int I;
int FIRST;
int LEN;
int MATCH;
// 1800
// 1801 len = s(0) + 1; ! number of bytes to search for
LEN = [/*BUG*/ 0] + 1;
// 1802
// 1803 ! We optimise the Null String "" in comparisons, so we remember
// 1804 ! the location here
// 1805 %if len = 0 %start
if (LEN != 0) goto L_0092;
// 1806 null string = getcotb(0)
NULLSTRING = GETCOTB(0);
// 1807 %result = null string
return NULLSTRING;
// 1808 %finish
L_0092:;
// 1809
// 1810 first = 0; ! offset to search in contable
FIRST = 0;
// 1811
// 1812 %while first + len - 1 < cotp %cycle; ! so long as there are that many bytes left
L_0093:;
if (FIRST + LEN - 1 >= COTP) goto L_0094;
// 1813 match = 1
MATCH = 1;
// 1814 %for i = 0, 1, len-1 %cycle
// %for I = 0, 1, LEN - 1 %cycle
{
int _final = LEN - 1;
if (invalid_for_loop(0, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle I = 0, 1, LEN - 1");
I = -1;
L_0095:
if (I == _final) goto L_0096;
I += 1;
// 1815 %if s(i) # contable(first + i) %start
if ([/*BUG*/ 0] == CONTABLE[FIRST + I]) goto L_0098;
// 1816 match = 0
MATCH = 0;
// 1817 %exit
goto L_0096;
// 1818 %finish
L_0098:;
// 1819 %repeat
goto L_0095;
}
L_0096:;
// 1820 %if match = 1 %then %result = first + cotoffset
if (MATCH != 1) goto L_0099;
return FIRST + COTOFFSET;
L_0099:;
// 1821 first = first + 1; ! try the next solution
FIRST = FIRST + 1;
// 1822 %repeat
goto L_0093;
L_0094:;
// 1823
// 1824 ! if we get here, it wasn't already in the constant table
// 1825 %if (cotp + len) >= cotsize %then flushcot
if (COTP + LEN < 2000) goto L_009A;
FLUSHCOT();
L_009A:;
// 1826
// 1827 first = cotp
FIRST = COTP;
// 1828 i = 0;
I = 0;
// 1829 %while len > 0 %cycle
L_009B:;
if (LEN <= 0) goto L_009C;
// 1830 contable(cotp) = s(i)
CONTABLE[COTP] = [/*BUG*/ 0];
// 1831 cotp = cotp + 1
COTP = COTP + 1;
// 1832 i = i + 1
I = I + 1;
// 1833 len = len - 1
LEN = LEN - 1;
// 1834 %repeat
goto L_009B;
L_009C:;
// 1835 %result = first + cotoffset
return FIRST + COTOFFSET;
// 1836 %end
} /* end of GETCOTS */
// 1837
// 1838 !------------------------------------------------------
// 1839 ! Data segment utility routines
// 1840 !
// 1841 ! Unlike constants, we can't re-use data segment items,
// 1842 ! which makes this much simpler
// 1843 !------------------------------------------------------
// 1844
// 1845 ! >> GBYTE <<
// 1846 ! Simple byte in data segment
// 1847 %routine gbyte(%integer n)
void GBYTE(int N) {
// 1848
// 1849 Abort("Data Seg Overflow") %if datatp > max dataseg
if (DATATP <= 12000) goto L_009D;
ABORT(_imp_str_literal("Data Seg Overflow"));
L_009D:;
// 1850 datat(datatp) = n & 255;
DATAT[DATATP] = N & 255;
// 1851 datatp = datatp + 1
DATATP = DATATP + 1;
// 1852 %end
return;
} /* end of GBYTE */
// 1853
// 1854 ! >> GPUT <<
// 1855 ! Put a word into data segment
// 1856 %routine gput(%integer n)
void GPUT(int N) {
// 1857
// 1858 gbyte(n & 255)
GBYTE(N & 255);
// 1859 gbyte(n >> 8);
GBYTE((unsigned int)N >> 8);
// 1860 %end
return;
} /* end of GPUT */
// 1861
// 1862 ! >> GFIX <<
// 1863 ! round off the datasegment pointer for alignment
// 1864 %routine gfix(%integer align)
void GFIX(int ALIGN) {
// 1865 gbyte(0) %while datatp & align # 0
L_009E:;
if (DATATP & ALIGN == 0) goto L_009F;
GBYTE(0);
goto L_009E;
L_009F:;
// 1866 %end
return;
} /* end of GFIX */
// 1867
// 1868 %routine flush data
void FLUSHDATA(void) {
// 1869 %integer i
int I;
// 1870
// 1871 ! We output a position hint to the diagnostic stream
// 1872
// 1873 selectoutput(listout)
_imp_SELECTOUTPUT(2);
// 1874 printstring(" ENDS
_imp_PRINTSTRING(_imp_str_literal(" ENDS\n DATA SEGMENT WORD PUBLIC 'DATA'\n"));
// 1875+ DATA SEGMENT WORD PUBLIC 'DATA'
// 1876+ ")
// 1877 i = 0
I = 0;
// 1878 %while i < datatp %cycle
L_00A0:;
if (I >= DATATP) goto L_00A1;
// 1879 dumpcdword((datat(i+1) << 8) ! datat(i), 0)
DUMPCDWORD(DATAT[I + 1] << 8 | DATAT[I], 0);
// 1880 i = i + 2;
I = I + 2;
// 1881 %repeat
goto L_00A0;
L_00A1:;
// 1882
// 1883 ! and send another hint
// 1884 selectoutput(listout)
_imp_SELECTOUTPUT(2);
// 1885 printstring(" DATA ENDS
_imp_PRINTSTRING(_imp_str_literal(" DATA ENDS\n"));
// 1886+ ")
// 1887
// 1888 %end
return;
} /* end of FLUSHDATA */
// 1889
// 1890 !-----------------------------------------------------
// 1891 ! The last table we collect as we go along is the switch
// 1892 ! table. We don't provide individual routines to fill
// 1893 ! it in, but for tidyness we provide this routine to send
// 1894 ! the contents to pass 3
// 1895
// 1896 %routine flush switch
void FLUSHSWITCH(void) {
// 1897 %integer i
int I;
// 1898
// 1899 select output(listout)
_imp_SELECTOUTPUT(2);
// 1900 printstring(" ENDS
_imp_PRINTSTRING(_imp_str_literal(" ENDS\n _SWTAB SEGMENT WORD PUBLIC '_SWTAB'\n"));
// 1901+ _SWTAB SEGMENT WORD PUBLIC '_SWTAB'
// 1902+ ")
// 1903 i = 0
I = 0;
// 1904 %while i < swtp %cycle
L_00A2:;
if (I >= SWTP) goto L_00A3;
// 1905 dumpcdword(swtab(i), 2)
DUMPCDWORD(SWTAB[I], 2);
// 1906 i = i + 1
I = I + 1;
// 1907 %repeat
goto L_00A2;
L_00A3:;
// 1908
// 1909 ! and send another hint
// 1910 selectoutput(listout)
_imp_SELECTOUTPUT(2);
// 1911 printstring(" _SWTAB ENDS
_imp_PRINTSTRING(_imp_str_literal(" _SWTAB ENDS\n"));
// 1912+ ")
// 1913
// 1914 %end
return;
} /* end of FLUSHSWITCH */
// 1915
// 1916 !-------------------------------------------------------------
// 1917 ! Print the source code lines up to the indicated line
// 1918 ! number - these will interleave with the diagnostic assembly
// 1919 ! output
// 1920
// 1921 %owninteger echoline = 0
static int ECHOLINE = 0;
// 1922
// 1923 %routine echo source line
void ECHOSOURCELINE(void) {
// 1924 %integer ch
int CH;
// 1925 %owninteger source eof = 0
static int SOURCEEOF = 0;
// 1926
// 1927 echoline = echoline + 1; ! update the count even if there's no input
ECHOLINE = ECHOLINE + 1;
// 1928
// 1929 %if source eof # 0 %then %return; ! silently ignore lack of source file
if (SOURCEEOF == 0) goto L_00A4;
return;
L_00A4:;
// 1930
// 1931 select input(source)
_imp_SELECTINPUT(2);
// 1932 select output(listout)
_imp_SELECTOUTPUT(2);
// 1933 %cycle
L_00A5:;
// 1934 readsymbol(ch)
_imp_READSYMBOL(/*?*/ &CH);
// 1935 printsymbol(ch)
_imp_PRINTSYMBOL(CH);
// 1936 %exit %if ch = 10 %or ch < 0
if (CH == 10) goto L_0097;
if (CH >= 0) goto L_00A6;
L_0097:;
goto L_00A7;
L_00A6:;
// 1937 %repeat
goto L_00A5;
L_00A7:;
// 1938
// 1939 %if ch < 0 %then source eof = 1
if (CH >= 0) goto L_00A8;
SOURCEEOF = 1;
L_00A8:;
// 1940
// 1941 select input(icode)
_imp_SELECTINPUT(1);
// 1942 select output(objout)
_imp_SELECTOUTPUT(1);
// 1943 %end
return;
} /* end of ECHOSOURCELINE */
// 1944
// 1945 !-----------------------------------------------------------
// 1946 ! General descriptor and register manipulation routines
// 1947 !-----------------------------------------------------------
// 1948
// 1949 ! >> FLOATING <<
// 1950 %integerfn floating(%record(stackfm)%name v)
int FLOATING(struct STACKFM * V) {
// 1951 ! check descriptor for floating point quantity
// 1952 %result = 1 %if v_type = real %or v_type = lreal
if (V->TYPE == 2) goto L_00A9;
if (V->TYPE != 6) goto L_00AA;
L_00A9:;
return 1;
L_00AA:;
// 1953 %result = 0
return 0;
// 1954 %end
} /* end of FLOATING */
// 1955
// 1956 ! >> ZERO <<
// 1957 %integerfn zero(%record(stackfm)%name v)
int ZERO(struct STACKFM * V) {
// 1958 ! CHECK DESCRIPTOR FOR (INTEGER) ZERO
// 1959 %result = 0 %if v_disp # 0 %or v_base # 0 %or (v_form # constant %and v_form # AV in S)
if (V->DISP != 0) goto L_00AB;
if (V->BASE != 0) goto L_00AB;
if (V->FORM == 0) goto L_00AC;
if (V->FORM == 5) goto L_00AC;
L_00AB:;
return 0;
L_00AC:;
// 1960 %result = 1
return 1;
// 1961 %end
} /* end of ZERO */
// 1962
// 1963 ! >> CONST <<
// 1964 %integerfn const(%record(stackfm)%name v)
int CONST(struct STACKFM * V) {
// 1965 ! CHECK DESCRIPTOR FOR CONSTANT (INTEGER) VALUE
// 1966 %result = 0 %unless v_form = constant
if (V->FORM == 0) goto L_00AD;
return 0;
L_00AD:;
// 1967 %result = 0 %if v_type > byte
if (V->TYPE <= 5) goto L_00AE;
return 0;
L_00AE:;
// 1968 %result = 1
return 1;
// 1969 %end
} /* end of CONST */
// 1970
// 1971 %integerfn Min Record Size(%record(stackfm)%name A, B)
int MINRECORDSIZE(struct STACKFM * A, struct STACKFM * B) {
// 1972 %integer N, M
int N;
int M;
// 1973 N = A_format; N = var(N)_size & 16_7FFF %if N # 0
N = A->FORMAT;
if (N == 0) goto L_00AF;
N = VAR[N].SIZE & 32767;
L_00AF:;
// 1974 M = B_format; M = var(M)_size & 16_7FFF %if M # 0
M = B->FORMAT;
if (M == 0) goto L_00B0;
M = VAR[M].SIZE & 32767;
L_00B0:;
// 1975 N = M %if N = 0 %or (M # 0 %and M < N)
if (N == 0) goto L_00B1;
if (M == 0) goto L_00B2;
if (M >= N) goto L_00B2;
L_00B1:;
N = M;
L_00B2:;
// 1976 %result = N %if N > 0
if (N <= 0) goto L_00B3;
return N;
L_00B3:;
// 1977 Abort("Min Rec Size")
ABORT(_imp_str_literal("Min Rec Size"));
// 1978 %end
_imp_signal(8, 4, 0, "result missing");
} /* end of MINRECORDSIZE */
// 1979
// 1980 ! >> MULSHIFT <<
// 1981 %integerfn mulshift(%integer n)
int MULSHIFT(int N) {
// 1982 %integer shift, ref
int SHIFT;
int REF;
// 1983 ref = 1
REF = 1;
// 1984 %for shift = 1, 1, 14 %cycle
// %for SHIFT = 1, 1, 14 %cycle
{
SHIFT = 0;
L_00B4:
if (SHIFT == 14) goto L_00B5;
SHIFT += 1;
// 1985 ref = ref<<1
REF = REF << 1;
// 1986 %if ref >= n %start
if (REF < N) goto L_00B7;
// 1987 %if ref = n %then %result = shift %else %result = -1
if (REF != N) goto L_00B8;
return SHIFT;
L_00B8:;
return -1;
// 1988 %finish
L_00B7:;
// 1989 %repeat
goto L_00B4;
}
L_00B5:;
// 1990 %result = -1
return -1;
// 1991 %end
} /* end of MULSHIFT */
// 1992
// 1993 ! >> SAME <<
// 1994 %integerfn same(%record(stackfm)%name v,w)
int SAME(struct STACKFM * V, struct STACKFM * W) {
// 1995 ! Test whether or not V and W describe the same object.
// 1996 %result = 0 %if v_disp # w_disp %or v_base # w_base
if (V->DISP != W->DISP) goto L_00B6;
if (V->BASE == W->BASE) goto L_00B9;
L_00B6:;
return 0;
L_00B9:;
// 1997 %result = 0 %if v_type # w_type %or v_form # w_form
if (V->TYPE != W->TYPE) goto L_00BA;
if (V->FORM == W->FORM) goto L_00BB;
L_00BA:;
return 0;
L_00BB:;
// 1998 %result = 0 %if v_extra # w_extra %or v_scope # w_scope
if (V->EXTRA != W->EXTRA) goto L_00BC;
if (V->SCOPE == W->SCOPE) goto L_00BD;
L_00BC:;
return 0;
L_00BD:;
// 1999 %result = 1
return 1;
// 2000 %end
} /* end of SAME */
// 2001
// 2002 ! >> READ TAG <<
// 2003 %integerfn read tag
int READTAG(void) {
// 2004 %integer s1, s2
int S1;
int S2;
// 2005 s1 = next sym
S1 = NEXTSYM;
// 2006 readsymbol(s2)
_imp_READSYMBOL(/*?*/ &S2);
// 2007 readsymbol(next sym)
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2008 %result = s1<<8!s2
return S1 << 8 | S2;
// 2009 %end
} /* end of READTAG */
// 2010
// 2011 ! >> GET D <<
// 2012 ! Read a floating point literal. Pass 1 treats these as strings
// 2013 ! and leaves it up to us to make a floating point number out of it
// 2014 ! We therefore expect [COUNT]NNN.NNN@NN
// 2015 %routine get d
void GETD(void) {
// 2016 %integer n
int N;
// 2017 %longreal p
double P;
// 2018 n = read tag; read symbol(next sym); ! char count, skip comma
N = READTAG();
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2019 rvalue = 0
RVALUE = 0;
// 2020 ! Start with the bit ahead of the decimal point
// 2021 %cycle
L_00BE:;
// 2022 sym = next sym; read symbol(next sym)
SYM = NEXTSYM;
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2023 %exit %if sym = '.'
if (SYM != 46) goto L_00BF;
goto L_00C0;
L_00BF:;
// 2024 n = n-1
N = N - 1;
// 2025 -> power %if sym = '@'
if (SYM != 64) goto L_00C1;
goto U_1008;
L_00C1:;
// 2026 rvalue = rvalue*10+(sym-'0')
RVALUE = RVALUE * 10 + (SYM - 48);
// 2027 -> SIGN %if n = 0
if (N != 0) goto L_00C2;
goto U_1009;
L_00C2:;
// 2028 %repeat
goto L_00BE;
L_00C0:;
// 2029 p = 1
P = 1;
// 2030 %cycle
L_00C3:;
// 2031 n = n-1; -> SIGN %if n = 0
N = N - 1;
if (N != 0) goto L_00C4;
goto U_1009;
L_00C4:;
// 2032 sym = next sym; read symbol(next sym)
SYM = NEXTSYM;
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2033 -> POWER %if sym = '@'
if (SYM != 64) goto L_00C5;
goto U_1008;
L_00C5:;
// 2034 p = p/10
P = (double)(P / 10);
// 2035 rvalue = rvalue + (sym-'0')*p
RVALUE = RVALUE + (SYM - 48) * P;
// 2036 %repeat
goto L_00C3;
// 2037 POWER:
U_1008:;
// 2038 n = read tag
N = READTAG();
// 2039 ! somewhat clunky so that we can be portable to a system that
// 2040 ! doesn't do exponents
// 2041 %while n > 0 %cycle
L_00C6:;
if (N <= 0) goto L_00C7;
// 2042 rvalue = rvalue * 10
RVALUE = RVALUE * 10;
// 2043 n = n - 1
N = N - 1;
// 2044 %repeat
goto L_00C6;
L_00C7:;
// 2045 %while n < 0 %cycle
L_00C8:;
if (N >= 0) goto L_00C9;
// 2046 rvalue = rvalue / 10
RVALUE = (double)(RVALUE / 10);
// 2047 n = n + 1
N = N + 1;
// 2048 %repeat
goto L_00C8;
L_00C9:;
// 2049 SIGN: ! sign of whole value
U_1009:;
// 2050 %if next sym = 'U' %start
if (NEXTSYM != 85) goto L_00CA;
// 2051 read symbol(next sym)
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2052 rvalue = -rvalue
RVALUE = -RVALUE;
// 2053 %finish
L_00CA:;
// 2054 %end
return;
} /* end of GETD */
// 2055
// 2056 ! grab a slab of working store in the local stack
// 2057 %integerfn getwork(%integer size)
int GETWORK(int SIZE) {
// 2058 %integer cell;
int CELL;
// 2059
// 2060 cell = worklist(level);
CELL = WORKLIST[LEVEL - 1];
// 2061 %while cell # 0 %cycle
L_00CB:;
if (CELL == 0) goto L_00CC;
// 2062 %if gp tags(cell)_info = size %and gp tags(cell)_flags = 0 %start; ! suitable candidate?
if (GPTAGS[CELL].INFO != SIZE) goto L_00CD;
if (GPTAGS[CELL].FLAGS != 0) goto L_00CD;
// 2063 gp tags(cell)_flags = 1; ! mark it as in use
GPTAGS[CELL].FLAGS = 1;
// 2064 %result = gp tags(cell)_addr;
return GPTAGS[CELL].ADDR;
// 2065 %finish
L_00CD:;
// 2066 cell = gp tags(cell)_link;
CELL = GPTAGS[CELL].LINK;
// 2067 %repeat
goto L_00CB;
L_00CC:;
// 2068
// 2069 ! no space available already - make more
// 2070 cell = get gp tag
CELL = GETGPTAG();
// 2071 frame = (frame - size) & (\1); ! make them all even boundaries
FRAME = FRAME - SIZE & (~1);
// 2072 gp tags(cell)_addr = frame;
GPTAGS[CELL].ADDR = FRAME;
// 2073 gp tags(cell)_info = size;
GPTAGS[CELL].INFO = SIZE;
// 2074 gp tags(cell)_link = worklist(level);
GPTAGS[CELL].LINK = WORKLIST[LEVEL - 1];
// 2075 worklist(level) = cell;
WORKLIST[LEVEL - 1] = CELL;
// 2076 gp tags(cell)_flags = 1; ! in use
GPTAGS[CELL].FLAGS = 1;
// 2077 %result = gp tags(cell)_addr;
return GPTAGS[CELL].ADDR;
// 2078 %end
} /* end of GETWORK */
// 2079
// 2080 ! Return a slab of working store to the free pool. Note that
// 2081 ! ReturnWork is cautious about what it accepts - it only takes
// 2082 ! in items it has previously given out, so we can call it
// 2083 ! fairly liberally with any old rubbish and it will do the
// 2084 ! right thing
// 2085 %routine Return Work(%integer addr)
void RETURNWORK(int ADDR) {
// 2086 %integer cell
int CELL;
// 2087
// 2088 cell = worklist(level);
CELL = WORKLIST[LEVEL - 1];
// 2089 %while cell # 0 %cycle
L_00CE:;
if (CELL == 0) goto L_00CF;
// 2090 %if gp tags(cell)_addr = addr %start
if (GPTAGS[CELL].ADDR != ADDR) goto L_00D0;
// 2091 %if gp tags(cell)_flags = 0 %then abort("Return Work")
if (GPTAGS[CELL].FLAGS != 0) goto L_00D1;
ABORT(_imp_str_literal("Return Work"));
L_00D1:;
// 2092 gp tags(cell)_flags = 0; ! mark it as free
GPTAGS[CELL].FLAGS = 0;
// 2093 %return
return;
// 2094 %finish
L_00D0:;
// 2095 cell = gp tags(cell)_link;
CELL = GPTAGS[CELL].LINK;
// 2096 %repeat
goto L_00CE;
L_00CF:;
// 2097
// 2098 ! Here, work area was not found - it probably wasn't a work area!
// 2099 %end
return;
} /* end of RETURNWORK */
// 2100
// 2101 ! Check to see if a variable is in a work list assigned block
// 2102 %integerfn Is Work(%record(stackfm)%name v)
int ISWORK(struct STACKFM * V) {
// 2103 %integer cell
int CELL;
// 2104
// 2105 %if v_base # BP %or v_disp >= 0 %or v_scope # 0 %or v_form # v in s %then %result = 0
if (V->BASE != 6) goto L_00D2;
if (V->DISP >= 0) goto L_00D2;
if (V->SCOPE != 0) goto L_00D2;
if (V->FORM == 4) goto L_00D3;
L_00D2:;
return 0;
L_00D3:;
// 2106
// 2107 cell = worklist(level);
CELL = WORKLIST[LEVEL - 1];
// 2108 %while cell # 0 %cycle
L_00D4:;
if (CELL == 0) goto L_00D5;
// 2109 %if gp tags(cell)_addr = v_disp %start
if (GPTAGS[CELL].ADDR != V->DISP) goto L_00D6;
// 2110 %if gp tags(cell)_flags = 0 %then abort("Is Work")
if (GPTAGS[CELL].FLAGS != 0) goto L_00D7;
ABORT(_imp_str_literal("Is Work"));
L_00D7:;
// 2111 %result = 1
return 1;
// 2112 %finish
L_00D6:;
// 2113 cell = gp tags(cell)_link;
CELL = GPTAGS[CELL].LINK;
// 2114 %repeat
goto L_00D4;
L_00D5:;
// 2115
// 2116 %result = 0
return 0;
// 2117 %end
} /* end of ISWORK */
// 2118
// 2119
// 2120 ! >> RELEASE <<
// 2121 %routine release(%integer reg)
void RELEASE(int REG) {
// 2122 ! Hazard the value in a register
// 2123 ! abort("Release bad register") %if reg > fr7
// 2124 %return %if reg = 0 %or reg > fr7 %or activity(reg) < 0; ! LOCKED
if (REG == 0) goto L_00D8;
if (REG > 16) goto L_00D8;
if (ACTIVITY[REG] >= 0) goto L_00D9;
L_00D8:;
return;
L_00D9:;
// 2125 activity(reg) = activity(reg)-1
ACTIVITY[REG] = ACTIVITY[REG] - 1;
// 2126 abort("Release inactive") %if activity(reg) < 0
if (ACTIVITY[REG] >= 0) goto L_00DA;
ABORT(_imp_str_literal("Release inactive"));
L_00DA:;
// 2127 claimed = claimed - 1
CLAIMED = CLAIMED - 1;
// 2128 %end
return;
} /* end of RELEASE */
// 2129
// 2130 ! >> CLAIM <<
// 2131 %routine claim(%integer reg)
void CLAIM(int REG) {
// 2132 ! Cherish the value in a register
// 2133 abort("Claim bad register") %if reg > fr7
if (REG <= 16) goto L_00DB;
ABORT(_imp_str_literal("Claim bad register"));
L_00DB:;
// 2134 %return %if reg = 0 %or activity(reg) < 0
if (REG == 0) goto L_00DC;
if (ACTIVITY[REG] >= 0) goto L_00DD;
L_00DC:;
return;
L_00DD:;
// 2135 activity(reg) = activity(reg)+1
ACTIVITY[REG] = ACTIVITY[REG] + 1;
// 2136 claimed = claimed+1
CLAIMED = CLAIMED + 1;
// 2137 %end
return;
} /* end of CLAIM */
// 2138
// 2139 ! >> HAZARD <<
// 2140 ! Protect any value in register REG by storing in a temporary.
// 2141 %routine hazard(%integer reg)
void HAZARD(int REG) {
// 2142 %integer i, n, t, type
int I;
int N;
int T;
int TYPE;
// 2143
// 2144 %routine mod(%record(stackfm)%name v)
void MOD(struct STACKFM * V) {
// 2145 %switch sw(0:a in rec)
int SW_index;
int SW_line;
char *SW_file;
static const void *SW[10] = {&&case_SW_missing, &&case_SW_missing, &&case_SW_missing, &&case_SW_missing,
&&case_SW_missing, &&case_SW_missing, &&case_SW_missing, &&case_SW_missing,
&&case_SW_missing, &&case_SW_missing};
// 2146 v_base = BP
V->BASE = 6;
// 2147 n = n-1
N = N - 1;
// 2148 -> sw(v_form)
SW_line = __LINE__;
SW_file = __FILE__;
SW_index = V->FORM;
goto case_SW_dispatch;
// 2149 sw(a in rec):
case_SW_9:;
// 2150 sw(av in rec):
case_SW_8:;
// 2151 sw(v in rec):
case_SW_7:;
// 2152 sw(constant): abort("Mod")
case_SW_0:;
ABORT(_imp_str_literal("Mod"));
// 2153
// 2154 sw(v in s): %if v_disp = 0 %and v_scope = 0 %start
case_SW_4:;
if (V->DISP != 0) goto L_00DF;
if (V->SCOPE != 0) goto L_00DF;
// 2155 v_disp = t; v_form = a in s; ->out1
V->DISP = T;
V->FORM = 6;
goto U_100A;
// 2156 %finish
L_00DF:;
// 2157 sw(a in s):
case_SW_6:;
// 2158 sw(av in s):
case_SW_5:;
// 2159 ! change (X in S) to (X in REC)
// 2160 v_form = v_form + 3; v_extra = t; -> OUT1
V->FORM = V->FORM + 3;
V->EXTRA = T;
goto U_100A;
// 2161
// 2162 sw(v in r): v_form = v in s; v_disp = t
case_SW_1:;
V->FORM = 4;
V->DISP = T;
// 2163 v_type = type
V->TYPE = TYPE;
// 2164 OUT1:
U_100A:;
// 2165 %end
return;
case_SW_dispatch:
if (SW_index < 0 || SW_index > 9)
_imp_signalf(6, 3, SW_index, "->SW(%d) out of bounds at %s line %d", SW_index, SW_file, SW_line);
goto *SW[SW_index - 0];
case_SW_missing:
_imp_signalf(8, 2, SW_index, "switch jump to undefined label SW(%d): at %s line %d", SW_index, SW_file, SW_line);
} /* end of MOD */
// 2166
// 2167 n = activity(reg); %return %if n <= 0; ! NOT IN USE OR CLAIMED
N = ACTIVITY[REG];
if (N > 0) goto L_00E0;
return;
L_00E0:;
// 2168
// 2169 claimed = claimed - n
CLAIMED = CLAIMED - N;
// 2170 activity(reg) = 0
ACTIVITY[REG] = 0;
// 2171 %if reg >= fr0 %start
if (REG < 9) goto L_00E1;
// 2172 ! Note that the FPU can only save the top of the stack.
// 2173 ! If we need to save something lower down, we need to pop
// 2174 ! the things above me first...
// 2175 %if reg - FR0 >= FPU Stack %then hazard(reg+1); ! and recurse as required
if (REG - 9 < FPUSTACK) goto L_00E2;
HAZARD(REG + 1);
L_00E2:;
// 2176 type = lreal
TYPE = 6;
// 2177 t = getwork(8)
T = GETWORK(8);
// 2178 dumpfloprm(FSTQ, BP, t)
DUMPFLOPRM(41, 6, T);
// 2179 %else
goto L_00E3;
L_00E1:;
// 2180 type = integer
TYPE = 1;
// 2181 t = getwork(2)
T = GETWORK(2);
// 2182 dumpmr(MOV, BP,t, reg)
DUMPMR(11, 6, T, REG);
// 2183 %finish
L_00E3:;
// 2184 %for i = 1, 1, stp %cycle
// %for I = 1, 1, STP %cycle
{
int _final = STP;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle I = 1, 1, STP");
I = 0;
L_00E4:
if (I == _final) goto L_00E5;
I += 1;
// 2185 mod(stack(i)) %if stack(i)_base = reg
if (STACK[I - 1].BASE != REG) goto L_00E7;
MOD(/*?*/ &STACK[I - 1]);
L_00E7:;
// 2186 %repeat
goto L_00E4;
}
L_00E5:;
// 2187 abort("Usage Outstanding") %if n # 0; ! USE STILL OUTSTANDING
if (N == 0) goto L_00E8;
ABORT(_imp_str_literal("Usage Outstanding"));
L_00E8:;
// 2188 %end
return;
} /* end of HAZARD */
// 2189
// 2190 ! >> HAZARD ALL <<
// 2191 %routine hazard all
void HAZARDALL(void) {
// 2192 %integer j
int J;
// 2193
// 2194 %if claimed # 0 %start; ! at least one register claimed
if (CLAIMED == 0) goto L_00E9;
// 2195 hazard(j) %for j = AX,1,FR7
// %for J = 1, 1, 16 %cycle
{
J = 0;
L_00EA:
if (J == 16) goto L_00EB;
J += 1;
HAZARD(J);
goto L_00EA;
}
L_00EB:;
// 2196 %finish
L_00E9:;
// 2197 %end
return;
} /* end of HAZARDALL */
// 2198
// 2199 ! >> GP REG <<
// 2200 ! Get a general (integer) register
// 2201 ! Note that registers AX, CX, DX, BX are, in order
// 2202 ! numbers 1, 2, 3 and 4 (which is convenient)
// 2203 %integerfn gpreg
int GPREG(void) {
// 2204 %integer r
int R;
// 2205
// 2206 ! look for an empty one
// 2207 %for r = AX,1,BX %cycle
// %for R = 1, 1, 4 %cycle
{
R = 0;
L_00ED:
if (R == 4) goto L_00EE;
R += 1;
// 2208 %result = r %if activity(r) = 0
if (ACTIVITY[R] != 0) goto L_00EF;
return R;
L_00EF:;
// 2209 %repeat
goto L_00ED;
}
L_00EE:;
// 2210
// 2211 ! look for an unlocked one
// 2212 %for r = AX,1,BX %cycle
// %for R = 1, 1, 4 %cycle
{
R = 0;
L_00F0:
if (R == 4) goto L_00F1;
R += 1;
// 2213 %if activity(r) > 0 %start
if (ACTIVITY[R] <= 0) goto L_00F2;
// 2214 hazard(r)
HAZARD(R);
// 2215 %result = r
return R;
// 2216 %finish
L_00F2:;
// 2217 %repeat
goto L_00F0;
}
L_00F1:;
// 2218
// 2219 abort("Get Reg")
ABORT(_imp_str_literal("Get Reg"));
// 2220 %end
_imp_signal(8, 4, 0, "result missing");
} /* end of GPREG */
// 2221
// 2222 ! >> PT REG <<
// 2223 %integerfn pt reg
int PTREG(void) {
// 2224 ! Get a register we can use as a pointer. We deliberately rotate
// 2225 ! around the candidates to make re-use more likely
// 2226 %constbyteintegerarray pt pref(0:2) =
const unsigned char PTPREF[3] = {7, 8, 4};
// 2227+ 7, 8, 4
// 2228 ! SI, DI, BX
// 2229 %owninteger next = 0
static int NEXT = 0;
// 2230 %integer r,j
int R;
int J;
// 2231
// 2232 ! look for an empty one
// 2233 %for j = 1,1,3 %cycle
// %for J = 1, 1, 3 %cycle
{
J = 0;
L_00F3:
if (J == 3) goto L_00F4;
J += 1;
// 2234 r = pt pref(next)
R = PTPREF[NEXT];
// 2235 next = next+1; next = 0 %if next = 3
NEXT = NEXT + 1;
if (NEXT != 3) goto L_00F5;
NEXT = 0;
L_00F5:;
// 2236 %result = r %if activity(r) = 0
if (ACTIVITY[R] != 0) goto L_00F6;
return R;
L_00F6:;
// 2237 %repeat
goto L_00F3;
}
L_00F4:;
// 2238
// 2239 ! look for an unlocked one
// 2240 %for j = 1,1,3 %cycle
// %for J = 1, 1, 3 %cycle
{
J = 0;
L_00F7:
if (J == 3) goto L_00F8;
J += 1;
// 2241 r = pt pref(j)
R = PTPREF[J];
// 2242 %if activity(r) > 0 %start
if (ACTIVITY[R] <= 0) goto L_00F9;
// 2243 hazard(r)
HAZARD(R);
// 2244 %result = r
return R;
// 2245 %finish
L_00F9:;
// 2246 %repeat
goto L_00F7;
}
L_00F8:;
// 2247
// 2248 abort("Get PT Reg")
ABORT(_imp_str_literal("Get PT Reg"));
// 2249 %end
_imp_signal(8, 4, 0, "result missing");
} /* end of PTREG */
// 2250
// 2251 ! >> FPU REG <<
// 2252 ! Returns the next register on the FPU stack
// 2253 %integerfn fpu reg
int FPUREG(void) {
// 2254 %result = FR0 + FPU Stack
return 9 + FPUSTACK;
// 2255 %end
} /* end of FPUREG */
// 2256
// 2257 ! >> GET DISPLAY <<
// 2258 ! return the register to use to access display level <n>
// 2259 %integerfn getdisplay(%integer l)
int GETDISPLAY(int L) {
// 2260 %integer r, lev
int R;
int LEV;
// 2261
// 2262 lev = l & 15; ! get rid of any relocation info
LEV = L & 15;
// 2263 %if lev = 0 %then %result = l; ! global
if (LEV != 0) goto L_00FA;
return L;
L_00FA:;
// 2264 %if lev = level %then %result = BP; ! local
if (LEV != LEVEL) goto L_00FB;
return 6;
L_00FB:;
// 2265
// 2266 ! We now try the 3 pointer register - they are not contiguously
// 2267 ! numbered, which is why this is unrolled!
// 2268 %if displayhint(BX) = lev %then %result = BX
if (DISPLAYHINT[3] != LEV) goto L_00FC;
return 4;
L_00FC:;
// 2269 %if displayhint(SI) = lev %then %result = SI
if (DISPLAYHINT[6] != LEV) goto L_00FD;
return 7;
L_00FD:;
// 2270 %if displayhint(DI) = lev %then %result = DI
if (DISPLAYHINT[7] != LEV) goto L_00FE;
return 8;
L_00FE:;
// 2271
// 2272 r = pt reg
R = PTREG();
// 2273 dumprm(MOV, r, DISPLAY, lev*2)
DUMPRM(11, R, 64, LEV * 2);
// 2274 displayhint(r) = lev
DISPLAYHINT[R - 1] = LEV;
// 2275 %result = r
return R;
// 2276 %end
} /* end of GETDISPLAY */
// 2277
// 2278 ! >> SET DOPE VECTOR <<
// 2279 ! Plants a dope vector for a 1-D constant bound array (usually
// 2280 ! OWN or CONST arrays) in the CONST segment, returns the offset
// 2281 ! Note that it also modifies the vlb and vub variables - after
// 2282 ! the call, VLB contains the byte offset for the first member
// 2283 ! and VUB contains the size to allocate for the array in bytes.
// 2284 %integerfn set dope vector
int SETDOPEVECTOR(void) {
// 2285 %integer t, dv
int T;
int DV;
// 2286
// 2287 t = vub-vlb+1
T = VUB - VLB + 1;
// 2288 dv = getcot4(1, vlb, vub, data size)
DV = GETCOT4(1, VLB, VUB, DATASIZE);
// 2289 vub = t*data size; vlb = vlb*data size
VUB = T * DATASIZE;
VLB = VLB * DATASIZE;
// 2290 %result = dv
return DV;
// 2291 %end
} /* end of SETDOPEVECTOR */
// 2292
// 2293 ! >> PERM <<
// 2294 ! calls a PERM and adjusts the stack by SPACE bytes afterwards
// 2295 %routine perm(%integer n, space)
void PERM(int N, int SPACE) {
// 2296 ! PERM routines are written in MS C, and they preserve SI and DI,
// 2297 ! but trash the general purpose registers
// 2298 hazard(AX); hazard(CX); hazard(DX); hazard(BX)
HAZARD(1);
HAZARD(2);
HAZARD(3);
HAZARD(4);
// 2299 dumpextcall(n)
DUMPEXTCALL(N);
// 2300 %if space # 0 %then dumpri(ADD, SP, space)
if (SPACE == 0) goto L_00FF;
DUMPRI(14, 5, SPACE);
L_00FF:;
// 2301 %end
return;
} /* end of PERM */
// 2302
// 2303 ! >> ASSEMBLE <<
// 2304 ! AMODE:
// 2305 ! -3: initial call
// 2306 ! -2: alternate record format
// 2307 ! -1: record format
// 2308 ! 0: begin block
// 2309 ! 1: procedure
// 2310 ! 2: %spec
// 2311
// 2312 %routine Assemble(%integer amode, labs, names)
void ASSEMBLE(int AMODE, int LABS, int NAMES) {
// 2313 %switch c(33:127)
int C_index;
int C_line;
char *C_file;
static const void *C[95] = {
&&case_C_33, &&case_C_34, &&case_C_35, &&case_C_36, &&case_C_37, &&case_C_38,
&&case_C_39, &&case_C_40, &&case_C_41, &&case_C_42, &&case_C_43, &&case_C_default,
&&case_C_45, &&case_C_46, &&case_C_47, &&case_C_default, &&case_C_default, &&case_C_default,
&&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default,
&&case_C_default, &&case_C_58, &&case_C_59, &&case_C_60, &&case_C_61, &&case_C_62,
&&case_C_63, &&case_C_64, &&case_C_65, &&case_C_66, &&case_C_67, &&case_C_68,
&&case_C_69, &&case_C_70, &&case_C_71, &&case_C_72, &&case_C_73, &&case_C_74,
&&case_C_75, &&case_C_76, &&case_C_77, &&case_C_78, &&case_C_79, &&case_C_80,
&&case_C_81, &&case_C_82, &&case_C_83, &&case_C_84, &&case_C_85, &&case_C_86,
&&case_C_87, &&case_C_88, &&case_C_default, &&case_C_90, &&case_C_91, &&case_C_92,
&&case_C_93, &&case_C_94, &&case_C_95, &&case_C_default, &&case_C_97, &&case_C_98,
&&case_C_default, &&case_C_100, &&case_C_101, &&case_C_102, &&case_C_103, &&case_C_104,
&&case_C_105, &&case_C_106, &&case_C_107, &&case_C_108, &&case_C_109, &&case_C_110,
&&case_C_111, &&case_C_112, &&case_C_113, &&case_C_114, &&case_C_115, &&case_C_116,
&&case_C_117, &&case_C_118, &&case_C_119, &&case_C_120, &&case_C_121, &&case_C_122,
&&case_C_123, &&case_C_default, &&case_C_125, &&case_C_126, &&case_C_default};
// 2314 %record(varfm)%name v; ! General purpose pointer
struct VARFM *V;
// 2315 %record(varfm)%name procvar; ! Var of the current procedure we're compiling
struct VARFM *PROCVAR;
// 2316 %record(varfm)%name ap, fp; ! Actual parameter & formal parameter ptrs, used to copy parms to parm area
struct VARFM *AP;
struct VARFM *FP;
// 2317 %record(stackfm)%name lhs, rhs; ! General stack pointers
struct STACKFM *LHS;
struct STACKFM *RHS;
// 2318 %record(stackfm) temp; ! A stack record for shuffling and copying
struct STACKFM TEMP;
// 2319 %integer max frame; ! Used for alternate records to find the largest alternate
int MAXFRAME;
// 2320 %integer first name; ! First descriptor at this level
int FIRSTNAME;
// 2321 %integer staticalloc; ! Tag used by pass 3 to fix up this level's stack allocation
int STATICALLOC;
// 2322 %integer skipproc, lastskip; ! Used to jump around routines
int SKIPPROC;
int LASTSKIP;
// 2323 %integer First label; ! First label at this level
int FIRSTLABEL;
// 2324 %integer old frame; ! Previous level's static allocation
int OLDFRAME;
// 2325 %integer i, j, k, n, t
int I;
int J;
int K;
int N;
int T;
// 2326 %integer opr, val, dv
int OPR;
int VAL;
int DV;
auto void COMPILETOSTRING(struct STACKFM * V);
auto void LOAD(struct STACKFM * V, int R);
auto void ASSIGN(int ASSOP);
auto void ARRAYREF(int MODE);
auto void OPERATE(int OP);
auto void COMPARE(struct STACKFM * L, struct STACKFM * R);
auto void TESTZERO(struct STACKFM * V);
auto int NEWTAG(void);
// 2327
// 2328 %routinespec compile to string(%record(stackfm)%name v)
// 2329 %routinespec load(%record(stackfm)%name v, %integer reg)
// 2330 %routinespec assign(%integer assop)
// 2331 %routinespec array ref(%integer mode)
// 2332 %routinespec operate(%integer n)
// 2333 %routinespec compare(%record(stackfm)%name l,r)
// 2334 %routinespec test zero(%record(stackfm)%name v)
// 2335 %integerfnspec new tag
// 2336
// 2337
// 2338 ! Actual code for Assemble is down around label NEXT
// 2339
// 2340
// 2341 ! >> DEFINE VAR <<
// 2342 %routine define var
void DEFINEVAR(void) {
// 2343 %integer type, form, tf, size, format, s, new, round, dimension
int TYPE;
int FORM;
int TF;
int SIZE;
int FORMAT;
int S;
int NEW;
int ROUND;
int DIMENSION;
// 2344 %integer dv; ! dope vector offset
int DV;
// 2345 %owninteger prim no = 0
static int PRIMNO = 0;
// 2346
// 2347 internal id = ""; new = 0; round = align
_imp_strncpy(/*?*/ &INTERNALID, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 255);
NEW = 0;
ROUND = 1;
// 2348
// 2349 ! Get the var index
// 2350 decl = read tag
DECL = READTAG();
// 2351 %if decl = 0 %start; ! RECORD FORMAT ELEMENT NAME
if (DECL != 0) goto L_0100;
// 2352 parms = parms-1; abort("Def Var Parms") %if parms <= names
PARMS = PARMS - 1;
if (PARMS > NAMES) goto L_0101;
ABORT(_imp_str_literal("Def Var Parms"));
L_0101:;
// 2353 decvar == var(parms)
DECVAR = (struct VARFM *)/*?*/ &VAR[PARMS];
// 2354 decvar = 0
*DECVAR = (struct VARFM){0};
// 2355 %else
goto L_0102;
L_0100:;
// 2356 abort("Def Var Names") %if decl >= parms
if (DECL < PARMS) goto L_0103;
ABORT(_imp_str_literal("Def Var Names"));
L_0103:;
// 2357 decvar == var(decl)
DECVAR = (struct VARFM *)/*?*/ &VAR[DECL];
// 2358 %if decl > names %start
if (DECL <= NAMES) goto L_0104;
// 2359 names = decl; new = 1
NAMES = DECL;
NEW = 1;
// 2360 decvar = 0
*DECVAR = (struct VARFM){0};
// 2361 %finish
L_0104:;
// 2362 %finish
L_0102:;
// 2363
// 2364 ! Now get the variable name
// 2365 %cycle
L_0105:;
// 2366 sym = next sym; read symbol(next sym); %exit %if sym = ','
SYM = NEXTSYM;
_imp_READSYMBOL(/*?*/ &NEXTSYM);
if (SYM != 44) goto L_0106;
goto L_0107;
L_0106:;
// 2367 %if length(internal id) # 255 %start
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &INTERNALID) == 255) goto L_0108;
// 2368 internal id = internal id.to string(sym)
_imp_strncpy(/*?*/ &INTERNALID, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &INTERNALID, ({
__typeof__(_imp_string1) tmp; /*E*/
tmp = _imp_TOSTRING(SYM);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 255);
// 2369 %finish
L_0108:;
// 2370 %repeat
goto L_0105;
L_0107:;
// 2371
// 2372 ! Now read the type and form word
// 2373 tf = read tag; read symbol(next sym)
TF = READTAG();
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2374 type = tf>>4; form = tf&15
TYPE = (unsigned int)TF >> 4;
FORM = TF & 15;
// 2375
// 2376 ! And get the size/format word
// 2377 size = read tag; read symbol(next sym)
SIZE = READTAG();
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2378
// 2379 ! Map external type numbers into internal equivalents,
// 2380 ! and adjust for short/byte/long things
// 2381 %if type = integer %and size # 1 %start; ! INTEGER
if (TYPE != 1) goto L_0109;
if (SIZE == 1) goto L_0109;
// 2382 type = byte %and round = 0 %if size = 2
if (SIZE != 2) goto L_010A;
TYPE = 5;
ROUND = 0;
L_010A:;
// 2383 size = vsize(type)
SIZE = VSIZE[TYPE];
// 2384 %else
goto L_010B;
L_0109:;
// 2385 %if type = real %start; ! REAL
if (TYPE != 2) goto L_010C;
// 2386 type = lreal %if size = 4; ! LONG REAL
if (SIZE != 4) goto L_010D;
TYPE = 6;
L_010D:;
// 2387 size = vsize(type)
SIZE = VSIZE[TYPE];
// 2388 %else
goto L_010E;
L_010C:;
// 2389 %if type = record %start; ! record
if (TYPE != 4) goto L_010F;
// 2390 format = size
FORMAT = SIZE;
// 2391 decvar_format = format
DECVAR->FORMAT = FORMAT;
// 2392 size = var(format)_size %if format <= names
if (FORMAT > NAMES) goto L_0110;
SIZE = VAR[FORMAT].SIZE;
L_0110:;
// 2393 %else
goto L_0111;
L_010F:;
// 2394 %if type = string %start; ! string
if (TYPE != 3) goto L_0112;
// 2395 round = 0
ROUND = 0;
// 2396 decvar_size = size
DECVAR->SIZE = SIZE;
// 2397 size = size + 1
SIZE = SIZE + 1;
// 2398 %else
goto L_0113;
L_0112:;
// 2399 size = vsize(type)
SIZE = VSIZE[TYPE];
// 2400 %finish
L_0113:;
// 2401 %finish
L_0111:;
// 2402 %finish
L_010E:;
// 2403 %finish
L_010B:;
// 2404
// 2405 decvar_size = size %if type # string
if (TYPE == 3) goto L_0114;
DECVAR->SIZE = SIZE;
L_0114:;
// 2406 decvar_type = type; decvar_form = form
DECVAR->TYPE = TYPE;
DECVAR->FORM = FORM;
// 2407
// 2408 ! Now read the Scope word
// 2409 otype = read tag
OTYPE = READTAG();
// 2410 spec = (otype>>3)&1; dimension = otype>>8&255; otype = otype&7
SPEC = (unsigned int)OTYPE >> 3 & 1;
DIMENSION = (unsigned int)OTYPE >> 8 & 255;
OTYPE = OTYPE & 7;
// 2411
// 2412 %if otype # 0 %start; ! Set external linkage name if appropriate
if (OTYPE == 0) goto L_0115;
// 2413 %if otype >= external %start
if (OTYPE < 3) goto L_0116;
// 2414 %if length(alias) # 0 %start
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &ALIAS) == 0) goto L_0117;
// 2415 external id = alias
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = ALIAS;
(void *)&tmp;
}),
/*max:*/ 255);
// 2416 %else
goto L_0118;
L_0117:;
// 2417 %if otype = system %start
if (OTYPE != 4) goto L_0119;
// 2418 external id = system prefix.internal id
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ &SYSTEMPREFIX, (_imp_string *)/*?*/ &INTERNALID);
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 255);
// 2419 %else
goto L_011A;
L_0119:;
// 2420 external id = "_".internal id
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("_"), (_imp_string *)/*?*/ &INTERNALID);
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 255);
// 2421 %finish
L_011A:;
// 2422 %finish
L_0118:;
// 2423 otype = external %if otype <= dynamic; !external, system, dynamic
if (OTYPE > 5) goto L_011B;
OTYPE = 3;
L_011B:;
// 2424 %finish
L_0116:;
// 2425 %finish
L_0115:;
// 2426 alias = ""
_imp_strncpy(/*?*/ &ALIAS, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 255);
// 2427
// 2428 %if 7 <= form %and form <= 10 %start; ! PROCEDURE
if (7 > FORM) goto L_011C;
if (FORM > 10) goto L_011C;
// 2429 block type = 1 + spec; ! 1 for normal proc, 2 for spec
BLOCKTYPE = 1 + SPEC;
// 2430 %if otype # 0 %and spec # 0 %start; ! external spec
if (OTYPE == 0) goto L_011D;
if (SPEC == 0) goto L_011D;
// 2431 %if otype = primrt %start
if (OTYPE != 6) goto L_011E;
// 2432 primno = primno + 1
PRIMNO = PRIMNO + 1;
// 2433 decvar_level = 128
DECVAR->LEVEL = 128;
// 2434 decvar_disp = prim no
DECVAR->DISP = PRIMNO;
// 2435 %return
return;
// 2436 %finish
L_011E:;
// 2437 decvar_disp = externalref(external id)
DECVAR->DISP = EXTERNALREF(
*({
__typeof__(_imp_string255) tmp = EXTERNALID /*q*/;
(_imp_string255 *)&tmp;
})
);
// 2438 decvar_level = 0
DECVAR->LEVEL = 0;
// 2439 decvar_scope = EXT
DECVAR->SCOPE = 80;
// 2440 %return
return;
// 2441 %finish
L_011D:;
// 2442
// 2443 %if in params = 0 %start; ! NOT A PARAMETER
if (INPARAMS != 0) goto L_011F;
// 2444 potype = otype
POTYPE = OTYPE;
// 2445 %if new # 0 %start; ! NEW NAME
if (NEW == 0) goto L_0120;
// 2446 decvar_disp = new tag; ! Procedure ID
DECVAR->DISP = NEWTAG();
// 2447 %finish
L_0120:;
// 2448 %return
return;
// 2449 %finish
L_011F:;
// 2450
// 2451 otype = 0; size = 2; data size = 2; ! procedure parameter
OTYPE = 0;
SIZE = 2;
DATASIZE = 2;
// 2452
// 2453 %else; ! This is not a procedure declaration
goto L_0121;
L_011C:;
// 2454
// 2455 data size = size
DATASIZE = SIZE;
// 2456
// 2457 %if form # 1 %start
if (FORM == 1) goto L_0122;
// 2458 Round = Align
ROUND = 1;
// 2459 %if type = general %start; ! General %name
if (TYPE != 0) goto L_0123;
// 2460 decvar_extra = in params; ! FOR LABELS
DECVAR->EXTRA = INPARAMS;
// 2461 size = 4
SIZE = 4;
// 2462 %else
goto L_0124;
L_0123:;
// 2463 %if form = array %or form = name array %start
if (FORM == 11) goto L_0125;
if (FORM != 13) goto L_0126;
L_0125:;
// 2464 ! We will fill in dimensions and allocate space when
// 2465 ! we are told the bounds later
// 2466 size = 0
SIZE = 0;
// 2467 data size = 2 %if form = name array
if (FORM != 13) goto L_0127;
DATASIZE = 2;
L_0127:;
// 2468 %else
goto L_0128;
L_0126:;
// 2469 %if form = array name %or form = name array name %start
if (FORM == 12) goto L_0129;
if (FORM != 14) goto L_012A;
L_0129:;
// 2470 decvar_dim = dimension
DECVAR->DIM = DIMENSION;
// 2471 size = 4; round = align; ! array header
SIZE = 4;
ROUND = 1;
// 2472 %else
goto L_012B;
L_012A:;
// 2473 size = 2; ! integer (etc) %name
SIZE = 2;
// 2474 %finish
L_012B:;
// 2475 %finish
L_0128:;
// 2476 %finish
L_0124:;
// 2477 %finish
L_0122:;
// 2478 %finish
L_0121:;
// 2479
// 2480 ! Now deal with OWN (or const/extern/etc) data items
// 2481
// 2482 %if otype # 0 %start; ! OWN DATA
if (OTYPE == 0) goto L_012C;
// 2483 %if otype = con %start; ! CONST INTEGER ETC.
if (OTYPE != 2) goto L_012D;
// 2484 data size = 0 %if type = string %and form = 1; ! use actual size for plain strings
if (TYPE != 3) goto L_012E;
if (FORM != 1) goto L_012E;
DATASIZE = 0;
L_012E:;
// 2485 %if form = 2 %or form = arrayname %or form = namearrayname %start
if (FORM == 2) goto L_012F;
if (FORM == 12) goto L_012F;
if (FORM != 14) goto L_0130;
L_012F:;
// 2486 otype = 0; ! Treat as special later
OTYPE = 0;
// 2487 %finish
L_0130:;
// 2488 %else; ! OWN, not CONST
goto L_0131;
L_012D:;
// 2489 gfix(round); ! so make it even if needed
GFIX(ROUND);
// 2490 %finish
L_0131:;
// 2491
// 2492 ! set globals used by our data collection utilities
// 2493 own type = type; own form = form
OWNTYPE = TYPE;
OWNFORM = FORM;
// 2494 own type = integer %and data size = 2 %if form = 2; ! %name's are really integers
if (FORM != 2) goto L_0132;
OWNTYPE = 1;
DATASIZE = 2;
L_0132:;
// 2495
// 2496 %if spec = 0 %start
if (SPEC != 0) goto L_0133;
// 2497 %if form = array %or form = name array %start
if (FORM == 11) goto L_0134;
if (FORM != 13) goto L_0135;
L_0134:;
// 2498 gfix(align)
GFIX(1);
// 2499 dv = set dope vector; ! N.B. changes vlb, vub
DV = SETDOPEVECTOR();
// 2500 ! We treat OWN and CONST arrays identically - both are in data segment
// 2501 gfix(align)
GFIX(1);
// 2502 decvar_disp = datatp - vlb; decvar_level = 0; decvar_scope = DATA
DECVAR->DISP = DATATP - VLB;
DECVAR->LEVEL = 0;
DECVAR->SCOPE = 16;
// 2503 decvar_pbase = dv; ! save the dope vector pointer here
DECVAR->PBASE = DV;
// 2504 decvar_dim = 1; ! own arrays are always 1-D
DECVAR->DIM = 1;
// 2505 fill external(DATA, decvar_disp, external id) %if otype = external
if (OTYPE != 3) goto L_0136;
FILLEXTERNAL(16, DECVAR->DISP,
*({
__typeof__(_imp_string255) tmp = EXTERNALID /*q*/;
(_imp_string255 *)&tmp;
})
);
L_0136:;
// 2506 %finish
L_0135:;
// 2507 %else
goto L_0137;
L_0133:;
// 2508 decvar_level = 0; decvar_scope = EXT
DECVAR->LEVEL = 0;
DECVAR->SCOPE = 80;
// 2509 decvar_disp = external ref(external id)
DECVAR->DISP = EXTERNALREF(
*({
__typeof__(_imp_string255) tmp = EXTERNALID /*q*/;
(_imp_string255 *)&tmp;
})
);
// 2510 %finish
L_0137:;
// 2511 %return
return;
// 2512 %finish
L_012C:;
// 2513
// 2514 %if form = 3 %start; !%label
if (FORM != 3) goto L_0138;
// 2515 decvar_disp = new tag
DECVAR->DISP = NEWTAG();
// 2516 %return
return;
// 2517 %finish
L_0138:;
// 2518
// 2519 %if form = switch %start
if (FORM != 6) goto L_0139;
// 2520 size = vub - vlb
SIZE = VUB - VLB;
// 2521 %if swtp + size > Max Switch %then abort("Switch Table Full")
if (SWTP + SIZE <= 1000) goto L_013A;
ABORT(_imp_str_literal("Switch Table Full"));
L_013A:;
// 2522 decvar_scope = SWT; decvar_disp = swtp - vlb
DECVAR->SCOPE = 96;
DECVAR->DISP = SWTP - VLB;
// 2523 decvar_extra = set dope vector
DECVAR->EXTRA = SETDOPEVECTOR();
// 2524 %for s = swtp, 1, swtp + size %cycle
// %for S = SWTP, 1, SWTP + SIZE %cycle
{
int _initial = SWTP, _final = SWTP + SIZE;
if (invalid_for_loop(_initial, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle S = SWTP, 1, SWTP + SIZE");
S = _initial - (1);
L_013B:
if (S == _final) goto L_013C;
S += 1;
// 2525 swtab(s) = 0; ! should really deal with undefined switch entries
SWTAB[S] = 0;
// 2526 %repeat
goto L_013B;
}
L_013C:;
// 2527 swtp = swtp + size + 1
SWTP = SWTP + SIZE + 1;
// 2528 %return
return;
// 2529 %finish
L_0139:;
// 2530
// 2531 %if form = record format %start
if (FORM != 4) goto L_013D;
// 2532 %if in params # 0 %start
if (INPARAMS == 0) goto L_013E;
// 2533 frame = decvar_size %if decvar_size > frame
if (DECVAR->SIZE <= FRAME) goto L_013F;
FRAME = DECVAR->SIZE;
L_013F:;
// 2534 %else
goto L_0140;
L_013E:;
// 2535 block type = -1; spec = -1
BLOCKTYPE = -1;
SPEC = -1;
// 2536 %finish
L_0140:;
// 2537 %return
return;
// 2538 %finish
L_013D:;
// 2539
// 2540 ! Here we've got an ordinary local variable, parameter or record entry
// 2541
// 2542 decvar_level = level
DECVAR->LEVEL = LEVEL;
// 2543 %if in params = 0 %start; ! local variable
if (INPARAMS != 0) goto L_0141;
// 2544 frame = (frame - size) & (\round)
FRAME = FRAME - SIZE & (~ROUND);
// 2545 decvar_disp = frame
DECVAR->DISP = FRAME;
// 2546 %else; ! parameter or record
goto L_0142;
L_0141:;
// 2547 %if block type > 0 %start; ! procedure parameters
if (BLOCKTYPE <= 0) goto L_0143;
// 2548 frame = (frame + size + 1) & (\1); ! parameters are always word aligned
FRAME = FRAME + SIZE + 1 & (~1);
// 2549 decvar_disp = frame; ! offset will be adjusted at '}'
DECVAR->DISP = FRAME;
// 2550 %else; ! records
goto L_0144;
L_0143:;
// 2551 frame = (frame + round) & (\round)
FRAME = FRAME + ROUND & (~ROUND);
// 2552 decvar_disp = frame
DECVAR->DISP = FRAME;
// 2553 frame = frame + size
FRAME = FRAME + SIZE;
// 2554 decvar_level = 0; ! no base register
DECVAR->LEVEL = 0;
// 2555 %finish
L_0144:;
// 2556 %finish
L_0142:;
// 2557 %end; ! define var
return;
} /* end of DEFINEVAR */
// 2558
// 2559
// 2560 !----------------------------------------------------------------------
// 2561 ! Stack manipulation routines
// 2562 !----------------------------------------------------------------------
// 2563
// 2564 ! >> POP STACK <<
// 2565 ! Pop the top of the stack
// 2566 %routine Pop Stack
void POPSTACK(void) {
// 2567 %if stp = 0 %then abort("Pop")
if (STP != 0) goto L_0145;
ABORT(_imp_str_literal("Pop"));
L_0145:;
// 2568 monitor(top, "Pop") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_0146;
MONITOR(TOP, _imp_str_literal_size(15, "Pop"));
L_0146:;
// 2569 stp = stp - 1
STP = STP - 1;
// 2570 %if stp # 0 %then top == stack(stp) %else top == null
if (STP == 0) goto L_0147;
TOP = (struct STACKFM *)/*?*/ &STACK[STP - 1];
goto L_0148;
L_0147:;
TOP = (struct STACKFM *)/*?*/ &NULL;
L_0148:;
// 2571 %end
return;
} /* end of POPSTACK */
// 2572
// 2573 ! >> POP REL <<
// 2574 ! Pop the top of the stack, and release its' register
// 2575 %routine pop rel
void POPREL(void) {
// 2576 release(top_base)
RELEASE(TOP->BASE);
// 2577 pop stack
POPSTACK();
// 2578 %end
return;
} /* end of POPREL */
// 2579
// 2580 ! >> PUSH VAR <<
// 2581 ! Push a descriptor on the stack corresponding to Var "var no"
// 2582 ! We map the variable form to a stack form, and assign a register
// 2583 ! for the base if it is non local. Finally, we absorb the scope
// 2584 ! into the base register.
// 2585 %routine push var(%integer var no)
void PUSHVAR(int VARNO) {
// 2586 %record(varfm)%name w
struct VARFM *W;
// 2587 %constbyteintegerarray fmap(0:15) = %c
const unsigned char FMAP[16] = {0, 4, 6, 10, 4, 0, 6, 0, 1, 4, 1, 4, 6, 4, 6, 0};
// 2588+ 0, 4, 6, 10, 4, 0,
// 2589+ ! 0, v in s, a in s, pgm label, recordformat, 0,
// 2590+ 6, 0, 1, 4, 1, 4, 6, 4, 6, 0
// 2591 ! switch, 0, v in r, v in s, v in r, v in s, a in s, v in s, a in s, 0
// 2592
// 2593 abort("Push Var Idx") %unless 0 <= var no %and var no <= max vars
if (0 > VARNO) goto L_00E6;
if (VARNO <= 600) goto L_0149;
L_00E6:;
ABORT(_imp_str_literal("Push Var Idx"));
L_0149:;
// 2594 w == var(varno)
W = (struct VARFM *)/*?*/ &VAR[VARNO];
// 2595 stp = stp + 1
STP = STP + 1;
// 2596 %if stp > Max Stack %then abort("Push V Stack Overflow")
if (STP <= 16) goto L_014A;
ABORT(_imp_str_literal("Push V Stack Overflow"));
L_014A:;
// 2597 top == stack(stp)
TOP = (struct STACKFM *)/*?*/ &STACK[STP - 1];
// 2598 top = 0
*TOP = (struct STACKFM){0};
// 2599
// 2600 ! Translate "level" into "base register" - if it is non local
// 2601 ! we flag it by adding 16 to the desired level, which later will
// 2602 ! force us to pick up a pointer register
// 2603 %if w_level # 0 %start
if (W->LEVEL == 0) goto L_014B;
// 2604 %if w_level = level %then top_base = BP %else top_base = w_level + 16
if (W->LEVEL != LEVEL) goto L_014C;
TOP->BASE = 6;
goto L_014D;
L_014C:;
TOP->BASE = W->LEVEL + 16;
L_014D:;
// 2605 %else
goto L_014E;
L_014B:;
// 2606 top_base = 0
TOP->BASE = 0;
// 2607 %finish
L_014E:;
// 2608
// 2609 top_scope = w_scope
TOP->SCOPE = W->SCOPE;
// 2610 top_type = w_type
TOP->TYPE = W->TYPE;
// 2611
// 2612 ! AFORM contains the real original declared form, while
// 2613 ! FORM contains the on-the-stack subset of possible forms
// 2614 top_aform = w_form
TOP->AFORM = W->FORM;
// 2615 top_form = fmap(w_form)
TOP->FORM = FMAP[W->FORM];
// 2616 top_dim = w_dim
TOP->DIM = W->DIM;
// 2617 top_disp = w_disp
TOP->DISP = W->DISP;
// 2618 top_scope = w_scope
TOP->SCOPE = W->SCOPE;
// 2619 top_format = w_format
TOP->FORMAT = W->FORMAT;
// 2620 top_size = w_size
TOP->SIZE = W->SIZE;
// 2621 top_extra = w_extra
TOP->EXTRA = W->EXTRA;
// 2622 top_pbase = w_pbase
TOP->PBASE = W->PBASE;
// 2623
// 2624 top_varno = varno
TOP->VARNO = VARNO;
// 2625 monitor(top, "Var stack") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_014F;
MONITOR(TOP, _imp_str_literal_size(15, "Var stack"));
L_014F:;
// 2626 %end
return;
} /* end of PUSHVAR */
// 2627
// 2628 ! >> PUSH COPY <<
// 2629 ! Push a duplicate of a stack record onto the stack
// 2630 %routine push copy(%record(stackfm)%name v)
void PUSHCOPY(struct STACKFM * V) {
// 2631 stp = stp + 1
STP = STP + 1;
// 2632 %if stp > Max Stack %then abort("Stack Const")
if (STP <= 16) goto L_0150;
ABORT(_imp_str_literal("Stack Const"));
L_0150:;
// 2633 top == stack(stp)
TOP = (struct STACKFM *)/*?*/ &STACK[STP - 1];
// 2634 top = v
*TOP = *V;
// 2635 monitor(top, "Stack Copy") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_0151;
MONITOR(TOP, _imp_str_literal_size(15, "Stack Copy"));
L_0151:;
// 2636 %end
return;
} /* end of PUSHCOPY */
// 2637
// 2638 ! >> PUSH CONST <<
// 2639 ! Push a constant on the stack
// 2640 %routine push const(%integer n)
void PUSHCONST(int N) {
// 2641 stp = stp + 1
STP = STP + 1;
// 2642 %if stp > Max Stack %then abort("Stack Const")
if (STP <= 16) goto L_0152;
ABORT(_imp_str_literal("Stack Const"));
L_0152:;
// 2643 top == stack(stp)
TOP = (struct STACKFM *)/*?*/ &STACK[STP - 1];
// 2644 top = 0
*TOP = (struct STACKFM){0};
// 2645 top_disp = n
TOP->DISP = N;
// 2646 top_type = integer
TOP->TYPE = 1;
// 2647 top_form = constant
TOP->FORM = 0;
// 2648 monitor(top, "push const") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_0153;
MONITOR(TOP, _imp_str_literal_size(15, "push const"));
L_0153:;
// 2649 %end
return;
} /* end of PUSHCONST */
// 2650
// 2651 !-----------------------------------------------------------------------
// 2652 !STRING PROCESSING
// 2653 !-----------------------------------------------------------------------
// 2654
// 2655 ! >> DUMP STRING <<
// 2656 ! writes the latest received string (in Current String) to
// 2657 ! either const or data segment (depending on SIZE). Returns
// 2658 ! the offset in that segment of the string. The size of space
// 2659 ! to reserve is in SIZE. In the special case where SIZE is zero
// 2660 ! this is a fixed constant string and can be re-used in the
// 2661 ! constant table, otherwise we put it in the data segment
// 2662 %integerfn dump string(%integer size)
int DUMPSTRING(int SIZE) {
// 2663 %integer j, p
int J;
int P;
// 2664
// 2665 %if size = 0 %start; ! Fixed constant string
if (SIZE != 0) goto L_0154;
// 2666 %result = getcots(current string)
return GETCOTS(CURRENTSTRING);
// 2667 %finish
L_0154:;
// 2668
// 2669 ! check for overflow
// 2670 %if cslen+1 > size %start
if (*CSLEN + 1 <= SIZE) goto L_0155;
// 2671 ! String constant too long - warn and truncate
// 2672 warn(5); current string(0) = size-1
WARN(5);
CURRENTSTRING[0] = SIZE - 1;
// 2673 %finish
L_0155:;
// 2674
// 2675 p = datatp
P = DATATP;
// 2676 %for j = 0,1,size-1 %cycle
// %for J = 0, 1, SIZE - 1 %cycle
{
int _final = SIZE - 1;
if (invalid_for_loop(0, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 0, 1, SIZE - 1");
J = -1;
L_0156:
if (J == _final) goto L_0157;
J += 1;
// 2677 gbyte(current string(j))
GBYTE(CURRENTSTRING[J]);
// 2678 %repeat
goto L_0156;
}
L_0157:;
// 2679 %result = p
return P;
// 2680 %end
} /* end of DUMPSTRING */
// 2681
// 2682 ! >> GET STRING <<
// 2683 ! Read a string literal from the iCode stream
// 2684 %routine get string
void GETSTRING(void) {
// 2685 %integer l
int L;
// 2686 l = next sym; !length
L = NEXTSYM;
// 2687 cslen = 0
*CSLEN = 0;
// 2688 %while l > 0 %cycle
L_0159:;
if (L <= 0) goto L_015A;
// 2689 l = l-1
L = L - 1;
// 2690 read symbol(next sym)
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2691 cslen = (cslen+1)&255; current string(cslen) = next sym
*CSLEN = *CSLEN + 1 & 255;
CURRENTSTRING[*CSLEN] = NEXTSYM;
// 2692 %repeat
goto L_0159;
L_015A:;
// 2693
// 2694 ! if this is about to be used as a literal, put it straight into
// 2695 ! the CONST segment and stack it, otherwise leave it in curr string to see
// 2696 ! what comes next and stack a dummy zero
// 2697 readsymbol(next sym)
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 2698 %if next sym # 'A' %and next sym # '$' %start
if (NEXTSYM == 65) goto L_015B;
if (NEXTSYM == 36) goto L_015B;
// 2699 otype = con; ! anonymous %const
OTYPE = 2;
// 2700 push const(dump string(0)); top_type = string
PUSHCONST(DUMPSTRING(0));
TOP->TYPE = 3;
// 2701 top_base = 0; top_scope = COT; top_form = VinS; top_format = cslen+1
TOP->BASE = 0;
TOP->SCOPE = 32;
TOP->FORM = 4;
TOP->FORMAT = *CSLEN + 1;
// 2702 %else
goto L_015C;
L_015B:;
// 2703 push const(0); ! explicit string initialisation coming next
PUSHCONST(0);
// 2704 %finish
L_015C:;
// 2705 %end
return;
} /* end of GETSTRING */
// 2706
// 2707 ! >> REAL CONSTANT <<
// 2708 ! Put the current rvalue in the constant table, return the offset
// 2709 %integerfn real constant
int REALCONSTANT(void) {
// 2710 %integer w1, w2, w3, w4
int W1;
int W2;
int W3;
int W4;
// 2711
// 2712 ! Warning - this is horribly non-portable, and relies on this
// 2713 ! being a native compiler. For cross-compiling, think again!
// 2714 ! It's also a wee bit messy 'cos we've redefined the word INTEGER
// 2715 ! so we can't use the built-in map!
// 2716 w1 = byteinteger(addr(rvalue)) ! byteinteger(addr(rvalue)+1)<<8
W1 = *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE)) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 1) << 8;
// 2717 w2 = byteinteger(addr(rvalue)+2) ! byteinteger(addr(rvalue)+3)<<8
W2 = *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 2) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 3) << 8;
// 2718 w3 = byteinteger(addr(rvalue)+4) ! byteinteger(addr(rvalue)+5)<<8
W3 = *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 4) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 5) << 8;
// 2719 w4 = byteinteger(addr(rvalue)+6) ! byteinteger(addr(rvalue)+7)<<8
W4 = *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 6) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 7) << 8;
// 2720
// 2721 %result = getcot4(w1, w2, w3, w4)
return GETCOT4(W1, W2, W3, W4);
// 2722 %end; ! real constant
} /* end of REALCONSTANT */
// 2723
// 2724 !-------------------------------------------------------
// 2725 !LABEL PROCESSING
// 2726 !
// 2727 ! Labels fixups are handled by pass 3 - we just plant
// 2728 ! numerical labels for code locations, and then jump to or call
// 2729 ! those labels. Pass 3 turns them into real locations.
// 2730 ! Unfortunately Pass 3 needs unique label numbers whereas
// 2731 ! Pass 1 produces lame local label numbers that can
// 2732 ! be reused once they've been defined. We therefore
// 2733 ! maintain an indirect database to map Pass 1 label numbers
// 2734 ! into unique tags
// 2735
// 2736 ! >> NEW TAG <<
// 2737 ! Get the next consecutive Pass 3 label ID
// 2738 %integerfn new tag
int NEWTAG(void) {
// 2739 %owninteger free tag = 999
static int FREETAG = 999;
// 2740
// 2741 free tag = free tag + 1
FREETAG = FREETAG + 1;
// 2742 %result = free tag
return FREETAG;
// 2743 %end
} /* end of NEWTAG */
// 2744
// 2745 ! >> NEW LABEL <<
// 2746 ! Get the next available label database index
// 2747 %integerfn New Label
int NEWLABEL(void) {
// 2748 labs = labs+1; abort("Labels") %if labs > Max Labs
LABS = LABS + 1;
if (LABS <= 50) goto L_015D;
ABORT(_imp_str_literal("Labels"));
L_015D:;
// 2749 %result = labs
return LABS;
// 2750 %end
} /* end of NEWLABEL */
// 2751
// 2752 ! >> FIND LABEL<<
// 2753 ! return the index in our label table of the Pass 1 label
// 2754 %integerfn Find Label(%integer label)
int FINDLABEL(int LABEL) {
// 2755 %integer lp
int LP;
// 2756
// 2757 lp = labs
LP = LABS;
// 2758 %while lp # first label %cycle
L_015E:;
if (LP == FIRSTLABEL) goto L_015F;
// 2759 %result = lp %if labels(lp)_id = label
if (LABELS[LP - 1].ID != LABEL) goto L_0160;
return LP;
L_0160:;
// 2760 lp = lp-1
LP = LP - 1;
// 2761 %repeat
goto L_015E;
L_015F:;
// 2762 %result = 0
return 0;
// 2763 %end
} /* end of FINDLABEL */
// 2764
// 2765 ! >> DEFINE LABEL <<
// 2766 ! This label is "here"
// 2767 %routine Define Label(%integer label)
void DEFINELABEL(int LABEL) {
// 2768 %integer lp
int LP;
// 2769 %record(labelfm)%name l
struct LABELFM *L;
// 2770
// 2771 lp = Find Label(label)
LP = FINDLABEL(LABEL);
// 2772 %if lp = 0 %start; ! Not yet been used
if (LP != 0) goto L_0161;
// 2773 lp = New Label
LP = NEWLABEL();
// 2774 l == labels(lp)
L = (struct LABELFM *)/*?*/ &LABELS[LP - 1];
// 2775 l_id = label
L->ID = LABEL;
// 2776 l_tag = new tag
L->TAG = NEWTAG();
// 2777 %else
goto L_0162;
L_0161:;
// 2778 l == labels(lp)
L = (struct LABELFM *)/*?*/ &LABELS[LP - 1];
// 2779 %if l_tag & 16_8000 # 0 %and label > 0 %then l_tag = new tag
if (L->TAG & 32768 == 0) goto L_0163;
if (LABEL <= 0) goto L_0163;
L->TAG = NEWTAG();
L_0163:;
// 2780 %finish
L_0162:;
// 2781
// 2782 dump label(l_tag)
DUMPLABEL(L->TAG);
// 2783 l_tag = l_tag ! 16_8000
L->TAG = L->TAG | 32768;
// 2784 uncond jump = 0; ! You can get here
UNCONDJUMP = 0;
// 2785 %end; ! define label
return;
} /* end of DEFINELABEL */
// 2786
// 2787 ! >> JUMP TO <<
// 2788 ! A wrapper for conditional jumps to labels that we're going
// 2789 ! to map into tags
// 2790 %routine Jump To(%integer label, op, flag)
void JUMPTO(int LABEL, int OP, int FLAG) {
// 2791 %record(labelfm)%name l
struct LABELFM *L;
// 2792 %integer lp
int LP;
// 2793
// 2794 lp = Find Label(label)
LP = FINDLABEL(LABEL);
// 2795 %if lp = 0 %start
if (LP != 0) goto L_0164;
// 2796 lp = New Label
LP = NEWLABEL();
// 2797 l == labels(lp)
L = (struct LABELFM *)/*?*/ &LABELS[LP - 1];
// 2798 l_id = label
L->ID = LABEL;
// 2799 l_tag = new tag
L->TAG = NEWTAG();
// 2800 %else
goto L_0165;
L_0164:;
// 2801 l == labels(lp)
L = (struct LABELFM *)/*?*/ &LABELS[LP - 1];
// 2802 %if flag # 0 %and l_tag & 16_8000 # 0 %then l_tag = new tag
if (FLAG == 0) goto L_0166;
if (L->TAG & 32768 == 0) goto L_0166;
L->TAG = NEWTAG();
L_0166:;
// 2803 %finish
L_0165:;
// 2804
// 2805 dump jump(op, l_tag & 16_7FFF)
DUMPJUMP(OP, L->TAG & 32767);
// 2806
// 2807 %if op = JMP %then uncond jump = nextcad
if (OP != 35) goto L_0167;
UNCONDJUMP = NEXTCAD;
L_0167:;
// 2808 %end; ! jump to
return;
} /* end of JUMPTO */
// 2809
// 2810
// 2811 !-------------------------------------------------------
// 2812 ! Stack variable transformations
// 2813 !-------------------------------------------------------
// 2814
// 2815 ! >> REDUCE <<
// 2816 ! Convert a variable which is addressed in a Rec into a simple variable
// 2817 ! by loading the indirect value into a register and changing the form
// 2818 %routine reduce(%record(stackfm)%name v)
void REDUCE(struct STACKFM * V) {
// 2819 %integer type, form, disp, scope
int TYPE;
int FORM;
int DISP;
int SCOPE;
// 2820
// 2821 form = v_form - 3; ! X in REC => X in S
FORM = V->FORM - 3;
// 2822 type = v_type
TYPE = V->TYPE;
// 2823 disp = v_disp
DISP = V->DISP;
// 2824 ! Here's a trick - we've got two displacements, DISP and EXTRA, but only
// 2825 ! one SCOPE hint. Which does it belong to? If the REC form came from
// 2826 ! a HAZARD then the scope belongs to the DISP, but for all other cases
// 2827 ! the scope belongs to the EXTRA. If we got here through HAZARD then
// 2828 ! the BASE will be BP - for all other cases it will be either a different
// 2829 ! register, or zero.
// 2830 %if v_base = BP %start
if (V->BASE != 6) goto L_0168;
// 2831 scope = v_scope
SCOPE = V->SCOPE;
// 2832 v_scope = 0
V->SCOPE = 0;
// 2833 %else
goto L_0169;
L_0168:;
// 2834 scope = 0
SCOPE = 0;
// 2835 %finish
L_0169:;
// 2836 v_disp = v_extra; v_type = integer; v_form = v in s
V->DISP = V->EXTRA;
V->TYPE = 1;
V->FORM = 4;
// 2837 load(v, anyp)
LOAD(V, 27);
// 2838 v_type = type; v_form = form
V->TYPE = TYPE;
V->FORM = FORM;
// 2839 v_disp = disp; v_scope = scope
V->DISP = DISP;
V->SCOPE = SCOPE;
// 2840 %end
return;
} /* end of REDUCE */
// 2841
// 2842 ! >> AMAP <<
// 2843 ! convert V into a descriptor for the address of V
// 2844 %routine amap(%record(stackfm)%name v)
void AMAP(struct STACKFM * V) {
// 2845 %integer f
int F;
// 2846 %constintegerarray addr map(0:15) =
const int ADDRMAP[16] = {-1, -2, -3, -4, 5, -5, 4, 8, -6, 7, -7, -8, -9, -10, -11, -12};
// 2847+ -1, -2, -3, -4, 5, -5, 4, 8, -6, 7,
// 2848+ ! -1, -2, -3, -4, av in s, -5, v in s, av in rec, -6, v in rec,
// 2849+ -7, -8, -9, -10, -11 , -12
// 2850 ! -7, -8, -9, -10, -11 {PGM LABEL}, -12 {record format}
// 2851
// 2852 ! ABD - should be code here to deal with ADDR(pgm label)
// 2853
// 2854 f = addr map(v_form)
F = ADDRMAP[V->FORM];
// 2855 %if f < 0 %start
if (F >= 0) goto L_016A;
// 2856 monitor(v, "AMAP target")
MONITOR(V, _imp_str_literal_size(15, "AMAP target"));
// 2857 abort("AMAP")
ABORT(_imp_str_literal("AMAP"));
// 2858 %finish
L_016A:;
// 2859
// 2860 ! Try to simplify some forms...
// 2861 %if v_disp = 0 %and v_scope = 0 %start
if (V->DISP != 0) goto L_016B;
if (V->SCOPE != 0) goto L_016B;
// 2862 %if f = AVinS %start
if (F != 5) goto L_016C;
// 2863 %if v_base = 0 %then f = constant %else f = VinR
if (V->BASE != 0) goto L_016D;
F = 0;
goto L_016E;
L_016D:;
F = 1;
L_016E:;
// 2864 %else
goto L_016F;
L_016C:;
// 2865 %if (f = VinREC %or f = AVinREC) %start; ! eliminate redundant LOAD
if (F == 7) goto L_0170;
if (F != 8) goto L_0171;
L_0170:;
// 2866 %if f = VinREC %then f = AinS %else f = VinS
if (F != 7) goto L_0172;
F = 6;
goto L_0173;
L_0172:;
F = 4;
L_0173:;
// 2867 v_disp = v_extra
V->DISP = V->EXTRA;
// 2868 %finish
L_0171:;
// 2869 %finish
L_016F:;
// 2870 %finish
L_016B:;
// 2871 v_type = integer
V->TYPE = 1;
// 2872 v_form = f
V->FORM = F;
// 2873 %end
return;
} /* end of AMAP */
// 2874
// 2875 ! >> VMAP <<
// 2876 ! The inverse of AMAP: i.e. vmap(amap(x)) => x
// 2877 %routine vmap(%record(stackfm)%name v)
void VMAP(struct STACKFM * V) {
// 2878 %integer f, t
int F;
int T;
// 2879 %constintegerarray var map(0:8) =
const int VARMAP[9] = {4, 4, -1, -2, 6, 4, -3, 9, 7};
// 2880+ 4, 4, -1, -2, 6, 4, -3, 9, 7
// 2881 ! v in s, v in s, -1, -2, a in s, v in s, -3, a in rec, v in rec
// 2882
// 2883 %if v_form = a in s %or v_form = a in rec %start
if (V->FORM == 6) goto L_0158;
if (V->FORM != 9) goto L_0174;
L_0158:;
// 2884 t = v_type
T = V->TYPE;
// 2885 amap(v)
AMAP(V);
// 2886 load(v,anyp)
LOAD(V, 27);
// 2887 v_type = t; v_form = VinS
V->TYPE = T;
V->FORM = 4;
// 2888 %finish
L_0174:;
// 2889 f = var map(v_form); abort("VMap") %if f < 0
F = VARMAP[V->FORM];
if (F >= 0) goto L_0175;
ABORT(_imp_str_literal("VMap"));
L_0175:;
// 2890 v_form = f
V->FORM = F;
// 2891 %end; ! v map
return;
} /* end of VMAP */
// 2892
// 2893 ! >> ADDRESS <<
// 2894 ! convert V into a form in which it is directly addressable
// 2895 ! that means either V in R, V in S or Constant
// 2896 %routine address(%record(stackfm)%name v)
void ADDRESS(struct STACKFM * V) {
// 2897 %integer type, form, r
int TYPE;
int FORM;
int R;
// 2898
// 2899 monitor(v, "ADDRESS") %if diagnose&2 # 0
if (DIAGNOSE & 2 == 0) goto L_0176;
MONITOR(V, _imp_str_literal_size(15, "ADDRESS"));
L_0176:;
// 2900
// 2901 form = v_form; type = v_type
FORM = V->FORM;
TYPE = V->TYPE;
// 2902 %if form >= V in REC %start
if (FORM < 7) goto L_0177;
// 2903 reduce(v); form = v_form
REDUCE(V);
FORM = V->FORM;
// 2904 %finish
L_0177:;
// 2905
// 2906 ! Now pick up a base register if we needed one...
// 2907 %if v_base > 16 %start
if (V->BASE <= 16) goto L_0178;
// 2908 v_base = get display(v_base - 16)
V->BASE = GETDISPLAY(V->BASE - 16);
// 2909 claim(v_base)
CLAIM(V->BASE);
// 2910 %finish
L_0178:;
// 2911
// 2912 %return %if form = V in R %or form = constant
if (FORM == 1) goto L_0179;
if (FORM != 0) goto L_017A;
L_0179:;
return;
L_017A:;
// 2913
// 2914 %if form = AV in S %start
if (FORM != 5) goto L_017B;
// 2915 %if v_base = 0 %start
if (V->BASE != 0) goto L_017C;
// 2916 v_form = constant
V->FORM = 0;
// 2917 %else
goto L_017D;
L_017C:;
// 2918 %if v_disp = 0 %and v_scope = 0 %start
if (V->DISP != 0) goto L_017E;
if (V->SCOPE != 0) goto L_017E;
// 2919 v_form = V in R
V->FORM = 1;
// 2920 %else
goto L_017F;
L_017E:;
// 2921 load(v, any)
LOAD(V, 25);
// 2922 %finish
L_017F:;
// 2923 %finish
L_017D:;
// 2924 %return
return;
// 2925 %finish
L_017B:;
// 2926
// 2927 ! It is possible to end up with an in-store form, but the
// 2928 ! base register isn't one that can be used in an address...
// 2929 %if v_base # 0 %and v_base < BX %start
if (V->BASE == 0) goto L_0180;
if (V->BASE >= 4) goto L_0180;
// 2930 r = PT Reg; claim(r)
R = PTREG();
CLAIM(R);
// 2931 dumprr(MOV, r, v_base); release(v_base)
DUMPRR(11, R, V->BASE);
RELEASE(V->BASE);
// 2932 v_base = r
V->BASE = R;
// 2933 %finish
L_0180:;
// 2934
// 2935 %return %if form = V in S
if (FORM != 4) goto L_0181;
return;
L_0181:;
// 2936
// 2937 %if form = A in S %start
if (FORM != 6) goto L_0182;
// 2938 v_form = V in S; v_type = integer
V->FORM = 4;
V->TYPE = 1;
// 2939 load(v,anyp)
LOAD(V, 27);
// 2940 v_type = type; v_form = V in S; v_disp = 0
V->TYPE = TYPE;
V->FORM = 4;
V->DISP = 0;
// 2941 %finish
L_0182:;
// 2942 %end; ! address
return;
} /* end of ADDRESS */
// 2943
// 2944 ! >> LOAD <<
// 2945 ! Load variable V into register R
// 2946 ! Along the way any register the variable owned is released, and
// 2947 ! the new register is claimed.
// 2948 %routine Load(%record(stackfm)%name v, %integer r)
void LOAD(struct STACKFM * V, int R) {
// 2949 %switch f(0:9)
int F_index;
int F_line;
char *F_file;
static const void *F[10] = {&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing,
&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing,
&&case_F_missing, &&case_F_missing};
// 2950 %integer ptr, op
int PTR;
int OP;
// 2951
// 2952 monitor(v, "LOAD") %if diagnose&2 # 0
if (DIAGNOSE & 2 == 0) goto L_0183;
MONITOR(V, _imp_str_literal_size(15, "LOAD"));
L_0183:;
// 2953
// 2954 %if r = anyf %then ->reals
if (R != 28) goto L_0184;
goto U_100B;
L_0184:;
// 2955
// 2956 ! If the request is one of the variations on "any" then we need
// 2957 ! to first allocate a target register. First, we make a local
// 2958 ! adjustment because we can't load bytes into "any" register,
// 2959 ! only into the GP registers...
// 2960 %if v_type = byte %start
if (V->TYPE != 5) goto L_0185;
// 2961 %if r = any %then r = anyg
if (R != 25) goto L_0186;
R = 26;
L_0186:;
// 2962 ! What's more, there is only one register that is both a pointer
// 2963 ! and a legal byte destination
// 2964 %if r = anyp %then r = BX
if (R != 27) goto L_0187;
R = 4;
L_0187:;
// 2965 %finish
L_0185:;
// 2966
// 2967 ! We also map the virtual display into a real register if we
// 2968 ! need to. Also, it is possible that an in-store form may
// 2969 ! be derived from a non-pointer register, so we fix that too.
// 2970 %if v_base > 16 %then %start
if (V->BASE <= 16) goto L_0188;
// 2971 v_base = get display(v_base - 16)
V->BASE = GETDISPLAY(V->BASE - 16);
// 2972 claim(v_base)
CLAIM(V->BASE);
// 2973 %else
goto L_0189;
L_0188:;
// 2974 %if v_base # 0 %and v_base < BX %and v_form >= V in S %start
if (V->BASE == 0) goto L_018A;
if (V->BASE >= 4) goto L_018A;
if (V->FORM < 4) goto L_018A;
// 2975 ptr = pt reg
PTR = PTREG();
// 2976 dumprr(MOV, ptr, v_base)
DUMPRR(11, PTR, V->BASE);
// 2977 claim(ptr); release(v_base)
CLAIM(PTR);
RELEASE(V->BASE);
// 2978 v_base = ptr
V->BASE = PTR;
// 2979 %finish
L_018A:;
// 2980 %finish
L_0189:;
// 2981
// 2982 ! Now go ahead and allocate a register
// 2983 %if r = any %then %start
if (R != 25) goto L_018B;
// 2984 ! If we've got a base, it's not in use by anyone else, and isn't a display register, use it
// 2985 %if v_base # 0 %and activity(v_base) = 1 %and displayhint(v_base) = 0 %start
if (V->BASE == 0) goto L_018C;
if (ACTIVITY[V->BASE] != 1) goto L_018C;
if (DISPLAYHINT[V->BASE - 1] != 0) goto L_018C;
// 2986 r = v_base
R = V->BASE;
// 2987 %else
goto L_018D;
L_018C:;
// 2988 r = gp reg
R = GPREG();
// 2989 %finish
L_018D:;
// 2990 %else
goto L_018E;
L_018B:;
// 2991 %if r = anyg %then %start
if (R != 26) goto L_018F;
// 2992 %if 0 < v_base %and v_base <= BX %and activity(v_base) = 1 %start
if (0 >= V->BASE) goto L_0190;
if (V->BASE > 4) goto L_0190;
if (ACTIVITY[V->BASE] != 1) goto L_0190;
// 2993 r = v_base
R = V->BASE;
// 2994 %else
goto L_0191;
L_0190:;
// 2995 r = gp reg
R = GPREG();
// 2996 %finish
L_0191:;
// 2997 %else
goto L_0192;
L_018F:;
// 2998 %if r = anyp %then %start
if (R != 27) goto L_0193;
// 2999 %if activity(v_base) = 1 %and (v_base = BX %or v_base = SI %or v_base = DI) %then %start
if (ACTIVITY[V->BASE] != 1) goto L_0194;
if (V->BASE == 4) goto L_0195;
if (V->BASE == 7) goto L_0195;
if (V->BASE != 8) goto L_0194;
L_0195:;
// 3000 r = v_base
R = V->BASE;
// 3001 %else
goto L_0196;
L_0194:;
// 3002 r = pt reg
R = PTREG();
// 3003 %finish
L_0196:;
// 3004 %else
goto L_0197;
L_0193:;
// 3005 %if v_base = r %start
if (V->BASE != R) goto L_0198;
// 3006 %if activity(r) > 1 %start; ! protect other uses
if (ACTIVITY[R] <= 1) goto L_0199;
// 3007 release(r); v_base = 0; ! Hide my ownership for the moment
RELEASE(R);
V->BASE = 0;
// 3008 hazard(r); ! Zap everybody else
HAZARD(R);
// 3009 claim(r); v_base = r; ! Get it back
CLAIM(R);
V->BASE = R;
// 3010 %finish
L_0199:;
// 3011 %else
goto L_019A;
L_0198:;
// 3012 hazard(r)
HAZARD(R);
// 3013 %finish
L_019A:;
// 3014 %finish
L_0197:;
// 3015 %finish
L_0192:;
// 3016 %finish
L_018E:;
// 3017 -> f(v_form)
F_line = __LINE__;
F_file = __FILE__;
F_index = V->FORM;
goto case_F_dispatch;
// 3018
// 3019 f(constant):
case_F_0:;
// 3020 ldconst:
U_100C:;
// 3021 %if v_disp = 0 %and v_scope = 0 %start
if (V->DISP != 0) goto L_019C;
if (V->SCOPE != 0) goto L_019C;
// 3022 dumprr(XOR, r, r)
DUMPRR(19, R, R);
// 3023 %else
goto L_019D;
L_019C:;
// 3024 dumprioffset(MOV, r, v_scope, v_disp)
DUMPRIOFFSET(11, R, V->SCOPE, V->DISP);
// 3025 %finish
L_019D:;
// 3026 setup:v_base = r
U_100D:;
V->BASE = R;
// 3027 v_disp = 0
V->DISP = 0;
// 3028 v_scope = 0
V->SCOPE = 0;
// 3029 v_form = v in r
V->FORM = 1;
// 3030 claim(r)
CLAIM(R);
// 3031 %return
return;
// 3032
// 3033 f(v in r):
case_F_1:;
// 3034 %return %if v_base = r
if (V->BASE != R) goto L_019E;
return;
L_019E:;
// 3035 dumprr(MOV, r, v_base)
DUMPRR(11, R, V->BASE);
// 3036 release(v_base)
RELEASE(V->BASE);
// 3037 -> setup
goto U_100D;
// 3038
// 3039 f(av in r):
case_F_2:;
// 3040 f(a in r):
case_F_3:;
// 3041 Abort("Unexpected Stack Form")
ABORT(_imp_str_literal("Unexpected Stack Form"));
// 3042
// 3043 f(a in s):
case_F_6:;
// 3044 ! is the register a pointer?
// 3045 %if r = BX %or r = SI %or r = DI %start
if (R == 4) goto L_019F;
if (R == 7) goto L_019F;
if (R != 8) goto L_01A0;
L_019F:;
// 3046 ptr = r
PTR = R;
// 3047 %else
goto L_01A1;
L_01A0:;
// 3048 ptr = pt reg
PTR = PTREG();
// 3049 %finish
L_01A1:;
// 3050 dumprm(MOV, ptr, v_base!v_scope, v_disp)
DUMPRM(11, PTR, V->BASE | V->SCOPE, V->DISP);
// 3051 release(v_base); claim(ptr)
RELEASE(V->BASE);
CLAIM(PTR);
// 3052 v_base = ptr
V->BASE = PTR;
// 3053 v_disp = 0
V->DISP = 0;
// 3054 v_scope = 0
V->SCOPE = 0;
// 3055 ! fall through to normal V in S
// 3056
// 3057 f(v in s):
case_F_4:;
// 3058 %if v_type = integer %start
if (V->TYPE != 1) goto L_01A2;
// 3059 dumprm(MOV, r, v_base!v_scope, v_disp)
DUMPRM(11, R, V->BASE | V->SCOPE, V->DISP);
// 3060 %else
goto L_01A3;
L_01A2:;
// 3061 %if v_type = byte %start
if (V->TYPE != 5) goto L_01A4;
// 3062 dumprm8(MOV, r+16, v_base!v_scope, v_disp)
DUMPRM8(11, R + 16, V->BASE | V->SCOPE, V->DISP);
// 3063 dumprr8(XOR, r+20, r+20)
DUMPRR8(19, R + 20, R + 20);
// 3064 v_type = integer
V->TYPE = 1;
// 3065 %else; ! reals
goto L_01A5;
L_01A4:;
// 3066 abort("Load Real")
ABORT(_imp_str_literal("Load Real"));
// 3067 %finish
L_01A5:;
// 3068 %finish
L_01A3:;
// 3069 release(v_base)
RELEASE(V->BASE);
// 3070 ->setup
goto U_100D;
// 3071
// 3072 f(av in s):
case_F_5:;
// 3073 %if v_base # 0 %start
if (V->BASE == 0) goto L_01A6;
// 3074 dumprm(LEA, r, v_base!v_scope, v_disp)
DUMPRM(10, R, V->BASE | V->SCOPE, V->DISP);
// 3075 release(v_base)
RELEASE(V->BASE);
// 3076 v_type = integer
V->TYPE = 1;
// 3077 ->setup
goto U_100D;
// 3078 %finish
L_01A6:;
// 3079 ! else
// 3080 ->ldconst
goto U_100C;
// 3081
// 3082 f(v in rec):
case_F_7:;
// 3083 f(av in rec):
case_F_8:;
// 3084 f(a in rec):
case_F_9:;
// 3085 reduce(v)
REDUCE(V);
// 3086 ->f(v_form)
F_line = __LINE__;
F_file = __FILE__;
F_index = V->FORM;
goto case_F_dispatch;
// 3087
// 3088 ! Equivalents for real numbers...
// 3089
// 3090 reals:; ! because there's very little clever we can do, we first
U_100B:;
// 3091 ! simplify somewhat...
// 3092 Address(v)
ADDRESS(V);
// 3093
// 3094 ! Now it's either Constant, V in R or V in S - we now turn them
// 3095 ! all into V in S - the only thing we can load
// 3096
// 3097 ! Start with one we have no instructions for, and promote it to
// 3098 ! something we know how to handle...
// 3099 %if v_type = byte %then load(v, any)
if (V->TYPE != 5) goto L_01A7;
LOAD(V, 25);
L_01A7:;
// 3100
// 3101 %if v_form = V in R %start
if (V->FORM != 1) goto L_01A8;
// 3102 %return %if v_base >= FR0
if (V->BASE < 9) goto L_01A9;
return;
L_01A9:;
// 3103 ! This must be an integer in a CPU register - we need to store it
// 3104 ! before we can use it
// 3105 v_disp = getwork(2)
V->DISP = GETWORK(2);
// 3106 dumpmr(MOV, BP, v_disp, v_base)
DUMPMR(11, 6, V->DISP, V->BASE);
// 3107 release(v_base)
RELEASE(V->BASE);
// 3108 v_base = BP
V->BASE = 6;
// 3109 v_scope = 0
V->SCOPE = 0;
// 3110 v_form = V in S
V->FORM = 4;
// 3111 ! Now it looks like an integer V in S
// 3112 %finish
L_01A8:;
// 3113
// 3114 %if v_form = constant %start; ! This is an integer constant
if (V->FORM != 0) goto L_01AA;
// 3115 %if v_disp = 0 %start; ! We have a special instruction for zero
if (V->DISP != 0) goto L_01AB;
// 3116 r = FR0 + FPU Stack
R = 9 + FPUSTACK;
// 3117 dumpflopspec(FLDZ)
DUMPFLOPSPEC(52);
// 3118 -> set up real
goto U_100E;
// 3119 %finish
L_01AB:;
// 3120 ! Otherwise, we need it in store
// 3121 v_disp = getcotw(v_disp)
V->DISP = GETCOTW(V->DISP);
// 3122 v_form = V in S
V->FORM = 4;
// 3123 v_base = 0
V->BASE = 0;
// 3124 v_scope = COT
V->SCOPE = 32;
// 3125 %finish
L_01AA:;
// 3126
// 3127 ! Now everything that's left is a V in S
// 3128
// 3129 %if v_type = integer %start
if (V->TYPE != 1) goto L_01AC;
// 3130 op = FILD
OP = 36;
// 3131 %else
goto L_01AD;
L_01AC:;
// 3132 %if v_type = real %start
if (V->TYPE != 2) goto L_01AE;
// 3133 op = FLDD
OP = 37;
// 3134 %else
goto L_01AF;
L_01AE:;
// 3135 op = FLDQ
OP = 38;
// 3136 %finish
L_01AF:;
// 3137 %finish
L_01AD:;
// 3138
// 3139 ! register is going to be the top of stack
// 3140 r = FR0 + FPU Stack
R = 9 + FPUSTACK;
// 3141
// 3142 dumpfloprm(op, v_base!v_scope, v_disp)
DUMPFLOPRM(OP, V->BASE | V->SCOPE, V->DISP);
// 3143 release(v_base)
RELEASE(V->BASE);
// 3144 set up real:
U_100E:;
// 3145 v_base = r
V->BASE = R;
// 3146 claim(r)
CLAIM(R);
// 3147 v_disp = 0;
V->DISP = 0;
// 3148 v_form = v in r
V->FORM = 1;
// 3149 v_type = real
V->TYPE = 2;
// 3150 %end
return;
case_F_dispatch:
if (F_index < 0 || F_index > 9)
_imp_signalf(6, 3, F_index, "->F(%d) out of bounds at %s line %d", F_index, F_file, F_line);
goto *F[F_index - 0];
case_F_missing:
_imp_signalf(8, 2, F_index, "switch jump to undefined label F(%d): at %s line %d", F_index, F_file, F_line);
} /* end of LOAD */
// 3151
// 3152 ! >> OPERATE <<
// 3153 ! perform the operation OP on the top two elements of the stack.
// 3154 ! (single element for unary operators)
// 3155 %routine operate(%integer op)
void OPERATE(int OP) {
// 3156 %record(stackfm)%name lhs, rhs
struct STACKFM *LHS;
struct STACKFM *RHS;
// 3157 %integer assign pending, work, value, s
int ASSIGNPENDING;
int WORK;
int VALUE;
int S;
// 3158 %switch oper(1:17), roper(1:17), fold(1:17)
int OPER_index;
int OPER_line;
char *OPER_file;
static const void *OPER[17] = {&&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing,
&&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing,
&&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing,
&&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing, &&case_OPER_missing,
&&case_OPER_missing};
int ROPER_index;
int ROPER_line;
char *ROPER_file;
static const void *ROPER[17] = {
&&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing,
&&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing,
&&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing, &&case_ROPER_missing,
&&case_ROPER_missing, &&case_ROPER_missing};
int FOLD_index;
int FOLD_line;
char *FOLD_file;
static const void *FOLD[17] = {&&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing,
&&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing,
&&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing,
&&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing, &&case_FOLD_missing,
&&case_FOLD_missing};
// 3159 %constintegerarray opmap(1:17) =
const int OPMAP[17] = {14, 18, 23, 22, 0, 15, 17, 19, 20, 21, 22, 0, 0, 0, 7, 6, 0};
// 3160+ 14, 18, 23, 22, 0, 15, 17, 19, 20, 21, 22, 0, 0, 0, 7, 6, 0
// 3161 ! add, sub, mul, div, conc,and,or, xor, lsh, rsh, rem, exp, rexp, rdiv, not, neg, abs
// 3162
// 3163 %constintegerarray flopmap(1:17) =
const int FLOPMAP[17] = {42, 43, 45, 46, 0, 0, 0, 0, 0, 0, 0, 0, 0, 46, 0, 49, 50};
// 3164+ 42, 43, 45, 46, 0, 0, 0, 0, 0, 0, 0, 0, 0, 46, 0, 49, 50
// 3165 ! fadd, fsub, fmul, fdiv, 0, 0, 0, 0, 0, 0, rem, exp, rexp, fdiv, 0, fchs, fabs
// 3166
// 3167 %constintegerarray indec(-1:1) = 4, 0, 5; ! decrement, and increment opcodes
const int INDEC[3] = {4, 0, 5};
// 3168
// 3169 %routine swap
void SWAP(void) {
// 3170 %record(stackfm) temp
struct STACKFM TEMP;
// 3171 temp = lhs
TEMP = *LHS;
// 3172 lhs = rhs
*LHS = *RHS;
// 3173 rhs = temp
*RHS = TEMP;
// 3174 %end
return;
} /* end of SWAP */
// 3175
// 3176 assign pending = 0
ASSIGNPENDING = 0;
// 3177 rhs == top
RHS = (struct STACKFM *)TOP;
// 3178 %if op < Unaries %then %start
if (OP >= 15) goto L_01B0;
// 3179 lhs == stack(stp-1)
LHS = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 3180 %if lhs_type = real %or lhs_type = lreal %then ->reals
if (LHS->TYPE == 2) goto L_00EC;
if (LHS->TYPE != 6) goto L_01B1;
L_00EC:;
goto U_100F;
L_01B1:;
// 3181 %finish
L_01B0:;
// 3182
// 3183 %if rhs_type = real %or rhs_type = lreal %then ->reals
if (RHS->TYPE == 2) goto L_01B2;
if (RHS->TYPE != 6) goto L_01B3;
L_01B2:;
goto U_100F;
L_01B3:;
// 3184
// 3185 %if rhs_form = constant %and (op >= Unaries %or lhs_form = constant) %then ->fold(op)
if (RHS->FORM != 0) goto L_01B4;
if (OP >= 15) goto L_01B5;
if (LHS->FORM != 0) goto L_01B4;
L_01B5:;
FOLD_line = __LINE__;
FOLD_file = __FILE__;
FOLD_index = OP;
goto case_FOLD_dispatch;
L_01B4:;
// 3186
// 3187 ! now look for optimisations for x = x <op> whatever
// 3188 %if next sym = 'S' %or next sym = 'j' %start; ! the next task is an assignment
if (NEXTSYM == 83) goto L_01B7;
if (NEXTSYM != 106) goto L_01B8;
L_01B7:;
// 3189 %if op >= Unaries %start
if (OP < 15) goto L_01B9;
// 3190 %if same(top, stack(stp-1)) # 0 %then assign pending = 1
if (SAME(TOP, /*?*/ &STACK[STP - 1 - 1]) == 0) goto L_01BA;
ASSIGNPENDING = 1;
L_01BA:;
// 3191 %else
goto L_01BB;
L_01B9:;
// 3192 %if same(lhs, stack(stp-2)) # 0 %then assign pending = 1
if (SAME(LHS, /*?*/ &STACK[STP - 2 - 1]) == 0) goto L_01BC;
ASSIGNPENDING = 1;
L_01BC:;
// 3193 %finish
L_01BB:;
// 3194 %finish
L_01B8:;
// 3195
// 3196 ->oper(op)
OPER_line = __LINE__;
OPER_file = __FILE__;
OPER_index = OP;
goto case_OPER_dispatch;
// 3197
// 3198 oper(op not):
case_OPER_15:;
// 3199 oper(op neg):
case_OPER_16:;
// 3200 ! we optimise for e.g. fred = -fred as one instruction
// 3201 %if assign pending # 0 %then %start
if (ASSIGNPENDING == 0) goto L_01BE;
// 3202 read symbol(next sym)
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 3203 address(rhs)
ADDRESS(RHS);
// 3204 %if rhs_type = byte %start
if (RHS->TYPE != 5) goto L_01BF;
// 3205 dumpum8(opmap(op), rhs_base!rhs_scope, rhs_disp)
DUMPUM8(OPMAP[OP - 1], RHS->BASE | RHS->SCOPE, RHS->DISP);
// 3206 %else
goto L_01C0;
L_01BF:;
// 3207 dumpum(opmap(op), rhs_base!rhs_scope, rhs_disp)
DUMPUM(OPMAP[OP - 1], RHS->BASE | RHS->SCOPE, RHS->DISP);
// 3208 %finish
L_01C0:;
// 3209 pop rel
POPREL();
// 3210 pop rel
POPREL();
// 3211 %return
return;
// 3212 %finish
L_01BE:;
// 3213 load(rhs, any)
LOAD(RHS, 25);
// 3214 dumpur(opmap(op), rhs_base)
DUMPUR(OPMAP[OP - 1], RHS->BASE);
// 3215 %return
return;
// 3216
// 3217 ! 8086 has no "abs" instructions, so we do a test and jump
// 3218 oper(op abs):
case_OPER_17:;
// 3219 load(rhs, any)
LOAD(RHS, 25);
// 3220 dumpri(CMP, rhs_base, 0)
DUMPRI(16, RHS->BASE, 0);
// 3221 work = new tag
WORK = NEWTAG();
// 3222 dumpjump(JGE, work)
DUMPJUMP(28, WORK);
// 3223 dumpur(NEG, rhs_base)
DUMPUR(6, RHS->BASE);
// 3224 dumplabel(work)
DUMPLABEL(WORK);
// 3225 %return
return;
// 3226
// 3227
// 3228 oper(op add):
case_OPER_1:;
// 3229 %if lhs_form = constant %then swap
if (LHS->FORM != 0) goto L_01C1;
SWAP();
L_01C1:;
// 3230 ! and fall through to minus
// 3231
// 3232 oper(op sub):
case_OPER_2:;
// 3233 ! First look for fred = fred + <whatever>
// 3234 ! We can only safely do this for bytes if we're jamming or ignoring overflow
// 3235 %if assign pending # 0 %and %c
if (ASSIGNPENDING == 0) goto L_01C2;
if (LHS->TYPE == 1) goto L_01C3;
if (CONTROL & 1 == 0) goto L_01C3;
if (NEXTSYM != 106) goto L_01C2;
L_01C3:;
// 3236+ (lhs_type = integer %or control & check capacity = 0 %or Next Sym = 'j') %then %start
// 3237 readsymbol(next sym) ; ! we will do the assignment ourselves
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 3238 address(lhs) ; ! make LHS accessible
ADDRESS(LHS);
// 3239 %if rhs_form = constant %then %start
if (RHS->FORM != 0) goto L_01C4;
// 3240 value = rhs_disp
VALUE = RHS->DISP;
// 3241 %if value # 0 %start
if (VALUE == 0) goto L_01C5;
// 3242 %if op = op sub %then value = -value
if (OP != 2) goto L_01C6;
VALUE = -VALUE;
L_01C6:;
// 3243 ! look for increment or decrement instructions
// 3244 %if value < 2 %and value > -2 %then %start
if (VALUE >= 2) goto L_01C7;
if (VALUE <= -2) goto L_01C7;
// 3245 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_01C8;
// 3246 dumpum8(indec(value), lhs_base!lhs_scope, lhs_disp)
DUMPUM8(INDEC[VALUE + 1], LHS->BASE | LHS->SCOPE, LHS->DISP);
// 3247 %else
goto L_01C9;
L_01C8:;
// 3248 dumpum(indec(value), lhs_base!lhs_scope, lhs_disp)
DUMPUM(INDEC[VALUE + 1], LHS->BASE | LHS->SCOPE, LHS->DISP);
// 3249 %finish
L_01C9:;
// 3250 %else
goto L_01CA;
L_01C7:;
// 3251 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_01CB;
// 3252 dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
DUMPMI8(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->DISP);
// 3253 %else
goto L_01CC;
L_01CB:;
// 3254 dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
DUMPMI(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->DISP);
// 3255 %finish
L_01CC:;
// 3256 %finish
L_01CA:;
// 3257 %finish
L_01C5:;
// 3258 %else; ! RHS not a constant
goto L_01CD;
L_01C4:;
// 3259 load(rhs, any)
LOAD(RHS, 25);
// 3260 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_01CE;
// 3261 dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base+16)
DUMPMR8(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->BASE + 16);
// 3262 %else
goto L_01CF;
L_01CE:;
// 3263 dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base)
DUMPMR(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->BASE);
// 3264 %finish
L_01CF:;
// 3265 %finish
L_01CD:;
// 3266 pop rel
POPREL();
// 3267 pop rel
POPREL();
// 3268 pop rel
POPREL();
// 3269 %return
return;
// 3270 %finish
L_01C2:;
// 3271
// 3272 ! So, there is no assign pending
// 3273
// 3274 %if rhs_form = constant %then %start
if (RHS->FORM != 0) goto L_01D0;
// 3275 value = rhs_disp
VALUE = RHS->DISP;
// 3276 %if op = op sub %then value = -value
if (OP != 2) goto L_01D1;
VALUE = -VALUE;
L_01D1:;
// 3277 ! If it is already an address, do the math on the address offset
// 3278 %if lhs_form = avins %or lhs_form = avinrec %start
if (LHS->FORM == 5) goto L_01D2;
if (LHS->FORM != 8) goto L_01D3;
L_01D2:;
// 3279 lhs_disp = lhs_disp + value
LHS->DISP = LHS->DISP + VALUE;
// 3280 %else
goto L_01D4;
L_01D3:;
// 3281 load(lhs, any)
LOAD(LHS, 25);
// 3282 ! We don't particulary try for it, but if we ended up with a pointer
// 3283 ! register, we might as well convert this to use the address form...
// 3284 %if lhs_base = BX %start; ! BX is the only GP reg that's also a pointer
if (LHS->BASE != 4) goto L_01D5;
// 3285 lhs_form = avins
LHS->FORM = 5;
// 3286 lhs_disp = value
LHS->DISP = VALUE;
// 3287 %else; ! otherwise, don't bother deferring the operation
goto L_01D6;
L_01D5:;
// 3288 ! look for increment or decrement instructions
// 3289 %if value < 2 %and value > -2 %then %start
if (VALUE >= 2) goto L_01D7;
if (VALUE <= -2) goto L_01D7;
// 3290 %if value # 0 %then dumpur(indec(value), lhs_base)
if (VALUE == 0) goto L_01D8;
DUMPUR(INDEC[VALUE + 1], LHS->BASE);
L_01D8:;
// 3291 %else
goto L_01D9;
L_01D7:;
// 3292 dumpri(opmap(op), lhs_base, rhs_disp)
DUMPRI(OPMAP[OP - 1], LHS->BASE, RHS->DISP);
// 3293 %finish
L_01D9:;
// 3294 %finish
L_01D6:;
// 3295 %finish
L_01D4:;
// 3296 %else; ! not a constant
goto L_01DA;
L_01D0:;
// 3297 %if op = op add %and rhs_form = v in r %then swap; ! commutative, so flip it
if (OP != 1) goto L_01DB;
if (RHS->FORM != 1) goto L_01DB;
SWAP();
L_01DB:;
// 3298 load(lhs, any)
LOAD(LHS, 25);
// 3299 %if rhs_type = byte %start
if (RHS->TYPE != 5) goto L_01DC;
// 3300 load(rhs, any)
LOAD(RHS, 25);
// 3301 %else
goto L_01DD;
L_01DC:;
// 3302 address(rhs)
ADDRESS(RHS);
// 3303 %finish
L_01DD:;
// 3304 dumprv(opmap(op), lhs_base, rhs)
DUMPRV(OPMAP[OP - 1], LHS->BASE, RHS);
// 3305 %finish
L_01DA:;
// 3306 pop rel; ! the RHS
POPREL();
// 3307 %return
return;
// 3308
// 3309
// 3310 oper(op and):
case_OPER_6:;
// 3311 oper(op or):
case_OPER_7:;
// 3312 oper(op xor):
case_OPER_8:;
// 3313 ! Logical ops are a subset of ADD - similar behaviour, but no inc/dec/addr short forms
// 3314 %if lhs_form = constant %then swap
if (LHS->FORM != 0) goto L_01DE;
SWAP();
L_01DE:;
// 3315
// 3316 ! First look for fred = fred <op> <whatever>
// 3317 %if assign pending # 0 %then %start
if (ASSIGNPENDING == 0) goto L_01DF;
// 3318 readsymbol(next sym); ! we will do the assignment ourselves
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 3319 address(lhs); ! make LHS accessible
ADDRESS(LHS);
// 3320 %if rhs_form = constant %then %start
if (RHS->FORM != 0) goto L_01E0;
// 3321 value = rhs_disp
VALUE = RHS->DISP;
// 3322 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_01E1;
// 3323 warn(8) %if rhs_disp & (\255) # 0
if (RHS->DISP & (~255) == 0) goto L_01E2;
WARN(8);
L_01E2:;
// 3324 dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
DUMPMI8(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->DISP);
// 3325 %else
goto L_01E3;
L_01E1:;
// 3326 dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
DUMPMI(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->DISP);
// 3327 %finish
L_01E3:;
// 3328 %else; ! RHS not a constant
goto L_01E4;
L_01E0:;
// 3329 load(rhs, any)
LOAD(RHS, 25);
// 3330 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_01E5;
// 3331 dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base+16)
DUMPMR8(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->BASE + 16);
// 3332 %else
goto L_01E6;
L_01E5:;
// 3333 dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base)
DUMPMR(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->BASE);
// 3334 %finish
L_01E6:;
// 3335 %finish
L_01E4:;
// 3336 pop rel; ! RHS
POPREL();
// 3337 pop rel; ! LHS
POPREL();
// 3338 pop rel; ! Assignment destination
POPREL();
// 3339 %return
return;
// 3340 %finish
L_01DF:;
// 3341
// 3342 ! So, there is no assign pending
// 3343
// 3344 %if rhs_form = constant %then %start
if (RHS->FORM != 0) goto L_01E7;
// 3345 value = rhs_disp
VALUE = RHS->DISP;
// 3346 load(lhs, any)
LOAD(LHS, 25);
// 3347 dumpri(opmap(op), lhs_base, value)
DUMPRI(OPMAP[OP - 1], LHS->BASE, VALUE);
// 3348 %else; ! not a constant
goto L_01E8;
L_01E7:;
// 3349 %if rhs_form = v in r %then swap; ! all these are commutative, so flip it to make it easier
if (RHS->FORM != 1) goto L_01E9;
SWAP();
L_01E9:;
// 3350 load(lhs, any)
LOAD(LHS, 25);
// 3351 %if rhs_type = byte %and op = op and %start; ! AND needs all the bits to make sense
if (RHS->TYPE != 5) goto L_01EA;
if (OP != 6) goto L_01EA;
// 3352 load(rhs, any); ! NB Load changes type to Integer
LOAD(RHS, 25);
// 3353 %else
goto L_01EB;
L_01EA:;
// 3354 address(rhs)
ADDRESS(RHS);
// 3355 %finish
L_01EB:;
// 3356 %if rhs_type = byte %start; ! must be V in S - everything else would be Integer
if (RHS->TYPE != 5) goto L_01EC;
// 3357 dumprm8(opmap(op), lhs_base+16, rhs_scope!rhs_base, rhs_disp)
DUMPRM8(OPMAP[OP - 1], LHS->BASE + 16, RHS->SCOPE | RHS->BASE, RHS->DISP);
// 3358 %else
goto L_01ED;
L_01EC:;
// 3359 dumprv(opmap(op), lhs_base, rhs)
DUMPRV(OPMAP[OP - 1], LHS->BASE, RHS);
// 3360 %finish
L_01ED:;
// 3361 %finish
L_01E8:;
// 3362 pop rel; ! the RHS
POPREL();
// 3363 %return
return;
// 3364
// 3365 oper(op mul):
case_OPER_3:;
// 3366 %if lhs_form = constant %or rhs_base = AX %then swap
if (LHS->FORM == 0) goto L_01EE;
if (RHS->BASE != 1) goto L_01EF;
L_01EE:;
SWAP();
L_01EF:;
// 3367
// 3368 %if rhs_form = constant %then %start
if (RHS->FORM != 0) goto L_01F0;
// 3369 value = rhs_disp
VALUE = RHS->DISP;
// 3370 %if value = 0 %then %start; ! mul by zero is zero
if (VALUE != 0) goto L_01F1;
// 3371 release(lhs_base)
RELEASE(LHS->BASE);
// 3372 lhs = rhs
*LHS = *RHS;
// 3373 pop stack
POPSTACK();
// 3374 %return
return;
// 3375 %finish
L_01F1:;
// 3376 %if value = 1 %then %start; ! mul by 1 is the identity
if (VALUE != 1) goto L_01F2;
// 3377 pop stack
POPSTACK();
// 3378 %return
return;
// 3379 %finish
L_01F2:;
// 3380 s = mulshift(value); ! find a shift factor
S = MULSHIFT(VALUE);
// 3381 %if s > 0 %then %start
if (S <= 0) goto L_01F3;
// 3382 rhs_disp = s
RHS->DISP = S;
// 3383 op = op lsh
OP = 9;
// 3384 -> shift it
goto U_1010;
// 3385 %finish
L_01F3:;
// 3386 ! 8086 multiply instruction doesn't have an immediate operand form
// 3387 ! so we use an entry in the constant table...
// 3388 rhs_base = 0; rhs_scope = COT; rhs_disp = getcotw(value)
RHS->BASE = 0;
RHS->SCOPE = 32;
RHS->DISP = GETCOTW(VALUE);
// 3389 rhs_form = V in S
RHS->FORM = 4;
// 3390 ! and fall through to the not-a-constant path
// 3391 %finish
L_01F0:;
// 3392
// 3393 do mul:
U_1011:;
// 3394 load(lhs, AX)
LOAD(LHS, 1);
// 3395 address(rhs)
ADDRESS(RHS);
// 3396 hazard(DX)
HAZARD(3);
// 3397 %if rhs_form = V in R %start
if (RHS->FORM != 1) goto L_01F4;
// 3398 dumpur(IMUL, rhs_base)
DUMPUR(23, RHS->BASE);
// 3399 %else
goto L_01F5;
L_01F4:;
// 3400 dumpum(IMUL, rhs_base!rhs_scope, rhs_disp)
DUMPUM(23, RHS->BASE | RHS->SCOPE, RHS->DISP);
// 3401 %finish
L_01F5:;
// 3402 pop rel
POPREL();
// 3403 %return
return;
// 3404
// 3405 oper(op div):
case_OPER_4:;
// 3406 oper(op rem):
case_OPER_11:;
// 3407 load(lhs, AX)
LOAD(LHS, 1);
// 3408 address(rhs)
ADDRESS(RHS);
// 3409 hazard(DX)
HAZARD(3);
// 3410 dumpsimple(CWD)
DUMPSIMPLE(1);
// 3411 ! Plain 8086 Divide instruction also has no immediate operand form, so
// 3412 ! we move constants to the COT
// 3413 %if rhs_form = constant %start
if (RHS->FORM != 0) goto L_01F6;
// 3414 %if rhs_disp = 0 %then warn(1)
if (RHS->DISP != 0) goto L_01F7;
WARN(1);
L_01F7:;
// 3415 rhs_base = 0; rhs_scope = COT; rhs_disp = getcotw(rhs_disp)
RHS->BASE = 0;
RHS->SCOPE = 32;
RHS->DISP = GETCOTW(RHS->DISP);
// 3416 rhs_form = V in S
RHS->FORM = 4;
// 3417 %finish
L_01F6:;
// 3418 %if rhs_form = V in R %start
if (RHS->FORM != 1) goto L_01F8;
// 3419 dumpur(IDIV, rhs_base)
DUMPUR(22, RHS->BASE);
// 3420 %else
goto L_01F9;
L_01F8:;
// 3421 dumpum(IDIV, rhs_base!rhs_scope, rhs_disp)
DUMPUM(22, RHS->BASE | RHS->SCOPE, RHS->DISP);
// 3422 %finish
L_01F9:;
// 3423 pop rel
POPREL();
// 3424 %if op = op div %then %start
if (OP != 4) goto L_01FA;
// 3425 lhs_base = AX
LHS->BASE = 1;
// 3426 %else
goto L_01FB;
L_01FA:;
// 3427 lhs_base = DX
LHS->BASE = 3;
// 3428 release(AX)
RELEASE(1);
// 3429 claim(DX)
CLAIM(3);
// 3430 %finish
L_01FB:;
// 3431 %return
return;
// 3432
// 3433 oper(op lsh):
case_OPER_9:;
// 3434 oper(op rsh):
case_OPER_10:;
// 3435 shift it:
U_1010:;
// 3436 %if assign pending # 0 %and %c
if (ASSIGNPENDING == 0) goto L_01FC;
if (OP == 10) goto L_01FD;
if (LHS->TYPE == 1) goto L_01FD;
if (CONTROL & 1 == 0) goto L_01FD;
if (NEXTSYM != 106) goto L_01FC;
L_01FD:;
// 3437+ (op = op rsh %or lhs_type = integer %or control & check capacity = 0 %or Next Sym = 'j') %then %start
// 3438 readsymbol(next sym); ! we will do the assignment ourselves
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 3439 address(lhs); ! make LHS accessible
ADDRESS(LHS);
// 3440 ! Note that in-register shifting it is actually quicker for small
// 3441 ! constant shifts to plant multiple "shift by one" instructions than
// 3442 ! it is to load up CL with the shift count. That is NOT true for
// 3443 ! in-store shifts, since there's a fetch and store for every bit shift
// 3444 ! Hence the test for disp = 1 below
// 3445 %if rhs_form = constant %and rhs_disp = 1 %start
if (RHS->FORM != 0) goto L_01FE;
if (RHS->DISP != 1) goto L_01FE;
// 3446 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_01FF;
// 3447 dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, 1)
DUMPMI8(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, 1);
// 3448 %else
goto L_0200;
L_01FF:;
// 3449 dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, 1)
DUMPMI(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, 1);
// 3450 %finish
L_0200:;
// 3451 %else; ! RHS not a one
goto L_0201;
L_01FE:;
// 3452 ! Since the shift instruction only uses the bottom 4 bits of the
// 3453 ! value in CX, the value is "byte safe". Rather than do a full
// 3454 ! "load(rhs,CX)" we therefore fiddle about and do it the hard way
// 3455 ! to save redundant coding
// 3456 %if rhs_type = byte %start
if (RHS->TYPE != 5) goto L_0202;
// 3457 hazard(CX)
HAZARD(2);
// 3458 address(rhs)
ADDRESS(RHS);
// 3459 dumprm8(MOV, CL, rhs_scope!rhs_base, rhs_disp)
DUMPRM8(11, 18, RHS->SCOPE | RHS->BASE, RHS->DISP);
// 3460 %else
goto L_0203;
L_0202:;
// 3461 load(rhs,CX)
LOAD(RHS, 2);
// 3462 %finish
L_0203:;
// 3463 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_0204;
// 3464 dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, CL)
DUMPMR8(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, 18);
// 3465 %else
goto L_0205;
L_0204:;
// 3466 dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, CX)
DUMPMR(OPMAP[OP - 1], LHS->BASE | LHS->SCOPE, LHS->DISP, 2);
// 3467 %finish
L_0205:;
// 3468 %finish
L_0201:;
// 3469 pop rel; ! RHS
POPREL();
// 3470 pop rel; ! LHS
POPREL();
// 3471 pop rel; ! Assignment destination
POPREL();
// 3472 %return
return;
// 3473 %finish
L_01FC:;
// 3474
// 3475 ! deal with constant shifts first...
// 3476 %if rhs_form = constant %then %start
if (RHS->FORM != 0) goto L_0206;
// 3477 value = rhs_disp
VALUE = RHS->DISP;
// 3478 %if value <= 4 %then %start; ! plant individual shift 1 instructions
if (VALUE > 4) goto L_0207;
// 3479 load(lhs, any)
LOAD(LHS, 25);
// 3480 %while value > 0 %cycle
L_0208:;
if (VALUE <= 0) goto L_0209;
// 3481 dumpri(opmap(op), lhs_base, 1)
DUMPRI(OPMAP[OP - 1], LHS->BASE, 1);
// 3482 value = value - 1
VALUE = VALUE - 1;
// 3483 %repeat
goto L_0208;
L_0209:;
// 3484 %else
goto L_020A;
L_0207:;
// 3485 load(rhs, CX)
LOAD(RHS, 2);
// 3486 load(lhs, any)
LOAD(LHS, 25);
// 3487 dumprr(opmap(op), lhs_base, CX)
DUMPRR(OPMAP[OP - 1], LHS->BASE, 2);
// 3488 %finish
L_020A:;
// 3489 %else; ! RHS variable
goto L_020B;
L_0206:;
// 3490 ! Since the shift instruction only uses the bottom 4 bits of the
// 3491 ! value in CX, the value is "byte safe". Rather than do a full
// 3492 ! "load(rhs,CX)" we therefore fiddle about and do it the hard way
// 3493 ! to save redundant coding
// 3494 %if rhs_type = byte %start
if (RHS->TYPE != 5) goto L_020C;
// 3495 hazard(CX)
HAZARD(2);
// 3496 address(rhs)
ADDRESS(RHS);
// 3497 dumprm8(MOV, CL, rhs_scope!rhs_base, rhs_disp)
DUMPRM8(11, 18, RHS->SCOPE | RHS->BASE, RHS->DISP);
// 3498 release(rhs_base)
RELEASE(RHS->BASE);
// 3499 rhs_base = CX
RHS->BASE = 2;
// 3500 claim(CX)
CLAIM(2);
// 3501 %else
goto L_020D;
L_020C:;
// 3502 load(rhs,CX)
LOAD(RHS, 2);
// 3503 %finish
L_020D:;
// 3504 load(lhs, any)
LOAD(LHS, 25);
// 3505 dumprr(opmap(op), lhs_base, CX);
DUMPRR(OPMAP[OP - 1], LHS->BASE, 2);
// 3506 %finish
L_020B:;
// 3507 pop rel
POPREL();
// 3508 %return
return;
// 3509
// 3510 oper(op exp):
case_OPER_12:;
// 3511 %if rhs_form = constant %then %start
if (RHS->FORM != 0) goto L_020E;
// 3512 %if rhs_disp = 0 %start
if (RHS->DISP != 0) goto L_020F;
// 3513 pop rel
POPREL();
// 3514 pop rel
POPREL();
// 3515 push const(1)
PUSHCONST(1);
// 3516 %return
return;
// 3517 %finish
L_020F:;
// 3518
// 3519 %if rhs_disp = 1 %then %start
if (RHS->DISP != 1) goto L_0210;
// 3520 pop rel
POPREL();
// 3521 %return
return;
// 3522 %finish
L_0210:;
// 3523
// 3524 %if rhs_disp = 2 %then %start
if (RHS->DISP != 2) goto L_0211;
// 3525 rhs = lhs
*RHS = *LHS;
// 3526 claim(rhs_base)
CLAIM(RHS->BASE);
// 3527 ->do mul
goto U_1011;
// 3528 %finish
L_0211:;
// 3529 %finish
L_020E:;
// 3530
// 3531 load(rhs, any)
LOAD(RHS, 25);
// 3532 dumpur(PUSH, rhs_base)
DUMPUR(9, RHS->BASE);
// 3533 pop rel
POPREL();
// 3534 load(lhs, any)
LOAD(LHS, 25);
// 3535 dumpur(PUSH, lhs_base)
DUMPUR(9, LHS->BASE);
// 3536 release(lhs_base)
RELEASE(LHS->BASE);
// 3537 perm(iexp, 4)
PERM(1, 4);
// 3538 lhs_base = AX; claim(AX)
LHS->BASE = 1;
CLAIM(1);
// 3539 lhs_form = V in R
LHS->FORM = 1;
// 3540 %return
return;
// 3541
// 3542 oper(op rexp):
case_OPER_13:;
// 3543 oper(op rdiv):
case_OPER_14:;
// 3544 abort("Oper unexpected op")
ABORT(_imp_str_literal("Oper unexpected op"));
// 3545
// 3546 !-----------------------------------------------
// 3547 ! Fold constant expressions at compile time
// 3548 fold(op neg): value = -rhs_disp; -> set unary
case_FOLD_16:;
VALUE = -RHS->DISP;
goto U_1012;
// 3549 fold(op not): value = \rhs_disp; -> set unary
case_FOLD_15:;
VALUE = (~RHS->DISP);
goto U_1012;
// 3550 fold(op abs): value = rhs_disp; %if value < 0 %then value = -value; -> set value
case_FOLD_17:;
VALUE = RHS->DISP;
if (VALUE >= 0) goto L_0212;
VALUE = -VALUE;
L_0212:;
goto U_1013;
// 3551 fold(op add): value = lhs_disp + rhs_disp; -> set value
case_FOLD_1:;
VALUE = LHS->DISP + RHS->DISP;
goto U_1013;
// 3552 fold(op sub): value = lhs_disp - rhs_disp; -> set value
case_FOLD_2:;
VALUE = LHS->DISP - RHS->DISP;
goto U_1013;
// 3553 fold(op or): value = lhs_disp ! rhs_disp; -> set value
case_FOLD_7:;
VALUE = LHS->DISP | RHS->DISP;
goto U_1013;
// 3554 fold(op and): value = lhs_disp & rhs_disp; -> set value
case_FOLD_6:;
VALUE = LHS->DISP & RHS->DISP;
goto U_1013;
// 3555 fold(op xor): value = lhs_disp !! rhs_disp; -> set value
case_FOLD_8:;
VALUE = LHS->DISP ^ RHS->DISP;
goto U_1013;
// 3556 fold(op lsh): value = lhs_disp << rhs_disp; -> set value
case_FOLD_9:;
VALUE = LHS->DISP << RHS->DISP;
goto U_1013;
// 3557 fold(op mul): value = lhs_disp * rhs_disp; -> set value
case_FOLD_3:;
VALUE = LHS->DISP * RHS->DISP;
goto U_1013;
// 3558 fold(op rsh): value = lhs_disp >> rhs_disp; -> set value
case_FOLD_10:;
VALUE = (unsigned int)LHS->DISP >> RHS->DISP;
goto U_1013;
// 3559 fold(op exp): %if rhs_disp < 0 %then abort("Fold -ve Exp")
case_FOLD_12:;
if (RHS->DISP >= 0) goto L_0213;
ABORT(_imp_str_literal("Fold -ve Exp"));
L_0213:;
// 3560 value = 1
VALUE = 1;
// 3561 %for op=1, 1, rhs_disp %cycle
// %for OP = 1, 1, RHS->DISP %cycle
{
int _final = RHS->DISP;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle OP = 1, 1, RHS->DISP");
OP = 0;
L_0214:
if (OP == _final) goto L_0215;
OP += 1;
// 3562 value = value * lhs_disp
VALUE = VALUE * LHS->DISP;
// 3563 %repeat
goto L_0214;
}
L_0215:;
// 3564 -> set value
goto U_1013;
// 3565 fold(op rem):
case_FOLD_11:;
// 3566 fold(op div): value = rhs_disp;
case_FOLD_4:;
VALUE = RHS->DISP;
// 3567 warn(1) %and value = 1 %if value = 0
if (VALUE != 0) goto L_0217;
WARN(1);
VALUE = 1;
L_0217:;
// 3568 value = lhs_disp // value
VALUE = ((long)LHS->DISP / (long)VALUE);
// 3569 %if op = op div %then -> set value
if (OP != 4) goto L_0218;
goto U_1013;
L_0218:;
// 3570 value = lhs_disp - (rhs_disp * value)
VALUE = LHS->DISP - RHS->DISP * VALUE;
// 3571 -> set value
goto U_1013;
// 3572
// 3573 fold(op rexp): abort("No reals yet")
case_FOLD_13:;
ABORT(_imp_str_literal("No reals yet"));
// 3574 fold(op rdiv): abort("No reals yet")
case_FOLD_14:;
ABORT(_imp_str_literal("No reals yet"));
// 3575
// 3576 set value:
U_1013:;
// 3577 pop stack
POPSTACK();
// 3578 set unary:
U_1012:;
// 3579 top_disp = value
TOP->DISP = VALUE;
// 3580 %return
return;
// 3581
// 3582 fold(op conc): abort("Fold Conc")
case_FOLD_5:;
ABORT(_imp_str_literal("Fold Conc"));
// 3583
// 3584 !--------------------------------------------------------------------
// 3585 ! String operations - the only one is concatenate...
// 3586
// 3587 oper(op conc):
case_OPER_5:;
// 3588
// 3589 %if assign pending # 0 %start; ! It's S = S.T
if (ASSIGNPENDING == 0) goto L_0219;
// 3590 amap(lhs)
AMAP(LHS);
// 3591 load(lhs, any)
LOAD(LHS, 25);
// 3592 dumpur(PUSH, lhs_base)
DUMPUR(9, LHS->BASE);
// 3593 amap(rhs)
AMAP(RHS);
// 3594 load(rhs, any)
LOAD(RHS, 25);
// 3595 dumpur(PUSH, rhs_base)
DUMPUR(9, RHS->BASE);
// 3596 pop rel
POPREL();
// 3597 pop rel
POPREL();
// 3598 dumppushi(0, lhs_size)
DUMPPUSHI(0, LHS->SIZE);
// 3599 %if Next Sym = 'S' %then perm(sconc, 6) %else perm(sjconc, 6)
if (NEXTSYM != 83) goto L_021A;
PERM(5, 6);
goto L_021B;
L_021A:;
PERM(6, 6);
L_021B:;
// 3600 ! and finally, skip the pending assignment, and drop the LHS
// 3601 readsymbol(Next Sym)
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 3602 pop rel
POPREL();
// 3603 %return
return;
// 3604 %finish
L_0219:;
// 3605
// 3606 ! here we've got T.U - if T is already in a WORK location
// 3607 ! we've got a simple append. If it is a user variable, we've
// 3608 ! got to both copy it to a temp area and do the append
// 3609
// 3610 %if Is Work(lhs) = 0 %start; ! Not a work area
if (ISWORK(LHS) != 0) goto L_021C;
// 3611 work = getwork(256)
WORK = GETWORK(256);
// 3612 push const(work)
PUSHCONST(WORK);
// 3613 top_form = av in s
TOP->FORM = 5;
// 3614 top_base = BP
TOP->BASE = 6;
// 3615 load(top, any)
LOAD(TOP, 25);
// 3616 dumpur(PUSH, top_base)
DUMPUR(9, TOP->BASE);
// 3617 pop rel
POPREL();
// 3618 amap(lhs)
AMAP(LHS);
// 3619 load(lhs, any)
LOAD(LHS, 25);
// 3620 dumpur(PUSH, lhs_base)
DUMPUR(9, LHS->BASE);
// 3621 release(lhs_base)
RELEASE(LHS->BASE);
// 3622 dumppushi(0, 255)
DUMPPUSHI(0, 255);
// 3623 perm(smove, 6)
PERM(3, 6);
// 3624 ! Now we need to redefine the LHS as our temporary area
// 3625 lhs = 0; ! gratuitous clear-it-all-out
*LHS = (struct STACKFM){0};
// 3626 lhs_type = string
LHS->TYPE = 3;
// 3627 lhs_form = V in S
LHS->FORM = 4;
// 3628 lhs_base = BP
LHS->BASE = 6;
// 3629 lhs_disp = work
LHS->DISP = WORK;
// 3630 lhs_size = 255
LHS->SIZE = 255;
// 3631 %finish
L_021C:;
// 3632
// 3633 ! Here we are doing an in-situ concatenation
// 3634
// 3635 ! We want to leave the result as a normal variable, so we
// 3636 ! suck up a copy for the AMAP fiddling
// 3637 push copy(lhs)
PUSHCOPY(LHS);
// 3638 amap(top)
AMAP(TOP);
// 3639 load(top, any)
LOAD(TOP, 25);
// 3640 dumpur(PUSH, top_base)
DUMPUR(9, TOP->BASE);
// 3641 poprel
POPREL();
// 3642 amap(rhs)
AMAP(RHS);
// 3643 load(rhs, any)
LOAD(RHS, 25);
// 3644 dumpur(PUSH, rhs_base)
DUMPUR(9, RHS->BASE);
// 3645 pop rel
POPREL();
// 3646 dumppushi(0, lhs_size)
DUMPPUSHI(0, LHS->SIZE);
// 3647 perm(sconc, 6)
PERM(5, 6);
// 3648 %return
return;
// 3649
// 3650 Reals:
U_100F:;
// 3651 %if op < Unaries %then load(lhs, anyf)
if (OP >= 15) goto L_021D;
LOAD(LHS, 28);
L_021D:;
// 3652 %if op # op rexp %then load(rhs, anyf)
if (OP == 13) goto L_021E;
LOAD(RHS, 28);
L_021E:;
// 3653 ->roper(op)
ROPER_line = __LINE__;
ROPER_file = __FILE__;
ROPER_index = OP;
goto case_ROPER_dispatch;
// 3654
// 3655 roper(op neg):
case_ROPER_16:;
// 3656 roper(op abs):
case_ROPER_17:;
// 3657 dumpfloprr(flopmap(op), rhs_base, rhs_base)
DUMPFLOPRR(FLOPMAP[OP - 1], RHS->BASE, RHS->BASE);
// 3658 %return
return;
// 3659
// 3660 roper(op add):
case_ROPER_1:;
// 3661 roper(op mul):
case_ROPER_3:;
// 3662 ! Commutative, so we don't care
// 3663 %if lhs_base > rhs_base %then swap
if (LHS->BASE <= RHS->BASE) goto L_0220;
SWAP();
L_0220:;
// 3664 dumpfloprr(flopmap(op), lhs_base, rhs_base)
DUMPFLOPRR(FLOPMAP[OP - 1], LHS->BASE, RHS->BASE);
// 3665 pop rel
POPREL();
// 3666 %return
return;
// 3667
// 3668 roper(op sub):
case_ROPER_2:;
// 3669 roper(op div):
case_ROPER_4:;
// 3670 roper(op rdiv):
case_ROPER_14:;
// 3671 ! We can't swap these, so we use the reverse form of
// 3672 ! the opcode (which in our internal form is always one
// 3673 ! more than the basic opcode index)
// 3674 op = flopmap(op)
OP = FLOPMAP[OP - 1];
// 3675 %if lhs_base > rhs_base %start
if (LHS->BASE <= RHS->BASE) goto L_0221;
// 3676 swap
SWAP();
// 3677 op = op + 1
OP = OP + 1;
// 3678 %finish
L_0221:;
// 3679 dumpfloprr(op, lhs_base, rhs_base)
DUMPFLOPRR(OP, LHS->BASE, RHS->BASE);
// 3680 pop rel
POPREL();
// 3681 %return
return;
// 3682
// 3683 roper(op rexp):
case_ROPER_13:;
// 3684 ! This is implemented as a PERM routine
// 3685 load(rhs, any)
LOAD(RHS, 25);
// 3686 dumpur(PUSH, rhs_base)
DUMPUR(9, RHS->BASE);
// 3687 pop rel
POPREL();
// 3688 ! The usual slightly clunky floating point "push"
// 3689 work = ptreg
WORK = PTREG();
// 3690 dumpri(SUB, SP, 8)
DUMPRI(18, 5, 8);
// 3691 dumprr(MOV, work, SP)
DUMPRR(11, WORK, 5);
// 3692 dumpfloprm(FSTQ, work, 0)
DUMPFLOPRM(41, WORK, 0);
// 3693 release(lhs_base)
RELEASE(LHS->BASE);
// 3694 perm(fexp, 10)
PERM(2, 10);
// 3695 ! Since rexp is actually a standard C routine, the result will
// 3696 ! be in store, pointed to by AX...
// 3697 lhs_base = AX; claim(AX)
LHS->BASE = 1;
CLAIM(1);
// 3698 lhs_form = V in S; lhs_disp = 0; lhs_scope = 0
LHS->FORM = 4;
LHS->DISP = 0;
LHS->SCOPE = 0;
// 3699 lhs_type = lreal
LHS->TYPE = 6;
// 3700 load(lhs, anyf)
LOAD(LHS, 28);
// 3701 %return
return;
// 3702
// 3703 roper(op not):
case_ROPER_15:;
// 3704 roper(op and):
case_ROPER_6:;
// 3705 roper(op or):
case_ROPER_7:;
// 3706 roper(op xor):
case_ROPER_8:;
// 3707 roper(op rem):
case_ROPER_11:;
// 3708 roper(op lsh):
case_ROPER_9:;
// 3709 roper(op rsh):
case_ROPER_10:;
// 3710 roper(op exp):
case_ROPER_12:;
// 3711 abort("Unsupported Real Operation")
ABORT(_imp_str_literal("Unsupported Real Operation"));
// 3712
// 3713 %end; ! operate
return;
case_OPER_dispatch:
if (OPER_index < 1 || OPER_index > 17)
_imp_signalf(6, 3, OPER_index, "->OPER(%d) out of bounds at %s line %d", OPER_index, OPER_file, OPER_line);
goto *OPER[OPER_index - 1];
case_OPER_missing:
_imp_signalf(8, 2, OPER_index, "switch jump to undefined label OPER(%d): at %s line %d", OPER_index, OPER_file,
OPER_line);
case_ROPER_dispatch:
if (ROPER_index < 1 || ROPER_index > 17)
_imp_signalf(6, 3, ROPER_index, "->ROPER(%d) out of bounds at %s line %d", ROPER_index, ROPER_file, ROPER_line);
goto *ROPER[ROPER_index - 1];
case_ROPER_missing:
_imp_signalf(8, 2, ROPER_index, "switch jump to undefined label ROPER(%d): at %s line %d", ROPER_index,
ROPER_file, ROPER_line);
case_FOLD_dispatch:
if (FOLD_index < 1 || FOLD_index > 17)
_imp_signalf(6, 3, FOLD_index, "->FOLD(%d) out of bounds at %s line %d", FOLD_index, FOLD_file, FOLD_line);
goto *FOLD[FOLD_index - 1];
case_FOLD_missing:
_imp_signalf(8, 2, FOLD_index, "switch jump to undefined label FOLD(%d): at %s line %d", FOLD_index, FOLD_file,
FOLD_line);
} /* end of OPERATE */
// 3714
// 3715 ! >> ASSIGN <<
// 3716 ! ASSOP = -1: parameter assignment
// 3717 ! 0: == assignment
// 3718 ! 1: = assignment
// 3719 ! 2: <- assignment
// 3720 %routine assign(%integer assop)
void ASSIGN(int ASSOP) {
// 3721 %record(stackfm)%name lh,rh
struct STACKFM *LH;
struct STACKFM *RH;
// 3722 %record(stackfm) temp
struct STACKFM TEMP;
// 3723 %integer n, p, t, form, r
int N;
int P;
int T;
int FORM;
int R;
// 3724
// 3725 ! Store the item in RHS to LHS. Encapsulates the dificulties
// 3726 ! of variable length items and pushing things on the stack to
// 3727 ! keep the rest of "Assign" looking tidy
// 3728 %routine Store(%record(stackfm)%name lhs, rhs)
void STORE(struct STACKFM * LHS, struct STACKFM * RHS) {
// 3729 %integer pt, s, op
int PT;
int S;
int OP;
// 3730
// 3731 %if lhs_base = SP %start; ! it's a push
if (LHS->BASE != 5) goto L_0222;
// 3732 %if lhs_type = integer %or lhs_type = byte %start
if (LHS->TYPE == 1) goto L_0223;
if (LHS->TYPE != 5) goto L_0224;
L_0223:;
// 3733 %if rhs_type = byte %start
if (RHS->TYPE != 5) goto L_0225;
// 3734 load(rhs, any)
LOAD(RHS, 25);
// 3735 %else
goto L_0226;
L_0225:;
// 3736 address(rhs)
ADDRESS(RHS);
// 3737 %finish
L_0226:;
// 3738 dumpvpush(rhs)
DUMPVPUSH(RHS);
// 3739 %else; ! must be a real
goto L_0227;
L_0224:;
// 3740 %if lhs_type = real %start
if (LHS->TYPE != 2) goto L_0228;
// 3741 s = 4
S = 4;
// 3742 op = FSTD
OP = 40;
// 3743 %else
goto L_0229;
L_0228:;
// 3744 s = 8
S = 8;
// 3745 op = FSTQ
OP = 41;
// 3746 %finish
L_0229:;
// 3747 load(rhs, anyf)
LOAD(RHS, 28);
// 3748 pt = ptreg
PT = PTREG();
// 3749 dumpri(SUB, SP, s)
DUMPRI(18, 5, S);
// 3750 dumprr(MOV, pt, SP)
DUMPRR(11, PT, 5);
// 3751 dumpfloprm(op, pt, 0)
DUMPFLOPRM(OP, PT, 0);
// 3752 %finish
L_0227:;
// 3753 %return
return;
// 3754 %finish
L_0222:;
// 3755 %if lhs_type = integer %start
if (LHS->TYPE != 1) goto L_022A;
// 3756 %if rhs_form = constant %and rhs_scope = 0 %start
if (RHS->FORM != 0) goto L_022B;
if (RHS->SCOPE != 0) goto L_022B;
// 3757 dumpmi(MOV, lhs_base!lhs_scope, lhs_disp, rhs_disp)
DUMPMI(11, LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->DISP);
// 3758 %else
goto L_022C;
L_022B:;
// 3759 load(rhs, any)
LOAD(RHS, 25);
// 3760 dumpmr(MOV, lhs_base!lhs_scope, lhs_disp, rhs_base)
DUMPMR(11, LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->BASE);
// 3761 %finish
L_022C:;
// 3762 %else
goto L_022D;
L_022A:;
// 3763 %if lhs_type = byte %start
if (LHS->TYPE != 5) goto L_022E;
// 3764 %if rhs_form = constant %and rhs_scope = 0 %start
if (RHS->FORM != 0) goto L_022F;
if (RHS->SCOPE != 0) goto L_022F;
// 3765 dumpmi8(MOV, lhs_base!lhs_scope, lhs_disp, rhs_disp)
DUMPMI8(11, LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->DISP);
// 3766 %else
goto L_0230;
L_022F:;
// 3767 %if rhs_type = byte %start; ! try to avoid pointless promoting to an int
if (RHS->TYPE != 5) goto L_0231;
// 3768 ! We will reproduce a "Load" but without the word extension
// 3769 address(rhs)
ADDRESS(RHS);
// 3770 pt = gp reg
PT = GPREG();
// 3771 dumprm8(MOV, pt+16, rhs_base!rhs_scope, rhs_disp)
DUMPRM8(11, PT + 16, RHS->BASE | RHS->SCOPE, RHS->DISP);
// 3772 release(rhs_base)
RELEASE(RHS->BASE);
// 3773 rhs_base = pt; rhs_form = V in R; rhs_type = Integer
RHS->BASE = PT;
RHS->FORM = 1;
RHS->TYPE = 1;
// 3774 claim(pt)
CLAIM(PT);
// 3775 %else
goto L_0232;
L_0231:;
// 3776 load(rhs, any)
LOAD(RHS, 25);
// 3777 ! ABD - should add a capacity check here
// 3778 %finish
L_0232:;
// 3779 dumpmr8(MOV, lhs_base!lhs_scope, lhs_disp, rhs_base+16)
DUMPMR8(11, LHS->BASE | LHS->SCOPE, LHS->DISP, RHS->BASE + 16);
// 3780 %finish
L_0230:;
// 3781 %else
goto L_0233;
L_022E:;
// 3782 load(rhs, anyf)
LOAD(RHS, 28);
// 3783 %if lhs_type = real %start
if (LHS->TYPE != 2) goto L_0234;
// 3784 op = FSTD
OP = 40;
// 3785 %else; ! long real
goto L_0235;
L_0234:;
// 3786 op = FSTQ
OP = 41;
// 3787 %finish
L_0235:;
// 3788 dumpfloprm(op, lhs_base!lhs_scope, lhs_disp)
DUMPFLOPRM(OP, LHS->BASE | LHS->SCOPE, LHS->DISP);
// 3789 %finish
L_0233:;
// 3790 %finish
L_022D:;
// 3791 %end
return;
} /* end of STORE */
// 3792
// 3793 abort("Assign Stack") %if stp < 2
if (STP >= 2) goto L_0236;
ABORT(_imp_str_literal("Assign Stack"));
L_0236:;
// 3794
// 3795 rh == top
RH = (struct STACKFM *)TOP;
// 3796 lh == stack(stp-1)
LH = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 3797
// 3798 form = lh_form; ! to avoid the ravages of amap, load etc
FORM = LH->FORM;
// 3799
// 3800 %if diagnose&4 # 0 %start
if (DIAGNOSE & 4 == 0) goto L_0237;
// 3801 monitor(lh, "ASS LH")
MONITOR(LH, _imp_str_literal_size(15, "ASS LH"));
// 3802 monitor(rh, "ASS RH")
MONITOR(RH, _imp_str_literal_size(15, "ASS RH"));
// 3803 %finish
L_0237:;
// 3804
// 3805 %if same(lh, rh) # 0 %then %start
if (SAME(LH, RH) == 0) goto L_0238;
// 3806 pop rel
POPREL();
// 3807 pop rel
POPREL();
// 3808 %return
return;
// 3809 %finish
L_0238:;
// 3810
// 3811 %if assop < 0 %start; ! Parameter
if (ASSOP >= 0) goto L_0239;
// 3812 %if lh_base >= 128 %start; ! Special - prim routine
if (LH->BASE < 128) goto L_023A;
// 3813 temp = lh; lh = rh; rh = temp
TEMP = *LH;
*LH = *RH;
*RH = TEMP;
// 3814 %return
return;
// 3815 %finish
L_023A:;
// 3816
// 3817 ! Extract the next formal parameter and make it our target
// 3818 lh_pbase = lh_pbase - 1
LH->PBASE = LH->PBASE - 1;
// 3819 push var(lh_pbase)
PUSHVAR(LH->PBASE);
// 3820 ! Now make our destination look reasonable
// 3821 lh == top
LH = (struct STACKFM *)TOP;
// 3822 lh_base = SP; ! target is the stack
LH->BASE = 5;
// 3823 assop = 0 %if lh_form # v in s; ! %name parameter is '=='
if (LH->FORM == 4) goto L_023B;
ASSOP = 0;
L_023B:;
// 3824
// 3825 ! We need special treatment for procedure parameters
// 3826 %if 7 <= lh_aform <= 10 %start; ! this is a procedure
{
// Double-sided test on LH->AFORM (Part I)
int tmp;
if (7 > (tmp = LH->AFORM)) goto L_023C;
// Double-sided test on LH->AFORM (Part II)
if (tmp > 10) goto L_023C;
}
// 3827 assop = 1; ! we will treat it as a value assignment
ASSOP = 1;
// 3828 rh_type = integer; ! of an integer
RH->TYPE = 1;
// 3829 lh_type = integer; lh_form = V in S
LH->TYPE = 1;
LH->FORM = 4;
// 3830 %if rh_base # 0 %start; ! RH is already a parameter
if (RH->BASE == 0) goto L_023D;
// 3831 rh_form = V in S
RH->FORM = 4;
// 3832 %else
goto L_023E;
L_023D:;
// 3833 %if rh_scope = EXT %start; ! it is an external procedure
if (RH->SCOPE != 80) goto L_023F;
// 3834 rh_form = A V in S; ! pick up the addres
RH->FORM = 5;
// 3835 %else; ! it is a local procedure
goto L_0240;
L_023F:;
// 3836 ! HACK: local procedures are Tags until Pass3 fixes them up. The
// 3837 ! only way we have of converting tags to addresses is with the switch
// 3838 ! table - so we'll plant a fake switch entry for the label of the
// 3839 ! local routine, and then load that value!
// 3840 %if swtp >= Max Switch %then abort("Proc - Switch Table Full")
if (SWTP < 1000) goto L_0241;
ABORT(_imp_str_literal("Proc - Switch Table Full"));
L_0241:;
// 3841 swtab(swtp) = rh_disp; rh_disp = swtp * 2; swtp = swtp+1
SWTAB[SWTP] = RH->DISP;
RH->DISP = SWTP * 2;
SWTP = SWTP + 1;
// 3842 rh_scope = SWT
RH->SCOPE = 96;
// 3843 rh_form = V in S
RH->FORM = 4;
// 3844 %finish
L_0240:;
// 3845 %finish
L_023E:;
// 3846 %finish
L_023C:;
// 3847 %finish
L_0239:;
// 3848
// 3849 %if array <= rh_aform %and rh_aform <= namearrayname %start; ! Arrayname
if (11 > RH->AFORM) goto L_0242;
if (RH->AFORM > 14) goto L_0242;
// 3850 ! An array name is two words - a pointer to the data and a
// 3851 ! pointer to the dope vector. If the RHS is already one of these
// 3852 ! then we just want to copy the two words. If it is a static
// 3853 ! array, we need to map the data to make a pointer, and its' dope
// 3854 ! vector will be in the constant table, so we fetch that.
// 3855 amap(lh)
AMAP(LH);
// 3856 address(lh)
ADDRESS(LH);
// 3857 amap(rh); ! This works because arrays are stacked as V in S, arraynames are A in S
AMAP(RH);
// 3858 address(rh)
ADDRESS(RH);
// 3859 ! We do the dope vector first - that makes it easier when we're parameter passing
// 3860 %if rh_aform = array %or rh_aform = name array %start; ! simple static - DV in COT
if (RH->AFORM == 11) goto L_0243;
if (RH->AFORM != 13) goto L_0244;
L_0243:;
// 3861 ! We will rustle up a dummy record for the DV address
// 3862 temp = 0
TEMP = (struct STACKFM){0};
// 3863 temp_form = A V in S
TEMP.FORM = 5;
// 3864 temp_type = integer
TEMP.TYPE = 1;
// 3865 temp_disp = rh_pbase
TEMP.DISP = RH->PBASE;
// 3866 temp_scope = COT
TEMP.SCOPE = 32;
// 3867 %else; ! already an array name
goto L_0245;
L_0244:;
// 3868 temp = rh; claim(temp_base)
TEMP = *RH;
CLAIM(TEMP.BASE);
// 3869 temp_disp = temp_disp + 2
TEMP.DISP = TEMP.DISP + 2;
// 3870 %finish
L_0245:;
// 3871 lh_disp = lh_disp+2
LH->DISP = LH->DISP + 2;
// 3872 store(lh, temp)
STORE(LH, /*?*/ &TEMP);
// 3873 release(temp_base)
RELEASE(TEMP.BASE);
// 3874 lh_disp = lh_disp-2
LH->DISP = LH->DISP - 2;
// 3875 store(lh, rh)
STORE(LH, RH);
// 3876 pop rel
POPREL();
// 3877 pop rel
POPREL();
// 3878 %return
return;
// 3879 %finish
L_0242:;
// 3880
// 3881 %if lh_type = general %start; ! general %name parameter
if (LH->TYPE != 0) goto L_0246;
// 3882 abort("Assign GenName") %unless assop = 0; ! Only '==' is allowed
if (ASSOP == 0) goto L_0247;
ABORT(_imp_str_literal("Assign GenName"));
L_0247:;
// 3883 ! A general name pointer is two words - the pointer itself
// 3884 ! and a second word to convey type information. If the RHS
// 3885 ! is already one of thse guys it's easy - just copy the two
// 3886 ! words. Otherwise, we need to rustle up the second word at
// 3887 ! compile time
// 3888 amap(lh)
AMAP(LH);
// 3889 address(lh)
ADDRESS(LH);
// 3890 %if rh_type = general %start
if (RH->TYPE != 0) goto L_0248;
// 3891 temp = rh; ! make a copy for the second word
TEMP = *RH;
// 3892 claim(temp_base); temp_disp = temp_disp + 2
CLAIM(TEMP.BASE);
TEMP.DISP = TEMP.DISP + 2;
// 3893 amap(temp)
AMAP(/*?*/ &TEMP);
// 3894 %else
goto L_0249;
L_0248:;
// 3895 temp = 0
TEMP = (struct STACKFM){0};
// 3896 temp_type = integer
TEMP.TYPE = 1;
// 3897 temp_disp = (rh_size << 4) + genmap(t)
TEMP.DISP = (RH->SIZE << 4) + GENMAP[T];
// 3898 %finish
L_0249:;
// 3899 amap(rh)
AMAP(RH);
// 3900 store(lh, rh)
STORE(LH, RH);
// 3901 lh_disp = lh_disp + 2
LH->DISP = LH->DISP + 2;
// 3902 store(lh, temp)
STORE(LH, /*?*/ &TEMP);
// 3903 release(temp_base)
RELEASE(TEMP.BASE);
// 3904 pop rel
POPREL();
// 3905 pop rel
POPREL();
// 3906 %return
return;
// 3907 %finish
L_0246:;
// 3908
// 3909 %if assop = 0 %start; ! ==
if (ASSOP != 0) goto L_024A;
// 3910 amap(lh); ! destination
AMAP(LH);
// 3911 amap(rh); ! ABD %string(*)%name NOT handled special here - should be?
AMAP(RH);
// 3912 %finish
L_024A:;
// 3913
// 3914 %if Lh_Type = record %start
if (LH->TYPE != 4) goto L_024B;
// 3915 %if lh_base = SP %start; ! pass record by value - destination is the stack
if (LH->BASE != 5) goto L_024C;
// 3916 n = lh_size
N = LH->SIZE;
// 3917 hazard(DI)
HAZARD(8);
// 3918 dumpri(SUB, SP, lh_size)
DUMPRI(18, 5, LH->SIZE);
// 3919 dumprr(MOV, DI, SP)
DUMPRR(11, 8, 5);
// 3920 claim(DI)
CLAIM(8);
// 3921 lh_base = DI
LH->BASE = 8;
// 3922 %else
goto L_024D;
L_024C:;
// 3923 n = Min Record Size(Lh, Rh)
N = MINRECORDSIZE(LH, RH);
// 3924 amap(lh)
AMAP(LH);
// 3925 load(lh, DI)
LOAD(LH, 8);
// 3926 %finish
L_024D:;
// 3927 hazard(CX)
HAZARD(2);
// 3928 dumpri(MOV, CX, n)
DUMPRI(11, 2, N);
// 3929 %if rh_Form = Constant %start
if (RH->FORM != 0) goto L_024E;
// 3930 hazard(AX)
HAZARD(1);
// 3931 dumprr(XOR, AX,AX); ! get a zero
DUMPRR(19, 1, 1);
// 3932 dumprepstosb
DUMPREPSTOSB();
// 3933 %else
goto L_024F;
L_024E:;
// 3934 amap(rh)
AMAP(RH);
// 3935 load(rh, SI)
LOAD(RH, 7);
// 3936 dumprepmovsb
DUMPREPMOVSB();
// 3937 %finish
L_024F:;
// 3938 pop rel
POPREL();
// 3939 pop rel
POPREL();
// 3940 %return
return;
// 3941 %finish
L_024B:;
// 3942
// 3943 %if lh_type = string %start
if (LH->TYPE != 3) goto L_0250;
// 3944 %if assop > 0 %and rh_format = 1 %start; ! null string as zero byte ?
if (ASSOP <= 0) goto L_0251;
if (RH->FORMAT != 1) goto L_0251;
// 3945 lh_type = byte
LH->TYPE = 5;
// 3946 pop rel; ! zap current RHS
POPREL();
// 3947 push const(0); ! get a zero
PUSHCONST(0);
// 3948 assign(assop); ! and assign it
ASSIGN(ASSOP);
// 3949 %return
return;
// 3950 %finish
L_0251:;
// 3951
// 3952 ! our copy routines expect DEST then SOURCE then LENGTH on the stack
// 3953 %if lh_base = SP %start; ! pass string by value - destination is the stack
if (LH->BASE != 5) goto L_0252;
// 3954 ! space is string size, plus one for length, plus make it even
// 3955 p = lh_size + 1; p = (p+1) & (\1)
P = LH->SIZE + 1;
P = P + 1 & (~1);
// 3956 dumpri(SUB, SP, p)
DUMPRI(18, 5, P);
// 3957 ! we want to Push SP here - sadly different versions of x86
// 3958 ! architecture have different interpretations of "PUSH SP", so...
// 3959 r = gp reg
R = GPREG();
// 3960 dumprr(MOV, r, SP)
DUMPRR(11, R, 5);
// 3961 dumpur(PUSH, r)
DUMPUR(9, R);
// 3962 %else
goto L_0253;
L_0252:;
// 3963 amap(lh)
AMAP(LH);
// 3964 load(lh, any)
LOAD(LH, 25);
// 3965 dumpur(PUSH, lh_base)
DUMPUR(9, LH->BASE);
// 3966 %finish
L_0253:;
// 3967 ! It is likely that the RH variable is a temporary work area
// 3968 ! Before we trash the information, we try to release it
// 3969 Return Work(rh_disp)
RETURNWORK(RH->DISP);
// 3970 amap(rh)
AMAP(RH);
// 3971 load(rh, any)
LOAD(RH, 25);
// 3972 dumpur(PUSH, rh_base)
DUMPUR(9, RH->BASE);
// 3973 pop rel
POPREL();
// 3974 pop rel
POPREL();
// 3975 dumppushi(0, lh_size)
DUMPPUSHI(0, LH->SIZE);
// 3976 %if assop = 2 %then perm(sjam, 6) %else perm(smove, 6)
if (ASSOP != 2) goto L_0254;
PERM(4, 6);
goto L_0255;
L_0254:;
PERM(3, 6);
L_0255:;
// 3977 %return
return;
// 3978 %finish
L_0250:;
// 3979
// 3980 address(lh)
ADDRESS(LH);
// 3981
// 3982 store(lh, rh)
STORE(LH, RH);
// 3983
// 3984 pop rel
POPREL();
// 3985 pop rel
POPREL();
// 3986 %end; ! assign
return;
} /* end of ASSIGN */
// 3987
// 3988 ! >> ARRAY REF <<
// 3989 ! Array references always use the PERM unless they are 1 dimensional, AND
// 3990 ! the %control bit has been turned off
// 3991 %routine array ref(%integer mode)
void ARRAYREF(int MODE) {
// 3992 %record(stackfm)%name av
struct STACKFM *AV;
// 3993 %integer type, form, size, format
int TYPE;
int FORM;
int SIZE;
int FORMAT;
// 3994
// 3995 %if mode#0 %then %start
if (MODE == 0) goto L_0256;
// 3996 ! Put non-terminal index onto stack for PERM
// 3997 %if top_type = byte %start
if (TOP->TYPE != 5) goto L_0257;
// 3998 load(top, any)
LOAD(TOP, 25);
// 3999 %else
goto L_0258;
L_0257:;
// 4000 address(top)
ADDRESS(TOP);
// 4001 %finish
L_0258:;
// 4002 dumpvpush(top)
DUMPVPUSH(TOP);
// 4003 pop rel
POPREL();
// 4004 %return
return;
// 4005 %finish
L_0256:;
// 4006
// 4007 av == stack(stp-1)
AV = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 4008 size = av_size
SIZE = AV->SIZE;
// 4009 size = size + 1 %if av_type = string
if (AV->TYPE != 3) goto L_0259;
SIZE = SIZE + 1;
L_0259:;
// 4010 form = av_aform
FORM = AV->AFORM;
// 4011 %if form=namearray %or form=namearrayname %then size = 2
if (FORM == 13) goto L_0216;
if (FORM != 14) goto L_025A;
L_0216:;
SIZE = 2;
L_025A:;
// 4012
// 4013 %if control & check array = 0 %and av_dim = 1 %start
if (CONTROL & 4 != 0) goto L_025B;
if (AV->DIM != 1) goto L_025B;
// 4014 ! This will be unchecked, the top of the stack is the only index (1D),
// 4015 ! so we can do a cheap multiplication here
// 4016 %if size#1 %start; ! multiply offset by var size
if (SIZE == 1) goto L_025C;
// 4017 push const(size)
PUSHCONST(SIZE);
// 4018 operate(op mul)
OPERATE(3);
// 4019 %finish
L_025C:;
// 4020 %else
goto L_025D;
L_025B:;
// 4021 ! This is the final (and perhaps only) subscript for a checked array,
// 4022 ! so we are going to use the Perm - therefore pass this as a parameter
// 4023 %if top_type = byte %start
if (TOP->TYPE != 5) goto L_025E;
// 4024 load(top, any)
LOAD(TOP, 25);
// 4025 %else
goto L_025F;
L_025E:;
// 4026 address(top)
ADDRESS(TOP);
// 4027 %finish
L_025F:;
// 4028 dumpvpush(top)
DUMPVPUSH(TOP);
// 4029 pop rel
POPREL();
// 4030 %finish
L_025D:;
// 4031
// 4032 ! How we do the rest of the access depends on whether this is a simple
// 4033 ! static array, or an array name...
// 4034
// 4035 %if form = arrayname %or form = namearrayname %start; ! array is a "name"
if (FORM == 12) goto L_0260;
if (FORM != 14) goto L_0261;
L_0260:;
// 4036 ! We will AMAP the name, so we remember the info and then put it all back later
// 4037 type = av_type
TYPE = AV->TYPE;
// 4038 format = av_format
FORMAT = AV->FORMAT;
// 4039 size = av_size
SIZE = AV->SIZE;
// 4040 %if form = arrayname %then form = v in s %else form = a in s
if (FORM != 12) goto L_0262;
FORM = 4;
goto L_0263;
L_0262:;
FORM = 6;
L_0263:;
// 4041 amap(av)
AMAP(AV);
// 4042
// 4043 %if control & check array # 0 %or av_dim > 1 %start; ! do the rest of the check
if (CONTROL & 4 != 0) goto L_0264;
if (AV->DIM <= 1) goto L_0265;
L_0264:;
// 4044 ! This is a bit clunky, because we may load registers in order
// 4045 ! to access AV, only to Hazard them for the PERM
// 4046 address(av)
ADDRESS(AV);
// 4047 push copy(av); claim(top_base)
PUSHCOPY(AV);
CLAIM(TOP->BASE);
// 4048 top_disp = top_disp + 2; ! Dope Vector address follows A(0)
TOP->DISP = TOP->DISP + 2;
// 4049 dumpvpush(top)
DUMPVPUSH(TOP);
// 4050 pop rel
POPREL();
// 4051 perm(aref, (av_dim * 2) + 2); ! DV word, plus a word for every subscript
PERM(9, AV->DIM * 2 + 2);
// 4052 push const(0)
PUSHCONST(0);
// 4053 top_form = V in R; top_base = AX; claim(AX)
TOP->FORM = 1;
TOP->BASE = 1;
CLAIM(1);
// 4054 %finish
L_0265:;
// 4055
// 4056 load(top, anyp); ! make sure index is in a pointer register
LOAD(TOP, 27);
// 4057 operate(op add)
OPERATE(1);
// 4058 top_type = type
TOP->TYPE = TYPE;
// 4059 top_form = form
TOP->FORM = FORM;
// 4060 top_format = format
TOP->FORMAT = FORMAT;
// 4061 top_size = size
TOP->SIZE = SIZE;
// 4062 top_disp = 0
TOP->DISP = 0;
// 4063 %else; ! simple arrays are always 1D, but can still be checked
goto L_0266;
L_0261:;
// 4064 %if control & check array # 0 %start
if (CONTROL & 4 == 0) goto L_0267;
// 4065 ! Pass a pointer to the Dope Vector
// 4066 dumppushi(COT, av_pbase); ! simple arrays have compile-time DV's in the COT
DUMPPUSHI(32, AV->PBASE);
// 4067 perm(aref, 4)
PERM(9, 4);
// 4068 push const(0)
PUSHCONST(0);
// 4069 top_form = V in R; top_base = AX; claim(AX)
TOP->FORM = 1;
TOP->BASE = 1;
CLAIM(1);
// 4070 %finish
L_0267:;
// 4071
// 4072 address(av)
ADDRESS(AV);
// 4073 %if av_form # v in s %then abort("Aref Form")
if (AV->FORM == 4) goto L_0268;
ABORT(_imp_str_literal("Aref Form"));
L_0268:;
// 4074 %if top_form = constant %start; ! simple constant a(k)
if (TOP->FORM != 0) goto L_0269;
// 4075 av_disp = av_disp + top_disp; ! just add it to the offset
AV->DISP = AV->DISP + TOP->DISP;
// 4076 %else
goto L_026A;
L_0269:;
// 4077 load(top, anyp); ! pick up index in a pointer
LOAD(TOP, 27);
// 4078 %if av_base # 0 %start; ! add the base we've already got
if (AV->BASE == 0) goto L_026B;
// 4079 dumprr(ADD, top_base, av_base)
DUMPRR(14, TOP->BASE, AV->BASE);
// 4080 release(av_base)
RELEASE(AV->BASE);
// 4081 %finish
L_026B:;
// 4082 av_base = top_base
AV->BASE = TOP->BASE;
// 4083 %finish
L_026A:;
// 4084 %if form = array %then av_form = v in s %else av_form = a in s
if (FORM != 11) goto L_026C;
AV->FORM = 4;
goto L_026D;
L_026C:;
AV->FORM = 6;
L_026D:;
// 4085 pop stack
POPSTACK();
// 4086 %finish
L_0266:;
// 4087
// 4088 top_aform = 0; ! not an array any more
TOP->AFORM = 0;
// 4089
// 4090 %end; ! array ref
return;
} /* end of ARRAYREF */
// 4091
// 4092 ! >> TEST ZERO <<
// 4093 ! test a real/integer/byte variable against zero
// 4094 %routine test zero(%record(stackfm)%name v)
void TESTZERO(struct STACKFM * V) {
// 4095
// 4096 %if v_type = integer %or v_type = byte %start
if (V->TYPE == 1) goto L_026E;
if (V->TYPE != 5) goto L_026F;
L_026E:;
// 4097 load(v,any)
LOAD(V, 25);
// 4098 dumpri(CMP, v_base, 0)
DUMPRI(16, V->BASE, 0);
// 4099 %else
goto L_0270;
L_026F:;
// 4100 abort("Test Zero")
ABORT(_imp_str_literal("Test Zero"));
// 4101 %finish
L_0270:;
// 4102 %end; ! test zero
return;
} /* end of TESTZERO */
// 4103
// 4104 %routine Compare Records(%record(stackfm)%name L, R, %integer N)
void COMPARERECORDS(struct STACKFM * L, struct STACKFM * R, int N) {
// 4105 abort("Compare Records")
ABORT(_imp_str_literal("Compare Records"));
// 4106 %end
return;
} /* end of COMPARERECORDS */
// ?N unused
// ?R unused
// ?L unused
// 4107
// 4108 ! >> COMPARE REALS <<
// 4109 %routine compare reals(%record(stackfm)%name l,r)
void COMPAREREALS(struct STACKFM * L, struct STACKFM * R) {
// 4110 load(l, anyf)
LOAD(L, 28);
// 4111 load(r, anyf)
LOAD(R, 28);
// 4112 hazard(AX)
HAZARD(1);
// 4113 ! who's ended up on top?
// 4114 %if l_base > r_base %start; ! l_base is the top of the FPU stack
if (L->BASE <= R->BASE) goto L_0271;
// 4115 dumpfloprr(FCMP, r_base, l_base)
DUMPFLOPRR(48, R->BASE, L->BASE);
// 4116 %else
goto L_0272;
L_0271:;
// 4117 dumpfloprr(FCMP, l_base, r_base)
DUMPFLOPRR(48, L->BASE, R->BASE);
// 4118 invert = invert !! 1
INVERT = INVERT ^ 1;
// 4119 %finish
L_0272:;
// 4120 dumpflopspec(FSTSW); ! puts status into AX
DUMPFLOPSPEC(51);
// 4121 dumpsimple(SAHF); ! and move it to flags
DUMPSIMPLE(3);
// 4122 compare unsign = 1; ! because FPU reports as if operands were unsigned
COMPAREUNSIGN = 1;
// 4123 %end; ! compare reals
return;
} /* end of COMPAREREALS */
// 4124
// 4125 ! >> COMPARE STRINGS <<
// 4126 %routine compare strings(%record(stackfm)%name l,r)
void COMPARESTRINGS(struct STACKFM * L, struct STACKFM * R) {
// 4127 %record(stackfm)%name temp
struct STACKFM *TEMP;
// 4128 %if l_base = COT %and l_disp = null string %start
if (L->BASE != 32) goto L_0273;
if (L->DISP != NULLSTRING) goto L_0273;
// 4129 temp == r; r == l; l == temp
TEMP = (struct STACKFM *)R;
R = (struct STACKFM *)L;
L = (struct STACKFM *)TEMP;
// 4130 invert = invert !! 1
INVERT = INVERT ^ 1;
// 4131 %finish
L_0273:;
// 4132 %if r_base = COT %and r_disp = null string %start
if (R->BASE != 32) goto L_0274;
if (R->DISP != NULLSTRING) goto L_0274;
// 4133 l_type = byte
L->TYPE = 5;
// 4134 test zero(l)
TESTZERO(L);
// 4135 %else
goto L_0275;
L_0274:;
// 4136 amap(l)
AMAP(L);
// 4137 load(l, any)
LOAD(L, 25);
// 4138 dumpur(PUSH, l_base)
DUMPUR(9, L->BASE);
// 4139 amap(r)
AMAP(R);
// 4140 load(r, any)
LOAD(R, 25);
// 4141 dumpur(PUSH, r_base)
DUMPUR(9, R->BASE);
// 4142 perm(scomp, 4)
PERM(8, 4);
// 4143 dumpri(CMP, AX, 0)
DUMPRI(16, 1, 0);
// 4144 %finish
L_0275:;
// 4145 %end; ! compare strings
return;
} /* end of COMPARESTRINGS */
// 4146
// 4147 ! >> COMPARE <<
// 4148 %routine compare(%record(stackfm)%name l,r)
void COMPARE(struct STACKFM * L, struct STACKFM * R) {
// 4149 %if l_type = 0 %or l_type = string %start
if (L->TYPE == 0) goto L_0276;
if (L->TYPE != 3) goto L_0277;
L_0276:;
// 4150 compare strings(l,r); %return
COMPARESTRINGS(L, R);
return;
// 4151 %finish
L_0277:;
// 4152 %if floating(l)#0 %or floating(r)#0 %start
if (FLOATING(L) != 0) goto L_0278;
if (FLOATING(R) == 0) goto L_0279;
L_0278:;
// 4153 compare reals(l,r); %return
COMPAREREALS(L, R);
return;
// 4154 %finish
L_0279:;
// 4155 %if zero(r) # 0 %start
if (ZERO(R) == 0) goto L_027A;
// 4156 test zero(l); %return
TESTZERO(L);
return;
// 4157 %finish
L_027A:;
// 4158 %if zero(l) # 0 %start
if (ZERO(L) == 0) goto L_027B;
// 4159 test zero(r); invert = invert !! 1
TESTZERO(R);
INVERT = INVERT ^ 1;
// 4160 %return
return;
// 4161 %finish
L_027B:;
// 4162 %if L_Type = Record %start
if (L->TYPE != 4) goto L_027C;
// 4163 Compare Records(L, R, Min Record Size(L, R))
COMPARERECORDS(L, R, MINRECORDSIZE(L, R));
// 4164 %return
return;
// ?access
// 4165 %finish
L_027C:;
// 4166 load(l,any)
LOAD(L, 25);
// 4167 %if r_type = byte %start
if (R->TYPE != 5) goto L_027D;
// 4168 load(r, anyg)
LOAD(R, 26);
// 4169 %else
goto L_027E;
L_027D:;
// 4170 address(r)
ADDRESS(R);
// 4171 %finish
L_027E:;
// 4172 dumprv(CMP, l_base, r)
DUMPRV(16, L->BASE, R);
// 4173 %end; ! compare
return;
} /* end of COMPARE */
// 4174
// 4175 ! >> RESOLVE <<
// 4176 %routine resolve(%integer flag)
void RESOLVE(int FLAG) {
// 4177 !S -> A.(B).C
// 4178 %if flag&1 = 0 %then push const(0) %else amap(top); ! C missing?
if (FLAG & 1 != 0) goto L_027F;
PUSHCONST(0);
goto L_0280;
L_027F:;
AMAP(TOP);
L_0280:;
// 4179 load(top, any)
LOAD(TOP, 25);
// 4180 dumpur(PUSH, top_base)
DUMPUR(9, TOP->BASE);
// 4181 pop rel
POPREL();
// 4182 amap(top); ! B
AMAP(TOP);
// 4183 load(top, any)
LOAD(TOP, 25);
// 4184 dumpur(PUSH, top_base)
DUMPUR(9, TOP->BASE);
// 4185 pop rel
POPREL();
// 4186 %if flag&2 = 0 %then push const(0) %else amap(top); ! A missing?
if (FLAG & 2 != 0) goto L_0281;
PUSHCONST(0);
goto L_0282;
L_0281:;
AMAP(TOP);
L_0282:;
// 4187 load(top, any)
LOAD(TOP, 25);
// 4188 dumpur(PUSH, top_base)
DUMPUR(9, TOP->BASE);
// 4189 pop rel
POPREL();
// 4190 amap(top); ! S
AMAP(TOP);
// 4191 load(top, any)
LOAD(TOP, 25);
// 4192 dumpur(PUSH, top_base)
DUMPUR(9, TOP->BASE);
// 4193 pop rel
POPREL();
// 4194 perm(sresln, 8)
PERM(7, 8);
// 4195 %if flag&4 # 0 %then dumpri(CMP, AX, 0)
if (FLAG & 4 == 0) goto L_0283;
DUMPRI(16, 1, 0);
L_0283:;
// 4196 %end; ! resolve
return;
} /* end of RESOLVE */
// 4197
// 4198
// 4199 %integerfn enter
int ENTER(void) {
// 4200 %integer cad;
int CAD;
// 4201
// 4202 uncond jump = -1; ! can get here
UNCONDJUMP = -1;
// 4203
// 4204 ! This is a convenient place to include external definitions if needed
// 4205 %if potype >= external %start
if (POTYPE < 3) goto L_0284;
// 4206 fill external(CODE, next cad, external id)
FILLEXTERNAL(112, NEXTCAD,
*({
__typeof__(_imp_string255) tmp = EXTERNALID /*q*/;
(_imp_string255 *)&tmp;
})
);
// 4207 %finish
L_0284:;
// 4208
// 4209 dumprm(MOV, BX, DISPLAY,level*2);
DUMPRM(11, 4, 64, LEVEL * 2);
// 4210 dumpur(PUSH, BX);
DUMPUR(9, 4);
// 4211 dumpur(PUSH, BP);
DUMPUR(9, 6);
// 4212 dumprr(MOV, BP,SP);
DUMPRR(11, 6, 5);
// 4213 dumpmr(MOV, DISPLAY, level*2, BP);
DUMPMR(11, 64, LEVEL * 2, 6);
// 4214
// 4215 cad = nextcad;
CAD = NEXTCAD;
// 4216 dumpstaticalloc(cad); ! plants code to subtract static allocation (if any) from SP
DUMPSTATICALLOC(CAD);
// 4217 %result = cad;
return CAD;
// 4218 %end
} /* end of ENTER */
// 4219
// 4220 ! >> DUMP RETURN <<
// 4221 %routine dump return
void DUMPRETURN(void) {
// 4222 %return %if uncond jump = next cad; ! can't get here ?
if (UNCONDJUMP != NEXTCAD) goto L_0285;
return;
L_0285:;
// 4223
// 4224 dumprr(MOV, SP, BP);
DUMPRR(11, 5, 6);
// 4225 dumpur(POP, BP);
DUMPUR(8, 6);
// 4226 dumpur(POP, BX);
DUMPUR(8, 4);
// 4227 dumpmr(MOV, DISPLAY, level*2, BX);
DUMPMR(11, 64, LEVEL * 2, 4);
// 4228 dumpsimple(RET);
DUMPSIMPLE(2);
// 4229
// 4230 uncond jump = next cad
UNCONDJUMP = NEXTCAD;
// 4231 %end; ! return
return;
} /* end of DUMPRETURN */
// 4232
// 4233 ! Routine to do "to string" as an in-line, either by making
// 4234 ! a constant string in the CONST area, or putting one onto
// 4235 ! the current workspace
// 4236 %routine compile to string(%record(stackfm)%name v)
void COMPILETOSTRING(struct STACKFM * V) {
// 4237 %integer tmp
int TMP;
// 4238
// 4239 %if const(v)#0 %start
if (CONST(V) == 0) goto L_0286;
// 4240 current string(0) = 1; current string(1) = v_disp&255
CURRENTSTRING[0] = 1;
CURRENTSTRING[1] = V->DISP & 255;
// 4241 v_base = COT; v_disp = getcots(current string)
V->BASE = 32;
V->DISP = GETCOTS(CURRENTSTRING);
// 4242 %else
goto L_0287;
L_0286:;
// 4243 tmp = getwork(2)
TMP = GETWORK(2);
// 4244 load(v,anyg); ! Must be a byte-addressable register
LOAD(V, 26);
// 4245 dumpri(AND, v_base, 255)
DUMPRI(15, V->BASE, 255);
// 4246 dumpri(OR, v_base, 16_0100)
DUMPRI(17, V->BASE, 256);
// 4247 dumprr8(XCHG, v_base+16, v_base+20)
DUMPRR8(12, V->BASE + 16, V->BASE + 20);
// 4248 dumpmr(MOV, BP, tmp, v_base)
DUMPMR(11, 6, TMP, V->BASE);
// 4249 release(v_base)
RELEASE(V->BASE);
// 4250 v_base = BP; v_disp = tmp
V->BASE = 6;
V->DISP = TMP;
// 4251 %finish
L_0287:;
// 4252 v_type = string; v_form = VinS; v_size = 1
V->TYPE = 3;
V->FORM = 4;
V->SIZE = 1;
// 4253 %end
return;
} /* end of COMPILETOSTRING */
// 4254
// 4255 ! >> COMPILE CALL <<
// 4256 ! Call the routine on the top of the stack. Note - the parameters
// 4257 ! are all hidden underneath the routine, so we need to push them
// 4258 ! here
// 4259 %routine compile call(%record(stackfm)%name v)
void COMPILECALL(struct STACKFM * V) {
// 4260 %switch b(1:15)
int B_index;
int B_line;
char *B_file;
static const void *B[15] = {&&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing,
&&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing,
&&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing,
&&case_B_missing, &&case_B_missing, &&case_B_missing};
// 4261 ! 1 = rem
// 4262 ! 2 = float
// 4263 ! 3 = to string
// 4264 ! 4 = addr
// 4265 ! 5 = integer
// 4266 ! 6 = byte integer
// 4267 ! 7 = string
// 4268 ! 8 = record
// 4269 ! 9 = real
// 4270 ! 10 = long real
// 4271 ! 11 = length
// 4272 ! 12 = charno
// 4273 ! 13 = type of ( type of general name parameter )
// 4274 ! 14 = size of ( physical length in bytes )
// 4275 ! 15 = int (from real)
// 4276
// 4277 %constbyteintegerarray new type(5:12) =
const unsigned char NEWTYPE[8] = {1, 5, 3, 4, 2, 6, 5, 5};
// 4278+ 1, 5, 3, 4, 2, 6, 5, 5
// 4279 ! integer, byte, string, record, real, lreal, byte, byte
// 4280 %integer t,l,p
int T;
int L;
int P;
// 4281
// 4282 %if v_base >= 128 %start; ! built-in primitive
if (V->BASE < 128) goto L_0288;
// 4283 l = 0; t = v_disp; sym = 0; ! 'sym=0' used as flag elsewhere
L = 0;
T = V->DISP;
SYM = 0;
// 4284 pop rel
POPREL();
// 4285 -> b(t)
B_line = __LINE__;
B_file = __FILE__;
B_index = T;
goto case_B_dispatch;
// 4286 b(1):; ! REM
case_B_1:;
// 4287 operate(op rem); %return
OPERATE(11);
return;
// 4288 b(2):; ! FLOAT
case_B_2:;
// 4289 load(top, anyf)
LOAD(TOP, 28);
// 4290 %return
return;
// 4291 b(3):; ! TO STRING
case_B_3:;
// 4292 compile to string(top)
COMPILETOSTRING(TOP);
// 4293 %return
return;
// 4294 b(4):; ! ADDR
case_B_4:;
// 4295 amap(top)
AMAP(TOP);
// 4296 %return
return;
// 4297
// 4298 b(11):; ! LENGTH
case_B_11:;
// 4299 push const(0); ! length is charno zero
PUSHCONST(0);
// 4300 b(12):; ! CHARNO
case_B_12:;
// 4301 amap(stack(stp-1))
AMAP(/*?*/ &STACK[STP - 1 - 1]);
// 4302 operate(op add); !LHS&RHS reversed in operate??
OPERATE(1);
// 4303 -> map it
goto U_1014;
// 4304 b(7):; ! STRING
case_B_7:;
// 4305 b(5):b(6):; ! INTEGER, BYTE
case_B_5:;
case_B_6:;
// 4306 b(8):; ! RECORD
case_B_8:;
// 4307 b(9):b(10):; ! REAL, LONG REAL
case_B_9:;
case_B_10:;
// 4308 map it:
U_1014:;
// 4309 vmap(top); top_type = new type(t)
VMAP(TOP);
TOP->TYPE = NEWTYPE[T - 5];
// 4310 top_size = v size(top_Type)
TOP->SIZE = VSIZE[TOP->TYPE];
// 4311 %return
return;
// 4312 b(13):; ! type of(..)
case_B_13:;
// 4313 b(14):; ! size of(..)
case_B_14:;
// 4314 %if top_type # general %start; ! type explicitly specified
if (TOP->TYPE == 0) goto L_0289;
// 4315 %if t = 14 %start; ! type of
if (T != 14) goto L_028A;
// 4316 p = gen map(top_type)
P = GENMAP[TOP->TYPE];
// 4317 %else
goto L_028B;
L_028A:;
// 4318 p = top_size; p = p+1 %if top_type = string
P = TOP->SIZE;
if (TOP->TYPE != 3) goto L_028C;
P = P + 1;
L_028C:;
// 4319 %finish
L_028B:;
// 4320 release(top_base)
RELEASE(TOP->BASE);
// 4321 top_type = integer; top_form = constant
TOP->TYPE = 1;
TOP->FORM = 0;
// 4322 top_base = 0; top_disp = p
TOP->BASE = 0;
TOP->DISP = P;
// 4323 %else
goto L_028D;
L_0289:;
// 4324 top_disp = top_disp + 2; ! reference property-word
TOP->DISP = TOP->DISP + 2;
// 4325 top_form = V in S; top_type = integer
TOP->FORM = 4;
TOP->TYPE = 1;
// 4326 %if t = 14 %start; ! type of
if (T != 14) goto L_028E;
// 4327 push const(15); operate(op and)
PUSHCONST(15);
OPERATE(6);
// 4328 %else; ! size of
goto L_028F;
L_028E:;
// 4329 push const(4); operate(op rsh)
PUSHCONST(4);
OPERATE(10);
// 4330 %finish
L_028F:;
// 4331 %finish
L_028D:;
// 4332 %return
return;
// 4333 b(15):; ! INT(real)
case_B_15:;
// 4334 load(top, anyf)
LOAD(TOP, 28);
// 4335 release(top_base)
RELEASE(TOP->BASE);
// 4336 p = getwork(2)
P = GETWORK(2);
// 4337 dumpfloprm(FSTI, BP, p)
DUMPFLOPRM(39, 6, P);
// 4338 top_type = integer
TOP->TYPE = 1;
// 4339 top_form = V in S
TOP->FORM = 4;
// 4340 top_base = BP
TOP->BASE = 6;
// 4341 top_disp = p
TOP->DISP = P;
// 4342 %return
return;
// 4343 %finish
L_0288:;
// 4344
// 4345 ! -- normal routine calls --
// 4346
// 4347 ! String functions have a hidden last parameter to point
// 4348 ! to the result area
// 4349 %if v_type = string %and v_aform = 8 %start
if (V->TYPE != 3) goto L_0290;
if (V->AFORM != 8) goto L_0290;
// 4350 t = getwork(v_size+1)
T = GETWORK(V->SIZE + 1);
// 4351 p = gp reg
P = GPREG();
// 4352 dumprm(LEA, p, BP, t)
DUMPRM(10, P, 6, T);
// 4353 dumpur(PUSH, p)
DUMPUR(9, P);
// 4354 %finish
L_0290:;
// 4355 hazard all
HAZARDALL();
// 4356 %if v_scope = EXT %start; ! external
if (V->SCOPE != 80) goto L_0291;
// 4357 dumpextcall(v_disp)
DUMPEXTCALL(V->DISP);
// 4358 %else
goto L_0292;
L_0291:;
// 4359 %if v_base # 0 %start; ! procedure-as-parameter
if (V->BASE == 0) goto L_0293;
// 4360 dumpum(CALL, v_base, v_disp); ! plants call indirect through variable
DUMPUM(24, V->BASE, V->DISP);
// 4361 %else; ! local routine
goto L_0294;
L_0293:;
// 4362 dumpjump(CALL, v_disp); ! plants fixup for the tag
DUMPJUMP(24, V->DISP);
// 4363 %finish
L_0294:;
// 4364 %finish
L_0292:;
// 4365 ! adjust the stack
// 4366 %if v_extra # 0 %then dumpri(ADD, SP, v_extra)
if (V->EXTRA == 0) goto L_0295;
DUMPRI(14, 5, V->EXTRA);
L_0295:;
// 4367 %if v_type = 0 %start; ! not function or map
if (V->TYPE != 0) goto L_0296;
// 4368 pop rel
POPREL();
// 4369 %else; ! Here we've got a result
goto L_0297;
L_0296:;
// 4370 v_scope = 0; ! Result is local, even if the function wasn't
V->SCOPE = 0;
// 4371 %if v_type = string %and v_aform = 8 %start
if (V->TYPE != 3) goto L_0298;
if (V->AFORM != 8) goto L_0298;
// 4372 v_base = BP; ! String result will have been copied back here
V->BASE = 6;
// 4373 v_disp = t
V->DISP = T;
// 4374 v_form = V in S
V->FORM = 4;
// 4375 %else
goto L_0299;
L_0298:;
// 4376 v_base = AX; ! Result is always in AX
V->BASE = 1;
// 4377 v_disp = 0; ! Clear this for MAP results
V->DISP = 0;
// 4378 claim(AX)
CLAIM(1);
// 4379 %if (v_type = real %or v_type = lreal) %and v_aform = 8 %start
if (V->TYPE == 2) goto L_029A;
if (V->TYPE != 6) goto L_029B;
L_029A:;
if (V->AFORM != 8) goto L_029B;
// 4380 ! Floating result will be in the "FAC" location, pointed at by AX
// 4381 ! In other words, it comes out like a %map. Unfortunately the
// 4382 ! FAC location is global, so we need to copy it back out of there
// 4383 ! before somebody steps on it
// 4384 v_form = V in S
V->FORM = 4;
// 4385 load(v, anyf)
LOAD(V, 28);
// 4386 %finish
L_029B:;
// 4387 %finish
L_0299:;
// 4388 %finish
L_0297:;
// 4389 %end; ! call
return;
case_B_dispatch:
if (B_index < 1 || B_index > 15)
_imp_signalf(6, 3, B_index, "->B(%d) out of bounds at %s line %d", B_index, B_file, B_line);
goto *B[B_index - 1];
case_B_missing:
_imp_signalf(8, 2, B_index, "switch jump to undefined label B(%d): at %s line %d", B_index, B_file, B_line);
} /* end of COMPILECALL */
// 4390
// 4391 ! >> COMPILE FOR <<
// 4392 %routine compile for
void COMPILEFOR(void) {
// 4393 %record(stackfm)%name cv, iv, inc, fv
struct STACKFM *CV;
struct STACKFM *IV;
struct STACKFM *INC;
struct STACKFM *FV;
// 4394 %integer lab, n
int LAB;
int N;
// 4395
// 4396 ! Lock a value into a temporary to make sure it is invariant
// 4397 %routine stab(%record(stackfm)%name v, %integer type)
void STAB(struct STACKFM * V, int TYPE) {
// 4398 %integer t,r
int T;
int R;
// 4399 %return %if const(v)#0
if (CONST(V) == 0) goto L_029C;
return;
L_029C:;
// 4400 load(v,any); r = v_base
LOAD(V, 25);
R = V->BASE;
// 4401 t = getwork(2)
T = GETWORK(2);
// 4402 dumpmr(MOV, BP,t, r)
DUMPMR(11, 6, T, R);
// 4403 v_base = BP; v_disp = t; v_scope = 0
V->BASE = 6;
V->DISP = T;
V->SCOPE = 0;
// 4404 v_type = type; v_form = V in S
V->TYPE = TYPE;
V->FORM = 4;
// 4405 release(r)
RELEASE(R);
// 4406 %end
return;
} /* end of STAB */
// 4407
// 4408 iv == top
IV = (struct STACKFM *)TOP;
// 4409 fv == stack(stp-1)
FV = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 4410 inc == stack(stp-2)
INC = (struct STACKFM *)/*?*/ &STACK[STP - 2 - 1];
// 4411 cv == stack(stp-3)
CV = (struct STACKFM *)/*?*/ &STACK[STP - 3 - 1];
// 4412 lab = read tag
LAB = READTAG();
// 4413
// 4414 stab(fv,integer)
STAB(FV, 1);
// 4415 stab(inc,integer)
STAB(INC, 1);
// 4416
// 4417 %if cv_form # v in s %or (cv_base # 0 %and activity(cv_base) >= 0) %start
if (CV->FORM != 4) goto L_029D;
if (CV->BASE == 0) goto L_029E;
if (ACTIVITY[CV->BASE] < 0) goto L_029E;
L_029D:;
// 4418 n = cv_type
N = CV->TYPE;
// 4419 amap(cv)
AMAP(CV);
// 4420 stab(cv, n)
STAB(CV, N);
// 4421 cv_form = a in s
CV->FORM = 6;
// 4422 %finish
L_029E:;
// 4423
// 4424 push copy(cv)
PUSHCOPY(CV);
// 4425 push copy(iv)
PUSHCOPY(IV);
// 4426 push copy(inc);
PUSHCOPY(INC);
// 4427 operate(op sub)
OPERATE(2);
// 4428 assign(1); ! cv = iv - inc
ASSIGN(1);
// 4429
// 4430 define label(lab)
DEFINELABEL(LAB);
// 4431 pop stack;! zap unwanted copy of IV
POPSTACK();
// 4432
// 4433 ! Stack is now top->[FV[INC[CV
// 4434 push copy(cv); ! in case compare alters it
PUSHCOPY(CV);
// 4435 compare(top, fv)
COMPARE(TOP, FV);
// 4436 jump to(lab+1, JE, 1)
JUMPTO(LAB + 1, 25, 1);
// 4437 invert = 0; ! because the compare might have flipped this (N/A for JE)
INVERT = 0;
// 4438 ! Stack is now top->[CV'[FV[INC[CV where CV' is a register copy of CV
// 4439 release(fv_base); fv = top; ! trash FV and make a copy of CV' in that slot
RELEASE(FV->BASE);
*FV = *TOP;
// 4440 pop stack; ! discard the top copy
POPSTACK();
// 4441 ! stack is now top->[CV'[INC[CV
// 4442 operate(op add)
OPERATE(1);
// 4443 assign(1)
ASSIGN(1);
// 4444 %end; ! for
return;
} /* end of COMPILEFOR */
// 4445
// 4446 !--------------------------------------------------------------
// 4447 ! Code for ASSEMBLE starts here...
// 4448
// 4449
// 4450 First Name = Names
FIRSTNAME = NAMES;
// 4451 First Label = Labs
FIRSTLABEL = LABS;
// 4452 Proc Var == Decvar
PROCVAR = (struct VARFM *)DECVAR;
// 4453 last skip = -1
LASTSKIP = -1;
// 4454 old frame = frame
OLDFRAME = FRAME;
// 4455 frame = 0
FRAME = 0;
// 4456
// 4457 %if amode >= 0 %start; ! NOT A RECORDFORMAT
if (AMODE < 0) goto L_029F;
// 4458 level = level+1; abort("Level") %if level > max level %and spec = 0
LEVEL = LEVEL + 1;
if (LEVEL <= 16) goto L_02A0;
if (SPEC != 0) goto L_02A0;
ABORT(_imp_str_literal("Level"));
L_02A0:;
// 4459 worklist(level) = 0
WORKLIST[LEVEL - 1] = 0;
// 4460
// 4461 %if amode = 0 %start; ! %begin block
if (AMODE != 0) goto L_02A1;
// 4462 %if level = 1 %start; ! Initial %begin ?
if (LEVEL != 1) goto L_02A2;
// 4463 external id = program ep; ! linkage to program entry
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string8) tmp; /*B*/
tmp = PROGRAMEP;
(void *)&tmp;
}),
/*max:*/ 255);
// 4464 otype = external; potype = otype
OTYPE = 3;
POTYPE = OTYPE;
// 4465 %finish
L_02A2:;
// 4466 static alloc = enter
STATICALLOC = ENTER();
// 4467 %finish
L_02A1:;
// 4468 %else
goto L_02A3;
L_029F:;
// 4469 %if amode = -1 %start; ! normal record format
if (AMODE != -1) goto L_02A4;
// 4470 ProcVar_pbase = parms; ! where our members start
PROCVAR->PBASE = PARMS;
// 4471 %else
goto L_02A5;
L_02A4:;
// 4472 %if amode = -2 %then frame = oldframe; ! alternates start at the current offset
if (AMODE != -2) goto L_02A6;
FRAME = OLDFRAME;
L_02A6:;
// 4473 %finish
L_02A5:;
// 4474 max frame = frame; ! start counting space here
MAXFRAME = FRAME;
// 4475 %finish
L_02A3:;
// 4476
// 4477 ! --- main compilation loop ---
// 4478 next: sym = nextsym; read symbol(nextsym)
U_100E:;
SYM = NEXTSYM;
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 4479 %if sym < 33 %or sym > 127 %then %start
if (SYM < 33) goto L_02A7;
if (SYM <= 127) goto L_02A8;
L_02A7:;
// 4480 selectoutput(0)
_imp_SELECTOUTPUT(0);
// 4481 printsymbol('('); write(sym, 1); printsymbol(','); write(nextsym, 1); printsymbol(')')
_imp_PRINTSYMBOL(40);
_imp_WRITE(SYM, 1);
_imp_PRINTSYMBOL(44);
_imp_WRITE(NEXTSYM, 1);
_imp_PRINTSYMBOL(41);
// 4482 abort("Bad I Code")
ABORT(_imp_str_literal("Bad I Code"));
// 4483 %finish
L_02A8:;
// 4484 -> c(sym)
C_line = __LINE__;
C_file = __FILE__;
C_index = SYM;
goto case_C_dispatch;
// 4485
// 4486 c('l'): %if read tag # 0 %then abort("Language")
case_C_108:;
if (READTAG() == 0) goto L_02AA;
ABORT(_imp_str_literal("Language"));
L_02AA:;
// 4487 ->next; ! We only support standard IMP
goto U_100E;
// 4488
// 4489 c('O'):; ! Set line number
case_C_79:;
// 4490 abort("Stack?") %if stp # 0
if (STP == 0) goto L_02AB;
ABORT(_imp_str_literal("Stack?"));
L_02AB:;
// 4491 abort("Claimed") %if claimed # 0
if (CLAIMED == 0) goto L_02AC;
ABORT(_imp_str_literal("Claimed"));
L_02AC:;
// 4492 current line = read tag
CURRENTLINE = READTAG();
// 4493 ! Pass1 sends the line number multiple times if there's more than
// 4494 ! one statement per line - for debugging we only want "real" line numbers
// 4495 %if echo line < current line %start
if (ECHOLINE >= CURRENTLINE) goto L_02AD;
// 4496 dump line number(current line)
DUMPLINENUMBER(CURRENTLINE);
// 4497 %while echo line < current line %cycle
L_02AE:;
if (ECHOLINE >= CURRENTLINE) goto L_02AF;
// 4498 echo source line
ECHOSOURCELINE();
// 4499 %repeat
goto L_02AE;
L_02AF:;
// 4500 %finish
L_02AD:;
// 4501 ->next
goto U_100E;
// 4502
// 4503 c('$'): define var; ->next; ! Define VAR
case_C_36:;
DEFINEVAR();
goto U_100E;
// 4504
// 4505 c('b'):; ! Define constant bounded Dope Vector
case_C_98:;
// 4506 vub = top_disp; pop stack
VUB = TOP->DISP;
POPSTACK();
// 4507 vlb = top_disp; pop stack
VLB = TOP->DISP;
POPSTACK();
// 4508 ->next
goto U_100E;
// 4509
// 4510 ! Utility routine used when dumping initialisers for OWNs
// 4511 ! Note non-portable use of real values
// 4512 %routine adump
void ADUMP(void) {
// 4513 %integer i
int I;
// 4514 %real rv32
float RV32;
// 4515 %switch ot(0:6)
int OT_index;
int OT_line;
char *OT_file;
static const void *OT[7] = {&&case_OT_0, &&case_OT_1, &&case_OT_2, &&case_OT_3,
&&case_OT_4, &&case_OT_5, &&case_OT_6};
// 4516
// 4517 ->ot(own type)
OT_line = __LINE__;
OT_file = __FILE__;
OT_index = OWNTYPE;
goto case_OT_dispatch;
// 4518
// 4519 ot(general): abort("General Own?")
case_OT_0:;
ABORT(_imp_str_literal("General Own?"));
// 4520
// 4521 ot(integer): gput(ownval); -> done
case_OT_1:;
GPUT(OWNVAL);
goto U_1014;
// 4522 ot(real): rv32 = rvalue; ! because our default variable is a 64 bit long real
case_OT_2:;
RV32 = RVALUE;
// 4523 gput(byteinteger(addr(rv32))!byteinteger(addr(rv32)+1)<<8)
GPUT(*_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RV32)) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RV32) + 1) << 8);
// 4524 gput(byteinteger(addr(rv32)+2)!byteinteger(addr(rv32)+3)<<8)
GPUT(*_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RV32) + 2) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RV32) + 3) << 8);
// 4525 -> done
goto U_1014;
// 4526 ot(string): i = dump string(data size); ! need result for const strings
case_OT_3:;
I = DUMPSTRING(DATASIZE);
// 4527 %if decvar_scope = COT %then decvar_disp = i
if (DECVAR->SCOPE != 32) goto L_02B1;
DECVAR->DISP = I;
L_02B1:;
// 4528 -> done
goto U_1014;
// 4529 ot(record): %for i = 1,1,data size %cycle
case_OT_4:;
// %for I = 1, 1, DATASIZE %cycle
{
int _final = DATASIZE;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle I = 1, 1, DATASIZE");
I = 0;
L_02B2:
if (I == _final) goto L_02B3;
I += 1;
// 4530 gbyte(0)
GBYTE(0);
// 4531 %repeat
goto L_02B2;
}
L_02B3:;
// 4532 -> done
goto U_1014;
// 4533 ot(byte): gbyte(ownval); -> done
case_OT_5:;
GBYTE(OWNVAL);
goto U_1014;
// 4534
// 4535 ot(lreal): gput(byteinteger(addr(rvalue))!byteinteger(addr(rvalue)+1)<<8)
case_OT_6:;
GPUT(*_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE)) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 1) << 8);
// 4536 gput(byteinteger(addr(rvalue)+2)!byteinteger(addr(rvalue)+3)<<8)
GPUT(*_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 2) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 3) << 8);
// 4537 gput(byteinteger(addr(rvalue)+4)!byteinteger(addr(rvalue)+5)<<8)
GPUT(*_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 4) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 5) << 8);
// 4538 gput(byteinteger(addr(rvalue)+6)!byteinteger(addr(rvalue)+7)<<8)
GPUT(*_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 6) | *_imp_BYTEINTEGER(_imp_ADDR(/*?*/ &RVALUE) + 7) << 8);
// 4539 done:
U_1014:;
// 4540 %end
return;
case_OT_dispatch:
if (OT_index < 0 || OT_index > 6)
_imp_signalf(6, 3, OT_index, "->OT(%d) out of bounds at %s line %d", OT_index, OT_file, OT_line);
goto *OT[OT_index - 0];
} /* end of ADUMP */
// 4541
// 4542 c('A'):; ! Initialise OWN variable
case_C_65:;
// 4543 i = read tag; ! Number of values to assign
I = READTAG();
// 4544 %if stp # 0 %start; ! Value supplied?
if (STP == 0) goto L_02B5;
// 4545 own val = top_disp
OWNVAL = TOP->DISP;
// 4546 pop stack
POPSTACK();
// 4547 %if own type = real %or own type = lreal %start
if (OWNTYPE == 2) goto L_02B6;
if (OWNTYPE != 6) goto L_02B7;
L_02B6:;
// 4548 rvalue = own val; ! copy integer supplied into floater
RVALUE = OWNVAL;
// 4549 %finish
L_02B7:;
// 4550 %else; ! initialise to default pattern
goto L_02B8;
L_02B5:;
// 4551 ownval = 0
OWNVAL = 0;
// 4552 cslen = 0; ! in case it's a string
*CSLEN = 0;
// 4553 %finish
L_02B8:;
// 4554
// 4555 %if own form = array %or own form = name array %start
if (OWNFORM == 11) goto L_02B4;
if (OWNFORM != 13) goto L_02B9;
L_02B4:;
// 4556 adump %for j = 1,1,i
// %for J = 1, 1, I %cycle
{
int _final = I;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, I");
J = 0;
L_02BA:
if (J == _final) goto L_02BB;
J += 1;
ADUMP();
goto L_02BA;
}
L_02BB:;
// 4557 %else
goto L_02BD;
L_02B9:;
// 4558 %if otype = 0 %start ; ! %const .... %name
if (OTYPE != 0) goto L_02BE;
// 4559 Abort("Constant Name");
ABORT(_imp_str_literal("Constant Name"));
// 4560 %else
L_02BE:;
// 4561 ! constant strings are treated as literals - everything else is "DATA"
// 4562 %if otype = con %and own type = string %start
if (OTYPE != 2) goto L_02BF;
if (OWNTYPE != 3) goto L_02BF;
// 4563 decvar_scope = COT
DECVAR->SCOPE = 32;
// 4564 %else
goto L_02C0;
L_02BF:;
// 4565 decvar_scope = DATA
DECVAR->SCOPE = 16;
// 4566 %finish
L_02C0:;
// 4567 decvar_level = 0; decvar_disp = datatp
DECVAR->LEVEL = 0;
DECVAR->DISP = DATATP;
// 4568 adump
ADUMP();
// 4569 %finish
// 4570 %finish
L_02BD:;
// 4571 ->next
goto U_100E;
// 4572
// 4573 c(''''): get string; ->next; ! Stack string constant
case_C_39:;
GETSTRING();
goto U_100E;
// 4574
// 4575 c('G'): get string; ! Alias for item about to be declared
case_C_71:;
GETSTRING();
// 4576 alias = ""
_imp_strncpy(/*?*/ &ALIAS, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 255);
// 4577 %for j = 1, 1, cslen %cycle
// %for J = 1, 1, *CSLEN %cycle
{
int _final = *CSLEN;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, *CSLEN");
J = 0;
L_02C1:
if (J == _final) goto L_02C2;
J += 1;
// 4578 alias = alias.tostring(current string(j))
_imp_strncpy(/*?*/ &ALIAS, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &ALIAS, ({
__typeof__(_imp_string1) tmp; /*E*/
tmp = _imp_TOSTRING(CURRENTSTRING[J]);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 255);
// 4579 %repeat
goto L_02C1;
}
L_02C2:;
// 4580 pop stack
POPSTACK();
// 4581 ->next
goto U_100E;
// 4582
// 4583 c('N'):; ! Stack integer constant
case_C_78:;
// 4584 ! pass1 is 32 bit, but we are only 16 bit
// 4585 j = read tag; ! discard the low half
J = READTAG();
// 4586 push const(read tag); ->next
PUSHCONST(READTAG());
goto U_100E;
// 4587
// 4588 c('D'):; ! Stack real constant
case_C_68:;
// 4589 get d; ! suck the value into rvalue
GETD();
// 4590 push const(0) %and ->next %if rvalue = 0
if (RVALUE != 0) goto L_02C4;
PUSHCONST(0);
goto U_100E;
L_02C4:;
// 4591 ->next %if next sym = 'A'
if (NEXTSYM != 65) goto L_02C5;
goto U_100E;
L_02C5:;
// 4592 otype = con; ! anonymous %const
OTYPE = 2;
// 4593 j = real constant; ! N.B. ** %fn + side-effect **
J = REALCONSTANT();
// 4594 push const(0)
PUSHCONST(0);
// 4595 top_type = lreal; top_scope = COT; top_disp = j; top_form = v in s
TOP->TYPE = 6;
TOP->SCOPE = 32;
TOP->DISP = J;
TOP->FORM = 4;
// 4596 ->next
goto U_100E;
// 4597
// 4598 c('n'):; ! Select member from record format
case_C_110:;
// 4599 ! Contrary to earlier iCode versions, this one seems to use 'n' for
// 4600 ! both normal record member access and alternate formats?
// 4601
// 4602 lhs == top; ! Points to the base record
LHS = (struct STACKFM *)TOP;
// 4603 i = read tag
I = READTAG();
// 4604 push var(var(top_format)_pbase - i); ! Push descriptor for the i-th member
PUSHVAR(VAR[TOP->FORMAT].PBASE - I);
// 4605
// 4606 %if top_aform # recordformat %start; ! not record format - must be a member
if (TOP->AFORM == 4) goto L_02C6;
// 4607 %if lhs_form = v in s %or lhs_form = VinRec %start
if (LHS->FORM == 4) goto L_02BC;
if (LHS->FORM != 7) goto L_02C7;
L_02BC:;
// 4608 top_disp = lhs_disp + top_disp
TOP->DISP = LHS->DISP + TOP->DISP;
// 4609 lhs_form = lhs_form - v in s + top_form
LHS->FORM = LHS->FORM - 4 + TOP->FORM;
// 4610 %else
goto L_02C8;
L_02C7:;
// 4611 %if lhs_form = a in rec %start
if (LHS->FORM != 9) goto L_02C9;
// 4612 lhs_form = VinRec; lhs_type = integer
LHS->FORM = 7;
LHS->TYPE = 1;
// 4613 load(lhs,any)
LOAD(LHS, 25);
// 4614 lhs_form = top_form
LHS->FORM = TOP->FORM;
// 4615 %else
goto L_02CA;
L_02C9:;
// 4616 %if lhs_form <= VinR %start
if (LHS->FORM > 1) goto L_02CB;
// 4617 lhs_form = top_form; ! ????
LHS->FORM = TOP->FORM;
// 4618 %else; ! A in S
goto L_02CC;
L_02CB:;
// 4619 lhs_extra = lhs_disp
LHS->EXTRA = LHS->DISP;
// 4620 lhs_form = top_form+3
LHS->FORM = TOP->FORM + 3;
// 4621 %finish
L_02CC:;
// 4622 %finish
L_02CA:;
// 4623 %finish
L_02C8:;
// 4624 lhs_disp = top_disp
LHS->DISP = TOP->DISP;
// 4625 lhs_type = top_type
LHS->TYPE = TOP->TYPE;
// 4626 lhs_aform = top_aform
LHS->AFORM = TOP->AFORM;
// 4627 lhs_dim = top_dim
LHS->DIM = TOP->DIM;
// 4628 %finish
L_02C6:;
// 4629 lhs_size = top_size; lhs_format = top_format
LHS->SIZE = TOP->SIZE;
LHS->FORMAT = TOP->FORMAT;
// 4630 pop stack
POPSTACK();
// 4631 ->next
goto U_100E;
// 4632
// 4633 c('@'):; ! Stack variable descriptor
case_C_64:;
// 4634 push var(read tag)
PUSHVAR(READTAG());
// 4635 ->next
goto U_100E;
// 4636
// 4637 c('E'):compile call(top); ! Call procedure
case_C_69:;
COMPILECALL(TOP);
// 4638 ->next
goto U_100E;
// 4639
// 4640 c('M'):; ! MAP result
case_C_77:;
// 4641 amap(top)
AMAP(TOP);
// 4642 load(top, AX)
LOAD(TOP, 1);
// 4643 pop rel
POPREL();
// 4644 dump return
DUMPRETURN();
// 4645 ->next
goto U_100E;
// 4646
// 4647 c('V'):; ! FN result
case_C_86:;
// 4648 %if procvar_type = integer %start
if (PROCVAR->TYPE != 1) goto L_02CD;
// 4649 load(top, AX)
LOAD(TOP, 1);
// 4650 pop rel
POPREL();
// 4651 %else
goto L_02CE;
L_02CD:;
// 4652 %if procvar_type = real %or procvar_type = lreal %start
if (PROCVAR->TYPE == 2) goto L_02CF;
if (PROCVAR->TYPE != 6) goto L_02D0;
L_02CF:;
// 4653 ! Floating point results are put into store, and AX contains
// 4654 ! the address
// 4655 load(top, anyf)
LOAD(TOP, 28);
// 4656 pop rel
POPREL();
// 4657 %if fp result loc = -1 %start; ! clunky allocation coming up
if (FPRESULTLOC != -1) goto L_02D1;
// 4658 gfix(align)
GFIX(1);
// 4659 fp result loc = datatp
FPRESULTLOC = DATATP;
// 4660 gput(0); gput(0); gput(0); gput(0)
GPUT(0);
GPUT(0);
GPUT(0);
GPUT(0);
// 4661 %finish
L_02D1:;
// 4662 %if procvar_type = real %start
if (PROCVAR->TYPE != 2) goto L_02D2;
// 4663 dumpfloprm(FSTD, DATA, fp result loc)
DUMPFLOPRM(40, 16, FPRESULTLOC);
// 4664 %else
goto L_02D3;
L_02D2:;
// 4665 dumpfloprm(FSTQ, DATA, fp result loc)
DUMPFLOPRM(41, 16, FPRESULTLOC);
// 4666 %finish
L_02D3:;
// 4667 dumprioffset(MOV, AX, DATA, fp result loc)
DUMPRIOFFSET(11, 1, 16, FPRESULTLOC);
// 4668 %else ; ! string or record - pass back through the hidden parameter
goto L_02D4;
L_02D0:;
// 4669 push copy(top); ! Make a copy of the thing on top
PUSHCOPY(TOP);
// 4670 lhs == stack(stp-1); ! point to the (now spare) next item
LHS = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 4671 lhs_type = procvar_type; ! and make it look like a destination
LHS->TYPE = PROCVAR->TYPE;
// 4672 lhs_size = procvar_size
LHS->SIZE = PROCVAR->SIZE;
// 4673 lhs_format = procvar_format
LHS->FORMAT = PROCVAR->FORMAT;
// 4674 lhs_base = BP
LHS->BASE = 6;
// 4675 lhs_disp = 6; ! At the offset of the last parameter
LHS->DISP = 6;
// 4676 lhs_form = a in s
LHS->FORM = 6;
// 4677 assign(1)
ASSIGN(1);
// 4678 %finish
L_02D4:;
// 4679 %finish
L_02CE:;
// 4680
// 4681 c('R'):; ! RETURN
case_C_82:;
// 4682 dump return
DUMPRETURN();
// 4683 ->next
goto U_100E;
// 4684
// 4685 c('K'):; ! %false
case_C_75:;
// 4686 k = 0; -> true false
K = 0;
goto U_1015;
// 4687
// 4688 c('T'):; ! %true
case_C_84:;
// 4689 k = -1
K = -1;
// 4690 true false:
U_1015:;
// 4691 dumpri(MOV, AX, k)
DUMPRI(11, 1, K);
// 4692 dump return
DUMPRETURN();
// 4693 ->next
goto U_100E;
// 4694
// 4695 c('a'): array ref(0); ->next
case_C_97:;
ARRAYREF(0);
goto U_100E;
// 4696 c('i'): array ref(1); ->next
case_C_105:;
ARRAYREF(1);
goto U_100E;
// 4697 c('.'): operate(op conc); ->next
case_C_46:;
OPERATE(5);
goto U_100E;
// 4698 c('+'): operate(op add); ->next
case_C_43:;
OPERATE(1);
goto U_100E;
// 4699 c('\'): operate(op not); ->next
case_C_92:;
OPERATE(15);
goto U_100E;
// 4700 c('U'): operate(op neg); ->next
case_C_85:;
OPERATE(16);
goto U_100E;
// 4701 c('-'): operate(op sub); ->next
case_C_45:;
OPERATE(2);
goto U_100E;
// 4702 c('!'): operate(op or); ->next
case_C_33:;
OPERATE(7);
goto U_100E;
// 4703 c('%'): operate(op xor); ->next
case_C_37:;
OPERATE(8);
goto U_100E;
// 4704 c('&'): operate(op and); ->next
case_C_38:;
OPERATE(6);
goto U_100E;
// 4705 c('['): operate(op lsh); ->next
case_C_91:;
OPERATE(9);
goto U_100E;
// 4706 c(']'): operate(op rsh); ->next
case_C_93:;
OPERATE(10);
goto U_100E;
// 4707 c('*'): operate(op mul); ->next
case_C_42:;
OPERATE(3);
goto U_100E;
// 4708 c('/'): operate(op div); ->next
case_C_47:;
OPERATE(4);
goto U_100E;
// 4709 c('Q'): operate(op rdiv); ->next
case_C_81:;
OPERATE(14);
goto U_100E;
// 4710 c('X'): operate(op exp); ->next
case_C_88:;
OPERATE(12);
goto U_100E;
// 4711 c('x'): operate(op rexp); ->next
case_C_120:;
OPERATE(13);
goto U_100E;
// 4712 c('v'): operate(op abs); ->next
case_C_118:;
OPERATE(17);
goto U_100E;
// 4713
// 4714 c('j'): assign(2); ->next; ! JAM transfer
case_C_106:;
ASSIGN(2);
goto U_100E;
// 4715 c('S'): assign(1); ->next; ! Normal value assignment
case_C_83:;
ASSIGN(1);
goto U_100E;
// 4716 c('Z'): assign(0); ->next; ! Assign address '=='
case_C_90:;
ASSIGN(0);
goto U_100E;
// 4717
// 4718 c('p'): assign(-1); ->next; ! Pass a parameter
case_C_112:;
ASSIGN(-1);
goto U_100E;
// 4719
// 4720 c('u'): opr = op add; ->uq common; !++
case_C_117:;
OPR = 1;
goto U_1016;
// 4721 c('q'): opr = op sub; !--
case_C_113:;
OPR = 2;
// 4722 uq common:
U_1016:;
// 4723 lhs == stack(stp-1)
LHS = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 4724 t = lhs_type; j = lhs_size
T = LHS->TYPE;
J = LHS->SIZE;
// 4725 j = j+1 %if t = string
if (T != 3) goto L_02D5;
J = J + 1;
L_02D5:;
// 4726 amap(lhs)
AMAP(LHS);
// 4727 abort("++/-- size") %if j = 0
if (J != 0) goto L_02D6;
ABORT(_imp_str_literal("++/-- size"));
L_02D6:;
// 4728 push const(j)
PUSHCONST(J);
// 4729 operate(op mul)
OPERATE(3);
// 4730 operate(k)
OPERATE(K);
// 4731 vmap(top); top_type = t
VMAP(TOP);
TOP->TYPE = T;
// 4732 ->next
goto U_100E;
// 4733
// 4734 c('k'): dumpri(CMP, AX, 0); ! Branch on FALSE (= 0) ! Branch =
case_C_107:;
DUMPRI(16, 1, 0);
// 4735 c('='): opr = JE; -> cond
case_C_61:;
OPR = 25;
goto U_1017;
// 4736 c('t'): dumpri(CMP, AX, 0); ! Branch on TRUE (# 0)
case_C_116:;
DUMPRI(16, 1, 0);
// 4737 c('#'): opr = JNE; -> cond
case_C_35:;
OPR = 26;
goto U_1017;
// 4738 c('<'): %if invert # 0 %then opr = JG %else opr = JL; -> cond
case_C_60:;
if (INVERT == 0) goto L_02D7;
OPR = 27;
goto L_02D8;
L_02D7:;
OPR = 29;
L_02D8:;
goto U_1017;
// 4739 c('>'): %if invert # 0 %then opr = JL %else opr = JG; -> cond
case_C_62:;
if (INVERT == 0) goto L_02D9;
OPR = 29;
goto L_02DA;
L_02D9:;
OPR = 27;
L_02DA:;
goto U_1017;
// 4740 c('('): %if invert # 0 %then opr = JGE %else opr = JLE; -> cond
case_C_40:;
if (INVERT == 0) goto L_02DB;
OPR = 28;
goto L_02DC;
L_02DB:;
OPR = 30;
L_02DC:;
goto U_1017;
// 4741 c(')'): %if invert # 0 %then opr = JLE %else opr = JGE; -> cond
case_C_41:;
if (INVERT == 0) goto L_02DD;
OPR = 30;
goto L_02DE;
L_02DD:;
OPR = 28;
L_02DE:;
goto U_1017;
// 4742 cond:
U_1017:;
// 4743 ! move the > and < operators to unsigned versions if needed
// 4744 %if compare unsign # 0 %and opr >= JG %then opr = opr + 4
if (COMPAREUNSIGN == 0) goto L_02DF;
if (OPR < 27) goto L_02DF;
OPR = OPR + 4;
L_02DF:;
// 4745 compare unsign = 0
COMPAREUNSIGN = 0;
// 4746 val = read tag
VAL = READTAG();
// 4747 jump to(val, opr, 1); invert = 0
JUMPTO(VAL, OPR, 1);
INVERT = 0;
// 4748 ->next
goto U_100E;
// 4749
// 4750 c('C'):; ! Compare addresses
case_C_67:;
// 4751 amap(top); amap(stack(stp-1)); ! fall through to values
AMAP(TOP);
AMAP(/*?*/ &STACK[STP - 1 - 1]);
// 4752
// 4753 c('?'):; ! Compare values
case_C_63:;
// 4754 LHS == stack(stp-1)
LHS = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 4755 RHS == top
RHS = (struct STACKFM *)TOP;
// 4756 compare(lhs,rhs)
COMPARE(LHS, RHS);
// 4757 pop rel
POPREL();
// 4758 pop rel
POPREL();
// 4759 ->next
goto U_100E;
// 4760
// 4761 c('"'):; ! Compare values, double sided
case_C_34:;
// 4762 LHS == stack(stp-1)
LHS = (struct STACKFM *)/*?*/ &STACK[STP - 1 - 1];
// 4763 RHS == top
RHS = (struct STACKFM *)TOP;
// 4764 load(rhs, any)
LOAD(RHS, 25);
// 4765 ! We happen to know that Compare loads the left parameter in a register.
// 4766 ! We've already got RHS in a register, so we flip the LHS and RHS to the
// 4767 ! comparison and set Invert accordingly
// 4768 compare(rhs, lhs)
COMPARE(RHS, LHS);
// 4769 invert = 1
INVERT = 1;
// 4770 ! release LH and then overwrite it with RH
// 4771 release(lhs_base)
RELEASE(LHS->BASE);
// 4772 lhs = rhs
*LHS = *RHS;
// 4773 pop stack
POPSTACK();
// 4774 ->next
goto U_100E;
// 4775
// 4776 c('r'): resolve(read tag); ->next
case_C_114:;
RESOLVE(READTAG());
goto U_100E;
// 4777
// 4778 c('_'):; ! Define switch label
case_C_95:;
// 4779 uncond jump = 0
UNCONDJUMP = 0;
// 4780 v == var(read tag)
V = (struct VARFM *)/*?*/ &VAR[READTAG()];
// 4781 j = top_disp; pop stack
J = TOP->DISP;
POPSTACK();
// 4782 t = new tag
T = NEWTAG();
// 4783 dumplabel(t);
DUMPLABEL(T);
// 4784 swtab(v_disp+j) = t;
SWTAB[V->DISP + J] = T;
// 4785 ->next
goto U_100E;
// 4786
// 4787 c('W'):; ! Jump to switch
case_C_87:;
// 4788 v == var(read tag)
V = (struct VARFM *)/*?*/ &VAR[READTAG()];
// 4789 push const(1); operate(op lsh); ! subscript X 2
PUSHCONST(1);
OPERATE(9);
// 4790 load(top, anyp)
LOAD(TOP, 27);
// 4791 dumpum(JMP, SWT!top_base, v_disp * 2); ! swtab is word-size, hence * 2
DUMPUM(35, 96 | TOP->BASE, V->DISP * 2);
// 4792 pop rel
POPREL();
// 4793 uncond jump = next cad
UNCONDJUMP = NEXTCAD;
// 4794 ->next
goto U_100E;
// 4795
// 4796 c('B'):; ! Backward Jump
case_C_66:;
// 4797 val = read tag
VAL = READTAG();
// 4798 jump to(val, JMP, 0);
JUMPTO(VAL, 35, 0);
// 4799 ->next
goto U_100E;
// 4800
// 4801 c('F'):; ! Forward Jump
case_C_70:;
// 4802 val = read tag
VAL = READTAG();
// 4803 %if val = 0 %then %start
if (VAL != 0) goto L_02E0;
// 4804 %if last skip # next cad %then %start
if (LASTSKIP == NEXTCAD) goto L_02E1;
// 4805 skip proc = new tag
SKIPPROC = NEWTAG();
// 4806 dumpjump(JMP, skip proc)
DUMPJUMP(35, SKIPPROC);
// 4807 %finish
L_02E1:;
// 4808 ->next
goto U_100E;
// 4809 %finish
L_02E0:;
// 4810 jump to(val, JMP, 1)
JUMPTO(VAL, 35, 1);
// 4811 ->next
goto U_100E;
// 4812
// 4813 %integerfn user label(%integer lab)
int USERLABEL(int LAB) {
// 4814 %record(varfm)%name v
struct VARFM *V;
// 4815 %if lab > names %start
if (LAB <= NAMES) goto L_02E2;
// 4816 names = lab
NAMES = LAB;
// 4817 v == var(lab)
V = (struct VARFM *)/*?*/ &VAR[LAB];
// 4818 v = 0
*V = (struct VARFM){0};
// 4819 v_form = pgm label
V->FORM = 10;
// 4820 v_disp = new tag
V->DISP = NEWTAG();
// 4821 %result = v_disp
return V->DISP;
// 4822 %finish
L_02E2:;
// 4823 %result = var(lab)_disp
return VAR[LAB].DISP;
// 4824 %end
} /* end of USERLABEL */
// 4825 c('J'):; ! Jump to user label
case_C_74:;
// 4826 dumpjump(JMP, user label(read tag))
DUMPJUMP(35, USERLABEL(READTAG()));
// 4827 ->next
goto U_100E;
// 4828
// 4829 c('L'):; ! Define user label
case_C_76:;
// 4830 dump label(user label(read tag))
DUMPLABEL(USERLABEL(READTAG()));
// 4831 ->next
goto U_100E;
// 4832
// 4833 c(':'):; ! Define compiler label
case_C_58:;
// 4834 j = read tag
J = READTAG();
// 4835 %if j = 0 %start
if (J != 0) goto L_02E3;
// 4836 dump label(skipproc)
DUMPLABEL(SKIPPROC);
// 4837 last skip = next cad
LASTSKIP = NEXTCAD;
// 4838 Uncond Jump = 0
UNCONDJUMP = 0;
// 4839 -> next
goto U_100E;
// 4840 %finish
L_02E3:;
// 4841 define label(j); ->next
DEFINELABEL(J);
goto U_100E;
// 4842
// 4843 c('f'):; ! FOR loop header
case_C_102:;
// 4844 compile for; ->next
COMPILEFOR();
goto U_100E;
// 4845
// 4846 c('w'):; ! Machine code
case_C_119:;
// 4847 abort("Machine Code")
ABORT(_imp_str_literal("Machine Code"));
// 4848 ! ->next
// 4849
// 4850 c('P'):; ! Machine code literal
case_C_80:;
// 4851 abort("Machine Literal")
ABORT(_imp_str_literal("Machine Literal"));
// 4852 ! cput(top_disp)
// 4853 ! pop stack
// 4854 ! ->next
// 4855
// 4856 c('y'):; ! %diagnose n
case_C_121:;
// 4857 j = read tag
J = READTAG();
// 4858 %if (j>>14)&3 = 2 %start; ! it's for pass 2
if ((unsigned int)J >> 14 & 3 != 2) goto L_02E4;
// 4859 diagnose = j & 16_3FFF
DIAGNOSE = J & 16383;
// 4860 %else
goto L_02E5;
L_02E4:;
// 4861 !***** should pass onto next pass ******
// 4862 %finish
L_02E5:;
// 4863 ->next
goto U_100E;
// 4864
// 4865 c('z'):; ! %control n
case_C_122:;
// 4866 control = read tag; ->next
CONTROL = READTAG();
goto U_100E;
// 4867
// 4868 c('m'):; ! %monitor
case_C_109:;
// 4869 j = -1; -> SIGNAL EVENT
J = -1;
goto U_100F;
// 4870
// 4871 c('s'):; ! %stop
case_C_115:;
// 4872 j = 0; -> SIGNAL EVENT
J = 0;
goto U_100F;
// 4873
// 4874 c('e'):; ! %signal event
case_C_101:;
// 4875 j = read tag
J = READTAG();
// 4876 SIGNAL EVENT:
U_100F:;
// 4877 push const(0) %while stp < 2
L_02E6:;
if (STP >= 2) goto L_02E7;
PUSHCONST(0);
goto L_02E6;
L_02E7:;
// 4878 push const(j)
PUSHCONST(J);
// 4879 load(top, any); dumpur(PUSH, top_base); pop rel
LOAD(TOP, 25);
DUMPUR(9, TOP->BASE);
POPREL();
// 4880 load(top, any); dumpur(PUSH, top_base); pop rel
LOAD(TOP, 25);
DUMPUR(9, TOP->BASE);
POPREL();
// 4881 load(top, any); dumpur(PUSH, top_base); pop rel
LOAD(TOP, 25);
DUMPUR(9, TOP->BASE);
POPREL();
// 4882 perm(signal, 6)
PERM(11, 6);
// 4883 uncond jump = next cad
UNCONDJUMP = NEXTCAD;
// 4884 ->next
goto U_100E;
// 4885
// 4886 c('o'):; ! %on %event block
case_C_111:;
// 4887 ->next
goto U_100E;
// 4888
// 4889 c('h'):; ! compiler op(n)
case_C_104:;
// 4890 ! compiler op(tag)
// 4891 ->next
goto U_100E;
// 4892
// 4893 c('g'):; !array formats
case_C_103:;
// 4894 c('d'):
case_C_100:;
// 4895 ! in params: =0 -> simple array, # 0 -> array-in-record
// 4896
// 4897 ! First get dimensions
// 4898 dim = read tag; abort("Array Dim") %unless 0 < dim < 3
DIM = READTAG();
{
// Double-sided test on DIM (Part I)
int tmp;
if (0 >= (tmp = DIM)) goto L_02C3;
// Double-sided test on DIM (Part II)
if (tmp < 3) goto L_02E8;
}
L_02C3:;
ABORT(_imp_str_literal("Array Dim"));
L_02E8:;
// 4899
// 4900 ! Now get number of (previously declared) array variables we are defining
// 4901 read symbol(next sym); n = read tag
_imp_READSYMBOL(/*?*/ &NEXTSYM);
N = READTAG();
// 4902
// 4903 %if in params # 0 %start; ! Array in record
if (INPARAMS == 0) goto L_02E9;
// 4904 parms = parms+n
PARMS = PARMS + N;
// 4905 vub = top_disp; pop stack
VUB = TOP->DISP;
POPSTACK();
// 4906 vlb = top_disp; pop stack
VLB = TOP->DISP;
POPSTACK();
// 4907 abort("Array Bounds") %if vlb > vub
if (VLB <= VUB) goto L_02EA;
ABORT(_imp_str_literal("Array Bounds"));
L_02EA:;
// 4908 dv = set dope vector
DV = SETDOPEVECTOR();
// 4909 %else
goto L_02EB;
L_02E9:;
// 4910 names = names-n
NAMES = NAMES - N;
// 4911 ! Now we need to plant code to manufacture a dope vector
// 4912 frame = (frame - ((dim * 4)+4))&(\1); ! space for :Dim:<bound pairs>:DataSize:
FRAME = FRAME - (DIM * 4 + 4) & (~1);
// 4913 dv = frame
DV = FRAME;
// 4914 ! First store the dimension
// 4915 dumpmi(MOV, BP, dv, dim)
DUMPMI(11, 6, DV, DIM);
// 4916 ! And the data size is also constant
// 4917 dumpmi(MOV, BP, dv + (dim*4) + 2, data size)
DUMPMI(11, 6, DV + DIM * 4 + 2, DATASIZE);
// 4918 ! Now the bounds
// 4919 j = 0; ! points to before the first stack value
J = 0;
// 4920 %for i=1,1,dim*2 %cycle
// %for I = 1, 1, DIM * 2 %cycle
{
int _final = DIM * 2;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle I = 1, 1, DIM * 2");
I = 0;
L_02EC:
if (I == _final) goto L_02ED;
I += 1;
// 4921 j = j + 1; lhs == stack(j)
J = J + 1;
LHS = (struct STACKFM *)/*?*/ &STACK[J - 1];
// 4922 %if lhs_form = constant %start
if (LHS->FORM != 0) goto L_02EF;
// 4923 dumpmi(MOV, BP, dv + (i*2), lhs_disp)
DUMPMI(11, 6, DV + I * 2, LHS->DISP);
// 4924 %else
goto L_02F0;
L_02EF:;
// 4925 load(lhs, any)
LOAD(LHS, 25);
// 4926 dumpmr(MOV, BP, dv + (i*2), lhs_base)
DUMPMR(11, 6, DV + I * 2, LHS->BASE);
// 4927 %finish
L_02F0:;
// 4928 %repeat
goto L_02EC;
}
L_02ED:;
// 4929 ! Now we need to allocate the space for the array
// 4930 %if dim > 1 %or control & check array # 0 %start
if (DIM > 1) goto L_02EE;
if (CONTROL & 4 == 0) goto L_02F1;
L_02EE:;
// 4931 ! Do it with the PERM
// 4932 %while stp # 0 %cycle
L_02F2:;
if (STP == 0) goto L_02F3;
// 4933 pop rel; ! get rid of all the bounds - they are in the DV already
POPREL();
// 4934 %repeat
goto L_02F2;
L_02F3:;
// 4935 dumprm(LEA, AX, BP, dv)
DUMPRM(10, 1, 6, DV);
// 4936 dumpur(PUSH, AX)
DUMPUR(9, 1);
// 4937 perm(adef, 2)
PERM(10, 2);
// 4938 ! We now need to make our result match the inline version
// 4939 ! by putting AX and DX into stacklike variables
// 4940 push const(0); lhs == top
PUSHCONST(0);
LHS = (struct STACKFM *)TOP;
// 4941 push const(0); rhs == top
PUSHCONST(0);
RHS = (struct STACKFM *)TOP;
// 4942 lhs_base = AX; lhs_form = V in R; claim(AX)
LHS->BASE = 1;
LHS->FORM = 1;
CLAIM(1);
// 4943 rhs_base = DX; rhs_form = V in R; claim(DX)
RHS->BASE = 3;
RHS->FORM = 1;
CLAIM(3);
// 4944 pop stack
POPSTACK();
// 4945 pop stack
POPSTACK();
// 4946 %else
goto L_02F4;
L_02F1:;
// 4947 push const(1)
PUSHCONST(1);
// 4948 operate(op add)
OPERATE(1);
// 4949 push const(data size)
PUSHCONST(DATASIZE);
// 4950 operate(op mul)
OPERATE(3);
// 4951 push copy(stack(stp-1)); ! suck up the lower bound
PUSHCOPY(/*?*/ &STACK[STP - 1 - 1]);
// 4952 push const(data size)
PUSHCONST(DATASIZE);
// 4953 operate(op mul)
OPERATE(3);
// 4954 ! top is now the lower bound, next is the upper, and a bogus copy of lb is next
// 4955 load(top, any); ! Make sure this is in a register
LOAD(TOP, 25);
// 4956 lhs == top; ! Point to it
LHS = (struct STACKFM *)TOP;
// 4957 pop stack; ! and drop (without release) this copy
POPSTACK();
// 4958 load(top, any); ! This is now UB - load it in a register as well
LOAD(TOP, 25);
// 4959 rhs == top; ! Point to it
RHS = (struct STACKFM *)TOP;
// 4960 pop stack; ! and keep RHS (Upper)
POPSTACK();
// 4961 pop stack; ! dump the bogus lb
POPSTACK();
// 4962 %finish
L_02F4:;
// 4963 ! Note - there are 4 GP registers, and we're going to need them ALL here
// 4964 t = gp reg; ! get a working register for the dope vector address
T = GPREG();
// 4965 dumprm(LEA, t, BP, dv); ! load it
DUMPRM(10, T, 6, DV);
// 4966 dv = t; claim(dv); ! use this to hold the register number
DV = T;
CLAIM(DV);
// 4967 t = gp reg; ! the last one! (which we don't claim, 'cos we can't lose it)
T = GPREG();
// 4968 dumprr(MOV, t, SP); ! working copy of SP so that real SP is always "OK"
DUMPRR(11, T, 5);
// 4969 %finish
L_02EB:;
// 4970
// 4971 %for j = 1,1,n %cycle
// %for J = 1, 1, N %cycle
{
int _final = N;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, N");
J = 0;
L_02F5:
if (J == _final) goto L_02F6;
J += 1;
// 4972 decvar_dim = dim
DECVAR->DIM = DIM;
// 4973 %if in params = 0 %start; ! array not in record
if (INPARAMS != 0) goto L_02F8;
// 4974 names = names+1; decvar == var(names)
NAMES = NAMES + 1;
DECVAR = (struct VARFM *)/*?*/ &VAR[NAMES];
// 4975 decvar_level = level
DECVAR->LEVEL = LEVEL;
// 4976 frame = frame - 4; ! 2-word header
FRAME = FRAME - 4;
// 4977 decvar_disp = frame
DECVAR->DISP = FRAME;
// 4978 %if decvar_form = array %or decvar_form = namearray %c
if (DECVAR->FORM == 11) goto L_02F9;
if (DECVAR->FORM != 13) goto L_02FA;
L_02F9:;
DECVAR->FORM = DECVAR->FORM + 1;
L_02FA:;
// 4979+ %then decvar_form = decvar_form + 1; ! force arrayname
// 4980 dumprr(SUB, t, rhs_base);
DUMPRR(18, T, RHS->BASE);
// 4981 dumpmr(MOV, BP, frame, t); ! store a(0) address
DUMPMR(11, 6, FRAME, T);
// 4982 dumpmr(MOV, BP, frame+2, dv); ! store dope vector pointer
DUMPMR(11, 6, FRAME + 2, DV);
// 4983 dumprr(ADD, t, lhs_base);
DUMPRR(14, T, LHS->BASE);
// 4984 %else; ! array-in-record
goto L_02FB;
L_02F8:;
// 4985 parms = parms-1; decvar == var(parms)
PARMS = PARMS - 1;
DECVAR = (struct VARFM *)/*?*/ &VAR[PARMS];
// 4986 decvar_disp = frame - vlb
DECVAR->DISP = FRAME - VLB;
// 4987 frame = frame + vub; ! noting that Set Dope Vector has changed VUB to the array size
FRAME = FRAME + VUB;
// 4988 decvar_pbase = dv
DECVAR->PBASE = DV;
// 4989 %finish
L_02FB:;
// 4990 %repeat
goto L_02F5;
}
L_02F6:;
// 4991
// 4992 %if in params = 0 %start
if (INPARAMS != 0) goto L_02FC;
// 4993 dumprr(MOV,SP,t)
DUMPRR(11, 5, T);
// 4994 release(lhs_base)
RELEASE(LHS->BASE);
// 4995 release(rhs_base)
RELEASE(RHS->BASE);
// 4996 release(dv)
RELEASE(DV);
// 4997 %finish
L_02FC:;
// 4998 ->next
goto U_100E;
// 4999
// 5000 c('^'):; ! {Set Format}
case_C_94:;
// 5001 top_type = record
TOP->TYPE = 4;
// 5002 top_format = read tag
TOP->FORMAT = READTAG();
// 5003 ->next
goto U_100E;
// 5004
// 5005 c('I'): Abort("Pascal?");! {ESCAPE for Pascal etc.}
case_C_73:;
ABORT(_imp_str_literal("Pascal?"));
// 5006
// 5007 c('~'):; ! alternate record format
case_C_126:;
// 5008 sym = next sym; read symbol(next sym)
SYM = NEXTSYM;
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 5009 %if sym = 'A' %start; ! alt start
if (SYM != 65) goto L_02FD;
// 5010 decvar == procvar
DECVAR = (struct VARFM *)PROCVAR;
// 5011 assemble(-2,labs,names)
ASSEMBLE(-2, LABS, NAMES);
// 5012 ->next
goto U_100E;
// 5013 %finish
L_02FD:;
// 5014
// 5015 %if sym = 'B' %then -> out; ! alt end
if (SYM != 66) goto L_02FE;
goto U_1010;
L_02FE:;
// 5016
// 5017 abort("Alt Record") %if sym # 'C'; ! faulty intermediate code
if (SYM == 67) goto L_02FF;
ABORT(_imp_str_literal("Alt Record"));
L_02FF:;
// 5018 ! Compile the next alternate - update limit and set frame back to where we started
// 5019 max frame = frame %if frame > max frame
if (FRAME <= MAXFRAME) goto L_0300;
MAXFRAME = FRAME;
L_0300:;
// 5020 frame = old frame
FRAME = OLDFRAME;
// 5021 ->next
goto U_100E;
// 5022
// 5023 c('{'):; ! Start of formal parameters
case_C_123:;
// 5024 in params = -1
INPARAMS = -1;
// 5025 ! this is either a record format, a procedure, or a proc spec;
// 5026 ! - block type was set by decvar to tell us which
// 5027 assemble(block type,labs,names)
ASSEMBLE(BLOCKTYPE, LABS, NAMES);
// 5028 ->next
goto U_100E;
// 5029
// 5030 c('}'):; ! End of formal parameters
case_C_125:;
// 5031 in params = 0
INPARAMS = 0;
// 5032 -> OUT %if amode < 0; ! end of %record %format defn.
if (AMODE >= 0) goto L_0301;
goto U_1010;
L_0301:;
// 5033 -> OUT %if procvar_level = 128; ! prim routine reference
if (PROCVAR->LEVEL != 128) goto L_0302;
goto U_1010;
L_0302:;
// 5034
// 5035 ! Here it's a real subroutine - copy any parameters to the PARM area
// 5036 %if names > first name %start
if (NAMES <= FIRSTNAME) goto L_0303;
// 5037 procvar_pbase = parms; ! Point one beyond the first parameter
PROCVAR->PBASE = PARMS;
// 5038 frame = (frame + 1) & (\1); ! Even up the stack size
FRAME = FRAME + 1 & (~1);
// 5039 %if procvar_type = string %and procvar_form = 8 %start
if (PROCVAR->TYPE != 3) goto L_0304;
if (PROCVAR->FORM != 8) goto L_0304;
// 5040 frame = frame + 2; ! string functions have a hidden result parameter
FRAME = FRAME + 2;
// 5041 %finish
L_0304:;
// 5042 procvar_extra = frame; ! Remember the stack offset
PROCVAR->EXTRA = FRAME;
// 5043 procvar_dim = names - first name; ! and the number of parameters
PROCVAR->DIM = NAMES - FIRSTNAME;
// 5044 frame = frame + 6; ! leave space for return linkage
FRAME = FRAME + 6;
// 5045 %for j = first name+1, 1, names %cycle
// %for J = FIRSTNAME + 1, 1, NAMES %cycle
{
int _initial = FIRSTNAME + 1, _final = NAMES;
if (invalid_for_loop(_initial, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = FIRSTNAME + 1, 1, NAMES");
J = _initial - (1);
L_0305:
if (J == _final) goto L_0306;
J += 1;
// 5046 ap == var(j)
AP = (struct VARFM *)/*?*/ &VAR[J];
// 5047 parms = parms-1; fp == var(parms)
PARMS = PARMS - 1;
FP = (struct VARFM *)/*?*/ &VAR[PARMS];
// 5048 fp = ap
*FP = *AP;
// 5049 ! formal parameter base and displacement is implicit (on the stack)
// 5050 fp_level = 0
FP->LEVEL = 0;
// 5051 ! we also need to adjust the offsets of the actual parameters, because
// 5052 ! they were allocated going "forwards", but will be pushed on the stack
// 5053 ! "backwards" - that is, the first item passed will end up with the
// 5054 ! highest address. DefineVar has done part of the work for us by tagging
// 5055 ! the displacements in the right style, but it can't tell the whole frame
// 5056 ! offset, so we calculate the final offsets here...
// 5057 ap_disp = frame - ap_disp
AP->DISP = FRAME - AP->DISP;
// 5058 %repeat
goto L_0305;
}
L_0306:;
// 5059 abort("Params") %if parms < names
if (PARMS >= NAMES) goto L_0308;
ABORT(_imp_str_literal("Params"));
L_0308:;
// 5060 %finish
L_0303:;
// 5061 -> OUT %if amode = 2; ! this was just a spec
if (AMODE != 2) goto L_0309;
goto U_1010;
L_0309:;
// 5062 frame = 0
FRAME = 0;
// 5063 dumplabel(procvar_disp)
DUMPLABEL(PROCVAR->DISP);
// 5064 static alloc = enter
STATICALLOC = ENTER();
// 5065 ->next
goto U_100E;
// 5066
// 5067 c('H'):; ! Start of BEGIN block
case_C_72:;
// 5068 decvar == begin; decvar_disp = new tag
DECVAR = (struct VARFM *)/*?*/ &BEGIN;
DECVAR->DISP = NEWTAG();
// 5069 otype = 0; spec = 0; potype = 0
OTYPE = 0;
SPEC = 0;
POTYPE = 0;
// 5070 %if level # 0 %start; ! not outermost %begin
if (LEVEL == 0) goto L_030A;
// 5071 push const(decvar_disp)
PUSHCONST(DECVAR->DISP);
// 5072 top_type = 0; ! it's not a function!
TOP->TYPE = 0;
// 5073 compile call(top)
COMPILECALL(TOP);
// 5074 skip proc = new tag
SKIPPROC = NEWTAG();
// 5075 dump jump(JMP, skip proc)
DUMPJUMP(35, SKIPPROC);
// 5076 %finish
L_030A:;
// 5077 assemble(0,labs,names)
ASSEMBLE(0, LABS, NAMES);
// 5078 %if level # 0 %start
if (LEVEL == 0) goto L_030B;
// 5079 dump label(skip proc)
DUMPLABEL(SKIPPROC);
// 5080 last skip = next cad
LASTSKIP = NEXTCAD;
// 5081 Uncond Jump = 0
UNCONDJUMP = 0;
// 5082 %finish
L_030B:;
// 5083 ->next
goto U_100E;
// 5084
// 5085 ! To catch the sinners!!
// 5086 C(*):
case_C_default:;
// 5087 abort("Bad I Code")
ABORT(_imp_str_literal("Bad I Code"));
// 5088
// 5089 c(';'):
case_C_59:;
// 5090 %if amode >= 0 %start; ! No return code for %endoffile
if (AMODE < 0) goto L_030C;
// 5091 dump return
DUMPRETURN();
// 5092 dumpstaticfill(staticalloc, frame);
DUMPSTATICFILL(STATICALLOC, FRAME);
// 5093 %finish
L_030C:;
// 5094
// 5095 OUT:
U_1010:;
// 5096 %if amode >= 0 %start; ! end of declarative block
if (AMODE < 0) goto L_030D;
// 5097 level = level-1
LEVEL = LEVEL - 1;
// 5098 %else; ! end of record format defn
goto L_030E;
L_030D:;
// 5099 %if amode = -2 %start; ! end of alternative only
if (AMODE != -2) goto L_030F;
// 5100 frame = max frame %if max frame > frame; ! use the longest alternative
if (MAXFRAME <= FRAME) goto L_0310;
FRAME = MAXFRAME;
L_0310:;
// 5101 old frame = frame
OLDFRAME = FRAME;
// 5102 %else
goto L_0311;
L_030F:;
// 5103 frame = (frame+align)&(\align); ! **** temporary ****
FRAME = FRAME + 1 & (~1);
// 5104 procvar_size = frame
PROCVAR->SIZE = FRAME;
// 5105 %finish
L_0311:;
// 5106 %finish
L_030E:;
// 5107 frame = old frame
FRAME = OLDFRAME;
// 5108
// 5109 %end;
return;
case_C_dispatch:
if (C_index < 33 || C_index > 127)
_imp_signalf(6, 3, C_index, "->C(%d) out of bounds at %s line %d", C_index, C_file, C_line);
goto *C[C_index - 33];
} /* end of ASSEMBLE */
// ?TEMP unused
// 5110 ; ! assemble
// 5110
// 5111
// 5112 ! -------- it all starts here ---------
// 5113
// 5114 select input(icode)
_imp_SELECTINPUT(1);
// 5115 select output(objout)
_imp_SELECTOUTPUT(1);
// 5116
// 5117 var(0) = 0; ! for %RECORD(*) . . . . .
VAR[0] = (struct VARFM){0};
// 5118 parms = max vars
PARMS = 600;
// 5119
// 5120 cslen == current string(0)
CSLEN = (unsigned char *)/*?*/ &CURRENTSTRING[0];
// 5121
// 5122 ! Initialise the GP Tag ASL
// 5123 %for i=1,1,Max GP %cycle
// %for I = 1, 1, 100 %cycle
{
I = 0;
L_0312:
if (I == 100) goto L_0313;
I += 1;
// 5124 GP Tags(i)_link = i - 1
GPTAGS[I].LINK = I - 1;
// 5125 %repeat
goto L_0312;
}
L_0313:;
// 5126 gp asl = Max GP
GPASL = 100;
// 5127
// 5128 ! Tell the linker our source file name
// 5129 dumpsourcename("TEST.IMP"); ! ABD - a bit bogus at the moment!
DUMPSOURCENAME(_imp_str_literal("TEST.IMP"));
// 5130
// 5131 ! predefine the perms for the linker. We ignore
// 5132 ! the number (j) because we know they are in sequence
// 5133 %for i=1,1,lastperm %cycle
// %for I = 1, 1, 11 %cycle
{
I = 0;
L_0314:
if (I == 11) goto L_0315;
I += 1;
// 5134 j = externalref(permname(i))
J = EXTERNALREF(
*({
__typeof__(_imp_string12) tmp = PERMNAME[I - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 5135 %repeat
goto L_0314;
}
L_0315:;
// 5136
// 5137 read symbol(next sym); ! Prime SYM/NEXT pair
_imp_READSYMBOL(/*?*/ &NEXTSYM);
// 5138
// 5139 Spec = 0
SPEC = 0;
// 5140 decvar == begin
DECVAR = (struct VARFM *)/*?*/ &BEGIN;
// 5141 assemble(-3,0,0)
ASSEMBLE(-3, 0, 0);
// 5142
// 5143 ! We flush constants
// 5144 flush cot
FLUSHCOT();
// 5145 flush data
FLUSHDATA();
// 5146 flush switch
FLUSHSWITCH();
// 5147
// 5148 %ENDOFPROGRAM
_imp_stop(0);
return 0;
end_0:;
}