#include <perms.h>
// Edinburgh IMP77 Compiler - Version 8.4
//
// 1 !!%include "Sysinc:com.inc"
// 2 {Include file for compiler communication}
// 3 %recordformat impcomfm(%integer statements, flags, code, gla, diags, perm,
struct IMPCOMFM {
union {
struct {
int STATEMENTS;
int FLAGS;
int CODE;
int GLA;
int DIAGS;
int PERM;
_imp_string31 FILE;
_imp_string63 OPTION;
};
};
};
// 4+ %string(31) file,
// 5+ %string(63) Option)
// 6 %externalrecord(impcomfm)%spec IMPCOM
extern struct IMPCOMFM IMPCOM;
// 7 !!%endoffile
// 8 ! **************************************************************
// 9 ! * *
// 10 ! * PERKIN-ELMER 32-bit series IMP compiler *
// 11 ! * Intermediate-code Assembler *
// 12 ! * *
// 13 ! * (General Service Version) *
// 14 ! * *
// 15 ! * Interactive Datasystems (Edinburgh) Ltd. *
// 16 ! * 32, Upper Gilmore Place, *
// 17 ! * Edinburgh EH3 9NJ *
// 18 ! * *
// 19 ! * Copyright (c) MAY 1st. 1980 *
// 20 ! * All Rights Reserved *
// 21 ! * *
// 22 ! **************************************************************
// 23
// 24
// 25
// 26
// 27
// 28 ! Known faults:
// 29
// 30 ! Outstanding:
// 31 ! %longreal is currently treated as %real
// 32 ! statically sized arrays within stack frame
// 33 !
// 34 ! Optimisations: (intended complete list)
// 35 ! integer constant folding *done*
// 36 ! real folding: integer/integer, integer^integer *done*
// 37 ! literals in shareable code segment *done*
// 38 ! special treatment of null string *done*
// 39 ! special treatment of simple append (S = S.T) *done*
// 40 ! special treatment of S=S.tostring(x) *done*
// 41 ! suppression of redundant capacity checks *done*
// 42 ! suppression of redundant unassigned checks *done*
// 43 ! register usage *done*
// 44 ! register environments *done*
// 45 ! k*2 -> k+k, k^2 -> k*k, k^^2 -> k*k *done*
// 46 ! Pass last param = string or record %value as %name then
// 47 ! copy within routine *done* (for strings only)
// 48 ! Detect and omit redundant array bound checks
// 49
// 50 50+ ! ABORT CODES
// 51 ! ===========
// 52 ! code routine reason
// 53 !
// 54 ! ?? x: assemble: faulty intermediate code operation 'x'
// 55
// 56 ! ADMP: adump: constant record ?
// 57 ! AM00: assemble: static block nesting > 5 levels
// 58 ! AM01: assemble: ('A') unknown constant type
// 59 ! AM05: assemble: ('u', 'q') unspecified length in ++, --
// 60 ! AM10: assemble: ('_') switch label outwith declared vector
// 61 ! AM15: assemble: ('B') intermediate code faulty at %repeat tag
// 62 ! AM25: assemble: ('F') user label out of range
// 63 ! AM30: assemble: (':') user label out of range
// 64 ! AM35: assemble: ('d') wrong no. of dimensions specified
// 65 ! AM40: assemble: ('d') %const/%own array inside out
// 66 ! AM45: assemble: ('~') faulty intermediate code in alternate record format
// 67
// 68 ! AM50: assemble: ('}') symbol table overflow (inserting formal parameter specs)
// 69 ! AM55: assemble: ('}') (OUT:) %record format > 64k bytes
// 70 ! AMAP: amap: impossible form
// 71 ! ARF1: array ref: no. of subscripts doesn't match declaration
// 72 ! ASS1: assign: not at least two items on operand stack
// 73 ! ASS2: assign: general %name not a %name
// 74 ! ASS3: assign: record length undefined in 'record = record'
// 75 ! CLM1: claim: reg > fr14
// 76 ! CLMD: assemble: ('O') registers still claimed at line flag
// 77 ! COP1: cop: exponent overflow in folding integer^integer
// 78 ! COP2: cop: inappropriate operator
// 79 ! DMP1: select literal area: literal area already selected
// 80 ! DMP2: select code area: code area already selected
// 81 ! DMP3: lit byte: literal area not selected
// 82 ! DMP4: claim literal: literal area currently selected
// 83 ! DMP5: external link: non-existent reference type
// 84 ! DROP: drop: descriptor not in use
// 85 ! DSC1: descriptor: operand stack overflow
// 86 ! DSC2: descriptor: descriptor free-list empty
// 87 ! DSC3: descriptor: link-block ('using') free-list empty
// 88 ! DFV1: define var: symbol table overflow (inserting record element name)
// 89 ! DFV2: define var: symbol table overflow (inserting non-format item)
// 90 ! FOR1: compile for: too many nested %for...%cycle .....%repeat pairs
// 91 ! HAZ1: hazard: attempt to hazard a constant
// 92 ! HAZ2: hazard: a use is still outstanding
// 93 ! HDR1: header: %string parameter in %begin ?
// 94 ! LD1: load: ADDRESS failed to simplify non-trivial address mode
// 95 ! LD2: load: real variable/integer register
// 96 ! LD3: load: inappropriate type
// 97 ! LD4: load: not/neg implemented in operate
// 98 ! LD5: load: load floating variable into 'any' ?
// 99 ! LD6: load: real operand with and/or/xor
// 100 ! LD7: load: real 'neg' implemented in operate
// 101 ! LD8: load: not a floating register
// 102 ! LD9: load: real exponent ?
// 103 ! LIT?: assemble: ('O') literal area still selected at line flag
// 104 ! NLBL: new label: no free labels
// 105 ! PICK: pickup (in LOAD) incompatible uses of a register
// 106 ! POPL: pop lhs: operand stack is already empty
// 107 ! REL1: release: reg > fr14
// 108 ! REL2: release: reg not claimed
// 109 ! RXD1: rxd: no immediate form of instruction
// 110 ! RXD2: rxd: faulty register specification
// 111 ! RXD3: rxd: faulty register specification
// 112 ! RXD4: rxd: non-elementary operand type supplied to 'RXD'
// 113 ! RXD5: rxd: displacement not aligned on 'type' boundary
// 114 ! SETB: set both: not at least two items on operand stack
// 115 ! STK?: assemble: ('O') operand stack not empty at line flag.
// 116 ! TAG?: block mark: more than 32767 third pass tags generated. See c('_'):
// 117 ! USNG: assemble: ('O') 'using' list not empty at line flag.
// 118 ! VMAP: vmap: impossible form
// 119 ! VSTK: vstack: variable no (symbol table index) out of bounds
// 120
// 121
// 122
// 123
// 124
// 125
// 126
// 127 ! == == == == == == == == == == == == == == == == == ==
// 128 ! Known Faults:
// 129 ! READ SYMBOL is not implemented properly
// 130 ! external linkage dumping is too indiscriminate
// 131 ! general name parameter types don't match old subsystem
// 132 ! == == == == == == == == == == == == == == == == == ==
// 133 133+ !*****************************************************************************
// 134 !
// 135 ! Options: (enabled when control bit = 1)
// 136 !
// 137 ! 1: Capacity check on all store operations
// 138 ! Overflow check on integer multiply
// 139 ! 2: Unassigned check on %string, %integer, %real & %longreal operands
// 140 ! 4: Array bound checking
// 141 ! Checks for integrity of %for construction
// 142 ! 16: Assorted extra checks:
// 143 ! complete arithmetic overflow checking (*not yet*)
// 144 ! 32: Permit removal of ALL diagnostic code and optimisations which are
// 145 ! not 100% safe.
// 146 ! Diagnostic code removed:
// 147 ! Unassigned check on P in R string parameter
// 148 ! Stack limit check
// 149 ! Risky optimisations:
// 150 ! Remembering pointers over an assignment via
// 151 ! another pointer. Aliasing might JUST occur.
// 152 ! 64: Enable trace option
// 153 ! 128: No register optimisation: primarily for suppressing compiler faults
// 154 !
// 155 ! NOTE:
// 156 ! Switch references are always checked
// 157 ! Stack overflow is checked unless 'TRUSTED' is specified.
// 158 !
// 159 !******************************************************************************
// 160 ! N.B. The bit positions in CONTROL corresponding to 256 and 512
// 161 ! are reserved to control the dumping of diagnostic tables
// 162 ! by PASS 3.
// 163 !
// 164 ! OPT is set (implicitly) by disabling all explicitly settable
// 165 ! checks (bits 1,2,4,8,16)
// 166 !
// 167 ! TRUSTED disables all checks and also sets the '32' bit.
// 168 !******************************************************************************
// 169
// 170
// 171
// 172
// 173
// 174 %begin; ! 7/32 DIAGNOSTIC ASSEMBLER
int main(int argc, char **argv) { /*%begin*/
_imp_initialise(argc, argv);
// 175 !SIZE CONSTANTS
// 176 %constinteger max vars = 800
// 177 %constinteger max labels = 80
// 178 %constinteger max depth = 16
// 179 %constinteger max stack = 25
// 180 %constinteger max labdef = 7999
// 181 %constinteger max refs = 2000
// 182 %constinteger SetLen = 32 {bytes per set}
// 183 %constinteger max prim = 23
// 184 %constinteger max cycle = 30
// 185 %constinteger max temps = 60
// 186 %constinteger max use = 20; !limit for klist
// 187 %constinteger max envirs = 5; !Environments
// 188 %constinteger max knowledge = max use*(max envirs+1)
// 189 %conststring(3) program ep = "%GO"; ! Main program external name
const _imp_string3 PROGRAMEP = _imp_str_init("%GO");
// 190 %conststring(1) system prefix = "$"; ! prefixed to %system routine idents
const _imp_string1 SYSTEMPREFIX = _imp_str_init("$");
// 191 %conststring(6) trace routine = "$TRACE"; ! external called by trace option
const _imp_string6 TRACEROUTINE = _imp_str_init("$TRACE");
// 192 %conststring(10) read sym fn = "#READSYMFN"; ! linkage name of "read symbol" perm
const _imp_string10 READSYMFN = _imp_str_init("#READSYMFN");
// 193 %constinteger ident len = 19; ! Significant chars in internal idents
// 194 %constinteger extern len = 12; ! Max. length of names in diags/link
// 195
// 196 !Input/output streams
// 197 %constinteger in=1
// 198 %constinteger report=0, direct=1, object=2
// 199
// 200
// 201 ! Language mask bits (generally =0 for 'obvious' or IMP interpretation)
// 202 ! Note that each bit controls compilation of a particular source level
// 203 ! abstraction and each first pass can select any convenient combination
// 204 ! of options.
// 205 %constinteger UNUSED = 1, {currently not used - IMP pass1!!}
// 206+ non IMP for = 2 {exit on >= final value (zero trip)}
// 207
// 208 !CONTROL BITS
// 209 %constinteger check capacity=1
// 210 %constinteger check unass=2
// 211 %constinteger check array=4, check for = 4
// 212 %constinteger check extra=16
// 213 %constinteger trusted=32
// 214 %constinteger trace=64
// 215 %constinteger suppress=128
// 216 %constinteger check bits = check capacity+check unass+check array+check extra
// 217
// 218 %constinteger bit15 = -32768; ! halfword sign-bit
// 219
// 220 !SPECIAL ADDRESSES
// 221 %constinteger unass = 12; ! unassigned pattern at unass(code)
// 222 %constinteger init gla = 12; ! first usable displacement into gla
// 223 %constinteger init lit = 8; ! first literal ends at -INITLIT(CODE)
// 224
// 225 ! Derived constants
// 226 %constinteger for lab base = 8000; ! = MAX LABDEF+1
// 227
// 228 228+
// 229+ !REGISTERS
// 230 %constinteger R0 = 1
// 231 %constinteger R1 = 2; ! Fn/map result, @final string result
// 232 %constinteger p3 = R1; ! SPECIAL STRING PARAMETER
// 233 %constinteger R2 = 3
// 234 %constinteger R3 = 4
// 235 %constinteger R4 = 5
// 236 %constinteger R5 = 6, p2 = R5
// 237 %constinteger R6 = 7, p1 = R6
// 238 %constinteger R7 = 8, wsp = R7
// 239 %constinteger R8 = 9, base1 = R8
// 240 %constinteger R9 = 10, base2 = R9
// 241 %constinteger R10 = 11, base3 = R10
// 242 %constinteger R11 = 12, base4 = R11
// 243 %constinteger R12 = 13, base5 = R12; ! (unassigned pattern for levels 1:4)
// 244 %constinteger R13 = 14, gla = R13
// 245 %constinteger R14 = 15, code = R14
// 246 %constinteger R15 = 16, link = R15
// 247 %constinteger FR0 = 17; ! FN RESULT
// 248 %constinteger FR2 = 18
// 249 %constinteger FR4 = 19
// 250 %constinteger FR6 = 20
// 251 %constinteger FR8 = 21
// 252 %constinteger FR10 = 22
// 253 %constinteger FR12 = 23
// 254 %constinteger FR14 = 24
// 255 !PSEUDO REGISTERS
// 256 %constinteger any = 25
// 257 %constinteger anyf = 26
// 258 %constbyteintegerarray actual(0:fr14) = 0,
const unsigned char ACTUAL[25] = {0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 0, 2, 4, 6, 8, 10, 12, 14};
// 259+ 0, 1, 2, 3, 4, 5, 6, 7,
// 260+ ! R0 R1 R2 R3 R4 P2 P1 WSP
// 261+
// 262+ 8, 9, 10, 11, 12, 13, 14, 15,
// 263+ ! R8 R9 R10 R11 R12 GLA CODE LINK
// 264+
// 265+ 0, 2, 4, 6, 8, 10, 12, 14
// 266 ! FR0 FR2 FR4 FR6 FR8 FR10 FR12 FR14
// 267 %constbyteintegerarray breg(-1:5) =
const unsigned char BREG[7] = {0, 0, 9, 10, 11, 12, 13};
// 268+ 0, 0, base1, base2, base3, base4, base5
// 269 !DATA FORMS
// 270 ! EXTERNAL
// 271 %constinteger recordformat = 4
// 272 %constinteger switch = 6
// 273 %constinteger array = 11
// 274 %constinteger arrayname = 12
// 275 %constinteger namearray = 13
// 276 %constinteger namearrayname = 14
// 277 ! INTERNAL
// 278 %constinteger constant = 0
// 279 %constinteger v in r = 1
// 280 %constinteger av in r = 2
// 281 %constinteger a in r = 3
// 282 %constinteger v in s = 4
// 283 %constinteger av in s = 5
// 284 %constinteger a in s = 6
// 285 %constinteger v in rec = 7
// 286 %constinteger av in rec = 8
// 287 %constinteger a in rec = 9
// 288 %constinteger pgm label = 14
// 289 !!N.B. FORM=15 denotes %record format
// 290 ! Flag bits used in conjunction with form:
// 291 %constinteger quick conc = 1, {optimise: S = S.tostring(symbol) }
// 292+ P in R = 2, {parameter-in-register}
// 293+ prim bit = 4, {primitive known to compiler}
// 294+ assigned = 8, {assigned and known to be}
// 295+ proc bit = 16, {routine/fn/map/predicate}
// 296+ abit = 32, {array by value}
// 297+ anbit = 64, {array by name}
// 298+ label bit = 128 {data is an address}
// 299 %constinteger array bits = abit ! anbit; ! for convenience
// 300
// 301 ! All arrays are in fact treated as by name (i.e. with a dope vector) and
// 302 ! the ABIT bit is misused to indicate that an array is a candidate for
// 303 ! subscript scaling by the use of 'multiply halfword'
// 304 %constinteger cheap array bit = abit
// 305
// 306 ! 'FLAG' byte of 'xform':
// 307
// 308 !=======================================================================!
// 309 ! label AN A proc assigned prim P in R ------ !
// 310 ! bit bit bit bit bit !
// 311 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !
// 312 ! 128 64 32 16 8 4 2 1 !
// 313 !=======================================================================!
// 314 ! : !
// 315 ! : D I M E N S I O N S !
// 316 ! : (if %array) !
// 317 ! :______________________________!
// 318 ! N.B.
// 319 ! In 'varfm' the 4,2,1 bits are used to hold the number of dimensions
// 320 ! when the table entry represents an array object. This field is
// 321 ! unpacked into the 'DIM' field of 'stackfm' by 'VSTACK'
// 322
// 323 323+ !LABEL CONSTANTS
// 324 %constinteger define new = 0
// 325 %constinteger redefine old = 1
// 326 %constinteger internal tag = -1; ! N.B. This must be <0 and others >=0
// 327 !DATA TYPES
// 328 %constinteger integers = 1
// 329 %constinteger short = 2
// 330 %constinteger byte = 3
// 331 %constinteger general = 4
// 332 %constinteger strings = 5
// 333 %constinteger records = 6
// 334 %constinteger reals = 7
// 335 %constinteger reall = 7; ! (SET TO 8 FOR LONG REALS)
// 336 !Figurative data types used internally (reduce to INTEGERS)
// 337 !! %constinteger pointer = -1
// 338 !! %constinteger in store const = -2
// 339 !LENGTHS
// 340 %constinteger single=4; ! bytes in single precision %real
// 341 %constinteger double = single*(reall-reals+1)
// 342 %constinteger align = 3; ! Basic alignment mask
// 343 %constinteger reglen=4; ! no. of bytes in GP register
// 344 %constinteger basic frame = (link-p2+1)*reglen
// 345 !OWN INFO
// 346 %constinteger own = 1
// 347 %constinteger con = 2
// 348 %constinteger external = 3
// 349 %constinteger system = 4
// 350 %constinteger dynamic = 5
// 351 %constinteger primrt = 6
// 352 %constinteger permrt = 7
// 353
// 354
// 355 ! Constants used to define sizes of various objects known to pass 3
// 356 %constinteger short ident = 6; ! characters: related to 'extern len' !!
// 357 %constinteger basic vdiag = 4; ! halfwords: no. req'd for 'short ident'
// 358 %constinteger extra vdiag = 2; ! halfwords: basic+extra == extern len
// 359
// 360
// 361
// 362
// 363 ! Define type codes known externally (to pass 3 and user):
// 364 %constbyteintegerarray gen map(integers:reals+1) =
const unsigned char GENMAP[8] = {1, 6, 5, 0, 3, 4, 2, 8};
// 365+ 1, 6, 5, 0, 3, 4, 2, 8
// 366 ! integer short byte general string record reals reall
// 367 367+
// 368+ !PERM ROUTINES
// 369 ! ** UNASSIGNED CHECK as a special at 0(code) **
// 370 %constinteger asschk=1
// 371
// 372 %constinteger iexp=2
// 373 %constinteger fexp=3; ! floating exponent
// 374 %constinteger smove=4
// 375 %constinteger sjam=5
// 376 %constinteger sconc=6
// 377 %constinteger sresln=7; ! conditional resolution
// 378 %constinteger sresv=8; ! check SRESLN succeeded
// 379 %constinteger scomp=9
// 380 %constinteger frac part = 10; ! IMP 'frac pt' function
// 381 %constinteger sfcap=11; ! string capacity exceeded
// 382 %constinteger substr = 12; ! substring
// 383 %constinteger aref1=13; ! 1-D with checks
// 384 %constinteger aref2=14; ! 2-D with checks
// 385 %constinteger aref3=15; ! n-D with checks
// 386 %constinteger aref4=16; ! 2-D without checks
// 387 %constinteger set dv=17; ! set dope vector
// 388 %constinteger alloc=18; ! claim array space
// 389 %constinteger swjump=19
// 390 %constinteger signal=20
// 391 %constinteger mulchk=21; ! check for 32-bit result from integer multiply
// 392 %constinteger cap16=22; ! check for 16-bit signed overflow
// 393 %constinteger cap8=23; ! . . . 8-bit unsigned . .
// 394 %constinteger fchk1=24; ! %for loop parameter check
// 395 %constinteger fchk2=25; ! check for %for loop counter fiddling
// 396 %constinteger pentc=26; ! checked procedure entry
// 397 %constinteger rcopy=27; ! record copy
// 398 %constinteger rzero=28; ! clear record
// 399 %constinteger vschk=29; ! variable shift parameter check
// 400 %constinteger smovopt=30; ! fast unchecked string move (also see P in R string)
// 401 %constinteger chmap=31; ! IMP 'charno' %map
// 402 %constinteger freesp=32; ! IMP 'free space' function
// 403 %constinteger int fn=33; ! IMP 'int' function
// 404 %constinteger rcomp = 34 {record compare}
// 405 %constinteger set comp = 35,
// 406+ set union = 36,
// 407+ set difference = 37,
// 408+ set intersection = 38
// 409
// 410 %constbytearray Set ops(1:3) = Set union, Set Difference, Set intersection
const unsigned char SETOPS[3] = {36, 37, 38};
// 411
// 412 %constinteger iocp = 49
// 413 %constinteger enter trace = 50
// 414
// 415 !OPERATIONS
// 416 ! logical => both <= code generator
// 417 %constinteger not = 1, lw = 1
// 418 %constinteger neg = 2, st = 2
// 419 %constinteger add = 3
// 420 %constinteger sub = 4
// 421 %constinteger mul = 5
// 422 %constinteger div = 6
// 423 %constinteger conc = 7, cmp = 7
// 424 %constinteger and = 8
// 425 %constinteger or = 9
// 426 %constinteger xor = 10
// 427 %constinteger lsh = 11
// 428 %constinteger rsh = 12
// 429 %constinteger mult16 = 13
// 430 %constinteger rem = 14
// 431 %constinteger exp = 15
// 432 %constinteger rexp = 16
// 433 %constinteger rdiv = 17
// 434
// 435 !CODE GENERATOR TABLES
// 436 ! mask bits in 'op index' array
// 437 %constinteger fw imm=2048, hw imm=4096, sf imm=8192, inv imm=16384
// 438 %constinteger fw rr=256, fw rx=512, short rx=1024, byte rx=32768
// 439 %constinteger fp base = rem-1
// 440 %constshortintegerarray op index(1:40) =
const short int OPINDEX[40] = {65281, 34313, 32529, 32536, 799, 801, 7971, 7976, 7981, 7986,
12343, 12349, 1909, 3907, 2631, 3915, 3919, 3923, 3927, 3931,
868, 870, 615, 616, 617, 363, 364, 8031, 4201, 366,
367, 1034, 623, 624, 625, 6256, 1142, 1656, 634, 635};
// 441+ x'FF01',; ! LW: load - 1 + all formats
// 442+ x'8609',; ! ST: store - 9 + full/half word + byte
// 443+ x'7F11',; ! ADD: add - 17 + all but byte
// 444+ x'7F18',; ! SUB: subtract - 24 + all but byte
// 445+ x'031F',; ! MUL: multiply - 31 + full word formats
// 446+ x'0321',; ! DIV: divide - 33 + full word formats
// 447+ x'1F23',; ! CMP: compare - 35 + all but byte and short immediate
// 448+ x'1F28',; ! AND: and - 40 + .....
// 449+ x'1F2D',; ! OR: or - 45 + ......
// 450+ x'1F32',; ! XOR: xor - 52 + ........
// 451+ x'3037',; ! LSH: left shift - 55 + halfword and shortform
// 452+ x'303D',; ! RSH: right shift - 61 + halfword and shortform
// 453+ x'0775',; ! MULT16: 117 + rr + rx + short rx
// 454+ ! ** floating point formats **
// 455+ x'0F43',; ! LW: load - single and double
// 456+ x'0A47',; ! ST: store - store reference formats only
// 457+ x'0F4B',; ! ADD: add - 75 + all formats
// 458+ x'0F4F',; ! SUB: subtract - 79 + ...
// 459+ x'0F53',; ! MUL: multiply - 83 + ...
// 460+ x'0F57',; ! DIV: divide - 87 + ...
// 461+ x'0F5B',; ! CMP: compare - 91 + ...
// 462+ ! ** specials **
// 463+ x'0364', ; ! JMP
// 464+ x'0366', ; ! BAL
// 465+ x'0267', ; ! LA
// 466+ x'0268', ; ! LM
// 467+ x'0269', ; ! STM
// 468+ x'016B', ; ! FLR
// 469+ x'016C', ; ! FXR
// 470+ x'1F5F', ; ! CLW
// 471+ x'1069', ; ! SRA
// 472+ x'016E', ; ! CHVR
// 473+ x'016F', ; ! LBR
// 474+ x'040A', ; ! STH
// 475+ x'026F', ; ! SVC
// 476+ x'0270', ; ! LME
// 477+ x'0271', ; ! STME
// 478+ x'1870', ; ! TEST (TI/THI)
// 479+ x'0476', ; ! LHL (short rx only)
// 480+ x'0678', ; ! AM (fullword and short rx only)
// 481+ x'027A', ; ! TBT
// 482+ x'027B' ; ! SBT
// 483
// 484
// 485 ! Each halfword below is treated as 4 groups of 4 bits [a:b:c:d] with the
// 486 ! following significance.
// 487 ! a,b: 8-bit machine op-code
// 488 ! c: special function bits
// 489 ! 1: this operation sets condition code other than relative
// 490 ! to zero.
// 491 ! 2: invert order of operands to provide for example
// 492 ! STR x,y => LR y,x
// 493 ! 4: this operation doesn't affect condition code
// 494 ! d: mask to check alignment of displacement required by this instruction.
// 495
// 496 %constshortintegerarray op code(1:124) =
const short int OPCODE[124] = {
2048, 22531, 18433, 63488, 51200, 9216, 9472, 54096, 2080, 20563, 16465, 0, 0, 0, 0, 53840,
2560, 23043, 18945, 64000, 51712, 9728, 9984, 2816, 23299, 19201, 64256, 51968, 9984, 9728, 7248, 23635,
7504, 23891, 2320, 22803, 18705, 63760, 51472, 1024, 21507, 17409, 62464, 50176, 1536, 22019, 17921, 62976,
50688, 1792, 22275, 18177, 63232, 50944, 0, 0, 0, 0, 60672, 4352, 0, 0, 0, 0,
60416, 4096, 10240, 26627, 14336, 30723, 10272, 24659, 0, 28755, 10752, 27139, 14848, 31235, 11008, 27395,
15104, 31491, 11264, 27651, 15360, 31747, 11520, 27907, 15616, 32003, 10512, 26899, 14608, 30995, 1296, 21779,
17681, 62736, 50448, 768, 17152, 256, 16640, 58960, 53584, 53328, 12032, 11776, 60944, 4608, 37712, 57616,
29264, 29008, 62224, 49936, 3152, 19537, 19537, 29441, 20755, 24849, 29697, 29953};
// 497+ x'0800', x'5803', x'4801', x'F800', x'C800', x'2400', x'2500', x'D350',
// 498+ ! LR L LH LI LHI LIS LCS LB
// 499+ x'0820', x'5053', x'4051', 0, 0, 0, 0, x'D250',
// 500+ ! STR ST STH -- -- -- -- STB
// 501+ x'0A00', x'5A03', x'4A01', x'FA00', x'CA00', x'2600', x'2700',
// 502+ ! AR A AH AI AHI AIS SIS
// 503+ x'0B00', x'5B03', x'4B01', x'FB00', x'CB00', x'2700', x'2600',
// 504+ ! SR S SH SI SHI SIS AIS
// 505+ x'1C50', x'5C53',
// 506+ ! MR M
// 507+ x'1D50', x'5D53',
// 508+ ! DR D
// 509+ x'0910', x'5913', x'4911', x'F910', x'C910',
// 510+ ! CR C CH CI CHI
// 511+ x'0400', x'5403', x'4401', x'F400', x'C400',
// 512+ ! NR N NH NI NHI
// 513+ x'0600', x'5603', x'4601', x'F600', x'C600',
// 514+ ! OR O OH OI OHI
// 515+ x'0700', x'5703', x'4701', x'F700', x'C700',
// 516+ ! XR X XH XI XHI
// 517+ 0, 0, 0, 0, x'ED00', x'1100',
// 518+ ! -- -- -- -- SLL SLLS
// 519+ 0, 0, 0, 0, x'EC00', x'1000',
// 520+ ! -- -- -- -- SRL SRLS
// 521+ x'2800', x'6803', x'3800', x'7803',
// 522+ ! LER LE LDR LD
// 523+ x'2820', x'6053', 0, x'7053',
// 524+ ! STER STE -- STD
// 525+ x'2A00', x'6A03', x'3A00', x'7A03',
// 526+ ! AER AE ADR AD
// 527+ x'2B00', x'6B03', x'3B00', x'7B03',
// 528+ ! SER SE SDR SD
// 529+ x'2C00', x'6C03', x'3C00', x'7C03',
// 530+ ! MER ME MDR MD
// 531+ x'2D00', x'6D03', x'3D00', x'7D03',
// 532+ ! DER DE DDR DD
// 533+ x'2910', x'6913', x'3910', x'7913',
// 534+ ! CER CE CDR CD
// 535+
// 536+ ! Special purpose entries.
// 537+ x'0510', x'5513', x'4511', x'F510', x'C510',
// 538+ ! CLR CL CLH CLI CLHI
// 539+ x'0300', x'4300',
// 540+ ! BFCR BFC
// 541+ x'0100', x'4100',
// 542+ ! BALR BAL
// 543+ x'E650',
// 544+ ! LA
// 545+ x'D150',
// 546+ ! LM
// 547+ x'D050',
// 548+ ! STM
// 549+ x'2F00',
// 550+ ! FLR
// 551+ x'2E00',
// 552+ ! FXR
// 553+ x'EE10',
// 554+ ! SRA
// 555+ x'1200',
// 556+ ! CHVR
// 557+ x'9350',
// 558+ ! LBR
// 559+ x'E110',
// 560+ ! SVC
// 561+ x'7250',
// 562+ ! LME
// 563+ x'7150',
// 564+ ! STME
// 565+ x'F310', x'C310',
// 566+ ! TI THI
// 567+ x'0C50', x'4C51', x'4C51',
// 568+ ! MHR M(H) MH
// 569+ x'7301',
// 570+ ! LHL
// 571+ x'5113', x'6111',
// 572+ ! AM AHM
// 573+ x'7401', x'7501'
// 574 ! TBT SBT
// 575
// 576 !Non-uniform operations for special situations
// 577 %constinteger jmp=21, always=r0; ! RR(JMP,always,LINK)
// 578 %constinteger bal=22; ! Branch-and-link
// 579 %constinteger la =23; ! Load Address (RX format)
// 580 %constinteger lm=24, stm=25; ! Load/Store Multiple
// 581 ! ** FLR below is really 25-fpbase **
// 582 %constinteger flr=26-fpbase, fxr=27; ! Float/Fix (RR format only)
// 583 %constinteger clw=28; ! Compare Logical (same formats as AND)
// 584 %constinteger sra=29; ! Shift Right Arithmetic (HW IMM only)
// 585 %constinteger chvr=30; ! Convert to halfword value (RR only)
// 586 %constinteger lbr=31; ! Load Byte Register (RR only)
// 587 %constinteger sth=32; ! Store half-word (Short RX only)
// 588 %constinteger svc=33; ! Supervisor call (RX format)
// 589 %constinteger lme=34-fpbase; ! Used in conjunction with SVC
// 590 %constinteger stme=35-fpbase; ! .... ditto ....
// 591 %constinteger test=36; ! test halfword? immediate
// 592 %constinteger LHL=37; ! load unsigned halfword (for switch)
// 593 %constinteger AM=38; ! add-to-memory (see ASSIGN)
// 594 %constinteger TBT = 39, SBT = 40
// 595
// 596
// 597 %constbytearray Inverted(16:21) =
const unsigned char INVERTED[6] = {0, 1, 3, 2, 5, 4};
// 598+ 0, 1, 3, 2, 5, 4
// 599 { = # < > <= >= }
// 600
// 601 !ASSORTED FUNNY CONSTANTS
// 602 %constinteger jump=12; ! logical condition code == unconditional jump
// 603 %constinteger not equal=1; ! . . . branch not equal
// 604 %constinteger less than=2, greater than=3
// 605 %constinteger less or equal=4, greater or equal=5
// 606
// 607 !CODES USED IN OUTPUT FOR 3RD. PASS
// 608 %constinteger tag def = 1
// 609 %constinteger r ref = 2; ! Routine/fn/map/predicate reference
// 610 %constinteger p ref = 3; ! Prim reference
// 611 %constinteger sw ref = 4; ! Switch reference
// 612 %constinteger j ref = 5; ! Jump reference
// 613 %constinteger c ref = 6; ! Conditional (jump) reference
// 614 %constinteger code item = 7
// 615 %constinteger gla item = 8
// 616 %constinteger line flag = 9
// 617 %constinteger line reset = 10
// 618 %constinteger var diag = 11
// 619 %constinteger code area = 12
// 620 %constinteger lit area = 13
// 621 %constinteger lit org = 14
// 622 %constinteger frame patch = 15
// 623 %constinteger block start = 16
// 624 %constinteger block end = 17
// 625 %constinteger prog end = 18
// 626 %constinteger c rel = 19
// 627 %constinteger g rel = 20
// 628 %constinteger extern = 21
// 629 ! (external references)
// 630 %constinteger data ref = 4, data defn = 5
// 631 %constinteger ep ref = 6, ep defn = 7
// 632 632+
// 633+
// 634+ %recordformat varfm(%integer disp, %c
struct VARFM {
union {
struct {
int DISP;
short int FORMAT;
short int EXTRA;
short int LENGTH;
short int HEADER;
union {
struct {
short int XFORM;
};
struct {
unsigned char FLAG;
unsigned char FORM;
};
};
unsigned char BASE;
unsigned char TYPE;
};
};
};
// 635+ %shortinteger format,extra,length,header, %c
// 636+ (%shortinteger xform %or %byteinteger flag,form),
// 637+ %byteinteger base,type)
// 638 %record(varfm)%array var(0:max vars)
struct VARFM VAR[801];
// 639 %record(varfm)%name decvar
struct VARFM *DECVAR;
// 640 %record(varfm)%name fp, ap
struct VARFM *FP;
struct VARFM *AP;
// 641 %ownrecord(varfm) begin = 0
static struct VARFM BEGIN = {0};
// 642
// 643 %recordformat stackfm(%integer disp,
struct STACKFM {
union {
struct {
int DISP;
short int FORMAT;
short int EXTRA;
short int LENGTH;
short int HEADER;
short int RT;
short int VARNO;
short int TYPE;
union {
struct {
short int XFORM;
};
struct {
unsigned char FLAG;
unsigned char FORM;
};
};
union {
struct {
short int XBASE;
};
struct {
unsigned char INDEX;
unsigned char BASE;
};
};
unsigned char DIM;
unsigned char OPER;
struct STACKFM *LINK;
};
};
};
// 644+ %shortinteger format, extra, length, header, rt,
// 645+ %shortinteger var no, type,
// 646+ (%shortinteger xform %or %byteinteger flag,form),
// 647+ (%short xbase %or %byte index, base),
// 648+ %byte dim, oper,
// 649+ %record(stackfm)%name link)
// 650 %record(stackfm)%array stak(0:max stack)
struct STACKFM STAK[26];
// 651 %record(stackfm)%name desc asl
struct STACKFM *DESCASL;
// 652
// 653 %recordformat sptfm(%record(stackfm)%name v)
struct SPTFM {
union {
struct {
struct STACKFM *V;
};
};
};
// 654 %record(sptfm)%array stacked(1:max depth)
struct SPTFM STACKED[16];
// 655
// 656 ! elements of USING list
// 657 %recordformat dfm(%record(stackfm)%name d, %record(dfm)%name link)
struct DFM {
union {
struct {
struct STACKFM *D;
struct DFM *LINK;
};
};
};
// 658 %record(dfm)%array dlist(0:max stack)
struct DFM DLIST[26];
// 659 %record(dfm)%name dasl
struct DFM *DASL;
// 660 %record(dfm) using
struct DFM USING;
// 661
// 662 ! for compiling %for/%repeat pairs
// 663 %recordformat cyclefm(%integer cv disp, fv disp, %c
struct CYCLEFM {
union {
struct {
int CVDISP;
int FVDISP;
short int LAB;
short int SHADOW;
short int INITIAL;
short int CVFORM;
unsigned char REG;
unsigned char CVTYPE;
unsigned char CVBASE;
unsigned char FVBASE;
unsigned char TEMPBASE;
};
};
};
// 664+ %shortinteger lab, shadow, initial, cv form, %c
// 665+ %byteinteger reg, cv type, cv base, %c
// 666+ fv base, temp base)
// 667 %record(cyclefm)%array for stk(0:max cycle)
struct CYCLEFM FORSTK[31];
// 668 %record(cyclefm)%name for; ! points to currently active level
struct CYCLEFM *FOR;
// 669 %owninteger for stp=0
static int FORSTP = 0;
// 670
// 671 ! mechanism to minimise no of temporaries allocated
// 672 %shortintegerarray temps(1:max temps)
short int TEMPS[60];
// 673 %owninteger temp base = 0, next temp = 0, new temp = 0
static int TEMPBASE = 0;
static int NEXTTEMP = 0;
static int NEWTEMP = 0;
// 674
// 675 ! list terminator
// 676 %constrecord(*)%name null == (0)
const struct TEMPBASE *NULL = 0;
// 677
// 678 %recordformat labelfm(%shortinteger id, tag)
struct LABELFM {
union {
struct {
short int ID;
short int TAG;
};
};
};
// 679 %record(labelfm)%array labels(1:max labels)
struct LABELFM LABELS[80];
// 680
// 681 %ownintegerarray activity(0:fr14) = 0(*)
static int ACTIVITY[25] = {[0 ... 24] = 0};
// 682 %owninteger claimed = 0
static int CLAIMED = 0;
// 683
// 684
// 685 %ownshortinteger control = check bits & (\check extra)
static short int CONTROL = 7;
// 686 %ownshortinteger diagnose = 0
static short int DIAGNOSE = 0;
// 687 ! 1: trace calls on descriptor stack handling primitives
// 688 ! 2: . . . . . . . . . LOAD
// 689 ! 4: . . . . . . . . . ASSIGN
// 690 ! 8: . . . . . . . optimisation routines and display generated code
// 691 ! 16: dump 'knowledge' list every time CHEAPEN is called with '8' bit on
// 692
// 693 %owninteger level = -1
static int LEVEL = -1;
// 694 %owninteger main ep = 0; ! non-zero if compiling main program
static int MAINEP = 0;
// 695 %owninteger unassigned rtn = 0; ! non-zero if unassigned check routine pr in
static int UNASSIGNEDRTN = 0;
// 696
// 697 %integer j,k,len,n,val,aparm,opr
int J;
int K;
int LEN;
int N;
int VAL;
int APARM;
int OPR;
// 698 %owninteger ca = 0; ! CODE ADDRESS
static int CA = 0;
// 699 %owninteger ga = init gla; ! GLA ADDRESS
static int GA = 12;
// 700 %owninteger lita = 0; ! Literal address: current address
static int LITA = 0;
// 701 %owninteger litmax=0; ! : limit of area claimed so far
static int LITMAX = 0;
// 702 %owninteger diag1 = 0; ! DIAG TABLES 1
static int DIAG1 = 0;
// 703 %owninteger diag2 = 0; ! DIAG TABLES 2
static int DIAG2 = 0;
// 704 %owninteger cc ca=0, cc reg=0; ! to remember condition code
static int CCCA = 0;
static int CCREG = 0;
// 705
// 706 %integer sym, next; ! CODE SYMBOL, NEXT SYMBOL
int SYM;
int NEXT;
// 707 %integer vlb,vub; ! VECTOR LOWER/UPPER BOUND
int VLB;
int VUB;
// 708 %integer Allocate; ! Flag for array(#0) or arrayformat (=0)
int ALLOCATE;
// 709 %integer Falign {alignment of internal formats}
int FALIGN;
// 710 %owninteger current line = 0; ! SOURCE LINE NUMBER
static int CURRENTLINE = 0;
// 711 %owninteger last line = 0
static int LASTLINE = 0;
// 712 %owninteger stp = 0; ! STACK POINTER
static int STP = 0;
// 713 %integer data size; ! CURRENT DATA ITEM SIZE
int DATASIZE;
// 714 %owninteger frame = 0; ! LOCAL STACK FRAME EXTENT
static int FRAME = 0;
// 715 %owninteger extra frame = 0; ! ALLOW EXTRA FRAME FOR STATIC ARRAYS
static int EXTRAFRAME = 0;
// 716 %integer parms; ! START OF PARAMETER STACK
int PARMS;
// 717 %integer local; ! LOCAL BASE REGISTER
int LOCAL;
// 718 %owninteger invert = 0, swopped = 0; ! CONDITION INVERSION FLAGS
static int INVERT = 0;
static int SWOPPED = 0;
// 719 %owninteger uncond jump = 0; ! ADDRESS OF CODE HOLE
static int UNCONDJUMP = 0;
// 720 %owninteger gtype = 0; ! 0=RECORDS, 1=PROCEDURE
static int GTYPE = 0;
// 721 %owninteger gmode = 0; ! NON-ZERO INSIDE PARAMETER LISTS
static int GMODE = 0;
// 722 %integer decl; ! LAST-DEFINED DESCRIPTOR
int DECL;
// 723 %ownshortinteger language mask = 0; ! selects language specific options
static short int LANGUAGEMASK = 0;
// 724 %integer cheap reg; !Preferred register after ADDRESS
int CHEAPREG;
// 725 %integer otype, owntype, ownform, spec, frozen, potype
int OTYPE;
int OWNTYPE;
int OWNFORM;
int SPEC;
int FROZEN;
int POTYPE;
// 726 %integer diag type=0, diag form=0, diag size=0; ! external form/type/size
int DIAGTYPE;
DIAGTYPE = 0;
int DIAGFORM;
DIAGFORM = 0;
int DIAGSIZE;
DIAGSIZE = 0;
// 727 %longreal rvalue
double RVALUE;
// 728 !! Initialised to suppress critical unassigned check when compiling itself
// 729 %owninteger ownval = 0, mantissa = 0; ! *order critical*
static int OWNVAL = 0;
static int MANTISSA = 0;
// 730 %integer oarea
int OAREA;
// 731 %integer dim,dv
int DIM;
int DV;
// 732 %integer wdisp, pdisp, gdisp
int WDISP;
int PDISP;
int GDISP;
// 733
// 734 %owninteger block no = 0; ! Ordered by block head
static int BLOCKNO = 0;
// 735 %owninteger defns=0, specs=0, relocations=0, var diags=0
static int DEFNS = 0;
static int SPECS = 0;
static int RELOCATIONS = 0;
static int VARDIAGS = 0;
// 736 %owninteger total ca = 0
static int TOTALCA = 0;
// 737 %owninteger last ca = -1; ! Used by 'set line'
static int LASTCA = -1;
// 738 %owninteger trace flag = 0; ! controls calling of DUMP TRACE routine
static int TRACEFLAG = 0;
// 739
// 740 %integer jtag; ! Set by 'JUMP TO'
int JTAG;
// 741 %ownstring(ident len) external id = "", alias = "", block name = ""
static _imp_string19 EXTERNALID = _imp_str_init("");
static _imp_string19 ALIAS = _imp_str_init("");
static _imp_string19 BLOCKNAME = _imp_str_init("");
// 742 %ownstring(ident len) internal id = ""
static _imp_string19 INTERNALID = _imp_str_init("");
// 743 %owninteger faulty=0
static int FAULTY = 0;
// 744 %owninteger null string = 0
static int NULLSTRING = 0;
// 745
// 746 %byteintegername cslen
unsigned char *CSLEN;
// 747 %byteintegerarray current string(0:255)
unsigned char CURRENTSTRING[256];
// 748
// 749 ! Register optimisation scratch pad
// 750
// 751 %owninteger Last Gpr = 1,
static int LASTGPR = 1;
static int LASTFPR = 17;
static int LASTEO = 1;
// 752+ Last Fpr = Fr0,
// 753+ Last EO = 1
// 754
// 755 %recordformat kfm(%record(kfm)%name link, array,
struct KFM {
union {
struct {
struct KFM *LINK;
struct KFM *ARRAY;
int DISP;
short int REG;
unsigned char TYPE;
unsigned char FORM;
unsigned char BASE;
unsigned char KTYPE;
};
};
};
// 756+ %integer disp,
// 757+ %shortinteger reg,
// 758+ %byteinteger type, form, base, ktype)
// 759 %record(kfm)%array knowledge(1:max knowledge)
struct KFM KNOWLEDGE[120];
// 760 %ownrecord(kfm)%name klist == (0), kasl == (0)
static struct KFM *KLIST = 0;
static struct KFM *KASL = 0;
// 761 %integer known regs = 0; ! bit mask: must contain at least ANYF+1 bits
int KNOWNREGS;
KNOWNREGS = 0;
// 762 %integer in use = 0; !counter to limit active uses
int INUSE;
INUSE = 0;
// 763
// 764 !Environment control
// 765
// 766 %recordformat envfm(%integer label, in use, known, %record(kfm)%name link)
struct ENVFM {
union {
struct {
int LABEL;
int INUSE;
int KNOWN;
struct KFM *LINK;
};
};
};
// 767 %record(envfm)%array envir(1:max envirs)
struct ENVFM ENVIR[5];
// 768 %owninteger envp = 0
static int ENVP = 0;
auto void RR(int OP, int R1, int R2);
auto void RX(int OP, int R1, int BASE, int DISP);
auto void RXI(int OP, int R1, int BASE, int DISP);
auto void RXD(int OP, int R1, struct STACKFM *V);
auto void SETLINE(void);
// 769
// 770
// 771 ! Code generation routine specs
// 772 %routinespec rr(%integer op,r1,r2)
// 773 %routinespec rx(%integer op,r1,base,disp)
// 774 %routinespec rxi(%integer op,r1,base,disp)
// 775 %routinespec rxd(%integer op,r1,%record(stackfm)%name v)
// 776 %routinespec set line
// 777
// 778 ! >> SHOW <<
// 779 %routine show(%record(stackfm)%name v)
void SHOW(struct STACKFM * V) {
// 780 write(v_varno,2); print symbol(':')
_imp_WRITE(V->VARNO, 2);
_imp_PRINTSYMBOL(58);
// 781 write(v_type,3); write(v_form,2); write(v_flag,2)
_imp_WRITE(V->TYPE, 3);
_imp_WRITE(V->FORM, 2);
_imp_WRITE(V->FLAG, 2);
// 782 write(v_base,3); write(v_disp,5)
_imp_WRITE(V->BASE, 3);
_imp_WRITE(V->DISP, 5);
// 783 write(v_length,3)
_imp_WRITE(V->LENGTH, 3);
// 784 write(v_extra,3); write(v_format,3)
_imp_WRITE(V->EXTRA, 3);
_imp_WRITE(V->FORMAT, 3);
// 785 write(v_header,3); write(v_dim,3)
_imp_WRITE(V->HEADER, 3);
_imp_WRITE(V->DIM, 3);
// 786 %if v_oper # 0 %start
if (V->OPER == 0) goto L_0001;
// 787 write(v_oper,2); newline
_imp_WRITE(V->OPER, 2);
_imp_NEWLINE();
// 788 print string(" +")
_imp_PRINTSTRING(_imp_str_literal(" +"));
// 789 show(v_link)
SHOW(V->LINK);
// 790 %else
goto L_0002;
L_0001:;
// 791 newline
_imp_NEWLINE();
// 792 %finish
L_0002:;
// 793 %end
return;
} /* end of SHOW */
// 794
// 795 ! >> ABORT <<
// 796 %routine abort(%integer code)
void ABORT(int CODE) {
// 797 %record(dfm)%name dd
struct DFM *DD;
// 798 %integer j
int J;
// 799 select output(report)
_imp_SELECTOUTPUT(0);
// 800 print string("*Compiler error '")
_imp_PRINTSTRING(_imp_str_literal("*Compiler error '"));
// 801 print symbol( (code>>j)&255 ) %for j = 24,-8,0
// %for J = 24, -8, 0 %cycle
{
J = 32;
L_0003:
if (J == 0) goto L_0004;
J -= 8;
_imp_PRINTSYMBOL((unsigned int)CODE >> J & 255);
goto L_0003;
}
L_0004:;
// 802 print string("' at line"); write(current line,1)
_imp_PRINTSTRING(_imp_str_literal("' at line"));
_imp_WRITE(CURRENTLINE, 1);
// 803 newline
_imp_NEWLINE();
// 804 print string("Please seek assistance!!"); newline
_imp_PRINTSTRING(_imp_str_literal("Please seek assistance!!"));
_imp_NEWLINE();
// 805 %if stp # 0 %start
if (STP == 0) goto L_0006;
// 806 print string("STACK:"); newline
_imp_PRINTSTRING(_imp_str_literal("STACK:"));
_imp_NEWLINE();
// 807 show(stacked(j)_v) %for j = 1,1,stp
// %for J = 1, 1, STP %cycle
{
int _final = STP;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, STP");
J = 0;
L_0007:
if (J == _final) goto L_0008;
J += 1;
SHOW(STACKED[J - 1].V);
goto L_0007;
}
L_0008:;
// 808 %finish
L_0006:;
// 809 %unless using_link == null %start
if (_imp_ADDR((void *)(USING.LINK)) == _imp_ADDR((void *)(NULL))) goto L_000A;
// 810 print string("USING:"); newline
_imp_PRINTSTRING(_imp_str_literal("USING:"));
_imp_NEWLINE();
// 811 dd == using_link
DD = (struct DFM *)USING.LINK;
// 812 %cycle
L_000B:;
// 813 show(dd_d)
SHOW(DD->D);
// 814 dd == dd_link; %exit %if dd == null
DD = (struct DFM *)DD->LINK;
if (_imp_ADDR((void *)(DD)) != _imp_ADDR((void *)(NULL))) goto L_000C;
goto L_000D;
L_000C:;
// 815 %repeat
goto L_000B;
L_000D:;
// 816 %finish
L_000A:;
// 817 select output(object)
_imp_SELECTOUTPUT(2);
// 818 %signal 15,15; ! %IF diagnose < 0
_imp_signal(15, 15, 0, "");
// 819 %end; ! abort
return;
} /* end of ABORT */
// 820
// 821 ! >> WARN <<
// 822 %routine warn(%integer n)
void WARN(int N) {
// 823 %switch w(1:8)
int W_index;
int W_line;
char *W_file;
static const void *W[8] = {&&case_W_missing, &&case_W_missing, &&case_W_missing, &&case_W_missing,
&&case_W_missing, &&case_W_missing, &&case_W_missing, &&case_W_missing};
// 824 select output(report)
_imp_SELECTOUTPUT(0);
// 825 print string("*WARNING: line")
_imp_PRINTSTRING(_imp_str_literal("*WARNING: line"));
// 826 write(current line, 1); print string(": ")
_imp_WRITE(CURRENTLINE, 1);
_imp_PRINTSTRING(_imp_str_literal(": "));
// 827 -> w(n)
W_line = __LINE__;
W_file = __FILE__;
W_index = N;
goto case_W_dispatch;
// 828 w(1): print string("division by zero"); -> at
case_W_1:;
_imp_PRINTSTRING(_imp_str_literal("division by zero"));
goto U_1000;
// 829 w(2): print string("Illegal FOR"); -> at
case_W_2:;
_imp_PRINTSTRING(_imp_str_literal("Illegal FOR"));
goto U_1000;
// 830 w(3): print string("Non-local control variable?"); -> at
case_W_3:;
_imp_PRINTSTRING(_imp_str_literal("Non-local control variable?"));
goto U_1000;
// 831 w(4): print string("Invalid parameter for READ SYMBOL"); -> at
case_W_4:;
_imp_PRINTSTRING(_imp_str_literal("Invalid parameter for READ SYMBOL"));
goto U_1000;
// 832 w(5): print string("String constant too long"); -> at
case_W_5:;
_imp_PRINTSTRING(_imp_str_literal("String constant too long"));
goto U_1000;
// 833 w(6): print string("No. of shifts outwith 0..31"); -> at
case_W_6:;
_imp_PRINTSTRING(_imp_str_literal("No. of shifts outwith 0..31"));
goto U_1000;
// 834 w(7): print string("Illegal constant exponent"); -> at
case_W_7:;
_imp_PRINTSTRING(_imp_str_literal("Illegal constant exponent"));
goto U_1000;
// 835 w(8): print string("Numerical constant too big"); -> at
case_W_8:;
_imp_PRINTSTRING(_imp_str_literal("Numerical constant too big"));
goto U_1000;
// 836 at: newline
U_1000:;
_imp_NEWLINE();
// 837 select output(object)
_imp_SELECTOUTPUT(2);
// 838 %end
return;
case_W_dispatch:
if (W_index < 1 || W_index > 8)
_imp_signalf(6, 3, W_index, "->W(%d) out of bounds at %s line %d", W_index, W_file, W_line);
goto *W[W_index - 1];
case_W_missing:
_imp_signalf(8, 2, W_index, "switch jump to undefined label W(%d): at %s line %d", W_index, W_file, W_line);
} /* end of WARN */
// 839
// 840 ! >> MONITOR <<
// 841 %routine monitor(%record(stackfm)%name v, %string(15) text)
void MONITOR(struct STACKFM * V, _imp_string15 TEXT) {
// 842 select output(report)
_imp_SELECTOUTPUT(0);
// 843 print string(text); print symbol(':')
_imp_PRINTSTRING(
*({
__typeof__(_imp_string15) tmp = TEXT /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_PRINTSYMBOL(58);
// 844 spaces(9-length(text))
_imp_SPACES(9 - *_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &TEXT));
// 845 show(v)
SHOW(V);
// 846 select output(object)
_imp_SELECTOUTPUT(2);
// 847 %end
return;
} /* end of MONITOR */
// 848
// 849 ! >> FLOATING <<
// 850 %predicate floating(%record(stackfm)%name v)
int FLOATING(struct STACKFM * V) {
// 851 ! check descriptor for floating point quantity
// 852 %true %if (v_type >= reals %and v_type # 255) %or (v_oper # 0 %c
if (V->TYPE < 7) goto L_000F;
if (V->TYPE != 255) goto L_0005;
L_000F:;
if (V->OPER == 0) goto L_0010;
if (V->LINK->TYPE < 7) goto L_0010;
L_0005:;
return 1 /*TRUE*/;
L_0010:;
// 853+ %and v_link_type >= reals)
// 854 %true %if v_oper >= rexp
if (V->OPER < 16) goto L_0011;
return 1 /*TRUE*/;
L_0011:;
// 855 %false
return 0 /*FALSE*/;
// 856 %end
} /* end of FLOATING */
// 857
// 858 ! >> ZERO <<
// 859 %predicate zero(%record(stackfm)%name v)
int ZERO(struct STACKFM * V) {
// 860 ! CHECK DESCRIPTOR FOR (INTEGER) ZERO
// 861 %false %if v_disp # 0 %or v_base # 0 %or constant # v_form # AV in S
if (V->DISP != 0) goto L_0012;
if (V->BASE != 0) goto L_0012;
{
// Double-sided test on V->FORM (Part I)
int tmp;
if (0 == (tmp = V->FORM)) goto L_0013;
// Double-sided test on V->FORM (Part II)
if (tmp == 5) goto L_0013;
}
L_0012:;
return 0 /*FALSE*/;
L_0013:;
// 862 %false %if v_oper # 0
if (V->OPER == 0) goto L_0014;
return 0 /*FALSE*/;
L_0014:;
// 863 %true
return 1 /*TRUE*/;
// 864 %end
} /* end of ZERO */
// 865
// 866 ! >> CONST <<
// 867 %predicate const(%record(stackfm)%name v)
int CONST(struct STACKFM * V) {
// 868 ! CHECK DESCRIPTOR FOR CONSTANT (INTEGER) VALUE
// 869 %false %unless v_form = constant %and v_oper = 0
if (V->FORM != 0) goto L_0015;
if (V->OPER == 0) goto L_0016;
L_0015:;
return 0 /*FALSE*/;
L_0016:;
// 870 %false %if v_type > byte
if (V->TYPE <= 3) goto L_0017;
return 0 /*FALSE*/;
L_0017:;
// 871 %true
return 1 /*TRUE*/;
// 872 %end
} /* end of CONST */
// 873
// 874 %integerfn Min Record Size(%record(stackfm)%name A, B)
int MINRECORDSIZE(struct STACKFM * A, struct STACKFM * B) {
// 875 %integer N, M
int N;
int M;
// 876 N = A_Format; N = Var(N)_Length&x'FFFF' %if N # 0
N = A->FORMAT;
if (N == 0) goto L_0018;
N = VAR[N].LENGTH & 65535;
L_0018:;
// 877 M = B_Format; M = Var(M)_Length&x'FFFF' %if M # 0
M = B->FORMAT;
if (M == 0) goto L_0019;
M = VAR[M].LENGTH & 65535;
L_0019:;
// 878 N = M %if N = 0 %or (M # 0 %and M < N)
if (N == 0) goto L_001A;
if (M == 0) goto L_001B;
if (M >= N) goto L_001B;
L_001A:;
N = M;
L_001B:;
// 879 %result = N %if N > 0
if (N <= 0) goto L_001C;
return N;
L_001C:;
// 880 Abort(m'Rec0')
ABORT(1382376240);
// 881 %end
_imp_signal(8, 4, 0, "result missing");
} /* end of MINRECORDSIZE */
// 882 ! >> SAME <<
// 883 %integerfn POWER(%integer n)
int POWER(int N) {
// 884 %integer j, ref
int J;
int REF;
// 885 ref = 1
REF = 1;
// 886 %for j = 1, 1, 14 %cycle
// %for J = 1, 1, 14 %cycle
{
J = 0;
L_001D:
if (J == 14) goto L_001E;
J += 1;
// 887 ref = ref<<1
REF = REF << 1;
// 888 %if ref >= n %start
if (REF < N) goto L_0020;
// 889 %if ref = n %then %result = j %else %result = -1
if (REF != N) goto L_0021;
return J;
L_0021:;
return -1;
// 890 %finish
L_0020:;
// 891 %repeat
goto L_001D;
}
L_001E:;
// 892 %result = -1
return -1;
// 893 %end
} /* end of POWER */
// 894
// 895 %predicate same(%record(stackfm)%name v,w)
int SAME(struct STACKFM * V, struct STACKFM * W) {
// 896 ! Test whether or not V and W describe the same object.
// 897 %true %if v_disp = w_disp %and v_base = w_base %c
if (V->DISP != W->DISP) goto L_0022;
if (V->BASE != W->BASE) goto L_0022;
if (V->TYPE != W->TYPE) goto L_0022;
if (V->FORM != W->FORM) goto L_0022;
if (V->EXTRA != W->EXTRA) goto L_0022;
return 1 /*TRUE*/;
L_0022:;
// 898+ %and v_type = w_type %and v_form = w_form %and v_extra = w_extra
// 899 %false
return 0 /*FALSE*/;
// 900 %end
} /* end of SAME */
// 901
// 902 ! >> IN FREE REG <<
// 903 %predicate in free reg(%record(stackfm)%name v)
int INFREEREG(struct STACKFM * V) {
// 904 ! TRUE if v is in a useable register
// 905 %false %unless v_form = v in r %and activity(v_base) <= 1
if (V->FORM != 1) goto L_001F;
if (ACTIVITY[V->BASE] <= 1) goto L_0023;
L_001F:;
return 0 /*FALSE*/;
L_0023:;
// 906 %true
return 1 /*TRUE*/;
// 907 %end
} /* end of INFREEREG */
// 908
// 909 ! >> TEMP <<
// 910 %integerfn temp
int TEMP(void) {
// 911 ! Allocate a temporary 4 bytes long
// 912 %integer t
int T;
// 913 %if next temp = new temp %start; ! no spare temps outstanding
if (NEXTTEMP != NEWTEMP) goto L_0024;
// 914 t = (frame+3)&(\3)
T = FRAME + 3 & (~3);
// 915 frame = t+4
FRAME = T + 4;
// 916 %result = t %if new temp = max temps; ! temp buffer overflow
if (NEWTEMP != 60) goto L_0025;
return T;
L_0025:;
// 917 new temp = new temp + 1
NEWTEMP = NEWTEMP + 1;
// 918 temps(new temp) = t
TEMPS[NEWTEMP - 1] = T;
// 919 %finish
L_0024:;
// 920 next temp = next temp + 1
NEXTTEMP = NEXTTEMP + 1;
// 921 %result = temps(next temp)&x'FFFF'
return TEMPS[NEXTTEMP - 1] & 65535;
// 922 %end
} /* end of TEMP */
// 923
// 924 ! >> TAG <<
// 925 %integerfn tag
int TAG(void) {
// 926 %integer s1, s2
int S1;
int S2;
// 927 s1 = next
S1 = NEXT;
// 928 readsymbol(s2)
_imp_READSYMBOL(/*?*/ &S2);
// 929 readsymbol(next)
_imp_READSYMBOL(/*?*/ &NEXT);
// 930 %result = s1<<8!s2
return S1 << 8 | S2;
// 931 %end
} /* end of TAG */
// 932
// 933 ! >> GET D <<
// 934 %routine get d
void GETD(void) {
// 935 %longreal p
double P;
// 936 %integer i, n
int I;
int N;
// 937 %real ten,one
float TEN;
float ONE;
// 938 n = 10 ; rvalue = n {initial base}
N = 10;
RVALUE = N;
// 939 n = 1; one = n
N = 1;
ONE = N;
// 940 n = tag; read symbol(next); ! Skip comma
N = TAG();
_imp_READSYMBOL(/*?*/ &NEXT);
// 941 BASE:
U_1001:;
// 942 ten = rvalue
TEN = RVALUE;
// 943 rvalue = 0
RVALUE = 0;
// 944 %cycle
L_0026:;
// 945 sym = next; read symbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 946 %exit %if sym = '.'
if (SYM != 46) goto L_0027;
goto L_0028;
L_0027:;
// 947 n = n-1
N = N - 1;
// 948 -> power %if sym = '@'
if (SYM != 64) goto L_0029;
goto U_1002;
L_0029:;
// 949 -> base %if sym = '_'
if (SYM != 95) goto L_002A;
goto U_1001;
L_002A:;
// 950 sym = sym-'A'+'0'+10 %if sym >= 'A'
if (SYM < 65) goto L_002B;
SYM = SYM - 65 + 48 + 10;
L_002B:;
// 951 rvalue = rvalue*ten+(sym-'0')
RVALUE = RVALUE * TEN + (SYM - 48);
// 952 -> SIGN %if n = 0
if (N != 0) goto L_002C;
goto U_1003;
L_002C:;
// 953 %repeat
goto L_0026;
L_0028:;
// 954 p = one
P = ONE;
// 955 %cycle
L_002D:;
// 956 n = n-1; -> SIGN %if n = 0
N = N - 1;
if (N != 0) goto L_002E;
goto U_1003;
L_002E:;
// 957 sym = next; read symbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 958 -> POWER %if sym = '@'
if (SYM != 64) goto L_002F;
goto U_1002;
L_002F:;
// 959 sym = sym-'A'+'0'+10 %if sym >= 'A'
if (SYM < 65) goto L_0030;
SYM = SYM - 65 + 48 + 10;
L_0030:;
// 960 p = p/ten
P = (double)(P / TEN);
// 961 rvalue = rvalue + (sym-'0')*p
RVALUE = RVALUE + (SYM - 48) * P;
// 962 %repeat
goto L_002D;
// 963 POWER:
U_1002:;
// 964 n = tag
N = TAG();
// 965 n = n ! 16_FFFF0000 %if n&16_8000 # 0
if (N & 32768 == 0) goto L_0031;
N = N | (-65536);
L_0031:;
// 966 rvalue = rvalue * (ten^n)
RVALUE = RVALUE * (_imp_REXP(TEN, N));
// 967 SIGN: ! sign of whole value
U_1003:;
// 968 %if next = 'U' %start
if (NEXT != 85) goto L_0032;
// 969 read symbol(next)
_imp_READSYMBOL(/*?*/ &NEXT);
// 970 rvalue = -rvalue
RVALUE = -RVALUE;
// 971 %finish
L_0032:;
// 972 %end
return;
} /* end of GETD */
// ?I unused
// 973
// 974 ! >> RELEASE <<
// 975 %routine release(%integer reg)
void RELEASE(int REG) {
// 976 ! Hazard the value in a register
// 977 abort(m'REL1') %if reg > fr14
if (REG <= 24) goto L_0033;
ABORT(1380273201);
L_0033:;
// 978 %return %if reg = 0 %or activity(reg) < 0; ! LOCKED
if (REG == 0) goto L_0034;
if (ACTIVITY[REG] >= 0) goto L_0035;
L_0034:;
return;
L_0035:;
// 979 activity(reg) = activity(reg)-1
ACTIVITY[REG] = ACTIVITY[REG] - 1;
// 980 abort(m'REL2') %if activity(reg) < 0
if (ACTIVITY[REG] >= 0) goto L_0036;
ABORT(1380273202);
L_0036:;
// 981 claimed = claimed - 1
CLAIMED = CLAIMED - 1;
// 982 %end
return;
} /* end of RELEASE */
// 983
// 984 ! >> CLAIM <<
// 985 %routine claim(%integer reg)
void CLAIM(int REG) {
// 986 ! Cherish the value in a register
// 987 abort(m'CLM1') %if reg > fr14
if (REG <= 24) goto L_0037;
ABORT(1129073969);
L_0037:;
// 988 %return %if reg = 0 %or activity(reg) < 0
if (REG == 0) goto L_0038;
if (ACTIVITY[REG] >= 0) goto L_0039;
L_0038:;
return;
L_0039:;
// 989 activity(reg) = activity(reg)+1
ACTIVITY[REG] = ACTIVITY[REG] + 1;
// 990 claimed = claimed+1
CLAIMED = CLAIMED + 1;
// 991 %end
return;
} /* end of CLAIM */
auto void FORGETREG(int REGMASK);
auto void FORGETALL(void);
auto void FORGETVAR(struct STACKFM * V);
// 992
// 993 %routinespec forget reg(%integer mask)
// 994 %routinespec forget all
// 995 %routinespec forget var(%record(stackfm)%name v)
// 996 ! >> HAZARD <<
// 997 %routine hazard(%integer reg)
void HAZARD(int REG) {
// 998 ! Protect the value in register REG by storing in a temporary.
// 999 %integer n, t, tot
int N;
int T;
int TOT;
// 1000 %record(dfm)%name p
struct DFM *P;
// 1001 %record(stackfm) u
struct STACKFM U;
// 1002 %routine mod(%record(stackfm)%name v)
void MOD(struct STACKFM * V) {
// 1003 %switch sw(0:a in rec)
int SW_index;
int SW_line;
char *SW_file;
static const void *SW[10] = {&&case_SW_missing, &&case_SW_missing, &&case_SW_missing, &&case_SW_missing,
&&case_SW_missing, &&case_SW_missing, &&case_SW_missing, &&case_SW_missing,
&&case_SW_missing, &&case_SW_missing};
// 1004 v_base = local
V->BASE = LOCAL;
// 1005 n = n-1
N = N - 1;
// 1006 -> sw(v_form)
SW_line = __LINE__;
SW_file = __FILE__;
SW_index = V->FORM;
goto case_SW_dispatch;
// 1007 sw(a in rec):
case_SW_9:;
// 1008 sw(av in rec):
case_SW_8:;
// 1009 sw(v in rec):
case_SW_7:;
// 1010 %if tot = 1 %start
if (TOT != 1) goto L_003B;
// 1011 claim(reg); rx(lw,reg,reg,v_extra)
CLAIM(REG);
RX(1, REG, REG, V->EXTRA);
// 1012 u_type = integers
U.TYPE = 1;
// 1013 v_extra = t
V->EXTRA = T;
// 1014 -> OUT2
goto U_1004;
// 1015 %finish
L_003B:;
// 1016 sw(constant): abort(m'HAZ1')
case_SW_0:;
ABORT(1212242481);
// 1017 sw(v in s): %if v_disp = 0 %start
case_SW_4:;
if (V->DISP != 0) goto L_003C;
// 1018 v_disp = t; v_form = a in s; ->out1
V->DISP = T;
V->FORM = 6;
goto U_1005;
// 1019 %finish
L_003C:;
// 1020 sw(a in s):
case_SW_6:;
// 1021 sw(av in s):
case_SW_5:;
// 1022 ! change (X in S) to (X in REC)
// 1023 v_form = v_form + 3; v_extra = t; -> OUT1
V->FORM = V->FORM + 3;
V->EXTRA = T;
goto U_1005;
// 1024 sw(v in r): v_form = v in s; v_disp = t
case_SW_1:;
V->FORM = 4;
V->DISP = T;
// 1025 v_type = u_type
V->TYPE = U.TYPE;
// 1026 OUT1:
U_1005:;
// 1027 v_flag = v_flag ! assigned
V->FLAG = V->FLAG | 8;
// 1028 OUT2:
U_1004:;
// 1029 %end
return;
case_SW_dispatch:
if (SW_index < 0 || SW_index > 9)
_imp_signalf(6, 3, SW_index, "->SW(%d) out of bounds at %s line %d", SW_index, SW_file, SW_line);
goto *SW[SW_index - 0];
case_SW_missing:
_imp_signalf(8, 2, SW_index, "switch jump to undefined label SW(%d): at %s line %d", SW_index, SW_file, SW_line);
} /* end of MOD */
// 1030
// 1031 n = activity(reg); %return %if n <= 0; ! NOT IN USE OR CLAIMED
N = ACTIVITY[REG];
if (N > 0) goto L_003D;
return;
L_003D:;
// 1032 tot = n
TOT = N;
// 1033 claimed = claimed - n
CLAIMED = CLAIMED - N;
// 1034 activity(reg) = 0
ACTIVITY[REG] = 0;
// 1035 t = temp; ! ** needs a parameter to deal with 8-byte reals **
T = TEMP();
// 1036 u_type = integers
U.TYPE = 1;
// 1037 u_type = reals %if FR0 <= reg <= FR14
{
// Double-sided test on REG (Part I)
int tmp;
if (17 > (tmp = REG)) goto L_003E;
// Double-sided test on REG (Part II)
if (tmp > 24) goto L_003E;
}
U.TYPE = 7;
L_003E:;
// 1038 p == using_link
P = (struct DFM *)USING.LINK;
// 1039 %cycle
L_003F:;
// 1040 %exit %if p == null
if (_imp_ADDR((void *)(P)) != _imp_ADDR((void *)(NULL))) goto L_0040;
goto L_0041;
L_0040:;
// 1041 mod(p_d) %if p_d_base = reg
if (P->D->BASE != REG) goto L_0042;
MOD(P->D);
L_0042:;
// 1042 p == p_link
P = (struct DFM *)P->LINK;
// 1043 %repeat
goto L_003F;
L_0041:;
// 1044 u_xbase = local; u_disp = t
U.XBASE = LOCAL;
U.DISP = T;
// 1045 u_xform = V in S ! (assigned << 8)
U.XFORM = 4 | 8 << 8;
// 1046 rxd(st,reg,u)
RXD(2, REG, /*?*/ &U);
// 1047 forget var(u)
FORGETVAR(/*?*/ &U);
// 1048 abort(m'HAZ2') %if n # 0; ! USE STILL OUTSTANDING
if (N == 0) goto L_0043;
ABORT(1212242482);
L_0043:;
// 1049 %end
return;
} /* end of HAZARD */
// 1050
// 1051 ! >> HAZARD ALL <<
// 1052 %routine hazard all
void HAZARDALL(void) {
// 1053 %integer j
int J;
// 1054 forget reg(-1)
FORGETREG(-1);
// 1055 %if claimed # 0 %start; ! at least one register claimed
if (CLAIMED == 0) goto L_0044;
// 1056 hazard(j) %for j = r0,1,fr14
// %for J = 1, 1, 24 %cycle
{
J = 0;
L_0045:
if (J == 24) goto L_0046;
J += 1;
HAZARD(J);
goto L_0045;
}
L_0046:;
// 1057 %finish
L_0044:;
// 1058 %end
return;
} /* end of HAZARDALL */
// 1059
// 1060 ! REGISTER OPTIMISATION ROUTINES
// 1061 %constinteger register contents = 1
// 1062
// 1063 %routine Reset Optimisation Data
void RESETOPTIMISATIONDATA(void) {
// 1064 %integer J
int J;
// 1065 Last Gpr = 1
LASTGPR = 1;
// 1066 Last Fpr = Fr0
LASTFPR = 17;
// 1067 Last EO = 1
LASTEO = 1;
// 1068 Envp = 0
ENVP = 0;
// 1069 Known Regs = -1
KNOWNREGS = -1;
// 1070 In Use = 0
INUSE = 0;
// 1071 Kasl == Null
KASL = (struct KFM *)NULL;
// 1072 Klist == Null
KLIST = (struct KFM *)NULL;
// 1073 %for j = 1,1,max knowledge %cycle
// %for J = 1, 1, 120 %cycle
{
J = 0;
L_0047:
if (J == 120) goto L_0048;
J += 1;
// 1074 knowledge(j)_Link == Kasl
KNOWLEDGE[J - 1].LINK = (struct KFM *)KASL;
// 1075 Kasl == knowledge(j)
KASL = (struct KFM *)/*?*/ &KNOWLEDGE[J - 1];
// 1076 %repeat
goto L_0047;
}
L_0048:;
// 1077 %for j = 1,1,max envirs %cycle
// %for J = 1, 1, 5 %cycle
{
J = 0;
L_004A:
if (J == 5) goto L_004B;
J += 1;
// 1078 Envir(j)_Label = 0
ENVIR[J - 1].LABEL = 0;
// 1079 Envir(j)_Link == Null
ENVIR[J - 1].LINK = (struct ENVFM *)NULL;
// 1080 %repeat
goto L_004A;
}
L_004B:;
// 1081 %end
return;
} /* end of RESETOPTIMISATIONDATA */
// 1082
// 1083 ! >> DUMP OPT LIST <<
// 1084 %routine dump opt list
void DUMPOPTLIST(void) {
// 1085 %record(kfm)%name p
struct KFM *P;
// 1086 select output(report)
_imp_SELECTOUTPUT(0);
// 1087 p == klist
P = (struct KFM *)KLIST;
// 1088 %if p == null %start
if (_imp_ADDR((void *)(P)) != _imp_ADDR((void *)(NULL))) goto L_004C;
// 1089 print string("*opt list empty")
_imp_PRINTSTRING(_imp_str_literal("*opt list empty"));
// 1090 newline
_imp_NEWLINE();
// 1091 %else
goto L_004D;
L_004C:;
// 1092 %cycle
L_004E:;
// 1093 write(p_type,1); write(p_form,1)
_imp_WRITE(P->TYPE, 1);
_imp_WRITE(P->FORM, 1);
// 1094 write(p_disp,3); print symbol('(')
_imp_WRITE(P->DISP, 3);
_imp_PRINTSYMBOL(40);
// 1095 write(p_base,-1); print string(") =")
_imp_WRITE(P->BASE, -1);
_imp_PRINTSTRING(_imp_str_literal(") ="));
// 1096 write(p_reg,1); newline
_imp_WRITE(P->REG, 1);
_imp_NEWLINE();
// 1097 p == p_link
P = (struct KFM *)P->LINK;
// 1098 %repeat %until p == null
if (_imp_ADDR((void *)(P)) == _imp_ADDR((void *)(NULL))) goto L_004F;
goto L_004E;
L_004F:;
// 1099 %finish
L_004D:;
// 1100 select output(object)
_imp_SELECTOUTPUT(2);
// 1101 %end; ! dump opt list
return;
} /* end of DUMPOPTLIST */
// 1102
// 1103 ! >> K ENTRY <<
// 1104 %record(kfm)%map k entry(%record(stackfm)%name v, %integer fuzz)
struct KFM *KENTRY(struct STACKFM * V, int FUZZ)
{
// 1105 %record(kfm)%name p,q
struct KFM *P;
struct KFM *Q;
// 1106 fuzz = \fuzz
FUZZ = (~FUZZ);
// 1107 p == k list
P = (struct KFM *)KLIST;
// 1108 q == null
Q = (struct KFM *)NULL;
// 1109 %while %not p == null %cycle
L_0050:;
if (_imp_ADDR((void *)(P)) == _imp_ADDR((void *)(NULL))) goto L_0051;
// 1110 -> FOUND %if (p_disp!!v_disp)&fuzz = 0 %and p_base = v_base
if ((P->DISP ^ V->DISP) & FUZZ != 0) goto L_0052;
if (P->BASE != V->BASE) goto L_0052;
goto U_1006;
L_0052:;
// 1111 q == p
Q = (struct KFM *)P;
// 1112 p == p_link
P = (struct KFM *)P->LINK;
// 1113 %repeat
goto L_0050;
L_0051:;
// 1114 %result == null; ! failure
return NULL;
// 1115 FOUND:
U_1006:;
// 1116 %if %not q == null %start; ! promote if not first item already
if (_imp_ADDR((void *)(Q)) == _imp_ADDR((void *)(NULL))) goto L_0053;
// 1117 q_link == p_link
Q->LINK = (struct KFM *)P->LINK;
// 1118 p_link == klist
P->LINK = (struct KFM *)KLIST;
// 1119 klist == p
KLIST = (struct KFM *)P;
// 1120 %finish
L_0053:;
// 1121 %result == klist
return KLIST;
// 1122 %end; ! k entry
} /* end of KENTRY */
// 1123
// 1124 ! >> NEW KCELL <<
// 1125 %record(kfm)%map new kcell
struct KFM *NEWKCELL(void)
{
// 1126 %record(kfm)%name p, q
struct KFM *P;
struct KFM *Q;
// 1127 %integer n
int N;
// 1128 %if kasl == null %or in use >= max use %start; ! no free cells left
if (_imp_ADDR((void *)(KASL)) == _imp_ADDR((void *)(NULL))) goto L_0049;
if (INUSE < 20) goto L_0054;
L_0049:;
// 1129 ! In extremis so reclaim last item from KLIST.
// 1130 p == klist; q == null
P = (struct KFM *)KLIST;
Q = (struct KFM *)NULL;
// 1131 n = max use
N = 20;
// 1132 %cycle
L_0055:;
// 1133 n = n-1
N = N - 1;
// 1134 %exit %if p_link == null
if (_imp_ADDR((void *)(P->LINK)) != _imp_ADDR((void *)(NULL))) goto L_0056;
goto L_0057;
L_0056:;
// 1135 q == p
Q = (struct KFM *)P;
// 1136 p == p_link
P = (struct KFM *)P->LINK;
// 1137 %repeat
goto L_0055;
L_0057:;
// 1138 abort(m'OPT1') %if n # 0
if (N == 0) goto L_0058;
ABORT(1330664497);
L_0058:;
// 1139 q_link == null; ! truncate KLIST
Q->LINK = (struct KFM *)NULL;
// 1140 p_link == kasl; kasl == p; !give on back
P->LINK = (struct KFM *)KASL;
KASL = (struct KFM *)P;
// 1141 in use = in use-1
INUSE = INUSE - 1;
// 1142 %finish
L_0054:;
// 1143 p == kasl; kasl == kasl_link
P = (struct KFM *)KASL;
KASL = (struct KFM *)KASL->LINK;
// 1144 in use = in use+1; abort(m'Opt3') %if in use > max use
INUSE = INUSE + 1;
if (INUSE <= 20) goto L_0059;
ABORT(1332769843);
L_0059:;
// 1145 p = 0
*P = (struct KFM){0};
// 1146 %result == p
return P;
// 1147 %end; ! new kcell
} /* end of NEWKCELL */
// 1148
// 1149 ! >> ASSOCIATE <<
// 1150 %routine associate(%record(stackfm)%name v, %integer reg)
void ASSOCIATE(struct STACKFM * V, int REG) {
// 1151 %record(kfm)%name p
struct KFM *P;
// 1152 %return %if reg = R0 %or V_Base = Reg
if (REG == 1) goto L_005A;
if (V->BASE != REG) goto L_005B;
L_005A:;
return;
L_005B:;
// 1153 p == k entry(v,0)
P = (struct KFM *)KENTRY(V, 0);
// 1154 %if p == null %start; ! new entry
if (_imp_ADDR((void *)(P)) != _imp_ADDR((void *)(NULL))) goto L_005C;
// 1155 p == new kcell
P = (struct KFM *)NEWKCELL();
// 1156 p_link == klist
P->LINK = (struct KFM *)KLIST;
// 1157 klist == p
KLIST = (struct KFM *)P;
// 1158 %else; ! re-use this cell
goto L_005D;
L_005C:;
// 1159 forget reg(1<<p_reg)
FORGETREG(1 << P->REG);
// 1160 %finish
L_005D:;
// 1161 p_reg = reg
P->REG = REG;
// 1162 p_base = v_base
P->BASE = V->BASE;
// 1163 p_disp = v_disp
P->DISP = V->DISP;
// 1164 p_type = v_type
P->TYPE = V->TYPE;
// 1165 p_form = v_form
P->FORM = V->FORM;
// 1166 p_ktype = register contents
P->KTYPE = 1;
// 1167 known regs = known regs ! (1<<reg)
KNOWNREGS = KNOWNREGS | 1 << REG;
// 1168 known regs = known regs ! (1<<p_base) %if activity(p_base) >= 0; ! unlocked ?
if (ACTIVITY[P->BASE] < 0) goto L_005E;
KNOWNREGS = KNOWNREGS | 1 << P->BASE;
L_005E:;
// 1169 %end; ! associate
return;
} /* end of ASSOCIATE */
// 1170
// 1171 ! >> CHEAPEN <<
// 1172 %routine cheapen(%record(stackfm)%name v, %integer mode)
void CHEAPEN(struct STACKFM * V, int MODE) {
// 1173 !! modes: >= 0: looking for value
// 1174 ! < 1: looking for address
// 1175 %record(kfm)%name p
struct KFM *P;
// 1176 %integer reg, form, type
int REG;
int FORM;
int TYPE;
// 1177 form = v_form; type = v_type
FORM = V->FORM;
TYPE = V->TYPE;
// 1178 p == k entry(v,0)
P = (struct KFM *)KENTRY(V, 0);
// 1179 %return %if p == null
if (_imp_ADDR((void *)(P)) != _imp_ADDR((void *)(NULL))) goto L_005F;
return;
L_005F:;
// 1180 v_flag = v_flag ! assigned %if p_form = V in S; ! it's at least assigned
if (P->FORM != 4) goto L_0060;
V->FLAG = V->FLAG | 8;
L_0060:;
// 1181 %return %if p_reg = 0; !*psr* Nothing known
if (P->REG != 0) goto L_0061;
return;
L_0061:;
// 1182 cheap reg = p_reg %if form # AinS %and p_type = Type
if (FORM == 6) goto L_0062;
if (P->TYPE != TYPE) goto L_0062;
CHEAPREG = P->REG;
L_0062:;
// 1183 %return %if mode < 0 %and form = V in S; ! V in S on left-hand side
if (MODE >= 0) goto L_0063;
if (FORM != 4) goto L_0063;
return;
L_0063:;
// 1184 reg = p_reg
REG = P->REG;
// 1185 %if form = A in S %and p_type = integers %and p_form = V in S %start
if (FORM != 6) goto L_0064;
if (P->TYPE != 1) goto L_0064;
if (P->FORM != 4) goto L_0064;
// 1186 release(v_base); claim(reg)
RELEASE(V->BASE);
CLAIM(REG);
// 1187 v_base = reg; v_disp = 0; v_Xform = V in S {changed to Xform - PSR}
V->BASE = REG;
V->DISP = 0;
V->XFORM = 4;
// 1188 cheapen(v,mode)
CHEAPEN(V, MODE);
// 1189 %else
goto L_0065;
L_0064:;
// 1190 %return %if p_type # type %or p_form # form
if (P->TYPE != TYPE) goto L_0009;
if (P->FORM == FORM) goto L_0066;
L_0009:;
return;
L_0066:;
// 1191 release(v_base); claim(reg)
RELEASE(V->BASE);
CLAIM(REG);
// 1192 v_base = reg; v_disp = 0; v_Xform = V in R {changed to Xform - PSR}
V->BASE = REG;
V->DISP = 0;
V->XFORM = 1;
// 1193 %finish
L_0065:;
// 1194 %if diagnose < 0 %start
if (DIAGNOSE >= 0) goto L_0067;
// 1195 monitor(v, "CHEAPENED")
MONITOR(V, _imp_str_literal_size(15, "CHEAPENED"));
// 1196 dump opt list %if diagnose & 16 # 0
if (DIAGNOSE & 16 == 0) goto L_0068;
DUMPOPTLIST();
L_0068:;
// 1197 %finish
L_0067:;
// 1198 %end; ! cheapen
return;
} /* end of CHEAPEN */
// 1199
// 1200 !!! * * * * * This needs to be a bit brighter * * * * *
// 1201 ! >> FORGET VAR <<
// 1202 %routine forget var(%record(stackfm)%name v)
void FORGETVAR(struct STACKFM * V) {
// 1203 %record(kfm)%name p
struct KFM *P;
// 1204 !!!!! p == k entry(v, align)
// 1205 !!!!! forget reg(1<<p_reg) %unless p == null
// 1206
// 1207 %cycle
L_0069:;
// 1208 p == k entry(V, align)
P = (struct KFM *)KENTRY(V, 3);
// 1209 %return %if p == null
if (_imp_ADDR((void *)(P)) != _imp_ADDR((void *)(NULL))) goto L_006A;
return;
L_006A:;
// 1210 p_base = anyf+1 {invalid entry}
P->BASE = 26 + 1;
// 1211 %repeat
goto L_0069;
// 1212
// 1213 %end; ! forget var
} /* end of FORGETVAR */
// 1214
// 1215 ! >> FORGET REG <<
// 1216 %routine forget reg(%integer reg mask)
void FORGETREG(int REGMASK) {
// 1217 %record(kfm)%name p
struct KFM *P;
// 1218 %return %if known regs & reg mask = 0; ! for speed: nothing to do
if (KNOWNREGS & REGMASK != 0) goto L_006B;
return;
L_006B:;
// 1219 reg mask = reg mask & (\1); ! R0 = 1 not 0
REGMASK = REGMASK & (~1);
// 1220 known regs = known regs & (\reg mask)
KNOWNREGS = KNOWNREGS & (~REGMASK);
// 1221 p == klist
P = (struct KFM *)KLIST;
// 1222 %if reg mask < 0 %start; ! forget the lot
if (REGMASK >= 0) goto L_006C;
// 1223 %while %not p == null %cycle
L_006D:;
if (_imp_ADDR((void *)(P)) == _imp_ADDR((void *)(NULL))) goto L_006E;
// 1224 p_base = anyf+1 %if regmask & (1<<p_base) # 0; ! invalidate entry
if (REGMASK & 1 << P->BASE == 0) goto L_006F;
P->BASE = 26 + 1;
L_006F:;
// 1225 p_reg = 0
P->REG = 0;
// 1226 p == p_link
P = (struct KFM *)P->LINK;
// 1227 %repeat
goto L_006D;
L_006E:;
// 1228 %else; ! selective forget
goto L_0070;
L_006C:;
// 1229 %while %not p == null %cycle
L_0071:;
if (_imp_ADDR((void *)(P)) == _imp_ADDR((void *)(NULL))) goto L_0072;
// 1230 p_base = anyf+1 %if reg mask & (1<<p_base) # 0; ! invalidate entry
if (REGMASK & 1 << P->BASE == 0) goto L_0073;
P->BASE = 26 + 1;
L_0073:;
// 1231 p_reg = 0 %if reg mask & (1<<p_reg) # 0; ! forget reg association
if (REGMASK & 1 << P->REG == 0) goto L_0074;
P->REG = 0;
L_0074:;
// 1232 p == p_link
P = (struct KFM *)P->LINK;
// 1233 %repeat
goto L_0071;
L_0072:;
// 1234 %finish
L_0070:;
// 1235 ! Clean up any old kcells which can be recovered easily
// 1236 %while klist ## null %and klist_base = anyf+1 %cycle
L_0075:;
if (_imp_ADDR((void *)(KLIST)) == _imp_ADDR((void *)(NULL))) goto L_0076;
if (KLIST->BASE != 26 + 1) goto L_0076;
// 1237 p == klist; klist == klist_link
P = (struct KFM *)KLIST;
KLIST = (struct KFM *)KLIST->LINK;
// 1238 p_link == kasl
P->LINK = (struct KFM *)KASL;
// 1239 kasl == p
KASL = (struct KFM *)P;
// 1240 in use = in use-1
INUSE = INUSE - 1;
// 1241 %repeat
goto L_0075;
L_0076:;
// 1242 abort(m'Use?') %if in use < 0
if (INUSE >= 0) goto L_0077;
ABORT(1433625919);
L_0077:;
// 1243 %end; ! forget reg
return;
} /* end of FORGETREG */
// 1244
// 1245 ! >> FORGET ALL <<
// 1246 %routine forget all
void FORGETALL(void) {
// 1247 %record(kfm)%name p
struct KFM *P;
// 1248 %if %not klist == null %start
if (_imp_ADDR((void *)(KLIST)) == _imp_ADDR((void *)(NULL))) goto L_0078;
// 1249 p == klist
P = (struct KFM *)KLIST;
// 1250 %cycle
L_0079:;
// 1251 in use = in use-1
INUSE = INUSE - 1;
// 1252 %exit %if p_link == null
if (_imp_ADDR((void *)(P->LINK)) != _imp_ADDR((void *)(NULL))) goto L_007A;
goto L_007B;
L_007A:;
// 1253 p == p_link
P = (struct KFM *)P->LINK;
// 1254 %repeat
goto L_0079;
L_007B:;
// 1255 p_link == kasl
P->LINK = (struct KFM *)KASL;
// 1256 kasl == klist
KASL = (struct KFM *)KLIST;
// 1257 klist == null
KLIST = (struct KFM *)NULL;
// 1258 %finish
L_0078:;
// 1259 abort(m'Fall') %unless in use = 0
if (INUSE == 0) goto L_007C;
ABORT(1180789868);
L_007C:;
// 1260 known regs = 0
KNOWNREGS = 0;
// 1261 %end; ! forget all
return;
} /* end of FORGETALL */
// 1262 !environment control
// 1263
// 1264 %record(envfm)%map environment(%integer label)
struct ENVFM *ENVIRONMENT(int LABEL)
{
// 1265 %record(envfm)%name E
struct ENVFM *E;
// 1266 %integer j
int J;
// 1267 %if label > 0 %start
if (LABEL <= 0) goto L_007D;
// 1268 %for j = 1,1,max envirs %cycle
// %for J = 1, 1, 5 %cycle
{
J = 0;
L_007E:
if (J == 5) goto L_007F;
J += 1;
// 1269 E == envir(j)
E = (struct ENVFM *)/*?*/ &ENVIR[J - 1];
// 1270 %result == E %if E_label = label
if (E->LABEL != LABEL) goto L_0081;
return E;
L_0081:;
// 1271 %repeat
goto L_007E;
}
L_007F:;
// 1272 %finish
L_007D:;
// 1273 %result == null
return NULL;
// 1274 %end
} /* end of ENVIRONMENT */
// 1275 %record(envfm)%map new env(%record(envfm)%name E)
struct ENVFM *NEWENV(struct ENVFM * E)
{
// 1276 %record(kfm)%name K
struct KFM *K;
// 1277 %if E == null %start
if (_imp_ADDR((void *)(E)) != _imp_ADDR((void *)(NULL))) goto L_0082;
// 1278 envp = envp+1; envp = 1 %if envp > max envirs
ENVP = ENVP + 1;
if (ENVP <= 5) goto L_0083;
ENVP = 1;
L_0083:;
// 1279 e == envir(envp)
E = (struct ENVFM *)/*?*/ &ENVIR[ENVP - 1];
// 1280 %finish
L_0082:;
// 1281 k == E_link
K = (struct KFM *)E->LINK;
// 1282 %unless k == null %start
if (_imp_ADDR((void *)(K)) == _imp_ADDR((void *)(NULL))) goto L_0084;
// 1283 k == k_link %while k_link ## null
L_0085:;
if (_imp_ADDR((void *)(K->LINK)) == _imp_ADDR((void *)(NULL))) goto L_0086;
K = (struct KFM *)K->LINK;
goto L_0085;
L_0086:;
// 1284 k_link == kasl
K->LINK = (struct KFM *)KASL;
// 1285 kasl == E_link
KASL = (struct KFM *)E->LINK;
// 1286 %finish
L_0084:;
// 1287 E_in use = 0
E->INUSE = 0;
// 1288 E_label = 0
E->LABEL = 0;
// 1289 E_link == null
E->LINK = (struct ENVFM *)NULL;
// 1290 %result == E
return E;
// 1291 %end
} /* end of NEWENV */
// 1292 %record(kfm)%map Ecopy(%record(kfm)%name L)
struct KFM *ECOPY(struct KFM * L)
{
// 1293 %record(kfm)%name K
struct KFM *K;
// 1294 %result == null %if l == null
if (_imp_ADDR((void *)(L)) != _imp_ADDR((void *)(NULL))) goto L_0087;
return NULL;
L_0087:;
// 1295 abort(m'Ecop') %if kasl == null
if (_imp_ADDR((void *)(KASL)) != _imp_ADDR((void *)(NULL))) goto L_0088;
ABORT(1164144496);
L_0088:;
// 1296 k == kasl; kasl == k_link
K = (struct KFM *)KASL;
KASL = (struct KFM *)K->LINK;
// 1297 k = l
*K = *L;
// 1298 k_link == Ecopy(l_link)
K->LINK = (struct KFM *)ECOPY(L->LINK);
// 1299 %result == k
return K;
// 1300 %end
} /* end of ECOPY */
// 1301 %routine restore environment(%integer label)
void RESTOREENVIRONMENT(int LABEL) {
// 1302 %record(envfm)%name E
struct ENVFM *E;
// 1303 %record(envfm) temp
struct ENVFM TEMP;
// 1304 temp_link == klist
TEMP.LINK = (struct ENVFM *)KLIST;
// 1305 e == new env(temp) {release current environment}
E = (struct ENVFM *)NEWENV(/*?*/ &TEMP);
// 1306 E == environment(label)
E = (struct ENVFM *)ENVIRONMENT(LABEL);
// 1307 %if E == null %start
if (_imp_ADDR((void *)(E)) != _imp_ADDR((void *)(NULL))) goto L_0089;
// 1308 klist == null
KLIST = (struct KFM *)NULL;
// 1309 known regs = 0
KNOWNREGS = 0;
// 1310 in use = 0
INUSE = 0;
// 1311 %else
goto L_008A;
L_0089:;
// 1312 klist == Ecopy(E_link)
KLIST = (struct KFM *)ECOPY(E->LINK);
// 1313 known regs = E_known
KNOWNREGS = E->KNOWN;
// 1314 in use = E_in use
INUSE = E->INUSE;
// 1315 %finish
L_008A:;
// 1316 %end
return;
} /* end of RESTOREENVIRONMENT */
// 1317 %routine remember environment(%integer label)
void REMEMBERENVIRONMENT(int LABEL) {
// 1318 %record(envfm)%name E
struct ENVFM *E;
// 1319 %return %if label <= 0
if (LABEL > 0) goto L_008B;
return;
L_008B:;
// 1320 E == environment(label)
E = (struct ENVFM *)ENVIRONMENT(LABEL);
// 1321 E == new env(E)
E = (struct ENVFM *)NEWENV(E);
// 1322 E_label = label
E->LABEL = LABEL;
// 1323 E_known = known regs
E->KNOWN = KNOWNREGS;
// 1324 E_in use = in use
E->INUSE = INUSE;
// 1325 E_link == Ecopy(klist)
E->LINK = (struct ENVFM *)ECOPY(KLIST);
// 1326 %end
return;
} /* end of REMEMBERENVIRONMENT */
// 1327 %routine merge environment(%integer label)
void MERGEENVIRONMENT(int LABEL) {
// 1328 %record(ENVFM)%name e
struct ENVFM *E;
// 1329 %record(kfm)%name K, end, X
struct KFM *K;
struct KFM *END;
struct KFM *X;
// 1330 %record(kfm) khead
struct KFM KHEAD;
// 1331 %routine MERGE(%record(kfm)%name K)
void MERGE(struct KFM * K) {
// 1332 %record(kfm)%name p
struct KFM *P;
// 1333 p == klist
P = (struct KFM *)KLIST;
// 1334 %while p ## null %cycle
L_008C:;
if (_imp_ADDR((void *)(P)) == _imp_ADDR((void *)(NULL))) goto L_008D;
// 1335 %if p_disp = k_disp %and
if (P->DISP != K->DISP) goto L_008E;
if (P->REG != K->REG) goto L_008E;
if (P->BASE != K->BASE) goto L_008E;
if (P->FORM != K->FORM) goto L_008E;
if (P->TYPE != K->TYPE) goto L_008E;
if (P->KTYPE != K->KTYPE) goto L_008E;
// 1336+ p_reg = k_reg %and
// 1337+ p_base = k_base %and
// 1338+ p_form = k_form %and
// 1339+ p_type = k_type %and
// 1340+ p_ktype= k_ktype %start
// 1341 {*****Beware when array opt is put in***}
// 1342 end_link == k
END->LINK = (struct KFM *)K;
// 1343 end == k
END = (struct KFM *)K;
// 1344 E_known = E_known ! (1<<p_reg) ! (1<<p_base)
E->KNOWN = E->KNOWN | 1 << P->REG | 1 << P->BASE;
// 1345 E_in use = E_in use+1
E->INUSE = E->INUSE + 1;
// 1346 %return
return;
// 1347 %finish
L_008E:;
// 1348 p == p_link
P = (struct KFM *)P->LINK;
// 1349 %repeat
goto L_008C;
L_008D:;
// 1350 k_link == kasl; kasl == k
K->LINK = (struct KFM *)KASL;
KASL = (struct KFM *)K;
// 1351 %end
return;
} /* end of MERGE */
// 1352 E == environment(label)
E = (struct ENVFM *)ENVIRONMENT(LABEL);
// 1353 %if E ## null %start
if (_imp_ADDR((void *)(E)) == _imp_ADDR((void *)(NULL))) goto L_008F;
// 1354 k == E_link
K = (struct KFM *)E->LINK;
// 1355 e_link == null
E->LINK = (struct ENVFM *)NULL;
// 1356 e_in use = 0
E->INUSE = 0;
// 1357 e_known = 0
E->KNOWN = 0;
// 1358 khead_link == null; end == khead
KHEAD.LINK = (struct KFM *)NULL;
END = (struct KFM *)/*?*/ &KHEAD;
// 1359 %while k ## null %cycle
L_0090:;
if (_imp_ADDR((void *)(K)) == _imp_ADDR((void *)(NULL))) goto L_0091;
// 1360 x == k_link
X = (struct KFM *)K->LINK;
// 1361 merge(k)
MERGE(K);
// 1362 k == x
K = (struct KFM *)X;
// 1363 %repeat
goto L_0090;
L_0091:;
// 1364 end_link == null
END->LINK = (struct KFM *)NULL;
// 1365 e_link == khead_link
E->LINK = (struct ENVFM *)KHEAD.LINK;
// 1366 %finish
L_008F:;
// 1367 %end
return;
} /* end of MERGEENVIRONMENT */
// 1368
// 1369 ! >> GPR <<
// 1370 %integerfn gpr
int GPR(void) {
// 1371 ! Get a general (integer) register
// 1372 %constinteger nregs=8
// 1373 %constbyteintegerarray pref(1:nregs) =
const unsigned char PREF[8] = {7, 6, 5, 10, 11, 12, 4, 13};
// 1374+ P1, P2, R4, R9, R10, R11, R3, R12
// 1375 %integer r,j,mask
int R;
int J;
int MASK;
// 1376 mask = known regs
MASK = KNOWNREGS;
// 1377 %cycle
L_0092:;
// 1378 %for j = 1,1,nregs %cycle
// %for J = 1, 1, 8 %cycle
{
J = 0;
L_0093:
if (J == 8) goto L_0094;
J += 1;
// 1379 Last Gpr = Last Gpr-1; Last Gpr = nregs %if Last Gpr = 0
LASTGPR = LASTGPR - 1;
if (LASTGPR != 0) goto L_0095;
LASTGPR = 8;
L_0095:;
// 1380 r = pref(Last Gpr)
R = PREF[LASTGPR - 1];
// 1381 %result = r %if activity(r) = 0 %and mask & (1<<r) = 0
if (ACTIVITY[R] != 0) goto L_0096;
if (MASK & 1 << R != 0) goto L_0096;
return R;
L_0096:;
// 1382 %repeat
goto L_0093;
}
L_0094:;
// 1383 %exit %if mask = 0
if (MASK != 0) goto L_0097;
goto L_0098;
L_0097:;
// 1384 mask = 0
MASK = 0;
// 1385 %repeat
goto L_0092;
L_0098:;
// 1386 hazard(R4)
HAZARD(5);
// 1387 %result = R4
return 5;
// 1388 %end
} /* end of GPR */
// 1389
// 1390 ! >> EVEN/ODD PAIR <<
// 1391 %integerfn even odd pair
int EVENODDPAIR(void) {
// 1392 ! Get an even/odd (integer) register pair
// 1393 ! the odd register is returned
// 1394 ! registers are hazarded here
// 1395 %constinteger regs = 3
// 1396 %constbyteintegerarray even(1:regs) = r2, r10, r4
const unsigned char EVEN[3] = {3, 11, 5};
// 1397 %integer j,r,mask
int J;
int R;
int MASK;
// 1398 mask = known regs
MASK = KNOWNREGS;
// 1399 %cycle
L_0099:;
// 1400 %for j = 1,1,regs %cycle
// %for J = 1, 1, 3 %cycle
{
J = 0;
L_009A:
if (J == 3) goto L_009B;
J += 1;
// 1401 Last EO = Last EO-1; Last EO = regs %if Last EO = 0
LASTEO = LASTEO - 1;
if (LASTEO != 0) goto L_009C;
LASTEO = 3;
L_009C:;
// 1402 r = even(Last EO)
R = EVEN[LASTEO - 1];
// 1403 %result = r+1 %if activity(r) = 0 %and activity(r+1) = 0 %c
if (ACTIVITY[R] != 0) goto L_009D;
if (ACTIVITY[R + 1] != 0) goto L_009D;
if (MASK & 3 << R != 0) goto L_009D;
return R + 1;
L_009D:;
// 1404+ %and mask & (3<<r) = 0
// 1405 %repeat
goto L_009A;
}
L_009B:;
// 1406 %exit %if mask = 0
if (MASK != 0) goto L_009E;
goto L_009F;
L_009E:;
// 1407 mask = 0
MASK = 0;
// 1408 %repeat
goto L_0099;
L_009F:;
// 1409 hazard(r2); hazard(r3); %result = r3
HAZARD(3);
HAZARD(4);
return 4;
// 1410 %end
} /* end of EVENODDPAIR */
// 1411
// 1412 ! >> FPR <<
// 1413 %integerfn fpr
int FPR(void) {
// 1414 ! get a floating point register
// 1415 %integer j,mask
int J;
int MASK;
// 1416 mask = known regs
MASK = KNOWNREGS;
// 1417 %cycle
L_00A0:;
// 1418 %for j = fr0,1,fr14 %cycle
// %for J = 17, 1, 24 %cycle
{
J = 16;
L_00A1:
if (J == 24) goto L_00A2;
J += 1;
// 1419 Last Fpr = Last Fpr-1; Last Fpr = fr14 %if Last Fpr = fr0-1
LASTFPR = LASTFPR - 1;
if (LASTFPR != 17 - 1) goto L_00A3;
LASTFPR = 24;
L_00A3:;
// 1420 %result = Last Fpr %if activity(Last Fpr) = 0
if (ACTIVITY[LASTFPR] != 0) goto L_00A4;
return LASTFPR;
L_00A4:;
// 1421 %repeat
goto L_00A1;
}
L_00A2:;
// 1422 %exit %if mask = 0
if (MASK != 0) goto L_00A5;
goto L_00A6;
L_00A5:;
// 1423 mask = 0
MASK = 0;
// 1424 %repeat
goto L_00A0;
L_00A6:;
// 1425 hazard(fr0)
HAZARD(17);
// 1426 %result = fr0
return 17;
// 1427 %end
} /* end of FPR */
// 1428
// 1429 !OBJECT FILE HANDLING ROUTINES
// 1430 ! >> PUT <<
// 1431 %routine put(%integer n)
void PUT(int N) {
// 1432 print symbol(n>>8); print symbol(n&255)
_imp_PRINTSYMBOL((unsigned int)N >> 8);
_imp_PRINTSYMBOL(N & 255);
// 1433 %end
return;
} /* end of PUT */
// 1434
// 1435 ! >> SELECT LITERAL AREA <<
// 1436 %routine select literal area
void SELECTLITERALAREA(void) {
// 1437 %integer k
int K;
// 1438 print symbol(lit area)
_imp_PRINTSYMBOL(13);
// 1439 abort(m'DMP1') %if ca < 0
if (CA >= 0) goto L_00A7;
ABORT(1145917489);
L_00A7:;
// 1440 k = lita; lita = ca; ca = k
K = LITA;
LITA = CA;
CA = K;
// 1441 %end
return;
} /* end of SELECTLITERALAREA */
// 1442
// 1443 ! >> SELECT CODE AREA <<
// 1444 %routine select code area
void SELECTCODEAREA(void) {
// 1445 %integer k
int K;
// 1446 abort(m'DMP2') %if ca > 0
if (CA <= 0) goto L_00A8;
ABORT(1145917490);
L_00A8:;
// 1447 k = lita; lita = ca; ca = k
K = LITA;
LITA = CA;
CA = K;
// 1448 print symbol(code area)
_imp_PRINTSYMBOL(12);
// 1449 %end
return;
} /* end of SELECTCODEAREA */
// 1450
// 1451 %routine phex(%integer n)
void PHEX(int N) {
// 1452 %integer j,k
int J;
int K;
// 1453 spaces(2)
_imp_SPACES(2);
// 1454 %for j = 12,-4,0 %cycle
// %for J = 12, -4, 0 %cycle
{
J = 16;
L_00A9:
if (J == 0) goto L_00AA;
J -= 4;
// 1455 k = (n>>j)&15
K = (unsigned int)N >> J & 15;
// 1456 %if k <= 9 %then k = k+'0' %else k = k-10+'A'
if (K > 9) goto L_00AC;
K = K + 48;
goto L_00AD;
L_00AC:;
K = K - 10 + 65;
L_00AD:;
// 1457 print symbol(k)
_imp_PRINTSYMBOL(K);
// 1458 %repeat
goto L_00A9;
}
L_00AA:;
// 1459 %end
return;
} /* end of PHEX */
// 1460
// 1461 ! >> DUMP TAG <<
// 1462 %routine dump tag(%integer tag, type)
void DUMPTAG(int TAG, int TYPE) {
// 1463 %conststring(7)%array s(tag def:c ref) =
const _imp_string7 S[6] = {_imp_str_init(" defn"), _imp_str_init(" r ref"), _imp_str_init(" p ref"),
_imp_str_init(" sw ref"), _imp_str_init(" j ref"), _imp_str_init(" c ref")};
// 1464+ " defn", " r ref", " p ref", " sw ref", " j ref", " c ref"
// 1465 select output(report)
_imp_SELECTOUTPUT(0);
// 1466 print symbol('*'); write(ca,-3)
_imp_PRINTSYMBOL(42);
_imp_WRITE(CA, -3);
// 1467 print string(s(type))
_imp_PRINTSTRING(
*({
__typeof__(_imp_string7) tmp = S[TYPE - 1] /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1468 write(tag,1)
_imp_WRITE(TAG, 1);
// 1469 newline
_imp_NEWLINE();
// 1470 select output(object)
_imp_SELECTOUTPUT(2);
// 1471 %end; ! dump tag
return;
} /* end of DUMPTAG */
// 1472
// 1473 ! >> DUMP <<
// 1474 %routine dump(%integer p,val)
void DUMP(int P, int VAL) {
// 1475 %integer k
int K;
// 1476 select output(report)
_imp_SELECTOUTPUT(0);
// 1477 %if p = m'CA' %start
if (P != 17217) goto L_00AE;
// 1478 print string("CA "); k = ca
_imp_PRINTSTRING(_imp_str_literal("CA "));
K = CA;
// 1479 %else
goto L_00AF;
L_00AE:;
// 1480 print string("GA "); k = ga
_imp_PRINTSTRING(_imp_str_literal("GA "));
K = GA;
// 1481 %finish
L_00AF:;
// 1482 write(k-2,-3); print symbol(':')
_imp_WRITE(K - 2, -3);
_imp_PRINTSYMBOL(58);
// 1483 phex(val)
PHEX(VAL);
// 1484 newline
_imp_NEWLINE();
// 1485 select output(object)
_imp_SELECTOUTPUT(2);
// 1486 %end; ! dump
return;
} /* end of DUMP */
// 1487
// 1488 ! >> CPUT <<
// 1489 %routine cput(%integer n)
void CPUT(int N) {
// 1490 ! Output one halfword to code area
// 1491 print symbol(code item)
_imp_PRINTSYMBOL(7);
// 1492 print symbol(n>>8); print symbol(n&255)
_imp_PRINTSYMBOL((unsigned int)N >> 8);
_imp_PRINTSYMBOL(N & 255);
// 1493 ca = ca+2
CA = CA + 2;
// 1494 dump(m'CA',n) %if diagnose < 0
if (DIAGNOSE >= 0) goto L_00B0;
DUMP(17217, N);
L_00B0:;
// 1495 %end
return;
} /* end of CPUT */
// 1496
// 1497 ! >> GPUT <<
// 1498 %routine gput(%integer n)
void GPUT(int N) {
// 1499 ! Output one halfword to gla area
// 1500 print symbol(gla item)
_imp_PRINTSYMBOL(8);
// 1501 print symbol(n>>8); print symbol(n&255)
_imp_PRINTSYMBOL((unsigned int)N >> 8);
_imp_PRINTSYMBOL(N & 255);
// 1502 ga = ga+2
GA = GA + 2;
// 1503 dump(m'GA',n) %if diagnose < 0
if (DIAGNOSE >= 0) goto L_00B1;
DUMP(18241, N);
L_00B1:;
// 1504 %end
return;
} /* end of GPUT */
// 1505
// 1506 ! >> CWORD <<
// 1507 %routine cword(%integer n)
void CWORD(int N) {
// 1508 cput(n>>16); cput(n)
CPUT((unsigned int)N >> 16);
CPUT(N);
// 1509 %end
return;
} /* end of CWORD */
// 1510
// 1511 ! >> LIT BYTE <<
// 1512 %routine lit byte(%integer n)
void LITBYTE(int N) {
// 1513 %owninteger v=0,f=0
static int V = 0;
static int F = 0;
// 1514 f = \f
F = (~F);
// 1515 %if f=0 %start
if (F != 0) goto L_00B2;
// 1516 ca = ca+1; cput(v<<8 + n&255)
CA = CA + 1;
CPUT((V << 8) + (N & 255));
// 1517 %else
goto L_00B3;
L_00B2:;
// 1518 v = n; ca = ca-1
V = N;
CA = CA - 1;
// 1519 %finish
L_00B3:;
// 1520 abort(m'DMP3') %unless ca <= 0
if (CA <= 0) goto L_00B4;
ABORT(1145917491);
L_00B4:;
// 1521 %end
return;
} /* end of LITBYTE */
// 1522
// 1523 ! >> GWORD <<
// 1524 %routine gword(%integer n)
void GWORD(int N) {
// 1525 gput(n>>16); gput(n&x'FFFF')
GPUT((unsigned int)N >> 16);
GPUT(N & 65535);
// 1526 %end
return;
} /* end of GWORD */
// 1527
// 1528 ! >> GWORD REL <<
// 1529 %routine gword rel(%integer n)
void GWORDREL(int N) {
// 1530 ! Word in GLA modified at load-time by gla base address - used to relocate
// 1531 ! %ownarray headers.
// 1532 gput(n>>16); gput(n&x'FFFF')
GPUT((unsigned int)N >> 16);
GPUT(N & 65535);
// 1533 print symbol(g rel); relocations = relocations + 1
_imp_PRINTSYMBOL(20);
RELOCATIONS = RELOCATIONS + 1;
// 1534 %end; ! gword rel
return;
} /* end of GWORDREL */
// 1535
// 1536 ! >> GWORD CREL <<
// 1537 %routine gword crel(%integer n)
void GWORDCREL(int N) {
// 1538 ! Word in GLA modified at load-time by code base address - used to relocate
// 1539 ! %constarray headers
// 1540 gput(n>>16); gput(n&x'FFFF')
GPUT((unsigned int)N >> 16);
GPUT(N & 65535);
// 1541 print symbol(c rel); relocations = relocations+1
_imp_PRINTSYMBOL(19);
RELOCATIONS = RELOCATIONS + 1;
// 1542 %end; ! GWORD CREL
return;
} /* end of GWORDCREL */
// 1543
// 1544 ! >> GBYTE <<
// 1545 %routine gbyte(%integer n)
void GBYTE(int N) {
// 1546 %owninteger v=0, f=0
static int V = 0;
static int F = 0;
// 1547 f = \f
F = (~F);
// 1548 %if f = 0 %start
if (F != 0) goto L_00B5;
// 1549 ga = ga-1; gput(v<<8 + n&255)
GA = GA - 1;
GPUT((V << 8) + (N & 255));
// 1550 %else
goto L_00B6;
L_00B5:;
// 1551 v = n; ga = ga+1
V = N;
GA = GA + 1;
// 1552 %finish
L_00B6:;
// 1553 %end
return;
} /* end of GBYTE */
// 1554
// 1555 ! >> GFIX <<
// 1556 %routine gfix(%integer align)
void GFIX(int ALIGN) {
// 1557 gbyte(0) %while ga&align # 0
L_00B7:;
if (GA & ALIGN == 0) goto L_00B8;
GBYTE(0);
goto L_00B7;
L_00B8:;
// 1558 %end
return;
} /* end of GFIX */
// 1559
// 1560 ! >> DEFINE TAG <<
// 1561 %routine define tag(%integer ref)
void DEFINETAG(int REF) {
// 1562 %integer k
int K;
// 1563 select output(direct)
_imp_SELECTOUTPUT(1);
// 1564 print symbol(tag def)
_imp_PRINTSYMBOL(1);
// 1565 print symbol(ref>>8); print symbol(ref&255)
_imp_PRINTSYMBOL((unsigned int)REF >> 8);
_imp_PRINTSYMBOL(REF & 255);
// 1566 k = ca>>1; ! ******* Halfword units
K = (unsigned int)CA >> 1;
// 1567 print symbol(k>>8); print symbol(k&255)
_imp_PRINTSYMBOL((unsigned int)K >> 8);
_imp_PRINTSYMBOL(K & 255);
// 1568 select output(object)
_imp_SELECTOUTPUT(2);
// 1569 dump tag(ref,tag def) %if diagnose < 0
if (DIAGNOSE >= 0) goto L_00B9;
DUMPTAG(REF, 1);
L_00B9:;
// 1570 %end; ! define tag
return;
} /* end of DEFINETAG */
// 1571
// 1572 ! >> DEFINE REFERENCE <<
// 1573 %routine define reference(%integer ref, type)
void DEFINEREFERENCE(int REF, int TYPE) {
// 1574 %integer k
int K;
// 1575 set line %if current line # last line
if (CURRENTLINE == LASTLINE) goto L_00BA;
SETLINE();
L_00BA:;
// 1576 select output(direct)
_imp_SELECTOUTPUT(1);
// 1577 print symbol(type)
_imp_PRINTSYMBOL(TYPE);
// 1578 print symbol(ref>>8); print symbol(ref&255)
_imp_PRINTSYMBOL((unsigned int)REF >> 8);
_imp_PRINTSYMBOL(REF & 255);
// 1579 k = ca>>1; ! ******** Halfword units
K = (unsigned int)CA >> 1;
// 1580 print symbol(k>>8); print symbol(k&255)
_imp_PRINTSYMBOL((unsigned int)K >> 8);
_imp_PRINTSYMBOL(K & 255);
// 1581 select output(object)
_imp_SELECTOUTPUT(2);
// 1582 dump tag(ref,type) %if diagnose < 0
if (DIAGNOSE >= 0) goto L_00BB;
DUMPTAG(REF, TYPE);
L_00BB:;
// 1583 print symbol(type)
_imp_PRINTSYMBOL(TYPE);
// 1584 %if type = r ref %start
if (TYPE != 2) goto L_00BC;
// 1585 print symbol(ref>>8); print symbol(ref&255)
_imp_PRINTSYMBOL((unsigned int)REF >> 8);
_imp_PRINTSYMBOL(REF & 255);
// 1586 %finish
L_00BC:;
// 1587 %end; ! define reference
return;
} /* end of DEFINEREFERENCE */
// 1588
// 1589 ! >> CLAIM LITERAL <<
// 1590 %routine claim literal(%integer size,align)
void CLAIMLITERAL(int SIZE, int ALIGN) {
// 1591 %integer k
int K;
// 1592 abort(m'DMP4') %if ca < 0 %or litmax > 0
if (CA < 0) goto L_00AB;
if (LITMAX <= 0) goto L_00BD;
L_00AB:;
ABORT(1145917492);
L_00BD:;
// 1593 %if lita&1 # 0 %start; ! odd no. of bytes
if (LITA & 1 == 0) goto L_00BE;
// 1594 select literal area
SELECTLITERALAREA();
// 1595 lit byte(0)
LITBYTE(0);
// 1596 select code area
SELECTCODEAREA();
// 1597 %finish
L_00BE:;
// 1598 litmax = -((-litmax+size+align)&(\align))
LITMAX = -(-LITMAX + SIZE + ALIGN & (~ALIGN));
// 1599 lita = litmax
LITA = LITMAX;
// 1600 k = (-lita)>>1
K = (unsigned int)-LITA >> 1;
// 1601 print symbol(lit org); put(k); ! Tell pass 3
_imp_PRINTSYMBOL(14);
PUT(K);
// 1602 %end; ! claim literal
return;
} /* end of CLAIMLITERAL */
// 1603
// 1604 ! >> SET LINE <<
// 1605 %routine set line
void SETLINE(void) {
// 1606 %integer flag
int FLAG;
// 1607 %return %if ca < 0; !in literal area
if (CA >= 0) goto L_00BF;
return;
L_00BF:;
// 1608 %if current line-last line # 1 %then flag = line reset %c
if (CURRENTLINE - LASTLINE == 1) goto L_00C0;
FLAG = 10;
goto L_00C1;
L_00C0:;
FLAG = 9;
L_00C1:;
// 1609+ %else flag = line flag
// 1610 select output(direct)
_imp_SELECTOUTPUT(1);
// 1611 print symbol(flag); put(current line) %if flag = line reset
_imp_PRINTSYMBOL(FLAG);
if (FLAG != 10) goto L_00C2;
PUT(CURRENTLINE);
L_00C2:;
// 1612 %if diagnose < 0 %start
if (DIAGNOSE >= 0) goto L_00C3;
// 1613 select output(report)
_imp_SELECTOUTPUT(0);
// 1614 print string("-->line"); write(current line,1)
_imp_PRINTSTRING(_imp_str_literal("-->line"));
_imp_WRITE(CURRENTLINE, 1);
// 1615 newline
_imp_NEWLINE();
// 1616 %finish
L_00C3:;
// 1617 select output(object)
_imp_SELECTOUTPUT(2);
// 1618 print symbol(flag); put(current line) %if flag = line reset
_imp_PRINTSYMBOL(FLAG);
if (FLAG != 10) goto L_00C4;
PUT(CURRENTLINE);
L_00C4:;
// 1619 last line = current line; last ca = ca
LASTLINE = CURRENTLINE;
LASTCA = CA;
// 1620 %end; ! set line
return;
} /* end of SETLINE */
// 1621
// 1622 ! >> DESCRIBE <<
// 1623 %routine describe(%integer base,disp, %string(ident len)%name xsym)
void DESCRIBE(int BASE, int DISP, _imp_string19 *XSYM) {
// 1624 ! Generate a full description of the variable specified by (base,disp)
// 1625 ! Assumes that DIAG SIZE, DIAG TYPE, DIAG FORM, OTYPE are appropriately set.
// 1626 %integer size,type
int SIZE;
int TYPE;
// 1627 %integer j,k
int J;
int K;
// 1628 %constbyteintegerarray compressed type(0:13) =
const unsigned char COMPRESSEDTYPE[14] = {1, 2, 3, 4, 5, [5 ... 7] = 0, 6, [9 ... 12] = 0, 7};
// 1629+ 1, 2, 3, 4, 5, 0(3), 6, 0(4), 7
// 1630 ! integer real string record byte short long real
// 1631 length(xsym) = extern len %if length(xsym) > extern len
if (*_imp_LENGTH((_imp_string255 *)/*p*/ XSYM) <= 12) goto L_00C5;
*_imp_LENGTH((_imp_string255 *)/*p*/ XSYM) = 12;
L_00C5:;
// 1632 print symbol(length(xsym))
_imp_PRINTSYMBOL(*_imp_LENGTH((_imp_string255 *)/*p*/ XSYM));
// 1633 print symbol(charno(xsym,j)) %for j = 1,1,length(xsym); ! name
// %for J = 1, 1, *_imp_LENGTH((_imp_string255 *)/*p*/XSYM) %cycle
{
int _final = *_imp_LENGTH((_imp_string255 *)/*p*/ XSYM);
if (invalid_for_loop(1, 1, _final))
_imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, *_imp_LENGTH((_imp_string255 *)/*p*/XSYM)");
J = 0;
L_00C6:
if (J == _final) goto L_00C7;
J += 1;
_imp_PRINTSYMBOL(*_imp_CHARNO((_imp_string255 *)/*p*/ XSYM, J));
goto L_00C6;
}
L_00C7:;
// 1634 %return %if base < 0
if (BASE >= 0) goto L_00C9;
return;
L_00C9:;
// 1635 size = diag size; type = diag type
SIZE = DIAGSIZE;
TYPE = DIAGTYPE;
// 1636 size = 1 %if diag type >= 3 %or diag form > 2 %or size = 0
if (DIAGTYPE >= 3) goto L_00C8;
if (DIAGFORM > 2) goto L_00C8;
if (SIZE != 0) goto L_00CA;
L_00C8:;
SIZE = 1;
L_00CA:;
// 1637 type = 1 %if diag type <= 0
if (DIAGTYPE > 0) goto L_00CB;
TYPE = 1;
L_00CB:;
// 1638 k = (size-1) << 2 + (type-1)
K = (SIZE - 1 << 2) + (TYPE - 1);
// 1639 j = 0
J = 0;
// 1640 j = x'80' %if Otype # 0 %and Spec # 0 {external data spec}
if (OTYPE == 0) goto L_00CC;
if (SPEC == 0) goto L_00CC;
J = 128;
L_00CC:;
// 1641 print symbol(otype)
_imp_PRINTSYMBOL(OTYPE);
// 1642 print symbol( compressed type(k) << 4 ! DIAG FORM ! J)
_imp_PRINTSYMBOL(COMPRESSEDTYPE[K] << 4 | DIAGFORM | J);
// 1643 j = actual(base)<<20 + disp&x'000FFFFF'
J = (ACTUAL[BASE] << 20) + (DISP & 1048575);
// 1644 print symbol(j>>16); print symbol(j>>8); print symbol(j)
_imp_PRINTSYMBOL((unsigned int)J >> 16);
_imp_PRINTSYMBOL((unsigned int)J >> 8);
_imp_PRINTSYMBOL(J);
// 1645 %end; ! describe
return;
} /* end of DESCRIBE */
// 1646
// 1647 ! >> SET DIAG <<
// 1648 %routine set diag(%integer base,disp)
void SETDIAG(int BASE, int DISP) {
// 1649 ! Implicit parameters: DIAG TYPE DIAG FORM DIAG SIZE OTYPE
// 1650 var diags = var diags + basic vdiag
VARDIAGS = VARDIAGS + 4;
// 1651 var diags = var diags + extra vdiag %if length(internal id) > short ident
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &INTERNALID) <= 6) goto L_00CD;
VARDIAGS = VARDIAGS + 2;
L_00CD:;
// 1652 print symbol(var diag); describe(base,disp,internal id)
_imp_PRINTSYMBOL(11);
DESCRIBE(BASE, DISP, (_imp_string19 *)/*p*/ /*?*/ &INTERNALID);
// 1653 %end
return;
} /* end of SETDIAG */
// 1654
// 1655 ! >> EXTERNAL LINK <<
// 1656 %routine external link(%integer ref type,data size,addr)
void EXTERNALLINK(int REFTYPE, int DATASIZE, int ADDR) {
// 1657 !Note that ADDR is ignored when defining procedure entry points
// 1658 ! it is assumed that the link is set IMMEDIATELY before the entry point.
// 1659 %integer k
int K;
// 1660 abort(m'DMP5') %unless data ref <= ref type <= ep defn
{
// Double-sided test on REFTYPE (Part I)
int tmp;
if (4 > (tmp = REFTYPE)) goto L_00CE;
// Double-sided test on REFTYPE (Part II)
if (tmp <= 7) goto L_00CF;
}
L_00CE:;
ABORT(1145917493);
L_00CF:;
// 1661 %if ref type&1 # 0 %then defns = defns+1 %else specs = specs+1
if (REFTYPE & 1 == 0) goto L_00D0;
DEFNS = DEFNS + 1;
goto L_00D1;
L_00D0:;
SPECS = SPECS + 1;
L_00D1:;
// 1662 print symbol(extern)
_imp_PRINTSYMBOL(21);
// 1663 print symbol(ref type)
_imp_PRINTSYMBOL(REFTYPE);
// 1664 put(data size//2); ! Halfwords for pass3
PUT(((long)DATASIZE / (long)2));
// 1665 k = gla; k = code %if ref type = ep defn
K = 14;
if (REFTYPE != 7) goto L_00D2;
K = 15;
L_00D2:;
// 1666 describe(k,addr//2,external id)
DESCRIBE(K, ((long)ADDR / (long)2), (_imp_string19 *)/*p*/ /*?*/ &EXTERNALID);
// 1667 %if ref type&1 = 0 %start; !a spec
if (REFTYPE & 1 != 0) goto L_00D3;
// 1668 gword(0); gword(0)
GWORD(0);
GWORD(0);
// 1669 %if ref type = ep ref %then gword(0) %else gword(-1)
if (REFTYPE != 6) goto L_00D4;
GWORD(0);
goto L_00D5;
L_00D4:;
GWORD(-1);
L_00D5:;
// 1670 %finish
L_00D3:;
// 1671 %end
return;
} /* end of EXTERNALLINK */
// 1672
// 1673 ! >> CLOSE FILES <<
// 1674 %routine close files
void CLOSEFILES(void) {
// 1675 select output(direct)
_imp_SELECTOUTPUT(1);
// 1676 print symbol(prog end)
_imp_PRINTSYMBOL(18);
// 1677 put(total ca>>1); put((-litmax)>>1); put(ga>>1); ! Halfword units
PUT((unsigned int)TOTALCA >> 1);
PUT((unsigned int)-LITMAX >> 1);
PUT((unsigned int)GA >> 1);
// 1678 put(defns); put(specs); put(relocations)
PUT(DEFNS);
PUT(SPECS);
PUT(RELOCATIONS);
// 1679 print symbol(0); ! to prevent potential trouble with binary 4 = EOF
_imp_PRINTSYMBOL(0);
// 1680 close output
_imp_CLOSEOUTPUT();
// 1681 select output(object); print symbol(prog end)
_imp_SELECTOUTPUT(2);
_imp_PRINTSYMBOL(18);
// 1682 close output
_imp_CLOSEOUTPUT();
// 1683 %end; ! close files
return;
} /* end of CLOSEFILES */
// 1684
// 1685 ! code generation routines
// 1686 ! >> RXD <<
// 1687 ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
// 1688 ! B a s i c C o d e G e n e r a t o r
// 1689 !
// 1690 %routine RXD(%integer op, r1, %record(stackfm)%name v)
void RXD(int OP, int R1, struct STACKFM *V) {
// 1691 %integer index, mask, code, format
int INDEX;
int MASK;
int CODE;
int FORMAT;
// 1692 %integer type, form, base, disp, x
int TYPE;
int FORM;
int BASE;
int DISP;
int X;
// 1693 %integer k, old ca
int K;
int OLDCA;
// 1694 %record(stackfm) u
struct STACKFM U;
// 1695 %constbyteintegerarray type index(integers:reals+1) =
const unsigned char TYPEINDEX[8] = {1, 2, 7, [3 ... 5] = 0, 1, 0};
// 1696+ 1, 2, 7, 0(3), 1, 0
// 1697 ! integer short byte reals reall
// 1698 old ca = ca
OLDCA = CA;
// 1699 type = v_type; form = v_form
TYPE = V->TYPE;
FORM = V->FORM;
// 1700 base = v_base; disp = v_disp; x = v_index
BASE = V->BASE;
DISP = V->DISP;
X = V->INDEX;
// 1701 op = op + fp base %if r1 >= FR0
if (R1 < 17) goto L_00D6;
OP = OP + 13;
L_00D6:;
// 1702 mask = op index(op); index = mask&255
MASK = OPINDEX[OP - 1];
INDEX = MASK & 255;
// 1703 set line %if last line # current line
if (LASTLINE == CURRENTLINE) goto L_00D7;
SETLINE();
L_00D7:;
// 1704
// 1705 %if form = constant %or form = AV in S %start; ! RXI
if (FORM == 0) goto L_00D8;
if (FORM != 5) goto L_00D9;
L_00D8:;
// 1706 abort(m'RXDx') %if x # 0
if (X == 0) goto L_00DA;
ABORT(1381516408);
L_00DA:;
// 1707 %if disp = 0 %and base # 0 %and LSH # op # RSH %and op # SRA %start
if (DISP != 0) goto L_00DB;
if (BASE == 0) goto L_00DB;
{
// Double-sided test on OP (Part I)
int tmp;
if (11 == (tmp = OP)) goto L_00DB;
// Double-sided test on OP (Part II)
if (tmp == 12) goto L_00DB;
}
if (OP == 29) goto L_00DB;
// 1708 ! optimise: LHI x,0(y) => LR x,y
// 1709 ! remove: LHI x,0(x)
// 1710 %if r1 # base %or op # LW %start
if (R1 != BASE) goto L_00DC;
if (OP == 1) goto L_00DD;
L_00DC:;
// 1711 u_xbase = base; u_disp = 0; ! **** u_disp otherwise unassigned ****
U.XBASE = BASE;
U.DISP = 0;
// 1712 u_form = V in R; rxd(op,r1,u)
U.FORM = 1;
RXD(OP, R1, /*?*/ &U);
// 1713 %return
return;
// 1714 %finish
L_00DD:;
// 1715 code = x'10'; !(psr) preserve CC at end - see later
CODE = 16;
// 1716 %else %if op = LW %and r1 = base %and 15 >= disp >= -15
goto L_00DE;
L_00DB:;
if (OP != 1) goto L_00DF;
if (R1 != BASE) goto L_00DF;
{
// Double-sided test on DISP (Part I)
int tmp;
if (15 < (tmp = DISP)) goto L_00DF;
// Double-sided test on DISP (Part II)
if (tmp < -15) goto L_00DF;
}
// 1717 ! LHI x, 15(x) => AIS x,15
// 1718 ! LHI x,-15(x) => SIS x,15
// 1719 op = add
OP = 3;
// 1720 %if disp < 0 %start
if (DISP >= 0) goto L_00E0;
// 1721 op = sub; disp = -disp
OP = 4;
DISP = -DISP;
// 1722 %finish
L_00E0:;
// 1723 u_form = constant; u_xbase = 0; u_disp = disp; rxd(op,r1,u)
U.FORM = 0;
U.XBASE = 0;
U.DISP = DISP;
RXD(OP, R1, /*?*/ &U);
// 1724 release(base)
RELEASE(BASE);
// 1725 %return
return;
// 1726 %else %if op = LSH %and disp = 1 %and base = 0
L_00DF:;
if (OP != 11) goto L_00E1;
if (DISP != 1) goto L_00E1;
if (BASE != 0) goto L_00E1;
// 1727 ! SLLS x,1 => AR x,x
// 1728 claim(r1)
CLAIM(R1);
// 1729 u_xbase = r1; u_disp = 0
U.XBASE = R1;
U.DISP = 0;
// 1730 u_form = V in R; rxd(add,r1,u); %return
U.FORM = 1;
RXD(3, R1, /*?*/ &U);
return;
// 1731 %else; ! general case (RXI)
L_00E1:;
// 1732 abort(m'RXD1') %if mask&FWIMM = 0 %and LSH # op # RSH %and op # SRA
if (MASK & 2048 != 0) goto L_00E2;
{
// Double-sided test on OP (Part I)
int tmp;
if (11 == (tmp = OP)) goto L_00E2;
// Double-sided test on OP (Part II)
if (tmp == 12) goto L_00E2;
}
if (OP == 29) goto L_00E2;
ABORT(1381516337);
L_00E2:;
// 1733 index = index + 3; ! fullword immediate
INDEX = INDEX + 3;
// 1734 format = 0
FORMAT = 0;
// 1735 %if 15>=disp>=-15 %and base=0 %and (SF IMM+INV IMM)&mask # 0 %start
{
// Double-sided test on DISP (Part I)
int tmp;
if (15 < (tmp = DISP)) goto L_00E3;
// Double-sided test on DISP (Part II)
if (tmp < -15) goto L_00E3;
}
if (BASE != 0) goto L_00E3;
if (8192 + 16384 & MASK == 0) goto L_00E3;
// 1736 %if disp >= 0 %start
if (DISP < 0) goto L_00E4;
// 1737 format = 2
FORMAT = 2;
// 1738 %else
goto L_00E5;
L_00E4:;
// 1739 format = 3; disp = -disp
FORMAT = 3;
DISP = -DISP;
// 1740 %finish
L_00E5:;
// 1741 %else %if 32767 >= disp >= -32768
goto L_00E6;
L_00E3:;
{
// Double-sided test on DISP (Part I)
int tmp;
if (32767 < (tmp = DISP)) goto L_00E7;
// Double-sided test on DISP (Part II)
if (tmp < -32768) goto L_00E7;
}
// 1742 format = 1
FORMAT = 1;
// 1743 %finish
L_00E7:;
L_00E6:;
// 1744 code = op code(index + format)
CODE = OPCODE[INDEX + FORMAT - 1];
// 1745 %if format >= 2 %start
if (FORMAT < 2) goto L_00E8;
// 1746 cput(code&x'FF00' + actual(r1)<<4 + disp)
CPUT((CODE & 65280) + (ACTUAL[R1] << 4) + DISP);
// 1747 %else
goto L_00E9;
L_00E8:;
// 1748 cput(code&x'FF00' + actual(r1)<<4 + actual(base))
CPUT((CODE & 65280) + (ACTUAL[R1] << 4) + ACTUAL[BASE]);
// 1749 cput(disp>>16) %if format = 0; ! fullword immediate ?
if (FORMAT != 0) goto L_00EA;
CPUT((unsigned int)DISP >> 16);
L_00EA:;
// 1750 cput(disp)
CPUT(DISP);
// 1751 %finish
L_00E9:;
// 1752 %finish
L_00DE:;
// 1753 %else %if form = V in R; ! register-register operation
goto L_00EB;
L_00D9:;
if (FORM != 1) goto L_00EC;
// 1754 abort(m'RXD2') %if r1 = 0 %or base = 0 %or x # 0
if (R1 == 0) goto L_0080;
if (BASE == 0) goto L_0080;
if (X == 0) goto L_00ED;
L_0080:;
ABORT(1381516338);
L_00ED:;
// 1755 code = op code(index); ! ** N.B. op code(index + 0) really ......
CODE = OPCODE[INDEX - 1];
// 1756 %if code&x'20' # 0 %start; ! STR => LR etc.
if (CODE & 32 == 0) goto L_00EE;
// 1757 k = r1; r1 = base; base = k
K = R1;
R1 = BASE;
BASE = K;
// 1758 %finish
L_00EE:;
// 1759 cput(code&x'FF00' + actual(r1)<<4 + actual(base))
CPUT((CODE & 65280) + (ACTUAL[R1] << 4) + ACTUAL[BASE]);
// 1760 %else; ! RX (integer,real,short,byte)
goto L_00EB;
L_00EC:;
// 1761 abort(m'RXD3') %if r1 = 0 %or base = R0
if (R1 == 0) goto L_00EF;
if (BASE != 1) goto L_00F0;
L_00EF:;
ABORT(1381516339);
L_00F0:;
// 1762 format = type index(type); abort(m'RXD4') %if format = 0
FORMAT = TYPEINDEX[TYPE - 1];
if (FORMAT != 0) goto L_00F1;
ABORT(1381516340);
L_00F1:;
// 1763 code = op code(index + format)
CODE = OPCODE[INDEX + FORMAT - 1];
// 1764 abort(m'RXD5') %if (code&15)&disp # 0
if (CODE & 15 & DISP == 0) goto L_00F2;
ABORT(1381516341);
L_00F2:;
// 1765 cput(code&x'FF00' + actual(r1)<<4 + actual(base))
CPUT((CODE & 65280) + (ACTUAL[R1] << 4) + ACTUAL[BASE]);
// 1766 %unless 0 <= disp <= 16383 %and x = 0 %start
{
// Double-sided test on DISP (Part I)
int tmp;
if (0 > (tmp = DISP)) goto L_00F3;
// Double-sided test on DISP (Part II)
if (tmp > 16383) goto L_00F3;
}
if (X == 0) goto L_00F4;
L_00F3:;
// 1767 cput(x'4000' + actual(x)<<8 + (disp>>16)&255)
CPUT(16384 + (ACTUAL[X] << 8) + ((unsigned int)DISP >> 16 & 255));
// 1768 %finish
L_00F4:;
// 1769 cput(disp)
CPUT(DISP);
// 1770 %finish
L_00EB:;
// 1771 release(base) %if base > 0; !(PSR)
if (BASE <= 0) goto L_00F5;
RELEASE(BASE);
L_00F5:;
// 1772 release(x) %if x # 0
if (X == 0) goto L_00F6;
RELEASE(X);
L_00F6:;
// 1773 %if code&x'40' # 0 %start; ! leaves cond code completely unchanged
if (CODE & 64 == 0) goto L_00F7;
// 1774 cc ca = cc ca + ca - old ca
CCCA = CCCA + CA - OLDCA;
// 1775 %else %if code&x'10' = 0; ! cond code relative to zero ?
goto L_00F8;
L_00F7:;
if (CODE & 16 != 0) goto L_00F9;
// 1776 cc ca = ca; cc reg = r1
CCCA = CA;
CCREG = R1;
// 1777 %finish
L_00F9:;
L_00F8:;
// 1778 %end; ! of 'RXD'
return;
} /* end of RXD */
// 1779 ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
// 1780
// 1781 ! >> RR <<
// 1782 %routine rr(%integer op,r1,r2)
void RR(int OP, int R1, int R2) {
// 1783 %record(stackfm) v
struct STACKFM V;
// 1784 v_xbase = r2; v_disp = 0
V.XBASE = R2;
V.DISP = 0;
// 1785 v_type = integers; v_type = reals %if r1 >= FR0
V.TYPE = 1;
if (R1 < 17) goto L_00FA;
V.TYPE = 7;
L_00FA:;
// 1786 v_form = V in R; rxd(op, r1, v)
V.FORM = 1;
RXD(OP, R1, /*?*/ &V);
// 1787 %end
return;
} /* end of RR */
// 1788
// 1789 ! >> RXI <<
// 1790 %routine rxi(%integer op, r1, base, disp)
void RXI(int OP, int R1, int BASE, int DISP) {
// 1791 %record(stackfm) v
struct STACKFM V;
// 1792 v_xbase = base; v_disp = disp
V.XBASE = BASE;
V.DISP = DISP;
// 1793 v_type = integers
V.TYPE = 1;
// 1794 v_form = constant; rxd(op, r1, v)
V.FORM = 0;
RXD(OP, R1, /*?*/ &V);
// 1795 %end
return;
} /* end of RXI */
// 1796
// 1797 ! >> RX <<
// 1798 %routine rx(%integer op, r1, base, disp)
void RX(int OP, int R1, int BASE, int DISP) {
// 1799 %record(stackfm) v
struct STACKFM V;
// 1800 v_xbase = base; v_disp = disp
V.XBASE = BASE;
V.DISP = DISP;
// 1801 v_type = integers; v_type = reals %if r1 >= FR0
V.TYPE = 1;
if (R1 < 17) goto L_00FB;
V.TYPE = 7;
L_00FB:;
// 1802 v_form = V in S; rxd(op, r1, v)
V.FORM = 4;
RXD(OP, R1, /*?*/ &V);
// 1803 %end
return;
} /* end of RX */
// 1804
// 1805 ! >> SKIP <<
// 1806 %routine skip(%integer half words, condition)
void SKIP(int HALFWORDS, int CONDITION) {
// 1807 ! Plant a short forward jump to skip over unwanted code sequence:
// 1808 ! skips forward the number of halfwords specified NOT COUNTING the
// 1809 ! code dumped to effect the skip
// 1810 ! Must be used with care as it doesn't account automatically for register
// 1811 ! contents.
// 1812 %constshortintegerarray jump(0:5) =
const short int JUMP[6] = {9008, 8496, 8464, 8480, 8992, 8976};
// 1813+ x'2330', x'2130', x'2110', x'2120', x'2320', x'2310'
// 1814 ! BES BNES BMS BPS BNPS BNMS
// 1815 Condition = Inverted(Condition) %if Condition&16 # 0
if (CONDITION & 16 == 0) goto L_00FC;
CONDITION = INVERTED[CONDITION - 16];
L_00FC:;
// 1816 abort(m'SKP1') %unless 0 < halfwords <= 14 %and 0 <= condition <= 5
{
// Double-sided test on HALFWORDS (Part I)
int tmp;
if (0 >= (tmp = HALFWORDS)) goto L_00FD;
// Double-sided test on HALFWORDS (Part II)
if (tmp > 14) goto L_00FD;
}
{
// Double-sided test on CONDITION (Part I)
int tmp;
if (0 > (tmp = CONDITION)) goto L_00FD;
// Double-sided test on CONDITION (Part II)
if (tmp <= 5) goto L_00FE;
}
L_00FD:;
ABORT(1397444657);
L_00FE:;
// 1817 cput( jump(condition) ! (halfwords + 1) )
CPUT(JUMP[CONDITION] | HALFWORDS + 1);
// 1818 %end
return;
} /* end of SKIP */
// 1819
// 1820 ! >> MACHINE CODE <<
// 1821 %routine machine code
void MACHINECODE(void) {
// 1822 %constinteger branch = 1
// 1823 %constinteger rr = 2
// 1824 %constinteger indexed = 4
// 1825 %constinteger ri1 = 8
// 1826 %constinteger ri2 = 16
// 1827 !*delete*
// 1828 %constinteger mc entries = 204
// 1829 %constintegerarray mcop(1:mc entries) =
const int MCOP[204] = {
65, 66, 67, 68, 76, 77, 78, 79, 83, 88,
4100, 4101, 4104, 4105, 4108, 4109, 4114, 4228, 4229, 4232,
4233, 4236, 4242, 4291, 4293, 4295, 4300, 4301, 4303, 4304,
4306, 4314, 4420, 4421, 4424, 4434, 4868, 4869, 4872, 4882,
4929, 4930, 4932, 4933, 4936, 4937, 4941, 4946, 4995, 5000,
5001, 5010, 5064, 5065, 5074, 5252, 5253, 5256, 5257, 5266,
5267, 5268, 5314, 5316, 5320, 5449, 5459, 5506, 5508, 5512,
5704, 5705, 5714, 262348, 262418, 262482, 262675, 262729, 262733, 263500,
270548, 270610, 270674, 270921, 271170, 271176, 271177, 271186, 274444, 274578,
274706, 274821, 274834, 274883, 275218, 275269, 275282, 275346, 275395, 275397,
275404, 275405, 275407, 275408, 275418, 275538, 275779, 276040, 276178, 282898,
282962, 283218, 291666, 292434, 311570, 311634, 311890, 315539, 315602, 315666,
315730, 315923, 315977, 315980, 316164, 316165, 319634, 320073, 324169, 324496,
336016, 336084, 336146, 336210, 336403, 336457, 336705, 337042, 337089, 337100,
337106, 337218, 337220, 337221, 337224, 337229, 337347, 340172, 340178, 340180,
340306, 340562, 340812, 341196, 341324, 348372, 348745, 352466, 352594, 352850,
365129, 17339858, 17355337, 17564498, 17588498, 17592466, 17592466, 17592531, 17592787, 17617170,
17625234, 17625362, 17625874, 17625938, 17626002, 17626194, 17626834, 17649810, 17649875, 17650131,
17666885, 17896594, 17928402, 17928786, 18665810, 18714962, 20255895, 20767826, 21529556, 21549633,
21549644, 21549907, 21574209, 21574220, 21574483, 21582034, 21582596, 21582597, 1112292466, 1112292470,
1296377234, 1379177299, 1380750163, 1429472581};
// 1830+ x'00000041', x'00000042', x'00000043', x'00000044', x'0000004C',
// 1831+ ! A B C D L
// 1832+ x'0000004D', x'0000004E', x'0000004F', x'00000053', x'00000058',
// 1833+ ! M N O S X
// 1834+ x'00001004', x'00001005', x'00001008', x'00001009', x'0000100C',
// 1835+ ! AD AE AH AI AL
// 1836+ x'0000100D', x'00001012', x'00001084', x'00001085', x'00001088',
// 1837+ ! AM AR CD CE CH
// 1838+ x'00001089', x'0000108C', x'00001092', x'000010C3', x'000010C5',
// 1839+ ! CI CL CR BC BE
// 1840+ x'000010C7', x'000010CC', x'000010CD', x'000010CF', x'000010D0',
// 1841+ ! BG BL BM BO BP
// 1842+ x'000010D2', x'000010DA', x'00001144', x'00001145', x'00001148',
// 1843+ ! BR BZ DD DE DH
// 1844+ x'00001152', x'00001304', x'00001305', x'00001308', x'00001312',
// 1845+ ! DR MD ME MH MR
// 1846+ x'00001341', x'00001342', x'00001344', x'00001345', x'00001348',
// 1847+ ! LA LB LD LE LH
// 1848+ x'00001349', x'0000134D', x'00001352', x'00001383', x'00001388',
// 1849+ ! LI LM LR OC OH
// 1850+ x'00001389', x'00001392', x'000013C8', x'000013C9', x'000013D2',
// 1851+ ! OI OR NH NI NR
// 1852+ x'00001484', x'00001485', x'00001488', x'00001489', x'00001492',
// 1853+ ! SD SE SH SI SR
// 1854+ x'00001493', x'00001494', x'000014C2', x'000014C4', x'000014C8',
// 1855+ ! SS ST RB RD RH
// 1856+ x'00001549', x'00001553', x'00001582', x'00001584', x'00001588',
// 1857+ ! TI TS WB WD WH
// 1858+ x'00001648', x'00001649', x'00001652', x'000400CC', x'00040112',
// 1859+ ! XH XI XR ABL AER
// 1860+ x'00040152', x'00040213', x'00040249', x'0004024D', x'0004054C',
// 1861+ ! ADR AIS AHI AHM ATL
// 1862+ x'000420D4', x'00042112', x'00042152', x'00042249', x'00042342',
// 1863+ ! CBT CER CDR CHI CLB
// 1864+ x'00042348', x'00042349', x'00042352', x'0004300C', x'00043092',
// 1865+ ! CLH CLI CLR BAL BCR
// 1866+ x'00043112', x'00043185', x'00043192', x'000431C3', x'00043312',
// 1867+ ! BER BGE BGR BFC BMR
// 1868+ x'00043345', x'00043352', x'00043392', x'000433C3', x'000433C5',
// 1869+ ! BLE BLR BOR BNC BNE
// 1870+ x'000433CC', x'000433CD', x'000433CF', x'000433D0', x'000433DA',
// 1871+ ! BNL BNM BNO BNP BNZ
// 1872+ x'00043452', x'00043543', x'00043648', x'000436D2', x'00045112',
// 1873+ ! BPR BTC BXH BZR DER
// 1874+ x'00045152', x'00045252', x'00047352', x'00047652', x'0004C112',
// 1875+ ! DDR DHR FLR FXR MER
// 1876+ x'0004C152', x'0004C252', x'0004D093', x'0004D0D2', x'0004D112',
// 1877+ ! MDR MHR LCS LBR LER
// 1878+ x'0004D152', x'0004D213', x'0004D249', x'0004D24C', x'0004D304',
// 1879+ ! LDR LIS LHI LHL LMD
// 1880+ x'0004D305', x'0004E092', x'0004E249', x'0004F249', x'0004F390',
// 1881+ ! LME OCR OHI NHI NOP
// 1882+ x'00052090', x'000520D4', x'00052112', x'00052152', x'00052213',
// 1883+ ! SCP SBT SER SDR SIS
// 1884+ x'00052249', x'00052341', x'00052492', x'000524C1', x'000524CC',
// 1885+ ! SHI SLA SSR SRA SRL
// 1886+ x'000524D2', x'00052542', x'00052544', x'00052545', x'00052548',
// 1887+ ! SRR STB STD STE STH
// 1888+ x'0005254D', x'000525C3', x'000530CC', x'000530D2', x'000530D4',
// 1889+ ! STM SVC RBL RBR RBT
// 1890+ x'00053152', x'00053252', x'0005334C', x'000534CC', x'0005354C',
// 1891+ ! RDR RHR RLL RRL RTL
// 1892+ x'000550D4', x'00055249', x'000560D2', x'00056152', x'00056252',
// 1893+ ! TBT THI WBR WDR WHR
// 1894+ x'00059249', x'010895D2', x'0108D249', x'010C0352', x'010C6112',
// 1895+ ! XHI CHVR CLHI BALR BGER
// 1896+ x'010C7092', x'010C7092', x'010C70D3', x'010C71D3', x'010CD112',
// 1897+ ! BFCR BFCR BFBS BFFS BLER
// 1898+ x'010CF092', x'010CF112', x'010CF312', x'010CF352', x'010CF392',
// 1899+ ! BNCR BNER BNMR BNLR BNOR
// 1900+ x'010CF452', x'010CF6D2', x'010D5092', x'010D50D3', x'010D51D3',
// 1901+ ! BNPR BNZR BTCR BTBS BTFS
// 1902+ x'010D9345', x'01111492', x'011190D2', x'01119252', x'011CD152',
// 1903+ ! BXLE EPSR EXBR EXHR FLDR
// 1904+ x'011D9152', x'01351497', x'013CE452', x'014883D4', x'0148D241',
// 1905+ ! FXDR LPSW NOPR SINT SLHA
// 1906+ x'0148D24C', x'0148D353', x'01493241', x'0149324C', x'01493353',
// 1907+ ! SLHL SLLS SRHA SRHL SRLS
// 1908+ x'014950D2', x'01495304', x'01495305', x'424C3C72', x'424C3C76',
// 1909+ ! STBR STMD STME CRC12 CRC16
// 1910+ x'4D452592', x'52349353', x'524C9353', x'55340545'
// 1911 ! LPSWR SLHLS SRHLS TLATE
// 1912 %constshortintegerarray opflags(1:mc entries) =
const short int OPFLAGS[204] = {
23044, 17157, 22788, 23812, 22532, 23556, 21508, 22020, 23300, 22276, 31236, 27140, 18948, 64016, 54529, 20740,
2562, 30980, 26884, 18692, 63760, 21764, 2306, 17029, 17205, 16933, 17029, 16917, 16965, 16933, 771, 17205,
32004, 27908, 19716, 7426, 31748, 27652, 19460, 7170, 58884, 54020, 30724, 26628, 18436, 63504, 53508, 2050,
56836, 17924, 62992, 1538, 17412, 62480, 1026, 31492, 27396, 19204, 64272, 2818, 56580, 20484, 55044, 56068,
55556, 62224, 57348, 54788, 55812, 55300, 18180, 63248, 1794, 25860, 10754, 14850, 9730, 51720, 24836, 25604,
30468, 10498, 14594, 51464, 54276, 17668, 62736, 1282, 16644, 641, 819, 17173, 547, 17156, 531, 17189,
643, 579, 17285, 16949, 17285, 17173, 17221, 17189, 16949, 547, 16900, 49156, 819, 11522, 15618, 3330,
12034, 11778, 11266, 15362, 3074, 9474, 37634, 10242, 14338, 9218, 51208, 29444, 32516, 29188, 40450, 50696,
50184, 16901, 58116, 29956, 11010, 15106, 9986, 51976, 61184, 40194, 60928, 60416, 60672, 53764, 28676, 24580,
16388, 53252, 57604, 26372, 38658, 30212, 39682, 39170, 60160, 59904, 26116, 29700, 49928, 38402, 39426, 38914,
50952, 4610, 50440, 258, 787, 770, 4866, 8706, 8962, 803, 899, 563, 787, 899, 835, 803,
563, 514, 8194, 8450, 49412, 38146, 37890, 13314, 16130, 15874, 49669, 515, 57857, 53000, 52488, 4354,
52744, 52232, 4098, 37378, 32260, 28932, 24068, 24324, 6145, 37122, 36866, 59140};
// 1913+ x'5A04', x'4305', x'5904', x'5D04', x'5804', x'5C04', x'5404', x'5604',
// 1914+ ! A B C D L M N O
// 1915+ x'5B04', x'5704', x'7A04', x'6A04', x'4A04', x'FA10', x'D501', x'5104',
// 1916+ ! S X AD AE AH AI AL AM
// 1917+ x'0A02', x'7904', x'6904', x'4904', x'F910', x'5504', x'0902', x'4285',
// 1918+ ! AR CD CE CH CI CL CR BC
// 1919+ x'4335', x'4225', x'4285', x'4215', x'4245', x'4225', x'0303', x'4335',
// 1920+ ! BE BG BL BM BO BP BR BZ
// 1921+ x'7D04', x'6D04', x'4D04', x'1D02', x'7C04', x'6C04', x'4C04', x'1C02',
// 1922+ ! DD DE DH DR MD ME MH MR
// 1923+ x'E604', x'D304', x'7804', x'6804', x'4804', x'F810', x'D104', x'0802',
// 1924+ ! LA LB LD LE LH LI LM LR
// 1925+ x'DE04', x'4604', x'F610', x'0602', x'4404', x'F410', x'0402', x'7B04',
// 1926+ ! OC OH OI OR NH NI NR SD
// 1927+ x'6B04', x'4B04', x'FB10', x'0B02', x'DD04', x'5004', x'D704', x'DB04',
// 1928+ ! SE SH SI SR SS ST RB RD
// 1929+ x'D904', x'F310', x'E004', x'D604', x'DA04', x'D804', x'4704', x'F710',
// 1930+ ! RH TI TS WB WD WH XH XI
// 1931+ x'0702', x'6504', x'2A02', x'3A02', x'2602', x'CA08', x'6104', x'6404',
// 1932+ ! XR ABL AER ADR AIS AHI AHM ATL
// 1933+ x'7704', x'2902', x'3902', x'C908', x'D404', x'4504', x'F510', x'0502',
// 1934+ ! CBT CER CDR CHI CLB CLH CLI CLR
// 1935+ x'4104', x'0281', x'0333', x'4315', x'0223', x'4304', x'0213', x'4325',
// 1936+ ! BAL BCR BER BGE BGR BFC BMR BLE
// 1937+ x'0283', x'0243', x'4385', x'4235', x'4385', x'4315', x'4345', x'4325',
// 1938+ ! BLR BOR BNC BNE BNL BNM BNO BNP
// 1939+ x'4235', x'0223', x'4204', x'C004', x'0333', x'2D02', x'3D02', x'0D02',
// 1940+ ! BNZ BPR BTC BXH BZR DER DDR DHR
// 1941+ x'2F02', x'2E02', x'2C02', x'3C02', x'0C02', x'2502', x'9302', x'2802',
// 1942+ ! FLR FXR MER MDR MHR LCS LBR LER
// 1943+ x'3802', x'2402', x'C808', x'7304', x'7F04', x'7204', x'9E02', x'C608',
// 1944+ ! LDR LIS LHI LHL LMD LME OCR OHI
// 1945+ x'C408', x'4205', x'E304', x'7504', x'2B02', x'3B02', x'2702', x'CB08',
// 1946+ ! NHI NOP SCP SBT SER SDR SIS SHI
// 1947+ x'EF00', x'9D02', x'EE00', x'EC00', x'ED00', x'D204', x'7004', x'6004',
// 1948+ ! SLA SSR SRA SRL SRR STB STD STE
// 1949+ x'4004', x'D004', x'E104', x'6704', x'9702', x'7604', x'9B02', x'9902',
// 1950+ ! STH STM SVC RBL RBR RBT RDR RHR
// 1951+ x'EB00', x'EA00', x'6604', x'7404', x'C308', x'9602', x'9A02', x'9802',
// 1952+ ! RLL RRL RTL TBT THI WBR WDR WHR
// 1953+ x'C708', x'1202', x'C508', x'0102', x'0313', x'0302', x'1302', x'2202',
// 1954+ ! XHI CHVR CLHI BALR BGER BFCR BFCR BFBS
// 1955+ x'2302', x'0323', x'0383', x'0233', x'0313', x'0383', x'0343', x'0323',
// 1956+ ! BFFS BLER BNCR BNER BNMR BNLR BNOR BNPR
// 1957+ x'0233', x'0202', x'2002', x'2102', x'C104', x'9502', x'9402', x'3402',
// 1958+ ! BNZR BTCR BTBS BTFS BXLE EPSR EXBR EXHR
// 1959+ x'3F02', x'3E02', x'C205', x'0203', x'E201', x'CF08', x'CD08', x'1102',
// 1960+ ! FLDR FXDR LPSW NOPR SINT SLHA SLHL SLLS
// 1961+ x'CE08', x'CC08', x'1002', x'9202', x'7E04', x'7104', x'5E04', x'5F04',
// 1962+ ! SRHA SRHL SRLS STBR STMD STME CRC12 CRC16
// 1963+ x'1801', x'9102', x'9002', x'E704'
// 1964 ! LPSWR SLHLS SRHLS TLATE
// 1965
// 1966 !*end*
// 1967 %string(7) opcode
_imp_string7 OPCODE;
// 1968 %record(varfm)%name v
struct VARFM *V;
// 1969 %integer op, base, disp, index, flags, p, n, reg
int OP;
int BASE;
int DISP;
int INDEX;
int FLAGS;
int P;
int N;
int REG;
// 1970 %routine mc error(%string(255) s)
void MCERROR(_imp_string255 S) {
// 1971 selectoutput(0)
_imp_SELECTOUTPUT(0);
// 1972 printsymbol('*')
_imp_PRINTSYMBOL(42);
// 1973 write(current line, 3)
_imp_WRITE(CURRENTLINE, 3);
// 1974 space
_imp_SPACE();
// 1975 printstring(opcode)
_imp_PRINTSTRING(
*({
__typeof__(_imp_string7) tmp = OPCODE /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1976 printstring(": ")
_imp_PRINTSTRING(_imp_str_literal(": "));
// 1977 printstring(s)
_imp_PRINTSTRING(
*({
__typeof__(_imp_string255) tmp = S /*q*/;
(_imp_string255 *)&tmp;
})
);
// 1978 newline
_imp_NEWLINE();
// 1979 selectoutput(object)
_imp_SELECTOUTPUT(2);
// 1980 %while sym # ';' %cycle
L_00FF:;
if (SYM == 59) goto L_0100;
// 1981 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 1982 %repeat
goto L_00FF;
L_0100:;
// 1983 %end
return;
} /* end of MCERROR */
// 1984 %routine get opcode
void GETOPCODE(void) {
// 1985 opcode = ""; op = 0
_imp_strncpy(/*?*/ &OPCODE, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 7);
OP = 0;
// 1986 %cycle
L_0101:;
// 1987 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 1988 %exit %if sym = '_'
if (SYM != 95) goto L_0102;
goto L_0103;
L_0102:;
// 1989 %if length(opcode) # 6 %start
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &OPCODE) == 6) goto L_0104;
// 1990 op = op<<6!!sym
OP = OP << 6 ^ SYM;
// 1991 opcode = opcode.tostring(sym)
_imp_strncpy(/*?*/ &OPCODE, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &OPCODE, ({
__typeof__(_imp_string1) tmp; /*E*/
tmp = _imp_TOSTRING(SYM);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 7);
// 1992 %finish
L_0104:;
// 1993 %repeat
goto L_0101;
L_0103:;
// 1994 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 1995 %end
return;
} /* end of GETOPCODE */
// 1996 %integerfn find opcode
int FINDOPCODE(void) {
// 1997 %integer high, low, p
int HIGH;
int LOW;
int P;
// 1998 high = mc entries; low = 1
HIGH = 204;
LOW = 1;
// 1999 %while high >= low %cycle
L_0105:;
if (HIGH < LOW) goto L_0106;
// 2000 p = (high+low)>>1
P = (unsigned int)HIGH + LOW >> 1;
// 2001 %result = p %if mcop(p) = op
if (MCOP[P - 1] != OP) goto L_0107;
return P;
L_0107:;
// 2002 %if mcop(p) > op %then high = p-1 %else low = p+1
if (MCOP[P - 1] <= OP) goto L_0108;
HIGH = P - 1;
goto L_0109;
L_0108:;
LOW = P + 1;
L_0109:;
// 2003 %repeat
goto L_0105;
L_0106:;
// 2004 mc error("unknown operation")
MCERROR(_imp_str_literal("unknown operation"));
// 2005 %result = 0
return 0;
// 2006 %end
} /* end of FINDOPCODE */
// 2007 %predicate value(%integername n)
int VALUE(int *N) {
// 2008 n = 0
*N = 0;
// 2009 %false %unless '0' <= sym <= '7'
{
// Double-sided test on SYM (Part I)
int tmp;
if (48 > (tmp = SYM)) goto L_010A;
// Double-sided test on SYM (Part II)
if (tmp <= 55) goto L_010B;
}
L_010A:;
return 0 /*FALSE*/;
L_010B:;
// 2010 %cycle
L_010C:;
// 2011 n = n<<3!(sym-'0')
*N = *N << 3 | SYM - 48;
// 2012 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 2013 %true %unless '0' <= sym <= '7'
{
// Double-sided test on SYM (Part I)
int tmp;
if (48 > (tmp = SYM)) goto L_010D;
// Double-sided test on SYM (Part II)
if (tmp <= 55) goto L_010E;
}
L_010D:;
return 1 /*TRUE*/;
L_010E:;
// 2014 %repeat
goto L_010C;
// 2015 %end
} /* end of VALUE */
// 2016 %predicate register(%integername r)
int REGISTER(int *R) {
// 2017 %false %unless value(r)
if (VALUE(R)) goto L_010F;
return 0 /*FALSE*/;
L_010F:;
// 2018 %false %unless 0 <= r <= 15
{
// Double-sided test on R (Part I)
int tmp;
if (0 > (tmp = *R)) goto L_0110;
// Double-sided test on R (Part II)
if (tmp <= 15) goto L_0111;
}
L_0110:;
return 0 /*FALSE*/;
L_0111:;
// 2019 %true
return 1 /*TRUE*/;
// 2020 %end
} /* end of REGISTER */
// 2021 %predicate deal with plus minus
int DEALWITHPLUSMINUS(void) {
// 2022 %integer sign, n
int SIGN;
int N;
// 2023 %true %unless sym = '+' %or sym = '-'
if (SYM == 43) goto L_0112;
if (SYM == 45) goto L_0112;
return 1 /*TRUE*/;
L_0112:;
// 2024 sign = sym; sym = next; readsymbol(next)
SIGN = SYM;
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 2025 %unless value(n) %start
if (VALUE(/*?*/ &N)) goto L_0113;
// 2026 mc error("invalid offset")
MCERROR(_imp_str_literal("invalid offset"));
// 2027 %false
return 0 /*FALSE*/;
// 2028 %finish
L_0113:;
// 2029 n = -n %if sign = '-'
if (SIGN != 45) goto L_0114;
N = -N;
L_0114:;
// 2030 disp = disp+n
DISP = DISP + N;
// 2031 %true
return 1 /*TRUE*/;
// 2032 %end
} /* end of DEALWITHPLUSMINUS */
// 2033
// 2034 base = -1; index = -1; disp = 0
BASE = -1;
INDEX = -1;
DISP = 0;
// 2035 get opcode
GETOPCODE();
// 2036 p = find opcode; %return %if p = 0
P = FINDOPCODE();
if (P != 0) goto L_0115;
return;
L_0115:;
// 2037 flags = opflags(p)
FLAGS = OPFLAGS[P - 1];
// 2038
// 2039 %if flags&branch # 0 %start
if (FLAGS & 1 == 0) goto L_0116;
// 2040 reg = flags>>4&15; !cond-code
REG = (unsigned int)FLAGS >> 4 & 15;
// 2041 %else %unless register(reg)
goto L_0117;
L_0116:;
if (REGISTER(/*?*/ ®)) goto L_0118;
// 2042 mc error("register 1?"); %return
MCERROR(_imp_str_literal("register 1?"));
return;
// 2043 %else %if sym # ','
L_0118:;
if (SYM == 44) goto L_0119;
// 2044 mc error("comma missing"); %return
MCERROR(_imp_str_literal("comma missing"));
return;
// 2045 %else
L_0119:;
// 2046 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 2047 %finish
L_0117:;
// 2048 %if flags&rr # 0 %start
if (FLAGS & 2 == 0) goto L_011A;
// 2049 %unless register(base) %start
if (REGISTER(/*?*/ &BASE)) goto L_011B;
// 2050 mc error("register 2?"); %return
MCERROR(_imp_str_literal("register 2?"));
return;
// 2051 %finish
L_011B:;
// 2052 %else %if sym = ' '; !named operand
goto L_011C;
L_011A:;
if (SYM != 32) goto L_011D;
// 2053 n = tag
N = TAG();
// 2054 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 2055 v == var(n)
V = (struct VARFM *)/*?*/ &VAR[N];
// 2056 disp = v_disp
DISP = V->DISP;
// 2057 %if v_form = pgm label %start; !%label
if (V->FORM != 14) goto L_011E;
// 2058 define reference(disp&X'FFF', r ref); !make it look like a routine
DEFINEREFERENCE(DISP & 4095, 2);
// 2059 disp = 0; Base = Code
DISP = 0;
BASE = 15;
// 2060 %return %unless deal with plus minus
if (DEALWITHPLUSMINUS()) goto L_011F;
return;
L_011F:;
// 2061 %else
goto L_0120;
L_011E:;
// 2062 base = actual(v_base) %unless v_base = 0
if (V->BASE == 0) goto L_0121;
BASE = ACTUAL[V->BASE];
L_0121:;
// 2063 %return %unless deal with plus minus
if (DEALWITHPLUSMINUS()) goto L_0122;
return;
L_0122:;
// 2064 %if sym = '(' %start
if (SYM != 40) goto L_0123;
// 2065 ->ix %if base > 0
if (BASE <= 0) goto L_0124;
goto U_1007;
L_0124:;
// 2066 ->ib
goto U_1008;
// 2067 %finish
L_0123:;
// 2068 %finish
L_0120:;
// 2069 %else
goto L_011C;
L_011D:;
// 2070 %if sym = '-' %and deal with plus minus %start
if (SYM != 45) goto L_0125;
if (!(DEALWITHPLUSMINUS())) goto L_0125;
// 2071 !only needs the side-effect of deal with ..
// 2072 %else %unless value(disp)
goto L_0126;
L_0125:;
if (VALUE(/*?*/ &DISP)) goto L_0127;
// 2073 mc error("displacement?"); %return
MCERROR(_imp_str_literal("displacement?"));
return;
// 2074 %finish
L_0127:;
L_0126:;
// 2075 %return %unless deal with plus minus
if (DEALWITHPLUSMINUS()) goto L_0128;
return;
L_0128:;
// 2076 %if sym = '(' %start
if (SYM != 40) goto L_0129;
// 2077 ib: sym = next; readsymbol(next)
U_1008:;
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 2078 %unless register(base) %start
if (REGISTER(/*?*/ &BASE)) goto L_012A;
// 2079 mc error("base register?"); %return
MCERROR(_imp_str_literal("base register?"));
return;
// 2080 %finish
L_012A:;
// 2081 %if sym = ',' %start
if (SYM != 44) goto L_012B;
// 2082 ix: sym = next; readsymbol(next)
U_1007:;
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 2083 %if flags&indexed = 0 %start
if (FLAGS & 4 != 0) goto L_012C;
// 2084 mc error("no double indexed form"); %return
MCERROR(_imp_str_literal("no double indexed form"));
return;
// 2085 %finish
L_012C:;
// 2086 %unless register(index) %start
if (REGISTER(/*?*/ &INDEX)) goto L_012D;
// 2087 mc error("index register?"); %return
MCERROR(_imp_str_literal("index register?"));
return;
// 2088 %finish
L_012D:;
// 2089 %finish
L_012B:;
// 2090 %if sym # ')' %start
if (SYM == 41) goto L_012E;
// 2091 mc error(") missing"); %return
MCERROR(_imp_str_literal(") missing"));
return;
// 2092 %finish
L_012E:;
// 2093 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 2094 %finish
L_0129:;
// 2095 %finish
L_011C:;
// 2096 %if sym # ';' %start
if (SYM == 59) goto L_012F;
// 2097 mc error("form?"); %return
MCERROR(_imp_str_literal("form?"));
return;
// 2098 %finish
L_012F:;
// 2099
// 2100 base = 0 %if base < 0
if (BASE >= 0) goto L_0130;
BASE = 0;
L_0130:;
// 2101 index = 0 %if index < 0
if (INDEX >= 0) goto L_0131;
INDEX = 0;
L_0131:;
// 2102 base = index %and index = 0 %if base = 0 %and index # 0
if (BASE != 0) goto L_0132;
if (INDEX == 0) goto L_0132;
BASE = INDEX;
INDEX = 0;
L_0132:;
// 2103
// 2104 cput(flags&x'FF00'+reg<<4+base)
CPUT((FLAGS & 65280) + (REG << 4) + BASE);
// 2105 %if flags&ri1 # 0 %start
if (FLAGS & 8 == 0) goto L_0133;
// 2106 cput(disp&x'FFFF')
CPUT(DISP & 65535);
// 2107 %else %if flags&ri2 # 0 %and flags&branch = 0
goto L_0134;
L_0133:;
if (FLAGS & 16 == 0) goto L_0135;
if (FLAGS & 1 != 0) goto L_0135;
// 2108 cput(disp>>16); cput(disp&x'FFFF')
CPUT((unsigned int)DISP >> 16);
CPUT(DISP & 65535);
// 2109 %else %if flags&rr = 0
goto L_0134;
L_0135:;
if (FLAGS & 2 != 0) goto L_0136;
// 2110 %if disp>>14 # 0 %or index > 0 %start
if ((unsigned int)DISP >> 14 != 0) goto L_0137;
if (INDEX <= 0) goto L_0138;
L_0137:;
// 2111 mc error("no RX3 form") %and %return %if flags&indexed = 0
if (FLAGS & 4 != 0) goto L_0139;
MCERROR(_imp_str_literal("no RX3 form"));
return;
L_0139:;
// 2112 cput(x'4000'+index<<8+disp>>16&x'FF')
CPUT(16384 + (INDEX << 8) + ((unsigned int)DISP >> 16 & 255));
// 2113 %finish
L_0138:;
// 2114 cput(disp&x'FFFF')
CPUT(DISP & 65535);
// 2115 %finish
L_0136:;
L_0134:;
// 2116 %end
return;
} /* end of MACHINECODE */
// 2117
// 2118 ! >> SET DOPE VECTOR <<
// 2119 %routine set dope vector
void SETDOPEVECTOR(void) {
// 2120 %integer t
int T;
// 2121 t = vub-vlb+1
T = VUB - VLB + 1;
// 2122 claim literal(4*reglen,3)
CLAIMLITERAL(4 * 4, 3);
// 2123 select literal area
SELECTLITERALAREA();
// 2124 dv = ca
DV = CA;
// 2125 cword(1)
CWORD(1);
// 2126 cword(vlb); cword(vub)
CWORD(VLB);
CWORD(VUB);
// 2127 cword(data size)
CWORD(DATASIZE);
// 2128 select code area
SELECTCODEAREA();
// 2129 vub = t*data size; vlb = vlb*data size
VUB = T * DATASIZE;
VLB = VLB * DATASIZE;
// 2130 %end
return;
} /* end of SETDOPEVECTOR */
// 2131
// 2132 ! >> PERM <<
// 2133 %routine perm(%integer n)
void PERM(int N) {
// 2134 %constinteger g0=1, g1=2, g2=4, g3=8, g4=16, g5=32, g6=64; ! General Registers
// 2135 %constinteger f0=128, f2=256; ! Floating Registers
// 2136 %constinteger prot = (-1)<<15; ! protect stack around call
// 2137 %constshortintegerarray rmap(0:8) = R0, R1, R2, R3, R4, P2, P1, FR0, FR2
const short int RMAP[9] = {1, 2, 3, 4, 5, 6, 7, 17, 18};
// 2138 %integer k,r,h
int K;
int R;
int H;
// 2139 !
// 2140 ! **** N.B. The following table must match the properties of the perm
// 2141 ! routines in use.
// 2142 %constinteger perm routines = 50
// 2143 %constshortintegerarray hazard reg(1:perm routines) =
const short int HAZARDREG[50] = {0, 9, 385, 25, 41, 63, 97, 0, 57, 384, 0, -32753, 7, 19, 51, 19, 15,
33, 0, 0, 0, 0, 0, 3, 0, 28, 9, 9, 0, 25, 3, 2, 258, 57,
127, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 511, 511};
// 2144+ 0, ; ! 1: ASSCHK
// 2145+ G0+G3, ; ! 2: IEXP
// 2146+ G0+F0+F2, ; ! 3: REXP
// 2147+ G0+G3+G4, ; ! 4: SMOVE
// 2148+ G0+G3+G5, ; ! 4: SJAM
// 2149+ G0+G1+G2+G3+G4+G5, ; ! 6: SCONC
// 2150+ G0+G5+G6, ; ! 7: SRESLN
// 2151+ 0, ; ! 8: SRESV
// 2152+ G0+G3+G4+G5, ; ! 9: SCOMP
// 2153+ F0+F2, ; ! 10: FRAC PT
// 2154+ 0, ; ! 11: SFCAP
// 2155+ G0+G1+G2+G3+prot, ; ! 12: SUBSTR
// 2156+ G0+G1+G2, ; ! 13: AREF1
// 2157+ G0+G1+G4, ; ! 14: AREF2
// 2158+ G0+G1+G4+G5, ; ! 15: AREF3
// 2159+ G0+G1+G4, ; ! 16: AREF4
// 2160+ G0+G1+G2+G3, ; ! 17: SETDV
// 2161+ G0+G5, ; ! 18: ALLOC
// 2162+ 0, ; ! 19: SWJMP
// 2163+ 0, ; ! 20: SIGNAL
// 2164+ 0, ; ! 21: MULCHK
// 2165+ 0, ; ! 22: CAP16
// 2166+ 0, ; ! 23: CAP8
// 2167+ G0+G1, ; ! 24: FCHK1
// 2168+ 0, ; ! 25: FCHK2
// 2169+ G2+G3+G4, ; ! 26: PENTC
// 2170+ G0+G3, ; ! 27: RCOPY
// 2171+ G0+G3, ; ! 28: RZERO
// 2172+ 0, ; ! 29: VSCHK
// 2173+ G0+G3+G4, ; ! 30: SMOVOPT
// 2174+ G0+G1, ; ! 31: CHMAP
// 2175+ G1, ; ! 32: FREESP
// 2176+ G1+F2, ; ! 33: INT
// 2177+ G0+G3+G4+G5, ; ! 34: RECORD COMPARE
// 2178+ G0+G1+G2+G3+G4+G5+G6, ; ! 35: SET COMPARE
// 2179+ G0+G3, ; ! 36: SET UNION
// 2180+ G0+G3, ; ! 37: SET DIFFERENCE
// 2181+ G0+G3, ; ! 38: SET INTERSECTION
// 2182+ 0, ; ! 39:
// 2183+ 0, ; ! 40:
// 2184+ 0, ; ! 41:
// 2185+ 0, ; ! 42:
// 2186+ 0, ; ! 43:
// 2187+ 0, ; ! 44:
// 2188+ 0, ; ! 45:
// 2189+ 0, ; ! 46:
// 2190+ 0, ; ! 47:
// 2191+ 0, ; ! 48:
// 2192+ G0+G1+G2+G3+G4+G5+G6+F0+F2, ; ! 49: IOCP
// 2193+ G0+G1+G2+G3+G4+G5+G6+F0+F2 ; ! 50: ENTER TRACE
// 2194
// 2195 h = hazard reg(n); ! property mask for nth. perm routine
H = HAZARDREG[N - 1];
// 2196 %if claimed # 0 %start; ! maybe something to do .. perhaps
if (CLAIMED == 0) goto L_013A;
// 2197 k = h&x'7FFF'; ! register mask
K = H & 32767;
// 2198 r = 0
R = 0;
// 2199 %while k # 0 %cycle
L_013B:;
if (K == 0) goto L_013C;
// 2200 hazard(rmap(r)) %if k&1 # 0
if (K & 1 == 0) goto L_013D;
HAZARD(RMAP[R]);
L_013D:;
// 2201 k = k>>1
K = (unsigned int)K >> 1;
// 2202 r = r+1
R = R + 1;
// 2203 %repeat
goto L_013B;
L_013C:;
// 2204 %finish
L_013A:;
// 2205
// 2206 ! forget all registers which are at risk
// 2207 r = ( ((h&(F0+F2)) << (FR0-P1)) ! (h&127) ) << 1; ! ** N.B. P1 == G6
R = ((H & 128 + 256) << 17 - 7 | H & 127) << 1;
// 2208 forget reg(r)
FORGETREG(R);
// 2209
// 2210 rxi(ADD,wsp,0,wdisp) %if h < 0 %and wdisp # 0
if (H >= 0) goto L_013E;
if (WDISP == 0) goto L_013E;
RXI(3, 8, 0, WDISP);
L_013E:;
// 2211 define reference(n&255,p ref)
DEFINEREFERENCE(N & 255, 3);
// 2212 rx(bal,link,code,n&255)
RX(22, 16, 15, N & 255);
// 2213 %if h < 0 %start
if (H >= 0) goto L_013F;
// 2214 rxi(SUB,wsp,0,wdisp) %if wdisp # 0
if (WDISP == 0) goto L_0140;
RXI(4, 8, 0, WDISP);
L_0140:;
// 2215 wdisp = wdisp + basic frame + 256; ! protect it
WDISP = WDISP + 44 + 256;
// 2216 %finish
L_013F:;
// 2217 %end
return;
} /* end of PERM */
// 2218
// 2219 ! >> DUMP TRACE <<
// 2220 %routine DUMP TRACE
void DUMPTRACE(void) {
// 2221 %if current line # last line %start
if (CURRENTLINE == LASTLINE) goto L_0141;
// 2222 trace flag = 0
TRACEFLAG = 0;
// 2223 perm(enter trace); cput(current line)
PERM(50);
CPUT(CURRENTLINE);
// 2224 %finish
L_0141:;
// 2225 %end
return;
} /* end of DUMPTRACE */
// 2226
// 2227 ! >> ASSEMBLE <<
// 2228 ! AMODE:
// 2229 ! -2: alternate record format
// 2230 ! -1: record format
// 2231 ! 0: procedure
// 2232 ! 1: %spec
// 2233 ! 2: initial call
// 2234
// 2235 %routine Assemble(%integer amode, labs, names)
void ASSEMBLE(int AMODE, int LABS, int NAMES) {
// 2236 %switch c(33:127), Pc('A':'Z')
int C_index;
int C_line;
char *C_file;
static const void *C[95] = {
&&case_C_33, &&case_C_34, &&case_C_35, &&case_C_36, &&case_C_37, &&case_C_38,
&&case_C_39, &&case_C_40, &&case_C_41, &&case_C_42, &&case_C_43, &&case_C_default,
&&case_C_45, &&case_C_46, &&case_C_47, &&case_C_default, &&case_C_default, &&case_C_default,
&&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default,
&&case_C_default, &&case_C_58, &&case_C_59, &&case_C_60, &&case_C_61, &&case_C_62,
&&case_C_63, &&case_C_64, &&case_C_65, &&case_C_66, &&case_C_67, &&case_C_68,
&&case_C_69, &&case_C_70, &&case_C_71, &&case_C_72, &&case_C_73, &&case_C_74,
&&case_C_75, &&case_C_76, &&case_C_77, &&case_C_78, &&case_C_79, &&case_C_80,
&&case_C_81, &&case_C_82, &&case_C_83, &&case_C_84, &&case_C_85, &&case_C_86,
&&case_C_87, &&case_C_88, &&case_C_default, &&case_C_90, &&case_C_91, &&case_C_92,
&&case_C_93, &&case_C_94, &&case_C_95, &&case_C_default, &&case_C_97, &&case_C_98,
&&case_C_default, &&case_C_100, &&case_C_101, &&case_C_102, &&case_C_103, &&case_C_104,
&&case_C_105, &&case_C_106, &&case_C_107, &&case_C_108, &&case_C_109, &&case_C_110,
&&case_C_111, &&case_C_112, &&case_C_113, &&case_C_114, &&case_C_115, &&case_C_116,
&&case_C_117, &&case_C_118, &&case_C_119, &&case_C_120, &&case_C_121, &&case_C_122,
&&case_C_123, &&case_C_default, &&case_C_125, &&case_C_126, &&case_C_default};
int PC_index;
int PC_line;
char *PC_file;
static const void *PC[26] = {&&case_PC_65, &&case_PC_66, &&case_PC_67, &&case_PC_68,
&&case_PC_missing, &&case_PC_missing, &&case_PC_71, &&case_PC_72,
&&case_PC_73, &&case_PC_74, &&case_PC_75, &&case_PC_76,
&&case_PC_missing, &&case_PC_78, &&case_PC_missing, &&case_PC_missing,
&&case_PC_missing, &&case_PC_missing, &&case_PC_83, &&case_PC_missing,
&&case_PC_missing, &&case_PC_missing, &&case_PC_87, &&case_PC_missing,
&&case_PC_missing, &&case_PC_missing};
// 2237 %recordformat evfm(%integer low, high, events, label)
struct EVFM {
union {
struct {
int LOW;
int HIGH;
int EVENTS;
int LABEL;
};
};
};
// 2238 %record(evfm) event = 0
struct EVFM EVENT;
EVENT = (struct EVFM){0};
// 2239 %record(varfm)%name v
struct VARFM *V;
// 2240 %record(varfm)%name gvar {procedure var}
struct VARFM *GVAR;
// 2241 %record(stackfm)%name lhs, rhs, x
struct STACKFM *LHS;
struct STACKFM *RHS;
struct STACKFM *X;
// 2242 %integer old frame, old extra frame, old jump
int OLDFRAME;
int OLDEXTRAFRAME;
int OLDJUMP;
// 2243 %integer old temp base, old next temp
int OLDTEMPBASE;
int OLDNEXTTEMP;
// 2244 %integer true frame base, putative frame base, max frame, alt first, alt align=0
int TRUEFRAMEBASE;
int PUTATIVEFRAMEBASE;
int MAXFRAME;
int ALTFIRST;
int ALTALIGN;
ALTALIGN = 0;
// 2245 %integer old var diags
int OLDVARDIAGS;
// 2246 %integer gstart {first descriptor at this level}
int GSTART;
// 2247 %integer label start {first label for this level}
int LABELSTART;
// 2248 %owninteger free tag = 0
static int FREETAG = 0;
// 2249 %integer max local = 0
int MAXLOCAL;
MAXLOCAL = 0;
// 2250 %integer max parm = 0
int MAXPARM;
MAXPARM = 0;
// 2251 %integer min parm = 0 {P1, P2 parameter registers used ?}
int MINPARM;
MINPARM = 0;
// 2252 %integer mark assigned = 1 {mark VAR table entries as 'assigned' if # 0}
int MARKASSIGNED;
MARKASSIGNED = 1;
// 2253 %integer Closed = Assigned {assume it can't return}
int CLOSED;
CLOSED = 8;
// 2254 %integer Return Label = 0 {label on return code}
int RETURNLABEL;
RETURNLABEL = 0;
// 2255 %integer px = 0
int PX;
PX = 0;
// 2256 %integer proc ca = ca
int PROCCA;
PROCCA = CA;
// 2257 %integer sw list = 0
int SWLIST;
SWLIST = 0;
// 2258 %integer last a = -1
int LASTA;
LASTA = -1;
// 2259 %integer line size = 0
int LINESIZE;
LINESIZE = 0;
// 2260 %integer block index
int BLOCKINDEX;
// 2261 %integer j, k, t
int J;
int K;
int T;
auto void COMPILETOSTRING(struct STACKFM * V);
auto void POPLHS(void);
auto void LRD(struct STACKFM * V, int REG);
auto void LOAD(struct STACKFM * V, int R);
auto void ASSIGN(int ASSOP);
auto void ARRAYREF(int MODE);
auto void OPERATE(int OPER);
auto void COMPARE(struct STACKFM * L, struct STACKFM * R, int NEXT);
auto void TESTZERO(struct STACKFM * V);
auto void HEADER(struct VARFM * V);
auto void BLOCKMARK(int MARK);
auto int NEWTAG(void);
// 2262
// 2263 %routinespec compile to string(%record(stackfm)%name v)
// 2264 %routinespec pop lhs
// 2265 %routinespec lrd(%record(stackfm)%name v, %integer reg)
// 2266 %routinespec load(%record(stackfm)%name v, %integer reg)
// 2267 %routinespec assign(%integer assop)
// 2268 %routinespec array ref(%integer mode)
// 2269 %routinespec operate(%integer n)
// 2270 %routinespec compare(%record(stackfm)%name l,r, %integer next)
// 2271 %routinespec test zero(%record(stackfm)%name v)
// 2272 %routinespec header(%record(varfm)%name v)
// 2273 %routinespec block mark(%integer mark)
// 2274 %integerfnspec new tag
// 2275
// 2276 old jump = uncond jump; uncond jump = -1
OLDJUMP = UNCONDJUMP;
UNCONDJUMP = -1;
// 2277 old var diags = var diags; var diags = 0
OLDVARDIAGS = VARDIAGS;
VARDIAGS = 0;
// 2278 label start = labs
LABELSTART = LABS;
// 2279 old frame = frame; old extra frame = extra frame; extra frame = 0
OLDFRAME = FRAME;
OLDEXTRAFRAME = EXTRAFRAME;
EXTRAFRAME = 0;
// 2280 old temp base = temp base; old next temp = next temp
OLDTEMPBASE = TEMPBASE;
OLDNEXTTEMP = NEXTTEMP;
// 2281 temp base = new temp; Next Temp = New Temp
TEMPBASE = NEWTEMP;
NEXTTEMP = NEWTEMP;
// 2282 forget the lot:
U_1009:;
// 2283 pdisp = 0; wdisp = 0; gdisp = -1; event_events = 0
PDISP = 0;
WDISP = 0;
GDISP = -1;
EVENT.EVENTS = 0;
// 2284 abort(m'-1 ?') %unless gdisp = -1; !************????????????
if (GDISP == -1) goto L_0142;
ABORT(758194239);
L_0142:;
// 2285 gvar == decvar; gstart = names
GVAR = (struct VARFM *)DECVAR;
GSTART = NAMES;
// 2286 %if amode >= 0 %start; ! NOT A RECORDFORMAT
if (AMODE < 0) goto L_0143;
// 2287 frame = basic frame; ca = 0
FRAME = 44;
CA = 0;
// 2288 level = level+1; abort(m'AM00') %if level > 5 %and spec = 0
LEVEL = LEVEL + 1;
if (LEVEL <= 5) goto L_0144;
if (SPEC != 0) goto L_0144;
ABORT(1095577648);
L_0144:;
// 2289 local = breg(level)
LOCAL = BREG[LEVEL + 1];
// 2290 activity(local) = -1
ACTIVITY[LOCAL] = -1;
// 2291 gdisp = (p1-p2)*reglen
GDISP = (7 - 6) * 4;
// 2292 Reset Optimisation Data %if Spec = 0
if (SPEC != 0) goto L_0145;
RESETOPTIMISATIONDATA();
L_0145:;
// 2293 %if amode = 0 %start; ! procedure, proc. parameter, %begin block
if (AMODE != 0) goto L_0146;
// 2294 block no = block no + 1; block index = block no
BLOCKNO = BLOCKNO + 1;
BLOCKINDEX = BLOCKNO;
// 2295 block mark(block start)
BLOCKMARK(16);
// 2296 %if sym = 'H' %start; ! %BEGIN block
if (SYM != 72) goto L_0147;
// 2297 gdisp = -1
GDISP = -1;
// 2298 %if level = 1 %start; ! Initial %begin ?
if (LEVEL != 1) goto L_0148;
// 2299 external id = program ep; ! linkage to program entry
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string3) tmp; /*B*/
tmp = PROGRAMEP;
(void *)&tmp;
}),
/*max:*/ 19);
// 2300 otype = external; potype = otype
OTYPE = 3;
POTYPE = OTYPE;
// 2301 %finish
L_0148:;
// 2302 header(gvar)
HEADER(GVAR);
// 2303 %finish
L_0147:;
// 2304 %finish
L_0146:;
// 2305 %else
goto L_0149;
L_0143:;
// 2306 %if amode = -1 %start; ! record format
if (AMODE != -1) goto L_014A;
// 2307 gvar_extra = parms
GVAR->EXTRA = PARMS;
// 2308 frame = 0
FRAME = 0;
// 2309 %finish
L_014A:;
// 2310 true frame base = frame
TRUEFRAMEBASE = FRAME;
// 2311 putative frame base = (frame+align)&(\align)
PUTATIVEFRAMEBASE = FRAME + 3 & (~3);
// 2312 frame = putative frame base
FRAME = PUTATIVEFRAMEBASE;
// 2313 max frame = frame
MAXFRAME = FRAME;
// 2314 alt first = parms-1; ! note start of this alternative list
ALTFIRST = PARMS - 1;
// 2315 %finish
L_0149:;
// 2316
// 2317
// 2318 ! >> BLOCK MARK <<
// 2319 %routine block mark(%integer mark)
void BLOCKMARK(int MARK) {
// 2320 %integer k, limit
int K;
int LIMIT;
// 2321 k = direct
K = 1;
// 2322 %cycle
L_014B:;
// 2323 select output(k)
_imp_SELECTOUTPUT(K);
// 2324 print symbol(mark)
_imp_PRINTSYMBOL(MARK);
// 2325 %if mark = block start %start
if (MARK != 16) goto L_014C;
// 2326 print symbol(block index)
_imp_PRINTSYMBOL(BLOCKINDEX);
// 2327 %if k = object %start; ! procedure head diagnostics
if (K != 2) goto L_014D;
// 2328 put(current line); last line = -15; !force a reset
PUT(CURRENTLINE);
LASTLINE = -15;
// 2329 describe(-1,0,block name); ! internal name for procedure
DESCRIBE(-1, 0, (_imp_string19 *)/*p*/ /*?*/ &BLOCKNAME);
// 2330 %finish
L_014D:;
// 2331 %else %if k = direct; ! %and mark = block end (by implication)
goto L_014E;
L_014C:;
if (K != 1) goto L_014F;
// 2332 abort(m'TAG?') %if free tag > 32767; ! too many pass3 tags
if (FREETAG <= 32767) goto L_0150;
ABORT(1413564223);
L_0150:;
// 2333 put(ca>>1); ! code size for this block (half words)
PUT((unsigned int)CA >> 1);
// 2334 put(var diags); ! var. diags local to this block
PUT(VARDIAGS);
// 2335 frame = (frame+align)&(\align)
FRAME = FRAME + 3 & (~3);
// 2336 k = frame + extra frame; ! include in-frame array space
K = FRAME + EXTRAFRAME;
// 2337 %if control & trusted = 0 %start
if (CONTROL & 32 != 0) goto L_0151;
// 2338 ! using checked (perm) entry sequence
// 2339 k = k>>2; ! to full word units
K = (unsigned int)K >> 2;
// 2340 limit = 65535; ! treated as unsigned 16 bits by perm
LIMIT = 65535;
// 2341 %else
goto L_0152;
L_0151:;
// 2342 ! in-line entry sequence
// 2343 limit = 32767; ! must be positive 2's complement (byte units)
LIMIT = 32767;
// 2344 %finish
L_0152:;
// 2345 abort(m'FRM?') %unless 0 < k <= limit
{
// Double-sided test on K (Part I)
int tmp;
if (0 >= (tmp = K)) goto L_0153;
// Double-sided test on K (Part II)
if (tmp <= LIMIT) goto L_0154;
}
L_0153:;
ABORT(1179798847);
L_0154:;
// 2346 put(k)
PUT(K);
// 2347 print symbol(actual(local)); ! current display register
_imp_PRINTSYMBOL(ACTUAL[LOCAL]);
// 2348 put(event_events); ! events-trapped mask
PUT(EVENT.EVENTS);
// 2349 put(event_label); ! Event block ep
PUT(EVENT.LABEL);
// 2350 put(event_low); ! Event block %finish
PUT(EVENT.LOW);
// 2351 total ca = total ca + ca
TOTALCA = TOTALCA + CA;
// 2352 %finish
L_014F:;
L_014E:;
// 2353 %exit %if k = object
if (K != 2) goto L_0155;
goto L_0156;
L_0155:;
// 2354 k = object
K = 2;
// 2355 %repeat
goto L_014B;
L_0156:;
// 2356 last ca = -1
LASTCA = -1;
// 2357 %end; ! block mark
return;
} /* end of BLOCKMARK */
// 2358
// 2359 ! >> SET FRAME PATCH <<
// 2360 %routine set frame patch
void SETFRAMEPATCH(void) {
// 2361 %if diagnose < 0 %start
if (DIAGNOSE >= 0) goto L_0157;
// 2362 select output(report)
_imp_SELECTOUTPUT(0);
// 2363 print string(" Block index"); write(block index,1)
_imp_PRINTSTRING(_imp_str_literal(" Block index"));
_imp_WRITE(BLOCKINDEX, 1);
// 2364 newline
_imp_NEWLINE();
// 2365 select output(object)
_imp_SELECTOUTPUT(2);
// 2366 %finish
L_0157:;
// 2367 print symbol(frame patch)
_imp_PRINTSYMBOL(15);
// 2368 %end; ! set frame patch
return;
} /* end of SETFRAMEPATCH */
// 2369
// 2370 ! >> DEFINE VAR <<
// 2371 %routine define var
void DEFINEVAR(void) {
// 2372 %integer type, form, tf, size, format, s, new, round, dimension
int TYPE;
int FORM;
int TF;
int SIZE;
int FORMAT;
int S;
int NEW;
int ROUND;
int DIMENSION;
// 2373 %integer ignore; ! ** used to control dumping of diags **
int IGNORE;
// 2374 %record(stackfm) temp
struct STACKFM TEMP;
// 2375 %integer k
int K;
// 2376 !!!*** N.B. On machines with the PDP-11/VAX perversion relating to the order
// 2377 ! of register bytes in store, the following table will have to
// 2378 ! be changed as will a few constants in this routine.
// 2379 ! The relevant piece of record format to consider is:
// 2380 ! (%shortinteger xform %or %byteinteger flag,form)
// 2381 ! which must have the effect of mapping 'flag' onto the
// 2382 ! more significant byte of 'xform'.
// 2383 %constshortintegerarray fmap(0:18) = 0,
const short int FMAP[19] = {0, 4, 6, 14, 15, 0, 0, 4096, 4097, 4100,
4101, 8196, 16388, 40964, 49156, 8199, 16391, 40967, 49159};
// 2384+ V in S, {simple variable}
// 2385+ A in S, {name: pointer variable}
// 2386+ pgm label, {label ** SPECIAL **}
// 2387+ 15, {record format **SPECIAL**}
// 2388+ 0, {unused}
// 2389+ 0, {switch}
// 2390+ proc bit<<8 + 0, {routine}
// 2391+ proc bit<<8 + V in R, {function}
// 2392+ proc bit<<8 + V in S, {map}
// 2393+ proc bit<<8 + 5, {predicate}
// 2394+ abit<<8 + V in S, {array}
// 2395+ anbit<<8 + V in S, {array name}
// 2396+ (abit+label bit)<<8 + V in S, {name array}
// 2397+ (anbit+label bit)<<8 + V in S, {name array name}
// 2398+ ! external manifestations of array forms
// 2399+ abit<<8 + V in REC, {external array}
// 2400+ anbit<<8 + V in REC, {external array name}
// 2401+ (abit+label bit)<<8 + V in REC, {external name array}
// 2402+ (anbit+label bit)<<8 + V in REC {external name array name}
// 2403 %constbyteintegerarray vsize(0:8) = 0,4,2,1,8,0,0,4,8
const unsigned char VSIZE[9] = {0, 4, 2, 1, 8, 0, 0, 4, 8};
// 2404 %owninteger prim no = 0
static int PRIMNO = 0;
// 2405 ignore = 0
IGNORE = 0;
// 2406 ignore = 1 %if amode < 0 %or amode = 1; ! no diags for specs of any kind!!
if (AMODE < 0) goto L_0158;
if (AMODE != 1) goto L_0159;
L_0158:;
IGNORE = 1;
L_0159:;
// 2407 internal id = ""; new = 0; round = align
_imp_strncpy(/*?*/ &INTERNALID, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 19);
NEW = 0;
ROUND = 3;
// 2408 decl = tag
DECL = TAG();
// 2409 %if decl = 0 %start; ! RECORD FORMAT ELEMENT NAME
if (DECL != 0) goto L_015A;
// 2410 parms = parms-1; abort(m'DFV1') %if parms <= names
PARMS = PARMS - 1;
if (PARMS > NAMES) goto L_015B;
ABORT(1145460273);
L_015B:;
// 2411 decvar == var(parms)
DECVAR = (struct VARFM *)/*?*/ &VAR[PARMS];
// 2412 decvar = 0; !(psr)
*DECVAR = (struct VARFM){0};
// 2413 %else
goto L_015C;
L_015A:;
// 2414 abort(m'DFV2') %if decl >= parms
if (DECL < PARMS) goto L_015D;
ABORT(1145460274);
L_015D:;
// 2415 decvar == var(decl)
DECVAR = (struct VARFM *)/*?*/ &VAR[DECL];
// 2416 %if decl > names %start
if (DECL <= NAMES) goto L_015E;
// 2417 names = decl; new = 1
NAMES = DECL;
NEW = 1;
// 2418 decvar = 0
*DECVAR = (struct VARFM){0};
// 2419 %finish
L_015E:;
// 2420 %finish
L_015C:;
// 2421 %cycle
L_015F:;
// 2422 sym = next; read symbol(next); %exit %if sym = ','
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
if (SYM != 44) goto L_0160;
goto L_0161;
L_0160:;
// 2423 %if length(internal id) # extern len %start
if (*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &INTERNALID) == 12) goto L_0162;
// 2424 internal id = internal id.to string(sym)
_imp_strncpy(/*?*/ &INTERNALID, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &INTERNALID, ({
__typeof__(_imp_string1) tmp; /*E*/
tmp = _imp_TOSTRING(SYM);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 19);
// 2425 %finish
L_0162:;
// 2426 %repeat
goto L_015F;
L_0161:;
// 2427 ignore = 1 %if internal id = ""
if (_imp_strcmp((_imp_string *)/*?*/ &INTERNALID, (_imp_string *)/*?*/ _imp_str_literal_ptr("")) != 0)
goto L_0163;
IGNORE = 1;
L_0163:;
// 2428 tf = tag; read symbol(next)
TF = TAG();
_imp_READSYMBOL(/*?*/ &NEXT);
// 2429 type = tf>>4; form = tf&15
TYPE = (unsigned int)TF >> 4;
FORM = TF & 15;
// 2430 size = tag; read symbol(next)
SIZE = TAG();
_imp_READSYMBOL(/*?*/ &NEXT);
// 2431 diag type = type; diag form = form; diag size = size
DIAGTYPE = TYPE;
DIAGFORM = FORM;
DIAGSIZE = SIZE;
// 2432 %if type = integers %and size # 1 %start; ! INTEGER
if (TYPE != 1) goto L_0164;
if (SIZE == 1) goto L_0164;
// 2433 type = byte %and round = 0 %if size = 2
if (SIZE != 2) goto L_0165;
TYPE = 3;
ROUND = 0;
L_0165:;
// 2434 type = short %and round = 1 %if size = 3
if (SIZE != 3) goto L_0166;
TYPE = 2;
ROUND = 1;
L_0166:;
// 2435 size = vsize(type)
SIZE = VSIZE[TYPE];
// 2436 %else %if type = 2; ! REAL
goto L_0167;
L_0164:;
if (TYPE != 2) goto L_0168;
// 2437 type = reals
TYPE = 7;
// 2438 ! *** for 8/32, 'round = 3' below should be changed to 'round = 7'
// 2439 !????????????? type = reall %and round = 3 %if size = 4; ! LONG REAL
// 2440 size = vsize(type)
SIZE = VSIZE[TYPE];
// 2441 %else %if type = 4; ! record
goto L_0167;
L_0168:;
if (TYPE != 4) goto L_0169;
// 2442 type = records
TYPE = 6;
// 2443 format = size
FORMAT = SIZE;
// 2444 decvar_format = format; size = var(format)_length&x'FFFF' %if format <= names
DECVAR->FORMAT = FORMAT;
if (FORMAT > NAMES) goto L_016A;
SIZE = VAR[FORMAT].LENGTH & 65535;
L_016A:;
// 2445 %else %if type = 3; ! string
goto L_0167;
L_0169:;
if (TYPE != 3) goto L_016B;
// 2446 type = strings
TYPE = 5;
// 2447 round = 0
ROUND = 0;
// 2448 decvar_length = size
DECVAR->LENGTH = SIZE;
// 2449 size = size + 1
SIZE = SIZE + 1;
// 2450 %else
goto L_0167;
L_016B:;
// 2451 size = vsize(type)
SIZE = VSIZE[TYPE];
// 2452 %finish
L_0167:;
// 2453 decvar_length = size %if type # strings
if (TYPE == 5) goto L_016C;
DECVAR->LENGTH = SIZE;
L_016C:;
// 2454 decvar_type = type; decvar_xform = fmap(form)
DECVAR->TYPE = TYPE;
DECVAR->XFORM = FMAP[FORM];
// 2455 otype = tag
OTYPE = TAG();
// 2456 spec = (otype>>3)&1; dimension = otype>>8&255; otype = otype&7
SPEC = (unsigned int)OTYPE >> 3 & 1;
DIMENSION = (unsigned int)OTYPE >> 8 & 255;
OTYPE = OTYPE & 7;
// 2457 %if otype # 0 %start; ! Set external linkage name if appropriate
if (OTYPE == 0) goto L_016D;
// 2458 %if otype >= external %start
if (OTYPE < 3) goto L_016E;
// 2459 %if alias # "" %start
if (_imp_strcmp((_imp_string *)/*?*/ &ALIAS, (_imp_string *)/*?*/ _imp_str_literal_ptr("")) == 0) goto L_016F;
// 2460 external id = alias
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string19) tmp; /*B*/
tmp = ALIAS;
(void *)&tmp;
}),
/*max:*/ 19);
// 2461 %else %if otype = system
goto L_0170;
L_016F:;
if (OTYPE != 4) goto L_0171;
// 2462 external id <- system prefix.internal id
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string255) tmp; /*C*/
tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ &SYSTEMPREFIX, (_imp_string *)/*?*/ &INTERNALID);
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 19);
/* truncated copy of no more than 19 chars */
if (*_imp_LENGTH((_imp_string *)/*?*/ &EXTERNALID) > 19) *_imp_LENGTH((_imp_string *)/*?*/ &EXTERNALID) = 19;
// 2463 %else
goto L_0170;
L_0171:;
// 2464 external id = internal id
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string19) tmp; /*B*/
tmp = INTERNALID;
(void *)&tmp;
}),
/*max:*/ 19);
// 2465 %finish
L_0170:;
// 2466 otype = external %if otype <= dynamic {external, system, dynamic}
if (OTYPE > 5) goto L_0172;
OTYPE = 3;
L_0172:;
// 2467 %finish
L_016E:;
// 2468 %finish
L_016D:;
// 2469 alias = ""
_imp_strncpy(/*?*/ &ALIAS, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 19);
// 2470 %if 7 <= form <= 10 %start; ! PROCEDURE
{
// Double-sided test on FORM (Part I)
int tmp;
if (7 > (tmp = FORM)) goto L_0173;
// Double-sided test on FORM (Part II)
if (tmp > 10) goto L_0173;
}
// 2471 gtype = spec
GTYPE = SPEC;
// 2472 %if otype # 0 %and spec # 0 %start; ! external spec
if (OTYPE == 0) goto L_0174;
if (SPEC == 0) goto L_0174;
// 2473 %if otype = primrt %start
if (OTYPE != 6) goto L_0175;
// 2474 primno = primno + 1
PRIMNO = PRIMNO + 1;
// 2475 decvar_flag = decvar_flag ! prim bit
DECVAR->FLAG = DECVAR->FLAG | 4;
// 2476 decvar_header = prim no; ! *** THIS NEEDS FIXING ***
DECVAR->HEADER = PRIMNO;
// 2477 %return %if prim no # 2; ! not READ SYMBOL
if (PRIMNO == 2) goto L_0176;
return;
L_0176:;
// 2478 otype = external; external id = read sym fn; ! see "CALL"
OTYPE = 3;
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string10) tmp; /*B*/
tmp = READSYMFN;
(void *)&tmp;
}),
/*max:*/ 19);
// 2479 %finish
L_0175:;
// 2480 gfix(align)
GFIX(3);
// 2481 decvar_disp = ga; decvar_base = gla
DECVAR->DISP = GA;
DECVAR->BASE = 14;
// 2482 external link(ep ref, 0, ga)
EXTERNALLINK(6, 0, GA);
// 2483 %return
return;
// 2484 %finish
L_0174:;
// 2485 %if gmode = 0 %start; ! NOT A PARAMETER
if (GMODE != 0) goto L_0177;
// 2486 potype = otype
POTYPE = OTYPE;
// 2487 %if new # 0 %start; ! NEW NAME
if (NEW == 0) goto L_0178;
// 2488 decvar_disp = new tag; ! Procedure ID
DECVAR->DISP = NEWTAG();
// 2489 %finish
L_0178:;
// 2490 block name = internal id %if spec = 0
if (SPEC != 0) goto L_0179;
_imp_strncpy(/*?*/ &BLOCKNAME, ({
__typeof__(_imp_string19) tmp; /*B*/
tmp = INTERNALID;
(void *)&tmp;
}),
/*max:*/ 19);
L_0179:;
// 2491 %return
return;
// 2492 %finish
L_0177:;
// 2493 ignore = 1
IGNORE = 1;
// 2494 otype = 0; size = 4; data size = 4; ! procedure parameter
OTYPE = 0;
SIZE = 4;
DATASIZE = 4;
// 2495 %else
goto L_017A;
L_0173:;
// 2496 data size = size
DATASIZE = SIZE;
// 2497 %if form # 1 %start
if (FORM == 1) goto L_017B;
// 2498 Round = Align
ROUND = 3;
// 2499 %if type = 0 %start; ! General %name
if (TYPE != 0) goto L_017C;
// 2500 ignore = 1
IGNORE = 1;
// 2501 decvar_extra = gmode; ! FOR LABELS
DECVAR->EXTRA = GMODE;
// 2502 type = general; size = 8
TYPE = 4;
SIZE = 8;
// 2503 decvar_type = general
DECVAR->TYPE = 4;
// 2504 %else %if form = array %or form = name array
goto L_017D;
L_017C:;
if (FORM == 11) goto L_017E;
if (FORM != 13) goto L_017F;
L_017E:;
// 2505 ignore = 1
IGNORE = 1;
// 2506 size = 0
SIZE = 0;
// 2507 data size = reglen %if form = name array
if (FORM != 13) goto L_0180;
DATASIZE = 4;
L_0180:;
// 2508 %else %if form = array name %or form = name array name
goto L_017D;
L_017F:;
if (FORM == 12) goto L_0181;
if (FORM != 14) goto L_0182;
L_0181:;
// 2509 ignore = 1
IGNORE = 1;
// 2510 size = 2*reglen; round = align; ! array header
SIZE = 2 * 4;
ROUND = 3;
// 2511 decvar_header = -1
DECVAR->HEADER = -1;
// 2512 abort(m'DFV3') %unless 0 < dimension <= 7
{
// Double-sided test on DIMENSION (Part I)
int tmp;
if (0 >= (tmp = DIMENSION)) goto L_0183;
// Double-sided test on DIMENSION (Part II)
if (tmp <= 7) goto L_0184;
}
L_0183:;
ABORT(1145460275);
L_0184:;
// 2513 decvar_flag = decvar_flag ! dimension; ! 'dim' in low order 3 bits
DECVAR->FLAG = DECVAR->FLAG | DIMENSION;
// 2514 %else
goto L_017D;
L_0182:;
// 2515 size = 4; ! integer (etc) %name
SIZE = 4;
// 2516 %finish
L_017D:;
// 2517 %finish
L_017B:;
// 2518 %finish
L_017A:;
// 2519
// 2520 %if otype # 0 %start; ! OWN DATA
if (OTYPE == 0) goto L_0185;
// 2521 %if otype = con %start; ! CONST INTEGER ETC.
if (OTYPE != 2) goto L_0186;
// 2522 data size = 0 %if type=strings %and form=1; ! use actual size
if (TYPE != 5) goto L_0187;
if (FORM != 1) goto L_0187;
DATASIZE = 0;
L_0187:;
// 2523 %if form = 2 %or form = arrayname %or form = namearrayname %start
if (FORM == 2) goto L_0188;
if (FORM == 12) goto L_0188;
if (FORM != 14) goto L_0189;
L_0188:;
// 2524 otype = 0; ! Treat as special later
OTYPE = 0;
// 2525 %else
goto L_018A;
L_0189:;
// 2526 ignore = 1; ! no diags for named constants
IGNORE = 1;
// 2527 %finish
L_018A:;
// 2528 %else
goto L_018B;
L_0186:;
// 2529 gfix(round)
GFIX(ROUND);
// 2530 set diag(gla,ga) %if ignore # 1
if (IGNORE == 1) goto L_018C;
SETDIAG(14, GA);
L_018C:;
// 2531 %finish
L_018B:;
// 2532 own type = type; own form = form
OWNTYPE = TYPE;
OWNFORM = FORM;
// 2533 own type = integers %and data size = 4 %if form = 2
if (FORM != 2) goto L_018D;
OWNTYPE = 1;
DATASIZE = 4;
L_018D:;
// 2534 decvar_header = -1
DECVAR->HEADER = -1;
// 2535 %if spec = 0 %start
if (SPEC != 0) goto L_018E;
// 2536 %if form = array %or form = name array %start
if (FORM == 11) goto L_018F;
if (FORM != 13) goto L_0190;
L_018F:;
// 2537 own form = array; ! to simplify subsequent test at 'A'
OWNFORM = 11;
// 2538 decvar_flag = decvar_flag&(\array bits)!(anbit!1); ! 1-D %name
DECVAR->FLAG = DECVAR->FLAG & (~96) | (64 | 1);
// 2539 ! mark as candidate for MHR subscript scaling if bounds do not
// 2540 ! exceed -32768 <= x <= 32767 and data size <= 32767
// 2541 decvar_flag = decvar_flag ! cheap array bit %if %c
{
// Double-sided test on DECVAR->LENGTH (Part I)
int tmp;
if (0 >= (tmp = DECVAR->LENGTH)) goto L_0191;
// Double-sided test on DECVAR->LENGTH (Part II)
if (tmp > 32767) goto L_0191;
}
if (-32768 > VLB) goto L_0191;
if (VUB > 32767) goto L_0191;
DECVAR->FLAG = DECVAR->FLAG | 32;
L_0191:;
// 2542+ 0 < decvar_length <= 32767 %and %c
// 2543+ -32768 <= vlb {<= 32767} %and %c
// 2544+ {-32768 <=} vub <= 32767
// 2545 {Note: vlb <= vub-1}
// 2546 gfix(align)
GFIX(3);
// 2547 set dope vector; ! N.B. changes vlb, vub
SETDOPEVECTOR();
// 2548 %if otype # con %start
if (OTYPE == 2) goto L_0192;
// 2549 decvar_disp = ga; decvar_base = gla
DECVAR->DISP = GA;
DECVAR->BASE = 14;
// 2550 gword rel(ga+8-vlb); ! @A(0) (in gla area)
GWORDREL(GA + 8 - VLB);
// 2551 gword crel(dv); ! @dope vector (in code area)
GWORDCREL(DV);
// 2552 %else; ! %const ...... %array
goto L_0193;
L_0192:;
// 2553 claim literal(vub,align); ! no header this time (it's in GLA)
CLAIMLITERAL(VUB, 3);
// 2554 select literal area
SELECTLITERALAREA();
// 2555 decvar_disp = ga; decvar_base = gla
DECVAR->DISP = GA;
DECVAR->BASE = 14;
// 2556 gword crel(ca-vlb)
GWORDCREL(CA - VLB);
// 2557 gword crel(dv)
GWORDCREL(DV);
// 2558 select code area
SELECTCODEAREA();
// 2559 %finish
L_0193:;
// 2560 external link(data defn,0,ga-8) %if otype = external
if (OTYPE != 3) goto L_0194;
EXTERNALLINK(5, 0, GA - 8);
L_0194:;
// 2561 %finish
L_0190:;
// 2562 %else
goto L_0195;
L_018E:;
// 2563 {to RECORD variant with 1-dim bit set, if nesc}
// 2564 decvar_xform = (decvar_xform+3) ! (assigned<<8)
DECVAR->XFORM = DECVAR->XFORM + 3 | 8 << 8;
// 2565 decvar_xform = decvar_Xform!1<<8 %if Form >= Array
if (FORM < 11) goto L_0196;
DECVAR->XFORM = DECVAR->XFORM | 1 << 8;
L_0196:;
// 2566 decvar_base = gla; decvar_disp = 0; decvar_extra = ga+8
DECVAR->BASE = 14;
DECVAR->DISP = 0;
DECVAR->EXTRA = GA + 8;
// 2567 external link(data ref,0,ga)
EXTERNALLINK(4, 0, GA);
// 2568 %finish
L_0195:;
// 2569 %return
return;
// 2570 %finish
L_0185:;
// 2571
// 2572 %if form = 3 %start; !%label
if (FORM != 3) goto L_0197;
// 2573 decvar_disp = new tag
DECVAR->DISP = NEWTAG();
// 2574 %return
return;
// 2575 %finish
L_0197:;
// 2576
// 2577 %if form = switch %start
if (FORM != 6) goto L_0198;
// 2578 decvar_extra = vlb; decvar_length = vub-vlb+1
DECVAR->EXTRA = VLB;
DECVAR->LENGTH = VUB - VLB + 1;
// 2579 decvar_format = free tag + 1; ! base tag
DECVAR->FORMAT = FREETAG + 1;
// 2580 claim literal((vub-vlb+1+2)*2,1)
CLAIMLITERAL((VUB - VLB + 1 + 2) * 2, 1);
// 2581 decvar_base = code; decvar_disp = litmax
DECVAR->BASE = 15;
DECVAR->DISP = LITMAX;
// 2582 select literal area
SELECTLITERALAREA();
// 2583 cput(vlb); cput(vub); ! switch bounds
CPUT(VLB);
CPUT(VUB);
// 2584 %for s = vlb,1,vub %cycle
// %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_0199:
if (S == _final) goto L_019A;
S += 1;
// 2585 free tag = free tag + 1
FREETAG = FREETAG + 1;
// 2586 define reference(free tag,sw ref)
DEFINEREFERENCE(FREETAG, 4);
// 2587 cput(free tag)
CPUT(FREETAG);
// 2588 %repeat
goto L_0199;
}
L_019A:;
// 2589 select code area
SELECTCODEAREA();
// 2590 %return
return;
// 2591 %finish
L_0198:;
// 2592
// 2593 %if form = record format %start
if (FORM != 4) goto L_019C;
// 2594 %if gmode # 0 %start
if (GMODE == 0) goto L_019D;
// 2595 frame = decvar_length %if decvar_length > frame
if (DECVAR->LENGTH <= FRAME) goto L_019E;
FRAME = DECVAR->LENGTH;
L_019E:;
// 2596 %else
goto L_019F;
L_019D:;
// 2597 gtype = -1; spec = -1
GTYPE = -1;
SPEC = -1;
// 2598 %finish
L_019F:;
// 2599 %return
return;
// 2600 %finish
L_019C:;
// 2601
// 2602 decvar_base = local
DECVAR->BASE = LOCAL;
// 2603 %if gdisp >= 0 %and decvar_flag & array bits = 0 %c
if (GDISP < 0) goto L_01A0;
if (DECVAR->FLAG & 96 != 0) goto L_01A0;
if (DECVAR->FORM != 6) goto L_01A1;
if (DECVAR->TYPE != 4) goto L_01A2;
L_01A1:;
if (DECVAR->FORM != 4) goto L_01A0;
if (DECVAR->TYPE > 3) goto L_01A0;
L_01A2:;
// 2604+ %and ( (decvar_form = a in s %and decvar_type # general) %c
// 2605+ %or (decvar_form = v in s %and decvar_type <= byte) ) %start
// 2606 decvar_disp = gdisp; gdisp = gdisp - reglen
DECVAR->DISP = GDISP;
GDISP = GDISP - 4;
// 2607 decvar_disp = decvar_disp + decvar_type %if %c
if (DECVAR->FORM != 4) goto L_01A3;
{
// Double-sided test on DECVAR->TYPE (Part I)
int tmp;
if (2 > (tmp = DECVAR->TYPE)) goto L_01A3;
// Double-sided test on DECVAR->TYPE (Part II)
if (tmp > 3) goto L_01A3;
}
DECVAR->DISP = DECVAR->DISP + DECVAR->TYPE;
L_01A3:;
// 2608+ decvar_form = v in s %and short <= decvar_type <= byte
// 2609 decvar_flag = decvar_flag ! P in R; ! Parameter in Register
DECVAR->FLAG = DECVAR->FLAG | 2;
// 2610 min parm = min parm + 1; ! for use by 'HEADER'
MINPARM = MINPARM + 1;
// 2611 %if control & suppress = 0 %start
if (CONTROL & 128 != 0) goto L_01A4;
// 2612 temp_form = decvar_form; temp_type = decvar_type
TEMP.FORM = DECVAR->FORM;
TEMP.TYPE = DECVAR->TYPE;
// 2613 temp_xbase = decvar_base; temp_disp = decvar_disp
TEMP.XBASE = DECVAR->BASE;
TEMP.DISP = DECVAR->DISP;
// 2614 %if temp_form = A in S %start
if (TEMP.FORM != 6) goto L_01A5;
// 2615 temp_form = V in S; temp_type = integers
TEMP.FORM = 4;
TEMP.TYPE = 1;
// 2616 %finish
L_01A5:;
// 2617 associate(temp, p1 - (min parm-1))
ASSOCIATE(/*?*/ &TEMP, 7 - (MINPARM - 1));
// 2618 %finish
L_01A4:;
// 2619 %else
goto L_01A6;
L_01A0:;
// 2620 frame = (frame+round)&(\round)
FRAME = FRAME + ROUND & (~ROUND);
// 2621 max local = frame
MAXLOCAL = FRAME;
// 2622 decvar_disp = frame
DECVAR->DISP = FRAME;
// 2623 frame = frame + size
FRAME = FRAME + SIZE;
// 2624 alt align = alt align ! round
ALTALIGN = ALTALIGN | ROUND;
// 2625 %finish
L_01A6:;
// 2626 set diag(local,decvar_disp) %if ignore = 0
if (IGNORE != 0) goto L_01A7;
SETDIAG(LOCAL, DECVAR->DISP);
L_01A7:;
// 2627 %end;
return;
} /* end of DEFINEVAR */
// ?K unused
// 2628 ; ! define var
// 2628
// 2629 ! >> CHECKABLE <<
// 2630 %predicate checkable(%record(stackfm)%name v)
int CHECKABLE(struct STACKFM * V) {
// 2631 ! Presumes test on 'CONTROL&CHECK UNASS' in line for speed
// 2632 ! Note that a string temporary (v_type = 0) yields FALSE
// 2633 %false %if v_form = constant %or v_form = AV in S
if (V->FORM == 0) goto L_01A8;
if (V->FORM != 5) goto L_01A9;
L_01A8:;
return 0 /*FALSE*/;
L_01A9:;
// 2634 %false %if v_flag & assigned # 0
if (V->FLAG & 8 == 0) goto L_01AA;
return 0 /*FALSE*/;
L_01AA:;
// 2635 %true %if v_type = integers %or v_type = strings %or v_type >= reals
if (V->TYPE == 1) goto L_01AB;
if (V->TYPE == 5) goto L_01AB;
if (V->TYPE < 7) goto L_01AC;
L_01AB:;
return 1 /*TRUE*/;
L_01AC:;
// 2636 %false
return 0 /*FALSE*/;
// 2637 %end; ! checkable
} /* end of CHECKABLE */
// 2638
// 2639 ! >> DESCRIPTOR <<
// 2640 ! N.B. Note that the record zero operation is used, among
// 2641 ! other things, to set the link field to NULL. This
// 2642 ! equivalence between binary zero and NULL links must
// 2643 ! be maintained.
// 2644 %record(stackfm)%map descriptor
struct STACKFM *DESCRIPTOR(void)
{
// 2645 %record(dfm)%name d
struct DFM *D;
// 2646 %record(stackfm)%name v
struct STACKFM *V;
// 2647 stp = stp+1; abort(m'DSC1') %if stp > max depth
STP = STP + 1;
if (STP <= 16) goto L_01AD;
ABORT(1146307377);
L_01AD:;
// 2648
// 2649 v == desc asl; abort(m'DSC2') %if v == null
V = (struct STACKFM *)DESCASL;
if (_imp_ADDR((void *)(V)) != _imp_ADDR((void *)(NULL))) goto L_01AE;
ABORT(1146307378);
L_01AE:;
// 2650 d == dasl; abort(m'DSC3') %if d == null
D = (struct DFM *)DASL;
if (_imp_ADDR((void *)(D)) != _imp_ADDR((void *)(NULL))) goto L_01AF;
ABORT(1146307379);
L_01AF:;
// 2651 desc asl == v_link; v = 0
DESCASL = (struct STACKFM *)V->LINK;
*V = (struct STACKFM){0};
// 2652 dasl == d_link; d_link == using_link; using_link == d
DASL = (struct DFM *)D->LINK;
D->LINK = (struct DFM *)USING.LINK;
USING.LINK = (struct DFM *)D;
// 2653 d_d == v
D->D = (struct DFM *)V;
// 2654 %result == v
return V;
// 2655 %end
} /* end of DESCRIPTOR */
// 2656
// 2657 ! >> DROP <<
// 2658 %routine drop(%record(stackfm)%name descriptor)
void DROP(struct STACKFM * DESCRIPTOR) {
// 2659 %record(dfm)%name p,q
struct DFM *P;
struct DFM *Q;
// 2660 p == using
P = (struct DFM *)/*?*/ &USING;
// 2661 %cycle
L_01B0:;
// 2662 q == p_link
Q = (struct DFM *)P->LINK;
// 2663 abort(m'DROP') %if q == null
if (_imp_ADDR((void *)(Q)) != _imp_ADDR((void *)(NULL))) goto L_01B1;
ABORT(1146244944);
L_01B1:;
// 2664 %exit %if q_d == descriptor
if (_imp_ADDR((void *)(Q->D)) != _imp_ADDR((void *)(DESCRIPTOR))) goto L_01B2;
goto L_01B3;
L_01B2:;
// 2665 p == q
P = (struct DFM *)Q;
// 2666 %repeat
goto L_01B0;
L_01B3:;
// 2667 p_link == q_link
P->LINK = (struct DFM *)Q->LINK;
// 2668 q_link == dasl; dasl == q
Q->LINK = (struct DFM *)DASL;
DASL = (struct DFM *)Q;
// 2669 descriptor_link == desc asl; desc asl == descriptor
DESCRIPTOR->LINK = (struct STACKFM *)DESCASL;
DESCASL = (struct STACKFM *)DESCRIPTOR;
// 2670 %end
return;
} /* end of DROP */
// 2671
// 2672 ! >> VSTACK <<
// 2673 %routine vstack(%integer var no)
void VSTACK(int VARNO) {
// 2674 %record(varfm)%name w
struct VARFM *W;
// 2675 abort(m'VSTK') %unless 0 <= var no <= max vars
{
// Double-sided test on VARNO (Part I)
int tmp;
if (0 > (tmp = VARNO)) goto L_01B4;
// Double-sided test on VARNO (Part II)
if (tmp <= 800) goto L_01B5;
}
L_01B4:;
ABORT(1448301643);
L_01B5:;
// 2676 w == var(varno)
W = (struct VARFM *)/*?*/ &VAR[VARNO];
// 2677 lhs == descriptor
LHS = (struct STACKFM *)DESCRIPTOR();
// 2678 stacked(stp)_v == lhs
STACKED[STP - 1].V = (struct SPTFM *)LHS;
// 2679 lhs_base = w_base
LHS->BASE = W->BASE;
// 2680 lhs_disp = w_disp
LHS->DISP = W->DISP;
// 2681 lhs_format = w_format
LHS->FORMAT = W->FORMAT;
// 2682 lhs_extra = w_extra
LHS->EXTRA = W->EXTRA;
// 2683 lhs_type = w_type
LHS->TYPE = W->TYPE;
// 2684 lhs_length = w_length
LHS->LENGTH = W->LENGTH;
// 2685 lhs_header = w_header
LHS->HEADER = W->HEADER;
// 2686 lhs_link == null
LHS->LINK = (struct STACKFM *)NULL;
// 2687 lhs_type = w_type; lhs_xform = w_xform
LHS->TYPE = W->TYPE;
LHS->XFORM = W->XFORM;
// 2688 lhs_dim = w_flag&7; ! in case it's an array
LHS->DIM = W->FLAG & 7;
// 2689 lhs_varno = varno
LHS->VARNO = VARNO;
// 2690 monitor(lhs, "V stack") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_01B6;
MONITOR(LHS, _imp_str_literal_size(15, "V stack"));
L_01B6:;
// 2691 %end
return;
} /* end of VSTACK */
// 2692
// 2693 ! >> SSTACK <<
// 2694 %routine sstack(%record(stackfm)%name v)
void SSTACK(struct STACKFM * V) {
// 2695 %record(stackfm)%name t
struct STACKFM *T;
// 2696 t == descriptor; t = v
T = (struct STACKFM *)DESCRIPTOR();
*T = *V;
// 2697 stacked(stp)_v == t
STACKED[STP - 1].V = (struct SPTFM *)T;
// 2698 monitor(t, "S STACK") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_01B7;
MONITOR(T, _imp_str_literal_size(15, "S STACK"));
L_01B7:;
// 2699 %end
return;
} /* end of SSTACK */
// 2700
// 2701 ! >> C STACK <<
// 2702 %routine c stack(%integer n)
void CSTACK(int N) {
// 2703 rhs == descriptor
RHS = (struct STACKFM *)DESCRIPTOR();
// 2704 rhs_base = 0
RHS->BASE = 0;
// 2705 rhs_disp = n
RHS->DISP = N;
// 2706 rhs_type = integers
RHS->TYPE = 1;
// 2707 rhs_form = constant
RHS->FORM = 0;
// 2708 stacked(stp)_v == rhs
STACKED[STP - 1].V = (struct SPTFM *)RHS;
// 2709 monitor(rhs, "C stack") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_01B8;
MONITOR(RHS, _imp_str_literal_size(15, "C stack"));
L_01B8:;
// 2710 %end
return;
} /* end of CSTACK */
// 2711
// 2712 ! >> C LOAD <<
// 2713 %routine cload(%integer value, reg)
void CLOAD(int VALUE, int REG) {
// 2714 c stack(value)
CSTACK(VALUE);
// 2715 pop lhs
POPLHS();
// 2716 lrd(lhs,reg)
LRD(LHS, REG);
// 2717 %end
return;
} /* end of CLOAD */
// 2718
// 2719 ! >> SSET <<
// 2720 %routine sset(%integer base, disp, xform, extra)
void SSET(int BASE, int DISP, int XFORM, int EXTRA) {
// 2721 rhs == descriptor
RHS = (struct STACKFM *)DESCRIPTOR();
// 2722 rhs_base = base
RHS->BASE = BASE;
// 2723 rhs_disp = disp
RHS->DISP = DISP;
// 2724 rhs_type = integers
RHS->TYPE = 1;
// 2725 rhs_xform = xform
RHS->XFORM = XFORM;
// 2726 rhs_extra = extra
RHS->EXTRA = EXTRA;
// 2727 rhs_link == null
RHS->LINK = (struct STACKFM *)NULL;
// 2728 stacked(stp)_v == rhs
STACKED[STP - 1].V = (struct SPTFM *)RHS;
// 2729 monitor(rhs, "SSET") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_01B9;
MONITOR(RHS, _imp_str_literal_size(15, "SSET"));
L_01B9:;
// 2730 %end
return;
} /* end of SSET */
// 2731
// 2732 ! >> SET LHS <<
// 2733 %routine set lhs
void SETLHS(void) {
// 2734 lhs == stacked(stp)_v
LHS = (struct STACKFM *)STACKED[STP - 1].V;
// 2735 monitor(lhs, "SET LHS") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_01BA;
MONITOR(LHS, _imp_str_literal_size(15, "SET LHS"));
L_01BA:;
// 2736 %end
return;
} /* end of SETLHS */
// 2737
// 2738 ! >> SET BOTH <<
// 2739 %routine set both
void SETBOTH(void) {
// 2740 abort(m'SETB') %if stp <= 1
if (STP > 1) goto L_01BB;
ABORT(1397052482);
L_01BB:;
// 2741 lhs == stacked(stp-1)_v
LHS = (struct STACKFM *)STACKED[STP - 1 - 1].V;
// 2742 rhs == stacked(stp)_v
RHS = (struct STACKFM *)STACKED[STP - 1].V;
// 2743 %if diagnose&1 # 0 %start
if (DIAGNOSE & 1 == 0) goto L_01BC;
// 2744 monitor(lhs, "BOTH LHS")
MONITOR(LHS, _imp_str_literal_size(15, "BOTH LHS"));
// 2745 monitor(rhs, "BOTH RHS")
MONITOR(RHS, _imp_str_literal_size(15, "BOTH RHS"));
// 2746 %finish
L_01BC:;
// 2747 %end
return;
} /* end of SETBOTH */
// 2748
// 2749 ! >> POP LHS <<
// 2750 %routine pop lhs
void POPLHS(void) {
// 2751 abort(m'POPL') %if stp <= 0
if (STP > 0) goto L_01BD;
ABORT(1347375180);
L_01BD:;
// 2752 lhs == stacked(stp)_v
LHS = (struct STACKFM *)STACKED[STP - 1].V;
// 2753 stp = stp-1
STP = STP - 1;
// 2754 monitor(lhs, "POP LHS") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_01BE;
MONITOR(LHS, _imp_str_literal_size(15, "POP LHS"));
L_01BE:;
// 2755 %end
return;
} /* end of POPLHS */
// 2756
// 2757 ! >> POP DROP <<
// 2758 %routine pop drop
void POPDROP(void) {
// 2759 pop lhs
POPLHS();
// 2760 monitor(lhs, "POP DROP") %if diagnose&1 # 0
if (DIAGNOSE & 1 == 0) goto L_01BF;
MONITOR(LHS, _imp_str_literal_size(15, "POP DROP"));
L_01BF:;
// 2761 drop(lhs)
DROP(LHS);
// 2762 %end
return;
} /* end of POPDROP */
// 2763
// 2764 !STRING PROCESSING
// 2765 ! >> DUMP STRING <<
// 2766 %routine dump string(%integer max)
void DUMPSTRING(int MAX) {
// 2767 %integer j
int J;
// 2768 %if max = 0 %start; ! DUMP AS MUCH AS NEEDED
if (MAX != 0) goto L_01C0;
// 2769 max = cslen+1
MAX = *CSLEN + 1;
// 2770 %else; ! DUMP NO MORE THAN MAX
goto L_01C1;
L_01C0:;
// 2771 %if cslen+1 > max %start
if (*CSLEN + 1 <= MAX) goto L_01C2;
// 2772 ! String constant too long - warn and truncate
// 2773 %if cslen # x'80' %or current string(1) # x'80' %start
if (*CSLEN != 128) goto L_01C3;
if (CURRENTSTRING[1] == 128) goto L_01C4;
L_01C3:;
// 2774 warn(5); current string(0) = max-1
WARN(5);
CURRENTSTRING[0] = MAX - 1;
// 2775 %finish
L_01C4:;
// 2776 %finish
L_01C2:;
// 2777 %finish
L_01C1:;
// 2778 %if otype = con %start
if (OTYPE != 2) goto L_01C5;
// 2779 select literal area
SELECTLITERALAREA();
// 2780 lit byte(current string(j)) %for j = 0,1,max-1
// %for J = 0, 1, MAX - 1 %cycle
{
int _final = MAX - 1;
if (invalid_for_loop(0, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 0, 1, MAX - 1");
J = -1;
L_01C6:
if (J == _final) goto L_01C7;
J += 1;
LITBYTE(CURRENTSTRING[J]);
goto L_01C6;
}
L_01C7:;
// 2781 select code area
SELECTCODEAREA();
// 2782 %else; ! %own
goto L_01C8;
L_01C5:;
// 2783 gbyte(current string(j)) %for j = 0,1,max-1
// %for J = 0, 1, MAX - 1 %cycle
{
int _final = MAX - 1;
if (invalid_for_loop(0, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 0, 1, MAX - 1");
J = -1;
L_01C9:
if (J == _final) goto L_01CA;
J += 1;
GBYTE(CURRENTSTRING[J]);
goto L_01C9;
}
L_01CA:;
// 2784 %finish
L_01C8:;
// 2785 %end
return;
} /* end of DUMPSTRING */
// 2786
// 2787 ! >> GET STRING <<
// 2788 %routine get string
void GETSTRING(void) {
// 2789 %integer l
int L;
// 2790 l = next; !length
L = NEXT;
// 2791 cslen = 0
*CSLEN = 0;
// 2792 %while l > 0 %cycle
L_01CB:;
if (L <= 0) goto L_01CC;
// 2793 l = l-1
L = L - 1;
// 2794 read symbol(next)
_imp_READSYMBOL(/*?*/ &NEXT);
// 2795 cslen = (cslen+1)&255; current string(cslen) = next
*CSLEN = *CSLEN + 1 & 255;
CURRENTSTRING[*CSLEN] = NEXT;
// 2796 %repeat
goto L_01CB;
L_01CC:;
// 2797 readsymbol(next)
_imp_READSYMBOL(/*?*/ &NEXT);
// 2798 %if next # 'A' %and next # '$' %start
if (NEXT == 65) goto L_01CD;
if (NEXT == 36) goto L_01CD;
// 2799 %if next = '.' %and cslen = 1 %and
if (NEXT != 46) goto L_01CE;
if (*CSLEN != 1) goto L_01CE;
if (CONTROL & (1 | 2) != 0) goto L_01CE;
// 2800+ control&(check capacity!check unass) = 0 %start
// 2801 cstack(current string(1))
CSTACK(CURRENTSTRING[1]);
// 2802 Rhs_Flag = Rhs_Flag!Quick Conc
RHS->FLAG = RHS->FLAG | 1;
// 2803 %return
return;
// 2804 %finish
L_01CE:;
// 2805 cstack(0); rhs_type = strings
CSTACK(0);
RHS->TYPE = 5;
// 2806 otype = con; ! anonymous %const
OTYPE = 2;
// 2807 rhs_base = code; rhs_xform = VinS!(assigned<<8); rhs_format = cslen+1
RHS->BASE = 15;
RHS->XFORM = 4 | 8 << 8;
RHS->FORMAT = *CSLEN + 1;
// 2808 %if cslen # 0 %or null string = 0 %start
if (*CSLEN != 0) goto L_019B;
if (NULLSTRING != 0) goto L_01CF;
L_019B:;
// 2809 claim literal(cslen+1,1); ! Alignment req'd for buffer flushing
CLAIMLITERAL(*CSLEN + 1, 1);
// 2810 rhs_disp = lita; dump string(0)
RHS->DISP = LITA;
DUMPSTRING(0);
// 2811 null string = rhs_disp %if null string = 0 = cslen
{
// Double-sided test on 0 (Part I)
int tmp;
if (NULLSTRING != (tmp = 0)) goto L_01D0;
// Double-sided test on 0 (Part II)
if (tmp != *CSLEN) goto L_01D0;
}
NULLSTRING = RHS->DISP;
L_01D0:;
// 2812 %else
goto L_01D1;
L_01CF:;
// 2813 rhs_disp = null string
RHS->DISP = NULLSTRING;
// 2814 %finish
L_01D1:;
// 2815 %else
goto L_01D2;
L_01CD:;
// 2816 cstack(0); ! explicit string initialisation
CSTACK(0);
// 2817 %finish
L_01D2:;
// 2818 %end
return;
} /* end of GETSTRING */
// 2819
// 2820 ! >> REAL CONSTANT <<
// 2821 %integerfn real constant(%integer force)
int REALCONSTANT(int FORCE) {
// 2822 %owninteger last = 0, next = 0
static int LAST = 0;
static int NEXT = 0;
// 2823 %integer j,k
int J;
int K;
// 2824 %ownintegerarray val(0:31) = 0(32)
static int VAL[32] = {[0 ... 31] = 0};
// 2825 %ownshortintegerarray index(0:31) = 0(32)
static short int INDEX[32] = {[0 ... 31] = 0};
// 2826 k = integer(addr(rvalue))
K = *_imp_INTEGER(_imp_ADDR(/*?*/ &RVALUE));
// 2827 %if otype # con %start
if (OTYPE == 2) goto L_01D3;
// 2828 gfix(3); gword(k)
GFIX(3);
GWORD(K);
// 2829 %result = ga-4
return GA - 4;
// 2830 %finish
L_01D3:;
// 2831 ! deal with %const anonymous or not
// 2832 %if force = 0 %start
if (FORCE != 0) goto L_01D4;
// 2833 j = last
J = LAST;
// 2834 %cycle
L_01D5:;
// 2835 -> FOUND %if val(last) = k
if (VAL[LAST] != K) goto L_01D6;
goto U_100A;
L_01D6:;
// 2836 last = (last+1)&31
LAST = LAST + 1 & 31;
// 2837 %exit %if last = j
if (LAST != J) goto L_01D7;
goto L_01D8;
L_01D7:;
// 2838 %repeat
goto L_01D5;
L_01D8:;
// 2839 claim literal(single,single-1); ! anonymous value not in cache
CLAIMLITERAL(4, 4 - 1);
// 2840 %finish
L_01D4:;
// 2841 next = (next+1)&31; last = next
NEXT = NEXT + 1 & 31;
LAST = NEXT;
// 2842 select literal area
SELECTLITERALAREA();
// 2843 val(last) = k; index(last) = ca
VAL[LAST] = K;
INDEX[LAST] = CA;
// 2844 cword(k)
CWORD(K);
// 2845 select code area
SELECTCODEAREA();
// 2846 FOUND:
U_100A:;
// 2847 %result = index(last)
return INDEX[LAST];
// 2848 %end; ! real constant
} /* end of REALCONSTANT */
// 2849
// 2850 !LABEL PROCESSING
// 2851 ! >> NEW TAG <<
// 2852 %integerfn new tag
int NEWTAG(void) {
// 2853 free tag = free tag + 1
FREETAG = FREETAG + 1;
// 2854 %result = free tag
return FREETAG;
// 2855 %end
} /* end of NEWTAG */
// 2856
// 2857 ! >> NEW LABEL <<
// 2858 %record(labelfm)%map new label
struct LABELFM *NEWLABEL(void)
{
// 2859 labs = labs+1; abort(m'NLBL') %if labs > max labels
LABS = LABS + 1;
if (LABS <= 80) goto L_01D9;
ABORT(1313620556);
L_01D9:;
// 2860 %result == labels(labs)
return /*?*/ &LABELS[LABS - 1];
// 2861 %end
} /* end of NEWLABEL */
// 2862
// 2863 ! >> FIND <<
// 2864 %record(labelfm)%map find(%integer label)
struct LABELFM *FIND(int LABEL)
{
// 2865 %integer lp
int LP;
// 2866 %record(labelfm)%name l
struct LABELFM *L;
// 2867 lp = labs
LP = LABS;
// 2868 %while lp # label start %cycle
L_01DA:;
if (LP == LABELSTART) goto L_01DB;
// 2869 l == labels(lp)
L = (struct LABELFM *)/*?*/ &LABELS[LP - 1];
// 2870 %result == l %if l_id = label
if (L->ID != LABEL) goto L_01DC;
return L;
L_01DC:;
// 2871 lp = lp-1
LP = LP - 1;
// 2872 %repeat
goto L_01DA;
L_01DB:;
// 2873 %result == null
return NULL;
// 2874 %end
} /* end of FIND */
// 2875
// 2876 ! >> DEFINE LABEL <<
// 2877 %routine define label(%integer label)
void DEFINELABEL(int LABEL) {
// 2878 %integer ltag, new
int LTAG;
int NEW;
// 2879 %record(labelfm)%name l
struct LABELFM *L;
// 2880 %record(envfm)%name E
struct ENVFM *E;
// 2881 cc ca = 0 {must forget condition code}
CCCA = 0;
// 2882 new = 0
NEW = 0;
// 2883 %return %if label = 0; ! JUMP AROUND PROCEDURE
if (LABEL != 0) goto L_01DD;
return;
L_01DD:;
// 2884 %if label < 0 %start
if (LABEL >= 0) goto L_01DE;
// 2885 ltag = -label
LTAG = -LABEL;
// 2886 new = 1
NEW = 1;
// 2887 %else
goto L_01DF;
L_01DE:;
// 2888 l == find(label)
L = (struct LABELFM *)FIND(LABEL);
// 2889 %if l == null %start
if (_imp_ADDR((void *)(L)) != _imp_ADDR((void *)(NULL))) goto L_01E0;
// 2890 l == new label
L = (struct LABELFM *)NEWLABEL();
// 2891 l_id = label; l_tag = new tag
L->ID = LABEL;
L->TAG = NEWTAG();
// 2892 new = 1
NEW = 1;
// 2893 %else
goto L_01E1;
L_01E0:;
// 2894 %if l_tag < 0 %and label >= 0 %start
if (L->TAG >= 0) goto L_01E2;
if (LABEL < 0) goto L_01E2;
// 2895 l_tag = new tag
L->TAG = NEWTAG();
// 2896 new = 1
NEW = 1;
// 2897 %finish
L_01E2:;
// 2898 %finish
L_01E1:;
// 2899 l_tag = l_tag ! bit15
L->TAG = L->TAG | (-32768);
// 2900 ltag = l_tag
LTAG = L->TAG;
// 2901 %finish
L_01DF:;
// 2902 %if new # 0 %start
if (NEW == 0) goto L_01E3;
// 2903 e == environment(label)
E = (struct ENVFM *)ENVIRONMENT(LABEL);
// 2904 e_label = 0 %if e ## null
if (_imp_ADDR((void *)(E)) == _imp_ADDR((void *)(NULL))) goto L_01E4;
E->LABEL = 0;
L_01E4:;
// 2905 %finish
L_01E3:;
// 2906 define tag(ltag & x'7FFF')
DEFINETAG(LTAG & 32767);
// 2907 merge environment(label) %if uncond jump # ca
if (UNCONDJUMP == CA) goto L_01E5;
MERGEENVIRONMENT(LABEL);
L_01E5:;
// 2908 restore environment(label)
RESTOREENVIRONMENT(LABEL);
// 2909 %if trace flag # 0 %start
if (TRACEFLAG == 0) goto L_01E6;
// 2910 dump trace %if next # ':' %and next # 'L'
if (NEXT == 58) goto L_01E7;
if (NEXT == 76) goto L_01E7;
DUMPTRACE();
L_01E7:;
// 2911 %finish
L_01E6:;
// 2912 uncond jump = 0; ! YOU CAN GET HERE !
UNCONDJUMP = 0;
// 2913 mark assigned = 0; ! can't be sure any more
MARKASSIGNED = 0;
// 2914 %end; ! define label
return;
} /* end of DEFINELABEL */
// 2915
// 2916 ! >> JUMP TO <<
// 2917 %routine jump to(%integer label, cond, def)
void JUMPTO(int LABEL, int COND, int DEF) {
// 2918 %record(labelfm)%name lab
struct LABELFM *LAB;
// 2919 %integer ref
int REF;
// 2920 invert = 0
INVERT = 0;
// 2921 Cond = Inverted(Cond) %if Cond&16 # 0
if (COND & 16 == 0) goto L_01E8;
COND = INVERTED[COND - 16];
L_01E8:;
// 2922 %if def >= 0 %start; ! Compiler defined label
if (DEF < 0) goto L_01E9;
// 2923 %return %if label = 0; ! jump round routine
if (LABEL != 0) goto L_01EA;
return;
L_01EA:;
// 2924 %if label < 0 %start
if (LABEL >= 0) goto L_01EB;
// 2925 j tag = -label
JTAG = -LABEL;
// 2926 %else
goto L_01EC;
L_01EB:;
// 2927 lab == find(label)
LAB = (struct LABELFM *)FIND(LABEL);
// 2928 %if lab == null %start
if (_imp_ADDR((void *)(LAB)) != _imp_ADDR((void *)(NULL))) goto L_01ED;
// 2929 lab == new label
LAB = (struct LABELFM *)NEWLABEL();
// 2930 lab_id = label; lab_tag = new tag
LAB->ID = LABEL;
LAB->TAG = NEWTAG();
// 2931 remember environment(label)
REMEMBERENVIRONMENT(LABEL);
// 2932 %else %if lab_tag < 0 %and def = redefine old
goto L_01EE;
L_01ED:;
if (LAB->TAG >= 0) goto L_01EF;
if (DEF != 1) goto L_01EF;
// 2933 lab_tag = new tag
LAB->TAG = NEWTAG();
// 2934 remember environment(label)
REMEMBERENVIRONMENT(LABEL);
// 2935 %else
goto L_01EE;
L_01EF:;
// 2936 merge environment(label) %if lab_tag > 0
if (LAB->TAG <= 0) goto L_01F0;
MERGEENVIRONMENT(LABEL);
L_01F0:;
// 2937 %finish
L_01EE:;
// 2938 j tag = lab_tag&x'7FFF'
JTAG = LAB->TAG & 32767;
// 2939 %finish
L_01EC:;
// 2940 %else; ! Tag internal to pass 2
goto L_01F1;
L_01E9:;
// 2941 jtag = label; ! *** N.B. This is %not a pass1-visible label ***
JTAG = LABEL;
// 2942 %finish
L_01F1:;
// 2943 %if cond = jump %then ref = j ref %else ref = c ref
if (COND != 12) goto L_01F2;
REF = 5;
goto L_01F3;
L_01F2:;
REF = 6;
L_01F3:;
// 2944 define reference(j tag,ref)
DEFINEREFERENCE(JTAG, REF);
// 2945 cput(jtag<<4 + cond&15); cc ca = cc ca + 2; ! these two bytes can't change CC
CPUT((JTAG << 4) + (COND & 15));
CCCA = CCCA + 2;
// 2946 %if cond = jump %start
if (COND != 12) goto L_01F4;
// 2947 uncond jump = ca; ! no way past here
UNCONDJUMP = CA;
// 2948 trace flag = control&trace %if next = ':'; ! to catch 'else', 'repeat' etc
if (NEXT != 58) goto L_01F5;
TRACEFLAG = CONTROL & 64;
L_01F5:;
// 2949 %else
goto L_01F6;
L_01F4:;
// 2950 trace flag = control&trace; ! maybe trace flow on next line
TRACEFLAG = CONTROL & 64;
// 2951 %finish
L_01F6:;
// 2952 mark assigned = 0
MARKASSIGNED = 0;
// 2953 %end; ! jump to
return;
} /* end of JUMPTO */
// 2954
// 2955 ! >> FLOAT <<
// 2956 %routine float(%record(stackfm)%name v, %integer r)
void FLOAT(struct STACKFM * V, int R) {
// 2957 ! Convert 'v' into floating point form
// 2958 %integer k
int K;
// 2959 !!!!!%longreal x
// 2960 r = fpr %if r = anyf
if (R != 26) goto L_01F7;
R = FPR();
L_01F7:;
// 2961 %if const(v) %start
if (!(CONST(V))) goto L_01F8;
// 2962 %if v_disp = 0 %start
if (V->DISP != 0) goto L_01F9;
// 2963 hazard(r); claim(r)
HAZARD(R);
CLAIM(R);
// 2964 rr(sub,r,r); claim(r)
RR(4, R, R);
CLAIM(R);
// 2965 v_type = reall; v_form = v in r; v_base = r
V->TYPE = 7;
V->FORM = 1;
V->BASE = R;
// 2966 %else
goto L_01FA;
L_01F9:;
// 2967 rvalue = v_disp; ! ** IMPLICIT FLOATING **
RVALUE = V->DISP;
// 2968 otype = con; k = real constant(0)
OTYPE = 2;
K = REALCONSTANT(0);
// 2969 v_xform = (assigned<<8) ! V in S; v_type = reals
V->XFORM = 8 << 8 | 4;
V->TYPE = 7;
// 2970 v_base = code; v_disp = k
V->BASE = 15;
V->DISP = K;
// 2971 %finish
L_01FA:;
// 2972 %else
goto L_01FB;
L_01F8:;
// 2973 load(v,any)
LOAD(V, 25);
// 2974 rr(flr,r,v_base); claim(r)
RR(13, R, V->BASE);
CLAIM(R);
// 2975 v_form = v in r; v_type = reall
V->FORM = 1;
V->TYPE = 7;
// 2976 v_base = r
V->BASE = R;
// 2977 %finish
L_01FB:;
// 2978 %end
return;
} /* end of FLOAT */
// 2979
// 2980 ! >> LRD <<
// 2981 %routine lrd(%record(stackfm)%name v, %integer reg)
void LRD(struct STACKFM * V, int REG) {
// 2982 ! load, release and drop
// 2983 load(v,reg)
LOAD(V, REG);
// 2984 release(v_base)
RELEASE(V->BASE);
// 2985 drop(v)
DROP(V);
// 2986 %end
return;
} /* end of LRD */
// 2987
// 2988 ! >> QUICK LOAD <<
// 2989 %routine QUICK LOAD(%integer reg, form, base, disp)
void QUICKLOAD(int REG, int FORM, int BASE, int DISP) {
// 2990 %record(stackfm) v
struct STACKFM V;
// 2991 v = 0
V = (struct STACKFM){0};
// 2992 v_type = integers; v_form = form
V.TYPE = 1;
V.FORM = FORM;
// 2993 v_base = base; v_disp = disp
V.BASE = BASE;
V.DISP = DISP;
// 2994 load(v, reg)
LOAD(/*?*/ &V, REG);
// 2995 %end
return;
} /* end of QUICKLOAD */
// 2996
// 2997 ! >> REDUCE <<
// 2998 %routine reduce(%record(stackfm)%name v)
void REDUCE(struct STACKFM * V) {
// 2999 %integer type, xform, disp, base
int TYPE;
int XFORM;
int DISP;
int BASE;
// 3000 xform = v_xform - 3; ! X in REC => X in S
XFORM = V->XFORM - 3;
// 3001 type = v_type
TYPE = V->TYPE;
// 3002 disp = v_disp; base = v_base
DISP = V->DISP;
BASE = V->BASE;
// 3003 v_disp = v_extra; v_type = integers; v_form = v in s
V->DISP = V->EXTRA;
V->TYPE = 1;
V->FORM = 4;
// 3004 load(v,any)
LOAD(V, 25);
// 3005 v_type = type; v_xform = xform & (\(assigned<<8))
V->TYPE = TYPE;
V->XFORM = XFORM & ~(8 << 8);
// 3006 v_disp = disp
V->DISP = DISP;
// 3007 %end
return;
} /* end of REDUCE */
// 3008
// 3009 ! >> AMAP <<
// 3010 %routine amap(%record(stackfm)%name v)
void AMAP(struct STACKFM * V) {
// 3011 ! convert V into a descriptor for the address of V
// 3012 %integer f
int F;
// 3013 %constshortintegerarray map(0:15) =
const short int MAP[16] = {-1, -2, -3, -4, 5, -5, 4, 8, -6, 7, -7, -8, -9, -10, -11, -12};
// 3014+ -1, -2, -3, -4, av in s, -5, v in s, av in rec, -6, v in rec,
// 3015+ -7, -8, -9, -10, -11 {PGM LABEL}, -12 {record format}
// 3016 f = map(v_form)
F = MAP[V->FORM];
// 3017 %if f < 0 %start
if (F >= 0) goto L_01FC;
// 3018 abort(m'AMAP') %unless v_form = pgm label
if (V->FORM == 14) goto L_01FD;
ABORT(1095582032);
L_01FD:;
// 3019 ! Deal with ADDR(pgm label)
// 3020 f = gpr; forget reg(1<<f)
F = GPR();
FORGETREG(1 << F);
// 3021 define reference(v_disp&x'FFF',r ref)
DEFINEREFERENCE(V->DISP & 4095, 2);
// 3022 rx(LA,f,code,0)
RX(23, F, 15, 0);
// 3023 v_type = integers; v_xform = VinR
V->TYPE = 1;
V->XFORM = 1;
// 3024 v_base = f; v_disp = 0
V->BASE = F;
V->DISP = 0;
// 3025 claim(f)
CLAIM(F);
// 3026 %return
return;
// 3027 %finish
L_01FC:;
// 3028 %if (f = VinREC %or f = AVinREC) %and v_disp = 0 %start {eliminate redundant LOAD}
if (F == 7) goto L_01FE;
if (F != 8) goto L_01FF;
L_01FE:;
if (V->DISP != 0) goto L_01FF;
// 3029 %if f = VinREC %then f = AinS %else f = VinS
if (F != 7) goto L_0200;
F = 6;
goto L_0201;
L_0200:;
F = 4;
L_0201:;
// 3030 v_disp = v_extra
V->DISP = V->EXTRA;
// 3031 %finish
L_01FF:;
// 3032 v_type = integers; v_form = f
V->TYPE = 1;
V->FORM = F;
// 3033 %end
return;
} /* end of AMAP */
// 3034
// 3035 ! >> AMAPS <<
// 3036 %routine amaps(%record(stackfm)%name v)
void AMAPS(struct STACKFM * V) {
// 3037 %integer t,l
int T;
int L;
// 3038 t = v_type; l = v_length
T = V->TYPE;
L = V->LENGTH;
// 3039 amap(v)
AMAP(V);
// 3040 %return %if t # strings; ! put length in top byte
if (T == 5) goto L_0202;
return;
L_0202:;
// 3041 reduce(v) %if v_form >= V in REC
if (V->FORM < 7) goto L_0203;
REDUCE(V);
L_0203:;
// 3042 load(v,any) %if v_form = V in S %or v_Form = AinS
if (V->FORM == 4) goto L_0204;
if (V->FORM != 6) goto L_0205;
L_0204:;
LOAD(V, 25);
L_0205:;
// 3043 !! It must be: const, V in R or AV in S
// 3044 v_disp = v_disp + l<<24
V->DISP = V->DISP + (L << 24);
// 3045 v_form = AV in S
V->FORM = 5;
// 3046 %end
return;
} /* end of AMAPS */
// 3047
// 3048 ! >> VMAP <<
// 3049 %routine vmap(%record(stackfm)%name v)
void VMAP(struct STACKFM * V) {
// 3050 ! The inverse of AMAP: i.e. vmap(amap(x)) => x
// 3051 %integer mod, f, t
int MOD;
int F;
int T;
// 3052 %constshortintegerarray map(0:8) =
const short int MAP[9] = {4, 4, -1, -2, 6, 4, -3, 9, 7};
// 3053+ v in s, v in s, -1, -2, a in s, v in s, -3, a in rec, v in rec
// 3054 mod = 0
MOD = 0;
// 3055 %if v_oper # 0 %start
if (V->OPER == 0) goto L_0206;
// 3056 %if (v_oper=add %or v_oper=sub) %and const(v_link) %start
if (V->OPER == 3) goto L_0207;
if (V->OPER != 4) goto L_0208;
L_0207:;
if (!(CONST(V->LINK))) goto L_0208;
// 3057 mod = v_link_disp
MOD = V->LINK->DISP;
// 3058 mod = -mod %if v_oper = sub
if (V->OPER != 4) goto L_0209;
MOD = -MOD;
L_0209:;
// 3059 v_oper = 0; drop(v_link)
V->OPER = 0;
DROP(V->LINK);
// 3060 %finish
L_0208:;
// 3061 load(v,any)
LOAD(V, 25);
// 3062 %else %if v_form = a in s %or v_form = a in rec
goto L_020A;
L_0206:;
if (V->FORM == 6) goto L_020B;
if (V->FORM != 9) goto L_020C;
L_020B:;
// 3063 T = V_Type
T = V->TYPE;
// 3064 Amap(V)
AMAP(V);
// 3065 load(v,any)
LOAD(V, 25);
// 3066 V_Type = T; V_Form = VinS
V->TYPE = T;
V->FORM = 4;
// 3067 %finish
L_020C:;
L_020A:;
// 3068 f = map(v_form); abort(m'VMAP') %if f < 0
F = MAP[V->FORM];
if (F >= 0) goto L_020D;
ABORT(1447903568);
L_020D:;
// 3069 v_form = f
V->FORM = F;
// 3070 v_disp = v_disp + mod
V->DISP = V->DISP + MOD;
// 3071 %end; ! v map
return;
} /* end of VMAP */
// 3072
// 3073 ! >> ADDRESS <<
// 3074 %routine address(%record(stackfm)%name v, %integer mode)
void ADDRESS(struct STACKFM * V, int MODE) {
// 3075 ! convert V into a form in which it is directly addressable
// 3076 ! MODE parameter specifies what type of result is required.
// 3077 ! >= 0 : a value (RHS)
// 3078 ! < 0 : a name (LHS)
// 3079 ! Further, if MODE > 0, the value is taken to specify the target register
// 3080 ! for any LOAD which may be generated.
// 3081 %integer type, form, reg, d, cr
int TYPE;
int FORM;
int REG;
int D;
int CR;
// 3082 %ownrecord(stackfm)%name last == (0); ! ***** null actually ****** UGH
static struct STACKFM *LAST = 0;
// 3083 monitor(v, "ADDRESS") %if diagnose&2 # 0
if (DIAGNOSE & 2 == 0) goto L_020E;
MONITOR(V, _imp_str_literal_size(15, "ADDRESS"));
L_020E:;
// 3084 reg = mode
REG = MODE;
// 3085 %if reg <= 0 %start
if (REG > 0) goto L_020F;
// 3086 reg = any
REG = 25;
// 3087 reg = anyf %if v_type >= reals %or (v_oper # 0 %and floating(v))
if (V->TYPE >= 7) goto L_0210;
if (V->OPER == 0) goto L_0211;
if (!(FLOATING(V))) goto L_0211;
L_0210:;
REG = 26;
L_0211:;
// 3088 %finish
L_020F:;
// 3089 cr = reg; !*psr*
CR = REG;
// 3090 %if v_oper # 0 %start; ! compound object
if (V->OPER == 0) goto L_0212;
// 3091 %if v_oper = ADD %and const(v_link) %and v_type <= BYTE %start
if (V->OPER != 3) goto L_0213;
if (!(CONST(V->LINK))) goto L_0213;
if (V->TYPE > 3) goto L_0213;
// 3092 d = v_link_disp; drop(v_link)
D = V->LINK->DISP;
DROP(V->LINK);
// 3093 v_oper = 0
V->OPER = 0;
// 3094 load(v,reg)
LOAD(V, REG);
// 3095 v_disp = d; v_form = AV in S
V->DISP = D;
V->FORM = 5;
// 3096 %else
goto L_0214;
L_0213:;
// 3097 load(v,reg)
LOAD(V, REG);
// 3098 %finish
L_0214:;
// 3099 ->SET CR
goto U_100B;
// 3100 %finish
L_0212:;
// 3101 form = v_form; type = v_type
FORM = V->FORM;
TYPE = V->TYPE;
// 3102 %if form >= V in REC %start
if (FORM < 7) goto L_0215;
// 3103 reduce(v); form = v_form
REDUCE(V);
FORM = V->FORM;
// 3104 %finish
L_0215:;
// 3105 %if control & suppress = 0 %start
if (CONTROL & 128 != 0) goto L_0216;
// 3106 cheap reg = cr
CHEAPREG = CR;
// 3107 cheapen(v,mode)
CHEAPEN(V, MODE);
// 3108 cr = cheap reg
CR = CHEAPREG;
// 3109 form = v_form
FORM = V->FORM;
// 3110 %finish
L_0216:;
// 3111 ->SET CR %if form = V in R %or form = constant
if (FORM == 1) goto L_0217;
if (FORM != 0) goto L_0218;
L_0217:;
goto U_100B;
L_0218:;
// 3112 %if form = AV in S %start
if (FORM != 5) goto L_0219;
// 3113 %if v_base = 0 %start
if (V->BASE != 0) goto L_021A;
// 3114 v_form = constant
V->FORM = 0;
// 3115 %else %if v_disp = 0
goto L_021B;
L_021A:;
if (V->DISP != 0) goto L_021C;
// 3116 v_form = V in R
V->FORM = 1;
// 3117 %finish
L_021C:;
L_021B:;
// 3118 ->SET CR
goto U_100B;
// 3119 %finish
L_0219:;
// 3120 %if form = A in S %start
if (FORM != 6) goto L_021D;
// 3121 v_form = V in S; v_type = integers
V->FORM = 4;
V->TYPE = 1;
// 3122 load(v,any)
LOAD(V, 25);
// 3123 v_type = type; v_xform = (v_flag&(\assigned))<<8 ! V in S; v_disp = 0
V->TYPE = TYPE;
V->XFORM = (V->FLAG & (~8)) << 8 | 4;
V->DISP = 0;
// 3124 form = V in S
FORM = 4;
// 3125 %finish
L_021D:;
// 3126 %if %not last == v %start; ! *** FRIG: to prevent mutually recursive loop
if (_imp_ADDR((void *)(LAST)) == _imp_ADDR((void *)(V))) goto L_021E;
// 3127 last == v
LAST = (struct STACKFM *)V;
// 3128 %if mode >= 0 %and ((control&check unass#0 %and v_type#strings %c
if (MODE < 0) goto L_021F;
if (CONTROL & 2 == 0) goto L_0220;
if (V->TYPE == 5) goto L_0220;
if (CHECKABLE(V)) goto L_0221;
L_0220:;
if (V->TYPE != 3) goto L_021F;
L_0221:;
// 3129+ %and checkable(v)) %or v_type = byte) %start
// 3130 load(v,reg)
LOAD(V, REG);
// 3131 %finish
L_021F:;
// 3132 last == null
LAST = (struct STACKFM *)NULL;
// 3133 %finish
L_021E:;
// 3134
// 3135 SET CR:
U_100B:;
// 3136
// 3137 cheap reg = cr
CHEAPREG = CR;
// 3138 %end; ! address
return;
} /* end of ADDRESS */
// 3139
// 3140 ! >> LOAD <<
// 3141 %routine load(%record(stackfm)%name v, %integer r)
void LOAD(struct STACKFM * V, int R) {
// 3142 ! load the entity described by V into register R
// 3143
// 3144 %record(stackfm)%name w
struct STACKFM *W;
// 3145 %switch f(constant:a in rec), iop(not:rdiv), rop(not:rdiv)
int F_index;
int F_line;
char *F_file;
static const void *F[10] = {&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing,
&&case_F_missing, &&case_F_missing, &&case_F_missing, &&case_F_missing,
&&case_F_missing, &&case_F_missing};
int IOP_index;
int IOP_line;
char *IOP_file;
static const void *IOP[17] = {&&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[17] = {&&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};
// 3146 %record(stackfm) z
struct STACKFM Z;
// 3147 %record(stackfm)%name temp rhs
struct STACKFM *TEMPRHS;
// 3148 %integer op, d, type, temp, n, uflag
int OP;
int D;
int TYPE;
int TEMP;
int N;
int UFLAG;
// 3149
// 3150 %constbyteintegerarray twin(R0:R15) =
const unsigned char TWIN[16] = {2, 1, 4, 3, 6, 5, 8, 7, 10, 9, 12, 11, 14, 13, 16, 15};
// 3151+ R1,R0, R3,R2, R5,R4, R7,R6, R9,R8, R11,R10, R13,R12, R15,R14
// 3152
// 3153
// 3154 %routine PICKUP(%record(stackfm)%name V)
void PICKUP(struct STACKFM * V) {
// 3155 %integer old
int OLD;
// 3156 load(v, r)
LOAD(V, R);
// 3157 %if R = Any %or R = AnyF %start
if (R == 25) goto L_0222;
if (R != 26) goto L_0223;
L_0222:;
// 3158 old = R; R = V_Base
OLD = R;
R = V->BASE;
// 3159 %return %if Activity(R) = 1 %or (Activity(R)=2 %and W_Base = R)
if (ACTIVITY[R] == 1) goto L_0224;
if (ACTIVITY[R] != 2) goto L_0225;
if (W->BASE != R) goto L_0225;
L_0224:;
return;
L_0225:;
// 3160 %if old = Any %then R = Gpr %else R = Fpr
if (OLD != 25) goto L_0226;
R = GPR();
goto L_0227;
L_0226:;
R = FPR();
L_0227:;
// 3161 Load(V, R)
LOAD(V, R);
// 3162 %else
goto L_0228;
L_0223:;
// 3163 abort(m'Pick') %if activity(r) # 1
if (ACTIVITY[R] == 1) goto L_0229;
ABORT(1349084011);
L_0229:;
// 3164 %finish
L_0228:;
// 3165 %end
return;
} /* end of PICKUP */
// 3166
// 3167 monitor(v, "LOAD") %if diagnose&2 # 0
if (DIAGNOSE & 2 == 0) goto L_022A;
MONITOR(V, _imp_str_literal_size(15, "LOAD"));
L_022A:;
// 3168 -> realv %if floating(v) %or fr0 <= r <= fr14 %or r = anyf
if (FLOATING(V)) goto L_022B;
{
// Double-sided test on R (Part I)
int tmp;
if (17 > (tmp = R)) goto L_022C;
// Double-sided test on R (Part II)
if (tmp <= 24) goto L_022B;
}
L_022C:;
if (R != 26) goto L_022D;
L_022B:;
goto U_100C;
L_022D:;
// 3169 op = v_oper; v_oper = 0
OP = V->OPER;
V->OPER = 0;
// 3170 %if op # 0 %start
if (OP == 0) goto L_022E;
// 3171 w == v_link; {address(w,0)}; ! records reduced here
W = (struct STACKFM *)V->LINK;
// 3172 load(w,any) %if w_base = r # v_base; ! *** FRIG: to avoid problem
{
// Double-sided test on R (Part I)
int tmp;
if (W->BASE != (tmp = R)) goto L_022F;
// Double-sided test on R (Part II)
if (tmp == V->BASE) goto L_022F;
}
LOAD(W, 25);
L_022F:;
// 3173 ! with HAZARD and e.g. -> sw( -A(j) )
// 3174 -> iop(op)
IOP_line = __LINE__;
IOP_file = __FILE__;
IOP_index = OP;
goto case_IOP_dispatch;
// 3175 %finish
L_022E:;
// 3176 amap(v) %if v_type = 0 %or v_type = strings %or v_type = records
if (V->TYPE == 0) goto L_0231;
if (V->TYPE == 5) goto L_0231;
if (V->TYPE != 6) goto L_0232;
L_0231:;
AMAP(V);
L_0232:;
// 3177 address(v,r)
ADDRESS(V, R);
// 3178 %if r = any %start
if (R != 25) goto L_0233;
// 3179 %return %if v_form = VinR
if (V->FORM != 1) goto L_0234;
return;
L_0234:;
// 3180 %if v_form = AV in S %and activity(v_base) = 1 %and -15 <= v_disp <= 15 %start
if (V->FORM != 5) goto L_0235;
if (ACTIVITY[V->BASE] != 1) goto L_0235;
{
// Double-sided test on V->DISP (Part I)
int tmp;
if (-15 > (tmp = V->DISP)) goto L_0235;
// Double-sided test on V->DISP (Part II)
if (tmp > 15) goto L_0235;
}
// 3181 r = v_base
R = V->BASE;
// 3182 %else
goto L_0236;
L_0235:;
// 3183 r = gpr
R = GPR();
// 3184 %finish
L_0236:;
// 3185 %else
goto L_0237;
L_0233:;
// 3186 %if v_base = r %start
if (V->BASE != R) goto L_0238;
// 3187 %if activity(r) > 1 %start {protect other uses}
if (ACTIVITY[R] <= 1) goto L_0239;
// 3188 release(r); v_base = 0
RELEASE(R);
V->BASE = 0;
// 3189 hazard(r)
HAZARD(R);
// 3190 claim(r); v_base = r
CLAIM(R);
V->BASE = R;
// 3191 %finish
L_0239:;
// 3192 %else
goto L_023A;
L_0238:;
// 3193 hazard(r)
HAZARD(R);
// 3194 %finish
L_023A:;
// 3195 %finish
L_0237:;
// 3196 -> f(v_form)
F_line = __LINE__;
F_file = __FILE__;
F_index = V->FORM;
goto case_F_dispatch;
// 3197
// 3198 f(av in rec):
case_F_8:;
// 3199 f(a in rec):
case_F_9:;
// 3200 f(v in rec):
case_F_7:;
// 3201 f(A in S):
case_F_6:;
// 3202 abort(m'LD1'); ! These forms should have been simplified by ADDRESS
ABORT(4998193);
// 3203
// 3204 f(av in s):
case_F_5:;
// 3205 f(constant):
case_F_0:;
// 3206 abort(m'LD2') %if v_type >= reals
if (V->TYPE < 7) goto L_023C;
ABORT(4998194);
L_023C:;
// 3207 rxi(lw,r,v_base,v_disp)
RXI(1, R, V->BASE, V->DISP);
// 3208 forget reg(1<<r); associate(v,r) %if r # v_base; ! e.g.LHI 12,1(12)
FORGETREG(1 << R);
if (R == V->BASE) goto L_023D;
ASSOCIATE(V, R);
L_023D:;
// 3209 CSETI:
U_100D:;
// 3210 v_type = integers
V->TYPE = 1;
// 3211 CSET:
U_100E:;
// 3212 v_form = v in r
V->FORM = 1;
// 3213 v_base = r; v_disp = 0
V->BASE = R;
V->DISP = 0;
// 3214 claim(r)
CLAIM(R);
// 3215 %return
return;
// 3216
// 3217 f(v in r):
case_F_1:;
// 3218 %return %if v_base = r
if (V->BASE != R) goto L_023E;
return;
L_023E:;
// 3219 rr(lw,r,v_base); forget reg(1<<r)
RR(1, R, V->BASE);
FORGETREG(1 << R);
// 3220 v_base = r
V->BASE = R;
// 3221 claim(r)
CLAIM(R);
// 3222 %return
return;
// 3223
// 3224 f(v in s):
case_F_4:;
// 3225 uflag = control & check unass
UFLAG = CONTROL & 2;
// 3226 %if integers < v_type < reals %start
{
// Double-sided test on V->TYPE (Part I)
int tmp;
if (1 >= (tmp = V->TYPE)) goto L_023F;
// Double-sided test on V->TYPE (Part II)
if (tmp >= 7) goto L_023F;
}
// 3227 abort(m'LD3') %if short # v_type # byte
{
// Double-sided test on V->TYPE (Part I)
int tmp;
if (2 == (tmp = V->TYPE)) goto L_0240;
// Double-sided test on V->TYPE (Part II)
if (tmp == 3) goto L_0240;
}
ABORT(4998195);
L_0240:;
// 3228 uflag = 0
UFLAG = 0;
// 3229 %else
goto L_0241;
L_023F:;
// 3230 uflag = 0 %if v_Flag&assigned # 0 %or %not checkable(v) %or v_Type = 255
if (V->FLAG & 8 != 0) goto L_0242;
if (!(CHECKABLE(V))) goto L_0242;
if (V->TYPE != 255) goto L_0243;
L_0242:;
UFLAG = 0;
L_0243:;
// 3231 %finish
L_0241:;
// 3232 %if V_Type = 255 %start
if (V->TYPE != 255) goto L_0244;
// 3233 V_Type = Short
V->TYPE = 2;
// 3234 Rxd(LHL, r, v)
RXD(37, R, V);
// 3235 Forget reg(1<<r)
FORGETREG(1 << R);
// 3236 %else
goto L_0245;
L_0244:;
// 3237 rxd(lw,r,v)
RXD(1, R, V);
// 3238 forget reg(1<<r); associate(v,r)
FORGETREG(1 << R);
ASSOCIATE(V, R);
// 3239 %finish
L_0245:;
// 3240 %if uflag # 0 %start
if (UFLAG == 0) goto L_0246;
// 3241 %if v_type < reals %start
if (V->TYPE >= 7) goto L_0247;
// 3242 v_type = integers
V->TYPE = 1;
// 3243 %if level # 5 %start
if (LEVEL == 5) goto L_0248;
// 3244 rr(clw,r,r12)
RR(28, R, 13);
// 3245 %else
goto L_0249;
L_0248:;
// 3246 rx(clw,r,code,unass)
RX(28, R, 15, 12);
// 3247 %finish
L_0249:;
// 3248 %else
goto L_024A;
L_0247:;
// 3249 v_type = reall
V->TYPE = 7;
// 3250 rx(cmp,r,code,unass)
RX(7, R, 15, 12);
// 3251 %finish
L_024A:;
// 3252 rr(bal,link,code)
RR(22, 16, 15);
// 3253 v_flag = v_flag & (\assigned); ! only one level remembered (1 bit !!)
V->FLAG = V->FLAG & (~8);
// 3254 %finish
L_0246:;
// 3255 -> CSET
goto U_100E;
// 3256
// 3257 ! integer operations
// 3258 iop(and):
case_IOP_8:;
// 3259 %if control&check unass = 0 %and w_form = constant %start
if (CONTROL & 2 != 0) goto L_024B;
if (W->FORM != 0) goto L_024B;
// 3260 address(v, r)
ADDRESS(V, R);
// 3261 %if w_disp = x'FFFF' %start
if (W->DISP != 65535) goto L_024C;
// 3262 %if v_form = VinS %and (v_type = integers %or v_type = short) %start
if (V->FORM != 4) goto L_024D;
if (V->TYPE == 1) goto L_024E;
if (V->TYPE != 2) goto L_024D;
L_024E:;
// 3263 v_disp = v_disp+2 %if v_type = integers
if (V->TYPE != 1) goto L_024F;
V->DISP = V->DISP + 2;
L_024F:;
// 3264 LOADL:
U_100F:;
// 3265 v_type = 255
V->TYPE = 255;
// 3266 drop(w)
DROP(W);
// 3267 Load(V, R)
LOAD(V, R);
// 3268 %return
return;
// 3269 %finish
L_024D:;
// 3270 %else %if w_disp = 255
goto L_0250;
L_024C:;
if (W->DISP != 255) goto L_0251;
// 3271 drop(w)
DROP(W);
// 3272 %if v_form = VinR %start
if (V->FORM != 1) goto L_0252;
// 3273 r = gpr %if r = any
if (R != 25) goto L_0253;
R = GPR();
L_0253:;
// 3274 rr(LBR, r, v_base)
RR(31, R, V->BASE);
// 3275 ->CSETI
goto U_100D;
// 3276 %finish
L_0252:;
// 3277 %if v_type = integers %start
if (V->TYPE != 1) goto L_0254;
// 3278 v_disp = v_disp+3
V->DISP = V->DISP + 3;
// 3279 %else %if v_type = short
goto L_0255;
L_0254:;
if (V->TYPE != 2) goto L_0256;
// 3280 v_disp = v_disp+1
V->DISP = V->DISP + 1;
// 3281 %finish
L_0256:;
L_0255:;
// 3282 v_type = byte
V->TYPE = 3;
// 3283 load(v, r)
LOAD(V, R);
// 3284 %return
return;
// 3285 %finish
L_0251:;
L_0250:;
// 3286 %finish
L_024B:;
// 3287 {** Drops through **}
// 3288 iop(add):
case_IOP_3:;
// 3289 iop(sub):
case_IOP_4:;
// 3290 iop(or):
case_IOP_9:;
// 3291 iop(xor):
case_IOP_10:;
// 3292 pickup(v) {sets R}
PICKUP(V);
// 3293 address(w, 0) {**Moved down one line**}
ADDRESS(W, 0);
// 3294 rxd(op,r,w)
RXD(OP, R, W);
// 3295 -> end op
goto U_1010;
// 3296
// 3297 iop(rsh):
case_IOP_12:;
// 3298 %if control&check unass = 0 %and w_form = constant %and w_disp = 16 %start
if (CONTROL & 2 != 0) goto L_0257;
if (W->FORM != 0) goto L_0257;
if (W->DISP != 16) goto L_0257;
// 3299 address(v, r)
ADDRESS(V, R);
// 3300 ->LOADL %if v_form = VinS %and v_type = integers
if (V->FORM != 4) goto L_0258;
if (V->TYPE != 1) goto L_0258;
goto U_100F;
L_0258:;
// 3301 %finish
L_0257:;
// 3302 iop(lsh):
case_IOP_11:;
// 3303 %if w_form # constant %and control&check capacity # 0 %start
if (W->FORM == 0) goto L_0259;
if (CONTROL & 1 == 0) goto L_0259;
// 3304 load(w,r2); perm(vschk)
LOAD(W, 3);
PERM(29);
// 3305 %finish
L_0259:;
// 3306 pickup(v) {sets R}
PICKUP(V);
// 3307 %if w_form = constant %start
if (W->FORM != 0) goto L_025A;
// 3308 warn(6) %unless 0 <= w_disp <= 8*reglen-1
{
// Double-sided test on W->DISP (Part I)
int tmp;
if (0 > (tmp = W->DISP)) goto L_025B;
// Double-sided test on W->DISP (Part II)
if (tmp <= 8 * 4 - 1) goto L_025C;
}
L_025B:;
WARN(6);
L_025C:;
// 3309 %else; ! variable shift
goto L_025D;
L_025A:;
// 3310 load(w,any) %if w_form # V in R
if (W->FORM == 1) goto L_025E;
LOAD(W, 25);
L_025E:;
// 3311 w_disp = 0
W->DISP = 0;
// 3312 %finish
L_025D:;
// 3313 rxi(op,v_base,w_base,w_disp)
RXI(OP, V->BASE, W->BASE, W->DISP);
// 3314 -> end op
goto U_1010;
// 3315
// 3316 ! these operations are changed immediately into binary subtracts
// 3317 ! and should themselves never appear in LOAD
// 3318 ! -x => 0 - x
// 3319 ! \x => -1 - x (assumes 2's complement)
// 3320 iop(not):
case_IOP_1:;
// 3321 iop(neg):
case_IOP_2:;
// 3322 abort(m'LD4')
ABORT(4998196);
// 3323
// 3324 iop(div):
case_IOP_6:;
// 3325 %if w_form = constant %start
if (W->FORM != 0) goto L_025F;
// 3326 n = power(w_disp)
N = POWER(W->DISP);
// 3327 %if n > 0 %start
if (N <= 0) goto L_0260;
// 3328 Pickup(V) {make sure it's in the correct register}
PICKUP(V);
// 3329 Test Zero(v); r = v_base
TESTZERO(V);
R = V->BASE;
// 3330 claim(r)
CLAIM(R);
// 3331 d = 1; d = 2 %if n > 4; ! 1 or 2 halfwords
D = 1;
if (N <= 4) goto L_0261;
D = 2;
L_0261:;
// 3332 skip(d, greater or equal)
SKIP(D, 5);
// 3333 rxi(ADD, v_base, 0, \((-1)<<n))
RXI(3, V->BASE, 0, ~((-1) << N));
// 3334 rxi(SRA, v_base, 0, n)
RXI(29, V->BASE, 0, N);
// 3335 ->END OP
goto U_1010;
// 3336 %finish
L_0260:;
// 3337 %finish
L_025F:;
// 3338 {** Drops through **}
// 3339
// 3340 ! *** N.B. ***
// 3341 ! The multiply routine below is not intended for use in array subscript
// 3342 ! calculation as it will include an overflow check. Currently all in-line
// 3343 ! subscript scaling uses shift or 'multiply halfword' instructions.
// 3344 iop(mul):
case_IOP_5:;
// 3345 iop(rem):
case_IOP_14:;
// 3346 %if r = any %start
if (R != 25) goto L_0262;
// 3347 n = 0; n = 1 %if op = MUL
N = 0;
if (OP != 5) goto L_0263;
N = 1;
L_0263:;
// 3348 %if in free reg(v) %and actual(v_base)&1 = n %c
if (!(INFREEREG(V))) goto L_0264;
if (ACTUAL[V->BASE] & 1 != N) goto L_0264;
if (ACTIVITY[TWIN[V->BASE - 1]] != 0) goto L_0264;
// 3349+ %and activity(twin(v_base)) = 0 %start
// 3350 temp = v_base
TEMP = V->BASE;
// 3351 temp = twin(temp) %if op # MUL
if (OP == 5) goto L_0265;
TEMP = TWIN[TEMP - 1];
L_0265:;
// 3352 %else
goto L_0266;
L_0264:;
// 3353 temp = even odd pair
TEMP = EVENODDPAIR();
// 3354 %finish
L_0266:;
// 3355 %else
goto L_0267;
L_0262:;
// 3356 %if actual(r)&1 # 0 %and activity(twin(r)) = 0 %start
if (ACTUAL[R] & 1 == 0) goto L_0268;
if (ACTIVITY[TWIN[R - 1]] != 0) goto L_0268;
// 3357 temp = r
TEMP = R;
// 3358 %else
goto L_0269;
L_0268:;
// 3359 temp = even odd pair
TEMP = EVENODDPAIR();
// 3360 %finish
L_0269:;
// 3361 %finish
L_0267:;
// 3362 n = twin(temp)
N = TWIN[TEMP - 1];
// 3363 claim(n); load(v,temp)
CLAIM(N);
LOAD(V, TEMP);
// 3364 release(n); hazard(n); claim(n)
RELEASE(N);
HAZARD(N);
CLAIM(N);
// 3365 d = op
D = OP;
// 3366 %if op # MUL %start
if (OP == 5) goto L_026A;
// 3367 rr(lw,n,temp); claim(temp)
RR(1, N, TEMP);
CLAIM(TEMP);
// 3368 rxi(sra,n,0,31); ! propagate sign
RXI(29, N, 0, 31);
// 3369 d = div
D = 6;
// 3370 %finish
L_026A:;
// 3371 forget reg( (2+1)<<n ); ! forget N,TEMP (adjacent)
FORGETREG(2 + 1 << N);
// 3372 address(w, 0)
ADDRESS(W, 0);
// 3373 ! Note complication below because machine op-code only caters
// 3374 ! for the cases INTEGER*INTEGER, INTEGER//INTEGER, rem(INTEGER,INTEGER)
// 3375 ! Short, byte and constant multipliers must therefore be preloaded
// 3376 ! into a register
// 3377 load(w,any) %if w_form = constant %or w_form = AV in S %or w_type # integers
if (W->FORM == 0) goto L_026B;
if (W->FORM == 5) goto L_026B;
if (W->TYPE == 1) goto L_026C;
L_026B:;
LOAD(W, 25);
L_026C:;
// 3378 rxd(d,n,w)
RXD(D, N, W);
// 3379 release(n)
RELEASE(N);
// 3380 %if op = MUL %start
if (OP != 5) goto L_026D;
// 3381 %if control & check capacity # 0 %start; ! overflow check
if (CONTROL & 1 == 0) goto L_026E;
// 3382 %if n # R0 %start
if (N == 1) goto L_026F;
// 3383 claim(n); rr(LW,r0,n)
CLAIM(N);
RR(1, 1, N);
// 3384 %finish
L_026F:;
// 3385 perm(mulchk)
PERM(21);
// 3386 %finish
L_026E:;
// 3387 %else %if op = rem
goto L_0270;
L_026D:;
if (OP != 14) goto L_0271;
// 3388 ! Interested in remainder not dividend
// 3389 claim(n); release(temp)
CLAIM(N);
RELEASE(TEMP);
// 3390 d = temp; temp = n; n = d
D = TEMP;
TEMP = N;
N = D;
// 3391 %finish
L_0271:;
L_0270:;
// 3392 v_base = temp; v_disp = 0; v_form = v in r
V->BASE = TEMP;
V->DISP = 0;
V->FORM = 1;
// 3393 load(v,r) %if temp # r
if (TEMP == R) goto L_0272;
LOAD(V, R);
L_0272:;
// 3394 -> end op
goto U_1010;
// 3395
// 3396 ! Special multiply routine used for array subscript scaling where all values
// 3397 ! involved are in range: -32768 <= x <= +32767
// 3398 iop(mult16):
case_IOP_13:;
// 3399 %if r = v_base %or v_type = byte %start
if (R == V->BASE) goto L_0273;
if (V->TYPE != 3) goto L_0274;
L_0273:;
// 3400 load(v,any)
LOAD(V, 25);
// 3401 %else
goto L_0275;
L_0274:;
// 3402 address(v,0)
ADDRESS(V, 0);
// 3403 load(v,any) %if v_form # V in S %and v_form # V in R %and v_form # constant
if (V->FORM == 4) goto L_0276;
if (V->FORM == 1) goto L_0276;
if (V->FORM == 0) goto L_0276;
LOAD(V, 25);
L_0276:;
// 3404 %finish
L_0275:;
// 3405 v_disp = v_disp+reglen//2 %if v_type = integers; ! ** halfword instruction!! **
if (V->TYPE != 1) goto L_0277;
V->DISP = V->DISP + ((long)4 / (long)2);
L_0277:;
// 3406 pickup(w); ! scale factor (data size) - & sets R
PICKUP(W);
// 3407 rxd(mult16,r,v)
RXD(13, R, V);
// 3408 v_base = r; v_disp = 0; v_xform = V in R
V->BASE = R;
V->DISP = 0;
V->XFORM = 1;
// 3409 -> end op
goto U_1010;
// 3410
// 3411 iop(exp):
case_IOP_15:;
// 3412 load(v,r3); load(w,r2)
LOAD(V, 4);
LOAD(W, 3);
// 3413 release(r3); release(r2)
RELEASE(4);
RELEASE(3);
// 3414 perm(iexp)
PERM(2);
// 3415 claim(r1); v_base = r1
CLAIM(2);
V->BASE = 2;
// 3416 -> end op
goto U_1010;
// 3417
// 3418 iop(conc):
case_IOP_7:;
// 3419 address(v, r)
ADDRESS(V, R);
// 3420 %if v_type # 0 %start
if (V->TYPE == 0) goto L_0278;
// 3421 pdisp = basic frame %if pdisp = 0
if (PDISP != 0) goto L_0279;
PDISP = 44;
L_0279:;
// 3422 ! N.B. Must %not corrupt LHS/RHS in LOAD
// 3423 temp rhs == rhs
TEMPRHS = (struct STACKFM *)RHS;
// 3424 sset(wsp,pdisp,V in S,0); rhs_type = strings; rhs_length = 255
SSET(8, PDISP, 4, 0);
RHS->TYPE = 5;
RHS->LENGTH = 255;
// 3425 rhs == temp rhs
RHS = (struct STACKFM *)TEMPRHS;
// 3426 sstack(v); v_Base = 0
SSTACK(V);
V->BASE = 0;
// 3427 assign(1)
ASSIGN(1);
// 3428 claim(r2)
CLAIM(3);
// 3429 v_type = strings; v_form = VinS
V->TYPE = 5;
V->FORM = 4;
// 3430 v_base = r2; v_disp = 0
V->BASE = 3;
V->DISP = 0;
// 3431 v_length = 255; ! it's a temporary now
V->LENGTH = 255;
// 3432 pdisp = pdisp + 256; ! ... so protect it
PDISP = PDISP + 256;
// 3433 %finish
L_0278:;
// 3434 %if w_flag & quick conc # 0 %start; ! S = S.tostring(sym)
if (W->FLAG & 1 == 0) goto L_027A;
// 3435 z = v; claim(z_base); z_type = byte
Z = *V;
CLAIM(Z.BASE);
Z.TYPE = 3;
// 3436 load(z, any)
LOAD(/*?*/ &Z, 25);
// 3437 rxi(LW, z_base, z_base, 1); claim(z_base) {length+1}
RXI(1, Z.BASE, Z.BASE, 1);
CLAIM(Z.BASE);
// 3438 load(w, any) {character}
LOAD(W, 25);
// 3439 v_index = z_base; v_type = byte; v_form = VinS
V->INDEX = Z.BASE;
V->TYPE = 3;
V->FORM = 4;
// 3440 rxd(ST, w_base, v); release(w_base)
RXD(2, W->BASE, V);
RELEASE(W->BASE);
// 3441 claim(v_base); v_index = 0
CLAIM(V->BASE);
V->INDEX = 0;
// 3442 rxd(ST, z_base, v)
RXD(2, Z.BASE, V);
// 3443 %else
goto L_027B;
L_027A:;
// 3444 load(v, r2)
LOAD(V, 3);
// 3445 load(w,r1); release(r1); release(r2)
LOAD(W, 2);
RELEASE(2);
RELEASE(3);
// 3446 n = v_length; n = 255 %if n = 0
N = V->LENGTH;
if (N != 0) goto L_027C;
N = 255;
L_027C:;
// 3447 perm(sconc); cput(n)
PERM(6);
CPUT(N);
// 3448 v_form = VinS
V->FORM = 4;
// 3449 %finish
L_027B:;
// 3450 claim(v_base)
CLAIM(V->BASE);
// 3451 v_type = 0
V->TYPE = 0;
// 3452 %if r # any %and r # 0 %start; ! not from OPERATE
if (R == 25) goto L_027D;
if (R == 0) goto L_027D;
// 3453 load(v,r); v_type = 0; v_form = v in s
LOAD(V, R);
V->TYPE = 0;
V->FORM = 4;
// 3454 %finish
L_027D:;
// 3455 drop(w)
DROP(W);
// 3456 %return {Note: nothing to forget}
return;
// 3457
// 3458 ! floating operations
// 3459 REALV:
U_100C:;
// 3460 abort(m'LD5') %if r = any; ! should be floating register
if (R != 25) goto L_027E;
ABORT(4998197);
L_027E:;
// 3461 op = v_oper; v_oper = 0
OP = V->OPER;
V->OPER = 0;
// 3462 %if op # 0 %start
if (OP == 0) goto L_027F;
// 3463 w == v_link
W = (struct STACKFM *)V->LINK;
// 3464 -> rop(op)
ROP_line = __LINE__;
ROP_file = __FILE__;
ROP_index = OP;
goto case_ROP_dispatch;
// 3465
// 3466 rop(not):
case_ROP_1:;
// 3467 rop(lsh):
case_ROP_11:;
// 3468 rop(rsh):
case_ROP_12:;
// 3469 rop(and):
case_ROP_8:;
// 3470 rop(or):
case_ROP_9:;
// 3471 rop(xor):
case_ROP_10:;
// 3472 rop(conc):
case_ROP_7:;
// 3473 rop(mult16):
case_ROP_13:;
// 3474 abort(m'LD6'); ! inappropriate operator
ABORT(4998198);
// 3475
// 3476 rop(rdiv):
case_ROP_17:;
// 3477 op = div
OP = 6;
// 3478 rop(div):
case_ROP_6:;
// 3479 rop(add):
case_ROP_3:;
// 3480 rop(sub):
case_ROP_4:;
// 3481 rop(mul):
case_ROP_5:;
// 3482 %if w_type < reals %start
if (W->TYPE >= 7) goto L_0281;
// 3483 float(w, anyf)
FLOAT(W, 26);
// 3484 %if w_form = V in R # v_form %and v_type >= reals %c
{
// Double-sided test on 1 (Part I)
int tmp;
if (W->FORM != (tmp = 1)) goto L_0282;
// Double-sided test on 1 (Part II)
if (tmp == V->FORM) goto L_0282;
}
if (V->TYPE < 7) goto L_0282;
if (OP == 3) goto L_0283;
if (OP != 5) goto L_0282;
L_0283:;
// 3485+ %and (op = add %or op = mul) %start
// 3486 z = v; v = w; w = z; ! interchange
Z = *V;
*V = *W;
*W = Z;
// 3487 %finish
L_0282:;
// 3488 %finish
L_0281:;
// 3489 Pickup(v); r = v_base
PICKUP(V);
R = V->BASE;
// 3490 Address(W, 0)
ADDRESS(W, 0);
// 3491 rxd(op,r,w)
RXD(OP, R, W);
// 3492 -> end op
goto U_1010;
// 3493
// 3494 rop(neg):
case_ROP_2:;
// 3495 abort(m'LD7'); ! should have been modified by OPERATE
ABORT(4998199);
// 3496
// 3497 %finish
L_027F:;
// 3498 float(v, r) %if v_type < reals
if (V->TYPE >= 7) goto L_0284;
FLOAT(V, R);
L_0284:;
// 3499 address(v, r) {AFTER float to prevent optimising constants}
ADDRESS(V, R);
// 3500 {e.g. I=0; R=0}
// 3501 %if v_form = v in r %start
if (V->FORM != 1) goto L_0285;
// 3502 %return %if r = anyf %or v_base = r
if (R == 26) goto L_0286;
if (V->BASE != R) goto L_0287;
L_0286:;
return;
L_0287:;
// 3503 hazard(r); rr(lw,r,v_base)
HAZARD(R);
RR(1, R, V->BASE);
// 3504 v_base = r; claim(r)
V->BASE = R;
CLAIM(R);
// 3505 %return
return;
// 3506 %finish
L_0285:;
// 3507 %if r = anyf %start
if (R != 26) goto L_0288;
// 3508 r = fpr
R = FPR();
// 3509 %else
goto L_0289;
L_0288:;
// 3510 hazard(r) %unless r = v_base
if (R == V->BASE) goto L_028A;
HAZARD(R);
L_028A:;
// 3511 %finish
L_0289:;
// 3512 abort(m'LD8') %unless fr0 <= r <= fr14
{
// Double-sided test on R (Part I)
int tmp;
if (17 > (tmp = R)) goto L_028B;
// Double-sided test on R (Part II)
if (tmp <= 24) goto L_028C;
}
L_028B:;
ABORT(4998200);
L_028C:;
// 3513 -> f(v_form)
F_line = __LINE__;
F_file = __FILE__;
F_index = V->FORM;
goto case_F_dispatch;
// 3514
// 3515 rop(rexp):
case_ROP_16:;
// 3516 abort(m'LD9') %if w_type >= reals
if (W->TYPE < 7) goto L_028D;
ABORT(4998201);
L_028D:;
// 3517 load(v,fr2); load(w,r1)
LOAD(V, 18);
LOAD(W, 2);
// 3518 release(fr2); release(r1)
RELEASE(18);
RELEASE(2);
// 3519 perm(fexp); ! floating exponent
PERM(3);
// 3520 claim(fr0); v_base = fr0
CLAIM(17);
V->BASE = 17;
// 3521
// 3522 END OP:
U_1010:;
// 3523 V_Type = Integers %if V_Type <= Byte
if (V->TYPE > 3) goto L_028E;
V->TYPE = 1;
L_028E:;
// 3524 forget reg(1<<v_base)
FORGETREG(1 << V->BASE);
// 3525 drop(w)
DROP(W);
// 3526 %end;
return;
case_F_dispatch:
if (F_index < 0 || F_index > 9)
_imp_signalf(6, 3, F_index, "->F(%d) out of bounds at %s line %d", F_index, F_file, F_line);
goto *F[F_index - 0];
case_F_missing:
_imp_signalf(8, 2, F_index, "switch jump to undefined label F(%d): at %s line %d", F_index, F_file, F_line);
case_IOP_dispatch:
if (IOP_index < 1 || IOP_index > 17)
_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 - 1];
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 < 1 || ROP_index > 17)
_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 - 1];
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 */
// ?TYPE unused
// 3527 ; ! load
// 3527
// 3528 ! >> COP <<
// 3529 %routine cop(%integer op, %record(stackfm)%name lh,rh)
void COP(int OP, struct STACKFM *LH, struct STACKFM *RH) {
// 3530 ! perform a compile-time operation
// 3531 %constinteger fp tens=70; ! max powers of ten available in floating point
// 3532 %integer l,r
int L;
int R;
// 3533 %switch s(1:rdiv)
int S_index;
int S_line;
char *S_file;
static const void *S[17] = {
&&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing,
&&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing,
&&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing, &&case_S_missing};
// 3534 %integerfn p10(%integer n); ! approximate powers of ten in 'n'
int P10(int N) {
// 3535 %integer value, power
int VALUE;
int POWER;
// 3536 value = 1; power = 0
VALUE = 1;
POWER = 0;
// 3537 %cycle
L_028F:;
// 3538 %result = power %if value >= n
if (VALUE < N) goto L_0290;
return POWER;
L_0290:;
// 3539 value = value*10
VALUE = VALUE * 10;
// 3540 power = power+1
POWER = POWER + 1;
// 3541 abort(m'COP1') %if power > 100
if (POWER <= 100) goto L_0291;
ABORT(1129271345);
L_0291:;
// 3542 %repeat
goto L_028F;
// 3543 %end
} /* end of P10 */
// 3544 l = lh_disp; r = rh_disp
L = LH->DISP;
R = RH->DISP;
// 3545 -> s(op)
S_line = __LINE__;
S_file = __FILE__;
S_index = OP;
goto case_S_dispatch;
// 3546 s(NEG):
case_S_2:;
// 3547 s(NOT):
case_S_1:;
// 3548 s(CONC): abort(m'COP2')
case_S_7:;
ABORT(1129271346);
// 3549
// 3550 s(ADD): l = l+r; -> EXIT
case_S_3:;
L = L + R;
goto U_100B;
// 3551 s(SUB): l = l-r; -> EXIT
case_S_4:;
L = L - R;
goto U_100B;
// 3552 s(OR): l = l!R; -> EXIT
case_S_9:;
L = L | R;
goto U_100B;
// 3553 s(AND): l = l&r; -> EXIT
case_S_8:;
L = L & R;
goto U_100B;
// 3554 s(XOR): l = l!!R; -> EXIT
case_S_10:;
L = L ^ R;
goto U_100B;
// 3555 s(LSH): l = l<<r; -> EXIT
case_S_11:;
L = L << R;
goto U_100B;
// 3556 s(MUL): l = l*r; -> EXIT
case_S_5:;
L = L * R;
goto U_100B;
// 3557 s(MULT16): l = l*r; -> EXIT
case_S_13:;
L = L * R;
goto U_100B;
// 3558 s(RSH): l = l>>r; -> EXIT
case_S_12:;
L = (unsigned int)L >> R;
goto U_100B;
// 3559 s(EXP): l = l^^r; -> EXIT
case_S_15:;
L = _imp_IEXP(L, R);
goto U_100B;
// 3560 s(DIV): warn(1) %and r = 1 %if r = 0
case_S_6:;
if (R != 0) goto L_0293;
WARN(1);
R = 1;
L_0293:;
// 3561 l = l//r; -> EXIT
L = ((long)L / (long)R);
goto U_100B;
// 3562 s(REM): warn(1) %and r = 1 %if r = 0
case_S_14:;
if (R != 0) goto L_0294;
WARN(1);
R = 1;
L_0294:;
// 3563 l = l-l//r*r; -> EXIT
L = L - ((long)L / (long)R) * R;
goto U_100B;
// 3564 s(REXP):
case_S_16:;
// 3565 warn(7) %and r = 0 %if p10(|l|) * r > fp tens
if (P10(_imp_IMOD(L)) * R <= 70) goto L_0295;
WARN(7);
R = 0;
L_0295:;
// 3566 rvalue = l^r; ! **** implicit floating ****
RVALUE = _imp_REXP(L, R);
// 3567 -> REAL
goto U_1011;
// 3568 s(RDIV):
case_S_17:;
// 3569 warn(1) %and r = 1 %if r = 0
if (R != 0) goto L_0296;
WARN(1);
R = 1;
L_0296:;
// 3570 rvalue = l/r; ! **** implicit floating ****
RVALUE = (double)(L / R);
// 3571 REAL:
U_1011:;
// 3572 otype = con; l = real constant(0)
OTYPE = 2;
L = REALCONSTANT(0);
// 3573 lh_base = code
LH->BASE = 15;
// 3574 lh_type = reall; lh_form = V in S
LH->TYPE = 7;
LH->FORM = 4;
// 3575 EXIT:
U_100B:;
// 3576 lh_disp = l
LH->DISP = L;
// 3577 %end
return;
case_S_dispatch:
if (S_index < 1 || S_index > 17)
_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 - 1];
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 COP */
// 3578 ! >> OPERATE <<
// 3579 %routine operate(%integer oper)
void OPERATE(int OPER) {
// 3580 ! perform the operation OPER on the top two elements of the stack.
// 3581 ! (single element for unary operators)
// 3582 %record(stackfm)%name lh,rh,with
struct STACKFM *LH;
struct STACKFM *RH;
struct STACKFM *WITH;
// 3583 %integer key,lcon,rcon,wcon,lop
int KEY;
int LCON;
int RCON;
int WCON;
int LOP;
// 3584 %constbyteintegerarray transitive(add:rdiv) =
const unsigned char TRANSITIVE[15] = {
0, 0, 1, [3 ... 4] = 15, [5 ... 7] = 1, [8 ... 9] = 15, 1, [11 ... 14] = 15};
// 3585+ 0,0,1,15(2),1(3),15(2),1,15(4)
// 3586 %constbyteintegerarray commutative(add:rdiv) =
const unsigned char COMMUTATIVE[15] = {1, 0, 1, 0, 0, [5 ... 7] = 1, [8 ... 9] = 0, 1, [11 ... 14] = 0};
// 3587+ 1,0,1,0,0,1(3),0(2),1,0(4)
// 3588 %constshortintegerarray nop value(add:rdiv) =
const short int NOPVALUE[15] = {0, 0, [2 ... 3] = 1, 0, -1, [6 ... 9] = 0, 1, [11 ... 14] = 1};
// 3589+ 0,0,1(2),0,-1,0(4),1,1(4)
// 3590 %routine pickup(%record(stackfm)%name v)
void PICKUP(struct STACKFM * V) {
// 3591 %if floating(v) %then load(v,anyf) %else load(v,any)
if (!(FLOATING(V))) goto L_0297;
LOAD(V, 26);
goto L_0298;
L_0297:;
LOAD(V, 25);
L_0298:;
// 3592 %end
return;
} /* end of PICKUP */
// 3593
// 3594 stp = stp-1
STP = STP - 1;
// 3595 lcon = 0; rcon = 0; wcon = 0
LCON = 0;
RCON = 0;
WCON = 0;
// 3596 lh == stacked(stp)_v
LH = (struct STACKFM *)STACKED[STP - 1].V;
// 3597 %if const(lh) %start
if (!(CONST(LH))) goto L_0299;
// 3598 lcon = 1
LCON = 1;
// 3599 %else %if lh_type # strings %and lh_type # 0
goto L_029A;
L_0299:;
if (LH->TYPE == 5) goto L_029B;
if (LH->TYPE == 0) goto L_029B;
// 3600 address(lh, 0) %if lh_oper = 0
if (LH->OPER != 0) goto L_029C;
ADDRESS(LH, 0);
L_029C:;
// 3601 %finish
L_029B:;
L_029A:;
// 3602 rh == stacked(stp+1)_v
RH = (struct STACKFM *)STACKED[STP + 1 - 1].V;
// 3603 %if const(rh) %start
if (!(CONST(RH))) goto L_029D;
// 3604 rcon = 1
RCON = 1;
// 3605 %if oper = sub %start
if (OPER != 4) goto L_029E;
// 3606 oper = add; rh_disp = -rh_disp
OPER = 3;
RH->DISP = -RH->DISP;
// 3607 %finish
L_029E:;
// 3608 %finish
L_029D:;
// 3609 %if lh_oper # 0 %start
if (LH->OPER == 0) goto L_029F;
// 3610 lop = lh_oper
LOP = LH->OPER;
// 3611 with == lh_link
WITH = (struct STACKFM *)LH->LINK;
// 3612 wcon = 1 %if const(with)
if (!(CONST(WITH))) goto L_02A0;
WCON = 1;
L_02A0:;
// 3613 %if wcon&rcon # 0 %start; !! fold
if (WCON & RCON == 0) goto L_02A1;
// 3614 key = transitive(oper)!transitive(lop)
KEY = TRANSITIVE[OPER - 3] | TRANSITIVE[LOP - 3];
// 3615 %if key = 0 %or (key = 1 %and oper = lop) %start
if (KEY == 0) goto L_02A2;
if (KEY != 1) goto L_02A3;
if (OPER != LOP) goto L_02A3;
L_02A2:;
// 3616 with_disp = -with_disp %and lop = add %if lop = sub
if (LOP != 4) goto L_02A4;
WITH->DISP = -WITH->DISP;
LOP = 3;
L_02A4:;
// 3617 cop(oper,rh,with); drop(with)
COP(OPER, RH, WITH);
DROP(WITH);
// 3618 lh_link == rh
LH->LINK = (struct STACKFM *)RH;
// 3619 lh_oper = lop
LH->OPER = LOP;
// 3620 -> STRIP NOP
goto U_1012;
// 3621 %finish
L_02A3:;
// 3622 %finish
L_02A1:;
// 3623 pickup(lh)
PICKUP(LH);
// 3624 %finish
L_029F:;
// 3625 %if rcon # 0 %start
if (RCON == 0) goto L_02A5;
// 3626 %if lcon#0 %or (oper=ADD %and lh_type=INTEGERS %and
if (LCON != 0) goto L_02A6;
if (OPER != 3) goto L_02A7;
if (LH->TYPE != 1) goto L_02A7;
if (LH->FORM == 1) goto L_02A6;
if (LH->FORM != 5) goto L_02A7;
L_02A6:;
// 3627+ (lh_form=VinR %or lh_form=AVinS)) %start
// 3628 lh_form = AV in S %if lh_form = VinR
if (LH->FORM != 1) goto L_02A8;
LH->FORM = 5;
L_02A8:;
// 3629 cop(oper,lh,rh); drop(rh)
COP(OPER, LH, RH);
DROP(RH);
// 3630 %return
return;
// 3631 %finish
L_02A7:;
// 3632 %finish
L_02A5:;
// 3633 %if rh_oper # 0 %start
if (RH->OPER == 0) goto L_02A9;
// 3634 pickup(rh)
PICKUP(RH);
// 3635 %else %if rcon # 0 %and rh_disp = 2
goto L_02AA;
L_02A9:;
if (RCON == 0) goto L_02AB;
if (RH->DISP != 2) goto L_02AB;
// 3636 ! treat *2 (real & integer) and ^2, ^^2 specially
// 3637 %if oper = mul %or oper = exp %or oper = rexp %start
if (OPER == 5) goto L_02AC;
if (OPER == 15) goto L_02AC;
if (OPER != 16) goto L_02AD;
L_02AC:;
// 3638 %if oper = mul %then oper = add %else oper = mul
if (OPER != 5) goto L_02AE;
OPER = 3;
goto L_02AF;
L_02AE:;
OPER = 5;
L_02AF:;
// 3639 rh = lh; rcon = 0; claim(rh_base)
*RH = *LH;
RCON = 0;
CLAIM(RH->BASE);
// 3640 %finish
L_02AD:;
// 3641 %finish
L_02AB:;
L_02AA:;
// 3642 %if commutative(oper) # 0 %and ( lcon # 0 %c
if (COMMUTATIVE[OPER - 3] == 0) goto L_02B0;
if (LCON != 0) goto L_02B1;
if (LH->FORM == 1) goto L_02B0;
if (RH->FORM != 1) goto L_02B0;
if (ACTIVITY[RH->BASE] < 0) goto L_02B0;
L_02B1:;
// 3643+ %or ( lh_form # VinR %and rh_form = VinR %and
// 3644+ activity(rh_base) >= 0 ) ) %start
// 3645 rh_link == lh
RH->LINK = (struct STACKFM *)LH;
// 3646 stacked(stp)_v == rh
STACKED[STP - 1].V = (struct SPTFM *)RH;
// 3647 rh_oper = oper
RH->OPER = OPER;
// 3648 ! keep various items valid for use at STRIP NOP:
// 3649 with == rh; rh == lh; lh == with
WITH = (struct STACKFM *)RH;
RH = (struct STACKFM *)LH;
LH = (struct STACKFM *)WITH;
// 3650 rcon = lcon
RCON = LCON;
// 3651 %else
goto L_02B2;
L_02B0:;
// 3652 lh_oper = oper; lh_link == rh
LH->OPER = OPER;
LH->LINK = (struct STACKFM *)RH;
// 3653 %finish
L_02B2:;
// 3654 STRIP NOP:
U_1012:;
// 3655 %if rcon # 0 %start
if (RCON == 0) goto L_02B3;
// 3656 %if rh_disp = nop value(oper) %start
if (RH->DISP != NOPVALUE[OPER - 3]) goto L_02B4;
// 3657 lh_oper = 0; drop(rh)
LH->OPER = 0;
DROP(RH);
// 3658 %else %if oper = MUL %and control&check capacity = 0
goto L_02B5;
L_02B4:;
if (OPER != 5) goto L_02B6;
if (CONTROL & 1 != 0) goto L_02B6;
// 3659 key = power(rh_disp)
KEY = POWER(RH->DISP);
// 3660 %if key > 0 %start
if (KEY <= 0) goto L_02B7;
// 3661 lh_oper = lsh; rh_disp = key
LH->OPER = 11;
RH->DISP = KEY;
// 3662 %finish
L_02B7:;
// 3663 %finish
L_02B6:;
L_02B5:;
// 3664 %finish
L_02B3:;
// 3665 %end; ! operate
return;
} /* end of OPERATE */
// 3666
// 3667 ! >> ASSIGN <<
// 3668 %routine assign(%integer assop)
void ASSIGN(int ASSOP) {
// 3669 ! ASSOP = -1: parameter assignment
// 3670 ! 0: == assignment
// 3671 ! 1: = assignment
// 3672 ! 2: <- assignment
// 3673 ! 3: Unchecked string move - either for speed or P in R
// 3674 %constbyteintegerarray string move(-1:3) = SMOVE, 0, SMOVE, SJAM, SMOVOPT
const unsigned char STRINGMOVE[5] = {4, 0, 4, 5, 30};
// 3675 %record(stackfm)%name lh,rh,x
struct STACKFM *LH;
struct STACKFM *RH;
struct STACKFM *X;
// 3676 %record(stackfm) temp
struct STACKFM TEMP;
// 3677 %integer n,p,t,op,insert,form,lhdisp
int N;
int P;
int T;
int OP;
int INSERT;
int FORM;
int LHDISP;
// 3678 insert = 0
INSERT = 0;
// 3679 abort(m'ASS1') %if stp < 2
if (STP >= 2) goto L_02B8;
ABORT(1095979825);
L_02B8:;
// 3680 rh == stacked(stp)_v
RH = (struct STACKFM *)STACKED[STP - 1].V;
// 3681 lh == stacked(stp-1)_v
LH = (struct STACKFM *)STACKED[STP - 1 - 1].V;
// 3682 form = lh_form; ! to avoid the ravages of amap, load etc
FORM = LH->FORM;
// 3683 %if diagnose&4 # 0 %start
if (DIAGNOSE & 4 == 0) goto L_02B9;
// 3684 monitor(lh, "ASS LH")
MONITOR(LH, _imp_str_literal_size(15, "ASS LH"));
// 3685 monitor(rh, "ASS RH")
MONITOR(RH, _imp_str_literal_size(15, "ASS RH"));
// 3686 %finish
L_02B9:;
// 3687
// 3688 %if assop < 0 %start; ! Parameter
if (ASSOP >= 0) goto L_02BA;
// 3689 %if lh_flag & prim bit # 0 %start; ! Special - prim routine
if (LH->FLAG & 4 == 0) goto L_02BB;
// 3690 temp = lh; lh = rh; rh = temp
TEMP = *LH;
*LH = *RH;
*RH = TEMP;
// 3691 p disp = 0
PDISP = 0;
// 3692 %return
return;
// 3693 %finish
L_02BB:;
// 3694 lh_extra = lh_extra - 1
LH->EXTRA = LH->EXTRA - 1;
// 3695 vstack(lh_extra); lh == stacked(stp)_v
VSTACK(LH->EXTRA);
LH = (struct STACKFM *)STACKED[STP - 1].V;
// 3696 form = lh_form; lh disp = lh_disp; ! preserve original values
FORM = LH->FORM;
LHDISP = LH->DISP;
// 3697 assop = 0 %if lh_form # v in s
if (LH->FORM == 4) goto L_02BC;
ASSOP = 0;
L_02BC:;
// 3698 %if lh_flag & p in r = 0 %start; ! not an in-register parameter
if (LH->FLAG & 2 != 0) goto L_02BD;
// 3699 p disp = lh_disp + lh_length
PDISP = LH->DISP + LH->LENGTH;
// 3700 p disp = p disp+1 %if lh_type = strings %and Form = VinS
if (LH->TYPE != 5) goto L_02BE;
if (FORM != 4) goto L_02BE;
PDISP = PDISP + 1;
L_02BE:;
// 3701 lh_disp = lh_disp + wdisp; ! adjust for nested calls
LH->DISP = LH->DISP + WDISP;
// 3702 %finish
L_02BD:;
// 3703 %if lh_flag & proc bit # 0 %start; ! Procedure parameter
if (LH->FLAG & 16 == 0) goto L_02BF;
// 3704 assop = 1
ASSOP = 1;
// 3705 lh_type = integers; lh_form = v in s
LH->TYPE = 1;
LH->FORM = 4;
// 3706 rh_type = integers; rh_form = av in s
RH->TYPE = 1;
RH->FORM = 5;
// 3707 %if rh_base # 0 %and rh_base # gla %start; ! param already
if (RH->BASE == 0) goto L_02C0;
if (RH->BASE == 14) goto L_02C0;
// 3708 rh_form = v in s
RH->FORM = 4;
// 3709 %else %if rh_base = gla; ! non-local external
goto L_02C1;
L_02C0:;
if (RH->BASE != 14) goto L_02C2;
// 3710 rh_disp = rh_disp-5*reglen; !dummy environment
RH->DISP = RH->DISP - 5 * 4;
// 3711 %else; ! local routine
goto L_02C1;
L_02C2:;
// 3712 p = (frame+3)&(\3)
P = FRAME + 3 & (~3);
// 3713 frame = p+8*reglen
FRAME = P + 8 * 4;
// 3714 t = rh_disp; !proc tag
T = RH->DISP;
// 3715 rh_disp = p; rh_base = local
RH->DISP = P;
RH->BASE = LOCAL;
// 3716 define reference(t, r ref)
DEFINEREFERENCE(T, 2);
// 3717 rx(la, link, code, 0)
RX(23, 16, 15, 0);
// 3718 rx(stm, r8, local, p)
RX(25, 9, LOCAL, P);
// 3719 %finish
L_02C1:;
// 3720 %finish
L_02BF:;
// 3721 %finish
L_02BA:;
// 3722 stp = stp-2
STP = STP - 2;
// 3723
// 3724 %if rh_flag & array bits # 0 %start; ! Arrayname
if (RH->FLAG & 96 == 0) goto L_02C3;
// 3725 p disp = lh_disp + 2*reglen
PDISP = LH->DISP + 2 * 4;
// 3726 hazard(r0)
HAZARD(1);
// 3727 address(lh,-1); address(rh,-1)
ADDRESS(LH, -1);
ADDRESS(RH, -1);
// 3728 %if rh_header = -1 %start; ! Simple case
if (RH->HEADER != -1) goto L_02C4;
// 3729 rx(lw,r0,rh_base,rh_disp); ! @A(0)
RX(1, 1, RH->BASE, RH->DISP);
// 3730 %else; ! Array-in-record
goto L_02C5;
L_02C4:;
// 3731 rxi(lw,r0,rh_base,rh_disp)
RXI(1, 1, RH->BASE, RH->DISP);
// 3732 rx(add,r0,gla,rh_header)
RX(3, 1, 14, RH->HEADER);
// 3733 rh_disp = rh_header; rh_base = GLA
RH->DISP = RH->HEADER;
RH->BASE = 14;
// 3734 %finish
L_02C5:;
// 3735 %if lh_type = strings %and lh_length = 0 %start; ! %string(*)%arrayname
if (LH->TYPE != 5) goto L_02C6;
if (LH->LENGTH != 0) goto L_02C6;
// 3736 RXI(ADD,r0,0,rh_length<<24); ! length in top byte
RXI(3, 1, 0, RH->LENGTH << 24);
// 3737 %finish
L_02C6:;
// 3738 forget reg(1<<r0)
FORGETREG(1 << 1);
// 3739 rx(st,r0,lh_base,lh_disp)
RX(2, 1, LH->BASE, LH->DISP);
// 3740 claim(rh_base); rx(lw,r0,rh_base,rh_disp+reglen)
CLAIM(RH->BASE);
RX(1, 1, RH->BASE, RH->DISP + 4);
// 3741 claim(lh_base); rx(st,r0,lh_base,lh_disp+reglen)
CLAIM(LH->BASE);
RX(2, 1, LH->BASE, LH->DISP + 4);
// 3742 drop(lh); drop(rh)
DROP(LH);
DROP(RH);
// 3743 %return
return;
// 3744 %finish
L_02C3:;
// 3745
// 3746 %if lh_type = general %start; ! general %name parameter
if (LH->TYPE != 4) goto L_02C7;
// 3747 abort(m'ASS2') %unless assop = 0
if (ASSOP == 0) goto L_02C8;
ABORT(1095979826);
L_02C8:;
// 3748 %if rh_type = general %start
if (RH->TYPE != 4) goto L_02C9;
// 3749 amap(lh); address(lh,-1)
AMAP(LH);
ADDRESS(LH, -1);
// 3750 amap(rh); address(rh,-1)
AMAP(RH);
ADDRESS(RH, -1);
// 3751 hazard(r0)
HAZARD(1);
// 3752 rx(lw,r0,rh_base,rh_disp)
RX(1, 1, RH->BASE, RH->DISP);
// 3753 rx(st,r0,lh_base,lh_disp)
RX(2, 1, LH->BASE, LH->DISP);
// 3754 claim(lh_base); claim(rh_base)
CLAIM(LH->BASE);
CLAIM(RH->BASE);
// 3755 rx(lw,r0,rh_base,rh_disp+reglen)
RX(1, 1, RH->BASE, RH->DISP + 4);
// 3756 rx(st,r0,lh_base,lh_disp+reglen)
RX(2, 1, LH->BASE, LH->DISP + 4);
// 3757 drop(lh); drop(rh)
DROP(LH);
DROP(RH);
// 3758 %return
return;
// 3759 %finish
L_02C9:;
// 3760 t = rh_type
T = RH->TYPE;
// 3761 rh_flag = rh_flag ! assigned; ! pointer proper may never be used !!!!!
RH->FLAG = RH->FLAG | 8;
// 3762 n = rh_length; n = n+1 %if t = strings; ! logical => physical length
N = RH->LENGTH;
if (T != 5) goto L_02CA;
N = N + 1;
L_02CA:;
// 3763 amaps(rh); lrd(rh,any); p = rh_base
AMAPS(RH);
LRD(RH, 25);
P = RH->BASE;
// 3764 rx(st,p,lh_base,lh_disp)
RX(2, P, LH->BASE, LH->DISP);
// 3765 claim(lh_base)
CLAIM(LH->BASE);
// 3766 cload((n<<4) + genmap(t),p)
CLOAD((N << 4) + GENMAP[T - 1], P);
// 3767 rx(st,p,lh_base,lh_disp+reglen)
RX(2, P, LH->BASE, LH->DISP + 4);
// 3768 drop(lh)
DROP(LH);
// 3769 %return
return;
// 3770 %finish
L_02C7:;
// 3771
// 3772 %if assop = 0 %start; ! ==
if (ASSOP != 0) goto L_02CB;
// 3773 amap(lh); ! destination
AMAP(LH);
// 3774 %if lh_length = 0 %then amaps(rh) %else amap(rh); ! %string(*)%name ?
if (LH->LENGTH != 0) goto L_02CC;
AMAPS(RH);
goto L_02CD;
L_02CC:;
AMAP(RH);
L_02CD:;
// 3775 %finish
L_02CB:;
// 3776
// 3777 %if Lh_Type = Records %start
if (LH->TYPE != 6) goto L_02CE;
// 3778 n = Min Record Size(Lh, Rh)
N = MINRECORDSIZE(LH, RH);
// 3779 %if rh_Form # Constant %start
if (RH->FORM == 0) goto L_02CF;
// 3780 lrd(rh,r1); ! source area
LRD(RH, 2);
// 3781 op = rcopy; ! copy record
OP = 27;
// 3782 %else
goto L_02D0;
L_02CF:;
// 3783 drop(rh)
DROP(RH);
// 3784 op = rzero; ! clear record
OP = 28;
// 3785 %finish
L_02D0:;
// 3786 lrd(lh,r2); ! destination area
LRD(LH, 3);
// 3787 cload(n>>2,R3); ! R3 = no. of WORDS to copy/zero
CLOAD((unsigned int)N >> 2, 4);
// 3788 perm(op)
PERM(OP);
// 3789 %return
return;
// 3790 %finish
L_02CE:;
// 3791
// 3792 %if lh_type = strings %and lh_flag & p in r = 0 %start
if (LH->TYPE != 5) goto L_02D1;
if (LH->FLAG & 2 != 0) goto L_02D1;
// 3793 %if assop > 0 %and rh_format = 1 %start; ! null string as zero byte ?
if (ASSOP <= 0) goto L_02D2;
if (RH->FORMAT != 1) goto L_02D2;
// 3794 drop(rh)
DROP(RH);
// 3795 lh_type = byte; sstack(lh); drop(lh)
LH->TYPE = 3;
SSTACK(LH);
DROP(LH);
// 3796 cstack(0); assign(assop)
CSTACK(0);
ASSIGN(ASSOP);
// 3797 %return
return;
// 3798 %finish
L_02D2:;
// 3799 p = lh_length
P = LH->LENGTH;
// 3800 %if assop # 2 %and same(lh,rh) %start; ! S = S or S = S.T
if (ASSOP == 2) goto L_02D3;
if (!(SAME(LH, RH))) goto L_02D3;
// 3801 %if rh_oper = 0 %start
if (RH->OPER != 0) goto L_02D4;
// 3802 drop(lh); drop(rh); ! S = S
DROP(LH);
DROP(RH);
// 3803 %else
goto L_02D5;
L_02D4:;
// 3804 rh_length = p
RH->LENGTH = P;
// 3805 release(lh_base); drop(lh)
RELEASE(LH->BASE);
DROP(LH);
// 3806 rh_type = 0{; address(rh,-1)}; lrd(rh,0) {0 = special for CONC}
RH->TYPE = 0;
LRD(RH, 0);
// 3807 %finish
L_02D5:;
// 3808 %else %if Control&Trusted # 0 %and
goto L_02D6;
L_02D3:;
if (CONTROL & 32 == 0) goto L_02D7;
if (ASSOP == 2) goto L_02D7;
if (RH->OPER == 0) goto L_02D7;
if (SAME(LH, RH)) goto L_02D7;
if (SAME(LH, RH->LINK)) goto L_02D7;
// 3809+ assop # 2 %and
// 3810+ Rh_Oper # 0 %and
// 3811+ %not Same(Lh, Rh) %and
// 3812+ %not Same(Lh, Rh_Link)
// 3813 x == Rh_Link; Rh_Oper = 0
X = (struct STACKFM *)RH->LINK;
RH->OPER = 0;
// 3814 Load(Lh, R2); Lrd(Rh, R1)
LOAD(LH, 3);
LRD(RH, 2);
// 3815 Perm(String Move(3))
PERM(STRINGMOVE[4]);
// 3816 Lh_Form = VinS; Lh_Type = 0
LH->FORM = 4;
LH->TYPE = 0;
// 3817 Lh_Oper = Conc; Lh_Link == X
LH->OPER = 7;
LH->LINK = (struct STACKFM *)X;
// 3818 Lrd(Lh, 0)
LRD(LH, 0);
// 3819 %else; ! general case
goto L_02D6;
L_02D7:;
// 3820
// 3821 rh_flag = rh_flag&(\quick conc); ! quicky not possible after all.
RH->FLAG = RH->FLAG & (~1);
// 3822
// 3823 ! use fast string move if 'trusted' or capacity exceeded is impossible
// 3824 ! and unassigned is not requested or impossible.
// 3825 %if assop # 2 %start; ! not jam transfer
if (ASSOP == 2) goto L_02D8;
// 3826 assop = 3 %if control & trusted # 0 %c
if (CONTROL & 32 != 0) goto L_02D9;
if (P < RH->LENGTH) goto L_02DA;
if (CONTROL & 2 == 0) goto L_02D9;
if (CHECKABLE(RH)) goto L_02DA;
L_02D9:;
ASSOP = 3;
L_02DA:;
// 3827+ %or ( p >= rh_length %c
// 3828+ %and (control&check unass = 0 %or %not checkable(rh)) )
// 3829 %finish
L_02D8:;
// 3830 %if rh_oper = 0 %start; !simple, so protect lhs first: s(j)=t
if (RH->OPER != 0) goto L_02DB;
// 3831 lrd(lh, r2); lrd(rh, r1)
LRD(LH, 3);
LRD(RH, 2);
// 3832 %else; !simplify rh first: s = t.u
goto L_02DC;
L_02DB:;
// 3833 lrd(rh, r1); lrd(lh, r2)
LRD(RH, 2);
LRD(LH, 3);
// 3834 %finish
L_02DC:;
// 3835 perm( string move(assop) )
PERM(STRINGMOVE[ASSOP + 1]);
// 3836 cput(p) %if assop # 3; ! max. length of destination for check ?
if (ASSOP == 3) goto L_02DD;
CPUT(P);
L_02DD:;
// 3837 %finish
L_02D6:;
// 3838 %return
return;
// 3839 %finish
L_02D1:;
// 3840
// 3841 %if lh_flag & p in r # 0 %start
if (LH->FLAG & 2 == 0) goto L_02DE;
// 3842 p = p1; p = p2 %if lh disp < reglen; p = p3 %if lh_type = strings
P = 7;
if (LHDISP >= 4) goto L_02DF;
P = 6;
L_02DF:;
if (LH->TYPE != 5) goto L_02E0;
P = 2;
L_02E0:;
// 3843 load(rh,p) %if rh_oper # 0
if (RH->OPER == 0) goto L_02E1;
LOAD(RH, P);
L_02E1:;
// 3844 drop(lh)
DROP(LH);
// 3845 lh == stacked(stp)_v
LH = (struct STACKFM *)STACKED[STP - 1].V;
// 3846 rh_oper = p; ! target register
RH->OPER = P;
// 3847 rh_link == lh_link; lh_link == rh
RH->LINK = (struct STACKFM *)LH->LINK;
LH->LINK = (struct STACKFM *)RH;
// 3848 address(lh, -1)
ADDRESS(LH, -1);
// 3849 %else
goto L_02E2;
L_02DE:;
// 3850 ! Test for case where add-to-memory can profitably be used.
// 3851 ! Note that the effective no-op of self-assignment can be detected easily
// 3852 address(lh, -1)
ADDRESS(LH, -1);
// 3853 %if control & check bits = 0 %and rh_type <= short %C
if (CONTROL & 23 != 0) goto L_02E3;
if (RH->TYPE > 2) goto L_02E3;
if (RH->OPER == 0) goto L_02E4;
if (RH->OPER != 3) goto L_02E3;
L_02E4:;
if (!(SAME(LH, RH))) goto L_02E3;
// 3854+ %and (rh_oper = 0 %or rh_oper = ADD) %and same(lh,rh) %start
// 3855 %if rh_oper = 0 %start; ! assignment-to-self
if (RH->OPER != 0) goto L_02E5;
// 3856 release(rh_base); drop(rh)
RELEASE(RH->BASE);
DROP(RH);
// 3857 release(lh_base); drop(lh)
RELEASE(LH->BASE);
DROP(LH);
// 3858 %return
return;
// 3859 %finish
L_02E5:;
// 3860 ! General case: add-to-memory
// 3861 x == rh; rh == rh_link
X = (struct STACKFM *)RH;
RH = (struct STACKFM *)RH->LINK;
// 3862 release(x_base); drop(x)
RELEASE(X->BASE);
DROP(X);
// 3863 load(rh,any)
LOAD(RH, 25);
// 3864 address(lh,-1); rxd(AM,rh_base,lh)
ADDRESS(LH, -1);
RXD(38, RH->BASE, LH);
// 3865 forget var(lh)
FORGETVAR(LH);
// 3866 release(rh_base); drop(rh); drop(lh)
RELEASE(RH->BASE);
DROP(RH);
DROP(LH);
// 3867 %return
return;
// 3868 %finish
L_02E3:;
// 3869 ! test for assignment of small constants to %short and %byte
// 3870 t = rh_type
T = RH->TYPE;
// 3871 %if rh_base = 0 %and rh_form = constant %and rh_Oper = 0 %start
if (RH->BASE != 0) goto L_02E6;
if (RH->FORM != 0) goto L_02E6;
if (RH->OPER != 0) goto L_02E6;
// 3872 %if -32768 <= rh_disp <= 32767 %start
{
// Double-sided test on RH->DISP (Part I)
int tmp;
if (-32768 > (tmp = RH->DISP)) goto L_02E7;
// Double-sided test on RH->DISP (Part II)
if (tmp > 32767) goto L_02E7;
}
// 3873 %if rh_disp&(\255) = 0 %start
if (RH->DISP & (~255) != 0) goto L_02E8;
// 3874 t = byte
T = 3;
// 3875 %else
goto L_02E9;
L_02E8:;
// 3876 t = short
T = 2;
// 3877 %finish
L_02E9:;
// 3878 %finish
L_02E7:;
// 3879 %finish
L_02E6:;
// 3880 ! . . . then suppress capacity check if LH is real or length RH is
// 3881 ! not greater than length LH.
// 3882 n = assop
N = ASSOP;
// 3883 assop = 2 %if lh_type > byte %or lh_type <= t
if (LH->TYPE > 3) goto L_02EA;
if (LH->TYPE > T) goto L_02EB;
L_02EA:;
ASSOP = 2;
L_02EB:;
// 3884
// 3885 %if Lh_Form = VinR %start {special by PSR - is it safe????}
if (LH->FORM != 1) goto L_02EC;
// 3886 Load(Rh, Lh_Base)
LOAD(RH, LH->BASE);
// 3887 Assop = 2
ASSOP = 2;
// 3888 %else
goto L_02ED;
L_02EC:;
// 3889 p = cheap reg {preferred register}
P = CHEAPREG;
// 3890 float(rh, p) %if lh_type >= reals %and %not floating(rh)
if (LH->TYPE < 7) goto L_02EE;
if (FLOATING(RH)) goto L_02EE;
FLOAT(RH, P);
L_02EE:;
// 3891 {Float here to prevent optimising the integer value}
// 3892 address(rh, p) {see where it is}
ADDRESS(RH, P);
// 3893 load(rh, p) %unless rh_form = VinR
if (RH->FORM == 1) goto L_02EF;
LOAD(RH, P);
L_02EF:;
// 3894 p = rh_base
P = RH->BASE;
// 3895 address(lh, -1) %unless lh_form = VinS
if (LH->FORM == 4) goto L_02F0;
ADDRESS(LH, -1);
L_02F0:;
// 3896 rxd(ST, p, lh)
RXD(2, P, LH);
// 3897
// 3898 %if control & suppress = 0 %start
if (CONTROL & 128 != 0) goto L_02F1;
// 3899 t = activity(lh_base)
T = ACTIVITY[LH->BASE];
// 3900 %if t < 0 %or control&trusted # 0 %start
if (T < 0) goto L_02F2;
if (CONTROL & 32 == 0) goto L_02F3;
L_02F2:;
// 3901 forget var(lh)
FORGETVAR(LH);
// 3902 %if mark assigned # 0 %and lh_base = local %start; ! set 'assigned' ?
if (MARKASSIGNED == 0) goto L_02F4;
if (LH->BASE != LOCAL) goto L_02F4;
// 3903 var(lh_varno)_flag = var(lh_varno)_flag ! assigned
VAR[LH->VARNO].FLAG = VAR[LH->VARNO].FLAG | 8;
// 3904 %finish
L_02F4:;
// 3905 %else
goto L_02F5;
L_02F3:;
// 3906 forget all
FORGETALL();
// 3907 %finish
L_02F5:;
// 3908 lh_flag = lh_flag ! (rh_flag & assigned)
LH->FLAG = LH->FLAG | RH->FLAG & 8;
// 3909 associate(lh,p) %if n # 2; ! not jam transfer
if (N == 2) goto L_02F6;
ASSOCIATE(LH, P);
L_02F6:;
// 3910 %finish
L_02F1:;
// 3911 release(p)
RELEASE(P);
// 3912 %finish
L_02ED:;
// 3913 drop(lh); drop(rh)
DROP(LH);
DROP(RH);
// 3914 %finish
L_02E2:;
// 3915 %if assop = 1 %and control&check capacity # 0 %start
if (ASSOP != 1) goto L_02F7;
if (CONTROL & 1 == 0) goto L_02F7;
// 3916 %if lh_type = short %start
if (LH->TYPE != 2) goto L_02F8;
// 3917 claim(p); rr(chvr,p,p)
CLAIM(P);
RR(30, P, P);
// 3918 perm(cap16); ! Test for 16-bit overflow
PERM(22);
// 3919 %else
goto L_02F9;
L_02F8:;
// 3920 rxi(TEST,p,0,\255); ! should give zero result
RXI(36, P, 0, (~255));
// 3921 perm(cap8); ! Test for 8-bit overflow
PERM(23);
// 3922 %finish
L_02F9:;
// 3923 %finish
L_02F7:;
// 3924 %end; ! assign
return;
} /* end of ASSIGN */
// 3925
// 3926 ! >> LOAD PARAMS <<
// 3927 %routine load params(%record(stackfm)%name v)
void LOADPARAMS(struct STACKFM * V) {
// 3928 ! called at c('E') to load in-register parameters set by ASSIGN above
// 3929 %integer reg
int REG;
// 3930 %record(stackfm)%name next
struct STACKFM *NEXT;
// 3931 %return %if v == null
if (_imp_ADDR((void *)(V)) != _imp_ADDR((void *)(NULL))) goto L_02FA;
return;
L_02FA:;
// 3932 reg = v_oper
REG = V->OPER;
// 3933 v_oper = 0
V->OPER = 0;
// 3934 next == v_link
NEXT = (struct STACKFM *)V->LINK;
// 3935 load(v,reg)
LOAD(V, REG);
// 3936 load params(next)
LOADPARAMS(NEXT);
// 3937 release(reg)
RELEASE(REG);
// 3938 drop(v)
DROP(V);
// 3939 %end; ! load params
return;
} /* end of LOADPARAMS */
// 3940
// 3941 ! >> ARRAY REF <<
// 3942 %routine array ref(%integer mode)
void ARRAYREF(int MODE) {
// 3943 ! Array references are by perm call except in the case of unchecked 1-D arrays
// 3944 ! which either:
// 3945 ! (i) have a data size which is an integral power of 2, not greater than 16384.
// 3946 ! or:
// 3947 ! (ii) have data size <= 32768 and constant bounds -32768 <= x <= 32767.
// 3948 %integer flags, p, type, base, assbit
int FLAGS;
int P;
int TYPE;
int BASE;
int ASSBIT;
// 3949 %integer mult, shift; ! ** PRESUMED SET BY 'UNCHECKED REF'
int MULT;
int SHIFT;
// 3950 %record(stackfm)%name temp
struct STACKFM *TEMP;
// 3951
// 3952 %predicate special case
int SPECIALCASE(void) {
// 3953 shift = power(mult)
SHIFT = POWER(MULT);
// 3954 %true %if shift >= 0 %or flags & cheap array bit # 0 %or Base = 0
if (SHIFT >= 0) goto L_02FB;
if (FLAGS & 32 != 0) goto L_02FB;
if (BASE != 0) goto L_02FC;
L_02FB:;
return 1 /*TRUE*/;
L_02FC:;
// 3955 %false
return 0 /*FALSE*/;
// 3956 %end; ! special case
} /* end of SPECIALCASE */
// 3957
// 3958 %routine unchecked ref
void UNCHECKEDREF(void) {
// 3959 %integer header, length, format, extra
int HEADER;
int LENGTH;
int FORMAT;
int EXTRA;
// 3960 header = lhs_header; length = lhs_length; format = lhs_format
HEADER = LHS->HEADER;
LENGTH = LHS->LENGTH;
FORMAT = LHS->FORMAT;
// 3961 extra = 0
EXTRA = 0;
// 3962 %if rhs_oper = ADD %or (rhs_oper = 0 %and
if (RHS->OPER == 3) goto L_02FD;
if (RHS->OPER != 0) goto L_02FE;
if (RHS->FORM == 5) goto L_02FD;
if (RHS->FORM != 0) goto L_02FE;
L_02FD:;
// 3963+ (rhs_form = AV in S %or rhs_form = Constant)) %start
// 3964 %if rhs_oper = ADD %start
if (RHS->OPER != 3) goto L_02FF;
// 3965 %if rhs_link_form = constant %or rhs_link_form = AV in S %start
if (RHS->LINK->FORM == 0) goto L_0300;
if (RHS->LINK->FORM != 5) goto L_0301;
L_0300:;
// 3966 extra = rhs_link_disp
EXTRA = RHS->LINK->DISP;
// 3967 %if rhs_link_form = AV in S %start; ! => VinR + const (see below)
if (RHS->LINK->FORM != 5) goto L_0302;
// 3968 rhs_link_form = VinR
RHS->LINK->FORM = 1;
// 3969 rhs_link_disp = 0
RHS->LINK->DISP = 0;
// 3970 %else; ! simple constant
goto L_0303;
L_0302:;
// 3971 rhs_oper = 0
RHS->OPER = 0;
// 3972 drop(rhs_link)
DROP(RHS->LINK);
// 3973 %finish
L_0303:;
// 3974 %finish
L_0301:;
// 3975 %else; ! AV in S (treat as VinR + constant)
goto L_0304;
L_02FF:;
// 3976 extra = rhs_disp; rhs_disp = 0
EXTRA = RHS->DISP;
RHS->DISP = 0;
// 3977 rhs_form = VinR %if rhs_form = AVinS
if (RHS->FORM != 5) goto L_0305;
RHS->FORM = 1;
L_0305:;
// 3978 %finish
L_0304:;
// 3979 extra = extra * mult
EXTRA = EXTRA * MULT;
// 3980 %finish
L_02FE:;
// 3981 %if shift >= 0 %start
if (SHIFT < 0) goto L_0306;
// 3982 cstack(shift); operate(lsh)
CSTACK(SHIFT);
OPERATE(11);
// 3983 %else
goto L_0307;
L_0306:;
// 3984 cstack(mult); operate(mult16)
CSTACK(MULT);
OPERATE(13);
// 3985 %finish
L_0307:;
// 3986 lhs_type = integers; ! address calculation
LHS->TYPE = 1;
// 3987 %if lhs_header >= 0 %start; ! array-in-record
if (LHS->HEADER < 0) goto L_0308;
// 3988 amap(lhs); ! address of record containing array
AMAP(LHS);
// 3989 sset(gla,lhs_header,v in s,0)
SSET(14, LHS->HEADER, 4, 0);
// 3990 operate(add)
OPERATE(3);
// 3991 %finish
L_0308:;
// 3992 operate(add)
OPERATE(3);
// 3993 set lhs
SETLHS();
// 3994 ! ! ***** F R I G *****
// 3995 ! load(lhs,any) %if lhs_oper = 0; ! Force load: zero subscript folded out
// 3996 ! ! ***** F R I G *****
// 3997 ! vmap(lhs)
// 3998 ! lhs_disp = lhs_disp + extra
// 3999 ! lhs_type = type
// 4000 ! lhs_format = format; lhs_length = length
// 4001 ! lhs_xform = assbit ! V in S
// 4002 ! lhs_form = A in S %if flags & label bit # 0
// 4003
// 4004 %if Extra # 0 %start
if (EXTRA == 0) goto L_0309;
// 4005 Cstack(Extra); Operate(Add)
CSTACK(EXTRA);
OPERATE(3);
// 4006 Set Lhs
SETLHS();
// 4007 %finish
L_0309:;
// 4008 Vmap(Lhs)
VMAP(LHS);
// 4009 Vmap(Lhs) %if Flags&Label Bit # 0 {namearray}
if (FLAGS & 128 == 0) goto L_030A;
VMAP(LHS);
L_030A:;
// 4010 Lhs_Type = Type
LHS->TYPE = TYPE;
// 4011 Lhs_Format = Format
LHS->FORMAT = FORMAT;
// 4012 Lhs_Length = Length
LHS->LENGTH = LENGTH;
// 4013 Lhs_Xform = Lhs_Form!Assbit
LHS->XFORM = LHS->FORM | ASSBIT;
// 4014 %end
return;
} /* end of UNCHECKEDREF */
// 4015
// 4016 %if mode # 0 %start; ! multi-dimensional: ingest non-terminal subscripts
if (MODE == 0) goto L_030B;
// 4017 set both; stp = stp-1
SETBOTH();
STP = STP - 1;
// 4018 load(rhs,any) %if rhs_oper # 0
if (RHS->OPER == 0) goto L_030C;
LOAD(RHS, 25);
L_030C:;
// 4019 rhs_link == lhs_link
RHS->LINK = (struct STACKFM *)LHS->LINK;
// 4020 lhs_link == rhs
LHS->LINK = (struct STACKFM *)RHS;
// 4021 lhs_oper = lhs_oper+1
LHS->OPER = LHS->OPER + 1;
// 4022 %return
return;
// 4023 %finish
L_030B:;
// 4024
// 4025 set both
SETBOTH();
// 4026 abort(m'ARF1') %if lhs_oper+1 # lhs_dim; ! No. of subscripts ?
if (LHS->OPER + 1 == LHS->DIM) goto L_030D;
ABORT(1095910961);
L_030D:;
// 4027
// 4028 flags = lhs_flag; ! protect from ravages of AMAP
FLAGS = LHS->FLAG;
// 4029 lhs_flag = lhs_flag & (\(label bit + array bits))
LHS->FLAG = LHS->FLAG & ~(128 + 96);
// 4030
// 4031 base = lhs_base; type = lhs_type; assbit = lhs_xform & (assigned<<8)
BASE = LHS->BASE;
TYPE = LHS->TYPE;
ASSBIT = LHS->XFORM & 8 << 8;
// 4032
// 4033 %if (control & check array = 0 %and lhs_oper = 0) %or
if (CONTROL & 4 != 0) goto L_030E;
if (LHS->OPER == 0) goto L_030F;
L_030E:;
if (BASE != 0) goto L_0310;
L_030F:;
// 4034+ Base = 0 %start; ! unchecked 1-D
// 4035 mult = lhs_length
MULT = LHS->LENGTH;
// 4036 mult = mult+1 %if lhs_type = strings
if (LHS->TYPE != 5) goto L_0311;
MULT = MULT + 1;
L_0311:;
// 4037 mult = 4 %if Flags&Label Bit # 0; !namearray
if (FLAGS & 128 == 0) goto L_0312;
MULT = 4;
L_0312:;
// 4038 %if special case %start; ! sets 'shift' as a side-effect
if (!(SPECIALCASE())) goto L_0313;
// 4039 unchecked ref; %return
UNCHECKEDREF();
return;
// 4040 %finish
L_0313:;
// 4041 %finish
L_0310:;
// 4042
// 4043 stp = stp-1
STP = STP - 1;
// 4044 %if lhs_oper = 0 %start; ! 1-D
if (LHS->OPER != 0) goto L_0314;
// 4045 load(rhs,r1); drop(rhs)
LOAD(RHS, 2);
DROP(RHS);
// 4046 p = aref1
P = 13;
// 4047 %else %if lhs_oper = 1; ! 2-D
goto L_0315;
L_0314:;
if (LHS->OPER != 1) goto L_0316;
// 4048 load(lhs_link,r1); drop(lhs_link)
LOAD(LHS->LINK, 2);
DROP(LHS->LINK);
// 4049 load(rhs,r2); drop(rhs)
LOAD(RHS, 3);
DROP(RHS);
// 4050 p = aref2
P = 14;
// 4051 p = aref4 %if control & check array = 0
if (CONTROL & 4 != 0) goto L_0317;
P = 16;
L_0317:;
// 4052 %else; ! 3-D or more
goto L_0315;
L_0316:;
// 4053 load(rhs, any) %if rhs_oper # 0 {**psr**}
if (RHS->OPER == 0) goto L_0318;
LOAD(RHS, 25);
L_0318:;
// 4054 rhs_link == lhs_link; ! tack on last subscript
RHS->LINK = (struct STACKFM *)LHS->LINK;
// 4055 %for p = pdisp,reglen,pdisp+(lhs_oper-1)*reglen %cycle
// %for P = PDISP, 4, PDISP + (LHS->OPER - 1) * 4 %cycle
{
int _initial = PDISP, _final = PDISP + (LHS->OPER - 1) * 4;
if (invalid_for_loop(_initial, 4, _final))
_imp_signal(5, 1, 0, "Illegal cycle P = PDISP, 4, PDISP + (LHS->OPER - 1) * 4");
P = _initial - (4);
L_0319:
if (P == _final) goto L_031A;
P += 4;
// 4056 temp == rhs_link
TEMP = (struct STACKFM *)RHS->LINK;
// 4057 lrd(rhs,any) {**psr**}
LRD(RHS, 25);
// 4058 rx(ST,rhs_base,wsp,p) {**psr**}
RX(2, RHS->BASE, 8, P);
// 4059 rhs == temp
RHS = (struct STACKFM *)TEMP;
// 4060 %repeat
goto L_0319;
}
L_031A:;
// 4061 load(rhs,r1); ! r1 = first subscript
LOAD(RHS, 2);
// 4062 rhs_form = AV in S; rhs_base = wsp; rhs_disp = pdisp
RHS->FORM = 5;
RHS->BASE = 8;
RHS->DISP = PDISP;
// 4063 load(rhs,r2); ! r2 = addr(subscript list)
LOAD(RHS, 3);
// 4064 drop(rhs)
DROP(RHS);
// 4065 p = aref3
P = 15;
// 4066 %finish
L_0315:;
// 4067 lhs_oper = 0
LHS->OPER = 0;
// 4068 amap(lhs)
AMAP(LHS);
// 4069 %if lhs_header >= 0 %start; ! array-within-record
if (LHS->HEADER < 0) goto L_031C;
// 4070 sset(gla,lhs_header,av in s,0)
SSET(14, LHS->HEADER, 5, 0);
// 4071 load(rhs,r3); drop(rhs); stp = stp-1
LOAD(RHS, 4);
DROP(RHS);
STP = STP - 1;
// 4072 %else
goto L_031D;
L_031C:;
// 4073 load(lhs,r3)
LOAD(LHS, 4);
// 4074 %finish
L_031D:;
// 4075 release(r1); release(r3)
RELEASE(2);
RELEASE(4);
// 4076 release(r2) %unless p = aref1
if (P == 13) goto L_031E;
RELEASE(3);
L_031E:;
// 4077 perm(p)
PERM(P);
// 4078 claim(r1)
CLAIM(2);
// 4079 %if lhs_header >= 0 %start; ! array-in-record
if (LHS->HEADER < 0) goto L_031F;
// 4080 sset(lhs_base,lhs_disp,lhs_form,lhs_extra); ! address of record
SSET(LHS->BASE, LHS->DISP, LHS->FORM, LHS->EXTRA);
// 4081 lhs_base = r1; lhs_disp = 0; lhs_form = VinR; ! array component
LHS->BASE = 2;
LHS->DISP = 0;
LHS->FORM = 1;
// 4082 lhs_type = integers; ! an address to be amapped
LHS->TYPE = 1;
// 4083 operate(add); ! record address + array component
OPERATE(3);
// 4084 %else
goto L_0320;
L_031F:;
// 4085 lhs_base = r1; lhs_disp = 0
LHS->BASE = 2;
LHS->DISP = 0;
// 4086 %finish
L_0320:;
// 4087 vmap(lhs)
VMAP(LHS);
// 4088 lhs_type = type
LHS->TYPE = TYPE;
// 4089 lhs_xform = assbit ! V in S
LHS->XFORM = ASSBIT | 4;
// 4090 lhs_form = A in S %if flags & label bit # 0
if (FLAGS & 128 == 0) goto L_0321;
LHS->FORM = 6;
L_0321:;
// 4091 %end; ! array ref
return;
} /* end of ARRAYREF */
// 4092
// 4093 ! >> TEST ZERO <<
// 4094 %routine test zero(%record(stackfm)%name v)
void TESTZERO(struct STACKFM * V) {
// 4095 %record(stackfm)%name w
struct STACKFM *W;
// 4096 %integer cr
int CR;
// 4097 cr = any
CR = 25;
// 4098 cr = anyf %if floating(v)
if (!(FLOATING(V))) goto L_0322;
CR = 26;
L_0322:;
// 4099 %if v_oper = AND %and sym = '?' %and const(v_link) %start
if (V->OPER != 8) goto L_0323;
if (SYM != 63) goto L_0323;
if (!(CONST(V->LINK))) goto L_0323;
// 4100 ! if x & const = 0 . . . . . . .
// 4101 w == v_link; v_oper = 0
W = (struct STACKFM *)V->LINK;
V->OPER = 0;
// 4102 load(v,cr)
LOAD(V, CR);
// 4103 rxd(TEST,v_base,w)
RXD(36, V->BASE, W);
// 4104 drop(w); release(v_base)
DROP(W);
RELEASE(V->BASE);
// 4105 %else
goto L_0324;
L_0323:;
// 4106 load(v,cr)
LOAD(V, CR);
// 4107 %if ca # cc ca %or cc reg # v_base %start
if (CA != CCCA) goto L_031B;
if (CCREG == V->BASE) goto L_0325;
L_031B:;
// 4108 rr(lw,v_base,v_base)
RR(1, V->BASE, V->BASE);
// 4109 %else
goto L_0326;
L_0325:;
// 4110 release(v_base)
RELEASE(V->BASE);
// 4111 %finish
L_0326:;
// 4112 %finish
L_0324:;
// 4113 %end; ! test zero
return;
} /* end of TESTZERO */
// 4114
// 4115 %routine Compare Records(%record(stackfm)%name L, R, %integer N)
void COMPARERECORDS(struct STACKFM * L, struct STACKFM * R, int N) {
// 4116 Amap(l); Load(l, R1)
AMAP(L);
LOAD(L, 2);
// 4117 Amap(r); Load(r, R2)
AMAP(R);
LOAD(R, 3);
// 4118 Cload(n, R3); Set Both {***beware of CLOAD and Lhs}
CLOAD(N, 4);
SETBOTH();
// 4119 Release(R1); Release(R2)
RELEASE(2);
RELEASE(3);
// 4120 Perm(Rcomp)
PERM(34);
// 4121 %end
return;
} /* end of COMPARERECORDS */
// 4122
// 4123 ! >> COMPARE REALS <<
// 4124 %routine compare reals(%record(stackfm)%name l,r)
void COMPAREREALS(struct STACKFM * L, struct STACKFM * R) {
// 4125 load(l,anyf)
LOAD(L, 26);
// 4126 address(r,0)
ADDRESS(R, 0);
// 4127 float(r, anyf) %unless floating(r)
if (FLOATING(R)) goto L_0327;
FLOAT(R, 26);
L_0327:;
// 4128 rxd(cmp,l_base,r)
RXD(7, L->BASE, R);
// 4129 release(l_base)
RELEASE(L->BASE);
// 4130 %end; ! compare reals
return;
} /* end of COMPAREREALS */
// 4131
// 4132 ! >> COMPARE STRINGS <<
// 4133 %routine compare strings(%record(stackfm)%name l,r)
void COMPARESTRINGS(struct STACKFM * L, struct STACKFM * R) {
// 4134 %record(stackfm)%name temp
struct STACKFM *TEMP;
// 4135 %if l_base = code %and l_disp = null string %start
if (L->BASE != 15) goto L_0328;
if (L->DISP != NULLSTRING) goto L_0328;
// 4136 temp == r; r == l; l == temp
TEMP = (struct STACKFM *)R;
R = (struct STACKFM *)L;
L = (struct STACKFM *)TEMP;
// 4137 invert = invert !! 16
INVERT = INVERT ^ 16;
// 4138 %finish
L_0328:;
// 4139 %if r_base = code %and r_disp = null string %start
if (R->BASE != 15) goto L_0329;
if (R->DISP != NULLSTRING) goto L_0329;
// 4140 load(l,any) %if l_oper # 0
if (L->OPER == 0) goto L_032A;
LOAD(L, 25);
L_032A:;
// 4141 l_type = byte
L->TYPE = 3;
// 4142 test zero(l)
TESTZERO(L);
// 4143 %else
goto L_032B;
L_0329:;
// 4144 load(r,r2) %if r_oper # 0
if (R->OPER == 0) goto L_032C;
LOAD(R, 3);
L_032C:;
// 4145 load(l,r1); load(r,r2)
LOAD(L, 2);
LOAD(R, 3);
// 4146 release(r1); release(r2)
RELEASE(2);
RELEASE(3);
// 4147 perm(scomp)
PERM(9);
// 4148 %finish
L_032B:;
// 4149 l_type = strings; l_form = v in s
L->TYPE = 5;
L->FORM = 4;
// 4150 p disp = 0
PDISP = 0;
// 4151 %end; ! compare strings
return;
} /* end of COMPARESTRINGS */
// 4152
// 4153 ! >> COMPARE <<
// 4154 %routine compare(%record(stackfm)%name l,r, %integer next)
void COMPARE(struct STACKFM * L, struct STACKFM * R, int NEXT) {
// 4155 swopped = 0
SWOPPED = 0;
// 4156 %if l_type = 0 %or l_type = strings %start
if (L->TYPE == 0) goto L_032D;
if (L->TYPE != 5) goto L_032E;
L_032D:;
// 4157 compare strings(l,r); %return
COMPARESTRINGS(L, R);
return;
// 4158 %finish
L_032E:;
// 4159 %if zero(r) %start
if (!(ZERO(R))) goto L_032F;
// 4160 test zero(l); %return
TESTZERO(L);
return;
// 4161 %finish
L_032F:;
// 4162 %if zero(l) %start
if (!(ZERO(L))) goto L_0330;
// 4163 test zero(r); invert = invert !! 16
TESTZERO(R);
INVERT = INVERT ^ 16;
// 4164 %return
return;
// 4165 %finish
L_0330:;
// 4166 %if floating(l) %or floating(r) %start
if (FLOATING(L)) goto L_0331;
if (!(FLOATING(R))) goto L_0332;
L_0331:;
// 4167 compare reals(l,r); %return
COMPAREREALS(L, R);
return;
// 4168 %finish
L_0332:;
// 4169 %if L_Type = Records %start
if (L->TYPE != 6) goto L_0333;
// 4170 Compare Records(L, R, Min Record Size(L, R))
COMPARERECORDS(L, R, MINRECORDSIZE(L, R));
// 4171 %return
return;
// 4172 %finish
L_0333:;
// 4173 address(l,0); load(l,any)
ADDRESS(L, 0);
LOAD(L, 25);
// 4174 address(r,0)
ADDRESS(R, 0);
// 4175 %if '=' # next # '#' %start
{
// Double-sided test on NEXT (Part I)
int tmp;
if (61 == (tmp = NEXT)) goto L_0334;
// Double-sided test on NEXT (Part II)
if (tmp == 35) goto L_0334;
}
// 4176 rxd(cmp,l_base,r)
RXD(7, L->BASE, R);
// 4177 %else
goto L_0335;
L_0334:;
// 4178 rxd(clw,l_base,r)
RXD(28, L->BASE, R);
// 4179 %finish
L_0335:;
// 4180 release(l_base)
RELEASE(L->BASE);
// 4181 %end; ! compare
return;
} /* end of COMPARE */
// 4182
// 4183 ! >> RESOLVE <<
// 4184 %routine resolve(%integer flag)
void RESOLVE(int FLAG) {
// 4185 !S -> A.(B).C
// 4186 %record(stackfm)%name s,a,b,c
struct STACKFM *S;
struct STACKFM *A;
struct STACKFM *B;
struct STACKFM *C;
// 4187 %integer p,q
int P;
int Q;
// 4188 cstack(0) %if flag&1 = 0; ! C missing
if (FLAG & 1 != 0) goto L_0336;
CSTACK(0);
L_0336:;
// 4189 pop lhs; c == lhs
POPLHS();
C = (struct STACKFM *)LHS;
// 4190 pop lhs; b == lhs
POPLHS();
B = (struct STACKFM *)LHS;
// 4191 cstack(0) %if flag&2 = 0; ! A missing
if (FLAG & 2 != 0) goto L_0337;
CSTACK(0);
L_0337:;
// 4192 pop lhs; a == lhs
POPLHS();
A = (struct STACKFM *)LHS;
// 4193 pop lhs; s == lhs
POPLHS();
S = (struct STACKFM *)LHS;
// 4194 load(s,r3); load(a,r2); load(b,r1); load(c,r4)
LOAD(S, 4);
LOAD(A, 3);
LOAD(B, 2);
LOAD(C, 5);
// 4195 p = a_length; !!!!! p = 255 %if p = 0
P = A->LENGTH;
// 4196 q = c_length; !!!!! q = 255 %if q = 0
Q = C->LENGTH;
// 4197 release(r3); drop(s)
RELEASE(4);
DROP(S);
// 4198 release(r2); drop(a)
RELEASE(3);
DROP(A);
// 4199 release(r1); drop(b)
RELEASE(2);
DROP(B);
// 4200 release(r4); drop(c)
RELEASE(5);
DROP(C);
// 4201 perm(sresln); cput( (p<<8) + (q&255) ); ! conditional resolution
PERM(7);
CPUT((P << 8) + (Q & 255));
// 4202 %if flag&4 = 0 %start; ! unconditional
if (FLAG & 4 != 0) goto L_0338;
// 4203 perm(sresv); ! verify it succeeded
PERM(8);
// 4204 %finish
L_0338:;
// 4205 %end; ! resolve
return;
} /* end of RESOLVE */
// 4206
// 4207 ! >> HEADER <<
// 4208 %routine header(%record(varfm)%name v)
void HEADER(struct VARFM * V) {
// 4209 frame = basic frame %if frame < basic frame
if (FRAME >= 44) goto L_0339;
FRAME = 44;
L_0339:;
// 4210 define tag(v_disp&x'FFF')
DEFINETAG(V->DISP & 4095);
// 4211 rx(stm, p2+2-minparm, wsp, (2-minparm)*reglen)
RX(25, 6 + 2 - MINPARM, 8, (2 - MINPARM) * 4);
// 4212 %if potype >= external %start
if (POTYPE < 3) goto L_033A;
// 4213
// 4214 !===== the order of the next two statements is critical =====
// 4215
// 4216 external link(ep defn,0,0)
EXTERNALLINK(7, 0, 0);
// 4217 rx(st,link,wsp,(link-p2)*reglen)
RX(2, 16, 8, (16 - 6) * 4);
// 4218
// 4219 %if control&unass # 0 %and unassigned rtn = 0 %start
if (CONTROL & 12 == 0) goto L_033B;
if (UNASSIGNEDRTN != 0) goto L_033B;
// 4220 ! Force inclusion of unassigned check routine if not already present
// 4221 unassigned rtn = 1
UNASSIGNEDRTN = 1;
// 4222 select output(direct)
_imp_SELECTOUTPUT(1);
// 4223 print symbol(p ref); put(asschk); put(0)
_imp_PRINTSYMBOL(3);
PUT(1);
PUT(0);
// 4224 select output(object)
_imp_SELECTOUTPUT(2);
// 4225 %finish
L_033B:;
// 4226 %finish
L_033A:;
// 4227 rr(lw,local,wsp)
RR(1, LOCAL, 8);
// 4228 %if v_header # 0 %start; ! special string parameter (P in R)
if (V->HEADER == 0) goto L_033C;
// 4229 abort(m'HDR1') %if v == begin
if (_imp_ADDR((void *)(V)) != _imp_ADDR((void *)(/*?*/ &BEGIN))) goto L_033D;
ABORT(1212437041);
L_033D:;
// 4230 sset(local,v_header,V in S,0); rhs_type = strings
SSET(LOCAL, V->HEADER, 4, 0);
RHS->TYPE = 5;
// 4231 sset(p3,0,VinR,0)
SSET(2, 0, 1, 0);
// 4232 claim(P3); ! parameter nominally at 0(P3)
CLAIM(2);
// 4233 assign(3); ! SMOVOPT
ASSIGN(3);
// 4234 %if control&trusted # 0 %start; ! suppress check if 'TRUSTED'
if (CONTROL & 32 == 0) goto L_033E;
// 4235 v_header = 0
V->HEADER = 0;
// 4236 %else
goto L_033F;
L_033E:;
// 4237 Cput(x'0812') {preserve R2 for later}
CPUT(2066);
// 4238 %finish
L_033F:;
// 4239 %finish
L_033C:;
// 4240 frame = (frame+align)&(\align); ! ensure non-parameter locals are aligned
FRAME = FRAME + 3 & (~3);
// 4241 %if control & trusted = 0 %start; ! stack overflow check
if (CONTROL & 32 != 0) goto L_0340;
// 4242 perm(pentc); ! checked procedure entry *** mustn't corrupt R2 ***
PERM(26);
// 4243 cput(frame); ! parameter size
CPUT(FRAME);
// 4244 cput(0); ! padding:- gets overwritten
CPUT(0);
// 4245 %else
goto L_0341;
L_0340:;
// 4246 rxi(add,wsp,0,basic frame); ! 2nd. halfword gets overwritten
RXI(3, 8, 0, 44);
// 4247 %finish
L_0341:;
// 4248 set frame patch; ! Total size
SETFRAMEPATCH();
// 4249 ! Use base reg(5) to hold unassigned pattern ( except at level 5 !! )
// 4250 %if level # 5 %and control & check unass # 0 %start
if (LEVEL == 5) goto L_0342;
if (CONTROL & 2 == 0) goto L_0342;
// 4251 rx(lw,base5,code,unass)
RX(1, 13, 15, 12);
// 4252 activity(base5) = -1; ! lock it
ACTIVITY[13] = -1;
// 4253 %finish
L_0342:;
// 4254 %if v_header # 0 %start; ! check P in R string
if (V->HEADER == 0) goto L_0343;
// 4255 Cput(x'0821') {*LR_2,1}
CPUT(2081);
// 4256 perm(smove)
PERM(4);
// 4257 cput(ap_length); ! 'AP' set at '}'
CPUT(AP->LENGTH);
// 4258 v_header = 0
V->HEADER = 0;
// 4259 %finish
L_0343:;
// 4260 %if control&trace # 0 %start; ! trace option enabled
if (CONTROL & 64 == 0) goto L_0344;
// 4261 %if v == begin %and potype >= external %start; ! main program %begin
if (_imp_ADDR((void *)(V)) != _imp_ADDR((void *)(/*?*/ &BEGIN))) goto L_0345;
if (POTYPE < 3) goto L_0345;
// 4262 external id = trace routine
_imp_strncpy(/*?*/ &EXTERNALID, ({
__typeof__(_imp_string6) tmp; /*B*/
tmp = TRACEROUTINE;
(void *)&tmp;
}),
/*max:*/ 19);
// 4263 external link(ep ref,0,ga)
EXTERNALLINK(6, 0, GA);
// 4264 perm(enter trace); cput(0); ! initialise user-supplied routine
PERM(50);
CPUT(0);
// 4265 %finish
L_0345:;
// 4266 trace flag = control&trace
TRACEFLAG = CONTROL & 64;
// 4267 %finish
L_0344:;
// 4268 event = 0
EVENT = (struct EVFM){0};
// 4269 %end; ! header
return;
} /* end of HEADER */
// 4270
// 4271 ! >> RETURN <<
// 4272 %routine return
void RETURN(void) {
// 4273 %return %if uncond jump = ca; ! can't get here ?
if (UNCONDJUMP != CA) goto L_0346;
return;
L_0346:;
// 4274 %if Return Label # 0 %start
if (RETURNLABEL == 0) goto L_0347;
// 4275 Jump To(Return Label, Jump, Define New)
JUMPTO(RETURNLABEL, 12, 0);
// 4276 %else
goto L_0348;
L_0347:;
// 4277 Return Label = x'7001' {something positive and unique}
RETURNLABEL = 28673;
// 4278 Define Label(Return Label)
DEFINELABEL(RETURNLABEL);
// 4279 rx(lm,wsp,local,(wsp-p2)*reglen)
RX(24, 8, LOCAL, (8 - 6) * 4);
// 4280 rr(jmp,always,link)
RR(21, 1, 16);
// 4281 %finish
L_0348:;
// 4282 uncond jump = ca
UNCONDJUMP = CA;
// 4283 Closed = 0 {can get back now}
CLOSED = 0;
// 4284 %end; ! return
return;
} /* end of RETURN */
// 4285
// 4286 %routine compile to string(%record(stackfm)%name v)
void COMPILETOSTRING(struct STACKFM * V) {
// 4287 {Delay if possible so S = S.tostring(k) can be optimised in LOAD}
// 4288 %if next = '.' %and control&(check capacity!check unass) = 0 %start
if (NEXT != 46) goto L_0349;
if (CONTROL & (1 | 2) != 0) goto L_0349;
// 4289 v_flag = v_flag ! quick conc
V->FLAG = V->FLAG | 1;
// 4290 %return
return;
// 4291 %else %if const(v)
L_0349:;
if (!(CONST(V))) goto L_034A;
// 4292 current string(0) = 1; current string(1) = v_disp&255
CURRENTSTRING[0] = 1;
CURRENTSTRING[1] = V->DISP & 255;
// 4293 claim literal(2,0); otype = con; dump string(0)
CLAIMLITERAL(2, 0);
OTYPE = 2;
DUMPSTRING(0);
// 4294 v_base = code; v_disp = litmax
V->BASE = 15;
V->DISP = LITMAX;
// 4295 %else
goto L_034B;
L_034A:;
// 4296 load(v,any)
LOAD(V, 25);
// 4297 frame = (frame+1)&(\1)
FRAME = FRAME + 1 & (~1);
// 4298 rr(lbr,R0,v_base)
RR(31, 1, V->BASE);
// 4299 rxi(add,R0,0,1<<8)
RXI(3, 1, 0, 1 << 8);
// 4300 rx(sth,R0,local,frame)
RX(32, 1, LOCAL, FRAME);
// 4301 v_base = local; v_disp = frame; frame = frame+2
V->BASE = LOCAL;
V->DISP = FRAME;
FRAME = FRAME + 2;
// 4302 %finish
L_034B:;
// 4303 v_type = strings; v_xform = VinS ! (assigned<<8); v_length = 1
V->TYPE = 5;
V->XFORM = 4 | 8 << 8;
V->LENGTH = 1;
// 4304 %end
return;
} /* end of COMPILETOSTRING */
// 4305 ! >> CALL <<
// 4306 %routine call(%record(stackfm)%name v)
void CALL(struct STACKFM * V) {
// 4307 %switch b(1:max prim)
int B_index;
int B_line;
char *B_file;
static const void *B[23] = {
&&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing,
&&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing,
&&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing,
&&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing, &&case_B_missing};
// 4308 ! 1 = rem
// 4309 ! 2 = read symbol
// 4310 ! 3 = float
// 4311 ! 4 = to string
// 4312 ! 5 = substring
// 4313 ! 6 = free space
// 4314 ! 7 = SVC; ! *** MOUSES specific ***
// 4315 ! 8 = addr
// 4316 ! 9 = integer
// 4317 ! 10 = short integer
// 4318 ! 11 = byte integer
// 4319 ! 12 = string
// 4320 ! 13 = record
// 4321 ! 14 = real
// 4322 ! 15 = long real
// 4323 ! 16 = length
// 4324 ! 17 = charno
// 4325 ! 18 = int
// 4326 ! 19 = int pt
// 4327 ! 20 = IOCP; ! *** temporary ***
// 4328 ! 21 = type of; ( type of general name parameter )
// 4329 ! 22 = size of; ( physical length in bytes )
// 4330 ! 23 = frac pt; ! *** replaces IOCP above in the fullness of time ***
// 4331 %constbyteintegerarray new type(9:17) =
const unsigned char NEWTYPE[9] = {1, 2, 3, 5, 6, 7, 7, 3, 3};
// 4332+ integers, short, byte, strings, records, reals, reall, byte, byte
// 4333 %constbytearray New Size(integers:reall) = 4,2,1,8,255,0,4
const unsigned char NEWSIZE[7] = {4, 2, 1, 8, 255, 0, 4};
// 4334 %integer t,l,p
int T;
int L;
int P;
// 4335
// 4336 %if v_flag & prim bit # 0 %start; ! built-in primitive
if (V->FLAG & 4 == 0) goto L_034C;
// 4337 l = 0; t = v_header; sym = 0; ! 'sym=0' used as flag elsewhere
L = 0;
T = V->HEADER;
SYM = 0;
// 4338 %if t = 2 %start; ! 'read symbol'
if (T != 2) goto L_034D;
// 4339 v_flag = v_flag & (\prim bit)
V->FLAG = V->FLAG & (~4);
// 4340 v_header = 0; ! otherwise looks like "P in R" in "HEADER" q.v.
V->HEADER = 0;
// 4341 %else
goto L_034E;
L_034D:;
// 4342 drop(v)
DROP(V);
// 4343 %finish
L_034E:;
// 4344 set lhs
SETLHS();
// 4345 -> b(t)
B_line = __LINE__;
B_file = __FILE__;
B_index = T;
goto case_B_dispatch;
// 4346 b(1): ! REM
case_B_1:;
// 4347 operate(rem); %return
OPERATE(14);
return;
// 4348 b(2): ! READ SYMBOL
case_B_2:;
// 4349 call(v)
CALL(V);
// 4350 sset(r1,0,VinR,0)
SSET(2, 0, 1, 0);
// 4351 %if lhs_type = records %or lhs_type = general %start
if (LHS->TYPE == 6) goto L_0350;
if (LHS->TYPE != 4) goto L_0351;
L_0350:;
// 4352 warn(4)
WARN(4);
// 4353 ! *** subsequently, force a call on external routine form of
// 4354 ! read symbol and leave it to generate the error
// 4355 ! *** FRIG ***
// 4356 cload(5,r0); cload(5,r1); perm(signal)
CLOAD(5, 1);
CLOAD(5, 2);
PERM(20);
// 4357 set lhs; lhs_type = byte; ! to prevent compiler failing
SETLHS();
LHS->TYPE = 3;
// 4358 ! *** FRIG ***
// 4359 %finish
L_0351:;
// 4360 claim(rhs_base)
CLAIM(RHS->BASE);
// 4361 compile to string(rhs) %if lhs_type = strings
if (LHS->TYPE != 5) goto L_0352;
COMPILETOSTRING(RHS);
L_0352:;
// 4362 assign(1)
ASSIGN(1);
// 4363 %return
return;
// 4364 b(3): ! FLOAT
case_B_3:;
// 4365 float(lhs, anyf); %return
FLOAT(LHS, 26);
return;
// 4366 b(4): ! TO STRING
case_B_4:;
// 4367 compile to string(lhs)
COMPILETOSTRING(LHS);
// 4368 %return
return;
// 4369 b(8): ! ADDR
case_B_8:;
// 4370 t = Lhs_Type
T = LHS->TYPE;
// 4371 amap(lhs)
AMAP(LHS);
// 4372 %if T = Strings %and Lhs_Form # AVinS %and Lhs_Form # AVinRec %start
if (T != 5) goto L_0353;
if (LHS->FORM == 5) goto L_0353;
if (LHS->FORM == 8) goto L_0353;
// 4373 Load(Lhs, Any)
LOAD(LHS, 25);
// 4374 Lhs_Form = VinS
LHS->FORM = 4;
// 4375 Forget Reg(1<<Lhs_Base)
FORGETREG(1 << LHS->BASE);
// 4376 Rxd(LA, Lhs_Base, Lhs); Claim(Lhs_Base)
RXD(23, LHS->BASE, LHS);
CLAIM(LHS->BASE);
// 4377 Lhs_Form = VinR
LHS->FORM = 1;
// 4378 %finish
L_0353:;
// 4379 %return
return;
// 4380
// 4381 b(16): ! LENGTH
case_B_16:;
// 4382 cstack(0)
CSTACK(0);
// 4383 b(17): ! CHARNO
case_B_17:;
// 4384 set both
SETBOTH();
// 4385 amap(lhs)
AMAP(LHS);
// 4386 %if control&check array = 0 %c
if (CONTROL & 4 == 0) goto L_0354;
if (!(CONST(RHS))) goto L_0355;
{
// Double-sided test on RHS->DISP (Part I)
int tmp;
if (T - 16 > (tmp = RHS->DISP)) goto L_0355;
// Double-sided test on RHS->DISP (Part II)
if (tmp > LHS->LENGTH) goto L_0355;
}
L_0354:;
// 4387+ %or (const(rhs) %and t-16 <= rhs_disp <= lhs_length) %start
// 4388 operate(add); set lhs; !LHS&RHS reversed in operate??
OPERATE(3);
SETLHS();
// 4389 %else
goto L_0356;
L_0355:;
// 4390 load(lhs,r1); load(rhs,r2)
LOAD(LHS, 2);
LOAD(RHS, 3);
// 4391 drop(rhs); stp = stp-1
DROP(RHS);
STP = STP - 1;
// 4392 release(r1); release(r2)
RELEASE(2);
RELEASE(3);
// 4393 !!**** charno(s,j) where S is %String(*)%name won't work: change perm as well
// 4394 perm(chmap); cput(lhs_length & 255)
PERM(31);
CPUT(LHS->LENGTH & 255);
// 4395 claim(r1)
CLAIM(2);
// 4396 set lhs; lhs_base = r1; lhs_disp = 0; lhs_xform = VinR
SETLHS();
LHS->BASE = 2;
LHS->DISP = 0;
LHS->XFORM = 1;
// 4397 %finish
L_0356:;
// 4398 -> map it
goto U_1013;
// 4399 b(12): ! STRING
case_B_12:;
// 4400 !!!!! l = 255
// 4401 b(9):b(10):b(11): ! INTEGER, SHORT, BYTE
case_B_9:;
case_B_10:;
case_B_11:;
// 4402 b(13): ! RECORD
case_B_13:;
// 4403 b(14):b(15): ! REAL, LONG REAL
case_B_14:;
case_B_15:;
// 4404 map it:
U_1013:;
// 4405 vmap(lhs); lhs_type = new type(t)
VMAP(LHS);
LHS->TYPE = NEWTYPE[T - 9];
// 4406 lhs_length = new size(Lhs_Type)
LHS->LENGTH = NEWSIZE[LHS->TYPE - 1];
// 4407 %return
return;
// 4408 b(19): ! INT PT
case_B_19:;
// 4409 load(lhs,anyf)
LOAD(LHS, 26);
// 4410 p = gpr; hazard(p)
P = GPR();
HAZARD(P);
// 4411 rr(fxr,p,lhs_base); claim(p)
RR(27, P, LHS->BASE);
CLAIM(P);
// 4412 lhs_base = p; lhs_type = integers; lhs_xform = VinR
LHS->BASE = P;
LHS->TYPE = 1;
LHS->XFORM = 1;
// 4413 %return
return;
// 4414 b(18): ! INT
case_B_18:;
// 4415 p = intfn; ! perm routine
P = 33;
// 4416 t = integers; ! resulting type
T = 1;
// 4417 l = R1; ! result register
L = 2;
// 4418 -> PERM1823
goto U_100C;
// 4419 b(23): ! FRAC PT
case_B_23:;
// 4420 p = frac part
P = 10;
// 4421 t = reall
T = 7;
// 4422 l = FR2
L = 18;
// 4423 PERM1823:
U_100C:;
// 4424 load(lhs,fr2); release(fr2)
LOAD(LHS, 18);
RELEASE(18);
// 4425 perm(p)
PERM(P);
// 4426 claim(l); ! result register
CLAIM(L);
// 4427 set lhs
SETLHS();
// 4428 lhs_base = l; lhs_xform = VinR; lhs_type = t
LHS->BASE = L;
LHS->XFORM = 1;
LHS->TYPE = T;
// 4429 %return
return;
// 4430 b(5): ! substring(S,from,to)
case_B_5:;
// 4431 load(lhs,r3); drop(lhs); stp = stp-1
LOAD(LHS, 4);
DROP(LHS);
STP = STP - 1;
// 4432 set both; stp = stp-2
SETBOTH();
STP = STP - 2;
// 4433 load(lhs,r1); load(rhs,r2); drop(lhs); drop(rhs)
LOAD(LHS, 2);
LOAD(RHS, 3);
DROP(LHS);
DROP(RHS);
// 4434 release(r1); release(r2); release(r3)
RELEASE(2);
RELEASE(3);
RELEASE(4);
// 4435 perm(substr); claim(r1)
PERM(12);
CLAIM(2);
// 4436 sset(r1,0,v in s,0); rhs_type = strings
SSET(2, 0, 4, 0);
RHS->TYPE = 5;
// 4437 %return
return;
// 4438 b(21): ! type of(..)
case_B_21:;
// 4439 b(22): ! size of(..)
case_B_22:;
// 4440 %if lhs_type # general %start; ! type explicitly specified
if (LHS->TYPE == 4) goto L_0357;
// 4441 %if t = 21 %start; ! type of
if (T != 21) goto L_0358;
// 4442 p = gen map(lhs_type)
P = GENMAP[LHS->TYPE - 1];
// 4443 %else
goto L_0359;
L_0358:;
// 4444 p = lhs_length; p = p+1 %if lhs_type = strings
P = LHS->LENGTH;
if (LHS->TYPE != 5) goto L_035A;
P = P + 1;
L_035A:;
// 4445 %finish
L_0359:;
// 4446 release(lhs_base)
RELEASE(LHS->BASE);
// 4447 lhs_type = integers; lhs_form = constant
LHS->TYPE = 1;
LHS->FORM = 0;
// 4448 lhs_base = 0; lhs_disp = p
LHS->BASE = 0;
LHS->DISP = P;
// 4449 %else
goto L_035B;
L_0357:;
// 4450 lhs_disp = lhs_disp + reglen; ! reference property-word
LHS->DISP = LHS->DISP + 4;
// 4451 lhs_xform = (assigned<<8) ! V in S; lhs_type = integers
LHS->XFORM = 8 << 8 | 4;
LHS->TYPE = 1;
// 4452 %if t = 21 %start; ! type of
if (T != 21) goto L_035C;
// 4453 cstack(15); operate(and)
CSTACK(15);
OPERATE(8);
// 4454 %else; ! size of
goto L_035D;
L_035C:;
// 4455 cstack(4); operate(rsh)
CSTACK(4);
OPERATE(12);
// 4456 %finish
L_035D:;
// 4457 %finish
L_035B:;
// 4458 %return
return;
// 4459 b(6): ! free space
case_B_6:;
// 4460 perm(freesp); claim(r1)
PERM(32);
CLAIM(2);
// 4461 sset(r1,0,VinR,0)
SSET(2, 0, 1, 0);
// 4462 %return
return;
// 4463 b(7): ! SVC (MOUSES SPECIFIC)
case_B_7:;
// 4464 hazard(p) %for p = fr0,1,fr14
// %for P = 17, 1, 24 %cycle
{
P = 16;
L_035E:
if (P == 24) goto L_035F;
P += 1;
HAZARD(P);
goto L_035E;
}
L_035F:;
// 4465 set both; stp = stp-2
SETBOTH();
STP = STP - 2;
// 4466 load(lhs,any) %unless const(lhs);
if (CONST(LHS)) goto L_0361;
LOAD(LHS, 25);
L_0361:;
// 4467 address(rhs,-1)
ADDRESS(RHS, -1);
// 4468 rx(lme,fr0,rhs_base,rhs_disp); claim(rhs_base)
RX(21, 17, RHS->BASE, RHS->DISP);
CLAIM(RHS->BASE);
// 4469 rx(svc,r0,lhs_base,lhs_disp)
RX(33, 1, LHS->BASE, LHS->DISP);
// 4470 rx(stme,fr0,rhs_base,rhs_disp)
RX(22, 17, RHS->BASE, RHS->DISP);
// 4471 drop(lhs); drop(rhs)
DROP(LHS);
DROP(RHS);
// 4472 forget reg(-1)
FORGETREG(-1);
// 4473 %return
return;
// 4474 b(20): ! IOCP *** temporary ***
case_B_20:;
// 4475 load(lhs,r4); ! required function
LOAD(LHS, 5);
// 4476 release(r4); drop(lhs); stp = stp-1
RELEASE(5);
DROP(LHS);
STP = STP - 1;
// 4477 perm(iocp)
PERM(49);
// 4478 %return
return;
// 4479
// 4480 %finish
L_034C:;
// 4481 ! -- normal routine calls --
// 4482 wdisp = (wdisp+align)&(\align); !keep WSP aligned
WDISP = WDISP + 3 & (~3);
// 4483 hazard all %if V_Flag&Assigned = 0 {beware - it returns}
if (V->FLAG & 8 != 0) goto L_0362;
HAZARDALL();
L_0362:;
// 4484 %if v_base # 0 %start; ! non-local
if (V->BASE == 0) goto L_0363;
// 4485 %if v_base # gla %start
if (V->BASE == 14) goto L_0364;
// 4486 t = new tag; define reference(t, r ref)
T = NEWTAG();
DEFINEREFERENCE(T, 2);
// 4487 rx(la, link, code, 0)
RX(23, 16, 15, 0);
// 4488 %finish
L_0364:;
// 4489 rx(STM,p2,wsp,wdisp)
RX(25, 6, 8, WDISP);
// 4490 rxi(ADD,wsp,0,wdisp) %if wdisp # 0
if (WDISP == 0) goto L_0365;
RXI(3, 8, 0, WDISP);
L_0365:;
// 4491 %if v_base = gla %start; ! external
if (V->BASE != 14) goto L_0366;
// 4492 rx(lm,gla,gla,v_disp)
RX(24, 14, 14, V->DISP);
// 4493 rr(bal, link, link)
RR(22, 16, 16);
// 4494 %else; ! procedure-as-parameter
goto L_0367;
L_0366:;
// 4495 quick load(r2, VinS, v_base, v_disp); forget reg(1<<R2)
QUICKLOAD(3, 4, V->BASE, V->DISP);
FORGETREG(1 << 3);
// 4496 rx(lm,r8,r2,0)
RX(24, 9, 3, 0);
// 4497 rx(bal, link, link, 4); !skip initial STM
RX(22, 16, 16, 4);
// 4498 define tag(t)
DEFINETAG(T);
// 4499 %finish
L_0367:;
// 4500 %else; ! local routine
goto L_0368;
L_0363:;
// 4501 rxi(ADD,wsp,0,wdisp) %if wdisp # 0; ! protect stacked parameters ?
if (WDISP == 0) goto L_0369;
RXI(3, 8, 0, WDISP);
L_0369:;
// 4502 define reference(v_disp&x'FFF',r ref)
DEFINEREFERENCE(V->DISP & 4095, 2);
// 4503 rx(bal,link,code,0)
RX(22, 16, 15, 0);
// 4504 rxi(SUB,wsp,0,wdisp) %if wdisp # 0; ! reset protection
if (WDISP == 0) goto L_036A;
RXI(4, 8, 0, WDISP);
L_036A:;
// 4505 Uncond Jump = Ca %if V_Flag&Assigned # 0 {it doesn't return}
if (V->FLAG & 8 == 0) goto L_036B;
UNCONDJUMP = CA;
L_036B:;
// 4506 %finish
L_0368:;
// 4507 wdisp = v_header; p disp = v_rt
WDISP = V->HEADER;
PDISP = V->RT;
// 4508 drop(v) %if v_type = 0; ! not function or map
if (V->TYPE != 0) goto L_036C;
DROP(V);
L_036C:;
// 4509 %end; ! call
return;
case_B_dispatch:
if (B_index < 1 || B_index > 23)
_imp_signalf(6, 3, B_index, "->B(%d) out of bounds at %s line %d", B_index, B_file, B_line);
goto *B[B_index - 1];
case_B_missing:
_imp_signalf(8, 2, B_index, "switch jump to undefined label B(%d): at %s line %d", B_index, B_file, B_line);
} /* end of CALL */
// 4510
// 4511 ! >> COMPILER OP <<
// 4512 !***** RE=ORGANISE 'call', 'prim' and this routine *****
// 4513 %routine compiler op(%integer n)
void COMPILEROP(int N) {
// 4514 %record(stackfm)%name p
struct STACKFM *P;
// 4515 p == descriptor; stp = stp-1 {DESCRIPTOR increments it!!}
P = (struct STACKFM *)DESCRIPTOR();
STP = STP - 1;
// 4516 p_flag= prim bit; p_header = n
P->FLAG = 4;
P->HEADER = N;
// 4517 abort(m'CMOP') %unless 0 < n <= max prim
{
// Double-sided test on N (Part I)
int tmp;
if (0 >= (tmp = N)) goto L_036D;
// Double-sided test on N (Part II)
if (tmp <= 23) goto L_036E;
}
L_036D:;
ABORT(1129140048);
L_036E:;
// 4518 call(p)
CALL(P);
// 4519 %end
return;
} /* end of COMPILEROP */
// 4520
// 4521 ! >> COMPILE FOR <<
// 4522 %routine compile for
void COMPILEFOR(void) {
// 4523 %record(stackfm)%name cv, iv, inc, fv
struct STACKFM *CV;
struct STACKFM *IV;
struct STACKFM *INC;
struct STACKFM *FV;
// 4524 %integer lab, safe, n, reg, shadow
int LAB;
int SAFE;
int N;
int REG;
int SHADOW;
// 4525 %routine stab(%record(stackfm)%name v, %integer type)
void STAB(struct STACKFM * V, int TYPE) {
// 4526 %integer t,r
int T;
int R;
// 4527 %return %if const(v)
if (!(CONST(V))) goto L_036F;
return;
L_036F:;
// 4528 load(v,any); r = v_base
LOAD(V, 25);
R = V->BASE;
// 4529 t = temp
T = TEMP();
// 4530 v_base = local; v_disp = t
V->BASE = LOCAL;
V->DISP = T;
// 4531 v_type = type; v_xform = (assigned<<8) ! V in S
V->TYPE = TYPE;
V->XFORM = 8 << 8 | 4;
// 4532 rx(ST,r,local,t); release(r)
RX(2, R, LOCAL, T);
RELEASE(R);
// 4533 associate(v,r) %if control & suppress = 0
if (CONTROL & 128 != 0) goto L_0370;
ASSOCIATE(V, R);
L_0370:;
// 4534 %end
return;
} /* end of STAB */
// 4535 %routine set(%record(stackfm)%name v,%integer reg)
void SET(struct STACKFM * V, int REG) {
// 4536 %record(stackfm)%name r
struct STACKFM *R;
// 4537 sstack(v); r == stacked(stp)_v
SSTACK(V);
R = (struct STACKFM *)STACKED[STP - 1].V;
// 4538 lrd(r,reg)
LRD(R, REG);
// 4539 stp = stp-1
STP = STP - 1;
// 4540 %end
return;
} /* end of SET */
// 4541 cv == stacked(stp-3)_v
CV = (struct STACKFM *)STACKED[STP - 3 - 1].V;
// 4542 inc == stacked(stp-2)_v
INC = (struct STACKFM *)STACKED[STP - 2 - 1].V;
// 4543 fv == stacked(stp-1)_v
FV = (struct STACKFM *)STACKED[STP - 1 - 1].V;
// 4544 lab = tag
LAB = TAG();
// 4545 abort(m'FOR1') %if for stp = max cycle
if (FORSTP != 30) goto L_0371;
ABORT(1179603505);
L_0371:;
// 4546 for stp = for stp + 1; for == for stk(for stp)
FORSTP = FORSTP + 1;
FOR = (struct CYCLEFM *)/*?*/ &FORSTK[FORSTP];
// 4547 n = next temp; ! remember current point in temp stack
N = NEXTTEMP;
// 4548 shadow = -1; shadow = temp %if control & check for # 0
SHADOW = -1;
if (CONTROL & 4 == 0) goto L_0372;
SHADOW = TEMP();
L_0372:;
// 4549 stab(fv,integers); stab(inc,integers)
STAB(FV, 1);
STAB(INC, 1);
// 4550 for_temp base = temp base
FOR->TEMPBASE = TEMPBASE;
// 4551 %if n # next temp %start; ! protect shadow, FV, INC ?
if (N == NEXTTEMP) goto L_0373;
// 4552 temp base = new temp
TEMPBASE = NEWTEMP;
// 4553 %finish
L_0373:;
// 4554 safe = 0
SAFE = 0;
// 4555 sstack(inc); operate(sub)
SSTACK(INC);
OPERATE(4);
// 4556 iv == stacked(stp)_v; ! iv = iv - inc
IV = (struct STACKFM *)STACKED[STP - 1].V;
// 4557 %if cv_form # v in s %or activity(cv_base) >= 0 %start
if (CV->FORM != 4) goto L_0374;
if (ACTIVITY[CV->BASE] < 0) goto L_0375;
L_0374:;
// 4558 n = cv_type
N = CV->TYPE;
// 4559 amap(cv)
AMAP(CV);
// 4560 stab(cv, n)
STAB(CV, N);
// 4561 cv_form = a in s
CV->FORM = 6;
// 4562 %finish
L_0375:;
// 4563 stp = stp-4
STP = STP - 4;
// 4564 %if const(fv) %and const(iv) %and const(inc) %start
if (!(CONST(FV))) goto L_0376;
if (!(CONST(IV))) goto L_0376;
if (!(CONST(INC))) goto L_0376;
// 4565 %if inc_disp # 0 %start
if (INC->DISP == 0) goto L_0377;
// 4566 n = fv_disp-iv_disp
N = FV->DISP - IV->DISP;
// 4567 %if n !! inc_disp >= 0 %and (n//inc_disp)*inc_disp = n %start
if (N ^ INC->DISP < 0) goto L_0378;
if (((long)N / (long)INC->DISP) * INC->DISP != N) goto L_0378;
// 4568 safe = 1
SAFE = 1;
// 4569 %finish
L_0378:;
// 4570 %finish
L_0377:;
// 4571 %if safe = 0 %start
if (SAFE != 0) goto L_0379;
// 4572 warn(2); ! constant faulty %for parameters
WARN(2);
// 4573 %else
goto L_037A;
L_0379:;
// 4574 safe = fv_disp - iv_disp; ! null cycle ?
SAFE = FV->DISP - IV->DISP;
// 4575 %finish
L_037A:;
// 4576 %finish
L_0376:;
// 4577 reg = iv_base
REG = IV->BASE;
// 4578 %if reg <= r2 %start
if (REG > 3) goto L_037B;
// 4579 reg = gpr {**cannot return r0,r1,r2}
REG = GPR();
// 4580 %else
goto L_037C;
L_037B:;
// 4581 reg = any
REG = 25;
// 4582 %finish
L_037C:;
// 4583 load(iv,reg); reg = iv_base
LOAD(IV, REG);
REG = IV->BASE;
// 4584 %if safe = 0 %and control & check for # 0 %start
if (SAFE != 0) goto L_037D;
if (CONTROL & 4 == 0) goto L_037D;
// 4585 set(iv,r0); claim(reg)
SET(IV, 1);
CLAIM(REG);
// 4586 set(fv,r1); set(inc,r2)
SET(FV, 2);
SET(INC, 3);
// 4587 perm(fchk1); ! Check %for parameters before entry
PERM(24);
// 4588 %finish
L_037D:;
// 4589 %if safe = 0 %start; ! non-constant or null cycle
if (SAFE != 0) goto L_037E;
// 4590 sstack(cv); sstack(iv); assign(1); claim(reg)
SSTACK(CV);
SSTACK(IV);
ASSIGN(1);
CLAIM(REG);
// 4591 for_initial = for lab base + for stp
FOR->INITIAL = 8000 + FORSTP;
// 4592 jump to(for_initial,jump,redefine old)
JUMPTO(FOR->INITIAL, 12, 1);
// 4593 %finish
L_037E:;
// 4594 define label(lab); trace flag = control&trace
DEFINELABEL(LAB);
TRACEFLAG = CONTROL & 64;
// 4595 sstack(cv)
SSTACK(CV);
// 4596 sstack(iv); sstack(inc); operate(add); ! CV + INC
SSTACK(IV);
SSTACK(INC);
OPERATE(3);
// 4597 drop(iv); drop(inc)
DROP(IV);
DROP(INC);
// 4598 set lhs; load(lhs,reg); ! to make sure ASSIGN doesn't use wrong register
SETLHS();
LOAD(LHS, REG);
// 4599 assign(1)
ASSIGN(1);
// 4600 rx(st,reg,local,shadow) %if shadow >= 0
if (SHADOW < 0) goto L_037F;
RX(2, REG, LOCAL, SHADOW);
L_037F:;
// 4601 for_lab = lab; for_reg = reg; for_shadow = shadow
FOR->LAB = LAB;
FOR->REG = REG;
FOR->SHADOW = SHADOW;
// 4602 for_cvbase = cv_base; for_cvdisp = cv_disp
FOR->CVBASE = CV->BASE;
FOR->CVDISP = CV->DISP;
// 4603 for_cvtype = cv_type; for_cvform = cv_xform
FOR->CVTYPE = CV->TYPE;
FOR->CVFORM = CV->XFORM;
// 4604 for_fvbase = fv_base; for_fvdisp = fv_disp
FOR->FVBASE = FV->BASE;
FOR->FVDISP = FV->DISP;
// 4605 drop(cv); drop(fv)
DROP(CV);
DROP(FV);
// 4606 %end; ! for
return;
} /* end of COMPILEFOR */
// 4607
// 4608
// 4609 %cycle; ! --- main loop ---
L_0380:;
// 4610 sym = next; read symbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 4611 -> c(sym)
C_line = __LINE__;
C_file = __FILE__;
C_index = SYM;
goto case_C_dispatch;
// 4612
// 4613 c('l'): language mask = tag; %continue; ! Select language dependent options
case_C_108:;
LANGUAGEMASK = TAG();
goto L_0382;
// 4614
// 4615 c('O'):
case_C_79:;
// 4616 abort(m'STK?') %if stp # 0
if (STP == 0) goto L_0383;
ABORT(1398033215);
L_0383:;
// 4617 abort(m'USNG') %unless using_link == null
if (_imp_ADDR((void *)(USING.LINK)) == _imp_ADDR((void *)(NULL))) goto L_0384;
ABORT(1431522887);
L_0384:;
// 4618 abort(m'CLMD') %if claimed # 0
if (CLAIMED == 0) goto L_0385;
ABORT(1129073988);
L_0385:;
// 4619 abort(m'LIT?') %if ca < 0; ! 'select code/literal area' misused
if (CA >= 0) goto L_0386;
ABORT(1279874111);
L_0386:;
// 4620 wdisp = 0; p disp = 0
WDISP = 0;
PDISP = 0;
// 4621 next temp = temp base
NEXTTEMP = TEMPBASE;
// 4622 current line = tag
CURRENTLINE = TAG();
// 4623 %if control&trace # 0 %start
if (CONTROL & 64 == 0) goto L_0387;
// 4624 %if next = ':' %or next = 'L' %start
if (NEXT == 58) goto L_0388;
if (NEXT != 76) goto L_0389;
L_0388:;
// 4625 trace flag = 1
TRACEFLAG = 1;
// 4626 %else %if trace flag # 0
goto L_038A;
L_0389:;
if (TRACEFLAG == 0) goto L_038B;
// 4627 dump trace
DUMPTRACE();
// 4628 %finish
L_038B:;
L_038A:;
// 4629 %finish
L_0387:;
// 4630 %continue
goto L_0382;
// 4631
// 4632 c('$'): define var; %continue
case_C_36:;
DEFINEVAR();
goto L_0382;
// 4633
// 4634 c('b'):
case_C_98:;
// 4635 pop drop; vub = lhs_disp
POPDROP();
VUB = LHS->DISP;
// 4636 pop drop; vlb = lhs_disp
POPDROP();
VLB = LHS->DISP;
// 4637 %continue
goto L_0382;
// 4638
// 4639 %routine adump
void ADUMP(void) {
// 4640 %switch c(integers:8),g(integers:8); ! 8 =REALS+1 !!!!!
int C_index;
int C_line;
char *C_file;
static const void *C[8] = {&&case_C_1, &&case_C_2, &&case_C_3, &&case_C_missing,
&&case_C_5, &&case_C_6, &&case_C_7, &&case_C_8};
int G_index;
int G_line;
char *G_file;
static const void *G[8] = {&&case_G_1, &&case_G_2, &&case_G_3, &&case_G_missing,
&&case_G_5, &&case_G_6, &&case_G_7, &&case_G_8};
// 4641 %constintegerarray low(integers:8) = 0,-32768, 0, 0(*)
const int LOW[8] = {0, -32768, 0, [3 ... 7] = 0};
// 4642 %constintegerarray high(integers:8) = 0, 65535, 255, 0(*)
const int HIGH[8] = {0, 65535, 255, [3 ... 7] = 0};
// 4643 %integer j
int J;
// 4644 %if high(owntype) # 0 %and control & check capacity # 0 %start
if (HIGH[OWNTYPE - 1] == 0) goto L_038C;
if (CONTROL & 1 == 0) goto L_038C;
// 4645 warn(8) %unless low(owntype) <= ownval <= high(owntype)
{
// Double-sided test on OWNVAL (Part I)
int tmp;
if (LOW[OWNTYPE - 1] > (tmp = OWNVAL)) goto L_0360;
// Double-sided test on OWNVAL (Part II)
if (tmp <= HIGH[OWNTYPE - 1]) goto L_038D;
}
L_0360:;
WARN(8);
L_038D:;
// 4646 %finish
L_038C:;
// 4647 -> g(owntype) %if otype # con
if (OTYPE == 2) goto L_038E;
G_line = __LINE__;
G_file = __FILE__;
G_index = OWNTYPE;
goto case_G_dispatch;
L_038E:;
// 4648 select literal area %if strings # owntype < reals
{
// Double-sided test on OWNTYPE (Part I)
int tmp;
if (5 == (tmp = OWNTYPE)) goto L_0390;
// Double-sided test on OWNTYPE (Part II)
if (tmp >= 7) goto L_0390;
}
SELECTLITERALAREA();
L_0390:;
// 4649 -> c(owntype)
C_line = __LINE__;
C_file = __FILE__;
C_index = OWNTYPE;
goto case_C_dispatch;
// 4650 g(integers): gword(ownval); %return
case_G_1:;
GWORD(OWNVAL);
return;
// 4651 c(integers): cword(ownval); -> exit
case_C_1:;
CWORD(OWNVAL);
goto U_100C;
// 4652 c(reals):c(8):
case_C_7:;
case_C_8:;
// 4653 g(reals):g(8): j = real constant(1); %return
case_G_7:;
case_G_8:;
J = REALCONSTANT(1);
return;
// 4654 g(byte): gbyte(ownval); %return
case_G_3:;
GBYTE(OWNVAL);
return;
// 4655 c(byte): lit byte(ownval); -> exit
case_C_3:;
LITBYTE(OWNVAL);
goto U_100C;
// 4656 g(short): gput(ownval); %return
case_G_2:;
GPUT(OWNVAL);
return;
// 4657 c(short): cput(ownval); -> exit
case_C_2:;
CPUT(OWNVAL);
goto U_100C;
// 4658 c(strings):
case_C_5:;
// 4659 g(strings): dump string(data size); %return
case_G_5:;
DUMPSTRING(DATASIZE);
return;
// 4660 g(records): gput(0) %for j = 1,1,data size>>1
case_G_6:;
// %for J = 1, 1, (unsigned int)DATASIZE >> 1 %cycle
{
int _final = (unsigned int)DATASIZE >> 1;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, (unsigned int)DATASIZE >> 1");
J = 0;
L_0380:
if (J == _final) goto L_0392;
J += 1;
GPUT(0);
goto L_0380;
}
L_0392:;
// 4661 %return
return;
// 4662 c(records): abort(m'ADMP')
case_C_6:;
ABORT(1094995280);
// 4663 exit: select code area
U_100C:;
SELECTCODEAREA();
// 4664 %end; ! adump
return;
case_C_dispatch:
if (C_index < 1 || C_index > 8)
_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 - 1];
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);
case_G_dispatch:
if (G_index < 1 || G_index > 8)
_imp_signalf(6, 3, G_index, "->G(%d) out of bounds at %s line %d", G_index, G_file, G_line);
goto *G[G_index - 1];
case_G_missing:
_imp_signalf(8, 2, G_index, "switch jump to undefined label G(%d): at %s line %d", G_index, G_file, G_line);
} /* end of ADUMP */
// 4665 c('A'):
case_C_65:;
// 4666 aparm = tag
APARM = TAG();
// 4667 %if stp # 0 %start
if (STP == 0) goto L_0393;
// 4668 decvar_flag = decvar_flag ! assigned; ! explicit initialisation
DECVAR->FLAG = DECVAR->FLAG | 8;
// 4669 pop drop
POPDROP();
// 4670 %if own type >= reals %start
if (OWNTYPE < 7) goto L_0394;
// 4671 rvalue = lhs_disp %if lhs_type < reals
if (LHS->TYPE >= 7) goto L_0395;
RVALUE = LHS->DISP;
L_0395:;
// 4672 ownval = integer(addr(rvalue))
OWNVAL = *_imp_INTEGER(_imp_ADDR(/*?*/ &RVALUE));
// 4673 mantissa = integer(addr(rvalue)+4)
MANTISSA = *_imp_INTEGER(_imp_ADDR(/*?*/ &RVALUE) + 4);
// 4674 %else
goto L_0396;
L_0394:;
// 4675 ownval = lhs_disp; ! a string
OWNVAL = LHS->DISP;
// 4676 %finish
L_0396:;
// 4677 %else; ! initialise to UNASSIGNED pattern
goto L_0397;
L_0393:;
// 4678 %if own type = byte %start
if (OWNTYPE != 3) goto L_0398;
// 4679 own val = x'80'
OWNVAL = 128;
// 4680 %else %if own type = short
goto L_0399;
L_0398:;
if (OWNTYPE != 2) goto L_039A;
// 4681 own val = x'FFFF8080'
OWNVAL = -32640;
// 4682 %else %if owntype # strings
goto L_0399;
L_039A:;
if (OWNTYPE == 5) goto L_039B;
// 4683 ownval = x'80808080'; mantissa = x'80808080'
OWNVAL = -2139062144;
MANTISSA = -2139062144;
// 4684 %else
goto L_0399;
L_039B:;
// 4685 cslen = x'80'; current string(1) = x'80'
*CSLEN = 128;
CURRENTSTRING[1] = 128;
// 4686 %finish
L_0399:;
// 4687 %finish
L_0397:;
// 4688 %if own form = array %or own form = name array %start
if (OWNFORM == 11) goto L_039C;
if (OWNFORM != 13) goto L_039D;
L_039C:;
// 4689 adump %for j = 1,1,aparm
// %for J = 1, 1, APARM %cycle
{
int _final = APARM;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, APARM");
J = 0;
L_039E:
if (J == _final) goto L_039F;
J += 1;
ADUMP();
goto L_039E;
}
L_039F:;
// 4690 %else
goto L_03A1;
L_039D:;
// 4691 %if otype = 0 %start
if (OTYPE != 0) goto L_03A2;
// 4692 decvar_flag = decvar_flag & (\assigned); ! %const .... %name
DECVAR->FLAG = DECVAR->FLAG & (~8);
// 4693 decvar_disp = ownval; decvar_base = 0
DECVAR->DISP = OWNVAL;
DECVAR->BASE = 0;
// 4694 ! %CONSTINTEGERNAME -> INTEGER
// 4695 ! A in S -> V in S, A in REC -> VinREC
// 4696 %if Decvar_Form = VinS %start
if (DECVAR->FORM != 4) goto L_03A3;
// 4697 Decvar_Form = Constant
DECVAR->FORM = 0;
// 4698 %else
goto L_03A4;
L_03A3:;
// 4699 Set Diag(0, Ownval) %if Decvar_Form = AinS
if (DECVAR->FORM != 6) goto L_03A5;
SETDIAG(0, OWNVAL);
L_03A5:;
// 4700 decvar_form = decvar_form + (v in s - a in s)
DECVAR->FORM = DECVAR->FORM + (4 - 6);
// 4701 %finish
L_03A4:;
// 4702 %else
goto L_03A6;
L_03A2:;
// 4703 decvar_base = gla; decvar_disp = ga
DECVAR->BASE = 14;
DECVAR->DISP = GA;
// 4704 %if otype >= external %start
if (OTYPE < 3) goto L_03A7;
// 4705 decvar_flag = decvar_flag & (\assigned)
DECVAR->FLAG = DECVAR->FLAG & (~8);
// 4706 external link(data defn,data size,ga)
EXTERNALLINK(5, DATASIZE, GA);
// 4707 %else %if otype = con ; ! %const
goto L_03A8;
L_03A7:;
if (OTYPE != 2) goto L_03A9;
// 4708 %if decvar_type = strings %start
if (DECVAR->TYPE != 5) goto L_03AA;
// 4709 claim literal(cslen+1,1)
CLAIMLITERAL(*CSLEN + 1, 1);
// 4710 j = litmax; dump string(0)
J = LITMAX;
DUMPSTRING(0);
// 4711 %else %if decvar_type >= reals
goto L_03AB;
L_03AA:;
if (DECVAR->TYPE < 7) goto L_03AC;
// 4712 j = real constant(0); ! ** N.B. %fn + side-effect **
J = REALCONSTANT(0);
// 4713 %else
goto L_03AB;
L_03AC:;
// 4714 abort(m'AM01')
ABORT(1095577649);
// 4715 %finish
L_03AB:;
// 4716 decvar_base = code; decvar_disp = j
DECVAR->BASE = 15;
DECVAR->DISP = J;
// 4717 %continue
goto L_0382;
// 4718 %finish
L_03A9:;
L_03A8:;
// 4719 adump
ADUMP();
// 4720 %finish
L_03A6:;
// 4721 %finish
L_03A1:;
// 4722 %continue
goto L_0382;
// 4723
// 4724 c(''''): get string; %continue
case_C_39:;
GETSTRING();
goto L_0382;
// 4725 c('G'): get string
case_C_71:;
GETSTRING();
// 4726 alias = ""
_imp_strncpy(/*?*/ &ALIAS, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("");
(void *)&tmp;
}),
/*max:*/ 19);
// 4727 %for j = 1, 1, cslen %cycle
// %for J = 1, 1, *CSLEN %cycle
{
int _final = *CSLEN;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, *CSLEN");
J = 0;
L_03AD:
if (J == _final) goto L_03AE;
J += 1;
// 4728 alias = alias.tostring(current string(j))
_imp_strncpy(/*?*/ &ALIAS, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ &ALIAS, ({
__typeof__(_imp_string1) tmp; /*E*/
tmp = _imp_TOSTRING(CURRENTSTRING[J]);
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
});
(void *)&tmp;
}),
/*max:*/ 19);
// 4729 %repeat
goto L_03AD;
}
L_03AE:;
// 4730 pop drop
POPDROP();
// 4731 %continue
goto L_0382;
// 4732 c('N'): cstack(tag<<16!tag); %continue
case_C_78:;
CSTACK(TAG() << 16 | TAG());
goto L_0382;
// 4733 c('D'):
case_C_68:;
// 4734 get d
GETD();
// 4735 cstack(0) %and %continue %if rvalue = 0
if (RVALUE != 0) goto L_03B0;
CSTACK(0);
goto L_0382;
L_03B0:;
// 4736 %continue %if next = 'A'
if (NEXT != 65) goto L_03B1;
goto L_0382;
L_03B1:;
// 4737 otype = con; ! anonymous %const
OTYPE = 2;
// 4738 j = real constant(0); ! N.B. ** %fn + side-effect **
J = REALCONSTANT(0);
// 4739 sset(code,j,v in s,0); rhs_type = reals
SSET(15, J, 4, 0);
RHS->TYPE = 7;
// 4740 %continue
goto L_0382;
// 4741
// 4742 c('n'):
case_C_110:;
// 4743 j = tag; set lhs
J = TAG();
SETLHS();
// 4744 vstack( var(lhs_format)_extra - j )
VSTACK(VAR[LHS->FORMAT].EXTRA - J);
// 4745 set both; stp = stp-1
SETBOTH();
STP = STP - 1;
// 4746 %if rhs_form # 15 %start; ! not record format
if (RHS->FORM == 15) goto L_03B2;
// 4747 %if lhs_form = v in s %or lhs_form = VinRec %start
if (LHS->FORM == 4) goto L_03A0;
if (LHS->FORM != 7) goto L_03B3;
L_03A0:;
// 4748 rhs_disp = lhs_disp + rhs_disp
RHS->DISP = LHS->DISP + RHS->DISP;
// 4749 lhs_xform = lhs_form - v in s + rhs_xform
LHS->XFORM = LHS->FORM - 4 + RHS->XFORM;
// 4750 %else
goto L_03B4;
L_03B3:;
// 4751 %if lhs_form = a in rec %start
if (LHS->FORM != 9) goto L_03B5;
// 4752 lhs_form = VinRec; lhs_type = integers
LHS->FORM = 7;
LHS->TYPE = 1;
// 4753 load(lhs,any)
LOAD(LHS, 25);
// 4754 lhs_xform = rhs_xform
LHS->XFORM = RHS->XFORM;
// 4755 %else
goto L_03B6;
L_03B5:;
// 4756 %if lhs_form <= VinR %start
if (LHS->FORM > 1) goto L_03B7;
// 4757 lhs_xform = rhs_xform; ! ????
LHS->XFORM = RHS->XFORM;
// 4758 %else
goto L_03B8;
L_03B7:;
// 4759 lhs_extra = lhs_disp
LHS->EXTRA = LHS->DISP;
// 4760 lhs_xform = rhs_xform+3
LHS->XFORM = RHS->XFORM + 3;
// 4761 %finish
L_03B8:;
// 4762 %finish
L_03B6:;
// 4763 %finish
L_03B4:;
// 4764 lhs_disp = rhs_disp
LHS->DISP = RHS->DISP;
// 4765 lhs_type = rhs_type
LHS->TYPE = RHS->TYPE;
// 4766 lhs_rt = rhs_rt
LHS->RT = RHS->RT;
// 4767 lhs_header = rhs_header
LHS->HEADER = RHS->HEADER;
// 4768 %finish
L_03B2:;
// 4769 lhs_length = rhs_length; lhs_format = rhs_format
LHS->LENGTH = RHS->LENGTH;
LHS->FORMAT = RHS->FORMAT;
// 4770 lhs_dim = rhs_dim
LHS->DIM = RHS->DIM;
// 4771 drop(rhs)
DROP(RHS);
// 4772 %continue
goto L_0382;
// 4773
// 4774 c('@'):
case_C_64:;
// 4775 vstack(tag)
VSTACK(TAG());
// 4776 %if lhs_flag & proc bit # 0 %and next # 'p' %c
if (LHS->FLAG & 16 == 0) goto L_03B9;
if (NEXT == 112) goto L_03B9;
if (LHS->FLAG & 4 != 0) goto L_03B9;
// 4777+ %and lhs_flag&prim bit = 0 %start
// 4778 lhs_rt = p disp
LHS->RT = PDISP;
// 4779 lhs_header = wdisp
LHS->HEADER = WDISP;
// 4780 w disp = (p disp+align)&(\align)
WDISP = PDISP + 3 & (~3);
// 4781 p disp = 0
PDISP = 0;
// 4782 %finish
L_03B9:;
// 4783 %continue
goto L_0382;
// 4784 c('E'):
case_C_69:;
// 4785 pop lhs; x == lhs
POPLHS();
X = (struct STACKFM *)LHS;
// 4786 load params(x_link)
LOADPARAMS(X->LINK);
// 4787 call(x)
CALL(X);
// 4788 %if x_type # 0 %and sym # 0 %start; ! fn/map - SYM=0: see 'CALL'!?!?!?!?
if (X->TYPE == 0) goto L_03BA;
if (SYM == 0) goto L_03BA;
// 4789 sstack(x); drop(x); set lhs
SSTACK(X);
DROP(X);
SETLHS();
// 4790 %if lhs_type >= reals %then opr = fr0 %else opr = r1
if (LHS->TYPE < 7) goto L_03BB;
OPR = 17;
goto L_03BC;
L_03BB:;
OPR = 2;
L_03BC:;
// 4791 lhs_base = opr; lhs_disp = 0
LHS->BASE = OPR;
LHS->DISP = 0;
// 4792 claim(opr)
CLAIM(OPR);
// 4793 %if lhs_form = VinR %c
if (LHS->FORM != 1) goto L_03BD;
if (LHS->TYPE == 5) goto L_03BE;
if (LHS->TYPE != 6) goto L_03BD;
L_03BE:;
// 4794+ %and (lhs_type = strings %or lhs_type = records) %start
// 4795 lhs_base = R1; lhs_form = V in S
LHS->BASE = 2;
LHS->FORM = 4;
// 4796 %if next # 'S' %and next # 'p' %and next # '?' %start
if (NEXT == 83) goto L_03BF;
if (NEXT == 112) goto L_03BF;
if (NEXT == 63) goto L_03BF;
// 4797 %if lhs_type = strings %start
if (LHS->TYPE != 5) goto L_03C0;
// 4798 n = 256; lhs_length = 255
N = 256;
LHS->LENGTH = 255;
// 4799 %else
goto L_03C1;
L_03C0:;
// 4800 n = var(lhs_format)_length
N = VAR[LHS->FORMAT].LENGTH;
// 4801 %finish
L_03C1:;
// 4802 pdisp = basic frame %if pdisp = 0
if (PDISP != 0) goto L_03C2;
PDISP = 44;
L_03C2:;
// 4803 lhs_base = wsp; lhs_disp = pdisp
LHS->BASE = 8;
LHS->DISP = PDISP;
// 4804 sstack(lhs); ! a copy for 'ASSIGN' below
SSTACK(LHS);
// 4805 sset(r1,0,V in S,0); ! N.B. sets RHS implicitly
SSET(2, 0, 4, 0);
// 4806 %if lhs_type = strings %start
if (LHS->TYPE != 5) goto L_03C3;
// 4807 rhs_type = strings
RHS->TYPE = 5;
// 4808 %else
goto L_03C4;
L_03C3:;
// 4809 rhs_type = records; rhs_format = lhs_format
RHS->TYPE = 6;
RHS->FORMAT = LHS->FORMAT;
// 4810 %finish
L_03C4:;
// 4811 assign(1)
ASSIGN(1);
// 4812 pdisp = pdisp + n; ! protect stacked temporary
PDISP = PDISP + N;
// 4813 lhs_type = 0 %if lhs_type = strings
if (LHS->TYPE != 5) goto L_03C5;
LHS->TYPE = 0;
L_03C5:;
// 4814 %finish
L_03BF:;
// 4815 %finish
L_03BD:;
// 4816 %finish
L_03BA:;
// 4817 %continue
goto L_0382;
// 4818
// 4819 c('M'):
case_C_77:;
// 4820 c('V'):
case_C_86:;
// 4821 set lhs
SETLHS();
// 4822 opr = r1
OPR = 2;
// 4823 %if sym = 'V' %start
if (SYM != 86) goto L_03C6;
// 4824 %if gvar_type >= reals %start
if (GVAR->TYPE < 7) goto L_03C7;
// 4825 opr = FR0
OPR = 17;
// 4826 %else %if gvar_type = records %and zero(lhs); ! recordfn result = 0
goto L_03C8;
L_03C7:;
if (GVAR->TYPE != 6) goto L_03C9;
if (!(ZERO(LHS))) goto L_03C9;
// 4827 lhs_type = records; lhs_form = V in S
LHS->TYPE = 6;
LHS->FORM = 4;
// 4828 lhs_base = wsp; lhs_disp = 0
LHS->BASE = 8;
LHS->DISP = 0;
// 4829 lhs_format = gvar_format
LHS->FORMAT = GVAR->FORMAT;
// 4830 sstack(lhs); ! duplicate
SSTACK(LHS);
// 4831 cstack(0)
CSTACK(0);
// 4832 assign(1); ! construct zero record
ASSIGN(1);
// 4833 set lhs
SETLHS();
// 4834 %finish
L_03C9:;
L_03C8:;
// 4835 %else
goto L_03CA;
L_03C6:;
// 4836 amaps(lhs)
AMAPS(LHS);
// 4837 %finish
L_03CA:;
// 4838 lrd(lhs,opr); stp = stp-1
LRD(LHS, OPR);
STP = STP - 1;
// 4839 %if sym = 'V' %start
if (SYM != 86) goto L_03CB;
// 4840 %if gvar_type = strings %and gvar_length > 0 %start
if (GVAR->TYPE != 5) goto L_03CC;
if (GVAR->LENGTH <= 0) goto L_03CC;
// 4841 cload(gvar_length,r0)
CLOAD(GVAR->LENGTH, 1);
// 4842 perm(sfcap); ! string function capacity
PERM(11);
// 4843 %else %if control & check capacity # 0
goto L_03CD;
L_03CC:;
if (CONTROL & 1 == 0) goto L_03CE;
// 4844 %if gvar_type = short %start
if (GVAR->TYPE != 2) goto L_03CF;
// 4845 claim(opr); rr(CHVR,opr,opr)
CLAIM(OPR);
RR(30, OPR, OPR);
// 4846 perm(cap16)
PERM(22);
// 4847 %else %if gvar_type = byte
goto L_03D0;
L_03CF:;
if (GVAR->TYPE != 3) goto L_03D1;
// 4848 rxi(TEST,opr,0,\255)
RXI(36, OPR, 0, (~255));
// 4849 perm(cap8)
PERM(23);
// 4850 %finish
L_03D1:;
L_03D0:;
// 4851 %finish
L_03CE:;
L_03CD:;
// 4852 %finish
L_03CB:;
// 4853 c('R'):
case_C_82:;
// 4854 return
RETURN();
// 4855 %continue
goto L_0382;
// 4856 c('K'): ! %false
case_C_75:;
// 4857 k = 0; -> true false
K = 0;
goto U_1014;
// 4858 c('T'): ! %true
case_C_84:;
// 4859 k = -1
K = -1;
// 4860 true false:
U_1014:;
// 4861 cload(k,r1)
CLOAD(K, 2);
// 4862 return
RETURN();
// 4863 %continue
goto L_0382;
// 4864
// 4865 c('a'): array ref(0); %continue
case_C_97:;
ARRAYREF(0);
goto L_0382;
// 4866 c('i'): array ref(1); %continue
case_C_105:;
ARRAYREF(1);
goto L_0382;
// 4867 c('.'): operate(conc); %continue
case_C_46:;
OPERATE(7);
goto L_0382;
// 4868 c('+'): operate(add); %continue
case_C_43:;
OPERATE(3);
goto L_0382;
// 4869 c('\'): k = -1; -> not neg; ! NOT
case_C_92:;
K = -1;
goto U_1015;
// 4870 c('U'): k = 0; ! NEG
case_C_85:;
K = 0;
// 4871 not neg:
U_1015:;
// 4872 pop lhs; cstack(k); sstack(lhs); drop(lhs)
POPLHS();
CSTACK(K);
SSTACK(LHS);
DROP(LHS);
// 4873 c('-'): operate(sub); %continue
case_C_45:;
OPERATE(4);
goto L_0382;
// 4874 c('!'): operate(or); %continue
case_C_33:;
OPERATE(9);
goto L_0382;
// 4875 c('%'): operate(xor); %continue
case_C_37:;
OPERATE(10);
goto L_0382;
// 4876 c('&'): operate(and); %continue
case_C_38:;
OPERATE(8);
goto L_0382;
// 4877 c('['): operate(lsh); %continue
case_C_91:;
OPERATE(11);
goto L_0382;
// 4878 c(']'): operate(rsh); %continue
case_C_93:;
OPERATE(12);
goto L_0382;
// 4879 c('*'): operate(mul); %continue
case_C_42:;
OPERATE(5);
goto L_0382;
// 4880 c('/'): operate(div); %continue
case_C_47:;
OPERATE(6);
goto L_0382;
// 4881 c('Q'): operate(rdiv); %continue
case_C_81:;
OPERATE(17);
goto L_0382;
// 4882 c('X'): operate(exp); %continue
case_C_88:;
OPERATE(15);
goto L_0382;
// 4883 c('x'): operate(rexp); %continue
case_C_120:;
OPERATE(16);
goto L_0382;
// 4884
// 4885 c('v'):
case_C_118:;
// 4886 set lhs
SETLHS();
// 4887 %if floating(lhs) %start
if (!(FLOATING(LHS))) goto L_03D2;
// 4888 load(lhs,anyf); opr = fpr
LOAD(LHS, 26);
OPR = FPR();
// 4889 %else
goto L_03D3;
L_03D2:;
// 4890 load(lhs,any); opr = gpr
LOAD(LHS, 25);
OPR = GPR();
// 4891 %finish
L_03D3:;
// 4892 pop lhs
POPLHS();
// 4893 k = lhs_base
K = LHS->BASE;
// 4894 load(lhs,opr)
LOAD(LHS, OPR);
// 4895 n = new tag
N = NEWTAG();
// 4896 jump to(n,greater or equal,internal tag)
JUMPTO(N, 5, -1);
// 4897 cstack(0); sstack(lhs); drop(lhs)
CSTACK(0);
SSTACK(LHS);
DROP(LHS);
// 4898 operate(sub)
OPERATE(4);
// 4899 set lhs; load(lhs,k)
SETLHS();
LOAD(LHS, K);
// 4900 define tag(n)
DEFINETAG(N);
// 4901 %continue
goto L_0382;
// 4902
// 4903 c('j'): assign(2); %continue
case_C_106:;
ASSIGN(2);
goto L_0382;
// 4904 c('S'): assign(1); %continue
case_C_83:;
ASSIGN(1);
goto L_0382;
// 4905 c('Z'): assign(0); %continue
case_C_90:;
ASSIGN(0);
goto L_0382;
// 4906 c('p'): assign(-1); %continue
case_C_112:;
ASSIGN(-1);
goto L_0382;
// 4907
// 4908 c('u'): !++
case_C_117:;
// 4909 c('q'): !--
case_C_113:;
// 4910 %if sym = 'u' %then k = add %else k = sub
if (SYM != 117) goto L_03D4;
K = 3;
goto L_03D5;
L_03D4:;
K = 4;
L_03D5:;
// 4911 set both
SETBOTH();
// 4912 t = lhs_type; j = lhs_length
T = LHS->TYPE;
J = LHS->LENGTH;
// 4913 j = j+1 %if t = strings
if (T != 5) goto L_03D6;
J = J + 1;
L_03D6:;
// 4914 amap(lhs)
AMAP(LHS);
// 4915 abort(m'AM05') %if j = 0
if (J != 0) goto L_03D7;
ABORT(1095577653);
L_03D7:;
// 4916 %if j = 2 %start
if (J != 2) goto L_03D8;
// 4917 cstack(1); j = lsh
CSTACK(1);
J = 11;
// 4918 %else %if j = 4
goto L_03D9;
L_03D8:;
if (J != 4) goto L_03DA;
// 4919 cstack(2); j = lsh
CSTACK(2);
J = 11;
// 4920 %else
goto L_03D9;
L_03DA:;
// 4921 cstack(j); j = mul
CSTACK(J);
J = 5;
// 4922 %finish
L_03D9:;
// 4923 operate(j)
OPERATE(J);
// 4924 operate(k)
OPERATE(K);
// 4925 set lhs
SETLHS();
// 4926 vmap(lhs); lhs_type = t
VMAP(LHS);
LHS->TYPE = T;
// 4927 %continue
goto L_0382;
// 4928
// 4929 c('='):
case_C_61:;
// 4930 c('k'): opr = 0; -> cond
case_C_107:;
OPR = 0;
goto U_1016;
// 4931 c('#'):
case_C_35:;
// 4932 c('t'): opr = 1; -> cond
case_C_116:;
OPR = 1;
goto U_1016;
// 4933 c('<'): opr = 2; -> cond
case_C_60:;
OPR = 2;
goto U_1016;
// 4934 c('>'): opr = 3; -> cond
case_C_62:;
OPR = 3;
goto U_1016;
// 4935 c('('): opr = 4; -> cond
case_C_40:;
OPR = 4;
goto U_1016;
// 4936 c(')'): opr = 5; -> cond
case_C_41:;
OPR = 5;
goto U_1016;
// 4937 cond:
U_1016:;
// 4938 val = tag
VAL = TAG();
// 4939 jump to(val,opr+invert,redefine old); invert = 0
JUMPTO(VAL, OPR + INVERT, 1);
INVERT = 0;
// 4940 %continue
goto L_0382;
// 4941
// 4942 c('C'):
case_C_67:;
// 4943 set both
SETBOTH();
// 4944 t = lhs_type
T = LHS->TYPE;
// 4945 amap(lhs); amap(rhs)
AMAP(LHS);
AMAP(RHS);
// 4946 %if t = strings %and (lhs_form = V in S %or lhs_form = VinREC %c
if (T != 5) goto L_03DB;
if (LHS->FORM == 4) goto L_03AF;
if (LHS->FORM == 7) goto L_03AF;
if (RHS->FORM == 4) goto L_03AF;
if (RHS->FORM != 7) goto L_03DB;
L_03AF:;
// 4947+ %or rhs_form = V in S %or rhs_form = VinREC) %start
// 4948 operate(xor)
OPERATE(10);
// 4949 cstack(8); operate(lsh)
CSTACK(8);
OPERATE(11);
// 4950 cstack(0)
CSTACK(0);
// 4951 %finish
L_03DB:;
// 4952 c('?'):
case_C_63:;
// 4953 set both
SETBOTH();
// 4954 compare(lhs,rhs, next); stp = stp-2
COMPARE(LHS, RHS, NEXT);
STP = STP - 2;
// 4955 drop(lhs); drop(rhs)
DROP(LHS);
DROP(RHS);
// 4956 %continue
goto L_0382;
// 4957 c('"'):
case_C_34:;
// 4958 set both; invert = 16
SETBOTH();
INVERT = 16;
// 4959 compare(rhs,lhs, next)
COMPARE(RHS, LHS, NEXT);
// 4960 stp = stp-1; lhs = rhs; drop(rhs)
STP = STP - 1;
*LHS = *RHS;
DROP(RHS);
// 4961 claim(lhs_base)
CLAIM(LHS->BASE);
// 4962 %continue
goto L_0382;
// 4963
// 4964 c('r'): resolve(tag); %continue
case_C_114:;
RESOLVE(TAG());
goto L_0382;
// 4965 c('_'):
case_C_95:;
// 4966 uncond jump = 0; mark assigned = 0
UNCONDJUMP = 0;
MARKASSIGNED = 0;
// 4967 forget all
FORGETALL();
// 4968 v == var(tag); pop drop
V = (struct VARFM *)/*?*/ &VAR[TAG()];
POPDROP();
// 4969 j = lhs_disp - v_extra; ! this label - lower bound
J = LHS->DISP - V->EXTRA;
// 4970 abort(m'AM10') %unless 0 <= j < v_length; ! within vector ?
{
// Double-sided test on J (Part I)
int tmp;
if (0 > (tmp = J)) goto L_03DC;
// Double-sided test on J (Part II)
if (tmp < V->LENGTH) goto L_03DD;
}
L_03DC:;
ABORT(1095577904);
L_03DD:;
// 4971 define tag((v_format + j)!x'8000'); ! N.B. marked as a switch defn.
DEFINETAG(V->FORMAT + J | 32768);
// 4972 %continue
goto L_0382;
// 4973 c('W'):
case_C_87:;
// 4974 v == var(tag)
V = (struct VARFM *)/*?*/ &VAR[TAG()];
// 4975 %if control & trusted = 0 %start; ! checked switch via PERM
if (CONTROL & 32 != 0) goto L_03DE;
// 4976 pop lhs
POPLHS();
// 4977 lrd(lhs,r1)
LRD(LHS, 2);
// 4978 rxi(lw,r2,code,v_disp)
RXI(1, 3, 15, V->DISP);
// 4979 perm(swjump)
PERM(19);
// 4980 %else
goto L_03DF;
L_03DE:;
// 4981 cstack(1); operate(lsh); ! subscript X 2
CSTACK(1);
OPERATE(11);
// 4982 pop lhs
POPLHS();
// 4983 k = v_disp+2*2-v_extra*2
K = V->DISP + 2 * 2 - V->EXTRA * 2;
// 4984 %if const(lhs) %start
if (!(CONST(LHS))) goto L_03E0;
// 4985 k = k+lhs_disp
K = K + LHS->DISP;
// 4986 j = 0
J = 0;
// 4987 %else
goto L_03E1;
L_03E0:;
// 4988 load(lhs, Any)
LOAD(LHS, 25);
// 4989 j = Lhs_Base
J = LHS->BASE;
// 4990 %finish
L_03E1:;
// 4991 lhs_base = code; lhs_index = j; lhs_disp = k
LHS->BASE = 15;
LHS->INDEX = J;
LHS->DISP = K;
// 4992 lhs_type = short; lhs_form = V in S
LHS->TYPE = 2;
LHS->FORM = 4;
// 4993 rxd(LHL,r1,lhs); claim(r1)
RXD(37, 2, LHS);
CLAIM(2);
// 4994 drop(lhs)
DROP(LHS);
// 4995 rr(ADD,r1,r1); claim(r1)
RR(3, 2, 2);
CLAIM(2);
// 4996 rr(ADD,r1,code)
RR(3, 2, 15);
// 4997 rr(JMP,always,r1)
RR(21, 1, 2);
// 4998 %finish
L_03DF:;
// 4999 uncond jump = ca
UNCONDJUMP = CA;
// 5000 %continue
goto L_0382;
// 5001 c('B'):
case_C_66:;
// 5002 val = tag
VAL = TAG();
// 5003 %if val # for_lab %start; ! not %for .... %repeat
if (VAL == FOR->LAB) goto L_03E2;
// 5004 jump to(val,jump,define new)
JUMPTO(VAL, 12, 0);
// 5005 %else
goto L_03E3;
L_03E2:;
// 5006 sset(for_cvbase,for_cvdisp,for_cvform,0)
SSET(FOR->CVBASE, FOR->CVDISP, FOR->CVFORM, 0);
// 5007 hazard(for_reg)
HAZARD(FOR->REG);
// 5008 pop lhs
POPLHS();
// 5009 lhs_type = for_cvtype; lhs_flag = lhs_flag ! assigned
LHS->TYPE = FOR->CVTYPE;
LHS->FLAG = LHS->FLAG | 8;
// 5010 lrd(lhs,for_reg)
LRD(LHS, FOR->REG);
// 5011 %if for_shadow >= 0 %start
if (FOR->SHADOW < 0) goto L_03E4;
// 5012 rx(clw,for_reg,local,for_shadow)
RX(28, FOR->REG, LOCAL, FOR->SHADOW);
// 5013 perm(fchk2)
PERM(25);
// 5014 %finish
L_03E4:;
// 5015 %if for_initial # 0 %start
if (FOR->INITIAL == 0) goto L_03E5;
// 5016 define label(for_initial); for_initial = 0
DEFINELABEL(FOR->INITIAL);
FOR->INITIAL = 0;
// 5017 %finish
L_03E5:;
// 5018 %if for_fvbase = 0 %start; ! constant
if (FOR->FVBASE != 0) goto L_03E6;
// 5019 %if for_fvdisp = 0 %start; ! zero
if (FOR->FVDISP != 0) goto L_03E7;
// 5020 claim(for_reg); rr(lw,for_reg,for_reg)
CLAIM(FOR->REG);
RR(1, FOR->REG, FOR->REG);
// 5021 %else
goto L_03E8;
L_03E7:;
// 5022 rxi(clw,for_reg,for_fvbase,for_fvdisp)
RXI(28, FOR->REG, FOR->FVBASE, FOR->FVDISP);
// 5023 %finish
L_03E8:;
// 5024 %else
goto L_03E9;
L_03E6:;
// 5025 rx(clw,for_reg,for_fvbase,for_fvdisp)
RX(28, FOR->REG, FOR->FVBASE, FOR->FVDISP);
// 5026 %finish
L_03E9:;
// 5027 jump to(val,not equal,define new)
JUMPTO(VAL, 1, 0);
// 5028 abort(m'AM15') %if next # ':'
if (NEXT == 58) goto L_03EA;
ABORT(1095577909);
L_03EA:;
// 5029 read symbol(next); define label(tag)
_imp_READSYMBOL(/*?*/ &NEXT);
DEFINELABEL(TAG());
// 5030 %if for_shadow >= 0 %start
if (FOR->SHADOW < 0) goto L_03EB;
// 5031 %if level # 5 %start
if (LEVEL == 5) goto L_03EC;
// 5032 rx(st,r12,local,for_shadow)
RX(2, 13, LOCAL, FOR->SHADOW);
// 5033 %else
goto L_03ED;
L_03EC:;
// 5034 rx(lw,for_reg,code,unass)
RX(1, FOR->REG, 15, 12);
// 5035 rx(st,for_reg,local,for_shadow)
RX(2, FOR->REG, LOCAL, FOR->SHADOW);
// 5036 forget reg(1<<for_reg)
FORGETREG(1 << FOR->REG);
// 5037 %finish
L_03ED:;
// 5038 %finish
L_03EB:;
// 5039 temp base = for_temp base; ! unprotect shadow, FV, INC
TEMPBASE = FOR->TEMPBASE;
// 5040 for stp = for stp-1; abort(m'AM20') %if for stp < 0
FORSTP = FORSTP - 1;
if (FORSTP >= 0) goto L_03EE;
ABORT(1095578160);
L_03EE:;
// 5041 for == for stk(for stp)
FOR = (struct CYCLEFM *)/*?*/ &FORSTK[FORSTP];
// 5042 %finish
L_03E3:;
// 5043 %continue
goto L_0382;
// 5044 c('F'):
case_C_70:;
// 5045 val = tag; abort(m'AM25') %if val >= for lab base
VAL = TAG();
if (VAL < 8000) goto L_03EF;
ABORT(1095578165);
L_03EF:;
// 5046 jump to(val,jump,redefine old)
JUMPTO(VAL, 12, 1);
// 5047 %continue
goto L_0382;
// 5048
// 5049 %integerfn user label(%integer lab)
int USERLABEL(int LAB) {
// 5050 %record(varfm)%name v
struct VARFM *V;
// 5051 %if lab > names %start
if (LAB <= NAMES) goto L_03F0;
// 5052 names = lab
NAMES = LAB;
// 5053 v == var(lab)
V = (struct VARFM *)/*?*/ &VAR[LAB];
// 5054 v = 0
*V = (struct VARFM){0};
// 5055 v_form = pgm label
V->FORM = 14;
// 5056 v_disp = new tag
V->DISP = NEWTAG();
// 5057 %result = -v_disp
return -V->DISP;
// 5058 %finish
L_03F0:;
// 5059 %result = -var(lab)_disp
return -VAR[LAB].DISP;
// 5060 %end
} /* end of USERLABEL */
// 5061 c('J'):
case_C_74:;
// 5062 jump to(user label(tag),jump,define new)
JUMPTO(USERLABEL(TAG()), 12, 0);
// 5063 %continue
goto L_0382;
// 5064 c('L'):
case_C_76:;
// 5065 define label(user label(tag))
DEFINELABEL(USERLABEL(TAG()));
// 5066 %continue
goto L_0382;
// 5067 c(':'):
case_C_58:;
// 5068 j = tag; abort(m'AM30') %if j >= for lab base
J = TAG();
if (J < 8000) goto L_03F1;
ABORT(1095578416);
L_03F1:;
// 5069 define label(j); %continue
DEFINELABEL(J);
goto L_0382;
// 5070 c('f'):
case_C_102:;
// 5071 compile for; %continue
COMPILEFOR();
goto L_0382;
// 5072 c('w'): mark assigned = 0; machine code; forget reg(-1); %continue
case_C_119:;
MARKASSIGNED = 0;
MACHINECODE();
FORGETREG(-1);
goto L_0382;
// 5073 c('P'):
case_C_80:;
// 5074 pop drop; cput(lhs_disp); forget reg(-1)
POPDROP();
CPUT(LHS->DISP);
FORGETREG(-1);
// 5075 %continue
goto L_0382;
// 5076 c('y'): ! %diagnose n
case_C_121:;
// 5077 j = tag
J = TAG();
// 5078 diagnose = 0
DIAGNOSE = 0;
// 5079 %if (j>>14)&3 = 2 %start; ! it's for pass 2
if ((unsigned int)J >> 14 & 3 != 2) goto L_03F2;
// 5080 diagnose = j&x'3FFF'
DIAGNOSE = J & 16383;
// 5081 diagnose = diagnose ! ((-1)<<15) %if diagnose&4 # 0; ! only for speed
if (DIAGNOSE & 4 == 0) goto L_03F3;
DIAGNOSE = DIAGNOSE | (-1) << 15;
L_03F3:;
// 5082 %else
goto L_03F4;
L_03F2:;
// 5083 !***** should pass onto next pass ******
// 5084 %finish
L_03F4:;
// 5085 %continue
goto L_0382;
// 5086 c('z'):
case_C_122:;
// 5087 control = tag; %continue
CONTROL = TAG();
goto L_0382;
// 5088 c('m'):
case_C_109:;
// 5089 j = -1; -> SIGNAL EVENT
J = -1;
goto U_1013;
// 5090 c('s'):
case_C_115:;
// 5091 %if control&trace # 0 %start
if (CONTROL & 64 == 0) goto L_03F5;
// 5092 perm(enter trace); cput(0); ! close off user-supplied routine
PERM(50);
CPUT(0);
// 5093 %finish
L_03F5:;
// 5094 j = 0; -> SIGNAL EVENT
J = 0;
goto U_1013;
// 5095 c('e'):
case_C_101:;
// 5096 j = tag
J = TAG();
// 5097 SIGNAL EVENT:
U_1013:;
// 5098 cstack(0) %while stp < 2
L_03F6:;
if (STP >= 2) goto L_03F7;
CSTACK(0);
goto L_03F6;
L_03F7:;
// 5099 pop lhs; lrd(lhs,r2)
POPLHS();
LRD(LHS, 3);
// 5100 pop lhs; lrd(lhs,r1)
POPLHS();
LRD(LHS, 2);
// 5101 cload(j,R0)
CLOAD(J, 1);
// 5102 perm(signal)
PERM(20);
// 5103 uncond jump = ca
UNCONDJUMP = CA;
// 5104 %continue
goto L_0382;
// 5105 c('o'):
case_C_111:;
// 5106 event_events = tag; ! events trapped
EVENT.EVENTS = TAG();
// 5107 read symbol(next); k = tag
_imp_READSYMBOL(/*?*/ &NEXT);
K = TAG();
// 5108 j = (frame+align)&(\align); frame = j+reglen
J = FRAME + 3 & (~3);
FRAME = J + 4;
// 5109 rx(ST,wsp,local,j); ! for use below
RX(2, 8, LOCAL, J);
// 5110 jump to(k,jump,redefine old); event_low = j tag; ! skip event body
JUMPTO(K, 12, 1);
EVENT.LOW = JTAG;
// 5111 forget all
FORGETALL();
// 5112 event_label = new tag
EVENT.LABEL = NEWTAG();
// 5113 define tag(event_label); ! entry point
DEFINETAG(EVENT.LABEL);
// 5114 rx(LW,wsp,local,j)
RX(1, 8, LOCAL, J);
// 5115 %continue
goto L_0382;
// 5116 c('h'): ! compiler op(n)
case_C_104:;
// 5117 compiler op(tag)
COMPILEROP(TAG());
// 5118 %continue
goto L_0382;
// 5119 c('g'): !array formats
case_C_103:;
// 5120 c('d'):
case_C_100:;
// 5121 ! array allocation and dope vector dumping.
// 5122 Allocate = Sym-'g' {0=format}
ALLOCATE = SYM - 103;
// 5123 ! GMODE: =0 -> simple array, # 0 -> array-in-record
// 5124 ! When OPT is specified, in-line code is dumped to
// 5125 ! allocate 1-D constant-bounded arrays
// 5126 dim = tag; abort(m'AM35') %unless 0 < dim <= 7
DIM = TAG();
{
// Double-sided test on DIM (Part I)
int tmp;
if (0 >= (tmp = DIM)) goto L_03F8;
// Double-sided test on DIM (Part II)
if (tmp <= 7) goto L_03F9;
}
L_03F8:;
ABORT(1095578421);
L_03F9:;
// 5127 read symbol(next); n = tag
_imp_READSYMBOL(/*?*/ &NEXT);
N = TAG();
// 5128 %if gmode = 0 %then names = names-n %else parms = parms+n
if (GMODE != 0) goto L_03FA;
NAMES = NAMES - N;
goto L_03FB;
L_03FA:;
PARMS = PARMS + N;
L_03FB:;
// 5129 set both
SETBOTH();
// 5130 dv = 0; ! used as a flag subsequently
DV = 0;
// 5131 t = -1
T = -1;
// 5132 ! **** The test for OPT must come out once this optimisation is
// 5133 ! implemented correctly ****
// 5134 %if control&checkbits=0 %and dim = 1 %and lhs_disp <= rhs_disp+1 %start
if (CONTROL & 23 != 0) goto L_03FC;
if (DIM != 1) goto L_03FC;
if (LHS->DISP > RHS->DISP + 1) goto L_03FC;
// 5135 %if const(rhs) %and const(lhs) %start
if (!(CONST(RHS))) goto L_03FD;
if (!(CONST(LHS))) goto L_03FD;
// 5136 t = 0; ! candidate for cheap allocation at least
T = 0;
// 5137 %if 0 < data size <= 32767 %c
{
// Double-sided test on DATASIZE (Part I)
int tmp;
if (0 >= (tmp = DATASIZE)) goto L_03FE;
// Double-sided test on DATASIZE (Part II)
if (tmp > 32767) goto L_03FE;
}
{
// Double-sided test on LHS->DISP (Part I)
int tmp;
if (-32768 > (tmp = LHS->DISP)) goto L_03FE;
// Double-sided test on LHS->DISP (Part II)
if (tmp > 32767) goto L_03FE;
}
{
// Double-sided test on RHS->DISP (Part I)
int tmp;
if (-32768 > (tmp = RHS->DISP)) goto L_03FE;
// Double-sided test on RHS->DISP (Part II)
if (tmp > 32767) goto L_03FE;
}
// 5138+ %and -32768 <= lhs_disp <= 32767 %c
// 5139+ %and -32768 <= rhs_disp <= 32767 %start
// 5140 dim = dim ! cheap array bit; ! stuffed in below
DIM = DIM | 32;
// 5141 %finish
L_03FE:;
// 5142 %finish
L_03FD:;
// 5143 %finish
L_03FC:;
// 5144 %if gmode # 0 %or t >= 0 %start
if (GMODE != 0) goto L_03FF;
if (T < 0) goto L_0400;
L_03FF:;
// 5145 vlb = lhs_disp; vub = rhs_disp
VLB = LHS->DISP;
VUB = RHS->DISP;
// 5146 abort(m'AM40') %if vlb > vub+1; ! null array, A(1:0) allowed
if (VLB <= VUB + 1) goto L_0401;
ABORT(1095578672);
L_0401:;
// 5147 set dope vector
SETDOPEVECTOR();
// 5148 stp = stp-2; drop(lhs); drop(rhs)
STP = STP - 2;
DROP(LHS);
DROP(RHS);
// 5149 %if gmode = 0 %start; ! constant-bounded 1-D simple array
if (GMODE != 0) goto L_0402;
// 5150 quick load(R4, AVinS, code, dv); release(R4)
QUICKLOAD(5, 5, 15, DV);
RELEASE(5);
// 5151 vub = (vub+align) & (\align); ! to preserve stack-front alignment
VUB = VUB + 3 & (~3);
// 5152 %finish
L_0402:;
// 5153 %else
goto L_0403;
L_0400:;
// 5154 frame = (frame+align)&(\align); k = frame; Frame = Frame+Reglen
FRAME = FRAME + 3 & (~3);
K = FRAME;
FRAME = FRAME + 4;
// 5155 quick load(R4, AVinS, local, K); release(R4)
QUICKLOAD(5, 5, LOCAL, K);
RELEASE(5);
// 5156 stp = 0
STP = 0;
// 5157 %for j = 1,1,dim<<1 %cycle; ! N.B. not changed above on this path
// %for J = 1, 1, DIM << 1 %cycle
{
int _final = DIM << 1;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, DIM << 1");
J = 0;
L_0404:
if (J == _final) goto L_0405;
J += 1;
// 5158 stp = stp+1; set lhs
STP = STP + 1;
SETLHS();
// 5159 claim(r4); lrd(lhs,any)
CLAIM(5);
LRD(LHS, 25);
// 5160 rx(st,lhs_base,r4,frame-k); frame = frame+reglen
RX(2, LHS->BASE, 5, FRAME - K);
FRAME = FRAME + 4;
// 5161 frame = frame+reglen %if j&1 = 0; ! LEAVE HOLE FOR MULTIPLIER
if (J & 1 != 0) goto L_0407;
FRAME = FRAME + 4;
L_0407:;
// 5162 %repeat
goto L_0404;
}
L_0405:;
// 5163 perm(set dv)
PERM(17);
// 5164 cput(dim); cput(data size)
CPUT(DIM);
CPUT(DATASIZE);
// 5165 stp = 0
STP = 0;
// 5166 %finish
L_0403:;
// 5167 %if dv = 0 %start
if (DV != 0) goto L_0408;
// 5168 quick load(R2, AVinS, local, frame)
QUICKLOAD(3, 5, LOCAL, FRAME);
// 5169 release(R2)
RELEASE(3);
// 5170 forget reg(1<<r2)
FORGETREG(1 << 3);
// 5171 %finish
L_0408:;
// 5172 %for j = 1,1,n %cycle
// %for J = 1, 1, N %cycle
{
int _final = N;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, N");
J = 0;
L_0409:
if (J == _final) goto L_040A;
J += 1;
// 5173 %if gmode = 0 %start
if (GMODE != 0) goto L_040C;
// 5174 names = names+1; decvar == var(names)
NAMES = NAMES + 1;
DECVAR = (struct VARFM *)/*?*/ &VAR[NAMES];
// 5175 %else
goto L_040D;
L_040C:;
// 5176 parms = parms-1; decvar == var(parms)
PARMS = PARMS - 1;
DECVAR = (struct VARFM *)/*?*/ &VAR[PARMS];
// 5177 %finish
L_040D:;
// 5178 decvar_disp = frame
DECVAR->DISP = FRAME;
// 5179 decvar_flag = decvar_flag ! dim; ! may also set 'cheap array bit'
DECVAR->FLAG = DECVAR->FLAG | DIM;
// 5180 %if gmode = 0 %start; ! array not in record
if (GMODE != 0) goto L_040E;
// 5181 decvar_header = -1; decvar_base = local
DECVAR->HEADER = -1;
DECVAR->BASE = LOCAL;
// 5182 decvar_flag = decvar_flag ! anbit; ! force arrayname
DECVAR->FLAG = DECVAR->FLAG | 64;
// 5183 %if dv = 0 %start
if (DV != 0) goto L_040F;
// 5184 %if Allocate # 0 %start
if (ALLOCATE == 0) goto L_0410;
// 5185 perm(alloc); ! general method of allocation
PERM(18);
// 5186 %else
goto L_0411;
L_0410:;
// 5187 RX(ST, R4, Local, Frame+Reglen)
RX(2, 5, LOCAL, FRAME + 4);
// 5188 RX(ST, R1, Local, Frame+0)
RX(2, 2, LOCAL, FRAME + 0);
// 5189 %finish
L_0411:;
// 5190 %else
goto L_0412;
L_040F:;
// 5191 ! dope-vector was dumped statically above
// 5192 ! Note that the data area for each array is allocated within
// 5193 ! the high address end of the static frame startingat the top
// 5194 ! and working downwards. Pass3 patches in the displacement req'd
// 5195 ! from 'local'
// 5196 rx(ST,r4,local,frame+reglen); ! @DV
RX(2, 5, LOCAL, FRAME + 4);
// 5197 %if Allocate # 0 %start
if (ALLOCATE == 0) goto L_0413;
// 5198 rxi(LW,r0,wsp,-vlb); ! @A(0) for Jth array
RXI(1, 1, 8, -VLB);
// 5199 rxi(ADD,wsp,0,vub); !****temp fix****
RXI(3, 8, 0, VUB);
// 5200 %else
goto L_0414;
L_0413:;
// 5201 rxi(LW,R0,0,-vlb)
RXI(1, 1, 0, -VLB);
// 5202 %finish
L_0414:;
// 5203 rx(ST,r0,local,frame+0); ! plug into header
RX(2, 1, LOCAL, FRAME + 0);
// 5204 %finish
L_0412:;
// 5205 frame = frame + 2*reglen; ! 2-word header
FRAME = FRAME + 2 * 4;
// 5206 %else; ! array-in-record
goto L_0415;
L_040E:;
// 5207 gfix(align); !*****psr*****
GFIX(3);
// 5208 decvar_header = ga; decvar_base = 0
DECVAR->HEADER = GA;
DECVAR->BASE = 0;
// 5209 gword(-vlb); ! relative to start of array
GWORD(-VLB);
// 5210 gword crel(dv); ! relative to code base
GWORDCREL(DV);
// 5211 frame = frame+vub %if Allocate # 0
if (ALLOCATE == 0) goto L_0416;
FRAME = FRAME + VUB;
L_0416:;
// 5212 %finish
L_0415:;
// 5213 %repeat
goto L_0409;
}
L_040A:;
// 5214 %continue
goto L_0382;
// 5215
// 5216 c('^'): {Set Format}
case_C_94:;
// 5217 Set Lhs
SETLHS();
// 5218 Lhs_Type = Records
LHS->TYPE = 6;
// 5219 Lhs_Format = Tag
LHS->FORMAT = TAG();
// 5220 %continue
goto L_0382;
// 5221
// 5222
// 5223 %routine Temp Set
void TEMPSET(void) {
// 5224 Frame = (Frame+Align)&(\Align)
FRAME = FRAME + 3 & (~3);
// 5225 Sset(Local, Frame, VinS, 0)
SSET(LOCAL, FRAME, 4, 0);
// 5226 Rhs_Type = Records
RHS->TYPE = 6;
// 5227 Rhs_Format = Max Vars
RHS->FORMAT = 800;
// 5228 Frame = Frame+SetLen
FRAME = FRAME + 32;
// 5229 %end
return;
} /* end of TEMPSET */
// 5230
// 5231 c('I'): {ESCAPE for Pascal etc.}
case_C_73:;
// 5232 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 5233 ->Pc(Sym) %if 'A' <= Sym <= 'Z'
{
// Double-sided test on SYM (Part I)
int tmp;
if (65 > (tmp = SYM)) goto L_0417;
// Double-sided test on SYM (Part II)
if (tmp > 90) goto L_0417;
}
PC_line = __LINE__;
PC_file = __FILE__;
PC_index = SYM;
goto case_PC_dispatch;
L_0417:;
// 5234 Abort(M'I ?' - ' '<<8 +Sym<<8)
ABORT(1226842175 - (32 << 8) + (SYM << 8));
// 5235 Pc('A'): {Compare}
case_PC_65:;
// 5236 Pc('D'): {Compare records}
case_PC_68:;
// 5237 Pc('K'): {Test set membership}
case_PC_75:;
// 5238 cload(0, R6); claim(R6)
CLOAD(0, 7);
CLAIM(7);
// 5239 set both
SETBOTH();
// 5240 j = next; readsymbol(next)
J = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 5241 %if Sym = 'A' %start
if (SYM != 65) goto L_0419;
// 5242 %if j <= 1 %then k = '=' %else k = '<'
if (J > 1) goto L_041A;
K = 61;
goto L_041B;
L_041A:;
K = 60;
L_041B:;
// 5243 compare(lhs, rhs, k)
COMPARE(LHS, RHS, K);
// 5244 %else %if Sym = 'K'
goto L_041C;
L_0419:;
if (SYM != 75) goto L_041D;
// 5245 Load(Lhs, Any); Address(Rhs, -1)
LOAD(LHS, 25);
ADDRESS(RHS, -1);
// 5246 Rhs_Type = Integers
RHS->TYPE = 1;
// 5247 Rxd(Tbt, Lhs_Base, Rhs)
RXD(39, LHS->BASE, RHS);
// 5248 Release(Lhs_Base)
RELEASE(LHS->BASE);
// 5249 %else
goto L_041C;
L_041D:;
// 5250 k = next; readsymbol(next)
K = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 5251 Compare Records(Lhs, Rhs, K)
COMPARERECORDS(LHS, RHS, K);
// 5252 %finish
L_041C:;
// 5253 stp = stp-2; drop(lhs); drop(rhs)
STP = STP - 2;
DROP(LHS);
DROP(RHS);
// 5254 skip(1, j+invert); ! short forward jump
SKIP(1, J + INVERT);
// 5255 Invert = 0
INVERT = 0;
// 5256 rxi(ADD, R6, 0, 1); ! reduces to halfword: AIS R6,1
RXI(3, 7, 0, 1);
// 5257 forget reg(1<<r6); CC CA = 0
FORGETREG(1 << 7);
CCCA = 0;
// 5258 sset(R6, 0, VinR, 0)
SSET(7, 0, 1, 0);
// 5259 %continue
goto L_0382;
// 5260
// 5261 Pc('B'): {Create space}
case_PC_66:;
// 5262 sym = next; readsymbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 5263 ownform = array; Owntype = byte
OWNFORM = 11;
OWNTYPE = 3;
// 5264 Claim Literal(Sym, Align)
CLAIMLITERAL(SYM, 3);
// 5265 Select Literal Area
SELECTLITERALAREA();
// 5266 Decvar_Disp = Ca; Decvar_Base = Code
DECVAR->DISP = CA;
DECVAR->BASE = 15;
// 5267 Select Code Area
SELECTCODEAREA();
// 5268 %continue
goto L_0382;
// 5269
// 5270 Pc('C'):
case_PC_67:;
// 5271 ! 'refer to' FORTRAN parameter in CALL
// 5272 ! If parameter is not a simple variable, then store into a
// 5273 ! temporary to make it so. Either way, convert to descriptor for
// 5274 ! address of simple variable for final parameter
// 5275 set lhs
SETLHS();
// 5276 %unless lhs_form = VinS %and lhs_oper = 0 %start
if (LHS->FORM != 4) goto L_040B;
if (LHS->OPER == 0) goto L_041E;
L_040B:;
// 5277 t = any; t = anyf %if floating(lhs)
T = 25;
if (!(FLOATING(LHS))) goto L_041F;
T = 26;
L_041F:;
// 5278 load(lhs,t)
LOAD(LHS, T);
// 5279 hazard(lhs_base); ! force into store temporary
HAZARD(LHS->BASE);
// 5280 %finish
L_041E:;
// 5281 %continue
goto L_0382;
// 5282
// 5283 Pc('I'): {Add to set}
case_PC_73:;
// 5284 Set Both
SETBOTH();
// 5285 Lrd(Rhs, Any)
LRD(RHS, 25);
// 5286 Address(Lhs, -1)
ADDRESS(LHS, -1);
// 5287 Lhs_Type = Integers
LHS->TYPE = 1;
// 5288 Rxd(Sbt, Rhs_base, Lhs); Claim(Lhs_Base)
RXD(40, RHS->BASE, LHS);
CLAIM(LHS->BASE);
// 5289 Lhs_Type = Records
LHS->TYPE = 6;
// 5290 Stp = Stp-1
STP = STP - 1;
// 5291 %continue
goto L_0382;
// 5292
// 5293 Pc('G'): {Make set null}
case_PC_71:;
// 5294 Pc('H'): {assign set}
case_PC_72:;
// 5295 k = Tag %if Sym = 'H'
if (SYM != 72) goto L_0420;
K = TAG();
L_0420:;
// 5296 %if Next # 'S' %start
if (NEXT == 83) goto L_0421;
// 5297 Temp Set
TEMPSET();
// 5298 Sstack(Rhs)
SSTACK(RHS);
// 5299 Rhs_Type = 0 {show it's a temporary}
RHS->TYPE = 0;
// 5300 %else
goto L_0422;
L_0421:;
// 5301 Readsymbol(Next)
_imp_READSYMBOL(/*?*/ &NEXT);
// 5302 %finish
L_0422:;
// 5303 %if Sym = 'G' %then Cstack(0) %else Vstack(k)
if (SYM != 71) goto L_0423;
CSTACK(0);
goto L_0424;
L_0423:;
VSTACK(K);
L_0424:;
// 5304 Assign(1)
ASSIGN(1);
// 5305 %continue
goto L_0382;
// 5306
// 5307 Pc('J'): {Compare sets}
case_PC_74:;
// 5308 Set Both
SETBOTH();
// 5309 Lrd(Lhs, R1)
LRD(LHS, 2);
// 5310 Lrd(Rhs, R2)
LRD(RHS, 3);
// 5311 Perm(Set Comp)
PERM(35);
// 5312 %if Next <= 1 %start {#, =}
if (NEXT > 1) goto L_0425;
// 5313 cput(0)
CPUT(0);
// 5314 %else %if Next = 3 {<=}
goto L_0426;
L_0425:;
if (NEXT != 3) goto L_0427;
// 5315 cput(2)
CPUT(2);
// 5316 %else {Next = 2} {>=}
goto L_0426;
L_0427:;
// 5317 cput(1)
CPUT(1);
// 5318 %finish
L_0426:;
// 5319 Stp = Stp-2
STP = STP - 2;
// 5320 Sset(R6, 0, VinR, 0); Claim(R6)
SSET(7, 0, 1, 0);
CLAIM(7);
// 5321 Rxi(Xor, R6, 0, 1) %if Next = 0 {#}
if (NEXT != 0) goto L_0428;
RXI(10, 7, 0, 1);
L_0428:;
// 5322 Readsymbol(Next)
_imp_READSYMBOL(/*?*/ &NEXT);
// 5323 %continue
goto L_0382;
// 5324
// 5325 Pc('L'): {Set operation}
case_PC_76:;
// 5326 Pop Lhs; X == Lhs
POPLHS();
X = (struct STACKFM *)LHS;
// 5327 Set Lhs
SETLHS();
// 5328 %if Lhs_Type # 0 %start {needs to be made temporary}
if (LHS->TYPE == 0) goto L_0429;
// 5329 Pop Lhs
POPLHS();
// 5330 Temp Set
TEMPSET();
// 5331 Sstack(Lhs); Drop(Lhs)
SSTACK(LHS);
DROP(LHS);
// 5332 Assign(1)
ASSIGN(1);
// 5333 Sset(Local, Frame-SetLen, VinS, 0)
SSET(LOCAL, FRAME - 32, 4, 0);
// 5334 Rhs_Type = 0
RHS->TYPE = 0;
// 5335 Set Lhs
SETLHS();
// 5336 %finish
L_0429:;
// 5337 Load(Lhs, R1)
LOAD(LHS, 2);
// 5338 Lrd(X, R2)
LRD(X, 3);
// 5339 Perm(Set Ops(next)); Readsymbol(Next)
PERM(SETOPS[NEXT - 1]);
_imp_READSYMBOL(/*?*/ &NEXT);
// 5340 %continue
goto L_0382;
// 5341
// 5342 Pc('S'): {Swop top of stack elements}
case_PC_83:;
// 5343 Set Both
SETBOTH();
// 5344 Stacked(Stp-1)_V == RHS
STACKED[STP - 1 - 1].V = (struct SPTFM *)RHS;
// 5345 Stacked(Stp)_V == LHS
STACKED[STP - 1].V = (struct SPTFM *)LHS;
// 5346 %continue
goto L_0382;
// 5347
// 5348 Pc('N'): {check not NIL}
case_PC_78:;
// 5349 %if Control&Check Unass # 0 %start
if (CONTROL & 2 == 0) goto L_042A;
// 5350 Set Lhs; Test Zero(Lhs); Claim(Lhs_Base)
SETLHS();
TESTZERO(LHS);
CLAIM(LHS->BASE);
// 5351 RR(Bal, Link, Code)
RR(22, 16, 15);
// 5352 %finish
L_042A:;
// 5353 %continue
goto L_0382;
// 5354
// 5355 Pc('W'): {Stack WSP}
case_PC_87:;
// 5356 Cstack(0)
CSTACK(0);
// 5357 Rhs_Form = VinR
RHS->FORM = 1;
// 5358 Rhs_Base = Wsp
RHS->BASE = 8;
// 5359 %continue
goto L_0382;
// 5360
// 5361 c('~'): ! alternate record format
case_C_126:;
// 5362 sym = next; read symbol(next)
SYM = NEXT;
_imp_READSYMBOL(/*?*/ &NEXT);
// 5363 %if sym = 'A' %start; ! alt start
if (SYM != 65) goto L_042B;
// 5364 decvar == gvar
DECVAR = (struct VARFM *)GVAR;
// 5365 assemble(-2,labs,names)
ASSEMBLE(-2, LABS, NAMES);
// 5366 Alt Align = Alt Align!Falign
ALTALIGN = ALTALIGN | FALIGN;
// 5367 %else %if sym = 'B'; ! alt end
goto L_042C;
L_042B:;
if (SYM != 66) goto L_042D;
// 5368 -> OUT
goto U_100D;
// 5369 %else
L_042D:;
// 5370 abort(m'AM45') %if sym # 'C'; ! faulty intermediate code
if (SYM == 67) goto L_042E;
ABORT(1095578677);
L_042E:;
// 5371 max frame = frame %if frame > max frame
if (FRAME <= MAXFRAME) goto L_042F;
MAXFRAME = FRAME;
L_042F:;
// 5372 frame = putative frame base
FRAME = PUTATIVEFRAMEBASE;
// 5373 %finish
L_042C:;
// 5374 %continue
goto L_0382;
// 5375 c('{'):
case_C_123:;
// 5376 gmode = -1
GMODE = -1;
// 5377 assemble(gtype,labs,names)
ASSEMBLE(GTYPE, LABS, NAMES);
// 5378 %continue
goto L_0382;
// 5379 c('}'):
case_C_125:;
// 5380 gmode = 0
GMODE = 0;
// 5381 -> OUT %if amode < 0; ! end of %record %format defn.
if (AMODE >= 0) goto L_0430;
goto U_100D;
L_0430:;
// 5382 -> OUT %if gvar_flag & primbit # 0; ! prim routine reference
if (GVAR->FLAG & 4 == 0) goto L_0431;
goto U_100D;
L_0431:;
// 5383 %if names > gstart %start
if (NAMES <= GSTART) goto L_0432;
// 5384 gvar_extra = parms
GVAR->EXTRA = PARMS;
// 5385 %for j = gstart+1,1,names %cycle
// %for J = 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 J = GSTART + 1, 1, NAMES");
J = _initial - (1);
L_0433:
if (J == _final) goto L_0434;
J += 1;
// 5386 ap == var(j)
AP = (struct VARFM *)/*?*/ &VAR[J];
// 5387 parms = parms-1; fp == var(parms)
PARMS = PARMS - 1;
FP = (struct VARFM *)/*?*/ &VAR[PARMS];
// 5388 fp = ap; fp_base = wsp
*FP = *AP;
FP->BASE = 8;
// 5389 ap_flag = ap_flag & (\p in r) ! assigned %if ap_flag&array bits = 0
if (AP->FLAG & 96 != 0) goto L_0435;
AP->FLAG = AP->FLAG & (~2) | 8;
L_0435:;
// 5390 %repeat
goto L_0433;
}
L_0434:;
// 5391 abort(m'AM50') %if parms < names
if (PARMS >= NAMES) goto L_0436;
ABORT(1095578928);
L_0436:;
// 5392 %if ap_type = strings %and ap_xform & (array bits<<8 + 255) = V in S %c
if (AP->TYPE != 5) goto L_0437;
if (AP->XFORM & (96 << 8) + 255 != 4) goto L_0437;
if (AP->BASE == 0) goto L_0437;
// 5393+ %and ap_base # 0 %start
// 5394 gvar_header = ap_disp
GVAR->HEADER = AP->DISP;
// 5395 fp_flag = fp_flag ! P in R; ! mark as 'in-register' param
FP->FLAG = FP->FLAG | 2;
// 5396 %finish
L_0437:;
// 5397 %finish
L_0432:;
// 5398 gdisp = -1; ! so locals are properly placed
GDISP = -1;
// 5399 max parm = frame; !start of local space
MAXPARM = FRAME;
// 5400 -> OUT %if amode # 0
if (AMODE == 0) goto L_0438;
goto U_100D;
L_0438:;
// 5401 header(gvar)
HEADER(GVAR);
// 5402 %continue
goto L_0382;
// 5403 c('H'):
case_C_72:;
// 5404 decvar == begin; decvar_disp = new tag
DECVAR = (struct VARFM *)/*?*/ &BEGIN;
DECVAR->DISP = NEWTAG();
// 5405 otype = 0; spec = 0; potype = 0
OTYPE = 0;
SPEC = 0;
POTYPE = 0;
// 5406 %if level # 0 %start; ! not outermost %begin
if (LEVEL == 0) goto L_0439;
// 5407 cstack(decvar_disp)
CSTACK(DECVAR->DISP);
// 5408 pop lhs; lhs_type = 0; call(lhs)
POPLHS();
LHS->TYPE = 0;
CALL(LHS);
// 5409 %finish
L_0439:;
// 5410 block name = "BLOCK"; ! Fix up diagnostic name for "%begin" block
_imp_strncpy(/*?*/ &BLOCKNAME, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("BLOCK");
(void *)&tmp;
}),
/*max:*/ 19);
// 5411 assemble(0,labs,names)
ASSEMBLE(0, LABS, NAMES);
// 5412 %continue
goto L_0382;
// 5413
// 5414 %repeat; ! --- end of main loop ---
L_0382:;
goto L_0000;
// 5415
// 5416 ! To catch the sinners!!
// 5417 C(*):
case_C_default:;
// 5418 abort(m'?? '<<8 ! sym)
ABORT(4144928 << 8 | SYM);
// 5419
// 5420 %routine ALIGN ALTERNATIVES
void ALIGNALTERNATIVES(void) {
// 5421 ! Routine to fix up alternate record definitions - implicit parameters in:
// 5422 ! true frame base, putative frame base, max frame, alt first, alt align
// 5423 %integer n, mod, j
int N;
int MOD;
int J;
// 5424 %record(varfm)%name v
struct VARFM *V;
// 5425 Falign = Alt Align
FALIGN = ALTALIGN;
// 5426 n = putative frame base - true frame base
N = PUTATIVEFRAMEBASE - TRUEFRAMEBASE;
// 5427 %return %if n = 0 %or alt align = align; ! no padding or fullword req'd
if (N == 0) goto L_043A;
if (ALTALIGN != 3) goto L_043B;
L_043A:;
return;
L_043B:;
// 5428 %if alt align = 0 %start; ! byte alignment possible
if (ALTALIGN != 0) goto L_043C;
// 5429 mod = n
MOD = N;
// 5430 %else; ! at least %short req'd
goto L_043D;
L_043C:;
// 5431 %return %if n = 1; ! can't move it back
if (N != 1) goto L_043E;
return;
L_043E:;
// 5432 mod = 2; ! n = 2,3
MOD = 2;
// 5433 %finish
L_043D:;
// 5434 ! now strip out extra unnecessary alignment
// 5435 %for j = parms,1,alt first %cycle
// %for J = PARMS, 1, ALTFIRST %cycle
{
int _initial = PARMS, _final = ALTFIRST;
if (invalid_for_loop(_initial, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = PARMS, 1, ALTFIRST");
J = _initial - (1);
L_043F:
if (J == _final) goto L_0440;
J += 1;
// 5436 v == var(j)
V = (struct VARFM *)/*?*/ &VAR[J];
// 5437 v_disp = v_disp - mod
V->DISP = V->DISP - MOD;
// 5438 %repeat
goto L_043F;
}
L_0440:;
// 5439 max frame = max frame - mod
MAXFRAME = MAXFRAME - MOD;
// 5440 %end; ! align alternatives
return;
} /* end of ALIGNALTERNATIVES */
// 5441
// 5442 c(';'):
case_C_59:;
// 5443 %if level # 0 %start
if (LEVEL == 0) goto L_0442;
// 5444 %if uncond jump # ca %or (gvar_type = 0 %and control&trusted = 0) %start
if (UNCONDJUMP != CA) goto L_0443;
if (GVAR->TYPE != 0) goto L_0444;
if (CONTROL & 32 != 0) goto L_0444;
L_0443:;
// 5445 %if control&trace # 0 %and level = 1 %start
if (CONTROL & 64 == 0) goto L_0445;
if (LEVEL != 1) goto L_0445;
// 5446 perm(enter trace); cput(0); ! close down user-supplied routine
PERM(50);
CPUT(0);
// 5447 %finish
L_0445:;
// 5448 return
RETURN();
// 5449 %finish
L_0444:;
// 5450 %else; ! level 0: flush literals and gla
goto L_0446;
L_0442:;
// 5451 gbyte(0) %if ga&1 # 0
if (GA & 1 == 0) goto L_0447;
GBYTE(0);
L_0447:;
// 5452 claim literal(0,0) %if lita&1 # 0
if (LITA & 1 == 0) goto L_0448;
CLAIMLITERAL(0, 0);
L_0448:;
// 5453 %finish
L_0446:;
// 5454 Gvar_Flag = Gvar_Flag!Closed
GVAR->FLAG = GVAR->FLAG | CLOSED;
// 5455 block mark(block end)
BLOCKMARK(17);
// 5456 Reset Optimisation Data
RESETOPTIMISATIONDATA();
// 5457 OUT:
U_100D:;
// 5458 %if amode >= 0 %start; ! end of declarative block
if (AMODE < 0) goto L_0449;
// 5459 activity(local) = 0 %unless local = base5; ! release old base register
if (LOCAL == 13) goto L_044A;
ACTIVITY[LOCAL] = 0;
L_044A:;
// 5460 level = level-1; local = breg(level)
LEVEL = LEVEL - 1;
LOCAL = BREG[LEVEL + 1];
// 5461 %else; ! end of record format defn
goto L_044B;
L_0449:;
// 5462 align alternatives
ALIGNALTERNATIVES();
// 5463 frame = max frame %if max frame > frame
if (MAXFRAME <= FRAME) goto L_044C;
FRAME = MAXFRAME;
L_044C:;
// 5464 %if amode = -2 %start; ! end of alternative only
if (AMODE != -2) goto L_044D;
// 5465 old frame = frame
OLDFRAME = FRAME;
// 5466 %else
goto L_044E;
L_044D:;
// 5467 frame = (frame+align)&(\align); ! **** temporary ****
FRAME = FRAME + 3 & (~3);
// 5468 abort(m'AM55') %unless frame>>16 = 0 {only 16 bits worth}
if ((unsigned int)FRAME >> 16 == 0) goto L_044F;
ABORT(1095578933);
L_044F:;
// 5469 gvar_length <- frame
GVAR->LENGTH = (int)(FRAME);
// 5470 %finish
L_044E:;
// 5471 %finish
L_044B:;
// 5472 frame = old frame; extra frame = old extra frame
FRAME = OLDFRAME;
EXTRAFRAME = OLDEXTRAFRAME;
// 5473 uncond jump = old jump; ca = proc ca
UNCONDJUMP = OLDJUMP;
CA = PROCCA;
// 5474 var diags = old var diags
VARDIAGS = OLDVARDIAGS;
// 5475 new temp = temp base
NEWTEMP = TEMPBASE;
// 5476 next temp = old next temp
NEXTTEMP = OLDNEXTTEMP;
// 5477 temp base = old temp base
TEMPBASE = OLDTEMPBASE;
// 5478 last line = -15
LASTLINE = -15;
// 5479
// 5480 %end;
return;
case_C_dispatch:
if (C_index < 33 || C_index > 127)
_imp_signalf(6, 3, C_index, "->C(%d) out of bounds at %s line %d", C_index, C_file, C_line);
goto *C[C_index - 33];
case_PC_dispatch:
if (PC_index < 65 || PC_index > 90)
_imp_signalf(6, 3, PC_index, "->PC(%d) out of bounds at %s line %d", PC_index, PC_file, PC_line);
goto *PC[PC_index - 65];
case_PC_missing:
_imp_signalf(8, 2, PC_index, "switch jump to undefined label PC(%d): at %s line %d", PC_index, PC_file, PC_line);
} /* end of ASSEMBLE */
// ?FORGETTHELOT unused
// ?LINESIZE unused
// ?LASTA unused
// ?SWLIST unused
// ?PX unused
// 5481 ; ! assemble
// 5481
// 5482
// 5483 ! -------- it all starts here ---------
// 5484
// 5485 control = IMPCOM_flags & 255; ! set compilation options
CONTROL = IMPCOM.FLAGS & 255;
// 5486 control = control & (\check bits) %if control & trusted # 0; ! force OPT
if (CONTROL & 32 == 0) goto L_0450;
CONTROL = CONTROL & (~23);
L_0450:;
// 5487
// 5488 select input(in)
_imp_SELECTINPUT(1);
// 5489 select output(object)
_imp_SELECTOUTPUT(2);
// 5490 print symbol(init gla>>1); ! Initial GLA allocation
_imp_PRINTSYMBOL((unsigned int)12 >> 1);
// 5491 print symbol(init lit>>1); ! specify literal area available to pass 3
_imp_PRINTSYMBOL((unsigned int)8 >> 1);
// 5492 claim literal(init lit,align); ! set literal base and initialise pass 3
CLAIMLITERAL(8, 3);
// 5493
// 5494 var(0) = 0; ! for %RECORD(*) . . . . .
VAR[0] = (struct VARFM){0};
// 5495 var(max vars)_Length = SetLen {for sets}
VAR[800].LENGTH = 32;
// 5496 parms = max vars
PARMS = 800;
// 5497 cslen == current string(0)
CSLEN = (unsigned char *)/*?*/ &CURRENTSTRING[0];
// 5498 activity(wsp) = -1; activity(code) = -1; activity(0) = -1
ACTIVITY[8] = -1;
ACTIVITY[15] = -1;
ACTIVITY[0] = -1;
// 5499 activity(gla) = -1; activity(link) = -1
ACTIVITY[14] = -1;
ACTIVITY[16] = -1;
// 5500
// 5501 %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_0451:
if (J == _final) goto L_0452;
J += 1;
// 5502 stak(j)_link == stak(j+1)
STAK[J].LINK = (struct STACKFM *)/*?*/ &STAK[J + 1];
// 5503 dlist(j)_link == dlist(j+1)
DLIST[J].LINK = (struct DFM *)/*?*/ &DLIST[J + 1];
// 5504 %repeat
goto L_0451;
}
L_0452:;
// 5505 stak(max stack)_link == null
STAK[25].LINK = (struct STACKFM *)NULL;
// 5506 dlist(max stack)_link == null
DLIST[25].LINK = (struct DFM *)NULL;
// 5507 desc asl == stak(0); dasl == dlist(0)
DESCASL = (struct STACKFM *)/*?*/ &STAK[0];
DASL = (struct DFM *)/*?*/ &DLIST[0];
// 5508 using_link == null
USING.LINK = (struct DFM *)NULL;
// 5509
// 5510 for stk(j) = 0 %for j = 0,1,max cycle
// %for J = 0, 1, 30 %cycle
{
J = -1;
L_0453:
if (J == 30) goto L_0454;
J += 1;
FORSTK[J] = (struct CYCLEFM){0};
goto L_0453;
}
L_0454:;
// 5511 for stp = 0; for == for stk(0)
FORSTP = 0;
FOR = (struct CYCLEFM *)/*?*/ &FORSTK[0];
// 5512
// 5513 read symbol(next); ! Prime SYM/NEXT pair
_imp_READSYMBOL(/*?*/ &NEXT);
// 5514 Spec = 0
SPEC = 0;
// 5515 decvar == begin
DECVAR = (struct VARFM *)/*?*/ &BEGIN;
// 5516 assemble(2,0,0)
ASSEMBLE(2, 0, 0);
// 5517 close files
CLOSEFILES();
// 5518 %signal 15,3 %if faulty # 0
if (FAULTY == 0) goto L_0455;
_imp_signal(15, 3, 0, "");
L_0455:;
// 5519 %endofprogram
_imp_stop(0);
return 0;
end_0:;
}