#include <perms.h>
// Edinburgh IMP77 Compiler - Version 8.4
//
// 1 %externalroutinespec exit %alias "exit" (%integer rc)
extern void EXIT(int RC) __asm__("exit");
// 2
// 3 %externalroutine{spec} getblock {%alias "GETBLOCK_JSB"} (%integer len, %bytename base)
void GETBLOCK(int LEN, unsigned char *BASE) {
// 4 %end
return;
} /* end of GETBLOCK */
// ?BASE unused
// ?LEN unused
// 5 %externalintegerfunction{spec} getlong {%alias "GETLONG_JSB"}
int GETLONG(void) {
// 6 %result=0
return 0;
// 7 %end
} /* end of GETLONG */
// 8 %externalintegerfunction{spec} getword {%alias "GETWORD_JSB"}
int GETWORD(void) {
// 9 %result=0
return 0;
// 10 %end
} /* end of GETWORD */
// 11 %externalroutine{spec} get(%integername n)
void GET(int *N) {
// 12 %end
return;
} /* end of GET */
// ?N unused
// 13 %externalroutine{spec} put(%integer n)
void PUT(int N) {
// 14 %end
return;
} /* end of PUT */
// ?N unused
// 15 %externalroutine{spec} putword(%integer n)
void PUTWORD(int N) {
// 16 %end
return;
} /* end of PUTWORD */
// ?N unused
// 17 %externalroutine{spec} putlong(%integer n)
void PUTLONG(int N) {
// 18 %end
return;
} /* end of PUTLONG */
// ?N unused
// 19 %externalroutine{spec} putblock(%integer len, %bytename b)
void PUTBLOCK(int LEN, unsigned char *B) {
// 20 %end
return;
} /* end of PUTBLOCK */
// ?B unused
// ?LEN unused
// 21 ! Computer Science VAX-11 Imp77 Compiler Second Pass
// 22 ! 23rd March 1981
// 23 !
// 24 ! Mods by MT June/July 1981:
// 25 !
// 26 ! - removed %const<>%name fault
// 27 ! - fixed problem with definition of externals after %externally
// 28 ! spec'ing them
// 29 ! - fixed trouble with ++ and -- : introduction of VMAP
// 30 ! - improved handling of 1-dimensional arrays (when checks off)
// 31 ! - better code in general cases (eg. a(j+const); a(const) -> store ref)
// 32 ! - generation of indexing (base[index]) in appropriate cases
// 33 ! - fixed bug with moving records > 255 bytes from rec(*) name
// 34 ! - generates error for untyped record moves
// 35 ! - fixed general bug with moving/clearing records > 32K
// 36 ! - improved record element access in several cases (save loading base)
// 37 ! - ADDRESS, code in ASSEMBLE at C('n'): modified.
// 38 ! - mod to LOAD to prefer 2-op operations where possible (but this
// 39 ! should perhaps be removed when - if ever - remembering reg contents
// 40 ! is implented, since useful information is deleted).
// 41 ! - fixed (subtle) problem where turning off iovf checks after proc entry
// 42 ! prevented suitable code to prevent traps on shifts, byte addition
// 43 ! from being planted: control&16 # 0 => entry mask&iovf bit # 0
// 44 ! - fixed bug where large quantities of data in gla made array header
// 45 ! displacement wrong (var_header was %short, changed to %integer)
// 46 !
// 47 ! August 81:
// 48 !
// 49 ! - fixed %external..%array for cases where aref address not loaded
// 50 ! into register - was losing XNO.....
// 51 !
// 52 ! September 81:
// 53 ! - extended %prims - skipsymbol/ch etc added
// 54 !
// 55 ! October 81:
// 56 ! - bug fix for "real = \integer" etc
// 57 ! - prims extended: PRINTSTRING parameter not now copied to
// 58 ! work string (but may already be there!)
// 59 ! - proper assignment checks on string resolution
// 60 ! - added $_X:: CHARNO (as perm call)
// 61 ! - %for loop mods
// 62 ! - constant-bound loops
// 63 ! - checks for validity at compile-time, no perm-call
// 64 ! - doesn't call %any perm for no-check case!!
// 65 ! - string length checking (AT LAST!!!!)
// 66 ! - checks on size of constants in operations: eg "byte = 257" fails
// 67 ! at compile time
// 68 ! - put in compiler-specific perm routines GET, GET WORD, PUT etc
// 69 ! as JSB-type, for compiler speed..
// 70 !
// 71 ! November 81:
// 72 ! - outlawed other than plain %integer %for control variables!!
// 73 ! - implemented READSYMBOL/CH for %strings
// 74 ! - improved code for things like ++ (and effectively similar cases)
// 75 ! - bug fixes for real constants, %for loops
// 76 !
// 77 ! December 81:
// 78 ! - fixed external refs to ensure PIC code generated (avoid P3
// 79 ! having to plug reference) ie @external never generated...
// 80 ! - fixed (obscure) bug in taking the address of a label
// 81 ! - generates error for ++, -- on string(*), record(*)
// 82 !
// 83 ! Known bugs:
// 84 !
// 85 ! * %external %routine %spec x (%routine y)
// 86 ! - corrupts next declaration
// 87 ! (this is actually a pass 1 problem and should go away sometime)
// 88 ! ? Meaning of %for j = x, 0, y %cycle ?
// 89 ! ? Meaning of ADDR(arrayname), ADDR(array) ?
// 90 !
// 91
// 92 %control 0
// _imp_control(0); /* %control is a compiler directive and does not generate code. */
// 93
// 94 ! Include common constants, specs etc
// 95
// 96 !!%include "control.imp"
// 97
// 98 {%systemroutinespec exit %alias "exit" (%integer s)
// 99 !%external %routine %spec PUT (%integer n)
// 100 !%external %routine %spec PUT WORD (%integer n)
// 101 !%external %routine %spec PUT LONG (%integer n)
// 102 !%external %routine %spec PUT BLOCK (%integer n, %bytename b)
// 103 %external %routine {%spec} SELECT INPUT TANK (%integer n)
void SELECTINPUTTANK(int N) {
// 104 %end
return;
} /* end of SELECTINPUTTANK */
// ?N unused
// 105 %external %routine {%spec} SELECT OUTPUT TANK (%integer n)
void SELECTOUTPUTTANK(int N) {
// 106 %end
return;
} /* end of SELECTOUTPUTTANK */
// ?N unused
// 107 !%external %routine %spec GET (%integer %name ch)
// 108 !%external %routine %spec GET BLOCK (%integer len, %byte %name b)
// 109 %external %routine %spec PRINT RECORD (%integer len, %byte %name buff)
extern void PRINTRECORD(int LEN, unsigned char *BUFF);
// 110 %external %integer %function %spec LOOK
extern int LOOK(void);
// 111 !%external %integer %function %spec GETWORD
// 112 !%external %integer %function %spec GETLONG
// 113 %external %integer %function %spec TAG %alias "GETLONG"; ! For pass 2
extern int TAG(void) __asm__("GETLONG");
// 114 %external %string(63) %function %spec ITOS (%integer n, p)
extern _imp_string63 ITOS(int N, int P);
// 115
// 116 ! streams
// 117 %const %integer report = 0
// 118 %const %integer object file = 1
// 119 %const %integer listing = 2
// 120 %const %integer diag stream = listing
// 121
// 122 ! miscellaneous
// 123 %const %integer max ident = 31; ! Length for external linkage
// 124 %const %integer fatal = 16_1000002C; ! Error exit code to VMS
// 125
// 126
// 127 ! external data (defined in driver)
// 128 %external %string(6) %spec version; ! Compiler version string
extern _imp_string6 VERSION;
// 129 %external %integer %spec command
extern int COMMAND;
// 130 %external %integer %spec control
extern int CONTROL;
// 131
// 132 ! command bit meanings (set by command line)
// 133 %const %integer diag bit = 8_00004
// 134 %const %integer line bit = 8_00010
// 135 %const %integer log bit = 8_00020
// 136 %const %integer time bit = 8_01000
// 137 %const %integer entry bit = 8_02000
// 138 %const %integer init bit = 8_04000
// 139 %const %integer pic bit = 8_10000
// 140
// 141 ! control bit meanings (%control n, or set by driver (/check= etc))
// 142 ! bit set => check on
// 143
// 144 %const %integer ass check = 1; ! unassigned checking
// 145 %const %integer str check = 2; ! string capacity checking
// 146 %const %integer for check = 4; ! %for checking
// 147 %const %integer arr check = 8; ! array bound checking
// 148 %const %integer ovf check = 16; ! integer overflow checking
// 149 %const %integer rec round = 128; ! rounding in records (turns it on)
// 150 %const %integer profiling = 256; ! call TRACE (line no) at bounds
// 151
// 152 ! object file commands Pass2 => Pass3
// 153
// 154 %const %integer obj extern = 1; ! insert external entry
// 155 %const %integer obj code = 2; ! code block
// 156 %const %integer obj gla = 3; ! gla block
// 157 %const %integer obj pdef = 4; ! external proc definition
// 158 %const %integer obj pspec = 5; ! external proc specification
// 159 %const %integer obj ddef = 6; ! external data definition
// 160 %const %integer obj dspec = 7; ! external data specification
// 161 %const %integer obj reloc = 8; ! relocate gla
// 162 %const %integer obj set = 9; ! set gla to tag address
// 163 %const %integer obj header = 10; ! start of procedure
// 164 %const %integer obj call = 11; ! procedure call
// 165 %const %integer obj jump = 12; ! jump
// 166 %const %integer obj prim spec = 13; ! prim definition
// 167 %const %integer obj end = 14; ! end of object file
// 168 %const %integer obj line = 15; ! line number
// 169 %const %integer obj term = 16; ! end of block
// 170 %const %integer obj diag p = 17; ! diags for proc header
// 171 %const %integer obj diag v = 18; ! diags for variable
// 172 %const %integer obj weak = 19
// 173 %const %integer obj b lab = 20; ! bxxb in m/code
// 174 %const %integer obj w lab = 21; ! bxxw in m/code
// 175 %const %integer obj glam = 22; ! initialise n items in GLA
// 176 %const %integer obj modd = 23; ! modify displacement
// 177 %const %integer obj prim ref = 24; ! call to prim
// 178 %const %integer obj ext ref = 25; ! call to external procedure
// 179 %const %integer last obj code = 25
// 180
// 181 ! directive file commands Pass2 => Pass3
// 182
// 183 %const %integer dir used = 1; ! external used
// 184 %const %integer dir ldef = 2; ! label definition
// 185 %const %integer dir pref = 3; ! procedure reference
// 186 %const %integer dir cref = 4; ! conditional label reference
// 187 %const %integer dir uref = 5; ! unconditional label reference
// 188 %const %integer dir end = 6; ! end of procedure
// 189 %const %integer dir sizes = 7; ! end of directives+sizes
// 190 %const %integer dir x end = 8; ! end of external entry
// 191 %const %integer dir header = 9; ! start of procedure
// 192 %const %integer dir entry = 10; ! define entry label
// 193 %const %integer last dir code = 10
// 194
// 195 !!%end %of %file
// 196
// 197 %external %routine PASS2 (%integer icode, object, directives)
void PASS2(int ICODE, int OBJECT, int DIRECTIVES) {
// 198 !
// 199 ! Aborts: (* means solution %might be to turn up a size constant)
// 200 !
// 201 ! 0 unimplemented feature
// 202 ! 1 Operand: bad base register for operand
// 203 ! 2 Operand: operation still pending on operand
// 204 ! 3 Release: register not claimed
// 205 ! 4 Hazard: bad operand form
// 206 ! 5 Hazard: register activity inconsistent
// 207 ! * 6 Descriptor: no free descriptors
// 208 ! * 7 Descriptor: no free descriptor pointers
// 209 ! * 8 Descriptor: stack overflow
// 210 ! 9 Drop: descriptor not on using list
// 211 ! 10 Set both: stack underflow
// 212 ! 11 Pop lhs: stack underflow
// 213 ! 12 Pop drop: stack underflow
// 214 ! 13 Operand: invalid operand form
// 215 ! * 14 Define var: var table overflow
// 216 ! 15 Amap: cannot take address of object
// 217 ! * 16 New label: no labels left
// 218 ! 17 Operate: stack empty on unary operation
// 219 ! 18 Operate: stack < 2 deep on binary
// 220 ! 19 Cop: unexpected operation
// 221 ! 20 For: non-integer control variable
// 222 ! 21 Assemble: bad code item
// 223 ! 22 Assemble: array in record bounds inside-out
// 224 ! 23 Line bound: stack not empty
// 225 ! 24 Line bound: using list not empty
// 226 ! 25 Line bound: regs still active
// 227 ! * 26 Assemble: var table overflow
// 228 ! 27 Operand: cannot perform indexing
// 229 ! 28 Operand: AP/FP/PC as register operand
// 230 ! * 29 Work string: too many temp areas required
// 231 ! 30 Load: 2nd reg for >> or REM is locked
// 232 ! 31 Hazard: index reg usage inconsistent (hazarding index reg)
// 233 ! 32 Load: cannot perform real op
// 234 ! 33 Load: cannot perform integer op
// 235 ! 34 Set cc: bad comparator specified
// 236 ! 35 Scale index: invalid length for indexed addressing
// 237 ! 36 Assemble: bad symbol after '~' (ie. not {A, B, C})
// 238 ! 37 Load: bad register
// 239 ! 38 Hazard: index register use inconsistent
// 240 ! 39 Line bound: index reg still active
// 241 ! 40 Claim: bad register for index
// 242 ! 41 Release: " " " " " " " "
// 243 ! 42 Release: released index reg is locked
// 244 ! 43 Release: released index reg but no indexing active
// 245 ! 44 Release: released index reg not claimed as index
// 246 ! 45 Record sel: invalid form for base record
// 247 ! 46 Address: bad form for indexed operand
// 248 ! 47 Call: operation pending on READSYMBOL parameter
// 249 ! 48 Set modulus: constant not %longreal %or %integer
// 250 !
// 251 !================================================================
// 252 !
// 253 ! %diagnose significance
// 254 !
// 255 ! diag bit: monitors:
// 256 ! 1 = stack procedures
// 257 ! 2 = load
// 258 ! 4 = hazard/claim/release
// 259 ! 8 = assign/array ref
// 260 ! 16 = call/push
// 261 ! 32 = address
// 262 ! 64 = amap/vmap
// 263 ! 128 = put code/operand
// 264 ! 256 = operate
// 265 !
// 266 ! 2048 = I-code main symbols
// 267 ! 4096 = stack dump on MONITOR
// 268 ! 8192 = %monitor on MONITOR
// 269 !
// 270
// 271 %own %integer original control
static int ORIGINALCONTROL;
// 272 original control = control
ORIGINALCONTROL = CONTROL;
// 273
// 274 %own %integer diag = 0
static int DIAG = 0;
// 275
// 276 %const %integer mainrt = 1, mainfn = 2
// 277
// 278 ! Size constants +++++++++++++++++++++ associated aborts
// 279
// 280 %const %integer max vars = 2000; ! 14, 26 : var table size
// 281 %const %integer max labels = 120; ! 16 : # active internal labs
// 282 %const %integer max depth = 16; ! 8 : depth of descr stack
// 283 %const %integer max stack = 25; ! 6, 7 : # in-use descriptors
// 284 %const %integer max work = 12; ! 29 : # active work strings
// 285
// 286 !register definition
// 287
// 288 %const %integer r0 = 1; !used in prim
// 289 %const %integer r1 = 2; !used in prim
// 290 %const %integer r2 = 3; !used in prim
// 291 %const %integer r3 = 4; !used in prim
// 292 %const %integer r4 = 5; !used in prim
// 293 %const %integer r5 = 6; !used in prim
// 294 %const %integer r6 = 7; !base register (level 1)
// 295 %const %integer r7 = 8; !base register (level 2)
// 296 %const %integer r8 = 9; !base register (level 3)
// 297 %const %integer r9 = 10; !base register (level 4)
// 298 %const %integer r10 = 11
// 299 %const %integer gla = 12; !r11 = gla base
// 300 %const %integer ap = 13; !argument pointer (r12)
// 301 %const %integer fp = 14; !frame pointer (lnb)
// 302 %const %integer sp = 15; !stack pointer (r14)
// 303 %const %integer pc = 16; !program counter (r15)
// 304 %const %integer any = 17; !any general register
// 305
// 306 %const %integer fpr0 = 18
// 307 %const %integer fpr2 = 19
// 308 %const %integer fpr4 = 20
// 309
// 310 %const %integer pending = 22; !spec pending
// 311
// 312 %const %short %array actual reg (0 : 20) =
const short int ACTUALREG[21] = {-1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 0, 0, 2, 4};
// 313+ -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
// 314+ 13, 14, 15, 0, 0, 2, 4
// 315
// 316 %const %short %array reg mask (0 : 20) =
const short int REGMASK[21] = {0, 0, 0, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 0, 0, 0, 0, 0, 0, 12, 48};
// 317+ 0, 0, 0, 4, 8, 16_10, 16_20, 16_40, 16_80,
// 318+ 16_100, 16_200, 16_400, 16_800, 0, 0, 0, 0, 0, 0,
// 319+ 16_c, 16_30
// 320
// 321 %const %integer iovf bit = 16_4000;! Set in entry mask to enable IOVF trap
// 322
// 323 %const %byte %array base reg (-1 : 6) =
const unsigned char BASEREG[8] = {13, 13, 7, 8, 9, 10, 13, 13};
// 324+ ap, ap, r6, r7, r8, r9, ap, ap
// 325
// 326 !types and precisions
// 327
// 328 %const %integer integers = 16_10
// 329 %const %integer byte = 2; !unsigned byte
// 330 %const %integer short = 1; !signed halfword
// 331 %const %integer long = 5; !longinteger
// 332 %const %integer reals = 16_23, reall = 16_24, real bit = 16_20
// 333 %const %integer strings = 16_40, in work = 4
// 334 %const %integer records = 16_80
// 335
// 336 %const %integer null string = 24; !disp of null string in gla
// 337
// 338 !data forms
// 339
// 340 %const %integer jump = 0; !cond code for jump
// 341 %const %integer switch = 6
// 342 %const %integer recfm = 4
// 343
// 344 %const %integer proc bit = 16
// 345 %const %integer array bit = 32
// 346 %const %integer arrayname bit = 64
// 347 %const %integer indirect bit = 128
// 348
// 349 %const %integer constant = 0
// 350 %const %integer v in r = 1; !variable in register
// 351 %const %integer v in s = 2; !variable in store
// 352 %const %integer av in s = 3; !address of variable in store
// 353 %const %integer a in s = 4; !address in store (indirect)
// 354 %const %integer rec mod = 3; ! x in rec = x in s + rec mod
// 355 %const %integer v in rec = 5; !variable in record (+extra)
// 356 %const %integer av in rec = 6; !address of variable in record (+extra)
// 357 %const %integer a in rec = 7; !address in record (indirect+extra)
// 358
// 359 !form flags
// 360
// 361 %const %integer indexed = 1, { base[index] }
// 362+ x defer = 2, {(with indexed) @base[index] - arrayname}
// 363+ auto i = 4,
// 364+ auto d = 8
// 365
// 366
// 367 %const %byte %array fmap (0 : 15) =
const unsigned char FMAP[16] = {0, 2, 132, 15, 4, 0, 6, 16, 17, 18, 16, 34, 66, 164, 196, 0};
// 368+ 0, vins, ains+indirect bit,
// 369+ {null scalar name}
// 370+ 15, recfm, 0, switch,
// 371+ {3 4 5 6}
// 372+ procbit, vinr+procbit, vins+procbit, procbit,
// 373+ {routine function map pred}
// 374+ vins+arraybit, vins+arrayname bit,
// 375+ {array arrayname}
// 376+ ains+array bit+indirect bit,
// 377+ {namearray}
// 378+ ains+arrayname bit+indirect bit,
// 379+ {namearrayname}
// 380+ 0
// 381 {null}
// 382
// 383
// 384 !operators
// 385
// 386 %const %integer not = 7
// 387 %const %integer neg = 8
// 388 %const %integer add = 9
// 389 %const %integer sub = 10
// 390 %const %integer bsub = 11
// 391 %const %integer bic = 12
// 392 %const %integer or = 13
// 393 %const %integer xor = 14
// 394 %const %integer lsh = 15
// 395 %const %integer rsh = 16
// 396 %const %integer div = 17
// 397 %const %integer bslh = 18
// 398 %const %integer brsh = 19
// 399 %const %integer bdiv = 20
// 400 %const %integer exp = 21
// 401 %const %integer rexp = 22
// 402 %const %integer rdiv = 23
// 403 %const %integer bexp = 24
// 404 %const %integer brexp= 25
// 405 %const %integer brdiv= 26
// 406 %const %integer mul = 27
// 407 %const %integer remy = 28
// 408 %const %integer brem = 29
// 409
// 410 !primitive routines
// 411
// 412 %const %integer prim rts = 26; ! number of last routine
// 413
// 414 %const %integer set dv = 1; ! A create dope vect on stack
// 415 %const %integer adec = 2; ! B declare array space
// 416 %const %integer test ass = 3; ! C %signal if unassigned
// 417 ! %const %integer = 4; ! D set up %for block (old)
// 418 ! %const %integer = 5; ! E V6 resolution
// 419 %const %integer check resolution = 6; ! F %signal if res fails
// 420 ! %const %integer for test = 7; ! G test %for validity
// 421 %const %integer stop = 8; ! H %signal 0, 0, 0
// 422 ! %const %integer smove = 9; ! I unused!!!!!
// 423 %const %integer for test = 10; ! J ** new %for test
// 424 %const %integer scomp = 11; ! K compare strings lexically
// 425 %const %integer monit = 12; ! L call diag routine
// 426 %const %integer proc enter = 13; ! M call proc param
// 427 %const %integer exp int = 14; ! N integer exponentiation
// 428 %const %integer exp real = 15; ! O real exponentiation
// 429 %const %integer signal = 16; ! P %signal
// 430 %const %integer arefn = 17; ! Q multi-dim array ref
// 431 %const %integer a ref = 18; ! R single dim array ref (check)
// 432 %const %integer sw jump = 19; ! S switch jump
// 433 %const %integer rch = 20; ! T read ch
// 434 %const %integer rsym = 21; ! U read symbol
// 435 %const %integer pch = 22; ! V print ch
// 436 %const %integer psym = 23; ! W print symbol
// 437 %const %integer char num = 24; ! X charno (checks range)
// 438 %const %integer test string ovf = 25; ! Y string length check
// 439 %const %integer resolution = 26; ! Z perform resolution
// 440
// 441 %const %byte %array prim mask (1 : primrts) =
const unsigned char PRIMMASK[26] = {60, 32, 0, 0, 60, 0, 0, 0, 0, 0, 60, 0, 0,
0, 60, 0, 60, 8, 0, 12, 12, 12, 12, 0, 0, 0};
// 442+ 16_3C, 16_20, 16_00, 16_00, 16_3C,
// 443+ 16_00, 16_00, 16_00, 16_00, 16_00,
// 444+ 16_3C, 16_00, 16_00, 16_00, 16_3C,
// 445+ 16_00, 16_3C, 16_08, 16_00, 16_0C,
// 446+ 16_0C, 16_0C, 16_0C, 16_00, 16_00,
// 447+ 16_00
// 448
// 449 !opcode flag bits
// 450
// 451 %const %integer one bit = 16_0100, {one operand}
// 452+ two bit = 16_0200, {two operand}
// 453+ add bit = 16_0400, {add operation}
// 454+ sub bit = 16_0800, {subtract operation}
// 455+ addr bit = 16_1000, {address operation}
// 456+ move bit = 16_2000, {move operation}
// 457+ commute = 16_4000, {commutative op}
// 458+ reversible = 16_8000 {order of operands unimportant}
// 459
// 460 %const %integer no short = 16_10000; ! use char instr in STRING3
// 461 %const %integer len check = 16_20000; ! check length on string op
// 462 %const %integer no ass chk = 16_40000 {omit string assigned check}
// 463
// 464 !opcodes
// 465
// 466 %const %integer movl = 1*8+move bit+one bit+two bit
// 467 %const %integer mnegl = 0*8
// 468 %const %integer mcoml = 3*8
// 469 %const %integer addl = 14*8+add bit+one bit+two bit+commute
// 470 %const %integer subl = 15*8+sub bit+one bit+two bit
// 471 %const %integer bicl = 18*8+two bit
// 472 %const %integer bisl = 19*8+two bit+commute
// 473 %const %integer xorl = 20*8+two bit+commute
// 474 %const %integer bitl = 21*8+commute+reversible
// 475 %const %integer mull = 16*8+two bit+commute
// 476 %const %integer divl = 17*8+two bit
// 477 %const %integer moval = 2*8+addr bit, movab = moval+2
// 478 %const %integer clrl = 6*8
// 479
// 480 %const %integer tstl = 29*8
// 481 %const %integer cmpl = 30*8, cmpd = cmpl+4, cmpw = cmpl+1
// 482
// 483 %const %integer calls = 0*8+7
// 484 %const %integer jsb = 1*8+7
// 485 %const %integer ret = 2*8+7
// 486
// 487 %const %integer sobgtr = 12*8+7
// 488
// 489 %const %integer ashq = 17*8+6
// 490 %const %integer ashl = 17*8+5
// 491 %const %integer ediv = 17*8+7
// 492
// 493 %const %integer incl = 12*8
// 494 %const %integer movzbl = 9*8, movzwl = 9*8+7
// 495 %const %integer movq = 1*8+5, movw = movl+1, movb = movl+2
// 496 %const %integer movd = 1*8+4, movf = 1*8+3
// 497 %const %integer pushal = 5*8 + addr bit
// 498 %const %integer pushl = 4*8
// 499
// 500 %const %integer movc3 = 3*8+6, cmpc3 = 30*8+6
// 501 %const %integer movc5 = 3*8+7
// 502
// 503 %const %integer mnegd = mnegl+4
// 504 %const %integer addd = addl+4, addb2 = addl+2
// 505 %const %integer subd = subl+4
// 506 %const %integer muld = mull+4
// 507 %const %integer divd = divl+4
// 508
// 509 %const %integer cvtlw = 7*8+1
// 510 %const %integer cvtld = 7*8+4
// 511 %const %integer movpsl = 4*8+7
// 512 %const %integer extzv = 10*8+7, extv = 11*8+7
// 513
// 514 ! sundry actual op-codes
// 515 %const %integer bicpsw vbit = 16_20B9; ! Clear V-bit in PSW
// 516 %const %integer bispsw vbit = 16_20B8; ! Set V-bit in PSW
// 517 %const %integer bgeq = 16_18; ! Branch if >= (0), for |X|
// 518
// 519 %const %integer three op = 8*8
// 520
// 521 %record %format varfm (%c
struct VARFM {
union {
struct {
int DISP;
int LENGTH;
int EXTRA;
int ZEROAD;
int HEADER;
short int FORMAT;
short int XNO;
unsigned char TYPE;
unsigned char FORM;
unsigned char BASE;
unsigned char FLAGS;
};
};
};
// 522+ %integer disp, length, extra, zeroad, header,
// 523+ %short format, xno,
// 524+ %byte type, form, base, flags)
// 525
// 526 %record %format stackfm (%c
struct STACKFM {
union {
struct {
union {
struct {
int DISP;
int MANTISSA;
};
struct {
double LRVAL;
};
};
int EXTRA;
int LENGTH;
int HEADER;
short int FORMAT;
short int XNO;
unsigned char TYPE;
unsigned char FORM;
unsigned char BASE;
unsigned char OPER;
unsigned char FLAGS;
unsigned char INDEX;
unsigned char ISCALE;
struct STACKFM *LINK;
};
};
};
// 527+ (%integer disp, mantissa %or %longreal lrval),
// 528+ %integer extra, length, header,
// 529+ %short format, xno,
// 530+ %byte type, form, base, oper, flags, index, iscale,
// 531+ %record(stackfm) %name link )
// 532
// 533 !data formats
// 534
// 535 %record %format dfm (%record(stackfm) %name d, %record(dfm) %name link)
struct DFM {
union {
struct {
struct STACKFM *D;
struct DFM *LINK;
};
};
};
// 536 %record %format labelfm (%short id, tag)
struct LABELFM {
union {
struct {
short int ID;
short int TAG;
};
};
};
// 537
// 538 %own %integer specs = 0; !size of spec area (code)
static int SPECS = 0;
// 539 %own %integer ca = 0; !current code address
static int CA = 0;
// 540 %own %integer ga = 0; !current gla address
static int GA = 0;
// 541 %own %integer cp = 0; !code buffer pointer
static int CP = 0;
// 542 %own %integer gp = 0; !gla buffer pointer
static int GP = 0;
// 543 %own %integer diag lines = 0; !size of line info
static int DIAGLINES = 0;
// 544 %own %integer diag size = 0; !size of diag tables
static int DIAGSIZE = 0;
// 545 %own %integer sym = 0; !current code symbol
static int SYM = 0;
// 546 %own %integer code = 0; !current coded code symbol
static int CODE = 0;
// 547 %own %integer errors = 0; !total errors
static int ERRORS = 0;
// 548 %own %integer line error = 0; !flag for errors on this line
static int LINEERROR = 0;
// 549 %own %integer current line = 0
static int CURRENTLINE = 0;
// 550 %own %integer stp = 0
static int STP = 0;
// 551 %own %integer data size = 0
static int DATASIZE = 0;
// 552 %own %integer ivbit state = 0; ! for overflow masking
static int IVBITSTATE = 0;
// 553 %own %integer entry mask = 0; !proc entry mask
static int ENTRYMASK = 0;
// 554 %own %integer frame = 0; !current stack frame limit
static int FRAME = 0;
// 555 %own %integer last local; !local limit for unass check
static int LASTLOCAL;
// 556 %own %integer level = -1
static int LEVEL = -1;
// 557 %own %integer unsigned = 0
static int UNSIGNED = 0;
// 558 %own %integer invert = 0; !condition inversion flag
static int INVERT = 0;
// 559 %own %integer uncond jump = 0
static int UNCONDJUMP = 0;
// 560 %own %integer last movc3 = -1; !address of MOVC3
static int LASTMOVC3 = -1;
// 561 %own %integer gmode = 0; !parameter-format flag
static int GMODE = 0;
// 562 %own %integer gtype = 0; ! do.
static int GTYPE = 0;
// 563 %own %integer last ref = 0
static int LASTREF = 0;
// 564 %own %integer evno = 0; !event trap counter
static int EVNO = 0;
// 565 %own %integer ownval, mantissa; !***Own and order critical***
static int OWNVAL;
static int MANTISSA;
// 566 %own %integer discard
static int DISCARD;
// 567 %own %integer index regs = 0
static int INDEXREGS = 0;
// 568 %own %integer active regs = 0
static int ACTIVEREGS = 0;
// 569 %integer parms = max vars+1; !start of parameter area
int PARMS;
PARMS = 2000 + 1;
// 570 %integer local = 0; !local base register
int LOCAL;
LOCAL = 0;
// 571 %integer otype, potype = 0
int OTYPE;
int POTYPE;
POTYPE = 0;
// 572 %integer decl; !last descriptor index
int DECL;
// 573 %integer owntype, ownform
int OWNTYPE;
int OWNFORM;
// 574 %integer spec
int SPEC;
// 575 %integer vlb, vub; !vector bounds
int VLB;
int VUB;
// 576 %integer j, n
int J;
int N;
// 577
// 578 %const %record(*) %name null == 0
const struct TAG *NULL = 0;
// 579
// 580 %record(stackfm) %name lhs, rhs
struct STACKFM *LHS;
struct STACKFM *RHS;
// 581 %record(stackfm) %name desc asl
struct STACKFM *DESCASL;
// 582 %record(dfm) %name dasl
struct DFM *DASL;
// 583 %record(dfm) using
struct DFM USING;
// 584 %record(varfm) %name decvar
struct VARFM *DECVAR;
// 585 %record(varfm) %name formal, actual
struct VARFM *FORMAL;
struct VARFM *ACTUAL;
// 586
// 587 %own %byte %array code buffer (1 : 128)
static unsigned char CODEBUFFER[128];
// 588 %own %byte %array gla buffer (1 : 128)
static unsigned char GLABUFFER[128];
// 589
// 590 %own %record(varfm) begin
static struct VARFM BEGIN;
// 591
// 592 %external %string(max ident) %spec entryname
extern _imp_string31 ENTRYNAME;
// 593 %own %string(255) text; !for string constants
static _imp_string255 TEXT;
// 594 %own %string(max ident) external name, alias, var name
static _imp_string31 EXTERNALNAME;
static _imp_string31 ALIAS;
static _imp_string31 VARNAME;
// 595
// 596 %own %record(stackfm) %array regv (r0 : fpr4)
static struct STACKFM REGV[20];
// 597 %own %integer %array activity (0 : fpr4) = 0(*)
static int ACTIVITY[21] = {[0 ... 20] = 0};
// 598 %own %integer %array used (0 : fpr4) = 0(*)
static int USED[21] = {[0 ... 20] = 0};
// 599 %own %byte %array indx (r0 : r10) = 0(*)
static unsigned char INDX[11] = {[0 ... 10] = 0};
// 600
// 601 %record(stackfm) head, dope, zeroth
struct STACKFM HEAD;
struct STACKFM DOPE;
struct STACKFM ZEROTH;
// 602 %record(stackfm) zero v
struct STACKFM ZEROV;
// 603 %record(stackfm) gla work; !used for clearing records
struct STACKFM GLAWORK;
// 604 %record(stackfm) spv; ! => -(SP) operand
struct STACKFM SPV;
// 605
// 606 %record(stackfm) %name %array stacked (1 : max depth)
struct STACKFM *STACKED[16];
// 607 %record(dfm) %array dlist (0 : max stack)
struct DFM DLIST[26];
// 608 %record(stackfm) %array stak (0 : max stack)
struct STACKFM STAK[26];
// 609 %record(labelfm) %array labels (1 : max labels)
struct LABELFM LABELS[120];
// 610 %record(varfm) %array var (0 : max vars)
struct VARFM VAR[2001];
// 611
// 612
// 613 %const %short %array op map (add : brem) =
const short int OPMAP[21] = {18352, 3000, 0, 720, 17112, 17120, 0, 0, 712, [9 ... 17] = 0, 17088, [19 ... 20] = 0};
// 614+ addl+three op, subl+three op, 0, bicl+three op,
// 615+ bisl+three op, xorl+three op, 0, 0,
// 616+ divl+three op, 0(9), mull+three op, 0(2)
// 617
// 618 !0 = ok, 1 = same, 2 = never
// 619 %const %byte %array trans (add : brem) =
const unsigned char TRANS[21] = {0, 0, 0, 2, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 2, 2};
// 620+ 0, 0,
// 621+ 0, 2, 1, 1,
// 622+ 2, 2, 2, 2,
// 623+ 2, 2, 2, 2,
// 624+ 2, 2, 2, 2,
// 625+ 1, 2, 2
// 626
// 627 %const %byte %array comm (add : brem) =
const unsigned char COMM[21] = {1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0};
// 628+ 1, 0,
// 629+ 0, 0, 1, 1,
// 630+ 0, 0, 0, 0,
// 631+ 0, 0, 0, 0,
// 632+ 0, 0, 0, 0,
// 633+ 1, 0, 0
// 634
// 635 %const %integer no null = 2
// 636
// 637 ! values of RH for which LH oper RH = LH: 2 => no value
// 638 %const %integer %array rnull op (add : brem) =
const int RNULLOP[21] = {0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 2, 2, 1, 1, 1, 2, 2, 2, 1, 2, 2};
// 639+ 0, 0,
// 640+ 0, 0, 0, 0,
// 641+ 0, 0, 1, 0,
// 642+ 2, 2, 1, 1,
// 643+ 1, 2, 2, 2,
// 644+ 1, 2, 2
// 645
// 646 ! values of LH for which LH oper RH = RH: 2 => no value
// 647 %const %integer %array lnull op (add : brem) =
const int LNULLOP[21] = {0, 2, 0, 2, 0, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 2, 2};
// 648+ 0, 2,
// 649+ 0, 2, 0, 0,
// 650+ 2, 2, 2, 2,
// 651+ 2, 2, 2, 2,
// 652+ 2, 2, 2, 2,
// 653+ 1, 2, 2
// 654
// 655 ! %const %byte %array op real (not : brem) =
// 656 ! 0, 1, 1, 1,
// 657 ! 0, 0, 0, 0,
// 658 ! 0, 0, 0, 0,
// 659 ! 0, 0, 0, 1,
// 660 ! 1, 0, 0, 0,
// 661 ! 1, 0, 0
// 662
// 663 %const %string(4) %array op name (not : brem) =
const _imp_string4 OPNAME[23] = {
_imp_str_init("U\\"), _imp_str_init("U-"), _imp_str_init("+"), _imp_str_init("-"), _imp_str_init("B-"),
_imp_str_init("BIC"), _imp_str_init("!"), _imp_str_init("!!"), _imp_str_init("<<"), _imp_str_init(">>"),
_imp_str_init("//"), _imp_str_init("B<<"), _imp_str_init("B>>"), _imp_str_init("B/"), _imp_str_init("^^"),
_imp_str_init("^"), _imp_str_init("/"), _imp_str_init("B^^"), _imp_str_init("B^"), _imp_str_init("B/"),
_imp_str_init("*"), _imp_str_init("REM"), _imp_str_init("BREM")};
// 664+ "U\", "U-", "+", "-",
// 665+ "B-", "BIC", "!", "!!",
// 666+ "<<", ">>", "//", "B<<",
// 667+ "B>>", "B/", "^^", "^",
// 668+ "/", "B^^", "B^", "B/",
// 669+ "*", "REM", "BREM"
// 670
// 671 !opcode table
// 672
// 673 %const %byte %array op code (0 : 31*8-1) =
const unsigned char OPCODE[248] = {
206, 174, 142, 82, 114, 0, 0, 251, 208, 176, 144, 80, 112, 125, 0, 22, 222, 62, 158, 222, 126, 126, 0,
4, 210, 178, 146, 0, 0, 0, 40, 44, 221, 0, 0, 0, 0, 0, 0, 220, 223, 63, 159, 223, 127, 127,
0, 0, 212, 180, 148, 212, 124, 124, 0, 0, 208, 247, 144, 78, 110, 0, 0, 0, 50, 176, 144, 77, 109,
0, 0, 0, 154, 155, 144, 76, 108, 0, 0, 60, 74, 73, 72, 80, 86, 0, 75, 239, 106, 105, 104, 118,
112, 0, 107, 238, 214, 182, 150, 0, 0, 0, 0, 245, 215, 183, 151, 0, 0, 0, 0, 0, 192, 160, 128,
64, 96, 0, 0, 0, 194, 162, 130, 66, 98, 0, 0, 0, 196, 164, 132, 68, 100, 0, 0, 0, 198, 166,
134, 70, 102, 120, 121, 123, 202, 170, 138, 0, 0, 0, 0, 0, 200, 168, 136, 0, 0, 0, 0, 0, 204,
172, 140, 0, 0, 0, 0, 0, 211, 179, 147, 0, 0, 0, 0, 0, 193, 161, 129, 65, 97, 0, 0, 0,
195, 163, 131, 67, 99, 0, 0, 0, 197, 165, 133, 69, 101, 0, 0, 0, 199, 167, 135, 71, 103, 0, 0,
0, 203, 171, 139, 0, 0, 0, 0, 0, 201, 169, 137, 0, 0, 0, 185, 184, 205, 173, 141, 0, 0, 0,
0, 0, 213, 181, 149, 83, 115, 0, 0, 0, 209, 177, 145, 81, 113, 113, 41, 45};
// 674+ 16_ce, 16_ae, 16_8e, 16_52, 16_72, 0, 0, 16_fb,
// 675+ ! 0 mnegl mnegw mnegb mnegf mnegd - - calls
// 676+ 16_d0, 16_b0, 16_90, 16_50, 16_70, 16_7d, 0, 16_16,
// 677+ ! 1 movl movw movb movf movd movq - jsb
// 678+ 16_de, 16_3e, 16_9e, 16_de, 16_7e, 16_7e, 0, 16_04,
// 679+ ! 2 moval movaw movab movaf movad movaq - ret
// 680+ 16_d2, 16_b2, 16_92, 0, 0, 0, 16_28, 16_2c,
// 681+ ! 3 mcoml mcomw mcomb - - - movc3 movc5
// 682+ 16_dd, 0, 0, 0, 0, 0, 0, 16_dc,
// 683+ ! 4 pushl - - - - - - movpsl
// 684+ 16_df, 16_3f, 16_9f, 16_df, 16_7f, 16_7f, 0, 0,
// 685+ ! 5 pushal pushaw pushab pushaf pushad pushaq - -
// 686+ 16_d4, 16_b4, 16_94, 16_d4, 16_7c, 16_7c, 0, 0,
// 687+ ! 6 clrl clrw clrb clrf clrd clrq - -
// 688+ 16_d0, 16_f7, 16_90, 16_4e, 16_6e, 0, 0, 0,
// 689+ ! 7 movl cvtlw movb cvtlf cvtld - - -
// 690+ 16_32, 16_b0, 16_90, 16_4d, 16_6d, 0, 0, 0,
// 691+ ! 8 cvtwl movw movb cvtwf cvtwd - - -
// 692+ 16_9a, 16_9b, 16_90, 16_4c, 16_6c, 0, 0, 16_3c,
// 693+ ! 9 movzbl movzbw movb cvtbf cvtbd - - movzwl
// 694+ 16_4a, 16_49, 16_48, 16_50, 16_56, 0, 16_4b, 16_ef,
// 695+ !10 cvtfl cvtfw cvtfb movf cvtfd - cvtrfl extzv
// 696+ 16_6a, 16_69, 16_68, 16_76, 16_70, 0, 16_6b, 16_ee,
// 697+ !11 cvtdl cvtdw cvtdb cvtdf movd - cvtrdl extv
// 698+ 16_d6, 16_b6, 16_96, 0, 0, 0, 0, 16_f5,
// 699+ !12 incl incw incb - - - - sobgtr
// 700+ 16_d7, 16_b7, 16_97, 0, 0, 0, 0, 0,
// 701+ !13 decl decw decb - - - - -
// 702+ 16_c0, 16_a0, 16_80, 16_40, 16_60, 0, 0, 0,
// 703+ !14 addl2 addw2 addb2 addf2 addd2 - - -
// 704+ 16_c2, 16_a2, 16_82, 16_42, 16_62, 0, 0, 0,
// 705+ !15 subl2, subw2, subb2, subf2, subd2 - - -
// 706+ 16_c4, 16_a4, 16_84, 16_44, 16_64, 0, 0, 0,
// 707+ !16 mull2 mulw2 mulb2 mulf2 muld2 - - -
// 708+ 16_c6, 16_a6, 16_86, 16_46, 16_66, 16_78, 16_79, 16_7b,
// 709+ !17 divl2 divw2 divb2 divf2 divd2 ashl ashq ediv
// 710+ 16_ca, 16_aa, 16_8a, 0, 0, 0, 0, 0,
// 711+ !18 bicl2 bicw2 bicb2 - - - - -
// 712+ 16_c8, 16_a8, 16_88, 0, 0, 0, 0, 0,
// 713+ !19 bisl2 bisw2 bisb2 - - - - -
// 714+ 16_cc, 16_ac, 16_8c, 0, 0, 0, 0, 0,
// 715+ !20 xorl2 xorw2 xorb2 - - - - -
// 716+ 16_d3, 16_b3, 16_93, 0, 0, 0, 0, 0,
// 717+ !21 bitl bitw bitb - - - - -
// 718+ 16_c1, 16_a1, 16_81, 16_41, 16_61, 0, 0, 0,
// 719+ !22 addl3 addw3 addb3 addf3 addd3 - - -
// 720+ 16_c3, 16_a3, 16_83, 16_43, 16_63, 0, 0, 0,
// 721+ !23 subl3 subw3 subb3 subf3 subd3 - - -
// 722+ 16_c5, 16_a5, 16_85, 16_45, 16_65, 0, 0, 0,
// 723+ !24 mull3 mulw3 mulb3 mulf3 muld3 - - -
// 724+ 16_c7, 16_a7, 16_87, 16_47, 16_67, 0, 0, 0,
// 725+ !25 divl3 divw3 divb3 divf3 divd3 - - -
// 726+ 16_cb, 16_ab, 16_8b, 0, 0, 0, 0, 0,
// 727+ !26 bicl3 bicw3 bicb3 - - - - -
// 728+ 16_c9, 16_a9, 16_89, 0, 0, 0, 16_b9, 16_b8,
// 729+ !27 bisl3 bisw3 bisb3 - - - bicpsw bispsw
// 730+ 16_cd, 16_ad, 16_8d, 0, 0, 0, 0, 0,
// 731+ !28 xorl3 xorw3 xorb3 - - - - -
// 732+ 16_d5, 16_b5, 16_95, 16_53, 16_73, 0, 0, 0,
// 733+ !29 tstl tstw tstb tstf tstd - - -
// 734+ 16_d1, 16_b1, 16_91, 16_51, 16_71, 16_71, 16_29, 16_2d
// 735 !30 cmpl cmpw cmpb cmpf cmpd cmpd cmpc3 cmpc5
// 736
// 737 !bit significance:
// 738
// 739 %const %integer check1 = 2_0000 0001,
// 740+ check2 = 2_0000 0010,
// 741+ check3 = 2_0000 0100,
// 742+ move check = 2_0000 1000
// 743
// 744 %const %byte %array operand bits (0 : 255) =
const unsigned char OPERANDBITS[256] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 1, 1,
1, 1, 0, 0, 1, 0, 9, 3, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 1, 1, 1, 1, 0, 0, 1,
0, 9, 1, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 0, 9, 3, 1, 3, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
// 745+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 746+ ! 0 halt nop rei bpt ret rsb
// 747+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 748+ ! 6 ldpctx svpctx cvtps cvtsp index crc
// 749+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 750+ ! 12 prober probew insque remque bsbb brb
// 751+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 752+ ! 18 bneq beql bgtr bleq jsb jmp
// 753+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 754+ ! 24 bgeq blss bgtru blequ bvc bvs
// 755+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 756+ ! 30 bgequ blssu addp4 addp6 subp4 subp6
// 757+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 758+ ! 36 cvtpt mulp cvttp divp movc3 cmpc3
// 759+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 760+ ! 42 scanc spanc movc5 cmpc5 movtc movtuc
// 761+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 762+ ! 48 bsbw brw cvtwl cvtwb movp comp3
// 763+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 764+ ! 54 cvtpl cmpp4 editpc matchc locc skpc
// 765+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0011,2_0000 0011,
// 766+ ! 60 movzwl acbw movaw pushaw addf2 addf3
// 767+ 2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
// 768+ ! 66 subf2 subf3 mulf2 mulf3 divf2 divf3
// 769+ 2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0000,2_0000 0000,
// 770+ ! 72 cvtfb cvtfw cvtfl cvtrfl cvtbf
// 771+ 2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0011,2_0000 0001,2_0000 0001,
// 772+ ! 78 cvtlf acbf movf cmpf mnegf tstf
// 773+ 2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,2_0000 0000,2_0000 0000,
// 774+ ! 84 emodf polyf cvtfd adawi
// 775+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 776+ ! 90
// 777+ 2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
// 778+ ! 96 addd2 addd3 subd2 subd3 muld2 muld3
// 779+ 2_0000 0011,2_0000 0011,2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0001,
// 780+ !102 divd2 divd3 cvtdb cvtdw cvtdl cvtrdl
// 781+ 2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0001,
// 782+ !108 cvtbd cvtwd cvtld acbd movd cmpd
// 783+ 2_0000 0001,2_0000 0001,2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,
// 784+ !114 mnegd tstd emodd polyd cvtdf
// 785+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 786+ !120 ashl ashq emul ediv clrq movq
// 787+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 788+ !126 movaq pushaq addb2 addb3 subb2 subb3
// 789+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 790+ !132 mulb2 mulb3 devb2 divb3 bisb2 misb3
// 791+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 792+ !138 bicb2 bicb3 xorb2 xorb3 mnegb caseb
// 793+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 794+ !144 movb cmpb mcomb bitb clrb tstb
// 795+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 796+ !150 incb decb cvtbl cvtbw movzbl movzbw
// 797+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 798+ !156 rotl acbb movab pushab addw2 addw3
// 799+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 800+ !162 subw2 subw3 mulw2 mulw3 divw2 divw3
// 801+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 802+ !168 bisw2 bisw3 bicw2 bicw3 xorw2 xorw3
// 803+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 804+ !174 mnegw casew movw cmpw mcomw bitw
// 805+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 806+ !180 clrw tstw incw decw bispsw bicpsw
// 807+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 808+ !186 popr pushr chmk chme chms chmu
// 809+ 2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
// 810+ !192 addl2 addl3 subl2 subl3 mull2 mull3
// 811+ 2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
// 812+ !198 divl2 divl3 bisl2 bisl3 bicl2 bicl3
// 813+ 2_0000 0011,2_0000 0011,2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0011,
// 814+ !204 xorl2 xorl3 mnegl casel movl cmpl
// 815+ 2_0000 0001,2_0000 0011,2_0000 0000,2_0000 0001,2_0000 0001,2_0000 0001,
// 816+ !210 mcoml bitl clrl tstl incl decl
// 817+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0001,
// 818+ !216 adwc sbwc mtpr mfpr movpsl pushl
// 819+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 820+ !222 moval pushal bbs bbc bbss bbcs
// 821+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 822+ !228 bbsc bbcc bbssi bbcci blbs blbc
// 823+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 824+ !234 ffs ffc cmpv cmpzv extv extzv
// 825+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 826+ !240 insv acbl aoblss aobleq sobgeq sobgtr
// 827+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
// 828+ !246 cvtlb cvtlw ashp cvtlp callg calls
// 829+ 2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000
// 830 !252 xfc
// 831
// 832 !diagnostic tables
// 833
// 834 %const %string(3)%array reg name (0 : 20) =
const _imp_string3 REGNAME[21] = {
_imp_str_init("???"), _imp_str_init(" R0"), _imp_str_init(" R1"), _imp_str_init(" R2"), _imp_str_init(" R3"),
_imp_str_init(" R4"), _imp_str_init(" R5"), _imp_str_init(" R6"), _imp_str_init(" R7"), _imp_str_init(" R8"),
_imp_str_init(" R9"), _imp_str_init("R10"), _imp_str_init("GLA"), _imp_str_init(" AP"), _imp_str_init(" FP"),
_imp_str_init(" SP"), _imp_str_init(" PC"), _imp_str_init("Any"), _imp_str_init(" F0"), _imp_str_init(" F2"),
_imp_str_init(" F4")};
// 835+ "???", " R0", " R1", " R2", " R3", " R4", " R5", " R6", " R7",
// 836+ " R8", " R9", "R10", "GLA", " AP", " FP", " SP", " PC", "Any",
// 837+ " F0", " F2", " F4"
// 838
// 839 %const %string(6) %array op mnem (0 : 255) =
const _imp_string6 OPMNEM[256] = {_imp_str_init("HALT"), _imp_str_init("NOP"),
_imp_str_init("REI"), _imp_str_init("BPT"),
_imp_str_init("RET"), _imp_str_init("RSB"),
_imp_str_init("LDPCTX"), _imp_str_init("SVPCTX"),
_imp_str_init("CVTPS"), _imp_str_init("CVTSP"),
_imp_str_init("INDEX"), _imp_str_init("CRC"),
_imp_str_init("PROBER"), _imp_str_init("PROBEW"),
_imp_str_init("INSQUE"), _imp_str_init("REMQUE"),
_imp_str_init("BSBB"), _imp_str_init("BRB"),
_imp_str_init("BNEQ"), _imp_str_init("BEQL"),
_imp_str_init("BGTR"), _imp_str_init("BLEQ"),
_imp_str_init("JSB"), _imp_str_init("JMP"),
_imp_str_init("BGEQ"), _imp_str_init("BLSS"),
_imp_str_init("BGTRU"), _imp_str_init("BLEQU"),
_imp_str_init("BVC"), _imp_str_init("BVS"),
_imp_str_init("BGEQU"), _imp_str_init("BLSSU"),
_imp_str_init("ADDP4"), _imp_str_init("ADDP6"),
_imp_str_init("SUBP4"), _imp_str_init("SUBP6"),
_imp_str_init("CVTPT"), _imp_str_init("MULP"),
_imp_str_init("CVTTP"), _imp_str_init("DIVP"),
_imp_str_init("MOVC3"), _imp_str_init("CMPC3"),
_imp_str_init("SCANC"), _imp_str_init("SPANC"),
_imp_str_init("MOVC5"), _imp_str_init("CMPC5"),
_imp_str_init("MOVTC"), _imp_str_init("MOVTUC"),
_imp_str_init("BSBW"), _imp_str_init("BRW"),
_imp_str_init("CVTWL"), _imp_str_init("CVTWB"),
_imp_str_init("MOVP"), _imp_str_init("COMP3"),
_imp_str_init("CVTPL"), _imp_str_init("CMPP4"),
_imp_str_init("EDITPC"), _imp_str_init("MATCHC"),
_imp_str_init("LOCC"), _imp_str_init("SKPC"),
_imp_str_init("MOVZWL"), _imp_str_init("ACBW"),
_imp_str_init("MOVAW"), _imp_str_init("PUSHAW"),
_imp_str_init("ADDF2"), _imp_str_init("ADDF3"),
_imp_str_init("SUBF2"), _imp_str_init("SUBF3"),
_imp_str_init("MULF2"), _imp_str_init("MULF3"),
_imp_str_init("DIVF2"), _imp_str_init("DIVF3"),
_imp_str_init("CVTFB"), _imp_str_init("CVTFW"),
_imp_str_init("CVTFL"), _imp_str_init("CVTRFL"),
_imp_str_init("CVTBF"), _imp_str_init("?????"),
_imp_str_init("CVTLF"), _imp_str_init("ACBF"),
_imp_str_init("MOVF"), _imp_str_init("CMPF"),
_imp_str_init("MNEGF"), _imp_str_init("TSTF"),
_imp_str_init("EMODF"), _imp_str_init("POLYF"),
_imp_str_init("CVTFD"), _imp_str_init("?????"),
_imp_str_init("ADAWI"), _imp_str_init("?????"),
_imp_str_init("?????"), _imp_str_init("?????"),
_imp_str_init("?????"), _imp_str_init("?????"),
_imp_str_init("?????"), _imp_str_init("?????"),
_imp_str_init("ADDD2"), _imp_str_init("ADDD3"),
_imp_str_init("SUBD2"), _imp_str_init("SUBD3"),
_imp_str_init("MULD2"), _imp_str_init("MULD3"),
_imp_str_init("DIVD2"), _imp_str_init("DIVD3"),
_imp_str_init("CVTDB"), _imp_str_init("CVTDW"),
_imp_str_init("CVTDL"), _imp_str_init("CVTRDL"),
_imp_str_init("CVTBD"), _imp_str_init("CVTWD"),
_imp_str_init("CVTLD"), _imp_str_init("ACBD"),
_imp_str_init("MOVD"), _imp_str_init("CMPD"),
_imp_str_init("MNEGD"), _imp_str_init("TSTD"),
_imp_str_init("EMODD"), _imp_str_init("POLYD"),
_imp_str_init("CVTDF"), _imp_str_init("?????"),
_imp_str_init("ASHL"), _imp_str_init("ASHQ"),
_imp_str_init("EMUL"), _imp_str_init("EDIV"),
_imp_str_init("CLRQ"), _imp_str_init("MOVQ"),
_imp_str_init("MOVAQ"), _imp_str_init("PUSHAQ"),
_imp_str_init("ADDB2"), _imp_str_init("ADDB3"),
_imp_str_init("SUBB2"), _imp_str_init("SUBB3"),
_imp_str_init("MULB2"), _imp_str_init("MULB3"),
_imp_str_init("DEVB2"), _imp_str_init("DIVB3"),
_imp_str_init("BISB2"), _imp_str_init("BISB3"),
_imp_str_init("BICB2"), _imp_str_init("BICB3"),
_imp_str_init("XORB2"), _imp_str_init("XORB3"),
_imp_str_init("MNEG"), _imp_str_init("CASEB"),
_imp_str_init("MOVB"), _imp_str_init("CMPB"),
_imp_str_init("MCOMB"), _imp_str_init("BITB"),
_imp_str_init("CLRB"), _imp_str_init("TSTB"),
_imp_str_init("INCB"), _imp_str_init("DECB"),
_imp_str_init("CVTBL"), _imp_str_init("CVTBW"),
_imp_str_init("MOVZBL"), _imp_str_init("MOVZBW"),
_imp_str_init("ROTL"), _imp_str_init("ACBB"),
_imp_str_init("MOVAB"), _imp_str_init("PUSHAB"),
_imp_str_init("ADDW2"), _imp_str_init("ADDW3"),
_imp_str_init("SUBW2"), _imp_str_init("SUBW3"),
_imp_str_init("MULW2"), _imp_str_init("MULW3"),
_imp_str_init("DIVW2"), _imp_str_init("DIVW3"),
_imp_str_init("BISW2"), _imp_str_init("BISW3"),
_imp_str_init("BICW2"), _imp_str_init("BICW3"),
_imp_str_init("XORW2"), _imp_str_init("XORW3"),
_imp_str_init("MNEGW"), _imp_str_init("CASEW"),
_imp_str_init("MOVW"), _imp_str_init("CMPW"),
_imp_str_init("MCOMW"), _imp_str_init("BITW"),
_imp_str_init("CLRW"), _imp_str_init("TSTW"),
_imp_str_init("INCW"), _imp_str_init("DECW"),
_imp_str_init("BISPSW"), _imp_str_init("BICPSW"),
_imp_str_init("POPR"), _imp_str_init("PUSHR"),
_imp_str_init("CHMK"), _imp_str_init("CHME"),
_imp_str_init("CHMS"), _imp_str_init("CHMU"),
_imp_str_init("ADDL2"), _imp_str_init("ADDL3"),
_imp_str_init("SUBL2"), _imp_str_init("SUBL3"),
_imp_str_init("MULL2"), _imp_str_init("MULL3"),
_imp_str_init("DIVL2"), _imp_str_init("DIVL3"),
_imp_str_init("BISL2"), _imp_str_init("BISL3"),
_imp_str_init("BICL2"), _imp_str_init("BICL3"),
_imp_str_init("XORL2"), _imp_str_init("XORL3"),
_imp_str_init("MNEGL"), _imp_str_init("CASEL"),
_imp_str_init("MOVL"), _imp_str_init("CMPL"),
_imp_str_init("MCOML"), _imp_str_init("BITL"),
_imp_str_init("CLRL"), _imp_str_init("TSTL"),
_imp_str_init("INCL"), _imp_str_init("DECL"),
_imp_str_init("ADWC"), _imp_str_init("SBWC"),
_imp_str_init("MTPR"), _imp_str_init("MFPR"),
_imp_str_init("MOVPSL"), _imp_str_init("PUSHL"),
_imp_str_init("MOVAL"), _imp_str_init("PUSHAL"),
_imp_str_init("BBS"), _imp_str_init("BBC"),
_imp_str_init("BBSS"), _imp_str_init("BBCS"),
_imp_str_init("BBSC"), _imp_str_init("BBCC"),
_imp_str_init("BBSSI"), _imp_str_init("BBCCI"),
_imp_str_init("BLBS"), _imp_str_init("BLBC"),
_imp_str_init("FFS"), _imp_str_init("FFC"),
_imp_str_init("CMPV"), _imp_str_init("CMPZV"),
_imp_str_init("EXTV"), _imp_str_init("EXTZV"),
_imp_str_init("INSV"), _imp_str_init("ACBL"),
_imp_str_init("AOBLSS"), _imp_str_init("AOBLEQ"),
_imp_str_init("SOBGEQ"), _imp_str_init("SOBGTR"),
_imp_str_init("CVTLB"), _imp_str_init("CVTLW"),
_imp_str_init("ASHP"), _imp_str_init("CVTLP"),
_imp_str_init("CALLG"), _imp_str_init("CALLS"),
_imp_str_init("XFC"), [253 ... 255] = _imp_str_init("????")};
auto void FLUSHCODE(void);
auto void HAZARD(int REG);
auto void CLAIM(int REG);
auto void RELEASE(int REG);
auto void PRIM(int N);
auto int SCALETYPE(int LEN);
auto struct STACKFM *LITERAL(int N)
;
auto struct STACKFM *TEMP(int SIZE)
;
// 840+ "HALT", "NOP", "REI", "BPT", "RET", "RSB",
// 841+ "LDPCTX", "SVPCTX", "CVTPS", "CVTSP", "INDEX", "CRC",
// 842+ "PROBER", "PROBEW", "INSQUE", "REMQUE", "BSBB", "BRB",
// 843+ "BNEQ", "BEQL", "BGTR", "BLEQ", "JSB", "JMP",
// 844+ "BGEQ", "BLSS", "BGTRU", "BLEQU", "BVC", "BVS",
// 845+ "BGEQU", "BLSSU", "ADDP4", "ADDP6", "SUBP4", "SUBP6",
// 846+ "CVTPT", "MULP", "CVTTP", "DIVP", "MOVC3", "CMPC3",
// 847+ "SCANC", "SPANC", "MOVC5", "CMPC5", "MOVTC", "MOVTUC",
// 848+ "BSBW", "BRW", "CVTWL", "CVTWB", "MOVP", "COMP3",
// 849+ "CVTPL", "CMPP4", "EDITPC", "MATCHC", "LOCC", "SKPC",
// 850+ "MOVZWL", "ACBW", "MOVAW", "PUSHAW", "ADDF2", "ADDF3",
// 851+ "SUBF2", "SUBF3", "MULF2", "MULF3", "DIVF2", "DIVF3",
// 852+ "CVTFB", "CVTFW", "CVTFL", "CVTRFL", "CVTBF", "?????",
// 853+ "CVTLF", "ACBF", "MOVF", "CMPF", "MNEGF", "TSTF",
// 854+ "EMODF", "POLYF", "CVTFD", "?????", "ADAWI", "?????",
// 855+ "?????", "?????", "?????", "?????", "?????", "?????",
// 856+ "ADDD2", "ADDD3", "SUBD2", "SUBD3", "MULD2", "MULD3",
// 857+ "DIVD2", "DIVD3", "CVTDB", "CVTDW", "CVTDL", "CVTRDL",
// 858+ "CVTBD", "CVTWD", "CVTLD", "ACBD", "MOVD", "CMPD",
// 859+ "MNEGD", "TSTD", "EMODD", "POLYD", "CVTDF", "?????",
// 860+ "ASHL", "ASHQ", "EMUL", "EDIV", "CLRQ", "MOVQ",
// 861+ "MOVAQ", "PUSHAQ", "ADDB2", "ADDB3", "SUBB2", "SUBB3",
// 862+ "MULB2", "MULB3", "DEVB2", "DIVB3", "BISB2", "BISB3",
// 863+ "BICB2", "BICB3", "XORB2", "XORB3", "MNEG", "CASEB",
// 864+ "MOVB", "CMPB", "MCOMB", "BITB", "CLRB", "TSTB",
// 865+ "INCB", "DECB", "CVTBL", "CVTBW", "MOVZBL", "MOVZBW",
// 866+ "ROTL", "ACBB", "MOVAB", "PUSHAB", "ADDW2", "ADDW3",
// 867+ "SUBW2", "SUBW3", "MULW2", "MULW3", "DIVW2", "DIVW3",
// 868+ "BISW2", "BISW3", "BICW2", "BICW3", "XORW2", "XORW3",
// 869+ "MNEGW", "CASEW", "MOVW", "CMPW", "MCOMW", "BITW",
// 870+ "CLRW", "TSTW", "INCW", "DECW", "BISPSW", "BICPSW",
// 871+ "POPR", "PUSHR", "CHMK", "CHME", "CHMS", "CHMU",
// 872+ "ADDL2", "ADDL3", "SUBL2", "SUBL3", "MULL2", "MULL3",
// 873+ "DIVL2", "DIVL3", "BISL2", "BISL3", "BICL2", "BICL3",
// 874+ "XORL2", "XORL3", "MNEGL", "CASEL", "MOVL", "CMPL",
// 875+ "MCOML", "BITL", "CLRL", "TSTL", "INCL", "DECL",
// 876+ "ADWC", "SBWC", "MTPR", "MFPR", "MOVPSL", "PUSHL",
// 877+ "MOVAL", "PUSHAL", "BBS", "BBC", "BBSS", "BBCS",
// 878+ "BBSC", "BBCC", "BBSSI", "BBCCI", "BLBS", "BLBC",
// 879+ "FFS", "FFC", "CMPV", "CMPZV", "EXTV", "EXTZV",
// 880+ "INSV", "ACBL", "AOBLSS", "AOBLEQ", "SOBGEQ", "SOBGTR",
// 881+ "CVTLB", "CVTLW", "ASHP", "CVTLP", "CALLG", "CALLS",
// 882+ "XFC", "????"(*)
// 883
// 884
// 885 %routine %spec FLUSH CODE
// 886 %routine %spec HAZARD (%integer reg)
// 887 %routine %spec CLAIM (%integer reg)
// 888 %routine %spec RELEASE (%integer reg)
// 889 %routine %spec PRIM (%integer n)
// 890 %integer %function %spec SCALE TYPE (%integer length)
// 891 %record(stackfm) %map %spec LITERAL (%integer n)
// 892 %record(stackfm) %map %spec TEMP (%integer size)
// 893
// 894
// 895 !******** initialisation *********
// 896
// 897 regv(r0)_base = r0; regv(r0)_type = integers; regv(r0)_form=vinr
REGV[0].BASE = 1;
REGV[0].TYPE = 16;
REGV[0].FORM = 1;
// 898 regv(r1)_base = r1; regv(r1)_type = integers; regv(r1)_form=vinr
REGV[1].BASE = 2;
REGV[1].TYPE = 16;
REGV[1].FORM = 1;
// 899 regv(r2)_base = r2; regv(r2)_type = integers; regv(r2)_form=vinr
REGV[2].BASE = 3;
REGV[2].TYPE = 16;
REGV[2].FORM = 1;
// 900 regv(r3)_base = r3; regv(r3)_type = integers; regv(r3)_form=vinr
REGV[3].BASE = 4;
REGV[3].TYPE = 16;
REGV[3].FORM = 1;
// 901 regv(r4)_base = r4; regv(r4)_type = integers; regv(r4)_form=vinr
REGV[4].BASE = 5;
REGV[4].TYPE = 16;
REGV[4].FORM = 1;
// 902 regv(r5)_base = r5; regv(r5)_type = integers; regv(r5)_form=vinr
REGV[5].BASE = 6;
REGV[5].TYPE = 16;
REGV[5].FORM = 1;
// 903 regv(r6)_base = r6; regv(r6)_type = integers; regv(r6)_form=vinr
REGV[6].BASE = 7;
REGV[6].TYPE = 16;
REGV[6].FORM = 1;
// 904 regv(r7)_base = r7; regv(r7)_type = integers; regv(r7)_form=vinr
REGV[7].BASE = 8;
REGV[7].TYPE = 16;
REGV[7].FORM = 1;
// 905 regv(r8)_base = r8; regv(r8)_type = integers; regv(r8)_form=vinr
REGV[8].BASE = 9;
REGV[8].TYPE = 16;
REGV[8].FORM = 1;
// 906 regv(r9)_base = r9; regv(r9)_type = integers; regv(r9)_form=vinr
REGV[9].BASE = 10;
REGV[9].TYPE = 16;
REGV[9].FORM = 1;
// 907 regv(r10)_base= r10; regv(r10)_type= integers; regv(r10)_form=vinr
REGV[10].BASE = 11;
REGV[10].TYPE = 16;
REGV[10].FORM = 1;
// 908 regv(gla)_base= gla; regv(gla)_type= integers; regv(gla)_form=vinr
REGV[11].BASE = 12;
REGV[11].TYPE = 16;
REGV[11].FORM = 1;
// 909 regv(fp)_base = fp; regv(fp)_type = integers; regv(fp)_form=vinr
REGV[13].BASE = 14;
REGV[13].TYPE = 16;
REGV[13].FORM = 1;
// 910 regv(ap)_base = ap; regv(ap)_type = integers; regv(ap)_form=vinr
REGV[12].BASE = 13;
REGV[12].TYPE = 16;
REGV[12].FORM = 1;
// 911 regv(sp)_base = sp; regv(sp)_type = integers; regv(sp)_form=vinr
REGV[14].BASE = 15;
REGV[14].TYPE = 16;
REGV[14].FORM = 1;
// 912 regv(pc)_base = pc; regv(pc)_type = integers; regv(pc)_form=vinr
REGV[15].BASE = 16;
REGV[15].TYPE = 16;
REGV[15].FORM = 1;
// 913 regv(fpr0)_base=fpr0; regv(fpr0)_type = reall; regv(fpr0)_form = vinr
REGV[17].BASE = 18;
REGV[17].TYPE = 36;
REGV[17].FORM = 1;
// 914 regv(fpr2)_base=fpr2; regv(fpr2)_type = reall; regv(fpr2)_form = vinr
REGV[18].BASE = 19;
REGV[18].TYPE = 36;
REGV[18].FORM = 1;
// 915 regv(fpr4)_base=fpr4; regv(fpr4)_type = reall; regv(fpr4)_form = vinr
REGV[19].BASE = 20;
REGV[19].TYPE = 36;
REGV[19].FORM = 1;
// 916
// 917 zerov = 0
ZEROV = (struct STACKFM){0};
// 918 zerov_type = integers; zerov_form = constant
ZEROV.TYPE = 16;
ZEROV.FORM = 0;
// 919
// 920 gla work = 0
GLAWORK = (struct STACKFM){0};
// 921 gla work_type = integers; gla work_form = v in s
GLAWORK.TYPE = 16;
GLAWORK.FORM = 2;
// 922 gla work_base = gla
GLAWORK.BASE = 12;
// 923
// 924 spv = 0
SPV = (struct STACKFM){0};
// 925 spv_type = integers; spv_form = v in s
SPV.TYPE = 16;
SPV.FORM = 2;
// 926 spv_base = sp; spv_flags = auto d
SPV.BASE = 15;
SPV.FLAGS = 8;
// 927
// 928 zeroth = 0
ZEROTH = (struct STACKFM){0};
// 929 zeroth_type = integers; zeroth_form = v in s
ZEROTH.TYPE = 16;
ZEROTH.FORM = 2;
// 930
// 931 dope = 0
DOPE = (struct STACKFM){0};
// 932 dope_base = gla; dope_type = integers; dope_form = v in s
DOPE.BASE = 12;
DOPE.TYPE = 16;
DOPE.FORM = 2;
// 933
// 934 head = 0
HEAD = (struct STACKFM){0};
// 935 head_type = integers; head_form = v in s
HEAD.TYPE = 16;
HEAD.FORM = 2;
// 936
// 937 select input tank (icode); select output tank (object)
SELECTINPUTTANK(ICODE);
SELECTOUTPUTTANK(OBJECT);
// 938 select output (diag stream)
_imp_SELECTOUTPUT(2);
// 939
// 940 var(0) = 0
VAR[0] = (struct VARFM){0};
// 941 activity(pc) = -1
ACTIVITY[16] = -1;
// 942 activity(sp) = -1
ACTIVITY[15] = -1;
// 943 activity(fp) = -1
ACTIVITY[14] = -1;
// 944 activity(ap) = -1
ACTIVITY[13] = -1;
// 945 activity(gla) = -1
ACTIVITY[12] = -1;
// 946 activity(0) = -1
ACTIVITY[0] = -1;
// 947
// 948 %for j = 0, 1, max stack-1 %cycle
// %for J = 0, 1, 25 - 1 %cycle
{
int _final = 25 - 1;
if (invalid_for_loop(0, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 0, 1, 25 - 1");
J = -1;
L_0001:
if (J == _final) goto L_0002;
J += 1;
// 949 stak(j)_link == stak(j+1)
STAK[J].LINK = (struct STACKFM *)/*?*/ &STAK[J + 1];
// 950 dlist(j)_link == dlist(j+1)
DLIST[J].LINK = (struct DFM *)/*?*/ &DLIST[J + 1];
// 951 %repeat
goto L_0001;
}
L_0002:;
// 952
// 953 stak(max stack)_link == null
STAK[25].LINK = (struct STACKFM *)NULL;
// 954 dlist(max stack)_link == null
DLIST[25].LINK = (struct DFM *)NULL;
// 955 desc asl == stak(0)
DESCASL = (struct STACKFM *)/*?*/ &STAK[0];
// 956 dasl == dlist(0)
DASL = (struct DFM *)/*?*/ &DLIST[0];
// 957
// 958 using_link == null
USING.LINK = (struct DFM *)NULL;
// 959
// 960 decvar == begin
DECVAR = (struct VARFM *)/*?*/ &BEGIN;
// 961
// 962 !********************************************
// 963
// 964
// 965 ! Utilities
// 966
// 967 %predicate ZERO (%record(stackfm) %name v)
int ZERO(struct STACKFM * V) {
// 968 ! check descriptor for zero
// 969 %false %unless v_form = constant %and v_type&(integers!reals) # 0
if (V->FORM != 0) goto L_0003;
if (V->TYPE & (16 | 35) != 0) goto L_0004;
L_0003:;
return 0 /*FALSE*/;
L_0004:;
// 970 %false %unless v_disp = 0 %and v_oper = 0
if (V->DISP != 0) goto L_0005;
if (V->OPER == 0) goto L_0006;
L_0005:;
return 0 /*FALSE*/;
L_0006:;
// 971 %false %if v_type = reall %and v_mantissa # 0
if (V->TYPE != 36) goto L_0007;
if (V->MANTISSA == 0) goto L_0007;
return 0 /*FALSE*/;
L_0007:;
// 972 %true
return 1 /*TRUE*/;
// 973 %end
} /* end of ZERO */
// 974
// 975 %predicate CONST (%record(stackfm) %name v)
int CONST(struct STACKFM * V) {
// 976 ! check descriptor for a constant value (integer)
// 977 %true %if v_form = constant %and v_oper = 0 %and v_type&integers # 0
if (V->FORM != 0) goto L_0008;
if (V->OPER != 0) goto L_0008;
if (V->TYPE & 16 == 0) goto L_0008;
return 1 /*TRUE*/;
L_0008:;
// 978 %false
return 0 /*FALSE*/;
// 979 %end
} /* end of CONST */
// 980
// 981 %predicate SAME (%record(stackfm) %name a, b)
int SAME(struct STACKFM * A, struct STACKFM * B) {
// 982 %switch f (constant : a in rec)
int F_index;
int F_line;
char *F_file;
static const void *F[8] = {&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing,
&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing};
// 983 %false %unless a_oper = 0 = b_oper %c
{
// Double-sided test on 0 (Part I)
int tmp;
if (A->OPER != (tmp = 0)) goto L_0009;
// Double-sided test on 0 (Part II)
if (tmp != B->OPER) goto L_0009;
}
{
// Double-sided test on 0 (Part I)
int tmp;
if (A->FLAGS & 1 != (tmp = 0)) goto L_0009;
// Double-sided test on 0 (Part II)
if (tmp != B->FLAGS & 1) goto L_0009;
}
if (A->TYPE != B->TYPE) goto L_0009;
if (A->FORM != B->FORM) goto L_0009;
if (A->XNO != B->XNO) goto L_0009;
if (A->FLAGS == B->FLAGS) goto L_000A;
L_0009:;
return 0 /*FALSE*/;
L_000A:;
// 984+ %and a_flags&indexed = 0 = b_flags&indexed %c
// 985+ %and a_type = b_type %c
// 986+ %and a_form = b_form %c
// 987+ %and a_xno = b_xno %c
// 988+ %and a_flags = b_flags
// 989 %if a_type&records # 0 %start
if (A->TYPE & 128 == 0) goto L_000B;
// 990 %false %unless a_format = b_format
if (A->FORMAT == B->FORMAT) goto L_000C;
return 0 /*FALSE*/;
L_000C:;
// 991 %finish
L_000B:;
// 992 -> f (a_form&7)
F_line = __LINE__;
F_file = __FILE__;
F_index = A->FORM & 7;
goto case_F_dispatch;
// 993 f(constant):
case_F_0:;
// 994 %true %if a_type&integers # 0 %and a_disp = b_disp
if (A->TYPE & 16 == 0) goto L_000E;
if (A->DISP != B->DISP) goto L_000E;
return 1 /*TRUE*/;
L_000E:;
// 995 %true %if a_type&real bit # 0 %and a_lrval = b_lrval
if (A->TYPE & 32 == 0) goto L_000F;
if (A->LRVAL != B->LRVAL) goto L_000F;
return 1 /*TRUE*/;
L_000F:;
// 996 %false
return 0 /*FALSE*/;
// 997 f(v in rec):
case_F_5:;
// 998 f(a in rec):
case_F_7:;
// 999 f(av in rec):
case_F_6:;
// 1000 %false %unless a_extra = b_extra
if (A->EXTRA == B->EXTRA) goto L_0010;
return 0 /*FALSE*/;
L_0010:;
// 1001 f(v in s):
case_F_2:;
// 1002 f(a in s):
case_F_4:;
// 1003 f(av in s):
case_F_3:;
// 1004 %false %unless a_disp = b_disp
if (A->DISP == B->DISP) goto L_0011;
return 0 /*FALSE*/;
L_0011:;
// 1005 f(v in r):
case_F_1:;
// 1006 %false %unless a_base = b_base
if (A->BASE == B->BASE) goto L_0012;
return 0 /*FALSE*/;
L_0012:;
// 1007 %true
return 1 /*TRUE*/;
// 1008 %end
case_F_dispatch:
if (F_index < 0 || F_index > 7)
_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 SAME */
// 1009
// 1010 %predicate FLOATING (%record(stackfm) %name v)
int FLOATING(struct STACKFM * V) {
// 1011 %true %if v_type&real bit # 0
if (V->TYPE & 32 == 0) goto L_0013;
return 1 /*TRUE*/;
L_0013:;
// 1012 %false %if v_oper <= neg
if (V->OPER > 8) goto L_0014;
return 0 /*FALSE*/;
L_0014:;
// 1013 %true %if v_oper = rdiv %or v_oper = rexp
if (V->OPER == 23) goto L_0015;
if (V->OPER != 22) goto L_0016;
L_0015:;
return 1 /*TRUE*/;
L_0016:;
// 1014 %false %if v_link_type&real bit = 0
if (V->LINK->TYPE & 32 != 0) goto L_0017;
return 0 /*FALSE*/;
L_0017:;
// 1015 %true
return 1 /*TRUE*/;
// 1016 %end
} /* end of FLOATING */
// 1017
// 1018 %predicate IN FREE REG (%record(stackfm) %name v)
int INFREEREG(struct STACKFM * V) {
// 1019 ! true if v is in a useable register
// 1020 %false %unless v_form = v in r
if (V->FORM == 1) goto L_0018;
return 0 /*FALSE*/;
L_0018:;
// 1021 %false %unless activity(v_base) = 1
if (ACTIVITY[V->BASE] == 1) goto L_0019;
return 0 /*FALSE*/;
L_0019:;
// 1022 %true
return 1 /*TRUE*/;
// 1023 %end
} /* end of INFREEREG */
// 1024
// 1025
// 1026 !diagnostics
// 1027
// 1028 %string(15) %function TYPE STR (%integer type, max)
_imp_string15 TYPESTR(int TYPE, int MAX) {
// 1029 %string(15) res = ""
_imp_string15 RES;
_imp_strncpy(/*?*/ &RES, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 15);
// 1030 %integer i
int I;
// 1031 %const %byte %array tbits (0 : 9) =
const unsigned char TBITS[10] = {0, 128, 64, 68, 36, 35, 17, 21, 18, 16};
// 1032+ 0, records, strings, strings!in work, reall, reals,
// 1033+ integers+short, integers+long, integers+byte, integers
// 1034 %const %string(15) %array tstr (0 : 9) =
const _imp_string15 TSTR[10] = {_imp_str_init("no-type"), _imp_str_init("record "),
_imp_str_init("string "), _imp_str_init("w/string"),
_imp_str_init("l-real "), _imp_str_init("real "),
_imp_str_init("shortinteger"), _imp_str_init("long integer"),
_imp_str_init("byte integer"), _imp_str_init("integer ")};
// 1035+ "no-type", "record ", "string ", "w/string", "l-real ",
// 1036+ "real ","shortinteger", "long integer", "byte integer",
// 1037+ "integer "
// 1038 type = type & 16_FF
TYPE = TYPE & 255;
// 1039 %for i = 0, 1, 9 %cycle
// %for I = 0, 1, 9 %cycle
{
I = -1;
L_001A:
if (I == 9) goto L_001B;
I += 1;
// 1040 res = tstr(i) %and %exit %if type = tbits(i)
if (TYPE != TBITS[I]) goto L_001D;
_imp_strncpy(/*?*/ &RES, ({
__typeof__(_imp_string15) tmp; /*B*/
tmp = TSTR[I];
(void *)&tmp;
}),
/*max:*/ 15);
goto L_001B;
L_001D:;
// 1041 %repeat
goto L_001A;
}
L_001B:;
// 1042 res = "type=" . itos(type,-3) %if res = ""
if (_imp_strcmp((_imp_string *)/*?*/ &RES, (_imp_string *)/*?*/ _imp_str_literal_ptr("")) != 0) goto L_001E;
_imp_strncpy(/*?*/ &RES, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("type="), ({
__typeof__(_imp_string63) tmp; /*E*/
tmp = ITOS(TYPE, -3);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 15);
L_001E:;
// 1043 length(res) = max %if length(res) > max
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &RES) <= MAX) goto L_001F;
*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &RES) = MAX;
L_001F:;
// 1044 %result = res
return *(_imp_string15 *)/*?*/ &RES;
// 1045 %end
} /* end of TYPESTR */
// 1046
// 1047 %routine PREC (%record(stackfm) %name v)
void PREC(struct STACKFM * V) {
// 1048 %integer op, val
int OP;
int VAL;
// 1049 %const %string(9) %array fmstr (0 : 7) =
const _imp_string9 FMSTR[8] = {_imp_str_init("constant "), _imp_str_init("V-in-R "), _imp_str_init("V-in-S "),
_imp_str_init("AV-in-S "), _imp_str_init("A-in-S "), _imp_str_init("V-in-Rec "),
_imp_str_init("AV-in-Rec"), _imp_str_init("A-in-Rec ")};
// 1050+ "constant ", "V-in-R ", "V-in-S ", "AV-in-S ",
// 1051+ "A-in-S ", "V-in-Rec ", "AV-in-Rec", "A-in-Rec "
// 1052
// 1053 %routine NON ZERO (%integer n, %string(15) m)
void NONZERO(int N, _imp_string15 M) {
// 1054 %if n # 0 %start
if (N == 0) goto L_0020;
// 1055 print string (m)
_imp_PRINTSTRING(
*({
__typeof__(_imp_string15) tmp = M /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1056 write (n, 0)
_imp_WRITE(N, 0);
// 1057 %finish
L_0020:;
// 1058 %end
return;
} /* end of NONZERO */
// 1059
// 1060 %if v == null %start
if (_imp_ADDR((void *)(V)) != _imp_ADDR((void *)(NULL))) goto L_0021;
// 1061 print string ("(NULL!!!!!)")
_imp_PRINTSTRING(_imp_str_literal("(NULL!!!!!)"));
// 1062 newline
_imp_NEWLINE();
// 1063 %return
return;
// 1064 %finish
L_0021:;
// 1065 %if v_form = 15 %start
if (V->FORM != 15) goto L_0022;
// 1066 print string ("Label")
_imp_PRINTSTRING(_imp_str_literal("Label"));
// 1067 spaces (17)
_imp_SPACES(17);
// 1068 %else
goto L_0023;
L_0022:;
// 1069 print string (fmstr(v_form&7))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string9) tmp = FMSTR[V->FORM & 7] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1070 space; print string (type str (v_type, 8))
_imp_SPACE();
_imp_PRINTSTRING(
*({
__typeof__(_imp_string15) tmp = TYPESTR(V->TYPE, 8) /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1071 space; val = v_form & (\15)
_imp_SPACE();
VAL = V->FORM & (~15);
// 1072 %if val&arrayname bit # 0 %then print string ("AN") %c
if (VAL & 64 == 0) goto L_0024;
_imp_PRINTSTRING(_imp_str_literal("AN"));
goto L_0025;
L_0024:;
if (VAL & 16 == 0) goto L_0026;
_imp_PRINTSTRING(_imp_str_literal("PR"));
goto L_0025;
L_0026:;
_imp_SPACES(2);
L_0025:;
// 1073+ %else %if val&proc bit # 0 %then print string ("PR") %c
// 1074+ %else spaces (2)
// 1075 %finish
L_0023:;
// 1076 space; write (v_mantissa, 5)
_imp_SPACE();
_imp_WRITE(V->MANTISSA, 5);
// 1077 print symbol ('@') %if v_flags&(indexed!xdefer) = indexed!xdefer
if (V->FLAGS & (1 | 2) != 1 | 2) goto L_0027;
_imp_PRINTSYMBOL(64);
L_0027:;
// 1078 write (v_disp, 5)
_imp_WRITE(V->DISP, 5);
// 1079 %if v_form # constant %start
if (V->FORM == 0) goto L_0028;
// 1080 print symbol ('-') %if v_flags&autod # 0 %and v_disp = 0
if (V->FLAGS & 8 == 0) goto L_0029;
if (V->DISP != 0) goto L_0029;
_imp_PRINTSYMBOL(45);
L_0029:;
// 1081 printsymbol ('(')
_imp_PRINTSYMBOL(40);
// 1082 print string (reg name(v_base))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string3) tmp = REGNAME[V->BASE] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1083 printsymbol (')')
_imp_PRINTSYMBOL(41);
// 1084 print symbol ('+') %if v_flags&autoi # 0 %and v_disp = 0
if (V->FLAGS & 4 == 0) goto L_002A;
if (V->DISP != 0) goto L_002A;
_imp_PRINTSYMBOL(43);
L_002A:;
// 1085 %if v_flags&indexed # 0 %start
if (V->FLAGS & 1 == 0) goto L_002B;
// 1086 print symbol ('[')
_imp_PRINTSYMBOL(91);
// 1087 print string (reg name(v_index))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string3) tmp = REGNAME[V->INDEX] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1088 print symbol (']')
_imp_PRINTSYMBOL(93);
// 1089 write (v_iscale, 0); space
_imp_WRITE(V->ISCALE, 0);
_imp_SPACE();
// 1090 %finish
L_002B:;
// 1091 %if v_form >= v in rec %start
if (V->FORM < 5) goto L_002C;
// 1092 print string (": ")
_imp_PRINTSTRING(_imp_str_literal(": "));
// 1093 write (v_extra, 0)
_imp_WRITE(V->EXTRA, 0);
// 1094 %finish
L_002C:;
// 1095 %finish
L_0028:;
// 1096 non zero (v_header, " hdr=")
NONZERO(V->HEADER, _imp_str_literal_size(15, " hdr="));
// 1097 non zero (v_xno, " xno=")
NONZERO(V->XNO, _imp_str_literal_size(15, " xno="));
// 1098 print string (" L="); write (v_length,0)
_imp_PRINTSTRING(_imp_str_literal(" L="));
_imp_WRITE(V->LENGTH, 0);
// 1099 op = v_oper
OP = V->OPER;
// 1100 %if op # 0 %start
if (OP == 0) goto L_002D;
// 1101 print string (" oper=")
_imp_PRINTSTRING(_imp_str_literal(" oper="));
// 1102 %if not <= op <= brem %start
{
// Double-sided test on OP (Part I)
int tmp;
if (7 > (tmp = OP)) goto L_002E;
// Double-sided test on OP (Part II)
if (tmp > 29) goto L_002E;
}
// 1103 print symbol ('"')
_imp_PRINTSYMBOL(34);
// 1104 print string (op name(op))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OP - 7] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1105 print symbol ('"')
_imp_PRINTSYMBOL(34);
// 1106 %if op > neg %start
if (OP <= 8) goto L_002F;
// 1107 newline; spaces (13)
_imp_NEWLINE();
_imp_SPACES(13);
// 1108 prec (v_link)
PREC(V->LINK);
// 1109 %return
return;
// 1110 %finish
L_002F:;
// 1111 %else
goto L_0030;
L_002E:;
// 1112 write (op, 0)
_imp_WRITE(OP, 0);
// 1113 %finish
L_0030:;
// 1114 %finish
L_002D:;
// 1115 newline
_imp_NEWLINE();
// 1116 %end
return;
} /* end of PREC */
// 1117
// 1118 %routine STACK DUMP
void STACKDUMP(void) {
// 1119 %integer sp = stp
int SP;
SP = STP;
// 1120 print string ("Stack:")
_imp_PRINTSTRING(_imp_str_literal("Stack:"));
// 1121 %if sp <= 0 %start
if (SP > 0) goto L_0031;
// 1122 print string (" empty")
_imp_PRINTSTRING(_imp_str_literal(" empty"));
// 1123 newline
_imp_NEWLINE();
// 1124 %else
goto L_0032;
L_0031:;
// 1125 newline
_imp_NEWLINE();
// 1126 %while sp > 0 %cycle
L_0033:;
if (SP <= 0) goto L_0034;
// 1127 write (sp, 2); spaces (10)
_imp_WRITE(SP, 2);
_imp_SPACES(10);
// 1128 prec (stacked(sp)); sp = sp - 1
PREC(STACKED[SP - 1]);
SP = SP - 1;
// 1129 %repeat
goto L_0033;
L_0034:;
// 1130 %finish
L_0032:;
// 1131 %end
return;
} /* end of STACKDUMP */
// 1132
// 1133 %routine MON REG (%string(20) s, %integer r)
void MONREG(_imp_string20 S, int R) {
// 1134 print string (s); print symbol (':')
_imp_PRINTSTRING(
*({
__typeof__(_imp_string20) tmp = S /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_PRINTSYMBOL(58);
// 1135 spaces (11 - length(s))
_imp_SPACES(11 - *_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &S));
// 1136 print string (reg name(r))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string3) tmp = REGNAME[R] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1137 newline
_imp_NEWLINE();
// 1138 %end
return;
} /* end of MONREG */
// 1139
// 1140 %routine MONITOR (%record(stackfm) %name v, %string(15) s)
void MONITOR(struct STACKFM * V, _imp_string15 S) {
// 1141 print string (s)
_imp_PRINTSTRING(
*({
__typeof__(_imp_string15) tmp = S /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1142 printsymbol (':')
_imp_PRINTSYMBOL(58);
// 1143 spaces (12-length(s))
_imp_SPACES(12 - *_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &S));
// 1144 prec (v)
PREC(V);
// 1145 stack dump %if diag&4096 # 0
if (DIAG & 4096 == 0) goto L_0035;
STACKDUMP();
L_0035:;
// 1146 %monitor %if diag&8192 # 0
if (DIAG & 8192 == 0) goto L_0036;
/*_imp_monitor(__LINE__, __FILE__, PRETTY_FUNCTION);*/
L_0036:;
// 1147 %end
return;
} /* end of MONITOR */
// 1148
// 1149 %routine SHOW REGS
void SHOWREGS(void) {
// 1150 %integer reg
int REG;
// 1151 print string ("Register activity: "); newline
_imp_PRINTSTRING(_imp_str_literal("Register activity: "));
_imp_NEWLINE();
// 1152 print string (" R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 F0 F2 F4")
_imp_PRINTSTRING(_imp_str_literal(" R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 F0 F2 F4"));
// 1153 newline
_imp_NEWLINE();
// 1154 %for reg = r0, 1, r10 %cycle
// %for REG = 1, 1, 11 %cycle
{
REG = 0;
L_0037:
if (REG == 11) goto L_0038;
REG += 1;
// 1155 %if activity(reg) < 0 %start
if (ACTIVITY[REG] >= 0) goto L_0039;
// 1156 print string (" L")
_imp_PRINTSTRING(_imp_str_literal(" L"));
// 1157 %else
goto L_003A;
L_0039:;
// 1158 write (activity(reg), 3)
_imp_WRITE(ACTIVITY[REG], 3);
// 1159 %finish
L_003A:;
// 1160 %repeat
goto L_0037;
}
L_0038:;
// 1161 %for reg = fpr0, 1, fpr4 %cycle
// %for REG = 18, 1, 20 %cycle
{
REG = 17;
L_003B:
if (REG == 20) goto L_003C;
REG += 1;
// 1162 %if activity(reg) < 0 %then print string (" L") %c
if (ACTIVITY[REG] >= 0) goto L_003D;
_imp_PRINTSTRING(_imp_str_literal(" L"));
goto L_003E;
L_003D:;
_imp_WRITE(ACTIVITY[REG], 3);
L_003E:;
// 1163+ %else write (activity(reg), 3)
// 1164 %repeat
goto L_003B;
}
L_003C:;
// 1165 newline
_imp_NEWLINE();
// 1166 print string ("[]")
_imp_PRINTSTRING(_imp_str_literal("[]"));
// 1167 write (indx(r0), -2)
_imp_WRITE(INDX[0], -2);
// 1168 write (indx(reg), 3) %for reg = r1, 1, r10
// %for REG = 2, 1, 11 %cycle
{
REG = 1;
L_003F:
if (REG == 11) goto L_0040;
REG += 1;
_imp_WRITE(INDX[REG - 1], 3);
goto L_003F;
}
L_0040:;
// 1169 newline
_imp_NEWLINE();
// 1170 %end
return;
} /* end of SHOWREGS */
// 1171
// 1172 %routine ABORT (%integer n)
void ABORT(int N) {
// 1173 !report catastrophic failure and stop
// 1174 flush code
FLUSHCODE();
// 1175 select output (0)
_imp_SELECTOUTPUT(0);
// 1176 newline
_imp_NEWLINE();
// 1177 print string ("***Pass 2 fails ")
_imp_PRINTSTRING(_imp_str_literal("***Pass 2 fails "));
// 1178 write (n, 0)
_imp_WRITE(N, 0);
// 1179 print string (" at line ")
_imp_PRINTSTRING(_imp_str_literal(" at line "));
// 1180 write (current line, 0)
_imp_WRITE(CURRENTLINE, 0);
// 1181 newlines (2)
_imp_NEWLINES(2);
// 1182 show regs; newline
SHOWREGS();
_imp_NEWLINE();
// 1183 stack dump; newline
STACKDUMP();
_imp_NEWLINE();
// 1184 print string ("Using:")
_imp_PRINTSTRING(_imp_str_literal("Using:"));
// 1185 %if using_link == null %start
if (_imp_ADDR((void *)(USING.LINK)) != _imp_ADDR((void *)(NULL))) goto L_0041;
// 1186 print string (" empty")
_imp_PRINTSTRING(_imp_str_literal(" empty"));
// 1187 newline
_imp_NEWLINE();
// 1188 %else
goto L_0042;
L_0041:;
// 1189 newline
_imp_NEWLINE();
// 1190 %while using_link ## null %cycle
L_0043:;
if (_imp_ADDR((void *)(USING.LINK)) == _imp_ADDR((void *)(NULL))) goto L_0044;
// 1191 spaces (13)
_imp_SPACES(13);
// 1192 prec (using_link_d)
PREC(USING.LINK->D);
// 1193 using_link == using_link_link
USING.LINK = (struct DFM *)USING.LINK->LINK;
// 1194 %repeat
goto L_0043;
L_0044:;
// 1195 %finish
L_0042:;
// 1196 newline
_imp_NEWLINE();
// 1197 %monitor
/*_imp_monitor(__LINE__, __FILE__, PRETTY_FUNCTION);*/
// 1198 exit (16_1000002C) {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE}
EXIT(268435500);
// 1199 %stop; ! we don't come back - let pass 1/2 know..
_imp_stop(0);
// 1200 %end
} /* end of ABORT */
// 1201
// 1202 %routine ERROR (%integer sym, %string(127) s)
void ERROR(int SYM, _imp_string127 S) {
// 1203 %own %integer erred = 0
static int ERRED = 0;
// 1204 %integer st = report
int ST;
ST = 0;
// 1205 %return %if line error # 0
if (LINEERROR == 0) goto L_0045;
return;
L_0045:;
// 1206 line error = 1
LINEERROR = 1;
// 1207 %cycle
L_0046:;
// 1208 select output (st)
_imp_SELECTOUTPUT(ST);
// 1209 %if erred = 0 %start
if (ERRED != 0) goto L_0047;
// 1210 print string ("Pass 2:")
_imp_PRINTSTRING(_imp_str_literal("Pass 2:"));
// 1211 newline
_imp_NEWLINE();
// 1212 %finish
L_0047:;
// 1213 %if sym = '!' %start
if (SYM != 33) goto L_0048;
// 1214 print string ("**** Fatal error at line ")
_imp_PRINTSTRING(_imp_str_literal("**** Fatal error at line "));
// 1215 write (current line, 0)
_imp_WRITE(CURRENTLINE, 0);
// 1216 print symbol (':')
_imp_PRINTSYMBOL(58);
// 1217 %else
goto L_0049;
L_0048:;
// 1218 print symbol (sym)
_imp_PRINTSYMBOL(SYM);
// 1219 write (current line, 4)
_imp_WRITE(CURRENTLINE, 4);
// 1220 %finish
L_0049:;
// 1221 spaces (2); print string (s)
_imp_SPACES(2);
_imp_PRINTSTRING(
*({
__typeof__(_imp_string127) tmp = S /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1222 newline
_imp_NEWLINE();
// 1223 %exit %if st # report
if (ST == 0) goto L_004A;
goto L_004B;
L_004A:;
// 1224 st = diag stream
ST = 2;
// 1225 %repeat
goto L_0046;
L_004B:;
// 1226 exit (fatal) %if sym = '!'
if (SYM != 33) goto L_004C;
EXIT(268435500);
L_004C:;
// 1227 erred = 1
ERRED = 1;
// 1228 errors = errors + 1 %if sym # '?'
if (SYM == 63) goto L_004D;
ERRORS = ERRORS + 1;
L_004D:;
// 1229 %end
return;
} /* end of ERROR */
// 1230
// 1231 %integer %function NEW TAG
int NEWTAG(void) {
// 1232 %own %integer tag = 0
static int TAG = 0;
// 1233 tag = tag + 1
TAG = TAG + 1;
// 1234 %result = tag
return TAG;
// 1235 %end
} /* end of NEWTAG */
// 1236
// 1237 !code planting routines
// 1238
// 1239 %routine SET LINE
void SETLINE(void) {
// 1240 %own %integer last line = 0
static int LASTLINE = 0;
// 1241 %return %if command & 8 = 0
if (COMMAND & 8 != 0) goto L_004E;
return;
L_004E:;
// 1242 %return %if last line = current line %or current line = 0
if (LASTLINE == CURRENTLINE) goto L_001C;
if (CURRENTLINE != 0) goto L_004F;
L_001C:;
return;
L_004F:;
// 1243 last line = current line
LASTLINE = CURRENTLINE;
// 1244 diag lines = diag lines + 6
DIAGLINES = DIAGLINES + 6;
// 1245 put (obj line); put word (current line)
PUT(15);
PUTWORD(CURRENTLINE);
// 1246 %end
return;
} /* end of SETLINE */
// 1247
// 1248 %routine FLUSH CODE
void FLUSHCODE(void) {
// 1249 %return %if cp = 0
if (CP != 0) goto L_0050;
return;
L_0050:;
// 1250 set line
SETLINE();
// 1251 put (obj code)
PUT(2);
// 1252 put (cp)
PUT(CP);
// 1253 put block (cp, codebuffer(1))
PUTBLOCK(CP, /*?*/ &CODEBUFFER[0]);
// 1254 cp = 0
CP = 0;
// 1255 %end
return;
} /* end of FLUSHCODE */
// 1256
// 1257 %routine PUT NUMBER BYTE (%integer n)
void PUTNUMBERBYTE(int N) {
// 1258 cp = cp + 1
CP = CP + 1;
// 1259 code buffer(cp) = n&255
CODEBUFFER[CP - 1] = N & 255;
// 1260 flush code %if cp > 120
if (CP <= 120) goto L_0051;
FLUSHCODE();
L_0051:;
// 1261 ca = ca + 1
CA = CA + 1;
// 1262 %end
return;
} /* end of PUTNUMBERBYTE */
// 1263
// 1264 %routine PUT CODE (%integer op)
void PUTCODE(int OP) {
// 1265 op = op&255
OP = OP & 255;
// 1266 put number byte (op)
PUTNUMBERBYTE(OP);
// 1267 %if diag&128 # 0 %start
if (DIAG & 128 == 0) goto L_0052;
// 1268 print string ("Op code = ")
_imp_PRINTSTRING(_imp_str_literal("Op code = "));
// 1269 print string (op mnem(op))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string6) tmp = OPMNEM[OP] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1270 newline
_imp_NEWLINE();
// 1271 %finish
L_0052:;
// 1272 %end
return;
} /* end of PUTCODE */
// 1273
// 1274 %routine WORD (%integer n)
void WORD(int N) {
// 1275 shortinteger(addr(codebuffer(cp+1))) = n
*_imp_SHORTINTEGER(_imp_ADDR(/*?*/ &CODEBUFFER[CP + 1 - 1])) = N;
// 1276 cp = cp + 2
CP = CP + 2;
// 1277 flush code %if cp > 120
if (CP <= 120) goto L_0053;
FLUSHCODE();
L_0053:;
// 1278 ca = ca + 2
CA = CA + 2;
// 1279 %end
return;
} /* end of WORD */
// 1280
// 1281 %routine LONGWORD (%integer n)
void LONGWORD(int N) {
// 1282 integer(addr(codebuffer(cp+1))) = n
*_imp_INTEGER(_imp_ADDR(/*?*/ &CODEBUFFER[CP + 1 - 1])) = N;
// 1283 cp = cp + 4
CP = CP + 4;
// 1284 flush code %if cp > 120
if (CP <= 120) goto L_0054;
FLUSHCODE();
L_0054:;
// 1285 ca = ca + 4
CA = CA + 4;
// 1286 %end
return;
} /* end of LONGWORD */
// 1287
// 1288 %routine FLUSH GLA
void FLUSHGLA(void) {
// 1289 %return %if gp = 0
if (GP != 0) goto L_0055;
return;
L_0055:;
// 1290 put (obj gla)
PUT(3);
// 1291 put long (ga-gp)
PUTLONG(GA - GP);
// 1292 put (gp)
PUT(GP);
// 1293 put block (gp, gla buffer(1))
PUTBLOCK(GP, /*?*/ &GLABUFFER[0]);
// 1294 gp = 0
GP = 0;
// 1295 %end
return;
} /* end of FLUSHGLA */
// 1296
// 1297 %routine INIT GLA (%integer count, size, val)
void INITGLA(int COUNT, int SIZE, int VAL) {
// 1298 flush gla
FLUSHGLA();
// 1299 put (obj glam)
PUT(22);
// 1300 put long (ga)
PUTLONG(GA);
// 1301 put long (val)
PUTLONG(VAL);
// 1302 put long (count)
PUTLONG(COUNT);
// 1303 put long (size)
PUTLONG(SIZE);
// 1304 ga = ga + size*count
GA = GA + SIZE * COUNT;
// 1305 %end
return;
} /* end of INITGLA */
// 1306
// 1307 %routine GBYTE (%integer v)
void GBYTE(int V) {
// 1308 gp = gp + 1; ga = ga + 1
GP = GP + 1;
GA = GA + 1;
// 1309 gla buffer(gp) = v&255
GLABUFFER[GP - 1] = V & 255;
// 1310 flush gla %if gp > 120
if (GP <= 120) goto L_0056;
FLUSHGLA();
L_0056:;
// 1311 %end
return;
} /* end of GBYTE */
// 1312
// 1313 %routine GWORD (%integer v)
void GWORD(int V) {
// 1314 shortinteger(addr(glabuffer(gp+1))) = v
*_imp_SHORTINTEGER(_imp_ADDR(/*?*/ &GLABUFFER[GP + 1 - 1])) = V;
// 1315 gp = gp + 2; ga = ga + 2
GP = GP + 2;
GA = GA + 2;
// 1316 flush gla %if gp > 120
if (GP <= 120) goto L_0057;
FLUSHGLA();
L_0057:;
// 1317 %end
return;
} /* end of GWORD */
// 1318
// 1319 %routine GLONGWORD (%integer v)
void GLONGWORD(int V) {
// 1320 integer(addr(glabuffer(gp+1))) = v
*_imp_INTEGER(_imp_ADDR(/*?*/ &GLABUFFER[GP + 1 - 1])) = V;
// 1321 gp = gp + 4; ga = ga + 4
GP = GP + 4;
GA = GA + 4;
// 1322 flush gla %if gp > 120
if (GP <= 120) goto L_0058;
FLUSHGLA();
L_0058:;
// 1323 %end
return;
} /* end of GLONGWORD */
// 1324
// 1325 %routine GFIX (%integer mask)
void GFIX(int MASK) {
// 1326 gbyte (0) %while ga&mask # 0
L_0059:;
if (GA & MASK == 0) goto L_005A;
GBYTE(0);
goto L_0059;
L_005A:;
// 1327 %end
return;
} /* end of GFIX */
// 1328
// 1329 %integer %function SCALE TYPE (%integer len)
int SCALETYPE(int LEN) {
// 1330 %result = byte %if len = 1; ! byte
if (LEN != 1) goto L_005B;
return 2;
L_005B:;
// 1331 %result = short %if len = 2; ! word
if (LEN != 2) goto L_005C;
return 1;
L_005C:;
// 1332 %result = 0 %if len = 4; ! longword
if (LEN != 4) goto L_005D;
return 0;
L_005D:;
// 1333 %result = long %if len = 8; ! quadword (not double)
if (LEN != 8) goto L_005E;
return 5;
L_005E:;
// 1334 %result = -1
return -1;
// 1335 %end
} /* end of SCALETYPE */
// 1336
// 1337 %integer %function CTYPE (%integer i)
int CTYPE(int I) {
// 1338 ! Given an integer value, returns the type
// 1339 ! code required to contain this value.
// 1340 ! Note that this applies to IMP-type ranges
// 1341 ! ie. byte 0:255, NOT -128:127
// 1342 ! result -1 means that the value may be contained
// 1343 ! in a short literal operand (type irrelevant)
// 1344 %result = -1 %if 0 <= i <= 63
{
// Double-sided test on I (Part I)
int tmp;
if (0 > (tmp = I)) goto L_005F;
// Double-sided test on I (Part II)
if (tmp > 63) goto L_005F;
}
return -1;
L_005F:;
// 1345 %result = byte %if 0 <= i <= 255
{
// Double-sided test on I (Part I)
int tmp;
if (0 > (tmp = I)) goto L_0060;
// Double-sided test on I (Part II)
if (tmp > 255) goto L_0060;
}
return 2;
L_0060:;
// 1346 %result = short %if \16_7FFF <= i <= 16_7FFF
{
// Double-sided test on I (Part I)
int tmp;
if ((~32767) > (tmp = I)) goto L_0061;
// Double-sided test on I (Part II)
if (tmp > 32767) goto L_0061;
}
return 1;
L_0061:;
// 1347 %result = 0 {int}
return 0;
// 1348 %end
} /* end of CTYPE */
// 1349
// 1350 %integer %function MSIZE (%integer val)
int MSIZE(int VAL) {
// 1351 ! Returns the number of bytes required to
// 1352 ! hold an integer constant of value 'val'
// 1353 ! Note: value interpreted as machine signed
// 1354 ! value.
// 1355 ! (0 => short lit OK)
// 1356 %result = 0 %if 0 <= val <= 63; ! Short lit
{
// Double-sided test on VAL (Part I)
int tmp;
if (0 > (tmp = VAL)) goto L_0062;
// Double-sided test on VAL (Part II)
if (tmp > 63) goto L_0062;
}
return 0;
L_0062:;
// 1357 %result = 1 %if -128 <= val <= 127
{
// Double-sided test on VAL (Part I)
int tmp;
if (-128 > (tmp = VAL)) goto L_0063;
// Double-sided test on VAL (Part II)
if (tmp > 127) goto L_0063;
}
return 1;
L_0063:;
// 1358 %result = 2 %if \16_7FFF <= val <= 16_7FFF
{
// Double-sided test on VAL (Part I)
int tmp;
if ((~32767) > (tmp = VAL)) goto L_0064;
// Double-sided test on VAL (Part II)
if (tmp > 32767) goto L_0064;
}
return 2;
L_0064:;
// 1359 %result = 4
return 4;
// 1360 %end
} /* end of MSIZE */
// 1361
// 1362 %predicate FITS (%integer val, type)
int FITS(int VAL, int TYPE) {
// 1363 ! True if the value val can be held
// 1364 ! in an object of type 'type' (IMP-types)
// 1365 %integer vtype
int VTYPE;
// 1366 type = type&7
TYPE = TYPE & 7;
// 1367 vtype = ctype (val)
VTYPE = CTYPE(VAL);
// 1368 %true %if vtype < 0; ! Short lit : OK
if (VTYPE >= 0) goto L_0065;
return 1 /*TRUE*/;
L_0065:;
// 1369 %true %if type = 0; ! integer - OK
if (TYPE != 0) goto L_0066;
return 1 /*TRUE*/;
L_0066:;
// 1370 %true %if type = short %and vtype # 0
if (TYPE != 1) goto L_0067;
if (VTYPE == 0) goto L_0067;
return 1 /*TRUE*/;
L_0067:;
// 1371 %true %if type = byte = vtype
{
// Double-sided test on 2 (Part I)
int tmp;
if (TYPE != (tmp = 2)) goto L_0068;
// Double-sided test on 2 (Part II)
if (tmp != VTYPE) goto L_0068;
}
return 1 /*TRUE*/;
L_0068:;
// 1372 %false
return 0 /*FALSE*/;
// 1373 %end
} /* end of FITS */
// 1374
// 1375 %integer %function SHORT LITERAL (%record(stack fm) %name v)
int SHORTLITERAL(struct STACKFM * V) {
// 1376 ! returns byte operand if v can be held as short lit,
// 1377 ! otherwise -1
// 1378 %if v_form = constant %and v_type&(integers!realbit) # 0 %start
if (V->FORM != 0) goto L_0069;
if (V->TYPE & (16 | 32) == 0) goto L_0069;
// 1379 %if v_type&integers # 0 %start
if (V->TYPE & 16 == 0) goto L_006A;
// 1380 %result = v_disp %if 0 <= v_disp <= 63
{
// Double-sided test on V->DISP (Part I)
int tmp;
if (0 > (tmp = V->DISP)) goto L_006B;
// Double-sided test on V->DISP (Part II)
if (tmp > 63) goto L_006B;
}
return V->DISP;
L_006B:;
// 1381 %else %if v_mantissa = 0 %and
goto L_006C;
L_006A:;
if (V->MANTISSA != 0) goto L_006D;
if (V->DISP & (-1009) != 16384) goto L_006D;
// 1382+ v_disp&16_FFFFFC0F = 16_00004000
// 1383 %result = v_disp>>4&2_111 111
return (unsigned int)V->DISP >> 4 & 63;
// 1384 %finish
L_006D:;
L_006C:;
// 1385 %finish
L_0069:;
// 1386 %result = -1
return -1;
// 1387 %end
} /* end of SHORTLITERAL */
// 1388
// 1389 %routine OPERAND (%record(stackfm) %name v)
void OPERAND(struct STACKFM * V) {
// 1390 %integer base, disp, abase, mod
int BASE;
int DISP;
int ABASE;
int MOD;
// 1391 %integer index, size, val, err
int INDEX;
int SIZE;
int VAL;
int ERR;
// 1392 %switch f (constant : a in rec)
int F_index;
int F_line;
char *F_file;
static const void *F[8] = {&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing,
&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing};
// 1393
// 1394 monitor (v, "Operand") %if diag&128 # 0
if (DIAG & 128 == 0) goto L_006E;
MONITOR(V, _imp_str_literal_size(15, "Operand"));
L_006E:;
// 1395 mod = 0
MOD = 0;
// 1396 disp = v_disp
DISP = V->DISP;
// 1397 abase = v_base
ABASE = V->BASE;
// 1398 abort (28) %if v_form = v in r %and
if (V->FORM != 1) goto L_006F;
if (ABASE == 16) goto L_0070;
if (ABASE == 14) goto L_0070;
if (ABASE != 13) goto L_006F;
L_0070:;
ABORT(28);
L_006F:;
// 1399+ (abase = pc %or abase = fp %or abase = ap)
// 1400 %if abase = local %start
if (ABASE != LOCAL) goto L_0071;
// 1401 abase = fp
ABASE = 14;
// 1402 abase = ap %and disp = disp - 60 %if disp > 0; !parameter
if (DISP <= 0) goto L_0072;
ABASE = 13;
DISP = DISP - 60;
L_0072:;
// 1403 %finish
L_0071:;
// 1404 abort (1) %if abase = 0 %and v_form # constant %and v_form # v in s
if (ABASE != 0) goto L_0073;
if (V->FORM == 0) goto L_0073;
if (V->FORM == 2) goto L_0073;
ABORT(1);
L_0073:;
// 1405 abort (2) %if v_oper # 0
if (V->OPER == 0) goto L_0074;
ABORT(2);
L_0074:;
// 1406 base = actual reg(abase)
BASE = ACTUALREG[ABASE];
// 1407 entry mask = entry mask ! regmask(abase) %if v_form = v in r
if (V->FORM != 1) goto L_0075;
ENTRYMASK = ENTRYMASK | REGMASK[ABASE];
L_0075:;
// 1408 %if v_flags&indexed # 0 %start
if (V->FLAGS & 1 == 0) goto L_0076;
// 1409 index = v_index
INDEX = V->INDEX;
// 1410 abort (27) %if index = 0 %or index = pc %or
if (INDEX == 0) goto L_0077;
if (INDEX == 16) goto L_0077;
if (INDEX == V->BASE) goto L_0077;
if (V->FORM == 2) goto L_0078;
L_0077:;
ABORT(27);
L_0078:;
// 1411+ index = v_base %or v_form # v in s
// 1412 %if v_flags&xdefer # 0 %start; ! @base[index]
if (V->FLAGS & 2 == 0) goto L_0079;
// 1413 abort (27) %if base < 0
if (BASE >= 0) goto L_007A;
ABORT(27);
L_007A:;
// 1414 base = base ! 16
BASE = BASE | 16;
// 1415 %finish
L_0079:;
// 1416 put number byte (16_40+index-1)
PUTNUMBERBYTE(64 + INDEX - 1);
// 1417 release (index!128)
RELEASE(INDEX | 128);
// 1418 %finish
L_0076:;
// 1419 -> f (v_form)
F_line = __LINE__;
F_file = __FILE__;
F_index = V->FORM;
goto case_F_dispatch;
// 1420
// 1421 f(constant):
case_F_0:;
// 1422 val = short literal (v)
VAL = SHORTLITERAL(V);
// 1423 %if val >= 0 %start; ! short literal
if (VAL < 0) goto L_007C;
// 1424 put number byte (val)
PUTNUMBERBYTE(VAL);
// 1425 %else %if v_type&real bit # 0
goto L_007D;
L_007C:;
if (V->TYPE & 32 == 0) goto L_007E;
// 1426 put number byte (16_8f)
PUTNUMBERBYTE(143);
// 1427 longword (disp)
LONGWORD(DISP);
// 1428 longword (v_mantissa) %if v_type = reall
if (V->TYPE != 36) goto L_007F;
LONGWORD(V->MANTISSA);
L_007F:;
// 1429 %else; !use immediate
goto L_007D;
L_007E:;
// 1430 put number byte (16_8F); !(pc)+
PUTNUMBERBYTE(143);
// 1431 %unless fits (disp, v_type) %start
if (FITS(DISP, V->TYPE)) goto L_0080;
// 1432 err = '*'
ERR = 42;
// 1433 err = '?' %if control&ovf check = 0; ! Warn only
if (CONTROL & 16 != 0) goto L_0081;
ERR = 63;
L_0081:;
// 1434 error (err, "value " . itos(disp,0) . " overflows " . %c
ERROR(ERR,
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ &*({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ &*({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("value "), ({
__typeof__(_imp_string63) tmp; /*E*/
tmp = ITOS(DISP, 0);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
}),
(_imp_string *)/*?*/ _imp_str_literal_ptr(" overflows "));
(_imp_string255 *)&tmp;
}),
({
__typeof__(_imp_string15) tmp; /*E*/
tmp = TYPESTR(V->TYPE & 16 + 7, 15);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string127 *)&tmp;
})
);
// 1435+ type str(v_type&(integers+7), 15))
// 1436 %finish
L_0080:;
// 1437 %if v_type = integers %start
if (V->TYPE != 16) goto L_0082;
// 1438 longword (disp)
LONGWORD(DISP);
// 1439 %else %if v_type = short+integers
goto L_0083;
L_0082:;
if (V->TYPE != 1 + 16) goto L_0084;
// 1440 word (disp)
WORD(DISP);
// 1441 %else %if v_type = byte+integers
goto L_0083;
L_0084:;
if (V->TYPE != 2 + 16) goto L_0085;
// 1442 put number byte (disp)
PUTNUMBERBYTE(DISP);
// 1443 %finish
L_0085:;
L_0083:;
// 1444 %finish
L_007D:;
// 1445 %return
return;
// 1446
// 1447 f(v in r):
case_F_1:;
// 1448 put number byte (16_50+base); ! register
PUTNUMBERBYTE(80 + BASE);
// 1449 %return
return;
// 1450
// 1451 f(a in s):
case_F_4:;
// 1452 base = base ! 16; ! to overflow into mode field
BASE = BASE | 16;
// 1453 f(v in s):
case_F_2:;
// 1454 %if base < 0 %start; ! %const<*>%name, object(const adr)
if (BASE >= 0) goto L_0086;
// 1455 put number byte (16_9f); !@#
PUTNUMBERBYTE(159);
// 1456 longword (disp)
LONGWORD(DISP);
// 1457 %return
return;
// 1458 %finish
L_0086:;
// 1459 release (v_base)
RELEASE(V->BASE);
// 1460 %if v_xno # 0 %start
if (V->XNO == 0) goto L_0087;
// 1461 flush code
FLUSHCODE();
// 1462 put (obj ext ref)
PUT(25);
// 1463 put word (v_xno); put long (disp); ca = ca + 5
PUTWORD(V->XNO);
PUTLONG(DISP);
CA = CA + 5;
// 1464 put (base)
PUT(BASE);
// 1465 %return
return;
// 1466 %finish
L_0087:;
// 1467 ! check if param of higher level
// 1468 %if r6 <= abase <= r9 %and disp > 60 %and abase < local %start
{
// Double-sided test on ABASE (Part I)
int tmp;
if (7 > (tmp = ABASE)) goto L_0088;
// Double-sided test on ABASE (Part II)
if (tmp > 10) goto L_0088;
}
if (DISP <= 60) goto L_0088;
if (ABASE >= LOCAL) goto L_0088;
// 1469 flush code
FLUSHCODE();
// 1470 put (obj modd)
PUT(23);
// 1471 mod = 1
MOD = 1;
// 1472 %finish
L_0088:;
// 1473 size = msize (disp)
SIZE = MSIZE(DISP);
// 1474 %if size <= 1 %start; !byte displacement
if (SIZE > 1) goto L_0089;
// 1475 %if disp = 0 %and base&16 = 0 %start; !register deferred
if (DISP != 0) goto L_008A;
if (BASE & 16 != 0) goto L_008A;
// 1476 %if v_flags&auto d # 0 %start
if (V->FLAGS & 8 == 0) goto L_008B;
// 1477 put number byte (16_70+base)
PUTNUMBERBYTE(112 + BASE);
// 1478 %else %if v_flags&auto i # 0
goto L_008C;
L_008B:;
if (V->FLAGS & 4 == 0) goto L_008D;
// 1479 put number byte (16_80+base)
PUTNUMBERBYTE(128 + BASE);
// 1480 %else
goto L_008C;
L_008D:;
// 1481 put number byte (16_60+base)
PUTNUMBERBYTE(96 + BASE);
// 1482 %finish
L_008C:;
// 1483 %else
goto L_008E;
L_008A:;
// 1484 put number byte (16_A0+base)
PUTNUMBERBYTE(160 + BASE);
// 1485 put number byte (disp)
PUTNUMBERBYTE(DISP);
// 1486 %finish
L_008E:;
// 1487 %else %if size = 2
goto L_008F;
L_0089:;
if (SIZE != 2) goto L_0090;
// 1488 put number byte (16_c0+base)
PUTNUMBERBYTE(192 + BASE);
// 1489 word (disp)
WORD(DISP);
// 1490 %else
goto L_008F;
L_0090:;
// 1491 put number byte (16_e0+base)
PUTNUMBERBYTE(224 + BASE);
// 1492 longword (disp)
LONGWORD(DISP);
// 1493 %finish
L_008F:;
// 1494 flush code %if mod # 0
if (MOD == 0) goto L_0091;
FLUSHCODE();
L_0091:;
// 1495 %return
return;
// 1496
// 1497 f(*):abort (13)
case_F_default:;
ABORT(13);
// 1498 %end
return;
case_F_dispatch:
if (F_index < 0 || F_index > 7)
_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 OPERAND */
// 1499
// 1500 %routine REMOVE (%record(stackfm) %name v)
void REMOVE(struct STACKFM * V) {
// 1501 release (v_base) %if v_form # v in r
if (V->FORM == 1) goto L_0092;
RELEASE(V->BASE);
L_0092:;
// 1502 release (v_index!128) %if v_flags&indexed # 0
if (V->FLAGS & 1 == 0) goto L_0093;
RELEASE(V->INDEX | 128);
L_0093:;
// 1503 %end
return;
} /* end of REMOVE */
// 1504
// 1505 %predicate NEGATIVE (%record(stackfm) %name v)
int NEGATIVE(struct STACKFM * V) {
// 1506 %false %if v_form # constant
if (V->FORM == 0) goto L_0094;
return 0 /*FALSE*/;
L_0094:;
// 1507 %if v_type&real bit # 0 %start
if (V->TYPE & 32 == 0) goto L_0095;
// 1508 %false %unless v_disp&16_8000 # 0
if (V->DISP & 32768 != 0) goto L_0096;
return 0 /*FALSE*/;
L_0096:;
// 1509 v_lrval = -v_lrval
V->LRVAL = -V->LRVAL;
// 1510 %else
goto L_0097;
L_0095:;
// 1511 %false %if v_disp = 16_80000000
if (V->DISP != -2147483648) goto L_0098;
return 0 /*FALSE*/;
L_0098:;
// 1512 %false %unless v_disp < 0
if (V->DISP < 0) goto L_0099;
return 0 /*FALSE*/;
L_0099:;
// 1513 v_disp = -v_disp
V->DISP = -V->DISP;
// 1514 %finish
L_0097:;
// 1515 %true
return 1 /*TRUE*/;
// 1516 %end
} /* end of NEGATIVE */
// 1517
// 1518 %routine TEST ASSIGNED (%record(stackfm) %name v)
void TESTASSIGNED(struct STACKFM * V) {
// 1519 %integer op, old d
int OP;
int OLDD;
// 1520 %return %if v_form = constant %or v_form = v in r %or
if (V->FORM == 0) goto L_009A;
if (V->FORM == 1) goto L_009A;
if (V->BASE == 12) goto L_009A;
if (V->XNO == 0) goto L_009B;
L_009A:;
return;
L_009B:;
// 1521+ v_base = gla %or v_xno # 0
// 1522 v_form = v in r %if v_form = 255; !special from plant2
if (V->FORM != 255) goto L_009C;
V->FORM = 1;
L_009C:;
// 1523 %return %if control&ass check = 0
if (CONTROL & 1 != 0) goto L_009D;
return;
L_009D:;
// 1524 %if v_type = reall %then op = cmpd&255 %else op = cmpl&255
if (V->TYPE != 36) goto L_009E;
OP = 244 & 255;
goto L_009F;
L_009E:;
OP = 240 & 255;
L_009F:;
// 1525 op = cmpw&255 %if v_type = strings
if (V->TYPE != 64) goto L_00A0;
OP = 241 & 255;
L_00A0:;
// 1526 %return %if v_base = local %and
if (V->BASE != LOCAL) goto L_00A1;
if (V->DISP <= 0) goto L_00A2;
if (V->FORM != 4) goto L_00A3;
L_00A2:;
if (V->DISP >= LASTLOCAL) goto L_00A1;
L_00A3:;
return;
L_00A1:;
// 1527+ ((v_disp > 0 %and v_form # a in s) %or v_disp < last local)
// 1528 old d = diag; diag = 0; ! Don't monitor anything here
OLDD = DIAG;
DIAG = 0;
// 1529 put code (opcode(op))
PUTCODE(OPCODE[OP]);
// 1530 operand (v); claim (v_base) %unless v_form = v in r
OPERAND(V);
if (V->FORM == 1) goto L_00A4;
CLAIM(V->BASE);
L_00A4:;
// 1531 claim (v_index!128) %if v_flags&indexed # 0
if (V->FLAGS & 1 == 0) goto L_00A5;
CLAIM(V->INDEX | 128);
L_00A5:;
// 1532 put number byte (16_60+gla-1); !(gla)
PUTNUMBERBYTE(96 + 12 - 1);
// 1533 diag = old d
DIAG = OLDD;
// 1534 prim (test ass)
PRIM(3);
// 1535 %end
return;
} /* end of TESTASSIGNED */
// 1536
// 1537 %routine CHECK INDIRECT (%record(stackfm) %name v)
void CHECKINDIRECT(struct STACKFM * V) {
// 1538 %integer save
int SAVE;
// 1539 %return %if control&ass check = 0
if (CONTROL & 1 != 0) goto L_00A6;
return;
L_00A6:;
// 1540 %if v_form = v in s %and
if (V->FORM != 2) goto L_00A7;
if (V->FLAGS & (1 | 2) != 1 | 2) goto L_00A7;
// 1541+ v_flags&(indexed!xdefer) = indexed!xdefer %start
// 1542 save = v_flags; v_flags = 0
SAVE = V->FLAGS;
V->FLAGS = 0;
// 1543 test assigned (v)
TESTASSIGNED(V);
// 1544 v_flags = save
V->FLAGS = SAVE;
// 1545 %else %if v_form = a in s
goto L_00A8;
L_00A7:;
if (V->FORM != 4) goto L_00A9;
// 1546 save = v_type; v_type = integers; v_form = v in s
SAVE = V->TYPE;
V->TYPE = 16;
V->FORM = 2;
// 1547 test assigned (v)
TESTASSIGNED(V);
// 1548 v_type = save; v_form = a in s
V->TYPE = SAVE;
V->FORM = 4;
// 1549 %finish
L_00A9:;
L_00A8:;
// 1550 %end
return;
} /* end of CHECKINDIRECT */
// 1551
// 1552 %routine PLANT1 (%integer op, %record(stackfm) %name v)
void PLANT1(int OP, struct STACKFM *V) {
// 1553 op = opcode(op&255)
OP = OPCODE[OP & 255];
// 1554 %if control&ass check # 0 %start
if (CONTROL & 1 == 0) goto L_00AA;
// 1555 check indirect (v)
CHECKINDIRECT(V);
// 1556 test assigned (v) %if operand bits(op)&check1 # 0
if (OPERANDBITS[OP] & 1 == 0) goto L_00AB;
TESTASSIGNED(V);
L_00AB:;
// 1557 %finish
L_00AA:;
// 1558 put code (op); operand (v)
PUTCODE(OP);
OPERAND(V);
// 1559 %end
return;
} /* end of PLANT1 */
auto void PLANT3(int OP, struct STACKFM *V1, struct STACKFM *V2, struct STACKFM *V3);
// 1560
// 1561 %routine %spec PLANT3 (%integer op, %record(stack fm) %name v1, v2, v3)
// 1562 %routine PLANT2 (%integer op, %record(stackfm) %name v1, v2)
void PLANT2(int OP, struct STACKFM *V1, struct STACKFM *V2) {
// 1563 %integer bits, negflag
int BITS;
int NEGFLAG;
// 1564 %record(stackfm) work
struct STACKFM WORK;
// 1565 %record(stack fm) %name temp
struct STACKFM *TEMP;
// 1566 %if op&addr bit # 0 %and v1_base # pc %and v1_form = v in s %and
if (OP & 4096 == 0) goto L_00AC;
if (V1->BASE == 16) goto L_00AC;
if (V1->FORM != 2) goto L_00AC;
if (V1->FLAGS & 1 != 0) goto L_00AC;
// 1567+ v1_flags&indexed = 0 %start
// 1568 ! MOVAx_k(Rn),Y
// 1569 %if v1_disp = 0 %start
if (V1->DISP != 0) goto L_00AD;
// 1570 ! MOVAx_(Rn),Y -> MOVL_Rn,Y : twice as fast!!
// 1571 work = v1; v1 == work
WORK = *V1;
V1 = (struct STACKFM *)/*?*/ &WORK;
// 1572 v1_form = v in r; op = op&(\7) - 1*8
V1->FORM = 1;
OP = (OP & (~7)) - 1 * 8;
// 1573 release (v1_base); ! OPERAND doesn't in this case...
RELEASE(V1->BASE);
// 1574 %else %if -63 <= v1_disp <= 63 %and
goto L_00AE;
L_00AD:;
{
// Double-sided test on V1->DISP (Part I)
int tmp;
if (-63 > (tmp = V1->DISP)) goto L_00AF;
// Double-sided test on V1->DISP (Part II)
if (tmp > 63) goto L_00AF;
}
if (V1->DISP < 0) goto L_00B0;
if (V1->BASE == LOCAL) goto L_00AF;
L_00B0:;
// 1575+ (v1_disp < 0 %or v1_base # local)
// 1576 ! MOVAx_S(Rn),Y -> ADDL3_Rn,#S,Y where s is short lit, and
// 1577 ! not a parameter!!!!
// 1578 work = 0; work_disp = v1_disp; work_type = integers
WORK = (struct STACKFM){0};
WORK.DISP = V1->DISP;
WORK.TYPE = 16;
// 1579 plant3 (addl+three op, regv(v1_base), work, v2)
PLANT3(18288 + 64, /*?*/ ®V[V1->BASE - 1], /*?*/ &WORK, V2);
// 1580 release (v1_base)
RELEASE(V1->BASE);
// 1581 %return
return;
// 1582 %finish
L_00AF:;
L_00AE:;
// 1583 %finish
L_00AC:;
// 1584 negflag = 0
NEGFLAG = 0;
// 1585 negflag = 1 %if v1_type&integers#0 %and v1_form = constant %and
if (V1->TYPE & 16 == 0) goto L_00B1;
if (V1->FORM != 0) goto L_00B1;
{
// Double-sided test on V1->DISP (Part I)
int tmp;
if (-64 > (tmp = V1->DISP)) goto L_00B1;
// Double-sided test on V1->DISP (Part II)
if (tmp >= 0) goto L_00B1;
}
NEGFLAG = 1;
L_00B1:;
// 1586+ -64 <= v1_disp < 0
// 1587 %if op&one bit # 0 %start; !has 1-op variant
if (OP & 256 == 0) goto L_00B2;
// 1588 %if v2 == spv %start; !-(sp)
if (_imp_ADDR((void *)(V2)) != _imp_ADDR((void *)(/*?*/ &SPV))) goto L_00B3;
// 1589 %if op&addr bit # 0 %or
if (OP & 4096 != 0) goto L_00B4;
if (OP != 8968) goto L_00B5;
if (NEGFLAG != 0) goto L_00B5;
L_00B4:;
// 1590+ (op = movl %and negflag = 0) %start; ! pusha, pushl
// 1591 op = op+8*3
OP = OP + 8 * 3;
// 1592 plant1 (op, v1); %return
PLANT1(OP, V1);
return;
// 1593 %finish
L_00B5:;
// 1594 %finish
L_00B3:;
// 1595 %if v1_form = constant %start
if (V1->FORM != 0) goto L_00B6;
// 1596 %if op&move bit # 0 %start
if (OP & 8192 == 0) goto L_00B7;
// 1597 %if zero (v1) %and v2_form # v in r %start
if (!(ZERO(V1))) goto L_00B8;
if (V2->FORM == 1) goto L_00B8;
// 1598 ! mov #0 -> clr, except when dest a register!!!
// 1599 plant1 (op+8*5, v2)
PLANT1(OP + 8 * 5, V2);
// 1600 %return
return;
// 1601 %else %if negflag # 0 %and v1_type # byte+integers
L_00B8:;
if (NEGFLAG == 0) goto L_00B9;
if (V1->TYPE == 2 + 16) goto L_00B9;
// 1602 %if v1_disp = -64 %start
if (V1->DISP != -64) goto L_00BA;
// 1603 v1_disp = \v1_disp; ! movx #-64 -> mcomx #63
V1->DISP = (~V1->DISP);
// 1604 op = op + 8*2
OP = OP + 8 * 2;
// 1605 %else
goto L_00BB;
L_00BA:;
// 1606 v1_disp = -v1_disp
V1->DISP = -V1->DISP;
// 1607 op = op - 8*1; ! movx #-n -> mnegl #n
OP = OP - 8 * 1;
// 1608 %finish
L_00BB:;
// 1609 %finish
L_00B9:;
// 1610 %finish
L_00B7:;
// 1611 %if op&(add bit!sub bit) # 0 %start
if (OP & (1024 | 2048) == 0) goto L_00BC;
// 1612 op = op!!(8!add bit!sub bit!commute) %if negative (v1)
if (!(NEGATIVE(V1))) goto L_00BD;
OP = OP ^ (8 | 1024 | 2048 | 16384);
L_00BD:;
// 1613 %if v1_type&integers # 0 %and v1_disp = 1 %and
if (V1->TYPE & 16 == 0) goto L_00BE;
if (V1->DISP != 1) goto L_00BE;
if (V2->FORM == 1) goto L_00BE;
// 1614+ v2_form # v in r %start
// 1615 ! add -> inc, except when dest reg...
// 1616 plant1 (op-8*2, v2)
PLANT1(OP - 8 * 2, V2);
// 1617 %return
return;
// 1618 %finish
L_00BE:;
// 1619 %finish
L_00BC:;
// 1620 %finish
L_00B6:;
// 1621 %finish
L_00B2:;
// 1622 %if op&reversible # 0 %and short literal (v1) >= 0 %start
if (OP & 32768 == 0) goto L_00BF;
if (SHORTLITERAL(V1) < 0) goto L_00BF;
// 1623 ! If possible, make a short literal the 2nd operand,
// 1624 ! for pipelining speed gain.
// 1625 temp == v1; v1 == v2; v2 == temp
TEMP = (struct STACKFM *)V1;
V1 = (struct STACKFM *)V2;
V2 = (struct STACKFM *)TEMP;
// 1626 %finish
L_00BF:;
// 1627 op = opcode(op&255)
OP = OPCODE[OP & 255];
// 1628 bits = operand bits(op)
BITS = OPERANDBITS[OP];
// 1629 check indirect (v1) %if control&ass check # 0
if (CONTROL & 1 == 0) goto L_00C0;
CHECKINDIRECT(V1);
L_00C0:;
// 1630 %if bits&move check = 0 %or v2_form # v in r %start
if (BITS & 8 == 0) goto L_00C1;
if (V2->FORM == 1) goto L_00C2;
L_00C1:;
// 1631 %if control&ass check # 0 %start
if (CONTROL & 1 == 0) goto L_00C3;
// 1632 test assigned (v1) %if bits&check1 # 0
if (BITS & 1 == 0) goto L_00C4;
TESTASSIGNED(V1);
L_00C4:;
// 1633 check indirect (v2)
CHECKINDIRECT(V2);
// 1634 test assigned (v2) %if bits&check2 # 0
if (BITS & 2 == 0) goto L_00C5;
TESTASSIGNED(V2);
L_00C5:;
// 1635 %finish
L_00C3:;
// 1636 put code (op)
PUTCODE(OP);
// 1637 operand (v1)
OPERAND(V1);
// 1638 operand (v2)
OPERAND(V2);
// 1639 %else
goto L_00C6;
L_00C2:;
// 1640 put code (op)
PUTCODE(OP);
// 1641 operand (v1)
OPERAND(V1);
// 1642 operand (v2)
OPERAND(V2);
// 1643 %if (v1_type = integers %or v1_type&real bit # 0) %andc
if (V1->TYPE == 16) goto L_00C7;
if (V1->TYPE & 32 == 0) goto L_00C8;
L_00C7:;
if (V1->FORM == 4) goto L_00C9;
if (V1->FORM != 2) goto L_00C8;
if (V1->BASE != LOCAL) goto L_00C9;
if (V1->DISP < LASTLOCAL) goto L_00C8;
L_00C9:;
// 1644+ (v1_form = a in s %or
// 1645+ (v1_form = v in s %and
// 1646+ (v1_base # local %or
// 1647+ v1_disp >= last local))) %start
// 1648 v2_form = 255; !**special**
V2->FORM = 255;
// 1649 test assigned (v2)
TESTASSIGNED(V2);
// 1650 %finish
L_00C8:;
// 1651 %finish
L_00C6:;
// 1652 %end
return;
} /* end of PLANT2 */
// 1653
// 1654 %routine PLANT3 (%integer op, %record(stackfm) %name v1, v2, v3)
void PLANT3(int OP, struct STACKFM *V1, struct STACKFM *V2, struct STACKFM *V3) {
// 1655 %integer bits
int BITS;
// 1656 %record(stackfm) %name temp
struct STACKFM *TEMP;
// 1657 %record(stackfm) work
struct STACKFM WORK;
// 1658 %if op&commute # 0 %start
if (OP & 16384 == 0) goto L_00CA;
// 1659 %if v2_form = constant %or same (v1, v3) %start
if (V2->FORM == 0) goto L_00CB;
if (!(SAME(V1, V3))) goto L_00CC;
L_00CB:;
// 1660 temp == v1; v1 == v2; v2 == temp
TEMP = (struct STACKFM *)V1;
V1 = (struct STACKFM *)V2;
V2 = (struct STACKFM *)TEMP;
// 1661 %finish
L_00CC:;
// 1662 %finish
L_00CA:;
// 1663 %if op&two bit # 0 %start
if (OP & 512 == 0) goto L_00CD;
// 1664 %if op&(add bit!sub bit) # 0 %start
if (OP & (1024 | 2048) == 0) goto L_00CE;
// 1665 op = op!!(8!add bit!sub bit!commute) %if negative (v1)
if (!(NEGATIVE(V1))) goto L_00CF;
OP = OP ^ (8 | 1024 | 2048 | 16384);
L_00CF:;
// 1666 %if v3_type = integers %and v1_form = constant %and
if (V3->TYPE != 16) goto L_00D0;
if (V1->FORM != 0) goto L_00D0;
{
// Double-sided test on V1->DISP (Part I)
int tmp;
if (0 > (tmp = V1->DISP)) goto L_00D1;
// Double-sided test on V1->DISP (Part II)
if (tmp <= 63) goto L_00D0;
}
L_00D1:;
if (V2->FORM != 1) goto L_00D0;
if (V2->TYPE & 32 != 0) goto L_00D0;
if (SAME(V2, V3)) goto L_00D0;
// 1667+ %not 0 <= v1_disp <= 63 %and
// 1668+ v2_form = v in r %and v2_type&realbit = 0 %and
// 1669+ %not same (v2, v3) %start
// 1670 ! addl3_#n,Rm,X -> moval_n(Rm),X
// 1671 v1_disp = -v1_disp %if op&sub bit # 0
if (OP & 2048 == 0) goto L_00D2;
V1->DISP = -V1->DISP;
L_00D2:;
// 1672 work = v2
WORK = *V2;
// 1673 work_form = v in s
WORK.FORM = 2;
// 1674 work_disp = v1_disp
WORK.DISP = V1->DISP;
// 1675 claim (v2_base); ! will get released
CLAIM(V2->BASE);
// 1676 plant2 (moval, work, v3)
PLANT2(4112, /*?*/ &WORK, V3);
// 1677 %return
return;
// 1678 %finish
L_00D0:;
// 1679 %finish
L_00CE:;
// 1680 %if same (v2, v3) %start; !can use two op form
if (!(SAME(V2, V3))) goto L_00D3;
// 1681 remove (v2)
REMOVE(V2);
// 1682 plant2 ((op-8*8)&(\commute), v1, v3)
PLANT2(OP - 8 * 8 & (~16384), V1, V3);
// 1683 %return
return;
// 1684 %finish
L_00D3:;
// 1685 %finish
L_00CD:;
// 1686 %if op&commute # 0 %and short literal (v1) >= 0 %start
if (OP & 16384 == 0) goto L_00D4;
if (SHORTLITERAL(V1) < 0) goto L_00D4;
// 1687 ! Better to have short literal 2nd, for
// 1688 ! pipelining effects
// 1689 temp == v1; v1 == v2; v2 == temp
TEMP = (struct STACKFM *)V1;
V1 = (struct STACKFM *)V2;
V2 = (struct STACKFM *)TEMP;
// 1690 %finish
L_00D4:;
// 1691 op = opcode(op&255)
OP = OPCODE[OP & 255];
// 1692 bits = operand bits(op)
BITS = OPERANDBITS[OP];
// 1693 %if control&ass check # 0 %start
if (CONTROL & 1 == 0) goto L_00D5;
// 1694 check indirect (v1); test assigned (v1) %if bits&check1 # 0
CHECKINDIRECT(V1);
if (BITS & 1 == 0) goto L_00D6;
TESTASSIGNED(V1);
L_00D6:;
// 1695 check indirect (v2); test assigned (v2) %if bits&check2 # 0
CHECKINDIRECT(V2);
if (BITS & 2 == 0) goto L_00D7;
TESTASSIGNED(V2);
L_00D7:;
// 1696 check indirect (v3); test assigned (v3) %if bits&check3 # 0
CHECKINDIRECT(V3);
if (BITS & 4 == 0) goto L_00D8;
TESTASSIGNED(V3);
L_00D8:;
// 1697 %finish
L_00D5:;
// 1698 put code (op)
PUTCODE(OP);
// 1699 operand (v1)
OPERAND(V1);
// 1700 operand (v2)
OPERAND(V2);
// 1701 operand (v3)
OPERAND(V3);
// 1702 %end
return;
} /* end of PLANT3 */
// 1703
// 1704 %routine PLANT4 (%integer op, %record(stackfm) %name v1, v2, v3, v4)
void PLANT4(int OP, struct STACKFM *V1, struct STACKFM *V2, struct STACKFM *V3, struct STACKFM *V4) {
// 1705 %if control&ass check # 0 %start
if (CONTROL & 1 == 0) goto L_00D9;
// 1706 check indirect (v1); check indirect (v2)
CHECKINDIRECT(V1);
CHECKINDIRECT(V2);
// 1707 check indirect (v3); check indirect (v4)
CHECKINDIRECT(V3);
CHECKINDIRECT(V4);
// 1708 %finish
L_00D9:;
// 1709 put code (opcode(op&255))
PUTCODE(OPCODE[OP & 255]);
// 1710 operand (v1); operand (v2)
OPERAND(V1);
OPERAND(V2);
// 1711 operand (v3); operand (v4)
OPERAND(V3);
OPERAND(V4);
// 1712 %end
return;
} /* end of PLANT4 */
// 1713
// 1714 %routine PLANT5 (%integer op, %record(stackfm) %name v1, v2, v3, v4, v5)
void PLANT5(int OP, struct STACKFM *V1, struct STACKFM *V2, struct STACKFM *V3, struct STACKFM *V4,
struct STACKFM *V5) {
// 1715 %if control&ass check # 0 %start
if (CONTROL & 1 == 0) goto L_00DA;
// 1716 check indirect (v1); check indirect (v2); check indirect (v3)
CHECKINDIRECT(V1);
CHECKINDIRECT(V2);
CHECKINDIRECT(V3);
// 1717 check indirect (v4); check indirect (v5)
CHECKINDIRECT(V4);
CHECKINDIRECT(V5);
// 1718 %finish
L_00DA:;
// 1719 put code (opcode(op&255))
PUTCODE(OPCODE[OP & 255]);
// 1720 operand (v1); operand (v2); operand (v3)
OPERAND(V1);
OPERAND(V2);
OPERAND(V3);
// 1721 operand (v4); operand (v5)
OPERAND(V4);
OPERAND(V5);
// 1722 entry mask = entry mask ! 16_3c
ENTRYMASK = ENTRYMASK | 60;
// 1723 %end
return;
} /* end of PLANT5 */
// 1724
// 1725 %routine HAZARD STRINGS
void HAZARDSTRINGS(void) {
// 1726 %integer reg
int REG;
// 1727 hazard (reg) %for reg = r0, 1, r5
// %for REG = 1, 1, 6 %cycle
{
REG = 0;
L_00DB:
if (REG == 6) goto L_00DC;
REG += 1;
HAZARD(REG);
goto L_00DB;
}
L_00DC:;
// 1728 %end
return;
} /* end of HAZARDSTRINGS */
// 1729
// 1730 %routine IOVF OFF
void IOVFOFF(void) {
// 1731 ! prevent overflow trap
// 1732 %if entry mask&iovf bit # 0 %and ivbit state # 0 %start
if (ENTRYMASK & 16384 == 0) goto L_00DE;
if (IVBITSTATE == 0) goto L_00DE;
// 1733 word (bicpsw vbit)
WORD(8377);
// 1734 ivbit state = 0
IVBITSTATE = 0;
// 1735 %finish
L_00DE:;
// 1736 %end
return;
} /* end of IOVFOFF */
// 1737
// 1738 %routine IOVF ON
void IOVFON(void) {
// 1739 ! re-enable overflow trap if it should be on
// 1740 %if entry mask&iovf bit # 0 %and ivbit state = 0 %start
if (ENTRYMASK & 16384 == 0) goto L_00DF;
if (IVBITSTATE != 0) goto L_00DF;
// 1741 word (bispsw vbit)
WORD(8376);
// 1742 ivbit state = 1
IVBITSTATE = 1;
// 1743 %finish
L_00DF:;
// 1744 %end
return;
} /* end of IOVFON */
// 1745
// 1746 %routine STRING3 (%integer op, %record(stackfm) %name v1, v2, v3)
void STRING3(int OP, struct STACKFM *V1, struct STACKFM *V2, struct STACKFM *V3) {
// 1747 %integer code, stype, no check v2, old control = control
int CODE;
int STYPE;
int NOCHECKV2;
int OLDCONTROL;
OLDCONTROL = CONTROL;
// 1748 no check v2 = op&no ass chk
NOCHECKV2 = OP & 262144;
// 1749 op = op & (\no ass chk)
OP = OP & (~262144);
// 1750 code = 0
CODE = 0;
// 1751 %if v1_form = constant %start
if (V1->FORM != 0) goto L_00E0;
// 1752 v1_type = short+integers
V1->TYPE = 1 + 16;
// 1753 %if op = 0 %or op = movc3 %start; !look for short form
if (OP == 0) goto L_00E1;
if (OP != 30) goto L_00E2;
L_00E1:;
// 1754 stype = scale type (v1_disp)
STYPE = SCALETYPE(V1->DISP);
// 1755 code = movl+stype %if stype >= 0
if (STYPE < 0) goto L_00E3;
CODE = 8968 + STYPE;
L_00E3:;
// 1756 %finish
L_00E2:;
// 1757 %finish
L_00E0:;
// 1758 op = op & (\no short)
OP = OP & (~65536);
// 1759 %if code = 0 %start; ! character op required
if (CODE != 0) goto L_00E4;
// 1760 release (v1_base); release (v2_base); release (v3_base)
RELEASE(V1->BASE);
RELEASE(V2->BASE);
RELEASE(V3->BASE);
// 1761 hazard strings
HAZARDSTRINGS();
// 1762 claim (v1_base); claim (v2_base); claim (v3_base)
CLAIM(V1->BASE);
CLAIM(V2->BASE);
CLAIM(V3->BASE);
// 1763 %finish
L_00E4:;
// 1764 %if control&ass check # 0 %start
if (CONTROL & 1 == 0) goto L_00E5;
// 1765 %if no check v2 = 0 %start
if (NOCHECKV2 != 0) goto L_00E6;
// 1766 check indirect (v2)
CHECKINDIRECT(V2);
// 1767 test assigned (v2)
TESTASSIGNED(V2);
// 1768 %finish
L_00E6:;
// 1769 check indirect (v3)
CHECKINDIRECT(V3);
// 1770 test assigned (v3) %if op = cmpc3
if (OP != 246) goto L_00E7;
TESTASSIGNED(V3);
L_00E7:;
// 1771 control = control & (\ass check)
CONTROL = CONTROL & (~1);
// 1772 %finish
L_00E5:;
// 1773 %if op = 0 %start; !concat
if (OP != 0) goto L_00E8;
// 1774 op = movc3
OP = 30;
// 1775 v2_disp = v2_disp + 1; !skip the length
V2->DISP = V2->DISP + 1;
// 1776 %finish
L_00E8:;
// 1777 %if code # 0 %start
if (CODE == 0) goto L_00E9;
// 1778 %if v3_base = r3 %and v3_disp = 0 %and
if (V3->BASE != 4) goto L_00EA;
if (V3->DISP != 0) goto L_00EA;
if (V3->FORM != 2) goto L_00EA;
{
// Double-sided test on 0 (Part I)
int tmp;
if (V3->FLAGS != (tmp = 0)) goto L_00EA;
// Double-sided test on 0 (Part II)
if (tmp != V3->XNO) goto L_00EA;
}
// 1779+ v3_form = v in s %and v3_flags = 0 = v3_xno %start
// 1780 v3_flags = auto i
V3->FLAGS = 4;
// 1781 op = 0
OP = 0;
// 1782 %finish
L_00EA:;
// 1783 plant2 (code, v2, v3)
PLANT2(CODE, V2, V3);
// 1784 last movc3 = ca %and v3_flags = 0 %if op = 0
if (OP != 0) goto L_00EB;
LASTMOVC3 = CA;
V3->FLAGS = 0;
L_00EB:;
// 1785 %else
goto L_00EC;
L_00E9:;
// 1786 entry mask = entry mask ! 16_3C; ! R0:R5 used
ENTRYMASK = ENTRYMASK | 60;
// 1787 plant3 (op, v1, v2, v3)
PLANT3(OP, V1, V2, V3);
// 1788 last movc3 = ca %if op = movc3
if (OP != 30) goto L_00ED;
LASTMOVC3 = CA;
L_00ED:;
// 1789 %finish
L_00EC:;
// 1790 control = old control
CONTROL = OLDCONTROL;
// 1791 %end
return;
} /* end of STRING3 */
// 1792
// 1793 ! %routine STRING5 (%integer op,
// 1794 ! %record(stackfm) %name v1, v2, v3, v4, v5)
// 1795 ! release (v1_base)
// 1796 ! release (v2_base)
// 1797 ! release (v3_base)
// 1798 ! release (v4_base)
// 1799 ! release (v5_base)
// 1800 ! hazard strings
// 1801 ! claim (v1_base)
// 1802 ! claim (v2_base)
// 1803 ! claim (v3_base)
// 1804 ! claim (v4_base)
// 1805 ! claim (v5_base)
// 1806 ! entry mask = entry mask ! 16_3c
// 1807 ! plant5 (op, v1, v2, v3, v4, v5)
// 1808 ! %end
// 1809
// 1810 %routine PRIM EP (%integer n)
void PRIMEP(int N) {
// 1811 %integer ep
int EP;
// 1812 %own %byte %array prim eps (1 : prim rts) = 0(*)
static unsigned char PRIMEPS[26] = {[0 ... 25] = 0};
// 1813 ep = prim eps(n)
EP = PRIMEPS[N - 1];
// 1814 %if ep = 0 %start; !first use
if (EP != 0) goto L_00EE;
// 1815 prim eps(n) = 1
PRIMEPS[N - 1] = 1;
// 1816 put (obj prim spec); put (n)
PUT(13);
PUT(N);
// 1817 %finish
L_00EE:;
// 1818 entry mask = entry mask ! prim mask(n)
ENTRYMASK = ENTRYMASK | PRIMMASK[N - 1];
// 1819 %end
return;
} /* end of PRIMEP */
// 1820
// 1821 %routine PRIM (%integer n)
void PRIM(int N) {
// 1822 %integer r
int R;
// 1823 prim ep (n)
PRIMEP(N);
// 1824 %if test ass # n # test string ovf %start
{
// Double-sided test on N (Part I)
int tmp;
if (3 == (tmp = N)) goto L_00EF;
// Double-sided test on N (Part II)
if (tmp == 25) goto L_00EF;
}
// 1825 hazard (r) %for r = r0, 1, r5
// %for R = 1, 1, 6 %cycle
{
R = 0;
L_00F0:
if (R == 6) goto L_00F1;
R += 1;
HAZARD(R);
goto L_00F0;
}
L_00F1:;
// 1826 %finish
L_00EF:;
// 1827 flush code; set line
FLUSHCODE();
SETLINE();
// 1828 put (obj prim ref); put (n); ca = ca + 6
PUT(24);
PUT(N);
CA = CA + 6;
// 1829 %end
return;
} /* end of PRIM */
// 1830
// 1831 %routine DUMP TEXT (%string(*) %name text)
void DUMPTEXT(_imp_string * TEXT) {
// 1832 %integer p, sym
int P;
int SYM;
// 1833 length(text) = max ident %if length(text) > max ident
if (*_imp_LENGTH((_imp_string255 *)/*p*/ TEXT) <= 31) goto L_00F3;
*_imp_LENGTH((_imp_string255 *)/*p*/ TEXT) = 31;
L_00F3:;
// 1834 %for p = 0, 1, length(text) %cycle
// %for P = 0, 1, *_imp_LENGTH((_imp_string255 *)/*p*/TEXT) %cycle
{
int _final = *_imp_LENGTH((_imp_string255 *)/*p*/ TEXT);
if (invalid_for_loop(0, 1, _final))
_imp_signal(5, 1, 0, "Illegal cycle P = 0, 1, *_imp_LENGTH((_imp_string255 *)/*p*/TEXT)");
P = -1;
L_00F4:
if (P == _final) goto L_00F5;
P += 1;
// 1835 sym = charno(text, p)
SYM = *_imp_CHARNO((_imp_string255 *)/*p*/ TEXT, P);
// 1836 sym = sym-32 %if 'a' <= sym <= 'z'
{
// Double-sided test on SYM (Part I)
int tmp;
if (97 > (tmp = SYM)) goto L_00F6;
// Double-sided test on SYM (Part II)
if (tmp > 122) goto L_00F6;
}
SYM = SYM - 32;
L_00F6:;
// 1837 put (sym)
PUT(SYM);
// 1838 %repeat
goto L_00F4;
}
L_00F5:;
// 1839 %end
return;
} /* end of DUMPTEXT */
// 1840
// 1841 %routine LPUT (%integer ep, addr)
void LPUT(int EP, int ADDR) {
// 1842 put (ep)
PUT(EP);
// 1843 put long (addr)
PUTLONG(ADDR);
// 1844 dump text (external name)
DUMPTEXT((_imp_string255 *)/*p*/ /*?*/ &EXTERNALNAME);
// 1845 %end
return;
} /* end of LPUT */
// 1846
// 1847 %routine DEFINE TAG (%integer ref)
void DEFINETAG(int REF) {
// 1848 select output tank (directives)
SELECTOUTPUTTANK(DIRECTIVES);
// 1849 put (dir ldef)
PUT(2);
// 1850 put word (ref); put long (ca)
PUTWORD(REF);
PUTLONG(CA);
// 1851 select output tank (object)
SELECTOUTPUTTANK(OBJECT);
// 1852 %end
return;
} /* end of DEFINETAG */
// 1853
// 1854 %routine DEFINE ENTRY (%integer ref)
void DEFINEENTRY(int REF) {
// 1855 select output tank (directives)
SELECTOUTPUTTANK(DIRECTIVES);
// 1856 put (dir entry); put word (ref)
PUT(10);
PUTWORD(REF);
// 1857 select output tank (object)
SELECTOUTPUTTANK(OBJECT);
// 1858 %end
return;
} /* end of DEFINEENTRY */
// 1859
// 1860 %routine DEFINE REFERENCE (%integer ref, type)
void DEFINEREFERENCE(int REF, int TYPE) {
// 1861 select output tank (directives)
SELECTOUTPUTTANK(DIRECTIVES);
// 1862 put (type)
PUT(TYPE);
// 1863 last ref = ref
LASTREF = REF;
// 1864 put word (ref); put long (ca)
PUTWORD(REF);
PUTLONG(CA);
// 1865 select output tank (object)
SELECTOUTPUTTANK(OBJECT);
// 1866 %end
return;
} /* end of DEFINEREFERENCE */
// 1867
// 1868 !register handling routines
// 1869
// 1870 %routine CLAIM (%integer reg)
void CLAIM(int REG) {
// 1871 !cherish the value in the register
// 1872 %string(2) s = ""
_imp_string2 S;
_imp_strncpy(/*?*/ &S, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 2);
// 1873 %integer j
int J;
// 1874 %if reg&128 # 0 %start; ! Claimed as index
if (REG & 128 == 0) goto L_00F7;
// 1875 reg = reg & 127
REG = REG & 127;
// 1876 index regs = index regs + 1
INDEXREGS = INDEXREGS + 1;
// 1877 abort (40) %unless activity(reg) >= 0 %and r0 <= reg <= r10
if (ACTIVITY[REG] < 0) goto L_00F2;
{
// Double-sided test on REG (Part I)
int tmp;
if (1 > (tmp = REG)) goto L_00F2;
// Double-sided test on REG (Part II)
if (tmp <= 11) goto L_00F8;
}
L_00F2:;
ABORT(40);
L_00F8:;
// 1878 indx(reg) = indx(reg) + 1
INDX[REG - 1] = INDX[REG - 1] + 1;
// 1879 s = "[]"
_imp_strncpy(/*?*/ &S, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("[]");
(void *)&tmp;
}),
/*max:*/ 2);
// 1880 %finish
L_00F7:;
// 1881 %return %if reg = 0 %or activity(reg) < 0; !none or locked
if (REG == 0) goto L_00DD;
if (ACTIVITY[REG] >= 0) goto L_00F9;
L_00DD:;
return;
L_00F9:;
// 1882 mon reg ("Claim".s, reg) %if diag&4 # 0
if (DIAG & 4 == 0) goto L_00FA;
MONREG(
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("Claim"), (_imp_string *)/*?*/ &S);
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string20 *)&tmp;
})
,
REG);
L_00FA:;
// 1883 active regs = active regs+1; !one more active
ACTIVEREGS = ACTIVEREGS + 1;
// 1884 activity(reg) = activity(reg)+1; !note claimed
ACTIVITY[REG] = ACTIVITY[REG] + 1;
// 1885 used(reg) = ca; !and note when used last
USED[REG] = CA;
// 1886 %if reg >= fpr0 %start; !claim general equivs
if (REG < 18) goto L_00FB;
// 1887 reg = (reg-fpr0)<<1+r0
REG = (REG - 18 << 1) + 1;
// 1888 j = diag; diag = 0
J = DIAG;
DIAG = 0;
// 1889 claim (reg); claim (reg+1)
CLAIM(REG);
CLAIM(REG + 1);
// 1890 diag = j
DIAG = J;
// 1891 %finish
L_00FB:;
// 1892 %end
return;
} /* end of CLAIM */
// 1893
// 1894 %routine RELEASE (%integer reg)
void RELEASE(int REG) {
// 1895 ! hazard the value in a register
// 1896 %integer old d
int OLDD;
// 1897 %string(2) s = ""
_imp_string2 S;
_imp_strncpy(/*?*/ &S, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 2);
// 1898 %if reg&128 # 0 %start
if (REG & 128 == 0) goto L_00FC;
// 1899 reg = reg&127
REG = REG & 127;
// 1900 abort (41) %unless r0 <= reg <= r10
{
// Double-sided test on REG (Part I)
int tmp;
if (1 > (tmp = REG)) goto L_00FD;
// Double-sided test on REG (Part II)
if (tmp <= 11) goto L_00FE;
}
L_00FD:;
ABORT(41);
L_00FE:;
// 1901 abort (42) %if activity(reg) < 0
if (ACTIVITY[REG] >= 0) goto L_00FF;
ABORT(42);
L_00FF:;
// 1902 index regs = index regs - 1
INDEXREGS = INDEXREGS - 1;
// 1903 abort (43) %if index regs < 0
if (INDEXREGS >= 0) goto L_0100;
ABORT(43);
L_0100:;
// 1904 indx(reg) = indx(reg) - 1
INDX[REG - 1] = INDX[REG - 1] - 1;
// 1905 abort (44) %if indx(reg) < 0
if (INDX[REG - 1] >= 0) goto L_0101;
ABORT(44);
L_0101:;
// 1906 s = "[]"
_imp_strncpy(/*?*/ &S, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("[]");
(void *)&tmp;
}),
/*max:*/ 2);
// 1907 %finish
L_00FC:;
// 1908 %return %if reg = 0 %or activity(reg) < 0; !none or locked
if (REG == 0) goto L_0102;
if (ACTIVITY[REG] >= 0) goto L_0103;
L_0102:;
return;
L_0103:;
// 1909 mon reg ("Release".s, reg) %if diag&4 # 0
if (DIAG & 4 == 0) goto L_0104;
MONREG(
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("Release"), (_imp_string *)/*?*/ &S);
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string20 *)&tmp;
})
,
REG);
L_0104:;
// 1910 active regs = active regs - 1; !one less active
ACTIVEREGS = ACTIVEREGS - 1;
// 1911 activity(reg) = activity(reg) - 1; !one less user
ACTIVITY[REG] = ACTIVITY[REG] - 1;
// 1912 abort (3) %if activity(reg) < 0; !too many
if (ACTIVITY[REG] >= 0) goto L_0105;
ABORT(3);
L_0105:;
// 1913 %if reg >= fpr0 %start
if (REG < 18) goto L_0106;
// 1914 reg = (reg-fpr0)<<1+r0
REG = (REG - 18 << 1) + 1;
// 1915 old d = diag; diag = 0
OLDD = DIAG;
DIAG = 0;
// 1916 release (reg); release (reg+1)
RELEASE(REG);
RELEASE(REG + 1);
// 1917 diag = old d
DIAG = OLDD;
// 1918 %finish
L_0106:;
// 1919 %end
return;
} /* end of RELEASE */
// 1920
// 1921 %routine CLEAR (%record(stackfm) %name v)
void CLEAR(struct STACKFM * V) {
// 1922 monitor (v, "Clear") %if diag&4 # 0
if (DIAG & 4 == 0) goto L_0107;
MONITOR(V, _imp_str_literal_size(15, "Clear"));
L_0107:;
// 1923 release (v_base) %if v_form = v in r
if (V->FORM != 1) goto L_0108;
RELEASE(V->BASE);
L_0108:;
// 1924 %end
return;
} /* end of CLEAR */
// 1925
// 1926 %routine SCALE INDEX (%integername op, %record(stackfm) %name v)
void SCALEINDEX(int *OP, struct STACKFM *V) {
// 1927 ! Ensure that array elements are scaled correctly when
// 1928 ! the address of one is required (the descriptor will normally
// 1929 ! look like an integer at this stage!)
// 1930 %integer type
int TYPE;
// 1931 %return %if op&addr bit = 0 %or v_flags&indexed = 0
if (*OP & 4096 == 0) goto L_0109;
if (V->FLAGS & 1 != 0) goto L_010A;
L_0109:;
return;
L_010A:;
// 1932 monitor (v, "Scale index") %if diag&128 # 0
if (DIAG & 128 == 0) goto L_010B;
MONITOR(V, _imp_str_literal_size(15, "Scale index"));
L_010B:;
// 1933 type = scale type (v_iscale)
TYPE = SCALETYPE(V->ISCALE);
// 1934 abort(35) %if type < 0
if (TYPE >= 0) goto L_010C;
ABORT(35);
L_010C:;
// 1935 op = (op&(\7)) ! type
*OP = *OP & (~7) | TYPE;
// 1936 %end
return;
} /* end of SCALEINDEX */
// 1937
// 1938 %routine HAZARD (%integer reg)
void HAZARD(int REG) {
// 1939 ! protect the value in register 'reg' by storing in a temp
// 1940 %integer n, op, r, form
int N;
int OP;
int R;
int FORM;
// 1941 %record(dfm) %name p
struct DFM *P;
// 1942 %record(stackfm) temp
struct STACKFM TEMP;
// 1943 %record(stackfm) %name s
struct STACKFM *S;
// 1944
// 1945 %routine MOD (%record(stackfm) %name v)
void MOD(struct STACKFM * V) {
// 1946 %switch s (constant : a in rec)
int S_index;
int S_line;
char *S_file;
static const void *S[8] = {&&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing,
&&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing};
// 1947 n = n - 1
N = N - 1;
// 1948 active regs = active regs - 1
ACTIVEREGS = ACTIVEREGS - 1;
// 1949 monitor (v, "Hazard") %if diag&4 # 0
if (DIAG & 4 == 0) goto L_010D;
MONITOR(V, _imp_str_literal_size(15, "Hazard"));
L_010D:;
// 1950 -> s(v_form&7)
S_line = __LINE__;
S_file = __FILE__;
S_index = V->FORM & 7;
goto case_S_dispatch;
// 1951 s(constant):
case_S_0:;
// 1952 s(v in rec):
case_S_5:;
// 1953 s(avin rec):
case_S_6:;
// 1954 s(a in rec):
case_S_7:;
// 1955 abort (4)
ABORT(4);
// 1956 s(v in s):
case_S_2:;
// 1957 s(avin s):
case_S_3:;
// 1958 s(a in s):
case_S_4:;
// 1959 v_form = v_form+3; v_extra = temp_disp; v_base = local
V->FORM = V->FORM + 3;
V->EXTRA = TEMP.DISP;
V->BASE = LOCAL;
// 1960 %return
return;
// 1961 s(v in r):
case_S_1:;
// 1962 v_form = v in s; v_disp = temp_disp; v_base = local
V->FORM = 2;
V->DISP = TEMP.DISP;
V->BASE = LOCAL;
// 1963 %end
return;
case_S_dispatch:
if (S_index < 0 || S_index > 7)
_imp_signalf(6, 3, S_index, "->S(%d) out of bounds at %s line %d", S_index, S_file, S_line);
goto *S[S_index - 0];
case_S_missing:
_imp_signalf(8, 2, S_index, "switch jump to undefined label S(%d): at %s line %d", S_index, S_file, S_line);
} /* end of MOD */
// 1964
// 1965 %routine SET TEMP (%integer size)
void SETTEMP(int SIZE) {
// 1966 frame = frame-(size)&(\(size-1))
FRAME = FRAME - (SIZE & ~(SIZE - 1));
// 1967 temp = 0
TEMP = (struct STACKFM){0};
// 1968 temp_base = local; temp_disp = frame
TEMP.BASE = LOCAL;
TEMP.DISP = FRAME;
// 1969 temp_type = integers; temp_form = v in s
TEMP.TYPE = 16;
TEMP.FORM = 2;
// 1970 op = movl; op = movd %if size = 8
OP = 8968;
if (SIZE != 8) goto L_010F;
OP = 12;
L_010F:;
// 1971 %end
return;
} /* end of SETTEMP */
// 1972
// 1973 mon reg ("Hazard", reg) %if diag&4 # 0
if (DIAG & 4 == 0) goto L_0110;
MONREG(_imp_str_literal_size(20, "Hazard"), REG);
L_0110:;
// 1974 n = activity(reg)
N = ACTIVITY[REG];
// 1975 %if n <= 0 %start
if (N > 0) goto L_0111;
// 1976 %return %if reg < fpr0
if (REG >= 18) goto L_0112;
return;
L_0112:;
// 1977 reg = (reg-fpr0)<<1+r0
REG = (REG - 18 << 1) + 1;
// 1978 hazard (reg); hazard (reg+1)
HAZARD(REG);
HAZARD(REG + 1);
// 1979 %return
return;
// 1980 %finish
L_0111:;
// 1981 %if indx(reg) # 0 %start; ! Reg in use as index
if (INDX[REG - 1] == 0) goto L_0113;
// 1982 p == using_link
P = (struct DFM *)USING.LINK;
// 1983 %while p ## null %cycle
L_0114:;
if (_imp_ADDR((void *)(P)) == _imp_ADDR((void *)(NULL))) goto L_0115;
// 1984 s == p_d
S = (struct STACKFM *)P->D;
// 1985 %if s_flags&indexed # 0 %and s_index = reg %start
if (S->FLAGS & 1 == 0) goto L_0116;
if (S->INDEX != REG) goto L_0116;
// 1986 set temp (4)
SETTEMP(4);
// 1987 op = moval; scale index (op, s)
OP = 4112;
SCALEINDEX(/*?*/ &OP, S);
// 1988 form = s_form+3; s_form = v in s
FORM = S->FORM + 3;
S->FORM = 2;
// 1989 plant2 (op, s, temp)
PLANT2(OP, S, /*?*/ &TEMP);
// 1990 s_flags = 0; s_form = form; s_disp = 0
S->FLAGS = 0;
S->FORM = FORM;
S->DISP = 0;
// 1991 s_base = local; s_extra = temp_disp
S->BASE = LOCAL;
S->EXTRA = TEMP.DISP;
// 1992 %finish
L_0116:;
// 1993 p == p_link
P = (struct DFM *)P->LINK;
// 1994 %repeat
goto L_0114;
L_0115:;
// 1995 abort (31) %if indx(reg) # 0
if (INDX[REG - 1] == 0) goto L_0117;
ABORT(31);
L_0117:;
// 1996 abort (5) %if activity(reg) # 0
if (ACTIVITY[REG] == 0) goto L_0118;
ABORT(5);
L_0118:;
// 1997 %return
return;
// 1998 %finish
L_0113:;
// 1999 activity(reg) = 0
ACTIVITY[REG] = 0;
// 2000 %if reg >= fpr0 %start
if (REG < 18) goto L_0119;
// 2001 r = (reg-fpr0)<<1+r0
R = (REG - 18 << 1) + 1;
// 2002 activity(r) = 0; activity(r+1) = 0
ACTIVITY[R] = 0;
ACTIVITY[R + 1] = 0;
// 2003 active regs = active regs-n-n
ACTIVEREGS = ACTIVEREGS - N - N;
// 2004 set temp (8)
SETTEMP(8);
// 2005 %else
goto L_011A;
L_0119:;
// 2006 %if reg <= r5 %start; !check fpr equivs
if (REG > 6) goto L_011B;
// 2007 r = (reg-r0)>>1+fpr0
R = ((unsigned int)REG - 1 >> 1) + 18;
// 2008 %if activity(r) > 0 %start
if (ACTIVITY[R] <= 0) goto L_011C;
// 2009 hazard (r); %return
HAZARD(R);
return;
// 2010 %finish
L_011C:;
// 2011 %finish
L_011B:;
// 2012 set temp (4)
SETTEMP(4);
// 2013 %finish
L_011A:;
// 2014 plant2 (op, regv(reg), temp)
PLANT2(OP, /*?*/ ®V[REG - 1], /*?*/ &TEMP);
// 2015
// 2016 p == using_link
P = (struct DFM *)USING.LINK;
// 2017 %while p ## null %cycle
L_011D:;
if (_imp_ADDR((void *)(P)) == _imp_ADDR((void *)(NULL))) goto L_011E;
// 2018 mod (p_d) %if p_d_base = reg
if (P->D->BASE != REG) goto L_011F;
MOD(P->D);
L_011F:;
// 2019 p == p_link
P = (struct DFM *)P->LINK;
// 2020 %repeat
goto L_011D;
L_011E:;
// 2021 abort (5) %if n # 0
if (N == 0) goto L_0120;
ABORT(5);
L_0120:;
// 2022 %end
return;
} /* end of HAZARD */
// 2023
// 2024 %integer %function REGISTER (%integer pair)
int REGISTER(int PAIR) {
// 2025 !returns a suitable register
// 2026 %integer r
int R;
// 2027 %integer worstn, worstr, worstu
int WORSTN;
int WORSTR;
int WORSTU;
// 2028
// 2029 worstn = 100; worstu = ca
WORSTN = 100;
WORSTU = CA;
// 2030
// 2031 %for r = r10, -1, r1 %cycle
// %for R = 11, -1, 2 %cycle
{
R = 12;
L_0121:
if (R == 2) goto L_0122;
R -= 1;
// 2032 %if activity(r) = 0 = activity(r+pair) %start; !not being used
{
// Double-sided test on 0 (Part I)
int tmp;
if (ACTIVITY[R] != (tmp = 0)) goto L_0124;
// Double-sided test on 0 (Part II)
if (tmp != ACTIVITY[R + PAIR]) goto L_0124;
}
// 2033 used(r) = ca; %result = r
USED[R] = CA;
return R;
// 2034 %else %if 0 < activity(r) < worstn
L_0124:;
{
// Double-sided test on ACTIVITY[R] (Part I)
int tmp;
if (0 >= (tmp = ACTIVITY[R])) goto L_0125;
// Double-sided test on ACTIVITY[R] (Part II)
if (tmp >= WORSTN) goto L_0125;
}
// 2035 worstn = activity(r); worstr = r
WORSTN = ACTIVITY[R];
WORSTR = R;
// 2036 worstu = used(r)
WORSTU = USED[R];
// 2037 %else %if activity(r) = worstn %and used(r) < worstu
goto L_0126;
L_0125:;
if (ACTIVITY[R] != WORSTN) goto L_0127;
if (USED[R] >= WORSTU) goto L_0127;
// 2038 worstr = r; worstu = used(r)
WORSTR = R;
WORSTU = USED[R];
// 2039 %finish
L_0127:;
L_0126:;
// 2040 %repeat
goto L_0121;
}
L_0122:;
// 2041
// 2042 hazard (worstr)
HAZARD(WORSTR);
// 2043 used(worstr) = ca
USED[WORSTR] = CA;
// 2044 %result = worstr
return WORSTR;
// 2045 %end
} /* end of REGISTER */
// 2046
// 2047 %integer %function FPR
int FPR(void) {
// 2048 %own %integer next = fpr4+1
static int NEXT = 21;
// 2049 %result = fpr0 %if activity(r0) = 0 = activity(r1)
{
// Double-sided test on 0 (Part I)
int tmp;
if (ACTIVITY[1] != (tmp = 0)) goto L_0128;
// Double-sided test on 0 (Part II)
if (tmp != ACTIVITY[2]) goto L_0128;
}
return 18;
L_0128:;
// 2050 %result = fpr2 %if activity(r2) = 0 = activity(r3)
{
// Double-sided test on 0 (Part I)
int tmp;
if (ACTIVITY[3] != (tmp = 0)) goto L_0129;
// Double-sided test on 0 (Part II)
if (tmp != ACTIVITY[4]) goto L_0129;
}
return 19;
L_0129:;
// 2051 %result = fpr4 %if activity(r4) = 0 = activity(r5)
{
// Double-sided test on 0 (Part I)
int tmp;
if (ACTIVITY[5] != (tmp = 0)) goto L_012A;
// Double-sided test on 0 (Part II)
if (tmp != ACTIVITY[6]) goto L_012A;
}
return 20;
L_012A:;
// 2052 next = fpr4+1 %if next = fpr0
if (NEXT != 18) goto L_012B;
NEXT = 20 + 1;
L_012B:;
// 2053 next = next-1
NEXT = NEXT - 1;
// 2054 hazard (next)
HAZARD(NEXT);
// 2055 %result = next
return NEXT;
// 2056 %end
} /* end of FPR */
// 2057
// 2058 !descriptor processing
// 2059
// 2060 %record(stackfm) %map DESCRIPTOR
struct STACKFM *DESCRIPTOR(void)
{
// 2061 %record(dfm) %name d
struct DFM *D;
// 2062 %record(stackfm) %name v
struct STACKFM *V;
// 2063 v == desc asl; abort (6) %if v == null
V = (struct STACKFM *)DESCASL;
if (_imp_ADDR((void *)(V)) != _imp_ADDR((void *)(NULL))) goto L_012C;
ABORT(6);
L_012C:;
// 2064 d == d asl; abort (7) %if d == null
D = (struct DFM *)DASL;
if (_imp_ADDR((void *)(D)) != _imp_ADDR((void *)(NULL))) goto L_012D;
ABORT(7);
L_012D:;
// 2065 desc asl == v_link; v = 0; v_link == null
DESCASL = (struct STACKFM *)V->LINK;
*V = (struct STACKFM){0};
V->LINK = (struct STACKFM *)NULL;
// 2066 d asl == d_link
DASL = (struct DFM *)D->LINK;
// 2067 d_link == using_link
D->LINK = (struct DFM *)USING.LINK;
// 2068 using_link == d
USING.LINK = (struct DFM *)D;
// 2069 d_d == v
D->D = (struct DFM *)V;
// 2070 abort (8) %if stp >= max depth
if (STP < 16) goto L_012E;
ABORT(8);
L_012E:;
// 2071 stp = stp + 1
STP = STP + 1;
// 2072 stacked(stp) == v
STACKED[STP - 1] = (struct STACKFM *)V;
// 2073 %result == v
return V;
// 2074 %end
} /* end of DESCRIPTOR */
// 2075
// 2076 %routine DROP (%record(stackfm) %name d)
void DROP(struct STACKFM * D) {
// 2077 %record(dfm) %name p, q
struct DFM *P;
struct DFM *Q;
// 2078 monitor (d, "Drop") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_012F;
MONITOR(D, _imp_str_literal_size(15, "Drop"));
L_012F:;
// 2079 p == using
P = (struct DFM *)/*?*/ &USING;
// 2080 %cycle
L_0130:;
// 2081 q == p_link
Q = (struct DFM *)P->LINK;
// 2082 abort (9) %if q == null
if (_imp_ADDR((void *)(Q)) != _imp_ADDR((void *)(NULL))) goto L_0131;
ABORT(9);
L_0131:;
// 2083 %exit %if q_d == d
if (_imp_ADDR((void *)(Q->D)) != _imp_ADDR((void *)(D))) goto L_0132;
goto L_0133;
L_0132:;
// 2084 p == q
P = (struct DFM *)Q;
// 2085 %repeat
goto L_0130;
L_0133:;
// 2086 p_link == q_link
P->LINK = (struct DFM *)Q->LINK;
// 2087 q_link == d asl
Q->LINK = (struct DFM *)DASL;
// 2088 d asl == q
DASL = (struct DFM *)Q;
// 2089 d_link == desc asl
D->LINK = (struct STACKFM *)DESCASL;
// 2090 desc asl == d
DESCASL = (struct STACKFM *)D;
// 2091 %end
return;
} /* end of DROP */
// 2092
// 2093 %routine VSTACK (%record(varfm) %name v)
void VSTACK(struct VARFM * V) {
// 2094 %record(stackfm) %name x
struct STACKFM *X;
// 2095 x == descriptor
X = (struct STACKFM *)DESCRIPTOR();
// 2096 x_type = v_type
X->TYPE = V->TYPE;
// 2097 x_form = v_form&(15!arrayname bit!proc bit)
X->FORM = V->FORM & (15 | 64 | 16);
// 2098 x_base = v_base
X->BASE = V->BASE;
// 2099 x_disp = v_disp
X->DISP = V->DISP;
// 2100 x_format = v_format
X->FORMAT = V->FORMAT;
// 2101 x_extra = v_extra
X->EXTRA = V->EXTRA;
// 2102 x_length = v_length
X->LENGTH = V->LENGTH;
// 2103 x_header = v_header
X->HEADER = V->HEADER;
// 2104 x_mantissa = v_zeroad; ! Zero-address for C-B arrays
X->MANTISSA = V->ZEROAD;
// 2105 x_mantissa = v_flags %if v_flags # 0; ! or prim index
if (V->FLAGS == 0) goto L_0134;
X->MANTISSA = V->FLAGS;
L_0134:;
// 2106 x_xno = v_xno
X->XNO = V->XNO;
// 2107 monitor (x, "Vstack") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_0135;
MONITOR(X, _imp_str_literal_size(15, "Vstack"));
L_0135:;
// 2108 %end
return;
} /* end of VSTACK */
// 2109
// 2110 %routine DSTACK (%record(stackfm) %name v)
void DSTACK(struct STACKFM * V) {
// 2111 %record(stackfm) %name t
struct STACKFM *T;
// 2112 t == descriptor
T = (struct STACKFM *)DESCRIPTOR();
// 2113 t = v
*T = *V;
// 2114 monitor (t, "Dstack") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_0136;
MONITOR(T, _imp_str_literal_size(15, "Dstack"));
L_0136:;
// 2115 %end
return;
} /* end of DSTACK */
// 2116
// 2117 %routine GET REAL
void GETREAL(void) {
// 2118 %long %real p, val
double P;
double VAL;
// 2119 %record(stackfm) %name v
struct STACKFM *V;
// 2120 %integer n, s
int N;
int S;
// 2121 %on 1 %start; ! real overflow!
if (!_imp_on_event(1)) goto L_0137;
// 2122 error ('*', "real value too large")
ERROR(42, _imp_str_literal_size(127, "real value too large"));
// 2123 val = 0; -> out
VAL = 0;
goto U_1000;
// 2124 %finish
L_0137:;
// 2125 n = getword; get (discard)
N = GETWORD();
GET(/*?*/ &DISCARD);
// 2126 val = 0
VAL = 0;
// 2127 %cycle
L_0138:;
// 2128 get (s)
GET(/*?*/ &S);
// 2129 -> power %if s = '@'
if (S != 64) goto L_0139;
goto U_1001;
L_0139:;
// 2130 %exit %if s = '.'
if (S != 46) goto L_013A;
goto L_013B;
L_013A:;
// 2131 val = val*10+(s-'0')
VAL = VAL * 10 + (S - 48);
// 2132 n = n-1
N = N - 1;
// 2133 -> out %if n = 0
if (N != 0) goto L_013C;
goto U_1000;
L_013C:;
// 2134 %repeat
goto L_0138;
L_013B:;
// 2135 p = 1
P = 1;
// 2136 %cycle
L_013D:;
// 2137 n = n - 1; -> out %if n = 0
N = N - 1;
if (N != 0) goto L_013E;
goto U_1000;
L_013E:;
// 2138 get (s)
GET(/*?*/ &S);
// 2139 -> power %if s = '@'
if (S != 64) goto L_013F;
goto U_1001;
L_013F:;
// 2140 p = p/10
P = (double)(P / 10);
// 2141 val = val + (s-'0')*p
VAL = VAL + (S - 48) * P;
// 2142 %repeat
goto L_013D;
// 2143 power:
U_1001:;
// 2144 n = getword; ! Was GETLONG!!!!
N = GETWORD();
// 2145 val = val*10\n
VAL = VAL * (_imp_REXP(10, N));
// 2146 out:
U_1000:;
// 2147 v == descriptor
V = (struct STACKFM *)DESCRIPTOR();
// 2148 v_type = reall; v_form = constant
V->TYPE = 36;
V->FORM = 0;
// 2149 v_lrval = val
V->LRVAL = VAL;
// 2150 %end
return;
} /* end of GETREAL */
// 2151
// 2152 %routine CSTACK (%integer value)
void CSTACK(int VALUE) {
// 2153 %record(stackfm) %name v
struct STACKFM *V;
// 2154 v == descriptor
V = (struct STACKFM *)DESCRIPTOR();
// 2155 v_disp = value
V->DISP = VALUE;
// 2156 v_type = integers
V->TYPE = 16;
// 2157 v_form = constant
V->FORM = 0;
// 2158 monitor (v, "Cstack") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_0140;
MONITOR(V, _imp_str_literal_size(15, "Cstack"));
L_0140:;
// 2159 %end
return;
} /* end of CSTACK */
// 2160
// 2161 %routine LSTACK (%integer disp)
void LSTACK(int DISP) {
// 2162 %record(stackfm) %name v
struct STACKFM *V;
// 2163 v == descriptor
V = (struct STACKFM *)DESCRIPTOR();
// 2164 v_disp = disp
V->DISP = DISP;
// 2165 v_base = local
V->BASE = LOCAL;
// 2166 v_type = integers
V->TYPE = 16;
// 2167 v_form = v in s
V->FORM = 2;
// 2168 monitor (v, "Lstack") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_0141;
MONITOR(V, _imp_str_literal_size(15, "Lstack"));
L_0141:;
// 2169 lhs == v
LHS = (struct STACKFM *)V;
// 2170 %end
return;
} /* end of LSTACK */
// 2171
// 2172 %record(stackfm) %map TEMP (%integer size)
struct STACKFM *TEMP(int SIZE)
{
// 2173 %record(stackfm) %name d
struct STACKFM *D;
// 2174 d == descriptor
D = (struct STACKFM *)DESCRIPTOR();
// 2175 frame = (frame-size)&(\3)
FRAME = FRAME - SIZE & (~3);
// 2176 d_base = local; d_disp = frame
D->BASE = LOCAL;
D->DISP = FRAME;
// 2177 d_type = integers; d_form = v in s
D->TYPE = 16;
D->FORM = 2;
// 2178 %result == d
return D;
// 2179 %end
} /* end of TEMP */
// 2180
// 2181 %record(stackfm) %map LITERAL (%integer n)
struct STACKFM *LITERAL(int N)
{
// 2182 %record(stackfm) %name d
struct STACKFM *D;
// 2183 d == descriptor
D = (struct STACKFM *)DESCRIPTOR();
// 2184 d_base = 0; d_disp = n
D->BASE = 0;
D->DISP = N;
// 2185 d_type = integers; d_form = constant
D->TYPE = 16;
D->FORM = 0;
// 2186 %result == d
return D;
// 2187 %end
} /* end of LITERAL */
// 2188
// 2189 %routine SET LHS
void SETLHS(void) {
// 2190 lhs == stacked(stp)
LHS = (struct STACKFM *)STACKED[STP - 1];
// 2191 monitor (lhs, "Set lhs") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_0142;
MONITOR(LHS, _imp_str_literal_size(15, "Set lhs"));
L_0142:;
// 2192 %end
return;
} /* end of SETLHS */
// 2193
// 2194 %routine SET BOTH
void SETBOTH(void) {
// 2195 abort (10) %if stp <= 1
if (STP > 1) goto L_0143;
ABORT(10);
L_0143:;
// 2196 lhs == stacked(stp-1)
LHS = (struct STACKFM *)STACKED[STP - 1 - 1];
// 2197 rhs == stacked(stp )
RHS = (struct STACKFM *)STACKED[STP - 1];
// 2198 %if diag&1 # 0 %start
if (DIAG & 1 == 0) goto L_0144;
// 2199 monitor (lhs, "Both lhs")
MONITOR(LHS, _imp_str_literal_size(15, "Both lhs"));
// 2200 monitor (rhs, " rhs")
MONITOR(RHS, _imp_str_literal_size(15, " rhs"));
// 2201 %finish
L_0144:;
// 2202 %end
return;
} /* end of SETBOTH */
// 2203
// 2204 %routine POP LHS
void POPLHS(void) {
// 2205 abort (11) %if stp <= 0
if (STP > 0) goto L_0145;
ABORT(11);
L_0145:;
// 2206 stp = stp - 1
STP = STP - 1;
// 2207 lhs == stacked(stp+1)
LHS = (struct STACKFM *)STACKED[STP + 1 - 1];
// 2208 monitor (lhs, "Pop lhs") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_0146;
MONITOR(LHS, _imp_str_literal_size(15, "Pop lhs"));
L_0146:;
// 2209 %end
return;
} /* end of POPLHS */
// 2210
// 2211 %routine POP DROP
void POPDROP(void) {
// 2212 %integer d
int D;
// 2213 %record(stack fm) %name t
struct STACKFM *T;
// 2214 abort (12) %if stp <= 0
if (STP > 0) goto L_0147;
ABORT(12);
L_0147:;
// 2215 stp = stp - 1
STP = STP - 1;
// 2216 t == stacked(stp+1)
T = (struct STACKFM *)STACKED[STP + 1 - 1];
// 2217 monitor (t, "Pop drop") %if diag&1 # 0
if (DIAG & 1 == 0) goto L_0148;
MONITOR(T, _imp_str_literal_size(15, "Pop drop"));
L_0148:;
// 2218 d = diag; diag = 0; drop (t); diag = d
D = DIAG;
DIAG = 0;
DROP(T);
DIAG = D;
// 2219 %end
return;
} /* end of POPDROP */
// 2220
// 2221 %routine MACHINE CODE
void MACHINECODE(void) {
// 2222 %integer sym, n, j
int SYM;
int N;
int J;
// 2223 %integer opcode, operands, flags
int OPCODE;
int OPERANDS;
int FLAGS;
// 2224 %string(6) optext
_imp_string6 OPTEXT;
// 2225
// 2226 %const %integer %array code (0 : 511) =
const int CODE[512] = {
-2028848911, -211812005, -2028848461, -228589221, -2001548617, -1189085182, -2001024329, -1205862398,
-1953804084, 1799356444, -1953804020, 1262485531, -1905927613, 947913290, -1760899355, 239075353,
-1670834472, 100663296, -1640295101, 964690570, -1625535828, -601882621, -1625531677, 801153610,
-1625526132, -1707081703, -1625526121, -1690304495, -1625525460, 1010827290, -1521970958, 207618129,
-1521970953, 224395345, -1518688158, -1625292799, -1518688148, -551550973, -1518688143, 2132803588,
-1518688137, 1059061762, -1468543259, 255852569, -1424874255, -197132245, -1424873774, -180355029,
-1417079080, 117440512, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 69763, -513801909, 69779, -530579125,
70228, 50331648, 70274, 287309829, 70295, 824180742, 70403, 471859205,
70419, 488636421, 71299, 195048089, 73987, -343931317, 74003, -360708533,
78320, 387973121, 78498, 371195905, 82480, 16777216, 86249, 33554432,
86260, 67108864, 86690, 83886080, 92419, -67108864, 2200706, -1652552631,
2200708, 1870662948, 2200710, 1333791963, 2200716, -243266341, 2200727, 1031802002,
2202403, -666894309, 2217292, 2019557593, 2217296, -121593263, 2217297, 2036334881,
2232483, -446693045, 2232499, -480247477, 2232995, -463470261, 2233011, -497024693,
2236012, 320864261, 2237681, 404750341, 2238162, 337641477, 2240194, -1824522231,
2240204, -750780389, 2240215, -1287651310, 2242691, -381681621, 2242707, -398458837,
2242801, 354418693, 2243251, 421527557, 2244849, 304087045, 2249858, 270532613,
2249879, 807403526, 2271717, -1121976318, 2271723, -1138753534, 2271731, -1105199102,
2271733, -1088421886, 2275970, -1809842175, 2275980, -736100349, 2275985, 2082471940,
2275991, -1272971262, 2276930, -1858076663, 2276932, 1900019748, 2276934, 1363148827,
2276940, -784334821, 2276950, -327154101, 2276951, -1321205742, 2301090, -1759510527,
2301100, -685768701, 2301111, -1222639614, 2305808, 666935946, 2333046, 2071987939,
2342636, 2055211227, 2353878, -293599669, 2428372, 0, 2474146, -1776287743,
2474156, -702545917, 2474167, -1239416830, 2474678, -260046245, 2573475, 979370065,
2597458, -616562661, 2606850, -1874853879, 2606852, 1883242532, 2606854, 1346371611,
2606860, -801112037, 2606864, 878706762, 2606865, 2101346340, 2606871, -1337982958,
2611794, -633339877, 2612688, 633381514, 2704978, -1172307966, 2770636, -1671429927,
2790179, -650117093, 2799171, 996147281, 2840258, -1793064959, 2840260, 1931476996,
2840262, 1394606083, 2840268, -719323133, 2840279, -1256194046, 70455081, 1480589330,
70457458, -2143289335, 70457459, -2124414903, 70457522, 1614807076, 70457523, 1633681700,
70457586, 1077936155, 70457587, 1094713371, 70457778, -1069547493, 70457779, -1050672933,
70457908, 545260170, 70457910, 566272650, 70458130, -1606418414, 70458131, -1587543918,
71439529, -413138613, 71456425, -429915829, 71605877, 505413637, 71621269, 438304773,
71668850, -1975517175, 71668851, -1956642743, 71669170, -901775333, 71669171, -882900773,
71669522, -1438646254, 71669523, -1419771758, 71685234, -2009071607, 71685554, -935329765,
71685555, -916455205, 71685906, -1472200686, 71685907, -1453326190, 71769717, 455081989,
71784117, 522190853, 72464839, -96468983, 72464851, -79691765, 72471778, -1889533879,
72471788, -815791909, 72471799, -1352662894, 72861843, 694157386, 72861845, 765465674,
72862260, 931136138, 72862614, -310376885, 72924723, 895483978, 73160836, 1816133665,
73160838, 1279262745, 73160844, -1740636135, 73160855, -1723858927, 73160898, 1749024780,
73160902, 1983905820, 73160908, 1782579228, 73160919, 1765802004, 73160962, 1212153867,
73160964, 1447034915, 73160972, 1245708315, 73160983, 1228931091, 73161154, -163577845,
73161156, 1849688099, 73161158, 1312817179, 73161168, -111148973, 73161175, -146800621,
73161292, 912261322, 73161299, 142606986, 73161300, 614470730, 73161392, 159384202,
73161424, 648025162, 73161506, 859832330, 73161508, 1832910874, 73161516, 843055130,
73654386, -2042626039, 73785459, -2023751607, 73785522, 1715470372, 73785523, 1734344996,
73785586, 1178599451, 73785587, 1197474011, 73785778, -968884197, 73785779, -950009637,
73786130, -1505755118, 73786131, -1486880622, 74958020, 1956661004, 74958022, 1419785931,
75324310, -276822453, 79173880, 180467419, 83019234, -1841299447, 83019244, -767557605,
83019255, -1304428526, 83219571, -1990197175, 83369250, -1908408311, 83369252, 1916796964,
83369254, 1379926043, 83369260, -834666469, 83369271, -1371537390, 83419234, -1639972839,
83419244, -566231013, 83419249, 2118123548, 83419255, 1044381722, 83419283, 677380170,
83419285, 748688458, 83419843, 784376394, 83605618, -2076180471, 83605619, -2057306039,
83605682, 1681915940, 83605683, 1700790564, 83605746, 1145045019, 83605747, 1163919579,
83605938, -1002438629, 83605939, -983564069, 83606290, -1539309550, 83606291, -1520435054,
86555492, 1969225812, 86555494, 1432354899, 86758732, -585105405, 86758738, -1155530750,
89296387, 713032266, 89722371, 729809482, 89886834, -2109734903, 89886835, -2090860471,
89886898, 1648361508, 89886899, 1667236132, 89886962, 1111490587, 89886963, 1130365147,
89887154, -1035993061, 89887155, -1017118501, 89887284, 578814602, 89887286, 599827082,
89887506, -1572863982, 89887507, -1553989486, 94949490, -1941962743, 94949491, -1923088311,
94949810, -868220901, 94949811, -849346341, 94950162, -1405091822, 94950163, -1386217326};
// 2227+ 16_871238F1,16_F360015B, 16_87123AB3,16_F260015B,
// 2228+ 16_88B2CAB7,16_B9200002, 16_88BACAB7,16_B8200002,
// 2229+ 16_8B8B50CC,16_6B40001C, 16_8B8B510C,16_4B40001B,
// 2230+ 16_8E65DA43,16_3880024A, 16_970ACEE5,16_0E400019,
// 2231+ 16_9C6916D8,16_06000000, 16_9E3B1543,16_3980028A,
// 2232+ 16_9F1C4AAC,16_DC200003, 16_9F1C5AE3,16_2FC0A24A,
// 2233+ 16_9F1C708C,16_9A400019, 16_9F1C7097,16_9B400011,
// 2234+ 16_9F1C732C,16_3C40001A, 16_A54890F2,16_0C600051,
// 2235+ 16_A54890F7,16_0D600051, 16_A57AA862,16_9F200001,
// 2236+ 16_A57AA86C,16_DF200003, 16_A57AA871,16_7F200004,
// 2237+ 16_A57AA877,16_3F200002, 16_A877CEE5,16_0F400019,
// 2238+ 16_AB1224F1,16_F440002B, 16_AB1226D2,16_F540002B,
// 2239+ 16_AB8916D8,16_07000000, 16_00000000,16_00000000,
// 2240+ 16_00000000,16_00000000, 16_00000000,16_00000000,
// 2241+ 16_00000000,16_00000000, 16_00000000,16_00000000,
// 2242+ 16_00000000,16_00000000, 16_00000000,16_00000000,
// 2243+ 16_00000000,16_00000000, 16_00000000,16_00000000,
// 2244+ 16_00000000,16_00000000, 16_00000000,16_00000000,
// 2245+ 16_00000000,16_00000000, 16_00000000,16_00000000,
// 2246+ 16_00011083,16_E160014B, 16_00011093,16_E060014B,
// 2247+ 16_00011254,16_03000000, 16_00011282,16_11200005,
// 2248+ 16_00011297,16_31200006, 16_00011303,16_1C200005,
// 2249+ 16_00011313,16_1D200005, 16_00011683,16_0BA03299,
// 2250+ 16_00012103,16_EB80064B, 16_00012113,16_EA80064B,
// 2251+ 16_000131F0,16_17200001, 16_000132A2,16_16200001,
// 2252+ 16_00014230,16_01000000, 16_000150E9,16_02000000,
// 2253+ 16_000150F4,16_04000000, 16_000152A2,16_05000000,
// 2254+ 16_00016903,16_FC000000, 16_00219482,16_9D800C49,
// 2255+ 16_00219484,16_6F800D24, 16_00219486,16_4F800CDB,
// 2256+ 16_0021948C,16_F1800CDB, 16_00219497,16_3D800C92,
// 2257+ 16_00219B23,16_D840001B, 16_0021D54C,16_786000D9,
// 2258+ 16_0021D550,16_F8C0A251, 16_0021D551,16_79600121,
// 2259+ 16_002210A3,16_E560014B, 16_002210B3,16_E360014B,
// 2260+ 16_002212A3,16_E460014B, 16_002212B3,16_E260014B,
// 2261+ 16_00221E6C,16_13200005, 16_002224F1,16_18200005,
// 2262+ 16_002226D2,16_14200005, 16_00222EC2,16_93400009,
// 2263+ 16_00222ECC,16_D340001B, 16_00222ED7,16_B3400012,
// 2264+ 16_00223883,16_E940002B, 16_00223893,16_E840002B,
// 2265+ 16_002238F1,16_15200005, 16_00223AB3,16_19200005,
// 2266+ 16_002240F1,16_12200005, 16_00225482,16_10200005,
// 2267+ 16_00225497,16_30200006, 16_0022A9E5,16_BD200002,
// 2268+ 16_0022A9EB,16_BC200002, 16_0022A9F3,16_BE200002,
// 2269+ 16_0022A9F5,16_BF200002, 16_0022BA82,16_94200001,
// 2270+ 16_0022BA8C,16_D4200003, 16_0022BA91,16_7C200004,
// 2271+ 16_0022BA97,16_B4200002, 16_0022BE42,16_91400009,
// 2272+ 16_0022BE44,16_71400024, 16_0022BE46,16_5140001B,
// 2273+ 16_0022BE4C,16_D140001B, 16_0022BE56,16_EC80064B,
// 2274+ 16_0022BE57,16_B1400012, 16_00231CA2,16_97200001,
// 2275+ 16_00231CAC,16_D7200003, 16_00231CB7,16_B7200002,
// 2276+ 16_00232F10,16_27C0A28A, 16_00239976,16_7B8006E3,
// 2277+ 16_0023BEEC,16_7A8008DB, 16_0023EAD6,16_EE80064B,
// 2278+ 16_00250DD4,16_00000000, 16_0025C0A2,16_96200001,
// 2279+ 16_0025C0AC,16_D6200003, 16_0025C0B7,16_B6200002,
// 2280+ 16_0025C2B6,16_F080025B, 16_002744A3,16_3A600051,
// 2281+ 16_0027A252,16_DB40001B, 16_0027C702,16_90400009,
// 2282+ 16_0027C704,16_70400024, 16_0027C706,16_5040001B,
// 2283+ 16_0027C70C,16_D040001B, 16_0027C710,16_3460004A,
// 2284+ 16_0027C711,16_7D400024, 16_0027C717,16_B0400012,
// 2285+ 16_0027DA52,16_DA40001B, 16_0027DDD0,16_25C0A28A,
// 2286+ 16_00294652,16_BA200002, 16_002A46CC,16_9C6000D9,
// 2287+ 16_002A9323,16_D940001B, 16_002AB643,16_3B600051,
// 2288+ 16_002B56C2,16_95200001, 16_002B56C4,16_73200004,
// 2289+ 16_002B56C6,16_53200003, 16_002B56CC,16_D5200003,
// 2290+ 16_002B56D7,16_B5200002, 16_04330F29,16_58400012,
// 2291+ 16_04331872,16_80400009, 16_04331873,16_81600049,
// 2292+ 16_043318B2,16_60400024, 16_043318B3,16_61600124,
// 2293+ 16_043318F2,16_4040001B, 16_043318F3,16_4140001B,
// 2294+ 16_043319B2,16_C040001B, 16_043319B3,16_C16000DB,
// 2295+ 16_04331A34,16_2080028A, 16_04331A36,16_21C0A28A,
// 2296+ 16_04331B12,16_A0400012, 16_04331B13,16_A1600092,
// 2297+ 16_044214A9,16_E760014B, 16_044256A9,16_E660014B,
// 2298+ 16_04449E75,16_1E200005, 16_0444DA95,16_1A200005,
// 2299+ 16_04459472,16_8A400009, 16_04459473,16_8B600049,
// 2300+ 16_044595B2,16_CA40001B, 16_044595B3,16_CB6000DB,
// 2301+ 16_04459712,16_AA400012, 16_04459713,16_AB600092,
// 2302+ 16_0445D472,16_88400009, 16_0445D5B2,16_C840001B,
// 2303+ 16_0445D5B3,16_C96000DB, 16_0445D712,16_A8400012,
// 2304+ 16_0445D713,16_A9600092, 16_04471E75,16_1B200005,
// 2305+ 16_044756B5,16_1F200005, 16_0451B9C7,16_FA400009,
// 2306+ 16_0451B9D3,16_FB40000B, 16_0451D4E2,16_8F600049,
// 2307+ 16_0451D4EC,16_CF6000DB, 16_0451D4F7,16_AF600092,
// 2308+ 16_0457C893,16_2960004A, 16_0457C895,16_2DA0144A,
// 2309+ 16_0457CA34,16_3780028A, 16_0457CB96,16_ED80064B,
// 2310+ 16_0458BE33,16_3560004A, 16_045C5884,16_6C400021,
// 2311+ 16_045C5886,16_4C400019, 16_045C588C,16_98400019,
// 2312+ 16_045C5897,16_99400011, 16_045C58C2,16_6840000C,
// 2313+ 16_045C58C6,16_7640001C, 16_045C58CC,16_6A40001C,
// 2314+ 16_045C58D7,16_69400014, 16_045C5902,16_4840000B,
// 2315+ 16_045C5904,16_56400023, 16_045C590C,16_4A40001B,
// 2316+ 16_045C5917,16_49400013, 16_045C59C2,16_F640000B,
// 2317+ 16_045C59C4,16_6E400023, 16_045C59C6,16_4E40001B,
// 2318+ 16_045C59D0,16_F9600053, 16_045C59D7,16_F7400013,
// 2319+ 16_045C5A4C,16_366000CA, 16_045C5A53,16_0880028A,
// 2320+ 16_045C5A54,16_24A0144A, 16_045C5AB0,16_0980028A,
// 2321+ 16_045C5AD0,16_26A0144A, 16_045C5B22,16_3340000A,
// 2322+ 16_045C5B24,16_6D40001A, 16_045C5B2C,16_3240001A,
// 2323+ 16_0463E072,16_86400009, 16_0465E073,16_87600049,
// 2324+ 16_0465E0B2,16_66400024, 16_0465E0B3,16_67600124,
// 2325+ 16_0465E0F2,16_4640001B, 16_0465E0F3,16_476000DB,
// 2326+ 16_0465E1B2,16_C640001B, 16_0465E1B3,16_C76000DB,
// 2327+ 16_0465E312,16_A6400012, 16_0465E313,16_A7600092,
// 2328+ 16_0477C4C4,16_74A0470C, 16_0477C4C6,16_54A036CB,
// 2329+ 16_047D5B96,16_EF80064B, 16_04B818F8,16_0AC1B6DB,
// 2330+ 16_04F2C5E2,16_92400009, 16_04F2C5EC,16_D240001B,
// 2331+ 16_04F2C5F7,16_B2400012, 16_04F5D473,16_89600049,
// 2332+ 16_04F81D22,16_8E400009, 16_04F81D24,16_72400024,
// 2333+ 16_04F81D26,16_5240001B, 16_04F81D2C,16_CE40001B,
// 2334+ 16_04F81D37,16_AE400012, 16_04F8E062,16_9E400019,
// 2335+ 16_04F8E06C,16_DE40001B, 16_04F8E071,16_7E40001C,
// 2336+ 16_04F8E077,16_3E40001A, 16_04F8E093,16_2860004A,
// 2337+ 16_04F8E095,16_2CA0144A, 16_04F8E2C3,16_2EC0A24A,
// 2338+ 16_04FBB872,16_84400009, 16_04FBB873,16_85600049,
// 2339+ 16_04FBB8B2,16_64400024, 16_04FBB8B3,16_65600124,
// 2340+ 16_04FBB8F2,16_4440001B, 16_04FBB8F3,16_456000DB,
// 2341+ 16_04FBB9B2,16_C440001B, 16_04FBB9B3,16_C56000DB,
// 2342+ 16_04FBBB12,16_A4400012, 16_04FBBB13,16_A5600092,
// 2343+ 16_0528BB64,16_75600054, 16_0528BB66,16_55600053,
// 2344+ 16_052BD54C,16_DD200003, 16_052BD552,16_BB200002,
// 2345+ 16_05528E03,16_2A80024A, 16_05590E03,16_2B80024A,
// 2346+ 16_055B9072,16_82400009, 16_055B9073,16_83600049,
// 2347+ 16_055B90B2,16_62400024, 16_055B90B3,16_63600124,
// 2348+ 16_055B90F2,16_4240001B, 16_055B90F3,16_436000DB,
// 2349+ 16_055B91B2,16_C240001B, 16_055B91B3,16_C36000DB,
// 2350+ 16_055B9234,16_2280028A, 16_055B9236,16_23C0A28A,
// 2351+ 16_055B9312,16_A2400012, 16_055B9313,16_A3600092,
// 2352+ 16_05A8D072,16_8C400009, 16_05A8D073,16_8D600049,
// 2353+ 16_05A8D1B2,16_CC40001B, 16_05A8D1B3,16_CD6000DB,
// 2354+ 16_05A8D312,16_AC400012, 16_05A8D313,16_AD600092
// 2355
// 2356 %routine MC ERROR (%string(23) text)
void MCERROR(_imp_string23 TEXT) {
// 2357 error ('*', optext.": ".text)
ERROR(42,
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &*({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ &OPTEXT,
(_imp_string *)/*?*/ _imp_str_literal_ptr(": "));
(_imp_string255 *)&tmp;
}),
(_imp_string *)/*?*/ &TEXT);
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string127 *)&tmp;
})
);
// 2358 get (sym) %while sym # ';'
L_0149:;
if (SYM == 59) goto L_014A;
GET(/*?*/ &SYM);
goto L_0149;
L_014A:;
// 2359 %end
return;
} /* end of MCERROR */
// 2360
// 2361 %integer %function FIND (%integer key)
int FIND(int KEY) {
// 2362 %integer a, b, p
int A;
int B;
int P;
// 2363 a = 0; b = 512
A = 0;
B = 512;
// 2364 %while a <= b %cycle
L_014B:;
if (A > B) goto L_014C;
// 2365 p = (a+b)>>2<<1
P = (unsigned int)A + B >> 2 << 1;
// 2366 %result = p %if code(p) = key
if (CODE[P] != KEY) goto L_014D;
return P;
L_014D:;
// 2367 %if key > code(p) %then a = p+2 %else b = p-2
if (KEY <= CODE[P]) goto L_014E;
A = P + 2;
goto L_014F;
L_014E:;
B = P - 2;
L_014F:;
// 2368 %repeat
goto L_014B;
L_014C:;
// 2369 %result = -1
return -1;
// 2370 %end
} /* end of FIND */
// 2371
// 2372 %predicate PARSED OPERAND (%integer flag)
int PARSEDOPERAND(int FLAG) {
// 2373 %byte %array oper (1 : 128)
unsigned char OPER[128];
// 2374 %integer base, disp, sign, indirect, m, p, size
int BASE;
int DISP;
int SIGN;
int INDIRECT;
int M;
int P;
int SIZE;
// 2375 %record(varfm) %name v
struct VARFM *V;
// 2376
// 2377 %predicate LITERAL (%integername n)
int LITERAL(int *N) {
// 2378 %false %unless '0' <= sym <= '7'
{
// Double-sided test on SYM (Part I)
int tmp;
if (48 > (tmp = SYM)) goto L_0123;
// Double-sided test on SYM (Part II)
if (tmp <= 55) goto L_0150;
}
L_0123:;
return 0 /*FALSE*/;
L_0150:;
// 2379 n = 0
*N = 0;
// 2380 %cycle
L_0151:;
// 2381 n = n<<3 + sym-'0'
*N = (*N << 3) + SYM - 48;
// 2382 get (sym)
GET(/*?*/ &SYM);
// 2383 %true %unless '0' <= sym <= '7'
{
// Double-sided test on SYM (Part I)
int tmp;
if (48 > (tmp = SYM)) goto L_0152;
// Double-sided test on SYM (Part II)
if (tmp <= 55) goto L_0153;
}
L_0152:;
return 1 /*TRUE*/;
L_0153:;
// 2384 %repeat
goto L_0151;
// 2385 %end
} /* end of LITERAL */
// 2386
// 2387 %predicate REG (%integername r)
int REG(int *R) {
// 2388 get (sym); !skip (
GET(/*?*/ &SYM);
// 2389 %false %unless literal (r)
if (LITERAL(R)) goto L_0154;
return 0 /*FALSE*/;
L_0154:;
// 2390 %false %unless 0 <= r <= 15
{
// Double-sided test on R (Part I)
int tmp;
if (0 > (tmp = *R)) goto L_0155;
// Double-sided test on R (Part II)
if (tmp <= 15) goto L_0156;
}
L_0155:;
return 0 /*FALSE*/;
L_0156:;
// 2391 %false %if sym # ')'
if (SYM == 41) goto L_0157;
return 0 /*FALSE*/;
L_0157:;
// 2392 get (sym)
GET(/*?*/ &SYM);
// 2393 %true
return 1 /*TRUE*/;
// 2394 %end
} /* end of REG */
// 2395
// 2396 %routine SET BYTE (%integer b)
void SETBYTE(int B) {
// 2397 p = p + 1; oper(p) = b
P = P + 1;
OPER[P - 1] = B;
// 2398 %end
return;
} /* end of SETBYTE */
// 2399
// 2400 %routine SET WORD (%integer n)
void SETWORD(int N) {
// 2401 shortinteger(addr(oper(p+1))) = n
*_imp_SHORTINTEGER(_imp_ADDR(/*?*/ &OPER[P + 1 - 1])) = N;
// 2402 p = p + 2
P = P + 2;
// 2403 %end
return;
} /* end of SETWORD */
// 2404
// 2405 %routine SET LONGWORD (%integer n)
void SETLONGWORD(int N) {
// 2406 integer(addr(oper(p+1))) = n
*_imp_INTEGER(_imp_ADDR(/*?*/ &OPER[P + 1 - 1])) = N;
// 2407 p = p + 4
P = P + 4;
// 2408 %end
return;
} /* end of SETLONGWORD */
// 2409
// 2410 p = 0
P = 0;
// 2411 indirect = 0; sign = 1
INDIRECT = 0;
SIGN = 1;
// 2412
// 2413 entry mask = entry mask ! 16_ffc
ENTRYMASK = ENTRYMASK | 4092;
// 2414
// 2415 %if sym = '@' %and flag < 5 %start
if (SYM != 64) goto L_0158;
if (FLAG >= 5) goto L_0158;
// 2416 indirect = 16_10; get (sym)
INDIRECT = 16;
GET(/*?*/ &SYM);
// 2417 %finish
L_0158:;
// 2418
// 2419 %if sym = '#' %start
if (SYM != 35) goto L_0159;
// 2420 get (sym)
GET(/*?*/ &SYM);
// 2421 sign = -1 %and get (sym) %if sym = '-'
if (SYM != 45) goto L_015A;
SIGN = -1;
GET(/*?*/ &SYM);
L_015A:;
// 2422 %false %unless literal (disp)
if (LITERAL(/*?*/ &DISP)) goto L_015B;
return 0 /*FALSE*/;
L_015B:;
// 2423 disp = disp*sign
DISP = DISP * SIGN;
// 2424 %if 0 <= disp <= 63 %and indirect = 0 %start
{
// Double-sided test on DISP (Part I)
int tmp;
if (0 > (tmp = DISP)) goto L_015C;
// Double-sided test on DISP (Part II)
if (tmp > 63) goto L_015C;
}
if (INDIRECT != 0) goto L_015C;
// 2425 set byte (disp); ->ok
SETBYTE(DISP);
goto U_1002;
// 2426 %finish
L_015C:;
// 2427 set byte (16_8F)
SETBYTE(143);
// 2428 %if flag = 3 %or indirect # 0 %start
if (FLAG == 3) goto L_015D;
if (INDIRECT == 0) goto L_015E;
L_015D:;
// 2429 set longword (disp); ->ok
SETLONGWORD(DISP);
goto U_1002;
// 2430 %finish
L_015E:;
// 2431 %if flag = 1 %or flag = 5 %start
if (FLAG == 1) goto L_015F;
if (FLAG != 5) goto L_0160;
L_015F:;
// 2432 set byte (disp); ->ok
SETBYTE(DISP);
goto U_1002;
// 2433 %finish
L_0160:;
// 2434 %if flag = 2 %or flag = 6 %start
if (FLAG == 2) goto L_0161;
if (FLAG != 6) goto L_0162;
L_0161:;
// 2435 set word (disp); ->ok
SETWORD(DISP);
goto U_1002;
// 2436 %finish
L_0162:;
// 2437 set longword (disp); set longword (0); ->ok
SETLONGWORD(DISP);
SETLONGWORD(0);
goto U_1002;
// 2438 %finish
L_0159:;
// 2439
// 2440 %if sym = '(' %start
if (SYM != 40) goto L_0163;
// 2441 %false %unless reg (base) %and flag < 5
if (!(REG(/*?*/ &BASE))) goto L_0164;
if (FLAG < 5) goto L_0165;
L_0164:;
return 0 /*FALSE*/;
L_0165:;
// 2442 disp = 0 %and -> basedisp %if indirect # 0
if (INDIRECT == 0) goto L_0166;
DISP = 0;
goto U_1003;
L_0166:;
// 2443 base = base+16_60
BASE = BASE + 96;
// 2444 %if sym = '+' %start
if (SYM != 43) goto L_0167;
// 2445 get (sym)
GET(/*?*/ &SYM);
// 2446 base = base+16_20
BASE = BASE + 32;
// 2447 %finish
L_0167:;
// 2448 set byte (base+indirect)
SETBYTE(BASE + INDIRECT);
// 2449 -> ok
goto U_1002;
// 2450 %finish
L_0163:;
// 2451
// 2452 %if sym = ' ' %start; !tag value
if (SYM != 32) goto L_0168;
// 2453 get (sym)
GET(/*?*/ &SYM);
// 2454 %false %unless literal(m)
if (LITERAL(/*?*/ &M)) goto L_0169;
return 0 /*FALSE*/;
L_0169:;
// 2455 v == var(m)
V = (struct VARFM *)/*?*/ &VAR[M];
// 2456 base = v_base
BASE = V->BASE;
// 2457 disp = v_disp
DISP = V->DISP;
// 2458 %if v_form = 15 %start; !label
if (V->FORM != 15) goto L_016A;
// 2459 flush code
FLUSHCODE();
// 2460 %if flag = 5 %start; !byte disp
if (FLAG != 5) goto L_016B;
// 2461 put (obj b lab); ca = ca+1
PUT(20);
CA = CA + 1;
// 2462 %else %if flag = 6; !word disp
goto L_016C;
L_016B:;
if (FLAG != 6) goto L_016D;
// 2463 put (obj w lab); ca = ca+2
PUT(21);
CA = CA + 2;
// 2464 %else; !pc-rel
goto L_016C;
L_016D:;
// 2465 define reference (disp, dir pref)
DEFINEREFERENCE(DISP, 3);
// 2466 put (obj call); ca = ca + 2
PUT(11);
CA = CA + 2;
// 2467 put long (disp)
PUTLONG(DISP);
// 2468 %true
return 1 /*TRUE*/;
// 2469 %finish
L_016C:;
// 2470 put word (disp)
PUTWORD(DISP);
// 2471 %true
return 1 /*TRUE*/;
// 2472 %finish
L_016A:;
// 2473 %if base = local %start
if (BASE != LOCAL) goto L_016E;
// 2474 base = fp
BASE = 14;
// 2475 base = ap %and disp = disp-60 %if disp > 0
if (DISP <= 0) goto L_016F;
BASE = 13;
DISP = DISP - 60;
L_016F:;
// 2476 %finish
L_016E:;
// 2477 base = base-1
BASE = BASE - 1;
// 2478 %if sym = '+' %or sym = '-' %start
if (SYM == 43) goto L_0170;
if (SYM != 45) goto L_0171;
L_0170:;
// 2479 sign = sym
SIGN = SYM;
// 2480 get (sym)
GET(/*?*/ &SYM);
// 2481 %false %unless literal (m)
if (LITERAL(/*?*/ &M)) goto L_0172;
return 0 /*FALSE*/;
L_0172:;
// 2482 m = -m %if sign = '-'
if (SIGN != 45) goto L_0173;
M = -M;
L_0173:;
// 2483 disp = disp+m
DISP = DISP + M;
// 2484 %finish
L_0171:;
// 2485 base disp:
U_1003:;
// 2486 base = base+indirect
BASE = BASE + INDIRECT;
// 2487 size = msize (disp)
SIZE = MSIZE(DISP);
// 2488 %if size <= 1 %start
if (SIZE > 1) goto L_0174;
// 2489 set byte (16_a0+base)
SETBYTE(160 + BASE);
// 2490 set byte (disp)
SETBYTE(DISP);
// 2491 %else %if size = 2
goto L_0175;
L_0174:;
if (SIZE != 2) goto L_0176;
// 2492 set byte (16_c0+base)
SETBYTE(192 + BASE);
// 2493 set word (disp)
SETWORD(DISP);
// 2494 %else
goto L_0175;
L_0176:;
// 2495 set byte (16_e0+base)
SETBYTE(224 + BASE);
// 2496 set longword (disp)
SETLONGWORD(DISP);
// 2497 %finish
L_0175:;
// 2498 -> ok
goto U_1002;
// 2499 %finish
L_0168:;
// 2500
// 2501 %if sym = '-' %and indirect = 0 %and flag < 5 %start
if (SYM != 45) goto L_0177;
if (INDIRECT != 0) goto L_0177;
if (FLAG >= 5) goto L_0177;
// 2502 get (sym)
GET(/*?*/ &SYM);
// 2503 %if sym = '(' %start
if (SYM != 40) goto L_0178;
// 2504 %false %unless reg (base)
if (REG(/*?*/ &BASE)) goto L_0179;
return 0 /*FALSE*/;
L_0179:;
// 2505 set byte (16_70+base)
SETBYTE(112 + BASE);
// 2506 -> ok
goto U_1002;
// 2507 %finish
L_0178:;
// 2508 %false %unless literal (disp)
if (LITERAL(/*?*/ &DISP)) goto L_017A;
return 0 /*FALSE*/;
L_017A:;
// 2509 disp = -disp
DISP = -DISP;
// 2510 -> bd
goto U_1004;
// 2511 %finish
L_0177:;
// 2512
// 2513 %false %unless literal (disp) %and flag < 5
if (!(LITERAL(/*?*/ &DISP))) goto L_017B;
if (FLAG < 5) goto L_017C;
L_017B:;
return 0 /*FALSE*/;
L_017C:;
// 2514 bd: %if sym = '(' %start
U_1004:;
if (SYM != 40) goto L_017D;
// 2515 %false %unless reg (base)
if (REG(/*?*/ &BASE)) goto L_017E;
return 0 /*FALSE*/;
L_017E:;
// 2516 -> base disp
goto U_1003;
// 2517 %finish
L_017D:;
// 2518 %false %unless 0 <= disp <= 15
{
// Double-sided test on DISP (Part I)
int tmp;
if (0 > (tmp = DISP)) goto L_017F;
// Double-sided test on DISP (Part II)
if (tmp <= 15) goto L_0180;
}
L_017F:;
return 0 /*FALSE*/;
L_0180:;
// 2519 set byte (16_50+disp)
SETBYTE(80 + DISP);
// 2520
// 2521 ok: %if sym = '[' %and flag < 5 %start; !indexed
U_1002:;
if (SYM != 91) goto L_0181;
if (FLAG >= 5) goto L_0181;
// 2522 get (sym)
GET(/*?*/ &SYM);
// 2523 %false %unless literal (base) %and sym = ']'
if (!(LITERAL(/*?*/ &BASE))) goto L_0182;
if (SYM == 93) goto L_0183;
L_0182:;
return 0 /*FALSE*/;
L_0183:;
// 2524 get (sym)
GET(/*?*/ &SYM);
// 2525 put number byte (16_40+base)
PUTNUMBERBYTE(64 + BASE);
// 2526 %finish
L_0181:;
// 2527 put number byte (oper(m)) %for m = 1, 1, p
// %for M = 1, 1, P %cycle
{
int _final = P;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle M = 1, 1, P");
M = 0;
L_0184:
if (M == _final) goto L_0185;
M += 1;
PUTNUMBERBYTE(OPER[M - 1]);
goto L_0184;
}
L_0185:;
// 2528 %true
return 1 /*TRUE*/;
// 2529 %end
} /* end of PARSEDOPERAND */
// 2530
// 2531 get (sym)
GET(/*?*/ &SYM);
// 2532 op text = ""; n = 0
_imp_strncpy(/*?*/ &OPTEXT, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 6);
N = 0;
// 2533 %cycle
L_0187:;
// 2534 %exit %if sym = '_'
if (SYM != 95) goto L_0188;
goto L_0189;
L_0188:;
// 2535 %if length(optext) # 6 %start
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &OPTEXT) == 6) goto L_018A;
// 2536 optext = optext . tostring(sym)
_imp_strncpy(/*?*/ &OPTEXT, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &OPTEXT, ({
__typeof__(_imp_string1) tmp; /*E*/
tmp = _imp_TOSTRING(SYM);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 6);
// 2537 n = n<<5 + sym
N = (N << 5) + SYM;
// 2538 %finish
L_018A:;
// 2539 get (sym)
GET(/*?*/ &SYM);
// 2540 %repeat
goto L_0187;
L_0189:;
// 2541 get (sym)
GET(/*?*/ &SYM);
// 2542 j = find (n)
J = FIND(N);
// 2543 %if j < 0 %start
if (J >= 0) goto L_018B;
// 2544 mc error("Unknown opcode")
MCERROR(_imp_str_literal_size(23, "Unknown opcode"));
// 2545 %return
return;
// 2546 %finish
L_018B:;
// 2547 flags = code(j+1)
FLAGS = CODE[J + 1];
// 2548 opcode = flags>>24
OPCODE = (unsigned int)FLAGS >> 24;
// 2549 operands = flags>>21&7
OPERANDS = (unsigned int)FLAGS >> 21 & 7;
// 2550 put code (opcode)
PUTCODE(OPCODE);
// 2551 %if operands > 0 %start
if (OPERANDS <= 0) goto L_018C;
// 2552 %cycle
L_018D:;
// 2553 %unless parsed operand (flags&7) %start
if (PARSEDOPERAND(FLAGS & 7)) goto L_018E;
// 2554 mc error ("Bad operand")
MCERROR(_imp_str_literal_size(23, "Bad operand"));
// 2555 %return
return;
// 2556 %finish
L_018E:;
// 2557 flags = flags>>3
FLAGS = (unsigned int)FLAGS >> 3;
// 2558 operands = operands-1
OPERANDS = OPERANDS - 1;
// 2559 %exit %if operands = 0
if (OPERANDS != 0) goto L_018F;
goto L_0190;
L_018F:;
// 2560 %if sym # ',' %then mc error ("Operands?") %else get (sym)
if (SYM == 44) goto L_0191;
MCERROR(_imp_str_literal_size(23, "Operands?"));
goto L_0192;
L_0191:;
GET(/*?*/ &SYM);
L_0192:;
// 2561 %repeat
goto L_018D;
L_0190:;
// 2562 %finish
L_018C:;
// 2563 mc error ("Operands?") %if sym # ';'
if (SYM == 59) goto L_0193;
MCERROR(_imp_str_literal_size(23, "Operands?"));
L_0193:;
// 2564 %end
return;
} /* end of MACHINECODE */
// 2565
// 2566 %routine PLANT
void PLANT(void) {
// 2567 ! Plant in-line code values (from "*=constant")
// 2568 %integer j
int J;
// 2569 %for j = 1, 1, stp %cycle
// %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_0194:
if (J == _final) goto L_0195;
J += 1;
// 2570 lhs == stacked(j)
LHS = (struct STACKFM *)STACKED[J - 1];
// 2571 word (lhs_disp)
WORD(LHS->DISP);
// 2572 drop (lhs)
DROP(LHS);
// 2573 %repeat
goto L_0194;
}
L_0195:;
// 2574 stp = 0
STP = 0;
// 2575 %end
return;
} /* end of PLANT */
// 2576
// 2577 %routine ASSEMBLE (%integer amode, labs, names)
void ASSEMBLE(int AMODE, int LABS, int NAMES) {
// 2578 !amode : = -1 - recordformat
// 2579 ! = -2 - alternate format starting
// 2580 ! = 0 - procedure definition
// 2581 ! = 1 - procedure spec
// 2582 %switch c (' ' : 127)
int C_index;
int C_line;
char *C_file;
static const void *C[96] = {
&&case_C_default, &&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_default, &&case_C_95, &&case_C_default, &&case_C_97,
&&case_C_98, &&case_C_99, &&case_C_100, &&case_C_101, &&case_C_102, &&case_C_default,
&&case_C_default, &&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};
// 2583 %record(varfm) %name v
struct VARFM *V;
// 2584 %record(varfm) %name gvar == decvar
struct VARFM *GVAR;
GVAR = (struct VARFM *)DECVAR;
// 2585 %integer %array string areas (1 : max work)
int STRINGAREAS[12];
// 2586 %integer duplic = 0
int DUPLIC;
DUPLIC = 0;
// 2587 %integer this area = 0
int THISAREA;
THISAREA = 0;
// 2588 %integer last area = 0
int LASTAREA;
LASTAREA = 0;
// 2589 %integer old mask = entry mask
int OLDMASK;
OLDMASK = ENTRYMASK;
// 2590 %integer old ca = ca
int OLDCA;
OLDCA = CA;
// 2591 %integer old frame = frame
int OLDFRAME;
OLDFRAME = FRAME;
// 2592 %integer max frame
int MAXFRAME;
// 2593 %integer frame base
int FRAMEBASE;
// 2594 %integer old last local = last local
int OLDLASTLOCAL;
OLDLASTLOCAL = LASTLOCAL;
// 2595 %integer old jump = uncond jump
int OLDJUMP;
OLDJUMP = UNCONDJUMP;
// 2596 %integer old ivbit = ivbit state
int OLDIVBIT;
OLDIVBIT = IVBITSTATE;
// 2597 %integer gstart = names
int GSTART;
GSTART = NAMES;
// 2598 %integer gfunction = 0; !#0 for string/record functions
int GFUNCTION;
GFUNCTION = 0;
// 2599 %integer label start = labs
int LABELSTART;
LABELSTART = LABS;
// 2600 %integer block tag
int BLOCKTAG;
// 2601 %integer block end tag = 0
int BLOCKENDTAG;
BLOCKENDTAG = 0;
// 2602 %integer local lines = diag lines; diag lines = 6
int LOCALLINES;
LOCALLINES = DIAGLINES;
DIAGLINES = 6;
// 2603 %integer local diags = 0
int LOCALDIAGS;
LOCALDIAGS = 0;
// 2604 %integer events = 0
int EVENTS;
EVENTS = 0;
// 2605 %integer evlow, evep
int EVLOW;
int EVEP;
// 2606 %integer proctype, mainprog = 0
int PROCTYPE;
int MAINPROG;
MAINPROG = 0;
auto void DUMPDIAG(int FLAG);
auto void LOAD(struct STACKFM * V, int REG);
auto void LRD(struct STACKFM * V, int REG);
auto void JUMPTO(int LABEL, int COND, int DEF);
auto void TESTZERO(struct STACKFM * V);
auto void PUSH(struct STACKFM * T, int *N);
// 2607
// 2608 %routinespec DUMP DIAG (%integer flag)
// 2609 %routinespec LOAD (%record(stackfm) %name v, %integer r)
// 2610 %routinespec LRD (%record(stackfm) %name v, %integer r)
// 2611 %routinespec JUMP TO (%integer label, cond, def)
// 2612 %routinespec TEST ZERO (%record(stack fm) %name d)
// 2613 %routinespec PUSH (%record(stackfm) %name v, %integername n)
// 2614
// 2615 !====================== Initialisation =============================
// 2616
// 2617 flush code
FLUSHCODE();
// 2618 uncond jump = -1
UNCONDJUMP = -1;
// 2619 last movc3 = -1
LASTMOVC3 = -1;
// 2620 frame = 0 %if amode # -2
if (AMODE == -2) goto L_0196;
FRAME = 0;
L_0196:;
// 2621 frame base = frame; max frame = frame
FRAMEBASE = FRAME;
MAXFRAME = FRAME;
// 2622 ca = 0
CA = 0;
// 2623 entry mask = 16_3c; entry mask = 0 %if control&1 = 0
ENTRYMASK = 60;
if (CONTROL & 1 != 0) goto L_0197;
ENTRYMASK = 0;
L_0197:;
// 2624 ivbit state = 0
IVBITSTATE = 0;
// 2625 %if control&ovf check # 0 %start
if (CONTROL & 16 == 0) goto L_0198;
// 2626 entry mask = iovf bit!entry mask
ENTRYMASK = 16384 | ENTRYMASK;
// 2627 ivbit state = 1
IVBITSTATE = 1;
// 2628 %finish
L_0198:;
// 2629 proctype = potype
PROCTYPE = POTYPE;
// 2630 %if amode = 0 %start
if (AMODE != 0) goto L_0199;
// 2631 level = level + 1
LEVEL = LEVEL + 1;
// 2632 error ('!', "nesting too deep") %if level > 6
if (LEVEL <= 6) goto L_019A;
ERROR(33, _imp_str_literal_size(127, "nesting too deep"));
L_019A:;
// 2633 local = base reg(level)
LOCAL = BASEREG[LEVEL + 1];
// 2634 activity(local) = -1
ACTIVITY[LOCAL] = -1;
// 2635 gfunction = 1 %if gvar_type&(strings!records) # 0 %and
if (GVAR->TYPE & (64 | 128) == 0) goto L_019B;
if (GVAR->FORM != 1 + 16) goto L_019B;
GFUNCTION = 1;
L_019B:;
// 2636+ gvar_form = v in r+proc bit
// 2637 %if level # 0 %start
if (LEVEL == 0) goto L_019C;
// 2638 entry mask = entry mask ! regmask(local)
ENTRYMASK = ENTRYMASK | REGMASK[LOCAL];
// 2639 decvar_disp = newtag %if decvar_disp = 0
if (DECVAR->DISP != 0) goto L_019D;
DECVAR->DISP = NEWTAG();
L_019D:;
// 2640 block tag = decvar_disp
BLOCKTAG = DECVAR->DISP;
// 2641 block end tag = new tag
BLOCKENDTAG = NEWTAG();
// 2642 select output tank (directives); put (dir header)
SELECTOUTPUTTANK(DIRECTIVES);
PUT(9);
// 2643 select output tank (object)
SELECTOUTPUTTANK(OBJECT);
// 2644 put (obj header)
PUT(10);
// 2645 put (local-1); put word (block tag)
PUT(LOCAL - 1);
PUTWORD(BLOCKTAG);
// 2646 put word (block end tag)
PUTWORD(BLOCKENDTAG);
// 2647 put word (current line)
PUTWORD(CURRENTLINE);
// 2648 %if proctype # 0 %start; ! external
if (PROCTYPE == 0) goto L_019E;
// 2649 dump text (externalname)
DUMPTEXT((_imp_string255 *)/*p*/ /*?*/ &EXTERNALNAME);
// 2650 entry mask = entry mask ! 16_800; ! Save GLA on entry
ENTRYMASK = ENTRYMASK | 2048;
// 2651 %if command & entrybit # 0 %andc
if (COMMAND & 1024 == 0) goto L_019F;
if (_imp_strcmp((_imp_string *)/*?*/ &ENTRYNAME, (_imp_string *)/*?*/ _imp_str_literal_ptr("")) == 0) goto L_01A0;
if (_imp_strcmp((_imp_string *)/*?*/ &EXTERNALNAME, (_imp_string *)/*?*/ &ENTRYNAME) != 0) goto L_019F;
L_01A0:;
// 2652+ (entryname = "" %or externalname = entryname) %start
// 2653 mainprog = mainrt; mainprog = mainfn %if decvar_type # 0
MAINPROG = 1;
if (DECVAR->TYPE == 0) goto L_01A1;
MAINPROG = 2;
L_01A1:;
// 2654 define entry (block tag)
DEFINEENTRY(BLOCKTAG);
// 2655 %finish
L_019F:;
// 2656 %finish
L_019E:;
// 2657 define tag (block tag)
DEFINETAG(BLOCKTAG);
// 2658 lput (obj pdef, block tag) %if potype # 0
if (POTYPE == 0) goto L_01A2;
LPUT(4, BLOCKTAG);
L_01A2:;
// 2659 dump diag (0)
DUMPDIAG(0);
// 2660 %finish
L_019C:;
// 2661 %else %if amode = -1
goto L_01A3;
L_0199:;
if (AMODE != -1) goto L_01A4;
// 2662 gvar_extra = parms
GVAR->EXTRA = PARMS;
// 2663 %finish
L_01A4:;
L_01A3:;
// 2664
// 2665
// 2666 !===================================================================
// 2667
// 2668
// 2669 %routine SPEC EXTERNAL (%record(varfm) %name v)
void SPECEXTERNAL(struct VARFM * V) {
// 2670 v_base = pc
V->BASE = 16;
// 2671 select output tank (directives)
SELECTOUTPUTTANK(DIRECTIVES);
// 2672 put (dir used); put word (v_xno)
PUT(1);
PUTWORD(V->XNO);
// 2673 select output tank (object)
SELECTOUTPUTTANK(OBJECT);
// 2674 %end
return;
} /* end of SPECEXTERNAL */
// 2675
// 2676 %routine DUMP DIAG (%integer flag)
void DUMPDIAG(int FLAG) {
// 2677 %integer type, disp, base, indirect
int TYPE;
int DISP;
int BASE;
int INDIRECT;
// 2678 %return %if amode # 0 %or command&diag bit = 0
if (AMODE != 0) goto L_0186;
if (COMMAND & 4 != 0) goto L_01A5;
L_0186:;
return;
L_01A5:;
// 2679 indirect = 0
INDIRECT = 0;
// 2680 base = decvar_base - 1
BASE = DECVAR->BASE - 1;
// 2681 type = decvar_type
TYPE = DECVAR->TYPE;
// 2682 %if flag = 0 %start; !proc header
if (FLAG != 0) goto L_01A6;
// 2683 put (obj diag p)
PUT(17);
// 2684 local diags = local diags+2
LOCALDIAGS = LOCALDIAGS + 2;
// 2685 %else %if decvar_form&15 = v in s
goto L_01A7;
L_01A6:;
if (DECVAR->FORM & 15 != 2) goto L_01A8;
// 2686 put (obj diag v)
PUT(18);
// 2687 %else %if decvar_form&15 = a in s
goto L_01A7;
L_01A8:;
if (DECVAR->FORM & 15 != 4) goto L_01A9;
// 2688 put (obj diag v)
PUT(18);
// 2689 indirect = 128
INDIRECT = 128;
// 2690 %else
goto L_01A7;
L_01A9:;
// 2691 %return
return;
// 2692 %finish
L_01A7:;
// 2693 local diags = local diags+7+length(var name)
LOCALDIAGS = LOCALDIAGS + 7 + *_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &VARNAME);
// 2694 %if flag = 0 %start
if (FLAG != 0) goto L_01AA;
// 2695 put word (current line)
PUTWORD(CURRENTLINE);
// 2696 %else
goto L_01AB;
L_01AA:;
// 2697 put (type)
PUT(TYPE);
// 2698 disp = decvar_disp
DISP = DECVAR->DISP;
// 2699 %if base = local-1 %start
if (BASE != LOCAL - 1) goto L_01AC;
// 2700 %if disp >= 0 %start
if (DISP < 0) goto L_01AD;
// 2701 disp = disp+4 %if gfunction # 0
if (GFUNCTION == 0) goto L_01AE;
DISP = DISP + 4;
L_01AE:;
// 2702 disp = disp+4; base = ap-1
DISP = DISP + 4;
BASE = 13 - 1;
// 2703 %else
goto L_01AF;
L_01AD:;
// 2704 base = fp-1
BASE = 14 - 1;
// 2705 %finish
L_01AF:;
// 2706 %finish
L_01AC:;
// 2707 put (base!indirect)
PUT(BASE | INDIRECT);
// 2708 put long (disp)
PUTLONG(DISP);
// 2709 %finish
L_01AB:;
// 2710 dump text (var name)
DUMPTEXT((_imp_string255 *)/*p*/ /*?*/ &VARNAME);
// 2711 %end
return;
} /* end of DUMPDIAG */
// 2712
// 2713 %routine SET DOPE VECTOR (%integer %name gdisp)
void SETDOPEVECTOR(int *GDISP) {
// 2714 gfix (3)
GFIX(3);
// 2715 gdisp = ga
*GDISP = GA;
// 2716 glongword (1); !dimension
GLONGWORD(1);
// 2717 glongword (vlb)
GLONGWORD(VLB);
// 2718 glongword (vub)
GLONGWORD(VUB);
// 2719 vub = vub-vlb+1
VUB = VUB - VLB + 1;
// 2720 glongword (data size)
GLONGWORD(DATASIZE);
// 2721 vlb = vlb*data size
VLB = VLB * DATASIZE;
// 2722 %end
return;
} /* end of SETDOPEVECTOR */
// 2723
// 2724 %routine DEFINE VAR
void DEFINEVAR(void) {
// 2725 %integer type, form, tf, s, size
int TYPE;
int FORM;
int TF;
int S;
int SIZE;
// 2726 %integer new, round, dv
int NEW;
int ROUND;
int DV;
// 2727 %own %integer prim no = 0, xno = 0
static int PRIMNO = 0;
static int XNO = 0;
// 2728
// 2729 new = 0
NEW = 0;
// 2730
// 2731 decl = getword
DECL = GETWORD();
// 2732 %if decl = 0 %start; !recordformat element
if (DECL != 0) goto L_01B0;
// 2733 parms = parms - 1; decvar == var(parms); decvar = 0
PARMS = PARMS - 1;
DECVAR = (struct VARFM *)/*?*/ &VAR[PARMS];
*DECVAR = (struct VARFM){0};
// 2734 %else
goto L_01B1;
L_01B0:;
// 2735 decvar == var(decl)
DECVAR = (struct VARFM *)/*?*/ &VAR[DECL];
// 2736 %if decl > names %or decvar_xno # 0 %start
if (DECL > NAMES) goto L_01B2;
if (DECVAR->XNO == 0) goto L_01B3;
L_01B2:;
// 2737 ! Either a new name or one previously %externally spec'd
// 2738 decvar = 0
*DECVAR = (struct VARFM){0};
// 2739 names = decl %if decl > names
if (DECL <= NAMES) goto L_01B4;
NAMES = DECL;
L_01B4:;
// 2740 new = 1
NEW = 1;
// 2741 %finish
L_01B3:;
// 2742 %finish
L_01B1:;
// 2743 var name = ""
_imp_strncpy(/*?*/ &VARNAME, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 31);
// 2744 %cycle
L_01B5:;
// 2745 get (s); %exit %if s = ','
GET(/*?*/ &S);
if (S != 44) goto L_01B6;
goto L_01B7;
L_01B6:;
// 2746 var name = var name.tostring(s) %if length(var name) < max ident
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &VARNAME) >= 31) goto L_01B8;
_imp_strncpy(/*?*/ &VARNAME, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &VARNAME, ({
__typeof__(_imp_string1) tmp; /*E*/
tmp = _imp_TOSTRING(S);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 31);
L_01B8:;
// 2747 %repeat
goto L_01B5;
L_01B7:;
// 2748 abort (14) %if names >= parms
if (NAMES < PARMS) goto L_01B9;
ABORT(14);
L_01B9:;
// 2749 get (tf)
GET(/*?*/ &TF);
// 2750 type = tf>>4
TYPE = (unsigned int)TF >> 4;
// 2751 form = fmap(tf&15); !convert to internal form
FORM = FMAP[TF & 15];
// 2752 round = 3; data size = 4; ! defaults (integer)
ROUND = 3;
DATASIZE = 4;
// 2753 get (discard); size = getword
GET(/*?*/ &DISCARD);
SIZE = GETWORD();
// 2754 %if type = 1 %start; ! integer
if (TYPE != 1) goto L_01BA;
// 2755 type = integers
TYPE = 16;
// 2756 %if size = 2 %start
if (SIZE != 2) goto L_01BB;
// 2757 type = byte+integers; round = 0; size = 1
TYPE = 2 + 16;
ROUND = 0;
SIZE = 1;
// 2758 %else %if size = 3
goto L_01BC;
L_01BB:;
if (SIZE != 3) goto L_01BD;
// 2759 type = short+integers; round = 1; size = 2
TYPE = 1 + 16;
ROUND = 1;
SIZE = 2;
// 2760 %else %if size = 4
goto L_01BC;
L_01BD:;
if (SIZE != 4) goto L_01BE;
// 2761 type = long+integers; round = 7; size = 8
TYPE = 5 + 16;
ROUND = 7;
SIZE = 8;
// 2762 %else
goto L_01BC;
L_01BE:;
// 2763 size = 4
SIZE = 4;
// 2764 %finish
L_01BC:;
// 2765 type = integers %if form = procbit+v in r; !integer functions
if (FORM != 16 + 1) goto L_01BF;
TYPE = 16;
L_01BF:;
// 2766 %else %if type = 2; ! %real, %longreal
goto L_01C0;
L_01BA:;
if (TYPE != 2) goto L_01C1;
// 2767 %if size = 4 %start; !longreal
if (SIZE != 4) goto L_01C2;
// 2768 size = 8; type = reall; round = 7
SIZE = 8;
TYPE = 36;
ROUND = 7;
// 2769 %else
goto L_01C3;
L_01C2:;
// 2770 size = 4; type = reals
SIZE = 4;
TYPE = 35;
// 2771 %finish
L_01C3:;
// 2772 %else %if type = 3; ! %string
goto L_01C0;
L_01C1:;
if (TYPE != 3) goto L_01C4;
// 2773 type = strings
TYPE = 64;
// 2774 round = 0
ROUND = 0;
// 2775 size = size + 1 %if size # 0; !infiltrate length cell, unless (*)
if (SIZE == 0) goto L_01C5;
SIZE = SIZE + 1;
L_01C5:;
// 2776 %else %if type = 4; ! %record
goto L_01C0;
L_01C4:;
if (TYPE != 4) goto L_01C6;
// 2777 type = records
TYPE = 128;
// 2778 decvar_format = size
DECVAR->FORMAT = SIZE;
// 2779 size = var(size)_length
SIZE = VAR[SIZE].LENGTH;
// 2780 %finish
L_01C6:;
L_01C0:;
// 2781 data size = size; !actual size
DATASIZE = SIZE;
// 2782 decvar_length = data size
DECVAR->LENGTH = DATASIZE;
// 2783
// 2784 get (discard); otype = getlong
GET(/*?*/ &DISCARD);
OTYPE = GETLONG();
// 2785 duplic = otype&256
DUPLIC = OTYPE & 256;
// 2786 spec = otype&8; otype = otype&7; !ignore prot for now
SPEC = OTYPE & 8;
OTYPE = OTYPE & 7;
// 2787 %if alias # "" %start
if (_imp_strcmp((_imp_string *)/*?*/ &ALIAS, (_imp_string *)/*?*/ _imp_str_literal_ptr("")) == 0) goto L_01C7;
// 2788 external name = alias; alias = ""
_imp_strncpy(/*?*/ &EXTERNALNAME, ({
__typeof__(_imp_string31) tmp; /*B*/
tmp = ALIAS;
(void *)&tmp;
}),
/*max:*/ 31);
_imp_strncpy(/*?*/ &ALIAS, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 31);
// 2789 %else
goto L_01C8;
L_01C7:;
// 2790 %if otype = 4 %start; !system
if (OTYPE != 4) goto L_01C9;
// 2791 %if length(var name) > max ident-4 %start
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &VARNAME) <= 31 - 4) goto L_01CA;
// 2792 length(var name) = max ident-4
*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &VARNAME) = 31 - 4;
// 2793 %finish
L_01CA:;
// 2794 external name = "SYS$".var name
_imp_strncpy(/*?*/ &EXTERNALNAME, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("SYS$"), (_imp_string *)/*?*/ &VARNAME);
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 31);
// 2795 %else
goto L_01CB;
L_01C9:;
// 2796 external name = var name
_imp_strncpy(/*?*/ &EXTERNALNAME, ({
__typeof__(_imp_string31) tmp; /*B*/
tmp = VARNAME;
(void *)&tmp;
}),
/*max:*/ 31);
// 2797 %finish
L_01CB:;
// 2798 %finish
L_01C8:;
// 2799
// 2800 size = 4 %if gmode # 0 %and amode >= 0 %and type # reall
if (GMODE == 0) goto L_01CC;
if (AMODE < 0) goto L_01CC;
if (TYPE == 36) goto L_01CC;
SIZE = 4;
L_01CC:;
// 2801 !parameters are longwords
// 2802 %if form&proc bit # 0 %start; !procedure
if (FORM & 16 == 0) goto L_01CD;
// 2803 decvar_type = type; decvar_form = form
DECVAR->TYPE = TYPE;
DECVAR->FORM = FORM;
// 2804 decvar_header = -1
DECVAR->HEADER = -1;
// 2805 gtype = 0
GTYPE = 0;
// 2806 gtype = 1 %if spec # 0
if (SPEC == 0) goto L_01CE;
GTYPE = 1;
L_01CE:;
// 2807 %if otype # 0 %and spec # 0 %start; !external spec
if (OTYPE == 0) goto L_01CF;
if (SPEC == 0) goto L_01CF;
// 2808 %if otype >= 6 %start; !primitive, permanent
if (OTYPE < 6) goto L_01D0;
// 2809 prim no = prim no+1
PRIMNO = PRIMNO + 1;
// 2810 decvar_flags = prim no
DECVAR->FLAGS = PRIMNO;
// 2811 %return %if otype = 6; !primitive
if (OTYPE != 6) goto L_01D1;
return;
L_01D1:;
// 2812 %finish
L_01D0:;
// 2813 xno = xno + 1
XNO = XNO + 1;
// 2814 decvar_base = pending; decvar_xno = xno
DECVAR->BASE = 22;
DECVAR->XNO = XNO;
// 2815 put (obj pspec); put word (xno); dump text (externalname)
PUT(5);
PUTWORD(XNO);
DUMPTEXT((_imp_string255 *)/*p*/ /*?*/ &EXTERNALNAME);
// 2816 %return
return;
// 2817 %finish
L_01CF:;
// 2818 %if gmode = 0 %start; !not a parameter
if (GMODE != 0) goto L_01D2;
// 2819 potype = otype
POTYPE = OTYPE;
// 2820 %if new # 0 %start
if (NEW == 0) goto L_01D3;
// 2821 decvar_base = pc
DECVAR->BASE = 16;
// 2822 decvar_disp = new tag
DECVAR->DISP = NEWTAG();
// 2823 %finish
L_01D3:;
// 2824 %return
return;
// 2825 %finish
L_01D2:;
// 2826 size = 4
SIZE = 4;
// 2827 %else
goto L_01D4;
L_01CD:;
// 2828 %if form&(indirect bit!array bit!arrayname bit) # 0 %start
if (FORM & (128 | 32 | 64) == 0) goto L_01D5;
// 2829 size = 4
SIZE = 4;
// 2830 %if form&arrayname bit # 0 %start
if (FORM & 64 == 0) goto L_01D6;
// 2831 size = 8; datasize = 8
SIZE = 8;
DATASIZE = 8;
// 2832 %else %if form&indirect bit # 0
goto L_01D7;
L_01D6:;
if (FORM & 128 == 0) goto L_01D8;
// 2833 data size = 4
DATASIZE = 4;
// 2834 %finish
L_01D8:;
L_01D7:;
// 2835 round = 3 %if form&(indirect bit!arrayname bit) # 0
if (FORM & (128 | 64) == 0) goto L_01D9;
ROUND = 3;
L_01D9:;
// 2836 %if type = 0 %start; !general type
if (TYPE != 0) goto L_01DA;
// 2837 size = 8
SIZE = 8;
// 2838 %else %if form&arrayname bit # 0
goto L_01DB;
L_01DA:;
if (FORM & 64 == 0) goto L_01DC;
// 2839 decvar_header = -1
DECVAR->HEADER = -1;
// 2840 %finish
L_01DC:;
L_01DB:;
// 2841 %finish
L_01D5:;
// 2842 %finish
L_01D4:;
// 2843 decvar_type = type; decvar_form = form
DECVAR->TYPE = TYPE;
DECVAR->FORM = FORM;
// 2844
// 2845 !deal with owns
// 2846
// 2847 %if otype # 0 %start; !own data
if (OTYPE == 0) goto L_01DD;
// 2848 owntype = type; ownform = form
OWNTYPE = TYPE;
OWNFORM = FORM;
// 2849 %if otype = 2 %and form&indirect bit # 0 %start
if (OTYPE != 2) goto L_01DE;
if (FORM & 128 == 0) goto L_01DE;
// 2850 otype = 0
OTYPE = 0;
// 2851 %else
goto L_01DF;
L_01DE:;
// 2852 %if spec = 0 %start
if (SPEC != 0) goto L_01E0;
// 2853 %if form&array bit # 0 %start
if (FORM & 32 == 0) goto L_01E1;
// 2854 set dope vector (dv)
SETDOPEVECTOR(/*?*/ &DV);
// 2855 decvar_base = gla; decvar_disp = ga
DECVAR->BASE = 12;
DECVAR->DISP = GA;
// 2856 glongword (0); glongword (0)
GLONGWORD(0);
GLONGWORD(0);
// 2857 decvar_header = -2; decvar_zeroad = ga - vlb
DECVAR->HEADER = -2;
DECVAR->ZEROAD = GA - VLB;
// 2858 flush gla
FLUSHGLA();
// 2859 ! %if command & picbit # 0 %start
// 2860 ! head_base = gla; head_disp = ga - 8
// 2861 ! dope_disp = dv
// 2862 ! zeroth_base = gla; zeroth_disp = ga - vlb
// 2863 ! plant2 (moval, zeroth, head); head_disp = head_disp + 4
// 2864 ! plant2 (moval, dope, head)
// 2865 ! %else
// 2866 put (obj reloc); put long (ga-8); put long (ga-vlb)
PUT(8);
PUTLONG(GA - 8);
PUTLONG(GA - VLB);
// 2867 put (obj reloc); put long (ga-4); put long (dv)
PUT(8);
PUTLONG(GA - 4);
PUTLONG(DV);
// 2868 ! %finish
// 2869 lput (obj ddef, ga-8) %if otype > 2
if (OTYPE <= 2) goto L_01E2;
LPUT(6, GA - 8);
L_01E2:;
// 2870 %finish
L_01E1:;
// 2871 %else
goto L_01E3;
L_01E0:;
// 2872 xno = xno+1; decvar_xno = xno; decvar_base = pc
XNO = XNO + 1;
DECVAR->XNO = XNO;
DECVAR->BASE = 16;
// 2873 s = objdspec; s = obj weak %if otype = 5
S = 7;
if (OTYPE != 5) goto L_01E4;
S = 19;
L_01E4:;
// 2874 put (s); put word (xno); dump text (externalname)
PUT(S);
PUTWORD(XNO);
DUMPTEXT((_imp_string255 *)/*p*/ /*?*/ &EXTERNALNAME);
// 2875 ! Externalarrays actually arraynames....
// 2876 decvar_header = -1 %if decvar_form&arraybit # 0
if (DECVAR->FORM & 32 == 0) goto L_01E5;
DECVAR->HEADER = -1;
L_01E5:;
// 2877 %finish
L_01E3:;
// 2878 %finish
L_01DF:;
// 2879 owntype = integers %if form&indirect bit # 0
if (FORM & 128 == 0) goto L_01E6;
OWNTYPE = 16;
L_01E6:;
// 2880 owntype = records %if form&arrayname bit # 0; !to dump a lot
if (FORM & 64 == 0) goto L_01E7;
OWNTYPE = 128;
L_01E7:;
// 2881 %return
return;
// 2882 %finish
L_01DD:;
// 2883
// 2884 %if form = 15 %start; !label
if (FORM != 15) goto L_01E8;
// 2885 jump to (-decl, 32, 0)
JUMPTO(-DECL, 32, 0);
// 2886 %return
return;
// 2887 %finish
L_01E8:;
// 2888
// 2889 %if form = switch %start
if (FORM != 6) goto L_01E9;
// 2890 data size = 4
DATASIZE = 4;
// 2891 gfix (3); dv = ga
GFIX(3);
DV = GA;
// 2892 glongword (1)
GLONGWORD(1);
// 2893 glongword (vlb); glongword (vub)
GLONGWORD(VLB);
GLONGWORD(VUB);
// 2894 glongword (4); ! data size
GLONGWORD(4);
// 2895 decvar_type = integers; decvar_form = av in s
DECVAR->TYPE = 16;
DECVAR->FORM = 3;
// 2896 decvar_base = gla; decvar_disp = dv
DECVAR->BASE = 12;
DECVAR->DISP = DV;
// 2897 decvar_extra = ga-vlb*4
DECVAR->EXTRA = GA - VLB * 4;
// 2898 glongword (0) %for s = vlb, 1, vub
// %for S = VLB, 1, VUB %cycle
{
int _initial = VLB, _final = VUB;
if (invalid_for_loop(_initial, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle S = VLB, 1, VUB");
S = _initial - (1);
L_01EA:
if (S == _final) goto L_01EB;
S += 1;
GLONGWORD(0);
goto L_01EA;
}
L_01EB:;
// 2899 %return
return;
// 2900 %finish
L_01E9:;
// 2901
// 2902 %if form = recfm %start
if (FORM != 4) goto L_01ED;
// 2903 gtype = -1
GTYPE = -1;
// 2904 %return
return;
// 2905 %finish
L_01ED:;
// 2906
// 2907 %return %if form&array bit # 0
if (FORM & 32 == 0) goto L_01EE;
return;
L_01EE:;
// 2908 %if gmode = 0 %start; !reverse definition
if (GMODE != 0) goto L_01EF;
// 2909 frame = (frame-size)&(\round)
FRAME = FRAME - SIZE & (~ROUND);
// 2910 decvar_disp = frame
DECVAR->DISP = FRAME;
// 2911 last local = frame
LASTLOCAL = FRAME;
// 2912 %else
goto L_01F0;
L_01EF:;
// 2913 round = 3 %if amode >=0
if (AMODE < 0) goto L_01F1;
ROUND = 3;
L_01F1:;
// 2914 frame = (frame+round)&(\round) %if control&rec round # 0
if (CONTROL & 128 == 0) goto L_01F2;
FRAME = FRAME + ROUND & (~ROUND);
L_01F2:;
// 2915 decvar_disp = frame
DECVAR->DISP = FRAME;
// 2916 frame = frame+size
FRAME = FRAME + SIZE;
// 2917 %finish
L_01F0:;
// 2918 decvar_base = local
DECVAR->BASE = LOCAL;
// 2919 dump diag (1) %if form&arrayname bit = 0
if (FORM & 64 != 0) goto L_01F3;
DUMPDIAG(1);
L_01F3:;
// 2920 %end
return;
} /* end of DEFINEVAR */
// 2921
// 2922 %routine DEFINE PARAMETERS
void DEFINEPARAMETERS(void) {
// 2923 %integer p, disp
int P;
int DISP;
// 2924 gvar_extra = parms
GVAR->EXTRA = PARMS;
// 2925 disp = 64
DISP = 64;
// 2926 disp = 68 %if gfunction # 0
if (GFUNCTION == 0) goto L_01F4;
DISP = 68;
L_01F4:;
// 2927 %for p = gstart+1, 1, names %cycle
// %for P = GSTART + 1, 1, NAMES %cycle
{
int _initial = GSTART + 1, _final = NAMES;
if (invalid_for_loop(_initial, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle P = GSTART + 1, 1, NAMES");
P = _initial - (1);
L_01F5:
if (P == _final) goto L_01F6;
P += 1;
// 2928 actual == var(p)
ACTUAL = (struct VARFM *)/*?*/ &VAR[P];
// 2929 parms = parms - 1; formal == var(parms)
PARMS = PARMS - 1;
FORMAL = (struct VARFM *)/*?*/ &VAR[PARMS];
// 2930 formal = actual
*FORMAL = *ACTUAL;
// 2931 actual_disp = actual_disp+disp
ACTUAL->DISP = ACTUAL->DISP + DISP;
// 2932 %if actual_type&(records!strings) # 0 %start
if (ACTUAL->TYPE & (128 | 64) == 0) goto L_01F8;
// 2933 !string and record values passed by name
// 2934 actual_form = a in s %if actual_form = v in s
if (ACTUAL->FORM != 2) goto L_01F9;
ACTUAL->FORM = 4;
L_01F9:;
// 2935 %finish
L_01F8:;
// 2936 %repeat
goto L_01F5;
}
L_01F6:;
// 2937 abort (26) %if parms <= names
if (PARMS > NAMES) goto L_01FA;
ABORT(26);
L_01FA:;
// 2938 %end
return;
} /* end of DEFINEPARAMETERS */
// 2939
// 2940 %routine AMAP (%record(stackfm) %name v)
void AMAP(struct STACKFM * V) {
// 2941 !convert 'v' into a descriptor for the address of 'v'
// 2942 %integer f
int F;
// 2943 %const %short %array map(constant:a in rec) =
const short int MAP[8] = {-1, -1, 3, -1, 2, 6, -1, 5};
// 2944+ -1, -1, avins, -1, vins, avinrec, -1, vinrec
// 2945 ! constant, vinr, vins, avins, ains, vinrec, avinrec, ainrec
// 2946 monitor (v, "Amap in") %if diag&64 # 0
if (DIAG & 64 == 0) goto L_01FB;
MONITOR(V, _imp_str_literal_size(15, "Amap in"));
L_01FB:;
// 2947 f = map(v_form&15)
F = MAP[V->FORM & 15];
// 2948 abort (15) %if f < 0 %or v_oper # 0
if (F < 0) goto L_01F7;
if (V->OPER == 0) goto L_01FC;
L_01F7:;
ABORT(15);
L_01FC:;
// 2949 %if f = av in s %and v_xno = 0 %start
if (F != 3) goto L_01FD;
if (V->XNO != 0) goto L_01FD;
// 2950 %if v_base = 0 %start
if (V->BASE != 0) goto L_01FE;
// 2951 f = constant
F = 0;
// 2952 %else %if v_disp = 0 %and v_flags&indexed = 0
goto L_01FF;
L_01FE:;
if (V->DISP != 0) goto L_0200;
if (V->FLAGS & 1 != 0) goto L_0200;
// 2953 f = v in r
F = 1;
// 2954 %finish
L_0200:;
L_01FF:;
// 2955 %finish
L_01FD:;
// 2956 v_form = f
V->FORM = F;
// 2957 %if f = v in s %or f = v in rec %start
if (F == 2) goto L_0201;
if (F != 5) goto L_0202;
L_0201:;
// 2958 v_length = 4
V->LENGTH = 4;
// 2959 %else
goto L_0203;
L_0202:;
// 2960 v_length = var(v_format)_length %if v_type = records
if (V->TYPE != 128) goto L_0204;
V->LENGTH = VAR[V->FORMAT].LENGTH;
L_0204:;
// 2961 v_length = v_iscale %if v_flags&indexed # 0
if (V->FLAGS & 1 == 0) goto L_0205;
V->LENGTH = V->ISCALE;
L_0205:;
// 2962 %finish
L_0203:;
// 2963 v_type = integers
V->TYPE = 16;
// 2964 monitor (v, "Amap out") %if diag&64 # 0
if (DIAG & 64 == 0) goto L_0206;
MONITOR(V, _imp_str_literal_size(15, "Amap out"));
L_0206:;
// 2965 %end
return;
} /* end of AMAP */
// 2966
// 2967 %routine VMAP (%record(stackfm) %name v)
void VMAP(struct STACKFM * V) {
// 2968 %integer n
int N;
// 2969 monitor (v, "Vmap in") %if diag&64 # 0
if (DIAG & 64 == 0) goto L_0207;
MONITOR(V, _imp_str_literal_size(15, "Vmap in"));
L_0207:;
// 2970 %if v_oper # 0 %start
if (V->OPER == 0) goto L_0208;
// 2971 %if (v_oper = add %or v_oper = sub) %and const (v_link) %start
if (V->OPER == 9) goto L_01EC;
if (V->OPER != 10) goto L_0209;
L_01EC:;
if (!(CONST(V->LINK))) goto L_0209;
// 2972 n = v_link_disp; drop (v_link)
N = V->LINK->DISP;
DROP(V->LINK);
// 2973 n = -n %if v_oper = sub
if (V->OPER != 10) goto L_020A;
N = -N;
L_020A:;
// 2974 v_oper = 0
V->OPER = 0;
// 2975 %if v_form = v in r %or v_form = av in s %start
if (V->FORM == 1) goto L_020B;
if (V->FORM != 3) goto L_020C;
L_020B:;
// 2976 v_disp = v_disp + n
V->DISP = V->DISP + N;
// 2977 %else %if v_form = v in s %and v_type = integers %and
goto L_020D;
L_020C:;
if (V->FORM != 2) goto L_020E;
if (V->TYPE != 16) goto L_020E;
if (V->FLAGS & 1 != 0) goto L_020E;
// 2978+ v_flags&indexed = 0
// 2979 v_extra = v_disp; v_disp = n
V->EXTRA = V->DISP;
V->DISP = N;
// 2980 v_form = av in rec
V->FORM = 6;
// 2981 %else
goto L_020D;
L_020E:;
// 2982 load (v, any); v_disp = n
LOAD(V, 17);
V->DISP = N;
// 2983 %finish
L_020D:;
// 2984 %else
goto L_020F;
L_0209:;
// 2985 load (v, any)
LOAD(V, 17);
// 2986 %finish
L_020F:;
// 2987 %finish
L_0208:;
// 2988 ! load (v, any) %if v_flags&indexed # 0 %and v_form # av in s
// 2989 %if v_form = v in s %or v_form = v in rec %start
if (V->FORM == 2) goto L_0210;
if (V->FORM != 5) goto L_0211;
L_0210:;
// 2990 v_form = v_form+2
V->FORM = V->FORM + 2;
// 2991 %else %if v_form = av in s %or v_form = av in rec
goto L_0212;
L_0211:;
if (V->FORM == 3) goto L_0213;
if (V->FORM != 6) goto L_0214;
L_0213:;
// 2992 v_form = v_form-1
V->FORM = V->FORM - 1;
// 2993 %else %if v_form = constant
goto L_0212;
L_0214:;
if (V->FORM != 0) goto L_0215;
// 2994 v_form = v in s; v_base = 0
V->FORM = 2;
V->BASE = 0;
// 2995 %else
goto L_0212;
L_0215:;
// 2996 load (v, any); v_form = v in s
LOAD(V, 17);
V->FORM = 2;
// 2997 %finish
L_0212:;
// 2998 monitor (v, "Vmap out") %if diag&64 # 0
if (DIAG & 64 == 0) goto L_0216;
MONITOR(V, _imp_str_literal_size(15, "Vmap out"));
L_0216:;
// 2999 %end
return;
} /* end of VMAP */
// 3000
// 3001 %routine ADDRESS VAR (%integer mode, %record(stack fm) %name v)
void ADDRESSVAR(int MODE, struct STACKFM *V) {
// 3002 ! If v is av in rec then change form of descriptor
// 3003 ! according to mode -
// 3004 ! mode # 0 -> value wanted -> make into v in s + const
// 3005 ! mode = 0 -> want address -> load base
// 3006 %record(stack fm) %name c
struct STACKFM *C;
// 3007 %integer n
int N;
// 3008 %return %if v_form # av in rec
if (V->FORM == 6) goto L_0217;
return;
L_0217:;
// 3009 n = v_disp
N = V->DISP;
// 3010 %if mode # 0 %and v_flags = 0 %start
if (MODE == 0) goto L_0218;
if (V->FLAGS != 0) goto L_0218;
// 3011 v_form = v in s; v_disp = v_extra; v_type = integers
V->FORM = 2;
V->DISP = V->EXTRA;
V->TYPE = 16;
// 3012 %if n # 0 %start
if (N == 0) goto L_0219;
// 3013 c == literal(n); stp = stp - 1
C = (struct STACKFM *)LITERAL(N);
STP = STP - 1;
// 3014 v_oper = add; v_link == c
V->OPER = 9;
V->LINK = (struct STACKFM *)C;
// 3015 %finish
L_0219:;
// 3016 %else
goto L_021A;
L_0218:;
// 3017 v_disp = v_extra; v_extra = 0; v_type = integers
V->DISP = V->EXTRA;
V->EXTRA = 0;
V->TYPE = 16;
// 3018 load (v, any); v_disp = n
LOAD(V, 17);
V->DISP = N;
// 3019 v_form = av in s
V->FORM = 3;
// 3020 %finish
L_021A:;
// 3021 %end
return;
} /* end of ADDRESSVAR */
// 3022
// 3023 !string constant processing
// 3024
// 3025 %record(stackfm) %map WORK STRING
struct STACKFM *WORKSTRING(void)
{
// 3026 %record(stackfm) %name d
struct STACKFM *D;
// 3027 this area = this area + 1
THISAREA = THISAREA + 1;
// 3028 %if this area > last area %start
if (THISAREA <= LASTAREA) goto L_021B;
// 3029 last area = this area
LASTAREA = THISAREA;
// 3030 abort (29) %if last area > max work
if (LASTAREA <= 12) goto L_021C;
ABORT(29);
L_021C:;
// 3031 frame = frame - 256
FRAME = FRAME - 256;
// 3032 string areas(last area) = frame
STRINGAREAS[LASTAREA - 1] = FRAME;
// 3033 %finish
L_021B:;
// 3034 d == descriptor
D = (struct STACKFM *)DESCRIPTOR();
// 3035 d_type = strings; d_form = v in s
D->TYPE = 64;
D->FORM = 2;
// 3036 d_base = local; d_disp = string areas(this area)
D->BASE = LOCAL;
D->DISP = STRINGAREAS[THISAREA - 1];
// 3037 %result == d
return D;
// 3038 %end
} /* end of WORKSTRING */
// 3039
// 3040 %routine DUMP STRING (%integer max)
void DUMPSTRING(int MAX) {
// 3041 %integer j, l
int J;
int L;
// 3042 l = length(text)
L = *_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &TEXT);
// 3043 %if max = 0 %start; !as much as nesc.
if (MAX != 0) goto L_021D;
// 3044 %return %if l = 0
if (L != 0) goto L_021E;
return;
L_021E:;
// 3045 max = l
MAX = L;
// 3046 %else; !explicit area
goto L_021F;
L_021D:;
// 3047 max = max - 1; !ignore length cell
MAX = MAX - 1;
// 3048 error ('*', "string constant too big") %if max < l
if (MAX >= L) goto L_0220;
ERROR(42, _imp_str_literal_size(127, "string constant too big"));
L_0220:;
// 3049 %finish
L_021F:;
// 3050 gbyte (length(text))
GBYTE(*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &TEXT));
// 3051 gbyte (charno(text,j)) %for j = 1, 1, max
// %for J = 1, 1, MAX %cycle
{
int _final = MAX;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, MAX");
J = 0;
L_0221:
if (J == _final) goto L_0222;
J += 1;
GBYTE(*_imp_CHARNO((_imp_string255 *)/*p*/ /*?*/ &TEXT, J));
goto L_0221;
}
L_0222:;
// 3052 %end
return;
} /* end of DUMPSTRING */
// 3053
// 3054 %routine GET STRING (%string(*) %name text)
void GETSTRING(_imp_string * TEXT) {
// 3055 %integer n, s
int N;
int S;
// 3056 get (n)
GET(/*?*/ &N);
// 3057 length(text) = n
*_imp_LENGTH((_imp_string255 *)/*p*/ TEXT) = N;
// 3058 get block (n, charno(text,1))
GETBLOCK(N, _imp_CHARNO((_imp_string255 *)/*p*/ TEXT, 1));
// 3059 %return %if sym = 'G'; !Alias
if (SYM != 71) goto L_0224;
return;
L_0224:;
// 3060 s = look; !next control item
S = LOOK();
// 3061 %if n = 0 %start; !null string
if (N != 0) goto L_0225;
// 3062 lstack (null string)
LSTACK(24);
// 3063 %else
goto L_0226;
L_0225:;
// 3064 lstack (ga)
LSTACK(GA);
// 3065 dump string (0) %unless s = '$' %or s = 'A'; !own strings
if (S == 36) goto L_0227;
if (S == 65) goto L_0227;
DUMPSTRING(0);
L_0227:;
// 3066 %finish
L_0226:;
// 3067 lhs_base = gla
LHS->BASE = 12;
// 3068 lhs_type = strings
LHS->TYPE = 64;
// 3069 lhs_format = n + 1
LHS->FORMAT = N + 1;
// 3070 %end
return;
} /* end of GETSTRING */
// 3071
// 3072 !jump processing
// 3073
// 3074 %record(labelfm) %map NEW LABEL
struct LABELFM *NEWLABEL(void)
{
// 3075 labs = labs + 1; abort (16) %if labs > max labels
LABS = LABS + 1;
if (LABS <= 120) goto L_0228;
ABORT(16);
L_0228:;
// 3076 %result == labels(labs)
return /*?*/ &LABELS[LABS - 1];
// 3077 %end
} /* end of NEWLABEL */
// 3078
// 3079 %record(labelfm) %map FIND (%integer label)
struct LABELFM *FIND(int LABEL)
{
// 3080 %integer lp
int LP;
// 3081 %record(labelfm) %name l
struct LABELFM *L;
// 3082 lp = labs
LP = LABS;
// 3083 %while lp # label start %cycle
L_0229:;
if (LP == LABELSTART) goto L_022A;
// 3084 l == labels(lp)
L = (struct LABELFM *)/*?*/ &LABELS[LP - 1];
// 3085 %result == l %if l_id = label
if (L->ID != LABEL) goto L_022B;
return L;
L_022B:;
// 3086 lp = lp - 1
LP = LP - 1;
// 3087 %repeat
goto L_0229;
L_022A:;
// 3088 %result == null
return NULL;
// 3089 %end
} /* end of FIND */
// 3090
// 3091 %routine DEFINE LABEL (%integer label)
void DEFINELABEL(int LABEL) {
// 3092 %record(labelfm) %name l
struct LABELFM *L;
// 3093 %return %if label = 0; !jump round proc
if (LABEL != 0) goto L_022C;
return;
L_022C:;
// 3094 l == find(label)
L = (struct LABELFM *)FIND(LABEL);
// 3095 %if l == null %start; !not found
if (_imp_ADDR((void *)(L)) != _imp_ADDR((void *)(NULL))) goto L_022D;
// 3096 l == new label
L = (struct LABELFM *)NEWLABEL();
// 3097 l_id = label; l_tag = new tag
L->ID = LABEL;
L->TAG = NEWTAG();
// 3098 %else %if l_tag < 0 %and label >= 0
goto L_022E;
L_022D:;
if (L->TAG >= 0) goto L_022F;
if (LABEL < 0) goto L_022F;
// 3099 l_tag = new tag
L->TAG = NEWTAG();
// 3100 %finish
L_022F:;
L_022E:;
// 3101 l_tag = l_tag!16_8000
L->TAG = L->TAG | 32768;
// 3102 define tag (l_tag&16_7fff)
DEFINETAG(L->TAG & 32767);
// 3103 uncond jump = 0; !you can get here!
UNCONDJUMP = 0;
// 3104 %end
return;
} /* end of DEFINELABEL */
// 3105
// 3106 %routine JUMP TO (%integer label, cond, def)
void JUMPTO(int LABEL, int COND, int DEF) {
// 3107 %const %byte %array inv (0 : 15) =
const unsigned char INV[16] = {0, 1, 4, 5, 2, 3, 6, 7, 8, 9, 12, 13, 10, 11, 14, 15};
// 3108+ 0, 1, 4, 5, 2, 3, 6, 7,
// 3109+ 0+8,1+8,4+8,5+8,2+8,3+8,6+8,7+8
// 3110 %integer ref
int REF;
// 3111 %record(labelfm) %name lab
struct LABELFM *LAB;
// 3112 invert = 0
INVERT = 0;
// 3113 %return %if label = 0 {jump round routine} %or uncond jump = ca
if (LABEL == 0) goto L_0223;
if (UNCONDJUMP != CA) goto L_0230;
L_0223:;
return;
L_0230:;
// 3114 cond = inv(cond&15) %if cond&16 # 0
if (COND & 16 == 0) goto L_0231;
COND = INV[COND & 15];
L_0231:;
// 3115 lab == find(label)
LAB = (struct LABELFM *)FIND(LABEL);
// 3116 %if lab == null %start
if (_imp_ADDR((void *)(LAB)) != _imp_ADDR((void *)(NULL))) goto L_0232;
// 3117 lab == new label
LAB = (struct LABELFM *)NEWLABEL();
// 3118 lab_id = label
LAB->ID = LABEL;
// 3119 lab_tag = new tag
LAB->TAG = NEWTAG();
// 3120 %else %if lab_tag < 0 %and def # 0
goto L_0233;
L_0232:;
if (LAB->TAG >= 0) goto L_0234;
if (DEF == 0) goto L_0234;
// 3121 lab_tag = new tag
LAB->TAG = NEWTAG();
// 3122 %finish
L_0234:;
L_0233:;
// 3123 %if cond = 32 %start; !from definevar
if (COND != 32) goto L_0235;
// 3124 decvar_disp = lab_tag&16_7fff
DECVAR->DISP = LAB->TAG & 32767;
// 3125 %return
return;
// 3126 %finish
L_0235:;
// 3127 %if cond = jump %then ref = dir uref %c
if (COND != 0) goto L_0236;
REF = 5;
goto L_0237;
L_0236:;
REF = 4;
L_0237:;
// 3128+ %else ref = dir cref
// 3129 flush code
FLUSHCODE();
// 3130 put (obj jump)
PUT(12);
// 3131 put (cond); put word (lab_tag&16_7fff)
PUT(COND);
PUTWORD(LAB->TAG & 32767);
// 3132 define reference (lab_tag&16_7fff, ref)
DEFINEREFERENCE(LAB->TAG & 32767, REF);
// 3133 ca = ca+2; !assume short
CA = CA + 2;
// 3134 uncond jump = ca %if cond = jump; !no way past here
if (COND != 0) goto L_0238;
UNCONDJUMP = CA;
L_0238:;
// 3135 %end
return;
} /* end of JUMPTO */
// 3136
// 3137 %routine DEFINE SWITCH LABEL
void DEFINESWITCHLABEL(void) {
// 3138 %integer tag, switch zero, index
int TAG;
int SWITCHZERO;
int INDEX;
// 3139 switch zero = var(getword)_extra; tag = new tag
SWITCHZERO = VAR[GETWORD()].EXTRA;
TAG = NEWTAG();
// 3140 pop lhs; index = lhs_disp; drop (lhs)
POPLHS();
INDEX = LHS->DISP;
DROP(LHS);
// 3141 define tag (tag); uncond jump = 0
DEFINETAG(TAG);
UNCONDJUMP = 0;
// 3142 flush gla; put (obj set)
FLUSHGLA();
PUT(9);
// 3143 put long (tag); put long (switch zero+index*4)
PUTLONG(TAG);
PUTLONG(SWITCHZERO + INDEX * 4);
// 3144 %end
return;
} /* end of DEFINESWITCHLABEL */
// 3145
// 3146 %routine SWITCH JUMP
void SWITCHJUMP(void) {
// 3147 vstack (var(getword))
VSTACK(/*?*/ &VAR[GETWORD()]);
// 3148 set both; stp = stp - 2
SETBOTH();
STP = STP - 2;
// 3149 lrd (lhs, r1); ! index
LRD(LHS, 2);
// 3150 lrd (rhs, r2); ! address of dope vector
LRD(RHS, 3);
// 3151 prim (swjump)
PRIM(19);
// 3152 uncond jump = ca
UNCONDJUMP = CA;
// 3153 %end
return;
} /* end of SWITCHJUMP */
// 3154
// 3155 !loading routines
// 3156
// 3157 %routine ADDRESS (%record(stackfm) %name v)
void ADDRESS(struct STACKFM * V) {
// 3158 !convert 'v' to a form in which it is directly addressable
// 3159 %own %record(stackfm) xvar = 0
static struct STACKFM XVAR = {0};
// 3160 %integer type, form, disp, len
int TYPE;
int FORM;
int DISP;
int LEN;
// 3161 monitor (v, "Address in") %if diag&32 # 0
if (DIAG & 32 == 0) goto L_0239;
MONITOR(V, _imp_str_literal_size(15, "Address in"));
L_0239:;
// 3162 load (v, any) %if v_oper # 0
if (V->OPER == 0) goto L_023A;
LOAD(V, 17);
L_023A:;
// 3163 %if v_form >= v in rec %start
if (V->FORM < 5) goto L_023B;
// 3164 %if v_disp = 0 %and
if (V->DISP != 0) goto L_023C;
if (V->FORM != 5) goto L_023C;
{
// Double-sided test on 0 (Part I)
int tmp;
if (V->FLAGS != (tmp = 0)) goto L_023C;
// Double-sided test on 0 (Part II)
if (tmp != V->XNO) goto L_023C;
}
// 3165+ v_form = v in rec %and v_flags = 0 = v_xno %start
// 3166 v_form = a in s; v_disp = v_extra
V->FORM = 4;
V->DISP = V->EXTRA;
// 3167 %else
goto L_023D;
L_023C:;
// 3168 type = v_type; form = v_form-3
TYPE = V->TYPE;
FORM = V->FORM - 3;
// 3169 disp = v_disp; len = v_length
DISP = V->DISP;
LEN = V->LENGTH;
// 3170 v_type = integers; v_form = v in s; v_disp = v_extra
V->TYPE = 16;
V->FORM = 2;
V->DISP = V->EXTRA;
// 3171 load (v, any)
LOAD(V, 17);
// 3172 v_type = type; v_form = form
V->TYPE = TYPE;
V->FORM = FORM;
// 3173 v_disp = disp; v_length = len
V->DISP = DISP;
V->LENGTH = LEN;
// 3174 %finish
L_023D:;
// 3175 %finish
L_023B:;
// 3176 %if v_form = a in s %and (v_xno # 0 %or v_base = 0 %or
if (V->FORM != 4) goto L_023E;
if (V->XNO != 0) goto L_023F;
if (V->BASE == 0) goto L_023F;
if (V->FLAGS & 1 == 0) goto L_023E;
L_023F:;
// 3177+ v_flags&indexed # 0) %start
// 3178 len = v_length; type = v_type
LEN = V->LENGTH;
TYPE = V->TYPE;
// 3179 v_form = v in s; v_length = 4; v_type = integers
V->FORM = 2;
V->LENGTH = 4;
V->TYPE = 16;
// 3180 load (v, any)
LOAD(V, 17);
// 3181 v_form = v in s
V->FORM = 2;
// 3182 v_length = len; v_type = type
V->LENGTH = LEN;
V->TYPE = TYPE;
// 3183 %finish
L_023E:;
// 3184 load (v, any) %if v_form = av in s
if (V->FORM != 3) goto L_0240;
LOAD(V, 17);
L_0240:;
// 3185 %if (v_xno # 0 %or v_base = 0) %and v_flags&xdefer # 0 %start
if (V->XNO != 0) goto L_0241;
if (V->BASE != 0) goto L_0242;
L_0241:;
if (V->FLAGS & 2 == 0) goto L_0242;
// 3186 xvar_type = integers; xvar_form = v in s
XVAR.TYPE = 16;
XVAR.FORM = 2;
// 3187 xvar_xno = v_xno; xvar_base = pc; xvar_disp = v_disp
XVAR.XNO = V->XNO;
XVAR.BASE = 16;
XVAR.DISP = V->DISP;
// 3188 load (xvar, any)
LOAD(/*?*/ &XVAR, 17);
// 3189 v_base = xvar_base; v_xno = 0; v_disp = 0;
V->BASE = XVAR.BASE;
V->XNO = 0;
V->DISP = 0;
// 3190 v_flags = v_flags&(\xdefer)
V->FLAGS = V->FLAGS & (~2);
// 3191 %finish
L_0242:;
// 3192 %if v_flags&indexed # 0 %start
if (V->FLAGS & 1 == 0) goto L_0243;
// 3193 %if v_form = v in s %start
if (V->FORM != 2) goto L_0244;
// 3194 %if v_iscale # v_length %start
if (V->ISCALE == V->LENGTH) goto L_0245;
// 3195 len = v_length; v_length = v_iscale
LEN = V->LENGTH;
V->LENGTH = V->ISCALE;
// 3196 type = v_type; v_type = integers
TYPE = V->TYPE;
V->TYPE = 16;
// 3197 v_form = av in s; load (v, any)
V->FORM = 3;
LOAD(V, 17);
// 3198 v_length = len; v_type = type
V->LENGTH = LEN;
V->TYPE = TYPE;
// 3199 v_form = v in s
V->FORM = 2;
// 3200 %finish
L_0245:;
// 3201 %else
goto L_0246;
L_0244:;
// 3202 abort (46)
ABORT(46);
// 3203 %finish
L_0246:;
// 3204 %finish
L_0243:;
// 3205 monitor (v, "Address out") %if diag&32 # 0
if (DIAG & 32 == 0) goto L_0247;
MONITOR(V, _imp_str_literal_size(15, "Address out"));
L_0247:;
// 3206 %end
return;
} /* end of ADDRESS */
// 3207
// 3208 %routine MOVE ARRAYNAME (%record(stackfm) %name v, to)
void MOVEARRAYNAME(struct STACKFM * V, struct STACKFM * TO) {
// 3209 %record(stackfm) w = 0
struct STACKFM W;
W = (struct STACKFM){0};
// 3210 %if v_header < 0 %start; !header complete
if (V->HEADER >= 0) goto L_0248;
// 3211 w_base = v_base; w_disp = v_disp
W.BASE = V->BASE;
W.DISP = V->DISP;
// 3212 w_extra = v_extra; w_type = v_type
W.EXTRA = V->EXTRA;
W.TYPE = V->TYPE;
// 3213 w_xno = v_xno; w_form = v in s
W.XNO = V->XNO;
W.FORM = 2;
// 3214 %if v_form&15 >= v in rec %start
if (V->FORM & 15 < 5) goto L_0249;
// 3215 w_form = a in s
W.FORM = 4;
// 3216 w_disp = v_extra
W.DISP = V->EXTRA;
// 3217 %finish
L_0249:;
// 3218 plant2 (movq, w, to)
PLANT2(13, /*?*/ &W, TO);
// 3219 drop (v)
DROP(V);
// 3220 %return
return;
// 3221 %finish
L_0248:;
// 3222 w_base = gla
W.BASE = 12;
// 3223 w_disp = v_header
W.DISP = V->HEADER;
// 3224 w_type = integers
W.TYPE = 16;
// 3225 w_form = v in s
W.FORM = 2;
// 3226 w_oper = 0
W.OPER = 0;
// 3227 !?PSR?! v_form = v in s; !**************
// 3228 %if to ## spv %start
if (_imp_ADDR((void *)(TO)) == _imp_ADDR((void *)(/*?*/ &SPV))) goto L_024A;
// 3229 !?PSR?! load (v,r3) %if v_base=r0 %or v_base=r1; !*************
// 3230 hazard (r0); hazard (r1)
HAZARD(1);
HAZARD(2);
// 3231 claim (r0); claim (r1)
CLAIM(1);
CLAIM(2);
// 3232 plant2 (movq, w, regv(r0))
PLANT2(13, /*?*/ &W, /*?*/ ®V[0]);
// 3233 %else
goto L_024B;
L_024A:;
// 3234 plant2 (movq, w, to)
PLANT2(13, /*?*/ &W, TO);
// 3235 %finish
L_024B:;
// 3236 amap (v); !*****************
AMAP(V);
// 3237 address (v); !****************
ADDRESS(V);
// 3238 %if to ## spv %start
if (_imp_ADDR((void *)(TO)) == _imp_ADDR((void *)(/*?*/ &SPV))) goto L_024C;
// 3239 plant2 (addl, v, regv(r0))
PLANT2(18288, V, /*?*/ ®V[0]);
// 3240 %if to ## regv(r0) %start
if (_imp_ADDR((void *)(TO)) == _imp_ADDR((void *)(/*?*/ ®V[0]))) goto L_024D;
// 3241 plant2 (movq, regv(r0), to)
PLANT2(13, /*?*/ ®V[0], TO);
// 3242 release (r0); release (r1)
RELEASE(1);
RELEASE(2);
// 3243 %finish
L_024D:;
// 3244 %else
goto L_024E;
L_024C:;
// 3245 w_base = sp; w_disp = 0
W.BASE = 15;
W.DISP = 0;
// 3246 plant2 (addl, v, w)
PLANT2(18288, V, /*?*/ &W);
// 3247 %finish
L_024E:;
// 3248 release (v_base) %if v_form = v in r;!********************
if (V->FORM != 1) goto L_024F;
RELEASE(V->BASE);
L_024F:;
// 3249 drop (v)
DROP(V);
// 3250 %end
return;
} /* end of MOVEARRAYNAME */
// 3251
// 3252 %routine STRING OP (%integer op, %record(stackfm) %name from, to)
void STRINGOP(int OP, struct STACKFM *FROM, struct STACKFM *TO) {
// 3253 %integer old control = control, tl = to_length
int OLDCONTROL;
OLDCONTROL = CONTROL;
int TL;
TL = TO->LENGTH;
// 3254 %record(stackfm) %name reg, len
struct STACKFM *REG;
struct STACKFM *LEN;
// 3255 %if from_flags&indexed # 0 %start
if (FROM->FLAGS & 1 == 0) goto L_0250;
// 3256 amap (from); load (from, any)
AMAP(FROM);
LOAD(FROM, 17);
// 3257 from_form = v in s; from_type = strings
FROM->FORM = 2;
FROM->TYPE = 64;
// 3258 %finish
L_0250:;
// 3259 to_length = 1; ! byte context for MOVC3
TO->LENGTH = 1;
// 3260 address (from); address (to)
ADDRESS(FROM);
ADDRESS(TO);
// 3261 reg == regv(register(0))
REG = (struct STACKFM *)/*?*/ ®V[REGISTER(0) - 1];
// 3262 plant2 (movzbl, from, reg)
PLANT2(72, FROM, REG);
// 3263 claim (from_base)
CLAIM(FROM->BASE);
// 3264 claim (reg_base)
CLAIM(REG->BASE);
// 3265 %if op&len check # 0 %start
if (OP & 131072 == 0) goto L_0251;
// 3266 test assigned (from)
TESTASSIGNED(FROM);
// 3267 control = control&(\ass check); ! So won't be done twice
CONTROL = CONTROL & (~1);
// 3268 op = op - len check
OP = OP - 131072;
// 3269 len == literal(tl-1)
LEN = (struct STACKFM *)LITERAL(TL - 1);
// 3270 len_type = byte+integers
LEN->TYPE = 2 + 16;
// 3271 plant2 (cmpl+byte, len, reg)
PLANT2(240 + 2, LEN, REG);
// 3272 pop drop
POPDROP();
// 3273 prim (test string ovf)
PRIM(25);
// 3274 %finish
L_0251:;
// 3275 plant1 (incl, reg)
PLANT1(96, REG);
// 3276 string3 (op, reg, from, to)
STRING3(OP, REG, FROM, TO);
// 3277 release (reg_base)
RELEASE(REG->BASE);
// 3278 control = old control
CONTROL = OLDCONTROL;
// 3279 %end
return;
} /* end of STRINGOP */
// 3280
// 3281 %routine ASSIGN STRING (%record(stackfm) %name from, to)
void ASSIGNSTRING(struct STACKFM * FROM, struct STACKFM * TO) {
// 3282 %record(stackfm) %name len
struct STACKFM *LEN;
// 3283 %integer op
int OP;
// 3284 %if from_format # 0 %start; !string constant
if (FROM->FORMAT == 0) goto L_0252;
// 3285 address (to)
ADDRESS(TO);
// 3286 %if from_format = 0+1 %start; !null string
if (FROM->FORMAT != 0 + 1) goto L_0253;
// 3287 plant1 (clrl+byte, to); !*clrb_to
PLANT1(48 + 2, TO);
// 3288 %return
return;
// 3289 %finish
L_0253:;
// 3290 len == literal(from_format); stp = stp-1; drop (len)
LEN = (struct STACKFM *)LITERAL(FROM->FORMAT);
STP = STP - 1;
DROP(LEN);
// 3291 %if 0 # to_length < len_disp %start
{
// Double-sided test on TO->LENGTH (Part I)
int tmp;
if (0 == (tmp = TO->LENGTH)) goto L_0254;
// Double-sided test on TO->LENGTH (Part II)
if (tmp >= LEN->DISP) goto L_0254;
}
// 3292 error ('*', "string constant will overflow destination")
ERROR(42, _imp_str_literal_size(127, "string constant will overflow destination"));
// 3293 %finish
L_0254:;
// 3294 string3 (movc3, len ,from, to)
STRING3(30, LEN, FROM, TO);
// 3295 %else
goto L_0255;
L_0252:;
// 3296 op = movc3
OP = 30;
// 3297 %if control&str check # 0 %start
if (CONTROL & 2 == 0) goto L_0256;
// 3298 %if to_type&4 = 0 {dest not work string} %and
if (TO->TYPE & 4 != 0) goto L_0257;
{
// Double-sided test on TO->LENGTH (Part I)
int tmp;
if (0 >= (tmp = TO->LENGTH)) goto L_0257;
// Double-sided test on TO->LENGTH (Part II)
if (tmp >= 256) goto L_0257;
}
// 3299+ 0 < to_length < 256 {ovf possible} %start
// 3300 op = op ! len check
OP = OP | 131072;
// 3301 %finish
L_0257:;
// 3302 %finish
L_0256:;
// 3303 string op (op, from, to)
STRINGOP(OP, FROM, TO);
// 3304 %finish
L_0255:;
// 3305 %end
return;
} /* end of ASSIGNSTRING */
// 3306
// 3307 %routine CONC (%record(stackfm) %name to, with)
void CONC(struct STACKFM * TO, struct STACKFM * WITH) {
// 3308 %record(stackfm) %name t
struct STACKFM *T;
// 3309 %record(stackfm) temp, rest, len
struct STACKFM TEMP;
struct STACKFM REST;
struct STACKFM LEN;
// 3310 %integer to len, wlen, total = 0, op
int TOLEN;
int WLEN;
int TOTAL;
TOTAL = 0;
int OP;
// 3311 to len = to_format-1; wlen = with_format-1
TOLEN = TO->FORMAT - 1;
WLEN = WITH->FORMAT - 1;
// 3312 %if wlen > 0 %and to len > 0 %start
if (WLEN <= 0) goto L_0258;
if (TOLEN <= 0) goto L_0258;
// 3313 ! Initial concat of const/literal strings
// 3314 total = wlen + tolen
TOTAL = WLEN + TOLEN;
// 3315 %finish
L_0258:;
// 3316 %if to_type&4 = 0 %start; ! first one
if (TO->TYPE & 4 != 0) goto L_0259;
// 3317 t == work string; stp = stp - 1
T = (struct STACKFM *)WORKSTRING();
STP = STP - 1;
// 3318 temp = t
TEMP = *T;
// 3319 t_type = strings!4; ! mark as w/string to skip
T->TYPE = 64 | 4;
// 3320 assign string (to, t); ! length check
ASSIGNSTRING(TO, T);
// 3321 drop (t)
DROP(T);
// 3322 %else
goto L_025A;
L_0259:;
// 3323 temp = to
TEMP = *TO;
// 3324 %finish
L_025A:;
// 3325 %if wlen = 0 %start; ! x."" ???
if (WLEN != 0) goto L_025B;
// 3326 drop (with)
DROP(WITH);
// 3327 %return
return;
// 3328 %finish
L_025B:;
// 3329 op = 0; ! 'concat' in STRING OP
OP = 0;
// 3330 rest = 0
REST = (struct STACKFM){0};
// 3331 rest_base = r3
REST.BASE = 4;
// 3332 rest_form = v in s; ! r3 points to free byte in temp
REST.FORM = 2;
// 3333 claim (r3)
CLAIM(4);
// 3334 %if last movc3 # ca %start; ! r3 undefined
if (LASTMOVC3 == CA) goto L_025C;
// 3335 %if temp_type&4 = 0 %and to len >= 0 %start
if (TEMP.TYPE & 4 != 0) goto L_025D;
if (TOLEN < 0) goto L_025D;
// 3336 ! Can work out start of area for new string
// 3337 rest = temp
REST = TEMP;
// 3338 rest_disp = rest_disp + (to len + 1)
REST.DISP = REST.DISP + (TOLEN + 1);
// 3339 release (r3); ! unused..
RELEASE(4);
// 3340 %else
goto L_025E;
L_025D:;
// 3341 plant2 (movzbl, temp, regv(r3))
PLANT2(72, /*?*/ &TEMP, /*?*/ ®V[3]);
// 3342 temp_index = r3; claim (r3!128)
TEMP.INDEX = 4;
CLAIM(4 | 128);
// 3343 temp_flags = indexed
TEMP.FLAGS = 1;
// 3344 temp_disp = temp_disp+1
TEMP.DISP = TEMP.DISP + 1;
// 3345 plant2 (movab, temp, regv(r3))
PLANT2(4114, /*?*/ &TEMP, /*?*/ ®V[3]);
// 3346 temp_disp = temp_disp-1
TEMP.DISP = TEMP.DISP - 1;
// 3347 temp_flags = 0
TEMP.FLAGS = 0;
// 3348 %finish
L_025E:;
// 3349 %finish
L_025C:;
// 3350 len = 0
LEN = (struct STACKFM){0};
// 3351 len_type = integers; len_length = 4
LEN.TYPE = 16;
LEN.LENGTH = 4;
// 3352 %if wlen > 0 %start; ! constant
if (WLEN <= 0) goto L_025F;
// 3353 len_form = constant
LEN.FORM = 0;
// 3354 len_disp = wlen
LEN.DISP = WLEN;
// 3355 %else
goto L_0260;
L_025F:;
// 3356 %if with_flags&indexed # 0 %start
if (WITH->FLAGS & 1 == 0) goto L_0261;
// 3357 amap (with); load (with, any)
AMAP(WITH);
LOAD(WITH, 17);
// 3358 with_form = v in s
WITH->FORM = 2;
// 3359 %finish
L_0261:;
// 3360 %if with_form # v in s %start
if (WITH->FORM == 2) goto L_0262;
// 3361 load (with, any)
LOAD(WITH, 17);
// 3362 with_form = v in s
WITH->FORM = 2;
// 3363 with_type = strings
WITH->TYPE = 64;
// 3364 %finish
L_0262:;
// 3365 %if activity(with_base) = 1 %start
if (ACTIVITY[WITH->BASE] != 1) goto L_0263;
// 3366 ! use auto inc to skip length byte
// 3367 with_flags = auto i
WITH->FLAGS = 4;
// 3368 op = movc3
OP = 30;
// 3369 %finish
L_0263:;
// 3370 claim (with_base)
CLAIM(WITH->BASE);
// 3371 len_form = v in r
LEN.FORM = 1;
// 3372 len_base = register (0)
LEN.BASE = REGISTER(0);
// 3373 plant2 (movzbl, with, len)
PLANT2(72, WITH, /*?*/ &LEN);
// 3374 with_flags = 0
WITH->FLAGS = 0;
// 3375 claim (len_base)
CLAIM(LEN.BASE);
// 3376 %finish
L_0260:;
// 3377 %if total > 0 %start; ! Const total length
if (TOTAL <= 0) goto L_0264;
// 3378 %if total > 255 %start
if (TOTAL <= 255) goto L_0265;
// 3379 error ('*', "string concatenation results in overflow")
ERROR(42, _imp_str_literal_size(127, "string concatenation results in overflow"));
// 3380 total = 255
TOTAL = 255;
// 3381 %finish
L_0265:;
// 3382 plant2 (movb, literal(total), temp)
PLANT2(8970, LITERAL(TOTAL), /*?*/ &TEMP);
// 3383 pop drop
POPDROP();
// 3384 %else
goto L_0266;
L_0264:;
// 3385 iovf off
IOVFOFF();
// 3386 len_type = byte+integers
LEN.TYPE = 2 + 16;
// 3387 plant2 (addb2, len, temp)
PLANT2(18290, /*?*/ &LEN, /*?*/ &TEMP);
// 3388 prim (test string ovf) %if control&str check # 0
if (CONTROL & 2 == 0) goto L_0267;
PRIM(25);
L_0267:;
// 3389 iovf on
IOVFON();
// 3390 %finish
L_0266:;
// 3391 string3 (op!no ass chk, len, with, rest)
STRING3(OP | 262144, /*?*/ &LEN, WITH, /*?*/ &REST);
// 3392 release (len_base)
RELEASE(LEN.BASE);
// 3393 drop (with)
DROP(WITH);
// 3394 to = temp
*TO = TEMP;
// 3395 to_type = strings!in work
TO->TYPE = 64 | 4;
// 3396 %end
return;
} /* end of CONC */
// 3397
// 3398 %routine FLOAT (%record(stackfm) %name v)
void FLOAT(struct STACKFM * V) {
// 3399 %integer r
int R;
// 3400 monitor (v, "Float in") %if diag&2 # 0
if (DIAG & 2 == 0) goto L_0268;
MONITOR(V, _imp_str_literal_size(15, "Float in"));
L_0268:;
// 3401 address (v)
ADDRESS(V);
// 3402 %if v_form = constant %and v_oper = 0 %start
if (V->FORM != 0) goto L_0269;
if (V->OPER != 0) goto L_0269;
// 3403 v_type = reall
V->TYPE = 36;
// 3404 v_lrval = v_disp; !float it here
V->LRVAL = V->DISP;
// 3405 %return
return;
// 3406 %finish
L_0269:;
// 3407 load (v, any) %if v_type = byte+integers %or v_oper # 0
if (V->TYPE == 2 + 16) goto L_026A;
if (V->OPER == 0) goto L_026B;
L_026A:;
LOAD(V, 17);
L_026B:;
// 3408 r = fpr
R = FPR();
// 3409 plant2 (cvtld+(v_type&7)*8, v, regv(r))
PLANT2(60 + (V->TYPE & 7) * 8, V, /*?*/ ®V[R - 1]);
// 3410 claim (r); clear (v)
CLAIM(R);
CLEAR(V);
// 3411 v_base = r; v_disp = 0; v_xno = 0
V->BASE = R;
V->DISP = 0;
V->XNO = 0;
// 3412 v_type = reall; v_form = v in r
V->TYPE = 36;
V->FORM = 1;
// 3413 monitor (v, "Float out") %if diag&2 # 0
if (DIAG & 2 == 0) goto L_026C;
MONITOR(V, _imp_str_literal_size(15, "Float out"));
L_026C:;
// 3414 %end
return;
} /* end of FLOAT */
// 3415
// 3416 %routine EQUATE (%record(stackfm) %name a, b, %integer either)
void EQUATE(struct STACKFM * A, struct STACKFM * B, int EITHER) {
// 3417 %record(stackfm) %name x, y
struct STACKFM *X;
struct STACKFM *Y;
// 3418 %integer key
int KEY;
// 3419 %switch op (0 : 4)
int OP_index;
int OP_line;
char *OP_file;
static const void *OP[5] = {&&case_OP_missing, &&case_OP_missing, &&case_OP_missing, &&case_OP_missing,
&&case_OP_missing};
// 3420 %const %byte %array map (0 : 24) =
const unsigned char MAP[25] = {0, 2, 2, 3, 3, 1, 0, 2, 3, 3, 1, 1, 0, 3, 3, 4, 4, 4, 0, 1, 4, 4, 4, 2, 0};
// 3421+ 0,2,2,3,3, 1,0,2,3,3, 1,1,0,3,3, 4,4,4,0,1, 4,4,4,2,0
// 3422 %return %if a_type = b_type
if (A->TYPE != B->TYPE) goto L_026D;
return;
L_026D:;
// 3423 x == b; y == a
X = (struct STACKFM *)B;
Y = (struct STACKFM *)A;
// 3424 key = (a_type&15)*5+b_type&15
KEY = (A->TYPE & 15) * 5 + (B->TYPE & 15);
// 3425 -> op(map(key))
OP_line = __LINE__;
OP_file = __FILE__;
OP_index = MAP[KEY];
goto case_OP_dispatch;
// 3426 op(1):
case_OP_1:;
// 3427 %return %if either = 0
if (EITHER != 0) goto L_026F;
return;
L_026F:;
// 3428 x == a; y == b
X = (struct STACKFM *)A;
Y = (struct STACKFM *)B;
// 3429 op(2):
case_OP_2:;
// 3430 load (x, any) %if x_form # constant
if (X->FORM == 0) goto L_0270;
LOAD(X, 17);
L_0270:;
// 3431 x_type = y_type
X->TYPE = Y->TYPE;
// 3432 %return
return;
// 3433 op(3):
case_OP_3:;
// 3434 %return %if either = 0
if (EITHER != 0) goto L_0271;
return;
L_0271:;
// 3435 x == a; y == b
X = (struct STACKFM *)A;
Y = (struct STACKFM *)B;
// 3436 op(4):
case_OP_4:;
// 3437 float (x)
FLOAT(X);
// 3438 x_type = y_type %if x_form = constant
if (X->FORM != 0) goto L_0272;
X->TYPE = Y->TYPE;
L_0272:;
// 3439 op(0):
case_OP_0:;
// 3440 %end
return;
case_OP_dispatch:
if (OP_index < 0 || OP_index > 4)
_imp_signalf(6, 3, OP_index, "->OP(%d) out of bounds at %s line %d", OP_index, OP_file, OP_line);
goto *OP[OP_index - 0];
case_OP_missing:
_imp_signalf(8, 2, OP_index, "switch jump to undefined label OP(%d): at %s line %d", OP_index, OP_file, OP_line);
} /* end of EQUATE */
// 3441
// 3442 %predicate SIMPLE SHIFT (%record(stackfm) %name from, to)
int SIMPLESHIFT(struct STACKFM * FROM, struct STACKFM * TO) {
// 3443 %record(stackfm) %name with, lit1, lit2
struct STACKFM *WITH;
struct STACKFM *LIT1;
struct STACKFM *LIT2;
// 3444 %integer pos, size
int POS;
int SIZE;
// 3445 %false %unless (from_oper = lsh %or from_oper = rsh) %and
if (FROM->OPER == 15) goto L_0273;
if (FROM->OPER != 16) goto L_0274;
L_0273:;
if (TO->TYPE == 16) goto L_0275;
L_0274:;
return 0 /*FALSE*/;
L_0275:;
// 3446+ to_type = integers
// 3447 with == from_link
WITH = (struct STACKFM *)FROM->LINK;
// 3448 pos = -with_disp
POS = -WITH->DISP;
// 3449 %false %unless pos >= 0 %and with_form = constant
if (POS < 0) goto L_0276;
if (WITH->FORM == 0) goto L_0277;
L_0276:;
return 0 /*FALSE*/;
L_0277:;
// 3450 from_oper = 0; drop (with)
FROM->OPER = 0;
DROP(WITH);
// 3451 size = 32
SIZE = 32;
// 3452 size = 16 %if from_type = short+integers
if (FROM->TYPE != 1 + 16) goto L_0278;
SIZE = 16;
L_0278:;
// 3453 size = 8 %if from_type = byte+integers
if (FROM->TYPE != 2 + 16) goto L_0279;
SIZE = 8;
L_0279:;
// 3454 pos = size %if pos > size
if (POS <= SIZE) goto L_027A;
POS = SIZE;
L_027A:;
// 3455 size = size - pos; !size of result
SIZE = SIZE - POS;
// 3456 address (from); address (to)
ADDRESS(FROM);
ADDRESS(TO);
// 3457 lit1 == literal(pos)
LIT1 = (struct STACKFM *)LITERAL(POS);
// 3458 lit2 == literal(size); lit2_type = byte+integers
LIT2 = (struct STACKFM *)LITERAL(SIZE);
LIT2->TYPE = 2 + 16;
// 3459 plant4 (extzv, lit1, lit2, from, to)
PLANT4(87, LIT1, LIT2, FROM, TO);
// 3460 pop drop; pop drop
POPDROP();
POPDROP();
// 3461 clear (from); drop (from)
CLEAR(FROM);
DROP(FROM);
// 3462 %true
return 1 /*TRUE*/;
// 3463 %end
} /* end of SIMPLESHIFT */
// 3464
// 3465 %routine LOAD (%record(stackfm) %name v, %integer reg)
void LOAD(struct STACKFM * V, int REG) {
// 3466 !load the entity described by 'v' into reg
// 3467 %integer oper, op, other, type, vtype, two op = 0
int OPER;
int OP;
int OTHER;
int TYPE;
int VTYPE;
int TWOOP;
TWOOP = 0;
// 3468 %record(stackfm) %name w, rv, x
struct STACKFM *W;
struct STACKFM *RV;
struct STACKFM *X;
// 3469 %switch iop (not : brem), rop (not : brem)
int IOP_index;
int IOP_line;
char *IOP_file;
static const void *IOP[23] = {&&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing,
&&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing,
&&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing,
&&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing,
&&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing,
&&case_IOP_missing, &&case_IOP_missing, &&case_IOP_missing};
int ROP_index;
int ROP_line;
char *ROP_file;
static const void *ROP[23] = {&&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing,
&&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing,
&&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing,
&&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing,
&&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing,
&&case_ROP_missing, &&case_ROP_missing, &&case_ROP_missing};
// 3470
// 3471 abort (37) %unless r0 <= reg <= fpr4; !load what???
{
// Double-sided test on REG (Part I)
int tmp;
if (1 > (tmp = REG)) goto L_027B;
// Double-sided test on REG (Part II)
if (tmp <= 20) goto L_027C;
}
L_027B:;
ABORT(37);
L_027C:;
// 3472 used(reg) = ca %if reg < any; !prevent intermediate use
if (REG >= 17) goto L_027D;
USED[REG] = CA;
L_027D:;
// 3473 %if v_oper = 0 %and v_form = av in rec %start
if (V->OPER != 0) goto L_027E;
if (V->FORM != 6) goto L_027E;
// 3474 address var (1, v)
ADDRESSVAR(1, V);
// 3475 %finish
L_027E:;
// 3476 type = v_type; vtype = integers; !default
TYPE = V->TYPE;
VTYPE = 16;
// 3477 oper = v_oper
OPER = V->OPER;
// 3478 monitor (v, "Load ".reg name(reg)) %if diag&2 # 0
if (DIAG & 2 == 0) goto L_027F;
MONITOR(V,
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("Load "), (_imp_string *)/*?*/ ®NAME[REG]);
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string15 *)&tmp;
})
);
L_027F:;
// 3479 %unless fpr0 <= reg <= fpr4 %or floating (v) %start
{
// Double-sided test on REG (Part I)
int tmp;
if (18 > (tmp = REG)) goto L_0280;
// Double-sided test on REG (Part II)
if (tmp <= 20) goto L_0281;
}
L_0280:;
if (FLOATING(V)) goto L_0281;
// 3480 ! Load integer
// 3481 %if oper # 0 %start; !complex descriptor
if (OPER == 0) goto L_0282;
// 3482 v_oper = 0
V->OPER = 0;
// 3483 w == v_link
W = (struct STACKFM *)V->LINK;
// 3484 %if oper = exp %start
if (OPER != 21) goto L_0283;
// 3485 load (v, r1); load (w, r2)
LOAD(V, 2);
LOAD(W, 3);
// 3486 drop (w)
DROP(W);
// 3487 release (r1); release (r2)
RELEASE(2);
RELEASE(3);
// 3488 prim (exp int)
PRIM(14);
// 3489 v_base = r0; claim (r0)
V->BASE = 1;
CLAIM(1);
// 3490 load (v, reg) %unless reg = any
if (REG == 17) goto L_0284;
LOAD(V, REG);
L_0284:;
// 3491 %return
return;
// 3492 %finish
L_0283:;
// 3493 %if oper = rsh %or oper = lsh %start
if (OPER == 16) goto L_0285;
if (OPER != 15) goto L_0286;
L_0285:;
// 3494 ! These take BYTE shift counts
// 3495 load (w, any) %if w_flags&indexed # 0 %and
if (W->FLAGS & 1 == 0) goto L_0287;
if (W->TYPE == 2 + 16) goto L_0287;
LOAD(W, 17);
L_0287:;
// 3496+ w_type # byte+integers
// 3497 %finish
L_0286:;
// 3498 %if oper = rsh %or oper = remy %start
if (OPER == 16) goto L_0288;
if (OPER != 28) goto L_0289;
L_0288:;
// 3499 ! fiddly - need reg pair...
// 3500 load (v, register(1)) %unless in free reg (v) %and
if (!(INFREEREG(V))) goto L_028A;
if (ACTIVITY[V->BASE + 1] == 0) goto L_028B;
L_028A:;
LOAD(V, REGISTER(1));
L_028B:;
// 3501+ activity(v_base+1) = 0
// 3502 other = v_base+1
OTHER = V->BASE + 1;
// 3503 abort (30) %if activity(other) < 0
if (ACTIVITY[OTHER] >= 0) goto L_028C;
ABORT(30);
L_028C:;
// 3504 hazard (other); !reg is never r10
HAZARD(OTHER);
// 3505 %if oper = rsh %start
if (OPER != 16) goto L_028D;
// 3506 plant1 (clrl, regv(other))
PLANT1(48, /*?*/ ®V[OTHER - 1]);
// 3507 %else
goto L_028E;
L_028D:;
// 3508 !rem - sign extend to 2nd register
// 3509 %if const (v) %start
if (!(CONST(V))) goto L_028F;
// 3510 plant2 (movl, literal(-(v_disp>>31)), regv(other))
PLANT2(8968, LITERAL(-((unsigned int)V->DISP >> 31)), /*?*/ ®V[OTHER - 1]);
// 3511 pop drop
POPDROP();
// 3512 %else
goto L_0290;
L_028F:;
// 3513 plant4 (extv, literal(31), literal(1),
PLANT4(95, LITERAL(31), LITERAL(1), /*?*/ ®V[V->BASE - 1], /*?*/ ®V[OTHER - 1]);
// 3514+ regv(v_base), regv(other))
// 3515 pop drop; pop drop
POPDROP();
POPDROP();
// 3516 %finish
L_0290:;
// 3517 %finish
L_028E:;
// 3518 claim (other)
CLAIM(OTHER);
// 3519 address (w)
ADDRESS(W);
// 3520 w_type = integers %if oper = rsh; ! to prevent loading
if (OPER != 16) goto L_0291;
W->TYPE = 16;
L_0291:;
// 3521 %else
goto L_0292;
L_0289:;
// 3522 %if v_type = integers %start
if (V->TYPE != 16) goto L_0293;
// 3523 address (v)
ADDRESS(V);
// 3524 %else
goto L_0294;
L_0293:;
// 3525 load (v, reg); reg = v_base
LOAD(V, REG);
REG = V->BASE;
// 3526 %finish
L_0294:;
// 3527 %finish
L_0292:;
// 3528 %if oper >= add %start
if (OPER < 9) goto L_0295;
// 3529 address (w)
ADDRESS(W);
// 3530 load (w, any) %if w_type # integers
if (W->TYPE == 16) goto L_0296;
LOAD(W, 17);
L_0296:;
// 3531 op = op map(oper)
OP = OPMAP[OPER - 9];
// 3532 %finish
L_0295:;
// 3533 %if oper # rsh %start
if (OPER == 16) goto L_0297;
// 3534 %if reg = any %start
if (REG != 17) goto L_0298;
// 3535 %if oper >= add %and op # 0 %start;! two op possible?
if (OPER < 9) goto L_0299;
if (OP == 0) goto L_0299;
// 3536 %if op&commute # 0 %and in free reg (w) %start
if (OP & 16384 == 0) goto L_029A;
if (!(INFREEREG(W))) goto L_029A;
// 3537 reg = w_base; x == v; two op = 1
REG = W->BASE;
X = (struct STACKFM *)V;
TWOOP = 1;
// 3538 %else %if in free reg (v)
goto L_029B;
L_029A:;
if (!(INFREEREG(V))) goto L_029C;
// 3539 reg = v_base; x == w; two op = 1
REG = V->BASE;
X = (struct STACKFM *)W;
TWOOP = 1;
// 3540 %finish
L_029C:;
L_029B:;
// 3541 %finish
L_0299:;
// 3542 reg = register (0) %if reg = any; ! Not yet got one?
if (REG != 17) goto L_029D;
REG = REGISTER(0);
L_029D:;
// 3543 %else
goto L_029E;
L_0298:;
// 3544 hazard (reg) %unless v_base = reg %or
if (V->BASE == REG) goto L_029F;
if (OPER < 9) goto L_02A0;
if (W->BASE == REG) goto L_029F;
L_02A0:;
HAZARD(REG);
L_029F:;
// 3545+ (oper >= add %and w_base = reg)
// 3546 %finish
L_029E:;
// 3547 rv == regv(reg)
RV = (struct STACKFM *)/*?*/ ®V[REG - 1];
// 3548 %finish
L_0297:;
// 3549
// 3550 -> iop(oper)
IOP_line = __LINE__;
IOP_file = __FILE__;
IOP_index = OPER;
goto case_IOP_dispatch;
// 3551
// 3552 iop(neg):plant2 (mnegl, v, rv); -> set
case_IOP_8:;
PLANT2(0, V, RV);
goto U_1005;
// 3553 iop(not):plant2 (mcoml, v, rv); -> set
case_IOP_7:;
PLANT2(24, V, RV);
goto U_1005;
// 3554
// 3555 iop(mul):
case_IOP_27:;
// 3556 %if w_form = constant %and (w_disp = 2 %or w_disp = 4) %start
if (W->FORM != 0) goto L_02A2;
if (W->DISP == 2) goto L_02A3;
if (W->DISP != 4) goto L_02A2;
L_02A3:;
// 3557 plant2 (movl, v, rv) %if two op = 0
if (TWOOP != 0) goto L_02A4;
PLANT2(8968, V, RV);
L_02A4:;
// 3558 plant2 (addl, rv, rv)
PLANT2(18288, RV, RV);
// 3559 plant2 (addl, rv, rv) %if w_disp = 4
if (W->DISP != 4) goto L_02A5;
PLANT2(18288, RV, RV);
L_02A5:;
// 3560 -> wset
goto U_1006;
// 3561 %finish
L_02A2:;
// 3562 iop(add):
case_IOP_9:;
// 3563 iop(or ):
case_IOP_13:;
// 3564 iop(xor):
case_IOP_14:;
// 3565 iop(sub):
case_IOP_10:;
// 3566 iop(div):
case_IOP_17:;
// 3567 iop(bic):
case_IOP_12:;
// 3568 %if two op # 0 %start
if (TWOOP == 0) goto L_02A6;
// 3569 plant2 (op - three op, x, rv)
PLANT2(OP - 64, X, RV);
// 3570 %else
goto L_02A7;
L_02A6:;
// 3571 plant3 (op, w, v, rv)
PLANT3(OP, W, V, RV);
// 3572 %finish
L_02A7:;
// 3573 -> wset
goto U_1006;
// 3574 iop(remy):
case_IOP_28:;
// 3575 plant4 (ediv, w, v, rv, rv)
PLANT4(143, W, V, RV, RV);
// 3576 release (other)
RELEASE(OTHER);
// 3577 -> wset
goto U_1006;
// 3578 iop(lsh):
case_IOP_15:;
// 3579 iop(rsh): ! rsh converted
case_IOP_16:;
// 3580 w_type = byte+integers
W->TYPE = 2 + 16;
// 3581 w_disp = w_disp&255 %if const (w)
if (!(CONST(W))) goto L_02A8;
W->DISP = W->DISP & 255;
L_02A8:;
// 3582 iovf off
IOVFOFF();
// 3583 %if oper = lsh %start
if (OPER != 15) goto L_02A9;
// 3584 plant3 (ashl, w, v, rv)
PLANT3(141, W, V, RV);
// 3585 iovf on
IOVFON();
// 3586 %else
goto L_02AA;
L_02A9:;
// 3587 plant3 (ashq, w, v, v)
PLANT3(142, W, V, V);
// 3588 iovf on
IOVFON();
// 3589 release (other)
RELEASE(OTHER);
// 3590 load (v, reg)
LOAD(V, REG);
// 3591 clear (w); drop (w)
CLEAR(W);
DROP(W);
// 3592 %return
return;
// 3593 %finish
L_02AA:;
// 3594
// 3595 wset: clear (w); drop (w)
U_1006:;
CLEAR(W);
DROP(W);
// 3596 -> set
goto U_1005;
// 3597
// 3598 iop(*): abort (33)
case_IOP_default:;
ABORT(33);
// 3599
// 3600 %else
L_0282:;
// 3601 ! just a simple descriptor
// 3602 amap (v) %if type&strings # 0; !only need address of string
if (TYPE & 64 == 0) goto L_02AB;
AMAP(V);
L_02AB:;
// 3603 %if reg = any %start; !none in particular
if (REG != 17) goto L_02AC;
// 3604 ! select an appropriate register
// 3605 %if activity (v_base) = 1 %start
if (ACTIVITY[V->BASE] != 1) goto L_02AD;
// 3606 ! Use own base
// 3607 %return %if v_form = v in r; !ok where it is
if (V->FORM != 1) goto L_02AE;
return;
L_02AE:;
// 3608 reg = v_base
REG = V->BASE;
// 3609 %else; !any other will do
goto L_02AF;
L_02AD:;
// 3610 reg = register(0)
REG = REGISTER(0);
// 3611 %finish
L_02AF:;
// 3612 %else; !specific register required
goto L_02B0;
L_02AC:;
// 3613 %if reg = v_base %start
if (REG != V->BASE) goto L_02B1;
// 3614 %return %if v_form = v in r
if (V->FORM != 1) goto L_02B2;
return;
L_02B2:;
// 3615 %else
goto L_02B3;
L_02B1:;
// 3616 hazard (reg)
HAZARD(REG);
// 3617 %finish
L_02B3:;
// 3618 %finish
L_02B0:;
// 3619 %finish
// 3620 %else
goto L_02B4;
L_0281:;
// 3621 ! Load real
// 3622 vtype = reall
VTYPE = 36;
// 3623 %if oper # 0 %and %not floating(v) %start
if (OPER == 0) goto L_02B5;
if (FLOATING(V)) goto L_02B5;
// 3624 ! integer operation pending
// 3625 load (v, any); oper = 0
LOAD(V, 17);
OPER = 0;
// 3626 %finish
L_02B5:;
// 3627 %if oper # 0 %start
if (OPER == 0) goto L_02B6;
// 3628 v_oper = 0; w == v_link
V->OPER = 0;
W = (struct STACKFM *)V->LINK;
// 3629 %if oper = rexp %start
if (OPER != 22) goto L_02B7;
// 3630 load (v, fpr2)
LOAD(V, 19);
// 3631 load (w, r4)
LOAD(W, 5);
// 3632 drop (w)
DROP(W);
// 3633 release (fpr2); release (r4)
RELEASE(19);
RELEASE(5);
// 3634 prim (exp real)
PRIM(15);
// 3635 v_base = fpr0; claim (fpr0)
V->BASE = 18;
CLAIM(18);
// 3636 load (v, reg) %unless reg = any
if (REG == 17) goto L_02B8;
LOAD(V, REG);
L_02B8:;
// 3637 %return
return;
// 3638 %finish
L_02B7:;
// 3639 %if v_type # reall %start
if (V->TYPE == 36) goto L_02B9;
// 3640 float (v) %unless v_type = reals;!??something fishy here??
if (V->TYPE == 35) goto L_02BA;
FLOAT(V);
L_02BA:;
// 3641 load (v, reg); reg = v_base
LOAD(V, REG);
REG = V->BASE;
// 3642 %else
goto L_02BB;
L_02B9:;
// 3643 address (v)
ADDRESS(V);
// 3644 %finish
L_02BB:;
// 3645 %if oper >= add %start
if (OPER < 9) goto L_02BC;
// 3646 address (w)
ADDRESS(W);
// 3647 float (w) %unless floating (w)
if (FLOATING(W)) goto L_02BD;
FLOAT(W);
L_02BD:;
// 3648 load (w, any) %unless w_type = reall
if (W->TYPE == 36) goto L_02BE;
LOAD(W, 17);
L_02BE:;
// 3649 clear (w); drop (w)
CLEAR(W);
DROP(W);
// 3650 %finish
L_02BC:;
// 3651 %if reg = any %start
if (REG != 17) goto L_02BF;
// 3652 %if v_form = v in r %then reg = v_base %else reg = fpr
if (V->FORM != 1) goto L_02C0;
REG = V->BASE;
goto L_02C1;
L_02C0:;
REG = FPR();
L_02C1:;
// 3653 %else
goto L_02C2;
L_02BF:;
// 3654 hazard (reg) %unless reg = v_base
if (REG == V->BASE) goto L_02C3;
HAZARD(REG);
L_02C3:;
// 3655 %finish
L_02C2:;
// 3656 rv == regv(reg)
RV = (struct STACKFM *)/*?*/ ®V[REG - 1];
// 3657 -> rop(oper)
ROP_line = __LINE__;
ROP_file = __FILE__;
ROP_index = OPER;
goto case_ROP_dispatch;
// 3658
// 3659 rop(neg):plant2 (mnegd, v, rv); -> set
case_ROP_8:;
PLANT2(4, V, RV);
goto U_1005;
// 3660
// 3661 rop(add):plant3 (addd+three op, v, w, rv); -> set
case_ROP_9:;
PLANT3(18292 + 64, V, W, RV);
goto U_1005;
// 3662 rop(sub):plant3 (subd+three op, w, v, rv); -> set
case_ROP_10:;
PLANT3(2940 + 64, W, V, RV);
goto U_1005;
// 3663 rop(mul):plant3 (muld+three op, v, w, rv); -> set
case_ROP_27:;
PLANT3(17028 + 64, V, W, RV);
goto U_1005;
// 3664 rop(rdiv):plant3 (divd+three op, w, v, rv); -> set
case_ROP_23:;
PLANT3(652 + 64, W, V, RV);
goto U_1005;
// 3665
// 3666 rop(*): abort (32)
case_ROP_default:;
ABORT(32);
// 3667
// 3668 %else
L_02B6:;
// 3669 ! Simple real object
// 3670 float (v) %and type = reall %if type&real bit = 0
if (TYPE & 32 != 0) goto L_02C5;
FLOAT(V);
TYPE = 36;
L_02C5:;
// 3671 %if reg = any %start
if (REG != 17) goto L_02C6;
// 3672 %return %if v_form = v in r %and v_type = reall
if (V->FORM != 1) goto L_02C7;
if (V->TYPE != 36) goto L_02C7;
return;
L_02C7:;
// 3673 reg = fpr
REG = FPR();
// 3674 %else
goto L_02C8;
L_02C6:;
// 3675 %return %if reg = v_base
if (REG != V->BASE) goto L_02C9;
return;
L_02C9:;
// 3676 hazard (reg)
HAZARD(REG);
// 3677 %finish
L_02C8:;
// 3678 %finish
// 3679 %finish
L_02B4:;
// 3680 op = (7+type&7)*8 + vtype&7
OP = (7 + (TYPE & 7)) * 8 + (VTYPE & 7);
// 3681 op = movl %if type = integers %or zero (v)
if (TYPE == 16) goto L_02CA;
if (!(ZERO(V))) goto L_02CB;
L_02CA:;
OP = 8968;
L_02CB:;
// 3682 %if v_form = av in s %or v_form = av in rec %start
if (V->FORM == 3) goto L_02CC;
if (V->FORM != 6) goto L_02CD;
L_02CC:;
// 3683 op = moval + type&7
OP = 4112 + (TYPE & 7);
// 3684 v_form = v_form - 1
V->FORM = V->FORM - 1;
// 3685 %finish
L_02CD:;
// 3686 address (v)
ADDRESS(V);
// 3687 scale index (op, v)
SCALEINDEX(/*?*/ &OP, V);
// 3688 plant2 (op, v, regv(reg))
PLANT2(OP, V, /*?*/ ®V[REG - 1]);
// 3689 set:
U_1005:;
// 3690 clear (v)
CLEAR(V);
// 3691 claim (reg)
CLAIM(REG);
// 3692 v_type = vtype
V->TYPE = VTYPE;
// 3693 v_form = v in r
V->FORM = 1;
// 3694 v_base = reg
V->BASE = REG;
// 3695 v_disp = 0; v_extra = 0
V->DISP = 0;
V->EXTRA = 0;
// 3696 v_xno = 0; v_flags = 0
V->XNO = 0;
V->FLAGS = 0;
// 3697 %end
return;
case_IOP_dispatch:
if (IOP_index < 7 || IOP_index > 29)
_imp_signalf(6, 3, IOP_index, "->IOP(%d) out of bounds at %s line %d", IOP_index, IOP_file, IOP_line);
goto *IOP[IOP_index - 7];
case_IOP_missing:
_imp_signalf(8, 2, IOP_index, "switch jump to undefined label IOP(%d): at %s line %d", IOP_index, IOP_file,
IOP_line);
case_ROP_dispatch:
if (ROP_index < 7 || ROP_index > 29)
_imp_signalf(6, 3, ROP_index, "->ROP(%d) out of bounds at %s line %d", ROP_index, ROP_file, ROP_line);
goto *ROP[ROP_index - 7];
case_ROP_missing:
_imp_signalf(8, 2, ROP_index, "switch jump to undefined label ROP(%d): at %s line %d", ROP_index, ROP_file,
ROP_line);
} /* end of LOAD */
// 3698
// 3699 %routine COP (%integer op, %integername l, %integer r)
void COP(int OP, int *L, int R) {
// 3700 !perform a compile-time operation
// 3701 %switch c (not : brem)
int C_index;
int C_line;
char *C_file;
static const void *C[23] = {
&&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing,
&&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing,
&&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing,
&&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing, &&case_C_missing};
// 3702 -> c (op)
C_line = __LINE__;
C_file = __FILE__;
C_index = OP;
goto case_C_dispatch;
// 3703 c(add): l = l+r; %return
case_C_9:;
*L = *L + R;
return;
// 3704 c(sub): l = l-r; %return
case_C_10:;
*L = *L - R;
return;
// 3705 c(bsub): l = r-l; %return
case_C_11:;
*L = R - *L;
return;
// 3706 c(mul): l = l*r; %return
case_C_27:;
*L = *L * R;
return;
// 3707 c(div): error ('*', "cannot divide by 0") %and r = 1 %if r = 0
case_C_17:;
if (R != 0) goto L_02CF;
ERROR(42, _imp_str_literal_size(127, "cannot divide by 0"));
R = 1;
L_02CF:;
// 3708 l = l//r; %return
*L = ((long)*L / (long)R);
return;
// 3709 c(remy): error ('*', "cannot take REM (c, 0)") %and r = 1 %if r = 0
case_C_28:;
if (R != 0) goto L_02D0;
ERROR(42, _imp_str_literal_size(127, "cannot take REM (c, 0)"));
R = 1;
L_02D0:;
// 3710 l = l-l//r*r; %return
*L = *L - ((long)*L / (long)R) * R;
return;
// 3711 c(bic): l = l&(\r); %return
case_C_12:;
*L = *L & (~R);
return;
// 3712 c(or ): l = l!r; %return
case_C_13:;
*L = *L | R;
return;
// 3713 c(xor): l = l!!r; %return
case_C_14:;
*L = *L ^ R;
return;
// 3714 c(rsh):!!!!!! rsh is same as lsh with shift negated, so << NOT >>
case_C_16:;
// 3715 c(lsh): l = l>>(-r); %return
case_C_15:;
*L = (unsigned int)*L >> -R;
return;
// 3716 c(exp): l = l\\r; %return
case_C_21:;
*L = _imp_IEXP(*L, R);
return;
// 3717 c(neg):
case_C_8:;
// 3718 c(not):
case_C_7:;
// 3719 c(rdiv):
case_C_23:;
// 3720 c(rexp):
case_C_22:;
// 3721 c(*):
case_C_default:;
// 3722 abort (19)
ABORT(19);
// 3723 %end
return;
case_C_dispatch:
if (C_index < 7 || C_index > 29)
_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 - 7];
case_C_missing:
_imp_signalf(8, 2, C_index, "switch jump to undefined label C(%d): at %s line %d", C_index, C_file, C_line);
} /* end of COP */
// 3724
// 3725 %routine OPERATE (%integer oper)
void OPERATE(int OPER) {
// 3726 %integer key, lcon, rcon, wcon, lop, rop, scale, j
int KEY;
int LCON;
int RCON;
int WCON;
int LOP;
int ROP;
int SCALE;
int J;
// 3727 %record(stackfm) %name with, lh, rh
struct STACKFM *WITH;
struct STACKFM *LH;
struct STACKFM *RH;
// 3728
// 3729 %routine LOSE (%record(stackfm) %name v)
void LOSE(struct STACKFM * V) {
// 3730 %if v_oper > neg %start
if (V->OPER <= 8) goto L_02D1;
// 3731 clear (v_link); drop (v_link)
CLEAR(V->LINK);
DROP(V->LINK);
// 3732 %finish
L_02D1:;
// 3733 clear (v); drop (v)
CLEAR(V);
DROP(V);
// 3734 %end
return;
} /* end of LOSE */
// 3735
// 3736 %routine SWAP
void SWAP(void) {
// 3737 %record(stackfm) temp
struct STACKFM TEMP;
// 3738 %integer t
int T;
// 3739 temp = lh; lh = rh; rh = temp
TEMP = *LH;
*LH = *RH;
*RH = TEMP;
// 3740 t = lcon; lcon = rcon; rcon = t
T = LCON;
LCON = RCON;
RCON = T;
// 3741 lop = lh_oper; rop = rh_oper
LOP = LH->OPER;
ROP = RH->OPER;
// 3742 %end
return;
} /* end of SWAP */
// 3743
// 3744 %predicate GOOD BASE (%record(stack fm) %name v, %integer mult)
int GOODBASE(struct STACKFM * V, int MULT) {
// 3745 ! Is v a suitable candidate for doing addition
// 3746 ! by address op fiddling?
// 3747 %integer f, t, d
int F;
int T;
int D;
// 3748 ! directly usable?
// 3749 %false %if v_flags&indexed # 0; ! already indexed
if (V->FLAGS & 1 == 0) goto L_02D2;
return 0 /*FALSE*/;
L_02D2:;
// 3750 %false %if v_oper # 0
if (V->OPER == 0) goto L_02D3;
return 0 /*FALSE*/;
L_02D3:;
// 3751 %if v_form = constant %and v_type = integers %and
if (V->FORM != 0) goto L_02D4;
if (V->TYPE != 16) goto L_02D4;
{
// Double-sided test on V->DISP (Part I)
int tmp;
if (0 > (tmp = V->DISP)) goto L_02D5;
// Double-sided test on V->DISP (Part II)
if (tmp <= 63) goto L_02D4;
}
L_02D5:;
if (MULT == 1) goto L_02D4;
// 3752+ %not 0 <= v_disp <= 63 %and mult # 1 %start
// 3753 v_form = av in s; v_base = 0
V->FORM = 3;
V->BASE = 0;
// 3754 %finish
L_02D4:;
// 3755 f = v_form; t = v_type
F = V->FORM;
T = V->TYPE;
// 3756 %true %if f = av in s %or
if (F == 3) goto L_02D6;
if (MULT == 1) goto L_02D7;
if (T != 16) goto L_02D7;
if (F != 2) goto L_02D7;
L_02D6:;
return 1 /*TRUE*/;
L_02D7:;
// 3757+ (mult # 1 %and t = integers %and
// 3758+ f = v in s); ! useable directly
// 3759 %false %unless f = av in rec %or
if (F == 6) goto L_02D8;
if (MULT == 1) goto L_02D9;
if (T != 16) goto L_02D9;
if (F == 5) goto L_02D8;
L_02D9:;
return 0 /*FALSE*/;
L_02D8:;
// 3760+ (mult # 1 %and t = integers %and f = v in rec)
// 3761 v_form = v in s; d = v_disp; v_disp = v_extra
V->FORM = 2;
D = V->DISP;
V->DISP = V->EXTRA;
// 3762 %if d = 0 %and f = v in rec %start
if (D != 0) goto L_02DA;
if (F != 5) goto L_02DA;
// 3763 v_form = a in s
V->FORM = 4;
// 3764 f = av in rec; ! => av in s
F = 6;
// 3765 %finish
L_02DA:;
// 3766 load (v, any)
LOAD(V, 17);
// 3767 v_disp = d; v_form = f - rec mod
V->DISP = D;
V->FORM = F - 3;
// 3768 %true
return 1 /*TRUE*/;
// 3769 %end
} /* end of GOODBASE */
// 3770
// 3771 %if diag&256 # 0 %start
if (DIAG & 256 == 0) goto L_02DB;
// 3772 print string ("Operate: ")
_imp_PRINTSTRING(_imp_str_literal("Operate: "));
// 3773 print string (op name(oper))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string4) tmp = OPNAME[OPER - 7] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 3774 newline
_imp_NEWLINE();
// 3775 %finish
L_02DB:;
// 3776
// 3777 %if oper <= neg %start; !unary
if (OPER > 8) goto L_02DC;
// 3778 abort (17) %if stp <= 0
if (STP > 0) goto L_02DD;
ABORT(17);
L_02DD:;
// 3779 lh == stacked(stp); lop = lh_oper
LH = (struct STACKFM *)STACKED[STP - 1];
LOP = LH->OPER;
// 3780 monitor (lh, "Oper in TOS") %if diag&256 # 0
if (DIAG & 256 == 0) goto L_02DE;
MONITOR(LH, _imp_str_literal_size(15, "Oper in TOS"));
L_02DE:;
// 3781 %if const (lh) %start
if (!(CONST(LH))) goto L_02DF;
// 3782 lh_disp = \lh_disp+oper-not; ! generates - or \ as req.
LH->DISP = (~LH->DISP) + OPER - 7;
// 3783 %else %if lh_form = constant %and lop = 0; ! real constant
goto L_02E0;
L_02DF:;
if (LH->FORM != 0) goto L_02E1;
if (LOP != 0) goto L_02E1;
// 3784 lh_lrval = -lh_lrval
LH->LRVAL = -LH->LRVAL;
// 3785 %else %if 0 # lop <= neg; ! unary pending
goto L_02E0;
L_02E1:;
{
// Double-sided test on LOP (Part I)
int tmp;
if (0 == (tmp = LOP)) goto L_02E2;
// Double-sided test on LOP (Part II)
if (tmp > 8) goto L_02E2;
}
// 3786 %if oper = lop %start; ! -(-A) => A
if (OPER != LOP) goto L_02E3;
// 3787 lh_oper = 0
LH->OPER = 0;
// 3788 %else
goto L_02E4;
L_02E3:;
// 3789 cstack (2*(oper-not)-1); ! neg=8,not=7
CSTACK(2 * (OPER - 7) - 1);
// 3790 operate (add)
OPERATE(9);
// 3791 %finish
L_02E4:;
// 3792 %else
goto L_02E0;
L_02E2:;
// 3793 %if lop # 0 %start
if (LOP == 0) goto L_02E5;
// 3794 %if oper = neg %and lop = sub %start
if (OPER != 8) goto L_02E6;
if (LOP != 10) goto L_02E6;
// 3795 ! -(A-B) => B-A
// 3796 with == lh_link; lh_link == null; oper = 0
WITH = (struct STACKFM *)LH->LINK;
LH->LINK = (struct STACKFM *)NULL;
OPER = 0;
// 3797 with_link == lh; with_oper = sub
WITH->LINK = (struct STACKFM *)LH;
WITH->OPER = 10;
// 3798 stacked(stp) == with
STACKED[STP - 1] = (struct STACKFM *)WITH;
// 3799 %else
goto L_02E7;
L_02E6:;
// 3800 load (lh, any)
LOAD(LH, 17);
// 3801 %finish
L_02E7:;
// 3802 %finish
L_02E5:;
// 3803 lh_oper = oper; lh_link == null
LH->OPER = OPER;
LH->LINK = (struct STACKFM *)NULL;
// 3804 %finish
L_02E0:;
// 3805 -> out
goto U_1007;
// 3806 %finish
L_02DC:;
// 3807
// 3808 abort (18) %if stp <= 1
if (STP > 1) goto L_02E8;
ABORT(18);
L_02E8:;
// 3809 stp = stp - 1; ! pop one
STP = STP - 1;
// 3810 lcon = 0; rcon = 0; wcon = 0
LCON = 0;
RCON = 0;
WCON = 0;
// 3811 lh == stacked(stp)
LH = (struct STACKFM *)STACKED[STP - 1];
// 3812 rh == stacked(stp+1)
RH = (struct STACKFM *)STACKED[STP + 1 - 1];
// 3813
// 3814 %if diag&256 # 0 %start
if (DIAG & 256 == 0) goto L_02E9;
// 3815 monitor (lh, "Oper in LHS")
MONITOR(LH, _imp_str_literal_size(15, "Oper in LHS"));
// 3816 monitor (rh, "Oper in RHS")
MONITOR(RH, _imp_str_literal_size(15, "Oper in RHS"));
// 3817 %finish
L_02E9:;
// 3818
// 3819 ! LH oper RH
// 3820
// 3821 %if const (lh) %start
if (!(CONST(LH))) goto L_02EA;
// 3822 %if lh_disp = lnull op(oper) # no null %start
{
// Double-sided test on LNULLOP[OPER - 9] (Part I)
int tmp;
if (LH->DISP != (tmp = LNULLOP[OPER - 9])) goto L_02EB;
// Double-sided test on LNULLOP[OPER - 9] (Part II)
if (tmp == 2) goto L_02EB;
}
// 3823 ! eg 0 + RH
// 3824 stacked(stp) == rh
STACKED[STP - 1] = (struct STACKFM *)RH;
// 3825 drop (lh)
DROP(LH);
// 3826 -> out
goto U_1007;
// 3827 %finish
L_02EB:;
// 3828 %if lh_disp = 0 %and
if (LH->DISP != 0) goto L_02EC;
if (OPER == 16) goto L_02ED;
if (OPER == 15) goto L_02ED;
if (OPER != 28) goto L_02EC;
L_02ED:;
// 3829+ (oper = rsh %or oper = lsh %or oper = remy) %start
// 3830 ! 0>>anything = 0
// 3831 ! 0<<anything = 0
// 3832 ! rem (0, anything) = 0
// 3833 lose (rh)
LOSE(RH);
// 3834 lh_disp = 0
LH->DISP = 0;
// 3835 -> out
goto U_1007;
// 3836 %finish
L_02EC:;
// 3837 lcon = 1
LCON = 1;
// 3838 %finish
L_02EA:;
// 3839 %if const (rh) %start
if (!(CONST(RH))) goto L_02EE;
// 3840 %if rh_disp = rnull op(oper) # no null %start
{
// Double-sided test on RNULLOP[OPER - 9] (Part I)
int tmp;
if (RH->DISP != (tmp = RNULLOP[OPER - 9])) goto L_02EF;
// Double-sided test on RNULLOP[OPER - 9] (Part II)
if (tmp == 2) goto L_02EF;
}
// 3841 ! eg LH // 1
// 3842 drop (rh)
DROP(RH);
// 3843 -> out
goto U_1007;
// 3844 %else %if (oper = rsh %and rh_disp > 31) %or
L_02EF:;
if (OPER != 16) goto L_02F0;
if (RH->DISP > 31) goto L_02F1;
L_02F0:;
if (OPER != 15) goto L_02F2;
if (RH->DISP >= -31) goto L_02F2;
L_02F1:;
// 3845+ (oper = lsh %and rh_disp < -31)
// 3846 ! eg J << 45 = 0
// 3847 lose (lh)
LOSE(LH);
// 3848 stacked(stp) == rh; rh_disp = 0
STACKED[STP - 1] = (struct STACKFM *)RH;
RH->DISP = 0;
// 3849 -> out
goto U_1007;
// 3850 %else %if oper = remy %and |rh_disp| = 1
L_02F2:;
if (OPER != 28) goto L_02F3;
if (_imp_IMOD(RH->DISP) != 1) goto L_02F3;
// 3851 ! rem(x,1) = rem(x,-1) = 0
// 3852 lose (lh)
LOSE(LH);
// 3853 stacked(stp) == rh; rh_disp = 0
STACKED[STP - 1] = (struct STACKFM *)RH;
RH->DISP = 0;
// 3854 -> out
goto U_1007;
// 3855 %finish
L_02F3:;
// 3856 rcon = 1
RCON = 1;
// 3857 %if oper = sub %start
if (OPER != 10) goto L_02F4;
// 3858 rh_disp = -rh_disp
RH->DISP = -RH->DISP;
// 3859 oper = add
OPER = 9;
// 3860 %finish
L_02F4:;
// 3861 %finish
L_02EE:;
// 3862 %if lcon&rcon # 0 %and oper # rdiv %and oper # rexp %start
if (LCON & RCON == 0) goto L_02F5;
if (OPER == 23) goto L_02F5;
if (OPER == 22) goto L_02F5;
// 3863 cop (oper, lh_disp, rh_disp); drop (rh)
COP(OPER, /*?*/ &LH->DISP, RH->DISP);
DROP(RH);
// 3864 -> out
goto U_1007;
// 3865 %finish
L_02F5:;
// 3866 swap %if lcon # 0 %and comm(oper) # 0; ! get var oper const
if (LCON == 0) goto L_02F6;
if (COMM[OPER - 9] == 0) goto L_02F6;
SWAP();
L_02F6:;
// 3867 lop = lh_oper; rop = rh_oper
LOP = LH->OPER;
ROP = RH->OPER;
// 3868 %if lop # 0 %start
if (LOP == 0) goto L_02F7;
// 3869 ! (LH lop WITH) oper RH
// 3870 with == lh_link
WITH = (struct STACKFM *)LH->LINK;
// 3871 wcon = 1 %if lop > neg %and const (with)
if (LOP <= 8) goto L_02F8;
if (!(CONST(WITH))) goto L_02F8;
WCON = 1;
L_02F8:;
// 3872 %if wcon&rcon # 0 %start
if (WCON & RCON == 0) goto L_02F9;
// 3873 key = trans(oper)!trans(lop)
KEY = TRANS[OPER - 9] | TRANS[LOP - 9];
// 3874 %if key = 0 %or (key = 1 %and oper = lop) %start
if (KEY == 0) goto L_02FA;
if (KEY != 1) goto L_02FB;
if (OPER != LOP) goto L_02FB;
L_02FA:;
// 3875 cop (oper, with_disp, rh_disp)
COP(OPER, /*?*/ &WITH->DISP, RH->DISP);
// 3876 drop (rh)
DROP(RH);
// 3877 %if with_disp = rnull op(lop) # no null %start
{
// Double-sided test on RNULLOP[LOP - 9] (Part I)
int tmp;
if (WITH->DISP != (tmp = RNULLOP[LOP - 9])) goto L_02FC;
// Double-sided test on RNULLOP[LOP - 9] (Part II)
if (tmp == 2) goto L_02FC;
}
// 3878 ! Can now remove WITH
// 3879 lh_oper = 0; drop (with)
LH->OPER = 0;
DROP(WITH);
// 3880 %finish
L_02FC:;
// 3881 -> out
goto U_1007;
// 3882 %finish
L_02FB:;
// 3883 %finish
L_02F9:;
// 3884 swap %if oper = add %and rop = 0
if (OPER != 9) goto L_02FD;
if (ROP != 0) goto L_02FD;
SWAP();
L_02FD:;
// 3885 %finish
L_02F7:;
// 3886 load (lh, any) %if lh_oper # 0
if (LH->OPER == 0) goto L_02FE;
LOAD(LH, 17);
L_02FE:;
// 3887 %if rcon # 0 %start
if (RCON == 0) goto L_02FF;
// 3888 %if rh_disp = -1 %and (oper = mul %or oper = xor) %start
if (RH->DISP != -1) goto L_0300;
if (OPER == 27) goto L_0301;
if (OPER != 14) goto L_0300;
L_0301:;
// 3889 %if oper = mul %start
if (OPER != 27) goto L_0302;
// 3890 lh_oper = neg; ! A*(-1) -> -A
LH->OPER = 8;
// 3891 %else
goto L_0303;
L_0302:;
// 3892 lh_oper = not; ! A!!(-1) -> \A
LH->OPER = 7;
// 3893 %finish
L_0303:;
// 3894 drop (rh); -> out
DROP(RH);
goto U_1007;
// 3895 %else %if oper = add %and lh_type = integers
L_0300:;
if (OPER != 9) goto L_0304;
if (LH->TYPE != 16) goto L_0304;
// 3896 ! a+const (not short lit)
// 3897 %if lh_form = v in r %and %not -63 <= rh_disp <= 63 %start
if (LH->FORM != 1) goto L_0305;
{
// Double-sided test on RH->DISP (Part I)
int tmp;
if (-63 > (tmp = RH->DISP)) goto L_0306;
// Double-sided test on RH->DISP (Part II)
if (tmp <= 63) goto L_0305;
}
L_0306:;
// 3898 lh_form = av in s; lh_disp = 0
LH->FORM = 3;
LH->DISP = 0;
// 3899 %finish
L_0305:;
// 3900 %if (lh_form = av in s %or lh_form = av in rec) %and
if (LH->FORM == 3) goto L_0307;
if (LH->FORM != 6) goto L_0308;
L_0307:;
if (LH->FLAGS & 2 != 0) goto L_0308;
// 3901+ lh_flags&xdefer = 0 %start
// 3902 lh_disp = lh_disp+rh_disp
LH->DISP = LH->DISP + RH->DISP;
// 3903 drop (rh); -> out
DROP(RH);
goto U_1007;
// 3904 %finish
L_0308:;
// 3905 %else %if oper = bic %and rh_disp = \255 %and
goto L_0309;
L_0304:;
if (OPER != 12) goto L_030A;
if (RH->DISP != (~255)) goto L_030A;
if (LH->FLAGS & 1 != 0) goto L_030A;
if (LH->FORM == 1) goto L_030A;
// 3906+ lh_flags&indexed = 0 %and lh_form # v in r
// 3907 !int&255 -> byte
// 3908 address (lh) %and test assigned (lh) %if lh_type = integers
if (LH->TYPE != 16) goto L_030B;
ADDRESS(LH);
TESTASSIGNED(LH);
L_030B:;
// 3909 lh_type = byte+integers
LH->TYPE = 2 + 16;
// 3910 drop (rh); -> out
DROP(RH);
goto U_1007;
// 3911 %finish
L_030A:;
L_0309:;
// 3912 %finish
L_02FF:;
// 3913 %if oper = add %start
if (OPER != 9) goto L_030C;
// 3914 ! Here LH + (RH {rop X}?)
// 3915 ! Look for various fiddles involving address ops
// 3916 ! and indexing
// 3917 scale = 1
SCALE = 1;
// 3918 %if rop > neg %start
if (ROP <= 8) goto L_030D;
// 3919 with == rh_link
WITH = (struct STACKFM *)RH->LINK;
// 3920 %if const (with) %and (rop = mul %or rop = lsh) %start
if (!(CONST(WITH))) goto L_030E;
if (ROP == 27) goto L_030F;
if (ROP != 15) goto L_030E;
L_030F:;
// 3921 j = with_disp
J = WITH->DISP;
// 3922 j = 1<<j %if rop = lsh
if (ROP != 15) goto L_0310;
J = 1 << J;
L_0310:;
// 3923 %if j = 2 %or j = 4 %or j = 8 %start
if (J == 2) goto L_0311;
if (J == 4) goto L_0311;
if (J != 8) goto L_0312;
L_0311:;
// 3924 scale = j
SCALE = J;
// 3925 %finish
L_0312:;
// 3926 %finish
L_030E:;
// 3927 %finish
L_030D:;
// 3928 %if good base (lh, scale) %start
if (!(GOODBASE(LH, SCALE))) goto L_0313;
// 3929 ! OK
// 3930 %else %if good base (rh, 1)
goto L_0314;
L_0313:;
if (!(GOODBASE(RH, 1))) goto L_0315;
// 3931 swap
SWAP();
// 3932 %else
goto L_0314;
L_0315:;
// 3933 -> no joy
goto U_1008;
// 3934 %finish
L_0314:;
// 3935 %if scale # 1 %start
if (SCALE == 1) goto L_0316;
// 3936 rh_oper = 0; rop = 0
RH->OPER = 0;
ROP = 0;
// 3937 drop (with)
DROP(WITH);
// 3938 %finish
L_0316:;
// 3939 -> no joy %if scale = 1 %and lh_form = v in s
if (SCALE != 1) goto L_0317;
if (LH->FORM != 2) goto L_0317;
goto U_1008;
L_0317:;
// 3940 load (rh, any)
LOAD(RH, 17);
// 3941 lh_index = rh_base; release (rh_base); drop (rh)
LH->INDEX = RH->BASE;
RELEASE(RH->BASE);
DROP(RH);
// 3942 lh_flags = indexed; claim (lh_index!128)
LH->FLAGS = 1;
CLAIM(LH->INDEX | 128);
// 3943 lh_flags = lh_flags!xdefer %if lh_form = v in s
if (LH->FORM != 2) goto L_0318;
LH->FLAGS = LH->FLAGS | 2;
L_0318:;
// 3944 lh_iscale = scale; lh_length = scale
LH->ISCALE = SCALE;
LH->LENGTH = SCALE;
// 3945 lh_form = av in s
LH->FORM = 3;
// 3946 -> out
goto U_1007;
// 3947 no joy:
U_1008:;
// 3948 %finish
L_030C:;
// 3949 %if rop # 0 %start
if (ROP == 0) goto L_0319;
// 3950 ! LH oper (RH rop WITH)
// 3951 with == rh_link
WITH = (struct STACKFM *)RH->LINK;
// 3952 %if rop = neg %and (oper = add %or oper = sub) %start
if (ROP != 8) goto L_031A;
if (OPER == 9) goto L_031B;
if (OPER != 10) goto L_031A;
L_031B:;
// 3953 ! A+(-B) -> A-B
// 3954 oper = add+sub-oper
OPER = 9 + 10 - OPER;
// 3955 rh_oper = 0
RH->OPER = 0;
// 3956 %else
goto L_031C;
L_031A:;
// 3957 load (rh, any)
LOAD(RH, 17);
// 3958 %finish
L_031C:;
// 3959 %finish
L_0319:;
// 3960 lh_oper = oper; lh_link == rh
LH->OPER = OPER;
LH->LINK = (struct STACKFM *)RH;
// 3961 out: monitor (lh, "Oper out") %if diag&256 # 0
U_1007:;
if (DIAG & 256 == 0) goto L_031D;
MONITOR(LH, _imp_str_literal_size(15, "Oper out"));
L_031D:;
// 3962 %end
return;
} /* end of OPERATE */
// 3963
// 3964 ! Following should really be operations..
// 3965
// 3966 %routine ADDRESS OP (%integer code)
void ADDRESSOP(int CODE) {
// 3967 ! Evaluate LHS ++ RHS
// 3968 %integer type, len
int TYPE;
int LEN;
// 3969 set both
SETBOTH();
// 3970 type = lhs_type; len = lhs_length
TYPE = LHS->TYPE;
LEN = LHS->LENGTH;
// 3971 error ('*', "object length unspecified for ++ or --") %if len = 0
if (LEN != 0) goto L_031E;
ERROR(42, _imp_str_literal_size(127, "object length unspecified for ++ or --"));
L_031E:;
// 3972 amap (lhs)
AMAP(LHS);
// 3973 cstack (len); operate (mul)
CSTACK(LEN);
OPERATE(27);
// 3974 %if code = 117 %then operate (add) %else operate (sub)
if (CODE != 117) goto L_031F;
OPERATE(9);
goto L_0320;
L_031F:;
OPERATE(10);
L_0320:;
// 3975 vmap (lhs)
VMAP(LHS);
// 3976 lhs_type = type; lhs_length = len
LHS->TYPE = TYPE;
LHS->LENGTH = LEN;
// 3977 %end
return;
} /* end of ADDRESSOP */
// 3978
// 3979 %routine CONCATENATE
void CONCATENATE(void) {
// 3980 ! Evaluate LHS . RHS
// 3981 set both
SETBOTH();
// 3982 conc (lhs, rhs)
CONC(LHS, RHS);
// 3983 stp = stp - 1
STP = STP - 1;
// 3984 %end
return;
} /* end of CONCATENATE */
// 3985
// 3986 %routine SET MODULUS
void SETMODULUS(void) {
// 3987 ! Evaluate |LHS|
// 3988 !
// 3989 ! Generates the sequence
// 3990 ! Load LHS,Rn
// 3991 ! TSTL Rn
// 3992 ! BGEQ Pos
// 3993 ! MNEGx Rn, Rn
// 3994 ! Pos:
// 3995 !
// 3996 ! leaving |LHS| in a register
// 3997 %integer op
int OP;
// 3998 set lhs
SETLHS();
// 3999 %if lhs_form = constant %and lhs_oper = 0 %start
if (LHS->FORM != 0) goto L_0321;
if (LHS->OPER != 0) goto L_0321;
// 4000 ! Do it in line...
// 4001 %if lhs_type&integers # 0 %start
if (LHS->TYPE & 16 == 0) goto L_0322;
// 4002 lhs_disp = |lhs_disp|
LHS->DISP = _imp_IMOD(LHS->DISP);
// 4003 %else %if lhs_type = reall
goto L_0323;
L_0322:;
if (LHS->TYPE != 36) goto L_0324;
// 4004 lhs_lrval = -lhs_lrval %if lhs_lrval < 0
if (LHS->LRVAL >= 0) goto L_0325;
LHS->LRVAL = -LHS->LRVAL;
L_0325:;
// 4005 %else
goto L_0323;
L_0324:;
// 4006 abort (48)
ABORT(48);
// 4007 %finish
L_0323:;
// 4008 %else
goto L_0326;
L_0321:;
// 4009 load (lhs, any)
LOAD(LHS, 17);
// 4010 test zero (lhs); claim (lhs_base)
TESTZERO(LHS);
CLAIM(LHS->BASE);
// 4011 word (bgeq+3<<8)
WORD(24 + (3 << 8));
// 4012 op = mnegl
OP = 0;
// 4013 op = mnegd %if lhs_type&real bit # 0
if (LHS->TYPE & 32 == 0) goto L_0327;
OP = 4;
L_0327:;
// 4014 plant2 (op, lhs, lhs); ! 3 bytes..
PLANT2(OP, LHS, LHS);
// 4015 %finish
L_0326:;
// 4016 %end
return;
} /* end of SETMODULUS */
// 4017
// 4018 %routine ASSIGN (%integer assop)
void ASSIGN(int ASSOP) {
// 4019 !assop = -1 : parameter assignment
// 4020 ! = 0 : == assignment
// 4021 ! = 1 : = assignment
// 4022 ! = 2 : <- assignment
// 4023 %integer op, oper, work, move, slen, dlen, total, loop ca
int OP;
int OPER;
int WORK;
int MOVE;
int SLEN;
int DLEN;
int TOTAL;
int LOOPCA;
// 4024 %integer st, dt, wt
int ST;
int DT;
int WT;
// 4025 %const %string(2) %array assym (-1 : 2) =
const _imp_string2 ASSYM[4] = {_imp_str_init("p="), _imp_str_init("=="), _imp_str_init("= "),
_imp_str_init("<-")};
// 4026+ "p=", "==", "= ", "<-"
// 4027 %record(varfm) %name vv
struct VARFM *VV;
// 4028 %record(stackfm) %name source, dest, len, w, count
struct STACKFM *SOURCE;
struct STACKFM *DEST;
struct STACKFM *LEN;
struct STACKFM *W;
struct STACKFM *COUNT;
// 4029
// 4030 %routine SHAPE UP (%integer type, %record(stackfm) %name cc)
void SHAPEUP(int TYPE, struct STACKFM *CC) {
// 4031 ! Get cc into a form such that OPERAND won't complain
// 4032 ! about size of constants, eg short = 16_FFFF would be wrong
// 4033 %if type = byte+integers %start
if (TYPE != 2 + 16) goto L_0328;
// 4034 cc_disp = cc_disp & 255
CC->DISP = CC->DISP & 255;
// 4035 %else %if type = short+integers
goto L_0329;
L_0328:;
if (TYPE != 1 + 16) goto L_032A;
// 4036 cc_disp = cc_disp & 16_FFFF; ! splat top bits
CC->DISP = CC->DISP & 65535;
// 4037 ! Sign extend short, ie bits <31:15> all 0 or all 1)
// 4038 cc_disp = cc_disp!(\16_FFFF) %if cc_disp&16_8000 # 0
if (CC->DISP & 32768 == 0) goto L_032B;
CC->DISP = CC->DISP | (~65535);
L_032B:;
// 4039 %finish
L_032A:;
L_0329:;
// 4040 cc_type = type
CC->TYPE = TYPE;
// 4041 %end
return;
} /* end of SHAPEUP */
// 4042
// 4043 dest == stacked(stp-1)
DEST = (struct STACKFM *)STACKED[STP - 1 - 1];
// 4044 source == stacked(stp)
SOURCE = (struct STACKFM *)STACKED[STP - 1];
// 4045
// 4046 %if diag&128 # 0 %start
if (DIAG & 128 == 0) goto L_032C;
// 4047 monitor (source, "Ass ".assym(assop)." srce")
MONITOR(SOURCE,
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &*({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("Ass "),
(_imp_string *)/*?*/ &ASSYM[ASSOP + 1]);
(_imp_string255 *)&tmp;
}),
(_imp_string *)/*?*/ _imp_str_literal_ptr(" srce"));
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string15 *)&tmp;
})
);
// 4048 monitor (dest, " dest")
MONITOR(DEST, _imp_str_literal_size(15, " dest"));
// 4049 %finish
L_032C:;
// 4050
// 4051 %if assop < 0 %start; !parameter assignment
if (ASSOP >= 0) goto L_032D;
// 4052 load (source, any) %if source_oper # 0
if (SOURCE->OPER == 0) goto L_032E;
LOAD(SOURCE, 17);
L_032E:;
// 4053 dest_extra = dest_extra-1
DEST->EXTRA = DEST->EXTRA - 1;
// 4054 vv == var(dest_extra)
VV = (struct VARFM *)/*?*/ &VAR[DEST->EXTRA];
// 4055 %if vv_form # v in s %start
if (VV->FORM == 2) goto L_032F;
// 4056 %if vv_form&arrayname bit # 0 %start
if (VV->FORM & 64 == 0) goto L_0330;
// 4057 source_oper = 1
SOURCE->OPER = 1;
// 4058 %else %if vv_form &proc bit # 0
goto L_0331;
L_0330:;
if (VV->FORM & 16 == 0) goto L_0332;
// 4059 %unless r6 <= source_base <= r9 %start;!not already a param
{
// Double-sided test on SOURCE->BASE (Part I)
int tmp;
if (7 > (tmp = SOURCE->BASE)) goto L_0333;
// Double-sided test on SOURCE->BASE (Part II)
if (tmp <= 10) goto L_0334;
}
L_0333:;
// 4060 w == temp(24); stp = stp - 1
W = (struct STACKFM *)TEMP(24);
STP = STP - 1;
// 4061 w_base = fp; work = w_disp
W->BASE = 14;
WORK = W->DISP;
// 4062 %if source_xno # 0 %start; !external
if (SOURCE->XNO == 0) goto L_0335;
// 4063 source_form = v in s
SOURCE->FORM = 2;
// 4064 plant2 (moval, source, w)
PLANT2(4112, SOURCE, W);
// 4065 %else; !normal routine
goto L_0336;
L_0335:;
// 4066 hazard (r10)
HAZARD(11);
// 4067 put code (opcode(moval&255))
PUTCODE(OPCODE[4112 & 255]);
// 4068 flush code
FLUSHCODE();
// 4069 define reference (source_disp, dirpref)
DEFINEREFERENCE(SOURCE->DISP, 3);
// 4070 put (obj call); put long (source_disp); ca = ca+2
PUT(11);
PUTLONG(SOURCE->DISP);
CA = CA + 2;
// 4071 put number byte (16_5a)
PUTNUMBERBYTE(90);
// 4072 !moval p,r10
// 4073 entry mask = entry mask ! 16_400; ! save R10
ENTRYMASK = ENTRYMASK | 1024;
// 4074 local = local!128; !prevent OPERAND changing it to FP
LOCAL = LOCAL | 128;
// 4075 plant2 (movl, regv(r10), w)
PLANT2(8968, /*?*/ ®V[10], W);
// 4076 %if local = r6!128 %then move = movl %c
if (LOCAL != 7 | 128) goto L_0337;
MOVE = 8968;
goto L_0338;
L_0337:;
MOVE = 13;
L_0338:;
// 4077+ %else move = movq
// 4078 w_disp = w_disp+4
W->DISP = W->DISP + 4;
// 4079 plant2 (move, regv(r6), w)
PLANT2(MOVE, /*?*/ ®V[6], W);
// 4080 w_disp = w_disp+8
W->DISP = W->DISP + 8;
// 4081 %if local > r7!128 %start
if (LOCAL <= 8 | 128) goto L_0339;
// 4082 %if local = r8!128 %then move = movl %c
if (LOCAL != 9 | 128) goto L_033A;
MOVE = 8968;
goto L_033B;
L_033A:;
MOVE = 13;
L_033B:;
// 4083+ %else move = movq
// 4084 plant2 (move, regv(r8), w)
PLANT2(MOVE, /*?*/ ®V[8], W);
// 4085 %finish
L_0339:;
// 4086 w_disp = w_disp + 8
W->DISP = W->DISP + 8;
// 4087 plant2 (movl, regv(gla), w)
PLANT2(8968, /*?*/ ®V[11], W);
// 4088 local = local&127
LOCAL = LOCAL & 127;
// 4089 %finish
L_0336:;
// 4090 drop (source); source == w; source_disp = work
DROP(SOURCE);
SOURCE = (struct STACKFM *)W;
SOURCE->DISP = WORK;
// 4091 w_base = local
W->BASE = LOCAL;
// 4092 source_form = av in s
SOURCE->FORM = 3;
// 4093 %else
goto L_033C;
L_0334:;
// 4094 source_form = v in s
SOURCE->FORM = 2;
// 4095 %finish
L_033C:;
// 4096 source_type = integers
SOURCE->TYPE = 16;
// 4097 %else %if vv_type = 0; !general type
goto L_0331;
L_0332:;
if (VV->TYPE != 0) goto L_033D;
// 4098 source_oper = 2
SOURCE->OPER = 2;
// 4099 source_oper = 3 %if source_type = 0; !also general
if (SOURCE->TYPE != 0) goto L_033E;
SOURCE->OPER = 3;
L_033E:;
// 4100 %else
goto L_0331;
L_033D:;
// 4101 amap (source)
AMAP(SOURCE);
// 4102 %finish
L_0331:;
// 4103 %else %if vv_type&real bit # 0
goto L_033F;
L_032F:;
if (VV->TYPE & 32 == 0) goto L_0340;
// 4104 float (source) %unless floating (source)
if (FLOATING(SOURCE)) goto L_0341;
FLOAT(SOURCE);
L_0341:;
// 4105 %if vv_type = reall %and source_type = reals %start
if (VV->TYPE != 36) goto L_0342;
if (SOURCE->TYPE != 35) goto L_0342;
// 4106 load (source, any)
LOAD(SOURCE, 17);
// 4107 %else %if vv_type = reals
goto L_0343;
L_0342:;
if (VV->TYPE != 35) goto L_0344;
// 4108 source_type = reals
SOURCE->TYPE = 35;
// 4109 %finish
L_0344:;
L_0343:;
// 4110 %finish
L_0340:;
L_033F:;
// 4111 %if vv_type = records %and source_format = 0 %start
if (VV->TYPE != 128) goto L_0345;
if (SOURCE->FORMAT != 0) goto L_0345;
// 4112 ! Passing rec(*) as value (parameter typed)
// 4113 source_format = vv_format
SOURCE->FORMAT = VV->FORMAT;
// 4114 %finish
L_0345:;
// 4115 source_link == dest_link
SOURCE->LINK = (struct STACKFM *)DEST->LINK;
// 4116 dest_link == source
DEST->LINK = (struct STACKFM *)SOURCE;
// 4117 stp = stp-1
STP = STP - 1;
// 4118 %return
return;
// 4119 %finish
L_032D:;
// 4120
// 4121 stp = stp-2
STP = STP - 2;
// 4122 %if dest_form&arrayname bit # 0 %start
if (DEST->FORM & 64 == 0) goto L_0346;
// 4123 op = dest_form&15
OP = DEST->FORM & 15;
// 4124 %if op >= v in rec %then op = v in rec %c
if (OP < 5) goto L_0347;
OP = 5;
goto L_0348;
L_0347:;
OP = 2;
L_0348:;
// 4125+ %else op = v in s
// 4126 dest_form = op
DEST->FORM = OP;
// 4127 address (dest)
ADDRESS(DEST);
// 4128 move arrayname (source, dest)
MOVEARRAYNAME(SOURCE, DEST);
// 4129 clear (dest); drop (dest)
CLEAR(DEST);
DROP(DEST);
// 4130 %return
return;
// 4131 %finish
L_0346:;
// 4132
// 4133 %if assop = 0 %start; !==
if (ASSOP != 0) goto L_0349;
// 4134 amap (source); amap (dest)
AMAP(SOURCE);
AMAP(DEST);
// 4135 %finish
L_0349:;
// 4136
// 4137 %if same (source, dest) %start; ! ????
if (!(SAME(SOURCE, DEST))) goto L_034A;
// 4138 clear (source); drop (source)
CLEAR(SOURCE);
DROP(SOURCE);
// 4139 clear (dest); drop (dest)
CLEAR(DEST);
DROP(DEST);
// 4140 %return
return;
// 4141 %finish
L_034A:;
// 4142
// 4143 %if source_oper = 0 %and source_form = av in rec %start
if (SOURCE->OPER != 0) goto L_034B;
if (SOURCE->FORM != 6) goto L_034B;
// 4144 address var (1, source)
ADDRESSVAR(1, SOURCE);
// 4145 %finish
L_034B:;
// 4146 %if dest_type&strings # 0 %start
if (DEST->TYPE & 64 == 0) goto L_034C;
// 4147 assign string (source, dest)
ASSIGNSTRING(SOURCE, DEST);
// 4148 drop (source); drop (dest)
DROP(SOURCE);
DROP(DEST);
// 4149 %return
return;
// 4150 %finish
L_034C:;
// 4151 %if dest_type = records %start
if (DEST->TYPE != 128) goto L_034D;
// 4152 slen = 0
SLEN = 0;
// 4153 slen = var(source_format)_length %if source_type = records
if (SOURCE->TYPE != 128) goto L_034E;
SLEN = VAR[SOURCE->FORMAT].LENGTH;
L_034E:;
// 4154 dlen = var(dest_format)_length
DLEN = VAR[DEST->FORMAT].LENGTH;
// 4155 %if dlen = 0 = slen %start; ! Eh ???
{
// Double-sided test on 0 (Part I)
int tmp;
if (DLEN != (tmp = 0)) goto L_034F;
// Double-sided test on 0 (Part II)
if (tmp != SLEN) goto L_034F;
}
// 4156 clear (source) %if source_type = records
if (SOURCE->TYPE != 128) goto L_0350;
CLEAR(SOURCE);
L_0350:;
// 4157 clear (dest)
CLEAR(DEST);
// 4158 error ('*', "record format not specified")
ERROR(42, _imp_str_literal_size(127, "record format not specified"));
// 4159 %else
goto L_0351;
L_034F:;
// 4160 %if dlen = 0 %start; ! rec = record(n)
if (DLEN != 0) goto L_0352;
// 4161 work = slen
WORK = SLEN;
// 4162 %else %if slen = 0; ! rec = 0
goto L_0353;
L_0352:;
if (SLEN != 0) goto L_0354;
// 4163 work = dlen
WORK = DLEN;
// 4164 %else
goto L_0353;
L_0354:;
// 4165 error ('*', "record format mismatch??") %if dlen # slen
if (DLEN == SLEN) goto L_0355;
ERROR(42, _imp_str_literal_size(127, "record format mismatch??"));
L_0355:;
// 4166 work = slen
WORK = SLEN;
// 4167 %finish
L_0353:;
// 4168 abort (0) %if work < 0; ! more than 1/2 a VM ?????
if (WORK >= 0) goto L_0356;
ABORT(0);
L_0356:;
// 4169 total = work
TOTAL = WORK;
// 4170 work = rem (total, 16_FFFF)
WORK = _imp_REM(TOTAL, 65535);
// 4171 total = (total-work)//16_FFFF;! No of blocks left
TOTAL = ((long)(TOTAL - WORK) / (long)65535);
// 4172 work = 16_FFFF %and total = total-1 %if work = 0
if (WORK != 0) goto L_0357;
WORK = 65535;
TOTAL = TOTAL - 1;
L_0357:;
// 4173 len == literal(work); stp = stp-1
LEN = (struct STACKFM *)LITERAL(WORK);
STP = STP - 1;
// 4174 shape up (short+integers, len)
SHAPEUP(1 + 16, LEN);
// 4175 %if dest_flags&indexed # 0 %and
if (DEST->FLAGS & 1 == 0) goto L_0358;
if (DEST->ISCALE != 1) goto L_0358;
if (TOTAL == 0) goto L_0358;
// 4176+ dest_iscale = 1 %and total # 0 %start
// 4177 ! If MOVCn required, context is BYTE,
// 4178 ! so fool ADDRESS.
// 4179 dest_length = 1
DEST->LENGTH = 1;
// 4180 %finish
L_0358:;
// 4181 address (dest); dest_type = integers
ADDRESS(DEST);
DEST->TYPE = 16;
// 4182 %if source_type = records %start
if (SOURCE->TYPE != 128) goto L_0359;
// 4183 op = movc3
OP = 30;
// 4184 %if total # 0 %start
if (TOTAL == 0) goto L_035A;
// 4185 op = op!no short
OP = OP | 65536;
// 4186 %if source_flags&indexed # 0 %and
if (SOURCE->FLAGS & 1 == 0) goto L_035B;
if (SOURCE->ISCALE != 1) goto L_035B;
// 4187+ source_iscale = 1 %start
// 4188 ! same fiddle as above
// 4189 source_length = 1
SOURCE->LENGTH = 1;
// 4190 %finish
L_035B:;
// 4191 %finish
L_035A:;
// 4192 address (source); source_type = integers
ADDRESS(SOURCE);
SOURCE->TYPE = 16;
// 4193 string3 (op, len, source, dest)
STRING3(OP, LEN, SOURCE, DEST);
// 4194 clear (source)
CLEAR(SOURCE);
// 4195 op = 1; ! mark record move
OP = 1;
// 4196 %else; ! rec = 0
goto L_035C;
L_0359:;
// 4197 work = scale type (work)
WORK = SCALETYPE(WORK);
// 4198 %if work >= 0 %and total = 0 %start
if (WORK < 0) goto L_035D;
if (TOTAL != 0) goto L_035D;
// 4199 ! Can use short form
// 4200 plant1 (clrl+work, dest)
PLANT1(48 + WORK, DEST);
// 4201 %else
goto L_035E;
L_035D:;
// 4202 plant5 (movc5, zerov, gla work, zerov, len, dest)
PLANT5(31, /*?*/ &ZEROV, /*?*/ &GLAWORK, /*?*/ &ZEROV, LEN, DEST);
// 4203 %finish
L_035E:;
// 4204 op = 0; ! marks rec=0
OP = 0;
// 4205 %finish
L_035C:;
// 4206 clear (dest)
CLEAR(DEST);
// 4207 %if total > 0 %start; ! more to do...
if (TOTAL <= 0) goto L_035F;
// 4208 %if total # 1 %start; ! need a loop
if (TOTAL == 1) goto L_0360;
// 4209 count == literal(total); stp = stp - 1
COUNT = (struct STACKFM *)LITERAL(TOTAL);
STP = STP - 1;
// 4210 load (count, r10)
LOAD(COUNT, 11);
// 4211 loop ca = ca
LOOPCA = CA;
// 4212 %finish
L_0360:;
// 4213 len_disp = -1; ! => 16_FFFF in OPERAND
LEN->DISP = -1;
// 4214 dest_base = r3; dest_disp = 0; dest_form = v in s
DEST->BASE = 4;
DEST->DISP = 0;
DEST->FORM = 2;
// 4215 dest_flags = 0; claim (r3)
DEST->FLAGS = 0;
CLAIM(4);
// 4216 %if op # 0 %start; ! rec move
if (OP == 0) goto L_0361;
// 4217 source_base = r1; source_disp = 0; source_form = v in s
SOURCE->BASE = 2;
SOURCE->DISP = 0;
SOURCE->FORM = 2;
// 4218 source_flags = 0; claim (r1)
SOURCE->FLAGS = 0;
CLAIM(2);
// 4219 plant3 (movc3, len, source, dest)
PLANT3(30, LEN, SOURCE, DEST);
// 4220 %else
goto L_0362;
L_0361:;
// 4221 plant5 (movc5, zerov, gla work, zerov, len, dest)
PLANT5(31, /*?*/ &ZEROV, /*?*/ &GLAWORK, /*?*/ &ZEROV, LEN, DEST);
// 4222 %finish
L_0362:;
// 4223 %if total # 1 %start
if (TOTAL == 1) goto L_0363;
// 4224 plant1 (sobgtr, count)
PLANT1(103, COUNT);
// 4225 put number byte (loop ca-(ca+1)); ! byte offset
PUTNUMBERBYTE(LOOPCA - (CA + 1));
// 4226 release (r10)
RELEASE(11);
// 4227 drop (count)
DROP(COUNT);
// 4228 %finish
L_0363:;
// 4229 %finish
L_035F:;
// 4230 drop (len)
DROP(LEN);
// 4231 %finish
L_0351:;
// 4232 drop (dest)
DROP(DEST);
// 4233 drop (source)
DROP(SOURCE);
// 4234 %return
return;
// 4235 %finish
L_034D:;
// 4236
// 4237 oper = source_oper
OPER = SOURCE->OPER;
// 4238 %if oper # 0 %start
if (OPER == 0) goto L_0364;
// 4239 %if assop = 2 %start
if (ASSOP != 2) goto L_0365;
// 4240 %if dest_type&integers # 0 %start
if (DEST->TYPE & 16 == 0) goto L_0366;
// 4241 iovf off
IOVFOFF();
// 4242 %finish
L_0366:;
// 4243 %finish
L_0365:;
// 4244 %if oper < add %start; !unary
if (OPER >= 9) goto L_0367;
// 4245 %if oper = not %and dest_type&real bit # 0 %start
if (OPER != 7) goto L_0368;
if (DEST->TYPE & 32 == 0) goto L_0368;
// 4246 ! Real = \integer
// 4247 load (source, any)
LOAD(SOURCE, 17);
// 4248 source_oper = 0
SOURCE->OPER = 0;
// 4249 %else
goto L_0369;
L_0368:;
// 4250 op = mnegl; op = mcoml %if oper = not
OP = 0;
if (OPER != 7) goto L_036A;
OP = 24;
L_036A:;
// 4251 source_oper = 0
SOURCE->OPER = 0;
// 4252 equate (dest, source, 0)
EQUATE(DEST, SOURCE, 0);
// 4253 %if dest_type = source_type # byte+integers %start
{
// Double-sided test on SOURCE->TYPE (Part I)
int tmp;
if (DEST->TYPE != (tmp = SOURCE->TYPE)) goto L_036B;
// Double-sided test on SOURCE->TYPE (Part II)
if (tmp == 2 + 16) goto L_036B;
}
// 4254 %if same (source, dest) %start
if (!(SAME(SOURCE, DEST))) goto L_036C;
// 4255 address (dest)
ADDRESS(DEST);
// 4256 source = dest; claim (source_base)
*SOURCE = *DEST;
CLAIM(SOURCE->BASE);
// 4257 %else
goto L_036D;
L_036C:;
// 4258 address (source); address (dest)
ADDRESS(SOURCE);
ADDRESS(DEST);
// 4259 %finish
L_036D:;
// 4260 plant2 (op+dest_type&7, source, dest)
PLANT2(OP + (DEST->TYPE & 7), SOURCE, DEST);
// 4261 clear (source)
CLEAR(SOURCE);
// 4262 drop (source); drop (dest)
DROP(SOURCE);
DROP(DEST);
// 4263 iovf on
IOVFON();
// 4264 %return
return;
// 4265 %finish
L_036B:;
// 4266 source_oper = oper
SOURCE->OPER = OPER;
// 4267 %finish
L_0369:;
// 4268 %else
goto L_036E;
L_0367:;
// 4269 op = op map(oper)
OP = OPMAP[OPER - 9];
// 4270 %if op # 0 %start; !3-op possible
if (OP == 0) goto L_036F;
// 4271 w == source_link
W = (struct STACKFM *)SOURCE->LINK;
// 4272 source_oper = 0
SOURCE->OPER = 0;
// 4273 wt = w_type; st = source_type; dt = dest_type
WT = W->TYPE;
ST = SOURCE->TYPE;
DT = DEST->TYPE;
// 4274 %if (dt!wt!st)&real bit = 0 %start
if ((DT | WT | ST) & 32 != 0) goto L_0370;
// 4275 ! Massage integer constants to permit 3-ops
// 4276 %if const (w) %and
if (!(CONST(W))) goto L_0371;
if (!(FITS(W->DISP, DT))) goto L_0371;
// 4277+ fits (w_disp, dt) %start
// 4278 w_type = dt %and wt = dt %if st = dt
if (ST != DT) goto L_0372;
W->TYPE = DT;
WT = DT;
L_0372:;
// 4279 %else %if const (source) %and
goto L_0373;
L_0371:;
if (!(CONST(SOURCE))) goto L_0374;
if (!(FITS(SOURCE->DISP, DT))) goto L_0374;
// 4280+ fits (source_disp, dt)
// 4281 source_type = dt %and st = dt %if wt = dt
if (WT != DT) goto L_0375;
SOURCE->TYPE = DT;
ST = DT;
L_0375:;
// 4282 %finish
L_0374:;
L_0373:;
// 4283 %finish
L_0370:;
// 4284 %unless dt # st = wt %start
{
// Double-sided test on ST (Part I)
int tmp;
if (DT == (tmp = ST)) goto L_0376;
// Double-sided test on ST (Part II)
if (tmp == WT) goto L_0377;
}
L_0376:;
// 4285 equate (dest, source, 0)
EQUATE(DEST, SOURCE, 0);
// 4286 equate (dest, w, 0)
EQUATE(DEST, W, 0);
// 4287 %if source_type = dest_type = w_type %start
{
// Double-sided test on DEST->TYPE (Part I)
int tmp;
if (SOURCE->TYPE != (tmp = DEST->TYPE)) goto L_0378;
// Double-sided test on DEST->TYPE (Part II)
if (tmp != W->TYPE) goto L_0378;
}
// 4288 %if same (dest, source) %start
if (!(SAME(DEST, SOURCE))) goto L_0379;
// 4289 address (dest); source = dest
ADDRESS(DEST);
*SOURCE = *DEST;
// 4290 claim (source_base)
CLAIM(SOURCE->BASE);
// 4291 address (w)
ADDRESS(W);
// 4292 %else %if same (dest, w)
goto L_037A;
L_0379:;
if (!(SAME(DEST, W))) goto L_037B;
// 4293 address (dest); w = dest
ADDRESS(DEST);
*W = *DEST;
// 4294 claim (w_base)
CLAIM(W->BASE);
// 4295 address (source)
ADDRESS(SOURCE);
// 4296 %else %if same (source, w); ! a = b + b
goto L_037A;
L_037B:;
if (!(SAME(SOURCE, W))) goto L_037C;
// 4297 address (source); w = source
ADDRESS(SOURCE);
*W = *SOURCE;
// 4298 claim (w_base)
CLAIM(W->BASE);
// 4299 address (dest)
ADDRESS(DEST);
// 4300 %else
goto L_037A;
L_037C:;
// 4301 address (source)
ADDRESS(SOURCE);
// 4302 address (dest)
ADDRESS(DEST);
// 4303 address (w)
ADDRESS(W);
// 4304 %finish
L_037A:;
// 4305 iovf off %if dest_type = byte+integers
if (DEST->TYPE != 2 + 16) goto L_037D;
IOVFOFF();
L_037D:;
// 4306 plant3 (op+dest_type&7, w, source, dest)
PLANT3(OP + (DEST->TYPE & 7), W, SOURCE, DEST);
// 4307 iovf on
IOVFON();
// 4308 clear (source); clear (w)
CLEAR(SOURCE);
CLEAR(W);
// 4309 drop (source); drop (dest); drop (w)
DROP(SOURCE);
DROP(DEST);
DROP(W);
// 4310 %return
return;
// 4311 %finish
L_0378:;
// 4312 %finish
L_0377:;
// 4313 source_oper = oper
SOURCE->OPER = OPER;
// 4314 %else
goto L_037E;
L_036F:;
// 4315 drop (dest) %and %return %if simple shift (source, dest)
if (!(SIMPLESHIFT(SOURCE, DEST))) goto L_037F;
DROP(DEST);
return;
L_037F:;
// 4316 %finish
L_037E:;
// 4317 %finish
L_036E:;
// 4318 load (source, any) %if source_oper # 0
if (SOURCE->OPER == 0) goto L_0380;
LOAD(SOURCE, 17);
L_0380:;
// 4319 %finish
L_0364:;
// 4320 ! Prevent trouble with "byte = intarray(n)": would generate MOVB
// 4321 ! but with source indexed, should be appropriate source length op.
// 4322 load (source, any) %if source_flags&indexed # 0 %and
if (SOURCE->FLAGS & 1 == 0) goto L_0381;
{
// Double-sided test on 2 + 16 (Part I)
int tmp;
if (SOURCE->TYPE == (tmp = 2 + 16)) goto L_0381;
// Double-sided test on 2 + 16 (Part II)
if (tmp != DEST->TYPE) goto L_0381;
}
LOAD(SOURCE, 17);
L_0381:;
// 4323+ source_type # byte+integers = dest_type
// 4324 shape up (dest_type, source) %if assop = 2 %and const (source)
if (ASSOP != 2) goto L_0382;
if (!(CONST(SOURCE))) goto L_0382;
SHAPEUP(DEST->TYPE, SOURCE);
L_0382:;
// 4325 address (dest)
ADDRESS(DEST);
// 4326 source_type = dest_type %if source_form = constant %and
if (SOURCE->FORM != 0) goto L_0383;
if (DEST->TYPE & 16 == 0) goto L_0383;
SOURCE->TYPE = DEST->TYPE;
L_0383:;
// 4327+ dest_type&integers # 0
// 4328 op = (source_type&7)*8+7*8
OP = (SOURCE->TYPE & 7) * 8 + 7 * 8;
// 4329 op = movl %if source_type = dest_type %or zero (source)
if (SOURCE->TYPE == DEST->TYPE) goto L_0384;
if (!(ZERO(SOURCE))) goto L_0385;
L_0384:;
OP = 8968;
L_0385:;
// 4330 op = op + dest_type&7
OP = OP + (DEST->TYPE & 7);
// 4331 %if source_form = av in s %or source_form = av in rec %start
if (SOURCE->FORM == 3) goto L_0386;
if (SOURCE->FORM != 6) goto L_0387;
L_0386:;
// 4332 %if dest_type # integers %start
if (DEST->TYPE == 16) goto L_0388;
// 4333 load (source, any)
LOAD(SOURCE, 17);
// 4334 %else
goto L_0389;
L_0388:;
// 4335 source_form = source_form-1; op = moval
SOURCE->FORM = SOURCE->FORM - 1;
OP = 4112;
// 4336 %finish
L_0389:;
// 4337 %finish
L_0387:;
// 4338 address (source)
ADDRESS(SOURCE);
// 4339 scale index (op, source)
SCALEINDEX(/*?*/ &OP, SOURCE);
// 4340 plant2 (op, source, dest)
PLANT2(OP, SOURCE, DEST);
// 4341 clear (source); clear (dest)
CLEAR(SOURCE);
CLEAR(DEST);
// 4342 drop (source); drop (dest)
DROP(SOURCE);
DROP(DEST);
// 4343 iovf on
IOVFON();
// 4344 %end
return;
} /* end of ASSIGN */
// 4345
// 4346 %routine LRD (%record(stackfm) %name v, %integer reg)
void LRD(struct STACKFM * V, int REG) {
// 4347 !load, release and drop
// 4348 load (v, reg)
LOAD(V, REG);
// 4349 release (v_base); !reg could be any!!!!!
RELEASE(V->BASE);
// 4350 drop (v)
DROP(V);
// 4351 %end
return;
} /* end of LRD */
// 4352
// 4353 %routine SET STATUS
void SETSTATUS(void) {
// 4354 ! This is the top level - load a 'success' result
// 4355 ! into R0 for the CLI's benefit (return pending).
// 4356 %record(stackfm) %name res
struct STACKFM *RES;
// 4357 %return %if uncond jump = ca
if (UNCONDJUMP != CA) goto L_038A;
return;
L_038A:;
// 4358 res == literal(1); stp = stp - 1
RES = (struct STACKFM *)LITERAL(1);
STP = STP - 1;
// 4359 lrd (res, r0)
LRD(RES, 1);
// 4360 %end
return;
} /* end of SETSTATUS */
// 4361
// 4362 %routine SET RESULT (%record(stack fm) %name v, %integer mode)
void SETRESULT(struct STACKFM * V, int MODE) {
// 4363 %integer reg
int REG;
// 4364 amap (v) %if mode = 'M'; !a map
if (MODE != 77) goto L_038B;
AMAP(V);
L_038B:;
// 4365 %if gvar_type&(strings!records) # 0 %and mode = 'V' %start
if (GVAR->TYPE & (64 | 128) == 0) goto L_038C;
if (MODE != 86) goto L_038C;
// 4366 ! Result of string/record function - goes via
// 4367 ! (hidden) first parameter..
// 4368 lstack (64); ! disp of result addr
LSTACK(64);
// 4369 lhs_form = a in s
LHS->FORM = 4;
// 4370 %if gvar_type&records # 0 %start
if (GVAR->TYPE & 128 == 0) goto L_038D;
// 4371 lhs_type = records; lhs_format = gvar_format
LHS->TYPE = 128;
LHS->FORMAT = GVAR->FORMAT;
// 4372 dstack (v); assign (1)
DSTACK(V);
ASSIGN(1);
// 4373 %else
goto L_038E;
L_038D:;
// 4374 lhs_type = strings; lhs_length = gvar_length
LHS->TYPE = 64;
LHS->LENGTH = GVAR->LENGTH;
// 4375 stp = stp - 1
STP = STP - 1;
// 4376 assign string (v, lhs)
ASSIGNSTRING(V, LHS);
// 4377 drop (lhs)
DROP(LHS);
// 4378 %finish
L_038E:;
// 4379 drop (v)
DROP(V);
// 4380 %else
goto L_038F;
L_038C:;
// 4381 reg = r0
REG = 1;
// 4382 reg = fpr0 %if gvar_type&real bit # 0 %and mode = 'V'
if (GVAR->TYPE & 32 == 0) goto L_0390;
if (MODE != 86) goto L_0390;
REG = 18;
L_0390:;
// 4383 lrd (v, reg)
LRD(V, REG);
// 4384 %finish
L_038F:;
// 4385 %end
return;
} /* end of SETRESULT */
// 4386
// 4387 %routine RETURN
void RETURN(void) {
// 4388 %return %if uncond jump = ca
if (UNCONDJUMP != CA) goto L_0391;
return;
L_0391:;
// 4389 put code (opcode(ret&255))
PUTCODE(OPCODE[23 & 255]);
// 4390 uncond jump = ca
UNCONDJUMP = CA;
// 4391 %end
return;
} /* end of RETURN */
// 4392
// 4393 %routine RECORD SELECT
void RECORDSELECT(void) {
// 4394 %integer n
int N;
// 4395 n = getword; set lhs
N = GETWORD();
SETLHS();
// 4396 vstack (var(var(lhs_format)_extra-n))
VSTACK(/*?*/ &VAR[VAR[LHS->FORMAT].EXTRA - N]);
// 4397 set both
SETBOTH();
// 4398 stp = stp - 1
STP = STP - 1;
// 4399 monitor (lhs, "Rec sel in") %if diag&8 # 0
if (DIAG & 8 == 0) goto L_0392;
MONITOR(LHS, _imp_str_literal_size(15, "Rec sel in"));
L_0392:;
// 4400 %if lhs_flags&indexed # 0 %and
if (LHS->FLAGS & 1 == 0) goto L_0393;
if (LHS->FLAGS & 2 != 0) goto L_0394;
if (LHS->FORM == 4) goto L_0394;
if (LHS->FORM != 7) goto L_0393;
L_0394:;
// 4401+ (lhs_flags&xdefer # 0 %or
// 4402+ lhs_form = a in s %or lhs_form = a in rec) %start
// 4403 ! address calc incomplete
// 4404 address (lhs)
ADDRESS(LHS);
// 4405 %if lhs_flags&xdefer # 0 %and rhs_disp # 0 %start
if (LHS->FLAGS & 2 == 0) goto L_0395;
if (RHS->DISP == 0) goto L_0395;
// 4406 amap (lhs)
AMAP(LHS);
// 4407 load (lhs, any)
LOAD(LHS, 17);
// 4408 lhs_form = v in s
LHS->FORM = 2;
// 4409 %finish
L_0395:;
// 4410 %finish
L_0393:;
// 4411 %if lhs_form = v in s %or lhs_form = v in rec %start
if (LHS->FORM == 2) goto L_0396;
if (LHS->FORM != 5) goto L_0397;
L_0396:;
// 4412 rhs_disp = rhs_disp+lhs_disp
RHS->DISP = RHS->DISP + LHS->DISP;
// 4413 lhs_form = lhs_form - v in s + rhs_form
LHS->FORM = LHS->FORM - 2 + RHS->FORM;
// 4414 rhs_mantissa = rhs_mantissa + lhs_disp; ! For arrays in records
RHS->MANTISSA = RHS->MANTISSA + LHS->DISP;
// 4415 %else %if lhs_form = a in s %or lhs_form = a in rec
goto L_0398;
L_0397:;
if (LHS->FORM == 4) goto L_0399;
if (LHS->FORM != 7) goto L_039A;
L_0399:;
// 4416 %if lhs_form = a in s %and activity(lhs_base) < 0 %start
if (LHS->FORM != 4) goto L_039B;
if (ACTIVITY[LHS->BASE] >= 0) goto L_039B;
// 4417 lhs_extra = lhs_disp
LHS->EXTRA = LHS->DISP;
// 4418 lhs_form = rhs_form + rec mod
LHS->FORM = RHS->FORM + 3;
// 4419 %else
goto L_039C;
L_039B:;
// 4420 lhs_form = lhs_form - 2; lhs_type = integers
LHS->FORM = LHS->FORM - 2;
LHS->TYPE = 16;
// 4421 load (lhs, any)
LOAD(LHS, 17);
// 4422 lhs_form = rhs_form
LHS->FORM = RHS->FORM;
// 4423 %finish
L_039C:;
// 4424 %else %if lhs_form <= v in r
goto L_0398;
L_039A:;
if (LHS->FORM > 1) goto L_039D;
// 4425 lhs_form = rhs_form
LHS->FORM = RHS->FORM;
// 4426 %else
goto L_0398;
L_039D:;
// 4427 abort (45)
ABORT(45);
// 4428 %finish
L_0398:;
// 4429 lhs_disp = rhs_disp
LHS->DISP = RHS->DISP;
// 4430 lhs_type = rhs_type
LHS->TYPE = RHS->TYPE;
// 4431 lhs_length = rhs_length
LHS->LENGTH = RHS->LENGTH;
// 4432 lhs_format = rhs_format
LHS->FORMAT = RHS->FORMAT;
// 4433 lhs_header = rhs_header
LHS->HEADER = RHS->HEADER;
// 4434 lhs_mantissa = rhs_mantissa
LHS->MANTISSA = RHS->MANTISSA;
// 4435 drop (rhs)
DROP(RHS);
// 4436 monitor (lhs, "Rec sel out") %if diag&8 # 0
if (DIAG & 8 == 0) goto L_039E;
MONITOR(LHS, _imp_str_literal_size(15, "Rec sel out"));
L_039E:;
// 4437 %end
return;
} /* end of RECORDSELECT */
// 4438
// 4439 %routine ARRAY REF (%integer mode)
void ARRAYREF(int MODE) {
// 4440 !mode = 0 - last subscript (or only)
// 4441 ! = 1 - not last subscript
// 4442 %record(stackfm) %name a, ind
struct STACKFM *A;
struct STACKFM *IND;
// 4443 %integer type, len, rlen, c, form, x, idrop
int TYPE;
int LEN;
int RLEN;
int C;
int FORM;
int X;
int IDROP;
// 4444 %integer aname, icon, ival, hbase, hdisp
int ANAME;
int ICON;
int IVAL;
int HBASE;
int HDISP;
// 4445
// 4446 %if mode # 0 %start; !multi-dim
if (MODE == 0) goto L_039F;
// 4447 set both
SETBOTH();
// 4448 %if lhs_oper = 0 %start
if (LHS->OPER != 0) goto L_03A0;
// 4449 lhs_oper = 1; lhs_link == null
LHS->OPER = 1;
LHS->LINK = (struct STACKFM *)NULL;
// 4450 %finish
L_03A0:;
// 4451 address (rhs); !index
ADDRESS(RHS);
// 4452 rhs_link == lhs_link; lhs_link == rhs
RHS->LINK = (struct STACKFM *)LHS->LINK;
LHS->LINK = (struct STACKFM *)RHS;
// 4453 stp = stp - 1
STP = STP - 1;
// 4454 %return
return;
// 4455 %finish
L_039F:;
// 4456
// 4457 a == stacked(stp-1)
A = (struct STACKFM *)STACKED[STP - 1 - 1];
// 4458 ind == stacked(stp); idrop = 1; ! index still stacked
IND = (struct STACKFM *)STACKED[STP - 1];
IDROP = 1;
// 4459 %if diag&8 # 0 %start
if (DIAG & 8 == 0) goto L_03A1;
// 4460 monitor (a, "Array base")
MONITOR(A, _imp_str_literal_size(15, "Array base"));
// 4461 monitor (ind, "Array index")
MONITOR(IND, _imp_str_literal_size(15, "Array index"));
// 4462 %finish
L_03A1:;
// 4463
// 4464 rlen = a_length; type = a_type
RLEN = A->LENGTH;
TYPE = A->TYPE;
// 4465 form = a_form&15; aname = a_form&arrayname bit
FORM = A->FORM & 15;
ANAME = A->FORM & 64;
// 4466 a_type = integers; a_form = v in s
A->TYPE = 16;
A->FORM = 2;
// 4467 %if form >= v in rec %start; ! Array or arrayname in record
if (FORM < 5) goto L_03A2;
// 4468 form = form - 3
FORM = FORM - 3;
// 4469 a_form = v in rec
A->FORM = 5;
// 4470 %finish
L_03A2:;
// 4471
// 4472 ! remember where header is - may be needed
// 4473 %if a_header > 0 %start
if (A->HEADER <= 0) goto L_03A3;
// 4474 hbase = gla; hdisp = a_header
HBASE = 12;
HDISP = A->HEADER;
// 4475 %else
goto L_03A4;
L_03A3:;
// 4476 hbase = a_base; hdisp = a_disp
HBASE = A->BASE;
HDISP = A->DISP;
// 4477 %finish
L_03A4:;
// 4478
// 4479 %if a_oper = 0 %start; ! 1-dim
if (A->OPER != 0) goto L_03A5;
// 4480 ! constant index?
// 4481 icon = 0; icon = 1 %and ival = ind_disp %if const (ind)
ICON = 0;
if (!(CONST(IND))) goto L_03A6;
ICON = 1;
IVAL = IND->DISP;
L_03A6:;
// 4482 ! sort out length of actual elements of array (may be %namearray)
// 4483 len = rlen; len = 4 %if form = a in s
LEN = RLEN;
if (FORM != 4) goto L_03A7;
LEN = 4;
L_03A7:;
// 4484 ! change A into a descriptor for the zeroth element
// 4485 %if a_form = v in rec %start
if (A->FORM != 5) goto L_03A8;
// 4486 %if aname = 0 %start; ! array in record
if (ANAME != 0) goto L_03A9;
// 4487 %if a_mantissa = 0 %start
if (A->MANTISSA != 0) goto L_03AA;
// 4488 ! ie addr(A(0)) = addr(record)
// 4489 a_form = a in s; a_disp = a_extra
A->FORM = 4;
A->DISP = A->EXTRA;
// 4490 %else
goto L_03AB;
L_03AA:;
// 4491 a_disp = a_extra; a_form = v in s
A->DISP = A->EXTRA;
A->FORM = 2;
// 4492 load (a, any)
LOAD(A, 17);
// 4493 a_form = v in s; a_disp = a_mantissa
A->FORM = 2;
A->DISP = A->MANTISSA;
// 4494 %finish
L_03AB:;
// 4495 %else; ! arrayname in record
goto L_03AC;
L_03A9:;
// 4496 a_form = a in rec
A->FORM = 7;
// 4497 address (a)
ADDRESS(A);
// 4498 hbase = a_base; hdisp = a_disp; ! Will have changed
HBASE = A->BASE;
HDISP = A->DISP;
// 4499 %finish
L_03AC:;
// 4500 %else; ! v in s
goto L_03AD;
L_03A8:;
// 4501 %if a_header = -1 %start
if (A->HEADER != -1) goto L_03AE;
// 4502 a_form = a in s; ! for arrayname or header complete
A->FORM = 4;
// 4503 %else
goto L_03AF;
L_03AE:;
// 4504 a_disp = a_mantissa
A->DISP = A->MANTISSA;
// 4505 a_form = v in s
A->FORM = 2;
// 4506 %finish
L_03AF:;
// 4507 %finish
L_03AD:;
// 4508
// 4509 %if control&arr check # 0 %start; ! Check array index
if (CONTROL & 8 == 0) goto L_03B0;
// 4510 load (ind, r1)
LOAD(IND, 2);
// 4511 lstack (hdisp); lhs_base = hbase
LSTACK(HDISP);
LHS->BASE = HBASE;
// 4512 lhs_xno = a_xno; stp = stp - 1
LHS->XNO = A->XNO;
STP = STP - 1;
// 4513 %if a_header < 0 %start; ! Header complete: load in 1 go
if (A->HEADER >= 0) goto L_03B1;
// 4514 hazard (r2); hazard (r3)
HAZARD(3);
HAZARD(4);
// 4515 plant2 (movq, lhs, regv(r2))
PLANT2(13, LHS, /*?*/ ®V[2]);
// 4516 %else
goto L_03B2;
L_03B1:;
// 4517 lhs_disp = lhs_disp + 4; ! point at dope vector pointer
LHS->DISP = LHS->DISP + 4;
// 4518 load (lhs, r3); ! load it: r3 -> dope vector
LOAD(LHS, 4);
// 4519 amap (a); load (a, r2); ! r2 is zero address
AMAP(A);
LOAD(A, 3);
// 4520 release (r2); release (r3)
RELEASE(3);
RELEASE(4);
// 4521 %finish
L_03B2:;
// 4522 drop (lhs)
DROP(LHS);
// 4523 release (r1)
RELEASE(2);
// 4524 prim (aref)
PRIM(18);
// 4525 claim (r1); a_base = r1; a_disp = 0
CLAIM(2);
A->BASE = 2;
A->DISP = 0;
// 4526 %else; ! No checking
goto L_03B3;
L_03B0:;
// 4527 aname = 0; aname = 1 %if a_form = a in s
ANAME = 0;
if (A->FORM != 4) goto L_03B4;
ANAME = 1;
L_03B4:;
// 4528 %if aname = 0 %and (ind_oper = add %or ind_oper = sub) %and
if (ANAME != 0) goto L_03B5;
if (IND->OPER == 9) goto L_03B6;
if (IND->OPER != 10) goto L_03B5;
L_03B6:;
if (!(CONST(IND->LINK))) goto L_03B5;
// 4529+ const (ind_link) %start
// 4530 ! a(j+const) -> a(j) ++ const
// 4531 c = ind_link_disp; c = -c %if ind_oper = sub
C = IND->LINK->DISP;
if (IND->OPER != 10) goto L_03B7;
C = -C;
L_03B7:;
// 4532 a_disp = a_disp + c * len
A->DISP = A->DISP + C * LEN;
// 4533 drop (ind_link); ind_oper = 0
DROP(IND->LINK);
IND->OPER = 0;
// 4534 %finish
L_03B5:;
// 4535 %if icon # 0 %and ival = 0 %and aname # 0 %and
if (ICON == 0) goto L_03B8;
if (IVAL != 0) goto L_03B8;
if (ANAME == 0) goto L_03B8;
if (FORM == 2) goto L_03B9;
if (ACTIVITY[A->BASE] >= 0) goto L_03B8;
L_03B9:;
// 4536+ (form = v in s %or activity(a_base) < 0) %start
// 4537 ! aname(0) -> @aname
// 4538 %if form = v in s %start
if (FORM != 2) goto L_03BA;
// 4539 form = a in s
FORM = 4;
// 4540 %else
goto L_03BB;
L_03BA:;
// 4541 form = a in rec; a_extra = a_disp; a_disp = 0
FORM = 7;
A->EXTRA = A->DISP;
A->DISP = 0;
// 4542 %finish
L_03BB:;
// 4543 %else
goto L_03BC;
L_03B8:;
// 4544 %if len = 0 %start; ! %record/%string(*) %arraynames
if (LEN != 0) goto L_03BD;
// 4545 !get size from dope vector
// 4546 lstack (hdisp+4); ! disp of dope vector pointer
LSTACK(HDISP + 4);
// 4547 lhs_base = hbase
LHS->BASE = HBASE;
// 4548 lhs_xno = a_xno
LHS->XNO = A->XNO;
// 4549 load (lhs, any)
LOAD(LHS, 17);
// 4550 lhs_form = v in s; lhs_disp = 12; ! size l/word in dv.
LHS->FORM = 2;
LHS->DISP = 12;
// 4551 %else
goto L_03BE;
L_03BD:;
// 4552 cstack (len)
CSTACK(LEN);
// 4553 %finish
L_03BE:;
// 4554 operate (mul)
OPERATE(27);
// 4555 amap (a); operate (add)
AMAP(A);
OPERATE(9);
// 4556 vmap (a)
VMAP(A);
// 4557 %if form = a in s %then form = a_form + 2 %c
if (FORM != 4) goto L_03BF;
FORM = A->FORM + 2;
goto L_03C0;
L_03BF:;
FORM = A->FORM;
L_03C0:;
// 4558+ %else form = a_form
// 4559 idrop = 0; ! ind will have been dropped
IDROP = 0;
// 4560 %finish
L_03BC:;
// 4561 %finish
L_03B3:;
// 4562 stp = stp - 1 %and drop (ind) %if idrop # 0; ! Not already done
if (IDROP == 0) goto L_03C1;
STP = STP - 1;
DROP(IND);
L_03C1:;
// 4563 %else; ! multi dim - uses the perm
goto L_03C2;
L_03A5:;
// 4564 stp = stp - 1
STP = STP - 1;
// 4565 a_oper = 0
A->OPER = 0;
// 4566 ! expend stacked indices
// 4567 address (ind)
ADDRESS(IND);
// 4568 push (ind, x)
PUSH(IND, /*?*/ &X);
// 4569 %cycle
L_03C3:;
// 4570 ind == a_link; a_link == ind_link
IND = (struct STACKFM *)A->LINK;
A->LINK = (struct STACKFM *)IND->LINK;
// 4571 push (ind, x)
PUSH(IND, /*?*/ &X);
// 4572 %repeat %until a_link == null
if (_imp_ADDR((void *)(A->LINK)) == _imp_ADDR((void *)(NULL))) goto L_03C4;
goto L_03C3;
L_03C4:;
// 4573 address (a)
ADDRESS(A);
// 4574 hazard (r2); hazard (r3)
HAZARD(3);
HAZARD(4);
// 4575 plant2 (movq, a, regv(r2))
PLANT2(13, A, /*?*/ ®V[2]);
// 4576 prim (arefn)
PRIM(17);
// 4577 claim (r1); a_base = r1; a_disp = 0; a_form = v in s
CLAIM(2);
A->BASE = 2;
A->DISP = 0;
A->FORM = 2;
// 4578 %finish
L_03C2:;
// 4579 a_form = form
A->FORM = FORM;
// 4580 a_xno = 0 %unless a_base = pc
if (A->BASE == 16) goto L_03C5;
A->XNO = 0;
L_03C5:;
// 4581 a_type = type; a_length = rlen
A->TYPE = TYPE;
A->LENGTH = RLEN;
// 4582 monitor (a, "Array ref") %if diag&8 # 0
if (DIAG & 8 == 0) goto L_03C6;
MONITOR(A, _imp_str_literal_size(15, "Array ref"));
L_03C6:;
// 4583 %end
return;
} /* end of ARRAYREF */
// 4584
// 4585 !comparison processing
// 4586
// 4587 %routine TEST ZERO (%record(stackfm) %name v)
void TESTZERO(struct STACKFM * V) {
// 4588 !check v against zero
// 4589 %record(stackfm) %name w
struct STACKFM *W;
// 4590 %integer d, op
int D;
int OP;
// 4591 unsigned = 0
UNSIGNED = 0;
// 4592 %if v_oper = bic %and v_link_form = constant %start
if (V->OPER != 12) goto L_03C7;
if (V->LINK->FORM != 0) goto L_03C7;
// 4593 d = \v_link_disp
D = (~V->LINK->DISP);
// 4594 drop (v_link); v_oper = 0
DROP(V->LINK);
V->OPER = 0;
// 4595 op = bitl
OP = 49320;
// 4596 %if v_type = byte+integers %start
if (V->TYPE != 2 + 16) goto L_03C8;
// 4597 %if d&(\255) # 0 %then load (v, any) %else op = bitl+byte
if (D & (~255) == 0) goto L_03C9;
LOAD(V, 17);
goto L_03CA;
L_03C9:;
OP = 49320 + 2;
L_03CA:;
// 4598 %else %if v_type = short+integers
goto L_03CB;
L_03C8:;
if (V->TYPE != 1 + 16) goto L_03CC;
// 4599 %if d&16_ffff0000 # 0 %then load (v, any) %else op = bitl+short
if (D & (-65536) == 0) goto L_03CD;
LOAD(V, 17);
goto L_03CE;
L_03CD:;
OP = 49320 + 1;
L_03CE:;
// 4600 %finish
L_03CC:;
L_03CB:;
// 4601 address (v)
ADDRESS(V);
// 4602 w == literal(d); stp = stp-1
W = (struct STACKFM *)LITERAL(D);
STP = STP - 1;
// 4603 w_type = v_type
W->TYPE = V->TYPE;
// 4604 plant2 (op, v, w)
PLANT2(OP, V, W);
// 4605 drop (w)
DROP(W);
// 4606 %else
goto L_03CF;
L_03C7:;
// 4607 address (v)
ADDRESS(V);
// 4608 unsigned = 8 %if v_type = byte+integers
if (V->TYPE != 2 + 16) goto L_03D0;
UNSIGNED = 8;
L_03D0:;
// 4609 plant1 (tstl+v_type&7, v)
PLANT1(232 + (V->TYPE & 7), V);
// 4610 %finish
L_03CF:;
// 4611 clear (v)
CLEAR(V);
// 4612 %end
return;
} /* end of TESTZERO */
// 4613
// 4614 %routine COMPARE (%record(stackfm) %name left, right, %integer mod)
void COMPARE(struct STACKFM * LEFT, struct STACKFM * RIGHT, int MOD) {
// 4615 ! set the cc from left and right
// 4616 %integer work
int WORK;
// 4617 %record(stackfm) %name len, temp
struct STACKFM *LEN;
struct STACKFM *TEMP;
// 4618
// 4619 %routine CHECK (%record(stackfm) %name a, b)
void CHECK(struct STACKFM * A, struct STACKFM * B) {
// 4620 ! a is a constant string
// 4621 %record(stackfm) len
struct STACKFM LEN;
// 4622 len = 0
LEN = (struct STACKFM){0};
// 4623 len_disp = a_format
LEN.DISP = A->FORMAT;
// 4624 %if len_disp = 0+1 %start; !null
if (LEN.DISP != 0 + 1) goto L_03D1;
// 4625 b_type = byte+integers
B->TYPE = 2 + 16;
// 4626 test zero (b)
TESTZERO(B);
// 4627 %else
goto L_03D2;
L_03D1:;
// 4628 address (b)
ADDRESS(B);
// 4629 string3 (cmpc3, len, a, b)
STRING3(246, /*?*/ &LEN, A, B);
// 4630 %finish
L_03D2:;
// 4631 %end
return;
} /* end of CHECK */
// 4632
// 4633 %if zero (right) %start
if (!(ZERO(RIGHT))) goto L_03D3;
// 4634 !************** rubbish %if mod # 0 %and left_oper = sub %start
// 4635 !************** rubbish ! a - b comp 0 => a comp b
// 4636 !************** rubbish drop (right); right == left_link; left_oper = 0
// 4637 !************** rubbish %else
// 4638 test zero (left); %return
TESTZERO(LEFT);
return;
// 4639 !*****************rubbish %finish
// 4640 %finish
L_03D3:;
// 4641 %if zero (left) %start
if (!(ZERO(LEFT))) goto L_03D4;
// 4642 %if mod # 0 %and right_oper = sub %start
if (MOD == 0) goto L_03D5;
if (RIGHT->OPER != 10) goto L_03D5;
// 4643 ! 0 comp a - b => b comp a
// 4644 drop (left); left == right_link; right_oper = 0
DROP(LEFT);
LEFT = (struct STACKFM *)RIGHT->LINK;
RIGHT->OPER = 0;
// 4645 %else
goto L_03D6;
L_03D5:;
// 4646 invert = invert!!16
INVERT = INVERT ^ 16;
// 4647 test zero (right); %return
TESTZERO(RIGHT);
return;
// 4648 %finish
L_03D6:;
// 4649 %finish
L_03D4:;
// 4650
// 4651 unsigned = 0
UNSIGNED = 0;
// 4652 %if right_type&strings # 0 %start
if (RIGHT->TYPE & 64 == 0) goto L_03D7;
// 4653 %unless '=' # look # '#' %start
{
// Double-sided test on LOOK() (Part I)
int tmp;
if (61 == (tmp = LOOK())) goto L_03D8;
// Double-sided test on LOOK() (Part II)
if (tmp != 35) goto L_03D9;
}
L_03D8:;
// 4654 %if left_format # 0 %start
if (LEFT->FORMAT == 0) goto L_03DA;
// 4655 check (left, right); %return
CHECK(LEFT, RIGHT);
return;
// 4656 %finish
L_03DA:;
// 4657 %if right_format # 0 %start
if (RIGHT->FORMAT == 0) goto L_03DB;
// 4658 check (right, left); %return
CHECK(RIGHT, LEFT);
return;
// 4659 %finish
L_03DB:;
// 4660 string op (cmpc3, left, right); %return
STRINGOP(246, LEFT, RIGHT);
return;
// 4661 %finish
L_03D9:;
// 4662 load (left, r10); load (right, r2)
LOAD(LEFT, 11);
LOAD(RIGHT, 3);
// 4663 release (r10); release (r2)
RELEASE(11);
RELEASE(3);
// 4664 prim (scomp)
PRIM(11);
// 4665 %return
return;
// 4666 %finish
L_03D7:;
// 4667 ! ???? Why the following, if pass1 won't let one compare records????????
// 4668 %if left_type = records %or right_type = records %start
if (LEFT->TYPE == 128) goto L_03DC;
if (RIGHT->TYPE != 128) goto L_03DD;
L_03DC:;
// 4669 work = var(left_format)_length
WORK = VAR[LEFT->FORMAT].LENGTH;
// 4670 %if work = 0 %and right_type = records %start
if (WORK != 0) goto L_03DE;
if (RIGHT->TYPE != 128) goto L_03DE;
// 4671 work = var(right_format)_length
WORK = VAR[RIGHT->FORMAT].LENGTH;
// 4672 %finish
L_03DE:;
// 4673 len == literal(work); stp = stp - 1
LEN = (struct STACKFM *)LITERAL(WORK);
STP = STP - 1;
// 4674 len_type = short+integers
LEN->TYPE = 1 + 16;
// 4675 address (left); left_type = integers
ADDRESS(LEFT);
LEFT->TYPE = 16;
// 4676 address (right); right_type=integers
ADDRESS(RIGHT);
RIGHT->TYPE = 16;
// 4677 string3 (cmpc3, len, left, right)
STRING3(246, LEN, LEFT, RIGHT);
// 4678 clear (left); clear (right)
CLEAR(LEFT);
CLEAR(RIGHT);
// 4679 drop (len)
DROP(LEN);
// 4680 %return
return;
// 4681 %finish
L_03DD:;
// 4682 address (left); address (right)
ADDRESS(LEFT);
ADDRESS(RIGHT);
// 4683 equate (left, right, 1)
EQUATE(LEFT, RIGHT, 1);
// 4684 unsigned = 8 %if left_type = byte+integers
if (LEFT->TYPE != 2 + 16) goto L_03DF;
UNSIGNED = 8;
L_03DF:;
// 4685 %if short literal(left) >= 0 %start
if (SHORTLITERAL(LEFT) < 0) goto L_03E0;
// 4686 ! faster to have it on the right...
// 4687 invert = invert!!16
INVERT = INVERT ^ 16;
// 4688 temp == right; right == left; left == temp
TEMP = (struct STACKFM *)RIGHT;
RIGHT = (struct STACKFM *)LEFT;
LEFT = (struct STACKFM *)TEMP;
// 4689 %finish
L_03E0:;
// 4690 plant2 (cmpl+left_type&7, left, right)
PLANT2(240 + (LEFT->TYPE & 7), LEFT, RIGHT);
// 4691 clear (left); clear (right)
CLEAR(LEFT);
CLEAR(RIGHT);
// 4692 %end
return;
} /* end of COMPARE */
// 4693
// 4694 %routine COMPARE ARRAYNAMES (%record(stack fm) %name lhs, rhs)
void COMPAREARRAYNAMES(struct STACKFM * LHS, struct STACKFM * RHS) {
// 4695 lhs_form = lhs_form&15; rhs_form = rhs_form&15
LHS->FORM = LHS->FORM & 15;
RHS->FORM = RHS->FORM & 15;
// 4696 address (lhs); address (rhs)
ADDRESS(LHS);
ADDRESS(RHS);
// 4697 plant2 (cmpd, lhs, rhs)
PLANT2(244, LHS, RHS);
// 4698 clear (lhs); clear (rhs)
CLEAR(LHS);
CLEAR(RHS);
// 4699 %end
return;
} /* end of COMPAREARRAYNAMES */
// 4700
// 4701 %routine SET CC
void SETCC(void) {
// 4702 %const %byte %array cc (1:6) = 4, 8, 8+2+1, 8+1, 8+2, 4+2
const unsigned char CC[6] = {4, 8, 11, 9, 10, 6};
// 4703 %const %byte %array cmap(1:6) = '=', '<', '(', '>', ')', '#'
const unsigned char CMAP[6] = {61, 60, 40, 62, 41, 35};
// 4704 %record(stackfm) %name pos, one, temp
struct STACKFM *POS;
struct STACKFM *ONE;
struct STACKFM *TEMP;
// 4705 %integer sym, code, r
int SYM;
int CODE;
int R;
// 4706
// 4707 get (sym)
GET(/*?*/ &SYM);
// 4708 code = 0
CODE = 0;
// 4709 %for r = 1,1,6 %cycle
// %for R = 1, 1, 6 %cycle
{
R = 0;
L_03E1:
if (R == 6) goto L_03E2;
R += 1;
// 4710 code = r %and %exit %if cmap(r) = sym
if (CMAP[R - 1] != SYM) goto L_03E4;
CODE = R;
goto L_03E2;
L_03E4:;
// 4711 %repeat
goto L_03E1;
}
L_03E2:;
// 4712 abort (34) %if code = 0
if (CODE != 0) goto L_03E5;
ABORT(34);
L_03E5:;
// 4713 code = cc(code)
CODE = CC[CODE - 1];
// 4714 set both
SETBOTH();
// 4715 %if code&1 # 0 %start; !swop first
if (CODE & 1 == 0) goto L_03E6;
// 4716 temp == lhs; lhs == rhs; rhs == temp
TEMP = (struct STACKFM *)LHS;
LHS = (struct STACKFM *)RHS;
RHS = (struct STACKFM *)TEMP;
// 4717 %finish
L_03E6:;
// 4718 compare (lhs, rhs, 1); stp = stp-2
COMPARE(LHS, RHS, 1);
STP = STP - 2;
// 4719 drop (lhs); drop (rhs)
DROP(LHS);
DROP(RHS);
// 4720 r = register (0)
R = REGISTER(0);
// 4721 temp == regv (r)
TEMP = (struct STACKFM *)/*?*/ ®V[R - 1];
// 4722 claim (r)
CLAIM(R);
// 4723 plant1 (movpsl, temp)
PLANT1(39, TEMP);
// 4724 plant2 (mcoml, temp, temp) %if code&2 # 0; !invert it
if (CODE & 2 == 0) goto L_03E7;
PLANT2(24, TEMP, TEMP);
L_03E7:;
// 4725 pos == literal(code&(4!8)); stp = stp - 1
POS = (struct STACKFM *)LITERAL(CODE & (4 | 8));
STP = STP - 1;
// 4726 one == literal(1); stp = stp - 1
ONE = (struct STACKFM *)LITERAL(1);
STP = STP - 1;
// 4727 drop (pos); drop (one)
DROP(POS);
DROP(ONE);
// 4728 plant4 (extzv, pos, one, temp, temp)
PLANT4(87, POS, ONE, TEMP, TEMP);
// 4729 dstack (temp)
DSTACK(TEMP);
// 4730 %end
return;
} /* end of SETCC */
// 4731
// 4732 %routine FOR
void FOR(void) {
// 4733 ! compile a %for clause
// 4734 %integer lab, err, fixed, old control
int LAB;
int ERR;
int FIXED;
int OLDCONTROL;
// 4735 %integer sc, sv, ic, iv, lc, lv, x
int SC;
int SV;
int IC;
int IV;
int LC;
int LV;
int X;
// 4736 %record(stackfm) %name cont, init, incr, last
struct STACKFM *CONT;
struct STACKFM *INIT;
struct STACKFM *INCR;
struct STACKFM *LAST;
// 4737
// 4738 %routine STAB (%record(stack fm) %name v, %integername con, val)
void STAB(struct STACKFM * V, int *CON, int *VAL) {
// 4739 %record(stack fm) %name w
struct STACKFM *W;
// 4740 con = 0
*CON = 0;
// 4741 %if const (v) %start
if (!(CONST(V))) goto L_03E8;
// 4742 con = 1
*CON = 1;
// 4743 val = v_disp
*VAL = V->DISP;
// 4744 %else
goto L_03E9;
L_03E8:;
// 4745 w == temp(4)
W = (struct STACKFM *)TEMP(4);
// 4746 dstack (v); v = w
DSTACK(V);
*V = *W;
// 4747 assign (1)
ASSIGN(1);
// 4748 %finish
L_03E9:;
// 4749 %end
return;
} /* end of STAB */
// 4750
// 4751 stp = stp - 4
STP = STP - 4;
// 4752 cont == stacked(stp+1)
CONT = (struct STACKFM *)STACKED[STP + 1 - 1];
// 4753 incr == stacked(stp+2)
INCR = (struct STACKFM *)STACKED[STP + 2 - 1];
// 4754 last == stacked(stp+3)
LAST = (struct STACKFM *)STACKED[STP + 3 - 1];
// 4755 init == stacked(stp+4)
INIT = (struct STACKFM *)STACKED[STP + 4 - 1];
// 4756
// 4757 abort (20) %if cont_type&integers = 0
if (CONT->TYPE & 16 != 0) goto L_03EA;
ABORT(20);
L_03EA:;
// 4758 %if cont_type # integers %start
if (CONT->TYPE == 16) goto L_03EB;
// 4759 error ('*', "only %integer %for-loop variables permitted")
ERROR(42, _imp_str_literal_size(127, "only %integer %for-loop variables permitted"));
// 4760 cont_type = integers
CONT->TYPE = 16;
// 4761 %finish
L_03EB:;
// 4762 stab (incr, ic, iv)
STAB(INCR, /*?*/ &IC, /*?*/ &IV);
// 4763 stab (last, lc, lv)
STAB(LAST, /*?*/ &LC, /*?*/ &LV);
// 4764 sc = 0; sc = 1 %and sv = init_disp %if const (init)
SC = 0;
if (!(CONST(INIT))) goto L_03EC;
SC = 1;
SV = INIT->DISP;
L_03EC:;
// 4765 %unless activity(cont_base) < 0 %and cont_form = v in s %and
if (ACTIVITY[CONT->BASE] >= 0) goto L_03E3;
if (CONT->FORM != 2) goto L_03E3;
if (CONT->FLAGS == 0) goto L_03ED;
L_03E3:;
// 4766+ cont_flags = 0 %start
// 4767 ! Can't use cv directly
// 4768 amap (cont); stab (cont, x, x); cont_form = a in s
AMAP(CONT);
STAB(CONT, /*?*/ &X, /*?*/ &X);
CONT->FORM = 4;
// 4769 %finish
L_03ED:;
// 4770 fixed = sc&ic&lc; ! constant bounded loop?
FIXED = SC & IC & LC;
// 4771 dstack (cont); ! to assign to
DSTACK(CONT);
// 4772 %if fixed = 0 %and control&for check # 0 %start
if (FIXED != 0) goto L_03EE;
if (CONTROL & 4 == 0) goto L_03EE;
// 4773 ! Need perm call
// 4774 dstack (init); pop lhs; lrd (lhs, r1)
DSTACK(INIT);
POPLHS();
LRD(LHS, 2);
// 4775 dstack (incr); pop lhs; lrd (lhs, r2)
DSTACK(INCR);
POPLHS();
LRD(LHS, 3);
// 4776 dstack (last); pop lhs; lrd (lhs, r3)
DSTACK(LAST);
POPLHS();
LRD(LHS, 4);
// 4777 prim (for test); ! returns init-incr
PRIM(10);
// 4778 dstack (regv(r0))
DSTACK(/*?*/ ®V[0]);
// 4779 claim (r0)
CLAIM(1);
// 4780 %else %if fixed # 0
goto L_03EF;
L_03EE:;
if (FIXED == 0) goto L_03F0;
// 4781 ! Fixed loop - test for legality
// 4782 sv = sv - iv
SV = SV - IV;
// 4783 err = 0
ERR = 0;
// 4784 %if iv = 0 %start
if (IV != 0) goto L_03F1;
// 4785 err = 1 %unless sv = lv; ! x, 0, y
if (SV == LV) goto L_03F2;
ERR = 1;
L_03F2:;
// 4786 %else
goto L_03F3;
L_03F1:;
// 4787 %if iv > 0 %start
if (IV <= 0) goto L_03F4;
// 4788 err = 1 %if sv > lv
if (SV <= LV) goto L_03F5;
ERR = 1;
L_03F5:;
// 4789 %else
goto L_03F6;
L_03F4:;
// 4790 err = 1 %if sv < lv
if (SV >= LV) goto L_03F7;
ERR = 1;
L_03F7:;
// 4791 %finish
L_03F6:;
// 4792 err = 1 %if rem (lv-sv, iv) # 0
if (_imp_REM(LV - SV, IV) == 0) goto L_03F8;
ERR = 1;
L_03F8:;
// 4793 %finish
L_03F3:;
// 4794 error ('*', "%for loop cannot terminate") %if err # 0
if (ERR == 0) goto L_03F9;
ERROR(42, _imp_str_literal_size(127, "%for loop cannot terminate"));
L_03F9:;
// 4795 cstack (sv)
CSTACK(SV);
// 4796 %else
goto L_03EF;
L_03F0:;
// 4797 dstack (init); dstack (incr); operate (sub)
DSTACK(INIT);
DSTACK(INCR);
OPERATE(10);
// 4798 %finish
L_03EF:;
// 4799 assign (1)
ASSIGN(1);
// 4800 lab = getword; define label (lab)
LAB = GETWORD();
DEFINELABEL(LAB);
// 4801
// 4802 ! No need to check assigned from here on
// 4803 old control = control
OLDCONTROL = CONTROL;
// 4804 control = control & (\ass check)
CONTROL = CONTROL & (~1);
// 4805
// 4806 ! %exit %if cont = last
// 4807 compare (cont, last, 0)
COMPARE(CONT, LAST, 0);
// 4808 jump to (lab+1, 1, 1)
JUMPTO(LAB + 1, 1, 1);
// 4809
// 4810 ! cont = cont + incr
// 4811 dstack (cont); dstack (cont); dstack (incr)
DSTACK(CONT);
DSTACK(CONT);
DSTACK(INCR);
// 4812 operate (add); assign (1)
OPERATE(9);
ASSIGN(1);
// 4813
// 4814 control = old control
CONTROL = OLDCONTROL;
// 4815
// 4816 drop (cont); drop (incr); drop (init); drop (last)
DROP(CONT);
DROP(INCR);
DROP(INIT);
DROP(LAST);
// 4817 %end
return;
} /* end of FOR */
// 4818
// 4819
// 4820 !procedure processing
// 4821
// 4822 %routine PUSH (%record(stackfm) %name t, %integer %name n)
void PUSH(struct STACKFM * T, int *N) {
// 4823 %integer op, mop, old op
int OP;
int MOP;
int OLDOP;
// 4824 %record(stackfm) %name w
struct STACKFM *W;
// 4825 %record(stackfm) ww
struct STACKFM WW;
// 4826
// 4827 monitor (t, "Push") %if diag&16 # 0
if (DIAG & 16 == 0) goto L_03FA;
MONITOR(T, _imp_str_literal_size(15, "Push"));
L_03FA:;
// 4828
// 4829 op = pushl; mop = -1
OP = 32;
MOP = -1;
// 4830 %if t_oper # 0 %start; !arraynames or %name
if (T->OPER == 0) goto L_03FB;
// 4831 old op = t_oper; t_oper = 0
OLDOP = T->OPER;
T->OPER = 0;
// 4832 %if old op = 2 %start; !general name
if (OLDOP != 2) goto L_03FC;
// 4833 push (literal(t_type<<24+t_length), n); stp = stp-1
PUSH(LITERAL((T->TYPE << 24) + T->LENGTH), N);
STP = STP - 1;
// 4834 t_form = t_form & 15
T->FORM = T->FORM & 15;
// 4835 address (t)
ADDRESS(T);
// 4836 amap (t)
AMAP(T);
// 4837 %else %if old op = 1
goto L_03FD;
L_03FC:;
if (OLDOP != 1) goto L_03FE;
// 4838 move arrayname (t, spv)
MOVEARRAYNAME(T, /*?*/ &SPV);
// 4839 n = n + 2; %return
*N = *N + 2;
return;
// 4840 %else
L_03FE:;
// 4841 t_form = v in s; mop = movq
T->FORM = 2;
MOP = 13;
// 4842 drop (t)
DROP(T);
// 4843 %finish
L_03FD:;
// 4844 %else %if t_type = integers
goto L_03FF;
L_03FB:;
if (T->TYPE != 16) goto L_0400;
// 4845 address (t) %if t_form # av in s
if (T->FORM == 3) goto L_0401;
ADDRESS(T);
L_0401:;
// 4846 %if t_form = constant %and -64 <= t_disp < 0 %start
if (T->FORM != 0) goto L_0402;
{
// Double-sided test on T->DISP (Part I)
int tmp;
if (-64 > (tmp = T->DISP)) goto L_0402;
// Double-sided test on T->DISP (Part II)
if (tmp >= 0) goto L_0402;
}
// 4847 ! Can use mcoml,mnegl - let PLANT2 fix it
// 4848 mop = movl;
MOP = 8968;
// 4849 drop (t); n = n - 1
DROP(T);
*N = *N - 1;
// 4850 %finish
L_0402:;
// 4851 %else
goto L_03FF;
L_0400:;
// 4852 %if t_type&(records!strings) # 0 %start
if (T->TYPE & (128 | 64) == 0) goto L_0403;
// 4853 %if t_type = records %start
if (T->TYPE != 128) goto L_0404;
// 4854 w == temp(var(t_format)_length)
W = (struct STACKFM *)TEMP(VAR[T->FORMAT].LENGTH);
// 4855 w_type = records; w_format = t_format
W->TYPE = 128;
W->FORMAT = T->FORMAT;
// 4856 dstack (w); dstack (t); assign (1)
DSTACK(W);
DSTACK(T);
ASSIGN(1);
// 4857 stp = stp - 1
STP = STP - 1;
// 4858 drop (t); t == w
DROP(T);
T = (struct STACKFM *)W;
// 4859 %else %if t_type = strings; !not already in wk strg
goto L_0405;
L_0404:;
if (T->TYPE != 64) goto L_0406;
// 4860 w == work string; stp = stp-1
W = (struct STACKFM *)WORKSTRING();
STP = STP - 1;
// 4861 ww = w
WW = *W;
// 4862 assign string (t, w); drop (t)
ASSIGNSTRING(T, W);
DROP(T);
// 4863 t == w; t = ww
T = (struct STACKFM *)W;
*T = WW;
// 4864 %finish
L_0406:;
L_0405:;
// 4865 t_type = integers; op = pushal
T->TYPE = 16;
OP = 4136;
// 4866 %else %if t_type&real bit # 0
goto L_0407;
L_0403:;
if (T->TYPE & 32 == 0) goto L_0408;
// 4867 address (t)
ADDRESS(T);
// 4868 drop (t); clear (t); mop = movd
DROP(T);
CLEAR(T);
MOP = 12;
// 4869 %if t_type = reals %start
if (T->TYPE != 35) goto L_0409;
// 4870 n = n - 1; mop = movf
*N = *N - 1;
MOP = 11;
// 4871 %finish
L_0409:;
// 4872 %else %if t_type = long+integers
goto L_0407;
L_0408:;
if (T->TYPE != 5 + 16) goto L_040A;
// 4873 mop = movq; address (t); drop (t)
MOP = 13;
ADDRESS(T);
DROP(T);
// 4874 %else
goto L_0407;
L_040A:;
// 4875 address (t); clear (t); drop (t)
ADDRESS(T);
CLEAR(T);
DROP(T);
// 4876 mop = t_type&7*8+7*8
MOP = (T->TYPE & 7) * 8 + 7 * 8;
// 4877 n = n - 1; !only 1 longword
*N = *N - 1;
// 4878 %finish
L_0407:;
// 4879 %finish
L_03FF:;
// 4880 %if mop = -1 %start
if (MOP != -1) goto L_040B;
// 4881 %if t_form = av in s %start
if (T->FORM != 3) goto L_040C;
// 4882 op = pushal; t_form = v in s
OP = 4136;
T->FORM = 2;
// 4883 %finish
L_040C:;
// 4884 scale index (op, t)
SCALEINDEX(/*?*/ &OP, T);
// 4885 plant1 (op, t) %if op # 0
if (OP == 0) goto L_040D;
PLANT1(OP, T);
L_040D:;
// 4886 clear (t); drop (t)
CLEAR(T);
DROP(T);
// 4887 %else
goto L_040E;
L_040B:;
// 4888 scale index (mop, t)
SCALEINDEX(/*?*/ &MOP, T);
// 4889 plant2 (mop, t, spv)
PLANT2(MOP, T, /*?*/ &SPV);
// 4890 n = n + 1; !an extra param
*N = *N + 1;
// 4891 %finish
L_040E:;
// 4892 n = n + 1
*N = *N + 1;
// 4893 %end
return;
} /* end of PUSH */
// 4894
// 4895 %routine CALL (%record(stackfm) %name v)
void CALL(struct STACKFM * V) {
// 4896 !call procedure 'v'
// 4897 %integer reg, n, disp, type, form, pn, pa
int REG;
int N;
int DISP;
int TYPE;
int FORM;
int PN;
int PA;
// 4898 %record(stackfm) %name t, p, w
struct STACKFM *T;
struct STACKFM *P;
struct STACKFM *W;
// 4899 %record(stackfm) ec
struct STACKFM EC;
// 4900 %switch pri (1 : 31)
int PRI_index;
int PRI_line;
char *PRI_file;
static const void *PRI[31] = {&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing,
&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing,
&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing,
&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing,
&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing,
&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing,
&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing,
&&case_PRI_missing, &&case_PRI_missing, &&case_PRI_missing};
// 4901 %const %byte %array params (1 : 31) =
const unsigned char PARAMS[31] = {
[0 ... 16] = 1, [17 ... 18] = 2, [19 ... 21] = 0, 1, [23 ... 26] = 1, 0, 0, 2, 2};
// 4902+ 1(17), 2(2), 0(3), 1, 1(4), 0, 0, 2, 2
// 4903 %const %byte %array ptype (2 : 8) =
const unsigned char PTYPE[7] = {18, 17, 16, 64, 128, 35, 36};
// 4904+ byte+integers, short+integers,
// 4905+ integers, strings, records,
// 4906+ reals, reall
// 4907 %const %byte %array plen (2 : 8) =
const unsigned char PLEN[7] = {1, 2, 4, 0, 0, 4, 8};
// 4908+ 1, 2, 4, 0, 0, 4, 8
// 4909
// 4910 monitor (v, "Call") %if diag&16 # 0
if (DIAG & 16 == 0) goto L_040F;
MONITOR(V, _imp_str_literal_size(15, "Call"));
L_040F:;
// 4911 type = v_type; form = v_form&15
TYPE = V->TYPE;
FORM = V->FORM & 15;
// 4912 disp = v_disp
DISP = V->DISP;
// 4913 pn = v_mantissa
PN = V->MANTISSA;
// 4914 %if pn # 0 %start; ! %PRIM
if (PN == 0) goto L_0410;
// 4915 pa = params(pn); ! #parameters
PA = PARAMS[PN - 1];
// 4916 %if pa > 0 %start
if (PA <= 0) goto L_0411;
// 4917 t == v_link; t_oper = 0
T = (struct STACKFM *)V->LINK;
T->OPER = 0;
// 4918 %if pa = 2 %start
if (PA != 2) goto L_0412;
// 4919 rhs == t; ! 2nd parameter heads list
RHS = (struct STACKFM *)T;
// 4920 t == t_link
T = (struct STACKFM *)T->LINK;
// 4921 t_oper = 0
T->OPER = 0;
// 4922 %finish
L_0412:;
// 4923 dstack (t); set lhs
DSTACK(T);
SETLHS();
// 4924 drop (t)
DROP(T);
// 4925 %finish
L_0411:;
// 4926 drop (v) %if pn < 23; ! No actual external ref
if (PN >= 23) goto L_0413;
DROP(V);
L_0413:;
// 4927 -> pri (pn)
PRI_line = __LINE__;
PRI_file = __FILE__;
PRI_index = PN;
goto case_PRI_dispatch;
// 4928 pri(1): !addr
case_PRI_1:;
// 4929 %if lhs_form = 15 %start; ! of label?
if (LHS->FORM != 15) goto L_0415;
// 4930 n = register (0); claim (n)
N = REGISTER(0);
CLAIM(N);
// 4931 entry mask = entry mask ! reg mask (n)
ENTRYMASK = ENTRYMASK | REGMASK[N];
// 4932 put code (16_9E); !movab
PUTCODE(158);
// 4933 flush code
FLUSHCODE();
// 4934 define reference (lhs_disp, dir pref)
DEFINEREFERENCE(LHS->DISP, 3);
// 4935 put (obj call); ca = ca + 2; !assume short
PUT(11);
CA = CA + 2;
// 4936 put long (lhs_disp)
PUTLONG(LHS->DISP);
// 4937 put number byte (16_50+n-1); !Rn
PUTNUMBERBYTE(80 + N - 1);
// 4938 lhs_base = n; lhs_disp = 0; lhs_xno = 0
LHS->BASE = N;
LHS->DISP = 0;
LHS->XNO = 0;
// 4939 lhs_type = integers; lhs_form = v in r
LHS->TYPE = 16;
LHS->FORM = 1;
// 4940 %else
goto L_0416;
L_0415:;
// 4941 !!!! error ('*' "cannot take address of...") %if .. ??
// 4942 amap (lhs)
AMAP(LHS);
// 4943 %finish
L_0416:;
// 4944 %return
return;
// 4945 pri(2): !byte
case_PRI_2:;
// 4946 pri(3): !short
case_PRI_3:;
// 4947 pri(4): !integer
case_PRI_4:;
// 4948 pri(5): !string
case_PRI_5:;
// 4949 pri(6): !record
case_PRI_6:;
// 4950 pri(7): !real
case_PRI_7:;
// 4951 pri(8): !longreal
case_PRI_8:;
// 4952 load (lhs, any) %if pn = 5 %and lhs_flags&indexed # 0
if (PN != 5) goto L_0417;
if (LHS->FLAGS & 1 == 0) goto L_0417;
LOAD(LHS, 17);
L_0417:;
// 4953 vmap (lhs)
VMAP(LHS);
// 4954 lhs_type = ptype(pn)
LHS->TYPE = PTYPE[PN - 2];
// 4955 lhs_length = plen(pn)
LHS->LENGTH = PLEN[PN - 2];
// 4956 lhs_format = 0; ! For strings/records
LHS->FORMAT = 0;
// 4957 %return
return;
// 4958 pri(9): !int
case_PRI_9:;
// 4959 pri(10): !intpt
case_PRI_10:;
// 4960 address (lhs)
ADDRESS(LHS);
// 4961 n = register (0); claim (n)
N = REGISTER(0);
CLAIM(N);
// 4962 plant2 (11*8-4*8+lhs_type&7*8+6*(10-pn), lhs, regv(n))
PLANT2(11 * 8 - 4 * 8 + (LHS->TYPE & 7) * 8 + 6 * (10 - PN), LHS, /*?*/ ®V[N - 1]);
// 4963 release (lhs_base)
RELEASE(LHS->BASE);
// 4964 lhs_base = n
LHS->BASE = N;
// 4965 lhs_form = v in r; lhs_disp = 0; lhs_xno = 0
LHS->FORM = 1;
LHS->DISP = 0;
LHS->XNO = 0;
// 4966 lhs_type = integers; lhs_length = 4
LHS->TYPE = 16;
LHS->LENGTH = 4;
// 4967 %return
return;
// 4968 pri(11): !read ch
case_PRI_11:;
// 4969 pri(12): !read symbol
case_PRI_12:;
// 4970 %if lhs_type&(integers!strings) = 0 %start
if (LHS->TYPE & (16 | 64) != 0) goto L_0418;
// 4971 error ('*', "invalid parameter to READ SYMBOL/CH")
ERROR(42, _imp_str_literal_size(127, "invalid parameter to READ SYMBOL/CH"));
// 4972 lhs_type = integers
LHS->TYPE = 16;
// 4973 %finish
L_0418:;
// 4974 prim (rch+pn-11)
PRIM(20 + PN - 11);
// 4975 abort (47) %if lhs_oper # 0
if (LHS->OPER == 0) goto L_0419;
ABORT(47);
L_0419:;
// 4976 %if lhs_type&strings # 0 %start
if (LHS->TYPE & 64 == 0) goto L_041A;
// 4977 %if lhs_form # v in s %or lhs_flags # 0 %start
if (LHS->FORM != 2) goto L_041B;
if (LHS->FLAGS == 0) goto L_041C;
L_041B:;
// 4978 amap (lhs); load (lhs, any)
AMAP(LHS);
LOAD(LHS, 17);
// 4979 lhs_form = v in s; lhs_type = byte+integers
LHS->FORM = 2;
LHS->TYPE = 2 + 16;
// 4980 %finish
L_041C:;
// 4981 lhs_flags = auto i %if activity(lhs_base) = 1
if (ACTIVITY[LHS->BASE] != 1) goto L_041D;
LHS->FLAGS = 4;
L_041D:;
// 4982 lhs_type = byte + integers; lhs_length = 1
LHS->TYPE = 2 + 16;
LHS->LENGTH = 1;
// 4983 dstack (lhs); cstack (1); assign (1)
DSTACK(LHS);
CSTACK(1);
ASSIGN(1);
// 4984 claim (lhs_base)
CLAIM(LHS->BASE);
// 4985 %if lhs_flags = auto i %start
if (LHS->FLAGS != 4) goto L_041E;
// 4986 lhs_flags = 0
LHS->FLAGS = 0;
// 4987 %else
goto L_041F;
L_041E:;
// 4988 lhs_disp = lhs_disp + 1
LHS->DISP = LHS->DISP + 1;
// 4989 %finish
L_041F:;
// 4990 %finish
L_041A:;
// 4991 w == regv(r0); claim (r0); dstack (w)
W = (struct STACKFM *)/*?*/ ®V[0];
CLAIM(1);
DSTACK(W);
// 4992 assign (1)
ASSIGN(1);
// 4993 %return
return;
// 4994 pri(20): !skip item
case_PRI_20:;
// 4995 pn = 22; !=skip symbol
PN = 22;
// 4996 pri(21): !skip ch
case_PRI_21:;
// 4997 pri(22): !skip symbol
case_PRI_22:;
// 4998 prim (rch+pn-21)
PRIM(20 + PN - 21);
// 4999 %return
return;
// 5000 pri(13): !printch
case_PRI_13:;
// 5001 pri(14): !print symbol
case_PRI_14:;
// 5002 stp = stp - 1
STP = STP - 1;
// 5003 lrd (lhs, r0)
LRD(LHS, 1);
// 5004 prim (pch+pn-13)
PRIM(22 + PN - 13);
// 5005 %return
return;
// 5006 pri(15): !tostring
case_PRI_15:;
// 5007 stp = stp-1
STP = STP - 1;
// 5008 w == temp(2); w_type = byte+integers
W = (struct STACKFM *)TEMP(2);
W->TYPE = 2 + 16;
// 5009 dstack (w); dstack (w)
DSTACK(W);
DSTACK(W);
// 5010 dstack (lhs); drop (lhs)
DSTACK(LHS);
DROP(LHS);
// 5011 set both; lhs_disp = lhs_disp + 1
SETBOTH();
LHS->DISP = LHS->DISP + 1;
// 5012 assign (1)
ASSIGN(1);
// 5013 cstack (1)
CSTACK(1);
// 5014 assign (1)
ASSIGN(1);
// 5015 set lhs; lhs_type = strings; lhs_format = 2
SETLHS();
LHS->TYPE = 64;
LHS->FORMAT = 2;
// 5016 %return
return;
// 5017 pri(18): !charno
case_PRI_18:;
// 5018 %if control&str check # 0 %start
if (CONTROL & 2 == 0) goto L_0420;
// 5019 load (lhs, r0); release (r0); ! string address
LOAD(LHS, 1);
RELEASE(1);
// 5020 lrd (rhs, r1); ! character #
LRD(RHS, 2);
// 5021 prim (char num)
PRIM(24);
// 5022 claim (r0)
CLAIM(1);
// 5023 lhs_form = v in s; lhs_length = 1
LHS->FORM = 2;
LHS->LENGTH = 1;
// 5024 lhs_type = byte+integers
LHS->TYPE = 2 + 16;
// 5025 %return
return;
// 5026 %finish
L_0420:;
// 5027 dstack (rhs); drop (rhs)
DSTACK(RHS);
DROP(RHS);
// 5028 operate (add); set lhs
OPERATE(9);
SETLHS();
// 5029 pri(17): !length
case_PRI_17:;
// 5030 vmap (lhs)
VMAP(LHS);
// 5031 lhs_type = byte+integers
LHS->TYPE = 2 + 16;
// 5032 lhs_length = 1
LHS->LENGTH = 1;
// 5033 %return
return;
// 5034 pri(19): !rem
case_PRI_19:;
// 5035 dstack (rhs); drop (rhs)
DSTACK(RHS);
DROP(RHS);
// 5036 operate (remy)
OPERATE(28);
// 5037 set lhs
SETLHS();
// 5038 pri(16): !float
case_PRI_16:;
// 5039 %return; ! already done by ASSIGN!
return;
// 5040 pri(24): !PUT
case_PRI_24:;
// 5041 pri(25): !PUT WORD
case_PRI_25:;
// 5042 pri(26): !PUT LONG
case_PRI_26:;
// 5043 pri(27): !GET (%integername b)
case_PRI_27:;
// 5044 pri(30): !PUT BLOCK
case_PRI_30:;
// 5045 pri(31): !GET BLOCK
case_PRI_31:;
// 5046 stp = stp - 1; ! no result
STP = STP - 1;
// 5047 lrd (lhs, r0)
LRD(LHS, 1);
// 5048 lrd (rhs, r1) %if pn >= 30
if (PN < 30) goto L_0421;
LRD(RHS, 2);
L_0421:;
// 5049 hazard (reg) %for reg = r0, 1, r10
// %for REG = 1, 1, 11 %cycle
{
REG = 0;
L_0422:
if (REG == 11) goto L_0423;
REG += 1;
HAZARD(REG);
goto L_0422;
}
L_0423:;
// 5050 v_form = v in s; plant1 (jsb, v); drop (v)
V->FORM = 2;
PLANT1(15, V);
DROP(V);
// 5051 %return
return;
// 5052 pri(28): !GET WORD ()
case_PRI_28:;
// 5053 pri(29): !GET LONG ()
case_PRI_29:;
// 5054 hazard (reg) %for reg = r0, 1, r10
// %for REG = 1, 1, 11 %cycle
{
REG = 0;
L_0425:
if (REG == 11) goto L_0426;
REG += 1;
HAZARD(REG);
goto L_0425;
}
L_0426:;
// 5055 v_form = v in s; plant1 (jsb, v); drop (v)
V->FORM = 2;
PLANT1(15, V);
DROP(V);
// 5056 dstack (regv(r0)); claim (r0); ! The result
DSTACK(/*?*/ ®V[0]);
CLAIM(1);
// 5057 %return
return;
// 5058 pri(23): !printstring
case_PRI_23:;
// 5059 ! main point of this is to prevent loading
// 5060 ! parameter into work string..
// 5061 ! (pity if it's there already!)
// 5062 stp = stp - 1
STP = STP - 1;
// 5063 v_link == lhs; lhs_link == null
V->LINK = (struct STACKFM *)LHS;
LHS->LINK = (struct STACKFM *)NULL;
// 5064 %if lhs_type = strings %start
if (LHS->TYPE != 64) goto L_0427;
// 5065 ! Not already in work string - hurrah!
// 5066 address (lhs)
ADDRESS(LHS);
// 5067 test assigned (lhs)
TESTASSIGNED(LHS);
// 5068 amap (lhs); ! now integer (av in s)
AMAP(LHS);
// 5069 %finish
L_0427:;
// 5070 %finish
L_0410:;
// 5071
// 5072 n = 0
N = 0;
// 5073 t == v_link
T = (struct STACKFM *)V->LINK;
// 5074 %while t ## null %cycle
L_0428:;
if (_imp_ADDR((void *)(T)) == _imp_ADDR((void *)(NULL))) goto L_0429;
// 5075 p == t_link
P = (struct STACKFM *)T->LINK;
// 5076 push (t, n)
PUSH(T, /*?*/ &N);
// 5077 t == p
T = (struct STACKFM *)P;
// 5078 %repeat
goto L_0428;
L_0429:;
// 5079 %if v_type&(strings!records) # 0 %and
if (V->TYPE & (64 | 128) == 0) goto L_042A;
if (V->FORM & 15 != 1) goto L_042A;
// 5080+ v_form&15 = v in r %start; !stringfn
// 5081 %if v_type&strings # 0 %then p == work string %c
if (V->TYPE & 64 == 0) goto L_042B;
P = (struct STACKFM *)WORKSTRING();
goto L_042C;
L_042B:;
P = (struct STACKFM *)TEMP(VAR[V->FORMAT].LENGTH);
L_042C:;
// 5082+ %else p == temp(var(v_format)_length)
// 5083 p_type = integers
P->TYPE = 16;
// 5084 plant1 (pushal, p)
PLANT1(4136, P);
// 5085 p_type = strings!4; !already in a work string
P->TYPE = 64 | 4;
// 5086 p_type = records %if v_type = records
if (V->TYPE != 128) goto L_042D;
P->TYPE = 128;
L_042D:;
// 5087 p_format = v_format
P->FORMAT = V->FORMAT;
// 5088 v_type = 0; type = 0
V->TYPE = 0;
TYPE = 0;
// 5089 n = n + 1; !an extra hidden parameter
N = N + 1;
// 5090 %finish
L_042A:;
// 5091 hazard (reg) %for reg = r0, 1, r10
// %for REG = 1, 1, 11 %cycle
{
REG = 0;
L_042E:
if (REG == 11) goto L_042F;
REG += 1;
HAZARD(REG);
goto L_042E;
}
L_042F:;
// 5092 %if v_base # pc %start; !parameter
if (V->BASE == 16) goto L_0431;
// 5093 v_type = integers; v_form = v in s
V->TYPE = 16;
V->FORM = 2;
// 5094 plant2 (movl, v, regv(r1))
PLANT2(8968, V, /*?*/ ®V[1]);
// 5095 primep (proc enter)
PRIMEP(13);
// 5096 plant1 (calls,literal(n)); popdrop
PLANT1(7, LITERAL(N));
POPDROP();
// 5097 flush code
FLUSHCODE();
// 5098 put (obj prim ref); put (proc enter); ca=ca+5
PUT(24);
PUT(13);
CA = CA + 5;
// 5099 %else %if v_xno # 0
goto L_0432;
L_0431:;
if (V->XNO == 0) goto L_0433;
// 5100 ec = v
EC = *V;
// 5101 ec_form = v in s
EC.FORM = 2;
// 5102 plant2 (calls, literal(n), ec); popdrop
PLANT2(7, LITERAL(N), /*?*/ &EC);
POPDROP();
// 5103 %else
goto L_0432;
L_0433:;
// 5104 plant1 (calls, literal(n)); pop drop; !second operand set in p3
PLANT1(7, LITERAL(N));
POPDROP();
// 5105 flush code
FLUSHCODE();
// 5106 define reference (disp, dir pref)
DEFINEREFERENCE(DISP, 3);
// 5107 put (obj call); put long (disp)
PUT(11);
PUTLONG(DISP);
// 5108 ca = ca + 2; !assume short
CA = CA + 2;
// 5109 %finish
L_0432:;
// 5110 %if type # 0 %start; !There's a result
if (TYPE == 0) goto L_0434;
// 5111 v_type = type; v_form = form
V->TYPE = TYPE;
V->FORM = FORM;
// 5112 v_base = r0; v_disp = 0; v_xno = 0
V->BASE = 1;
V->DISP = 0;
V->XNO = 0;
// 5113 claim (r0); dstack (v)
CLAIM(1);
DSTACK(V);
// 5114 %finish
L_0434:;
// 5115 drop (v)
DROP(V);
// 5116 %end
return;
case_PRI_dispatch:
if (PRI_index < 1 || PRI_index > 31)
_imp_signalf(6, 3, PRI_index, "->PRI(%d) out of bounds at %s line %d", PRI_index, PRI_file, PRI_line);
goto *PRI[PRI_index - 1];
case_PRI_missing:
_imp_signalf(8, 2, PRI_index, "switch jump to undefined label PRI(%d): at %s line %d", PRI_index, PRI_file,
PRI_line);
} /* end of CALL */
// 5117
// 5118 !sundries
// 5119
// 5120 %routine SET LANGUAGE
void SETLANGUAGE(void) {
// 5121 %integer l
int L;
// 5122 l = getword; !ignore!!!
L = GETWORD();
// 5123 %end
return;
} /* end of SETLANGUAGE */
// 5124
// 5125 %routine SET DIAG
void SETDIAG(void) {
// 5126 %integer new diag = getword
int NEWDIAG;
NEWDIAG = GETWORD();
// 5127 diag = new diag&16_3FFF %if new diag&(3<<14) = 2<<14
if (NEWDIAG & 3 << 14 != 2 << 14) goto L_0435;
DIAG = NEWDIAG & 16383;
L_0435:;
// 5128 %end
return;
} /* end of SETDIAG */
// 5129
// 5130 %routine SET CONTROL
void SETCONTROL(void) {
// 5131 %integer new control
int NEWCONTROL;
// 5132 ! Don't allow %control to turn on things
// 5133 ! which were turned off by command line
// 5134 ! (except for record rounding).
// 5135 new control = get word
NEWCONTROL = GETWORD();
// 5136 control = new control & (original control!rec round)
CONTROL = NEWCONTROL & (ORIGINALCONTROL | 128);
// 5137 %end
return;
} /* end of SETCONTROL */
// 5138
// 5139 %routine LINE BOUND
void LINEBOUND(void) {
// 5140 ! Perform consistency checks and update line counter
// 5141 abort (23) %if stp # 0
if (STP == 0) goto L_0436;
ABORT(23);
L_0436:;
// 5142 abort (24) %unless using_link == null
if (_imp_ADDR((void *)(USING.LINK)) == _imp_ADDR((void *)(NULL))) goto L_0437;
ABORT(24);
L_0437:;
// 5143 abort (25) %if active regs # 0
if (ACTIVEREGS == 0) goto L_0438;
ABORT(25);
L_0438:;
// 5144 abort (39) %if index regs # 0
if (INDEXREGS == 0) goto L_0439;
ABORT(39);
L_0439:;
// 5145 flush code; current line = getword
FLUSHCODE();
CURRENTLINE = GETWORD();
// 5146 this area = 0; !return work strings
THISAREA = 0;
// 5147 line error = 0
LINEERROR = 0;
// 5148 %if diag # 0 %start
if (DIAG == 0) goto L_043A;
// 5149 newline
_imp_NEWLINE();
// 5150 print string ("Line "); write (current line, 0)
_imp_PRINTSTRING(_imp_str_literal("Line "));
_imp_WRITE(CURRENTLINE, 0);
// 5151 newline
_imp_NEWLINE();
// 5152 %finish
L_043A:;
// 5153 %end
return;
} /* end of LINEBOUND */
// 5154
// 5155 %routine EVENT BLOCK
void EVENTBLOCK(void) {
// 5156 %record(stack fm) %name savesp
struct STACKFM *SAVESP;
// 5157 events = getword; get (discard)
EVENTS = GETWORD();
GET(/*?*/ &DISCARD);
// 5158 evlow = getword; !finish label
EVLOW = GETWORD();
// 5159 evno = evno + 1
EVNO = EVNO + 1;
// 5160 savesp == temp(4); stp = stp - 1
SAVESP = (struct STACKFM *)TEMP(4);
STP = STP - 1;
// 5161 plant2 (movl, regv(sp), savesp); !preserve stack
PLANT2(8968, /*?*/ ®V[14], SAVESP);
// 5162 jump to (evlow, jump, 1); evlow = last ref
JUMPTO(EVLOW, 0, 1);
EVLOW = LASTREF;
// 5163 evep = new tag; define tag (evep)
EVEP = NEWTAG();
DEFINETAG(EVEP);
// 5164 uncond jump = 0
UNCONDJUMP = 0;
// 5165 plant2 (movl, savesp, regv(sp))
PLANT2(8968, SAVESP, /*?*/ ®V[14]);
// 5166 drop (savesp)
DROP(SAVESP);
// 5167 %end
return;
} /* end of EVENTBLOCK */
// 5168
// 5169 %routine GENERATE SIGNAL
void GENERATESIGNAL(void) {
// 5170 cstack (0) %while stp < 2
L_043B:;
if (STP >= 2) goto L_043C;
CSTACK(0);
goto L_043B;
L_043C:;
// 5171 cstack (getword)
CSTACK(GETWORD());
// 5172 pop lhs; load (lhs, r0); drop (lhs)
POPLHS();
LOAD(LHS, 1);
DROP(LHS);
// 5173 pop lhs; load (lhs, r2); drop (lhs)
POPLHS();
LOAD(LHS, 3);
DROP(LHS);
// 5174 pop lhs; load (lhs, r1); drop (lhs)
POPLHS();
LOAD(LHS, 2);
DROP(LHS);
// 5175 release (r0); release (r1); release (r2)
RELEASE(1);
RELEASE(2);
RELEASE(3);
// 5176 prim (signal)
PRIM(16);
// 5177 uncond jump = ca
UNCONDJUMP = CA;
// 5178 %end
return;
} /* end of GENERATESIGNAL */
// 5179
// 5180 %routine SET BOUNDS
void SETBOUNDS(void) {
// 5181 set both
SETBOTH();
// 5182 vlb = lhs_disp; vub = rhs_disp
VLB = LHS->DISP;
VUB = RHS->DISP;
// 5183 pop drop; pop drop
POPDROP();
POPDROP();
// 5184 %end
return;
} /* end of SETBOUNDS */
// 5185
// 5186 %routine DECLARE ARRAY
void DECLAREARRAY(void) {
// 5187 %record(stackfm) d
struct STACKFM D;
// 5188 %integer dim, arrays, sp, j, hdisp, dv
int DIM;
int ARRAYS;
int SP;
int J;
int HDISP;
int DV;
// 5189 dim = getword; get (discard)
DIM = GETWORD();
GET(/*?*/ &DISCARD);
// 5190 arrays = getword; !how many
ARRAYS = GETWORD();
// 5191 %if gmode # 0 %start
if (GMODE == 0) goto L_043D;
// 5192 parms = parms + arrays
PARMS = PARMS + ARRAYS;
// 5193 set both
SETBOTH();
// 5194 vlb = lhs_disp; vub = rhs_disp
VLB = LHS->DISP;
VUB = RHS->DISP;
// 5195 abort (22) %if vlb > vub+1
if (VLB <= VUB + 1) goto L_043E;
ABORT(22);
L_043E:;
// 5196 set dope vector (dv)
SETDOPEVECTOR(/*?*/ &DV);
// 5197 stp = stp - 2
STP = STP - 2;
// 5198 drop (rhs); drop (lhs)
DROP(RHS);
DROP(LHS);
// 5199 %else
goto L_043F;
L_043D:;
// 5200 names = names - arrays
NAMES = NAMES - ARRAYS;
// 5201 set both
SETBOTH();
// 5202 %if dim = 1 %and const (lhs) %and const (rhs) %and
if (DIM != 1) goto L_0440;
if (!(CONST(LHS))) goto L_0440;
if (!(CONST(RHS))) goto L_0440;
if (RHS->DISP + 1 < LHS->DISP) goto L_0440;
// 5203+ rhs_disp+1 >= lhs_disp %start
// 5204 !can alocate in-line - trap array-inside-out at run time..??
// 5205 vlb = lhs_disp; vub = rhs_disp
VLB = LHS->DISP;
VUB = RHS->DISP;
// 5206 stp = stp - 2; !unstack them
STP = STP - 2;
// 5207 drop (rhs); drop (lhs)
DROP(RHS);
DROP(LHS);
// 5208 frame = (frame-arrays*8)&(\3)
FRAME = FRAME - ARRAYS * 8 & (~3);
// 5209 hdisp = frame
HDISP = FRAME;
// 5210 dim = 0; !for a marker
DIM = 0;
// 5211 set dope vector (dv)
SETDOPEVECTOR(/*?*/ &DV);
// 5212 zeroth_base = local
ZEROTH.BASE = LOCAL;
// 5213 dope_disp = dv
DOPE.DISP = DV;
// 5214 head_base = local; head_disp = hdisp
HEAD.BASE = LOCAL;
HEAD.DISP = HDISP;
// 5215 %else
goto L_0441;
L_0440:;
// 5216 frame = (frame-dim*12)&(\3)-4
FRAME = (FRAME - DIM * 12 & (~3)) - 4;
// 5217 lstack (frame)
LSTACK(FRAME);
// 5218 pop lhs
POPLHS();
// 5219 d = regv(r4); hazard (r4)
D = REGV[4];
HAZARD(5);
// 5220 plant2 (moval, lhs, d)
PLANT2(4112, LHS, /*?*/ &D);
// 5221 drop (lhs)
DROP(LHS);
// 5222 d_form = v in s; d_disp = 4-12
D.FORM = 2;
D.DISP = 4 - 12;
// 5223 %for sp = 2, 2, dim<<1 %cycle
// %for SP = 2, 2, DIM << 1 %cycle
{
int _final = DIM << 1;
if (invalid_for_loop(2, 2, _final)) _imp_signal(5, 1, 0, "Illegal cycle SP = 2, 2, DIM << 1");
SP = 0;
L_0442:
if (SP == _final) goto L_0443;
SP += 2;
// 5224 lhs == stacked(sp-1)
LHS = (struct STACKFM *)STACKED[SP - 1 - 1];
// 5225 rhs == stacked(sp)
RHS = (struct STACKFM *)STACKED[SP - 1];
// 5226 claim (r4)
CLAIM(5);
// 5227 lrd (lhs, r1); lrd (rhs, r2)
LRD(LHS, 2);
LRD(RHS, 3);
// 5228 d_disp = d_disp+12
D.DISP = D.DISP + 12;
// 5229 plant2 (movq, regv(r1), d)
PLANT2(13, /*?*/ ®V[1], /*?*/ &D);
// 5230 %repeat
goto L_0442;
}
L_0443:;
// 5231 prim (set dv)
PRIM(1);
// 5232 word (dim); word (data size)
WORD(DIM);
WORD(DATASIZE);
// 5233 stp = 0
STP = 0;
// 5234 frame = frame-arrays*8; hdisp = frame
FRAME = FRAME - ARRAYS * 8;
HDISP = FRAME;
// 5235 lstack (frame); pop lhs
LSTACK(FRAME);
POPLHS();
// 5236 plant2 (moval, lhs, regv(r3))
PLANT2(4112, LHS, /*?*/ ®V[3]);
// 5237 drop (lhs)
DROP(LHS);
// 5238 %finish
L_0441:;
// 5239 %finish
L_043F:;
// 5240 %for j = 1, 1, arrays %cycle
// %for J = 1, 1, ARRAYS %cycle
{
int _final = ARRAYS;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, ARRAYS");
J = 0;
L_0445:
if (J == _final) goto L_0446;
J += 1;
// 5241 %if gmode # 0 %start
if (GMODE == 0) goto L_0447;
// 5242 parms = parms - 1; decvar == var(parms)
PARMS = PARMS - 1;
DECVAR = (struct VARFM *)/*?*/ &VAR[PARMS];
// 5243 decvar_disp = frame; decvar_zeroad = frame-vlb
DECVAR->DISP = FRAME;
DECVAR->ZEROAD = FRAME - VLB;
// 5244 decvar_header = ga; decvar_base = 0
DECVAR->HEADER = GA;
DECVAR->BASE = 0;
// 5245 glongword (-vlb); glongword (0)
GLONGWORD(-VLB);
GLONGWORD(0);
// 5246 flush gla
FLUSHGLA();
// 5247 put (obj reloc); put long (ga-4); put long (dv)
PUT(8);
PUTLONG(GA - 4);
PUTLONG(DV);
// 5248 frame = frame + vub*data size; !now the total size
FRAME = FRAME + VUB * DATASIZE;
// 5249 %else
goto L_0448;
L_0447:;
// 5250 names = names + 1; decvar == var(names)
NAMES = NAMES + 1;
DECVAR = (struct VARFM *)/*?*/ &VAR[NAMES];
// 5251 decvar_base = local; decvar_header = -1
DECVAR->BASE = LOCAL;
DECVAR->HEADER = -1;
// 5252 decvar_disp = hdisp; hdisp = hdisp+8
DECVAR->DISP = HDISP;
HDISP = HDISP + 8;
// 5253 %if dim = 0 %start; !in-line
if (DIM != 0) goto L_0449;
// 5254 frame = (frame-vub*data size)&(\7)
FRAME = FRAME - VUB * DATASIZE & (~7);
// 5255 zeroth_disp = frame-vlb
ZEROTH.DISP = FRAME - VLB;
// 5256 decvar_zeroad = frame-vlb; ! zero address for fast access
DECVAR->ZEROAD = FRAME - VLB;
// 5257 decvar_header = -2; ! marker for above detail
DECVAR->HEADER = -2;
// 5258 plant2 (moval, zeroth, head); head_disp = head_disp+4
PLANT2(4112, /*?*/ &ZEROTH, /*?*/ &HEAD);
HEAD.DISP = HEAD.DISP + 4;
// 5259 plant2 (moval, dope, head); head_disp = head_disp+4
PLANT2(4112, /*?*/ &DOPE, /*?*/ &HEAD);
HEAD.DISP = HEAD.DISP + 4;
// 5260 %else
goto L_044A;
L_0449:;
// 5261 prim (adec); !bumps r3 note
PRIM(2);
// 5262 %finish
L_044A:;
// 5263 %finish
L_0448:;
// 5264 %repeat
goto L_0445;
}
L_0446:;
// 5265 %end
return;
} /* end of DECLAREARRAY */
// 5266
// 5267 %routine RESOLVE
void RESOLVE(void) {
// 5268 !compile a string resolution
// 5269 ! S -> A.(B).C
// 5270 %record(stackfm) %name s, a, b, c
struct STACKFM *S;
struct STACKFM *A;
struct STACKFM *B;
struct STACKFM *C;
// 5271 %integer flag, sc, bc, acf
int FLAG;
int SC;
int BC;
int ACF;
// 5272
// 5273 %routine TEST ASSIGNED (%integer base)
void TESTASSIGNED(int BASE) {
// 5274 put code (opcode(cmpw&255)); ! cmpw
PUTCODE(OPCODE[241 & 255]);
// 5275 put number byte (16_60+base-1); ! (base)
PUTNUMBERBYTE(96 + BASE - 1);
// 5276 put number byte (16_60+gla-1); ! (gla)
PUTNUMBERBYTE(96 + 12 - 1);
// 5277 prim (test ass)
PRIM(3);
// 5278 %end
return;
} /* end of TESTASSIGNED */
// 5279
// 5280 acf = control&ass check; ! assignment checking ?
ACF = CONTROL & 1;
// 5281 flag = getword; !<cond><a present><c present>
FLAG = GETWORD();
// 5282 cstack (0) %if flag&1 = 0; !c missing
if (FLAG & 1 != 0) goto L_044B;
CSTACK(0);
L_044B:;
// 5283 pop lhs; c == lhs
POPLHS();
C = (struct STACKFM *)LHS;
// 5284 pop lhs; b == lhs; bc = b_format
POPLHS();
B = (struct STACKFM *)LHS;
BC = B->FORMAT;
// 5285 cstack (0) %if flag&2 = 0; !a missing
if (FLAG & 2 != 0) goto L_044C;
CSTACK(0);
L_044C:;
// 5286 pop lhs; a == lhs
POPLHS();
A = (struct STACKFM *)LHS;
// 5287 pop lhs; s == lhs; sc = s_format
POPLHS();
S = (struct STACKFM *)LHS;
SC = S->FORMAT;
// 5288 lrd (a, r0)
LRD(A, 1);
// 5289 lrd (c, r1)
LRD(C, 2);
// 5290 lrd (b, r3); test assigned (r3) %if bc = 0 # acf
LRD(B, 4);
{
// Double-sided test on 0 (Part I)
int tmp;
if (BC != (tmp = 0)) goto L_044D;
// Double-sided test on 0 (Part II)
if (tmp == ACF) goto L_044D;
}
TESTASSIGNED(4);
L_044D:;
// 5291 lrd (s, r4); test assigned (r4) %if sc = 0 # acf
LRD(S, 5);
{
// Double-sided test on 0 (Part I)
int tmp;
if (SC != (tmp = 0)) goto L_044E;
// Double-sided test on 0 (Part II)
if (tmp == ACF) goto L_044E;
}
TESTASSIGNED(5);
L_044E:;
// 5292 prim (resolution)
PRIM(26);
// 5293 prim (check resolution) %if flag&4 = 0
if (FLAG & 4 != 0) goto L_044F;
PRIM(6);
L_044F:;
// 5294 %end
return;
} /* end of RESOLVE */
// 5295
// 5296 %routine ADUMP (%integer times)
void ADUMP(int TIMES) {
// 5297 %integer j
int J;
// 5298 %for j = times-1, -1, 0 %cycle
// %for J = TIMES - 1, -1, 0 %cycle
{
int _initial = TIMES - 1;
if (invalid_for_loop(_initial, -1, 0)) _imp_signal(5, 1, 0, "Illegal cycle J = TIMES - 1, -1, 0");
J = _initial - (-1);
L_0450:
if (J == 0) goto L_0451;
J -= 1;
// 5299 %if owntype = integers %start
if (OWNTYPE != 16) goto L_0452;
// 5300 glongword (ownval)
GLONGWORD(OWNVAL);
// 5301 %else %if owntype = byte+integers
goto L_0453;
L_0452:;
if (OWNTYPE != 2 + 16) goto L_0454;
// 5302 gbyte (ownval)
GBYTE(OWNVAL);
// 5303 %else %if owntype = short+integers
goto L_0453;
L_0454:;
if (OWNTYPE != 1 + 16) goto L_0455;
// 5304 gword (ownval)
GWORD(OWNVAL);
// 5305 %else %if owntype = strings
goto L_0453;
L_0455:;
if (OWNTYPE != 64) goto L_0456;
// 5306 dump string (data size)
DUMPSTRING(DATASIZE);
// 5307 %else %if owntype&real bit # 0
goto L_0453;
L_0456:;
if (OWNTYPE & 32 == 0) goto L_0457;
// 5308 glongword (ownval)
GLONGWORD(OWNVAL);
// 5309 glongword (mantissa) %if owntype = reall
if (OWNTYPE != 36) goto L_0458;
GLONGWORD(MANTISSA);
L_0458:;
// 5310 %else
goto L_0453;
L_0457:;
// 5311 init gla (data size, 1, 0)
INITGLA(DATASIZE, 1, 0);
// 5312 %finish
L_0453:;
// 5313 %repeat
goto L_0450;
}
L_0451:;
// 5314 %end
return;
} /* end of ADUMP */
// 5315
// 5316 %routine INITIALISE OWNS
void INITIALISEOWNS(void) {
// 5317 %integer aparm = getlong
int APARM;
APARM = GETLONG();
// 5318 %if stp # 0 %start
if (STP == 0) goto L_0459;
// 5319 pop lhs
POPLHS();
// 5320 ownval = lhs_disp; mantissa = lhs_mantissa
OWNVAL = LHS->DISP;
MANTISSA = LHS->MANTISSA;
// 5321 drop (lhs)
DROP(LHS);
// 5322 %if owntype&real bit # 0 %and
if (OWNTYPE & 32 == 0) goto L_045A;
if (LHS->TYPE & 32 != 0) goto L_045A;
// 5323+ lhs_type&real bit = 0 %start
// 5324 longreal(addr(ownval)) = ownval
*_imp_LONGREAL(_imp_ADDR(/*?*/ &OWNVAL)) = OWNVAL;
// 5325 %finish
L_045A:;
// 5326 %else
goto L_045B;
L_0459:;
// 5327 ownval = 0; mantissa = 0; text = ""
OWNVAL = 0;
MANTISSA = 0;
_imp_strncpy(/*?*/ &TEXT, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 255);
// 5328 %finish
L_045B:;
// 5329 %if ownform&array bit # 0 %start
if (OWNFORM & 32 == 0) goto L_045C;
// 5330 %if (owntype#strings %or text = "") %and
if (OWNTYPE != 64) goto L_0424;
if (_imp_strcmp((_imp_string *)/*?*/ &TEXT, (_imp_string *)/*?*/ _imp_str_literal_ptr("")) != 0) goto L_045D;
L_0424:;
if (OWNTYPE & 32 != 0) goto L_045D;
// 5331+ owntype&realbit = 0 %start
// 5332 %if owntype & integers # 0 %start
if (OWNTYPE & 16 == 0) goto L_045E;
// 5333 init gla (aparm, datasize, ownval)
INITGLA(APARM, DATASIZE, OWNVAL);
// 5334 %else
goto L_045F;
L_045E:;
// 5335 init gla (aparm*datasize, 1, 0)
INITGLA(APARM * DATASIZE, 1, 0);
// 5336 %finish
L_045F:;
// 5337 %else
goto L_0460;
L_045D:;
// 5338 adump (aparm)
ADUMP(APARM);
// 5339 %finish
L_0460:;
// 5340 %else %if otype = 0; !const
goto L_0461;
L_045C:;
if (OTYPE != 0) goto L_0462;
// 5341 decvar_disp = ownval; decvar_base = 0
DECVAR->DISP = OWNVAL;
DECVAR->BASE = 0;
// 5342 decvar_form = decvar_form-2
DECVAR->FORM = DECVAR->FORM - 2;
// 5343 %else
goto L_0461;
L_0462:;
// 5344 gfix (3)
GFIX(3);
// 5345 lput (objddef, ga) %if otype >= 3
if (OTYPE < 3) goto L_0463;
LPUT(6, GA);
L_0463:;
// 5346 decvar_base = gla; decvar_disp = ga
DECVAR->BASE = 12;
DECVAR->DISP = GA;
// 5347 adump (1)
ADUMP(1);
// 5348 dump diag (1) %if otype # 2
if (OTYPE == 2) goto L_0464;
DUMPDIAG(1);
L_0464:;
// 5349 %finish
L_0461:;
// 5350 %end
return;
} /* end of INITIALISEOWNS */
// 5351
// 5352 %routine ZERO OWN
void ZEROOWN(void) {
// 5353 init gla (vub*datasize, 1, 0)
INITGLA(VUB * DATASIZE, 1, 0);
// 5354 %end
return;
} /* end of ZEROOWN */
// 5355
// 5356
// 5357 !======================= main loop =======================
// 5358
// 5359 NEXT:
U_1009:;
// 5360 get (sym) %until sym # nl %and sym # ' '
L_0465:;
GET(/*?*/ &SYM);
if (SYM == 10) goto L_0430;
if (SYM != 32) goto L_0466;
L_0430:;
goto L_0465;
L_0466:;
// 5361 code = sym
CODE = SYM;
// 5362 abort (21) %unless ' ' < sym <= 127
{
// Double-sided test on SYM (Part I)
int tmp;
if (32 >= (tmp = SYM)) goto L_0467;
// Double-sided test on SYM (Part II)
if (tmp <= 127) goto L_0468;
}
L_0467:;
ABORT(21);
L_0468:;
// 5363 %if diag & 2048 # 0 %and sym # 'O' %start
if (DIAG & 2048 == 0) goto L_0469;
if (SYM == 79) goto L_0469;
// 5364 print string ("Sym='"); print symbol (sym)
_imp_PRINTSTRING(_imp_str_literal("Sym='"));
_imp_PRINTSYMBOL(SYM);
// 5365 print symbol (''''); newline
_imp_PRINTSYMBOL(39);
_imp_NEWLINE();
// 5366 %finish
L_0469:;
// 5367 -> c(code)
C_line = __LINE__;
C_file = __FILE__;
C_index = CODE;
goto case_C_dispatch;
// 5368 c(*): abort (21); !illegal code item
case_C_default:;
ABORT(21);
// 5369
// 5370 c('k'):code = 1; -> testit
case_C_107:;
CODE = 1;
goto U_100A;
// 5371 c('t'):code = 6; -> testit
case_C_116:;
CODE = 6;
goto U_100A;
// 5372 c('='):code = 1; -> jmp
case_C_61:;
CODE = 1;
goto U_100B;
// 5373 c('<'):code = 2; -> jmp
case_C_60:;
CODE = 2;
goto U_100B;
// 5374 c('('):code = 3; -> jmp
case_C_40:;
CODE = 3;
goto U_100B;
// 5375 c('>'):code = 4; -> jmp
case_C_62:;
CODE = 4;
goto U_100B;
// 5376 c(')'):code = 5; -> jmp
case_C_41:;
CODE = 5;
goto U_100B;
// 5377 c('#'):code = 6; -> jmp
case_C_35:;
CODE = 6;
goto U_100B;
// 5378 testit:
U_100A:;
// 5379 plant2 (bitl, literal(1), regv(r0))
PLANT2(49320, LITERAL(1), /*?*/ ®V[0]);
// 5380 pop drop
POPDROP();
// 5381 jmp:
U_100B:;
// 5382 jump to (getword, code+unsigned+invert, 1)
JUMPTO(GETWORD(), CODE + UNSIGNED + INVERT, 1);
// 5383 -> next
goto U_1009;
// 5384
// 5385 c(']'): operate (neg); !rsh
case_C_93:;
OPERATE(8);
// 5386 operate (rsh); -> next
OPERATE(16);
goto U_1009;
// 5387 c('['): operate (lsh); -> next
case_C_91:;
OPERATE(15);
goto U_1009;
// 5388 c('\'): operate (not); -> next
case_C_92:;
OPERATE(7);
goto U_1009;
// 5389 c('U'): operate (neg); -> next
case_C_85:;
OPERATE(8);
goto U_1009;
// 5390 c('+'): operate (add); -> next
case_C_43:;
OPERATE(9);
goto U_1009;
// 5391 c('-'): operate (sub); -> next
case_C_45:;
OPERATE(10);
goto U_1009;
// 5392 c('!'): operate (or); -> next
case_C_33:;
OPERATE(13);
goto U_1009;
// 5393 c('%'): operate (xor); -> next
case_C_37:;
OPERATE(14);
goto U_1009;
// 5394 c('/'): operate (div); -> next
case_C_47:;
OPERATE(17);
goto U_1009;
// 5395 c('X'): operate (exp); -> next
case_C_88:;
OPERATE(21);
goto U_1009;
// 5396 c('x'): operate (rexp); -> next
case_C_120:;
OPERATE(22);
goto U_1009;
// 5397 c('Q'): operate (rdiv); -> next
case_C_81:;
OPERATE(23);
goto U_1009;
// 5398 c('*'): operate (mul); -> next
case_C_42:;
OPERATE(27);
goto U_1009;
// 5399 c('&'): operate (not);
case_C_38:;
OPERATE(7);
// 5400 operate (bic); ->next
OPERATE(12);
goto U_1009;
// 5401 c(117): ! ++
case_C_117:;
// 5402 c(113): address op (code); -> next; ! --
case_C_113:;
ADDRESSOP(CODE);
goto U_1009;
// 5403 c('.'): concatenate; -> next
case_C_46:;
CONCATENATE();
goto U_1009;
// 5404 c('v'): set modulus; -> next
case_C_118:;
SETMODULUS();
goto U_1009;
// 5405
// 5406 c('B'): code = 0; -> bjf
case_C_66:;
CODE = 0;
goto U_100C;
// 5407 c('F'): code = 1
case_C_70:;
CODE = 1;
// 5408 bjf:
U_100C:;
// 5409 flush code; set line
FLUSHCODE();
SETLINE();
// 5410 jump to (getword, jump, code)
JUMPTO(GETWORD(), 0, CODE);
// 5411 -> next
goto U_1009;
// 5412
// 5413 c('J'):
case_C_74:;
// 5414 flush code; set line
FLUSHCODE();
SETLINE();
// 5415 jump to (-getword, jump, 0)
JUMPTO(-GETWORD(), 0, 0);
// 5416 -> next
goto U_1009;
// 5417
// 5418 c(':'):
case_C_58:;
// 5419 define label (getword)
DEFINELABEL(GETWORD());
// 5420 -> next
goto U_1009;
// 5421
// 5422 c('L'):
case_C_76:;
// 5423 n = getword
N = GETWORD();
// 5424 names = n %if n > names
if (N <= NAMES) goto L_046B;
NAMES = N;
L_046B:;
// 5425 define label (-n);
DEFINELABEL(-N);
// 5426 -> next
goto U_1009;
// 5427
// 5428 c('T'):
case_C_84:;
// 5429 cstack (-1); -> res
CSTACK(-1);
goto U_100D;
// 5430 c('K'):
case_C_75:;
// 5431 cstack (0)
CSTACK(0);
// 5432 c('M'):
case_C_77:;
// 5433 c('V'):
case_C_86:;
// 5434 res:
U_100D:;
// 5435 pop lhs
POPLHS();
// 5436 set result (lhs, code)
SETRESULT(LHS, CODE);
// 5437 ! and...
// 5438 c('R'):
case_C_82:;
// 5439 set status %if mainprog = mainrt %and code ='R'
if (MAINPROG != 1) goto L_046C;
if (CODE != 82) goto L_046C;
SETSTATUS();
L_046C:;
// 5440 return
RETURN();
// 5441 -> next
goto U_1009;
// 5442
// 5443 c('j'): assign (2); -> next
case_C_106:;
ASSIGN(2);
goto U_1009;
// 5444 c('S'): assign (1); -> next
case_C_83:;
ASSIGN(1);
goto U_1009;
// 5445 c('Z'): assign (0); -> next
case_C_90:;
ASSIGN(0);
goto U_1009;
// 5446 c('p'): assign (-1); -> next
case_C_112:;
ASSIGN(-1);
goto U_1009;
// 5447
// 5448 c('G'): get string (alias); -> next
case_C_71:;
GETSTRING((_imp_string255 *)/*p*/ /*?*/ &ALIAS);
goto U_1009;
// 5449 c('$'): define var; -> next
case_C_36:;
DEFINEVAR();
goto U_1009;
// 5450 c('N'): cstack (getlong); -> next
case_C_78:;
CSTACK(GETLONG());
goto U_1009;
// 5451 c(''''):get string (text); -> next
case_C_39:;
GETSTRING((_imp_string255 *)/*p*/ /*?*/ &TEXT);
goto U_1009;
// 5452 c('D'): get real; -> next
case_C_68:;
GETREAL();
goto U_1009;
// 5453
// 5454 c('n'): record select; -> next
case_C_110:;
RECORDSELECT();
goto U_1009;
// 5455
// 5456 c('a'): array ref (0); -> next
case_C_97:;
ARRAYREF(0);
goto U_1009;
// 5457 c('i'): array ref (1); -> next
case_C_105:;
ARRAYREF(1);
goto U_1009;
// 5458 c('d'): declare array; -> next
case_C_100:;
DECLAREARRAY();
goto U_1009;
// 5459
// 5460 c('O'): line bound; -> next
case_C_79:;
LINEBOUND();
goto U_1009;
// 5461
// 5462
// 5463 c('@'):
case_C_64:;
// 5464 v == var(getword)
V = (struct VARFM *)/*?*/ &VAR[GETWORD()];
// 5465 spec external (v) %if v_base = pending
if (V->BASE != 22) goto L_046D;
SPECEXTERNAL(V);
L_046D:;
// 5466 vstack (v)
VSTACK(V);
// 5467 -> next
goto U_1009;
// 5468
// 5469 c('~'):
case_C_126:;
// 5470 get (sym)
GET(/*?*/ &SYM);
// 5471 %if sym = 'A' %start
if (SYM != 65) goto L_046E;
// 5472 decvar == gvar
DECVAR = (struct VARFM *)GVAR;
// 5473 assemble (-2, labs, names)
ASSEMBLE(-2, LABS, NAMES);
// 5474 -> next
goto U_1009;
// 5475 %finish
L_046E:;
// 5476 %if sym = 'B' %start
if (SYM != 66) goto L_046F;
// 5477 -> out
goto U_100E;
// 5478 %finish
L_046F:;
// 5479 abort (36) %unless sym = 'C'
if (SYM == 67) goto L_0470;
ABORT(36);
L_0470:;
// 5480 maxframe = frame %if frame > maxframe
if (FRAME <= MAXFRAME) goto L_0471;
MAXFRAME = FRAME;
L_0471:;
// 5481 frame = frame base
FRAME = FRAMEBASE;
// 5482 -> next
goto U_1009;
// 5483
// 5484 c('E'): pop lhs; call (lhs); -> next
case_C_69:;
POPLHS();
CALL(LHS);
goto U_1009;
// 5485
// 5486 c('C'):
case_C_67:;
// 5487 set both
SETBOTH();
// 5488 %if lhs_form&(arrayname bit!arraybit) # 0 %start
if (LHS->FORM & (64 | 32) == 0) goto L_0472;
// 5489 compare arraynames (lhs, rhs)
COMPAREARRAYNAMES(LHS, RHS);
// 5490 pop drop; pop drop
POPDROP();
POPDROP();
// 5491 -> next
goto U_1009;
// 5492 %finish
L_0472:;
// 5493 amap (lhs); amap (rhs)
AMAP(LHS);
AMAP(RHS);
// 5494
// 5495 c('?'):
case_C_63:;
// 5496 set both
SETBOTH();
// 5497 compare (lhs, rhs, 1)
COMPARE(LHS, RHS, 1);
// 5498 pop drop; pop drop
POPDROP();
POPDROP();
// 5499 -> next
goto U_1009;
// 5500
// 5501 c('"'):
case_C_34:;
// 5502 set both; invert = 16
SETBOTH();
INVERT = 16;
// 5503 load (rhs, any) %if rhs_flags&indexed # 0
if (RHS->FLAGS & 1 == 0) goto L_0473;
LOAD(RHS, 17);
L_0473:;
// 5504 compare (rhs, lhs, 0)
COMPARE(RHS, LHS, 0);
// 5505 stp = stp - 1; lhs = rhs; drop (rhs)
STP = STP - 1;
*LHS = *RHS;
DROP(RHS);
// 5506 claim (lhs_base)
CLAIM(LHS->BASE);
// 5507 -> next
goto U_1009;
// 5508
// 5509 c('c'): set cc; -> next
case_C_99:;
SETCC();
goto U_1009;
// 5510 c('f'): for; -> next
case_C_102:;
FOR();
goto U_1009;
// 5511 c('l'): set language; -> next
case_C_108:;
SETLANGUAGE();
goto U_1009;
// 5512 c('r'): resolve; -> next
case_C_114:;
RESOLVE();
goto U_1009;
// 5513 c('A'): initialise owns; -> next
case_C_65:;
INITIALISEOWNS();
goto U_1009;
// 5514 c('I'): zero own; -> next
case_C_73:;
ZEROOWN();
goto U_1009;
// 5515 c('b'): set bounds; -> next
case_C_98:;
SETBOUNDS();
goto U_1009;
// 5516 c('y'): set diag; -> next
case_C_121:;
SETDIAG();
goto U_1009;
// 5517 c('z'): set control; -> next
case_C_122:;
SETCONTROL();
goto U_1009;
// 5518 c('W'): switch jump; -> next
case_C_87:;
SWITCHJUMP();
goto U_1009;
// 5519 c('_'): define switch label; -> next
case_C_95:;
DEFINESWITCHLABEL();
goto U_1009;
// 5520 c('o'): event block; -> next
case_C_111:;
EVENTBLOCK();
goto U_1009;
// 5521 c('e'): generate signal; -> next
case_C_101:;
GENERATESIGNAL();
goto U_1009;
// 5522 c('w'): machine code; -> next
case_C_119:;
MACHINECODE();
goto U_1009;
// 5523 c('P'): plant; -> next
case_C_80:;
PLANT();
goto U_1009;
// 5524 c('m'): prim (monit); -> next
case_C_109:;
PRIM(12);
goto U_1009;
// 5525 c('s'): prim (stop); uncond jump = ca; -> next
case_C_115:;
PRIM(8);
UNCONDJUMP = CA;
goto U_1009;
// 5526
// 5527 c('{'): gmode = -1
case_C_123:;
GMODE = -1;
// 5528 assemble (gtype, labs, names)
ASSEMBLE(GTYPE, LABS, NAMES);
// 5529 -> next
goto U_1009;
// 5530
// 5531 c('}'):
case_C_125:;
// 5532 gmode = 0
GMODE = 0;
// 5533 -> out %if amode < 0
if (AMODE >= 0) goto L_0474;
goto U_100E;
L_0474:;
// 5534 define parameters %if names > gstart
if (NAMES <= GSTART) goto L_0475;
DEFINEPARAMETERS();
L_0475:;
// 5535 -> out %if amode # 0; !spec
if (AMODE == 0) goto L_0476;
goto U_100E;
L_0476:;
// 5536 frame = 0
FRAME = 0;
// 5537 -> next
goto U_1009;
// 5538
// 5539 c('H'):
case_C_72:;
// 5540 decvar == begin; decvar_disp = new tag
DECVAR = (struct VARFM *)/*?*/ &BEGIN;
DECVAR->DISP = NEWTAG();
// 5541 otype = 0; spec = 0; potype = 3
OTYPE = 0;
SPEC = 0;
POTYPE = 3;
// 5542 %if level # 0 %start; !not initial begin
if (LEVEL == 0) goto L_0477;
// 5543 cstack (decvar_disp)
CSTACK(DECVAR->DISP);
// 5544 pop lhs; lhs_base = pc; lhs_type = 0
POPLHS();
LHS->BASE = 16;
LHS->TYPE = 0;
// 5545 lhs_header = -1; call (lhs)
LHS->HEADER = -1;
CALL(LHS);
// 5546 potype = 0
POTYPE = 0;
// 5547 %finish
L_0477:;
// 5548 var name = "$GO$"; external name = var name
_imp_strncpy(/*?*/ &VARNAME, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("$GO$");
(void *)&tmp;
}),
/*max:*/ 31);
_imp_strncpy(/*?*/ &EXTERNALNAME, ({
__typeof__(_imp_string31) tmp; /*B*/
tmp = VARNAME;
(void *)&tmp;
}),
/*max:*/ 31);
// 5549 assemble (0, labs, names)
ASSEMBLE(0, LABS, NAMES);
// 5550 -> next
goto U_1009;
// 5551
// 5552 c(';'):
case_C_59:;
// 5553 %if level # 0 %start
if (LEVEL == 0) goto L_0478;
// 5554 set status %if mainprog = mainrt
if (MAINPROG != 1) goto L_0479;
SETSTATUS();
L_0479:;
// 5555 return
RETURN();
// 5556 %finish
L_0478:;
// 5557 gfix (3)
GFIX(3);
// 5558 define tag (block end tag) %if block end tag # 0
if (BLOCKENDTAG == 0) goto L_047A;
DEFINETAG(BLOCKENDTAG);
L_047A:;
// 5559 flush code
FLUSHCODE();
// 5560 flush gla
FLUSHGLA();
// 5561
// 5562 OUT:
U_100E:;
// 5563
// 5564 %if amode = 0 %start
if (AMODE != 0) goto L_047B;
// 5565 activity(local) = 0; !release the base reg
ACTIVITY[LOCAL] = 0;
// 5566 level = level - 1; local = base reg(level)
LEVEL = LEVEL - 1;
LOCAL = BASEREG[LEVEL + 1];
// 5567 activity(local) = -1
ACTIVITY[LOCAL] = -1;
// 5568 frame = frame&(\7)
FRAME = FRAME & (~7);
// 5569 %if level >= 0 %start
if (LEVEL < 0) goto L_047C;
// 5570 select output tank (directives)
SELECTOUTPUTTANK(DIRECTIVES);
// 5571 local diags = local diags+1
LOCALDIAGS = LOCALDIAGS + 1;
// 5572 put (dir end); put long (proctype); put word (entry mask)
PUT(6);
PUTLONG(PROCTYPE);
PUTWORD(ENTRYMASK);
// 5573 put word (frame); put word (frame>>16)
PUTWORD(FRAME);
PUTWORD((unsigned int)FRAME >> 16);
// 5574 put word (local diags); put word (diag lines)
PUTWORD(LOCALDIAGS);
PUTWORD(DIAGLINES);
// 5575 put word (block tag); put long (ca)
PUTWORD(BLOCKTAG);
PUTLONG(CA);
// 5576 select output tank (object); put (obj term)
SELECTOUTPUTTANK(OBJECT);
PUT(16);
// 5577 put word (events)
PUTWORD(EVENTS);
// 5578 %if events # 0 %start
if (EVENTS == 0) goto L_047D;
// 5579 put word (evlow); put word (evep)
PUTWORD(EVLOW);
PUTWORD(EVEP);
// 5580 %finish
L_047D:;
// 5581 %finish
L_047C:;
// 5582 %else
goto L_047E;
L_047B:;
// 5583 %if amode < 0 %start
if (AMODE >= 0) goto L_047F;
// 5584 frame = maxframe %if maxframe > frame
if (MAXFRAME <= FRAME) goto L_0480;
FRAME = MAXFRAME;
L_0480:;
// 5585 %if amode = -1 %start
if (AMODE != -1) goto L_0481;
// 5586 gvar_length = frame
GVAR->LENGTH = FRAME;
// 5587 %else
goto L_0482;
L_0481:;
// 5588 oldframe = frame
OLDFRAME = FRAME;
// 5589 %finish
L_0482:;
// 5590 %finish
L_047F:;
// 5591 %finish
L_047E:;
// 5592 diag lines = local lines
DIAGLINES = LOCALLINES;
// 5593 diag size = diag size+local diags
DIAGSIZE = DIAGSIZE + LOCALDIAGS;
// 5594 frame = old frame
FRAME = OLDFRAME;
// 5595 last local = old last local
LASTLOCAL = OLDLASTLOCAL;
// 5596 uncond jump = old jump
UNCONDJUMP = OLDJUMP;
// 5597 ca = old ca
CA = OLDCA;
// 5598 entry mask = old mask
ENTRYMASK = OLDMASK;
// 5599 ivbit state = old ivbit
IVBITSTATE = OLDIVBIT;
// 5600 %end
return;
case_C_dispatch:
if (C_index < 32 || 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 - 32];
} /* end of ASSEMBLE */
// 5601
// 5602 glongword (16_80808080); glongword (16_80808080)
GLONGWORD(-2139062144);
GLONGWORD(-2139062144);
// 5603 glongword (3+'G'<<8+'L'<<16+'A'<<24); !gla marker
GLONGWORD(3 + (71 << 8) + (76 << 16) + (65 << 24));
// 5604 glongword (0); !codebase
GLONGWORD(0);
// 5605 glongword (0); !diagbase
GLONGWORD(0);
// 5606 glongword (0); !line base
GLONGWORD(0);
// 5607 gword (0); !null string
GWORD(0);
// 5608 glongword (0)
GLONGWORD(0);
// 5609 glongword (0); !event list
GLONGWORD(0);
// 5610
// 5611 assemble (0, 0, 0); !set it going<<<<<<<
ASSEMBLE(0, 0, 0);
// 5612
// 5613 gfix (7)
GFIX(7);
// 5614 put (obj end)
PUT(14);
// 5615
// 5616 select output tank (directives)
SELECTOUTPUTTANK(DIRECTIVES);
// 5617 put (dir sizes)
PUT(7);
// 5618 put long (ga)
PUTLONG(GA);
// 5619 put word (newtag-1)
PUTWORD(NEWTAG() - 1);
// 5620 put word (specs)
PUTWORD(SPECS);
// 5621 put word (diag size); put word (evno)
PUTWORD(DIAGSIZE);
PUTWORD(EVNO);
// 5622 put ('*')
PUT(42);
// 5623
// 5624
// 5625 exit (fatal) %if errors # 0
if (ERRORS == 0) goto L_0483;
EXIT(268435500);
L_0483:;
// 5626
// 5627 control = original control
CONTROL = ORIGINALCONTROL;
// 5628
// 5629 %end
return;
} /* end of PASS2 */
// ?CVTLW unused
// ?MOVW unused
// ?MOVZWL unused
// ?PSYM unused
// ?RSYM unused
// ?BRDIV unused
// ?BREXP unused
// ?BEXP unused
// ?BDIV unused
// ?BRSH unused
// ?BSLH unused
// 5630
// 5631 %BEGIN
int main(int argc, char **argv) { /*%begin*/
_imp_initialise(argc, argv);
// 5632 %END
_imp_stop(0);
return 0;
end_0:;
}
// 5633
// 5634 %end %of %file