#include // Edinburgh IMP77 Compiler - Version 8.4 // // 1 ! Some instances of the following records failed to identify fields: Q_ V_ S_ AVAR_ B_ C_ W_ F_ R_ CHAIN_ TARGET_ L_ // 2 // 3 {###################################} // 4 {# Copyright (C) 1988 #} // 5 {# 3L Limited #} // 6 {# #} // 7 {# All rights reserved #} // 8 {###################################} // 9 // 10 {Pass 2 for ARM IMP} // 11 // 12 %externalstring(7) P2 Version = "004" _imp_string7 P2VERSION = _imp_str_literal("004"); // 13 // 14 ! To Do: // 15 ! // 16 // 17 !Revision history: // 18 ! // 19 ! 004 7-Sep-88 PSR Made DALLOC forget Sp and // 20 ! made FORGET forget locked regs {C-136} // 21 ! 003 22-Jun-88 PSR Changes to compile native on A310 // 22 ! Made diag string 127 instead of 31 // 23 ! 002 23-Feb-88 PSR Changed to ARM calling stack frame // 24 ! 001 4-FEB-88 PSR Started additions for ACORN DEBUG // 25 ! - Record diags dumped in reverse order (that of declaration) // 26 ! 0.9 15-Jan-88 PSR Removed the %name %array ILABELS by means of // 27 ! another recordformat. // 28 ! ******* release 1.2 sent to Acorn & Validated ******* // 29 ! 2-Nov-87 PSR Put FORGET DESTINATION in JUMP BACKWARDS to permit // 30 ! unassigned checking of control // 31 ! catching unassigned FOR control variables // 32 ! - Made MULTIPLY call LOAD PROTECTED in case destination // 33 ! register is already in use. (SCR/87/448) // 34 ! 9-Oct-87 PSR Made R14 preferable when hazarding to prevent // 35 ! corrupting a parameter (e.g. for REAL EXP). (SCR/87/449) // 36 ! - Added check for "Subroutines nested too deeply" (SCR/87/447) // 37 ! 0.8 5-Oct-87 PSR Removed optimisation for C1*(V1+C2) :: overflow! // 38 ! - Added check for the cases: (I<= A*B (SCR/87/409) // 43 ! - Fixed OPERATE which was converting A<= [something] which was returning a zero/non-zero // 54 ! condition code but testing for a >= or <= code (SCR/87/398) // 55 ! - Added internally-generated NO-OP 128+'0' + // 56 ! - made WORK AREAS an indefinitely expanding list. (SCR/87/400) // 57 ! - Corrected bugs in ABS(ABS(X)), ABS(-X), and ABS(\X). // 58 ! (SCR/87/401, SCR/87/422) // 59 ! 0.6 16-Sep-87 PSR Test version for BSI visit // 60 ! - Made BUILD SET save & restore oper & link to fix // 61 ! problems with S := [1..x]-[y]; (SCR/87/388) // 62 ! - Set the WORK SET bit on the temp created by BUILD SET // 63 ! - Problem with passing longreals as parameters. The LDM // 64 ! in PPARAMS.INC was not preceded by the necessary HAZARDS // 65 ! - ABS(X) used unsafe MOVS to set condition code, // 66 ! would not work if CC already set incorrectly. // 67 ! 0.5 7-Aug-87 NPH [SCR/87/324] Set value to Default value in Update Line // 68 ! // 69 ! 0.5 4-Aug-87 NPH [SCR/87/325] If saved, Wsp must be saved after a Dalloc // 70 ! Quick soln : save it again if it has been saved. // 71 ! // 72 ! 30-Jul-87 PSR PESSIMISE got the wrong displacement when temps were // 73 ! a long way away from FP // 74 ! Was also a problem with STAB. // 75 ! 8-Jul-87 PSR Forget destination not forgetting after R_a(n) = ... // 76 ! - Stopped optimising X&255 -> byte load when checkable // 77 ! 0.4 24-Jun-87 PSR The event trap routine was forgetting everything // 78 ! AFTER it had planted the LDR Wsp .... This was wrong // 79 ! it the save area was too far away for a simple load. // 80 ! This gave rise to an address error in Pascal Pass1 after // 81 ! a *FATAL ERROR report. // 82 ! 0.3 14-Jun-87 PSR Fixed ALL CONST when first string isn't constant // 83 ! - Fixed PRINTSTRING("") // 84 ! 0.2 28-Mar-86 PSR Tightened up setting condition-code values // 85 ! - remembered ZERO after in-line loops // 86 ! - added optimisation to remember constants after IF x=const // 87 ! - improved handling of SHORTS (esp in S&16_FFFF) // 88 ! - optimised X op Y shift Const, X shift const op Y // 89 ! - corrected problem with OWNs living at 0(SB) // 90 ! - corrected problem causing Record=0 to clear by bytes. // 91 ! 0.01 24-Mar-86 PSR Released to Acorn // 92 ! 0.01 27-Jan-86 PSR Cloned from SUN pass2 v0.39 // 93 // 94 %owninteger Diag = 0, static int DIAG = 0; static int DEBUG = 0; static int CURRENTLINE = 0; // 95+ Debug = 0, {#0 if -DEBUG specified} {001} // 96+ Current Line = 0 {here to aid diagnostics} // 97 // 98 %constinteger MonCode = 1<<0, // 99+ MonStack = 1<<1, // 100+ MonReg = 1<<2, // 101+ MonOperand = 1<<3, // 102+ MonOperate = 1<<4, // 103+ MonMove = 1<<5, // 104+ MonLine = 1<<6, // 105+ MonOpt = 1<<7, // 106+ MonCond = 1<<8, // 107+ MonBang = 1<<9 // 108 // 109 %constinteger Infinity = (-1)>>1, // 110+ Minus Infinity = \Infinity // 111 // 112 %constinteger Max Vars = 2000, Var Top = Max Vars>>6, // 113+ Max Labels = 8000, Max Label = Max Labels!255, // 114+ Max Work Areas = 500, Max Work Area = Max Work Areas!15, // 115+ Max Nesting = 17, // 116+ Max Bound = 7, // 117+ Set Size = 256//8 // 118 // 119 {Types} // 120 // 121 %constinteger Undefined = 0, // 122+ Integers = 1, // 123+ Shorts = 2, // 124+ Halves = 3, // 125+ Bytes = 4, // 126+ Addrs = 5, // 127+ Reals = 6, // 128+ Lreals = 7, // 129+ Strings = 8, // 130+ Records = 9, // 131+ Generals = 10, // 132+ Labels = 11, // 133+ Booleans = 12, // 134+ Sets = 13 // 135 // 136 %constbytearray Internal Type(Undefined:Sets) = const unsigned char INTERNALTYPE[14] = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 4, 13}; // 137+ Undefined, Integers, Shorts, Halves, Bytes, Addrs, // 138+ Reals, Lreals, // 139+ Strings, Records, Generals, Labels, Bytes, Sets // 140 // 141 %conststring(7)%array TypeId(Undefined:Sets) = const _imp_string7 TYPEID[14] = {_imp_str_literal("Unknown"), _imp_str_literal("Integer"), _imp_str_literal("Short "), _imp_str_literal("Half "), _imp_str_literal("Byte "), _imp_str_literal("Addr "), _imp_str_literal("Real "), _imp_str_literal("Lreal "), _imp_str_literal("String "), _imp_str_literal("Record "), _imp_str_literal("General"), _imp_str_literal("Label "), _imp_str_literal("Boolean"), _imp_str_literal("Set ")}; // 142+ "Unknown", "Integer", "Short ", "Half ", "Byte ", "Addr ", // 143+ "Real ", "Lreal ", // 144+ "String ", "Record ", "General", "Label ", "Boolean", "Set " // 145 // 146 %constbytearray Type Fmt (Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,0, 0,1,32 const unsigned char TYPEFMT[14] = {0, 4, 2, 2, 1, 4, 4, 8, 0, 0, 0, 0, 1, 32}; // 147 %constbytearray Type Code(Undefined:Sets) = 0,1,6,6,5,1,2,8,3,4,0,10,0,0 const unsigned char TYPECODE[14] = {0, 1, 6, 6, 5, 1, 2, 8, 3, 4, 0, 10, 0, 0}; // 148 %constbytearray Type Size(Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,12,0,2,Set Size const unsigned char TYPESIZE[14] = {0, 4, 2, 2, 1, 4, 4, 8, 0, 0, 12, 0, 2, 32}; // 149 %constbytearray Ucheck (Undefined:Sets) = 0,1,0,0,0,1,1,1,1,0,0,0,0,0 const unsigned char UCHECK[14] = {0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0}; // 150 struct COMMFM { union { struct { int LANGUAGE; int OPTIONS; int SPECIALS; int PRIM; int STATEMENTS; int FAULTS; int REFCOUNT; int PRIMREFCOUNT; int DEFCOUNT; int PRIMDEFCOUNT; int BLOCKCOUNT; int PRIMBLOCKCOUNT; int EXTERNALCOUNT; int PRIMEXTERNALCOUNT; int GLOBALSIZE; int PRIMGLOBALSIZE; int FORMATS; int PRIMFORMATS; int CONSTANTSIZE; int PRIMCONSTANTSIZE; int GLOBALARRAYSIZE; int TOTALITEMS; int TOTALBLOCKS; int TOTALFORMATS; int TOTALEXTERNALS; _imp_string255 SOURCEFILE; _imp_string255 MODULE; }; }; }; // 151 !%from IMP %include Option3l, Stream3l, Spec3l, Interfac, // 152 ! Comm23, Attr, Lflags // 153 // 154 %include "imp/option3l.inc" // &1 %constinteger LL Trusted = 1<< 0, // &2 + LL Trace = 1<< 1, // &3 + LL Vars = 1<< 2, // &4 + LL Lines = 1<< 3, // &5 + LL Records = 1<< 4, // &6 + LL Assigned = 1<< 5, // &7 + LL Array = 1<< 6, // &8 + LL Range = 1<< 7, // &9 + LL Variants = 1<< 8, // &10 + LL Knuth = 1<< 9, // &11 + LL Warn = 1<<10, // &12 + LL Mon = 1<<11, // &13 + LL Reference = 1<<12, // &14 + LL Notify = 1<<13, // &15 + LL Extend = 1<<14, // &16 + LL Level0 = 1<<15, // &17 + LL Report = 1<<16, // &18 + LL Decode = 1<<17, // &19 + LL Predef = 1<<18, // &20 + LL List = 1<<19, // &21 + LL Stack = 1<<20, // &22 + LL Anon = 1<<21, // &23 + LL Brief = 1<<22, // &24 + LL Debug = 1<<23 // &25 %endoffile // 155 %include "imp/stream3l.inc" // &1 %constinteger Source = 1, Predef In = 2 // &2 // &3 %constinteger Icode In = 1, Icode Out = 1, // &4 + Icode In2 = 2, // &5 + Report = 0, // &6 + Objectives Out = 1, Objectives In = 1, PrimObj In = 3, // &7 + Directives Out = 2, Directives In = 2, PrimDir In = 4, // &8 + Object Out = 1, Decode Out = 3, // &9 + Listing = 7 // &10 %endoffile // 156 %include "imp/spec3l.inc" // &1 {Spec3L.INC} // &2 %endoffile // 157 %include "imp/interfac.inc" // &1 %recordformat CommFm( %c // &2 + %integer Language, // &3 + Options, // &4 + Specials, // &5 + Prim, // &6 + Statements, // &7 + Faults, // &8 + Ref Count, Prim Ref Count, // &9 + Def Count, Prim Def Count, // &10 + Block Count, Prim Block Count, // &11 + External Count, Prim External Count, // &12 + Global Size, Prim Global Size, // &13 + Formats, Prim Formats, // &14 + Constant Size, Prim Constant Size, // &15 + Global Array Size, // &16 + Total Items, // &17 + Total Blocks, // &18 + Total Formats, // &19 + Total Externals, // &20 + %string(255) Source File, // &21 + Module) // &22 // &23 %constinteger Special Main = 2_0001 // &24 %endoffile // 158 %include "imp/comm23.inc" // &1 %constinteger Dir Start Block = 1, // &2 + Dir Diag = 2, // &3 + Dir Line = 3, // &4 + Dir Include = 4, // &5 + Dir Record On = 5, // &6 + Dir Record Off = 6, // &7 + Dir Slabel = 7, // &8 + Dir Label = 8, // &9 + Dir Mark User = 9, // &10 + Dir Const Addr = 10 // &11 // &12 %constinteger Dir Const Load = 11, // &13 + Dir Real Load = 12, // &14 + Dir Spec Load = 13, // &15 + Dir Branch = 14, // &16 + Dir McLabel = 15, // &17 + Dir Modify = 16, // &18 + Dir Header = 17, // &19 + Dir Thunk = 18, // &20 + Dir xThunk = 19, // &21 + Dir Call = 20 // &22 // &23 %constinteger Dir Ext = 21, // &24 + Dir Xref = 22, // &25 + Dir xCall = 23, // &26 + Dir Assigned = 24, // &27 + Dir Prim = 25, // &28 + Dir Return = 26, // &29 + Dir Area = 27, // &30 + Dir Swdef = 28, // &31 + Dir Sw Ref = 29, // &32 + Dir Init = 30 // &33 // &34 %constinteger Dir Dump = 31, // &35 + Dir End Block = 32, // &36 + Dir Debug Array = 33, // &37 + Dir Debug Var = 34, // &38 + Dir Debug Start Proc = 35, // &39 + Dir Debug End Proc = 36 // &40 // &41 %constinteger Max Dir = 36 // &42 %endoffile // 159 %include "imp/attr.inc" // &1 %constinteger Attr Needs Display = 2_00 0000 0001, // &2 + Attr Inner Uses = 2_00 0000 0010, // &3 + Attr Needs Gp = 2_00 0000 0100, // &4 + Attr Prim = 2_00 0000 1000, // &5 + Attr Xdef = 2_00 0001 0000, // &6 + Attr Sp Unknown = 2_00 0010 0000, // &7 + Attr Dynamic = 2_00 0100 0000, // &8 + Attr Local Display = 2_00 1000 0000, // &9 + Attr Inherit = 2_01 0000 0000, // &10 + Attr Globals = 2_10 0000 0000 // &11 // &12 %constinteger Attr Both = 2_00 0000 0010 // &13 %endoffile // 160 %include "imp/lflags.inc" // &1 {lflags} // &2 // &3 %constinteger Pascal Flag = 2_0001, // &4 + Non Exact For = 2_0010, // &5 + Undefined Control = 2_0100 // &6 %endoffile // 161 // 162 // 163 %include "opcodes.inc" // &1 %constinteger Invert Cond = 16_E000 0000 // &2 // &3 %constinteger Cond EQ = 16_0000 0000 !! Invert Cond, // &4 + Cond NE = 16_1000 0000 !! Invert Cond, // &5 + Cond CS = 16_2000 0000 !! Invert Cond, // &6 + Cond CC = 16_3000 0000 !! Invert Cond, // &7 + Cond MI = 16_4000 0000 !! Invert Cond, // &8 + Cond PL = 16_5000 0000 !! Invert Cond, // &9 + Cond VS = 16_6000 0000 !! Invert Cond, // &10 + Cond VC = 16_7000 0000 !! Invert Cond, // &11 + Cond HI = 16_8000 0000 !! Invert Cond, // &12 + Cond LS = 16_9000 0000 !! Invert Cond, // &13 + Cond GE = 16_A000 0000 !! Invert Cond, // &14 + Cond LT = 16_B000 0000 !! Invert Cond, // &15 + Cond GT = 16_C000 0000 !! Invert Cond, // &16 + Cond LE = 16_D000 0000 !! Invert Cond, // &17 + Cond AL = 16_E000 0000 !! Invert Cond, // &18 + Cond NV = 16_F000 0000 !! Invert Cond // &19 // &20 {The Invert Cond is to make ALWAYS default to 0 internally} // &21 // &22 %constinteger Post Indexed = 16_0100 0000, // &23 + Reg Index = 16_0200 0000, // &24 + Write Back = 1<<21, // &25 + Byte Op = 1<<22, // &26 + Scc = 1<<20 // &27 // &28 %constinteger IA = 16_0080 0000, {increment after} // &29 + IB = 16_0180 0000, {increment before} // &30 + DA = 16_0000 0000, {decrement after} // &31 + DB = 16_0100 0000 {decrement before} // &32 // &33 %constinteger Logical Left = 2_000<<4, // &34 + Logical Right = 2_010<<4, // &35 + Arithmetic Right = 2_100<<4, // &36 + Rotate Right = 2_110<<4 // &37 // &38 %constinteger Logical Left R = 2_1001<<4, // &39 + Logical Right R = 2_1011<<4, // &40 + Arithmetic Right R = 2_1101<<4, // &41 + Rotate Right R = 2_1111<<4 // &42 // &43 %constinteger ADD = 16_4 << 21, // &44 + ADC = 16_5 << 21, // &45 + SUB = 16_2 << 21, // &46 + SBC = 16_6 << 21, // &47 + RSB = 16_3 << 21, // &48 + RSC = 16_7 << 21, // &49 + CMP = 16_A << 21 ! Scc, // &50 + CMN = 16_B << 21 ! Scc, // &51 + AND = 16_0 << 21, // &52 + EOR = 16_1 << 21, // &53 + ORR = 16_C << 21, // &54 + BIC = 16_E << 21, // &55 + TST = 16_8 << 21 ! Scc, // &56 + TEQ = 16_9 << 21 ! Scc, // &57 + MOV = 16_D << 21, // &58 + MVN = 16_F << 21 // &59 // &60 %constinteger LDR = 16_0410 0000, // &61 + STR = 16_0400 0000 // &62 // &63 %constinteger SWI = 16_0F00 0000 // &64 // &65 %constinteger LDM = 16_0810 0000, // &66 + STM = 16_0800 0000 // &67 // &68 %constinteger B = 16_0A00 0000, // &69 + BL = 16_0B00 0000 // &70 // &71 {Floating-point ops} // &72 // &73 %constinteger LDFD = 2_ 00001100 0 0 0 1 0000 1000 0001 00000000, // &74 + LDFS = 2_ 00001100 0 0 0 1 0000 0000 0001 00000000, // &75 + STFD = 2_ 00001100 0 0 0 0 0000 1000 0001 00000000, // &76 + STFS = 2_ 00001100 0 0 0 0 0000 0000 0001 00000000 // &77 // &78 %constinteger FLT = 2_ 00001110 000 0 1000 0000 0001 0001 0000, // &79 + FIX = 2_ 00001110 000 1 1000 0000 0001 0001 0000 // &80 // &81 %constinteger CMF = 2_ 00001110 100 1 0000 1111 0001 0001 0000, // &82 + CNF = 2_ 00001110 101 1 0000 1111 0001 0001 0000 // &83 // &84 %constinteger Small Constant = 8 // &85 // &86 !These are the extended-mode functions // &87 !%constinteger ADF = 2_ 00001110 0000 1000 0000 0001 0000 0000, // &88 ! MUF = 2_ 00001110 0001 1000 0000 0001 0000 0000, // &89 ! SUF = 2_ 00001110 0010 1000 0000 0001 0000 0000, // &90 ! RSF = 2_ 00001110 0011 1000 0000 0001 0000 0000, // &91 ! DVF = 2_ 00001110 0100 1000 0000 0001 0000 0000, // &92 ! RDF = 2_ 00001110 0101 1000 0000 0001 0000 0000, // &93 ! POW = 2_ 00001110 0110 1000 0000 0001 0000 0000, // &94 ! RPW = 2_ 00001110 0111 1000 0000 0001 0000 0000, // &95 ! RMF = 2_ 00001110 1000 1000 0000 0001 0000 0000, // &96 ! POL = 2_ 00001110 1100 1000 0000 0001 0000 0000, // &97 ! MVF = 2_ 00001110 0000 1000 1000 0001 0000 0000, // &98 ! MNF = 2_ 00001110 0001 1000 1000 0001 0000 0000, // &99 ! ABS = 2_ 00001110 0010 1000 1000 0001 0000 0000, // &100 ! SQT = 2_ 00001110 0100 1000 1000 0001 0000 0000, // &101 ! LOG = 2_ 00001110 0101 1000 1000 0001 0000 0000, // &102 ! LGN = 2_ 00001110 0110 1000 1000 0001 0000 0000, // &103 ! EXP = 2_ 00001110 0111 1000 1000 0001 0000 0000, // &104 ! SIN = 2_ 00001110 1000 1000 1000 0001 0000 0000, // &105 ! COS = 2_ 00001110 1001 1000 1000 0001 0000 0000, // &106 ! TAN = 2_ 00001110 1010 1000 1000 0001 0000 0000, // &107 ! ASN = 2_ 00001110 1011 1000 1000 0001 0000 0000, // &108 ! ACS = 2_ 00001110 1100 1000 1000 0001 0000 0000, // &109 ! ATN = 2_ 00001110 1101 1000 1000 0001 0000 0000, // &110 ! FML = 2_ 00001110 1001 0000 0000 0001 1000 0000, // &111 ! FDV = 2_ 00001110 1010 0000 0000 0001 1000 0000, // &112 ! FRD = 2_ 00001110 1011 0000 0000 0001 1000 0000, // &113 ! RND = 2_ 00001110 0011 0000 1000 0001 1000 0000 // &114 ! // &115 !These are the double-precision functions // &116 %constinteger ADF = 2_ 00001110 0000 0000 0000 0001 1000 0000, // &117 + MUF = 2_ 00001110 0001 0000 0000 0001 1000 0000, // &118 + SUF = 2_ 00001110 0010 0000 0000 0001 1000 0000, // &119 + RSF = 2_ 00001110 0011 0000 0000 0001 1000 0000, // &120 + DVF = 2_ 00001110 0100 0000 0000 0001 1000 0000, // &121 + RDF = 2_ 00001110 0101 0000 0000 0001 1000 0000, // &122 + POW = 2_ 00001110 0110 0000 0000 0001 1000 0000, // &123 + RPW = 2_ 00001110 0111 0000 0000 0001 1000 0000, // &124 + RMF = 2_ 00001110 1000 0000 0000 0001 1000 0000, // &125 + POL = 2_ 00001110 1100 0000 0000 0001 1000 0000, // &126 + MVF = 2_ 00001110 0000 0000 1000 0001 1000 0000, // &127 + MNF = 2_ 00001110 0001 0000 1000 0001 1000 0000, // &128 + ABS = 2_ 00001110 0010 0000 1000 0001 1000 0000, // &129 + SQT = 2_ 00001110 0100 0000 1000 0001 1000 0000, // &130 + LOG = 2_ 00001110 0101 0000 1000 0001 1000 0000, // &131 + LGN = 2_ 00001110 0110 0000 1000 0001 1000 0000, // &132 + EXP = 2_ 00001110 0111 0000 1000 0001 1000 0000, // &133 + SIN = 2_ 00001110 1000 0000 1000 0001 1000 0000, // &134 + COS = 2_ 00001110 1001 0000 1000 0001 1000 0000, // &135 + TAN = 2_ 00001110 1010 0000 1000 0001 1000 0000, // &136 + ASN = 2_ 00001110 1011 0000 1000 0001 1000 0000, // &137 + ACS = 2_ 00001110 1100 0000 1000 0001 1000 0000, // &138 + ATN = 2_ 00001110 1101 0000 1000 0001 1000 0000, // &139 + FML = 2_ 00001110 1001 0000 0000 0001 1000 0000, // &140 + FDV = 2_ 00001110 1010 0000 0000 0001 1000 0000, // &141 + FRD = 2_ 00001110 1011 0000 0000 0001 1000 0000, // &142 + RND = 2_ 00001110 0011 0000 1000 0001 1000 0000 // &143 %endoffile // 164 // 165 %externalroutine PASS2(%record(Commfm)%name Interface) void PASS2(struct COMMFM *INTERFACE) { extern void D68000( // 166 %constinteger Word Length = 4, {in bytes} // 167+ Alignment = 3, {word alignment needed} // 168+ Alignment Mask = \Alignment // 169 // 170 %externalroutinespec D68000(%integer Op, Ca) int OP, int CA); extern void DUMPENCODED( // 171 %externalroutinespec Dump Encoded(%integer N) int N); extern void PRINTHEX( // 172 %include "xspecs.inc" int N, int P) __asm__("3L_IMP_PRINT_HEX"); // &1 {xspecs} // &2 // &3 %externalroutinespec Print Hex %alias "3L_IMP_PRINT_HEX"(%integer N, P) // &4 %endoffile // 173 // 174 {Register info} // 175 // 176 {Integer activities are: 0 = free // 177 { -1 = locked // 178 { >0 = claimed that many times // 179 {NOTE: registers are only claimed by LOAD (or the load implied by OPTIMISE} // 180 // 181 { Register Alias} // 182 %constinteger None = 0, // 183+ R0 = 1, // 184+ R1 = 2, // 185+ R2 = 3, // 186+ R3 = 4, // 187+ R4 = 5, // 188+ R5 = 6, // 189+ R6 = 7, // 190+ R7 = 8, // 191+ R8 = 9, // 192+ R9 = 10, Sb = R9, // 193+ R10 = 11, Fp = R10, // 194+ R11 = 12, Ip = R11, // 195+ R12 = 13, Sp = R12, // 196+ R13 = 14, Sl = R13, // 197+ R14 = 15, Link = R14, // 198+ R15 = 16, Pc = R15, // 199+ Any = 17, // 200+ F0 = 18, // 201+ F1 = 19, // 202+ F2 = 20, // 203+ F3 = 21, // 204+ F4 = 22, // 205+ F5 = 23, // 206+ F6 = 24, // 207+ F7 = 25, // 208+ AnyF = 26 // 209 { Register Alias} // 210 // 211 %constbytearray Actual(0:AnyF) = 0, 0, 1, 2, 3, 4, 5, 6, 7, const unsigned char ACTUAL[27] = {0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 0, 0, 1, 2, 3, 4, 5, 6, 7, 0}; // 212+ 8, 9, 10, 11, 12, 13, 14, 15, 0, // 213+ 0, 1, 2, 3, 4, 5, 6, 7, 0 // 214 // 215 // 216 %conststring(3)%array RegId(0:AnyF) = "", const _imp_string3 REGID[27] = { _imp_str_literal(""), _imp_str_literal("R0 "), _imp_str_literal("R1 "), _imp_str_literal("R2 "), _imp_str_literal("R3 "), _imp_str_literal("R4 "), _imp_str_literal("R5 "), _imp_str_literal("R6 "), _imp_str_literal("R7 "), _imp_str_literal("R8 "), _imp_str_literal("R9 "), _imp_str_literal("R10"), _imp_str_literal("R11"), _imp_str_literal("R12"), _imp_str_literal("R13"), _imp_str_literal("R14"), _imp_str_literal("R15"), _imp_str_literal("R? "), _imp_str_literal("F0 "), _imp_str_literal("F1 "), _imp_str_literal("F2 "), _imp_str_literal("F3 "), _imp_str_literal("F4 "), _imp_str_literal("F5 "), _imp_str_literal("F6 "), _imp_str_literal("F7 "), _imp_str_literal("F? ")}; // 217+ "R0 ", "R1 ", "R2 ", "R3 ", "R4 ", "R5 ", "R6 ", "R7 ", // 218+ "R8 ", "R9 ", "R10", "R11", "R12", "R13", "R14", "R15", "R? ", // 219+ "F0 ", "F1 ", "F2 ", "F3 ", "F4 ", "F5 ", "F6 ", "F7 ", "F? " // 220 // 221 %constbytearray Rtype(0:AnyF) = Undefined, Integers(17), Lreals(9) const unsigned char RTYPE[27] = {0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 7, 7, 7, 7, 7, 7, 7, 7, 7}; // 222 // 223 %recordformat Boundfm(%integer Lower, Upper, Mult) struct BOUNDFM { union { struct { int LOWER; int UPPER; int MULT; }; }; }; // 224 %recordformat Afm(%integer Dimension, struct AFM { union { struct { int DIMENSION; int TOTALSIZE; int ZERODISPLACEMENT; int DV; int LOCALFRAME; int BASE; struct BOUNDFM BOUND[7]; }; }; }; // 225+ Total Size, // 226+ Zero Displacement, // 227+ DV, // 228+ Local Frame, // 229+ Base, // 230+ %record(Boundfm)%array Bound(1:Max Bound)) // 231 // 232 %constrecord(Afm)%name A type == 0 {for NEW} const struct AFM *ATYPE = 0; // 233 // 234 %recordformat Varfm(%integer Flags, struct VARFM { union { struct { int FLAGS; unsigned char BASE; unsigned char PRIM; unsigned char TYPE; unsigned char FORM; union { struct { double RVAR; }; struct { int DISP; union { struct { int EXTRA; }; struct { struct AFM *ADATA; }; }; }; }; union { struct { int FORMAT; }; struct { int SCALE; }; }; int AREA; }; }; }; // 235+ %byte Base, Prim, // 236+ %byte Type, Form, // 237+ (%longreal Rvar %or // 238+ %integer Disp, (%integer Extra %or %record(Afm)%name Adata)), // 239+ (%integer Format %or %integer Scale), // 240+ %integer Area) // 241 // 242 // 243 %recordformatspec Stackfm // 244 %recordformat Olfm(%integer Oper, %record(Stackfm)%name Link) struct OLFM { union { struct { int OPER; struct STACKFM *LINK; }; }; }; // 245 %recordformat Xfm(%integer Xsize, %record(Stackfm)%name Index) struct XFM { union { struct { int XSIZE; struct STACKFM *INDEX; }; }; }; // 246 // 247 %recordformat Datafm( %c struct DATAFM { union { struct { struct VARFM V; int VARNO; struct VARFM *FV; union { struct { int BIAS; }; struct { unsigned char REG; unsigned char LABEL; }; }; struct STACKFM *PARAMS; struct STACKFM *RECORD; union { struct { int OPER; struct STACKFM *LINK; }; struct { struct OLFM OPLINK; }; }; union { struct { int XSIZE; struct STACKFM *INDEX; }; struct { struct XFM X; }; }; }; }; }; // 248+ %record(Varfm) V, // 249+ %integer Varno, // 250+ %record(Varfm)%name Fv, // 251+ (%integer Bias %or %byte Reg, Label), // 252+ %record(Stackfm)%name Params, Record, // 253+ (%integer Oper, %record(Stackfm)%name Link %or %record(Olfm) Oplink), // 254+ (%integer Xsize, %record(Stackfm)%name Index %or %record(Xfm) X)) // 255 // 256 %recordformat Memberfm(%integer Const, Items, struct MEMBERFM { union { struct { int CONST; int ITEMS; struct STACKFM *A; struct STACKFM *B; struct MEMBERFM *LINK; }; }; }; // 257+ %record(Stackfm)%name A, B, // 258+ %record(Memberfm)%name Link) // 259 // 260 %constrecord(Memberfm)%name Memberfm Type == 0 const struct MEMBERFM *MEMBERFMTYPE = 0; // 261 // 262 %recordformat Stackfm( %c struct STACKFM { union { struct { struct VARFM V; }; struct { struct DATAFM DATA; }; struct { int FLAGS; unsigned char BASE; unsigned char PRIM; unsigned char TYPE; unsigned char FORM; union { struct { double RVAL; }; struct { int RHIGH; int RLOW; }; struct { union { struct { int DISP; union { struct { int EXTRA; }; struct { struct AFM *ADATA; }; }; }; }; union { struct { int FORMAT; }; struct { int SCALE; }; }; int AREA; int VARNO; union { struct { struct VARFM *FV; }; struct { struct MEMBERFM *MEMBERS; }; }; union { struct { int BIAS; }; struct { unsigned char REG; unsigned char LABEL; }; }; struct STACKFM *PARAMS; struct STACKFM *RECORD; union { struct { int OPER; struct STACKFM *LINK; }; struct { struct OLFM OPLINK; }; }; union { struct { int XSIZE; struct STACKFM *INDEX; }; struct { struct XFM X; }; }; }; }; struct STACKFM *USING; struct STACKFM *STACK; }; }; }; // 263+ %record(Varfm) V %or // 264+ %record(Datafm) Data %or // 265+ %integer Flags, // 266+ %byte Base, Prim, // 267+ %byte Type, Form, // 268+ (%longreal Rval %or %integer Rhigh, Rlow %c // 269+ %or (%integer Disp, (%integer Extra %or %record(Afm)%name Adata)), // 270+ (%integer Format %or %integer Scale), // 271+ %integer Area, // 272+ %integer Varno, // 273+ (%record(Varfm)%name Fv %or %record(Memberfm)%name Members), // 274+ (%integer Bias %or %byte Reg, Label), // 275+ %record(Stackfm)%name Params, Record, // 276+ (%integer Oper, %record(Stackfm)%name Link %or %record(Olfm) Oplink), // 277+ (%integer Xsize, %record(Stackfm)%name Index %or %record(Xfm) X)), // 278+ %record(Stackfm)%name Using, Stack) // 279 // 280 %constrecord(Stackfm)%name Stackfm Type == 0 const struct STACKFM *STACKFMTYPE = 0; // 281 // 282 %recordformat Withfm(%integer Key, %record(Datafm) Data, struct WITHFM { union { struct { int KEY; struct DATAFM DATA; struct WITHFM *LINK; }; }; }; // 283+ %record(Withfm)%name Link) // 284 %constrecord(Withfm)%name Withfm Type == 0 const struct WITHFM *WITHFMTYPE = 0; // 285 // 286 %recordformat Workfm(%integer Size, Displacement, Validity) struct WORKFM { union { struct { int SIZE; int DISPLACEMENT; int VALIDITY; }; }; }; // 287 %recordformat WorkVfm(%record(WorkVfm)%name Link, struct WORKVFM { union { struct { struct WORKVFM *LINK; struct WORKFM W[31]; }; }; }; // 288+ %record(Workfm)%array W(0:30)) // 289 %constrecord(WorkVfm)%name WorkVfmType == 0 const struct WORKVFM *WORKVFMTYPE = 0; // 290 %record(WorkVfm) Work List = 0 struct WORKVFM WORKLIST; WORKLIST = 0; // 291 %integer Work Validity = 1, Last Work = -1 int WORKVALIDITY; WORKVALIDITY = 1; int LASTWORK; LASTWORK = -1; // 292 // 293 {Flag bits} // 294 // 295 %constinteger By Ref = 1<< 0, {in FLAGS} // 296+ Array = 1<< 1, // 297+ Parameter = 1<< 2, {procedure parameter} // 298+ Defered = 1<< 3, {needs indirection} // 299+ Hazarded = 1<< 4, // 300+ Static = 1<< 5, // 301+ Arrayname = 1<< 6, // 302+ Known Ass = 1<< 7, {cannot be unassigned} // 303+ Prim Proc = 1<< 8, // 304+ Primitive = 1<< 9, {prim procedure} // 305+ Xproc Spec = 1<<10, {external procedure} // 306+ Closed = 1<<11, {cannot return} // 307+ Internal = 1<<12, {can use JSB} // 308+ Call it = 1<<13, {cannot use JSB} // 309+ Null Set = 1<<14, // 310+ Keep Local = 1<<15, // 311+ Nasty Proc = 1<<16, {uses the environment} // 312+ Awanted = 1<<17, // 313+ Work Set = 1<<18, // 314+ Answer = 1<<19, // 315+ Checkable = 1<<20, // 316+ Pred Call = 1<<21, {is a predicate} // 317+ Stored With = 1<<22, // 318+ Xdata Spec = 1<<23, // 319+ Xproc Def = 1<<24 // 320 // 321 %recordformat Forfm(%byte Label, Entry, Reg, CC, struct FORFM { union { struct { unsigned char LABEL; unsigned char ENTRY; unsigned char REG; unsigned char CC; int TYPE; int AS; struct DATAFM CONTROL; struct DATAFM FINAL; struct FORFM *LINK; }; }; }; // 322+ %integer Type, // 323+ %integer AS, // 324+ %record(Datafm) Control, Final, // 325+ %record(Forfm)%name Link) // 326 %constrecord(Forfm)%name ForfmType == 0 const struct FORFM *FORFMTYPE = 0; // 327 %ownrecord (Forfm)%name Fors == 0 static struct FORFM *FORS = 0; // 328 // 329 %ownrecord(Stackfm)%name Stack == 0 static struct STACKFM *STACK = 0; // 330 %ownrecord(Stackfm)%name Using == 0, static struct STACKFM *USING = 0; static struct STACKFM *DASL = 0; // 331+ Dasl == 0 // 332 // 333 %recordformat Valuefm(%longreal Real %or %c struct VALUEFM { union { struct { double REAL; }; struct { int INTEGER; }; struct { _imp_string255 STRING; }; struct { unsigned char FILL[256]; }; }; }; // 334+ %integer Integer %or %c // 335+ %string(255) String %or %c // 336+ %bytearray Fill(0:255)) // 337 // 338 %ownrecord(Valuefm) Value = 0, static struct VALUEFM VALUE = 0; static struct VALUEFM DEFAULTVALUE = 0; // 339+ Default Value = 0 // 340 // 341 // 342 {Internal operations} // 343 // 344 %constinteger Real Shift = 21 // 345 // 346 %constinteger NOTx = 1, {Integer operations} // 347+ NEGx = 2, // 348+ ABSx = 3, // 349+ ADDx = 4, // 350+ SUBx = 5, // 351+ MULx = 6, // 352+ DIVx = 7, // 353+ EXPx = 8, // 354+ ANDx = 9, // 355+ ORx = 10, // 356+ XORx = 11, // 357+ BICx = 12, // 358+ ROTx = 13, // 359+ LSHx = 14, // 360+ RSHx = 15, // 361+ REMx = 16, // 362+ MODx = 17, // 363+ MULHx = 18, {special for halfword multiply} // 364+ UDIVx = 19, {unsigned divide} // 365+ UREMx = 20, {unsigned rem} // 366+ EXTx = 21, // 367+ CONCx = 22, // 368+ RNEGx = NEGx+Real Shift, {floating-point operations} // 369+ RABSx = ABSx+Real Shift, // 370+ RADDx = ADDx+Real Shift, // 371+ RSUBx = SUBx+Real Shift, // 372+ RMULx = MULx+Real Shift, // 373+ RDIVx = DIVx+Real Shift, // 374+ REXPx = EXPx+Real Shift // 375 // 376 // 377 %conststring(4)%array OperId(NOTx:REXPx) = const _imp_string4 OPERID[29] = { _imp_str_literal("not "), _imp_str_literal("neg "), _imp_str_literal("abs "), _imp_str_literal("add "), _imp_str_literal("sub "), _imp_str_literal("mul "), _imp_str_literal("div "), _imp_str_literal("exp "), _imp_str_literal("and "), _imp_str_literal("or "), _imp_str_literal("xor "), _imp_str_literal("bic "), _imp_str_literal("rot "), _imp_str_literal("lsh "), _imp_str_literal("rsh "), _imp_str_literal("rem "), _imp_str_literal("mod "), _imp_str_literal("ext "), _imp_str_literal("mulh"), _imp_str_literal("udiv"), _imp_str_literal("urem"), _imp_str_literal("conc"), _imp_str_literal("negr"), _imp_str_literal("absr"), _imp_str_literal("addr"), _imp_str_literal("subr"), _imp_str_literal("mulr"), _imp_str_literal("divr"), _imp_str_literal("expr")}; // 378+ "not ", "neg ", "abs ", // 379+ "add ", "sub ", "mul ", "div ", "exp ", // 380+ "and ", "or ", "xor ", "bic ", "rot ", "lsh ", "rsh ", // 381+ "rem ", "mod ", // 382+ "ext ", "mulh", "udiv", "urem", "conc", // 383+ "negr", "absr", // 384+ "addr", "subr", "mulr", "divr", "expr" // 385 // 386 {Oper flags} // 387 // 388 %constinteger Commutative = 1<<0, // 389+ InPrim = 1<<1, // 390+ Easy = 1<<2, // 391+ Selfop = 1<<3, // 392+ Unary = 1<<5, // 393+ Incdec = 1<<6, // 394+ No Assoc = 1<<7, // 395+ Weak Assoc = 1<<8, Assoc Mask = No Assoc!Weak Assoc, // 396+ Nullop = 1<<9 // 397 // 398 %constshortarray Oper Flags(NOTx:REXPx) = const short int OPERFLAGS[29] = {40, 40, 32, 589, 588, 769, 640, 642, 781, 781, 781, 780, 640, 648, 648, 128, 128, 128, 128, 128, 128, 128, 168, 160, 129, 128, 129, 128, 130}; // 399+ {NOTx} Unary!Selfop, // 400+ {NEGx} Unary!Selfop, // 401+ {ABSx} Unary, // 402+ {ADDx} Commutative!Easy!Selfop!Nullop!Incdec, // 403+ {SUBx} Easy!Selfop!Nullop!Incdec, // 404+ {MULx} Commutative!Weak Assoc!Nullop, // 405+ {DIVx} No Assoc!Nullop, // 406+ {EXPx} InPrim!No Assoc!Nullop, // 407+ {ANDx} Weak Assoc!Easy!Nullop!Selfop!Commutative, // 408+ {ORx} Weak Assoc!Easy!Nullop!Selfop!Commutative, // 409+ {XORx} Weak Assoc!Easy!Nullop!Selfop!Commutative, // 410+ {BICx} Weak Assoc!Easy!Nullop!Selfop, // 411+ {ROTx} No Assoc!Nullop, // 412+ {LSHx} No Assoc!Nullop!Selfop, // 413+ {RSHx} No Assoc!Nullop!Selfop, // 414+ {REMx} No Assoc, // 415+ {MODx} No Assoc, // 416+ {EXTx} No Assoc, // 417+ {MULHx} No Assoc, // 418+ {UDIVx} No Assoc, // 419+ {UREMx} No Assoc, // 420+ {CONCx} No Assoc, // 421+ {RNEGx} No Assoc!Unary!Selfop, // 422+ {RABSx} No Assoc!Unary, // 423+ {RADDx} No Assoc!Commutative, // 424+ {RSUBx} No Assoc, // 425+ {RMULx} No Assoc!Commutative, // 426+ {RDIVx} No Assoc, // 427+ {REXPx} No Assoc!Inprim // 428 // 429 %constintegerarray Easy Op(ADDx:BICx) = const int EASYOP[9] = {8388608, 4194304, 0, 0, 0, 0, 25165824, 2097152, 29360128}; // 430+ {ADDx} ADD, // 431+ {SUBx} SUB, // 432+ {MULx} 0, // 433+ {DIVx} 0, // 434+ {EXPx} 0, // 435+ {ANDx} AND, // 436+ {ORx} ORR, // 437+ {XORx} EOR, // 438+ {BICx} BIC // 439 // 440 %constintegerarray Null Value(ADDx:RSHx) = const int NULLVALUE[12] = {0, 0, 1, 1, 1, -1, 0, 0, 0, 0, 0, 0}; // 441+ 0, {ADDx} 0, {SUBx} 1, {MULx} // 442+ 1, {DIVx} 1, {EXPx} -1, {ANDx} // 443+ 0, {ORx} 0, {XORx} 0, {BICx} 0, {ROTx} // 444+ 0, {LSHx} 0 {RSHx} // 445 // 446 {Condition codes} // 447 // 448 %constinteger EQ = 1, LT = 2, GT = 4, TT = 8, Always = 7, // 449+ NE = 6, LE = 3, GE = 5, FF = 9, Never = 0 // 450 // 451 %constbytearray Reverse(Never:FF) = Never, const unsigned char REVERSE[10] = {0, 1, 4, 5, 2, 3, 6, 7, 8, 9}; // 452+ EQ {EQ}, GT {LT}, GE {LE}, // 453+ LT {GT}, LE {GE}, NE {NE}, // 454+ Always, TT {TT}, FF {FF} // 455 // 456 %constbytearray Negated(Never:FF) = Always, const unsigned char NEGATED[10] = {7, 6, 5, 4, 3, 2, 1, 0, 9, 8}; // 457+ NE {EQ}, GE {LT}, GT {LE}, // 458+ LE {GT}, LT {GE}, EQ {NE}, // 459+ Never, FF {TT}, TT {FF} // 460 // 461 {Otypes} // 462 // 463 %constinteger Own = 1, EqualsEquals = 1, // 464+ Con = 2, Equals = 0, // 465+ External = 3, Jam = -1, // 466+ System = 4, // 467+ Dynamic = 5, // 468+ Primrt = 6, // 469+ Permrt = 7 // 470 // 471 {Procedure end codes} // 472 // 473 %constinteger Map = -2, // 474+ Fn = -1, {negative implies stacked result} // 475+ Routine = 0, // 476+ True = 1, // 477+ False = 2 // 478 // 479 // 480 %integer J, NN int J; int NN; // 481 %owninteger Code = 0, {current I-code symbol} static int CODE = 0; static int PENDING = 0; static int PENDINGTAG = 0; static int PENDINGLIT = 0; static int PENDINGAUTON = 0; static int PENDINGAUTO = 0; static int PENDINGAUTOCA = 0; static int LANGUAGEFLAGS = 0; static int STACKCHECK = 0; static int FALIGN = 0; // 482+ Pending = 0, {next I-code symbol} // 483+ Pending Tag = 0, {optimise 0<=N<=...} // 484+ Pending Lit = 0, // 485+ Pending Auto N = 0, // 486+ Pending Auto = 0, // 487+ Pending Auto Ca = 0, // 488+ Language Flags = 0, // 489+ Stack Check = 0, {entry for external} // 490+ Falign = 0 {worst internal alignment} // 491 // 492 %owninteger Invert = 0, static int INVERT = 0; static int UNSIGNED = 0; static int FREELABEL; // 493+ Unsigned = 0, // 494+ Free Label // 495 // 496 %constinteger Defined = 16_8000 0000, // 497+ Label Mask = \Defined, // 498+ Inverted = 1 // 499 // 500 %recordformat Knowfm(%byte Ftype, Reg, Base, Oper, struct KNOWFM { union { struct { unsigned char FTYPE; unsigned char REG; unsigned char BASE; unsigned char OPER; int DISP; int AREA; int OPND; int EXTRA; struct KNOWFM *LINK; }; }; }; // 501+ %integer Disp, Area, Opnd, Extra, // 502+ %record(Knowfm)%name Link) // 503 %constrecord(Knowfm)%name KnowfmType == 0 const struct KNOWFM *KNOWFMTYPE = 0; // 504 // 505 %recordformat Labelfm(%integer Lab, %record(Knowfm)%name Env) struct LABELFM { union { struct { int LAB; struct KNOWFM *ENV; }; }; }; // 506 // 507 %recordformat Ilabelfm(%record(Ilabelfm)%name Link, struct ILABELFM { union { struct { struct ILABELFM *LINK; struct LABELFM LAB[256]; }; }; }; // 508+ %record(Labelfm)%array Lab(0:255)) // 509 %constrecord(Ilabelfm)%name Ilabelfm Type == 0 const struct ILABELFM *ILABELFMTYPE = 0; // 510 %record(Ilabelfm)%name Ilabel List == NIL struct ILABELFM *ILABELLIST; ILABELLIST = NIL; // 511 // 512 !0.9! %record(Ilabelfm)%namearray Ilabels(0: Max Label>>8) // 513 {0.9} %recordformat IlabelPfm(%record(Ilabelfm)%name Label) struct ILABELPFM { union { struct { struct ILABELFM *LABEL; }; }; }; // 514 {0.9} %record(IlabelPfm)%array Ilabels(0:Max Label>>8) struct ILABELPFM ILABELS[((unsigned int)8191 >> 8) + 1]; // 515 // 516 %ownrecord(Knowfm)%name Knowing == 0, static struct KNOWFM *KNOWING = 0; static struct KNOWFM *KASL = 0; // 517+ Kasl == 0 // 518 %ownintegerarray Ktimes(0:AnyF) = 0(*) static int KTIMES[27] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; // 519 // 520 %owninteger Used Time = 0 static int USEDTIME = 0; // 521 %ownintegerarray Used(0:AnyF) = 0(*) static int USED[27] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; // 522 %ownintegerarray Activity(0:AnyF) = 0(*) static int ACTIVITY[27] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; // 523 %owninteger Active Registers = 0 static int ACTIVEREGISTERS = 0; // 524 // 525 %integer Pending Known Register = 0 int PENDINGKNOWNREGISTER; PENDINGKNOWNREGISTER = 0; // 526 %record(Stackfm) Pending Known struct STACKFM PENDINGKNOWN; // 527 // 528 %ownstring(127) Alias = "", {003} static _imp_string127 ALIAS = _imp_str_literal(""); static _imp_string127 INTERNALID = _imp_str_literal(""); static _imp_string127 EXTERNALID = _imp_str_literal(""); static _imp_string127 SECTIONID = _imp_str_literal(""); // 529+ Internal Id = "", // 530+ External Id = "", // 531+ Section Id = "" // 532 // 533 %owninteger Decl Size, static int DECLSIZE; static int VLB; static int VUB; static int OSTATE; static int OWNTYPE; static int OWNFORM; static int OWNEXTRA; static int CONSTANTTYPE; static int INITFLAG = 0; // 534+ Vlb, Vub, // 535+ Ostate, // 536+ OwnType, // 537+ OwnForm, // 538+ Ownextra, // 539+ Constant Type, // 540+ Init Flag = 0 // 541 // 542 %record(Varfm)%name DefV struct VARFM *DEFV; // 543 %record(Varfm) AltV struct VARFM ALTV; // 544 %owninteger Parms static int PARMS; // 545 %owninteger Section = 0 static int SECTION = 0; // 546 // 547 %owninteger Control = 0, {Unass Check} static int CONTROL = 0; static int UNASSIGNED = 0; static int COMPILINGPRIM = 0; // 548+ Unassigned = 0, {#0 for unassigned checks} // 549+ Compiling Prim = 0 {#0 when compiling PRIM file} // 550 // 551 {Forms} // 552 // 553 %constinteger Address = 0, // 554+ Direct = Address+1, // 555+ AutoI = 2, Memorable Limit = AutoI, // 556+ AutoD = 3, // 557+ Proc = 4, // 558+ LabelX = 5, // 559+ Indirect = 15 {**only for VARs**} // 560 // 561 %conststring(6)%array FormId(Address:LabelX) = "addr", "value", "()+", const _imp_string6 FORMID[6] = {_imp_str_literal("addr"), _imp_str_literal("value"), _imp_str_literal("()+"), _imp_str_literal("-()"), _imp_str_literal("proc"), _imp_str_literal("label")}; // 562+ "-()", "proc", "label" // 563 // 564 {Prim routines} // 565 // 566 %constinteger Signal = 1, {%signal} // 567+ Cscomp = 2, {compare string & constant} // 568+ Sres = 3, {string resolution} // 569+ Sw Jump = 4, {switch jump} // 570+ Intexp = 5, {integer exponentiation} // 571+ RealExp = 6, {real exponentiation} // 572+ Genmove = 7, {general string move} // 573+ Sconc = 8, {string concatenation} // 574+ Scomp = 9, {string comparison} // 575+ Sjam = 10, {string jam transfer, length known} // 576+ SetIn = 11, {test for R0 IN (R3)} // 577+ Resflop = 12, {string resolution fails} // 578+ TestNil = 13, {Nil, Unassigned & Disposed} // 579+ MakeLocal = 14, {copy array into local space} // 580+ Aref = 15, {n-dim array reference} // 581+ Dynamic Range= 16, {Check R2 <= R1 <= R3} // 582+ Dynamic N = 17, {n-dim array declaration} // 583+ Frag1 = 18, {assign resolution fragment 1} // 584+ RtMonitor = 19, {invoke run-time monitor} // 585+ Set Bit = 20, {bit -> 1 in set} // 586+ Captest = 21, {test for capacity exceeded} // 587+ Ass Test = 22, {unassigned test} // 588+ Trace Line = 23, {line trace debugger} // 589+ Frag2 = 24, {assign resolution fragment 2} // 590+ Clear Bit = 25, {bit -> 0 in set} // 591+ Test New = 26, {fail if variant NEW} // 592+ Nil Test = 27, {Test for NIL pointer} // 593+ Set Bits = 28, {set multiple bits in SETs} // 594+ Set Add = 29, // 595+ Set Sub = 30, // 596+ Set Inter = 31, // 597+ Set GE = 32, // 598+ Check Range = 33, // 599+ Test MOD = 34, {check for a MOD (<=0)} // 600+ Clear Bits = 35, {clear multiple bits in set} // 601+ Test Variant = 36, // 602+ Prim Mul = 37, // 603+ Prim Div = 38, // 604+ Test Real = 39, {compare real with zero} // 605+ Prim Compare = 40, // 606+ Real Intpt = 41, // 607+ Modulus = 42 // 608 { Avoid "Program too complex" compiler failure } // 609 %const %integer Dynamic 1 = 43, {single-dimension dynamic array} // 610+ Dynamic 2 = 44, {two-dimensional dynamic array} // 611+ Psymbol = 45, {printsymbol} // 612+ Set Range = 46, {check set ranges} // 613+ ReadCh = 47, {readsymbol in prim} // 614+ NextCh = 48, {nextsymbol in prim} // 615+ Prim Udiv = 49, {unsigned divide} // 616+ Set Zero = 50, {test for null set} // 617+ Set Equal = 51, {test for set equality} // 618+ Real Int = 52, {int(F0) -> R0} // 619+ Real Round = 53, {round(F0) -> R0} // 620+ CallP = 54, {call proc parameter} // 621+ Enter P = 55, {jump to procedure} // 622+ Dalloc = 56 {dynamic allocation & unassign} // 623 // 624 %constinteger Last Prim = 56 // 625 // 626 %owninteger Enter Proc = 0 {filled in on first use} static int ENTERPROC = 0; // 627 // 628 %constintegerarray Corrupts(Signal:Last Prim) = const int CORRUPTS[56] = {0, 1, 4607, 0, 47, 393217, 4095, 60, 126, 15, 9, 0, 7, 15, 0, 0, 2287, 135, 0, 25, 0, 0, 4095, 77, 25, 0, 0, 58, 2559, 2559, 2559, 2559, 0, 0, 58, 0, 3, 63, 0, 31, 262145, 62, 511, 255, 8189, 56, 1023, 1023, 15, 510, 2559, 393217, 131073, 0, 0, 6160}; // 629+ {FFFF FFFF A RRRR RRRR RRRR RRRR } // 630+ {7654 3210 FEDC BA98 7654 3210 } // 631+ 2_0000 0000 0 0000 0000 0000 0000, { 1:signal} // 632+ 2_0000 0000 0 0000 0000 0000 0001, { 2:cscomp} // 633+ 2_0000 0000 0 0001 0001 1111 1111, { 3:Sres} // 634+ 2_0000 0000 0 0000 0000 0000 0000, { 4:swjump} // 635+ 2_0000 0000 0 0000 0000 0010 1111, { 5:intexp} // 636+ 2_0000 0011 0 0000 0000 0000 0001, { 6:realexp} // 637+ 2_0000 0000 0 0000 1111 1111 1111, { 7:rtraceproc} // 638+ 2_0000 0000 0 0000 0000 0011 1100, { 8:Sconc} // 639+ 2_0000 0000 0 0000 0000 0111 1110, { 9:scomp} // 640+ 2_0000 0000 0 0000 0000 0000 1111, {10:sjam} // 641+ 2_0000 0000 0 0000 0000 0000 1001, {11:SetIn} // 642+ 2_0000 0000 0 0000 0000 0000 0000, {12:ResFlop} // 643+ 2_0000 0000 0 0000 0000 0000 0111, {13:sconc opt} // 644+ 2_0000 0000 0 0000 0000 0000 1111, {14:MakeLocal} // 645+ 2_0000 0000 0 0000 0000 0000 0000, {15:aref} // 646+ 2_0000 0000 0 0000 0000 0000 0000, {16:Dynamic Range} // 647+ 2_0000 0000 0 0000 1000 1110 1111, {17:dynamic n} // 648+ 2_0000 0000 0 0000 0000 1000 0111, {18:Frag1} // 649+ 2_0000 0000 0 0000 0000 0000 0000, {19:rtmonitor} // 650+ 2_0000 0000 0 0000 0000 0001 1001, {20:set bit} // 651+ 2_0000 0000 0 0000 0000 0000 0000, {21:captest} // 652+ 2_0000 0000 0 0000 0000 0000 0000, {22:asstest} // 653+ 2_0000 0000 0 0000 1111 1111 1111, {23:traceline} // 654+ 2_0000 0000 0 0000 0000 0100 1101, {24:Frag2} // 655+ 2_0000 0000 0 0000 0000 0001 1001, {25:Clear bit} // 656+ 2_0000 0000 0 0000 0000 0000 0000, {26:Test New} // 657+ 2_0000 0000 0 0000 0000 0000 0000, {27:Nil test} // 658+ 2_0000 0000 0 0000 0000 0011 1010, {28:Set Bits} // 659+ 2_0000 0000 0 0000 1001 1111 1111, {29:Set Add} // 660+ 2_0000 0000 0 0000 1001 1111 1111, {30:Set Sub} // 661+ 2_0000 0000 0 0000 1001 1111 1111, {31:Set Inter} // 662+ 2_0000 0000 0 0000 1001 1111 1111, {32:Set GE} // 663+ 2_0000 0000 0 0000 0000 0000 0000, {33:Check Range} // 664+ 2_0000 0000 0 0000 0000 0000 0000, {34:test mod} // 665+ 2_0000 0000 0 0000 0000 0011 1010, {35:Clear Bits} // 666+ 2_0000 0000 0 0000 0000 0000 0000, {36:Test Variant} // 667+ 2_0000 0000 0 0000 0000 0000 0011, {37:prim mul} // 668+ 2_0000 0000 0 0000 0000 0011 1111, {38:prim div} // 669+ 2_0000 0000 0 0000 0000 0000 0000, {39:test real} // 670+ 2_0000 0000 0 0000 0000 0001 1111, {40:primcomp} // 671+ 2_0000 0010 0 0000 0000 0000 0001, {41:intpt} // 672+ 2_0000 0000 0 0000 0000 0011 1110, {42:modulus} // 673+ 2_0000 0000 0 0000 0001 1111 1111, {43:dynamic 1} // 674+ 2_0000 0000 0 0000 0000 1111 1111, {44:dynamic 2} // 675+ 2_0000 0000 0 0001 1111 1111 1101, {45:Psymbol} // 676+ 2_0000 0000 0 0000 0000 0011 1000, {46:Set Range} // 677+ 2_0000 0000 0 0000 0011 1111 1111, {47:ReadCh} // 678+ 2_0000 0000 0 0000 0011 1111 1111, {48:NextCh} // 679+ 2_0000 0000 0 0000 0000 0000 1111, {49:prim udiv} // 680+ 2_0000 0000 0 0000 0001 1111 1110, {50:set zero} // 681+ 2_0000 0000 0 0000 1001 1111 1111, {51:set equal} // 682+ 2_0000 0011 0 0000 0000 0000 0001, {52:Real Int} // 683+ 2_0000 0001 0 0000 0000 0000 0001, {53:Real Round} // 684+ 2_0000 0000 0 0000 0000 0000 0000, {54:CallP} // 685+ 2_0000 0000 0 0000 0000 0000 0000, {55:EnterP} // 686+ 2_0000 0000 0 0001 1000 0001 0000 {56:Dalloc} {004} // 687 // 688 %constintegerarray Prim Parameter(Signal:Last Prim) = const int PRIMPARAMETER[56] = {0, 6, 7966, 2, 6, 131073, 0, 12, 6, 7, 6, 0, 7, 7, 0, 14, 2054, 4230, 0, 258, 0, 0, 0, 4172, 258, 0, 2, 259, 2304, 2304, 2304, 2304, 10, 0, 259, 10, 3, 6, 0, 7, 3, 6, 56, 472, 2, 7, 0, 0, 6, 1, 3, 131073, 131072, 0, 0, 16}; // 689+ {FFFF FFFF A RRRR RRRR RRRR RRRR } // 690+ {7654 3210 FEDC BA98 7654 3210 } // 691+ 2_0000 0000 0 0000 0000 0000 0000, { 1:signal} // 692+ 2_0000 0000 0 0000 0000 0000 0110, { 2:cscomp} // 693+ 2_0000 0000 0 0001 1111 0001 1110, { 3:Sres} // 694+ 2_0000 0000 0 0000 0000 0000 0010, { 4:swjump} // 695+ 2_0000 0000 0 0000 0000 0000 0110, { 5:intexp} // 696+ 2_0000 0001 0 0000 0000 0000 0001, { 6:realexp} // 697+ 2_0000 0000 0 0000 0000 0000 0000, { 7:traceproc} // 698+ 2_0000 0000 0 0000 0000 0000 1100, { 8:Sconc} // 699+ 2_0000 0000 0 0000 0000 0000 0110, { 9:scomp} // 700+ 2_0000 0000 0 0000 0000 0000 0111, {10:sjam} // 701+ 2_0000 0000 0 0000 0000 0000 0110, {11:SetIn} // 702+ 2_0000 0000 0 0000 0000 0000 0000, {12:ResFlop} // 703+ 2_0000 0000 0 0000 0000 0000 0111, {13:sconc opt} // 704+ 2_0000 0000 0 0000 0000 0000 0111, {14:MakeLocal} // 705+ 2_0000 0000 0 0000 0000 0000 0000, {15:aref} // 706+ 2_0000 0000 0 0000 0000 0000 1110, {16:Dynamic Range} // 707+ 2_0000 0000 0 0000 1000 0000 0110, {17:dynamic n} // 708+ 2_0000 0000 0 0001 0000 1000 0110, {18:Frag1} // 709+ 2_0000 0000 0 0000 0000 0000 0000, {19:rtmonitor} // 710+ 2_0000 0000 0 0000 0001 0000 0010, {20:set bit} // 711+ 2_0000 0000 0 0000 0000 0000 0000, {21:captest} // 712+ 2_0000 0000 0 0000 0000 0000 0000, {22:asstest} // 713+ 2_0000 0000 0 0000 0000 0000 0000, {23:traceline} // 714+ 2_0000 0000 0 0001 0000 0100 1100, {24:Frag2} // 715+ 2_0000 0000 0 0000 0001 0000 0010, {25:clear bit} // 716+ 2_0000 0000 0 0000 0000 0000 0000, {26:Test New} // 717+ 2_0000 0000 0 0000 0000 0000 0010, {27:Nil test} // 718+ 2_0000 0000 0 0000 0001 0000 0011, {28:Set Bits} // 719+ 2_0000 0000 0 0000 1001 0000 0000, {29:Set Add} // 720+ 2_0000 0000 0 0000 1001 0000 0000, {30:Set Sub} // 721+ 2_0000 0000 0 0000 1001 0000 0000, {31:Set Inter} // 722+ 2_0000 0000 0 0000 1001 0000 0000, {32:Set GE} // 723+ 2_0000 0000 0 0000 0000 0000 1010, {33:Check Range} // 724+ 2_0000 0000 0 0000 0000 0000 0000, {34:test mod} // 725+ 2_0000 0000 0 0000 0001 0000 0011, {35:Clear Bits} // 726+ 2_0000 0000 0 0000 0000 0000 1010, {36:Test Variant} // 727+ 2_0000 0000 0 0000 0000 0000 0011, {37:prim mul} // 728+ 2_0000 0000 0 0000 0000 0000 0110, {38:prim div} // 729+ 2_0000 0000 0 0000 0000 0000 0000, {39:test real} // 730+ 2_0000 0000 0 0000 0000 0000 0111, {40:primcomp} // 731+ 2_0000 0000 0 0000 0000 0000 0011, {41:intpt} // 732+ 2_0000 0000 0 0000 0000 0000 0110, {42:prim div} // 733+ 2_0000 0000 0 0000 0000 0011 1000, {43:dynamic 1} // 734+ 2_0000 0000 0 0000 0001 1101 1000, {44:dynamic 2} // 735+ 2_0000 0000 0 0000 0000 0000 0010, {45:Psymbol} // 736+ 2_0000 0000 0 0000 0000 0000 0111, {46:Set Range} // 737+ 2_0000 0000 0 0000 0000 0000 0000, {47:ReadCh} // 738+ 2_0000 0000 0 0000 0000 0000 0000, {48:NextCh} // 739+ 2_0000 0000 0 0000 0000 0000 0110, {49:prim udiv} // 740+ 2_0000 0000 0 0000 0000 0000 0001, {50:set zero} // 741+ 2_0000 0000 0 0000 0000 0000 0011, {51:set equal] // 742+ 2_0000 0001 0 0000 0000 0000 0001, {52:Real Int} // 743+ 2_0000 0001 0 0000 0000 0000 0000, {53:Real Round} // 744+ 2_0000 0000 0 0000 0000 0000 0000, {54:CallP} // 745+ 2_0000 0000 0 0000 0000 0000 0000, {55:EnterP} // 746+ 2_0000 0000 0 0000 0000 0001 0000 {56:Dalloc} // 747 // 748 {File data} // 749 // 750 %constinteger Icode = 1 // 751 // 752 %owninteger Last Dir = 0, static int LASTDIR = 0; static int REFS = 0; static int BLOCKS = 0; // 753+ Refs = 0, Blocks = 0 // 754 // 755 {Areas} // 756 // 757 %constinteger Code Area = 0<<8, // 758+ Own Area = 1<<8, // 759+ Constant Area = 2<<8, // 760+ Own Array Area = 3<<8 // 761 // 762 {============================================================} // 763 // 764 %owninteger Own Base = 0, {current own area address} static int OWNBASE = 0; static int MINSB = 0; static int OWNARRAYBASE = 0; static int CONSTANTBASE = 0; static int CURRENTAREA = 0; static int LASTAREA = 0; static int EXTERNALNO = 0; // 765+ Min SB = 0, {backward offset into SB} // 766+ Own Array Base = 0, // 767+ Constant Base = 0, {current constant area address} // 768+ Current Area = Code Area, {currently selected area} // 769+ Last Area = 0, // 770+ External No = 0 // 771 // 772 %constinteger Base Local = 128 // 773 // 774 %ownintegerarray Frame Use(Base Local:Base Local+Max Nesting) = 0(*) static int FRAMEUSE[18] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; // 775 %owninteger Fmark = 0 static int FMARK = 0; // 776 // 777 %record(Stackfm) Uapat, Zero, One, SpV struct STACKFM UAPAT; struct STACKFM ZERO; struct STACKFM ONE; struct STACKFM SPV; // 778 %record(Stackfm)%array RegV(None:AnyF) struct STACKFM REGV[27]; // 779 // 780 %record(Varfm)%name For Range == Nil {## Nil if check required} struct VARFM *FORRANGE; FORRANGE = NIL; // 781 // 782 %record(Stackfm) C255 = 0; C255_Disp = 255; C255_Type = Integers struct STACKFM C255; C255 = 0; C255.DISP = 255; C255.TYPE = 1; // 783 %constinteger No Danger = 16_7FFF {>> than 128+depth} // 784 %owninteger Jamit= 0, Entry Point = -1, static int JAMIT = 0; static int ENTRYPOINT = -1; static int DANGERLEVEL = 32767; // 785+ Danger Level = No Danger {limit of normal globals} // 786 // 787 %string(127) Include File = "" _imp_string127 INCLUDEFILE; INCLUDEFILE = _imp_str_literal(""); // 788 // 789 %integer Dtype {for remembering disag type on arrays} int DTYPE; // 790 // 791 %recordformat Qfm(%integer Type, Size, Round, Bias, Dim, Format, struct QFM { union { struct { int TYPE; int SIZE; int ROUND; int BIAS; int DIM; int FORMAT; int DIAGS; int DTYPE; int DFORM; int IND; struct QFM *POINTED; }; }; }; // 792+ Diags, Dtype, Dform, Ind, // 793+ %record(Qfm)%name Pointed) // 794 // 795 %recordformat Diag Fm(%record(Diagfm)%name Link, struct DIAGFM { union { struct { struct DIAGFM *LINK; struct VARFM *VAR; int X; int XTYPE; int FORMAT; int EXT; _imp_string127 ID; }; }; }; // 796+ %record(Varfm)%name Var, // 797+ %integer X, Xtype, // 798+ Format, // 799+ Ext, // 800+ %string(127) Id) {003} // 801 // 802 %constrecord(Diagfm)%name Diagfm Type == 0 const struct DIAGFM *DIAGFMTYPE = 0; // 803 %record(Diagfm)%name Diag List == Nil struct DIAGFM *DIAGLIST; DIAGLIST = NIL; // 804 // 805 %constinteger Display Limit = 128+17 // 806 %ownshortarray Display Vector(128:Display Limit) = 0(*) static short int DISPLAYVECTOR[18] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; // 807 // 808 %owninteger Cp = 0 static int CP = 0; // 809 %bytearray Code Buffer(0:255) unsigned char CODEBUFFER[256]; // 810 // 811 %recordformat Vvfm(%record(Vvfm)%name Link, %record(Varfm)%array V(0:63)) struct VVFM { union { struct { struct VVFM *LINK; struct VARFM V[64]; }; }; }; // 812 %constrecord(Vvfm)%name VvfmType == 0 const struct VVFM *VVFMTYPE = 0; // 813 %record(Vvfm)%name Var List == NIL struct VVFM *VARLIST; VARLIST = NIL; // 814 %recordformat Pvfm(%record(Vvfm)%name P) struct PVFM { union { struct { struct VVFM *P; }; }; }; // 815 %record(Pvfm)%array Pvar(0:Var Top) struct PVFM PVAR[32]; // 816 // 817 %record(Varfm)%map Var(%integer A) struct VARFM *VAR(int A) { // 818 %record(Vvfm)%name V struct VVFM *V; // 819 %record(Pvfm)%name X struct PVFM *X; X = &PVAR[(unsigned int)A >> // 820 X == Pvar(A>>6) 6]; // 821 %if X_P == Nil %start if (&X->P != NIL) goto L_0001; V = _imp_NEW(VVFMTYPE); // 822 V == NEW(VvfmType) // 823 V_Link == Var List; Var List == V V->LINK = VARLIST; VARLIST = V; // 824 X_P == V X->P = V; // 825 %finish L_0001: return & // 826 %result == X_P_V(A&63) X->P[A & 63]; // 827 %end } /* VAR */ // 828 // 829 %routine Flush Code void FLUSHCODE(void) { // 830 %integer J int J; // 831 %return %if Cp = 0 if (CP != 0) goto L_0002; return; L_0002: // 832 Printsymbol(Dir Dump) _imp_PRINTSYMBOL(31); // 833 Dump Encoded(Cp) DUMPENCODED(CP); // 834 Printsymbol(Code Buffer(J)) %for J = 1, 1, Cp J = 0; /*%for J = 1, 1, CP %cycle*/ L_0003: if (J == CP) goto L_0004; J += 1; _imp_PRINTSYMBOL(CODEBUFFER[J]); goto L_0003; L_0004: CP = // 835 Cp = 0 0; // 836 %end } /* FLUSHCODE */ // 837 // 838 %routine Assemble(%record(Varfm)%name Avar, void ASSEMBLE(struct VARFM * AVAR, int AMODE, int VARS, int LOCAL, int PARAMETERLIST, int *GLOBALATTRIBUTES) { auto void NOTINYET(void); auto void FAIL( // 839+ %integer Amode, Vars, Local, Parameter List, // 840+ %integername Global Attributes) // 841 {Amode = -16 - Initial call } // 842 { -2 - Alternate format start} // 843 { -1 - Recordformat } // 844 { 0 - Procedure } // 845 { >0 - Procedure spec } // 846 %routinespec Not in Yet // 847 %routinespec Fail(%string(63) Why) // 848 %routinespec Warn(%integer Fault, %string(63) What) // 849 %routinespec Display(%record(Stackfm)%name V, %integer Bias) // 850 %routinespec Monitor(%record(Stackfm)%name V, %string(127) Text) // 851 %predicatespec Iconst(%record(Stackfm)%name V) // 852 %predicatespec Iconst Item(%record(Stackfm)%name V) // 853 %predicatespec Const(%record(Stackfm)%name V) // 854 %predicatespec Same(%record(Stackfm)%name A, B) // 855 %predicatespec InReg(%record(Stackfm)%name V) // 856 %predicatespec Floating(%record(Stackfm)%name V) // 857 %integerfnspec Power(%integer N) // 858 %integerfnspec Item Size(%integer T) // 859 %record(Stackfm)%mapspec Register(%integer R) // 860 %routinespec Claim(%integer Register) // 861 %routinespec Release(%integer Register) // 862 %routinespec Release and Drop(%record(Stackfm)%name V) // 863 %routinespec Zap Index and Record(%record(Stackfm)%name V) // 864 %routinespec Release and Drop Pair(%record(Stackfm)%name A, B) // 865 %routinespec Hazard(%integer Register) // 866 %routinespec Pessimise(%record(Stackfm)%name V) // 867 %routinespec Forget(%integer Register) // 868 %routinespec Forget Destination(%record(Stackfm)%name V) // 869 %routinespec Forget Everything // 870 %routinespec Remember(%integer Register, %record(Stackfm)%name V) // 871 %routinespec Remember Zero(%integer Register) // 872 %routinespec Optimise(%record(Stackfm)%name V, %integer Mode) // 873 // 874 %routinespec Simplify(%record(Stackfm)%name V) // 875 %routinespec Amap(%record(Stackfm)%name V) // 876 %routinespec Vmap(%record(Stackfm)%name V, %integer Type) // 877 %routinespec Make AutoI(%record(Stackfm)%name V, %integer Type) // 878 %routinespec Advance(%record(Stackfm)%name V, %integer Type, By) // 879 %routinespec Load(%record(Stackfm)%name V, %integer Register) // 880 %routinespec Loadup(%record(Stackfm)%name V) // 881 %routinespec Load Address(%record(Stackfm)%name V, %integer R) // 882 %routinespec Loadup Address(%record(Stackfm)%name V) // 883 %routinespec Load Pair(%record(Stackfm)%name A, %integer Ar, // 884+ %record(Stackfm)%name B, %integer Br) // 885 %routinespec Load Trio(%record(Stackfm)%name A, %integer Ar, // 886+ %record(Stackfm)%name B, %integer Br, // 887+ %record(Stackfm)%name C, %integer Cr) // 888 %routinespec Pop Stack(%integer Bytes) // 889 %routinespec Load Protected(%record(Stackfm)%name V) // 890 %routinespec Move(%record(Stackfm)%name From, To) // 891 %routinespec Move Literal(%integer Lit, %record(Stackfm)%name V) // 892 %routinespec Store(%record(Stackfm)%name From, To) // 893 %routinespec Store Address(%record(Stackfm)%name From, To, // 894+ %integername Extra) // 895 %routinespec Operate(%integer Op, %record(Stackfm)%name L, R) // 896 %routinespec Compare(%record(Stackfm)%name L, R) // 897 %integerfnspec New Label // 898 %routinespec Jump To(%integer Internal Label, Cond Code) // 899 %routinespec Define Label(%integer Internal Label) // 900 %routinespec Test Zero(%record(Stackfm)%name V) // 901 %routinespec Test Range(%record(Stackfm)%name V, // 902+ %record(Varfm)%name R) // 903 %routinespec Clear Vars(%integer Limit) // 904 %routinespec DIR String(%integer Op, %string(*)%name S) // 905 %routinespec Float(%record(Stackfm)%name V, %integer R) // 906 %routinespec Dump External(%integer C, %record(Varfm)%name V) // 907 %routinespec Do(%string(31) Ident, %integername Ep, %integer Result) // 908 // 909 %integerfnspec GPR // 910 %integerfnspec FPR // 911 %integerfnspec Select Best(%record(Stackfm)%name From, To, %integer D) // 912 %record(Stackfm)%mapspec Descriptor // 913 %record(Stackfm)%mapspec Temporary // 914 %routinespec Drop(%record(Stackfm)%name V) // 915 %record(Stackfm)%mapspec Local Integer(%integer Disp) // 916 %record(Stackfm)%mapspec Literal(%integer N) // 917 %record(Stackfm)%mapspec Copy(%record(Stackfm)%name V) // 918 // 919 %integerfnspec Tag // 920 %integerfnspec Four Bytes // 921 // 922 %routinespec Prim(%integer N) // 923 %routinespec Dump Text(%integer Max) // 924 %routinespec Pass Parameters(%record(Stackfm)%name V, // 925+ %integername X, %integer BaseReg) // 926 %routinespec Assign(%integer How) // 927 %routinespec String Assign(%record(Stackfm)%name From, To) // 928 %routinespec Set Assign(%record(Stackfm)%name From, To) // 929 %routinespec Evaluate String Expression(%record(Stackfm)%name V) // 930 %routinespec Record Assign(%record(Stackfm)%name From, To) // 931 %record(Stackfm)%mapspec Claim Work Area(%integer Size, Type) // 932 %routinespec Flush Diags // 933 %routinespec Convert Format(%record(Stackfm)%name V, %integer Type) // 934 %routinespec To Short Real(%record(Stackfm)%name V) // 935 %routinespec Store Real Constant(%record(Stackfm)%name W) // 936 %routinespec Build Set(%record(Stackfm)%name S) // 937 %routinespec Drop Members(%record(Stackfm)%name S) // 938 // 939 %owninteger Frame = 0, // 940+ Round = 0 // 941 %integer Aframe = 0, {array extension to frame} // 942+ Parameter Frame = 0, // 943+ Parameter Regs = 0, // 944+ String Result = 0 // 945 // 946 %integer Block Type = 0, // 947+ Code Base = 0, // 948+ Uncond Jump = -1, // 949+ D, // 950+ N, // 951+ Parameter Mode, // 952+ VarBase = Vars, // 953+ First Alt = Parms-1, // 954+ Frame Base, // 955+ Old Frame, // 956+ Alt Align, {Worst alignment of record alternatives} // 957+ Frame Extra, {putative padding at front of alternative} // 958+ Max Frame {largest alternative so far} // 959 // 960 %integer Assign Lock = 1 {#0 to permit marking assigned permanently} // 961 // 962 %integer Attributes = 0, // 963+ At = 0, // 964+ Entry Mask = 0, // 965+ MyMark, // 966+ Open = Closed, {assume cannot return} // 967+ Event Label = 0, // 968+ Event Body = 0, // 969+ Event Bits = 0, // 970+ Wsp Save = 0, {frame address of where SP is saved} // 971+ Danger Marker = 0, {=1 if the block is dangerous} // 972+ Local Display = 0, {#0 if in a dangerous block} // 973+ Jlab, // 974+ Array Base = 0 {#0 if allocated} // 975 // 976 %integer Work Base = Last Work // 977 // 978 %integername Ca == Code Base {current Address} // 979 // 980 %string(127) Proc Id = Internal Id {003} // 981 // 982 %record(Withfm)%name Withs == Nil // 983 // 984 %conststring(255) Monitor Id = "3L___monitor" // 985 %owninteger Monitor Ep = 0 // 986 // 987 %routine Decode(%integer Word, At) // 988 %externalroutinespec D %alias "DECODE_ARM"(%integer W, A) // 989 Select Output(Report) // 990 D(Word, At) // 991 Select Output(Directives Out) // 992 %end // 993 // 994 %record(Stackfm)%map Display Info(%integer Base) // 995 %integer N // 996 %record(Stackfm)%name T // 997 %if Base < Danger Level %start {the safe case} // 998 Frame Use(Base) = 0 {show the level used} // 999 N = Display Vector(Base) // 1000 %if N = 0 %start // 1001 Min SB = Min SB-4; N = Min SB // 1002 Display Vector(Base) = N // 1003 %finish // 1004 T == Literal(N) // 1005 T_Form = Direct // 1006 T_Base = Sb // 1007 %else {the dangerous case - p-params} // 1008 T == Local Integer(Local Display+4*(Base-Danger Level)) // 1009 %finish // 1010 Attributes = Attributes!Attr Needs Display ! Attr Needs Gp // 1011 T_Flags = T_Flags!Known Ass // 1012 %result == T // 1013 %end // 1014 // 1015 %routine BD(%integer Base, Disp) // 1016 Write(Disp, 1) // 1017 Printsymbol('(') // 1018 %if None <= Base <= AnyF %start // 1019 Printstring(Regid(Base)) // 1020 %else // 1021 %if Base >= Base Local %start // 1022 %if Base = Local %start // 1023 Printstring("Fp") // 1024 %else // 1025 Printsymbol('L') // 1026 Base = Base-Base Local-1 // 1027 Write(Base, 0) // 1028 %finish // 1029 %else // 1030 Write(Base, 0) // 1031 %finish // 1032 %finish // 1033 Printsymbol(')') // 1034 %end // 1035 // 1036 %routine Show(%integer N, %string(15) Text) // 1037 %if N # 0 %start // 1038 Space; Printstring(Text) // 1039 Write(n, 1) // 1040 %finish // 1041 %end // 1042 // 1043 %routine Show Data(%record(Stackfm)%name V, %integer Left) // 1044 Spaces(Left); Printstring(Typeid(V_Type)) // 1045 Space; Printstring(Formid(V_Form)) // 1046 BD(V_Base, V_Disp) // 1047 Show(V_Format, "Fm:") // 1048 Show(V_Area, "A:") // 1049 Show(V_Flags, "Fl:") // 1050 PrintSymbol('R') %if V_Flags&By Ref # 0 // 1051 PrintSymbol('A') %if V_Flags&Array # 0 // 1052 PrintSymbol('N') %if V_Flags&Arrayname # 0 // 1053 PrintSymbol('P') %if V_Flags&Parameter # 0 // 1054 PrintSymbol('D') %if V_Flags&Defered # 0 // 1055 PrintSymbol('W') %if V_Flags&Awanted # 0 // 1056 PrintSymbol('S') %if V_Flags&Static # 0 // 1057 PrintSymbol('=') %if V_Flags&Known Ass # 0 // 1058 Printsymbol('H') %if V_Flags&Hazarded # 0 // 1059 Printsymbol('X') %if V_Flags&Xproc Spec # 0 // 1060 Printsymbol('n') %if V_Flags&Nasty Proc # 0 // 1061 Printsymbol('C') %if V_Flags&Checkable # 0 // 1062 PrintSymbol('#') %and Write(V_Varno, 0) %if V_Varno # 0 // 1063 %if V_Record ## Nil %start // 1064 Newline // 1065 Spaces(Left); Printstring(" _:") // 1066 Display(V_Record, Left+4) // 1067 %finish // 1068 %if V_Index ## Nil %start // 1069 Newline // 1070 Write(V_Xsize, Left+2); Printstring("i:") // 1071 Display(V_Index, Left+4) // 1072 %finish // 1073 %end // 1074 // 1075 %routine Display(%record(Stackfm)%name V, %integer Bias) // 1076 %if V == Nil %start // 1077 Printstring(" Nil"); Newline // 1078 %return // 1079 %finish // 1080 Show Data(V, Bias) // 1081 newline // 1082 %if V_Oper # 0 %start // 1083 Spaces(Bias-4); Printstring(Operid(V_Oper)) // 1084 Display(V_Link, Bias+4) // 1085 %finish // 1086 %end // 1087 // 1088 %routine Show Reg(%integer R) // 1089 %integer A // 1090 A = Activity(R) // 1091 Printstring(Regid(R)) // 1092 %if A = 0 %start // 1093 Printstring(" unused") // 1094 %else %if A < 0 // 1095 %if A = -1 %start // 1096 Printstring(" locked") // 1097 %else // 1098 Printstring(" ="); Printstring(Regid(-A)); Spaces(2) // 1099 %finish // 1100 %else // 1101 Printstring(" used*"); Write(A, -1) // 1102 %finish // 1103 Printstring(" u:"); Print Hex(Used(R), 5) // 1104 Printstring(" k:"); Write(Ktimes(R), 0) // 1105 Newline // 1106 %end // 1107 // 1108 %routine Monitor N(%integer N, %string(255) Text) // 1109 Select Output(Report) // 1110 Printstring(Text) // 1111 Write(N, 8) // 1112 Newline // 1113 Select Output(Directives Out) // 1114 %end // 1115 // 1116 %routine Monitor Register(%integer R, %string(127) Text) // 1117 Select Output(Report) // 1118 Printstring(Text); Spaces(9-length(Text)); Space // 1119 Show Reg(R) // 1120 Select Output(Directives Out) // 1121 %end // 1122 // 1123 %routine Monitor(%record(Stackfm)%name V, %string(127) Text) // 1124 Select Output(Report) // 1125 Printstring(Text); Spaces(9-length(Text)); Space // 1126 Display(V, 6) // 1127 Select Output(Directives Out) // 1128 %end // 1129 // 1130 %routine Mon Regid(%integer R, %string(127) Text) // 1131 Select Output(Report) // 1132 Printstring(Regid(R)); Space // 1133 Printstring(Text) // 1134 Newline // 1135 Select Output(Directives Out) // 1136 %end // 1137 // 1138 %routine Display Knowledge // 1139 %record(Knowfm)%name K // 1140 Select Output(Report) // 1141 K == Knowing // 1142 %while K ## Nil %cycle // 1143 Printstring(Regid(K_Reg)); Printstring(" = ") // 1144 Printstring(Typeid(K_Ftype>>4)); Space // 1145 Printstring(Formid(K_Ftype&15)); Space // 1146 BD(K_Base, K_Disp) // 1147 %if K_Extra # 0 %start // 1148 Printstring(" X:"); Write(K_Extra, 1) // 1149 %finish // 1150 %if K_Area # 0 %start // 1151 Printstring(" A:"); Write(K_Area, 1) // 1152 %finish // 1153 %if K_Oper # 0 %start // 1154 Space; Printstring(OperId(K_Oper)) // 1155 Write(K_Opnd, 1) // 1156 %finish // 1157 Newline // 1158 K == K_Link // 1159 %repeat // 1160 Select Output(Directives Out) // 1161 %end // 1162 // 1163 %routine Show Where // 1164 Select Output(Report) // 1165 Printstring(" at line "); Write(Current Line, 0) // 1166 Printstring(" in file ".Include File) %if Include File # "" // 1167 newline // 1168 %end // 1169 // 1170 %routine Fail(%string(63) Why) _imp_string63 WHY); auto void WARN( // 1171 // 1172 %routine Pcode(%integer S) // 1173 %if S >= 128 %start // 1174 Printstring("128+") // 1175 S = S-128 // 1176 %finish // 1177 %if ' ' <= S <= 126 %start // 1178 Printsymbol(''''); Printsymbol(S); Printsymbol('''') // 1179 %finish // 1180 write(S, 3) // 1181 %end // 1182 // 1183 %routine Err(%integer Stream) // 1184 %integer R // 1185 %record(Stackfm)%name U, S // 1186 Select Output(Stream) // 1187 Newline // 1188 Printstring("====> Pass 2 fails -- "); Printstring(Why) // 1189 Show Where // 1190 Printstring("Code "); Pcode(Code) // 1191 Printstring(" Pending "); Pcode(Pending) // 1192 Newline // 1193 %for R = R0, 1, R15 %cycle // 1194 Show Reg(R) %unless Activity(R) <= 0 // 1195 %repeat // 1196 S == Stack // 1197 %while S ## Nil %cycle // 1198 Printstring("S:"); Display(S, 5) // 1199 S == S_Stack // 1200 %repeat // 1201 U == Using // 1202 %while U ## Nil %cycle // 1203 Printstring("U:"); Display(U, 5) // 1204 U == U_Using // 1205 %repeat // 1206 Newline // 1207 %monitor // 1208 %end // 1209 Err(Report) {terminal} // 1210 Err(Listing) {listing} // 1211 %stop // 1212 %end // 1213 // 1214 %routine Warn(%integer Fault, %string(63) What) int FAULT, _imp_string63 WHAT); auto void DISPLAY( // 1215 Select Output(Report) struct STACKFM * V, int BIAS); auto void MONITOR( // 1216 Interface_Faults = Interface_Faults+Fault struct STACKFM * V, _imp_string127 TEXT); auto int ICONST( // 1217 %if Fault = 0 %then Printstring("Warning: ") %c // 1218+ %else Printstring("*Error: ") // 1219 Printstring(What) // 1220 Show Where // 1221 Select Output(Directives Out) // 1222 %end // 1223 // 1224 %routine Not in Yet // 1225 Fail("***Not implemented yet***") // 1226 %end // 1227 // 1228 %routine Dir1(%integer Code) // 1229 Flush Code // 1230 Printsymbol(Code) // 1231 Pending Auto = 0 // 1232 %end // 1233 // 1234 %routine Dir2(%integer Code, Arg1) // 1235 Flush Code // 1236 Printsymbol(Code) // 1237 Dump Encoded(Arg1) // 1238 Pending Auto = 0 %unless Code = Dir Line // 1239 %end // 1240 // 1241 %routine Dir3(%integer Code, Arg1, Arg2) // 1242 Flush Code // 1243 Printsymbol(Code) // 1244 Dump Encoded(Arg1) // 1245 Dump Encoded(Arg2) // 1246 Pending Auto = 0 // 1247 %end // 1248 // 1249 %routine Dir4(%integer Code, Arg1, Arg2, Arg3) // 1250 Flush Code // 1251 Printsymbol(Code) // 1252 Dump Encoded(Arg1) // 1253 Dump Encoded(Arg2) // 1254 Dump Encoded(Arg3) // 1255 Pending Auto = 0 // 1256 %end // 1257 // 1258 %record(Workfm)%map Work Area(%integer N) // 1259 %record(WorkVfm)%name W // 1260 %integer E, S, X // 1261 %on * %start // 1262 E = Event_Event; S = Event_Sub; X = 0; ! Event_Extra not supported in bootstrapping compiler // 1263 Fail("too many work areas:".itos(E, 0)) // 1264 %finish // 1265 Monitor N(N, "work area") %if Diag&MonOperand # 0 // 1266 W == Work List // 1267 %while N > 30 %cycle // 1268 N = N-30 // 1269 %if W_Link == NIL %start // 1270 W_Link == NEW(WorkVfmType) // 1271 W_Link = 0 // 1272 %finish // 1273 W == W_Link // 1274 %repeat // 1275 %result == W_W(N) // 1276 %end // 1277 // 1278 %record(Labelfm)%map Ilabel(%integer N) // 1279 %integer X, J // 1280 %record(Ilabelfm)%name I // 1281 %record(Labelfm)%name L // 1282 Fail("internal label/1") %if N > Max Label // 1283 X = N>>8 // 1284 !0.9! I == Ilabels(X) // 1285 {0.9} I == Ilabels(X)_Label // 1286 %if I == NIL %start // 1287 I == New(Ilabelfm Type) // 1288 !0.9! Ilabels(X) == I // 1289 {0.9} Ilabels(X)_Label == I // 1290 I_Link == Ilabel List; Ilabel List == I // 1291 %for J = 0, 1, 255 %cycle // 1292 L == I_Lab(J) // 1293 L_Lab = Defined // 1294 L_Env == NIL // 1295 %repeat // 1296 %finish // 1297 %result == I_Lab(N&255) // 1298 %end // 1299 // 1300 %routine Select Area(%integer Area Id, %integername Base) // 1301 Dir3(Dir Area, Area Id>>8, Base) // 1302 Current Area = Area Id // 1303 Ca == Base // 1304 %end // 1305 // 1306 %routine Select Code Area // 1307 Select Area(Code Area, Code Base) // 1308 %end // 1309 // 1310 %routine Select Constant Area // 1311 Select Area(Constant Area, Constant Base) // 1312 %end // 1313 // 1314 %routine Select Own Area // 1315 Select Area(Own Area, Own Base) // 1316 %end // 1317 // 1318 %routine Select Own Array Area // 1319 Select Area(Own Array Area, Own Array Base) // 1320 %end // 1321 // 1322 %include "plant.inc" // &1 %routine Dump Byte(%integer B) // &2 Printsymbol(Dir Dump); Printsymbol(1) // &3 Printsymbol(B&255) // &4 Ca = Ca+1 // &5 %end // &6 // &7 %routine Dump Half(%integer H) // &8 Printsymbol(Dir Dump); Printsymbol(2) // &9 Printsymbol(H&255) // &10 Printsymbol(H>>8&255) // &11 Ca = Ca+2 // &12 %end // &13 // &14 %routine Dump Word(%integer N) // &15 Printsymbol(Dir Dump); Printsymbol(4) // &16 Printsymbol(N&255) // &17 Printsymbol(N>>8&255) // &18 Printsymbol(N>>16&255) // &19 Printsymbol(N>>24) // &20 Decode(Ca, N) %if Diag & Mon Code # 0 %and Current Area = Code Area // &21 Ca = Ca+4 // &22 %end // &23 // &24 %integerfn Actual Register(%integer Base) // &25 %record(Stackfm)%name T // &26 %if Base >= 128 %start {base reigster not actual register} // &27 %if Base = Local %start // &28 Base = Fp // &29 %else %if Base > 128 {???} // &30 T == Display Info(Base) // &31 Loadup(T) // &32 Base = T_Base // &33 Release and Drop(T) {it will be used immediately ***?***} // &34 %finish // &35 %finish // &36 %result = Actual(Base) // &37 %end // &38 // &39 %integerfn Just(%integer R) // &40 %result = Actual Register(R) // &41 %end // &42 // &43 %integerfn Nothing // &44 %result = 16_0200 0000 // &45 %end // &46 // &47 %integerfn Immediate(%integer N) // &48 %integer Rot = 16 // &49 %if N # 0 %start // &50 Rot = Rot-1 %and N = N>>2 %while N&3 = 0 // &51 %result = -1 %if N>>8 # 0 // &52 %finish // &53 %result = (Rot&15)<<8 ! N ! 16_0200 0000 // &54 %end // &55 // &56 %integerfn Ishift(%integer Rm, By, How) // &57 Fail("Bad immediate shift") %if How&2_1 000 0000 # 0 // &58 %result = Actual Register(Rm) ! (By&2_11111)<<(3+4) ! How // &59 %end // &60 // &61 %integerfn Rshift(%integer Rm, Rs, How) // &62 Fail("Bad register shift") %if How&2_1 000 0000 = 0 // &63 %result = Actual Register(Rm) ! Actual Register(Rs)<<(4+4) ! How&2_0 111 0000 // &64 %end // &65 // &66 %integerfn Rot(%integer N, By) // &67 %result = (N&255 ! By<<8) ! 16_0200 0000 // &68 %end // &69 // &70 %owninteger Pending Pop = 0 // &71 // &72 %routine Plant1(%integer Fn, Rn, Rd, X) // &73 Dump Word((Fn!!Invert Cond) ! Actual Register(Rn)<<16 %c // &74 + ! Actual Register(Rd)<<12 ! X) // &75 Forget(Rd) %unless (Fn>>23)&3 = 2_10 // &76 %end // &77 // &78 %routine Plant2(%integer Fn, Rd, %record(Stackfm)%name V) // &79 %integer N, Shift, Sign, D, P, Base, Vbase, Extra = 0 // &80 %record(Stackfm)%name W // &81 Fn = Fn ! Byte Op %if V_Type = Bytes // &82 Simplify(V) // &83 D = V_Disp // &84 %if V_Form = AutoI %start // &85 D = Type Size(V_Type) // &86 Fn = Fn ! Post Indexed // &87 %else %if V_Form = AutoD // &88 D = -Type Size(V_Type) // &89 Fn = Fn ! Write Back // &90 %else %if V_Form # Direct // &91 Fail("illegal load/store") // &92 %finish // &93 // &94 %if V_Index == NIL %start // &95 Fail("Bad displacement") %unless -16_0FFF <= D <= 16_0FFF // &96 %if D >= 0 %then Fn = Fn ! 16_0080 0000 %c // &97 + %else D = -D // &98 Fn = Fn ! D // &99 %if D = 0 %start // &100 Pending Auto N = 0 // &101 Pending Auto = V_Base // &102 Pending Auto Ca = Ca // &103 %finish // &104 %else {V_Index ## NIL} // &105 Fail("Bad index displacement") %unless D = 0 // &106 N = V_Xsize; Fail("Zero Xsize") %if N = 0 // &107 P = Power(N) // &108 %if P >= 0 %start // &109 Loadup(V_Index) // &110 %else // &111 P = 0 // &112 Sign = N&16_80000000 // &113 P = P+1 %and N = (N>>1)!Sign %while N&1 = 0 // &114 Operate(MULx, V_Index, Literal(N)); V_Xsize = 1 // &115 Loadup(V_Index) // &116 %finish // &117 Fn = Fn ! 16_0080 0000 ! Reg Index ! Ishift(V_Index_Base, P, Logical Left) // &118 %finish // &119 %if V_Base = 0 %start {absolute!!} // &120 %if V_Record == NIL %start // &121 %if V_Area < 0 %start // &122 Loadup(V) // &123 Fn = Fn ! Actual Register(V_Base)<<16 // &124 %else // &125 Fail("No absolute yet") // &126 %finish // &127 %else // &128 Loadup(V_Record) // &129 V_Base = V_Record_Base // &130 Drop(V_Record); V_Record == NIL // &131 Fn = Fn ! Actual Register(V_Base)<<16 // &132 %finish // &133 %else // &134 Fn = Fn ! Actual Register(V_Base)<<16 // &135 %finish // &136 Forget(V_Base) %if FN&(Post Indexed ! Write Back) # 0 // &137 Fn = Fn !! Post Indexed ! Actual Register(Rd)<<12 // &138 Dump Word(Fn!!Invert Cond) // &139 Release(Extra) %if Extra # 0 // &140 %if Fn&16_0010 0000 # 0 %start {load} // &141 Forget(Rd) // &142 %else {store} // &143 Forget Destination(V) // &144 Remember(Rd, V) // &145 %finish // &146 %end // ?W unused // ?VBASE unused // ?BASE unused // ?SHIFT unused // &147 // &148 %routine Plant3(%integer Fn, N) // &149 Dump Word((Fn!!Invert Cond) ! N&16_00FF FFFF) // &150 %end // &151 // &152 %routine Plant4(%integer Fn, Rn, Operand) // &153 Dump Word((Fn!!Invert Cond) ! Actual Register(Rn)<<16 ! Operand&16_FFFF) // &154 Forget(Rn) %if Fn&Write Back # 0 // &155 %end // &156 // &157 %routine Plant5(%integer Fn, Offset) // &158 Dump Word((Fn!!Invert Cond) ! Offset&16_00FF FFFF) // &159 %end // &160 // &161 %routine Plant6(%integer Op, Fd, %record(Stackfm)%name V) // &162 {*** WARNING: the displacement is a WORD offset, not a byte one ***} // &163 %integer N, Shift, Sign, D, P, Base, Vbase // &164 %record(Stackfm)%name W // &165 Simplify(V) // &166 D = V_Disp // &167 Fail("Floating-point alignment") %if D&3 # 0 // &168 D = D//4 {convert to word displacement} // &169 %if V_Form = AutoI %start // &170 D = Type Size(V_Type)>>2 // &171 Op = Op ! Post Indexed // &172 %else %if V_Form = AutoD // &173 D = -(Type Size(V_Type)>>2) // &174 Op = Op ! Write Back // &175 %else %if V_Form # Direct // &176 Fail("illegal load/store") // &177 %finish // &178 %if V_Index ## NIL %start // &179 Fail("Fp Disp?") %unless -255 <= D <= 255 // &180 W == Copy(V) {Note - this reverts to a byte displacement} // &181 Loadup Address(W) // &182 W_Type = V_Type; W_Form = Direct // &183 Plant6(Op, Fd, W) // &184 Release and Drop(W) // &185 %return // &186 %finish // &187 %if D >= 0 %then Op = Op ! 16_0080 0000 %c // &188 + %else D = -D // &189 Op = Op ! D // &190 !!! %if D = 0 %start // &191 !!! Pending Auto N = 2 // &192 !!! Pending Auto = V_Base // &193 !!! Pending Auto Ca = Ca // &194 !!! %finish // &195 %if V_Base = 0 %start {absolute!!} // &196 %if V_Record == NIL %start // &197 %if V_Area < 0 %start // &198 Fail("Bad external") %if V_Type # Integers // &199 Loadup(V) // &200 Op = Op ! Actual Register(V_Base)<<16 // &201 %else // &202 Fail("No absolute yet") // &203 %finish // &204 %else // &205 Loadup(V_Record) // &206 V_Base = V_Record_Base // &207 Drop(V_Record); V_Record == NIL // &208 Op = Op ! Actual Register(V_Base)<<16 // &209 %finish // &210 %else // &211 Op = Op ! Actual Register(V_Base)<<16 // &212 %finish // &213 Forget(V_Base) %if Op&(Post Indexed ! Write Back) # 0 // &214 Op = Op !! Post Indexed ! Actual Register(Fd)<<12 // &215 Dump Word(Op!!Invert Cond) // &216 %if Op&16_0010 0000 # 0 %start {load} // &217 Forget(Fd) // &218 %else {store} // &219 Forget Destination(V) // &220 Remember(Fd, V) // &221 %finish // &222 %end // ?VBASE unused // ?BASE unused // ?P unused // ?SIGN unused // ?SHIFT unused // ?N unused // &223 // &224 %routine Plant7(%integer Op, Fn, Rd, Fm) // &225 Fm = Actual(Fm) %if Op&Small Constant = 0 // &226 Dump Word((Op!!Invert Cond) ! Actual(Fn)<<16 ! Actual(Rd)<<12 ! Fm) // &227 %if Op&16_0010 0000 = 0 %then Forget(Fn) %else Forget(Rd) // &228 %end // &229 // &230 %routine Plant8(%integer Op, Fn, Fm) {CPST} // &231 Fm = Actual(Fm) %if Op&Small Constant = 0 // &232 Dump Word((Op!!Invert Cond) ! Actual(Fn)<<16 ! Fm) // &233 %end // &234 // &235 %routine Plant9(%integer Op, Fn, Fd, Fm) {CPDO} // &236 Fm = Actual(Fm) %if Op&Small Constant = 0 // &237 Dump Word((Op!!Invert Cond) ! Actual(Fn)<<16 ! Actual(Fd)<<12 ! Fm) // &238 Forget(Fd) // &239 %end // &240 %endoffile // 1323 %include "load.inc" // &1 %recordformat Constfm(%integer N, Store, Type, V1, R1, V2, R2) // &2 %constinteger Const Zero = 1, {constant is zero} // &3 + Const Mone = 2, {constant is minus one} // &4 + Const Rot = 3, {get with one rotate} // &5 + Const Not Rot = 4, {get with two rotates} // &6 + Const None = 5 {must go via store} // &7 // &8 %routine Test Assigned // &9 Dir1(Dir Assigned); Ca = Ca+4; Refs = Refs+1 // &10 %end // &11 // &12 %routine Float(%record(Stackfm)%name V, %integer R) // &13 %integer N // &14 %longreal Long // &15 R = FPR %if R = AnyF // &16 %if Iconst(V) %start // &17 %if 0 <= V_Disp <= 5 %or V_Disp = 10 %start // &18 N = V_Disp; N = 7 %if V_Disp = 10 // &19 Plant9(MVF ! Small Constant, 0, R, N) // &20 %else %if -5 <= V_Disp <= 0 %or V_Disp = -10 // &21 N = -V_Disp; N = 7 %if N = 10 // &22 Plant9(MNF ! Small Constant, 0, R, N) // &23 %else // &24 Long = V_Disp; V_Rval = Long // &25 Convert Format(V, Lreals) // &26 Store Real Constant(V) // &27 Dir4(Dir Real Load, Actual(R), V_Disp, 1); Forget(R) // &28 Refs = Refs+1; Ca = Ca+4 // &29 %finish // &30 %else // &31 Loadup(V) // &32 Plant7(FLT, R, V_Base, 0); Release(V_Base) // &33 %finish // &34 V_Type = Lreals; V_Form = Address // &35 V_Base = R; V_Disp = 0 // &36 V_Area = 0 // &37 Claim(R) // &38 %end // &39 // &40 %routine Load Safely(%record(Stackfm)%name V, %integer R) // &41 %if R = Any %start // &42 Load Protected(V) // &43 %else %if R = AnyF // &44 Float(V, AnyF) %unless Floating(V) // &45 Load Protected(V) // &46 %else // &47 Hazard(R) %unless Activity(R) = 1 %and V_Base = R // &48 Load(V, R) // &49 %finish // &50 %end // &51 // &52 %routine Characterise Constant(%integer N, %record(Constfm)%name C) // &53 %integer Sh, V, S, X // &54 %constbytearray Bits(0:15) = 0, 1, 1, 2, 1, 2, 2, 3, // &55 + 1, 2, 2, 3, 2, 3, 3, 4 // &56 C_N = N // &57 V = N // &58 %if V = 0 %start // &59 C_Type = Const Zero; %return // &60 %else %if V = -1 // &61 C_Type = Const Mone; %return // &62 %else // &63 X = V; S = 0 {count 1 bits} // &64 %cycle // &65 S = S+Bits(X&15); X = X>>4 // &66 %repeat %until X = 0 // &67 // &68 C_Type = Const Rot // &69 C_Type = Const Not Rot %and V = ~V %if S > 16 // &70 // &71 %if V # 0 %start // &72 Sh = 16 // &73 Sh = Sh-1 %and V = V>>2 %while V&3 = 0 // &74 C_R1 = Sh&15; C_V1 = V&255; V = V>>8 // &75 C_R2 = 0; C_V2 = 0 // &76 %if V # 0 %start // &77 Sh = Sh-4 // &78 Sh = Sh-1 %and V = V>>2 %while V&3 = 0 // &79 C_R2 = Sh&15; C_V2 = V&255; V = V>>8 // &80 %finish // &81 %finish // &82 C_Type = Const None %if V # 0 // &83 %finish // &84 %end // &85 // &86 %routine Now in Register(%record(Stackfm)%name V, %integer R, Inherit) // &87 Remember(R, V) %if Inherit # 0 // &88 %if V_Index ## Nil %start // &89 Release and Drop(V_Index); V_Index == Nil // &90 %finish // &91 %if V_Record ## Nil %start // &92 Release and Drop(V_Record); V_Record == Nil // &93 %finish // &94 Release(V_Base) // &95 V_Data = 0; V_Base = R; V_Form = Address; V_Type = Rtype(R) // &96 Claim(R) // &97 %end // &98 // &99 %routine Simple Load(%record(Stackfm)%name V, %integer R) // &100 %record(Stackfm)%name W, B1, B2 // &101 %record(Constfm) C // &102 %integer P, N, X, T, Check // &103 // &104 Optimise(V, 1) // &105 %if InReg(V) %start // &106 %return %if V_Base = R %or (R = Any %and V_Base <= Any) %c // &107 + %or (R = AnyF %and V_Base >= F0) // &108 %finish // &109 // &110 %if R = Any %then R = Gpr %else %if R = AnyF %then R = Fpr // &111 Hazard(R) %unless V_Base = R %and Activity(R) = 1 // &112 // &113 Simplify(V) // &114 // &115 Float(V, R) %and %return %if R >= F0 %and %not Floating(V) // &116 // &117 %if Iconst(V) %start // &118 Characterise Constant(V_Disp, C) // &119 %if C_Type = Const Zero %start // &120 Plant1(MOV, 0, R, Rot(0, 0)) // &121 %else %if C_Type = Const Mone // &122 Plant1(MVN, 0, R, Rot(0, 0)) // &123 %else %if C_Type = Const Rot // &124 Plant1(MOV, 0, R, Rot(C_V1, C_R1)) // &125 Plant1(ORR, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0 // &126 %else %if C_Type = Const Not Rot // &127 Plant1(MVN, 0, R, Rot(C_V1, C_R1)) // &128 Plant1(EOR, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0 // &129 %else{%if C_Type = Const None} // &130 Constant Base = (Constant Base+3)&(\3) // &131 W == Literal(Constant Base); W_Form = Direct; W_Area = Constant Area // &132 Select Constant Area // &133 Dump Word(C_N) // &134 Select Code Area // &135 Dir3(Dir Const Load, Actual(R), Constant Base-4); Forget(R) // &136 Refs = Refs+1; Ca = Ca+4 // &137 Release and Drop(W) // &138 %finish // &139 Now in Register(V, R, 1) // &140 %else %if V_Form = Address // &141 %if InReg(V) %start // &142 %if V_Type >= Reals %start // &143 Plant9(MVF, 0, R, V_Base) // &144 %else // &145 Plant1(MOV, 0, R, Just(V_Base)) // &146 %finish // &147 Now in Register(V, R, 1) // &148 %return // &149 %finish // &150 %if V_Type >= Reals %start // &151 Store Real Constant(V) // &152 Dir4(Dir Real Load, Actual(R), V_Disp, 1); Forget(R) // &153 Refs = Refs+1; Ca = Ca+4 // &154 Remember(R, V) // &155 Now in Register(V, R, 1) // &156 %return // &157 %finish // &158 %if V_Area = Constant Area %start // &159 Dir3(Dir Const Addr, Actual(R), V_Disp); Forget(R) // &160 Refs = Refs+1; Ca = Ca+4 // &161 Now in Register(V, R, 1) // &162 %return // &163 %finish // &164 %if V_Index ## NIL %start // &165 %if V_Record ## NIL %and V_Base = 0 %start // &166 Loadup(V_Record) // &167 V_Base = V_Record_Base // &168 Drop(V_Record); V_Record == NIL // &169 %finish // &170 %if V_Base = 0 %start // &171 Not in Yet // &172 %else // &173 P = Power(V_Xsize) // &174 %if P >= 0 %start {can use logical shift} // &175 Loadup(V_Index) // &176 Plant1(ADD, V_Base, R, Ishift(V_Index_Base, P, Logical Left)) // &177 %else {must use multiply} // &178 Operate(MULx, V_Index, Literal(V_Xsize)) // &179 Loadup(V_Index); V_Xsize = 1 // &180 Plant1(ADD, V_Base, R, Just(V_Index_Base)) // &181 %finish // &182 %finish // &183 {at this point R contains BASE + scaled*INDEX} // &184 %if V_Disp > 0 %start // &185 Characterise Constant(V_Disp, C) // &186 %if C_Type = Const Rot %start // &187 Plant1(ADD, R, R, Rot(C_V1, C_R1)) // &188 Plant1(ADD, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0 // &189 %else %if C_Type = Const None // &190 Nasty: Constant Base = (Constant Base+3)&(\3) // &191 Select Constant Area // &192 Dump Word(V_Disp) // &193 Select Code Area // &194 X = GPR // &195 Dir3(Dir Const Load, Actual(X), Constant Base-4); Forget(X) // &196 Refs = Refs+1; Ca = Ca+4 // &197 Plant1(ADD, V_Base, R, Just(X)) // &198 %else // &199 Fail("Bad displacement") // &200 %finish // &201 %else %if V_Disp < 0 // &202 Characterise Constant(-V_Disp, C) // &203 %if C_Type = Const Rot %start // &204 Plant1(SUB, R, R, Rot(C_V1, C_R1)) // &205 Plant1(SUB, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0 // &206 %else %if C_Type = Const None // &207 W == Literal(V_Disp); W_Form = Direct; W_Base = Pc // &208 Loadup(W) // &209 Plant1(SUB, R, R, Just(W_Base)) // &210 Release and Drop(W) // &211 %else // &212 ->Nasty // &213 %finish // &214 %finish // &215 %else {V_Index==NIL} // &216 N = V_Disp; P = ADD // &217 N = -N %and P = SUB %if N < 0 // &218 Characterise Constant(N, C) // &219 %if C_Type = Const Zero %start // &220 Plant1(MOV, 0, R, Just(V_Base)) // &221 %else %if C_Type = Const Rot // &222 Plant1(P, V_Base, R, Rot(C_V1, C_R1)) // &223 Plant1(P, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0 // &224 %else %if C_Type = Const None // &225 W == Literal(C_N); Loadup(W) // &226 Plant1(P, V_Base, R, Just(W_Base)) // &227 Release and Drop(W) // &228 %else // &229 Fail("negate error") // &230 %finish // &231 %finish // &232 Now in Register(V, R, 1) // &233 %else %if V_Form = Direct // &234 Check = V_Flags & Checkable // &235 Check = 0 %if Unassigned = 0 %or V_Flags & Known Ass # 0 // &236 %if V_Area # 0 %start // &237 %if V_Area = Constant Area %start // &238 %if V_Type = Integers %start // &239 Dir3(Dir Const Load, Actual(R), V_Disp) // &240 %else %if V_Type = Lreals // &241 Dir4(Dir Real Load, Actual(R), V_Disp, 1) // &242 %else %if V_Type = Reals // &243 Dir4(Dir Real Load, Actual(R), V_Disp, 0) // &244 %else %if V_Type = Bytes %or V_Type = Shorts // &245 T = V_Type // &246 Amap(V); Load(V, R) // &247 V_Type = T; V_Form = Direct; Load(V, R) // &248 %return // &249 %else // &250 Fail("Bad constant type") // &251 %finish // &252 Refs = Refs+1; Ca = Ca+4 // &253 Forget(R) // &254 Now in Register(V, R, 1) // &255 %return // &256 %finish // &257 %if V_Area < 0 %start // &258 Fail("Bad external spec type") %if V_Type # Integers // &259 Dir3(Dir Spec Load, Actual(R), -V_Area); Forget(R) // &260 Refs = Refs+1; Ca = Ca+4 // &261 Now in Register(V, R, 1) // &262 %return // &263 %finish // &264 %finish // &265 // &266 %if V_Type = Bytes %start // &267 Plant2(LDR, R, V) // &268 Now in Register(V, R, 1) // &269 %if Check # 0 %start // &270 Plant1(CMP ! Scc, R, 0, Immediate(16_80)) // &271 Test Assigned // &272 %finish // &273 %else %if V_Type = Shorts // &274 Simplify(V) // &275 %if V_Index ## NIL %or V_Record ## NIL %start // &276 Loadup Address(V); V_Type = Shorts; V_Form = Direct // &277 %finish // &278 {Be careful to load [base+1] before [base+0] to leave} // &279 {the possibility of auto increment} // &280 B1 == Copy(V); Advance(B1, Bytes, 0) {low byte} // &281 B2 == Copy(V); Advance(B2, Bytes, 1) {high byte} // &282 B1_Flags = B1_Flags ! Known Ass // &283 B2_Flags = B2_Flags ! Known Ass // &284 Load(B2, R14); Load(B1, R); Loadup(B2) {in case of hazard} // &285 %if Check # 0 %start // &286 Plant1(CMP ! Scc, B1_Base, 0, Immediate(16_80)) // &287 Plant1(CMP ! Scc ! Cond EQ, B2_Base, 0, Immediate(16_80)) // &288 Test Assigned // &289 %finish // &290 Plant1(MOV, 0, B2_Base, Ishift(B2_Base, 24, Logical Left)) // &291 Plant1(ORR, B1_Base, R, Ishift(B2_Base, 16, Arithmetic Right)) // &292 Release and Drop Pair(B1, B2) // &293 Now in Register(V, R, 1) // &294 %else %if V_Type = Reals // &295 Plant6(LDFS, R, V) // &296 Now in Register(V, R, 1) // &297 %if Check # 0 %start // &298 B1 == Literal(0) // &299 B1_Type = Lreals; B1_Form = Direct; B1_Base = SB // &300 Loadup(B1); Release and Drop(B1) // &301 Plant8(CMF, B1_Base, R) // &302 Test Assigned // &303 %finish // &304 %else %if V_Type = Lreals // &305 Plant6(LDFD, R, V) // &306 Now in Register(V, R, 1) // &307 %if Check # 0 %start // &308 B1 == Literal(0) // &309 B1_Type = Lreals; B1_Form = Direct; B1_Base = SB // &310 Loadup(B1); Release and Drop(B1) // &311 Plant8(CMF, B1_Base, R) // &312 Test Assigned // &313 %finish // &314 %else // &315 Plant2(LDR, R, V) {default to integer} // &316 Now in Register(V, R, 1) // &317 %if Check # 0 %start // &318 B1 == Literal(0) // &319 B1_Form = Direct; B1_Base = SB // &320 Loadup(B1); Release and Drop(B1) // &321 Plant1(CMP ! Scc, B1_Base, 0, Just(R)) // &322 Test Assigned // &323 %finish // &324 %finish // &325 %else %if V_Form = AutoD // &326 Plant2(LDR, R, V); Forget(V_Base) // &327 Now in Register(V, R, 1) // &328 %else %if V_Form = AutoI // &329 Plant2(LDR, R, V); Forget(V_Base) // &330 Now in Register(V, R, 1) // &331 %else // &332 Fail("Unknown type for LOAD") // &333 %finish // &334 %end // &335 // &336 %routine Multiply(%record(Stackfm)%name V, W, %integer R) // &337 {BEWARE: this uses TEST ZERO and can there for alter INVERT, but} // &338 { multiply can occur during a condition evaluation therefore} // &339 { INVERT needs to be preserved across this call} // &340 // &341 %routine Cmul(%integer From, To, By) // &342 %integer X, Op, With, T // &343 %if By&1 = 0 %start // &344 Op = MOV; With = 0 // &345 %else %if By&3 = 1 // &346 Op = ADD; With = From // &347 %else {By&3 = 3} // &348 By = By+1 // &349 Op = RSB; With = From // &350 %finish // &351 X = 0; X = X+1 %and By = By>>1 %until By&1 # 0 // &352 %if By = 1 %start // &353 T = From // &354 %else // &355 T = Gpr // &356 Cmul(From, T, By) // &357 %finish // &358 Plant1(Op, With, To, Ishift(T, X, Logical Left)) // &359 %end // &360 // &361 %integer L, Inv // &362 %record(Stackfm)%name Z // &363 %if Iconst(W) %start // &364 Load Safely(V, R) // &365 Fail("Zero multiply") %if W_Disp = 0 // &366 Cmul(V_Base, V_Base, W_Disp) // &367 %else // &368 Optimise(V, 1) // &369 Optimise(W, 1) // &370 Z == Literal(0) // &371 %if R = Any %or R = AnyF %or Activity(R) # 0 %start {SCR/87/448} // &372 Load Protected(Z) // &373 %else // &374 Load(Z, R) // &375 %finish // &376 Load Protected(V) // &377 Load Protected(W) // &378 Inv = Invert; Invert = 0 // &379 L = New label // &380 Define Label(L) // &381 Plant1(MOV!Scc, 0, W_Base, Ishift(W_Base, 1, Logical Right)) // &382 Plant1(ADD ! Cond CS, Z_Base, Z_Base, Just(V_Base)) // &383 Plant1(MOV, 0, V_Base, Ishift(V_Base, 1, Logical Left)) // &384 Jump To(L, NE) // &385 Release(V_Base); V_Base = Z_Base; Drop(Z) // &386 Load(V, R) // &387 Invert = Inv // &388 %finish // &389 Release and Drop(W) // &390 %end // &391 // &392 %routine Divide(%record(Stackfm)%name V, W, %integer R, Q, U) // &393 {Q = 0 for quotient, 1 for remainder} // &394 {U = 0 for unsigned} // &395 %integer P, L, Op // &396 %if (Q = 0 %or U = 0) %and Iconst(W) %start // &397 P = Power(W_Disp) // &398 %if P > 0 %start // &399 %if U = 0 %start {unsigned} // &400 %if Q = 0 %start {divide} // &401 W_Disp = P // &402 Op = RSHx // &403 %else {REM} // &404 W_Disp = \((-1)<= RNEGx %or R >= F0 %start // &446 Fail("real load?") %if R <= Any // &447 %if Oper = REXPx %start // &448 Load Safely(V, F0) // &449 Load Pair(V, F0, W, R0) // &450 Prim(Real Exp) // &451 Release and Drop(W) {done here in case of HAZARD corrupting it} // &452 Load(V, R) // &453 %return // &454 %finish // &455 %if Oper < RNEGx %start // &456 V_Link == W; V_Oper = Oper; Load(V, Any) {integer operation} // &457 Load(V, R) // &458 %return // &459 %finish // &460 Load Safely(V, R) // &461 Op = Real Op(Oper) // &462 %if W == NIL %start {neg, abs} // &463 Plant9(Op, 0, V_Base, V_Base) // &464 %else // &465 %if Iconst(W) %and (0 <= W_Disp <= 5 %or W_Disp = 10) %start // &466 Reg2 = W_Disp; Reg2 = 7 %if Reg2 = 10 // &467 Op = Op ! Small Constant // &468 %else // &469 Load(W, AnyF) // &470 Reg2 = W_Base // &471 %finish // &472 Plant9(Op, V_Base, V_Base, Reg2) // &473 %finish // &474 ->OK // &475 %finish // &476 // &477 %if Oper = EXPx %start // &478 Load Safely(V, R1) // &479 Load Pair(V, R1, W, R2) // &480 Prim(IntExp) // &481 Release and Drop(W) {done here in case of HAZARD} // &482 Load(V, R) // &483 %return // &484 %finish // &485 // &486 %if Oper = MODx %start // &487 Load Safely(V, R1) // &488 Load Pair(V, R1, W, R2) // &489 Prim(MODULUS) // &490 Release and Drop(W) // &491 %return // &492 %finish // &493 // &494 Multiply(V, W, R) %and %return %if Oper = MULx // &495 Divide (V, W, R, 0, 1) %and %return %if Oper = DIVx // &496 Divide (V, W, R, 1, 1) %and %return %if Oper = REMx // &497 Divide (V, W, R, 0, 0) %and %return %if Oper = UDIVx // &498 Divide (V, W, R, 1, 0) %and %return %if Oper = UREMx // &499 // &500 %if Oper = SUBx %and Iconst(V) %start // &501 Characterise Constant(V_Disp, Cx) // &502 %if Cx_Type = Const Rot %start // &503 Load(W, R); R = W_Base // &504 Plant1(RSB, W_Base, R, Rot(Cx_V1, Cx_R1)) // &505 Plant1(ADD, R, R, Rot(Cx_V2, Cx_R2)) %if Cx_V2 # 0; ->OK Set // &506 %else %if Cx_Type = Const Mone // &507 Load Safely(W, R); R = W_Base // &508 Plant1(MVN, 0, R, Just(W_Base)) // &509 OK Set: V_Base = R; V_Disp = 0; W_Base = 0; ->OK // &510 %finish // &511 %finish // &512 // &513 %if Pending Auto # 0 %and Oper = ADDx %and Iconst(W) %c // &514 + %and -4095 <= W_Disp <= 4095 %start // &515 Pa = Pending Auto {the optimise will destroy it} // &516 Optimise(V, 1) // &517 %if Inreg(V) %and V_Base = Pa %c // &518 + %and (Pending Auto N = 0 %or |W_Disp>>2| <= 255) %start // &519 Dir3(Dir Modify, Ca-Pending Auto Ca, W_Disp>>Pending Auto N) // &520 Forget(Pa) // &521 Drop(W) // &522 Load Safely(V, R) // &523 %return // &524 %finish // &525 %finish // &526 // &527 %if V_Type = Shorts %and (Oper = ANDx %or Oper = BICx) %and Iconst(W) %start // &528 N = W_Disp // &529 N = \N %if Oper = BICx // &530 %if N>>16 = 0 %start // &531 Release and Drop(W) // &532 %if N <= 255 %start // &533 Advance(V, Bytes, 0) {low byte} // &534 Operate(ANDx, V, Literal(N)) %if N # 255 // &535 Load(V, R) // &536 %else %if N&255 = 0 // &537 V_Oper = 0; V_Link = 0 // &538 Advance(V, Bytes, 1) {high byte} // &539 Operate(ANDx, V, Literal(N>>8)) %if N>>8 # 255 // &540 Operate(LSHx, V, Literal(8)) // &541 Load(V, R) // &542 %else // &543 B == Copy(V); Advance(B, Bytes, 1) {high byte} // &544 Operate(ANDx, B, Literal(N>>8)) %if N>>8 # 255 // &545 Advance(V, Bytes, 0) {low byte} // &546 Operate(ANDx, V, Literal(N&255)) %if N&255 # 255 // &547 {be careful to load [b+1] before [b+0] to leave} // &548 {the possibility of auto increment} // &549 Loadup(B); Load Safely(V, R) // &550 Loadup(B); Load Safely(V, R) {in case of hazard} // &551 Plant1(ORR, V_Base, V_Base, Ishift(B_Base, 8, Logical Left)) // &552 Release and Drop(B) // &553 %finish // &554 %return // &555 %finish // &556 %finish // &557 // &558 Load Safely(V, R); R = V_Base // &559 %if W ## NIL %start // &560 %if Iconst(W) %start // &561 %if Oper = EXTx %start // &562 Plant1(MOV, 0, R, Ishift(V_Base, W_Disp&16_FFFF, Logical Right)) // &563 N = (-1)<<(W_Disp>>16) // &564 Plant1(AND, R, R, Immediate(\N)) // &565 ->OK // &566 %finish // &567 %if Oper = ANDx %and Immediate(W_Disp) < 0 %start // &568 Oper = BICx; W_Disp = \W_Disp // &569 %finish // &570 Characterise Constant(W_Disp, Cx) // &571 %if Cx_Type = Const Mone %start // &572 Plant1(SUB, V_Base, R, Rot(1, 0)) %and ->OK %if Oper = ADDx // &573 Plant1(ADD, V_Base, R, Rot(1, 0)) %and ->OK %if Oper = SUBx // &574 Plant1(MVN, 0, R, Just(V_Base)) %and ->OK %if Oper = XORx // &575 %else %if Cx_Type = Const Rot // &576 ->C2(Oper) // &577 // &578 C2(ADDx): Op = ADD; ->C2OK // &579 C2(SUBx): Op = SUB; ->C2OK // &580 C2(BICx): Op = BIC; ->C2OK // &581 C2( ORx): Op = ORR; ->C2OK // &582 C2(XORx): Op = EOR; ->C2OK // &583 C2(ANDx): Op = AND %and ->C2OK %if Cx_V2 = 0 // &584 ->Hard // &585 // &586 C2OK: Plant1(Op, V_Base, R, Rot(Cx_V1, Cx_R1)) // &587 Plant1(Op, R, R, Rot(Cx_V2, Cx_R2)) %if Cx_V2 # 0 // &588 ->OK // &589 // &590 C2(LSHx): Warn(1, "Dubious shift") %if W_Disp>>5 # 0 // &591 Plant1(MOV, 0, R, Ishift(V_Base, W_Disp&31, Logical Left)); ->OK // &592 C2(RSHx): Warn(1, "Dubious shift") %if W_Disp>>5 # 0 // &593 Plant1(MOV, 0, R, Ishift(V_Base, W_Disp&31, Logical Right)); ->OK // &594 %else %if Cx_Type = Const Not Rot // &595 Characterise Constant(-W_Disp, Cx) // &596 ->Hard %unless Cx_Type = Const Rot // &597 Op = SUB %and ->C2OK %if Oper = ADDx // &598 Op = ADD %and ->C2OK %if Oper = SUBx // &599 Warn(1, "Dubious shift") %if Oper = RSHx %or Oper = LSHx // &600 %finish // &601 %finish // &602 %finish // &603 // &604 Hard: // &605 C2(*): // &606 // &607 Loadup(W) %unless W == NIL // &608 ->C(Oper) // &609 // &610 C(NOTx): Plant1(MVN, 0, R, Just(V_Base)); ->OUT // &611 C(NEGx): Plant1(RSB, V_Base, R, Nothing); ->OUT // &612 C(ABSx): Plant1(ADD!Scc, R, R, Nothing) {set CC} {SCR/87/422} // &613 %begin // &614 %integer Label // &615 Label = New Label // &616 Jump To(Label, GE) // &617 Plant1(RSB, R, R, Nothing) // &618 Define Label(Label) // &619 %end // &620 ->OUT // &621 // &622 C(ADDx): Plant1(ADD, V_Base, R, Just(W_Base)); ->OK // &623 C(SUBx): Plant1(SUB, V_Base, R, Just(W_Base)); ->OK // &624 C(BICx): Plant1(BIC, V_Base, R, Just(W_Base)); ->OK // &625 C(ANDx): Plant1(AND, V_Base, R, Just(W_Base)); ->OK // &626 C( ORx): Plant1(ORR, V_Base, R, Just(W_Base)); ->OK // &627 C(XORx): Plant1(EOR, V_Base, R, Just(W_Base)); ->OK // &628 C(LSHx): Plant1(MOV, 0, R, Rshift(V_Base, W_Base, Logical Left R)); ->OK // &629 C(RSHx): Plant1(MOV, 0, R, Rshift(V_Base, W_Base, Logical Right R)); ->OK // &630 // &631 C(*): Not in Yet // &632 // &633 OK: Release and Drop(W) %if W ## NIL // &634 OUT: // &635 %end // &636 // &637 %routine Load(%record(Stackfm)%name V, %integer R) // &638 ! Monitor(V, "->Load ".RegId(R)) %if Diag&MonMove # 0 // &639 %if V_Oper = 0 %then Simple Load(V, R) %c // &640 + %else Complex Load(V, R) // &641 Monitor(V, "<-Load") %if Diag&MonMove # 0 // &642 %end // &643 // &644 %routine Load Pair(%record(Stackfm)%name A, %integer Ar, // &645 + %record(Stackfm)%name B, %integer Br) // &646 %if B_Oper # 0 %or B_Record ## NIL %or B_Index ## NIL %start // &647 Load(B, Br) // &648 Load(A, Ar) // &649 Load(B, Br) // &650 %else // &651 Load(A, Ar) // &652 Load(B, Br) // &653 Load(A, Ar) // &654 %finish // &655 %end // &656 // &657 %routine Load Trio(%record(Stackfm)%name A, %integer Ar, // &658 + %record(Stackfm)%name B, %integer Br, // &659 + %record(Stackfm)%name C, %integer Cr) // &660 %if B_Oper # 0 %or B_Record ## NIL %or B_Index ## NIL %start // &661 Load(B, Br) // &662 Load Pair(A, Ar, C, Cr) // &663 %else %if C_Oper # 0 %or C_Record ## NIL %or C_Index ## NIL // &664 Load(C, Br) // &665 Load Pair(A, Ar, B, Br) // &666 %else // &667 Load(A, Ar) // &668 Load Pair(B, Br, C, Cr) // &669 %finish // &670 Load(A, Ar); Load(B, Br); Load(C, Cr) // &671 %end // &672 %endoffile // 1324 %include "repeat.inc" // &1 %routine Repeat(%routine Body, %record(Stackfm)%name Times, %integer Inc, How) // &2 %integer Label // &3 %return %if Iconst(Times) %and Times_Disp <= 0 // &4 Loadup(Times) // &5 Label = New Label; Define Label(Label) // &6 Body // &7 Plant1(SUB!Scc, Times_Base, Times_Base, Immediate(Inc)) // &8 Jump To(Label, How) // &9 Remember Zero(Times_Base) %if How = NE // &10 Release and Drop(Times) // &11 %end // &12 %endoffile // 1325 // 1326 %integerfn Cheapest(%integer Low, High) // 1327 %integer R, A, U // 1328 %integer Min Activity, // 1329+ Min Known, // 1330+ Min Reg, {default to R3 or F3} // 1331+ Oldest // 1332 // 1333 Min Activity = 1000 // 1334 Min Known = 1000 // 1335 Min Reg = 0 // 1336 Used Time = Used Time+1 // 1337 Oldest = Used Time // 1338 %for R = Low, 1, High %cycle // 1339 A = Activity(R); %continue %if A < 0 {locked} // 1340 U = Used(R) // 1341 %if A = Min Activity %start // 1342 %if Min Known > Ktimes(R) %start // 1343 Min Reg = R // 1344 Min Known = Ktimes(R) // 1345 Oldest = U // 1346 %else %if Min Known = Ktimes(R) // 1347 %if Oldest > U %start {choose the oldest} // 1348 Min Reg = R // 1349 Oldest = U // 1350 %finish // 1351 %finish // 1352 %else %if A < Min Activity // 1353 Min Activity = A // 1354 Min Reg = R // 1355 Min Known = Ktimes(R) // 1356 Oldest = U // 1357 %finish // 1358 %repeat // 1359 Fail("all registers lost") %if Min Reg = 0 // 1360 Used(Min Reg) = Used Time // 1361 Hazard(Min Reg) %unless Min Activity = 0 // 1362 %result = Min Reg // 1363 %end // 1364 // 1365 %integerfn GPR // 1366 %result = Cheapest(R0, R8) // 1367 %end // 1368 // 1369 %integerfn FPR // 1370 %result = Cheapest(F0, F7) // 1371 %end // 1372 // 1373 %record(Stackfm)%map Register(%integer Reg) // 1374 %record(Stackfm)%name R // 1375 R == Descriptor // 1376 %if Reg = Any %start // 1377 R_Type = Integers // 1378 Reg = Cheapest(R0, R8) // 1379 %else %if Reg = AnyF // 1380 R_Type = Lreals // 1381 Reg = Cheapest(F0, F7) // 1382 %else // 1383 R_Type = Integers // 1384 R_Type = Lreals %if Reg >= F0 // 1385 %finish // 1386 R_Base = Reg; Claim(Reg) // 1387 %result == R // 1388 %end // 1389 // 1390 %predicate Locked(%integer R) // 1391 %true %if R >= 128 %or R = 0 %or Activity(R) < 0 // 1392 %false // 1393 %end // 1394 // 1395 %predicate Properly Aligned(%record(Stackfm)%name V, %integer Mask) // 1396 %true %if V_Type = Sets // 1397 %if V_Type = Records %start // 1398 %false %if V_Format >= 0 // 1399 %true %if Var(-V_Format)_Disp = 3 {format needs word alignment} // 1400 %finish // 1401 %false %unless Locked(V_Base) // 1402 %true %if V_Form = Direct %c // 1403+ %and V_Record == Nil %c // 1404+ %and V_Index == Nil %c // 1405+ %and V_Disp&Mask = 0 // 1406 %false // 1407 %end // 1408 // 1409 %include "simplify.inc" // &1 %routine Simplify(%record(Stackfm)%name V) // &2 %integer N, D // &3 %record(Stackfm)%name R, X // &4 // &5 Monitor(V, "->Simplify") %if Diag&MonOperate # 0 // &6 // &7 %if V_Oper # 0 %start {Can do nothing but load it?} // &8 Loadup(V); ->OK // &9 %finish // &10 // &11 %if V_Record ## Nil %start // &12 %if V_Form = Address %and V_Disp = 0 %c // &13 + %and V_Base = 0 %c // &14 + %and V_Index == Nil %start // &15 {it all reduces to just the value of _record} // &16 R == V_Record // &17 V_Data = R_Data // &18 R_Index == Nil; R_Record == Nil; Drop(R) // &19 Simplify(V) // &20 ->OK // &21 %finish // &22 Simplify(V_Record) // &23 Loadup(V_Record) %if V_Record_Index ## Nil %c // &24 + %or V_Record_Form # Address %c // &25 + %or V_Record_Area # 0 // &26 V_Disp = V_Disp+V_Record_Disp; V_Record_Disp = 0 // &27 {V_Record is now either the constant 0 or a register} // &28 %if V_Record_Base = None %start {it's zero} // &29 Drop(V_Record); V_Record == Nil // &30 %else %if V_Base = None {replace the base} // &31 V_Base = V_Record_Base // &32 Drop(V_Record); V_Record == Nil // &33 %else %if V_Index == Nil {make it the index} // &34 V_Index == V_Record; V_Xsize = 1 // &35 V_Record == Nil // &36 %else {combine it with the index} // &37 Operate(ADDx, V_Index, V_Record) // &38 V_Record == Nil // &39 %finish // &40 %finish // &41 // &42 %if V_Index ## Nil %start // &43 Simplify(V_Index) // &44 %if V_Area = Constant Area %start {temp frig} // &45 X == Literal(V_Disp); V_Disp = 0 // &46 X_Area = Constant Area; V_Area = 0 // &47 Loadup(X) // &48 %if V_Base = None %start // &49 V_Base = X_Base // &50 Drop(X) // &51 %else // &52 Operate(MULx, V_Index, Literal(V_Xsize)); V_Xsize = 1 // &53 Operate(ADDx, V_Index, X) // &54 %finish // &55 %else // &56 N = Power(V_Xsize) // &57 %if N < 0 %start // &58 Operate(MULx, V_Index, Literal(V_Xsize)); V_Xsize = 1 // &59 Loadup(V_Index) // &60 %finish // &61 %finish // &62 {There is no disp field on indexed instructions} // &63 %if V_Disp # 0 %start // &64 %if V_Xsize # 1 %start // &65 Operate(MULx, V_Index, Literal(V_Xsize)); V_Xsize = 1 // &66 %finish // &67 Operate(ADDx, V_Index, Literal(V_Disp)); V_Disp = 0 // &68 Loadup(V_Index) // &69 %finish // &70 %finish // &71 // &72 %routine Ensure Displacement(%integer D, Type) // &73 %record(Stackfm)%name W // &74 %if Type = Integers %start // &75 %return %if -16_0FFF <= D <= 16_0FFF // &76 %else // &77 Fail("real address error") %if D&3 # 0 // &78 %return %if -255 <= D//4 <= 255 // &79 %finish // &80 V_Disp = 0 // &81 W == Literal(D); Loadup(W) // &82 %if V_Index == NIL %start // &83 V_Index == W; V_Xsize = 1 // &84 %else // &85 %if V_Xsize # 1 %start // &86 Operate(MULx, V_Index, Literal(V_Xsize)); V_Xsize = 1 // &87 %finish // &88 Operate(ADDx, V_Index, W) // &89 %finish // &90 Simplify(V) // &91 %end // &92 // &93 D = V_Disp // &94 %if Iconst(V) %start {adjust the type of constants} // &95 %if 16_0000 <= D <= 16_00FF %then V_Type = Bytes %c // &96 + %else %if -16_8000 <= D <= 16_7FFF %then V_Type = Shorts // &97 %else %if V_Form # Address // &98 %if V_Type = Lreals %or V_Type = Reals %start // &99 Ensure Displacement(D, Reals) // &100 %else %if V_Type <= Addrs // &101 Ensure Displacement(D, Integers) // &102 %finish // &103 %finish // &104 OK:Monitor(V, "<-Simplify") %if Diag&MonOperate # 0 // &105 %end // &106 %endoffile // 1410 // 1411 %routine Apply Index(%record(Stackfm)%name V, X, %integer Xsize) // 1412 %integer N, MulOp // 1413 %if Iconst(X) %and V_Form = Direct %start {fold it in} // 1414 N = V_Disp+X_Disp*Xsize // 1415 V_Disp = N // 1416 Drop(X) // 1417 %return // 1418 %finish // 1419 %if V_Index == Nil %start {no index, just add the new one} // 1420 V_Index == X; V_Xsize = Xsize // 1421 %else %if V_Xsize = Xsize {equal scaling} // 1422 Operate(ADDx, V_Index, X) {add in the new bit} // 1423 %else {different scaling} // 1424 MulOp = MULx // 1425 Operate(MulOp, V_Index, Literal(V_Xsize)) %unless V_Xsize = 1 // 1426 Operate(MulOp, X, Literal(Xsize)) %unless Xsize = 1 // 1427 Operate(ADDx, V_Index, X) // 1428 V_Xsize = 1 // 1429 %finish // 1430 %end // 1431 // 1432 %routine Fix Unitary String(%record(Stackfm)%name V) // 1433 %integer Len, Val, At // 1434 %owninteger Null Address = -1 // 1435 // 1436 %integerfn Locate(%integer Len, Char) // 1437 %integer Here // 1438 Constant Base = (Constant Base+3)&(\3) // 1439 Here = Constant Base // 1440 Select Constant Area // 1441 Dump Byte(Len); Dump Byte(Char) %if Len # 0 // 1442 Select Code Area // 1443 %result = Here // 1444 %end // 1445 // 1446 %if V_Type = Strings %and V_Bias = 1 %start {""} // 1447 Null Address = Locate(0, 0) %if Null Address < 0 // 1448 At = Null Address // 1449 Len = 1 // 1450 %else %if V_Type = Sets // 1451 Build Set(V); %return // 1452 %else %if V_Type <= Addrs // 1453 Val = V_Disp&255 // 1454 Warn(1, "string character out of range") %if Val # V_Disp // 1455 At = Locate(1, Val) // 1456 Len = 2 // 1457 %else // 1458 Fail("bad tostring type") // 1459 %finish // 1460 V_Disp = At; V_Type = Strings; V_Form = Direct // 1461 V_Area = Constant Area; V_Format = Len; V_Bias = Len // 1462 %end // 1463 // 1464 %routine Amap(%record(Stackfm)%name V) // 1465 %record(Stackfm)%name W // 1466 %if V_Form = Address %start // 1467 Fix Unitary String(V) // 1468 %else %if V_Oper # 0 // 1469 Fail("Amap:oper") // 1470 %finish // 1471 V_Type = Integers {all addresses are integers} // 1472 %return %if V_Form = AutoD {special for the stack} // 1473 // 1474 %if V_Form = Proc %start // 1475 %if V_Flags&Xproc Spec # 0 %start {case 1 - an external} // 1476 Hazard(R13); Forget(R13) // 1477 Dir2(Dir xThunk, V_Disp) { load @vector into R13} // 1478 Refs = Refs+1; Ca = Ca+4 // 1479 V_Type = Integers; V_Form = Address // 1480 V_Base = R13; V_Disp = 0; V_Area = 0 // 1481 Claim(R13) // 1482 %else %if V_Flags&Parameter # 0 {case 2 - already a parameter} // 1483 V_Type = Integers; V_Form = Direct; V_Area = 0 // 1484 %else %if V_Flags&XprocDef # 0 {case 3 - simplified} // 1485 Hazard(R13); Forget(R13) // 1486 Dir2(Dir Thunk, V_Disp) { load @vector into R13} // 1487 Refs = Refs+1; Ca = Ca+4 // 1488 V_Type = Integers; V_Form = Address // 1489 V_Base = R13; V_Disp = 0; V_Area = 0 // 1490 Claim(R13) // 1491 %else {cases 3 & 4} // 1492 Fail("cannot address local procedures") // 1493 %finish // 1494 %else // 1495 Fail("Amap:form") %unless V_Form = Direct // 1496 V_Form = Address // 1497 %if V_Index ## Nil %and Iconst(V_Index) %start // 1498 V_Disp = V_Disp+V_Index_Disp*V_Xsize // 1499 Drop(V_Index); V_Index == Nil // 1500 %finish // 1501 %if V_Disp = 0 %and V_Index == Nil %and V_Record ## Nil %start // 1502 {convert addr 0(X) into X} // 1503 W == V_Record // 1504 V_Data = W_Data // 1505 W_Index == Nil; W_Record == Nil; Drop(W) // 1506 %finish // 1507 %finish // 1508 Monitor(V, "Amap<-") %if Diag&MonOperate # 0 // 1509 %end // 1510 // 1511 %routine Make AutoI(%record(Stackfm)%name V, %integer Type) // 1512 Amap(V) {get its address} // 1513 Load Protected(V) {to a safe register} // 1514 V_Type = Type; V_Form = AutoI // 1515 %end // 1516 // 1517 %routine Vmap(%record(Stackfm)%name V, %integer New Type) // 1518 %record(Stackfm)%name W, C // 1519 %integer D = 0 // 1520 Fail("Vmap:type") %unless Integers <= V_Type <= Addrs // 1521 %if V_Oper = ADDx %start // 1522 C == V_Link // 1523 %if Iconst(C) %start // 1524 D = C_Disp // 1525 Drop(C); V_Link == NIL; V_Oper = 0 // 1526 %finish // 1527 %finish // 1528 Loadup(V) %if V_Oper # 0 {PSR} // 1529 %if V_Form # Address %start // 1530 W == Descriptor; W_Data = V_Data // 1531 V_Data = 0 // 1532 V_Record == W // 1533 V_Disp = D // 1534 %finish // 1535 V_Type = Internal Type(New Type); V_Form = Direct // 1536 V_Format = Type Fmt(New Type) // 1537 Monitor(V, "Vmap<-") %if Diag&MonOperate # 0 // 1538 %end // 1539 // 1540 %routine Fmap(%integer NewType) // 1541 Hazard(Stack_Base) %if InReg(Stack) // 1542 Fail("Bad type for Fmap") %unless Stack_Type = Integers %c // 1543+ %and Stack_Form # Address // 1544 Stack_Form = Proc // 1545 Stack_Type = NewType // 1546 Stack_Flags = Stack_Flags ! Answer ! Parameter // 1547 %end // 1548 // 1549 %routine Advance(%record(Stackfm)%name V, %integer Type, By) // 1550 %integer Check Flag // 1551 %if V_Form # AutoD %start // 1552 Check Flag = V_Flags&Checkable // 1553 Amap(V) // 1554 Operate(ADDx, V, Literal(By)) // 1555 Vmap(V, Type) // 1556 V_Flags = V_Flags ! Check Flag // 1557 %else // 1558 V_Type = Type // 1559 %finish // 1560 %end // 1561 // 1562 !!%include "mtables.inc" {moved outside of mcode.inc because of "context" error} // 1563 !!%include "mcode.inc" // 1564 // 1565 { I need to move the above include in-line to avoid a "* 2755 dictionary full" error} // 1566 // 1567 !########################################################################## // 1568 %routine Machine Code // 1569 !%include "mtables.inc" { moved outside of Machine Code because of "context" error} // 1570 !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ // 1571 %constinteger Max Opcode = 95 // 1572 // 1573 %conststring(4)%array Opcode(1:Max Opcode) = // 1574+ "ABS", "ACS", "ADC", "ADD", "ADF", // 1575+ "AND", "ASN", "ATN", "B", "BAL", // 1576+ "BCC", "BCS", "BEQ", "BGE", "BGT", // 1577+ "BHI", "BIC", "BL", "BLAL", "BLCC", // 1578+ "BLCS", "BLE", "BLEQ", "BLGE", "BLGT", // 1579+ "BLHI", "BLLE", "BLLS", "BLLT", "BLMI", // 1580+ "BLNE", "BLNV", "BLPL", "BLS", "BLT", // 1581+ "BLVC", "BLVS", "BMI", "BNE", "BNV", // 1582+ "BPL", "BR", "BVC", "BVS", "CMF", // 1583+ "CMFE", "CMN", "CMP", "CNF", "CNFE", // 1584+ "COS", "DVF", "EOR", "EXP", "FDV", // 1585+ "FIX", "FLT", "FML", "FRD", "LDF", // 1586+ "LDM", "LDR", "LGN", "LOG", "MNF", // 1587+ "MOV", "MUF", "MVF", "MVN", "ORR", // 1588+ "POL", "POW", "RDF", "RFC", "RFS", // 1589+ "RMF", "RND", "RPW", "RSB", "RSC", // 1590+ "RSF", "SBC", "SIN", "SQT", "STF", // 1591+ "STM", "STR", "SUB", "SUF", "SWI", // 1592+ "TAN", "TEQ", "TST", "WFC", "WFS" // 1593 // 1594 %constbytearray Type(1:Max Opcode) = // 1595+ 10, 10, 1, 1, 10, // 1596+ 1, 10, 10, 5, 5, // 1597+ 5, 5, 5, 5, 5, // 1598+ 5, 1, 5, 5, 5, // 1599+ 5, 5, 5, 5, 5, // 1600+ 5, 5, 5, 5, 5, // 1601+ 5, 5, 5, 5, 5, // 1602+ 5, 5, 5, 5, 5, // 1603+ 5, 5, 5, 5, 9, // 1604+ 9, 1, 1, 9, 9, // 1605+ 10, 10, 1, 10, 10, // 1606+ 7, 7, 10, 10, 6, // 1607+ 4, 2, 10, 10, 10, // 1608+ 1, 10, 10, 1, 1, // 1609+ 10, 10, 10, 7, 7, // 1610+ 10, 10, 10, 1, 1, // 1611+ 10, 1, 10, 10, 6, // 1612+ 4, 2, 1, 10, 3, // 1613+ 10, 1, 1, 7, 7 // 1614 // 1615 %constintegerarray Value(1:Max Opcode) = // 1616+ 16_0E208100,16_0EC08100,16_00A00000,16_00800000,16_0E000100,16_00000000, // 1617+ 16_0EB08100,16_0ED08100,16_EA000000,16_EA000000,16_3A000000,16_2A000000, // 1618+ 16_0A000000,16_AA000000,16_CA000000,16_8A000000,16_01C00000,16_EB000000, // 1619+ 16_EB000000,16_3B000000,16_2B000000,16_DA000000,16_0B000000,16_AB000000, // 1620+ 16_CB000000,16_8B000000,16_DB000000,16_9B000000,16_BB000000,16_4B000000, // 1621+ 16_1B000000,16_FB000000,16_5B000000,16_9A000000,16_BA000000,16_7B000000, // 1622+ 16_6B000000,16_4A000000,16_1A000000,16_FA000000,16_5A000000,16_EA000000, // 1623+ 16_7A000000,16_6A000000,16_0E90F110,16_0ED0F110,16_01600000,16_01400000, // 1624+ 16_0EB0F110,16_0EF0F110,16_0E908100,16_0E400100,16_00200000,16_0E708100, // 1625+ 16_0EA00100,16_0E100110,16_0E000110,16_0E900100,16_0EB00100,16_0C100100, // 1626+ 16_08100000,16_04100000,16_0E608100,16_0E508100,16_0E108100,16_01A00000, // 1627+ 16_0E100100,16_0E008100,16_01E00000,16_01800000,16_0EC00100,16_0E600100, // 1628+ 16_0E500100,16_0E500110,16_0E300110,16_0E800100,16_0E308100,16_0E700100, // 1629+ 16_00600000,16_00E00000,16_0E300100,16_00C00000,16_0E808100,16_0E408100, // 1630+ 16_0C000100,16_08000000,16_04000000,16_00400000,16_0E200100,16_0F000000, // 1631+ 16_0EA08100,16_01200000,16_01000000,16_0E400110,16_0E200110 // 1632 // 1633 !%endoffile // 1634 !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ // 1635 // 1636 %integer Op Num, Op Type, Op Value=0, Op Length // 1637 %integer Operands, N, J, Key, P, X = 0, SymP, Disp // 1638 %integer Rn, Rd, Rs, Rm, Sh, Rot, Ud, Reg1, Reg2 // 1639 %integer Fdst, Fs1, Fs2 // 1640 %string(7) Op String // 1641 %record(Varfm)%name W // 1642 %switch Ot(-1:10) // 1643 // 1644 %routine Mc Error(%string(127) Text) // 1645 %routine Err(%integer Stream) // 1646 Select Output(Stream) // 1647 Printstring("*"); Write(Current Line, 4) // 1648 Printstring(" ".Op String.": ".Text) // 1649 Newline // 1650 %end // 1651 Err(Listing) {listing} // 1652 Err(Report) {terminal} // 1653 Fail("Bang") %if Diag&Mon Bang # 0 // 1654 Interface_Faults = Interface_Faults+1 // 1655 Select Output(Directives Out) // 1656 %signal 14 // 1657 %end // 1658 // 1659 %routine Find Opcode // 1660 %integer Min, Max, P // 1661 %string(4) Key // 1662 Key = "0" { this was a bare 0 - was that some new automatic type casting??? } // 1663 { it gets immediately overwritten so WTF??? } // 1664 Op Length = Length(Op String) // 1665 %if Op Length <= 3 %start // 1666 SymP = Op Length // 1667 Key = Op String // 1668 %else // 1669 SymP = 3 // 1670 { many 'tostring' calls added as that definitely was automatic type casting } // 1671 Key = tostring(Charno(Op String, 1)).tostring(Charno(Op String, 2)).tostring(Charno(Op String, 3)) // 1672 %if Charno(Op String, 1) = 'B' %and Charno(Op String, 2) = 'L' %c // 1673+ %and Op Length >= 4 %start // 1674 Key = Key.tostring(Charno(Op String, 4)) // 1675 SymP = 4 // 1676 %finish // 1677 %finish // 1678 Min = 1; Max = Max Opcode // 1679 %while Min <= Max %cycle // 1680 P =(Min+Max)>>1 // 1681 %if Opcode(P) = Key %start // 1682 Op Num = P; Op Type = Type(Op Num); Op Value = Value(Op Num) // 1683 %return // 1684 %finish // 1685 %if Key > Opcode(P) %then Min = P+1 %else Max = P-1 // 1686 %repeat // 1687 %if Op String = "BYTE" %or Op String = "BYTE1" %start // 1688 Op Num = -1; Op Type = -1; SymP = OpLength // 1689 %else %if Op String = "BYTE2" // 1690 Op Num = -2; Op Type = -1; SymP = OpLength // 1691 %else %if Op String = "BYTE4" // 1692 Op Num = -3; Op Type = -1; SymP = OpLength // 1693 %finish %else Mc Error("unknown opcode") // 1694 %end // 1695 // 1696 %predicate Match(%integer Wanted) // 1697 %false %unless Pending = Wanted // 1698 Readsymbol(Pending) // 1699 %true // 1700 %end // 1701 // 1702 %predicate PMatch(%integer Wanted) // 1703 %false %unless Pending = Wanted ! 128 // 1704 Readsymbol(Pending) // 1705 %true // 1706 %end // 1707 // 1708 %predicate Literal(%integername N) // 1709 %if Match('N') %start // 1710 N = Four Bytes // 1711 %true // 1712 %finish // 1713 %if Match(128+'b') %start // 1714 N = Pending; Readsymbol(Pending) // 1715 %true // 1716 %finish // 1717 %false %unless Match('-') // 1718 Mc Error("constant expected") %unless Literal(N) // 1719 N = -N // 1720 %true // 1721 %end // 1722 // 1723 %routine Want(%integer Sym) // 1724 Mc Error(Tostring(Sym)." expected") %unless Match(Sym) // 1725 %end // 1726 // 1727 %routine Want Literal(%integername N) // 1728 Mc Error("constant expected") %unless Literal(N) // 1729 %end // 1730 // 1731 %routine Register(%integername R) // 1732 Mc Error("Register expected") %unless Literal(R) %and 0 <= R <= 15 // 1733 %end // 1734 // 1735 %routine F Register(%integername R) // 1736 Mc Error("Floating register expected") %unless Literal(R) %c // 1737+ %and 16+0 <= R <= 16+7 // 1738 %end // 1739 // 1740 %routine Set CC // 1741 %constintegerarray CC(0:15) = // 1742+ 'E'<<8 ! 'Q', 'N'<<8 ! 'E', 'C'<<8 ! 'S', 'C'<<8 ! 'C', // 1743+ 'M'<<8 ! 'I', 'P'<<8 ! 'L', 'V'<<8 ! 'S', 'V'<<8 ! 'C', // 1744+ 'H'<<8 ! 'I', 'L'<<8 ! 'S', 'G'<<8 ! 'E', 'L'<<8 ! 'T', // 1745+ 'G'<<8 ! 'T', 'L'<<8 ! 'E', 'A'<<8 ! 'L', 'N'<<8 ! 'V' // 1746 %integer Sym, C // 1747 %if SymP+1 < Op Length %start // 1748 Sym = Charno(Op String, SymP+1)<<8 ! Charno(Op String, SymP+2) // 1749 %for C = 0, 1, 15 %cycle // 1750 %if CC(C) = Sym %start // 1751 Op Value = Op Value ! C<<28 // 1752 SymP = SymP+2 // 1753 %return // 1754 %finish // 1755 %repeat // 1756 %finish // 1757 Op Value = Op Value ! 16_E000 0000 {default to always} // 1758 %end // 1759 // 1760 %routine Comma // 1761 Mc Error("comma missing") %unless Match(',') // 1762 %end // 1763 // 1764 %predicate Omatch(%integer Sym) // 1765 %false %unless SymP < Op Length %and Charno(Op String, SymP+1) = Sym // 1766 SymP = SymP+1 // 1767 %true // 1768 %end // 1769 // 1770 %on 14 %start // 1771 Readsymbol(Pending) %while Pending # ';' // 1772 %else // 1773 Op String = "" // 1774 %while Pending # '_' %cycle // 1775 Op String = Op String.Tostring(Pending) %if Length(Op String) # 7 // 1776 Readsymbol(Pending) // 1777 %repeat // 1778 Readsymbol(Pending) // 1779 Find Opcode // 1780 Set CC %if Op Type > 0 {funnies} %and Op Type # 5 {branch} // 1781 ->Ot(Op Type) // 1782 // 1783 {data processing} // 1784 // 1785 %constbytearray Litsh(1:4) = 2_100 0000, 2_000 0000, // 1786+ 2_010 0000, 2_110 0000 // 1787 // 1788 %constbytearray Regsh(1:4) = 2_101 0000, 2_001 0000, // 1789+ 2_011 0000, 2_111 0000 // 1790 // 1791 %routine Bad Shift // 1792 Mc Error("unknown type of shift") // 1793 %end // 1794 // 1795 %routine Get Shift // 1796 %integer Sh // 1797 %if PMatch('A') %start // 1798 %if PMatch('S') %and PMatch('R') %start // 1799 Sh = 1 // 1800 %else // 1801 Bad Shift // 1802 %finish // 1803 %else %if PMatch('L') // 1804 %if PMatch('S') %start // 1805 %if PMatch('L') %start // 1806 Sh = 2 // 1807 %else %if PMatch('R') // 1808 Sh = 3 // 1809 %else // 1810 Bad Shift // 1811 %finish // 1812 %else // 1813 Bad Shift // 1814 %finish // 1815 %else %if PMatch('R') // 1816 %if PMatch('R') %start // 1817 Bad Shift %unless PMatch('X') // 1818 Sh = 0 // 1819 %else %if PMatch('O') %and PMatch('R') // 1820 Sh = 4 // 1821 %else // 1822 Bad Shift // 1823 %finish // 1824 %else // 1825 Bad Shift // 1826 %finish // 1827 %if Sh = 0 %start // 1828 Op Value = Op Value ! 2_00000 110 <<4 {RRX} // 1829 %else %if Match('#') // 1830 Want Literal(N) // 1831 Mc Error("shift out of range") %unless 0 <= N <= 32 // 1832 Op Value = Op Value ! (N&31)<<7 ! litsh(Sh) // 1833 %else // 1834 Register(Rs) // 1835 Op Value = Op Value ! Rs<<8 ! regsh(Sh) // 1836 %finish // 1837 %end // 1838 // 1839 Ot(1):Key = Op Value>>23&3 // 1840 N = Op Value>>21&15 // 1841 Rn = 0; Rd = 0; Rm = 0; Rs = 0 // 1842 %if Omatch('S') %start // 1843 Op Value = Op Value ! 1<<20 // 1844 %finish // 1845 %if Omatch('P') %start // 1846 Warn(1, "spurious P qualifier") %unless Key = 2_10 // 1847 Rd = 15 // 1848 %finish // 1849 Register(Rn) // 1850 %if Key # 2_10 %start // 1851 Rd = Rn; Rn = 0 // 1852 %if N # 13 %and N # 15 %start // 1853 Comma // 1854 Register(Rn) // 1855 %finish // 1856 %finish // 1857 Op Value = Op Value ! Rd<<12 ! Rn<<16 // 1858 Comma // 1859 %if Match('#') %start // 1860 Want Literal(N) // 1861 Rot = 16 // 1862 %if N # 0 %start // 1863 Rot = Rot-1 %and N = N>>2 %while N&3 = 0 // 1864 %finish // 1865 Mc Error("cannot generate constant") %if N>>8 # 0 // 1866 Op Value = Op Value ! (Rot&15)<<8 ! N ! 16_0200 0000 // 1867 %else // 1868 Register(Rm) // 1869 Get Shift %if Match(',') // 1870 Op Value = Op Value ! Rm // 1871 %finish // 1872 ->OK // 1873 // 1874 %routine Get Displacement(%integer Mode) // 1875 %integer Rm // 1876 Ud = 1 // 1877 %if Match('#') %start // 1878 Want Literal(Disp) // 1879 Ud = 0 %and Disp = -Disp %if Disp < 0 // 1880 %else // 1881 Disp = 0 // 1882 %if Match('-') %start // 1883 Ud = 0 // 1884 %else %if Match('+') // 1885 %finish // 1886 Register(Rm) // 1887 Op Value = Op Value ! Rm ! 16_0200 0000 // 1888 Get Shift %if Match(',') // 1889 %finish // 1890 Op Value = Op Value ! Mode // 1891 %end // 1892 // 1893 %routine Modify Disp // 1894 %integer Sign, Mod // 1895 Sign = Pending // 1896 %return %unless Match('+') %or Match('-') // 1897 Mc Error("constant expected") %unless Literal(Mod) // 1898 Mod = -Mod %if Sign = '-' // 1899 N = N+Mod // 1900 %end // 1901 // 1902 Ot(2):%if Omatch('B') %start // 1903 Op Value = Op Value ! 1<<22 {byte value} // 1904 %finish // 1905 %if Omatch('T') %start // 1906 Op Value = Op Value ! 1<<21 {translate bit} // 1907 %finish // 1908 Register(Rd) // 1909 Op Value = Op Value ! Rd<<12 // 1910 Comma // 1911 Ud = 1 // 1912 %if Match(' ') %start {a defined object} // 1913 W == Var(Tag) // 1914 Disp = W_Disp // 1915 Modify Disp // 1916 %if W_Base = Local %start // 1917 Rn = Actual(Fp) // 1918 %else %if W_Base = SB // 1919 Rn = Actual(Sb) // 1920 %else %if W_Base = 0 %and W_Area < 0 // 1921 Dir3(Dir Spec Load, Rd, -W_Area) // 1922 Refs = Refs+1; Ca = Ca+4 // 1923 Rn = Rd // 1924 Disp = 0 // 1925 %finish %else Mc Error("cannot address non-locals") // 1926 Disp = -Disp %and Ud = 0 %if Disp < 0 // 1927 Op Value = Op Value ! 16_0500 0000 ! Rn<<16 // 1928 %else // 1929 Want('[') // 1930 Register(Rn) // 1931 Op Value = Op Value ! Rn<<16 // 1932 %if Match(',') %start { [Rn, D] } // 1933 Warn(1, "spurious translate option") %if Op Value&(1<<21) # 0 // 1934 Get Displacement(16_0500 0000) // 1935 Want(']') // 1936 Op Value = Op Value ! 1<<21 %if Match('!') // 1937 %else // 1938 Want(']') // 1939 %if Match(',') %start { [Rn], D } // 1940 Get Displacement(16_0400 0000) // 1941 %else { [Rn] } // 1942 Disp = 0 // 1943 Op Value = Op Value ! 16_0400 0000 // 1944 %finish // 1945 %finish // 1946 %finish // 1947 Mc Error("displacement too large") %if Disp > 4095 // 1948 Op Value = Op Value ! Ud<<23 ! Disp // 1949 ->OK // 1950 // 1951 {Trap} // 1952 // 1953 Ot(3):Want Literal(N); Op Value = Op Value ! N&16_00FF FFFF; ->OK // 1954 // 1955 {Block data manipulation} // 1956 // 1957 %routine Rlist // 1958 Want('<') // 1959 %unless Pending = '>' %start // 1960 %cycle // 1961 Register(N) // 1962 Op Value = Op Value ! 1<') // 1966 %end // 1967 // 1968 Ot(4):%if Omatch('I') %start // 1969 %if Omatch('A') %start // 1970 Op Value = Op Value ! 2_01<<23 // 1971 %else %if Omatch('B') // 1972 Op Value = Op Value ! 2_11<<23 // 1973 %else // 1974 Mc Error("IA or IB expected") // 1975 %finish // 1976 %else %if Omatch('D') // 1977 %if Omatch('A') %start // 1978 Op Value = Op Value ! 2_00<<23 // 1979 %else %if Omatch('B') // 1980 Op Value = Op Value ! 2_10<<23 // 1981 %else // 1982 Mc Error("DA or DB expected") // 1983 %finish // 1984 %else // 1985 %if Omatch('F') %start // 1986 Op Value = Op Value ! 2_10<<23 // 1987 %else %if Omatch('E') // 1988 Op Value = Op Value ! 2_00<<23 // 1989 %finish // 1990 %if Omatch('A') %start // 1991 Op Value = Op Value ! 2_01<<23 // 1992 %else %if Omatch('D') // 1993 Op Value = Op Value ! 2_00<<23 // 1994 %finish // 1995 %finish // 1996 Register(Rn) // 1997 Op Value = Op Value ! Rn<<16 // 1998 Op Value = Op Value ! 1<<21 %if Match('!') {writeback} // 1999 Comma // 2000 Rlist // 2001 Op Value = Op Value ! 1<<22 %if Match('^') {set PSR} // 2002 ->OK // 2003 // 2004 Ot(5):%if Match(' ') %start {a defined object} // 2005 W == Var(Tag) // 2006 %if W_Type = Labels %start // 2007 Dir3(Dir McLabel, W_Disp, Op Value) // 2008 Ca = Ca+4 // 2009 ->Done // 2010 %finish // 2011 %finish // 2012 Mc Error("Unimplemented form of branch") // 2013 // 2014 %routine Set DS(%integer Let P) // 2015 %if Omatch('D') %start // 2016 Op Value = Op Value ! 16_0000 0080 // 2017 %else %if Omatch('E') // 2018 Op Value = Op Value ! 16_0008 0000 // 2019 %else %if Let P # 0 %and Omatch('P') // 2020 Op Value = Op Value ! 16_0008 0080 // 2021 %else %unless Omatch('S') // 2022 McError("D, S, E or P wanted") // 2023 %finish // 2024 %end // 2025 // 2026 %routine Lit Reg(%integername R) // 2027 %if Match('#') %start // 2028 Want Literal(R) // 2029 %if R = 1 %and Match('/') %start // 2030 Want Literal(R) // 2031 McError("only 1/2 permitted") %if R # 2 // 2032 R = 6 // 2033 %else // 2034 McError("bad range") %unless 0 <= R <= 5 %or R = 10 // 2035 R = 7 %if R = 10 // 2036 %finish // 2037 R = R ! 8 // 2038 %else // 2039 F Register(R); R = R&7 // 2040 %finish // 2041 %end // 2042 // 2043 Ot(6): %if Omatch('S') %start // 2044 %else %if Omatch('D') // 2045 Op Value = Op Value ! 2_000000000 0 000000 1 000000000000000 // 2046 %else %if Omatch('E') // 2047 Op Value = Op Value ! 2_000000000 1 000000 0 000000000000000 // 2048 %else %if Omatch('P') // 2049 Op Value = Op Value ! 2_000000000 1 000000 1 000000000000000 // 2050 %finish // 2051 F Register(Fdst); Comma // 2052 Ud = 1 // 2053 %if Match(' ') %start {a defined object} // 2054 W == Var(Tag) // 2055 Disp = W_Disp // 2056 Modify Disp // 2057 %if W_Base = Local %start // 2058 Rn = Actual(Fp) // 2059 %else %if W_Base = SB // 2060 Rn = Actual(Sb) // 2061 %else %if W_Base = 0 %and W_Area < 0 // 2062 Dir3(Dir Spec Load, Rd, -W_Area) // 2063 Refs = Refs+1; Ca = Ca+4 // 2064 Rn = Rd // 2065 Disp = 0 // 2066 %finish %else Mc Error("cannot address non-locals") // 2067 %else // 2068 Want('[') // 2069 Register(Rn) // 2070 %if Match(',') %start { [Rn, D] } // 2071 Warn(1, "spurious translate option") %if Op Value&(1<<21) # 0 // 2072 Get Displacement(16_0500 0000) // 2073 Want(']') // 2074 Op Value = Op Value ! 1<<21 %if Match('!') // 2075 %else // 2076 Want(']') // 2077 %if Match(',') %start { [Rn], D } // 2078 Get Displacement(16_0400 0000) // 2079 %else { [Rn] } // 2080 Op Value = Op Value ! 16_0400 0000 // 2081 %finish // 2082 %finish // 2083 %finish // 2084 Disp = -Disp %and Ud = 0 %if Disp < 0 // 2085 Mc Error("Alignment error") %if Disp&3 # 0 // 2086 Disp = Disp>>2 // 2087 Mc Error("displacement too large") %if Disp > 255 // 2088 Op Value = Op Value ! Disp ! 16_0500 0000 ! Rn<<16 %c // 2089+ ! (Fdst&7)<<12 ! Ud<<23 // 2090 ->OK // 2091 // 2092 %routine Set Round // 2093 %if Omatch('P') %start // 2094 Op Value = Op Value ! 16_0000 0020 // 2095 %else %if Omatch('M') // 2096 Op Value = Op Value ! 16_0000 0040 // 2097 %else %if Omatch('Z') // 2098 Op Value = Op Value ! 16_0000 0060 // 2099 %finish // 2100 %end // 2101 // 2102 Ot(7): Set DS(0) // 2103 Set Round // 2104 N = Op Value>>20&15 // 2105 %if N = 0 %start {flt} // 2106 F Register(Reg1); Comma; Register(Reg2) // 2107 Op Value = Op Value ! (Reg1&7)<<16 ! Reg2<<12 // 2108 %else %if N = 1 {fix} // 2109 Register(Reg1); Comma; F Register(Reg2) // 2110 Op Value = Op Value ! (Reg1)<<12 ! Reg2&7 // 2111 %else // 2112 Register(Reg1) // 2113 Op Value = Op Value ! Reg1<<12 // 2114 %finish // 2115 ->OK // 2116 // 2117 Ot(9): F Register(Fs1); Comma; Lit Reg(Fs2) // 2118 Op Value = Op Value ! (Fs1&7)<<16 ! Fs2 // 2119 ->OK // 2120 // 2121 Ot(10): Set DS(1) // 2122 Set Round // 2123 F Register(Fdst); Comma // 2124 %if Op Value&16_0000 8000 = 0 %start {dyadic} // 2125 F Register(Fs1); Comma // 2126 %else {monadic} // 2127 Fs1 = 0 // 2128 %finish // 2129 Lit Reg(Fs2) // 2130 Op Value = Op Value ! (Fdst&7)<<12 ! (Fs1&7)<<16 ! Fs2 // 2131 ->OK // 2132 // 2133 Ot(-1): %cycle // 2134 Mc Error("constant expected") %unless Literal(N) // 2135 %if Op Num = -1 %start // 2136 Dump Byte(N&255) // 2137 %else %if Op Num = -2 // 2138 Dump Byte(N&255) // 2139 Dump Byte(N>>8&255) // 2140 %else // 2141 Dump Word(N) // 2142 %finish // 2143 %repeat %until %not Match(',') // 2144 %if Ca&3 # 0 %start // 2145 Dump Byte(0) %until Ca&3 = 0 // 2146 Warn(0, "zero padding bytes added to ensure word alignment") // 2147 %finish // 2148 ->Done // 2149 // 2150 OK: Dump Word(Op Value) // 2151 Done: Mc Error("Too many operands") %unless Match(';') // 2152 Mc Error("spurious operation qualifiers") %if SymP # Op Length // 2153 %finish // 2154 %end // ?SH unused // ?X unused // ?P unused // ?J unused // ?OPERANDS unused // 2155 !%endoffile // 2156 !########################################################################## // 2157 // 2158 %integerfn Uses(%integer R, %record(Stackfm)%name V) // 2159 %integer N = 0 // 2160 %while V ## Nil %cycle // 2161 N = N+1 %if V_Base = R // 2162 N = N+Uses(R, V_Index) %unless V_Index == Nil // 2163 N = N+Uses(R, V_Record) %unless V_Record == Nil // 2164 V == V_Link // 2165 %repeat // 2166 %result = N // 2167 %end // 2168 // 2169 %routine Store Real Constant(%record(Stackfm)%name W) // 2170 %integer N // 2171 %if W_Form = Address %and W_Base = 0 %c // 2172+ %and W_Record == Nil %c // 2173+ %and W_Index == Nil %start {real constant} // 2174 Constant Base = (Constant Base+3)&(\3) // 2175 Select Constant Area // 2176 N = Ca // 2177 Dump Word(W_Rhigh) // 2178 Dump Word(W_Rlow) // 2179 Select Code Area // 2180 W_Disp = N; W_Area = Constant Area; W_Form = Direct // 2181 %finish // 2182 %end // 2183 // 2184 %predicate Potentially Unassigned(%record(Stackfm)%name V) // 2185 %false %if Unassigned = 0 // 2186 %false %if V_Flags&Known Ass # 0 // 2187 %false %unless V_Form = Direct %and V_Flags&Checkable # 0 // 2188 %true // 2189 %end // 2190 // 2191 %routine Simple(%record(Stackfm)%name From, To) // 2192 %record(Stackfm)%name W // 2193 W == Copy(From) // 2194 Move(W, To) // 2195 Release and Drop(W) // 2196 %end // 2197 // 2198 %routine Load Address(%record(Stackfm)%name V, %integer R) // 2199 Amap(V) // 2200 Load(V, R) // 2201 %end // 2202 // 2203 %routine Push(%record(Stackfm)%name V) // 2204 %record(Stackfm) S = 0 // 2205 S_Type = Integers; S_Form = AutoD; S_Base = SP // 2206 Store(V, S) // 2207 %end // 2208 // 2209 %routine Push Literal(%integer Lit) // 2210 %record(Stackfm)%name L == Literal(Lit) // 2211 Push(L) // 2212 Release and Drop(L) // 2213 %end // 2214 // 2215 %routine Push Address(%record(Stackfm)%name V) // 2216 Amap(V) // 2217 Push(V) // 2218 %end // 2219 // 2220 %routine Pop Stack(%integer Bytes) // 2221 %return %if Bytes = 0 // 2222 Fail("stack alignment") %if Bytes&3 # 0 // 2223 Plant1(ADD, Sp, Sp, Rot(Bytes>>2, 16-1)) // 2224 %end // 2225 // 2226 %routine Loadup Address(%record(Stackfm)%name V) // 2227 Amap(V) // 2228 Load(V, Any) // 2229 %end // 2230 // 2231 %routine Loadup(%record(Stackfm)%name From) // 2232 %integer Oper // 2233 %record(stackfm)%name W, Lhs // 2234 %if From_Type = Sets %start // 2235 Fail("Bad set") %if From_Oper = 0 // 2236 Oper = From_Oper; W == From_Link; From_Oper = 0; From_Link == NIL // 2237 %if From_Flags&Work Set = 0 %start // 2238 Lhs == Claim Work Area(Set Size, Sets); Lhs_Flags = Lhs_Flags!Work Set // 2239 Set Assign(From, Lhs) // 2240 Release(From_Base) // 2241 Zap Index and Record(From) // 2242 From_Data = Lhs_Data // 2243 Drop(Lhs) // 2244 %finish // 2245 Lhs == Copy(From) // 2246 From_Oper = Oper; From_Link == W // 2247 Set Assign(From, Lhs) // 2248 Release and Drop(Lhs) // 2249 %else %if Floating(From) // 2250 Load(From, AnyF) // 2251 %else // 2252 Load(From, Any) // 2253 %finish // 2254 %end // 2255 // 2256 %routine Load Protected(%record(Stackfm)%name V) // 2257 {load V somewhere it can be altered safely} // 2258 Monitor(V, "->Load protected") %if Diag&MonOperand # 0 // 2259 Loadup(V) // 2260 %if Activity(V_Base) # 1 %start {covers in use (>1) and locked (<0)} // 2261 %if V_Type >= Reals %then Load(V, FPR) %else Load(V, GPR) // 2262 %finish // 2263 Monitor(V, "<-Load protected") %if Diag&MonOperand # 0 // 2264 %end // 2265 // 2266 %routine Constant Operation(%integer Op, %integername L, // 2267+ %record(Stackfm)%name R) // 2268 %switch Cop(NOTX:REXPX) // 2269 %integer N // 2270 N = R_Disp; Drop(R) // 2271 ->Cop(Op) // 2272 Cop(ADDX): L = L+N; ->Out // 2273 Cop(SUBX): L = L-N; ->Out // 2274 Cop(MULHx): // 2275 Cop(MULX): L = L*N; ->Out // 2276 Cop(ANDx): L = L&N; ->Out // 2277 Cop(BICx): L = L&(\N); ->Out // 2278 Cop( ORX): L = L!N; ->Out // 2279 Cop(XORX): L = L!!N; ->Out // 2280 Cop(LSHX): L = L<Out // 2281 Cop(RSHX): L = L>>N; ->Out // 2282 Cop(EXPX): Fail("Exp") %if N < 0; L = L\\N; ->Out // 2283 Cop(MODx): Fail("Illegal MOD") %if N <= 0 // 2284 %if L < 0 %start // 2285 L = N-Rem(-L, N); L = 0 %if L = N; ->Out // 2286 %finish // 2287 Cop(REMx): Fail("Zero divide") %if N = 0; L = Rem(L, N); ->Out // 2288 Cop(DIVX): Fail("Zero divide") %if N = 0; L = L//N; ->Out // 2289 Cop(*): Fail("C-op") // 2290 Out: // 2291 %end // 2292 // 2293 %routine Operate(%integer NewOper, %record(Stackfm)%name Lhs, Rhs) // 2294 %integer Op, Rconst, Key, Lflags, Rflags, N, Fn // 2295 %record(Stackfm)%name W // 2296 // 2297 %routine Swop // 2298 %record(Stackfm) Temp // 2299 Temp_Data = Lhs_Data // 2300 Lhs_Data = Rhs_Data // 2301 Rhs_Data = Temp_Data // 2302 %end // 2303 // 2304 %routine Zap // 2305 {Make LHS = integer constant 0} // 2306 Drop(W) // 2307 Drop(Rhs) // 2308 Lhs_Link == Nil; Lhs_Oper = 0 // 2309 Rhs == Literal(0); Swop; Release and Drop(Rhs) // 2310 %end // 2311 // 2312 %routine Reduce Constant // 2313 %integer Op, N, F // 2314 // 2315 %routine Fix(%integer Op) // 2316 Lhs_Oper = Op // 2317 Drop(Lhs_Link) // 2318 Lhs_Link == Nil // 2319 %end // 2320 // 2321 Op = Lhs_Oper; F = Oper Flags(Op) // 2322 N = Lhs_Link_Disp // 2323 %if F&Nullop # 0 %and Null Value(Op) = N %start // 2324 Fix(0) // 2325 %else %if Op = MULx // 2326 %if N = 0 %start // 2327 Fix(0) // 2328 Release(Lhs_Base) // 2329 Lhs_Form = Address; Lhs_Base = None; Lhs_Disp = 0; Lhs_Area = 0 // 2330 Release and Drop(Lhs_Index) %if Lhs_Index ## Nil // 2331 Release and Drop(Lhs_Record) %if Lhs_Record ## Nil // 2332 Lhs_Record == Nil; Lhs_Index == Nil // 2333 %else %if N = -1 // 2334 Fix(NEGX) // 2335 %finish // 2336 %else %if Op = ADDx // 2337 %if Lhs_Form = Address %start // 2338 Fix(0); Lhs_Disp = Lhs_Disp+N // 2339 %finish // 2340 %else %if Op = ANDx %and Lhs_Form = Direct %and Lhs_Area = 0 // 2341 N = N&255 %if Lhs_Type = Bytes // 2342 %if Unassigned = 0 %or Lhs_Flags&Checkable = 0 %c // 2343+ %or Lhs_Flags&Known Ass # 0 %start // 2344 {only do this if Lhs is not to be checked for unassigned} // 2345 %if N&16_FFFFFF00 = 0 %start // 2346 Lhs_Type = Bytes // 2347 Fix(0) %if N = 255 // 2348 %else %if N&16_FFFF00FF = 0 %and Lhs_Type = Shorts // 2349 Lhs_Type = Bytes; Lhs_Disp = Lhs_Disp+1 // 2350 N = N>>8; Lhs_Link_Disp = N // 2351 Fix(0) %if N = 255 // 2352 Operate(LSHx, Lhs, Literal(8)) // 2353 %finish // 2354 %finish // 2355 %else %if Op = XORX %and N = -1 // 2356 Fix(NOTX) // 2357 %finish // 2358 %end // 2359 // 2360 %integerfn Field(%integer And, Shift, AndFirst) // 2361 %integer R = 0 // 2362 %if AndFirst # 0 %start {X&And >> Shift} // 2363 And = (And>>Shift)<>1 %and R = R+1 %while And&1 = 0 // 2366 %result = 0 %if Shift < R {shift must equal R} // 2367 {it's now in the form X>>Shift & And} // 2368 %else {X>>Shift & And} // 2369 And = (And<>Shift // 2370 %result = -1 %if And = 0 {zero result} // 2371 %finish // 2372 N = Power(And+1); %result = 0 %if N < 0 %or N > 8 // 2373 %result = N<<16 + Shift // 2374 %end // 2375 // 2376 %if Diag&MonOperate # 0 %start // 2377 Monitor(Lhs, "O-Lhs") // 2378 Monitor(Rhs, "O-Rhs") // 2379 %finish // 2380 Rflags = Oper Flags(NewOper) // 2381 %if Rflags&Unary # 0 %start // 2382 %if Iconst(Lhs) %start {this excludes reals} // 2383 %if NewOper = NEGX %start // 2384 Lhs_Disp = -Lhs_Disp // 2385 %else %if NewOper = NOTX // 2386 Lhs_Disp = \Lhs_Disp // 2387 %else %if NewOper = ABSx // 2388 Lhs_Disp = |Lhs_Disp| // 2389 %finish %else Fail("Operator") // 2390 %else // 2391 NewOper = NewOper+Real Shift %if Floating(Lhs) // 2392 %if Lhs_Oper # 0 %start // 2393 %if Lhs_Oper = NewOper %start {e.g. -(-A) } // 2394 {SCR/87/401} // 2395 Lhs_Oper = 0 %unless NewOper = ABSx %c // 2396+ %or NewOper = RABSx {BEWARE: ABS(ABS(X))} // 2397 ->Mon // 2398 %finish // 2399 %if NewOper = NEGx %or NewOper = NOTx %start {SCR/87/401} // 2400 %if Lhs_Oper = NEGx %or Lhs_Oper = NOTx %start // 2401 { -(\A) -> A+1 Note: -NEG = ADD } // 2402 { \(-A) -> A-1 -NOT = SUB } // 2403 Lhs_Oper = 0 // 2404 %if NewOper = NEGx %then NewOper = ADDx %else NewOper = SUBx // 2405 Operate(NewOper, Lhs, Literal(1)) // 2406 ->Mon // 2407 %finish // 2408 %finish // 2409 %if NewOper = NEGx %and Lhs_Oper = MULx %and Iconst(Lhs_Link) %start // 2410 %if Lhs_Link_Disp # Minus Infinity %start // 2411 Lhs_Link_Disp = -Lhs_Link_Disp // 2412 ->Mon // 2413 %finish // 2414 %finish // 2415 Loadup(Lhs) // 2416 %finish // 2417 Lhs_Oper = NewOper; Lhs_Link == Nil // 2418 %finish // 2419 ->Mon // 2420 %finish // 2421 // 2422 %if NewOper = ConcX %start // 2423 %if Rhs_Bias = 1 %start {s.""} // 2424 Drop(Rhs); %return // 2425 %finish // 2426 %if Lhs_Bias = 1 %start {"".S} // 2427 Fail("inconsistent concatenation") %if Lhs_Link ## Nil // 2428 Lhs_Data = Rhs_Data; Drop(Rhs) // 2429 %return // 2430 %finish // 2431 Loadup(Lhs) %if Lhs_Oper # 0 %and Lhs_Oper # CONCx // 2432 Loadup(Rhs) %if Rhs_Oper # 0 // 2433 Lhs == Lhs_Link %while Lhs_Oper # 0 {skip to the end} // 2434 Lhs_Oper = ConcX; Lhs_Link == Rhs {append the new bit} // 2435 ->Mon // 2436 %finish // 2437 // 2438 Swop %if Rflags&Commutative # 0 %and Iconst(Lhs) {1@? -> ?@1} // 2439 // 2440 %if Rhs_Oper # 0 %start // 2441 Op = Rhs_Oper // 2442 %if Op = NEGx %and (NewOper = ADDx %or NewOper = SUBx) %start // 2443 { Lhs + (-Rhs) } // 2444 NewOper = (ADDx+SUBx)-NewOper { Lhs - Rhs } // 2445 Rflags = Oper Flags(NewOper) // 2446 Rhs_Oper = 0 // 2447 %else %if Op = NOTx %and NewOper = ANDx {convert to BIC} // 2448 Rhs_Oper = 0; NewOper = BICx // 2449 %else %if (Op = LSHx %or Op = RSHx) %and Oper Flags(NewOper)&Easy # 0 %c // 2450+ %and Lhs_Type < Reals %c // 2451+ %and Lhs_Oper < Rnegx // 2452 {optimise A newoper B shift C} // 2453 W == Rhs_Link; Rhs_Link == NIL; Rhs_Oper = 0 // 2454 Loadup(Lhs) // 2455 Loadup(Rhs) // 2456 %if Iconst(W) %start // 2457 %if Op = LSHx %then N = Ishift(Rhs_Base, W_Disp, Logical Left) %c // 2458+ %else N = Ishift(Rhs_Base, W_Disp, Logical Right) // 2459 %else // 2460 Loadup(W) // 2461 %if Op = LSHx %then N = Rshift(Rhs_Base, W_Base, Logical Left R) %c // 2462+ %else N = Rshift(Rhs_Base, W_Base, Logical Right R) // 2463 %finish // 2464 Plant1(Easy Op(NewOper), Lhs_Base, Lhs_Base, N) // 2465 Release and Drop Pair(Rhs, W) // 2466 %return // 2467 %else // 2468 Loadup(Rhs) // 2469 %finish // 2470 %finish // 2471 // 2472 %if Iconst(Rhs) %start // 2473 Rconst = 1 // 2474 %if NewOper = SUBX %start { Lhs-(+const) } // 2475 %if Rhs_Disp # Minus Infinity %start // 2476 Rhs_Disp = -Rhs_Disp // 2477 NewOper = ADDx { Lhs+(-const) } // 2478 Rflags = Oper Flags(ADDx) // 2479 %finish // 2480 %finish // 2481 %if Oper Flags(NewOper)&Nullop # 0 %and Null Value(NewOper) = Rhs_Disp %start // 2482 Drop(Rhs) // 2483 %return // 2484 %finish // 2485 %else // 2486 Rconst = 0 // 2487 %finish // 2488 // 2489 %if Lhs_Oper # 0 %start // 2490 Op = Lhs_Oper; Lflags = Oper Flags(Op) // 2491 W == Lhs_Link // 2492 %if Op = NEGx %and NewOper = MULx %start // 2493 Lhs_Oper = 0 // 2494 Operate(MULx, Lhs, Rhs) // 2495 Operate(NEGx, Lhs, Nil) // 2496 %return // 2497 %finish // 2498 %if Lflags&Unary = 0 %and Iconst(W) %start // 2499 %if Rconst # 0 %and NewOper < RNEGx %start // 2500 Key = (Lflags!Rflags)&Assoc Mask // 2501 %if Key = 0 {strongly associative} %or %c // 2502+ (Key = Weak Assoc {weakly associative} %and NewOper = Op) %start // 2503 %if Rhs_Base = None %or NewOper = ADDX %start // 2504 Constant Operation(NewOper, W_Disp, Rhs) // 2505 Reduce Constant %if Rhs_Base = None // 2506 ->Mon // 2507 %finish // 2508 %finish // 2509 %if Op = LSHx %and NewOper = ANDx %and -31 <= W_Disp <= 0 %start // 2510 N = Field(Rhs_Disp, -W_Disp, 0) // 2511 %if N # 0 %start // 2512 Zap %and ->Mon %if N = -1 // 2513 W_Disp = N; Lhs_Oper = EXTx // 2514 Drop(Rhs) // 2515 ->Mon // 2516 %finish // 2517 %finish // 2518 %if Op = ANDx %and NewOper = RSHx %and 0 <= Rhs_Disp <= 31 %start // 2519 N = Field(W_Disp, Rhs_Disp, 1) // 2520 %if N # 0 %start // 2521 Zap %and ->Mon %if N = -1 // 2522 W_Disp = N // 2523 Lhs_Oper = EXTx // 2524 Drop(Rhs) // 2525 ->Mon // 2526 %finish // 2527 %finish // 2528 !! %if Op = ADDx %and NewOper = MULx %start { (A+c)*m -> Am+cm } // 2529 !! W_Disp = W_Disp*Rhs_Disp // 2530 !! Lhs_Link == Nil; Lhs_Oper = 0 // 2531 !! Operate(MULx, Lhs, Rhs) // 2532 !! Operate(ADDx, Lhs, W) // 2533 !! %return // 2534 !! %finish // 2535 %finish // 2536 %finish // 2537 %if (Op = LSHx %or Op = RSHx) %and Oper Flags(NewOper)&Easy # 0 %c // 2538+ %and NewOper # BICx %c // 2539+ %and Rhs_Type < Reals %start // 2540 Lhs_Link == NIL; Lhs_Oper = 0 // 2541 Loadup(Lhs) // 2542 Loadup(Rhs) // 2543 %if Iconst(W) %start // 2544 %if Op = LSHx %then N = Ishift(Lhs_Base, W_Disp, Logical Left) %c // 2545+ %else N = Ishift(Lhs_Base, W_Disp, Logical Right) // 2546 %else // 2547 Loadup(W) // 2548 %if Op = LSHx %then N =Rshift(Lhs_Base, W_Base, Logical LeftR) %c // 2549+ %else N =Rshift(Lhs_Base, W_Base, Logical RightR) // 2550 %finish // 2551 Fn = Easy Op(NewOper) // 2552 Fn = RSB %if NewOper = SUBx {not commutative} // 2553 Plant1(Fn, Rhs_Base, Lhs_Base, N) // 2554 Release and Drop Pair(Rhs, W) // 2555 %return // 2556 %finish // 2557 Loadup(Lhs) {no other choice} // 2558 %finish // 2559 // 2560 %if Iconst(Lhs) %and Rconst # 0 %and NewOper < RNEGx %start // 2561 Constant Operation(NewOper, Lhs_Disp, Rhs) // 2562 ->Mon // 2563 %finish // 2564 // 2565 %if Lhs_Type >= Reals %or Rhs_Type >= Reals %start // 2566 NewOper = NewOper+Real Shift %unless NewOper >= RNEGx // 2567 %if Lhs_Type = Sets %start // 2568 %if Lhs_Flags = Null Set %start // 2569 Swop %if NewOper = RADDx {keep the other set} // 2570 Rhs_Type = 0 // 2571 %else %if Rhs_Flags = Null Set // 2572 Swop %if NewOper = RMULx {keep the null set} // 2573 Rhs_Type = 0 // 2574 %finish // 2575 Lhs_Oper = NewOper; Lhs_Link == Rhs // 2576 %if Rhs_Type = 0 %start // 2577 Lhs_Oper = 0; Lhs_Link == Nil // 2578 Drop Members(Rhs); Release and Drop(Rhs) // 2579 %finish // 2580 ->Mon // 2581 %finish // 2582 %finish // 2583 // 2584 %if Rflags&Commutative # 0 %and InReg(Rhs) %start // 2585 Swop // 2586 Rconst = 0 // 2587 Rconst = 1 %if Iconst(Rhs) // 2588 %finish // 2589 %if NewOper = SUBx %and Lhs_Form = Address = Rhs_Form %start // 2590 {try to optimise addr(x) - addr(y)} // 2591 %if Lhs_Base = Rhs_Base %and Lhs_Area = Rhs_Area %start // 2592 %if Same(Lhs_Index, Rhs_Index) %and Same(Lhs_Record, Rhs_Record) %c // 2593+ %and Lhs_Xsize = Rhs_Xsize %start // 2594 Lhs_Disp = Lhs_Disp - Rhs_Disp // 2595 Release and Drop(Rhs) // 2596 Release and Drop(Lhs_Index) %if Lhs_Index ## Nil // 2597 Release and Drop(Lhs_Record) %if Lhs_Record ## Nil // 2598 Lhs_Base = 0 // 2599 Lhs_Xsize = 0 // 2600 ->Mon // 2601 %finish // 2602 %finish // 2603 %finish // 2604 Lhs_Oper = NewOper; Lhs_Link == Rhs // 2605 Reduce Constant %if Rconst # 0 // 2606 Mon: // 2607 Monitor(Lhs, "<-Operate") %if Diag&MonOperate # 0 // 2608 %end // 2609 // 2610 %routine Aop // 2611 %integer Type, Format, Size // 2612 %record(Stackfm)%name X // 2613 X == Stack {index value} // 2614 Stack == X_Stack {the base item} // 2615 Size = Item Size(Stack_Format) // 2616 %if Stack_Index == Nil %start // 2617 Stack_Index == X; Stack_Xsize = Size // 2618 %else %if Stack_Xsize = Size // 2619 Operate(ADDx, Stack_Index, X) // 2620 %else // 2621 Type = Stack_Type; Format = Stack_Format // 2622 Amap(Stack) // 2623 Operate(MULx, X, Literal(Size)) // 2624 Operate(ADDx, Stack, X) // 2625 Vmap(Stack, Type); Stack_Format = Format // 2626 %finish // 2627 %end // 2628 // 2629 %routine Operation(%integer Oper) // 2630 %record(Stackfm)%name V // 2631 V == Stack // 2632 Stack == Stack_Stack // 2633 Operate(Oper, Stack, V) // 2634 %end // 2635 // 2636 %routine Replace(%record(Stackfm)%name Old, New) // 2637 Zap Index and Record(Old) // 2638 Release(Old_Base) // 2639 Old_Base = New_Base // 2640 Old_Disp = New_Disp // 2641 Old_Extra = New_Extra // 2642 Old_Type = New_Type // 2643 Old_Form = New_Form // 2644 Old_Format = New_Format // 2645 Old_Area = New_Area // 2646 Old_Oper = 0 // 2647 Old_Link == Nil // 2648 Drop(New) // 2649 %end // 2650 // 2651 {***Register optimisation routines***} // 2652 // 2653 %predicate Memorable(%record(Stackfm)%name V, %record(Knowfm)%name K) // 2654 %integer Op = 0, Scale = 0 // 2655 %if V_Oper # 0 %start // 2656 %false %unless V_Link ## Nil %and Iconst(V_Link) // 2657 Op = V_Oper // 2658 Scale = V_Link_Disp // 2659 %finish // 2660 %false %if V_Index ## Nil %or V_Record ## Nil %or V_Form >= Memorable Limit // 2661 K_Ftype = V_Type<<4+V_Form // 2662 K_Base = V_Base // 2663 K_Disp = V_Disp // 2664 K_Extra = V_Extra // 2665 K_Area = V_Area // 2666 K_Opnd = Scale // 2667 K_Oper = Op // 2668 K_Ftype = Integers<<4 + Address %if Iconst(V) // 2669 %true // 2670 %end // 2671 // 2672 %routine Optimise(%record(Stackfm)%name V, %integer Swanted) // 2673 {Swanted = 0 if destination (address) wanted} // 2674 { = 1 if source (value) wanted} // 2675 %record(Knowfm)%name P // 2676 %record(Knowfm) M // 2677 %record(Stackfm)%name W // 2678 %integer Op // 2679 // 2680 // 2681 P == Knowing; %return %if P == Nil {nothing known} // 2682 // 2683 %if V_Oper # 0 %start // 2684 Op = V_Oper; V_Oper = 0 // 2685 W == V_Link; V_Link == Nil // 2686 Optimise(V, 1) // 2687 Optimise(W, 1) %unless W == Nil // 2688 V_Oper = Op; V_Link == W // 2689 %finish // 2690 // 2691 %if V_Record ## Nil %start // 2692 Optimise(V_Record, 1) // 2693 %if V_Record_Form = Address %start // 2694 Simplify(V) // 2695 P == Knowing; %return %if P == Nil {nothing known} // 2696 %finish // 2697 %finish // 2698 %return %unless Memorable(V, M) {worth looking for?} // 2699 Monitor(V, "Opt") %if Diag&MonOpt # 0 // 2700 // 2701 %routine Set(%integer Form) // 2702 %if V_Oper # 0 %start // 2703 Release and Drop(V_Link) // 2704 V_Oper = 0; V_Link == Nil // 2705 %finish // 2706 V_Type = Integers %if Form = Address %and V_Type <= Addrs {already expanded} // 2707 V_Form = Form // 2708 Release(V_Base) // 2709 V_Area = 0 // 2710 V_Disp = 0; V_Base = P_Reg // 2711 Pending Auto = 0 %if P_Reg = Pending Auto // 2712 Claim(V_Base) // 2713 Monitor(V, "Opt->") %if Diag&MonOpt # 0 // 2714 %end // 2715 // 2716 %cycle // 2717 %if P_Disp = M_Disp %and P_Area = M_Area %and // 2718+ P_Extra = M_Extra %and P_Oper = M_Oper %and // 2719+ P_Base = M_Base %and P_Opnd = M_Opnd %start {Basically ok} // 2720 %if P_Ftype = M_Ftype %and Swanted # 0 %start {exact match} // 2721 Set(Address) // 2722 %return // 2723 %else %if M_Oper = 0 %and M_Ftype&15 # Address {beware real zero} // 2724 %if P_Ftype = Integers<<4+Address %start {we have the address} // 2725 Set(V_Form) // 2726 Optimise(V, 1) %if Swanted # 0 // 2727 %return // 2728 %finish // 2729 %finish // 2730 %finish // 2731 P == P_Link // 2732 %repeat %until P == Nil // 2733 %end // 2734 // 2735 %record(Knowfm)%map NewK // 2736 %record(Knowfm)%name P // 2737 P == Kasl // 2738 %if P == Nil %start // 2739 P == NEW(KnowfmType); P = 0 // 2740 %else // 2741 Kasl == P_Link // 2742 %finish // 2743 %result == P // 2744 %end // 2745 // 2746 %routine Kinc(%record(Knowfm)%name K) // 2747 Ktimes(K_Reg) = Ktimes(K_Reg)+1 // 2748 Ktimes(K_Base) = Ktimes(K_Base)+1 %if K_Base&128 = 0 {beware base registers} // 2749 %end // 2750 // 2751 %routine Kdec(%record(Knowfm)%name K) // 2752 Ktimes(K_Reg) = Ktimes(K_Reg)-1 // 2753 Ktimes(K_Base) = Ktimes(K_Base)-1 %if K_Base&128 = 0 {beware base registers} // 2754 %end // 2755 // 2756 %routine Forget(%integer Register) // 2757 %integername N // 2758 %record(Knowfm)%name K, R // 2759 %return %unless R0 <= Register <= F7 // 2760 Pending Auto = 0 %if Pending Auto = Register // 2761 N == Ktimes(Register) // 2762 Used(Register) = 0 // 2763 %return %if N = 0 {%or Activity(Register) < 0} {004} // 2764 K == Knowing; Knowing == Nil // 2765 %while K ## Nil %cycle // 2766 R == K; K == K_Link // 2767 %if R_Reg = Register %or R_Base = Register %start // 2768 R_Link == Kasl; Kasl == R // 2769 Kdec(R) // 2770 Mon Regid(R_Reg, "Forgotten") %if Diag&MonOpt # 0 // 2771 %else // 2772 R_Link == Knowing; Knowing == R {retain it} // 2773 %finish // 2774 %repeat // 2775 Fail("Register still known") %if N # 0 // 2776 %end // 2777 // 2778 %routine Forget Everything // 2779 %record(Knowfm)%name K // 2780 Pending Auto = 0 // 2781 K == Knowing // 2782 %if K ## Nil %start // 2783 %cycle // 2784 Used(K_Reg) = 0 // 2785 Used(K_Base) = 0 %if K_Base&128 = 0 {beware of level bases} // 2786 Kdec(K) // 2787 %exit %if K_Link == Nil // 2788 K == K_Link // 2789 %repeat // 2790 K_Link == Kasl; Kasl == Knowing // 2791 Knowing == NIL // 2792 %finish // 2793 %end // 2794 // 2795 %routine Inherit(%integer New, Old) // 2796 %record(Knowfm)%name P, K, X // 2797 %return %if New = Old // 2798 Used(New) = Used Time // 2799 P == Knowing // 2800 %while P ## Nil %cycle // 2801 K == P; P == K_Link // 2802 %if K_Reg = Old %start // 2803 Mon Regid(Old, "inherited") %if Diag&MonOpt # 0 // 2804 X == NewK; %return %if X == Nil // 2805 X = K // 2806 X_Reg = New // 2807 X_Link == Knowing; Knowing == X // 2808 Kinc(X) // 2809 %finish // 2810 %repeat // 2811 %end // 2812 // 2813 %routine Remember(%integer Register, %record(Stackfm)%name V) // 2814 %record(Knowfm)%name K // 2815 %record(Knowfm) M // 2816 %return %unless R0 <= Register <= F7 %and Register # Any // 2817 Used(Register) = Used Time // 2818 %if InReg(V) %start {inherit other register's data} // 2819 Inherit(Register, V_Base) // 2820 %return // 2821 %finish // 2822 %return %if Register = V_Base // 2823 %if Memorable(V, M) %start // 2824 K == NewK; %return %if K == Nil // 2825 K = M // 2826 K_Reg = Register // 2827 K_Link == Knowing; Knowing == K // 2828 Kinc(K) // 2829 Monitor(V, "Remember ".Regid(Register)) %if Diag&MonOpt # 0 // 2830 %finish // 2831 %end // 2832 // 2833 %routine Remember Zero(%integer Register) // 2834 %record(Stackfm)%name Zero == Literal(0) // 2835 Forget(Register) // 2836 Remember(Register, Zero) // 2837 Drop(Zero) // 2838 %end // 2839 // 2840 %routine Forget Destination(%record(Stackfm)%name V) // 2841 %integer Low, High, Base = V_Base, Unsafe = 0, Alter // 2842 %record(Knowfm)%name P, K // 2843 Monitor(V, "Forget Dest") %if Diag&MonOpt # 0 // 2844 Forget(V_Base) %and %return %if InReg(V) // 2845 Low = V_Disp; High = Low+Item Size(V_Format)-1 // 2846 High = Low+3 %if High < Low // 2847 P == Knowing; Knowing == Nil // 2848 // 2849 ! // 2850 ! If generated a instruction of form STR _ Rx, y(Rz) then // 2851 ! should forget registers that hold non-address values. // 2852 ! Do not do this if trusted => trusted gets some progs wrong // 2853 ! // 2854 // 2855 %if Interface_Options & LL Trusted = 0 %start // 2856 %if V_Base < 128 %and Activity(V_Base) >= 0 %start // 2857 Unsafe = 1 // 2858 %else %if V_Index ## Nil // 2859 Unsafe = 1 // 2860 %finish // 2861 Monitor N(Unsafe, "Unsafe") %if Diag&MonOpt # 0 // 2862 %finish // 2863 // 2864 %while P ## Nil %cycle // 2865 K == P; P == P_Link // 2866 Alter = 0 // 2867 // 2868 Alter = Unsafe %if K_Base < 128 %and Activity(K_Base) >= 0 // 2869 // 2870 %if K_Ftype&15 # Address %start {can remember addresses} // 2871 Alter = 1 %if K_Base = Base %and Low <= K_Disp <= High // 2872 %finish // 2873 // 2874 %if Alter # 0 %start // 2875 Kdec(K) // 2876 K_Link == Kasl; Kasl == K // 2877 Mon Regid(K_Reg, "Altered") %if Diag&MonOpt # 0 // 2878 %else // 2879 K_Link == Knowing; Knowing == K {remember it} // 2880 %finish // 2881 %repeat // 2882 %end // 2883 // 2884 {Environment handling} // 2885 // 2886 %routine Forget Environment(%integer Label) // 2887 %record(Labelfm)%name L // 2888 %record(Knowfm)%name P, E // 2889 L == Ilabel(Label) // 2890 P == L_Env; L_Env == NIL // 2891 %if P ## NIL %start // 2892 E == P // 2893 P == P_Link %while P_Link ## NIL // 2894 P_Link == Kasl // 2895 Kasl == E // 2896 %finish // 2897 %end // 2898 // 2899 %routine Remember Environment(%integer Label) // 2900 %record(Knowfm)%name K, Top == NIL, P // 2901 Forget Environment(Label) // 2902 K == Knowing // 2903 %while K ## Nil %cycle // 2904 P == NewK {cannot return Nil} // 2905 P = K // 2906 P_Link == Top // 2907 Top == P // 2908 Mon RegId(P_Reg, "in env") %if Diag&MonOpt # 0 // 2909 K == K_Link {onto the next item} // 2910 %repeat // 2911 Ilabel(Label)_Env == Top {remember the start} // 2912 %end // 2913 // 2914 %routine Merge Environment(%integer Label) // 2915 {Update the saved environment of Label with the data in Knowing} // 2916 {Knowing is unaltered} // 2917 %record(Labelfm)%name L // 2918 %record(Knowfm)%name P, K, Next, Top // 2919 Monitor(Nil, "merge") %if Diag&MonOpt # 0 // 2920 %if Knowing == Nil %start // 2921 Forget Environment(Label) // 2922 %else // 2923 L == Ilabel(Label) // 2924 Top == Nil // 2925 Next == L_Env // 2926 %cycle // 2927 P == Next; %exit %if P == Nil // 2928 Next == P_Link // 2929 K == Knowing // 2930 %cycle // 2931 %if K_Reg = P_Reg %and %c // 2932+ K_Disp = P_Disp %and K_Base = P_Base %and %c // 2933+ K_Ftype = P_Ftype %and K_Area = P_Area %and %c // 2934+ K_Opnd = P_Opnd %and K_Oper = P_Oper %start // 2935 P_Link == Top; Top == P // 2936 Mon RegId(P_Reg, "Merged") %if Diag&MonOpt # 0 // 2937 ->Found // 2938 %finish // 2939 K == K_Link // 2940 %repeat %until K == Nil // 2941 {Not Found} // 2942 P_Link == Kasl; Kasl == P {return the cell} // 2943 Found:%repeat // 2944 L_Env == Top // 2945 %finish // 2946 %end // 2947 // 2948 %routine Restore Environment(%integer Label) // 2949 %record(Knowfm)%name P, K, Next // 2950 Forget Everything {dispose of old knowledge} // 2951 Next == Ilabel(Label)_Env // 2952 %cycle // 2953 P == Next; %return %if P == NIL // 2954 Next == P_Link // 2955 K == NewK // 2956 K = P // 2957 K_Link == Knowing; Knowing == K // 2958 Kinc(K) // 2959 Mon RegId(P_Reg, "back") %if Diag&MonOpt # 0 // 2960 %repeat // 2961 %end // 2962 // 2963 {Register Control} // 2964 // 2965 %routine Claim(%integer Register) // 2966 %return %unless R0 <= Register <= AnyF %and Activity(Register) >= 0 // 2967 Activity(Register) = Activity(Register)+1 // 2968 Active Registers = Active Registers+1 // 2969 Used Time = Used Time+1; Used(Register) = Used Time // 2970 Monitor Register(Register, "Claimed") %if Diag&MonReg # 0 // 2971 %end // 2972 // 2973 %routine Release(%integer Register) // 2974 %return %unless R0 <= Register <= AnyF %and Activity(Register) >= 0 // 2975 Activity(Register) = Activity(Register)-1 // 2976 Fail("Register not claimed") %if Activity(Register) < 0 // 2977 Monitor Register(Register, "Released") %if Diag&MonReg # 0 // 2978 Active Registers = Active Registers-1 // 2979 Fail("Register unclaimed") %if Active Registers < 0 // 2980 %end // 2981 // 2982 %routine To Store(%integer Code) // 2983 %if Code # 0 %start // 2984 %if Code = 3 %start {short} // 2985 Loadup(Stack) %if Stack_Type = Bytes // 2986 %else %if Code = 1 {integer} // 2987 Loadup(Stack) %if Stack_Type = Bytes %or Stack_Type = Shorts // 2988 %finish // 2989 %finish // 2990 %if Stack_Form = Address %or Stack_Oper # 0 %or Stack_Index ## Nil %start // 2991 %if Stack_Type = Strings %or Stack_Type = Records %start // 2992 Evaluate String Expression(Stack) {is this ok for records?} // 2993 %else // 2994 Loadup(Stack) // 2995 Hazard(Stack_Base) // 2996 %finish // 2997 %finish // 2998 %end // 2999 // 3000 %routine Pessimise(%record(Stackfm)%name V) // 3001 {this routine forces V into store - either by de-optimising it} // 3002 {or simply by storing it} // 3003 %integer Reg, N, Disp // 3004 %record(Knowfm)%name K // 3005 %record(Stackfm)%name T // 3006 Monitor(V, "Pessimise->") %if Diag&MonOperand # 0 // 3007 Fail("Not loaded") %unless Inreg(V) // 3008 Reg = V_Base // 3009 N = Ktimes(Reg) // 3010 K == Knowing; K == NIL %if N = 0 // 3011 %cycle // 3012 %if K == NIL %start {not known in store} // 3013 Fail("corrupt knowing") %if N # 0 // 3014 Reg = V_Base {Must store it} // 3015 %if R0 <= Reg <= R15 %start {integer} // 3016 T == Claim Work Area(Word Length, Integers) // 3017 %else {floating} // 3018 T == Claim Work Area(2*Word Length, Lreals) // 3019 %finish // 3020 Disp = T_Disp {in case SIMPLE corrupts it} // 3021 Simple(V, T) // 3022 Release(Reg) // 3023 V_Base = Local; V_Disp = Disp; V_Form = Direct // 3024 Drop(T) // 3025 %exit // 3026 %finish // 3027 %if K_Reg = Reg %start // 3028 N = N-1 // 3029 %if K_Oper = 0 = K_Opnd %start // 3030 %if K_Ftype = V_Type<<4 + Direct %and K_Area = V_Area %c // 3031+ %and Locked(K_Base) %start // 3032 Release(Reg) // 3033 V_Base = K_Base // 3034 V_Disp = K_Disp // 3035 V_Extra = K_Extra // 3036 V_Form = Direct // 3037 V_Flags = Known Ass // 3038 Claim(V_Base) // 3039 %exit // 3040 %else %if K_Ftype = Integers<<4 + Address %and K_Base = 0 %c // 3041+ %and K_Area = 0 {constant} // 3042 Release(Reg) // 3043 V_Base = 0; V_Disp = K_Disp // 3044 V_Form = Address // 3045 V_Area = 0 // 3046 V_Flags = Known Ass // 3047 %exit // 3048 %finish // 3049 %finish // 3050 %else %if K_Base = Reg // 3051 N = N-1 // 3052 %finish // 3053 K == K_Link // 3054 %repeat // 3055 Monitor(V, "Pessimise<-") %if Diag&MonOperand # 0 // 3056 %end // 3057 // 3058 %routine Hazard(%integer Reg) // 3059 %integer Register = |Reg| // 3060 {This unpleasant routine has to deal with the horrors of needing} // 3061 {a register and so needing to ensure that it does not hold} // 3062 {useful data already.} // 3063 {***perhaps improve use of PESSIMISE***} // 3064 %record(Stackfm)%name U, R // 3065 %integername N // 3066 %integer Disp, Stored = 0 // 3067 // 3068 %routine Store // 3069 %record(Stackfm)%name T // 3070 %return %if Stored # 0 // 3071 Stored = 1 // 3072 %if R0 <= Register <= R15 %start {integer} // 3073 T == Claim Work Area(Word Length, Integers) // 3074 %else {floating} // 3075 T == Claim Work Area(2*Word Length, Lreals) // 3076 %finish // 3077 Disp = T_Disp // 3078 Simple(RegV(Register), T); Release and Drop(T) // 3079 %end // 3080 // 3081 Monitor Register(Register, "Hazard") %if Diag&MonReg # 0 // 3082 // 3083 N == Activity(Register); %return %if N <= 0 {locked/free} // 3084 U == Using // 3085 %while U ## Nil %cycle // 3086 %if U_Base = Register %start {the index looks after itself} // 3087 Monitor(U, "Hazarding") %if Diag&MonReg # 0 // 3088 %if N = 1 %and Stored = 0 %and InReg(U) %start // 3089 Pessimise(U) // 3090 %return // 3091 %finish // 3092 Store // 3093 %if U_Form = Address %and U_Disp = 0 %and U_Index == Nil %start {it's a regster} // 3094 U_Form = Direct; U_Base = Local; U_Disp = Disp // 3095 %else {make it look like a record} // 3096 Fail("Corrupt record") %if U_Record ## Nil // 3097 R == Local Integer(Disp) // 3098 R_Flags = Hazarded // 3099 U_Base = None; U_Record == R // 3100 %finish // 3101 Release(Register) // 3102 %finish // 3103 U == U_Using // 3104 %repeat // 3105 // 3106 %if N # 0 %start // 3107 Fail("Use lost") %if N # 0 // 3108 %finish // 3109 %end // 3110 // 3111 %routine Hazard All // 3112 Hazard(R0); Hazard(R1); Hazard(R2); Hazard(R3) // 3113 %return %if Active Registers = 0 // 3114 Hazard(R4); Hazard(R5); Hazard(R6); Hazard(R7) // 3115 %return %if Active Registers = 0 // 3116 Hazard(R8); Hazard(R11); Hazard(R14) // 3117 %return %if Active Registers = 0 // 3118 Hazard(F0); Hazard(F1); Hazard(F2); Hazard(F3) // 3119 %return %if Active Registers = 0 // 3120 Hazard(F4); Hazard(F5); Hazard(F6); Hazard(F7) // 3121 %end // 3122 // 3123 {Descriptor Control} // 3124 // 3125 %record(Stackfm)%map Descriptor // 3126 %record(Stackfm)%name V // 3127 %if Dasl == Nil %start {empty, grab some from the heap} // 3128 Dasl == NEW(Stackfm Type) // 3129 Dasl_Using == Nil // 3130 %finish // 3131 V == Dasl; Dasl == V_Using // 3132 V = 0 // 3133 V_Using == Using; Using == V // 3134 %result == V // 3135 %end // 3136 // 3137 %routine Drop All(%record(Stackfm)%name V) // 3138 Drop All(V_Index) %and V_Index == Nil %if V_Index ## Nil // 3139 Drop All(V_Record) %and V_Record == Nil %if V_Record ## Nil // 3140 Drop(V) // 3141 %end // 3142 // 3143 %routine Drop(%record(Stackfm)%name V) // 3144 %record(Stackfm)%name P, E // 3145 Monitor(V, "Drop") %if Diag&MonStack # 0 // 3146 Zap Index and Record(V) // 3147 %if Using == V %start {first is quick} // 3148 Using == V_Using // 3149 %else {otherwise search for it} // 3150 P == Using // 3151 %cycle // 3152 Fail("Not in use") %if P == Nil // 3153 E == P // 3154 P == P_Using // 3155 %repeat %until P == V // 3156 E_Using == P_Using // 3157 %finish // 3158 V_Using == Dasl; Dasl == V // 3159 %end // 3160 // 3161 %routine Release and Drop(%record(Stackfm)%name V) // 3162 Release and Drop(V_Link) %unless V_Link == Nil // 3163 Release(V_Base) // 3164 Drop(V) // 3165 %end // 3166 // 3167 %routine Zap Index and Record(%record(Stackfm)%name V) // 3168 Release and Drop(V_Index ) %and V_Index == Nil %unless V_Index == Nil // 3169 Release and Drop(V_Record) %and V_Record == Nil %unless V_Record == Nil // 3170 %end // 3171 // 3172 %routine Release and Drop Pair(%record(Stackfm)%name A, B) // 3173 Release and Drop(A) // 3174 Release and Drop(B) // 3175 %end // 3176 // 3177 %routine Pop Release and Drop // 3178 %record(Stackfm)%name S // 3179 S == Stack // 3180 Stack == S_Stack // 3181 Release and Drop(S) // 3182 %end // 3183 // 3184 %routine Drop Members(%record(Stackfm)%name S) // 3185 %record(Memberfm)%name M, X // 3186 M == S_Members ; S_Members == Nil // 3187 %while M ## Nil %cycle // 3188 X == M ; M == M_Link // 3189 %if X_Const # 0 %start // 3190 Drop(X_A) // 3191 Drop(X_B) %if X_B ## Nil // 3192 %else // 3193 Release and Drop(X_A) // 3194 Release and Drop(X_B) %if X_B ## Nil // 3195 %finish // 3196 Dispose(X) // 3197 %repeat // 3198 %end // 3199 // 3200 %routine Apply Indirection {to the stack} // 3201 %record(Stackfm)%name W // 3202 W == Stack; Stack == Descriptor // 3203 Stack_Stack == W_Stack // 3204 Stack_Type = W_Type; Stack_Form = Direct; Stack_Record == W // 3205 Stack_Format = W_Format // 3206 W_Type = Integers; W_Form = Direct; W_Format = 0 // 3207 %end // 3208 // 3209 %routine Stack True or False(%integer CC) // 3210 {CC is the condition for TRUE} // 3211 %integer Other, R, Lab // 3212 %record(Stackfm)%name V // 3213 V == Literal(0); Optimise(V, 1) {try for zero=false} // 3214 %if InReg(V) %start {Yes} // 3215 CC = Negated(CC) // 3216 Other = 1 // 3217 %else {No, try for one=true} // 3218 V_Disp = 1; Other = 0 // 3219 %finish // 3220 Load Protected(V); R = V_Base {in case the register is in use} // 3221 Release and Drop(V) // 3222 Fail("register active") %unless Activity(R) = 0 // 3223 Lab = New Label // 3224 Jump To(Lab, CC); V == Literal(Other); Load(V, R); Define Label(Lab) // 3225 Forget(R) // 3226 V_Stack == Stack; Stack == V // 3227 %end // 3228 // 3229 %routine Stack Var(%integer Varno) // 3230 %integer Form, Flags // 3231 %record(Stackfm)%name V // 3232 V == Descriptor // 3233 V_V = Var(Varno) // 3234 V_Varno = Varno // 3235 V_Stack == Stack // 3236 Stack == V // 3237 Attributes = Attributes ! Attr Needs Gp %if Stack_Base = SB // 3238 Form = V_Form // 3239 %if V_Flags&XData Spec # 0 %start // 3240 Flags = V_Flags; V_Flags = 0 // 3241 Apply Indirection // 3242 Stack_Flags = Flags&(\XData Spec) // 3243 %finish // 3244 Apply Indirection %if Form = Indirect {Be careful to use original} // 3245 Monitor(Stack, "Stack Var") %if Diag&MonStack # 0 // 3246 %end // 3247 // 3248 %record(Stackfm)%map Local Integer(%integer Disp) // 3249 %record(Stackfm)%name V // 3250 V == Descriptor // 3251 V_Type = Integers; V_Form = Direct // 3252 V_Base = Local; V_Disp = Disp // 3253 V_Flags = Known Ass // 3254 %result == V // 3255 %end // 3256 // 3257 %record(Stackfm)%map Literal(%integer N) // 3258 %record(Stackfm)%name V // 3259 V == Descriptor // 3260 V_Disp = N // 3261 V_Type = Integers // 3262 V_Flags = Known Ass {ready for form being changed to direct} // 3263 %result == V // 3264 %end // 3265 // 3266 %routine Stack Integer(%integer N) // 3267 %record(Stackfm)%name V // 3268 V == Literal(N) // 3269 V_Stack == Stack // 3270 Stack == V // 3271 %end // 3272 // 3273 %integerfn Popped Value // 3274 %record(Stackfm)%name V // 3275 V == Stack // 3276 Stack == V_Stack // 3277 Drop(V) // 3278 %result = V_Disp // 3279 %end // 3280 // 3281 %record(Stackfm)%map Temporary // 3282 {Cannot use CLAIM WORK AREA as they get released at the end of EACH statement} // 3283 %record(Stackfm)%name V // 3284 Frame = Frame&Alignment Mask - Word Length // 3285 V == Local Integer(Frame) // 3286 %result == V // 3287 %end // 3288 // 3289 %record(Stackfm)%map Copy(%record(Stackfm)%name V) // 3290 %record(Stackfm)%name C // 3291 %result == Nil %if V == Nil // 3292 C == Descriptor // 3293 C_Data = V_Data; Claim(C_Base) // 3294 C_Oper = V_Oper // 3295 C_Index == Copy(V_Index) %unless V_Index == Nil // 3296 C_Record == Copy(V_Record) %unless V_Record == Nil // 3297 C_Link == Copy(V_Link) %unless V_Link == Nil // 3298 %result == C // 3299 %end // 3300 // 3301 {Stack control} // 3302 // 3303 %routine Select(%integer Item) // 3304 %record(Stackfm)%name V, X // 3305 %record(Varfm)%name Field // 3306 V == Stack // 3307 Field == Var(Var(-V_Format)_Extra-Item) // 3308 Fail("Select") %if V_Form = Address // 3309 Stack_Varno = 0 // 3310 {temp frig for A(4)_Sn == S} // 3311 %if V_Form = Direct %and V_Index == Nil %start // 3312 V_Disp = V_Disp+Field_Disp // 3313 V_Type = Field_Type // 3314 V_Form = Field_Form // 3315 V_Format = Field_Format // 3316 V_Flags = Field_Flags // 3317 V_Adata == Field_Adata // 3318 %else {Indirect} // 3319 Amap(V) {ready for REDUCE} // 3320 X == Descriptor // 3321 X_V = Field; X_Base = 0 // 3322 X_Record == V // 3323 Stack == X; X_Stack == V_Stack {re-link it} // 3324 %finish // 3325 Apply Indirection %if Stack_Form = Indirect // 3326 Monitor(Stack, "Select") %if Diag&MonStack # 0 // 3327 %end // 3328 // 3329 {Label & Jump Handling} // 3330 // 3331 %routine X Call(%integer Ep, Stackit, Hazard) // 3332 %record(Stackfm)%name V // 3333 Hazard All %if Hazard > 0 %and Active Registers # 0 // 3334 Dir2(Dir Xcall, Ep); Refs = Refs+1; Ca = Ca+4 // 3335 Forget Everything %unless Hazard < 0 // 3336 Attributes = Attributes!Attr Needs Gp // 3337 %if Stackit # 0 %start // 3338 Attributes = Attributes!Attr Dynamic // 3339 V == Register(Stackit) // 3340 V_Stack == Stack; Stack == V // 3341 %finish // 3342 %end // 3343 // 3344 %routine Check Compiler Label(%integer Label) // 3345 Fail("compiler labels/1") %if Label > Max Label // 3346 %end // 3347 // 3348 %integerfn New Label // 3349 Free Label = Free Label+1 // 3350 Fail("too many internal labels") %if Free Label&16_8000 # 0 // 3351 %result = Free Label // 3352 %end // 3353 // 3354 %routine Jump to(%integer Internal Label, Cond Code) // 3355 Jlab = Internal Label {remember for Events} // 3356 Cond Code = Reverse(Cond Code) %and Invert = 0 %if Invert # 0 // 3357 Dir3(Dir Branch, Internal Label, Cond Code+Unsigned); Unsigned = 0 // 3358 Refs = Refs+1 // 3359 Ca = Ca+4 {assume 2 bytes worth} // 3360 Uncond Jump = Ca %if Cond Code = Always {can't get past here} // 3361 Assign Lock = 0 {no longer safe} // 3362 %end // 3363 // 3364 %routine Define Label(%integer Internal Label) // 3365 Dir2(Dir Label, Internal Label) // 3366 Uncond Jump = -1 {can get here now} // 3367 Assign Lock = 0 {can no-longer remember ass} // 3368 %end // 3369 // 3370 %routine Define Compiler Label(%integer Label) // 3371 %record(Labelfm)%name L // 3372 Check Compiler Label(Label) // 3373 L == Ilabel(Label) // 3374 %if L_Lab&Defined # 0 %start {redefinition} // 3375 Forget Environment(Label) // 3376 L_Lab = New Label // 3377 %finish // 3378 L_Lab = L_Lab!Defined {show it's defined} // 3379 Merge Environment(Label) %if Uncond Jump # Ca // 3380 Define Label(L_Lab&Label Mask) // 3381 Restore Environment(Label) // 3382 %end // 3383 // 3384 %integerfn Forward Label(%integer Label) // 3385 %record(Labelfm)%name L // 3386 L == Ilabel(Label) // 3387 %if L_Lab&Defined # 0 %start {redefine it} // 3388 L_Lab = New Label // 3389 Remember Environment(Label) // 3390 %else {another reference} // 3391 Merge Environment(Label) // 3392 %finish // 3393 %result = L_Lab // 3394 %end // 3395 // 3396 %routine Jump Forward(%integer Label, Cond Code) // 3397 Check Compiler Label(Label) // 3398 Jump To(Forward Label(Label), Cond Code) // 3399 %if Cond Code = NE %and Pending Known Register # 0 %start // 3400 Remember(Pending Known Register, Pending Known) // 3401 %finish // 3402 Pending Known Register = 0 // 3403 %end // 3404 // 3405 %routine Jump Backward(%integer Label) // 3406 %record(Stackfm) C, F // 3407 %record(Stackfm)%name U, CC // 3408 %record(Forfm)%name For == Nil // 3409 %record(Varfm)%name Vr // 3410 %record(Labelfm)%name L // 3411 %integer How // 3412 Check Compiler Label(Label) // 3413 L == Ilabel(Label) // 3414 How = Always // 3415 Fail("Label missing") %if L_Lab&Defined = 0 // 3416 %if Fors ## Nil %and Label = Fors_Label %start {repeat of a %for stat} // 3417 For == Fors; Fors == Fors_Link {unchain this item} // 3418 C_Data = For_Control // 3419 Vmap(C, For_Type) // 3420 Load(C, For_Reg) // 3421 Define Compiler Label(For_Entry) %if For_Entry # 0 // 3422 F_Data = For_Final // 3423 Compare(C, F); Release(C_Base); Release(F_Base) // 3424 How = For_CC // 3425 %finish // 3426 Jump To(L_Lab&Label Mask, How) // 3427 %if For ## Nil %start // 3428 %if How # Always %and Language Flags&Undefined Control # 0 %c // 3429+ %and Unassigned # 0 %start // 3430 CC == Literal(0) // 3431 CC_Data = For_Control // 3432 Vmap(CC, For_Type) // 3433 U == Copy(UaPat); U_Type = For_Type // 3434 Simple(U, CC) {Zap the control variable} // 3435 Forget Destination(CC) {PSR 02NOV87} // 3436 Forget(U_Base) {beware of remembering bytes with zero} // 3437 Release and Drop(U) // 3438 Release and Drop(CC) // 3439 %if For_Control_Varno # 0 %start // 3440 Vr == Var(For_Control_Varno) // 3441 Vr_Flags = Vr_Flags&(\Known Ass) // 3442 %finish // 3443 %finish // 3444 Dispose(For) // 3445 %finish // 3446 %end // 3447 // 3448 %routine Set User Label(%integer Label) // 3449 %record(Varfm)%name V // 3450 V == Var(Label) // 3451 Clear Vars(Label) // 3452 V_Type = Labels // 3453 V_Base = Local // 3454 V_Disp = New Label // 3455 %end // 3456 // 3457 %routine User Jump(%integer Label) // 3458 %owninteger Jout = 0 // 3459 %integer B // 3460 %record(Stackfm)%name Base // 3461 %record(Varfm)%name V // 3462 %record(Varfm) C // 3463 V == Var(Label) // 3464 Set User Label(Label) %if Label > Vars %or V_Disp = 0 {Not in Yet allocated a var} // 3465 B = V_Base // 3466 %if B # Local %start {non-local} // 3467 Base == Display Info(B) // 3468 Release and Drop(Base) // 3469 Base == Literal(0); Base_Base = B; Base_Flags = Known Ass // 3470 Load(Base, Fp) {Restore old Fp} // 3471 Base_Disp = V_Extra; Base_Form = Direct; Base_Flags = Known Ass // 3472 Load(Base, R3); Release and Drop(Base) {new value for SP} // 3473 Do("3L_pascal___jump_out", Jout, 0) // 3474 %finish // 3475 Jump To(V_Disp, Always) // 3476 %end // ?C unused // 3477 // 3478 %routine Mark User Label // 3479 Dir1(Dir Mark User) // 3480 %end // 3481 // 3482 %routine Define User Label(%integer Label) // 3483 %record(Varfm)%name V // 3484 V == Var(Label) // 3485 Set User Label(Label) %if Label > Vars %or V_Disp = 0 {Not in Yet allocated a var} // 3486 Define Label(V_Disp) // 3487 Mark User Label // 3488 Forget Everything // 3489 %end // 3490 // 3491 %routine Return(%integer How) // 3492 %integer Result Reg, Type // 3493 %record(Stackfm)%name V, W // 3494 %if Uncond Jump = Ca %start // 3495 Pop Release and Drop %if How < 0 {remove stacked result} // 3496 %return // 3497 %finish // 3498 V == Nil // 3499 Result Reg = R0 // 3500 Type = Avar_Type // 3501 %if How = True %start // 3502 V == Literal(1) // 3503 %else %if How = False // 3504 V == Literal(0) // 3505 %else %if How # 0 // 3506 V == Stack; Stack == Stack_Stack // 3507 %if How = Map %start // 3508 Amap(V) // 3509 Type = Addrs {map result types are addresses} // 3510 %else %if Type = Strings %or Type = Records // 3511 W == Literal(0) // 3512 W_Type = Type; W_Form = Direct // 3513 W_Record == Local Integer(String Result) // 3514 W_Record_Format = Avar_Format // 3515 %if W_Type = Strings %then String Assign(V, W) %c // 3516+ %else Record Assign(V, W) // 3517 Release and Drop Pair(W, V) // 3518 V == Nil // 3519 %finish // 3520 %finish // 3521 %if V ## Nil %start // 3522 %if Type = Reals %or Type = Lreals %start // 3523 Load(V, F0) // 3524 %else // 3525 Load(V, Result Reg) // 3526 %finish // 3527 Release and Drop(V) // 3528 %finish // 3529 Dir2(Dir Return, Parameter Frame) // 3530 Refs = Refs+1 // 3531 Ca = Ca+4 {assume two bytes} // 3532 Uncond Jump = Ca {Can't get past here} // 3533 Open = 0 {the procedure returns} // 3534 %end // 3535 // 3536 %routine Stab(%record(Stackfm)%name V) // 3537 %record(Stackfm)%name T, TT // 3538 %return %if Iconst(V) // 3539 T == Temporary; TT == Copy(T) {in case of corruption by store} // 3540 Store(V, T) // 3541 Release and Drop(T) // 3542 Replace(V, TT) // 3543 V_Flags = V_Flags!Known Ass // 3544 %end // 3545 // 3546 %routine Compile For(%integer Repeat Label) // 3547 %integer Type, N // 3548 %record(Stackfm)%name Initial, {initial value} // 3549+ Final, {final value} // 3550+ Inc, {increment} // 3551+ Control, {control variable} // 3552+ Increment, {copy of increment} // 3553+ C {copy of control} // 3554 // 3555 %record(Forfm)%name For // 3556 %record(Varfm)%name V // 3557 // 3558 %integerfn Loop Type // 3559 %integer I, N // 3560 %result = 1 %unless Iconst(Initial) %and Iconst(Inc) %c // 3561+ %and Iconst(Final) // 3562 I = Inc_Disp // 3563 N = Final_Disp-Initial_Disp+I // 3564 %if I # 0 %start // 3565 %result = 1 %if N = 0 {zero iterations?} // 3566 %if N!!I >= 0 %and Rem(N, I) = 0 %start {constant} // 3567 %if For Range ## Nil %start // 3568 %unless For Range_Disp <= Initial_Disp <= For Range_Extra %and // 3569+ For Range_Disp <= Final_Disp <= For Range_Extra %start // 3570 %result = 1 {check it dynamically} // 3571 %finish // 3572 For Range == Nil {all OK} // 3573 %finish // 3574 %result = 0 // 3575 %finish // 3576 %finish %else I = 1 // 3577 %if Language Flags&Non Exact For = 0 %start // 3578 Warn(1, "Non-integral %for loop") // 3579 Final_Disp = Initial_Disp+N//I*I // 3580 %finish // 3581 %result = 1 // 3582 %end // 3583 // 3584 Final == Stack // 3585 Inc == Final_Stack // 3586 Initial == Inc_Stack // 3587 Control == Initial_Stack // 3588 Stack == Control_Stack // 3589 // 3590 Stab(Inc) // 3591 Type = Control_Type // 3592 %unless Control_Form = Direct %c // 3593+ %and Control_Index == NIL %c // 3594+ %and Control_Record == NIL %c // 3595+ %and (Control_Base = None %c // 3596+ %or Control_Base = Local %c // 3597+ %or Control_Base = SB) %start // 3598 {protect expensive (i.e. non-local) or moveable control variable} // 3599 Amap(Control); Stab(Control) {save its address} // 3600 %else // 3601 Amap(Control) // 3602 %finish // 3603 Simplify(Control) // 3604 // 3605 For == NEW(ForfmType); For_Link == Fors; Fors == For // 3606 For_Label = Repeat Label // 3607 For_Control = Control_Data // 3608 Vmap(Control, Type); For_Type = Type // 3609 For_Entry = Loop Type {and check on the fly} // 3610 For_AS = 0 {no +1 or -1 yet} // 3611 // 3612 N = Inc_Disp // 3613 For_CC = NE // 3614 %if Language Flags&Non Exact FOR # 0 %and For_Entry # 0 %start // 3615 %if N = 1 %start // 3616 For_CC = LT // 3617 %else %if N = -1 // 3618 For_CC = GT // 3619 %finish %else Fail("corrupt increment") // 3620 %finish // 3621 Increment == Copy(Inc) {beware of corruption in operate} // 3622 Operate(SUBx, Initial, Inc) // 3623 Loadup(Initial); For_Reg = Initial_Base // 3624 Stab(Final); For_Final = Final_Data // 3625 Load(Initial, For_Reg) {beware of HAZARD in STAB} // 3626 %if For_Entry # 0 %start {may never execute the loop} // 3627 %if Language Flags&Undefined Control = 0 %start // 3628 {must save the initial value in case the loop isn't executed} // 3629 C == Copy(Control) // 3630 Store(Initial, C) // 3631 Release and Drop(C) // 3632 %finish // 3633 For_Entry = Repeat Label+2 // 3634 Jump Forward(For_Entry, Always) // 3635 %finish // 3636 Define Compiler Label(Repeat Label) // 3637 // 3638 %if For_AS = 0 %start // 3639 Operate(ADDX, Initial, Increment) // 3640 Load(Initial, For_Reg) {can be removed if desired!} // 3641 %finish // 3642 %if For Range ## Nil %start // 3643 Test Range(Initial, For Range) {check initial value} // 3644 For Range == Nil // 3645 %finish // 3646 Store(Initial, Control) // 3647 For_Control_V_Flags = For_Control_V_Flags!Known Ass // 3648 // 3649 %if Control_Varno # 0 %start // 3650 V == Var(Control_Varno) // 3651 V_Flags = V_Flags!Known Ass // 3652 %finish // 3653 Release and Drop Pair(Control, Initial) // 3654 Release and Drop(Final) // 3655 %end // 3656 // 3657 %record(Stackfm)%map Const String // 3658 %record(Stackfm)%name W // 3659 Constant Base = (Constant Base+3)&(\3) {align it} // 3660 Select Constant Area // 3661 W == Literal(Ca) // 3662 W_Type = Strings; W_Form = Direct // 3663 W_Area = Constant Area // 3664 W_Format = Length(Value_String)+1 // 3665 W_Bias = W_Format // 3666 Dump Text(0) %unless Value_String = "" {I think this is safe?} // 3667 Select Code Area // 3668 %result == W // 3669 %end // 3670 // 3671 %routine Fix Tostring(%record(Stackfm)%name C) // 3672 %record(Stackfm)%name W // 3673 Value_String = Tostring(C_Disp) // 3674 W == Const String // 3675 C_Data = W_Data // 3676 Drop(W) // 3677 %end // 3678 // 3679 %routine Set Size or Type(%integer ST, %record(Stackfm)%name V) // 3680 %integer N // 3681 %if V_Type = Generals %start // 3682 Amap(V) // 3683 V_Disp = V_Disp+ST*Word Length {} // 3684 %else // 3685 %if ST = 1 {sizeof} %start // 3686 N = Item Size(V_Format) // 3687 %if N = 1 %and V_Type = Strings %start {string(*)name} // 3688 Amap(V) // 3689 Advance(V, Integers, Wordlength) // 3690 %return // 3691 %finish // 3692 %else // 3693 N = Type Code(V_Type) // 3694 %finish // 3695 Release(V_Base) // 3696 Zap Index and Record(V) // 3697 V_Data = 0 // 3698 V_Disp = N // 3699 V_Type = Integers // 3700 V_Form = Address // 3701 %finish // 3702 %end // 3703 // 3704 %include "call.inc" // &1 !Revision history // &2 // &3 ! 8-Jul-87 PSR INT was using the wrong instruction format to add the 0.5 // &4 ! - Readsymbol etc weren't hazarding registers // &5 // &6 %routine Apply Trunc(%record(Stackfm)%name V) // &7 %integer R // &8 %return %unless Floating(V) // &9 Load(V, AnyF); Release(V_Base) // &10 R = GPR // &11 Plant7(FIX ! 2_11<<5, 0, R, V_Base) {round to zero} // &12 V_Type = Integers; V_Base = R; Claim(R) // &13 %end // &14 // &15 %routine Convert Function(%integer Op, %record(Stackfm)%name V) // &16 %return %unless Floating(V) // &17 Load(V, F0); Release(F0) // &18 Prim(Op) // &19 V_Type = Integers; V_Base = R0; Claim(R0) // &20 %end // &21 // &22 %routine Apply Round(%record(Stackfm)%name V) // &23 Convert Function(Real Round, V) // &24 %end // &25 // &26 %routine Apply Intpt(%record(Stackfm)%name V) // &27 %integer R // &28 %return %unless Floating(V) // &29 Load(V, AnyF); Release(V_Base) // &30 R = GPR // &31 Plant7(FIX ! 2_10<<5, 0, R, V_Base) {round to minus infinity} // &32 V_Type = Integers; V_Base = R; Claim(R) // &33 %end // &34 // &35 %routine Apply Int(%record(Stackfm)%name V) // &36 %integer R // &37 %return %unless Floating(V) // &38 Load(V, AnyF); Release(V_Base) // &39 Plant9(ADF ! Small Constant, V_Base, V_Base, 6) {add 0.5} // &40 R = GPR // &41 Plant7(FIX ! 2_10<<5, 0, R, V_Base) {round to minus infinity} // &42 V_Type = Integers; V_Base = R; Claim(R) // &43 %end // &44 // &45 %routine X Define(%integername Ep, %string(63) Text, %integer P) // &46 %record(Varfm) C = 0 // &47 %if Ep = 0 %start // &48 External Id = Text // &49 %if P = 0 %start {data} // &50 Dump External(2_00, C) // &51 Ep = C_Area // &52 %else // &53 C_Form = Proc // &54 Dump External(2_10, C) // &55 Ep = C_Disp // &56 %finish // &57 %finish // &58 %end // &59 // &60 %routine Stack Register(%integer R) // &61 %record(Stackfm)%name X == Literal(0) // &62 X_Base = R; Claim(R) // &63 X_Stack == Stack; Stack == X // &64 %end // &65 // &66 %routine Do(%string(31) Ident, %integername Ep, %integer Result) // &67 X Define(Ep, Ident, 1) // &68 X Call(Ep, Result, 1) // &69 %end // &70 // &71 %routine Do Conditional External(%integer CC, %string(31) Ident, // &72 + %integername Ep) // &73 %integer Label // &74 X Define(Ep, Ident, 1) // &75 Hazard All %if Active Registers # 0 // &76 %if CC # Always %start // &77 Label = New Label // &78 Jump To(Label, Negated(CC)) // &79 %finish // &80 X Call(Ep, 0, 0) // &81 Define Label(Label) %if CC # Always // &82 %end // &83 // &84 %routine Special Call(%integer N) // &85 %record(Stackfm)%name V == Stack, X, Y, Z // &86 %owninteger Readch Ep = 0, Iread = 0, Rread = 0, Sread = 0, Nextch Ep = 0 // &87 %integer Type // &88 %constinteger Max Special = 59 // &89 %switch Sp(1:Max Special) // &90 %constbytearray Type Map(3:9) = Strings, Integers, Shorts, Bytes, Reals, // &91 + Lreals, Records // &92 %constbytearray Len Map(3:9) = 0, 4, 2, 1, 4, // &93 + 8, 0 // &94 // &95 // &96 ->Sp(N) %if 0 < N <= Max Special // &97 Sp(*): Fail("Bad primitive") // &98 // &99 %routine Psym(%record(Stackfm)%name Char) // &100 %owninteger Printsymbol Ep = 0 // &101 Load(Char, R0); Release and Drop(Char) // &102 Prim(Psymbol) // &103 Forget Everything // &104 %end // ?PRINTSYMBOLEP unused // &105 // &106 %routine Do Printstring // &107 %owninteger Printstring Ep = 0 // &108 %record(Stackfm)%name S, V == Stack // &109 Stack == Stack_Stack {pop the string} // &110 %cycle // &111 S == V; V == S_Link; S_Oper = 0; S_Link == Nil // &112 %if S_Type <= Addrs %start // &113 Psym(S) // &114 %else %if S_Bias = 1 {null} // &115 Release and Drop(S) // &116 %else // &117 Amap(S); Load(S, R0) // &118 Release and Drop(S) // &119 Do("3L_IMP_PRINT_STRING", Printstring Ep, 0) // &120 %finish // &121 %repeat %until V == Nil // &122 %end // &123 // &124 %routine Load External Variable(%string(63) Id, %integername Ep) // &125 %record(Stackfm)%name V // &126 %record(Varfm) X // &127 %if Ep = 0 %start // &128 X_Form = 0 // &129 External Id = Id; Dump External(0, X) // &130 Ep = -X_Area // &131 %finish // &132 Hazard(R1) // &133 Dir3(Dir Spec Load, Actual(R1), Ep) // &134 Refs = Refs+1; Ca = Ca+4 // &135 Attributes = Attributes ! Attr Needs Gp // &136 %end // ?V unused // &137 // &138 %routine Do Input(%integer Fn) // &139 %record(Stackfm)%name R // &140 %owninteger In Scb = 0 // &141 Hazard All // &142 Load External Variable("3L___cur_in", In Scb) {LDR _ 1, IN___SCB} // &143 Forget Everything // &144 Dump Word(16_E4911000) {LDR _ R1, [R1]} // &145 Dump Word(16_E891001C) {LDM _ R1, } // &146 {R2 = Next} // &147 {R3 = Limit} // &148 {R4 = Buffer Handler} // &149 Dump Word(16_E1520003) {CMP _ R2, R3 } // &150 Prim(Enter P) {BLGE_ (R4) } // &151 %if Fn = 0 %start {nextsymbol } // &152 {don't advance} // &153 Dump Word(16_E4D24000) {LDRB_ R4, [R2] } // &154 %else // &155 {advance} // &156 Dump Word(16_E4D24001) {LDRB _ R4, [R2], #1! } // &157 Dump Word(16_E4012000) {STR _ R2, [R1] } // &158 %finish // &159 %if Fn >= 0 %start {readsymbol/nextsymbol} // &160 {give some result} // &161 R == Register(R4) // &162 R_Stack == Stack; Stack == R // &163 Assign(Equals) %if Fn = 1 {readsymbol} // &164 %finish // &165 %end // &166 // &167 Sp(1): Do Input( 1); %return {readsymbol} // &168 Sp(2): Do Input( 0); %return {nextsymbol} // &169 Sp(26): Do Input(-1); %return {skipsymbol} // &170 // &171 Sp(25): Stack == V_Stack; Psym(V); %return {Printsymbol} // &172 Sp(27): X == Literal(10); Psym(X); %return {Newline} // &173 Sp(28): X == Literal(32); Psym(X); %return {Space} // &174 Sp(24): Do Printstring; %return {Printstring} // &175 // &176 Sp(23): %if V_Type = Strings %start {Read(STRING)} // &177 Type = Strings // &178 X == Literal(Item Size(Stack_Format)-1) // &179 Amap(Stack); Load(Stack, R0) // &180 Load(X, R1); Release and Drop(X) // &181 Pop Release and Drop // &182 Do("3L_IMP___read_s", Sread, 0) // &183 %else // &184 %if Integers <= V_Type <= Addrs %start // &185 Type = Integers; Do("3L_IMP___read_i", Iread, R0) // &186 %else %if V_Type = Reals %or V_Type = Lreals // &187 Type = Lreals; Do("3L_IMP___read_r", Rread, F0) // &188 %else // &189 Warn(1, "Bad type of parameter for READ") // &190 Type = Integers // &191 %finish // &192 Stack_Type = Type // &193 Stack_Form = Direct %if Type = Strings // &194 Assign(Equals) // &195 %finish // &196 %return // &197 Sp(20): Amap(V); %return {addr} // &198 // &199 Sp(3): {string} // &200 Sp(4): {integer} // &201 Sp(5): {shortinteger, short} // &202 Sp(6): {byteinteger, byte} // &203 Sp(7): {real} // &204 Sp(8): {longreal, long} // &205 Sp(9): Vmap(V, Type Map(N)) {record} // &206 V_Format = Len Map(N) // &207 %return // &208 Sp(10): Float(Stack, FPR); %return {float} // &209 Sp(11): X == V_Stack; Stack == X_Stack {rem} // &210 Operate(REMx, V, X) // &211 V_Stack == Stack; Stack == V // &212 %return // &213 Sp(12): Advance(V, Bytes, 0) {length} // &214 %return // &215 Sp(13): X == V_Stack; Stack == X_Stack {charno - the index} // &216 Simplify(V) %if V_Index ## Nil // &217 V_Type = Bytes // &218 Apply Index(V, X, 1) // &219 V_Stack == Stack; Stack == V {stack the result} // &220 %return // &221 Sp(14): Stack Integer(Nl) {snl} // &222 Sp(15): Simplify(Stack) {tostring} // &223 %return // &224 Sp(16): Set Size or Type(1, V); %return {sizeof} // &225 Sp(17): Set Size or Type(2, V); %return {typeof} // &226 Sp(19): Apply Int(V); %return {int} // &227 Sp(18): Apply Intpt(V); %return {intpt} // &228 Sp(22): Apply Round(V); %return {round} // &229 Sp(21): Apply Trunc(V); %return {trunc} // &230 // &231 {=== Pascal items ===} // &232 // &233 %conststring({*}255) Fill Id = "3L_pascal___fill"; %owninteger Fill Ep = 0 // &234 %conststring({*}255) Ftxt Id = "3L_pascal___fill_text"; %owninteger Ftxt Ep = 0 // &235 %conststring({*}255) Safe Id = "3L_pascal___safe"; %owninteger Safe Ep = 0 // &236 %conststring({*}255) Empty Id = "3L_pascal___empty"; %owninteger Empty Ep = 0 // &237 %conststring({*}255) Eoln Id = "3L_pascal___eoln_error"; %owninteger Eoln Ep = 0 // &238 %conststring({*}255) Readln Id = "3L_pascal___read_ln"; %owninteger Readln Ep = 0 // &239 %conststring({*}255) WritelnId = "3L_pascal___write_ln"; %owninteger WritelnEp = 0 // &240 %conststring({*}255) WriteC Id = "3L_pascal___write_char"; %owninteger WriteC Ep = 0 // &241 // &242 %constinteger InLim Displacement = 0, // &243 + Outlim Displacement = 4, // &244 + Size Displacement = 8, // &245 + EOF Displacement = 12, // &246 + EOLN Displacement = 13 // &247 // &248 %routine Make Safe(%record(Stackfm)%name F, %integer EOF) // &249 %record(Stackfm)%name P, B, V2, V3 // &250 Simplify(F) // &251 Advance(F, Integers, 0) // &252 P == Copy(F) {Buffer Pointer} // &253 B == Copy(F); Advance(B, Integers, 4) {PFCB} // &254 %if B_Base >= 128 %or Activity(B_Base) < 0 %start {can remember} // &255 V2 == Copy(B) // &256 V3 == Copy(P) // &257 %else // &258 V2 == NIL // &259 V3 == NIL // &260 %finish // &261 Load(B, R2) // &262 P_Flags = P_Flags ! Known Ass; Load(P, R3) // &263 Vmap(B, Integers) // &264 Advance(B, Integers, InLim Displacement); B_Flags = B_Flags ! Known Ass // &265 Load(B, R4) // &266 Compare(P, B); Release and Drop Pair(P, B) // &267 {EOF # 0 implies that EOF is an error} // &268 %if EOF = 0 %then Do Conditional External(GT, Ftxt Id, Ftxt Ep) {-}%c // &269 + %else Do Conditional External(GT, SAFE Id, SAFE Ep) // &270 F_Flags = F_Flags ! Known Ass // &271 %if V2 ## NIL %start {remember things} // &272 Remember(R2, V2) // &273 Remember(R3, V3) // &274 Release and Drop Pair(V2, V3) // &275 V2 == Register(R2); V2_Form = Direct // &276 Remember(R4, V2); Release and Drop(V2) // &277 %finish // &278 %end // &279 // &280 %routine Onto Boolean(%record(Stackfm)%name F, %integer Disp, Known) // &281 Advance(F, Integers, 4) {onto PFCB} // &282 F_Flags = F_Flags ! Known // &283 Load(F, R2) // &284 Vmap(F, Bytes); Advance(F, Bytes, Disp) // &285 F_Flags = F_Flags ! Known Ass // &286 %end // &287 // &288 %routine EOF(%record(Stackfm)%name F, %integer Text) // &289 Make Safe(F, 0) %if Text # 0 // &290 Onto Boolean(F, EOF Displacement, 0) // &291 %end // &292 // &293 %routine EOLN(%record(Stackfm)%name F) // &294 {EOLN must first test EOF as EOLN is invalid if EOF is true} // &295 Make Safe(F, 1) // &296 Onto Boolean(F, EOLN Displacement, Known Ass) // &297 %end // &298 // &299 !%prim(41)%routine P Get %alias"P_p_get"(%integername F) // &300 Sp(41): Stack == Stack_Stack // &301 Simplify(V) // &302 Advance(V, Integers, 0) // &303 X == Copy(V) // &304 Y == Copy(V); Load(Y, R3) {Buffer Pointer} // &305 Advance(V, Integers, 4); V_Flags = V_Flags ! Known Ass // &306 Load(V, R2) {PFCB} // &307 V_Form = Direct // &308 Z == Copy(V) // &309 Advance(V, Integers, Size Displacement); V_Flags = V_Flags ! Known Ass // &310 Operate(ADDx, Y, V) // &311 Advance(Z, Integers, InLim Displacement); Z_Flags = Z_Flags ! Known Ass // &312 Compare(Y, Z); Release and Drop Pair(Z, Y) // &313 Do Conditional External(GT, Fill Id, FILL Ep) // &314 Y == Register(R3); Simple(Y, X) // &315 Release and Drop Pair(X, Y) // &316 %return // &317 // &318 !%prim(42)%routine P Get Txt %alias"P_p_getx"(%integername F) // &319 Sp(42): Stack == Stack_Stack // &320 Make Safe(V, 1) // &321 Advance(V, Integers, 0) {Onto Buffer Pointer} // &322 Y == Register(R3) {loaded by MAKE SAFE} // &323 Operate(ADDx, Y, Literal(1)) // &324 Simple(Y, V) // &325 Release and Drop Pair(V, Y) // &326 %return // &327 // &328 !%prim(43)%integerfn P Safety %alias"P_p_safe"(%integername F) // &329 Sp(43): Stack == Stack_Stack // &330 Make Safe(V, 1) // &331 Release and Drop(V) // &332 V == Register(R3) // &333 V_Stack == Stack; Stack == V // &334 %return // &335 // &336 !%prim(44)%integerfn P ReadC %alias"P_p_rc"(%integername F) // &337 Sp(44): Stack == Stack_Stack // &338 Make Safe(V, 1) // &339 Y == Register(R3) // &340 X == Register(R1) // &341 Plant1(LDR ! Byte Op ! 16_0080 0000, R3, R1, 1) // &342 Simple(Y, V) // &343 Release and Drop Pair(V, Y) // &344 X_Stack == Stack; Stack == X // &345 %return // &346 // &347 !%prim(45)%routine P Readln %alias"P_p_rln"(%integername F) // &348 Sp(45): Stack == Stack_Stack // &349 Advance(V, Integers, 4) {onto PFCB} // &350 Load(V, R2) // &351 Release and Drop(V) // &352 Do(READLN Id, READLN Ep, 0) // &353 %return // &354 // &355 !%prim(46)%integerfn P Eoln %alias"P_p_eoln"(%integername F) // &356 Sp(46): EOLN(V) // &357 %return // &358 // &359 !%prim(47)%integerfn P Eof %alias"P_p_eof"(%integername F) // &360 Sp(47): EOF(V, 0); %return // &361 // &362 !%prim(48)%integerfn P Eof Txt %alias "P_p_eofx"(%integername F) // &363 Sp(48): EOF(V, 1); %return // &364 // &365 !%prim(49)%routine P Put %alias"P_p_put"(%integername F) // &366 Sp(49): Stack == Stack_Stack // &367 Simplify(V) // &368 Advance(V, Integers, 0) // &369 X == Copy(V) // &370 Y == Copy(V); Advance(Y, Integers, 4); Y_Flags = Y_Flags ! Known Ass // &371 Load(X, R3) // &372 Load(Y, R2) // &373 Y_Form = Direct; Y_Disp = OutLim Displacement // &374 Y_Flags = Y_Flags ! Known Ass // &375 Z == Copy(Y); Z_Disp = Size Displacement // &376 Operate(ADDx, X, Z); Load(X, R3) // &377 Compare(X, Y); Release and Drop Pair(Y, X) // &378 Do Conditional External(GE, EMPTY Id, EMPTY Ep) // &379 X == Register(R3) // &380 Simple(X, V) // &381 Release and Drop Pair(X, V) // &382 %return // &383 // &384 !%prim(50)%routine P Put Txt %alias"P_p_put"(%integername F) // &385 Sp(50): Stack == Stack_Stack // &386 Simplify(V) // &387 Advance(V, Integers, 0) // &388 X == Copy(V) // &389 Y == Copy(V); Advance(Y, Integers, 4); Y_Flags = Y_Flags ! Known Ass // &390 Load(X, R3) // &391 Load(Y, R2) // &392 Operate(ADDx, X, Literal(1)); Load(X, R3) // &393 Y_Form = Direct; Y_Disp = OutLim Displacement // &394 Y_Flags = Y_Flags ! Known Ass // &395 Compare(X, Y); Release and Drop Pair(Y, X) // &396 Do Conditional External(GE, EMPTY Id, EMPTY Ep) // &397 X == Register(R3) // &398 Simple(X, V) // &399 Release and Drop Pair(X, V) // &400 %return // &401 // &402 !%prim(51)%routine W Line %alias"P_p_line"(%integername F) // &403 Sp(51): Stack == Stack_Stack // &404 Advance(V, Integers, 4) // &405 Load(V, R2); Release and Drop(V) // &406 Do Conditional External(Always, Writeln Id, Writeln Ep) // &407 %return // &408 // &409 !%prim(52)%routine W Char %alias"P_p_wchr"(%integername F, %integer C, W) // &410 Sp(52): %begin // &411 %record(Stackfm)%name C, W, Bp, FCB, Z // &412 Simplify(V) // &413 C == V_Stack // &414 W == C_Stack // &415 Stack == W_Stack // &416 %if Iconst(W) %and W_Disp = 1 %start // &417 Release and Drop(W) // &418 Advance(V, Integers, 0) // &419 Bp == Copy(V) // &420 FCB == Copy(V); Advance(FCB, Integers, 4) // &421 Load(Bp, R3) // &422 FCB_Flags = FCB_Flags ! Known Ass // &423 Load(FCB, R2) // &424 Loadup(C); Plant1(STR ! Byte Op ! 16_0080 0000, R3, C_Base, 1) // &425 Release and Drop(C) // &426 FCB_Form = Direct; FCB_Disp = OutLim Displacement // &427 FCB_Flags = FCB_Flags ! Known Ass // &428 Compare(Bp, FCB); Release and Drop Pair(FCB, Bp) // &429 Do Conditional External(GT, EMPTY Id, EMPTY Ep) // &430 Bp == Register(R3) // &431 Simple(Bp, V) // &432 Release and Drop Pair(Bp, V) // &433 %else // &434 Load(W, R1) // &435 Load(C, R2) // &436 Amap(V); Load(V, R3) // &437 Release and Drop Pair(W, C) // &438 Release and Drop(V) // &439 Do(WRITEC Id, WRITEC Ep, 0) // &440 %finish // &441 %end // ?Z unused // &442 %return // &443 // &444 !%prim(53)%routine Assoc Complete %alias"P_p_assc" // &445 Sp(53): %return {no need for Assoc complete on ARM - yet} // &446 // &447 %routine Do Real Fn(%integer Fn) // &448 %integer Reg // &449 Load(V, AnyF) // &450 Reg = Fpr; Claim(Reg) // &451 Plant9(Fn, 0, Reg, V_Base) // &452 Release(V_Base); V_Base = Reg // &453 %end // &454 // &455 Sp(54): !%prim(54)%longrealfn Sqrt(%longreal R) // &456 Do Real Fn(SQT); %return // &457 // &458 Sp(55): !%prim(55)%longrealfn Sin(%longreal R) // &459 Do Real Fn(SIN); %return // &460 // &461 Sp(56): !%prim(56)%longrealfn Cos(%longreal R) // &462 Do Real Fn(COS); %return // &463 // &464 Sp(57): !%prim(57)%longrealfn Ln(%longreal R) // &465 Do Real Fn(LGN); %return // &466 // &467 Sp(58): !%prim(58)%longrealfn Exp(%longreal R) // &468 Do Real Fn(EXP); %return // &469 // &470 Sp(59): !%prim(59)%longrealfn Arctan(%longreal R) // &471 Do Real Fn(ATN); %return // &472 %end // ?EOLNEP unused // ?EOLNID unused // ?NEXTCHEP unused // ?READCHEP unused // &473 // &474 %routine Call(%integer Tidy) // &475 {Tidy#0 if the caller is to remove parameters from the stack} // &476 %record(Stackfm)%name V, Temp, X, W // &477 %record(Stackfm) Work // &478 %integer Ep, Flags, Extra, Op, BaseReg // &479 V == Stack // &480 Stack == Stack_Stack // &481 Flags = V_Flags // &482 %if Flags&Primitive # 0 %start // &483 %while V_Params ## Nil %cycle // &484 V_Params_Stack == Stack // &485 Stack == V_Params // &486 V_Params == V_Params_Params // &487 %repeat // &488 Special Call(V_Prim) // &489 Drop(V) // &490 %return // &491 %finish // &492 // &493 BaseReg = R0 // &494 BaseReg = R1 %if Flags&Answer # 0 %and V_Flags&Defered = 0 %and // &495 + (V_Type = Strings %or V_Type = Records) // &496 Pass Parameters(V, Extra, BaseReg) // &497 Hazard All %if Active Registers # 0 // &498 // &499 Assign Lock = 0 {no longer safe} // &500 Attributes = Attributes!Attr Dynamic // &501 // &502 Temp == Nil // &503 %if BaseReg = R1 %start {extra parameter for results} // &504 Temp == Claim Work Area(Item Size(V_Format), V_Type) // &505 Temp_Format = V_Format // &506 W == Copy(Temp) // &507 Amap(W); Load(W, R0) // &508 Release and Drop(W) // &509 %finish // &510 // &511 Ep = V_Disp // &512 %if Flags&Xproc Spec # 0 %start {external Call} // &513 %if Flags&Prim Proc # 0 %start // &514 Fail("XP-call") // &515 !!! Dir2(Dir xpCall, Ep); Ca = Ca+4; Refs = Refs+1 // &516 %else // &517 X Call(Ep, 0, 1) // &518 %finish // &519 %else %if Flags&Parameter # 0 %or V_Base # 0 %or V_Record ## Nil // &520 {procedure parameter call} // &521 W == Copy(V) // &522 W_Type = Integers; W_Form = Direct; W_Area = 0 // &523 Amap(W) // &524 Load(W, R4) // &525 Release and Drop(W) // &526 Prim(CallP) // &527 %else %if Flags&Prim Proc # 0 // &528 Fail("P-call") // &529 !!! Dir2(Dir pCall, Ep); Ca = Ca+4; Refs = Refs+1 // &530 %else {normal internal call} // &531 %if Flags&Nasty Proc # 0 %start {must pass an environment} // &532 Fail("No local display") %if Local Display = 0 // &533 X == Local Integer(Local Display) // &534 Load Address(X, R8) // &535 Release and Drop(X) // &536 %finish // &537 Dir2(Dir Call, Ep); Ca = Ca+4; Refs = Refs+1 // &538 %finish // &539 Pop Stack(Extra) %if Extra # 0 {restore the stack} // &540 Forget Everything // &541 // &542 %if Flags&Answer # 0 %start {set up result descriptor} // &543 %if Temp == Nil %start // &544 Temp == Literal(0) // &545 Temp_Type = V_Type // &546 Temp_Format = V_Format // &547 Temp_Base = R0 // &548 %if Flags&Defered # 0 %start {a map} // &549 Temp_Form = Direct // &550 Temp_Base = R0 // &551 %else %if Reals <= Temp_Type <= Lreals // &552 Temp_Base = F0; Temp_Type = Lreals // &553 %finish // &554 Claim(Temp_Base) // &555 %finish // &556 Temp_Stack == Stack; Stack == Temp // &557 %else %if Flags&Pred Call # 0 {a predicate} // &558 Plant1(TEQ, R0, 0, Nothing) {set CC} // &559 %finish // &560 Uncond Jump = Ca %if Flags&Closed # 0 // &561 Drop(V) // &562 %end // ?OP unused // ?WORK unused // ?TIDY unused // &563 // &564 %routine Prim(%integer N) // &565 %integer For, Reg, Par // &566 Fail("Prim ") %unless Signal <= N <= Last Prim // &567 Monitor(Nil, "Prim ".ItoS(N, 0)) %if Diag&MonOperate # 0 // &568 For = Corrupts(N) // &569 Par = Prim Parameter(N) // &570 Reg = R0 // &571 %while For # 0 %cycle // &572 %if For&1 # 0 %start {prim corrupts this register} // &573 %if Par&1 = 0 %start {it isn't a parameter} // &574 Hazard(Reg) // &575 %else {it is a parameter} // &576 Hazard(Reg) %if Activity(Reg) > 1 // &577 %finish // &578 Forget(Reg) {forget its value} // &579 %finish // &580 Reg = Reg+1 // &581 For = For>>1 // &582 Par = Par>>1 // &583 %repeat // &584 Dir2(Dir Prim, N); Ca = Ca+4; Refs = Refs+1 // &585 %end // &586 %endoffile // 3705 // 3706 %routine Switch Label(%integer Tag) // 3707 Dir2(Dir Slabel, Var(Tag)_Area+Popped Value) // 3708 Uncond Jump = -1 // 3709 Assign Lock = 0 // 3710 Mark User Label // 3711 Forget Everything // 3712 %end // 3713 // 3714 %routine Switch Jump(%integer Tag) // 3715 %record(Stackfm)%name X // 3716 X == Stack; Stack == Stack_Stack {the index} // 3717 Load(X, R1) // 3718 Release and Drop(X) // 3719 Prim(SwJump) // 3720 Dump Word(16_E792F105) {LDR_Pc,[R2,R5 %LSL #2]} // 3721 Dir2(Dir Sw Ref, Var(Tag)_Format); Ca = Ca+4 // 3722 Uncond Jump = Ca // 3723 %end // 3724 // 3725 %routine Save Wsp // 3726 %record(Stackfm)%name D // 3727 %if Wsp Save = 0 %start // 3728 Frame = (Frame&(\3))-4 // 3729 Wsp Save = Frame // 3730 %finish // 3731 D == Local Integer(Wsp Save); Plant2(STR, Sp, D); Release and Drop(D) // 3732 %end // 3733 // 3734 %routine Event Trap(%integer Bits) // 3735 {###################################################} // 3736 {# Block(......) #} // 3737 {# ............ #} // 3738 {# %on EVENT BITS %start #} // 3739 {# Event Label -> ....... #} // 3740 {# ....... #} // 3741 {# %finish #} // 3742 {# Event Body -> ....... #} // 3743 {# ....... #} // 3744 {# %end #} // 3745 // 3746 {###################################################} // 3747 %integer Lab // 3748 %record(Stackfm)%name D // 3749 Lab = Tag // 3750 Save Wsp // 3751 Jump Forward(Lab, Always) // 3752 Event Bits = Bits // 3753 Event Body = Jlab // 3754 Event Label = New Label // 3755 Define Label(Event Label); Mark User Label // 3756 Forget Everything // 3757 D == Local Integer(Wsp Save); Plant2(LDR, Sp ,D); Release and Drop(D) // 3758 Attributes = Attributes!Attr Dynamic // 3759 %end // 3760 // 3761 %routine Signal Event(%integer Event) // 3762 %record(Stackfm)%name E, Sub Event, Extra // 3763 Extra == Stack // 3764 Sub Event == Extra_Stack // 3765 Stack == Sub Event_Stack // 3766 E == Literal(Event) // 3767 Load Trio(E, R1, Sub Event, R2, Extra, R3) // 3768 Release and Drop Pair(E, Sub Event) // 3769 Release and Drop(Extra) // 3770 Prim(Signal) // 3771 Uncond Jump = Ca // 3772 Attributes = Attributes!Attr Dynamic // 3773 %end // 3774 // 3775 %include "compare.inc" // &1 !Revision history: // &2 // &3 ! 8-Jul-87 PSR test zero was using integer comparison for testing reals (-0) // &4 ! - comparison of null strings was wrong // &5 // &6 {Comparisons} // &7 // &8 %routine Set Pending for(%integer V) // &9 %integer Mask = 0 {bits set for <=>} // &10 %if Pending = '=' %then Mask = 2_010 {-}%c // &11 + %else %if Pending = '#' %then Mask = 2_101 {-}%c // &12 + %else %if Pending = '<' %then Mask = 2_100 {-}%c // &13 + %else %if Pending = '>' %then Mask = 2_001 {-}%c // &14 + %else %if Pending = '(' %then Mask = 2_110 {-}%c // &15 + %else %if Pending = ')' %then Mask = 2_011 {-}%c // &16 + %else %if Pending = 't' %then Mask = 2_101 {-}%c // &17 + %else %if Pending = 'k' %then Mask = 2_010 %else Fail("Bad cc") // &18 V = -V %and Invert = 0 %if Invert # 0 // &19 Pending = '#' {false} // &20 Pending = '=' %if (V = 0 %and Mask&2_010 # 0) {-}%c // &21 + %or (V > 0 %and Mask&2_001 # 0) {-}%c // &22 + %or (V < 0 %and Mask&2_100 # 0) // &23 Plant1(CMP ! Scc, 0, R0, Just(R0)) {set equal} // &24 %end // &25 // &26 %routine Test Zero(%record(Stackfm)%name V) // &27 %record(Stackfm)%name W // &28 %integer Op, X // &29 // &30 %routine Test Short Bits(%record(Stackfm)%name V, %integer Mask) // &31 %integer Op = TST // &32 %record(Stackfm)%name W // &33 Mask = Mask&16_FFFF // &34 V == Copy(V) // &35 %if Mask&255 = 0 %start {test the top byte only} // &36 Advance(V, Bytes, 1) // &37 Loadup(V) // &38 Plant1(TST, V_Base, 0, Immediate(Mask>>8)) {test high} // &39 %else %if Mask <= 255 {test the bottom byte only} // &40 Advance(V, Bytes, 0) // &41 Loadup(V) // &42 Plant1(TST, V_Base, 0, Immediate(Mask)) {test low} // &43 %else {test both} // &44 W == Copy(V) // &45 Advance(V, Bytes, 0) {low byte} // &46 Advance(W, Bytes, 1) {high byte} // &47 Loadup(V); Loadup(W) // &48 Plant1(TST, V_Base, 0, Immediate(Mask&255)) {test low} // &49 Plant1(TST ! Cond EQ, W_Base, 0, Immediate(Mask>>8)) {test high} // &50 Release and Drop(W) // &51 %finish // &52 Release and Drop(V) // &53 %end // ?OP unused // &54 // &55 %routine Test Integer Bits(%record(Stackfm)%name V, %integer Mask) // &56 %integer X, Op // &57 Loadup(V) // &58 Op = TST; X = 16 // &59 %while Mask # 0 %cycle // &60 Mask = Mask>>2 %and X = X-1 %while Mask&3 = 0 // &61 Plant1(Op, V_Base, 0, Rot(Mask&255, X&15)) // &62 Mask = Mask>>8; X = X-4 // &63 Op = Op ! Cond EQ // &64 %repeat // &65 Plant1(Op, V_Base, 0, Immediate(0)) %if X = 16 {special for &0????} // &66 %end // &67 // &68 Monitor(V, "Tzero") %if Diag&MonCond # 0 // &69 Optimise(V, 1) // &70 %if V_Oper # 0 %start // &71 W == V_Link // &72 %if (Pending = '=' %or Pending = '#' %or Pending = 't' %or Pending = 'k') {-}%c // &73 + %and V_Oper = ANDx %and Iconst(W) %start // &74 V_Oper = 0; V_Link == Nil // &75 %if V_Type = Shorts %start // &76 Test Short Bits(V, W_Disp) // &77 %else %if V_Type = Bytes // &78 Loadup(V); Plant1(TST, V_Base, 0, Immediate(W_Disp&255)) // &79 %else {integers} // &80 Test Integer Bits(V, W_Disp) // &81 %finish // &82 Release and Drop(W) // &83 %return // &84 %finish // &85 Loadup(V) // &86 %finish // &87 %if V_Type >= Reals %start // &88 Loadup(V) // &89 Plant8(CMF ! Small Constant, V_Base, 0) // &90 %else %if Iconst(V) {%if 0=1 ...} // &91 Set Pending for(V_Disp) // &92 %else // &93 Loadup(V) // &94 Plant1(CMP, V_Base, 0, Nothing) // &95 %if Pending = '#' %start {can remember the value} // &96 Pending Known Register = V_Base // &97 Pending Known = 0 // &98 %finish // &99 %finish // &100 %end // ?X unused // ?OP unused // &101 // &102 %routine Comp Tostring(%record(Stackfm)%name S, X) // &103 Amap(S) // &104 Load Pair(S, R2, X, R1) // &105 Prim(Cscomp) // &106 %end // &107 // &108 %routine Compare Strings(%record(Stackfm)%name Left, Right) // &109 %record(Stackfm)%name W // &110 Evaluate String Expression(Left) %if Left_Oper # 0 // &111 Evaluate String Expression(Right) %if Right_Oper # 0 // &112 Simplify(Left) // &113 Simplify(Right) // &114 Right == Copy(Right) // &115 Left == Copy(Left) // &116 %if Right_Bias = 1 %start {rhs null} // &117 %if Left_Type # Strings %start // &118 Loadup(Left); Plant1(CMN, 0, Left_Base, Immediate(1)) // &119 %else %if Left_Bias = 1 {both null} // &120 Plant1(CMP ! Scc, 0, R0, Just(R0)) {set cc equal} // &121 %else // &122 Left_Type = Bytes; Test Zero(Left) // &123 %finish // &124 %else %if Left_Bias = 1 {lhs null} // &125 %if Right_Type # Strings %start // &126 Loadup(Right); Plant1(CMN, 0, Right_Base, Immediate(1)) // &127 %else // &128 Right_Type = Bytes; Test Zero(Right) // &129 %finish // &130 Invert = Invert!!Inverted // &131 %else %if Right_Type # Strings {rhs a tostring} // &132 Comp Tostring(Left, Right) // &133 %else %if Left_Type # Strings {lhs a tostring} // &134 Comp Tostring(Right, Left) // &135 Invert = Invert !! Inverted // &136 %else {normal comparison} // &137 Amap(Left); Amap(Right) // &138 Load Pair(Left, R1, Right, R2) // &139 Prim(Scomp) // &140 %finish // &141 Release and Drop Pair(Left, Right) // &142 %end // ?W unused // &143 // &144 %routine Compare Records(%record(Stackfm)%name L, R) // &145 %record(Stackfm)%name Size // &146 %integer N, Op // &147 // &148 %routine Fix Set(%record(Stackfm)%name L) // &149 Simplify(L) // &150 %if L_Members ## Nil %start // &151 Build Set(L) // &152 %else %if L_Flags&Null Set # 0 // &153 L_Type = Integers // &154 %finish // &155 L_Format = 256//8 // &156 %end // &157 // &158 %routine Compare Set(%record(Stackfm)%name L, R, %integer CC) // &159 Pending = CC // &160 Amap(L); Amap(R) // &161 Load Pair(L, R8, R, R11) // &162 Prim(Set GE) // &163 %end // &164 // &165 Fix Set(L) %if L_Type = Sets // &166 Fix Set(R) %if R_Type = Sets // &167 %if L_Type = Integers %start // &168 %if R_Type = Integers %start {two null sets} // &169 Plant1(CMP ! Scc, 0, R0, Just(R0)) {set cc equal} // &170 %else // &171 Invert = Invert!!Inverted // &172 Compare Records(R, L) // &173 %finish // &174 %return // &175 %finish // &176 N = Item Size(L_Format); Fail("Null area?") %if N <= 0 // &177 %if R_Type = Integers %start {compare set against []} // &178 Fail("Bad set size") %if N # Set Size // &179 // &180 %routine Do Set(%integer Code) // &181 Pending = Code // &182 Load Address(L, R0) // &183 Prim(Set Zero) {This returns = or # ONLY} // &184 %end // &185 // &186 %if Pending = '=' %or Pending = '#' %start // &187 Do Set(Pending) // &188 %else %if Invert = 0 // &189 %if Pending = '>' %start // &190 Do Set('#') // &191 %else %if Pending = '<' // &192 Pending = 128+'0' {no-op, unconditionally false} // &193 %else %if Pending = ')' // &194 Pending = 'F' {unconditionally true} // &195 %else %if Pending = '(' // &196 Do Set('=') // &197 %finish %else Fail("Null/1") // &198 %else // &199 %if Pending = '>' %start // &200 Pending = 128+'0' {no-op, unconditionally false} // &201 %else %if Pending = '<' // &202 Do Set('#') // &203 %else %if Pending = ')' // &204 Do Set('=') // &205 %else %if Pending = '(' // &206 Pending = 'F' {always true} // &207 %finish %else Fail("Null/2") // &208 %finish // &209 Invert = 0 // &210 %else %if L_Type = Sets = R_Type {set comparison} // &211 Fail("Bad set size") %if N # Set Size // &212 %if Pending = '=' %or Pending = '#' %start // &213 Amap(L); Amap(R) // &214 Load Pair(L, R0, R, R1) // &215 Prim(Set Equal) // &216 %else // &217 {The prim routine gives: cc=0 if set(R8) >= set(R11), cc#0 otherwise} // &218 %if Pending = '<' %start {-> if L>=R } // &219 Compare Set(L, R, '#') // &220 %else %if Pending = '>' {-> if not(L<=R)} // &221 Compare Set(R, L, '#') // &222 %else %if Pending = '(' {-> if L<=R } // &223 Compare Set(R, L, '=') // &224 %else %if Pending = ')' {-> if not(L>=R)} // &225 Compare Set(L, R, '=') // &226 %else // &227 Fail("bad set comparison") // &228 %finish // &229 %finish // &230 %else {record comparison - byte arrays?} // &231 Amap(L); Amap(R) // &232 Size == Literal(N) // &233 Load Trio(L, R1, R, R2, Size, R0) // &234 Release and Drop(Size) // &235 Prim(Prim Compare) // &236 %finish // &237 %end // ?OP unused // &238 // &239 %routine Try for Zero(%record(Stackfm)%name V, %integer Mod) // &240 %integer Old // &241 Old = Pending // &242 %if V_Disp = Mod %start // &243 %if Pending = '<' %start {>=1 :: >0} // &244 Pending = '(' // &245 %else %if Pending = ')' {<1 :: <=0} // &246 Pending = '>' // &247 %finish // &248 %else %if V_Disp = -Mod // &249 %if Pending = '>' %start {<=-1 :: <0} // &250 Pending = ')' // &251 %else %if Pending = '(' {>-1 :: >=0} // &252 Pending = '<' // &253 %finish // &254 %finish // &255 V_Disp = 0 %if Pending # Old // &256 %end // &257 // &258 %routine Compare Floating(%record(Stackfm)%name Left, Right) // &259 // &260 %predicate Suitable Const(%record(Stackfm)%name L, R) // &261 %integer Op, N // &262 %false %unless Iconst(R) // &263 %if 0 <= R_Disp <= 5 %start // &264 Op = CMF; N = R_Disp // &265 %else %if -5 <= R_Disp <= 0 // &266 Op = CNF; N = -R_Disp // &267 %else %if R_Disp = 10 // &268 Op = CMF; N = 7 // &269 %else %if R_Disp = -10 // &270 Op = CNF; N = 7 // &271 %else // &272 %false // &273 %finish // &274 Load(L, AnyF) // &275 Plant8(Op ! Small Constant, L_Base, N) // &276 %true // &277 %end // &278 // &279 %return %if Suitable Const(Left, Right) // &280 Invert = Invert !! Inverted %and %return %if Suitable Const(Right, Left) // &281 Load(Left, AnyF) // &282 Load(Right, AnyF) // &283 Plant8(CMF, Left_Base, Right_Base) // &284 %end // &285 // &286 %routine Compare(%record(Stackfm)%name Left, Right) // &287 %integer Lab // &288 %record(Stackfm)%name W // &289 // &290 %routine Do Const(%record(Stackfm)%name A, B) // &291 %integer N, Op, V // &292 Loadup(A) // &293 V = B_Disp // &294 %if V >= 0 %start // &295 N = Immediate(V) // &296 Op = CMP // &297 %else // &298 N = Immediate(-V) // &299 Op = CMN // &300 %finish // &301 %if N < 0 %start // &302 Loadup(B) // &303 N = Just(B_Base) // &304 Op = CMP // &305 %finish // &306 Plant1(Op, A_Base, 0, N) // &307 %if Pending = '#' %start // &308 Pending Known Register = A_Base // &309 Pending Known = 0 // &310 Pending Known_Disp = V; Pending Known_Type = Integers // &311 %finish // &312 %end // &313 // &314 Pending Known Register = 0 // &315 Unsigned = 0 %if Code # 128+'?' %and Code # 128+'"' // &316 %if Pending Tag # 0 %start // &317 Lab = Pending Tag; Pending Tag = 0 {beware recursive loops} // &318 W == Literal(Pending Lit) // &319 %if (Pending # '>' %and Pending # ')') %or {-}%c // &320 + Right_Disp < Pending Lit %or %not Iconst(Right) %start // &321 Loadup(Left) {it's going to be used twice} // &322 Compare(Left, W); Release and Drop(W) // &323 Jump Forward(Lab, LT) // &324 %else // &325 Unsigned = 10 // &326 Operate(SUBx, Left, W) // &327 Right_Disp = Right_Disp-Pending Lit // &328 %finish // &329 %finish // &330 %if Left_Type = Strings %or Right_Type = Strings %or {-}%c // &331 + Left_Oper = CONCx %or Right_Oper = CONCx %start // &332 Compare Strings(Left, Right) // &333 %return // &334 %finish // &335 %if Left_Type = Records %or Left_Type = Sets {-}%c // &336 + %or Right_Type = Records %or Right_Type = Sets %start // &337 Compare Records(Left, Right); %return // &338 %finish // &339 // &340 %if Iconst(Right) %start // &341 Try for zero(Right, 1) %unless Floating(Left) // &342 %if Iconst(Left) %start // &343 Set Pending for(Left_Disp-Right_Disp) // &344 %return // &345 %finish // &346 %if Right_Disp = 0 %start // &347 Test Zero(Left); %return // &348 %finish // &349 %else %if Iconst(Left) // &350 Try for Zero(Left, -1) %unless Floating(Right) // &351 %if Left_Disp = 0 %start // &352 Test Zero(Right) // &353 Invert = Invert!!Inverted // &354 %return // &355 %finish // &356 %finish // &357 // &358 %if Floating(Left) %or Floating(Right) %start // &359 Compare Floating(Left, Right) // &360 %else // &361 %if Iconst(Right) %start // &362 Do Const(Left, Right) // &363 %else %if Iconst(Left) // &364 Do Const(Right, Left) // &365 Invert = Invert !! Inverted // &366 %else // &367 Loadup(Left); Loadup(Right); Loadup(Left) // &368 Plant1(CMP, Left_Base, 0, Just(Right_Base)) // &369 %finish // &370 %finish // &371 %end // &372 // &373 %routine Compare Values // &374 %record(Stackfm)%name L, R // &375 R == Stack // &376 L == R_Stack; Stack == L_Stack // &377 Compare(L, R) // &378 Release and Drop Pair(L, R) // &379 %end // &380 // &381 %routine Compare Double // &382 %record(Stackfm)%name L, R // &383 R == Stack // &384 L == R_Stack // &385 R_Stack == L_Stack // &386 %if R_Oper # 0 %start {beware %if 0 # X&7 # 5 etc} // &387 %if R_Oper = CONCx %start // &388 Evaluate String Expression(R) // &389 %else // &390 Loadup(R) // &391 %finish // &392 %finish // &393 %if Pending = '>' %and L_Disp >= 0 %and Iconst(L) %and R_Type <= Addrs %start // &394 {optimise const<=N<=...} // &395 Readsymbol(Pending) // &396 Pending Lit = L_Disp // &397 Pending Tag = Tag // &398 %else // &399 Compare(L, R) // &400 %finish // &401 Release and Drop(L) // &402 %end // &403 // &404 %routine Compare Addresses // &405 %record(Stackfm)%name L, R // &406 R == Stack // &407 L == R_Stack; Stack == L_Stack // &408 Amap(L); Amap(R) // &409 Compare(L, R) // &410 Release and Drop Pair(L, R) // &411 %end // &412 // &413 %routine Stack Condition // &414 %integer CC // &415 %record(Stackfm)%name L, R // &416 R == Stack; L == R_Stack; Stack == L_Stack // &417 Compare(L, R); Release and Drop Pair(L, R) // &418 %if Pending = '=' %then CC = EQ {-}%c // &419 + %else %if Pending = '<' %then CC = LT {-}%c // &420 + %else %if Pending = '(' %then CC = LE {-}%c // &421 + %else %if Pending = '>' %then CC = GT {-}%c // &422 + %else %if Pending = ')' %then CC = GE {-}%c // &423 + %else %if Pending = '#' %then CC = NE {-}%c // &424 + %else %if Pending = 't' %then CC = TT {-}%c // &425 + %else %if Pending = 'f' %then CC = FF {-}%c // &426 + %else %if Pending = 'F' %then CC = Always {-}%c // &427 + %else %if Pending = 128+'0' %then CC = Never {-}%c // &428 + %else Fail("Bad CC") // &429 Readsymbol(Pending) // &430 CC = Reverse(CC) %and Invert = 0 %if Invert # 0 // &431 Stack True or False(CC) // &432 %end // &433 // &434 %routine General Compare // &435 %integer Op // &436 %record(Stackfm)%name Right, Left, Rlen, Llen // &437 Rlen == Stack // &438 Llen == Rlen_Stack // &439 Right == Llen_Stack // &440 Left == Right_Stack // &441 Stack == Left_Stack // &442 Fail("variable compare") %unless Iconst(Rlen) %and Iconst(Llen) // &443 %if Rlen_Disp = Llen_Disp %start // &444 Amap(Left); Amap(Right) // &445 Load Trio(Left, R1, Right, R2, Rlen, R0) // &446 Prim(Prim Compare) // &447 %else // &448 Not in Yet // &449 %finish // &450 Release and Drop Pair(Rlen, Llen) // &451 Release and Drop Pair(Right, Left) // &452 %end // ?OP unused // &453 %endoffile // 3776 // 3777 {Assignment} // 3778 // 3779 %routine General Move // 3780 %record(Stackfm)%name F, T, Flen, Tlen // 3781 Flen == Stack // 3782 Tlen == Flen_Stack // 3783 F == Tlen_Stack // 3784 T == F_Stack // 3785 Stack == T_Stack // 3786 Load Pair(Tlen, R3, Flen, R4) // 3787 Load Pair(T, R1, F, R2) // 3788 Load Pair(Tlen, R3, Flen, R4) // 3789 Load Pair(T, R1, F, R2) // 3790 Release and Drop Pair(Flen, Tlen) // 3791 Release and Drop Pair(F, T) // 3792 Prim(GenMove) // 3793 Forget Everything // 3794 %end // 3795 // 3796 %routine Record Assign(%record(Stackfm)%name From, To) // 3797 %integer LenL, LenR, Inc, Mod, Load, R, Aligned = 1, Zero // 3798 // 3799 %routine Record Op // 3800 R = GPR %if R < 0 // 3801 Plant2(LDR ! Mod, R, From) %if Load # 0 // 3802 Plant2(STR ! Mod, R, To) // 3803 %end // 3804 // 3805 LenL = Item Size(To_Format) // 3806 LenR = Item Size(From_Format) {note: Var(0)_Format=0 - constants} // 3807 LenL = LenR %if LenL = 0 %or (LenR # 0 %and LenR < LenL) // 3808 %return %if LenL <= 0 // 3809 Aligned = 0 %unless LenL&3 = 0 %and Properly Aligned(To, 3) // 3810 Zero = 0 // 3811 %if Iconst(From) %start // 3812 Zero = 1 // 3813 %else // 3814 Aligned = 0 %unless Properly Aligned(From, 3) // 3815 %finish // 3816 Forget Destination(To) // 3817 Make AutoI(To, Integers) // 3818 Load = 1 // 3819 Inc = 4; Mod = 0 {assume words} // 3820 %if Aligned = 0 %start {must use bytes} // 3821 Inc = 1; Mod = Byte Op // 3822 To_Type = Bytes // 3823 %finish // 3824 %if Zero # 0 %start {record = 0} // 3825 Load = 0 {no load needed} // 3826 Loadup(From) // 3827 R = From_Base // 3828 %else // 3829 Make AutoI(From, To_Type) // 3830 R = -1 // 3831 %finish // 3832 // 3833 Repeat(Record Op, Literal(LenL), Inc, NE) // 3834 // 3835 %end // 3836 // 3837 %routine Set Assign(%record(Stackfm)%name From, Dest) // 3838 %record(Memberfm)%name M, X // 3839 %integer Op = From_Oper, Fn // 3840 %record(Stackfm)%name W, Index // 3841 %record(Stackfm)%name To == Copy(Dest) // 3842 // 3843 Build Set(From) %if From_Members ## Nil // 3844 W == From_Link // 3845 %if W ## Nil %start // 3846 From_Link == Nil; From_Oper = 0 // 3847 %if From_Flags&Null Set # 0 %start // 3848 From == W // 3849 %else // 3850 Fail("Bad set operator") %if Op # RADDx %c // 3851+ %and Op # RSUBx %c // 3852+ %and Op # RMULx // 3853 %if W_Flags&Null Set = 0 %start // 3854 %unless Same(From, To) %start // 3855 From_Oper = Op; From_Link == W; Loadup(From) // 3856 Set Assign(From, To) // 3857 Release and Drop(To) // 3858 %return // 3859 %finish // 3860 Build Set(W) %if W_Members ## NIL %and %c // 3861+ (W_Members_Items > 2 %or Op = RMULx) // 3862 Load Address(To, R8) // 3863 %if Op # RMULx %and W_Members ## Nil %start // 3864 M == W_Members; W_Members == Nil // 3865 %while M ## Nil %cycle // 3866 X == M; M == M_Link // 3867 Load Pair(To, R8, X_A, R1) // 3868 %if X_B ## Nil %start // 3869 Load(X_B, R0) // 3870 Load Pair(To, R8, X_A, R1) // 3871 Release and Drop(X_B) // 3872 %if Op = RADDx %then Fn = Set Bits %else Fn = Clear Bits // 3873 %else %if Op = RADDx // 3874 Fn = Set Bit // 3875 %else {%if Op = RSUBx} // 3876 Fn = ClearBit // 3877 %finish // 3878 Release and Drop(X_A); Dispose(X) // 3879 Prim(Fn) // 3880 %repeat // 3881 Release and Drop Pair(W, To) // 3882 %else // 3883 Amap(W); Load Pair(To, R8, W, R11) // 3884 Release and Drop(W) // 3885 %if Op = RADDx %then Fn = Set Add %else %c // 3886+ %if Op = RSUBx %then Fn = Set Sub %c // 3887+ %else Fn = Set Inter // 3888 Prim(Fn) // 3889 Release and Drop(To) // 3890 %finish // 3891 %return // 3892 %finish // 3893 %finish // 3894 %finish // 3895 Release and Drop(W) %unless W == Nil // 3896 // 3897 Forget Destination(To) // 3898 %if From_Flags&Null Set # 0 %start // 3899 %routine Zero(%integer R) // 3900 %record(Stackfm)%name W == Literal(0) // 3901 Load(W, R); Release and Drop(W) // 3902 %end // 3903 Load Address(To, R8) // 3904 Zero(R0); Zero(R1); Zero(R2); Zero(R3) // 3905 Plant4(STM ! IA ! Write Back, To_Base, 16_000F) // 3906 Plant4(STM ! IA, To_Base, 16_000F) // 3907 %else // 3908 {Note: if set expressions are about it is likely that the address} // 3909 { of FROM is in R8, so load R11 first to catch it} // 3910 Load Address(From, R11) // 3911 Load Address(To, R8) // 3912 Hazard(R0); Hazard(R1); Hazard(R2); Hazard(R3) // 3913 Hazard(R4); Hazard(R5); Hazard(R6); Hazard(R7) // 3914 Plant4(LDM ! IA, From_Base, 16_00FF) // 3915 Plant4(STM ! IA, To_Base, 16_00FF) // 3916 Forget(R0); Forget(R1); Forget(R2); Forget(R3) // 3917 Forget(R4); Forget(R5); Forget(R6); Forget(R7) // 3918 %finish // 3919 Release and Drop(To) // 3920 %end // ?INDEX unused // 3921 // 3922 %routine Resolve(%integer Flag) // 3923 {S -> A.(B).C} // 3924 %integer Lab, InLab = 0, Pend, N // 3925 %record(Stackfm)%name S, A, B, C // 3926 // 3927 N = 0 // 3928 %if Flag&1 # 0 %start // 3929 C == Stack; Stack == Stack_Stack // 3930 %else // 3931 N = N!1 // 3932 C == Nil // 3933 %finish // 3934 B == Stack %and Stack == Stack_Stack // 3935 %if Flag&2 # 0 %start // 3936 A == Stack; Stack == Stack_Stack // 3937 %else // 3938 N = N!2 // 3939 A == Nil // 3940 %finish // 3941 S == Stack; Stack == Stack_Stack // 3942 // 3943 Evaluate String Expression(B) %if B_Oper # 0 // 3944 Fix Tostring(B) %if B_Type <= Addrs // 3945 Amap(S); Amap(B) // 3946 Load Pair(S, R1, B, R2) // 3947 Release and Drop Pair(S, B) // 3948 Prim(Sres) // 3949 %if Flag&4 = 0 %start {unconditional} // 3950 Prim(Resflop) // 3951 %else {conditional} // 3952 Fail("corrupt resolution") %if Pending # 't' %and Pending # 'k' // 3953 Pend = Pending; Readsymbol(Pending) // 3954 InLab = Tag // 3955 %if Pend = 't' %start // 3956 Lab = New Label; Jump to(Lab, NE) // 3957 %else // 3958 Jump Forward(InLab, NE); InLab = 0 // 3959 %finish // 3960 %finish // 3961 Claim(R1); Claim(R7) {left fragment} // 3962 Claim(R3); Claim(R6) {right fragment} // 3963 %if A ## Nil %start // 3964 Load Address(A, R2); Prim(Frag1) // 3965 Release and Drop(A) // 3966 %finish // 3967 %if C ## Nil %start // 3968 Load Address(C, R2); Prim(Frag2) // 3969 Release and Drop(C) // 3970 %finish // 3971 Release(R1); Release(R7) // 3972 Release(R3); Release(R6) // 3973 %if InLab # 0 %start // 3974 Jump Forward(InLab, Always) // 3975 Define Label(Lab) // 3976 %finish // 3977 %end // 3978 // 3979 %include "strings.inc" // &1 %routine Evaluate String Expression(%record(Stackfm)%name V) // &2 %record(Stackfm)%name W // &3 W == Claim Work Area(256, Strings) // &4 String Assign(V, W) // &5 Replace(V, W) // &6 %end // &7 // &8 %routine String Assign(%record(Stackfm)%name R, L) // &9 %record(Stackfm)%name W, LL, DelayV, Z // &10 %integer Conc Length = 1, All Const = 1, Reg, Delay = 0, Len = 0 // &11 %integer Here, Lab, N // &12 %string(255) Val = "" // &13 // &14 %predicate Safe(%record(Stackfm)%name Target, Chain) // &15 %cycle // &16 Conc Length = Conc Length+1 // &17 Conc Length = -1000 %if Chain_Type > Addrs // &18 All Const = 0 %unless Iconst Item(Chain) // &19 Val = Val.Tostring(Chain_Disp&255) %if All Const # 0 // &20 %false %if Same(Target, Chain) %or (Target_Index ## Nil %and // &21 + Chain_Index ## Nil) // &22 Chain == Chain_Link // &23 %repeat %until Chain == Nil // &24 %true // &25 %end // &26 // &27 %routine Move1 // &28 Forget(L_Base); Forget(R_Base) // &29 Simple(R, L) // &30 %end // &31 // &32 // &33 Forget Destination(L) // &34 %if R_Oper = 0 %start // &35 {**********************************} // &36 {*** Simple assignment: S = T ***} // &37 {**********************************} // &38 // &39 N = R_Bias // &40 %if N # 0 %start {constant string} // &41 %if N = 1 %start {L = ""} // &42 L == Copy(L); L_Type = Bytes // &43 R == Literal(0) // &44 Simple(R, L) // &45 %else %if N < 0 {implied tostring} // &46 Ctos: L == Copy(L) // &47 Advance(L, Bytes, 1); Simple(R, L) {plug the character} // &48 R == Literal(1) // &49 Advance(L, Bytes, -1); Simple(R, L) {plug the length} // &50 %else {move in N bytes} // &51 L == Copy(L); Make AutoI(L, Bytes) // &52 R == Copy(R); Make AutoI(R, Bytes) // &53 Repeat(Move1, Literal(N), 1, NE) {NOTE length(S)+1} // &54 %finish // &55 Release and Drop Pair(L, R) // &56 %else %if R_Type <= Addrs {implied tostring} // &57 ->Ctos %if Iconst Item(R) // &58 W == Copy(L); Advance(W, Bytes, 1) // &59 Simple(R, W); Release and Drop(W) // &60 L == Copy(L); L_Type = Bytes // &61 Move Literal(1, L); Release and Drop(L) // &62 %else {Variable string} // &63 L == Copy(L); Make AutoI(L, Bytes) // &64 R == Copy(R); Make AutoI(R, Bytes) // &65 W == Copy(R); W_Form = Direct // &66 Repeat(Move1, W, 1, GE) // &67 Release and Drop Pair(L, R) // &68 %finish // &69 %return // &70 %finish // &71 // &72 {**************************************} // &73 {*** Complex assignment: S = A.B... ***} // &74 {**************************************} // &75 // &76 %routine Assign via Work // &77 %record(Stackfm)%name W // &78 W == Claim Work Area(255, Strings) // &79 String Assign(R, W) // &80 String Assign(W, L) // &81 Release and Drop(W) // &82 %end // &83 // &84 W == R_Link // &85 %unless Safe(L, W) %start // &86 Assign via Work; %return // &87 %finish // &88 // &89 R_OpLink = 0 // &90 %if Conc Length > 0 %and R_Type <= Addrs %start {all tostrings} // &91 L == Copy(L) // &92 All Const = 0 %unless Iconst Item(R) {first variable} // &93 %if All Const # 0 %start {it's in VAL} // &94 Value_String = Tostring(R_Disp&255).Val {don't forget the first} // &95 Z == Const String // &96 String Assign(Z, L) // &97 Release and Drop(Z) // &98 {all done, but fall through to drop descriptors} // &99 %else {some dynamic tostrings} // &100 Make AutoI(L, Bytes) // &101 Move Literal(Conc Length, L) {move in the total length} // &102 %finish // &103 // &104 %routine Assign Part // &105 R_OpLink = 0 // &106 Simple(R, L) %if All Const = 0 // &107 %end // &108 // &109 Assign Part // &110 %cycle // &111 R == W // &112 W == R_Link // &113 Assign Part // &114 Release and Drop(R) // &115 %repeat %until W == Nil // &116 Release and Drop(L) // &117 %return // &118 %finish // &119 // &120 %routine Concat(%record(Stackfm)%name Source) // &121 %record(Stackfm)%name Dest // &122 Source_Oplink = 0 // &123 %if Source_Type <= Addrs %start {Tostring(X)} // &124 Dest == Register(R2); Dest_Type = Bytes; Dest_Form = AutoI // &125 Simple(Source, Dest) // &126 Release and Drop(Dest) // &127 %return // &128 %finish // &129 {perhaps optimise if source length known} // &130 Load Address(Source, R3) // &131 Prim(Sconc) // &132 %end // &133 // &134 LL == Copy(L); Amap(LL) // &135 %if Same(L, R) %start {S = S.W.....} // &136 %if W_Link == Nil %and W_Type <= Addrs %start {S = S."*"} // &137 Loadup(LL); LL_Type = Bytes; LL_Form = Direct // &138 R == Copy(LL) {length pointer} // &139 Z == Copy(LL) // &140 Operate(ADDx, Z, Literal(1)) {length+1} // &141 Loadup(Z) {new length} // &142 LL_Index == Copy(Z); LL_Xsize = 1 {charno descriptor} // &143 Simple(W, LL) {plug in character} // &144 Simple(Z, R) {plug in new length} // &145 Release and Drop Pair(W, Z) // &146 Release and Drop Pair(LL,R) // &147 %return // &148 %finish // &149 Load(LL, R2) {pointer to length} // &150 Z == Copy(LL); Z_Type = Bytes; Z_Form = AutoI // &151 Load(Z, R1) {current length} // &152 R == Copy(LL); Load(R, R0); Drop(R) {copy of @charno(s, 1)} // &153 LL_Index == Z; LL_Xsize = 1 // &154 Load(LL, R2); Release(R2) {pointer past S} // &155 Forget(R2); Activity(R2) = -1 {lock R2} // &156 LL_Base = R0 {pointer for plugging length} // &157 %else // &158 DelayV == Nil // &159 %while R_Type <= Addrs %cycle {pull of leading tostrings} // &160 {NOTE - the case of all} // &161 {tostrings handled above} // &162 Delay = Delay+1 // &163 R_Oper = 0 // &164 R_Link == DelayV; DelayV == R {reverse them} // &165 R == W // &166 W == W_Link // &167 %repeat // &168 Operate(ADDx, LL, Literal(Delay+1)) {onto first real char space} // &169 Load(LL, R2) // &170 Load(LL, R0) {copy for pluging length} // &171 Forget(R2); Activity(R2) = -1 {lock R2} // &172 %if R ## Nil %start // &173 Concat(R) {first using Reg} // &174 Release(R_Base); R_Base = 0 // &175 Drop(R) %if Delay # 0 // &176 %else // &177 Len = Delay {final length} // &178 %finish // &179 %finish // &180 %while W ## Nil %cycle // &181 R == W // &182 W == R_Link; Concat(R) {remainder using R2 set by MOVS} // &183 Release and Drop(R) {Note first is left to be released} // &184 %repeat { by the caller} // &185 LL_Type = Bytes; LL_Form = AutoD // &186 %while Delay # 0 %cycle // &187 Delay = Delay-1 // &188 R == DelayV; DelayV == R_Link; R_Link == Nil // &189 Simple(R, LL) // &190 Release and Drop(R) %if Delay # 0 // &191 %repeat // &192 %if Len = 0 %start {final length unknown} // &193 Plant1(SUB, R2, R2, Just(R0)) // &194 Plant2(STR, R2, LL) // &195 Release and Drop(LL) // &196 LL == Copy(L); LL_Type = Bytes // &197 Remember(R2, LL) // &198 %else {final length known} // &199 Move Literal(Len, LL) {plug the length directly} // &200 %finish // &201 Release and Drop(LL) // &202 Activity(R2) = 0 {unlock R2} // &203 %end // ?LAB unused // ?HERE unused // ?REG unused // &204 %endoffile // 3980 %include "store.inc" // &1 !Revision history: // &2 // &3 ! 3-Jul-87 PSR corrected assigning longreal values to real locations // &4 ! - string(*)names were not being passed to %names properly // &5 // &6 %routine Store(%record(Stackfm)%name R, L) // &7 %unless R_Oper = 0 %and Same(L, R) %start // &8 %if L_Type = Records %start // &9 Record Assign(R, L) // &10 %else %if L_Type = Strings // &11 String Assign(R, L) // &12 %else %if L_Type = Sets // &13 Set Assign(R, L) // &14 %else // &15 Move(R, L) // &16 %finish // &17 %finish // &18 %end // &19 // &20 %routine Assign Procedure(%record(Stackfm)%name R, L) // &21 {A procedure parameter is a pointer to a tw0-word vector} // &22 {There are four cases} // &23 {1. The procedure is an external - } // &24 {2. The procedure is a parameter - pass the pointer} // &25 {3. The procedure is a safe local - pass and mark the parameter} // &26 { as needing an external entry} // &27 {4. The procedure is dangerous - pass and work hard} // &28 %integer Mask // &29 %record(Stackfm)%name W, V // &30 %if R_Flags&Xproc Spec # 0 %start {case 1 - an external} // &31 Hazard(R2) // &32 Dir2(Dir xThunk, R_Disp) { load @vector into R13} // &33 Refs = Refs+1; Ca = Ca+4 // &34 R == Register(R13) // &35 %else %if R_Flags&Parameter # 0 {case 2 - already a parameter} // &36 R_Type = Integers; R_Form = Direct; R_Area = 0 // &37 R == Copy(R) // &38 %else %if R_Flags&XprocDef # 0 {case 3 - simplified} // &39 Hazard(R13) // &40 Dir2(Dir Thunk, R_Disp) { load @vector into R13} // &41 Refs = Refs+1; Ca = Ca+4 // &42 R == Register(R13) // &43 %else {cases 3 & 4} // &44 Hazard(R13) // &45 Dir2(Dir Thunk, R_Disp) {Load @Ep into R13} // &46 Ca = Ca+4; Refs = Refs+1 // &47 Claim(R13) // &48 Mask = 2_0010 0100 0000 0000 {R10, R13 = Sb, Ep} // &49 W == NIL // &50 %if R_Flags&Nasty Proc # 0 %start {case 4 - a dangerous internal} // &51 Frame = Frame-4 // &52 W == Literal(Local Display); W_Base = Local // &53 Load(W, R14) // &54 Mask = 2_0110 0100 0000 0000 {R10, R13, R14 = Sb, Ep, Env} // &55 %finish // &56 Frame = Frame&(\3)-8 // &57 R == Local Integer(Frame); Loadup Address(R) // &58 Plant4(STM ! IA, R_Base, Mask) // &59 Release(R13) // &60 Release and Drop(W) %if W ## NIL // &61 %finish // &62 L_Type = Integers // &63 Simple(R, L) // &64 Release and Drop(R) // &65 %end // ?V unused // &66 // &67 %routine Assign Arrayname(%record(Stackfm)%name Array, To) // &68 %record(Stackfm)%name DopeVector // &69 Array_Type = Integers {the header contains integer addresses} // &70 To _Type = Integers // &71 %if Array_Flags&(Arrayname!Static) = 0 %start {in a record} // &72 %if Array_Adata == Nil %start // &73 DopeVector == Literal(0) // &74 %else // &75 DopeVector == Literal(Array_Adata_DV) // &76 DopeVector_Area = Constant Area // &77 %finish // &78 Amap(Array) // &79 %else // &80 DopeVector == Copy(Array) // &81 Advance(DopeVector, Integers, Word Length) // &82 %finish // &83 Simplify(To) // &84 Advance(To, Integers, Word Length) // &85 Simple(DopeVector, To); Release and Drop(DopeVector) {dope-vector} // &86 Advance(To, Integers,-Word Length) // &87 Simple(Array, To) {array0} // &88 %end // &89 // &90 %integerfn Select Best(%record(Stackfm)%name From, To, %integer Default) // &91 %record(Stackfm)%name W // &92 %integer Reg // &93 %result = Default %if InReg(From) // &94 W == Copy(To); Optimise(W, 1) // &95 %if InReg(W) %and Activity(W_Base) = 1 %then Reg = W_Base {-}%c // &96 + %else Reg = Default // &97 Release and Drop(W) // &98 %result = Reg // &99 %end // &100 // &101 %routine Move(%record(Stackfm)%name From, To) // &102 %record(Stackfm)%name Bf1, Bf2, Bt1, Bt2, W // &103 %integer R, Pa, N, Best, Op // &104 %if From_Oper = ADDx %and Pending Auto # 0 %start // &105 W == From_Link // &106 %if Iconst(W) %and -4095 <= W_Disp <= 4095 %start // &107 From_Oper = 0; From_Link == NIL // &108 Pa = Pending Auto {the optimise will destroy it} // &109 Optimise(From, 1) // &110 %if Inreg(From) %and From_Base = Pa {-}%c // &111 + %and (Pending Auto N = 0 %or |W_Disp>>2| <= 255) %start // &112 Dir3(Dir Modify, Ca-Pending Auto Ca, W_Disp>>Pending Auto N) // &113 Forget(Pa) // &114 Drop(W) // &115 %else // &116 From_Oper = ADDx; From_Link == W // &117 %finish // &118 %finish // &119 %finish // &120 %if From_Type = Shorts %and (From_Oper = ANDx %or From_Oper = BICx) {-}%c // &121 + %and To_Type = Integers {-}%c // &122 + %and Iconst(From_Link) %start // &123 N = From_Link_Disp // &124 N = \N %if From_Oper = BICx // &125 %if N&16_FFFF0000 = 0 %start // &126 Release and Drop(From_Link) // &127 From_Oper = 0; From_Link == NIL // &128 %if N <= 255 %start // &129 Advance(From, Bytes, 0) {low byte} // &130 Operate(ANDx, From, Literal(N)) %if N # 255 // &131 %else %if N&255 = 0 // &132 Release and Drop(From_Link) // &133 From_Oper = 0; From_Link = 0 // &134 Advance(From, Bytes, 1) {high byte} // &135 Operate(ANDx, From, Literal(N>>8)) %if N>>8 # 255 // &136 Operate(LSHx, From, Literal(8)) // &137 %else // &138 Best = Select Best(From, To, Any) // &139 Bf2 == Copy(From); Advance(Bf2, Bytes, 1) {high byte} // &140 Operate(ANDx, Bf2, Literal(N>>8)) %if N>>8 # 255 // &141 Advance(From, Bytes, 0) {low byte} // &142 Operate(ANDx, From, Literal(N&255)) %if N&255 # 255 // &143 Loadup(Bf2); Load Safely(From, Best) // &144 Loadup(Bf2); Load Safely(From, Best) {in case of hazard} // &145 Plant1(ORR, From_Base, From_Base, Ishift(Bf2_Base, 8, Logical Left)) // &146 Release and Drop(Bf2) // &147 %finish // &148 %finish // &149 %finish // &150 %if To_Type = Shorts %start // &151 %if Iconst(From) %start // &152 Bf1 == Literal(From_Disp&255) {low byte} // &153 Bf2 == Literal(From_Disp>>8&255) {high byte} // &154 %else %if From_Type = Shorts %and From_Oper = 0 // &155 %if From_Index ## NIL %or From_Record ## NIL %start // &156 Loadup Address(From); From_Type = Shorts; From_Form = Direct // &157 %finish // &158 Bf1 == Copy(From); Advance(Bf1, Bytes, 0) {low byte} // &159 Bf2 == Copy(From); Advance(Bf2, Bytes, 1) {high byte} // &160 %else %if From_Type = Bytes %and From_Oper = 0 // &161 Bf1 == Copy(From); Advance(Bf1, Bytes, 0) {low byte} // &162 Bf2 == Literal(0) {high byte} // &163 %else // &164 Loadup(From) // &165 Bf1 == Copy(From) // &166 Bf2 == Copy(From); Operate(RSHx, Bf2, Literal(8)) // &167 %finish // &168 Bt1 == Copy(To); Advance(Bt1, Bytes, 0) {low byte} // &169 Bt2 == Copy(To); Advance(Bt2, Bytes, 1) {high byte} // &170 Move(Bf2, Bt2) {do the [b+1] side first} // &171 Move(Bf1, Bt1) {and the [b+0] side last} // &172 Release and Drop Pair(Bf1, Bt1) // &173 Release and Drop Pair(Bf2, Bt2) // &174 %else %if To_Type = Bytes // &175 From_Type = Bytes %if From_Oper = 0 %and From_Type = Shorts // &176 Simplify(To) // &177 Loadup(From) // &178 Plant2(STR ! Byte Op, From_Base, To) // &179 %else %if To_Type = Lreals // &180 Best = Select Best(From, To, AnyF) // &181 Simplify(To) // &182 Load(From, Best) // &183 Plant6(STFD, From_Base, To) // &184 %else %if To_Type = Reals // &185 %if Iconst(From) %and (-5 <= From_Disp <= 5 %or From_Disp = 10 {-}%c // &186 + %or From_Disp = -10) %start // &187 Op = MVF // &188 N = From_Disp // &189 Op = MNF %and N = -N %if N < 0 // &190 N = 7 %if N = 10 // &191 R = FPR // &192 Plant9(Op ! Small Constant, 0, R, N) // &193 Plant6(STFS, R, To) // &194 %else %if From_Form = Direct %and From_Oper = 0 %and From_Type = Reals // &195 To == Copy(To); To_Type = Integers // &196 From == Copy(From); From_Type = Integers // &197 Move(From, To) // &198 Forget(From_Base) // &199 Release and Drop Pair(From, To) // &200 %else // &201 Simplify(To) // &202 Load(From, AnyF) // &203 Plant6(STFS, From_Base, To) {corrected for R0002.IMP} // &204 %finish // &205 %else // &206 Best = Select Best(From, To, Any) // &207 Simplify(To) // &208 Load(From, Best) // &209 Plant2(STR, From_Base, To) // &210 %finish // &211 %end // &212 // &213 %routine Move Literal(%integer Value, %record(Stackfm)%name To) // &214 %record(Stackfm)%name W == Literal(Value) // &215 Simple(W, To) // &216 Release and Drop(W) // &217 %end // &218 // &219 %routine Move Biased(%record(Stackfm)%name From, To, %integer Bias) // &220 From == Copy(From) // &221 To == Copy(To) // &222 Advance(From, Integers, Bias) %if From_Form = Direct // &223 Advance(To, Integers, Bias) // &224 Move(From, To) // &225 Release and Drop Pair(From, To) // &226 %end // &227 // &228 %routine Store Address(%record(Stackfm)%name R, L, %integername Extra) // &229 %record(Stackfm)%name W // &230 %integer Rt, Format // &231 %if L_Type = Generals %start // &232 L_Type = Integers {really three of them} // &233 Amap(L) %unless L_Form = AutoD // &234 Format = R_Format // &235 Rt = R_Type // &236 Amap(R) // &237 %if Rt = Generals %start // &238 Move Biased(R, L, WordLength*2) // &239 Move Biased(R, L, WordLength*1) // &240 Move (R, L) // &241 %else // &242 W == Literal(Type Code(Rt)) // &243 Move Biased(W, L, Wordlength*2) // &244 Release and Drop(W) // &245 %if Rt = Strings %and R_Form = Direct %and Format = 1 %start {(*)} // &246 Move Biased(R, L, Wordlength) // &247 Move (R, L) // &248 %else // &249 W == Literal(Item Size(Format)) // &250 Move Biased(W, L, Wordlength); Release and Drop(W) // &251 Move (R, L) // &252 %finish // &253 %finish // &254 Extra = Extra+12 // &255 %else %if L_Form = Proc // &256 Assign Procedure(R, L) // &257 Extra = Extra+4 // &258 %else %if L_Flags&Arrayname # 0 // &259 Assign Arrayname(R, L) // &260 Extra = Extra+8 // &261 %else %if L_Type = Strings %and L_Format = 1 // &262 N = R_Format // &263 Amap(L) // &264 Amap(R) // &265 %if N = 1 %and R_Form # Address %start {string(*)name} // &266 Move Biased(R, L, Wordlength) // &267 Move (R, L) // &268 %else // &269 W == Literal(N) // &270 Move Biased(W, L, Wordlength); Release and Drop(W) // &271 Move (R, L) // &272 %finish // &273 Extra = Extra+8 // &274 %else // &275 %if L_Form = AutoD %then L_Type = Integers {-}%c // &276 + %else Amap(L) // &277 Amap(R) // &278 Store(R, L) // &279 Extra = Extra+4 // &280 %finish // &281 %end // &282 // &283 %routine Jam Transfer(%record(Stackfm)%name L, R) // &284 %integer N, Type // &285 %record(Stackfm)%name M // &286 Type = L_Type // &287 %if Type # Strings %start {just omit the remember} // &288 Jamit = 1; Store(R, L); Jamit = 0 // &289 Forget Destination(L) // &290 %else // &291 N = L_Format-1 {maximum length} // &292 Evaluate String Expression(R) %if R_Oper # 0 // &293 Amap(L); Amap(R) // &294 %if N <= 0 %start {string(*)%name} // &295 M == Copy(L) // &296 M_Disp = M_Disp+Word Length; M_Type = Integers // &297 %else // &298 M == Literal(N+1) // &299 %finish // &300 Load Trio(L, R2, R, R1, M, R0) // &301 Prim(Sjam) // &302 Release and Drop(M) // &303 %finish // &304 %end // &305 // &306 %routine Assign(%integer How) // &307 %integer X = 0 // &308 %record(Varfm)%name V // &309 %record(Stackfm)%name L, R // &310 R == Stack // &311 L == R_Stack; Stack == L_Stack // &312 %if Diag&MonMove # 0 %start // &313 Monitor(L, "A-L") // &314 Monitor(R, "A-R") // &315 %finish // &316 %if How = Equals %start // &317 Store(R, L) // &318 %else %if How = EqualsEquals // &319 Store Address(R, L, X) // &320 %else // &321 Jam Transfer(L, R) // &322 %finish // &323 %if Assign Lock # 0 %and L_Varno # 0 %start // &324 V == Var(L_Varno) // &325 V_Flags = V_Flags!Known Ass // &326 %finish // &327 Release and Drop Pair(R, L) // &328 %end // &329 // &330 %routine Assign Parameter // &331 %record(Stackfm)%name Par // &332 Par == Stack {the parameter} // &333 Stack == Par_Stack {the procedure} // &334 Par_Params == Stack_Params // &335 Stack_Params == Par // &336 Stack_Extra = Stack_Extra-1 %unless Stack_Extra = 0 {beware of C} // &337 Par_Varno = Stack_Extra // &338 %end // &339 // &340 %record(Stackfm)%map To Temp(%record(Stackfm)%name V, %integer Size) // &341 %record(Stackfm)%name W // &342 W == Claim Work Area(Size, Strings) // &343 String Assign(V, W) // &344 Release and Drop(V) // &345 %result == W // &346 %end // &347 // &348 {%include "pparam.inc" // &349 %endoffile // 3981 %include "pparam.inc" {moved out of store.inc} // &1 !Revision history: // &2 ! // &3 ! C-0087 20-Jul-88 PSR Changed register processing to fix R(r*r, r*r,..) bug // &4 ! 0.9 15-Jan-88 PSR Removed %namearray for transputer work // &5 // &6 %record(Stackfm)%map Procedure Items(%record(Stackfm)%name R) // &7 {A procedure parameter is a pointer to a tw0-word vector} // &8 {There are four cases} // &9 {1. The procedure is an external - } // &10 {2. The procedure is a parameter - pass the pointer} // &11 {3. The procedure is a safe local - pass and mark the parameter} // &12 { as needing an external entry} // &13 {4. The procedure is dangerous - pass and work hard} // &14 %integer Mask // &15 %record(Stackfm)%name Ep, Env // &16 Env == NIL // &17 %if R_Flags&Xproc Spec # 0 %start {case 1 - an external} // &18 Min SB = Min SB-4 // &19 Ep == Local Integer(Min SB); Ep_Base = SB // &20 Dir3(Dir xThunk, R_Disp, Ep_Disp) {relocate entry pointer} // &21 %else %if R_Flags&Parameter # 0 {case 2 - already a parameter} // &22 {R defines pair} // &23 R_Type = Integers; R_Form = Direct; R_Area = 0 // &24 Env == Copy(R) // &25 Ep == Copy(Env); Advance(Ep, Integers, 4) // &26 %else // &27 %if R_Flags&XprocDef = 0 %and R_Flags&Nasty Proc # 0 %start // &28 {case 3 - not a dangerous internal} // &29 Env == Local Integer(Local Display); Amap(Env) // &30 %finish // &31 Min SB = Min SB-4 // &32 Ep == Local Integer(Min SB); Ep_Base = SB // &33 Dir3(Dir Thunk, R_Disp, Ep_Disp) {relocate entry pointer} // &34 Refs = Refs+1 // &35 %finish // &36 Env == Literal(0) %if Env == NIL // &37 Env_Prim = Integers; Ep_Prim = Integers // &38 Env_Params == Ep; Ep_Params == NIL // &39 %result == Env // &40 %end // ?MASK unused // &41 // &42 %record(Stackfm)%map Arrayname Items(%record(Stackfm)%name Array) // &43 %record(Stackfm)%name DopeVector // &44 Array == Copy(Array) // &45 Array_Type = Integers {the header contains integer addresses} // &46 %if Array_Flags&(Arrayname!Static) = 0 %start {in a record} // &47 %if Array_Adata == Nil %start // &48 DopeVector == Literal(0) // &49 %else // &50 DopeVector == Literal(Array_Adata_DV) // &51 DopeVector_Area = Constant Area // &52 %finish // &53 Amap(Array) // &54 %else // &55 DopeVector == Copy(Array) // &56 Advance(DopeVector, Integers, Word Length) // &57 %finish // &58 Array_Prim = Integers; DopeVector_Prim = Integers // &59 Array_Params == Dopevector; Dopevector_Params == NIL // &60 %result == Array // &61 %end // &62 // &63 %record(Stackfm)%map Address Items(%record(Stackfm)%name Par, Formal) // &64 %record(Stackfm)%name W, X, Y, Z // &65 %integer Rt, Format // &66 %result == Procedure Items(Par) %if Formal_Form = Proc // &67 %result == Arrayname Items(Par) %if Formal_Flags&Arrayname # 0 // &68 // &69 X == Copy(Par); Amap(X); X_Prim = Integers; X_Params == NIL // &70 // &71 Format = Par_Format // &72 %if Formal_Type = Generals %start // &73 Rt = Par_Type // &74 %if Rt = Generals %start // &75 Advance(X, Integers, 0) // &76 Y == Copy(X); Advance(Y, Integers, Wordlength) // &77 Z == Copy(X); Advance(Z, Integers, Wordlength*2) // &78 %else // &79 Z == Literal(Type Code(Rt)) // &80 %if Rt = Strings %and X_Form = Direct %and Format = 1 %start {(*)} // &81 Y == Copy(X); Advance(Y, Integers, Wordlength) // &82 %else // &83 Y == Literal(Item Size(Format)) // &84 %finish // &85 %finish // &86 Y_Prim = Integers; Z_Prim = Integers // &87 X_Params == Y; Y_Params == Z; Z_Params == NIL // &88 %else %if Formal_Type = Strings %and Formal_Format = 1 {lhs string(*)name} // &89 %if Format = 1 %and X_Form # Address %start {rhs string(*)name} // &90 Y == Copy(X); Advance(Y, Integers, Wordlength) // &91 %else // &92 Y == Literal(Format) // &93 %finish // &94 Y_Prim = Integers // &95 X_Params == Y; Y_Params == NIL // &96 %finish // &97 %result == X // &98 %end // ?W unused // &99 // &100 %routine Pass Parameters(%record(Stackfm)%name V, %integername Extra, // &101 + %integer BaseReg) // &102 %integer Completed // &103 %record(Stackfm)%name Par, Formal, Head, L // &104 %record(Stackfm)%name Items, Rest, X, Y // &105 %recordformat Rpfm(%record(Stackfm)%name P) // &106 %record(Rpfm)%array Reginfo(R0:R3) // &107 %ownrecord(Stackfm) Sp Mark {C-0087} // &108 // &109 Extra = 0 // &110 Head == V_Params; %return %if Head == NIL {no parameters} // &111 // &112 {Head is the start of a list of actual parameters in reverse (R-L) order} // &113 {First, convert this into a forward list of integer, real & longreal items} // &114 // &115 Items == NIL // &116 %while Head ## Nil %cycle // &117 Par == Head; Head == Head_Params // &118 Stack Var(Par_Varno); Formal == Stack; Stack == Formal_Stack // &119 %if Formal_Flags&Parameter # 0 %start {procedure parameter} // &120 X == Procedure Items(Par) // &121 %else %if Formal_Flags&Arrayname # 0 {arrayname parameter} // &122 X == Arrayname Items(Par) // &123 %else %if Formal_Flags&Awanted # 0 // &124 %if Par_Oper = CONCx %start // &125 Par == To Temp(Par, 256) // &126 %else %if Formal_Type = Strings %and Par_Type # Strings // &127 %if Iconst(Par) %then Fix Unitary String(Par) {-}%c // &128 + %else Par == To Temp(Par, 2) // &129 %else %if Par_Type = Strings %and Par_Bias = 1 {""} // &130 Fix Unitary String(Par) // &131 %else %if Par_Type = Sets // &132 %if Par_Oper # 0 %start // &133 Loadup(Par) // &134 %else %if Par_Members ## Nil // &135 Build Set(Par) // &136 %finish // &137 %finish // &138 X == Address Items(Par, Formal) // &139 %else // &140 X == Copy(Par) // &141 X_Prim = Formal_Type // &142 X_Params == NIL // &143 %finish // &144 Release and Drop Pair(Par, Formal) // &145 Y == X; Y == Y_Params %while Y_Params ## NIL // &146 Y_Params == Items // &147 Items == X // &148 %repeat // &149 // &150 %routine Complete Register Processing // &151 %integer R, N, Mask {C-0087} // &152 %record(Stackfm)%name V // &153 %return %if Completed # 0 // &154 Completed = 1 // &155 Monitor N(0, "+complete") %if Diag&MonOperand # 0 // &156 // &157 {first, deal with the complex parameters} // &158 %for R = R0, 1, R3 %cycle // &159 V == Reginfo(R)_P // &160 %continue %if V == NIL %or V == Sp Mark {C-0087} // &161 %if V_Oper # 0 %then Load(V, R) %else Simplify(V) // &162 %repeat // &163 // &164 {Now, load up all the free registers} // &165 // &166 %for R = R0, 1, R3 %cycle // &167 V == Reginfo(R)_P // &168 %continue %if V == NIL %or V == Sp Mark {C-0087} // &169 Load(V, R) %if Activity(R) = 0 %and Ktimes(R) = 0 // &170 %repeat // &171 // &172 {Now, load up the inactive registers} // &173 // &174 %for R = R0, 1, R3 %cycle // &175 V == Reginfo(R)_P // &176 %continue %if V == NIL %or V == Sp Mark {C-0087} // &177 Load(V, R) %if Activity(R) = 0 // &178 %repeat // &179 // &180 {last scan to make sure} // &181 // &182 N = 0 // &183 %for R = R0, 1, R3 %cycle // &184 V == Reginfo(R)_P // &185 %continue %if V == NIL %or V == Sp Mark {C-0087} // &186 Load(V, R) // &187 N = N+1 {one more active register} // &188 %repeat // &189 // &190 {Beware - once the registers have been loaded they are released} // &191 {If the HAZARD ALL in the CALL needs to use a register for } // &192 {Addressing it may well corrupt one of the parameter registers } // &193 {Therefore do the hazarding here SCR???} // &194 // &195 %if Active Registers # N %start {hazard pending registers} // &196 %for R = R0, 1, R3 %cycle // &197 V == Reginfo(R)_P // &198 Hazard(R) %if V == NIL %or V == Sp Mark // &199 %repeat // &200 Hazard(R4); Hazard(R5); Hazard(R6); Hazard(R7) // &201 %if Active Registers # N %start // &202 Hazard(R8); Hazard(R11); Hazard(R14) // &203 %if Active Registers # N %start // &204 Hazard(F0); Hazard(F1); Hazard(F2); Hazard(F3) // &205 %if Active Registers # N %start // &206 Hazard(F4); Hazard(F5); Hazard(F6); Hazard(F7) // &207 %finish // &208 %finish // &209 %finish // &210 %finish // &211 // &212 {now suck up any pushed values} {C-0087} // &213 Mask = 0 {C-0087} // &214 N = 1 {C-0087} // &215 %for R = R0, 1, R3 %cycle {C-0087} // &216 %if Reginfo(R)_P == Sp Mark %start {C-0087} // &217 Extra = Extra-4 {C-0087} // &218 Mask = Mask ! N {C-0087} // &219 %finish {C-0087} // &220 N = N<<1 {C-0087} // &221 %repeat {C-0087} // &222 %if Mask # 0 %start {C-0087} // &223 Plant4(LDM ! IA ! Write Back, Sp, Mask) {C-0087} // &224 %finish {C-0087} // &225 // &226 {finally, get rid of everything} // &227 // &228 %for R = R0, 1, R3 %cycle // &229 V == Reginfo(R)_P // &230 %continue %if V == NIL %or V == Sp Mark // &231 Release and Drop(V) // &232 %repeat // &233 Monitor N(0, "+complete") %if Diag&MonOperand # 0 // &234 %end // &235 // &236 %routine Push(%record(Stackfm)%name V, %integer Type) // &237 %record(Stackfm) Spv = 0 // &238 Spv_Type = Type // &239 Spv_Form = AutoD // &240 Spv_Base = Sp // &241 %if Type = Integers %start // &242 Load(V, Any) // &243 Plant2(STR, V_Base, SpV) // &244 %else %if Type = Lreals // &245 Load(V, AnyF) // &246 Plant6(STFD, V_Base, SpV) // &247 Extra = Extra+4 {twice as big as integers & reals} // &248 %else %if Type = Reals // &249 Load(V, AnyF) // &250 Plant6(STFS, V_Base, SpV) // &251 %else // &252 Fail("Bad push type") // &253 %finish // &254 Extra = Extra+4 // &255 Release and Drop(V) // &256 %end // &257 // &258 !{C-0087} // &259 ! %routine Pop(%integer Reg) // &260 ! {reg < 0 is a flag for loading |reg| and |reg|+1} // &261 ! %record(Stackfm)%name Spv // &262 ! %if Reg >= 0 %start // &263 ! Spv == Literal(0) // &264 ! Spv_Form = AutoI // &265 ! Spv_Base = Sp // &266 ! Load(Spv, Reg) // &267 ! Release and Drop(Spv) // &268 ! %else // &269 ! Reg = -Reg {SCR???} // &270 ! Hazard(Reg); Hazard(Reg+1) {SCR???} // &271 ! Plant4(LDM ! IA ! Write Back, Sp, 3< R3 %start {all registers dealt with} // &285 Process(Next, R4) {deal with all the rest} // &286 Push(V, V_Prim) {then push this one} // &287 %else %if V_Prim = Integers // &288 Reginfo(Rn)_P == V {remember for later} // &289 Process(Next, Rn+1) {deal with the rest} // &290 %else %if V_Prim = Reals // &291 Simplify(V) {better be safe} // &292 Load(V, AnyF) %if V_Type # Reals %and V_Type # Lreals // &293 {This one can go into a register, but it may need to use [Sp]} // &294 %if V_Form = Direct %start {can go straight there} // &295 V_Type = Integers // &296 Reginfo(Rn)_P == V {remember for later} // &297 Process(Next, Rn+1) {deal with the rest first} // &298 %else {must go via [Sp]} // &299 Process(Next, Rn+1) {deal with the rest first} // &300 Push(V, Reals) // &301 Reginfo(Rn)_P == Sp Mark {C-0087} // &302 ! Complete register processing {C-0087} // &303 ! Pop(Rn) {C-0087} // &304 %finish // &305 %else %if V_Prim = Lreals // &306 Simplify(V) {better be safe} // &307 Load(V, AnyF) %if V_Type # Lreals // &308 %if V_Form = Direct %start {at least one bit can go in a register} // &309 %if Rn = R3 %start {second half must be pushed} // &310 Process(Next, Rn+2) {deal with the rest first} // &311 Push(V, Lreals) {push both} // &312 Reginfo(Rn)_P == Sp Mark {C-0087} // &313 ! Complete register processing {C-0087} // &314 ! Pop(R3) {C-0087} {and bring back R3} // &315 %else {second half fits into the next register} // &316 V_Type = Integers // &317 X == Copy(V); Advance(X, Integers, 4) // &318 Reginfo(Rn+0)_P == V // &319 Reginfo(Rn+1)_P == X // &320 Process(Next, Rn+2) {deal with the rest} // &321 %finish // &322 %else {must go via [Sp]} // &323 Process(Next, Rn+2) {deal with the rest first} // &324 Push(V, Lreals) // &325 %if Rn = R3 %start {one into register} {C-0087} // &326 Reginfo(Rn+0)_P == Sp Mark {C-0087} // &327 %else {both into registers} {C-0087} // &328 Reginfo(Rn+0)_P == Sp Mark {C-0087} // &329 Reginfo(Rn+1)_P == Sp Mark {C-0087} // &330 %finish {C-0087} // &331 ! Complete register processing {C-0087} // &332 ! %if Rn = R3 %start {C-0087} {pop one into registers} // &333 ! Pop(Rn) {C-0087} // &334 ! %else {C-0087} {pop both into registers} // &335 ! Pop(-Rn) {C-0087} // &336 ! %finish {C-0087} // &337 %finish // &338 %else // &339 Fail("Bad process type") // &340 %finish // &341 %end // &342 // &343 Reginfo(R0)_P == NIL // &344 Reginfo(R1)_P == NIL // &345 Reginfo(R2)_P == NIL // &346 Reginfo(R3)_P == NIL // &347 Completed = 0 // &348 Process(Items, BaseReg) // &349 Complete register processing // &350 %end // ?REST unused // ?L unused // &351 %endoffile // 3982 // 3983 %routine Array Index // 3984 %record(Stackfm)%name X, End // 3985 X == Stack {the index} // 3986 Stack == Stack_Stack {the array} // 3987 End == Stack // 3988 End == End_Params %while End_Params ## Nil {find the end} // 3989 End_Params == X // 3990 X_Params == Nil // 3991 Stack_Oper = Stack_Oper+1 // 3992 %end // 3993 // 3994 %routine Array Access // 3995 %integer N, Lim, Flag, Type, Format, Xsize, Scale Needed = 0, MulOp // 3996 %record(Stackfm)%name X, All, Next, Mult, Scale // 3997 // 3998 %routine Set up MULT // 3999 Mult == Copy(X_Stack) {header} // 4000 Advance(Mult, Integers, 4) {onto dope vector pointer} // 4001 Loadup(Mult) {pick up dope vector} // 4002 Mult_Disp = 20; Mult_Form = Direct {select multiplier 0} // 4003 %end // 4004 // 4005 Scale == NIL // 4006 X == Stack {index value} // 4007 Flag = X_Stack_Flags // 4008 MulOp = MULx // 4009 %if Flag&Defered = 0 %start // 4010 Scale Needed = 1 %if (X_Stack_Type = Strings %and X_Stack_Format = 1) %c // 4011+ %or (X_Stack_Type = Records %and X_Stack_Format = 0) // 4012 %finish // 4013 Lim = 1 // 4014 %if X_Stack_Oper # 0 %start {final of multi-dimensional} // 4015 Array Index // 4016 Next == Stack_Params // 4017 All == Literal(0) // 4018 Lim = Stack_Oper; Stack_Oper = 0 // 4019 Set up MULT %if Flag&Arrayname # 0 {it's dynamic} // 4020 %for N = 1, 1, Lim %cycle // 4021 X == Next // 4022 Next == X_Params; X_Params == Nil // 4023 %if N # 1 %start // 4024 %if Flag&Arrayname # 0 %start {no constant dope vector} // 4025 Operate(MulOp, All, Copy(Mult)) // 4026 Mult_Disp = Mult_Disp+12 // 4027 %else // 4028 Operate(MulOp, All, Literal(Stack_Adata_Bound(N-1)_Mult)) // 4029 %finish // 4030 %finish // 4031 Operate(ADDx, All, X) // 4032 %repeat // 4033 Fail("Corrupt array index") %if Next ## Nil // 4034 X == All // 4035 %if Flag&Array = 0 %start // 4036 %if Scale Needed # 0 %start // 4037 Scale == Mult {pointing at element size in the dope vector} // 4038 %else // 4039 Release and Drop(Mult) // 4040 %finish // 4041 %finish // 4042 %else {Single dimensional} // 4043 Set up MULT %and Scale == Mult %if Scale Needed # 0 // 4044 Stack == X_Stack // 4045 %finish // 4046 Type = Stack_Type; Stack_Type = Integers // 4047 Format = Stack_Format // 4048 Vmap(Stack, Integers) %if Flag&Arrayname # 0 {indirect through the header} // 4049 %if Flag&Defered # 0 %start {namearray} // 4050 Xsize = Wordlength // 4051 Xsize = 2*Wordlength %if Type = Strings %and Format = 1 // 4052 %else %if Scale ## NIL // 4053 Operate(MulOp, X, Scale) // 4054 Xsize = 1 // 4055 %else // 4056 Xsize = Item Size(Format) // 4057 %finish // 4058 Stack_Flags = Stack_Flags ! Flag // 4059 Apply Index(Stack, X, Xsize) // 4060 %if Flag&Defered # 0 %start {namearray} // 4061 Vmap(Stack, Type) // 4062 %else // 4063 Stack_Type = Type // 4064 %finish // 4065 Stack_Format = Format // 4066 Stack_Flags = Stack_Flags&( \(Static!Array!Arrayname) ) // 4067 Monitor(Stack, "Array") %if Diag&MonOperand # 0 // 4068 %end // 4069 // 4070 %routine Update Line(%integer This Line) // 4071 Fail("Stack") %unless Stack == Nil // 4072 Fail("Registers") %unless Active Registers = 0 // 4073 Fail("Descriptors") %unless Using == Nil // 4074 Fail("Corrupt") %if RegV(Any )_Base # Any %c // 4075+ %or RegV(AnyF)_Base # AnyF // 4076 // 4077 %if This Line # Current Line %start // 4078 Current Line = This Line // 4079 Dir2(Dir Line, Current Line) %if Compiling Prim = 0 // 4080 %finish // 4081 // 4082 %if Diag&MonLine # 0 %start // 4083 Select Output(Report) // 4084 Printstring("Line:"); Write(This Line, 1); Newline // 4085 Select Output(Directives Out) // 4086 %finish // 4087 // 4088 Display Knowledge %if Diag&MonOpt # 0 // 4089 Work Validity = Work Validity+1 {release work areas} // 4090 Value = Default Value {restore default values} // 4091 // 4092 %end // 4093 // 4094 {Parameter and Format processing} // 4095 // 4096 %routine Terminate Block // 4097 %integer J, N, M // 4098 %record(Varfm)%name V // 4099 %if Amode < 0 %and Amode # -16 %start {format - align alternatives} // 4100 Falign = Alt Align {pass back nested alignment} // 4101 N = 0 // 4102 %if Falign = \0 %start {no alignment needed} // 4103 N = Frame Extra // 4104 %else %if Falign = \1 {halfword alignment} // 4105 N = Frame Extra&2 // 4106 %finish // 4107 M = N // 4108 %if N # 0 %start {can adjust} // 4109 %for J = Parms, 1, First Alt %cycle // 4110 V == Var(J) // 4111 V_Disp = V_Disp-N // 4112 %repeat // 4113 Max Frame = Max Frame-N // 4114 Frame = Frame-N // 4115 %finish // 4116 Frame = Max Frame %if Max Frame > Frame // 4117 %if Amode = -2 %start {end of alternative} // 4118 Old Frame = Frame {pass it back} // 4119 %else {end of complete format} // 4120 Avar_Disp = \Falign {***align***} // 4121 Frame = (Frame+(\Falign))&Falign // 4122 Avar_Format = Frame // 4123 Dir1(Dir Record Off) // 4124 %finish // 4125 %finish // 4126 Frame = Old Frame // 4127 %end // 4128 // 4129 %routine Copy Old Display // 4130 %integer T, J // 4131 // 4132 %routine Copy(%integer Flag, To) // 4133 %record(Stackfm)%name F, T // 4134 F == Literal(0) // 4135 %if Flag < 0 %start // 4136 F_Base = Local; // 4137 %else // 4138 F_Base = R8; F_Form = AutoI; Claim(F_Base) // 4139 Loadup(F) // 4140 %finish // 4141 T == Local Integer(To) // 4142 Plant2(STR, F_Base, T) // 4143 Release and Drop Pair(F, T) // 4144 %end // 4145 // 4146 T = Local Display // 4147 %for J = Danger Level, 1, Local-1 %cycle // 4148 Copy(0, T); T = T+4 // 4149 %repeat // 4150 Copy(-1, T) {special for FP} // 4151 %end // 4152 // 4153 %predicate Finish Params // 4154 %integer J, // 4155+ Mod = 0, {002} // 4156+ Type, A, N // 4157 %record(Varfm)%name Ap, Fp, V // 4158 %record(Stackfm)%name S // 4159 Parameter Regs = 0 // 4160 Parameter List = 0 {no longer in params or format} // 4161 Flush Diags %and %true %if Amode < 0 {end of format} // 4162 Parameter Frame = Frame // 4163 // 4164 %if Avar_Flags&Answer # 0 %and Avar_Flags&Defered = 0 %and // 4165+ (Avar_Type = Strings %or Avar_Type = Records) %start // 4166 {allocate a result parameter} // 4167 Parameter Frame = Parameter Frame+4 // 4168 String Result = 4; Mod = Mod+4 // 4169 %finish // 4170 // 4171 %if Amode = 0 %start {remember parameter registers} // 4172 N = R0 // 4173 A = 4 // 4174 %while A < Parameter Frame %cycle // 4175 S == Local Integer(A) // 4176 Remember(N, S); Drop(S) // 4177 Parameter Regs = Parameter Regs+1 // 4178 A = A+4 // 4179 %exit %if N = R3 // 4180 N = N+1 // 4181 %repeat // 4182 %finish // 4183 // 4184 Frame = -20 {ready for local variables} // 4185 %if Varbase # Vars %start {parameters given} // 4186 Avar_Extra = Parms {first-1} // 4187 Avar_Area = Parameter Frame {size of parameter part of frame} // 4188 %for J = Varbase+1, 1, Vars %cycle // 4189 Ap == Var(J) {actual} // 4190 Parms = Parms-1 // 4191 Fp == Var(Parms) {formal} // 4192 Ap_Base = Local // 4193 Fp = Ap // 4194 Fp_Base = Sp {WSP} // 4195 Fp_Form = AutoD // 4196 Fp_Disp = 0; Ap_Disp = Ap_Disp+Mod // 4197 Fp_Flags = Fp_Flags!Known Ass // 4198 Fp_Flags = Fp_Flags!Awanted %if Ap_Form # Direct // 4199 Fp_Type = Integers %if Fp_Type = Bytes %or Fp_Type = Shorts // 4200 %if Ap_Flags&Awanted # 0 %and Amode = 0 %and Ap_Form # PROC %start // 4201 {string/record value parameter} // 4202 Ap_Flags = Ap_Flags-Awanted // 4203 V == Var(Max Vars); V = Ap // 4204 Frame = Frame-Item Size(Ap_Format) // 4205 V_Base = Local; V_Disp = Frame // 4206 Stack Var(Max Vars); Stack Var(J) // 4207 Type = Stack_Type; Stack_Type = Integers; Vmap(Stack, Type) // 4208 Assign(Equals) // 4209 Ap = V // 4210 %finish // 4211 Ap_Flags = Ap_Flags!Known Ass %if Ap_Flags&Parameter = 0 // 4212 %repeat // 4213 Flush Diags // 4214 %finish // 4215 %true %if Amode # 0 {not a definition} // 4216 %if Danger Marker # 0 %start // 4217 Danger Level = Local %if Danger Level = No Danger // 4218 %finish // 4219 %if Danger Level # No Danger %start // 4220 Frame = Frame&(\3)-4*(Local-Danger Level+1) // 4221 Local Display = Frame // 4222 Attributes = Attributes ! Attr Local Display ! Attr Inherit // 4223 %finish // 4224 Copy old Display %if Local Display # 0 {copy the display} // 4225 %false {the body follows} // 4226 %end // 4227 // 4228 %integerfn Tag // 4229 %integer N // 4230 Readsymbol(N); N = Pending<<8+N // 4231 Readsymbol(Pending) // 4232 %result = N // 4233 %end // 4234 // 4235 %routine Get String(%string(*)%name Text) // 4236 %integer J, Sym, Limit // 4237 Limit = Size of(Text)-1 // 4238 Text = "" // 4239 %for J = Pending, -1,1 %cycle // 4240 Readsymbol(Sym) // 4241 Text = Text.Tostring(Sym) %if Length(Text) < Limit // 4242 %repeat // 4243 Readsymbol(Pending) // 4244 %end // 4245 // 4246 %predicate On IEEE // 4247 {differentiates between VAX & IEEE by means of the position} // 4248 {of the sign bit in floating-point numbers} // 4249 %integer Mone = -1 // 4250 %longreal M = Mone // 4251 %byteinteger B = Byteinteger(Addr(M)) // 4252 %true %if B = 0 %or B = 16_BF // 4253 %false // 4254 %end // 4255 // 4256 %routine Convert Format(%record(Stackfm)%name V, %integer Type) // 4257 %real Single // 4258 %integer A = V_Rhigh, // 4259+ B = V_Rlow, // 4260+ Fh, Fl, S, X // 4261 %unless A = 0 = B %or On IEEE %start // 4262 {first dismantle VAX form of FP numbers} // 4263 Fh = (A&2_1111111)<<16 ! (A>>16) {top 23 bits of FP number} // 4264 FL = (B&16_FFFF) <<16 ! (B>>16) {low 32 bits of FP number} // 4265 X = (A>>7) {true exponent} // 4266 X = X&255-128 // 4267 S = A>>15&1 {sign bit} // 4268 %if Type = Lreals %start // 4269 X = (X+1023-1)&2_111 1111 1111 {NS exponent} // 4270 B = (Fh&7)<<29 ! (Fl>>3) // 4271 A = S<<31 + X<<20 + (Fh>>3)&16_000FFFFF // 4272 %else {reals} // 4273 X = (X+127-1)&2_1111 1111 // 4274 A = S<<31 + X<<23 + Fh // 4275 B = 0 // 4276 %finish // 4277 %else %if Type = Reals {convert to short real} // 4278 Single = V_Rval // 4279 A = Integer(Addr(Single)) // 4280 B = 0 // 4281 %finish // 4282 V_Rhigh = A // 4283 V_Rlow = B // 4284 %end // 4285 // 4286 %routine To Short Real(%record(Stackfm)%name V) // 4287 %integer X, Y, Exp, S // 4288 %return %if V_Rhigh = 0 = V_Rlow // 4289 %if On IEEE %start // 4290 Real(Addr(V_Rval)) = V_Rval // 4291 %else // 4292 X = V_RHigh; S = X // 4293 Y = V_Rlow // 4294 Exp = ((X>>20)&2_111 1111 1111) - 1023 + 1 {true exponent} // 4295 Exp = Exp + 127 -1 {short format} // 4296 X = (X&2_0000 0000 0000 1111 1111 1111 1111 1111)<<3 // 4297 X = X ! (Y>>(32-3)) {extra bits from mantissa} // 4298 X = X+1 %if Y&16_1000 0000 # 0 {round it} // 4299 %if X&16_0080 0000 # 0 %start {need to normalise} // 4300 X = X>>1 // 4301 Exp = Exp+1 // 4302 %finish // 4303 X = X ! (Exp&255)<<23 // 4304 X = X ! 16_8000 0000 %if S < 0 // 4305 V_Rhigh = X // 4306 V_Rlow = 0 // 4307 %finish // 4308 %end // 4309 // 4310 %include "realcon.inc" // &1 %longrealfn Real Constant // &2 {Input an encoded real constant and convert to M/C representation} // &3 %externallongrealfnspec Text to Floating %alias "3L___text_to_float" {-}%c // &4 + (%string(255) S, %integer Exp) // &5 %integer Exp, J // &6 %longreal Value // &7 %string(255) S // &8 // &9 %on 1,4 %start // &10 %if Event_Event = 1 %start // &11 Fail("overflow while processing real constant") // &12 %else %if Event_Event=4 // &13 Fail("error in real constant") // &14 %else // &15 Fail("Bad signal") // &16 %finish // &17 %finish // &18 // &19 S = ""; Exp = 0 // &20 // &21 %for J = 1, 1, Tag %cycle {gather the non-exponent part into S} // &22 %if Pending = '@' %start {exponent marker} // &23 Readsymbol(Pending) {skip the '@'} // &24 Exp = Tag {only 16 bits} // &25 Exp = Exp!16_FFFF8000 %if Exp&16_FFFF8000 # 0 // &26 %exit // &27 %finish // &28 S = S.Tostring(Pending) // &29 Readsymbol(Pending) // &30 %repeat // &31 Value = Text to Floating(S, Exp) // &32 %if Pending = 'U' %start {unary minus following} // &33 Value = -Value // &34 Readsymbol(Pending) {skip the 'U'} // &35 %finish // &36 %result = Value // &37 %end // &38 %endoffile // 4311 // 4312 %integerfn Four Bytes // 4313 %integer A,B,C,D // 4314 A = Pending // 4315 Readsymbol(B) // 4316 Readsymbol(C) // 4317 Readsymbol(D) // 4318 Readsymbol(Pending) // 4319 %result = ((A<<8+B)<<8+C)<<8+D // 4320 %end // 4321 // 4322 %routine Input Integer Value(%integer Byte) // 4323 Constant Type = Integers // 4324 %if Byte = 0 %start // 4325 Value_Integer = Four Bytes // 4326 %else // 4327 Value_Integer = Pending; Readsymbol(Pending) // 4328 %finish // 4329 %if Pending = 'U' %start // 4330 Value_Integer = -Value_Integer // 4331 Readsymbol(Pending) // 4332 %else %if Pending = '\' // 4333 Value_Integer = \Value_Integer // 4334 Readsymbol(Pending) // 4335 %finish // 4336 Stack Integer(Value_Integer) %unless Pending = 'A' {%or Pending = '$'} // 4337 %end // 4338 // 4339 %routine Input Real Value // 4340 Constant Type = Reals // 4341 Value_Real = Real Constant // 4342 %if Pending # 'A' %and Pending # '$' %start // 4343 Stack Integer(0) // 4344 %unless Value_Real = 0 %and (Pending = 'S' %or Pending = '?') %start // 4345 {preserve true zero} // 4346 {beware - a C-oid parameter 0.0 MUST retain} // 4347 {its real-ness otherwise the wrong amount} // 4348 {gets stacked} // 4349 Stack_Type = Lreals; Stack_Rval = Value_Real // 4350 Convert Format(Stack, Lreals) // 4351 %finish // 4352 %finish // 4353 %end // 4354 // 4355 %routine Input String Value // 4356 %record(Stackfm)%name W // 4357 Constant Type = Strings // 4358 Get String(Value_String) // 4359 %return %if Pending = '$' %or Pending = 'A' // 4360 %if Length(Value_String) = 1 %start // 4361 Stack Integer(Charno(Value_String, 1)) // 4362 Stack_Bias = -1 // 4363 %else // 4364 W == Const String // 4365 W_Stack == Stack // 4366 Stack == W // 4367 %finish // 4368 %end // 4369 // 4370 {Testing Predicates} // 4371 // 4372 %predicate InReg(%record(Stackfm)%name V) // 4373 %false %if V == Nil %c // 4374+ %or V_Form # Address %c // 4375+ %or V_Disp # 0 %c // 4376+ %or V_Base = 0 %c // 4377+ %or V_Area # 0 %c // 4378+ %or V_Oper # 0 %c // 4379+ %or V_Index ## Nil %c // 4380+ %or V_Record ## Nil // 4381 %true // 4382 %end // 4383 // 4384 %predicate Floating(%record(Stackfm)%name V) // 4385 %true %if Reals <= V_Type <= Lreals %or V_Oper >= RNEGx // 4386 %false // 4387 %end // 4388 // 4389 %predicate Same(%record(Stackfm)%name A, B) // 4390 %true %if A == B // 4391 %false %if A == Nil %or B == Nil // 4392 %false %if A_Disp # B_Disp %or // 4393+ A_Base # B_Base %or // 4394+ A_Type # B_Type %or // 4395+ A_Form # B_Form %or // 4396+ A_Extra # B_Extra %or // 4397+ A_Area # B_Area // 4398 %if A_Index ## Nil %start // 4399 %false %unless B_Index ## Nil %c // 4400+ %and A_Xsize = B_Xsize %c // 4401+ %and Same(A_Index, B_Index) %c // 4402+ %and A_Index_Oper = B_Index_Oper %c // 4403+ %and Same(A_Index_Link, B_Index_Link) // 4404 %else // 4405 %false %if B_Index ## Nil // 4406 %finish // 4407 %if A_Record ## Nil %start // 4408 %false %unless B_Record ## Nil %c // 4409+ %and Same(A_Record, B_Record) %c // 4410+ %and A_Record_Oper = B_Record_Oper %c // 4411+ %and Same(A_Record_Link, B_Record_Link) // 4412 %else // 4413 %false %if B_Record ## Nil // 4414 %finish // 4415 %true // 4416 %end // 4417 // 4418 %predicate Const(%record(Stackfm)%name V) // 4419 %false %if V_Form # Address %or // 4420+ V_Base # 0 %or // 4421+ V_Oper # 0 %or // 4422+ V_Index ## Nil %or // 4423+ V_Record ## Nil %or // 4424+ V_Area # 0 // 4425 %true // 4426 %end // 4427 // 4428 %predicate Iconst(%record(Stackfm)%name V) struct STACKFM * V); auto int ICONSTITEM( // 4429 %false %if V == Nil %c // 4430+ %or V_Form # Address %c // 4431+ %or V_Base # 0 %c // 4432+ %or V_Oper # 0 %c // 4433+ %or V_Index ## Nil %c // 4434+ %or V_Record ## Nil %c // 4435+ %or V_Type > Addrs %c // 4436+ %or V_Area # 0 // 4437 %true // 4438 %end // 4439 // 4440 %predicate Iconst Item(%record(Stackfm)%name V) struct STACKFM * V); auto int CONST( // 4441 {Same as ICONST but ignores the OPER field} struct STACKFM * V); auto int SAME( // 4442 %false %if V == Nil %c struct STACKFM * A, struct STACKFM * B); auto int INREG( // 4443+ %or V_Form # Address %c struct STACKFM * V); auto int FLOATING( // 4444+ %or V_Base # 0 %c struct STACKFM * V); auto int POWER( // 4445+ %or V_Index ## Nil %c // 4446+ %or V_Record ## Nil %c // 4447+ %or V_Type > Addrs %c // 4448+ %or V_Area # 0 // 4449 %true // 4450 %end // 4451 // 4452 %integerfn Power(%integer N) int N); auto int ITEMSIZE( // 4453 %integer P, Mask // 4454 %result = -1 %if N > ( \( (-1)>>1 ) )>>1 {Beware x'4001' etc.} // 4455 Mask = 1 // 4456 P = 0 // 4457 %cycle // 4458 %result = P %if Mask = N // 4459 %result = -1 %if Mask > N // 4460 Mask = Mask<<1 // 4461 P = P+1 // 4462 %repeat // 4463 %end // 4464 // 4465 %integerfn Item Size(%integer F) int F); auto struct STACKFM *REGISTER( // 4466 %result = F %if F >= 0 int REG); auto void CLAIM( // 4467 %result = Var(-F)_Format int REGISTER); auto void RELEASE( // 4468 %end int REGISTER); auto void RELEASEANDDROP( // 4469 struct STACKFM * V); auto void ZAPINDEXANDRECORD( // 4470 %record(Stackfm)%map Claim Work Area(%integer Bytes, Type) struct STACKFM * V); auto void RELEASEANDDROPPAIR( // 4471 %record(Stackfm)%name T struct STACKFM * A, struct STACKFM * B); auto void HAZARD( // 4472 %record(Workfm)%name W, Best == NIL int REG); auto void PESSIMISE( // 4473 %integer P struct STACKFM * V); auto void FORGET( // 4474 Fail("claim work area/1") %if Bytes <= 0 int REGISTER); auto void FORGETDESTINATION( // 4475 P = Work Base struct STACKFM * V); auto void FORGETEVERYTHING(void); auto void REMEMBER( // 4476 %cycle int REGISTER, struct STACKFM *V); auto void REMEMBERZERO( // 4477 %if P = Last Work %start {no suitable one available} int REGISTER); auto void OPTIMISE( // 4478 %if Best == NIL %start struct STACKFM * V, int SWANTED); auto void SIMPLIFY( // 4479 Last Work = Last Work+1; Best == Work Area(Last Work) struct STACKFM * V); auto void AMAP( // 4480 Frame = (Frame-Bytes)&(\3) struct STACKFM * V); auto void VMAP( // 4481 Best_Size = Bytes; Best_Displacement = Frame struct STACKFM * V, int NEWTYPE); auto void MAKEAUTOI( // 4482 %finish struct STACKFM * V, int TYPE); auto void ADVANCE( // 4483 W == Best struct STACKFM * V, int TYPE, int BY); auto void LOAD( // 4484 %exit struct STACKFM * V, int R); auto void LOADUP( // 4485 %finish struct STACKFM * FROM); auto void LOADADDRESS( // 4486 P = P+1; W == Work Area(P) struct STACKFM * V, int R); auto void LOADUPADDRESS( // 4487 Monitor N(P, "try work") %if Diag&MonStack # 0 struct STACKFM * V); auto void LOADPAIR( // 4488 %if W_Validity < Work Validity %and W_Size >= Bytes %start struct STACKFM * A, int AR, struct STACKFM *B, int BR); auto void LOADTRIO( // 4489 %exit %if W_Size = Bytes struct STACKFM * A, int AR, struct STACKFM *B, int BR, struct STACKFM *C, int CR); auto void POPSTACK( // 4490 Best == W %if Best == NIL %or Best_Size > W_Size int BYTES); auto void LOADPROTECTED( // 4491 %finish struct STACKFM * V); auto void MOVE( // 4492 %repeat struct STACKFM * FROM, struct STACKFM * TO); auto void MOVELITERAL( // 4493 W_Validity = Work Validity {prevent its re-use} int VALUE, struct STACKFM *TO); auto void STORE( // 4494 Monitor N(W_Displacement, "temporary") %if Diag&MonStack # 0 struct STACKFM * R, struct STACKFM * L); auto void STOREADDRESS( // 4495 T == Literal(W_Displacement) struct STACKFM * R, struct STACKFM * L, int *EXTRA); auto void OPERATE( // 4496 T_Base = Local; T_Type = Type; T_Form = Direct; T_Format = Bytes int NEWOPER, struct STACKFM *LHS, struct STACKFM *RHS); auto void COMPARE( // 4497 %result == T struct STACKFM * LEFT, struct STACKFM * RIGHT); auto int NEWLABEL(void); auto void JUMPTO( // 4498 %end int INTERNALLABEL, int CONDCODE); auto void DEFINELABEL( // 4499 int INTERNALLABEL); auto void TESTZERO( // 4500 %routine Constant Bounds struct STACKFM * V); auto void TESTRANGE( // 4501 Vub = Popped Value // 4502 Vlb = Popped Value // 4503 %end // 4504 // 4505 %routine Set CD(%integer Value, %integername CD) // 4506 CD = Value&x'3FFF' %if Value&x'C000' = 2<<14 // 4507 %end // 4508 // 4509 %Predicate Alternate format(%integer Code) // 4510 %integer Attr = 0 // 4511 %record(Varfm) Dummy // 4512 %if Code = 'A' %start {Start of alternatives} // 4513 Assemble(Dummy, -2, Vars, Local, -1, Attr) // 4514 Alt Align = Alt Align&Falign // 4515 %else %if Code = 'C' {Next alternative} // 4516 Max Frame = Frame %if Frame > Max Frame // 4517 Frame = Frame Base // 4518 %else %if Code = 'B' {End of alternatives} // 4519 Frame = Max Frame %if Max Frame > Frame // 4520 Falign = Alt Align // 4521 %true // 4522 %else // 4523 Fail("Format ".ItoS(Code, 0)) // 4524 %finish // 4525 %false // 4526 %end // 4527 // 4528 %routine Compile Begin // 4529 %integer Main Ep = 0 // 4530 %record(Varfm) B // 4531 B = 0 {Dummy heading} // 4532 B_Type = Generals // 4533 B_Disp = New Label // 4534 B_Base = None {show an internal routine} // 4535 %if Local # Base Local %start {internal} // 4536 Stack Integer(B_Disp) // 4537 Stack_Flags = Stack_Flags!Nasty Proc %if Local >= Danger Level // 4538 Call(0) // 4539 Ostate = 0 // 4540 %else // 4541 Ostate = External // 4542 External Id = "3L___main_program" // 4543 Entry Point = External No+1 // 4544 Main Ep = 1 // 4545 %finish // 4546 Internal Id = "block" // 4547 Internal Id = Alias %and Alias = "" %if Alias # "" // 4548 Assemble(B, 0, Vars, Local+1, 0, Attributes) // 4549 %end // 4550 // 4551 %routine Clear Vars(%integer Limit) // 4552 Fail("Too many objects") %if Limit >= Parms // 4553 %while Vars < Limit %cycle // 4554 Vars = Vars+1 // 4555 Var(Vars) = 0 // 4556 %repeat // 4557 %end // 4558 // 4559 {Var control} // 4560 // 4561 %routine DIR String(%integer Op, %string(*)%name S) // 4562 %integer L = Length(S), J // 4563 Dir1(Op) %if Op >= 0 // 4564 Dir1(L) // 4565 Dir1(Charno(S, J)) %for J = 1, 1, L // 4566 %end // 4567 // 4568 %routine Dump External(%integer Code, %record(Varfm)%name V) // 4569 External No = External No+1 // 4570 %if Code&1 = 0 %start {spec} // 4571 %if V_Form = Proc %then V_Area = Dir Xcall %and V_Disp = External No %c // 4572+ %else V_Area = -External No %and V_Disp = 0 // 4573 %finish // 4574 Code = Code!4 %if Code&2 # 0 %and V_Flags&Prim Proc # 0 {not Prim proc} // 4575 DIR String(Dir Ext, External Id) // 4576 Dir2(Code, V_Disp) // 4577 %end // 4578 // 4579 %routine Plant Diag(%record(Diagfm)%name D) // 4580 %integer Disp, Type, Ind, Base, BType, PType // 4581 %record(Afm)%name Dv // 4582 %return %if D_X&64 # 0 %and D_Format&16_FFFF = 0 // 4583 Disp = D_Var_Disp // 4584 Disp = D_Ext %if D_Ext # 0 {external data} // 4585 Type = (D_X>>2)&15 // 4586 %if Interface_Options&LL Vars # 0 %and Type # 14 %start // 4587 Dir String(Dir Diag, D_Id) // 4588 Dump Encoded(D_X) // 4589 Dump Encoded(D_Xtype) // 4590 Dump Encoded(D_Var_Disp) // 4591 Dump Encoded(D_Format&16_FFFF) %if D_X&64 # 0 {records} // 4592 %finish // 4593 %if DEBUG # 0 %start // 4594 Base = D_X&3 // 4595 Ind = D_X>>7 // 4596 Btype = D_XType&15 // 4597 PType = (D_XType>>4)&15 // 4598 %if Type = 14 %start {Array} // 4599 Dir String(Dir DEBUG Array, D_Id) // 4600 Dv == D_Var_Adata // 4601 Dump Encoded(Dv_Bound(1)_Lower) // 4602 Dump Encoded(Dv_Bound(1)_Upper) // 4603 Dump Encoded(Dv_Total Size) // 4604 Dump Encoded(Btype) {base (element) type} // 4605 Dump Encoded(D_Format&16_FFFF) {Pointer to format} // 4606 %else // 4607 %return %if Base # 1 %and Base # 2 // 4608 Dir String(Dir DEBUG Var, D_Id) {Variable identifier} // 4609 Dump Encoded(Type) {Primary type} // 4610 Dump Encoded(Ind) {Indirect bit - VAR} // 4611 Dump Encoded(Base) {Addressing base} // 4612 Dump Encoded(Btype) {Base type of pointer} // 4613 Dump Encoded(PType) {Type pointed at} // 4614 Dump Encoded(D_Var_Disp) {Displacement from base} // 4615 Dump Encoded(D_Format&16_FFFF) {Pointer to format} // 4616 Dump Encoded(Item Size(D_Var_Format)) {object size} // 4617 %finish // 4618 %finish // 4619 %end // 4620 // 4621 %routine Dump Diag(%integer Base, %record(Qfm)%name Q) // 4622 %record(Diagfm) D // 4623 %record(Diagfm)%name ND // 4624 %return %if Compiling Prim # 0 // 4625 D_Link == Diag List {here to prevent UNASS from VAX} // 4626 D_Id = Internal Id // 4627 D_Xtype = 0 // 4628 D_Ext = 0 // 4629 %if Base = Any %start // 4630 %return %if Parameter List = 0 // 4631 Base = 0 // 4632 D_Xtype = (Q_Dtype>>2)&15 // 4633 Q_Dtype = 14<<2 // 4634 %else %if Base = Local // 4635 Base = 1 // 4636 %else %if Base = SB // 4637 Base = 2 // 4638 %else %if Base < 0 // 4639 D_Ext = -Base; Base = 3 // 4640 %else // 4641 Base = 0 // 4642 %finish // 4643 %if Q == Nil %start // 4644 D_X = 0 // 4645 D_Format = 0 // 4646 %else // 4647 D_Format = Q_Dform // 4648 %if Q_Pointed ## Nil %start // 4649 D_Xtype = Q_Dtype>>2 ! (Q_Pointed_Dtype>>2&15)<<4 // 4650 Q_Dtype = Q_Dtype ! 15<<2 ! Q_Pointed_Dtype&64 {escape} // 4651 D_Format = Q_Pointed_Dform // 4652 %finish // 4653 D_X = Q_Ind<<7 ! Q_Dtype ! Base // 4654 %finish // 4655 D_Var == DefV // 4656 %return %if D_Format = 0 %and D_X&64 # 0 {record(*)name} // 4657 %if Parameter List = 0 %start {not in record or parameters} // 4658 Plant Diag(D) // 4659 %else // 4660 ND == NEW(Diagfm Type) // 4661 SYY: ND = D // 4662 Diag List == ND {_Link set up above} // 4663 %finish // 4664 %end // ?SYY unused // 4665 // 4666 %routine Flush Diags // 4667 %routine Flush(%record(Diagfm)%name D) // 4668 %return %if D == NIL // 4669 Flush(D_Link) // 4670 Plant Diag(D) // 4671 Dispose(D) // 4672 %end // 4673 {The list is currently backwards - reverse it to preserve order} // 4674 Flush(Diag List) // 4675 Diag List == NIL // 4676 %end // 4677 // 4678 %routine Define Var // 4679 %integer Decl, Tf, NewV, Area, External Mode // 4680 %integername At // 4681 %integer Spec, Oflags, N, // 4682+ Type, {external item type} // 4683+ Form, {external item form} // 4684+ Format {external item size or format} // 4685 // 4686 %record(Varfm)%name Fv // 4687 %record(Qfm) Q, Pq // 4688 %record(Stackfm)%name Vv // 4689 // 4690 %constbytearray Form Map(0:15) = 0, {Unknown} // 4691+ Direct, {integer} // 4692+ Indirect, {integername} // 4693+ 0(4), {label/format/?/switch} // 4694+ Proc(4), {rt/fn/map/pred} // 4695+ Direct, {array} // 4696+ Direct, {arrayname} // 4697+ Direct, {namearray} // 4698+ Direct, {namearrayname} // 4699+ 0 // 4700 // 4701 %routine Encode Type(%integer Type, Format, %record(Qfm)%name Q) // 4702 %switch T(-3:10) // 4703 %constshortarray DiagMap(-3:10) = // 4704+ 5<<2 {-3}, 3<<2 {-2}, 2<<2 {-1}, // 4705+ 0 {0}, // 4706+ 1<<2 {1}, 4<<2 {2}, 6<<2 {3}, 7<<2!64 {4}, // 4707+ 8<<2 {5}, 13<<2 {6}, 10<<2!64 {7}, 11<<2!64 {8}, // 4708+ 12<<2 {9}, 9<<2 {10} // 4709 %constbytearray TypeMap(-3:10) = // 4710+ Lreals {-3}, Bytes {-2}, Shorts {-1}, // 4711+ Generals {0}, // 4712+ Integers {1}, Reals {2}, Strings {3}, Records {4}, // 4713+ Bytes {5}, Sets {6}, Bytes {7}, Shorts {8}, // 4714+ Integers {9}, Bytes {10} // 4715 %constbytearray SizeMap(-3:10) = // 4716+ WordLength*2 {-3}, 1 {-2}, 2 {-1}, // 4717+ WordLength*3 {0}, // 4718+ WordLength {1}, WordLength*1 {2}, 0 {3}, 0 {4}, // 4719+ 1 {5}, Set Size {6}, 1 {7}, 2 {8}, // 4720+ WordLength {9}, 1 {10} // 4721 %constbytearray AlgnMap(-3:10) = // 4722+ 3 {-3}, 0 {-2}, 1 {-1}, // 4723+ 3 {0}, // 4724+ 3 {1}, 3 {2}, 0 {3}, 0 {4}, // 4725+ 0 {5}, 3 {6}, 0 {7}, 1 {8}, // 4726+ 3 {9}, 0 {10} // 4727 // 4728 %if Type = 1 %start {split integers} // 4729 %if Format = 2 %then Type = -2 {bytes} %else %c // 4730+ %if Format = 3 %then Type = -1 {short} // 4731 %else %if Type = 2 {split reals} // 4732 %if Format = 4 %then Type = -3 {longreal} // 4733 %finish // 4734 // 4735 Fail("Unknown type") %unless -3 <= Type <= 10 // 4736 // 4737 Q_Type = TypeMap(Type) // 4738 Q_Size = SizeMap(Type); DefV_Format = Q_Size // 4739 Q_Round = AlgnMap(Type) // 4740 Q_Bias = 0 // 4741 Q_Dtype = DiagMap(Type) // 4742 Q_Dform = 0 // 4743 Q_Format = Format // 4744 Q_Diags = 1 {assume diags are sensible} // 4745 Q_Ind = 0 {assume not indirect} // 4746 Q_Pointed == Nil // 4747 // 4748 ->T(Type) // 4749 // 4750 T(0): {general} Q_Diags = 0; %return // 4751 // 4752 T(-3):{long} // 4753 T(1): {integer} // 4754 T(2): {real} // 4755 T(5): {boolean} DefV_Flags = DefV_Flags ! Checkable // 4756 T(-1):{short} // 4757 T(-2):{byte} // 4758 T(10):{char} %return // 4759 // 4760 T(3): {string} Q_Size = Format+1 // 4761 DefV_Format = Q_Size // 4762 %return // 4763 // 4764 T(4): {record} Fv == Var(Format) // 4765 %if Format > Vars %start // 4766 Clear Vars(Format) // 4767 Interface_Formats = Interface_Formats+1 // 4768 Fv_Area = Interface_Formats // 4769 %else // 4770 Q_Size = Fv_Format // 4771 %finish // 4772 DefV_Format = -Format // 4773 Q_Round = Fv_Disp {alignment required} // 4774 Q_Dform = Fv_Area {diagnostic index} // 4775 // 4776 T(7): {byte enumerated} Q_Dform = Var(Format)_Area; %return // 4777 // 4778 T(8): {short enumerated} Q_Dform = Var(Format)_Area; %return // 4779 // 4780 T(9): {pointer} DefV_Flags = DefV_Flags ! Checkable // 4781 T(6): {set} %if Q ## Pq %start // 4782 Encode Type(Q_Dim, Format, Pq) // 4783 DefV_Format = SizeMap(Type) {restore it} // 4784 Q_Pointed == Pq // 4785 %else // 4786 Q_Diags = 0 // 4787 %finish // 4788 %if Type = 6 {sets} %start // 4789 {beware of a checkable base type} // 4790 DefV_Flags = DefV_Flags & (\Checkable) // 4791 %finish // 4792 %return // 4793 // 4794 %end {of encode type} // 4795 // 4796 NewV = 1 // 4797 Decl = Tag // 4798 %if Decl # 0 %start {normal item} // 4799 NewV = 0 %if Decl <= Vars // 4800 DefV == Var(Decl); Clear Vars(Decl) // 4801 %else {format item} // 4802 Parms = Parms-1 // 4803 DefV == Var(Parms); DefV = 0 // 4804 %finish // 4805 Fail("Too many objects") %if Parms <= Vars // 4806 // 4807 Internal Id = "" // 4808 %while Pending # ',' %cycle // 4809 %if Length(Internal Id) # 127 %start // 4810 Internal Id = Internal Id.Tostring(Pending) // 4811 %finish // 4812 Readsymbol(Pending) // 4813 %repeat // 4814 Readsymbol(Pending) // 4815 // 4816 Tf = Tag // 4817 Format = Tag // 4818 Ostate = Tag // 4819 // 4820 Q_Dim = Ostate>>8 // 4821 Spec = Ostate&8 // 4822 Oflags = Ostate&16_F0 // 4823 Ostate = Ostate&7; Ostate = External %if Ostate = Dynamic // 4824 Type = Tf>>4&15 // 4825 Form = Tf&15 // 4826 // 4827 %if Alias # "" %start // 4828 Ostate = External %if Ostate = System // 4829 External Id = Alias; Alias = "" // 4830 %else %if Ostate = System // 4831 Ostate = External // 4832 External Id = "$".Internal Id // 4833 %else // 4834 External Id = Internal Id // 4835 %finish // 4836 External Mode = Ostate // 4837 // 4838 %if Form = 0 %and Decl = 0 %start {special for enumerated types} // 4839 Parms = Parms+1 // 4840 Dump Diag(0, Nil) // 4841 %return // 4842 %finish // 4843 // 4844 Encode Type(Type, Format, Q); Q_Diags = 0 %if Internal Id = "" // 4845 // 4846 DefV_Type = Q_Type // 4847 %if Oflags&16 # 0 %start {indirect} // 4848 DefV_Type = Integers; DefV_Format = 4 // 4849 Q_Ind = 1; Q_Size = 4; Q_Round = Alignment; Q_Bias = 0 // 4850 Form = 1 // 4851 %finish // 4852 Q_Bias = 0 %if Form # 1 // 4853 DefV_Flags = DefV_Flags!Checkable %if Oflags&32 # 0 // 4854 Decl Size = Q_Size // 4855 DefV_Form = Form Map(Form) // 4856 // 4857 %if Form = 4 %start {recordformat} // 4858 DefV_Extra = Parms // 4859 Parameter Mode = -1; Block Type = -1 // 4860 %if DefV_Area = 0 %start // 4861 Interface_Formats = Interface_Formats+1 // 4862 DefV_Area = Interface_Formats {diagnostic index} // 4863 %finish // 4864 %return // 4865 %else %if Form = 3 {label} // 4866 Set User Label(Decl) // 4867 %if Language Flags&Pascal Flag # 0 %start // 4868 Save Wsp %if Wsp Save = 0 // 4869 DefV_Extra = Wsp Save // 4870 %finish // 4871 %else %if Form = 6 {switch} // 4872 DefV_Area = Free Label-Vlb+1 {zero'th tag} // 4873 DefV_Disp = Vlb {lower bound} // 4874 DefV_Extra = Vub {upper bound} // 4875 N = Free Label+1 // 4876 Free Label = N+Vub-Vlb // 4877 Constant Base = (Constant Base+3)&(\3) {align it} // 4878 Select Constant Area // 4879 DefV_Format = Ca {address of vector} // 4880 Dump Word(Vub) {upper} // 4881 Dump Word(Vlb) {lower} // 4882 Dir3(Dir Swdef, N, Free Label) // 4883 Constant Base = Constant Base+4*(Vub-Vlb+1) // 4884 Select Code Area // 4885 %else %if 7 <= Form <= 10 {rt, fn, map, pred} // 4886 Parameter Mode = 1 // 4887 Block Type = Spec {0=def, 8=spec} // 4888 %if 8 <= Form <= 9 %start {fn/map} // 4889 DefV_Flags = DefV_Flags!Answer // 4890 %if Form = 9 %start {map} // 4891 DefV_Flags = DefV_Flags!Defered // 4892 %else %if DefV_Type <= Addrs {integral function} // 4893 DefV_Type = Integers {all results integers} // 4894 %finish // 4895 %else %if Form = 10 {predicate} // 4896 DefV_Flags = DefV_Flags!Pred Call // 4897 %finish // 4898 %if External Mode = OWN %start // 4899 External Mode = External // 4900 Ostate = External // 4901 DefV_Flags = DefV_Flags ! Keep Local // 4902 %else %if External Mode >= Primrt // 4903 %if External Mode = PrimRt %start // 4904 Defv_Flags = Defv_Flags!Primitive // 4905 Defv_Prim = Q_Dim // 4906 %else // 4907 Defv_Flags = DefV_Flags!Prim Proc // 4908 %finish // 4909 External Mode = External // 4910 Ostate = External // 4911 %finish // 4912 %if Parameter List > 0 %start {proc variable} // 4913 {beware - a spec will follow} // 4914 {which must not corrupt flags} // 4915 Danger Marker = 1 // 4916 Frame = (Frame+3)&(\3) {keep word aligned} // 4917 DefV_Disp = Frame // 4918 DefV_Base = Local // 4919 DefV_Flags = DefV_Flags!Parameter // 4920 Frame = Frame + Word Length*2 // 4921 %else %if Local >= Danger Level // 4922 DefV_Flags = DefV_Flags!Nasty Proc // 4923 %finish // 4924 %else // 4925 %if Form = 11 %or Form = 13 %start {array or namearray} // 4926 Q_Diags = 0 // 4927 %if Form = 13 %start {namearray} // 4928 Decl Size = Word Length // 4929 Decl Size = Word Length*2 %if Q_Type = Strings %c // 4930+ %and Q_Size = 1 {string(*)%namearray} // 4931 DefV_Flags = Defered // 4932 Q_Round = Alignment // 4933 %finish // 4934 Q_Size = 0 {no space allocated here} // 4935 %else %if Form = 2 {%name} // 4936 Q_Ind = 1 // 4937 Q_Round = Alignment // 4938 %if Q_Type # Generals %start // 4939 Decl Size = Word Length // 4940 Decl Size = Word Length*2 %if Q_Type = Strings %c // 4941+ %and Q_Size = 1 {string(*)name} // 4942 Q_Size = Decl Size // 4943 %finish // 4944 %else %if Form = 1 {simple variable} // 4945 %if Parameter List > 0 %and (Q_Type = Strings %c // 4946+ %or Q_Type = Records %c // 4947+ %or Q_Type = Sets) %start // 4948 Q_Size = Word Length // 4949 DefV_Flags = DefV_Flags!Awanted %if Oflags&16 = 0 // 4950 %finish // 4951 %else {arrayname or namearrayname} // 4952 Q_Diags = 0 // 4953 Q_Round = Alignment // 4954 Q_Size = Word Length*2 // 4955 DefV_Flags = Defered %if Form = 14 {namearrayname} // 4956 DefV_Flags = DefV_Flags!Arrayname // 4957 %finish // 4958 %if External Mode = 0 %start {automatic} // 4959 DefV_Base = Local // 4960 %if Decl = 0 %start {record} // 4961 Frame = (Frame+Q_Round)&(\Q_Round) // 4962 Defv_Disp = Frame; Frame = Frame+Q_Size // 4963 %else %if Parameter List > 0 {parameters} // 4964 Q_Round = 3 %if Q_Round < 3 // 4965 Q_Size = 4 %if Q_Size < 4 // 4966 Frame = (Frame+3)&(\3) {keep parameters word aligned} // 4967 DefV_Disp = Frame // 4968 Frame = Frame+Q_Size // 4969 %else // 4970 %if Q_Size > 256 %start {allocate dynamically} // 4971 Q_Ind = 1 // 4972 Frame = Frame&(\3)-4 {1 word slot} // 4973 DefV_Disp = Frame; DefV_Form = Indirect // 4974 DefV_Flags = DefV_Flags&(\Checkable) // 4975 N = (Q_Size+3)&(\3) {round up size} // 4976 Attributes = Attributes!Attr Sp Unknown // 4977 %if Unassigned # 0 %start {set it unassigned} // 4978 Attributes = Attributes!Attr Needs Gp // 4979 Vv == Literal(N) // 4980 Load(Vv, R4) // 4981 Release and Drop(Vv) // 4982 Prim(Dalloc) {alters SP} // 4983 %else // 4984 Vv == Local Integer(-N) // 4985 Vv_Base = Sp; Vv_Form = Address // 4986 Load(Vv, Sp) {adjust Sp} // 4987 Drop(Vv) // 4988 %finish // 4989 Vv == Local Integer(Frame) // 4990 Plant2(STR, Sp, Vv) {initialise pointer} // 4991 Release and Drop(Vv) // 4992 // 4993 %if wsp save # 0 %start {done it, => wrong} // 4994 save wsp {do it again} // 4995 %finish {quick hack} // 4996 // 4997 %else // 4998 Frame = Frame&(\Q_Round)-Q_Size // 4999 DefV_Disp = Frame // 5000 %finish // 5001 %finish // 5002 DefV_Flags = DefV_Flags!Known Ass %if Tf&256 # 0 // 5003 Dump Diag(Local, Q) %if Q_Diags#0 %and Amode <= 0 // 5004 %else {own/external} // 5005 Ownextra = 0 // 5006 %if Spec = 0 %start {definition} // 5007 Init Flag = 0 // 5008 OwnType = Q_Type; OwnForm = Form // 5009 %if External Mode = Con %start {const something} // 5010 %if Form = 2 {constname} %c // 5011+ %or Form = 12 {constarrayname} %c // 5012+ %or Form = 14 {constnamearrayname} %start // 5013 DefV_Form = Direct // 5014 Init Flag = -1 // 5015 %return // 5016 %finish // 5017 Constant Base = (Constant Base+3)&(\3) {align it} // 5018 Area = Constant Area; At == Constant Base // 5019 DefV_Area = Constant Area // 5020 Q_Diags = 0 // 5021 %else {ownish} // 5022 Area = Own Area; At == Own Base; DefV_Base = Sb // 5023 %if Form = 11 %or Form = 13 %start {array or namearray} // 5024 Own Array Base = (Own Array Base+3)&(\3) // 5025 Area = Own Array Area; At == Own Array Base // 5026 Ostate = 255 {flag for INIT} // 5027 %finish // 5028 %finish // 5029 Ownextra = 1 %if Ownform = 12 %or Ownform = 14 {..arrayname} // 5030 Ownextra = 1 %if Owntype = Strings %c // 5031+ %and DefV_Format = 1 %c // 5032+ %and (Ownform = 2 %or Ownform = 13) // 5033 {string(*) name & namearray} // 5034 OwnType = Integers %and Q_Round = 3 %if OwnForm # 1 %c // 5035+ %and OwnForm # 11 // 5036 At = (At+Q_Round)&(\Q_Round) // 5037 DefV_Disp = At // 5038 %if Form = 11 %or Form = 13 %start {array or namearray} // 5039 DefV_Flags = DefV_Flags!Arrayname // 5040 N = DefV_Disp-Vlb*Decl Size {back to A(0)} // 5041 Own Base = (Own Base+3)&(\3) // 5042 DefV_Base = SB; DefV_Disp = Own Base; DefV_Area = 0 // 5043 Select Own Area // 5044 Dir4(Dir Header, Area>>8, N, 0); Ca = Ca+8 // 5045 Select Code Area // 5046 Value = Default Value // 5047 Init Flag = 1 // 5048 {dummy dope-vector} // 5049 DefV_Adata == New(A Type) // 5050 SYY: DefV_Adata = 0 // 5051 %finish // 5052 %if External Mode = External %start // 5053 Dump External(2_01, DefV) // 5054 DefV_Area = 0 {beware prior %spec} // 5055 DefV_Flags = DefV_Flags&(\XData Spec) { " " " } // 5056 %finish // 5057 Dump Diag(DefV_Base, Q) %if Q_Diags # 0 // 5058 %else {external data spec} // 5059 DefV_Flags = DefV_Flags ! XData Spec // 5060 DefV_Flags = DefV_Flags!Arrayname %if Form = 11 %or Form = 13 // 5061 Dump External(2_00, DefV) // 5062 %finish // 5063 %finish // 5064 %finish // 5065 Alt Align = Alt Align&(\Q_Round) {remember worst alignment} // 5066 Round = Q_Round // 5067 Dtype = Q_Dtype {remember for arrays (dimension)} // 5068 %end // ?SYY unused // 5069 // 5070 %routine Dump Text(%integer Max) // 5071 %integer J, Len // 5072 Len = Length(Value_String) // 5073 %if Max = 0 %start {no upper limit} // 5074 Max = Len {use the actual length} // 5075 %else {check the length} // 5076 Len = Max %and Warn(0, "String truncated") %if Len > Max // 5077 %finish // 5078 Dump Byte(Len) // 5079 %for J = 1, 1, Max %cycle // 5080 %if J > Len %then Dump Byte(0) %c // 5081+ %else Dump Byte(Charno(Value_String, J)) // 5082 %repeat // 5083 %end // 5084 // 5085 %routine Adump // 5086 %record(Stackfm) Rv // 5087 %integer J, Disp, Key // 5088 %if OwnType = Integers %or OwnType = Addrs %start // 5089 %if Stack == Nil %start {the easy case} // 5090 Dump Word(Value_Integer) // 5091 %else // 5092 %if Stack_Record ## NIL %start // 5093 Fail("Adump/0") // 5094 %else // 5095 Simplify(Stack) // 5096 Disp = Stack_Disp // 5097 Fail("Adump/1") %unless Stack_Record== Nil %and Stack_Index == Nil // 5098 %if Stack_Form = Address %start // 5099 %if Stack_Base = SB %start // 5100 Key = 0 // 5101 %else %if Stack_Base = None // 5102 %if Stack_Area = Constant Area %start // 5103 Key = -1 // 5104 %else // 5105 Key = -Stack_Area // 5106 Fail("Adump/4") %if Key <= 0 // 5107 %finish // 5108 %finish %else Fail("Adump/2") // 5109 Dir3(Dir Init, Key, Disp) // 5110 %finish %else Fail("Adump/3") // 5111 %finish // 5112 Ca = Ca+4 // 5113 Pop Release and Drop // 5114 %finish // 5115 %else %if Owntype = Bytes %or Owntype = Booleans // 5116 Warn(0, "value truncated to 8 bits unsigned") %unless 0 <= Value_Integer <= 255 // 5117 Dump Byte(Value_Integer) // 5118 %else %if OwnType = Shorts // 5119 Warn(0, "value truncated to 16 bits signed") %unless 16_FFFF 8000 <= Value_Integer <= 16_0000 7FFF // 5120 Dump Half(Value_Integer) // 5121 %else %if OwnType = Reals %or OwnType = Lreals // 5122 Rv_Rval = Value_Real; Convert Format(Rv, Owntype) {BEWARE: = 1.3(12) etc} // 5123 Dump Word(Rv_Rhigh) // 5124 Dump Word(Rv_Rlow ) %if Owntype = Lreals // 5125 %else %if OwnType = Strings // 5126 Dump Text(Decl Size-1) // 5127 %else %if OwnType = Records %or Owntype = Sets // 5128 Dump Byte(0) %for J = 1, 1, Decl Size // 5129 %finish %else Fail("Init") // 5130 %while Ownextra > 0 %cycle // 5131 Dump Word(0) // 5132 Ownextra = Ownextra-1 // 5133 %repeat // 5134 %end // 5135 // 5136 %routine Init(%integer N) // 5137 %if Stack ## Nil %and Iconst(Stack) %start // 5138 Value_Integer = Stack_Disp // 5139 Constant Type = Integers // 5140 Pop Release and Drop // 5141 %finish // 5142 %if Reals <= OwnType <= Lreals %start // 5143 Value_Real = Value_Integer %if Constant Type = Integers // 5144 %finish // 5145 %if Init Flag < 0 %start {const?name} // 5146 DefV_Disp = Value_Integer // 5147 %else // 5148 %if Ostate = Con %then Select Constant Area %else %c // 5149+ %if Ostate = 255 %then Select Own Array Area %c // 5150+ %else Select Own Area // 5151 %while N > 0 %cycle // 5152 N = N-1; Adump // 5153 %repeat // 5154 Select Code Area // 5155 %finish // 5156 Value = Default Value {Restore the default values} // 5157 DefV_Flags = DefV_Flags!Known Ass // 5158 %end // 5159 // 5160 %routine Dimension(%integer Dim, N) // 5161 { %integerarray A(1:5) Base+Disp = Header (Direct) !Array!Static X=DV} // 5162 { %integerarray B(1:N) Base+Disp = Header (Direct) !Arrayname } // 5163 { %integerarray _C(1:5) Base+Disp = A(0) (Direct) !Array X=DV} // 5164 { %integerarrayname D Base+Disp = Header (Direct) !Arrayname } // 5165 // 5166 %integer X, Static Array = 0, J // 5167 %record(Varfm)%name V // 5168 %record(Afm) Dope // 5169 %record(Stackfm)%name B, Total, DopeVector, Zero, Header // 5170 %record(Stackfm)%name L1, L2, U1, U2, M1, M2 // 5171 %record(Qfm) Q // 5172 // 5173 %predicate All Const // 5174 %record(Stackfm)%name P // 5175 %record(Boundfm)%name B // 5176 %integer J, N // 5177 P == Stack // 5178 N = Decl Size // 5179 %for J = Dim, -1, 1 %cycle // 5180 B == Dope_Bound(J) // 5181 %false %unless Iconst(P); B_Upper = P_Disp; P == P_Stack // 5182 %false %unless Iconst(P); B_Lower = P_Disp; P == P_Stack // 5183 B_Mult = N // 5184 N = B_Upper-B_Lower+1 // 5185 Fail("Array inside-out") %if N < 0 // 5186 %repeat // 5187 Dope_Total Size = N {remember final bound} // 5188 // 5189 {A constant dope-vector} // 5190 // 5191 Dope_Base = Local // 5192 Dope_Dimension = Dim // 5193 Dope_Zero Displacement = 0 // 5194 N = 0 // 5195 %for J = 1, 1, Dim %cycle // 5196 B == Dope_Bound(J) // 5197 Dope_Zero Displacement = Dope_Zero Displacement*N-B_Lower // 5198 N = B_Mult // 5199 Dope_Total Size = Dope_Total Size*N // 5200 %repeat // 5201 Dope_Zero Displacement = Dope_Zero Displacement*N // 5202 Pop Release and Drop %for J = 1, 1, Dim*2 // 5203 Static Array = 1 // 5204 Constant Base = (Constant Base+Alignment)&Alignment Mask // 5205 Dope_Dv = Constant Base // 5206 %if Parameter List = 0 %start // 5207 Dope_Total Size = (Dope_Total Size+3)&(\3) {word align it} // 5208 %finish // 5209 Select Constant Area // 5210 Dump Word(Dim) // 5211 Dump Word(Dope_Total Size) // 5212 Dump Word(Dope_Zero Displacement) // 5213 %for J = 1, 1, Dim %cycle // 5214 B == Dope_Bound(J) // 5215 Dump Word(B_Lower) // 5216 Dump Word(B_Upper) // 5217 Dump Word(B_Mult) // 5218 %repeat // 5219 Select Code Area // 5220 %true // 5221 %end // 5222 // 5223 Attributes = Attributes ! Attr Sp Unknown // 5224 // 5225 {Create dope-vector} // 5226 // 5227 %if All Const %start {constant dope-vector} // 5228 %return %if N = 0 {own dope vector} // 5229 %if Parameter List # 0 %start {in format} // 5230 X = Parms+N // 5231 Frame = (Frame+Round)&(\Round) // 5232 %while N > 0 %cycle // 5233 N = N-1 // 5234 X = X-1; V == Var(X) // 5235 V_Disp = Frame+Dope_Zero Displacement // 5236 Frame = Frame+Dope_Total Size // 5237 V_Form = Direct // 5238 V_Flags = V_Flags!Array // 5239 V_Adata == New(A Type) // 5240 SYY: V_Adata = Dope // 5241 %if Debug # 0 %start // 5242 Q_Dform = 0 // 5243 Q_Dform = Var(-V_Format)_Area %if V_Format < 0 // 5244 Q_Pointed == NIL // 5245 Q_Ind = 0 // 5246 Q_Dtype = Dtype // 5247 DefV == V // 5248 Dump Diag(Any, Q) // 5249 %finish // 5250 %repeat // 5251 %return // 5252 %finish // 5253 Zero == Nil // 5254 Zero == Literal(Dope_Zero Displacement) %c // 5255+ %if Dope_Zero Displacement # 0 // 5256 Total == Literal(Dope_Total Size) // 5257 DopeVector == Literal(Dope_Dv) // 5258 DopeVector_Form = Address; DopeVector_Area = Constant Area // 5259 Load(DopeVector, R3) // 5260 Load(Zero, R2) %unless Zero == Nil // 5261 Load(Total, R1) // 5262 %else {dynamic dope-vector} // 5263 %if Dim = 1 %start {special case fir 1 dimension} // 5264 U1 == Stack; Stack == U1_Stack {upper bound} // 5265 L1 == Stack; Stack == L1_Stack {lower bound} // 5266 M1 == Literal(Decl Size) // 5267 Load Trio(U1, R4, L1, R3, M1, R5) // 5268 Release and Drop Pair(L1, U1); Release and Drop(M1) // 5269 Prim(Dynamic 1) // 5270 %else %if Dim = 2 {special case for 2 dimensions} // 5271 U2 == Stack; Stack == U2_Stack {upper bound} // 5272 L2 == Stack; Stack == L2_Stack {lower bound} // 5273 M2 == Literal(Decl Size) // 5274 U1 == Stack; Stack == U1_Stack {upper bound} // 5275 L1 == Stack; Stack == L1_Stack {lower bound} // 5276 Load Pair(U1, R4, L1, R3) // 5277 Load Trio(U2, R7, L2, R6, M2, R8) // 5278 Load Pair(U1, R4, L1, R3) // 5279 Load Trio(U2, R7, L2, R6, M2, R8) // 5280 Release and Drop Pair(L1, U1) // 5281 Release and Drop Pair(L2, U2); Release and Drop(M2) // 5282 Prim(Dynamic 2) // 5283 %else // 5284 X = Decl Size // 5285 %for J = 1,1,Dim %cycle // 5286 Push Literal(X); X = 0 // 5287 B == Stack; Stack == B_Stack; Push(B); Release and Drop(B) // 5288 B == Stack; Stack == B_Stack; Push(B); Release and Drop(B) // 5289 %repeat // 5290 Push Literal(0) // 5291 Push Literal(0) // 5292 Push Literal(Dim) // 5293 Prim(Dynamic N) // 5294 {returns with: R1 = Total size (rounded)} // 5295 { R2 = Zero Displacement} // 5296 { R3 = Dope Vector address} // 5297 %finish // 5298 Total == Register(R1) // 5299 Zero == Register(R2) // 5300 DopeVector == Register(R3) // 5301 %finish // 5302 // 5303 {create the arrays} // 5304 {a head looks like:
} // 5305 { ^ ^ } // 5306 { V_Disp V_Disp+4 } // 5307 // 5308 Frame = Frame & (\3) // 5309 Header == Local Integer(Frame-Wordlength) // 5310 Load Address(Header, R4) {end of headers} // 5311 // 5312 X = Vars-N // 5313 %while N > 0 %cycle // 5314 N = N-1 // 5315 X = X+1; V == Var(X) // 5316 Frame = Frame-2*Wordlength // 5317 V_Disp = Frame {address of header} // 5318 V_Flags = V_Flags!Known Ass!ArrayName // 5319 V_Form = Direct // 5320 Plant1(SUB, Sp, Sp, Just(R1)) {claim space} // 5321 {This can be improved by using R4 or Sp for the zero'th address} // 5322 {but it needs dope-vectors to be the other way round?} // 5323 %if Zero == NIL %start // 5324 Plant1(MOV, 0, R0, Just(Sp)) // 5325 %else // 5326 Plant1(ADD, Sp, R0, Just(R2)) // 5327 %finish // 5328 Plant4(STM ! Write Back, R4, 16_0009) {STM_, R0 = zero'th} // 5329 %repeat // 5330 Release and Drop(Total) // 5331 Release and Drop(Zero) %if Zero ## Nil // 5332 Release and Drop(DopeVector) // 5333 Release and Drop(Header) // 5334 %end // ?SYY unused // 5335 // 5336 %routine Swop // 5337 %record(Stackfm)%name T // 5338 T == Stack // 5339 Stack == T_Stack // 5340 T_Stack == Stack_Stack // 5341 Stack_Stack == T // 5342 %end // 5343 // 5344 %routine Define Range // 5345 %integer T // 5346 %record(Varfm)%name V // 5347 T = Tag; V == Var(T); Clear Vars(T) // 5348 Constant Bounds; V_Disp = Vlb; V_Extra = Vub; V_Format = -1 // 5349 %end // 5350 // 5351 %routine Test Range(%record(Stackfm)%name S, %record(Varfm)%name V) struct STACKFM * S, struct VARFM * V); auto void CLEARVARS( // 5352 %record(Stackfm)%name R, L, U, Low, High int LIMIT); auto void DIRSTRING( // 5353 %return %if Interface_Options&LL Range = 0 int OP, _imp_string *S); auto void FLOAT( // 5354 %if S_Type = Sets %start struct STACKFM * V, int R); auto void DUMPEXTERNAL( // 5355 Low == Literal(V_Disp) int CODE, struct VARFM *V); auto void DO( // 5356 High == Literal(V_Extra) _imp_string31 IDENT, int *EP, int RESULT); auto int GPR(void); auto int FPR(void); auto int SELECTBEST( // 5357 Loadup(S) %if S_Oper # 0 struct STACKFM * FROM, struct STACKFM * TO, int DEFAULT); auto struct STACKFM *DESCRIPTOR(void); auto struct STACKFM *TEMPORARY(void); auto void DROP( // 5358 Build Set(S) %if S_Members ## Nil struct STACKFM * V); auto struct STACKFM *LOCALINTEGER( // 5359 R == Copy(S); Amap(R) int DISP); auto struct STACKFM *LITERAL( // 5360 Load Trio(Low, R1, High, R2, R, R0) int N); auto struct STACKFM *COPY( // 5361 Prim(Set Range) struct STACKFM * V); auto int TAG(void); auto int FOURBYTES(void); auto void PRIM( // 5362 Release and Drop Pair(Low, High); Release and Drop(R) int N); auto void DUMPTEXT( // 5363 %return int MAX); auto void PASSPARAMETERS( // 5364 %finish struct STACKFM * V, int *EXTRA, int BASEREG); auto void ASSIGN( // 5365 int HOW); auto void STRINGASSIGN( // 5366 %if Iconst(S) %start struct STACKFM * R, struct STACKFM * L); auto void SETASSIGN( // 5367 %return %if V_Disp <= S_Disp <= V_Extra struct STACKFM * FROM, struct STACKFM * DEST); auto void EVALUATESTRINGEXPRESSION( // 5368 Warn(1, "Range violation") struct STACKFM * V); auto void RECORDASSIGN( // 5369 %finish struct STACKFM * FROM, struct STACKFM * TO); auto struct STACKFM *CLAIMWORKAREA( // 5370 int BYTES, int TYPE); auto void FLUSHDIAGS(void); auto void CONVERTFORMAT( // 5371 struct STACKFM * V, int TYPE); auto void TOSHORTREAL( // 5372 Loadup(S) struct STACKFM * V); auto void STOREREALCONSTANT( // 5373 R == Copy(S) {so as not to destroy the register} struct STACKFM * W); auto void BUILDSET( // 5374 U == Literal(V_Extra) // 5375 %if V_Disp # 0 %start {use dynamic range} // 5376 L == Literal(V_Disp) // 5377 Load Trio(R, R1, L, R2, U, R3) // 5378 Prim(Dynamic Range) // 5379 Release and Drop(L) // 5380 %else // 5381 Load Pair(R, R1, U, R3) // 5382 Prim(Check Range) // 5383 %finish // 5384 Release and Drop Pair(R, U) // 5385 %end // 5386 // 5387 %routine Duplicate // 5388 %record(Stackfm)%name V // 5389 V == Copy(Stack) // 5390 V_Stack == Stack // 5391 Stack == V // 5392 %end // 5393 // 5394 %routine Stack Work Variable // 5395 %integer T // 5396 %record(Varfm)%name V // 5397 T = Tag; V == Var(T); Clear Vars(T) // 5398 %if V_Base = None %start {a new one} // 5399 Frame = Frame&Alignment Mask-Wordlength // 5400 V_Type = Integers; V_Form = Direct // 5401 V_Base = Local; V_Disp = Frame // 5402 V_Flags = Known Ass // 5403 %finish // 5404 Stack Var(T) // 5405 %end // 5406 // 5407 %routine Claim With(%integer N) // 5408 %integer Format // 5409 %record(Withfm)%name W // 5410 W == NEW(Withfm Type) // 5411 W_Link == Withs; Withs == W // 5412 W_Key = N // 5413 %if Stack_Index ## Nil %or Stack_Record ## Nil %c // 5414+ %or Stack_Form # Direct %c // 5415+ %or %not Locked(Stack_Base) %start // 5416 Format = Stack_Format // 5417 Amap(Stack); Stab(Stack) // 5418 Stack_Format = Format // 5419 Stack_Flags = Stack_Flags ! Stored With // 5420 %finish // 5421 W_Data = Stack_Data // 5422 Pop Release and Drop // 5423 %end // 5424 // 5425 %routine Release With(%integer N) // 5426 %record(Withfm) Base // 5427 %record(Withfm)%name W == Base, X // 5428 Base_Link == Withs // 5429 %while W_Link ## Nil %cycle // 5430 %if W_Link_Key = N %start // 5431 X == W_Link // 5432 W_Link == X_Link // 5433 Withs == Base_Link // 5434 Dispose(X) // 5435 %return // 5436 %finish // 5437 W == W_Link // 5438 %repeat // 5439 Fail("No use") // 5440 %end // 5441 // 5442 %routine Use With(%integer N) // 5443 %integer Format // 5444 %record(Withfm)%name W == Withs // 5445 %while W ## Nil %cycle // 5446 %if W_Key = N %start // 5447 Stack Integer(0) // 5448 Stack_Data = W_Data // 5449 %if Stack_Flags&Stored With # 0 %start // 5450 Format = Stack_Format // 5451 Vmap(Stack, Integers) // 5452 Stack_Format = Format // 5453 %finish // 5454 %return // 5455 %finish // 5456 W == W_Link // 5457 %repeat // 5458 Fail("No use") // 5459 %end // 5460 // 5461 %routine Build Set(%record(Stackfm)%name S) struct STACKFM * S); auto void DROPMEMBERS( // 5462 %record(Stackfm)%name W, Z, OldLink struct STACKFM * S); // 5463 %record(Memberfm)%name M, X static int FRAME = 0; static int ROUND = 0; // 5464 %recordformat Csetfm(%bytearray Set(0:31)) {32*8 = 256} int AFRAME; AFRAME = 0; int PARAMETERFRAME; PARAMETERFRAME = 0; int PARAMETERREGS; PARAMETERREGS = 0; int STRINGRESULT; STRINGRESULT = 0; // 5465 %record(Csetfm) C int BLOCKTYPE; BLOCKTYPE = 0; int CODEBASE; CODEBASE = 0; int UNCONDJUMP; UNCONDJUMP = -1; int D; int N; int PARAMETERMODE; int VARBASE; VARBASE = *VARS; int FIRSTALT; FIRSTALT = PARMS - 1; int FRAMEBASE; int OLDFRAME; int ALTALIGN; int FRAMEEXTRA; int MAXFRAME; // 5466 %integer Dumped = 0, Marked = 0, In Work = 0, Low, High, Op, OldOper int ASSIGNLOCK; ASSIGNLOCK = 1; // 5467 int ATTRIBUTES; ATTRIBUTES = 0; int AT; AT = 0; int ENTRYMASK; ENTRYMASK = 0; int MYMARK; int OPEN; OPEN = 2048; int EVENTLABEL; EVENTLABEL = 0; int EVENTBODY; EVENTBODY = 0; int EVENTBITS; EVENTBITS = 0; int WSPSAVE; WSPSAVE = 0; int DANGERMARKER; DANGERMARKER = 0; int LOCALDISPLAY; LOCALDISPLAY = 0; int JLAB; int ARRAYBASE; ARRAYBASE = 0; // 5468 %routine Dump Set int WORKBASE; WORKBASE = LASTWORK; // 5469 %integer J int *CA; CA = &CODEBASE; // 5470 Dumped = 1 _imp_string127 PROCID; PROCID = INTERNALID; // 5471 Constant Base = (Constant Base+3)&(\3) {align it} struct WITHFM *WITHS; WITHS = NIL; // 5472 S_Type = Sets const _imp_string255 MONITORID = _imp_str_literal("3L___monitor"); // 5473 S_Disp = Constant Base; S_Form = Direct; S_Area = Constant Area static int MONITOREP = 0; // 5474 Select Constant Area void DECODE(int WORD, int AT) { extern void D( // 5475 Dump Byte(C_Set(J)) %for J = 0, 1, 31 int W, int A) __asm__("DECODE_ARM"); // 5476 Select Code Area _imp_SELECTOUTPUT(0); // 5477 %end D(WORD, AT); // 5478 _imp_SELECTOUTPUT(2); // 5479 %routine Mark(%integer N) } /* DECODE */ // 5480 %integer W struct STACKFM *DISPLAYINFO(int BASE) { // 5481 %unless 0 <= N <= 255 %start int N; // 5482 Warn(1, "Set element out of range ".itos(N, 0)) struct STACKFM *T; // 5483 %return if (BASE >= DANGERLEVEL) goto L_0006; FRAMEUSE[BASE] = // 5484 %finish 0; N = DISPLAYVECTOR[BASE]; // 5485 W = N>>3 if (N != 0) goto L_0007; MINSB = MINSB - // 5486 C_Set(W) = C_Set(W) ! (1<<(N&7)) 4; N = MINSB; DISPLAYVECTOR[BASE] = N; // 5487 Marked = 1 L_0007: T = LITERAL(N); // 5488 %end T->FORM = 1; // 5489 T->BASE = 10; // 5490 Monitor(S, "Bset->") %if Diag&Monoperand # 0 goto L_0008; L_0006: T = LOCALINTEGER(LOCALDISPLAY + // 5491 OldLink == S_Link; S_Link == NIL 4 * (BASE - DANGERLEVEL)); // 5492 OldOper = S_Oper; S_Oper = 0 L_0008: ATTRIBUTES = ATTRIBUTES | // 5493 C = 0 1 | 4; // 5494 M == S_Members; S_Members == Nil T->FLAGS = T->FLAGS | 128; return T; // 5495 S_Flags = S_Flags&(\Null Set) } /* DISPLAYINFO */ // 5496 %while M ## Nil %cycle void BD(int BASE, int DISP) { // 5497 X == M; M == M_Link _imp_WRITE(*DISP, 1); // 5498 %if X_Const # 0 %start _imp_PRINTSYMBOL(40); // 5499 High = X_A_Disp; Drop(X_A) if (0 > BASE) goto L_0009; if (BASE > 26) goto L_0009; // 5500 %if X_B == Nil %start _imp_PRINTSTRING(REGID[BASE]); // 5501 Mark(High) goto L_000A; L_0009: // 5502 %else if (BASE < 128) goto L_000B; // 5503 Low = X_B_Disp; Drop(X_B) if (BASE != *LOCAL) goto L_000C; // 5504 %while Low <= High %cycle _imp_PRINTSTRING(_imp_str_literal("Fp")); // 5505 Mark(Low); Low = Low+1 goto L_000D; L_000C: // 5506 %repeat _imp_PRINTSYMBOL(76); BASE = BASE - // 5507 %finish 128 - 1; // 5508 %else _imp_WRITE(BASE, 0); // 5509 %if In Work = 0 %start L_000D: // 5510 W == Claim Work Area(Set Size, Sets) goto L_000E; L_000B: // 5511 %if Marked # 0 %start _imp_WRITE(BASE, 0); // 5512 Dump Set %if Dumped = 0 L_000E: // 5513 Set Assign(S, W) L_000A: // 5514 Release(S_Base) {it's going to be copied over soon} _imp_PRINTSYMBOL(41); // 5515 Marked = 0 } /* BD */ // 5516 %else void SHOW(int N, _imp_string15 TEXT) { // 5517 Z == Literal(0); Z_Flags = Null Set if (*N == 0) goto L_000F; // 5518 Set Assign(Z, W) _imp_SPACE(); _imp_PRINTSTRING(TEXT); // 5519 Release and Drop(Z) _imp_WRITE(*N, 1); // 5520 %finish L_000F: // 5521 S_Data = W_Data } /* SHOW */ // 5522 Drop(W) void SHOWDATA(struct STACKFM * V, int LEFT) { // 5523 Dumped = 1 _imp_SPACES(LEFT); _imp_PRINTSTRING(TYPEID[V]); // 5524 In Work = 1 _imp_SPACE(); _imp_PRINTSTRING(FORMID[V]); // 5525 %finish BD(V, V); // 5526 Amap(S); Load Pair(S, R8, X_A, R1) SHOW(V, _imp_str_literal("Fm:")); // 5527 %if X_B == Nil %start SHOW(V, _imp_str_literal("A:")); // 5528 Op = Set Bit SHOW(V, _imp_str_literal("Fl:")); // 5529 %else if (V & 1 == 0) goto L_0010; _imp_PRINTSYMBOL(82); L_0010: // 5530 Load Trio(X_B, R0, S, R8, X_A, R1) if (V & 2 == 0) goto L_0011; _imp_PRINTSYMBOL(65); L_0011: // 5531 Release and Drop(X_B) if (V & 64 == 0) goto L_0012; _imp_PRINTSYMBOL(78); L_0012: // 5532 Op = Set Bits if (V & 4 == 0) goto L_0013; _imp_PRINTSYMBOL(80); L_0013: // 5533 %finish if (V & 8 == 0) goto L_0014; _imp_PRINTSYMBOL(68); L_0014: // 5534 Prim(Op) if (V & 131072 == 0) goto L_0015; _imp_PRINTSYMBOL(87); L_0015: // 5535 Vmap(S, Sets); S_Flags = S_Flags ! Work Set if (V & 32 == 0) goto L_0016; _imp_PRINTSYMBOL(83); L_0016: // 5536 Release and Drop(X_A) if (V & 128 == 0) goto L_0017; _imp_PRINTSYMBOL(61); L_0017: // 5537 %finish if (V & 16 == 0) goto L_0018; _imp_PRINTSYMBOL(72); L_0018: // 5538 Dispose(X) if (V & 1024 == 0) goto L_0019; _imp_PRINTSYMBOL(88); L_0019: // 5539 %repeat if (V & 65536 == 0) goto L_001A; _imp_PRINTSYMBOL(110); L_001A: // 5540 Dump Set %if Dumped = 0 if (V & 1048576 == 0) goto L_001B; _imp_PRINTSYMBOL(67); L_001B: // 5541 S_Link == OldLink if (V == 0) goto L_001C; _imp_PRINTSYMBOL(35); _imp_WRITE(V, 0); L_001C: // 5542 S_Oper = OldOper if (&V == NIL) goto L_001D; // 5543 Monitor(S, "Bset<-") %if Diag&MonOperand # 0 _imp_NEWLINE(); // 5544 %end _imp_SPACES(LEFT); _imp_PRINTSTRING(_imp_str_literal(" _:")); // 5545 DISPLAY(&V, LEFT + 4); // 5546 %routine Compile In(%integer Stack it) L_001D: // 5547 %integer N if (&V == NIL) goto L_001E; // 5548 %record(Stackfm)%name V, Set, C _imp_NEWLINE(); // 5549 Set == Stack; V == Set_Stack; Stack == V_Stack _imp_WRITE(V, LEFT + 2); _imp_PRINTSTRING(_imp_str_literal("i:")); // 5550 Build Set(Set) %if Set_Members ## Nil DISPLAY(&V, LEFT + 4); // 5551 Loadup(Set) %if Set_Oper # 0 L_001E: // 5552 %if Set_Flags&Null Set # 0 %start } /* SHOWDATA */ // 5553 %if Stackit # 0 %start void DISPLAY(struct STACKFM * V, int BIAS) { // 5554 C == Literal(0) {false} if (&V != NIL) goto L_001F; // 5555 C_Stack == Stack; Stack == C _imp_PRINTSTRING(_imp_str_literal(" Nil")); _imp_NEWLINE(); // 5556 %else return; // 5557 Dump Word(16_E150 0000) {CMPS _ R0, R0 = cc equal = false} L_001F: // 5558 %finish SHOWDATA(&V, BIAS); // 5559 Release and Drop(Set); Release and Drop(V) _imp_NEWLINE(); // 5560 %return if (V == 0) goto L_0020; // 5561 %finish _imp_SPACES(BIAS - 4); _imp_PRINTSTRING(OPERID[V]); // 5562 %if (Iconst(V) %and 0 <= V_Disp <= 255) %start DISPLAY(&V, BIAS + 4); // 5563 Advance(Set, Integers, (V_Disp>>5)<<2) L_0020: // 5564 Operate(ANDx, Set, Literal(1<<(V_Disp&31))) } /* DISPLAY */ // 5565 Test Zero(Set) void SHOWREG(int R) { // 5566 %else int A; A = ACTIVITY[R]; // 5567 Amap(Set) _imp_PRINTSTRING(REGID[R]); // 5568 Load Pair(V, R1, Set, R2) if (A != 0) goto L_0021; // 5569 Prim(SetIn) _imp_PRINTSTRING(_imp_str_literal(" unused")); // 5570 %finish goto L_0022; L_0021: if (A >= 0) goto L_0023; // 5571 Release and Drop Pair(Set, V) if (A != -1) goto L_0024; // 5572 Stack True or False(NE) %if Stackit # 0 _imp_PRINTSTRING(_imp_str_literal(" locked")); // 5573 %end goto L_0025; L_0024: // ?N unused // 5574 _imp_PRINTSTRING(_imp_str_literal(" =")); _imp_PRINTSTRING(REGID[-A]); _imp_SPACES(2); // 5575 %routine Add Member(%integer N) L_0025: // 5576 %record(Memberfm) Base goto L_0022; L_0023: // 5577 %record(Memberfm)%name M, P _imp_PRINTSTRING(_imp_str_literal(" used*")); _imp_WRITE(A, -1); // 5578 %record(Stackfm)%name A, B == Nil L_0022: // 5579 %integer Items = 0 _imp_PRINTSTRING(_imp_str_literal(" u:")); PRINTHEX(USED[R], 5); // 5580 A == Stack; Stack == A_Stack _imp_PRINTSTRING(_imp_str_literal(" k:")); _imp_WRITE(KTIMES[R], 0); // 5581 %if N # 0 %start _imp_NEWLINE(); // 5582 B == Stack; Stack == B_Stack } /* SHOWREG */ // 5583 %if Iconst(A) %and Iconst(B) %and A_Disp < B_Disp %start {empty} void MONITORN(int N, _imp_string255 TEXT) { // 5584 Drop(A); Drop(B); %return _imp_SELECTOUTPUT(0); // 5585 %finish _imp_PRINTSTRING(TEXT); // 5586 %finish _imp_WRITE(N, 8); // 5587 M == NEW(Memberfm Type) _imp_NEWLINE(); // 5588 M_A == A _imp_SELECTOUTPUT(2); // 5589 M_B == B } /* MONITORN */ // 5590 Items = Stack_Members_Items %if Stack_Members ## NIL void MONITORREGISTER(int R, _imp_string127 TEXT) { // 5591 %if Iconst(A) %and (B == Nil %or Iconst(B)) %start _imp_SELECTOUTPUT(0); // 5592 M_Const = 1 _imp_PRINTSTRING(TEXT); _imp_SPACES(9 - *_imp_LENGTH(&TEXT)); _imp_SPACE(); // 5593 M_Link == Stack_Members SHOWREG(R); // 5594 Stack_Members == M _imp_SELECTOUTPUT(2); // 5595 %else } /* MONITORREGISTER */ // 5596 M_Const = 0 void MONITOR(struct STACKFM * V, _imp_string127 TEXT) { // 5597 Base_Link == Stack_Members _imp_SELECTOUTPUT(0); // 5598 P == Base _imp_PRINTSTRING(TEXT); _imp_SPACES(9 - *_imp_LENGTH(&TEXT)); _imp_SPACE(); // 5599 P == P_Link %while P_Link ## Nil %and P_Link_Const # 0 DISPLAY(&V, 6); // 5600 M_Link == P_Link _imp_SELECTOUTPUT(2); // 5601 P_Link == M } /* MONITOR */ // 5602 Stack_Members == Base_Link void MONREGID(int R, _imp_string127 TEXT) { // 5603 %finish _imp_SELECTOUTPUT(0); // 5604 Stack_Members_Items = Items+1 _imp_PRINTSTRING(REGID[R]); _imp_SPACE(); // 5605 Stack_Flags = Stack_Flags&(\Null Set) _imp_PRINTSTRING(TEXT); // 5606 %end _imp_NEWLINE(); // 5607 _imp_SELECTOUTPUT(2); // 5608 %routine Stack Data Size } /* MONREGID */ // 5609 %integer T, N void DISPLAYKNOWLEDGE(void) { // 5610 T = Pending; Readsymbol(Pending) struct KNOWFM *K; // 5611 %if T = 0 %start _imp_SELECTOUTPUT(0); K = KNOWING; // 5612 T = Tag L_0026: if (K == NIL) goto L_0027; // 5613 N = Var(T)_Format _imp_PRINTSTRING(REGID[K->REG]); _imp_PRINTSTRING(_imp_str_literal(" = ")); // 5614 N = Var(-N)_Format %if N < 0 _imp_PRINTSTRING(TYPEID[(unsigned int)K->FTYPE >> 4]); _imp_SPACE(); // 5615 %else _imp_PRINTSTRING(FORMID[K->FTYPE & 15]); _imp_SPACE(); // 5616 %if Undefined <= T <= Sets %then N = Type Size(T) %c BD(K->BASE, K->DISP); // 5617+ %else N = 0 if (K->EXTRA == 0) goto L_0028; // 5618 Fail("Unknown type") %if N = 0 _imp_PRINTSTRING(_imp_str_literal(" X:")); _imp_WRITE(K->EXTRA, 1); // 5619 %finish L_0028: // 5620 Stack Integer(N) if (K->AREA == 0) goto L_0029; // 5621 %end _imp_PRINTSTRING(_imp_str_literal(" A:")); _imp_WRITE(K->AREA, 1); // 5622 L_0029: // 5623 %routine Test for NIL if (K->OPER == 0) goto L_002A; // 5624 %if Unassigned # 0 %start _imp_SPACE(); _imp_PRINTSTRING(OPERID[K->OPER]); // 5625 Stack_Flags = Stack_Flags!Known Ass _imp_WRITE(K->OPND, 1); // 5626 Load(Stack, R1) L_002A: // 5627 Prim(TestNil) {tests NIL, Unassigned & Disposed} _imp_NEWLINE(); K = & // 5628 %finish K->LINK; // 5629 %end goto L_0026; L_0027: // 5630 _imp_SELECTOUTPUT(2); // 5631 %routine Set Variant Count(%integer N) } /* DISPLAYKNOWLEDGE */ // 5632 %record(stackfm)%name V == Copy(Stack), Count void SHOWWHERE(void) { // 5633 Vmap(V, Shorts) _imp_SELECTOUTPUT(0); // 5634 Count == Literal(N) _imp_PRINTSTRING(_imp_str_literal(" at line ")); _imp_WRITE(CURRENTLINE, 0); // 5635 Simple(Count, V) if (_imp_strcmp(INCLUDEFILE, _imp_str_literal("")) == 0) goto L_002B; _imp_PRINTSTRING(_imp_join((_imp_string)(_imp_str_literal(" in file ")), (_imp_string)(INCLUDEFILE))); L_002B: // 5636 Release and Drop Pair(Count, V) _imp_NEWLINE(); // 5637 %end } /* SHOWWHERE */ // 5638 void FAIL(_imp_string63 WHY) { // 5639 void PCODE(int S) { // 5640 %routine Test Variant Count(%integer N) if (S < 128) goto L_002C; // 5641 %record(Stackfm)%name V == Copy(Stack), Count _imp_PRINTSTRING(_imp_str_literal("128+")); S = S - // 5642 Count == Literal(N) 128; // 5643 Vmap(V, Shorts) L_002C: // 5644 Load Pair(V, R3, Count, R0) if (32 > S) goto L_002D; if (S > 126) goto L_002D; // 5645 Prim(Test Variant) _imp_PRINTSYMBOL(39); _imp_PRINTSYMBOL(S); _imp_PRINTSYMBOL(39); // 5646 Release and Drop Pair(V, Count) L_002D: // 5647 %end _imp_WRITE(S, 3); // 5648 } /* PCODE */ // 5649 %routine Check not long NEW void ERR(int STREAM) { // 5650 %record(Stackfm)%name V == Copy(Stack) int R; // 5651 Amap(V); Vmap(V, Shorts) struct STACKFM *U; struct STACKFM *S; // 5652 Test Zero(V); Invert = 0 _imp_SELECTOUTPUT(STREAM); // 5653 Prim(Test NEW) _imp_NEWLINE(); // 5654 Release and Drop(V) _imp_PRINTSTRING(_imp_str_literal("====> Pass 2 fails -- ")); _imp_PRINTSTRING(WHY); // 5655 %end SHOWWHERE(); // 5656 _imp_PRINTSTRING(_imp_str_literal("Code ")); PCODE(CODE); // 5657 %routine Check Dynamic Bounds _imp_PRINTSTRING(_imp_str_literal(" Pending ")); PCODE(PENDING); // 5658 %record(Stackfm)%name Lower, Upper _imp_NEWLINE(); // 5659 Upper == Stack; Lower == Upper_Stack; Stack == Lower_Stack R = 0; /*%for R = 1, 1, 16 %cycle*/ L_002E: if (R == 16) goto L_002F; R += 1; // 5660 Load Trio(Stack, R1, Lower, R2, Upper, R3) if (ACTIVITY[R] <= 0) goto L_0030; SHOWREG(R); L_0030: // 5661 Prim(Dynamic Range) goto L_002E; L_002F: S = STACK; // 5662 Release and Drop Pair(Lower, Upper) L_0031: if (S == NIL) goto L_0032; // 5663 %end _imp_PRINTSTRING(_imp_str_literal("S:")); DISPLAY(S, 5); S = & // 5664 S->STACK; // 5665 %routine Localise goto L_0031; L_0032: U = USING; // 5666 {STACK Loc; STACK size; Stack Zero; LOCALISE} L_0033: if (U == NIL) goto L_0034; // 5667 {Loc is a pointer to an area containing SIZE bytes} _imp_PRINTSTRING(_imp_str_literal("U:")); DISPLAY(U, 5); U = & // 5668 {the area is copied into an anonymous local area and} U->USING; // 5669 {Zero is the displacement of AREA(first) from Area(0)} goto L_0033; L_0034: // 5670 {i.e. Area(first) = Loc+Zero} _imp_NEWLINE(); // 5671 {Loc is updated to point to this local area} /*_imp_monitor(__LINE__, __FILE__, PRETTY_FUNCTION);*/ // 5672 %record(Stackfm)%name Loc, Size, Zero } /* ERR */ // 5673 Zero == Stack ERR(0); // 5674 Size == Zero_Stack ERR(7); // 5675 Loc == Size_Stack _imp_stop(0); // 5676 Stack == Loc_Stack } /* FAIL */ // 5677 Forget Destination(Loc) void WARN(int FAULT, _imp_string63 WHAT) { // 5678 Amap(Loc) _imp_SELECTOUTPUT(0); // 5679 Load Trio(Size, R0, Zero, R1, Loc, R2) INTERFACE->FAULTS = INTERFACE->FAULTS + FAULT; // 5680 Prim(MakeLocal) if (FAULT != 0) goto L_0035; _imp_PRINTSTRING(_imp_str_literal("Warning: ")); goto L_0036; L_0035: _imp_PRINTSTRING(_imp_str_literal("*Error: ")); L_0036: // 5681 Attributes = Attributes ! Attr Sp Unknown _imp_PRINTSTRING(WHAT); // 5682 Release and Drop Pair(Size, Zero) SHOWWHERE(); // 5683 Release and Drop(Loc) _imp_SELECTOUTPUT(2); // 5684 %end } /* WARN */ // 5685 void NOTINYET(void) { // 5686 %routine End of Block FAIL(_imp_str_literal("***Not implemented yet***")); // 5687 %if Local # Base Local %start {not first (dummy) call} } /* NOTINYET */ // 5688 %if Uncond Jump # Ca %and Avar_Type = Generals %and void DIR1(int CODE) { // 5689+ Avar_Flags&Prim Proc = 0 %start FLUSHCODE(); // 5690 Return(Routine) _imp_PRINTSYMBOL(CODE); PENDINGAUTO = // 5691 %finish 0; // 5692 %finish } /* DIR1 */ // 5693 %end void DIR2(int CODE, int ARG1) { // 5694 FLUSHCODE(); // 5695 %routine Process Include File _imp_PRINTSYMBOL(CODE); // 5696 Get String(Include File) DUMPENCODED(ARG1); // 5697 Dir String(Dir Include, Include File) if (CODE == 3) goto L_0037; PENDINGAUTO = 0; L_0037: // 5698 %end } /* DIR2 */ // 5699 void DIR3(int CODE, int ARG1, int ARG2) { // 5700 %switch C(0:255) FLUSHCODE(); // 5701 _imp_PRINTSYMBOL(CODE); // 5702 At = 0 DUMPENCODED(ARG1); // 5703 Pending Auto = 0 DUMPENCODED(*ARG2); PENDINGAUTO = // 5704 Old Frame = Frame 0; // 5705 %if Amode >= -1 %start {procedure definition, format start} } /* DIR3 */ // 5706 Frame = 0 {ready for first field} void DIR4(int CODE, int ARG1, int ARG2, int ARG3) { // 5707 %if Amode >= 0 %start {procedure def} FLUSHCODE(); // 5708 Frame = 4 {ready for first parameter} _imp_PRINTSYMBOL(CODE); // 5709 %if Avar_Flags&Xproc Spec # 0 %start {previous external spec} DUMPENCODED(*ARG1); // 5710 Avar_Flags = Avar_Flags-Xproc Spec DUMPENCODED(*ARG2); // 5711 Avar_Disp = 0 DUMPENCODED(ARG3); PENDINGAUTO = // 5712 %finish 0; // 5713 Avar_Disp = New Label %if Avar_Disp = 0 %and } /* DIR4 */ // 5714+ (Permrt # Ostate # External %or Amode = 0) struct WORKFM *WORKAREA(int N) { // 5715 %if Amode = 0 %start {entry to block} struct WORKVFM *W; // 5716 %if Local > Base Local + Max Nesting %start int E; int S; int X; // 5717 Fail("Subroutines nested too deeply") if (!_imp_on_event(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)) goto L_0038; E = // 5718 %finish _imp_EVENT().EVENT; S = _imp_EVENT().SUB; X = 0; // 5719 Uncond Jump = -1; Forget Everything FAIL(_imp_join((_imp_string)(_imp_str_literal("too many work areas:")), (_imp_string)(_imp_ITOS(E, 0)))); // 5720 Dir2(Dir Start Block, Avar_Disp); Blocks = Blocks+1 L_0038: // 5721 DIR String(-1, Internal Id) if (DIAG & 8 == 0) goto L_0039; MONITORN(*N, _imp_str_literal("work area")); L_0039: W = &WORKLIST; // 5722 Fmark = Fmark+1; Frame Use(Local) = Fmark L_003A: if (*N <= 30) goto L_003B; *N = *N - // 5723 %if DEBUG # 0 %start {001} 30; // 5724 Dir3(Dir DEBUG Start Proc, {001} if (&W->LINK != NIL) goto L_003C; // 5725+ 0, {type} {001} W->LINK = _imp_NEW(WORKVFMTYPE); // 5726+ Current Line {source}) {001} W->LINK = 0; // 5727 %finish {001} L_003C: W = & // 5728 %finish W->LINK; // 5729 %if Ostate = External %start goto L_003A; L_003B: return & // 5730 %if Amode # 0 %start {external spec} W->W[*N]; // 5731 Avar_Flags = Avar_Flags!Xproc Spec } /* WORKAREA */ // 5732 Dump External(2_10, Avar) struct LABELFM *ILABEL(int N) { // 5733 %else {external definition} int X; int J; // 5734 Avar_Flags = Avar_Flags!Xproc Def struct ILABELFM *I; // 5735 N = 2_11 struct LABELFM *L; // 5736 N = 2_11 ! 1<<4 %if Avar_Flags&Keep Local # 0 if (*N <= 8191) goto L_003D; FAIL(_imp_str_literal("internal label/1")); L_003D: X = (unsigned int)*N >> // 5737 Dump External(N, Avar) 8; I = & // 5738 Attributes = Attributes!Attr Xdef ILABELS[X].LABEL; // 5739 %if Avar_Flags&Prim Proc # 0 %start if (I != NIL) goto L_003E; I = _imp_NEW(ILABELFMTYPE); // 5740 Attributes = Attributes!Attr Prim ILABELS[X].LABEL = I; // 5741 %finish I->LINK = ILABELLIST; ILABELLIST = I; // 5742 %finish J = -1; /*%for J = 0, 1, 255 %cycle*/ L_003F: if (J == 255) goto L_0040; J += 1; L = & // 5743 %finish I->LAB[J]; // 5744 %else L->LAB = -2147483648; // 5745 Dir2(Dir Record On, Avar_Area) L->ENV = NIL; // 5746 %finish goto L_003F; L_0040: // 5747 %finish L_003E: return & // 5748 I->LAB[*N & 255]; // 5749 Frame Extra = Frame } /* ILABEL */ // 5750 Frame = (Frame+Alignment)&Alignment Mask void SELECTAREA(int AREAID, int *BASE) { // 5751 Frame Extra = Frame-Frame Extra DIR3(27, (unsigned int)AREAID >> 8, BASE); CURRENTAREA = AREAID; CA = &BASE; // 5752 Frame Base = Frame } /* SELECTAREA */ // 5753 MyMark = Fmark void SELECTCODEAREA(void) { // 5754 Max Frame = 0 SELECTAREA(0, &CODEBASE); // 5755 Alt Align = \0 } /* SELECTCODEAREA */ // 5756 Pending Known Register = 0 void SELECTCONSTANTAREA(void) { // 5757 Pending Auto = 0 SELECTAREA(512, &CONSTANTBASE); // 5758 } /* SELECTCONSTANTAREA */ // 5759 ->C('}') %if Code = 'H' {special for BEGIN} void SELECTOWNAREA(void) { // 5760 SELECTAREA(256, &OWNBASE); // 5761 %cycle } /* SELECTOWNAREA */ // 5762 Code = Pending; Readsymbol(Pending); ->C(Code) void SELECTOWNARRAYAREA(void) { // 5763 SELECTAREA(768, &OWNARRAYBASE); // 5764 c('!'): Operation(ORx); %continue } /* SELECTOWNARRAYAREA */ // 5765 c('"'): Compare Double; %continue void DUMPBYTE(int B) { // 5766 c('#'): Jump Forward(Tag, NE); %continue _imp_PRINTSYMBOL(31); _imp_PRINTSYMBOL(1); // 5767 c('$'): Define Var; %continue _imp_PRINTSYMBOL(B & 255); *CA = *CA + // 5768 c('%'): Operation(XORx); %continue 1; // 5769 c('&'): Operation(ANDx); %continue } /* DUMPBYTE */ // 5770 c(''''): Input String Value; %continue void DUMPHALF(int H) { // 5771 c('('): Jump Forward(Tag, LE); %continue _imp_PRINTSYMBOL(31); _imp_PRINTSYMBOL(2); // 5772 c(')'): Jump Forward(Tag, GE); %continue _imp_PRINTSYMBOL(H & 255); // 5773 c('*'): Operation(MULx); %continue _imp_PRINTSYMBOL((unsigned int)H >> 8 & 255); *CA = *CA + // 5774 c('+'): Operation(ADDx); %continue 2; // 5775 c('-'): Operation(SUBx); %continue } /* DUMPHALF */ // 5776 c('.'): Operation(CONCx); %continue void DUMPWORD(int N) { // 5777 c('/'): Operation(DIVx); %continue _imp_PRINTSYMBOL(31); _imp_PRINTSYMBOL(4); // 5778 c(':'): Define Compiler Label(Tag); %continue _imp_PRINTSYMBOL(N & 255); // 5779 c(';'): End of Block; %exit _imp_PRINTSYMBOL((unsigned int)N >> 8 & 255); // 5780 c('<'): Jump Forward(Tag, LT); %continue _imp_PRINTSYMBOL((unsigned int)N >> 16 & 255); // 5781 c('='): Jump Forward(Tag, EQ); %continue _imp_PRINTSYMBOL((unsigned int)N >> 24); // 5782 c('>'): Jump Forward(Tag, GT); %continue if (DIAG & 1 == 0) goto L_0042; if (CURRENTAREA != 0) goto L_0042; DECODE(*CA, N); L_0042: *CA = *CA + // 5783 c('?'): Compare Values; %continue 4; // 5784 c('@'): Stack Var(Tag); %continue } /* DUMPWORD */ // 5785 c('A'): Init(Tag); %continue int ACTUALREGISTER(int BASE) { // 5786 c('B'): Jump Backward(Tag); %continue struct STACKFM *T; // 5787 c('C'): Compare Addresses; %continue if (BASE < 128) goto L_0043; // 5788 c('D'): Input Real Value; %continue if (BASE != *LOCAL) goto L_0044; BASE = // 5789 c('E'): Call(0); %continue 11; // 5790 c('F'): Jump Forward(Tag, Always); %continue goto L_0045; L_0044: if (BASE <= 128) goto L_0046; T = DISPLAYINFO(BASE); // 5791 c('G'): Get String(Alias); %continue LOADUP(T); BASE = // 5792 c('H'): Compile Begin; %continue T->BASE; // 5793 c('I'): Select Input(Icode In2); Readsymbol(Pending); %continue RELEASEANDDROP(T); // 5794 c('J'): User Jump(Tag); %continue L_0046: L_0045: // 5795 c('K'): Return(False); %continue L_0043: return ACTUAL[BASE]; // 5796 c('L'): Define User Label(Tag); %continue } /* ACTUALREGISTER */ // 5797 c('M'): Return(Map); %continue int JUST(int R) { return ACTUALREGISTER(*R); // 5798 c('N'): Input Integer Value(0); %continue } /* JUST */ // 5799 c('O'): Update Line(Tag); %continue int NOTHING(void) { return // 5800 c('P'): Dump Byte(Popped Value&255); %continue 33554432; // 5801 c('Q'): Operation(RDIVx); %continue } /* NOTHING */ // 5802 c('R'): Return(Routine); %continue int IMMEDIATE(int N) { // 5803 c('S'): Assign(Equals); %continue int ROT; ROT = 16; // 5804 c('T'): Return(True); %continue if (N == 0) goto L_0047; // 5805 c('U'): Operate(NEGx, Stack, Nil); %continue L_0048: if (N & 3 != 0) goto L_0049; ROT = ROT - 1; N = (unsigned int)N >> 2; goto L_0048; L_0049: // 5806 c('V'): Return(Fn); %continue if ((unsigned int)N >> 8 == 0) goto L_004A; return -1; L_004A: // 5807 c('W'): Switch Jump(Tag); %continue L_0047: return (ROT & // 5808 c('X'): Operation(EXPx); %continue 15) << 8 | N | 33554432; // 5809 c('Z'): Assign(EqualsEquals); %continue } /* IMMEDIATE */ // 5810 c('['): Operation(LSHx); %continue int ISHIFT(int RM, int BY, int HOW) { // 5811 c('\'): Operate(NOTx, Stack, Nil); %continue if (HOW & 128 == 0) goto L_004B; FAIL(_imp_str_literal("Bad immediate shift")); L_004B: return ACTUALREGISTER(RM) | (BY & // 5812 c(']'): Operation(RSHx); %continue 31) << 3 + 4 | HOW; // 5813 c('^'): Stack_Format = -Tag; %continue } /* ISHIFT */ // 5814 c('_'): Switch Label(Tag); %continue int RSHIFT(int RM, int RS, int HOW) { // 5815 c('a'): Array Access; %continue if (HOW & 128 != 0) goto L_004C; FAIL(_imp_str_literal("Bad register shift")); L_004C: return ACTUALREGISTER(RM) | ACTUALREGISTER(RS) << // 5816 c('b'): Constant Bounds; %continue 4 + 4 | HOW & 112; // 5817 c('c'): Section = 1; Get String(Section Id); %exit } /* RSHIFT */ // 5818 c('d'): D = Tag; N = Tag; Dimension(D, N); %continue int ROT(int N, int BY) { return N & // 5819 c('e'): Signal Event(Tag); %continue 255 | BY << 8 | 33554432; // 5820 c('f'): Compile For(Tag); %continue } /* ROT */ // 5821 c('g'): Test for NIL; %continue static int PENDINGPOP = 0; // 5822 c('h'): Special Call(Tag); %continue void PLANT1(int FN, int RN, int RD, int X) { // 5823 c('i'): Array Index; %continue DUMPWORD(FN ^ -536870912 | ACTUALREGISTER(RN) << 16 | ACTUALREGISTER(RD) << 12 | X); // 5824 c('j'): Assign(Jam); %continue if ((unsigned int)FN >> 23 & 3 == 2) goto L_004D; FORGET(RD); L_004D: // 5825 c('k'): Jump Forward(Tag, FF); %continue } /* PLANT1 */ // 5826 c('l'): Language Flags = Tag; %continue void PLANT2(int FN, int RD, struct STACKFM *V) { // 5827 c('m'): Do(Monitor Id, Monitor Ep, 0); %continue int N; int SHIFT; int SIGN; int D; int P; int BASE; int VBASE; int EXTRA; EXTRA = 0; // 5828 c('n'): Select(Tag); %continue struct STACKFM *W; // 5829 c('o'): Event Trap(Tag); %continue if (V != 4) goto L_004E; FN = FN | 4194304; L_004E: // 5830 c('p'): AssignParameter; %continue SIMPLIFY(&V); D = // 5831 c('q'): Process Include File; %continue V; // 5832 c('r'): Resolve(Tag); %continue if (V != 2) goto L_004F; D = TYPESIZE[ // 5833 c('s'): To Store(Tag); %continue V]; FN = FN | // 5834 c('t'): Jump Forward(Tag, TT); %continue 16777216; // 5835 c('u'): Aop; %continue goto L_0050; L_004F: if (V != 3) goto L_0051; D = -TYPESIZE[ // 5836 c('v'): Operate(ABSx, Stack, Nil); %continue V]; FN = FN | // 5837 c('w'): Machine Code; Forget Everything; %continue 2097152; // 5838 c('x'): Operation(REXPx); %continue goto L_0050; L_0051: if (V == 1) goto L_0052; // 5839 c('y'): Set CD(Tag, Diag); %continue FAIL(_imp_str_literal("illegal load/store")); // 5840 c('z'): Set CD(Tag, Control); %continue L_0052: L_0050: // 5841 c('{'): Assemble(DefV, if (&V != NIL) goto L_0053; // 5842+ Blocktype, if (-4095 > D) goto L_0041; if (D <= 4095) goto L_0054; L_0041: FAIL(_imp_str_literal("Bad displacement")); L_0054: // 5843+ Vars, if (D < 0) goto L_0055; FN = FN | 8388608; goto L_0056; L_0055: D = -D; L_0056: FN = FN | D; // 5844+ Local+1, if (D != 0) goto L_0057; PENDINGAUTON = // 5845+ Parameter Mode, Attributes) 0; PENDINGAUTO = // 5846 %continue V; PENDINGAUTOCA = *CA; // 5847 L_0057: // 5848 c('}'): %exit %if Finish Params goto L_0058; L_0053: // 5849 Do("3L___stack_check", Stack Check, 0) %if Interface_Options&LL Stack # 0 if (D == 0) goto L_0059; FAIL(_imp_str_literal("Bad index displacement")); L_0059: N = // 5850 %continue V; if (N != 0) goto L_005A; FAIL(_imp_str_literal("Zero Xsize")); L_005A: P = POWER(N); // 5851 c('~'): N = Pending; Readsymbol(Pending) if (P < 0) goto L_005B; // 5852 %exit %if Alternate Format(N); %continue LOADUP(&V); // 5853 goto L_005C; L_005B: P = // 5854 {************ Extra Items **************} 0; SIGN = N & // 5855 -2147483648; // 5856 c(128+'"'): Unsigned = 10; Stack Condition; %continue L_005D: if (N & 1 != 0) goto L_005E; P = P + 1; N = (unsigned int)N >> 1 | SIGN; goto L_005D; L_005E: // 5857 c(128+'?'): Unsigned = 10; Compare Values; %continue OPERATE(6, &V, LITERAL(N)); V = 1; // 5858 c(128+','): Max Frame = Frame %if Frame > Max Frame LOADUP(&V); // 5859 Frame = Frame Base; %continue L_005C: FN = FN | // 5860 c(128+'0'): N = Tag; {but no operation} %continue 8388608 | 33554432 | ISHIFT(V, P, 0); // 5861 c(128+'1'): Add Member(0); %continue L_0058: // 5862 c(128+'2'): Add Member(1); %continue if (V != 0) goto L_005F; // 5863 c(128+'3'): Set Variant Count(Tag); %continue if (&V != NIL) goto L_0060; // 5864 c(128+'4'): Test Variant Count(Tag); %continue if (V >= 0) goto L_0061; // 5865 c(128+'5'): Check not long NEW; %continue LOADUP(&V); FN = FN | ACTUALREGISTER( // 5866 c(128+'6'): Check Dynamic Bounds; %continue V) << 16; // 5867 goto L_0062; L_0061: // 5868 c(128+'/'): Operation(UDIVx); %continue FAIL(_imp_str_literal("No absolute yet")); // 5869 c(128+'|'): Operation(UREMx); %continue L_0062: // 5870 c(128+'@'): Decode(0, -1) %if Diag&Mon Code # 0 goto L_0063; L_0060: // 5871 Current Line = Tag; %continue LOADUP(&V); // 5872 c(128+'A'): Amap(Stack); %continue V = V; // 5873 c(128+'B'): %if Pending = 't' %then Pending = '#' %c DROP(&V); V = NIL; FN = FN | ACTUALREGISTER( // 5874+ %else Pending = '=' V) << 16; // 5875 Test Zero(Stack); Pop Release and Drop; %continue L_0063: // 5876 c(128+'C'): Unsigned = 0; Stack Condition; %continue goto L_0064; L_005F: FN = FN | ACTUALREGISTER( // 5877 c(128+'D'): Duplicate; %continue V) << 16; // 5878 c(128+'E'): Loadup(Stack) %unless Stack_Form = Address %c L_0064: // 5879+ %and Locked(Stack_Base) %c if (FN & (16777216 | 2097152) == 0) goto L_0065; FORGET(V); L_0065: FN = FN ^ // 5880+ %and Stack_Record == Nil %c 16777216 | ACTUALREGISTER(RD) << 12; // 5881+ %and Stack_Index == Nil; %continue DUMPWORD(FN ^ -536870912); // 5882 c(128+'F'): Stack_Format = -Tag; %continue if (EXTRA == 0) goto L_0066; RELEASE(EXTRA); L_0066: // 5883 c(128+'I'): Compile In(1); %continue if (FN & 1048576 == 0) goto L_0067; // 5884 c(128+'L'): Localise; %continue FORGET(RD); // 5885 c(128+'M'): Operation(MODx); %continue goto L_0068; L_0067: // 5886 c(128+'N'): Operation(REMx); %continue FORGETDESTINATION(&V); // 5887 C(128+'O'): Apply Round(Stack); %continue REMEMBER(RD, &V); // 5888 c(128+'P'): Pop Release and Drop; %continue L_0068: // 5889 c(128+'R'): Define Range; %continue } /* PLANT2 */ // 5890 c(128+'S'): Swop; %continue void PLANT3(int FN, int N) { // 5891 c(128+'T'): Apply Trunc(Stack); %continue DUMPWORD(FN ^ -536870912 | N & 16777215); // 5892 c(128+'U'): Use With(Tag); %continue } /* PLANT3 */ // 5893 c(128+'V'): Vmap(Stack, Tag); %continue void PLANT4(int FN, int RN, int OPERAND) { // 5894 c(128+'W'): Stack Work Variable; %continue DUMPWORD(FN ^ -536870912 | ACTUALREGISTER(RN) << 16 | OPERAND & 65535); // 5895 C(128+'X'): Loadup(Stack) %unless Stack_Type = Lreals; %continue if (FN & 2097152 == 0) goto L_0069; FORGET(RN); L_0069: // 5896 c(128+'Z'): Stack Integer(0); Stack_Type = Sets } /* PLANT4 */ // 5897 Stack_Flags = Null Set; %continue void PLANT5(int FN, int OFFSET) { // 5898 c(128+'['): Claim With(Tag); %continue DUMPWORD(FN ^ -536870912 | OFFSET & 16777215); // 5899 c(128+']'): Release With(Tag); %continue } /* PLANT5 */ // 5900 c(128+'b'): Input Integer Value(1); %continue void PLANT6(int OP, int FD, struct STACKFM *V) { // 5901 c(128+'c'): General Compare; %continue int N; int SHIFT; int SIGN; int D; int P; int BASE; int VBASE; // 5902 c(128+'e'): N = Stack_Type ; Amap(Stack) struct STACKFM *W; // 5903 Loadup(Stack) %unless Stack_Form = Address %c SIMPLIFY(&V); D = // 5904+ %and Locked(Stack_Base) %c V; // 5905+ %and Stack_Index == Nil %c if (D & 3 == 0) goto L_006A; FAIL(_imp_str_literal("Floating-point alignment")); L_006A: D = ((long)D / (long) // 5906+ %and Stack_Record == Nil 4); // 5907 Vmap(Stack, N); %continue if (V != 2) goto L_006B; D = (unsigned int)TYPESIZE[ // 5908 c(128+'f'): For Range == Var(Tag); %continue V] >> 2; OP = OP | // 5909 c(128+'g'): Call(1); %continue 16777216; // 5910 c(128+'i'): Compile In(0); %continue goto L_006C; L_006B: if (V != 3) goto L_006D; D = -((unsigned int)TYPESIZE[ // 5911 C(128+'n'): Apply Int(Stack); %continue V] >> 2); OP = OP | // 5912 c(128+'m'): General Move; %continue 2097152; // 5913 c(128+'o'): Owntype = Tag; %continue goto L_006C; L_006D: if (V == 1) goto L_006E; // 5914 c(128+'p'): Fmap(Tag); %continue FAIL(_imp_str_literal("illegal load/store")); // 5915 c(128+'r'): Test Range(Stack, Var(Tag)); %continue L_006E: L_006C: // 5916 c(128+'s'): Set Size or Type(1, Stack); %continue if (&V == NIL) goto L_006F; // 5917 c(128+'t'): Set Size or Type(2, Stack); %continue if (-255 > D) goto L_0070; if (D <= 255) goto L_0071; L_0070: FAIL(_imp_str_literal("Fp Disp?")); L_0071: W = COPY(&V); // 5918 c(128+'v'): Compare Values; Prim(Test Variant); %continue LOADUPADDRESS(W); // 5919 c(128+'w'): Apply Intpt(Stack); %continue W->TYPE = V; W->FORM = 1; // 5920 c(128+'z'): Stack Data Size; %continue PLANT6(OP, FD, W); // 5921 c(128+'{'): Nn = 0 RELEASEANDDROP(W); // 5922 Assemble(AltV, -2, Vars, Local, -1, Nn) return; // 5923 Alt Align = Alt Align&Falign; %continue L_006F: // 5924 c(128+'}'): Frame = Max Frame %if Max Frame > Frame if (D < 0) goto L_0072; OP = OP | 8388608; goto L_0073; L_0072: D = -D; L_0073: OP = OP | D; // 5925 Falign = Alt Align; %exit if (V != 0) goto L_0074; // 5926 %repeat if (&V != NIL) goto L_0075; // 5927 if (V >= 0) goto L_0076; // 5928 Global Attributes = Global Attributes! (Attributes&Attr GLOBALS) if (V == 1) goto L_0077; FAIL(_imp_str_literal("Bad external")); L_0077: // 5929 %if Amode&8 = 0 %start LOADUP(&V); OP = OP | ACTUALREGISTER( // 5930 Attributes = Attributes!Attr Inner Uses %if Frame Use(Local) # MyMark V) << 16; // 5931 %if DEBUG # 0 %start {001} goto L_0078; L_0076: // 5932 Dir2(Dir DEBUG End Proc, Current Line {source}) {001} FAIL(_imp_str_literal("No absolute yet")); // 5933 %finish {001} L_0078: // 5934 Dir1(Dir End Block) goto L_0079; L_0075: // 5935 Dump Encoded(Frame&Alignment Mask-Aframe) LOADUP(&V); // 5936 Dump Encoded(Code Base) V = V; // 5937 Dump Encoded(Parameter Frame) DROP(&V); V = NIL; OP = OP | ACTUALREGISTER( // 5938 Dump Encoded(Parameter Regs) V) << 16; // 5939 Dump Encoded(Display Vector(Local)) L_0079: // 5940 Dump Encoded(Local Display) goto L_007A; L_0074: OP = OP | ACTUALREGISTER( // 5941 Dump Encoded(Array Base) V) << 16; // 5942 Dump Encoded(Attributes) L_007A: // 5943 Dump Encoded(Entry Mask) if (OP & (16777216 | 2097152) == 0) goto L_007B; FORGET(V); L_007B: OP = OP ^ // 5944 Dump Encoded(Event Bits&16_FFFF) 16777216 | ACTUALREGISTER(FD) << 12; // 5945 Dump Encoded(Event Label) DUMPWORD(OP ^ -536870912); // 5946 Dump Encoded(Event Body) if (OP & 1048576 == 0) goto L_007C; // 5947 Forget Everything FORGET(FD); // 5948 Avar_Flags = Avar_Flags!Open goto L_007D; L_007C: // 5949 %finish FORGETDESTINATION(&V); // 5950 Terminate Block REMEMBER(FD, &V); // 5951 Display Vector(Local+1) = 0 %unless Local = Display Limit L_007D: // 5952 Danger Level = No Danger %if Danger Level = Local } /* PLANT6 */ // 5953 Pending Known Register = 0 void PLANT7(int OP, int FN, int RD, int FM) { // 5954 Pending Auto = 0 if (OP & 8 != 0) goto L_007E; FM = ACTUAL[FM]; L_007E: // 5955 Last Work = Work Base DUMPWORD(OP ^ -536870912 | ACTUAL[FN] << 16 | ACTUAL[RD] << 12 | FM); // 5956 %return if (OP & 1048576 != 0) goto L_007F; FORGET(FN); goto L_0080; L_007F: FORGET(RD); L_0080: // 5957 C(*): Fail("Code ".Itos(Code, 0)) } /* PLANT7 */ // 5958 %end void PLANT8(int OP, int FN, int FM) { // ?PUSHADDRESS unused // ?POTENTIALLYUNASSIGNED unused // ?PROCID unused // ?TOSHORTREAL unused // ?CONST unused // 5959 if (OP & 8 != 0) goto L_0081; FM = ACTUAL[FM]; L_0081: // 5960 {Initialisation} DUMPWORD(OP ^ -536870912 | ACTUAL[FN] << 16 | FM); // 5961 } /* PLANT8 */ // 5962 Activity(Sp) = -1 {lock the stack pointer} void PLANT9(int OP, int FN, int FD, int FM) { // 5963 Activity(Fp) = -1 {lock the frame pointer} if (OP & 8 != 0) goto L_0082; FM = ACTUAL[FM]; L_0082: // 5964 Activity(Sb) = -1 {lock the static base} DUMPWORD(OP ^ -536870912 | ACTUAL[FN] << 16 | ACTUAL[FD] << 12 | FM); // 5965 FORGET(FD); // 5966 Compiling Prim = Interface_Prim } /* PLANT9 */ // 5967 Unassigned = Interface_Options&LL Assigned struct CONSTFM { union { struct { int N; int STORE; int TYPE; int V1; int R1; int V2; int R2; }; }; }; // 5968 Debug = Interface_Options&LL Debug {001} void TESTASSIGNED(void) { // 5969 Own Base = 16 %if Unassigned # 0 DIR1(24); *CA = *CA + 4; REFS = REFS + 1; // 5970 } /* TESTASSIGNED */ // 5971 Pvar(J)_P == Nil %for J = 0, 1, Var Top void FLOAT(struct STACKFM * V, int R) { // 5972 !0.9! Ilabels(J) == NIL %for J = 0, 1, Max Label>>8 int N; // 5973 {0.9} Ilabels(J)_Label == NIL %for J = 0, 1, Max Label>>8 double LONG; // 5974 if (R != 26) goto L_0083; R = FPR(); L_0083: // 5975 Select Input(Icode In); Readsymbol(Pending) if (!(ICONST(&V))) goto L_0084; // 5976 Var(0) = 0 if (0 > V) goto L_0085; if (V <= 5) goto L_0086; L_0085: if (V != 10) goto L_0087; L_0086: N = // 5977 Default Value = 0 {*****make this unassigned later*****} V; if (V != 10) goto L_0088; N = 7; L_0088: // 5978 Value = Default Value PLANT9(234914176 | 8, 0, R, N); // 5979 goto L_0089; L_0087: if (-5 > V) goto L_008A; if (V <= 0) goto L_008B; L_008A: if (V != -10) goto L_008C; L_008B: N = - // 5980 %routine Initialise(%record(Stackfm)%name V, %integer Base, Form) V; if (N != 10) goto L_008D; N = 7; L_008D: // 5981 V = 0 PLANT9(235962752 | 8, 0, R, N); // 5982 V_Base = Base goto L_0089; L_008C: LONG = // 5983 V_Type = Integers V; V = LONG; // 5984 V_Form = Form CONVERTFORMAT(&V, 7); // 5985 V_Flags = Known Ass STOREREALCONSTANT(&V); // 5986 %end DIR4(12, ACTUAL[R], V, 1); FORGET(R); REFS = REFS + // 5987 1; *CA = *CA + 4; // 5988 Initialise(Ua Pat, Sb, Direct) L_0089: // 5989 Initialise(Zero, 0, Address) goto L_008E; L_0084: // 5990 Initialise(One, 0, Address); One_Disp = 1 LOADUP(&V); // 5991 Initialise(SpV, Sp, Address) PLANT7(235405584, R, V, 0); RELEASE(V); // 5992 L_008E: // 5993 %begin V = 7; V = 0; // 5994 %integer J V = R; V = 0; // 5995 %record(Stackfm)%name R V = 0; // 5996 %for J = R0, 1, AnyF %cycle CLAIM(R); // 5997 R == RegV(J) } /* FLOAT */ // 5998 R = 0 void LOADSAFELY(struct STACKFM * V, int R) { // 5999 R_Base = J if (R != 17) goto L_008F; // 6000 R_Type = Integers LOADPROTECTED(&V); // 6001 R_Form = Address goto L_0090; L_008F: if (R != 26) goto L_0091; // 6002 R_Format = Wordlength if (FLOATING(&V)) goto L_0092; FLOAT(&V, 26); L_0092: // 6003 %if J >= F0 %start LOADPROTECTED(&V); // 6004 R_Type = Lreals goto L_0090; L_0091: // 6005 R_Format = Wordlength*2 if (ACTIVITY[R] != 1) goto L_0093; if (V == R) goto L_0094; L_0093: HAZARD(R); L_0094: // 6006 %finish LOAD(&V, R); // 6007 %repeat L_0090: // 6008 %end } /* LOADSAFELY */ // 6009 void CHARACTERISECONSTANT(int N, struct CONSTFM *C) { // 6010 Knowing == Nil int SH; int V; int S; int X; // 6011 Kasl == Nil const unsigned char BITS[16] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; // 6012 C = N; V = N; // 6013 Select Output(Directives Out) if (V != 0) goto L_0095; // 6014 Parms = Max Vars {leaving Var(Max Vars) free} C = 1; return; // 6015 Constant Base = 0 L_0095: if (V != -1) goto L_0096; // 6016 Free Label = 0 C = 2; return; // 6017 Section = 0 L_0096: X = V; S = // 6018 Assemble(Var(0), -16, 0, Base Local, 0, J) {Var(0) is a dummy} 0; // 6019 L_0097: S = S + BITS[X & // 6020 Dump Encoded(Entry Point) 15]; X = (unsigned int)X >> 4; // 6021 Dump Encoded(Control) if (X == 0) goto L_0098; goto L_0097; L_0098: // 6022 Dump Encoded(Min SB) C = 3; // 6023 if (S <= 16) goto L_0099; C = 4; V = (~V); L_0099: // 6024 Interface_Ref Count = Refs if (V == 0) goto L_009A; SH = // 6025 Interface_Def Count = Free Label 16; // 6026 Interface_Block Count = Blocks L_009B: if (V & 3 != 0) goto L_009C; SH = SH - 1; V = (unsigned int)V >> 2; goto L_009B; L_009C: // 6027 Interface_External Count = External No C = SH & 15; C = V & 255; V = (unsigned int)V >> 8; // 6028 Interface_Global Size = Own Base C = 0; C = 0; // 6029 Interface_Global Array Size = Own Array Base if (V == 0) goto L_009D; SH = SH - // 6030 Interface_Constant Size = Constant Base 4; // 6031 L_009E: if (V & 3 != 0) goto L_009F; SH = SH - 1; V = (unsigned int)V >> 2; goto L_009E; L_009F: // 6032 %begin {get rid of heap objects} C = SH & 15; C = V & 255; V = (unsigned int)V >> 8; // 6033 %routine Monitor(%string(255) Text) L_009D: // 6034 Select Output(Report) L_009A: // 6035 Printstring(Text); Newline if (V == 0) goto L_00A0; C = 5; L_00A0: // 6036 %end } /* CHARACTERISECONSTANT */ // 6037 void NOWINREGISTER(struct STACKFM * V, int R, int INHERIT) { // 6038 if (INHERIT == 0) goto L_00A1; REMEMBER(R, &V); L_00A1: // 6039 %record(Vvfm)%name V if (&V == NIL) goto L_00A2; // 6040 Monitor("Dispose Vars") %if Diag&MonLine # 0 RELEASEANDDROP(&V); V = NIL; // 6041 %while Var List ## NIL %cycle L_00A2: // 6042 V == Var List; Var List == Var List_Link if (&V == NIL) goto L_00A3; // 6043 DISPOSE(V) RELEASEANDDROP(&V); V = NIL; // 6044 %repeat L_00A3: // 6045 RELEASE(V); // 6046 %record(Knowfm)%name K V = 0; V = R; V = 0; V = RTYPE[R]; // 6047 Monitor("Dispose Kasl") %if Diag&MonLine # 0 CLAIM(R); // 6048 %while Kasl ## Nil %cycle } /* NOWINREGISTER */ // 6049 K == Kasl; Kasl == Kasl_Link void SIMPLELOAD(struct STACKFM * V, int R) { // 6050 DISPOSE(K) struct STACKFM *W; struct STACKFM *B1; struct STACKFM *B2; // 6051 %repeat struct CONSTFM C; // 6052 int P; int N; int X; int T; int CHECK; // 6053 %record(Ilabelfm)%name I OPTIMISE(&V, 1); // 6054 Monitor("Dispose Labels") %if Diag&MonLine # 0 if (!(INREG(&V))) goto L_00A4; // 6055 %while Ilabel List ## NIL %cycle if (V == R) goto L_00A5; if (R != 17) goto L_00A6; if (V <= 17) goto L_00A5; L_00A6: if (R != 26) goto L_00A7; if (V < 18) goto L_00A7; L_00A5: return; L_00A7: // 6056 I == Ilabel List; Ilabel List == I_Link L_00A4: // 6057 DISPOSE(I) if (R != 17) goto L_00A8; R = GPR(); goto L_00A9; L_00A8: if (R != 26) goto L_00AA; R = FPR(); L_00AA: L_00A9: // 6058 %repeat if (V != R) goto L_0005; if (ACTIVITY[R] == 1) goto L_00AB; L_0005: HAZARD(R); L_00AB: // 6059 SIMPLIFY(&V); // 6060 %record(WorkVfm)%name W1, W2 == Work List_Link if (R < 18) goto L_00AC; if (FLOATING(&V)) goto L_00AC; FLOAT(&V, R); return; L_00AC: // 6061 Monitor("Dispose Work") %if Diag&MonLine # 0 if (!(ICONST(&V))) goto L_00AD; // 6062 %while W2 ## NIL %cycle CHARACTERISECONSTANT(V, &C); // 6063 W1 == W2; W2 == W2_Link if (C.TYPE != 1) goto L_00AE; // 6064 DISPOSE(W1) PLANT1(27262976, 0, R, ROT(0, 0)); // 6065 %repeat goto L_00AF; L_00AE: if (C.TYPE != 2) goto L_00B0; // 6066 Monitor("Disposed") %if Diag&MonLine # 0 PLANT1(31457280, 0, R, ROT(0, 0)); // 6067 %end goto L_00AF; L_00B0: if (C.TYPE != 3) goto L_00B1; // 6068 PLANT1(27262976, 0, R, ROT(C.V1, C.R1)); // 6069 %end if (C.V2 == 0) goto L_00B2; PLANT1(25165824, R, R, ROT(C.V2, C.R2)); L_00B2: // ?LASTAREA unused // ?LASTDIR unused // ?ICODE unused // ?ENTERPROC unused // ?REALINT unused // ?NEXTCH unused // ?READCH unused // ?REALINTPT unused // ?TESTREAL unused // ?PRIMMUL unused // ?TESTMOD unused // ?NILTEST unused // ?TRACELINE unused // ?ASSTEST unused // ?CAPTEST unused // ?RTMONITOR unused // ?AREF unused // ?ROTX unused // ?CALLIT unused // ?INTERNAL unused // ?LINK unused // ?SL unused // ?IP unused // ?D68000 unused // 6070 goto L_00AF; L_00B1: if (C.TYPE != 4) goto L_00B3; // 6071 %endoffile PLANT1(31457280, 0, R, ROT(C.V1, C.R1)); // // 8175 Statements compiled if (C.V2 == 0) goto L_00B4; PLANT1(2097152, R, R, ROT(C.V2, C.R2)); L_00B4: goto L_00AF; L_00B3: CONSTANTBASE = CONSTANTBASE + 3 & (~3); W = LITERAL(CONSTANTBASE); W->FORM = 1; W->AREA = 512; SELECTCONSTANTAREA(); DUMPWORD(C.N); SELECTCODEAREA(); DIR3(11, ACTUAL[R], CONSTANTBASE - 4); FORGET(R); REFS = REFS + 1; *CA = *CA + 4; RELEASEANDDROP(W); L_00AF: NOWINREGISTER(&V, R, 1); goto L_00B5; L_00AD: if (V != 0) goto L_00B6; if (!(INREG(&V))) goto L_00B7; if (V < 6) goto L_00B8; PLANT9(234914176, 0, R, V); goto L_00B9; L_00B8: PLANT1(27262976, 0, R, JUST(V)); L_00B9: NOWINREGISTER(&V, R, 1); return; L_00B7: if (V < 6) goto L_00BA; STOREREALCONSTANT(&V); DIR4(12, ACTUAL[R], V, 1); FORGET(R); REFS = REFS + 1; *CA = *CA + 4; REMEMBER(R, &V); NOWINREGISTER(&V, R, 1); return; L_00BA: if (V != 512) goto L_00BB; DIR3(10, ACTUAL[R], V); FORGET(R); REFS = REFS + 1; *CA = *CA + 4; NOWINREGISTER(&V, R, 1); return; L_00BB: if (&V == NIL) goto L_00BC; if (&V == NIL) goto L_00BD; if (V != 0) goto L_00BD; LOADUP(&V); V = V; DROP(&V); V = NIL; L_00BD: if (V != 0) goto L_00BE; NOTINYET(); L_00BE: P = POWER(V); if (P < 0) goto L_00BF; LOADUP(&V); PLANT1(8388608, V, R, ISHIFT(V, P, 0)); goto L_00C0; L_00BF: OPERATE(6, &V, LITERAL(V)); LOADUP(&V); V = 1; PLANT1(8388608, V, R, JUST(V)); L_00C0: if (V <= 0) goto L_00C1; CHARACTERISECONSTANT(V, &C); if (C.TYPE != 3) goto L_00C2; PLANT1(8388608, R, R, ROT(C.V1, C.R1)); if (C.V2 == 0) goto L_00C3; PLANT1(8388608, R, R, ROT(C.V2, C.R2)); L_00C3: goto L_00C4; L_00C2: if (C.TYPE != 5) goto L_00C5; U_1000: CONSTANTBASE = CONSTANTBASE + 3 & (~3); SELECTCONSTANTAREA(); DUMPWORD(V); SELECTCODEAREA(); X = GPR(); DIR3(11, ACTUAL[X], CONSTANTBASE - 4); FORGET(X); REFS = REFS + 1; *CA = *CA + 4; PLANT1(8388608, V, R, JUST(X)); goto L_00C4; L_00C5: FAIL(_imp_str_literal("Bad displacement")); L_00C4: goto L_00C6; L_00C1: if (V >= 0) goto L_00C7; CHARACTERISECONSTANT(-V, &C); if (C.TYPE != 3) goto L_00C8; PLANT1(4194304, R, R, ROT(C.V1, C.R1)); if (C.V2 == 0) goto L_00C9; PLANT1(4194304, R, R, ROT(C.V2, C.R2)); L_00C9: goto L_00CA; L_00C8: if (C.TYPE != 5) goto L_00CB; W = LITERAL(V); W->FORM = 1; W->BASE = 16; LOADUP(W); PLANT1(4194304, R, R, JUST(W->BASE)); RELEASEANDDROP(W); goto L_00CA; L_00CB: goto U_1000; L_00CA: L_00C7: L_00C6: goto L_00CC; L_00BC: N = V; P = 8388608; if (N >= 0) goto L_00CD; N = -N; P = 4194304; L_00CD: CHARACTERISECONSTANT(N, &C); if (C.TYPE != 1) goto L_00CE; PLANT1(27262976, 0, R, JUST(V)); goto L_00CF; L_00CE: if (C.TYPE != 3) goto L_00D0; PLANT1(P, V, R, ROT(C.V1, C.R1)); if (C.V2 == 0) goto L_00D1; PLANT1(P, R, R, ROT(C.V2, C.R2)); L_00D1: goto L_00CF; L_00D0: if (C.TYPE != 5) goto L_00D2; W = LITERAL(C.N); LOADUP(W); PLANT1(P, V, R, JUST(W->BASE)); RELEASEANDDROP(W); goto L_00CF; L_00D2: FAIL(_imp_str_literal("negate error")); L_00CF: L_00CC: NOWINREGISTER(&V, R, 1); goto L_00B5; L_00B6: if (V != 1) goto L_00D3; CHECK = V & 1048576; if (UNASSIGNED == 0) goto L_00D4; if (V & 128 == 0) goto L_00D5; L_00D4: CHECK = 0; L_00D5: if (V == 0) goto L_00D6; if (V != 512) goto L_00D7; if (V != 1) goto L_00D8; DIR3(11, ACTUAL[R], V); goto L_00D9; L_00D8: if (V != 7) goto L_00DA; DIR4(12, ACTUAL[R], V, 1); goto L_00D9; L_00DA: if (V != 6) goto L_00DB; DIR4(12, ACTUAL[R], V, 0); goto L_00D9; L_00DB: if (V == 4) goto L_00DC; if (V != 2) goto L_00DD; L_00DC: T = V; AMAP(&V); LOAD(&V, R); V = T; V = 1; LOAD(&V, R); return; L_00DD: FAIL(_imp_str_literal("Bad constant type")); L_00D9: REFS = REFS + 1; *CA = *CA + 4; FORGET(R); NOWINREGISTER(&V, R, 1); return; L_00D7: if (V >= 0) goto L_00DE; if (V == 1) goto L_00DF; FAIL(_imp_str_literal("Bad external spec type")); L_00DF: DIR3(13, ACTUAL[R], -V); FORGET(R); REFS = REFS + 1; *CA = *CA + 4; NOWINREGISTER(&V, R, 1); return; L_00DE: L_00D6: if (V != 4) goto L_00E0; PLANT2(68157440, R, &V); NOWINREGISTER(&V, R, 1); if (CHECK == 0) goto L_00E1; PLANT1(22020096 | 1048576, R, 0, IMMEDIATE(128)); TESTASSIGNED(); L_00E1: goto L_00E2; L_00E0: if (V != 2) goto L_00E3; SIMPLIFY(&V); if (&V != NIL) goto L_00E4; if (&V == NIL) goto L_00E5; L_00E4: LOADUPADDRESS(&V); V = 2; V = 1; L_00E5: B1 = COPY(&V); ADVANCE(B1, 4, 0); B2 = COPY(&V); ADVANCE(B2, 4, 1); B1->FLAGS = B1->FLAGS | 128; B2->FLAGS = B2->FLAGS | 128; LOAD(B2, 15); LOAD(B1, R); LOADUP(B2); if (CHECK == 0) goto L_00E6; PLANT1(22020096 | 1048576, B1->BASE, 0, IMMEDIATE(128)); PLANT1(22020096 | 1048576 | -536870912, B2->BASE, 0, IMMEDIATE(128)); TESTASSIGNED(); L_00E6: PLANT1(27262976, 0, B2->BASE, ISHIFT(B2->BASE, 24, 0)); PLANT1(25165824, B1->BASE, R, ISHIFT(B2->BASE, 16, 64)); RELEASEANDDROPPAIR(B1, B2); NOWINREGISTER(&V, R, 1); goto L_00E2; L_00E3: if (V != 6) goto L_00E7; PLANT6(202375424, R, &V); NOWINREGISTER(&V, R, 1); if (CHECK == 0) goto L_00E8; B1 = LITERAL(0); B1->TYPE = 7; B1->FORM = 1; B1->BASE = 10; LOADUP(B1); RELEASEANDDROP(B1); PLANT8(244379920, B1->BASE, R); TESTASSIGNED(); L_00E8: goto L_00E2; L_00E7: if (V != 7) goto L_00E9; PLANT6(202408192, R, &V); NOWINREGISTER(&V, R, 1); if (CHECK == 0) goto L_00EA; B1 = LITERAL(0); B1->TYPE = 7; B1->FORM = 1; B1->BASE = 10; LOADUP(B1); RELEASEANDDROP(B1); PLANT8(244379920, B1->BASE, R); TESTASSIGNED(); L_00EA: goto L_00E2; L_00E9: PLANT2(68157440, R, &V); NOWINREGISTER(&V, R, 1); if (CHECK == 0) goto L_00EB; B1 = LITERAL(0); B1->FORM = 1; B1->BASE = 10; LOADUP(B1); RELEASEANDDROP(B1); PLANT1(22020096 | 1048576, B1->BASE, 0, JUST(R)); TESTASSIGNED(); L_00EB: L_00E2: goto L_00B5; L_00D3: if (V != 3) goto L_00EC; PLANT2(68157440, R, &V); FORGET(V); NOWINREGISTER(&V, R, 1); goto L_00B5; L_00EC: if (V != 2) goto L_00ED; PLANT2(68157440, R, &V); FORGET(V); NOWINREGISTER(&V, R, 1); goto L_00B5; L_00ED: FAIL(_imp_str_literal("Unknown type for LOAD")); L_00B5: } /* SIMPLELOAD */ void MULTIPLY(struct STACKFM * V, struct STACKFM * W, int R) { void CMUL(int FROM, int TO, int BY) { int X; int OP; int WITH; int T; if (BY & 1 != 0) goto L_00EE; OP = 27262976; WITH = 0; goto L_00EF; L_00EE: if (BY & 3 != 1) goto L_00F0; OP = 8388608; WITH = FROM; goto L_00EF; L_00F0: BY = BY + 1; OP = 6291456; WITH = FROM; L_00EF: X = 0; L_00F1: X = X + 1; BY = (unsigned int)BY >> 1; if (BY & 1 != 0) goto L_00F2; goto L_00F1; L_00F2: if (BY != 1) goto L_00F3; T = FROM; goto L_00F4; L_00F3: T = GPR(); CMUL(FROM, T, BY); L_00F4: PLANT1(OP, WITH, TO, ISHIFT(T, X, 0)); } /* CMUL */ int L; int INV; struct STACKFM *Z; if (!(ICONST(W))) goto L_00F5; LOADSAFELY(&V, *R); if (W->DISP != 0) goto L_00F6; FAIL(_imp_str_literal("Zero multiply")); L_00F6: CMUL(V, V, W->DISP); goto L_00F7; L_00F5: OPTIMISE(&V, 1); OPTIMISE(W, 1); Z = LITERAL(0); if (*R == 17) goto L_00F8; if (*R == 26) goto L_00F8; if (ACTIVITY[*R] == 0) goto L_00F9; L_00F8: LOADPROTECTED(Z); goto L_00FA; L_00F9: LOAD(Z, *R); L_00FA: LOADPROTECTED(&V); LOADPROTECTED(W); INV = INVERT; INVERT = 0; L = NEWLABEL(); DEFINELABEL(L); PLANT1(27262976 | 1048576, 0, W->BASE, ISHIFT(W->BASE, 1, 32)); PLANT1(8388608 | -1073741824, Z->BASE, Z->BASE, JUST(V)); PLANT1(27262976, 0, V, ISHIFT(V, 1, 0)); JUMPTO(L, 6); RELEASE(V); V = Z->BASE; DROP(Z); LOAD(&V, *R); INVERT = INV; L_00F7: RELEASEANDDROP(W); } /* MULTIPLY */ void DIVIDE(struct STACKFM * V, struct STACKFM * W, int R, int Q, int U) { int P; int L; int OP; if (Q == 0) goto L_00FB; if (U != 0) goto L_00FC; L_00FB: if (!(ICONST(W))) goto L_00FC; P = POWER(W->DISP); if (P <= 0) goto L_00FD; if (U != 0) goto L_00FE; if (Q != 0) goto L_00FF; W->DISP = P; OP = 15; goto L_0100; L_00FF: W->DISP = ~(-1 << P); OP = 9; L_0100: OPERATE(OP, V, W); LOAD(V, R); return; L_00FE: if (P > 8) goto L_0101; LOADSAFELY(V, R); PLANT1(22020096 | 1048576, V->BASE, 0, NOTHING()); L = NEWLABEL(); JUMPTO(L, 5); PLANT1(8388608, V->BASE, V->BASE, ROT(W->DISP - 1, 0)); DEFINELABEL(L); PLANT1(27262976, 0, V->BASE, ISHIFT(V->BASE, P, 64)); DROP(W); return; L_0101: L_00FD: L_00FC: if (U != 0) goto L_0102; OP = 49; goto L_0103; L_0102: OP = 38; L_0103: LOADSAFELY(V, 2); LOADPAIR(V, 2, W, 3); PRIM(OP); if (Q != 0) goto L_0104; RELEASE(2); CLAIM(1); V->BASE = 1; L_0104: LOAD(V, R); RELEASEANDDROP(W); } /* DIVIDE */ void COMPLEXLOAD(struct STACKFM * V, int R) { static const void *C[29] = { &&case_C_1, &&case_C_2, &&case_C_3, &&case_C_4, &&case_C_5, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_9, &&case_C_10, &&case_C_11, &&case_C_12, &&case_C_default, &&case_C_14, &&case_C_15, &&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_default, &&case_C_default, &&case_C_default, &&case_C_default}; static const void *C2[29] = { &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_4, &&case_C2_5, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_9, &&case_C2_10, &&case_C2_11, &&case_C2_12, &&case_C2_default, &&case_C2_14, &&case_C2_15, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default, &&case_C2_default}; const int REALOP[7] = {235962752, 237011328, 234881408, 236978560, 235929984, 239075712, 241172864}; struct STACKFM *W; struct STACKFM *B; struct CONSTFM CX; int OPER; int OP; int REG2; int N; int PA; W = &V->LINK; V->LINK = NIL; OPER = V->OPER; V->OPER = 0; if (OPER >= 23) goto L_0105; if (R < 18) goto L_0106; L_0105: if (R > 17) goto L_0107; FAIL(_imp_str_literal("real load?")); L_0107: if (OPER != 29) goto L_0108; LOADSAFELY(V, 18); LOADPAIR(V, 18, W, 1); PRIM(6); RELEASEANDDROP(W); LOAD(V, R); return; L_0108: if (OPER >= 23) goto L_0109; V->LINK = W; V->OPER = OPER; LOAD(V, 17); LOAD(V, R); return; L_0109: LOADSAFELY(V, R); OP = REALOP[OPER]; if (W != NIL) goto L_010A; PLANT9(OP, 0, V->BASE, V->BASE); goto L_010B; L_010A: if (!(ICONST(W))) goto L_010C; if (0 > W->DISP) goto L_010D; if (W->DISP <= 5) goto L_010E; L_010D: if (W->DISP != 10) goto L_010C; L_010E: REG2 = W->DISP; if (REG2 != 10) goto L_010F; REG2 = 7; L_010F: OP = OP | 8; goto L_0110; L_010C: LOAD(W, 26); REG2 = W->BASE; L_0110: PLANT9(OP, V->BASE, V->BASE, REG2); L_010B: goto U_1001; L_0106: if (OPER != 8) goto L_0111; LOADSAFELY(V, 2); LOADPAIR(V, 2, W, 3); PRIM(5); RELEASEANDDROP(W); LOAD(V, R); return; L_0111: if (OPER != 17) goto L_0112; LOADSAFELY(V, 2); LOADPAIR(V, 2, W, 3); PRIM(42); RELEASEANDDROP(W); return; L_0112: if (OPER != 6) goto L_0113; MULTIPLY(V, W, R); return; L_0113: if (OPER != 7) goto L_0114; DIVIDE(V, W, R, 0, 1); return; L_0114: if (OPER != 16) goto L_0115; DIVIDE(V, W, R, 1, 1); return; L_0115: if (OPER != 19) goto L_0116; DIVIDE(V, W, R, 0, 0); return; L_0116: if (OPER != 20) goto L_0117; DIVIDE(V, W, R, 1, 0); return; L_0117: if (OPER != 5) goto L_0118; if (!(ICONST(V))) goto L_0118; CHARACTERISECONSTANT(V->DISP, &CX); if (CX.TYPE != 3) goto L_0119; LOAD(W, R); R = W->BASE; PLANT1(6291456, W->BASE, R, ROT(CX.V1, CX.R1)); if (CX.V2 == 0) goto L_011A; PLANT1(8388608, R, R, ROT(CX.V2, CX.R2)); L_011A: goto U_1002; L_0119: if (CX.TYPE != 2) goto L_011B; LOADSAFELY(W, R); R = W->BASE; PLANT1(31457280, 0, R, JUST(W->BASE)); U_1002: V->BASE = R; V->DISP = 0; W->BASE = 0; goto U_1001; L_011B: L_0118: if (PENDINGAUTO == 0) goto L_011C; if (OPER != 4) goto L_011C; if (!(ICONST(W))) goto L_011C; if (-4095 > W->DISP) goto L_011C; if (W->DISP > 4095) goto L_011C; PA = PENDINGAUTO; OPTIMISE(V, 1); if (!(INREG(V))) goto L_011D; if (V->BASE != PA) goto L_011D; if (PENDINGAUTON == 0) goto L_011E; if (_imp_IMOD((unsigned int)W->DISP >> 2) > 255) goto L_011D; L_011E: DIR3(16, *CA - PENDINGAUTOCA, (unsigned int)W->DISP >> PENDINGAUTON); FORGET(PA); DROP(W); LOADSAFELY(V, R); return; L_011D: L_011C: if (V->TYPE != 2) goto L_011F; if (OPER == 9) goto L_0120; if (OPER != 12) goto L_011F; L_0120: if (!(ICONST(W))) goto L_011F; N = W->DISP; if (OPER != 12) goto L_0121; N = (~N); L_0121: if ((unsigned int)N >> 16 != 0) goto L_0122; RELEASEANDDROP(W); if (N > 255) goto L_0123; ADVANCE(V, 4, 0); if (N == 255) goto L_0124; OPERATE(9, V, LITERAL(N)); L_0124: LOAD(V, R); goto L_0125; L_0123: if (N & 255 != 0) goto L_0126; V->OPER = 0; V->LINK = 0; ADVANCE(V, 4, 1); if ((unsigned int)N >> 8 == 255) goto L_0127; OPERATE(9, V, LITERAL((unsigned int)N >> 8)); L_0127: OPERATE(14, V, LITERAL(8)); LOAD(V, R); goto L_0125; L_0126: B = COPY(V); ADVANCE(B, 4, 1); if ((unsigned int)N >> 8 == 255) goto L_0128; OPERATE(9, B, LITERAL((unsigned int)N >> 8)); L_0128: ADVANCE(V, 4, 0); if (N & 255 == 255) goto L_0129; OPERATE(9, V, LITERAL(N & 255)); L_0129: LOADUP(B); LOADSAFELY(V, R); LOADUP(B); LOADSAFELY(V, R); PLANT1(25165824, V->BASE, V->BASE, ISHIFT(B->BASE, 8, 0)); RELEASEANDDROP(B); L_0125: return; L_0122: L_011F: LOADSAFELY(V, R); R = V->BASE; if (W == NIL) goto L_012A; if (!(ICONST(W))) goto L_012B; if (OPER != 21) goto L_012C; PLANT1(27262976, 0, R, ISHIFT(V->BASE, W->DISP & 65535, 32)); N = -1 << ((unsigned int)W->DISP >> 16); PLANT1(0, R, R, IMMEDIATE((~N))); goto U_1001; L_012C: if (OPER != 9) goto L_012D; if (IMMEDIATE(W->DISP) >= 0) goto L_012D; OPER = 12; W->DISP = (~W->DISP); L_012D: CHARACTERISECONSTANT(W->DISP, &CX); if (CX.TYPE != 2) goto L_012E; if (OPER != 4) goto L_012F; PLANT1(4194304, V->BASE, R, ROT(1, 0)); goto U_1001; L_012F: if (OPER != 5) goto L_0130; PLANT1(8388608, V->BASE, R, ROT(1, 0)); goto U_1001; L_0130: if (OPER != 11) goto L_0131; PLANT1(31457280, 0, R, JUST(V->BASE)); goto U_1001; L_0131: goto L_0132; L_012E: if (CX.TYPE != 3) goto L_0133; goto *C2[OPER - 1]; /*TO DO*/ case_C2_4:; OP = 8388608; goto U_1003; case_C2_5:; OP = 4194304; goto U_1003; case_C2_12:; OP = 29360128; goto U_1003; case_C2_10:; OP = 25165824; goto U_1003; case_C2_11:; OP = 2097152; goto U_1003; case_C2_9:; if (CX.V2 != 0) goto L_0135; OP = 0; goto U_1003; L_0135: goto U_1004; U_1003: PLANT1(OP, V->BASE, R, ROT(CX.V1, CX.R1)); if (CX.V2 == 0) goto L_0136; PLANT1(OP, R, R, ROT(CX.V2, CX.R2)); L_0136: goto U_1001; case_C2_14:; if ((unsigned int)W->DISP >> 5 == 0) goto L_0137; WARN(1, _imp_str_literal("Dubious shift")); L_0137: PLANT1(27262976, 0, R, ISHIFT(V->BASE, W->DISP & 31, 0)); goto U_1001; case_C2_15:; if ((unsigned int)W->DISP >> 5 == 0) goto L_0138; WARN(1, _imp_str_literal("Dubious shift")); L_0138: PLANT1(27262976, 0, R, ISHIFT(V->BASE, W->DISP & 31, 32)); goto U_1001; L_0133: if (CX.TYPE != 4) goto L_0139; CHARACTERISECONSTANT(-W->DISP, &CX); if (CX.TYPE == 3) goto L_013A; goto U_1004; L_013A: if (OPER != 4) goto L_013B; OP = 4194304; goto U_1003; L_013B: if (OPER != 5) goto L_013C; OP = 8388608; goto U_1003; L_013C: if (OPER == 15) goto L_013D; if (OPER != 14) goto L_013E; L_013D: WARN(1, _imp_str_literal("Dubious shift")); L_013E: L_0139: L_0132: L_012B: L_012A: U_1004: case_C2_default:; if (W == NIL) goto L_013F; LOADUP(W); L_013F: goto *C[OPER - 1]; /*TO DO*/ case_C_1:; PLANT1(31457280, 0, R, JUST(V->BASE)); goto U_1005; case_C_2:; PLANT1(6291456, V->BASE, R, NOTHING()); goto U_1005; case_C_3:; PLANT1(8388608 | 1048576, R, R, NOTHING()); { /*%begin*/ int LABEL; LABEL = NEWLABEL(); JUMPTO(LABEL, 5); PLANT1(6291456, R, R, NOTHING()); DEFINELABEL(LABEL); } goto U_1005; case_C_4:; PLANT1(8388608, V->BASE, R, JUST(W->BASE)); goto U_1001; case_C_5:; PLANT1(4194304, V->BASE, R, JUST(W->BASE)); goto U_1001; case_C_12:; PLANT1(29360128, V->BASE, R, JUST(W->BASE)); goto U_1001; case_C_9:; PLANT1(0, V->BASE, R, JUST(W->BASE)); goto U_1001; case_C_10:; PLANT1(25165824, V->BASE, R, JUST(W->BASE)); goto U_1001; case_C_11:; PLANT1(2097152, V->BASE, R, JUST(W->BASE)); goto U_1001; case_C_14:; PLANT1(27262976, 0, R, RSHIFT(V->BASE, W->BASE, 144)); goto U_1001; case_C_15:; PLANT1(27262976, 0, R, RSHIFT(V->BASE, W->BASE, 176)); goto U_1001; case_C_default:; NOTINYET(); U_1001: if (W == NIL) goto L_0141; RELEASEANDDROP(W); L_0141: U_1005: } /* COMPLEXLOAD */ void LOAD(struct STACKFM * V, int R) { if (V->OPER != 0) goto L_0142; SIMPLELOAD(V, R); goto L_0143; L_0142: COMPLEXLOAD(V, R); L_0143: if (DIAG & 32 == 0) goto L_0144; MONITOR(V, _imp_str_literal("<-Load")); L_0144: } /* LOAD */ void LOADPAIR(struct STACKFM * A, int AR, struct STACKFM *B, int BR) { if (B != 0) goto L_0145; if (&B != NIL) goto L_0145; if (&B == NIL) goto L_0146; L_0145: LOAD(&B, BR); LOAD(A, AR); LOAD(&B, BR); goto L_0147; L_0146: LOAD(A, AR); LOAD(&B, BR); LOAD(A, AR); L_0147: } /* LOADPAIR */ void LOADTRIO(struct STACKFM * A, int AR, struct STACKFM *B, int BR, struct STACKFM *C, int CR) { if (B != 0) goto L_0148; if (&B != NIL) goto L_0148; if (&B == NIL) goto L_0149; L_0148: LOAD(&B, BR); LOADPAIR(A, AR, &C, *CR); goto L_014A; L_0149: if (C != 0) goto L_014B; if (&C != NIL) goto L_014B; if (&C == NIL) goto L_014C; L_014B: LOAD(&C, BR); LOADPAIR(A, AR, &B, BR); goto L_014A; L_014C: LOAD(A, AR); LOADPAIR(&B, BR, &C, *CR); L_014A: LOAD(A, AR); LOAD(&B, BR); LOAD(&C, *CR); } /* LOADTRIO */ void REPEAT(void BODY(void), struct STACKFM *TIMES, int INC, int HOW) { int LABEL; if (!(ICONST(&TIMES))) goto L_014D; if (TIMES > 0) goto L_014D; return; L_014D: LOADUP(&TIMES); LABEL = NEWLABEL(); DEFINELABEL(LABEL); BODY(); PLANT1(4194304 | 1048576, TIMES, TIMES, IMMEDIATE(INC)); JUMPTO(LABEL, HOW); if (HOW != 6) goto L_014E; REMEMBERZERO(TIMES); L_014E: RELEASEANDDROP(&TIMES); } /* REPEAT */ int CHEAPEST(int LOW, int HIGH) { int R; int A; int U; int MINACTIVITY; int MINKNOWN; int MINREG; int OLDEST; MINACTIVITY = 1000; MINKNOWN = 1000; MINREG = 0; USEDTIME = USEDTIME + 1; OLDEST = USEDTIME; R = LOW - 1; /*%for R = LOW, 1, HIGH %cycle*/ L_014F: if (R == HIGH) goto L_0150; R += 1; A = ACTIVITY[R]; if (A >= 0) goto L_0152; goto L_0151; L_0152: U = USED[R]; if (A != MINACTIVITY) goto L_0153; if (MINKNOWN <= KTIMES[R]) goto L_0154; MINREG = R; MINKNOWN = KTIMES[R]; OLDEST = U; goto L_0155; L_0154: if (MINKNOWN != KTIMES[R]) goto L_0156; if (OLDEST <= U) goto L_0157; MINREG = R; OLDEST = U; L_0157: L_0156: L_0155: goto L_0158; L_0153: if (A >= MINACTIVITY) goto L_0159; MINACTIVITY = A; MINREG = R; MINKNOWN = KTIMES[R]; OLDEST = U; L_0159: L_0158: L_0151: goto L_014F; L_0150: if (MINREG != 0) goto L_015A; FAIL(_imp_str_literal("all registers lost")); L_015A: USED[MINREG] = USEDTIME; if (MINACTIVITY == 0) goto L_015B; HAZARD(MINREG); L_015B: return MINREG; } /* CHEAPEST */ int GPR(void) { return CHEAPEST(1, 9); } /* GPR */ int FPR(void) { return CHEAPEST(18, 25); } /* FPR */ struct STACKFM *REGISTER(int REG) { struct STACKFM *R; R = DESCRIPTOR(); if (REG != 17) goto L_015C; R->TYPE = 1; REG = CHEAPEST(1, 9); goto L_015D; L_015C: if (REG != 26) goto L_015E; R->TYPE = 7; REG = CHEAPEST(18, 25); goto L_015D; L_015E: R->TYPE = 1; if (REG < 18) goto L_015F; R->TYPE = 7; L_015F: L_015D: R->BASE = REG; CLAIM(REG); return R; } /* REGISTER */ int LOCKED(int R) { if (*R >= 128) goto L_0160; if (*R == 0) goto L_0160; if (ACTIVITY[*R] >= 0) goto L_0161; L_0160: return 1 /*TRUE*/; L_0161: return 0 /*FALSE*/; } /* LOCKED */ int PROPERLYALIGNED(struct STACKFM * V, int MASK) { if (V != 13) goto L_0162; return 1 /*TRUE*/; L_0162: if (V != 9) goto L_0163; if (V < 0) goto L_0164; return 0 /*FALSE*/; L_0164: if (VAR(-V)->DISP != 3) goto L_0165; return 1 /*TRUE*/; L_0165: L_0163: if (LOCKED(V)) goto L_0166; return 0 /*FALSE*/; L_0166: if (V != 1) goto L_0167; if (&V != NIL) goto L_0167; if (&V != NIL) goto L_0167; if (V & MASK != 0) goto L_0167; return 1 /*TRUE*/; L_0167: return 0 /*FALSE*/; } /* PROPERLYALIGNED */ void SIMPLIFY(struct STACKFM * V) { int N; int D; struct STACKFM *R; struct STACKFM *X; if (DIAG & 16 == 0) goto L_0168; MONITOR(&V, _imp_str_literal("->Simplify")); L_0168: if (V == 0) goto L_0169; LOADUP(&V); goto U_1006; L_0169: if (&V == NIL) goto L_016A; if (V != 0) goto L_016B; if (V != 0) goto L_016B; if (V != 0) goto L_016B; if (&V != NIL) goto L_016B; R = &V; V = R->DATA; R->INDEX = NIL; R->RECORD = NIL; DROP(R); SIMPLIFY(&V); goto U_1006; L_016B: SIMPLIFY(&V); if (&V != NIL) goto L_016C; if (V != 0) goto L_016C; if (V == 0) goto L_016D; L_016C: LOADUP(&V); L_016D: V = V + V; V = 0; if (V != 0) goto L_016E; DROP(&V); V = NIL; goto L_016F; L_016E: if (V != 0) goto L_0170; V = V; DROP(&V); V = NIL; goto L_016F; L_0170: if (&V != NIL) goto L_0171; V = &V; V = 1; V = NIL; goto L_016F; L_0171: OPERATE(4, &V, &V); V = NIL; L_016F: L_016A: if (&V == NIL) goto L_0172; SIMPLIFY(&V); if (V != 512) goto L_0173; X = LITERAL(V); V = 0; X->AREA = 512; V = 0; LOADUP(X); if (V != 0) goto L_0174; V = X->BASE; DROP(X); goto L_0175; L_0174: OPERATE(6, &V, LITERAL(V)); V = 1; OPERATE(4, &V, X); L_0175: goto L_0176; L_0173: N = POWER(V); if (N >= 0) goto L_0177; OPERATE(6, &V, LITERAL(V)); V = 1; LOADUP(&V); L_0177: L_0176: if (V == 0) goto L_0178; if (V == 1) goto L_0179; OPERATE(6, &V, LITERAL(V)); V = 1; L_0179: OPERATE(4, &V, LITERAL(V)); V = 0; LOADUP(&V); L_0178: L_0172: void ENSUREDISPLACEMENT(int D, int TYPE) { struct STACKFM *W; if (TYPE != 1) goto L_017A; if (-4095 > D) goto L_017B; if (D > 4095) goto L_017B; return; L_017B: goto L_017C; L_017A: if (D & 3 == 0) goto L_017D; FAIL(_imp_str_literal("real address error")); L_017D: if (-255 > ((long)D / (long)4)) goto L_017E; if (((long)D / (long)4) > 255) goto L_017E; return; L_017E: L_017C: V = 0; W = LITERAL(D); LOADUP(W); if (&V != NIL) goto L_017F; V = W; V = 1; goto L_0180; L_017F: if (V == 1) goto L_0181; OPERATE(6, &V, LITERAL(V)); V = 1; L_0181: OPERATE(4, &V, W); L_0180: SIMPLIFY(&V); } /* ENSUREDISPLACEMENT */ D = V; if (!(ICONST(&V))) goto L_0182; if (0 > D) goto L_0183; if (D > 255) goto L_0183; V = 4; goto L_0184; L_0183: if (-32768 > D) goto L_0185; if (D > 32767) goto L_0185; V = 2; L_0185: L_0184: goto L_0186; L_0182: if (V == 0) goto L_0187; if (V == 7) goto L_0188; if (V != 6) goto L_0189; L_0188: ENSUREDISPLACEMENT(D, 6); goto L_018A; L_0189: if (V > 5) goto L_018B; ENSUREDISPLACEMENT(D, 1); L_018B: L_018A: L_0187: L_0186: U_1006: if (DIAG & 16 == 0) goto L_018C; MONITOR(&V, _imp_str_literal("<-Simplify")); L_018C: } /* SIMPLIFY */ void APPLYINDEX(struct STACKFM * V, struct STACKFM * X, int XSIZE) { int N; int MULOP; if (!(ICONST(&X))) goto L_018D; if (V != 1) goto L_018D; N = V + X * *XSIZE; V = N; DROP(&X); return; L_018D: if (&V != NIL) goto L_018E; V = &X; V = *XSIZE; goto L_018F; L_018E: if (V != *XSIZE) goto L_0190; OPERATE(4, &V, &X); goto L_018F; L_0190: MULOP = 6; if (V == 1) goto L_0191; OPERATE(MULOP, &V, LITERAL(V)); L_0191: if (*XSIZE == 1) goto L_0192; OPERATE(MULOP, &X, LITERAL(*XSIZE)); L_0192: OPERATE(4, &V, &X); V = 1; L_018F: } /* APPLYINDEX */ void FIXUNITARYSTRING(struct STACKFM * V) { int LEN; int VAL; int AT; static int NULLADDRESS = -1; int LOCATE(int LEN, int CHAR) { int HERE; CONSTANTBASE = CONSTANTBASE + 3 & (~3); HERE = CONSTANTBASE; SELECTCONSTANTAREA(); DUMPBYTE(LEN); if (LEN == 0) goto L_0193; DUMPBYTE(*CHAR); L_0193: SELECTCODEAREA(); return HERE; } /* LOCATE */ if (V != 8) goto L_0194; if (V != 1) goto L_0194; if (NULLADDRESS >= 0) goto L_0195; NULLADDRESS = LOCATE(0, 0); L_0195: AT = NULLADDRESS; LEN = 1; goto L_0196; L_0194: if (V != 13) goto L_0197; BUILDSET(&V); return; L_0197: if (V > 5) goto L_0198; VAL = V & 255; if (VAL == V) goto L_0199; WARN(1, _imp_str_literal("string character out of range")); L_0199: AT = LOCATE(1, VAL); LEN = 2; goto L_0196; L_0198: FAIL(_imp_str_literal("bad tostring type")); L_0196: V = AT; V = 8; V = 1; V = 512; V = LEN; V = LEN; } /* FIXUNITARYSTRING */ void AMAP(struct STACKFM * V) { struct STACKFM *W; if (V != 0) goto L_019A; FIXUNITARYSTRING(&V); goto L_019B; L_019A: if (V == 0) goto L_019C; FAIL(_imp_str_literal("Amap:oper")); L_019C: L_019B: V = 1; if (V != 3) goto L_019D; return; L_019D: if (V != 4) goto L_019E; if (V & 1024 == 0) goto L_019F; HAZARD(14); FORGET(14); DIR2(19, V); REFS = REFS + 1; *CA = *CA + 4; V = 1; V = 0; V = 14; V = 0; V = 0; CLAIM(14); goto L_01A0; L_019F: if (V & 4 == 0) goto L_01A1; V = 1; V = 1; V = 0; goto L_01A0; L_01A1: if (V & 16777216 == 0) goto L_01A2; HAZARD(14); FORGET(14); DIR2(18, V); REFS = REFS + 1; *CA = *CA + 4; V = 1; V = 0; V = 14; V = 0; V = 0; CLAIM(14); goto L_01A0; L_01A2: FAIL(_imp_str_literal("cannot address local procedures")); L_01A0: goto L_01A3; L_019E: if (V == 1) goto L_01A4; FAIL(_imp_str_literal("Amap:form")); L_01A4: V = 0; if (&V == NIL) goto L_01A5; if (!(ICONST(&V))) goto L_01A5; V = V + V * V; DROP(&V); V = NIL; L_01A5: if (V != 0) goto L_01A6; if (&V != NIL) goto L_01A6; if (&V == NIL) goto L_01A6; W = &V; V = W->DATA; W->INDEX = NIL; W->RECORD = NIL; DROP(W); L_01A6: L_01A3: if (DIAG & 16 == 0) goto L_01A7; MONITOR(&V, _imp_str_literal("Amap<-")); L_01A7: } /* AMAP */ void MAKEAUTOI(struct STACKFM * V, int TYPE) { AMAP(&V); LOADPROTECTED(&V); V = *TYPE; V = 2; } /* MAKEAUTOI */ void VMAP(struct STACKFM * V, int NEWTYPE) { struct STACKFM *W; struct STACKFM *C; int D; D = 0; if (1 > V) goto L_01A8; if (V <= 5) goto L_01A9; L_01A8: FAIL(_imp_str_literal("Vmap:type")); L_01A9: if (V != 4) goto L_01AA; C = &V; if (!(ICONST(C))) goto L_01AB; D = C->DISP; DROP(C); V = NIL; V = 0; L_01AB: L_01AA: if (V == 0) goto L_01AC; LOADUP(&V); L_01AC: if (V == 0) goto L_01AD; W = DESCRIPTOR(); W->DATA = V; V = 0; V = W; V = D; L_01AD: V = INTERNALTYPE[*NEWTYPE]; V = 1; V = TYPEFMT[*NEWTYPE]; if (DIAG & 16 == 0) goto L_01AE; MONITOR(&V, _imp_str_literal("Vmap<-")); L_01AE: } /* VMAP */ void FMAP(int NEWTYPE) { if (!(INREG(STACK))) goto L_01AF; HAZARD(STACK->BASE); L_01AF: if (STACK->TYPE != 1) goto L_01B0; if (STACK->FORM != 0) goto L_01B1; L_01B0: FAIL(_imp_str_literal("Bad type for Fmap")); L_01B1: STACK->FORM = 4; STACK->TYPE = *NEWTYPE; STACK->FLAGS = STACK->FLAGS | 524288 | 4; } /* FMAP */ void ADVANCE(struct STACKFM * V, int TYPE, int BY) { int CHECKFLAG; if (V->FORM == 3) goto L_01B2; CHECKFLAG = V->FLAGS & 1048576; AMAP(V); OPERATE(4, V, LITERAL(*BY)); VMAP(V, *TYPE); V->FLAGS = V->FLAGS | CHECKFLAG; goto L_01B3; L_01B2: V->TYPE = *TYPE; L_01B3: } /* ADVANCE */ void MACHINECODE(void) { const _imp_string4 OPCODE[95] = { _imp_str_literal("ABS"), _imp_str_literal("ACS"), _imp_str_literal("ADC"), _imp_str_literal("ADD"), _imp_str_literal("ADF"), _imp_str_literal("AND"), _imp_str_literal("ASN"), _imp_str_literal("ATN"), _imp_str_literal("B"), _imp_str_literal("BAL"), _imp_str_literal("BCC"), _imp_str_literal("BCS"), _imp_str_literal("BEQ"), _imp_str_literal("BGE"), _imp_str_literal("BGT"), _imp_str_literal("BHI"), _imp_str_literal("BIC"), _imp_str_literal("BL"), _imp_str_literal("BLAL"), _imp_str_literal("BLCC"), _imp_str_literal("BLCS"), _imp_str_literal("BLE"), _imp_str_literal("BLEQ"), _imp_str_literal("BLGE"), _imp_str_literal("BLGT"), _imp_str_literal("BLHI"), _imp_str_literal("BLLE"), _imp_str_literal("BLLS"), _imp_str_literal("BLLT"), _imp_str_literal("BLMI"), _imp_str_literal("BLNE"), _imp_str_literal("BLNV"), _imp_str_literal("BLPL"), _imp_str_literal("BLS"), _imp_str_literal("BLT"), _imp_str_literal("BLVC"), _imp_str_literal("BLVS"), _imp_str_literal("BMI"), _imp_str_literal("BNE"), _imp_str_literal("BNV"), _imp_str_literal("BPL"), _imp_str_literal("BR"), _imp_str_literal("BVC"), _imp_str_literal("BVS"), _imp_str_literal("CMF"), _imp_str_literal("CMFE"), _imp_str_literal("CMN"), _imp_str_literal("CMP"), _imp_str_literal("CNF"), _imp_str_literal("CNFE"), _imp_str_literal("COS"), _imp_str_literal("DVF"), _imp_str_literal("EOR"), _imp_str_literal("EXP"), _imp_str_literal("FDV"), _imp_str_literal("FIX"), _imp_str_literal("FLT"), _imp_str_literal("FML"), _imp_str_literal("FRD"), _imp_str_literal("LDF"), _imp_str_literal("LDM"), _imp_str_literal("LDR"), _imp_str_literal("LGN"), _imp_str_literal("LOG"), _imp_str_literal("MNF"), _imp_str_literal("MOV"), _imp_str_literal("MUF"), _imp_str_literal("MVF"), _imp_str_literal("MVN"), _imp_str_literal("ORR"), _imp_str_literal("POL"), _imp_str_literal("POW"), _imp_str_literal("RDF"), _imp_str_literal("RFC"), _imp_str_literal("RFS"), _imp_str_literal("RMF"), _imp_str_literal("RND"), _imp_str_literal("RPW"), _imp_str_literal("RSB"), _imp_str_literal("RSC"), _imp_str_literal("RSF"), _imp_str_literal("SBC"), _imp_str_literal("SIN"), _imp_str_literal("SQT"), _imp_str_literal("STF"), _imp_str_literal("STM"), _imp_str_literal("STR"), _imp_str_literal("SUB"), _imp_str_literal("SUF"), _imp_str_literal("SWI"), _imp_str_literal("TAN"), _imp_str_literal("TEQ"), _imp_str_literal("TST"), _imp_str_literal("WFC"), _imp_str_literal("WFS")}; const unsigned char TYPE[95] = {10, 10, 1, 1, 10, 1, 10, 10, 5, 5, 5, 5, 5, 5, 5, 5, 1, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 9, 9, 1, 1, 9, 9, 10, 10, 1, 10, 10, 7, 7, 10, 10, 6, 4, 2, 10, 10, 10, 1, 10, 10, 1, 1, 10, 10, 10, 7, 7, 10, 10, 10, 1, 1, 10, 1, 10, 10, 6, 4, 2, 1, 10, 3, 10, 1, 1, 7, 7}; const int VALUE[95] = { 237011200, 247496960, 10485760, 8388608, 234881280, 0, 246448384, 248545536, -369098752, -369098752, 973078528, 704643072, 167772160, -1442840576, -905969664, -1979711488, 29360128, -352321536, -352321536, 989855744, 721420288, -637534208, 184549376, -1426063360, -889192448, -1962934272, -620756992, -1694498816, -1157627904, 1258291200, 452984832, -83886080, 1526726656, -1711276032, -1174405120, 2063597568, 1795162112, 1241513984, 436207616, -100663296, 1509949440, -369098752, 2046820352, 1778384896, 244379920, 248574224, 23068672, 20971520, 246477072, 250671376, 244351232, 239075584, 2097152, 242254080, 245367040, 235929872, 234881296, 244318464, 246415616, 202375424, 135266304, 68157440, 241205504, 240156928, 235962624, 27262976, 235929856, 234914048, 31457280, 25165824, 247464192, 241172736, 240124160, 240124176, 238027024, 243269888, 238059776, 242221312, 6291456, 14680064, 238027008, 12582912, 243302656, 239108352, 201326848, 134217728, 67108864, 4194304, 236978432, 251658240, 245399808, 18874368, 16777216, 239075600, 236978448}; int OPNUM; int OPTYPE; int OPVALUE; OPVALUE = 0; int OPLENGTH; int OPERANDS; int N; int J; int KEY; int P; int X; X = 0; int SYMP; int DISP; int RN; int RD; int RS; int RM; int SH; int ROT; int UD; int REG1; int REG2; int FDST; int FS1; int FS2; _imp_string7 OPSTRING; struct VARFM *W; static const void *OT[12] = {&&case_OT_M1, &&case_OT_missing, &&case_OT_1, &&case_OT_2, &&case_OT_3, &&case_OT_4, &&case_OT_5, &&case_OT_6, &&case_OT_7, &&case_OT_missing, &&case_OT_9, &&case_OT_10}; void MCERROR(_imp_string127 TEXT) { void ERR(int STREAM) { _imp_SELECTOUTPUT(STREAM); _imp_PRINTSTRING(_imp_str_literal("*")); _imp_WRITE(CURRENTLINE, 4); _imp_PRINTSTRING( _imp_join((_imp_string)(_imp_join( (_imp_string)(_imp_join((_imp_string)(_imp_str_literal(" ")), (_imp_string)(OPSTRING))), (_imp_string)(_imp_str_literal(": ")))), (_imp_string)(TEXT))); _imp_NEWLINE(); } /* ERR */ ERR(7); ERR(0); if (DIAG & 512 == 0) goto L_01B4; FAIL(_imp_str_literal("Bang")); L_01B4: INTERFACE->FAULTS = INTERFACE->FAULTS + 1; _imp_SELECTOUTPUT(2); _imp_SIGNAL(14, 0, 0); } /* MCERROR */ void FINDOPCODE(void) { int MIN; int MAX; int P; _imp_string4 KEY; KEY = _imp_str_literal("0"); OPLENGTH = *_imp_LENGTH(&OPSTRING); if (OPLENGTH > 3) goto L_01B5; SYMP = OPLENGTH; KEY = OPSTRING; goto L_01B6; L_01B5: SYMP = 3; KEY = _imp_join((_imp_string)(_imp_join((_imp_string)(_imp_TOSTRING(*_imp_CHARNO(&OPSTRING, 1))), (_imp_string)(_imp_TOSTRING(*_imp_CHARNO(&OPSTRING, 2))))), (_imp_string)(_imp_TOSTRING(*_imp_CHARNO(&OPSTRING, 3)))); if (*_imp_CHARNO(&OPSTRING, 1) != 66) goto L_01B7; if (*_imp_CHARNO(&OPSTRING, 2) != 76) goto L_01B7; if (OPLENGTH < 4) goto L_01B7; KEY = _imp_join((_imp_string)(KEY), (_imp_string)(_imp_TOSTRING(*_imp_CHARNO(&OPSTRING, 4)))); SYMP = 4; L_01B7: L_01B6: MIN = 1; MAX = 95; L_01B8: if (MIN > MAX) goto L_01B9; P = (unsigned int)MIN + MAX >> 1; if (_imp_strcmp(OPCODE[P], KEY) != 0) goto L_01BA; OPNUM = P; OPTYPE = TYPE[OPNUM]; OPVALUE = VALUE[OPNUM]; return; L_01BA: if (_imp_strcmp(KEY, OPCODE[P]) <= 0) goto L_01BB; MIN = P + 1; goto L_01BC; L_01BB: MAX = P - 1; L_01BC: goto L_01B8; L_01B9: if (_imp_strcmp(OPSTRING, _imp_str_literal("BYTE")) == 0) goto L_01BD; if (_imp_strcmp(OPSTRING, _imp_str_literal("BYTE1")) != 0) goto L_01BE; L_01BD: OPNUM = -1; OPTYPE = -1; SYMP = OPLENGTH; goto L_01BF; L_01BE: if (_imp_strcmp(OPSTRING, _imp_str_literal("BYTE2")) != 0) goto L_01C0; OPNUM = -2; OPTYPE = -1; SYMP = OPLENGTH; goto L_01BF; L_01C0: if (_imp_strcmp(OPSTRING, _imp_str_literal("BYTE4")) != 0) goto L_01C1; OPNUM = -3; OPTYPE = -1; SYMP = OPLENGTH; goto L_01BF; L_01C1: MCERROR(_imp_str_literal("unknown opcode")); L_01BF: } /* FINDOPCODE */ int MATCH(int WANTED) { if (PENDING == WANTED) goto L_01C2; return 0 /*FALSE*/; L_01C2: _imp_READSYMBOL(&PENDING); return 1 /*TRUE*/; } /* MATCH */ int PMATCH(int WANTED) { if (PENDING == WANTED | 128) goto L_01C3; return 0 /*FALSE*/; L_01C3: _imp_READSYMBOL(&PENDING); return 1 /*TRUE*/; } /* PMATCH */ int LITERAL(int *N) { if (!(MATCH(78))) goto L_01C4; N = FOURBYTES(); return 1 /*TRUE*/; L_01C4: if (!(MATCH(128 + 98))) goto L_01C5; N = PENDING; _imp_READSYMBOL(&PENDING); return 1 /*TRUE*/; L_01C5: if (MATCH(45)) goto L_01C6; return 0 /*FALSE*/; L_01C6: if (LITERAL(&N)) goto L_01C7; MCERROR(_imp_str_literal("constant expected")); L_01C7: N = -N; return 1 /*TRUE*/; } /* LITERAL */ void WANT(int SYM) { if (MATCH(SYM)) goto L_01C8; MCERROR(_imp_join((_imp_string)(_imp_TOSTRING(SYM)), (_imp_string)(_imp_str_literal(" expected")))); L_01C8: } /* WANT */ void WANTLITERAL(int *N) { if (LITERAL(&N)) goto L_01C9; MCERROR(_imp_str_literal("constant expected")); L_01C9: } /* WANTLITERAL */ void REGISTER(int *R) { if (!(LITERAL(&R))) goto L_01CA; if (0 > R) goto L_01CA; if (R <= 15) goto L_01CB; L_01CA: MCERROR(_imp_str_literal("Register expected")); L_01CB: } /* REGISTER */ void FREGISTER(int *R) { if (!(LITERAL(&R))) goto L_01CC; if (16 + 0 > R) goto L_01CC; if (R <= 16 + 7) goto L_01CD; L_01CC: MCERROR(_imp_str_literal("Floating register expected")); L_01CD: } /* FREGISTER */ void SETCC(void) { const int CC[16] = {17745, 20037, 17235, 17219, 19785, 20556, 22099, 22083, 18505, 19539, 18245, 19540, 18260, 19525, 16716, 20054}; int SYM; int C; if (SYMP + 1 >= OPLENGTH) goto L_01CE; SYM = *_imp_CHARNO(&OPSTRING, SYMP + 1) << 8 | *_imp_CHARNO(&OPSTRING, SYMP + 2); C = -1; /*%for C = 0, 1, 15 %cycle*/ L_01CF: if (C == 15) goto L_01D0; C += 1; if (CC[C] != SYM) goto L_01D2; OPVALUE = OPVALUE | C << 28; SYMP = SYMP + 2; return; L_01D2: goto L_01CF; L_01D0: L_01CE: OPVALUE = OPVALUE | -536870912; } /* SETCC */ void COMMA(void) { if (MATCH(44)) goto L_01D3; MCERROR(_imp_str_literal("comma missing")); L_01D3: } /* COMMA */ int OMATCH(int SYM) { if (SYMP >= OPLENGTH) goto L_01D4; if (*_imp_CHARNO(&OPSTRING, SYMP + 1) == SYM) goto L_01D5; L_01D4: return 0 /*FALSE*/; L_01D5: SYMP = SYMP + 1; return 1 /*TRUE*/; } /* OMATCH */ if (!_imp_on_event(14)) goto L_01D6; L_01D7: if (PENDING == 59) goto L_01D8; _imp_READSYMBOL(&PENDING); goto L_01D7; L_01D8: goto L_01D9; L_01D6: OPSTRING = _imp_str_literal(""); L_01DA: if (PENDING == 95) goto L_01DB; if (*_imp_LENGTH(&OPSTRING) == 7) goto L_01DC; OPSTRING = _imp_join((_imp_string)(OPSTRING), (_imp_string)(_imp_TOSTRING(PENDING))); L_01DC: _imp_READSYMBOL(&PENDING); goto L_01DA; L_01DB: _imp_READSYMBOL(&PENDING); FINDOPCODE(); if (OPTYPE <= 0) goto L_01DD; if (OPTYPE == 5) goto L_01DD; SETCC(); L_01DD: goto *OT[OPTYPE + 1]; /*TO DO*/ const unsigned char LITSH[4] = {64, 0, 32, 96}; const unsigned char REGSH[4] = {80, 16, 48, 112}; void BADSHIFT(void) { MCERROR(_imp_str_literal("unknown type of shift")); } /* BADSHIFT */ void GETSHIFT(void) { int SH; if (!(PMATCH(65))) goto L_01DF; if (!(PMATCH(83))) goto L_01E0; if (!(PMATCH(82))) goto L_01E0; SH = 1; goto L_01E1; L_01E0: BADSHIFT(); L_01E1: goto L_01D9; L_01DF: if (!(PMATCH(76))) goto L_01E2; if (!(PMATCH(83))) goto L_01E3; if (!(PMATCH(76))) goto L_01E4; SH = 2; goto L_01E5; L_01E4: if (!(PMATCH(82))) goto L_01E6; SH = 3; goto L_01E5; L_01E6: BADSHIFT(); L_01E5: goto L_01E7; L_01E3: BADSHIFT(); L_01E7: goto L_01D9; L_01E2: if (!(PMATCH(82))) goto L_01E8; if (!(PMATCH(82))) goto L_01E9; if (PMATCH(88)) goto L_01EA; BADSHIFT(); L_01EA: SH = 0; goto L_01EB; L_01E9: if (!(PMATCH(79))) goto L_01EC; if (!(PMATCH(82))) goto L_01EC; SH = 4; goto L_01EB; L_01EC: BADSHIFT(); L_01EB: goto L_01D9; L_01E8: BADSHIFT(); L_01D9: if (SH != 0) goto L_01ED; OPVALUE = OPVALUE | 6 << 4; goto L_01EE; L_01ED: if (!(MATCH(35))) goto L_01EF; WANTLITERAL(&N); if (0 > N) goto L_01D1; if (N <= 32) goto L_01F0; L_01D1: MCERROR(_imp_str_literal("shift out of range")); L_01F0: OPVALUE = OPVALUE | (N & 31) << 7 | LITSH[SH]; goto L_01EE; L_01EF: REGISTER(&RS); OPVALUE = OPVALUE | RS << 8 | REGSH[SH]; L_01EE: } /* GETSHIFT */ case_OT_1:; KEY = (unsigned int)OPVALUE >> 23 & 3; N = (unsigned int)OPVALUE >> 21 & 15; RN = 0; RD = 0; RM = 0; RS = 0; if (!(OMATCH(83))) goto L_01F1; OPVALUE = OPVALUE | 1 << 20; L_01F1: if (!(OMATCH(80))) goto L_01F2; if (KEY == 2) goto L_01F3; WARN(1, _imp_str_literal("spurious P qualifier")); L_01F3: RD = 15; L_01F2: REGISTER(&RN); if (KEY == 2) goto L_01F4; RD = RN; RN = 0; if (N == 13) goto L_01F5; if (N == 15) goto L_01F5; COMMA(); REGISTER(&RN); L_01F5: L_01F4: OPVALUE = OPVALUE | RD << 12 | RN << 16; COMMA(); if (!(MATCH(35))) goto L_01F6; WANTLITERAL(&N); ROT = 16; if (N == 0) goto L_01F7; L_01F8: if (N & 3 != 0) goto L_01F9; ROT = ROT - 1; N = (unsigned int)N >> 2; goto L_01F8; L_01F9: L_01F7: if ((unsigned int)N >> 8 == 0) goto L_01FA; MCERROR(_imp_str_literal("cannot generate constant")); L_01FA: OPVALUE = OPVALUE | (ROT & 15) << 8 | N | 33554432; goto L_01FB; L_01F6: REGISTER(&RM); if (!(MATCH(44))) goto L_01FC; GETSHIFT(); L_01FC: OPVALUE = OPVALUE | RM; L_01FB: goto U_1007; void GETDISPLACEMENT(int MODE) { int RM; UD = 1; if (!(MATCH(35))) goto L_01FD; WANTLITERAL(&DISP); if (DISP >= 0) goto L_01FE; UD = 0; DISP = -DISP; L_01FE: goto L_01FF; L_01FD: DISP = 0; if (!(MATCH(45))) goto L_0200; UD = 0; goto L_0201; L_0200: if (!(MATCH(43))) goto L_0202; L_0202: L_0201: REGISTER(&RM); OPVALUE = OPVALUE | RM | 33554432; if (!(MATCH(44))) goto L_0203; GETSHIFT(); L_0203: L_01FF: OPVALUE = OPVALUE | MODE; } /* GETDISPLACEMENT */ void MODIFYDISP(void) { int SIGN; int MOD; SIGN = PENDING; if (MATCH(43)) goto L_0204; if (MATCH(45)) goto L_0204; return; L_0204: if (LITERAL(&MOD)) goto L_0205; MCERROR(_imp_str_literal("constant expected")); L_0205: if (SIGN != 45) goto L_0206; MOD = -MOD; L_0206: N = N + MOD; } /* MODIFYDISP */ case_OT_2:; if (!(OMATCH(66))) goto L_0207; OPVALUE = OPVALUE | 1 << 22; L_0207: if (!(OMATCH(84))) goto L_0208; OPVALUE = OPVALUE | 1 << 21; L_0208: REGISTER(&RD); OPVALUE = OPVALUE | RD << 12; COMMA(); UD = 1; if (!(MATCH(32))) goto L_0209; W = VAR(TAG()); DISP = W->DISP; MODIFYDISP(); if (W->BASE != *LOCAL) goto L_020A; RN = ACTUAL[11]; goto L_020B; L_020A: if (W->BASE != 10) goto L_020C; RN = ACTUAL[10]; goto L_020B; L_020C: if (W->BASE != 0) goto L_020D; if (W->AREA >= 0) goto L_020D; DIR3(13, RD, -W->AREA); REFS = REFS + 1; *CA = *CA + 4; RN = RD; DISP = 0; goto L_020B; L_020D: MCERROR(_imp_str_literal("cannot address non-locals")); L_020B: if (DISP >= 0) goto L_020E; DISP = -DISP; UD = 0; L_020E: OPVALUE = OPVALUE | 83886080 | RN << 16; goto L_020F; L_0209: WANT(91); REGISTER(&RN); OPVALUE = OPVALUE | RN << 16; if (!(MATCH(44))) goto L_0210; if (OPVALUE & 1 << 21 == 0) goto L_0211; WARN(1, _imp_str_literal("spurious translate option")); L_0211: GETDISPLACEMENT(83886080); WANT(93); if (!(MATCH(33))) goto L_0212; OPVALUE = OPVALUE | 1 << 21; L_0212: goto L_0213; L_0210: WANT(93); if (!(MATCH(44))) goto L_0214; GETDISPLACEMENT(67108864); goto L_0215; L_0214: DISP = 0; OPVALUE = OPVALUE | 67108864; L_0215: L_0213: L_020F: if (DISP <= 4095) goto L_0216; MCERROR(_imp_str_literal("displacement too large")); L_0216: OPVALUE = OPVALUE | UD << 23 | DISP; goto U_1007; case_OT_3:; WANTLITERAL(&N); OPVALUE = OPVALUE | N & 16777215; goto U_1007; void RLIST(void) { WANT(60); if (PENDING == 62) goto L_0217; L_0218: REGISTER(&N); OPVALUE = OPVALUE | 1 << N; if (!(MATCH(44))) goto L_0219; goto L_0218; L_0219: L_0217: WANT(62); } /* RLIST */ case_OT_4:; if (!(OMATCH(73))) goto L_021A; if (!(OMATCH(65))) goto L_021B; OPVALUE = OPVALUE | 1 << 23; goto L_021C; L_021B: if (!(OMATCH(66))) goto L_021D; OPVALUE = OPVALUE | 3 << 23; goto L_021C; L_021D: MCERROR(_imp_str_literal("IA or IB expected")); L_021C: goto L_021E; L_021A: if (!(OMATCH(68))) goto L_021F; if (!(OMATCH(65))) goto L_0220; OPVALUE = OPVALUE | 0 << 23; goto L_0221; L_0220: if (!(OMATCH(66))) goto L_0222; OPVALUE = OPVALUE | 2 << 23; goto L_0221; L_0222: MCERROR(_imp_str_literal("DA or DB expected")); L_0221: goto L_021E; L_021F: if (!(OMATCH(70))) goto L_0223; OPVALUE = OPVALUE | 2 << 23; goto L_0224; L_0223: if (!(OMATCH(69))) goto L_0225; OPVALUE = OPVALUE | 0 << 23; L_0225: L_0224: if (!(OMATCH(65))) goto L_0226; OPVALUE = OPVALUE | 1 << 23; goto L_0227; L_0226: if (!(OMATCH(68))) goto L_0228; OPVALUE = OPVALUE | 0 << 23; L_0228: L_0227: L_021E: REGISTER(&RN); OPVALUE = OPVALUE | RN << 16; if (!(MATCH(33))) goto L_0229; OPVALUE = OPVALUE | 1 << 21; L_0229: COMMA(); RLIST(); if (!(MATCH(94))) goto L_022A; OPVALUE = OPVALUE | 1 << 22; L_022A: goto U_1007; case_OT_5:; if (!(MATCH(32))) goto L_022B; W = VAR(TAG()); if (W->TYPE != 11) goto L_022C; DIR3(15, W->DISP, OPVALUE); *CA = *CA + 4; goto U_1008; L_022C: L_022B: MCERROR(_imp_str_literal("Unimplemented form of branch")); void SETDS(int LETP) { if (!(OMATCH(68))) goto L_022D; OPVALUE = OPVALUE | 128; goto L_022E; L_022D: if (!(OMATCH(69))) goto L_022F; OPVALUE = OPVALUE | 524288; goto L_022E; L_022F: if (LETP == 0) goto L_0230; if (!(OMATCH(80))) goto L_0230; OPVALUE = OPVALUE | 524416; goto L_022E; L_0230: if (OMATCH(83)) goto L_0231; MCERROR(_imp_str_literal("D, S, E or P wanted")); L_0231: L_022E: } /* SETDS */ void LITREG(int *R) { if (!(MATCH(35))) goto L_0232; WANTLITERAL(&R); if (R != 1) goto L_0233; if (!(MATCH(47))) goto L_0233; WANTLITERAL(&R); if (R == 2) goto L_0234; MCERROR(_imp_str_literal("only 1/2 permitted")); L_0234: R = 6; goto L_0235; L_0233: if (0 > R) goto L_0236; if (R <= 5) goto L_0237; L_0236: if (R == 10) goto L_0237; MCERROR(_imp_str_literal("bad range")); L_0237: if (R != 10) goto L_0238; R = 7; L_0238: L_0235: R = R | 8; goto L_0239; L_0232: FREGISTER(&R); R = R & 7; L_0239: } /* LITREG */ case_OT_6:; if (!(OMATCH(83))) goto L_023A; goto L_023B; L_023A: if (!(OMATCH(68))) goto L_023C; OPVALUE = OPVALUE | 32768; goto L_023B; L_023C: if (!(OMATCH(69))) goto L_023D; OPVALUE = OPVALUE | 4194304; goto L_023B; L_023D: if (!(OMATCH(80))) goto L_023E; OPVALUE = OPVALUE | 4227072; L_023E: L_023B: FREGISTER(&FDST); COMMA(); UD = 1; if (!(MATCH(32))) goto L_023F; W = VAR(TAG()); DISP = W->DISP; MODIFYDISP(); if (W->BASE != *LOCAL) goto L_0240; RN = ACTUAL[11]; goto L_0241; L_0240: if (W->BASE != 10) goto L_0242; RN = ACTUAL[10]; goto L_0241; L_0242: if (W->BASE != 0) goto L_0243; if (W->AREA >= 0) goto L_0243; DIR3(13, RD, -W->AREA); REFS = REFS + 1; *CA = *CA + 4; RN = RD; DISP = 0; goto L_0241; L_0243: MCERROR(_imp_str_literal("cannot address non-locals")); L_0241: goto L_0244; L_023F: WANT(91); REGISTER(&RN); if (!(MATCH(44))) goto L_0245; if (OPVALUE & 1 << 21 == 0) goto L_0246; WARN(1, _imp_str_literal("spurious translate option")); L_0246: GETDISPLACEMENT(83886080); WANT(93); if (!(MATCH(33))) goto L_0247; OPVALUE = OPVALUE | 1 << 21; L_0247: goto L_0248; L_0245: WANT(93); if (!(MATCH(44))) goto L_0249; GETDISPLACEMENT(67108864); goto L_024A; L_0249: OPVALUE = OPVALUE | 67108864; L_024A: L_0248: L_0244: if (DISP >= 0) goto L_024B; DISP = -DISP; UD = 0; L_024B: if (DISP & 3 == 0) goto L_024C; MCERROR(_imp_str_literal("Alignment error")); L_024C: DISP = (unsigned int)DISP >> 2; if (DISP <= 255) goto L_024D; MCERROR(_imp_str_literal("displacement too large")); L_024D: OPVALUE = OPVALUE | DISP | 83886080 | RN << 16 | (FDST & 7) << 12 | UD << 23; goto U_1007; void SETROUND(void) { if (!(OMATCH(80))) goto L_024E; OPVALUE = OPVALUE | 32; goto L_024F; L_024E: if (!(OMATCH(77))) goto L_0250; OPVALUE = OPVALUE | 64; goto L_024F; L_0250: if (!(OMATCH(90))) goto L_0251; OPVALUE = OPVALUE | 96; L_0251: L_024F: } /* SETROUND */ case_OT_7:; SETDS(0); SETROUND(); N = (unsigned int)OPVALUE >> 20 & 15; if (N != 0) goto L_0252; FREGISTER(®1); COMMA(); REGISTER(®2); OPVALUE = OPVALUE | (REG1 & 7) << 16 | REG2 << 12; goto L_0253; L_0252: if (N != 1) goto L_0254; REGISTER(®1); COMMA(); FREGISTER(®2); OPVALUE = OPVALUE | REG1 << 12 | REG2 & 7; goto L_0253; L_0254: REGISTER(®1); OPVALUE = OPVALUE | REG1 << 12; L_0253: goto U_1007; case_OT_9:; FREGISTER(&FS1); COMMA(); LITREG(&FS2); OPVALUE = OPVALUE | (FS1 & 7) << 16 | FS2; goto U_1007; case_OT_10:; SETDS(1); SETROUND(); FREGISTER(&FDST); COMMA(); if (OPVALUE & 32768 != 0) goto L_0255; FREGISTER(&FS1); COMMA(); goto L_0256; L_0255: FS1 = 0; L_0256: LITREG(&FS2); OPVALUE = OPVALUE | (FDST & 7) << 12 | (FS1 & 7) << 16 | FS2; goto U_1007; case_OT_M1:; L_0257: if (LITERAL(&N)) goto L_0258; MCERROR(_imp_str_literal("constant expected")); L_0258: if (OPNUM != -1) goto L_0259; DUMPBYTE(N & 255); goto L_025A; L_0259: if (OPNUM != -2) goto L_025B; DUMPBYTE(N & 255); DUMPBYTE((unsigned int)N >> 8 & 255); goto L_025A; L_025B: DUMPWORD(N); L_025A: if (!(MATCH(44))) goto L_025C; goto L_0257; L_025C: if (*CA & 3 == 0) goto L_025D; L_025E: DUMPBYTE(0); if (*CA & 3 == 0) goto L_025F; goto L_025E; L_025F: WARN(0, _imp_str_literal("zero padding bytes added to ensure word alignment")); L_025D: goto U_1008; U_1007: DUMPWORD(OPVALUE); U_1008: if (MATCH(59)) goto L_0260; MCERROR(_imp_str_literal("Too many operands")); L_0260: if (SYMP == OPLENGTH) goto L_0261; MCERROR(_imp_str_literal("spurious operation qualifiers")); L_0261: L_0262: } /* MACHINECODE */ int USES(int R, struct STACKFM *V) { int N; N = 0; L_0262: if (&V == NIL) goto L_0263; if (V != R) goto L_0264; N = N + 1; L_0264: if (&V == NIL) goto L_0265; N = N + USES(R, &V); L_0265: if (&V == NIL) goto L_0266; N = N + USES(R, &V); L_0266: V = &V; goto L_0000; L_0263: return N; } /* USES */ void STOREREALCONSTANT(struct STACKFM * W) { int N; if (W != 0) goto L_0267; if (W != 0) goto L_0267; if (&W != NIL) goto L_0267; if (&W != NIL) goto L_0267; CONSTANTBASE = CONSTANTBASE + 3 & (~3); SELECTCONSTANTAREA(); N = *CA; DUMPWORD(W); DUMPWORD(W); SELECTCODEAREA(); W = N; W = 512; W = 1; L_0267: } /* STOREREALCONSTANT */ int POTENTIALLYUNASSIGNED(struct STACKFM * V) { if (UNASSIGNED != 0) goto L_0268; return 0 /*FALSE*/; L_0268: if (V & 128 == 0) goto L_0269; return 0 /*FALSE*/; L_0269: if (V != 1) goto L_026A; if (V & 1048576 != 0) goto L_026B; L_026A: return 0 /*FALSE*/; L_026B: return 1 /*TRUE*/; } /* POTENTIALLYUNASSIGNED */ void SIMPLE(struct STACKFM * FROM, struct STACKFM * TO) { struct STACKFM *W; W = COPY(&FROM); MOVE(W, &TO); RELEASEANDDROP(W); } /* SIMPLE */ void LOADADDRESS(struct STACKFM * V, int R) { AMAP(&V); LOAD(&V, R); } /* LOADADDRESS */ void PUSH(struct STACKFM * V) { struct STACKFM S; S = 0; S.TYPE = 1; S.FORM = 3; S.BASE = 13; STORE(&V, &S); } /* PUSH */ void PUSHLITERAL(int LIT) { struct STACKFM *L; L = LITERAL(LIT); PUSH(L); RELEASEANDDROP(L); } /* PUSHLITERAL */ void PUSHADDRESS(struct STACKFM * V) { AMAP(V); PUSH(V); } /* PUSHADDRESS */ void POPSTACK(int BYTES) { if (*BYTES != 0) goto L_026C; return; L_026C: if (*BYTES & 3 == 0) goto L_026D; FAIL(_imp_str_literal("stack alignment")); L_026D: PLANT1(8388608, 13, 13, ROT((unsigned int)*BYTES >> 2, 16 - 1)); } /* POPSTACK */ void LOADUPADDRESS(struct STACKFM * V) { AMAP(V); LOAD(V, 17); } /* LOADUPADDRESS */ void LOADUP(struct STACKFM * FROM) { int OPER; struct STACKFM *W; struct STACKFM *LHS; if (FROM->TYPE != 13) goto L_026E; if (FROM->OPER != 0) goto L_026F; FAIL(_imp_str_literal("Bad set")); L_026F: OPER = FROM->OPER; W = &FROM->LINK; FROM->OPER = 0; FROM->LINK = NIL; if (FROM->FLAGS & 262144 != 0) goto L_0270; LHS = CLAIMWORKAREA(32, 13); LHS->FLAGS = LHS->FLAGS | 262144; SETASSIGN(FROM, LHS); RELEASE(FROM->BASE); ZAPINDEXANDRECORD(FROM); FROM->DATA = LHS->DATA; DROP(LHS); L_0270: LHS = COPY(FROM); FROM->OPER = OPER; FROM->LINK = W; SETASSIGN(FROM, LHS); RELEASEANDDROP(LHS); goto L_0271; L_026E: if (!(FLOATING(FROM))) goto L_0272; LOAD(FROM, 26); goto L_0271; L_0272: LOAD(FROM, 17); L_0271: } /* LOADUP */ void LOADPROTECTED(struct STACKFM * V) { if (DIAG & 8 == 0) goto L_0273; MONITOR(V, _imp_str_literal("->Load protected")); L_0273: LOADUP(V); if (ACTIVITY[V->BASE] == 1) goto L_0274; if (V->TYPE < 6) goto L_0275; LOAD(V, FPR()); goto L_0276; L_0275: LOAD(V, GPR()); L_0276: L_0274: if (DIAG & 8 == 0) goto L_0277; MONITOR(V, _imp_str_literal("<-Load protected")); L_0277: } /* LOADPROTECTED */ void CONSTANTOPERATION(int OP, int *L, struct STACKFM *R) { static const void *COP[29] = { &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_4, &&case_COP_5, &&case_COP_6, &&case_COP_7, &&case_COP_8, &&case_COP_9, &&case_COP_10, &&case_COP_11, &&case_COP_12, &&case_COP_default, &&case_COP_14, &&case_COP_15, &&case_COP_16, &&case_COP_17, &&case_COP_18, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default, &&case_COP_default}; int N; N = R->DISP; DROP(R); goto *COP[OP - 1]; /*TO DO*/ case_COP_4:; *L = *L + N; goto U_1009; case_COP_5:; *L = *L - N; goto U_1009; case_COP_18:; case_COP_6:; *L = *L * N; goto U_1009; case_COP_9:; *L = *L & N; goto U_1009; case_COP_12:; *L = *L & (~N); goto U_1009; case_COP_10:; *L = *L | N; goto U_1009; case_COP_11:; *L = *L ^ N; goto U_1009; case_COP_14:; *L = *L << N; goto U_1009; case_COP_15:; *L = (unsigned int)*L >> N; goto U_1009; case_COP_8:; if (N >= 0) goto L_0279; FAIL(_imp_str_literal("Exp")); L_0279: *L = _imp_IEXP(*L, N); goto U_1009; case_COP_17:; if (N > 0) goto L_027A; FAIL(_imp_str_literal("Illegal MOD")); L_027A: if (*L >= 0) goto L_027B; *L = N - _imp_REM(-*L, N); if (*L != N) goto L_027C; *L = 0; L_027C: goto U_1009; L_027B: case_COP_16:; if (N != 0) goto L_027D; FAIL(_imp_str_literal("Zero divide")); L_027D: *L = _imp_REM(*L, N); goto U_1009; case_COP_7:; if (N != 0) goto L_027E; FAIL(_imp_str_literal("Zero divide")); L_027E: *L = ((long)*L / (long)N); goto U_1009; case_COP_default:; FAIL(_imp_str_literal("C-op")); U_1009: } /* CONSTANTOPERATION */ void OPERATE(int NEWOPER, struct STACKFM *LHS, struct STACKFM *RHS) { int OP; int RCONST; int KEY; int LFLAGS; int RFLAGS; int N; int FN; struct STACKFM *W; void SWOP(void) { struct STACKFM TEMP; TEMP.DATA = LHS->DATA; LHS->DATA = RHS->DATA; RHS->DATA = TEMP.DATA; } /* SWOP */ void ZAP(void) { DROP(W); DROP(RHS); LHS->LINK = NIL; LHS->OPER = 0; RHS = LITERAL(0); SWOP(); RELEASEANDDROP(RHS); } /* ZAP */ void REDUCECONSTANT(void) { int OP; int N; int F; void FIX(int OP) { LHS->OPER = OP; DROP(&LHS->LINK); LHS->LINK = NIL; } /* FIX */ OP = LHS->OPER; F = OPERFLAGS[OP]; N = LHS->LINK; if (F & 512 == 0) goto L_027F; if (NULLVALUE[OP] != N) goto L_027F; FIX(0); goto L_0280; L_027F: if (OP != 6) goto L_0281; if (N != 0) goto L_0282; FIX(0); RELEASE(LHS->BASE); LHS->FORM = 0; LHS->BASE = 0; LHS->DISP = 0; LHS->AREA = 0; if (&LHS->INDEX == NIL) goto L_0283; RELEASEANDDROP(&LHS->INDEX); L_0283: if (&LHS->RECORD == NIL) goto L_0284; RELEASEANDDROP(&LHS->RECORD); L_0284: LHS->RECORD = NIL; LHS->INDEX = NIL; goto L_0285; L_0282: if (N != -1) goto L_0286; FIX(2); L_0286: L_0285: goto L_0280; L_0281: if (OP != 4) goto L_0287; if (LHS->FORM != 0) goto L_0288; FIX(0); LHS->DISP = LHS->DISP + N; L_0288: goto L_0280; L_0287: if (OP != 9) goto L_0289; if (LHS->FORM != 1) goto L_0289; if (LHS->AREA != 0) goto L_0289; if (LHS->TYPE != 4) goto L_028A; N = N & 255; L_028A: if (UNASSIGNED == 0) goto L_028B; if (LHS->FLAGS & 1048576 == 0) goto L_028B; if (LHS->FLAGS & 128 == 0) goto L_028C; L_028B: if (N & -256 != 0) goto L_028D; LHS->TYPE = 4; if (N != 255) goto L_028E; FIX(0); L_028E: goto L_028F; L_028D: if (N & -65281 != 0) goto L_0290; if (LHS->TYPE != 2) goto L_0290; LHS->TYPE = 4; LHS->DISP = LHS->DISP + 1; N = (unsigned int)N >> 8; LHS->LINK = N; if (N != 255) goto L_0291; FIX(0); L_0291: OPERATE(14, LHS, LITERAL(8)); L_0290: L_028F: L_028C: goto L_0280; L_0289: if (OP != 11) goto L_0292; if (N != -1) goto L_0292; FIX(1); L_0292: L_0280: } /* REDUCECONSTANT */ int FIELD(int AND, int SHIFT, int ANDFIRST) { int R; R = 0; if (ANDFIRST == 0) goto L_0293; AND = (unsigned int)AND >> SHIFT << SHIFT; if (AND != 0) goto L_0294; return -1; L_0294: L_0295: if (AND & 1 != 0) goto L_0296; AND = (unsigned int)AND >> 1; R = R + 1; goto L_0295; L_0296: if (SHIFT >= R) goto L_0297; return 0; L_0297: goto L_0298; L_0293: AND = (unsigned int)AND << SHIFT >> SHIFT; if (AND != 0) goto L_0299; return -1; L_0299: L_0298: N = POWER(AND + 1); if (N < 0) goto L_029A; if (N <= 8) goto L_029B; L_029A: return 0; L_029B: return (N << 16) + SHIFT; } /* FIELD */ if (DIAG & 16 == 0) goto L_029C; MONITOR(LHS, _imp_str_literal("O-Lhs")); MONITOR(RHS, _imp_str_literal("O-Rhs")); L_029C: RFLAGS = OPERFLAGS[NEWOPER]; if (RFLAGS & 32 == 0) goto L_029D; if (!(ICONST(LHS))) goto L_029E; if (NEWOPER != 2) goto L_029F; LHS->DISP = -LHS->DISP; goto L_02A0; L_029F: if (NEWOPER != 1) goto L_02A1; LHS->DISP = (~LHS->DISP); goto L_02A0; L_02A1: if (NEWOPER != 3) goto L_02A2; LHS->DISP = _imp_IMOD(LHS->DISP); goto L_02A0; L_02A2: FAIL(_imp_str_literal("Operator")); L_02A0: goto L_02A3; L_029E: if (!(FLOATING(LHS))) goto L_02A4; NEWOPER = NEWOPER + 21; L_02A4: if (LHS->OPER == 0) goto L_02A5; if (LHS->OPER != NEWOPER) goto L_02A6; if (NEWOPER == 3) goto L_02A7; if (NEWOPER == 24) goto L_02A7; LHS->OPER = 0; L_02A7: goto U_100A; L_02A6: if (NEWOPER == 2) goto L_02A8; if (NEWOPER != 1) goto L_02A9; L_02A8: if (LHS->OPER == 2) goto L_02AA; if (LHS->OPER != 1) goto L_02AB; L_02AA: LHS->OPER = 0; if (NEWOPER != 2) goto L_02AC; NEWOPER = 4; goto L_02AD; L_02AC: NEWOPER = 5; L_02AD: OPERATE(NEWOPER, LHS, LITERAL(1)); goto U_100A; L_02AB: L_02A9: if (NEWOPER != 2) goto L_02AE; if (LHS->OPER != 6) goto L_02AE; if (!(ICONST(&LHS->LINK))) goto L_02AE; if (LHS->LINK == -2147483648) goto L_02AF; LHS->LINK = -LHS->LINK; goto U_100A; L_02AF: L_02AE: LOADUP(LHS); L_02A5: LHS->OPER = NEWOPER; LHS->LINK = NIL; L_02A3: goto U_100A; L_029D: if (NEWOPER != 22) goto L_02B0; if (RHS->BIAS != 1) goto L_02B1; DROP(RHS); return; L_02B1: if (LHS->BIAS != 1) goto L_02B2; if (&LHS->LINK == NIL) goto L_02B3; FAIL(_imp_str_literal("inconsistent concatenation")); L_02B3: LHS->DATA = RHS->DATA; DROP(RHS); return; L_02B2: if (LHS->OPER == 0) goto L_02B4; if (LHS->OPER == 22) goto L_02B4; LOADUP(LHS); L_02B4: if (RHS->OPER == 0) goto L_02B5; LOADUP(RHS); L_02B5: L_02B6: if (LHS->OPER == 0) goto L_02B7; LHS = &LHS->LINK; goto L_02B6; L_02B7: LHS->OPER = 22; LHS->LINK = RHS; goto U_100A; L_02B0: if (RFLAGS & 1 == 0) goto L_02B8; if (!(ICONST(LHS))) goto L_02B8; SWOP(); L_02B8: if (RHS->OPER == 0) goto L_02B9; OP = RHS->OPER; if (OP != 2) goto L_02BA; if (NEWOPER == 4) goto L_02BB; if (NEWOPER != 5) goto L_02BA; L_02BB: NEWOPER = 4 + 5 - NEWOPER; RFLAGS = OPERFLAGS[NEWOPER]; RHS->OPER = 0; goto L_02BC; L_02BA: if (OP != 1) goto L_02BD; if (NEWOPER != 9) goto L_02BD; RHS->OPER = 0; NEWOPER = 12; goto L_02BC; L_02BD: if (OP == 14) goto L_02BE; if (OP != 15) goto L_02BF; L_02BE: if (OPERFLAGS[NEWOPER] & 4 == 0) goto L_02BF; if (LHS->TYPE >= 6) goto L_02BF; if (LHS->OPER >= 23) goto L_02BF; W = &RHS->LINK; RHS->LINK = NIL; RHS->OPER = 0; LOADUP(LHS); LOADUP(RHS); if (!(ICONST(W))) goto L_02C0; if (OP != 14) goto L_02C1; N = ISHIFT(RHS->BASE, W->DISP, 0); goto L_02C2; L_02C1: N = ISHIFT(RHS->BASE, W->DISP, 32); L_02C2: goto L_02C3; L_02C0: LOADUP(W); if (OP != 14) goto L_02C4; N = RSHIFT(RHS->BASE, W->BASE, 144); goto L_02C5; L_02C4: N = RSHIFT(RHS->BASE, W->BASE, 176); L_02C5: L_02C3: PLANT1(EASYOP[NEWOPER], LHS->BASE, LHS->BASE, N); RELEASEANDDROPPAIR(RHS, W); return; L_02BF: LOADUP(RHS); L_02BC: L_02B9: if (!(ICONST(RHS))) goto L_02C6; RCONST = 1; if (NEWOPER != 5) goto L_02C7; if (RHS->DISP == -2147483648) goto L_02C8; RHS->DISP = -RHS->DISP; NEWOPER = 4; RFLAGS = OPERFLAGS[4]; L_02C8: L_02C7: if (OPERFLAGS[NEWOPER] & 512 == 0) goto L_02C9; if (NULLVALUE[NEWOPER] != RHS->DISP) goto L_02C9; DROP(RHS); return; L_02C9: goto L_02CA; L_02C6: RCONST = 0; L_02CA: if (LHS->OPER == 0) goto L_02CB; OP = LHS->OPER; LFLAGS = OPERFLAGS[OP]; W = &LHS->LINK; if (OP != 2) goto L_02CC; if (NEWOPER != 6) goto L_02CC; LHS->OPER = 0; OPERATE(6, LHS, RHS); OPERATE(2, LHS, NIL); return; L_02CC: if (LFLAGS & 32 != 0) goto L_02CD; if (!(ICONST(W))) goto L_02CD; if (RCONST == 0) goto L_02CE; if (NEWOPER >= 23) goto L_02CE; KEY = (LFLAGS | RFLAGS) & 384; if (KEY == 0) goto L_02CF; if (KEY != 256) goto L_02D0; if (NEWOPER != OP) goto L_02D0; L_02CF: if (RHS->BASE == 0) goto L_02D1; if (NEWOPER != 4) goto L_02D2; L_02D1: CONSTANTOPERATION(NEWOPER, &W->DISP, RHS); if (RHS->BASE != 0) goto L_02D3; REDUCECONSTANT(); L_02D3: goto U_100A; L_02D2: L_02D0: if (OP != 14) goto L_02D4; if (NEWOPER != 9) goto L_02D4; if (-31 > W->DISP) goto L_02D4; if (W->DISP > 0) goto L_02D4; N = FIELD(RHS->DISP, -W->DISP, 0); if (N == 0) goto L_02D5; if (N != -1) goto L_02D6; ZAP(); goto U_100A; L_02D6: W->DISP = N; LHS->OPER = 21; DROP(RHS); goto U_100A; L_02D5: L_02D4: if (OP != 9) goto L_02D7; if (NEWOPER != 15) goto L_02D7; if (0 > RHS->DISP) goto L_02D7; if (RHS->DISP > 31) goto L_02D7; N = FIELD(W->DISP, RHS->DISP, 1); if (N == 0) goto L_02D8; if (N != -1) goto L_02D9; ZAP(); goto U_100A; L_02D9: W->DISP = N; LHS->OPER = 21; DROP(RHS); goto U_100A; L_02D8: L_02D7: L_02CE: L_02CD: if (OP == 14) goto L_02DA; if (OP != 15) goto L_02DB; L_02DA: if (OPERFLAGS[NEWOPER] & 4 == 0) goto L_02DB; if (NEWOPER == 12) goto L_02DB; if (RHS->TYPE >= 6) goto L_02DB; LHS->LINK = NIL; LHS->OPER = 0; LOADUP(LHS); LOADUP(RHS); if (!(ICONST(W))) goto L_02DC; if (OP != 14) goto L_02DD; N = ISHIFT(LHS->BASE, W->DISP, 0); goto L_02DE; L_02DD: N = ISHIFT(LHS->BASE, W->DISP, 32); L_02DE: goto L_02DF; L_02DC: LOADUP(W); if (OP != 14) goto L_02E0; N = RSHIFT(LHS->BASE, W->BASE, 144); goto L_02E1; L_02E0: N = RSHIFT(LHS->BASE, W->BASE, 176); L_02E1: L_02DF: FN = EASYOP[NEWOPER]; if (NEWOPER != 5) goto L_02E2; FN = 6291456; L_02E2: PLANT1(FN, RHS->BASE, LHS->BASE, N); RELEASEANDDROPPAIR(RHS, W); return; L_02DB: LOADUP(LHS); L_02CB: if (!(ICONST(LHS))) goto L_02E3; if (RCONST == 0) goto L_02E3; if (NEWOPER >= 23) goto L_02E3; CONSTANTOPERATION(NEWOPER, &LHS->DISP, RHS); goto U_100A; L_02E3: if (LHS->TYPE >= 6) goto L_02E4; if (RHS->TYPE < 6) goto L_02E5; L_02E4: if (NEWOPER >= 23) goto L_02E6; NEWOPER = NEWOPER + 21; L_02E6: if (LHS->TYPE != 13) goto L_02E7; if (LHS->FLAGS != 16384) goto L_02E8; if (NEWOPER != 25) goto L_02E9; SWOP(); L_02E9: RHS->TYPE = 0; goto L_02EA; L_02E8: if (RHS->FLAGS != 16384) goto L_02EB; if (NEWOPER != 27) goto L_02EC; SWOP(); L_02EC: RHS->TYPE = 0; L_02EB: L_02EA: LHS->OPER = NEWOPER; LHS->LINK = RHS; if (RHS->TYPE != 0) goto L_02ED; LHS->OPER = 0; LHS->LINK = NIL; DROPMEMBERS(RHS); RELEASEANDDROP(RHS); L_02ED: goto U_100A; L_02E7: L_02E5: if (RFLAGS & 1 == 0) goto L_02EE; if (!(INREG(RHS))) goto L_02EE; SWOP(); RCONST = 0; if (!(ICONST(RHS))) goto L_02EF; RCONST = 1; L_02EF: L_02EE: if (NEWOPER != 5) goto L_02F0; if (LHS->FORM != 0) goto L_02F0; if (0 != RHS->FORM) goto L_02F0; if (LHS->BASE != RHS->BASE) goto L_02F1; if (LHS->AREA != RHS->AREA) goto L_02F1; if (!(SAME(&LHS->INDEX, &RHS->INDEX))) goto L_02F2; if (!(SAME(&LHS->RECORD, &RHS->RECORD))) goto L_02F2; if (LHS->XSIZE != RHS->XSIZE) goto L_02F2; LHS->DISP = LHS->DISP - RHS->DISP; RELEASEANDDROP(RHS); if (&LHS->INDEX == NIL) goto L_02F3; RELEASEANDDROP(&LHS->INDEX); L_02F3: if (&LHS->RECORD == NIL) goto L_02F4; RELEASEANDDROP(&LHS->RECORD); L_02F4: LHS->BASE = 0; LHS->XSIZE = 0; goto U_100A; L_02F2: L_02F1: L_02F0: LHS->OPER = NEWOPER; LHS->LINK = RHS; if (RCONST == 0) goto L_02F5; REDUCECONSTANT(); L_02F5: U_100A: if (DIAG & 16 == 0) goto L_02F6; MONITOR(LHS, _imp_str_literal("<-Operate")); L_02F6: } /* OPERATE */ void AOP(void) { int TYPE; int FORMAT; int SIZE; struct STACKFM *X; X = STACK; STACK = &X->STACK; SIZE = ITEMSIZE(STACK->FORMAT); if (&STACK->INDEX != NIL) goto L_02F7; STACK->INDEX = X; STACK->XSIZE = SIZE; goto L_02F8; L_02F7: if (STACK->XSIZE != SIZE) goto L_02F9; OPERATE(4, &STACK->INDEX, X); goto L_02F8; L_02F9: TYPE = STACK->TYPE; FORMAT = STACK->FORMAT; AMAP(STACK); OPERATE(6, X, LITERAL(SIZE)); OPERATE(4, STACK, X); VMAP(STACK, TYPE); STACK->FORMAT = FORMAT; L_02F8: } /* AOP */ void OPERATION(int OPER) { struct STACKFM *V; V = STACK; STACK = &STACK->STACK; OPERATE(OPER, STACK, V); } /* OPERATION */ void REPLACE(struct STACKFM * OLD, struct STACKFM * NEW) { ZAPINDEXANDRECORD(OLD); RELEASE(OLD->BASE); OLD->BASE = NEW->BASE; OLD->DISP = NEW->DISP; OLD->EXTRA = NEW->EXTRA; OLD->TYPE = NEW->TYPE; OLD->FORM = NEW->FORM; OLD->FORMAT = NEW->FORMAT; OLD->AREA = NEW->AREA; OLD->OPER = 0; OLD->LINK = NIL; DROP(NEW); } /* REPLACE */ int MEMORABLE(struct STACKFM * V, struct KNOWFM * K) { int OP; OP = 0; int SCALE; SCALE = 0; if (V->OPER == 0) goto L_02FA; if (&V->LINK == NIL) goto L_02FB; if (ICONST(&V->LINK)) goto L_02FC; L_02FB: return 0 /*FALSE*/; L_02FC: OP = V->OPER; SCALE = V->LINK; L_02FA: if (&V->INDEX != NIL) goto L_02FD; if (&V->RECORD != NIL) goto L_02FD; if (V->FORM < 2) goto L_02FE; L_02FD: return 0 /*FALSE*/; L_02FE: K = (V->TYPE << 4) + V->FORM; K = V->BASE; K = V->DISP; K = V->EXTRA; K = V->AREA; K = SCALE; K = OP; if (!(ICONST(V))) goto L_02FF; K = (1 << 4) + 0; L_02FF: return 1 /*TRUE*/; } /* MEMORABLE */ void OPTIMISE(struct STACKFM * V, int SWANTED) { struct KNOWFM *P; struct KNOWFM M; struct STACKFM *W; int OP; P = KNOWING; if (P != NIL) goto L_0300; return; L_0300: if (V->OPER == 0) goto L_0301; OP = V->OPER; V->OPER = 0; W = &V->LINK; V->LINK = NIL; OPTIMISE(V, 1); if (W == NIL) goto L_0302; OPTIMISE(W, 1); L_0302: V->OPER = OP; V->LINK = W; L_0301: if (&V->RECORD == NIL) goto L_0303; OPTIMISE(&V->RECORD, 1); if (V->RECORD != 0) goto L_0304; SIMPLIFY(V); P = KNOWING; if (P != NIL) goto L_0305; return; L_0305: L_0304: L_0303: if (MEMORABLE(V, &M)) goto L_0306; return; L_0306: if (DIAG & 128 == 0) goto L_0307; MONITOR(V, _imp_str_literal("Opt")); L_0307: void SET(int FORM) { if (V->OPER == 0) goto L_0308; RELEASEANDDROP(&V->LINK); V->OPER = 0; V->LINK = NIL; L_0308: if (FORM != 0) goto L_0309; if (V->TYPE > 5) goto L_0309; V->TYPE = 1; L_0309: V->FORM = FORM; RELEASE(V->BASE); V->AREA = 0; V->DISP = 0; V->BASE = P->REG; if (P->REG != PENDINGAUTO) goto L_030A; PENDINGAUTO = 0; L_030A: CLAIM(V->BASE); if (DIAG & 128 == 0) goto L_030B; MONITOR(V, _imp_str_literal("Opt->")); L_030B: } /* SET */ L_030C: if (P->DISP != M.DISP) goto L_030D; if (P->AREA != M.AREA) goto L_030D; if (P->EXTRA != M.EXTRA) goto L_030D; if (P->OPER != M.OPER) goto L_030D; if (P->BASE != M.BASE) goto L_030D; if (P->OPND != M.OPND) goto L_030D; if (P->FTYPE != M.FTYPE) goto L_030E; if (SWANTED == 0) goto L_030E; SET(0); return; L_030E: if (M.OPER != 0) goto L_030F; if (M.FTYPE & 15 == 0) goto L_030F; if (P->FTYPE != (1 << 4) + 0) goto L_0310; SET(V->FORM); if (SWANTED == 0) goto L_0311; OPTIMISE(V, 1); L_0311: return; L_0310: L_030F: L_030D: P = &P->LINK; if (P == NIL) goto L_0312; goto L_030C; L_0312: } /* OPTIMISE */ struct KNOWFM *NEWK(void) { struct KNOWFM *P; P = KASL; if (P != NIL) goto L_0313; P = _imp_NEW(KNOWFMTYPE); *P = 0; goto L_0314; L_0313: KASL = &P->LINK; L_0314: return P; } /* NEWK */ void KINC(struct KNOWFM * K) { KTIMES[K->REG] = KTIMES[K->REG] + 1; if (K->BASE & 128 != 0) goto L_0315; KTIMES[K->BASE] = KTIMES[K->BASE] + 1; L_0315: } /* KINC */ void KDEC(struct KNOWFM * K) { KTIMES[K.REG] = KTIMES[K.REG] - 1; if (K.BASE & 128 != 0) goto L_0316; KTIMES[K.BASE] = KTIMES[K.BASE] - 1; L_0316: } /* KDEC */ void FORGET(int REGISTER) { int *N; struct KNOWFM *K; struct KNOWFM *R; if (1 > REGISTER) goto L_0317; if (REGISTER <= 25) goto L_0318; L_0317: return; L_0318: if (PENDINGAUTO != REGISTER) goto L_0319; PENDINGAUTO = 0; L_0319: N = &KTIMES[REGISTER]; USED[REGISTER] = 0; if (*N != 0) goto L_031A; return; L_031A: K = KNOWING; KNOWING = NIL; L_031B: if (K == NIL) goto L_031C; R = K; K = &K->LINK; if (R->REG == REGISTER) goto L_031D; if (R->BASE != REGISTER) goto L_031E; L_031D: R->LINK = KASL; KASL = R; KDEC(R); if (DIAG & 128 == 0) goto L_031F; MONREGID(R->REG, _imp_str_literal("Forgotten")); L_031F: goto L_0320; L_031E: R->LINK = KNOWING; KNOWING = R; L_0320: goto L_031B; L_031C: if (*N == 0) goto L_0321; FAIL(_imp_str_literal("Register still known")); L_0321: } /* FORGET */ void FORGETEVERYTHING(void) { struct KNOWFM *K; PENDINGAUTO = 0; K = KNOWING; if (K == NIL) goto L_0322; L_0323: USED[K->REG] = 0; if (K->BASE & 128 != 0) goto L_0324; USED[K->BASE] = 0; L_0324: KDEC(K); if (&K->LINK != NIL) goto L_0325; goto L_0326; L_0325: K = &K->LINK; goto L_0323; L_0326: K->LINK = KASL; KASL = KNOWING; KNOWING = NIL; L_0322: } /* FORGETEVERYTHING */ void INHERIT(int NEW, int OLD) { struct KNOWFM *P; struct KNOWFM *K; struct KNOWFM *X; if (*NEW != *OLD) goto L_0327; return; L_0327: USED[*NEW] = USEDTIME; P = KNOWING; L_0328: if (P == NIL) goto L_0329; K = P; P = &K->LINK; if (K->REG != *OLD) goto L_032A; if (DIAG & 128 == 0) goto L_032B; MONREGID(*OLD, _imp_str_literal("inherited")); L_032B: X = NEWK(); if (X != NIL) goto L_032C; return; L_032C: *X = *K; X->REG = *NEW; X->LINK = KNOWING; KNOWING = X; KINC(X); L_032A: goto L_0328; L_0329: } /* INHERIT */ void REMEMBER(int REGISTER, struct STACKFM *V) { struct KNOWFM *K; struct KNOWFM M; if (1 > *REGISTER) goto L_032D; if (*REGISTER > 25) goto L_032D; if (*REGISTER != 17) goto L_032E; L_032D: return; L_032E: USED[*REGISTER] = USEDTIME; if (!(INREG(V))) goto L_032F; INHERIT(*REGISTER, V->OPER); return; L_032F: if (*REGISTER != V->OPER) goto L_0330; return; L_0330: if (!(MEMORABLE(V, &M))) goto L_0331; K = NEWK(); if (K != NIL) goto L_0332; return; L_0332: *K = M; K->REG = *REGISTER; K->LINK = KNOWING; KNOWING = K; KINC(K); if (DIAG & 128 == 0) goto L_0333; MONITOR(V, _imp_join((_imp_string)(_imp_str_literal("Remember ")), (_imp_string)(REGID[*REGISTER]))); L_0333: L_0331: } /* REMEMBER */ void REMEMBERZERO(int REGISTER) { struct STACKFM *ZERO; ZERO = LITERAL(0); FORGET(*REGISTER); REMEMBER(*REGISTER, ZERO); DROP(ZERO); } /* REMEMBERZERO */ void FORGETDESTINATION(struct STACKFM * V) { int LOW; int HIGH; int BASE; BASE = V; int UNSAFE; UNSAFE = 0; int ALTER; struct KNOWFM *P; struct KNOWFM *K; if (DIAG & 128 == 0) goto L_0334; MONITOR(V, _imp_str_literal("Forget Dest")); L_0334: if (!(INREG(V))) goto L_0335; FORGET(V); return; L_0335: LOW = V; HIGH = LOW + ITEMSIZE(V) - 1; if (HIGH >= LOW) goto L_0336; HIGH = LOW + 3; L_0336: P = KNOWING; KNOWING = NIL; if (INTERFACE->OPTIONS & 1 != 0) goto L_0337; if (V >= 128) goto L_0338; if (ACTIVITY[V] < 0) goto L_0338; UNSAFE = 1; goto L_0339; L_0338: if (&V == NIL) goto L_033A; UNSAFE = 1; L_033A: L_0339: if (DIAG & 128 == 0) goto L_033B; MONITORN(UNSAFE, _imp_str_literal("Unsafe")); L_033B: L_0337: L_033C: if (P == NIL) goto L_033D; K = P; P = &P->LINK; ALTER = 0; if (K->BASE >= 128) goto L_033E; if (ACTIVITY[K->BASE] < 0) goto L_033E; ALTER = UNSAFE; L_033E: if (K->FTYPE & 15 == 0) goto L_033F; if (K->BASE != BASE) goto L_0340; if (LOW > K->DISP) goto L_0340; if (K->DISP > HIGH) goto L_0340; ALTER = 1; L_0340: L_033F: if (ALTER == 0) goto L_0341; KDEC(K); K->LINK = KASL; KASL = K; if (DIAG & 128 == 0) goto L_0342; MONREGID(K->REG, _imp_str_literal("Altered")); L_0342: goto L_0343; L_0341: K->LINK = KNOWING; KNOWING = K; L_0343: goto L_033C; L_033D: } /* FORGETDESTINATION */ void FORGETENVIRONMENT(int LABEL) { struct LABELFM *L; struct KNOWFM *P; struct KNOWFM *E; L = ILABEL(LABEL); P = &L->ENV; L->ENV = NIL; if (P == NIL) goto L_0344; E = P; L_0345: if (&P->LINK == NIL) goto L_0346; P = &P->LINK; goto L_0345; L_0346: P->LINK = KASL; KASL = E; L_0344: } /* FORGETENVIRONMENT */ void REMEMBERENVIRONMENT(int LABEL) { struct KNOWFM *K; struct KNOWFM *TOP; TOP = NIL; struct KNOWFM *P; FORGETENVIRONMENT(*LABEL); K = KNOWING; L_0347: if (K == NIL) goto L_0348; P = NEWK(); *P = *K; P->LINK = TOP; TOP = P; if (DIAG & 128 == 0) goto L_0349; MONREGID(P->REG, _imp_str_literal("in env")); L_0349: K = &K->LINK; goto L_0347; L_0348: ILABEL(*LABEL)->ENV = TOP; } /* REMEMBERENVIRONMENT */ void MERGEENVIRONMENT(int LABEL) { struct LABELFM *L; struct KNOWFM *P; struct KNOWFM *K; struct KNOWFM *NEXT; struct KNOWFM *TOP; if (DIAG & 128 == 0) goto L_034A; MONITOR(NIL, _imp_str_literal("merge")); L_034A: if (KNOWING != NIL) goto L_034B; FORGETENVIRONMENT(*LABEL); goto L_034C; L_034B: L = ILABEL(*LABEL); TOP = NIL; NEXT = &L->ENV; L_034D: P = NEXT; if (P != NIL) goto L_034E; goto L_034F; L_034E: NEXT = &P->LINK; K = KNOWING; L_0350: if (K->REG != P->REG) goto L_0351; if (K->DISP != P->DISP) goto L_0351; if (K->BASE != P->BASE) goto L_0351; if (K->FTYPE != P->FTYPE) goto L_0351; if (K->AREA != P->AREA) goto L_0351; if (K->OPND != P->OPND) goto L_0351; if (K->OPER != P->OPER) goto L_0351; P->LINK = TOP; TOP = P; if (DIAG & 128 == 0) goto L_0352; MONREGID(P->REG, _imp_str_literal("Merged")); L_0352: goto U_100B; L_0351: K = &K->LINK; if (K == NIL) goto L_0353; goto L_0350; L_0353: P->LINK = KASL; KASL = P; U_100B: goto L_034D; L_034F: L->ENV = TOP; L_034C: } /* MERGEENVIRONMENT */ void RESTOREENVIRONMENT(int LABEL) { struct KNOWFM *P; struct KNOWFM *K; struct KNOWFM *NEXT; FORGETEVERYTHING(); NEXT = &ILABEL(*LABEL)->ENV; L_0354: P = NEXT; if (P != NIL) goto L_0355; return; L_0355: NEXT = &P->LINK; K = NEWK(); *K = *P; K->LINK = KNOWING; KNOWING = K; KINC(K); if (DIAG & 128 == 0) goto L_0356; MONREGID(P->REG, _imp_str_literal("back")); L_0356: goto L_0354; } /* RESTOREENVIRONMENT */ void CLAIM(int REGISTER) { if (1 > *REGISTER) goto L_0357; if (*REGISTER > 26) goto L_0357; if (ACTIVITY[*REGISTER] >= 0) goto L_0358; L_0357: return; L_0358: ACTIVITY[*REGISTER] = ACTIVITY[*REGISTER] + 1; ACTIVEREGISTERS = ACTIVEREGISTERS + 1; USEDTIME = USEDTIME + 1; USED[*REGISTER] = USEDTIME; if (DIAG & 4 == 0) goto L_0359; MONITORREGISTER(*REGISTER, _imp_str_literal("Claimed")); L_0359: } /* CLAIM */ void RELEASE(int REGISTER) { if (1 > *REGISTER) goto L_035A; if (*REGISTER > 26) goto L_035A; if (ACTIVITY[*REGISTER] >= 0) goto L_035B; L_035A: return; L_035B: ACTIVITY[*REGISTER] = ACTIVITY[*REGISTER] - 1; if (ACTIVITY[*REGISTER] >= 0) goto L_035C; FAIL(_imp_str_literal("Register not claimed")); L_035C: if (DIAG & 4 == 0) goto L_035D; MONITORREGISTER(*REGISTER, _imp_str_literal("Released")); L_035D: ACTIVEREGISTERS = ACTIVEREGISTERS - 1; if (ACTIVEREGISTERS >= 0) goto L_035E; FAIL(_imp_str_literal("Register unclaimed")); L_035E: } /* RELEASE */ void TOSTORE(int CODE) { if (*CODE == 0) goto L_035F; if (*CODE != 3) goto L_0360; if (STACK->TYPE != 4) goto L_0361; LOADUP(STACK); L_0361: goto L_0362; L_0360: if (*CODE != 1) goto L_0363; if (STACK->TYPE == 4) goto L_0364; if (STACK->TYPE != 2) goto L_0365; L_0364: LOADUP(STACK); L_0365: L_0363: L_0362: L_035F: if (STACK->FORM == 0) goto L_0366; if (STACK->OPER != 0) goto L_0366; if (&STACK->INDEX == NIL) goto L_0367; L_0366: if (STACK->TYPE == 8) goto L_0368; if (STACK->TYPE != 9) goto L_0369; L_0368: EVALUATESTRINGEXPRESSION(STACK); goto L_036A; L_0369: LOADUP(STACK); HAZARD(STACK->BASE); L_036A: L_0367: } /* TOSTORE */ void PESSIMISE(struct STACKFM * V) { int REG; int N; int DISP; struct KNOWFM *K; struct STACKFM *T; if (DIAG & 8 == 0) goto L_036B; MONITOR(V, _imp_str_literal("Pessimise->")); L_036B: if (INREG(V)) goto L_036C; FAIL(_imp_str_literal("Not loaded")); L_036C: REG = V->OPER; N = KTIMES[REG]; K = KNOWING; if (N != 0) goto L_036D; K = NIL; L_036D: L_036E: if (K != NIL) goto L_036F; if (N == 0) goto L_0370; FAIL(_imp_str_literal("corrupt knowing")); L_0370: REG = V->OPER; if (1 > REG) goto L_0371; if (REG > 16) goto L_0371; T = CLAIMWORKAREA(4, 1); goto L_0372; L_0371: T = CLAIMWORKAREA(2 * 4, 7); L_0372: DISP = T->DISP; SIMPLE(V, T); RELEASE(REG); V->OPER = *LOCAL; V = DISP; V->OPND = 1; DROP(T); goto L_0373; L_036F: if (K->REG != REG) goto L_0374; N = N - 1; if (K->OPER != 0) goto L_0375; if (0 != K->OPND) goto L_0375; if (K->FTYPE != (V->AREA << 4) + 1) goto L_0376; if (K->AREA != V) goto L_0376; if (!(LOCKED(K->BASE))) goto L_0376; RELEASE(REG); V->OPER = K->BASE; V = K->DISP; V = K->EXTRA; V->OPND = 1; V->BASE = 128; CLAIM(V->OPER); goto L_0373; L_0376: if (K->FTYPE != (1 << 4) + 0) goto L_0377; if (K->BASE != 0) goto L_0377; if (K->AREA != 0) goto L_0377; RELEASE(REG); V->OPER = 0; V = K->DISP; V->OPND = 0; V = 0; V->BASE = 128; goto L_0373; L_0377: L_0375: goto L_0378; L_0374: if (K->BASE != REG) goto L_0379; N = N - 1; L_0379: L_0378: K = &K->LINK; goto L_036E; L_0373: if (DIAG & 8 == 0) goto L_037A; MONITOR(V, _imp_str_literal("Pessimise<-")); L_037A: } /* PESSIMISE */ void HAZARD(int REG) { int REGISTER; REGISTER = _imp_MOD(*REG); struct STACKFM *U; struct STACKFM *R; int *N; int DISP; int STORED; STORED = 0; void STORE(void) { struct STACKFM *T; if (STORED == 0) goto L_037B; return; L_037B: STORED = 1; if (1 > REGISTER) goto L_037C; if (REGISTER > 16) goto L_037C; T = CLAIMWORKAREA(4, 1); goto L_037D; L_037C: T = CLAIMWORKAREA(2 * 4, 7); L_037D: DISP = T->DISP; SIMPLE(®V[REGISTER], T); RELEASEANDDROP(T); } /* STORE */ if (DIAG & 4 == 0) goto L_037E; MONITORREGISTER(REGISTER, _imp_str_literal("Hazard")); L_037E: N = &ACTIVITY[REGISTER]; if (*N > 0) goto L_037F; return; L_037F: U = USING; L_0380: if (U == NIL) goto L_0381; if (U->BASE != REGISTER) goto L_0382; if (DIAG & 4 == 0) goto L_0383; MONITOR(U, _imp_str_literal("Hazarding")); L_0383: if (*N != 1) goto L_0384; if (STORED != 0) goto L_0384; if (!(INREG(U))) goto L_0384; PESSIMISE(U); return; L_0384: STORE(); if (U->FORM != 0) goto L_0385; if (U->DISP != 0) goto L_0385; if (&U->INDEX != NIL) goto L_0385; U->FORM = 1; U->BASE = *LOCAL; U->DISP = DISP; goto L_0386; L_0385: if (&U->RECORD == NIL) goto L_0387; FAIL(_imp_str_literal("Corrupt record")); L_0387: R = LOCALINTEGER(DISP); R->FLAGS = 16; U->BASE = 0; U->RECORD = R; L_0386: RELEASE(REGISTER); L_0382: U = &U->USING; goto L_0380; L_0381: if (*N == 0) goto L_0388; if (*N == 0) goto L_0389; FAIL(_imp_str_literal("Use lost")); L_0389: L_0388: } /* HAZARD */ void HAZARDALL(void) { HAZARD(1); HAZARD(2); HAZARD(3); HAZARD(4); if (ACTIVEREGISTERS != 0) goto L_038A; return; L_038A: HAZARD(5); HAZARD(6); HAZARD(7); HAZARD(8); if (ACTIVEREGISTERS != 0) goto L_038B; return; L_038B: HAZARD(9); HAZARD(12); HAZARD(15); if (ACTIVEREGISTERS != 0) goto L_038C; return; L_038C: HAZARD(18); HAZARD(19); HAZARD(20); HAZARD(21); if (ACTIVEREGISTERS != 0) goto L_038D; return; L_038D: HAZARD(22); HAZARD(23); HAZARD(24); HAZARD(25); } /* HAZARDALL */ struct STACKFM *DESCRIPTOR(void) { struct STACKFM *V; if (DASL != NIL) goto L_038E; DASL = _imp_NEW(STACKFMTYPE); DASL->USING = NIL; L_038E: V = DASL; DASL = &V->USING; *V = 0; V->USING = USING; USING = V; return V; } /* DESCRIPTOR */ void DROPALL(struct STACKFM * V) { if (&V->INDEX == NIL) goto L_038F; DROPALL(&V->INDEX); V->INDEX = NIL; L_038F: if (&V->RECORD == NIL) goto L_0390; DROPALL(&V->RECORD); V->RECORD = NIL; L_0390: DROP(V); } /* DROPALL */ void DROP(struct STACKFM * V) { struct STACKFM *P; struct STACKFM *E; if (DIAG & 2 == 0) goto L_0391; MONITOR(V, _imp_str_literal("Drop")); L_0391: ZAPINDEXANDRECORD(V); if (USING != V) goto L_0392; USING = &V->USING; goto L_0393; L_0392: P = USING; L_0394: if (P != NIL) goto L_0395; FAIL(_imp_str_literal("Not in use")); L_0395: E = P; P = &P->USING; if (P == V) goto L_0396; goto L_0394; L_0396: E->USING = &P->USING; L_0393: V->USING = DASL; DASL = V; } /* DROP */ void RELEASEANDDROP(struct STACKFM * V) { if (&V->LINK == NIL) goto L_0397; RELEASEANDDROP(&V->LINK); L_0397: RELEASE(V->BASE); DROP(V); } /* RELEASEANDDROP */ void ZAPINDEXANDRECORD(struct STACKFM * V) { if (&V->INDEX == NIL) goto L_0398; RELEASEANDDROP(&V->INDEX); V->INDEX = NIL; L_0398: if (&V->RECORD == NIL) goto L_0399; RELEASEANDDROP(&V->RECORD); V->RECORD = NIL; L_0399: } /* ZAPINDEXANDRECORD */ void RELEASEANDDROPPAIR(struct STACKFM * A, struct STACKFM * B) { RELEASEANDDROP(A); RELEASEANDDROP(B); } /* RELEASEANDDROPPAIR */ void POPRELEASEANDDROP(void) { struct STACKFM *S; S = STACK; STACK = &S->STACK; RELEASEANDDROP(S); } /* POPRELEASEANDDROP */ void DROPMEMBERS(struct STACKFM * S) { struct MEMBERFM *M; struct MEMBERFM *X; M = &S->MEMBERS; S->MEMBERS = NIL; L_039A: if (M == NIL) goto L_039B; X = M; M = &M->LINK; if (X->CONST == 0) goto L_039C; DROP(&X->A); if (&X->B == NIL) goto L_039D; DROP(&X->B); L_039D: goto L_039E; L_039C: RELEASEANDDROP(&X->A); if (&X->B == NIL) goto L_039F; RELEASEANDDROP(&X->B); L_039F: L_039E: _imp_DISPOSE(X); goto L_039A; L_039B: } /* DROPMEMBERS */ void APPLYINDIRECTION(void) { struct STACKFM *W; W = STACK; STACK = DESCRIPTOR(); STACK->STACK = &W->STACK; STACK->TYPE = W->TYPE; STACK->FORM = 1; STACK->RECORD = W; STACK->FORMAT = W->FORMAT; W->TYPE = 1; W->FORM = 1; W->FORMAT = 0; } /* APPLYINDIRECTION */ void STACKTRUEORFALSE(int CC) { int OTHER; int R; int LAB; struct STACKFM *V; V = LITERAL(0); OPTIMISE(V, 1); if (!(INREG(V))) goto L_03A0; *CC = NEGATED[*CC]; OTHER = 1; goto L_03A1; L_03A0: V->DISP = 1; OTHER = 0; L_03A1: LOADPROTECTED(V); R = V->BASE; RELEASEANDDROP(V); if (ACTIVITY[R] == 0) goto L_03A2; FAIL(_imp_str_literal("register active")); L_03A2: LAB = NEWLABEL(); JUMPTO(LAB, *CC); V = LITERAL(OTHER); LOAD(V, R); DEFINELABEL(LAB); FORGET(R); V->STACK = STACK; STACK = V; } /* STACKTRUEORFALSE */ void STACKVAR(int VARNO) { int FORM; int FLAGS; struct STACKFM *V; V = DESCRIPTOR(); V->V = *VAR(VARNO); V->VARNO = VARNO; V->STACK = STACK; STACK = V; if (STACK->BASE != 10) goto L_03A3; ATTRIBUTES = ATTRIBUTES | 4; L_03A3: FORM = V->FORM; if (V->FLAGS & 8388608 == 0) goto L_03A4; FLAGS = V->FLAGS; V->FLAGS = 0; APPLYINDIRECTION(); STACK->FLAGS = FLAGS & (~8388608); L_03A4: if (FORM != 15) goto L_03A5; APPLYINDIRECTION(); L_03A5: if (DIAG & 2 == 0) goto L_03A6; MONITOR(STACK, _imp_str_literal("Stack Var")); L_03A6: } /* STACKVAR */ struct STACKFM *LOCALINTEGER(int DISP) { struct STACKFM *V; V = DESCRIPTOR(); V->TYPE = 1; V->FORM = 1; V->BASE = *LOCAL; V->DISP = DISP; V->FLAGS = 128; return V; } /* LOCALINTEGER */ struct STACKFM *LITERAL(int N) { struct STACKFM *V; V = DESCRIPTOR(); V->DISP = N; V->TYPE = 1; V->FLAGS = 128; return V; } /* LITERAL */ void STACKINTEGER(int N) { struct STACKFM *V; V = LITERAL(*N); V->STACK = STACK; STACK = V; } /* STACKINTEGER */ int POPPEDVALUE(void) { struct STACKFM *V; V = STACK; STACK = &V->STACK; DROP(V); return V->DISP; } /* POPPEDVALUE */ struct STACKFM *TEMPORARY(void) { struct STACKFM *V; FRAME = (FRAME & -4) - 4; V = LOCALINTEGER(FRAME); return V; } /* TEMPORARY */ struct STACKFM *COPY(struct STACKFM * V) { struct STACKFM *C; if (V != NIL) goto L_03A7; return NIL; L_03A7: C = DESCRIPTOR(); C->DATA = V->DATA; CLAIM(C->BASE); C->OPER = V->OPER; if (&V->INDEX == NIL) goto L_03A8; C->INDEX = COPY(&V->INDEX); L_03A8: if (&V->RECORD == NIL) goto L_03A9; C->RECORD = COPY(&V->RECORD); L_03A9: if (&V->LINK == NIL) goto L_03AA; C->LINK = COPY(&V->LINK); L_03AA: return C; } /* COPY */ void SELECT(int ITEM) { struct STACKFM *V; struct STACKFM *X; struct VARFM *FIELD; V = STACK; FIELD = VAR(VAR(-V->FORMAT)->EXTRA - *ITEM); if (V->FORM != 0) goto L_03AB; FAIL(_imp_str_literal("Select")); L_03AB: STACK->VARNO = 0; if (V->FORM != 1) goto L_03AC; if (&V->INDEX != NIL) goto L_03AC; V->DISP = V->DISP + FIELD->DISP; V->TYPE = FIELD->TYPE; V->FORM = FIELD->FORM; V->FORMAT = FIELD->FORMAT; V->FLAGS = FIELD->FLAGS; V->ADATA = &FIELD->ADATA; goto L_03AD; L_03AC: AMAP(V); X = DESCRIPTOR(); X->V = *FIELD; X->BASE = 0; X->RECORD = V; STACK = X; X->STACK = &V->STACK; L_03AD: if (STACK->FORM != 15) goto L_03AE; APPLYINDIRECTION(); L_03AE: if (DIAG & 2 == 0) goto L_03AF; MONITOR(STACK, _imp_str_literal("Select")); L_03AF: } /* SELECT */ void XCALL(int EP, int STACKIT, int HAZARD) { struct STACKFM *V; if (*HAZARD <= 0) goto L_03B0; if (ACTIVEREGISTERS == 0) goto L_03B0; HAZARDALL(); L_03B0: DIR2(23, *EP); REFS = REFS + 1; *CA = *CA + 4; if (*HAZARD < 0) goto L_03B1; FORGETEVERYTHING(); L_03B1: ATTRIBUTES = ATTRIBUTES | 4; if (*STACKIT == 0) goto L_03B2; ATTRIBUTES = ATTRIBUTES | 64; V = REGISTER(*STACKIT); V->STACK = STACK; STACK = V; L_03B2: } /* XCALL */ void CHECKCOMPILERLABEL(int LABEL) { if (*LABEL <= 8191) goto L_03B3; FAIL(_imp_str_literal("compiler labels/1")); L_03B3: } /* CHECKCOMPILERLABEL */ int NEWLABEL(void) { FREELABEL = FREELABEL + 1; if (FREELABEL & 32768 == 0) goto L_03B4; FAIL(_imp_str_literal("too many internal labels")); L_03B4: return FREELABEL; } /* NEWLABEL */ void JUMPTO(int INTERNALLABEL, int CONDCODE) { JLAB = *INTERNALLABEL; if (INVERT == 0) goto L_03B5; *CONDCODE = REVERSE[*CONDCODE]; INVERT = 0; L_03B5: DIR3(14, *INTERNALLABEL, *CONDCODE + UNSIGNED); UNSIGNED = 0; REFS = REFS + 1; *CA = *CA + 4; if (*CONDCODE != 7) goto L_03B6; UNCONDJUMP = *CA; L_03B6: ASSIGNLOCK = 0; } /* JUMPTO */ void DEFINELABEL(int INTERNALLABEL) { DIR2(8, *INTERNALLABEL); UNCONDJUMP = -1; ASSIGNLOCK = 0; } /* DEFINELABEL */ void DEFINECOMPILERLABEL(int LABEL) { struct LABELFM *L; CHECKCOMPILERLABEL(*LABEL); L = ILABEL(*LABEL); if (L->LAB & -2147483648 == 0) goto L_03B7; FORGETENVIRONMENT(*LABEL); L->LAB = NEWLABEL(); L_03B7: L->LAB = L->LAB | -2147483648; if (UNCONDJUMP == *CA) goto L_03B8; MERGEENVIRONMENT(*LABEL); L_03B8: DEFINELABEL(L->LAB & 2147483647); RESTOREENVIRONMENT(*LABEL); } /* DEFINECOMPILERLABEL */ int FORWARDLABEL(int LABEL) { struct LABELFM *L; L = ILABEL(*LABEL); if (L->LAB & -2147483648 == 0) goto L_03B9; L->LAB = NEWLABEL(); REMEMBERENVIRONMENT(*LABEL); goto L_03BA; L_03B9: MERGEENVIRONMENT(*LABEL); L_03BA: return L->LAB; } /* FORWARDLABEL */ void JUMPFORWARD(int LABEL, int CONDCODE) { CHECKCOMPILERLABEL(*LABEL); JUMPTO(FORWARDLABEL(*LABEL), CONDCODE); if (CONDCODE != 6) goto L_03BB; if (PENDINGKNOWNREGISTER == 0) goto L_03BB; REMEMBER(PENDINGKNOWNREGISTER, &PENDINGKNOWN); L_03BB: PENDINGKNOWNREGISTER = 0; } /* JUMPFORWARD */ void JUMPBACKWARD(int LABEL) { struct STACKFM C; struct STACKFM F; struct STACKFM *U; struct STACKFM *CC; struct FORFM *FOR; FOR = NIL; struct VARFM *VR; struct LABELFM *L; int HOW; CHECKCOMPILERLABEL(LABEL); L = ILABEL(LABEL); HOW = 7; if (L->LAB & -2147483648 != 0) goto L_03BC; FAIL(_imp_str_literal("Label missing")); L_03BC: if (FORS == NIL) goto L_03BD; if (LABEL != FORS->LABEL) goto L_03BD; FOR = FORS; FORS = &FORS->LINK; C.DATA = FOR->CONTROL; VMAP(&C, FOR->TYPE); LOAD(&C, FOR->REG); if (FOR->ENTRY == 0) goto L_03BE; DEFINECOMPILERLABEL(FOR->ENTRY); L_03BE: F.DATA = FOR->FINAL; COMPARE(&C, &F); RELEASE(C.BASE); RELEASE(F.BASE); HOW = FOR->CC; L_03BD: JUMPTO(L->LAB & 2147483647, HOW); if (FOR == NIL) goto L_03BF; if (HOW == 7) goto L_03C0; if (LANGUAGEFLAGS & 4 == 0) goto L_03C0; if (UNASSIGNED == 0) goto L_03C0; CC = LITERAL(0); CC->DATA = FOR->CONTROL; VMAP(CC, FOR->TYPE); U = COPY(&UAPAT); U->TYPE = FOR->TYPE; SIMPLE(U, CC); FORGETDESTINATION(CC); FORGET(U->BASE); RELEASEANDDROP(U); RELEASEANDDROP(CC); if (FOR->CONTROL == 0) goto L_03C1; VR = VAR(FOR->CONTROL); VR->FLAGS = VR->FLAGS & (~128); L_03C1: L_03C0: _imp_DISPOSE(FOR); L_03BF: } /* JUMPBACKWARD */ void SETUSERLABEL(int LABEL) { struct VARFM *V; V = VAR(LABEL); CLEARVARS(LABEL); V->TYPE = 11; V->BASE = *LOCAL; V->DISP = NEWLABEL(); } /* SETUSERLABEL */ void USERJUMP(int LABEL) { static int JOUT = 0; int B; struct STACKFM *BASE; struct VARFM *V; struct VARFM C; V = VAR(*LABEL); if (*LABEL > *VARS) goto L_03C2; if (V->DISP != 0) goto L_03C3; L_03C2: SETUSERLABEL(*LABEL); L_03C3: B = V->BASE; if (B == *LOCAL) goto L_03C4; BASE = DISPLAYINFO(B); RELEASEANDDROP(BASE); BASE = LITERAL(0); BASE->BASE = B; BASE->FLAGS = 128; LOAD(BASE, 11); BASE->DISP = V->EXTRA; BASE->FORM = 1; BASE->FLAGS = 128; LOAD(BASE, 4); RELEASEANDDROP(BASE); DO(_imp_str_literal("3L_pascal___jump_out"), &JOUT, 0); L_03C4: JUMPTO(V->DISP, 7); } /* USERJUMP */ void MARKUSERLABEL(void) { DIR1(9); } /* MARKUSERLABEL */ void DEFINEUSERLABEL(int LABEL) { struct VARFM *V; V = VAR(LABEL); if (LABEL > *VARS) goto L_03C5; if (V->DISP != 0) goto L_03C6; L_03C5: SETUSERLABEL(LABEL); L_03C6: DEFINELABEL(V->DISP); MARKUSERLABEL(); FORGETEVERYTHING(); } /* DEFINEUSERLABEL */ void RETURN(int HOW) { int RESULTREG; int TYPE; struct STACKFM *V; struct STACKFM *W; if (UNCONDJUMP != *CA) goto L_03C7; if (*HOW >= 0) goto L_03C8; POPRELEASEANDDROP(); L_03C8: return; L_03C7: V = NIL; RESULTREG = 1; TYPE = AVAR; if (*HOW != 1) goto L_03C9; V = LITERAL(1); goto L_03CA; L_03C9: if (*HOW != 2) goto L_03CB; V = LITERAL(0); goto L_03CA; L_03CB: if (*HOW == 0) goto L_03CC; V = STACK; STACK = &STACK->STACK; if (*HOW != -2) goto L_03CD; AMAP(V); TYPE = 5; goto L_03CE; L_03CD: if (TYPE == 8) goto L_03CF; if (TYPE != 9) goto L_03D0; L_03CF: W = LITERAL(0); W->TYPE = TYPE; W->FORM = 1; W->RECORD = LOCALINTEGER(STRINGRESULT); W->RECORD = AVAR; if (W->TYPE != 8) goto L_03D1; STRINGASSIGN(V, W); goto L_03D2; L_03D1: RECORDASSIGN(V, W); L_03D2: RELEASEANDDROPPAIR(W, V); V = NIL; L_03D0: L_03CE: L_03CC: L_03CA: if (V == NIL) goto L_03D3; if (TYPE == 6) goto L_03D4; if (TYPE != 7) goto L_03D5; L_03D4: LOAD(V, 18); goto L_03D6; L_03D5: LOAD(V, RESULTREG); L_03D6: RELEASEANDDROP(V); L_03D3: DIR2(26, PARAMETERFRAME); REFS = REFS + 1; *CA = *CA + 4; UNCONDJUMP = *CA; OPEN = 0; } /* RETURN */ void STAB(struct STACKFM * V) { struct STACKFM *T; struct STACKFM *TT; if (!(ICONST(&V))) goto L_03D7; return; L_03D7: T = TEMPORARY(); TT = COPY(T); STORE(&V, T); RELEASEANDDROP(T); REPLACE(&V, TT); V = V | 128; } /* STAB */ void COMPILEFOR(int REPEATLABEL) { int TYPE; int N; struct STACKFM *INITIAL; struct STACKFM *FINAL; struct STACKFM *INC; struct STACKFM *CONTROL; struct STACKFM *INCREMENT; struct STACKFM *C; struct FORFM *FOR; struct VARFM *V; int LOOPTYPE(void) { int I; int N; if (!(ICONST(INITIAL))) goto L_03D8; if (!(ICONST(INC))) goto L_03D8; if (ICONST(FINAL)) goto L_03D9; L_03D8: return 1; L_03D9: I = INC->DISP; N = FINAL->DISP - INITIAL->DISP + I; if (I == 0) goto L_03DA; if (N != 0) goto L_03DB; return 1; L_03DB: if (N ^ I < 0) goto L_03DC; if (_imp_REM(N, I) != 0) goto L_03DC; if (FORRANGE == NIL) goto L_03DD; if (FORRANGE->DISP > INITIAL->DISP) goto L_03DE; if (INITIAL->DISP > FORRANGE->EXTRA) goto L_03DE; if (FORRANGE->DISP > FINAL->DISP) goto L_03DE; if (FINAL->DISP <= FORRANGE->EXTRA) goto L_03DF; L_03DE: return 1; L_03DF: FORRANGE = NIL; L_03DD: return 0; L_03DC: goto L_03E0; L_03DA: I = 1; L_03E0: if (LANGUAGEFLAGS & 2 != 0) goto L_03E1; WARN(1, _imp_str_literal("Non-integral %for loop")); FINAL->DISP = INITIAL->DISP + ((long)N / (long)I) * I; L_03E1: return 1; } /* LOOPTYPE */ FINAL = STACK; INC = &FINAL->STACK; INITIAL = &INC->STACK; CONTROL = &INITIAL->STACK; STACK = &CONTROL->STACK; STAB(INC); TYPE = CONTROL->TYPE; if (CONTROL->FORM != 1) goto L_03E2; if (&CONTROL->INDEX != NIL) goto L_03E2; if (&CONTROL->RECORD != NIL) goto L_03E2; if (CONTROL->BASE == 0) goto L_03E3; if (CONTROL->BASE == *LOCAL) goto L_03E3; if (CONTROL->BASE == 10) goto L_03E3; L_03E2: AMAP(CONTROL); STAB(CONTROL); goto L_03E4; L_03E3: AMAP(CONTROL); L_03E4: SIMPLIFY(CONTROL); FOR = _imp_NEW(FORFMTYPE); FOR->LINK = FORS; FORS = FOR; FOR->LABEL = *REPEATLABEL; FOR->CONTROL = CONTROL->DATA; VMAP(CONTROL, TYPE); FOR->TYPE = TYPE; FOR->ENTRY = LOOPTYPE(); FOR->AS = 0; N = INC->DISP; FOR->CC = 6; if (LANGUAGEFLAGS & 2 == 0) goto L_03E5; if (FOR->ENTRY == 0) goto L_03E5; if (N != 1) goto L_03E6; FOR->CC = 2; goto L_03E7; L_03E6: if (N != -1) goto L_03E8; FOR->CC = 4; goto L_03E7; L_03E8: FAIL(_imp_str_literal("corrupt increment")); L_03E7: L_03E5: INCREMENT = COPY(INC); OPERATE(5, INITIAL, INC); LOADUP(INITIAL); FOR->REG = INITIAL->BASE; STAB(FINAL); FOR->FINAL = FINAL->DATA; LOAD(INITIAL, FOR->REG); if (FOR->ENTRY == 0) goto L_03E9; if (LANGUAGEFLAGS & 4 != 0) goto L_03EA; C = COPY(CONTROL); STORE(INITIAL, C); RELEASEANDDROP(C); L_03EA: FOR->ENTRY = *REPEATLABEL + 2; JUMPFORWARD(FOR->ENTRY, 7); L_03E9: DEFINECOMPILERLABEL(*REPEATLABEL); if (FOR->AS != 0) goto L_03EB; OPERATE(4, INITIAL, INCREMENT); LOAD(INITIAL, FOR->REG); L_03EB: if (FORRANGE == NIL) goto L_03EC; TESTRANGE(INITIAL, FORRANGE); FORRANGE = NIL; L_03EC: STORE(INITIAL, CONTROL); FOR->CONTROL = FOR->CONTROL | 128; if (CONTROL->VARNO == 0) goto L_03ED; V = VAR(CONTROL->VARNO); V->FLAGS = V->FLAGS | 128; L_03ED: RELEASEANDDROPPAIR(CONTROL, INITIAL); RELEASEANDDROP(FINAL); } /* COMPILEFOR */ struct STACKFM *CONSTSTRING(void) { struct STACKFM *W; CONSTANTBASE = CONSTANTBASE + 3 & (~3); SELECTCONSTANTAREA(); W = LITERAL(*CA); W->TYPE = 8; W->FORM = 1; W->AREA = 512; W->FORMAT = *_imp_LENGTH(&VALUE.STRING) + 1; W->BIAS = W->FORMAT; if (_imp_strcmp(VALUE.STRING, _imp_str_literal("")) == 0) goto L_03EE; DUMPTEXT(0); L_03EE: SELECTCODEAREA(); return W; } /* CONSTSTRING */ void FIXTOSTRING(struct STACKFM * C) { struct STACKFM *W; VALUE.STRING = _imp_TOSTRING(C); W = CONSTSTRING(); C = W->DATA; DROP(W); } /* FIXTOSTRING */ void SETSIZEORTYPE(int ST, struct STACKFM *V) { int N; if (V->TYPE != 10) goto L_03EF; AMAP(V); V->DISP = V->DISP + *ST * 4; goto L_03F0; L_03EF: if (*ST != 1) goto L_03F1; N = ITEMSIZE(V->FORMAT); if (N != 1) goto L_03F2; if (V->TYPE != 8) goto L_03F2; AMAP(V); ADVANCE(V, 1, 4); return; L_03F2: goto L_03F3; L_03F1: N = TYPECODE[V->TYPE]; L_03F3: RELEASE(V->BASE); ZAPINDEXANDRECORD(V); V->DATA = 0; V->DISP = N; V->TYPE = 1; V->FORM = 0; L_03F0: } /* SETSIZEORTYPE */ void APPLYTRUNC(struct STACKFM * V) { int R; if (FLOATING(V)) goto L_03F4; return; L_03F4: LOAD(V, 26); RELEASE(V->BASE); R = GPR(); PLANT7(236454160 | 3 << 5, 0, R, V->BASE); V->TYPE = 1; V->BASE = R; CLAIM(R); } /* APPLYTRUNC */ void CONVERTFUNCTION(int OP, struct STACKFM *V) { if (FLOATING(V)) goto L_03F5; return; L_03F5: LOAD(V, 18); RELEASE(18); PRIM(OP); V->TYPE = 1; V->BASE = 1; CLAIM(1); } /* CONVERTFUNCTION */ void APPLYROUND(struct STACKFM * V) { CONVERTFUNCTION(53, V); } /* APPLYROUND */ void APPLYINTPT(struct STACKFM * V) { int R; if (FLOATING(V)) goto L_03F6; return; L_03F6: LOAD(V, 26); RELEASE(V->BASE); R = GPR(); PLANT7(236454160 | 2 << 5, 0, R, V->BASE); V->TYPE = 1; V->BASE = R; CLAIM(R); } /* APPLYINTPT */ void APPLYINT(struct STACKFM * V) { int R; if (FLOATING(&V)) goto L_03F7; return; L_03F7: LOAD(&V, 26); RELEASE(V); PLANT9(234881408 | 8, V, V, 6); R = GPR(); PLANT7(236454160 | 2 << 5, 0, R, V); V = 1; V = R; CLAIM(R); } /* APPLYINT */ void XDEFINE(int *EP, _imp_string63 TEXT, int P) { struct VARFM C; C = 0; if (EP != 0) goto L_03F8; EXTERNALID = *TEXT; if (P != 0) goto L_03F9; DUMPEXTERNAL(0, &C); EP = C.AREA; goto L_03FA; L_03F9: C.FORM = 4; DUMPEXTERNAL(2, &C); EP = C.DISP; L_03FA: L_03F8: } /* XDEFINE */ void STACKREGISTER(int R) { struct STACKFM *X; X = LITERAL(0); X->BASE = *R; CLAIM(*R); X->STACK = STACK; STACK = X; } /* STACKREGISTER */ void DO(_imp_string31 IDENT, int *EP, int RESULT) { XDEFINE(EP, *IDENT, 1); XCALL(*EP, RESULT, 1); } /* DO */ void DOCONDITIONALEXTERNAL(int CC, _imp_string31 IDENT, int *EP) { int LABEL; XDEFINE(&EP, IDENT, 1); if (ACTIVEREGISTERS == 0) goto L_03FB; HAZARDALL(); L_03FB: if (*CC == 7) goto L_03FC; LABEL = NEWLABEL(); JUMPTO(LABEL, NEGATED[*CC]); L_03FC: XCALL(EP, 0, 0); if (*CC == 7) goto L_03FD; DEFINELABEL(LABEL); L_03FD: } /* DOCONDITIONALEXTERNAL */ void SPECIALCALL(int N) { struct STACKFM *V; V = STACK; struct STACKFM *X; struct STACKFM *Y; struct STACKFM *Z; static int READCHEP = 0; static int IREAD = 0; static int RREAD = 0; static int SREAD = 0; static int NEXTCHEP = 0; int TYPE; static const void *SP[59] = { &&case_SP_1, &&case_SP_2, &&case_SP_3, &&case_SP_4, &&case_SP_5, &&case_SP_6, &&case_SP_7, &&case_SP_8, &&case_SP_9, &&case_SP_10, &&case_SP_11, &&case_SP_12, &&case_SP_13, &&case_SP_14, &&case_SP_15, &&case_SP_16, &&case_SP_17, &&case_SP_18, &&case_SP_19, &&case_SP_20, &&case_SP_21, &&case_SP_22, &&case_SP_23, &&case_SP_24, &&case_SP_25, &&case_SP_26, &&case_SP_27, &&case_SP_28, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_default, &&case_SP_41, &&case_SP_42, &&case_SP_43, &&case_SP_44, &&case_SP_45, &&case_SP_46, &&case_SP_47, &&case_SP_48, &&case_SP_49, &&case_SP_50, &&case_SP_51, &&case_SP_52, &&case_SP_53, &&case_SP_54, &&case_SP_55, &&case_SP_56, &&case_SP_57, &&case_SP_58, &&case_SP_59}; const unsigned char TYPEMAP[7] = {8, 1, 2, 4, 6, 7, 9}; const unsigned char LENMAP[7] = {0, 4, 2, 1, 4, 8, 0}; if (0 >= N) goto L_03FE; if (N > 59) goto L_03FE; goto *SP[N - 1]; /*TO DO*/ L_03FE: case_SP_default:; FAIL(_imp_str_literal("Bad primitive")); void PSYM(struct STACKFM * CHAR) { static int PRINTSYMBOLEP = 0; LOAD(&CHAR, 1); RELEASEANDDROP(&CHAR); PRIM(45); FORGETEVERYTHING(); } /* PSYM */ void DOPRINTSTRING(void) { static int PRINTSTRINGEP = 0; struct STACKFM *S; struct STACKFM *V; V = STACK; STACK = &STACK->STACK; L_0400: S = V; V = &S->LINK; S->OPER = 0; S->LINK = NIL; if (S->TYPE > 5) goto L_0401; PSYM(S); goto L_0402; L_0401: if (S->BIAS != 1) goto L_0403; RELEASEANDDROP(S); goto L_0402; L_0403: AMAP(S); LOAD(S, 1); RELEASEANDDROP(S); DO(_imp_str_literal("3L_IMP_PRINT_STRING"), &PRINTSTRINGEP, 0); L_0402: if (V == NIL) goto L_0404; goto L_0400; L_0404: } /* DOPRINTSTRING */ void LOADEXTERNALVARIABLE(_imp_string63 ID, int *EP) { struct STACKFM *V; struct VARFM X; if (*EP != 0) goto L_0405; X.FORM = 0; EXTERNALID = *ID; DUMPEXTERNAL(0, &X); *EP = -X.AREA; L_0405: HAZARD(2); DIR3(13, ACTUAL[2], *EP); REFS = REFS + 1; *CA = *CA + 4; ATTRIBUTES = ATTRIBUTES | 4; } /* LOADEXTERNALVARIABLE */ void DOINPUT(int FN) { struct STACKFM *R; static int INSCB = 0; HAZARDALL(); LOADEXTERNALVARIABLE(_imp_str_literal("3L___cur_in"), &INSCB); FORGETEVERYTHING(); DUMPWORD(-460255232); DUMPWORD(-393150436); DUMPWORD(-514719741); PRIM(55); if (*FN != 0) goto L_0406; DUMPWORD(-455983104); goto L_0407; L_0406: DUMPWORD(-455983103); DUMPWORD(-469688320); L_0407: if (*FN < 0) goto L_0408; R = REGISTER(5); R->STACK = STACK; STACK = R; if (*FN != 1) goto L_0409; ASSIGN(0); L_0409: L_0408: } /* DOINPUT */ case_SP_1:; DOINPUT(1); return; case_SP_2:; DOINPUT(0); return; case_SP_26:; DOINPUT(-1); return; case_SP_25:; STACK = &V->STACK; PSYM(V); return; case_SP_27:; X = LITERAL(10); PSYM(X); return; case_SP_28:; X = LITERAL(32); PSYM(X); return; case_SP_24:; DOPRINTSTRING(); return; case_SP_23:; if (V->TYPE != 8) goto L_040A; TYPE = 8; X = LITERAL(ITEMSIZE(STACK->FORMAT) - 1); AMAP(STACK); LOAD(STACK, 1); LOAD(X, 2); RELEASEANDDROP(X); POPRELEASEANDDROP(); DO(_imp_str_literal("3L_IMP___read_s"), &SREAD, 0); goto L_040B; L_040A: if (1 > V->TYPE) goto L_040C; if (V->TYPE > 5) goto L_040C; TYPE = 1; DO(_imp_str_literal("3L_IMP___read_i"), &IREAD, 1); goto L_040D; L_040C: if (V->TYPE == 6) goto L_040E; if (V->TYPE != 7) goto L_040F; L_040E: TYPE = 7; DO(_imp_str_literal("3L_IMP___read_r"), &RREAD, 18); goto L_040D; L_040F: WARN(1, _imp_str_literal("Bad type of parameter for READ")); TYPE = 1; L_040D: STACK->TYPE = TYPE; if (TYPE != 8) goto L_0410; STACK->FORM = 1; L_0410: ASSIGN(0); L_040B: return; case_SP_20:; AMAP(V); return; case_SP_3:; case_SP_4:; case_SP_5:; case_SP_6:; case_SP_7:; case_SP_8:; case_SP_9:; VMAP(V, TYPEMAP[N]); V->FORMAT = LENMAP[N]; return; case_SP_10:; FLOAT(STACK, FPR()); return; case_SP_11:; X = &V->STACK; STACK = &X->STACK; OPERATE(16, V, X); V->STACK = STACK; STACK = V; return; case_SP_12:; ADVANCE(V, 4, 0); return; case_SP_13:; X = &V->STACK; STACK = &X->STACK; if (&V->INDEX == NIL) goto L_0411; SIMPLIFY(V); L_0411: V->TYPE = 4; APPLYINDEX(V, X, 1); V->STACK = STACK; STACK = V; return; case_SP_14:; STACKINTEGER(10); case_SP_15:; SIMPLIFY(STACK); return; case_SP_16:; SETSIZEORTYPE(1, V); return; case_SP_17:; SETSIZEORTYPE(2, V); return; case_SP_19:; APPLYINT(V); return; case_SP_18:; APPLYINTPT(V); return; case_SP_22:; APPLYROUND(V); return; case_SP_21:; APPLYTRUNC(V); return; const _imp_string255 FILLID = _imp_str_literal("3L_pascal___fill"); static int FILLEP = 0; const _imp_string255 FTXTID = _imp_str_literal("3L_pascal___fill_text"); static int FTXTEP = 0; const _imp_string255 SAFEID = _imp_str_literal("3L_pascal___safe"); static int SAFEEP = 0; const _imp_string255 EMPTYID = _imp_str_literal("3L_pascal___empty"); static int EMPTYEP = 0; const _imp_string255 EOLNID = _imp_str_literal("3L_pascal___eoln_error"); static int EOLNEP = 0; const _imp_string255 READLNID = _imp_str_literal("3L_pascal___read_ln"); static int READLNEP = 0; const _imp_string255 WRITELNID = _imp_str_literal("3L_pascal___write_ln"); static int WRITELNEP = 0; const _imp_string255 WRITECID = _imp_str_literal("3L_pascal___write_char"); static int WRITECEP = 0; void MAKESAFE(struct STACKFM * F, int EOF) { struct STACKFM *P; struct STACKFM *B; struct STACKFM *V2; struct STACKFM *V3; SIMPLIFY(&F); ADVANCE(&F, 1, 0); P = COPY(&F); B = COPY(&F); ADVANCE(B, 1, 4); if (B->BASE >= 128) goto L_0412; if (ACTIVITY[B->BASE] >= 0) goto L_0413; L_0412: V2 = COPY(B); V3 = COPY(P); goto L_0414; L_0413: V2 = NIL; V3 = NIL; L_0414: LOAD(B, 3); P->FLAGS = P->FLAGS | 128; LOAD(P, 4); VMAP(B, 1); ADVANCE(B, 1, 0); B->FLAGS = B->FLAGS | 128; LOAD(B, 5); COMPARE(P, B); RELEASEANDDROPPAIR(P, B); if (EOF != 0) goto L_0415; DOCONDITIONALEXTERNAL(4, FTXTID, &FTXTEP); goto L_0416; L_0415: DOCONDITIONALEXTERNAL(4, SAFEID, &SAFEEP); L_0416: F = F | 128; if (V2 == NIL) goto L_0417; REMEMBER(3, V2); REMEMBER(4, V3); RELEASEANDDROPPAIR(V2, V3); V2 = REGISTER(3); V2->FORM = 1; REMEMBER(5, V2); RELEASEANDDROP(V2); L_0417: } /* MAKESAFE */ void ONTOBOOLEAN(struct STACKFM * F, int DISP, int KNOWN) { ADVANCE(&F, 1, 4); F = F | *KNOWN; LOAD(&F, 3); VMAP(&F, 4); ADVANCE(&F, 4, *DISP); F = F | 128; } /* ONTOBOOLEAN */ void EOF(struct STACKFM * F, int TEXT) { if (*TEXT == 0) goto L_0418; MAKESAFE(F, 0); L_0418: ONTOBOOLEAN(F, 12, 0); } /* EOF */ void EOLN(struct STACKFM * F) { MAKESAFE(F, 1); ONTOBOOLEAN(F, 13, 128); } /* EOLN */ case_SP_41:; STACK = &STACK->STACK; SIMPLIFY(V); ADVANCE(V, 1, 0); X = COPY(V); Y = COPY(V); LOAD(Y, 4); ADVANCE(V, 1, 4); V->FLAGS = V->FLAGS | 128; LOAD(V, 3); V->FORM = 1; Z = COPY(V); ADVANCE(V, 1, 8); V->FLAGS = V->FLAGS | 128; OPERATE(4, Y, V); ADVANCE(Z, 1, 0); Z->FLAGS = Z->FLAGS | 128; COMPARE(Y, Z); RELEASEANDDROPPAIR(Z, Y); DOCONDITIONALEXTERNAL(4, FILLID, &FILLEP); Y = REGISTER(4); SIMPLE(Y, X); RELEASEANDDROPPAIR(X, Y); return; case_SP_42:; STACK = &STACK->STACK; MAKESAFE(V, 1); ADVANCE(V, 1, 0); Y = REGISTER(4); OPERATE(4, Y, LITERAL(1)); SIMPLE(Y, V); RELEASEANDDROPPAIR(V, Y); return; case_SP_43:; STACK = &STACK->STACK; MAKESAFE(V, 1); RELEASEANDDROP(V); V = REGISTER(4); V->STACK = STACK; STACK = V; return; case_SP_44:; STACK = &STACK->STACK; MAKESAFE(V, 1); Y = REGISTER(4); X = REGISTER(2); PLANT1(68157440 | 4194304 | 8388608, 4, 2, 1); SIMPLE(Y, V); RELEASEANDDROPPAIR(V, Y); X->STACK = STACK; STACK = X; return; case_SP_45:; STACK = &STACK->STACK; ADVANCE(V, 1, 4); LOAD(V, 3); RELEASEANDDROP(V); DO(READLNID, &READLNEP, 0); return; case_SP_46:; EOLN(V); return; case_SP_47:; EOF(V, 0); return; case_SP_48:; EOF(V, 1); return; case_SP_49:; STACK = &STACK->STACK; SIMPLIFY(V); ADVANCE(V, 1, 0); X = COPY(V); Y = COPY(V); ADVANCE(Y, 1, 4); Y->FLAGS = Y->FLAGS | 128; LOAD(X, 4); LOAD(Y, 3); Y->FORM = 1; Y->DISP = 4; Y->FLAGS = Y->FLAGS | 128; Z = COPY(Y); Z->DISP = 8; OPERATE(4, X, Z); LOAD(X, 4); COMPARE(X, Y); RELEASEANDDROPPAIR(Y, X); DOCONDITIONALEXTERNAL(5, EMPTYID, &EMPTYEP); X = REGISTER(4); SIMPLE(X, V); RELEASEANDDROPPAIR(X, V); return; case_SP_50:; STACK = &STACK->STACK; SIMPLIFY(V); ADVANCE(V, 1, 0); X = COPY(V); Y = COPY(V); ADVANCE(Y, 1, 4); Y->FLAGS = Y->FLAGS | 128; LOAD(X, 4); LOAD(Y, 3); OPERATE(4, X, LITERAL(1)); LOAD(X, 4); Y->FORM = 1; Y->DISP = 4; Y->FLAGS = Y->FLAGS | 128; COMPARE(X, Y); RELEASEANDDROPPAIR(Y, X); DOCONDITIONALEXTERNAL(5, EMPTYID, &EMPTYEP); X = REGISTER(4); SIMPLE(X, V); RELEASEANDDROPPAIR(X, V); return; case_SP_51:; STACK = &STACK->STACK; ADVANCE(V, 1, 4); LOAD(V, 3); RELEASEANDDROP(V); DOCONDITIONALEXTERNAL(7, WRITELNID, &WRITELNEP); return; case_SP_52:; { /*%begin*/ struct STACKFM *C; struct STACKFM *W; struct STACKFM *BP; struct STACKFM *FCB; struct STACKFM *Z; SIMPLIFY(V); C = &V->STACK; W = &C->STACK; STACK = &W->STACK; if (!(ICONST(W))) goto L_0419; if (W->DISP != 1) goto L_0419; RELEASEANDDROP(W); ADVANCE(V, 1, 0); BP = COPY(V); FCB = COPY(V); ADVANCE(FCB, 1, 4); LOAD(BP, 4); FCB->FLAGS = FCB->FLAGS | 128; LOAD(FCB, 3); LOADUP(C); PLANT1(67108864 | 4194304 | 8388608, 4, C->BASE, 1); RELEASEANDDROP(C); FCB->FORM = 1; FCB->DISP = 4; FCB->FLAGS = FCB->FLAGS | 128; COMPARE(BP, FCB); RELEASEANDDROPPAIR(FCB, BP); DOCONDITIONALEXTERNAL(4, EMPTYID, &EMPTYEP); BP = REGISTER(4); SIMPLE(BP, V); RELEASEANDDROPPAIR(BP, V); goto L_041A; L_0419: LOAD(W, 2); LOAD(C, 3); AMAP(V); LOAD(V, 4); RELEASEANDDROPPAIR(W, C); RELEASEANDDROP(V); DO(WRITECID, &WRITECEP, 0); L_041A: } return; case_SP_53:; return; void DOREALFN(int FN) { int REG; LOAD(V, 26); REG = FPR(); CLAIM(REG); PLANT9(*FN, 0, REG, V->BASE); RELEASE(V->BASE); V->BASE = REG; } /* DOREALFN */ case_SP_54:; DOREALFN(239108480); return; case_SP_55:; DOREALFN(243302784); return; case_SP_56:; DOREALFN(244351360); return; case_SP_57:; DOREALFN(241205632); return; case_SP_58:; DOREALFN(242254208); return; case_SP_59:; DOREALFN(248545664); return; } /* SPECIALCALL */ void CALL(int TIDY) { struct STACKFM *V; struct STACKFM *TEMP; struct STACKFM *X; struct STACKFM *W; struct STACKFM WORK; int EP; int FLAGS; int EXTRA; int OP; int BASEREG; V = STACK; STACK = &STACK->STACK; FLAGS = V->FLAGS; if (FLAGS & 512 == 0) goto L_041B; L_041C: if (&V->PARAMS == NIL) goto L_041D; V->PARAMS = STACK; STACK = &V->PARAMS; V->PARAMS = &V->PARAMS; goto L_041C; L_041D: SPECIALCALL(V->PRIM); DROP(V); return; L_041B: BASEREG = 1; if (FLAGS & 524288 == 0) goto L_041E; if (V->FLAGS & 8 != 0) goto L_041E; if (V->TYPE == 8) goto L_041F; if (V->TYPE != 9) goto L_041E; L_041F: BASEREG = 2; L_041E: PASSPARAMETERS(V, &EXTRA, BASEREG); if (ACTIVEREGISTERS == 0) goto L_0420; HAZARDALL(); L_0420: ASSIGNLOCK = 0; ATTRIBUTES = ATTRIBUTES | 64; TEMP = NIL; if (BASEREG != 2) goto L_0421; TEMP = CLAIMWORKAREA(ITEMSIZE(V->FORMAT), V->TYPE); TEMP->FORMAT = V->FORMAT; W = COPY(TEMP); AMAP(W); LOAD(W, 1); RELEASEANDDROP(W); L_0421: EP = V->DISP; if (FLAGS & 1024 == 0) goto L_0422; if (FLAGS & 256 == 0) goto L_0423; FAIL(_imp_str_literal("XP-call")); L_0423: XCALL(EP, 0, 1); goto L_0424; L_0422: if (FLAGS & 4 != 0) goto L_0425; if (V->BASE != 0) goto L_0425; if (&V->RECORD == NIL) goto L_0426; L_0425: W = COPY(V); W->TYPE = 1; W->FORM = 1; W->AREA = 0; AMAP(W); LOAD(W, 5); RELEASEANDDROP(W); PRIM(54); goto L_0424; L_0426: if (FLAGS & 256 == 0) goto L_0427; FAIL(_imp_str_literal("P-call")); L_0427: if (FLAGS & 65536 == 0) goto L_0428; if (LOCALDISPLAY != 0) goto L_0429; FAIL(_imp_str_literal("No local display")); L_0429: X = LOCALINTEGER(LOCALDISPLAY); LOADADDRESS(X, 9); RELEASEANDDROP(X); L_0428: DIR2(20, EP); *CA = *CA + 4; REFS = REFS + 1; L_0424: if (EXTRA == 0) goto L_042A; POPSTACK(EXTRA); L_042A: FORGETEVERYTHING(); if (FLAGS & 524288 == 0) goto L_042B; if (TEMP != NIL) goto L_042C; TEMP = LITERAL(0); TEMP->TYPE = V->TYPE; TEMP->FORMAT = V->FORMAT; TEMP->BASE = 1; if (FLAGS & 8 == 0) goto L_042D; TEMP->FORM = 1; TEMP->BASE = 1; goto L_042E; L_042D: if (6 > TEMP->TYPE) goto L_042F; if (TEMP->TYPE > 7) goto L_042F; TEMP->BASE = 18; TEMP->TYPE = 7; L_042F: L_042E: CLAIM(TEMP->BASE); L_042C: TEMP->STACK = STACK; STACK = TEMP; goto L_0430; L_042B: if (FLAGS & 2097152 == 0) goto L_0431; PLANT1(19922944, 1, 0, NOTHING()); L_0431: L_0430: if (FLAGS & 2048 == 0) goto L_0432; UNCONDJUMP = *CA; L_0432: DROP(V); } /* CALL */ void PRIM(int N) { int FOR; int REG; int PAR; if (1 > *N) goto L_0433; if (*N <= 56) goto L_0434; L_0433: FAIL(_imp_str_literal("Prim ")); L_0434: if (DIAG & 16 == 0) goto L_0435; MONITOR(NIL, _imp_join((_imp_string)(_imp_str_literal("Prim ")), (_imp_string)(_imp_ITOS(*N, 0)))); L_0435: FOR = CORRUPTS[*N]; PAR = PRIMPARAMETER[*N]; REG = 1; L_0436: if (FOR == 0) goto L_0437; if (FOR & 1 == 0) goto L_0438; if (PAR & 1 != 0) goto L_0439; HAZARD(REG); goto L_043A; L_0439: if (ACTIVITY[REG] <= 1) goto L_043B; HAZARD(REG); L_043B: L_043A: FORGET(REG); L_0438: REG = REG + 1; FOR = (unsigned int)FOR >> 1; PAR = (unsigned int)PAR >> 1; goto L_0436; L_0437: DIR2(25, *N); *CA = *CA + 4; REFS = REFS + 1; } /* PRIM */ void SWITCHLABEL(int TAG) { DIR2(7, VAR(TAG)->AREA + POPPEDVALUE()); UNCONDJUMP = -1; ASSIGNLOCK = 0; MARKUSERLABEL(); FORGETEVERYTHING(); } /* SWITCHLABEL */ void SWITCHJUMP(int TAG) { struct STACKFM *X; X = STACK; STACK = &STACK->STACK; LOAD(X, 2); RELEASEANDDROP(X); PRIM(4); DUMPWORD(-409800443); DIR2(29, VAR(TAG)->FORMAT); *CA = *CA + 4; UNCONDJUMP = *CA; } /* SWITCHJUMP */ void SAVEWSP(void) { struct STACKFM *D; if (WSPSAVE != 0) goto L_043C; FRAME = (FRAME & (~3)) - 4; WSPSAVE = FRAME; L_043C: D = LOCALINTEGER(WSPSAVE); PLANT2(67108864, 13, D); RELEASEANDDROP(D); } /* SAVEWSP */ void EVENTTRAP(int BITS) { int LAB; struct STACKFM *D; LAB = TAG(); SAVEWSP(); JUMPFORWARD(LAB, 7); EVENTBITS = *BITS; EVENTBODY = JLAB; EVENTLABEL = NEWLABEL(); DEFINELABEL(EVENTLABEL); MARKUSERLABEL(); FORGETEVERYTHING(); D = LOCALINTEGER(WSPSAVE); PLANT2(68157440, 13, D); RELEASEANDDROP(D); ATTRIBUTES = ATTRIBUTES | 64; } /* EVENTTRAP */ void SIGNALEVENT(int EVENT) { struct STACKFM *E; struct STACKFM *SUBEVENT; struct STACKFM *EXTRA; EXTRA = STACK; SUBEVENT = &EXTRA->STACK; STACK = &SUBEVENT->STACK; E = LITERAL(EVENT); LOADTRIO(E, 2, SUBEVENT, 3, EXTRA, 4); RELEASEANDDROPPAIR(E, SUBEVENT); RELEASEANDDROP(EXTRA); PRIM(1); UNCONDJUMP = *CA; ATTRIBUTES = ATTRIBUTES | 64; } /* SIGNALEVENT */ void SETPENDINGFOR(int V) { int MASK; MASK = 0; if (PENDING != 61) goto L_043D; MASK = 2; goto L_043E; L_043D: if (PENDING != 35) goto L_043F; MASK = 5; goto L_043E; L_043F: if (PENDING != 60) goto L_0440; MASK = 4; goto L_043E; L_0440: if (PENDING != 62) goto L_0441; MASK = 1; goto L_043E; L_0441: if (PENDING != 40) goto L_0442; MASK = 6; goto L_043E; L_0442: if (PENDING != 41) goto L_0443; MASK = 3; goto L_043E; L_0443: if (PENDING != 116) goto L_0444; MASK = 5; goto L_043E; L_0444: if (PENDING != 107) goto L_0445; MASK = 2; goto L_043E; L_0445: FAIL(_imp_str_literal("Bad cc")); L_043E: if (INVERT == 0) goto L_0446; *V = -*V; INVERT = 0; L_0446: PENDING = 35; if (*V != 0) goto L_0447; if (MASK & 2 != 0) goto L_0448; L_0447: if (*V <= 0) goto L_0449; if (MASK & 1 != 0) goto L_0448; L_0449: if (*V >= 0) goto L_044A; if (MASK & 4 == 0) goto L_044A; L_0448: PENDING = 61; L_044A: PLANT1(22020096 | 1048576, 0, 1, JUST(1)); } /* SETPENDINGFOR */ void TESTZERO(struct STACKFM * V) { struct STACKFM *W; int OP; int X; void TESTSHORTBITS(struct STACKFM * V, int MASK) { int OP; OP = 17825792; struct STACKFM *W; MASK = MASK & 65535; V = COPY(&V); if (MASK & 255 != 0) goto L_044B; ADVANCE(&V, 4, 1); LOADUP(&V); PLANT1(17825792, V, 0, IMMEDIATE((unsigned int)MASK >> 8)); goto L_044C; L_044B: if (MASK > 255) goto L_044D; ADVANCE(&V, 4, 0); LOADUP(&V); PLANT1(17825792, V, 0, IMMEDIATE(MASK)); goto L_044C; L_044D: W = COPY(&V); ADVANCE(&V, 4, 0); ADVANCE(W, 4, 1); LOADUP(&V); LOADUP(W); PLANT1(17825792, V, 0, IMMEDIATE(MASK & 255)); PLANT1(17825792 | -536870912, W->BASE, 0, IMMEDIATE((unsigned int)MASK >> 8)); RELEASEANDDROP(W); L_044C: RELEASEANDDROP(&V); } /* TESTSHORTBITS */ void TESTINTEGERBITS(struct STACKFM * V, int MASK) { int X; int OP; LOADUP(&V); OP = 17825792; X = 16; L_044E: if (MASK == 0) goto L_044F; L_0450: if (MASK & 3 != 0) goto L_0451; MASK = (unsigned int)MASK >> 2; X = X - 1; goto L_0450; L_0451: PLANT1(OP, V, 0, ROT(MASK & 255, X & 15)); MASK = (unsigned int)MASK >> 8; X = X - 4; OP = OP | -536870912; goto L_044E; L_044F: if (X != 16) goto L_0452; PLANT1(OP, V, 0, IMMEDIATE(0)); L_0452: } /* TESTINTEGERBITS */ if (DIAG & 256 == 0) goto L_0453; MONITOR(V, _imp_str_literal("Tzero")); L_0453: OPTIMISE(V, 1); if (V->OPER == 0) goto L_0454; W = &V->LINK; if (PENDING == 61) goto L_0455; if (PENDING == 35) goto L_0455; if (PENDING == 116) goto L_0455; if (PENDING != 107) goto L_0456; L_0455: if (V->OPER != 9) goto L_0456; if (!(ICONST(W))) goto L_0456; V->OPER = 0; V->LINK = NIL; if (V->TYPE != 2) goto L_0457; TESTSHORTBITS(V, W->DISP); goto L_0458; L_0457: if (V->TYPE != 4) goto L_0459; LOADUP(V); PLANT1(17825792, V->BASE, 0, IMMEDIATE(W->DISP & 255)); goto L_0458; L_0459: TESTINTEGERBITS(V, W->DISP); L_0458: RELEASEANDDROP(W); return; L_0456: LOADUP(V); L_0454: if (V->TYPE < 6) goto L_045A; LOADUP(V); PLANT8(244379920 | 8, V->BASE, 0); goto L_045B; L_045A: if (!(ICONST(V))) goto L_045C; SETPENDINGFOR(V->DISP); goto L_045B; L_045C: LOADUP(V); PLANT1(22020096, V->BASE, 0, NOTHING()); if (PENDING != 35) goto L_045D; PENDINGKNOWNREGISTER = V->BASE; PENDINGKNOWN = 0; L_045D: L_045B: } /* TESTZERO */ void COMPTOSTRING(struct STACKFM * S, struct STACKFM * X) { AMAP(S); LOADPAIR(S, 3, &X, 2); PRIM(2); } /* COMPTOSTRING */ void COMPARESTRINGS(struct STACKFM * LEFT, struct STACKFM * RIGHT) { struct STACKFM *W; if (LEFT == 0) goto L_045E; EVALUATESTRINGEXPRESSION(&LEFT); L_045E: if (RIGHT == 0) goto L_045F; EVALUATESTRINGEXPRESSION(&RIGHT); L_045F: SIMPLIFY(&LEFT); SIMPLIFY(&RIGHT); RIGHT = COPY(&RIGHT); LEFT = COPY(&LEFT); if (RIGHT != 1) goto L_0460; if (LEFT == 8) goto L_0461; LOADUP(&LEFT); PLANT1(24117248, 0, LEFT, IMMEDIATE(1)); goto L_0462; L_0461: if (LEFT != 1) goto L_0463; PLANT1(22020096 | 1048576, 0, 1, JUST(1)); goto L_0462; L_0463: LEFT = 4; TESTZERO(&LEFT); L_0462: goto L_0464; L_0460: if (LEFT != 1) goto L_0465; if (RIGHT == 8) goto L_0466; LOADUP(&RIGHT); PLANT1(24117248, 0, RIGHT, IMMEDIATE(1)); goto L_0467; L_0466: RIGHT = 4; TESTZERO(&RIGHT); L_0467: INVERT = INVERT ^ 1; goto L_0464; L_0465: if (RIGHT == 8) goto L_0468; COMPTOSTRING(&LEFT, &RIGHT); goto L_0464; L_0468: if (LEFT == 8) goto L_0469; COMPTOSTRING(&RIGHT, &LEFT); INVERT = INVERT ^ 1; goto L_0464; L_0469: AMAP(&LEFT); AMAP(&RIGHT); LOADPAIR(&LEFT, 2, &RIGHT, 3); PRIM(9); L_0464: RELEASEANDDROPPAIR(&LEFT, &RIGHT); } /* COMPARESTRINGS */ void COMPARERECORDS(struct STACKFM * L, struct STACKFM * R) { struct STACKFM *SIZE; int N; int OP; void FIXSET(struct STACKFM * L) { SIMPLIFY(&L); if (&L == NIL) goto L_046A; BUILDSET(&L); goto L_046B; L_046A: if (L & 16384 == 0) goto L_046C; L = 1; L_046C: L_046B: L = ((long)256 / (long)8); } /* FIXSET */ void COMPARESET(struct STACKFM * L, struct STACKFM * R, int CC) { PENDING = CC; AMAP(&L); AMAP(&R); LOADPAIR(&L, 9, &R, 12); PRIM(32); } /* COMPARESET */ if (L != 13) goto L_046D; FIXSET(&L); L_046D: if (R->TYPE != 13) goto L_046E; FIXSET(R); L_046E: if (L != 1) goto L_046F; if (R->TYPE != 1) goto L_0470; PLANT1(22020096 | 1048576, 0, 1, JUST(1)); goto L_0471; L_0470: INVERT = INVERT ^ 1; COMPARERECORDS(R, &L); L_0471: return; L_046F: N = ITEMSIZE(L); if (N > 0) goto L_0472; FAIL(_imp_str_literal("Null area?")); L_0472: if (R->TYPE != 1) goto L_0473; if (N == 32) goto L_0474; FAIL(_imp_str_literal("Bad set size")); L_0474: void DOSET(int CODE) { PENDING = CODE; LOADADDRESS(&L, 1); PRIM(50); } /* DOSET */ if (PENDING == 61) goto L_0475; if (PENDING != 35) goto L_0476; L_0475: DOSET(PENDING); goto L_0477; L_0476: if (INVERT != 0) goto L_0478; if (PENDING != 62) goto L_0479; DOSET(35); goto L_047A; L_0479: if (PENDING != 60) goto L_047B; PENDING = 128 + 48; goto L_047A; L_047B: if (PENDING != 41) goto L_047C; PENDING = 70; goto L_047A; L_047C: if (PENDING != 40) goto L_047D; DOSET(61); goto L_047A; L_047D: FAIL(_imp_str_literal("Null/1")); L_047A: goto L_0477; L_0478: if (PENDING != 62) goto L_047E; PENDING = 128 + 48; goto L_047F; L_047E: if (PENDING != 60) goto L_0480; DOSET(35); goto L_047F; L_0480: if (PENDING != 41) goto L_0481; DOSET(61); goto L_047F; L_0481: if (PENDING != 40) goto L_0482; PENDING = 70; goto L_047F; L_0482: FAIL(_imp_str_literal("Null/2")); L_047F: L_0477: INVERT = 0; goto L_0483; L_0473: if (L != 13) goto L_0484; if (13 != R->TYPE) goto L_0484; if (N == 32) goto L_0485; FAIL(_imp_str_literal("Bad set size")); L_0485: if (PENDING == 61) goto L_0486; if (PENDING != 35) goto L_0487; L_0486: AMAP(&L); AMAP(R); LOADPAIR(&L, 1, R, 2); PRIM(51); goto L_0488; L_0487: if (PENDING != 60) goto L_0489; COMPARESET(&L, R, 35); goto L_048A; L_0489: if (PENDING != 62) goto L_048B; COMPARESET(R, &L, 35); goto L_048A; L_048B: if (PENDING != 40) goto L_048C; COMPARESET(R, &L, 61); goto L_048A; L_048C: if (PENDING != 41) goto L_048D; COMPARESET(&L, R, 61); goto L_048A; L_048D: FAIL(_imp_str_literal("bad set comparison")); L_048A: L_0488: goto L_0483; L_0484: AMAP(&L); AMAP(R); SIZE = LITERAL(N); LOADTRIO(&L, 2, R, 3, SIZE, 1); RELEASEANDDROP(SIZE); PRIM(40); L_0483: } /* COMPARERECORDS */ void TRYFORZERO(struct STACKFM * V, int MOD) { int OLD; OLD = PENDING; if (V->DISP != *MOD) goto L_048E; if (PENDING != 60) goto L_048F; PENDING = 40; goto L_0490; L_048F: if (PENDING != 41) goto L_0491; PENDING = 62; L_0491: L_0490: goto L_0492; L_048E: if (V->DISP != -*MOD) goto L_0493; if (PENDING != 62) goto L_0494; PENDING = 41; goto L_0495; L_0494: if (PENDING != 40) goto L_0496; PENDING = 60; L_0496: L_0495: L_0493: L_0492: if (PENDING == OLD) goto L_0497; V->DISP = 0; L_0497: } /* TRYFORZERO */ void COMPAREFLOATING(struct STACKFM * LEFT, struct STACKFM * RIGHT) { int SUITABLECONST(struct STACKFM * L, struct STACKFM * R) { int OP; int N; if (ICONST(&R)) goto L_0498; return 0 /*FALSE*/; L_0498: if (0 > R) goto L_0499; if (R > 5) goto L_0499; OP = 244379920; N = R; goto L_049A; L_0499: if (-5 > R) goto L_049B; if (R > 0) goto L_049B; OP = 246477072; N = -R; goto L_049A; L_049B: if (R != 10) goto L_049C; OP = 244379920; N = 7; goto L_049A; L_049C: if (R != -10) goto L_049D; OP = 246477072; N = 7; goto L_049A; L_049D: return 0 /*FALSE*/; L_049A: LOAD(&L, 26); PLANT8(OP | 8, L, N); return 1 /*TRUE*/; } /* SUITABLECONST */ if (!(SUITABLECONST(LEFT, &RIGHT))) goto L_049E; return; L_049E: if (!(SUITABLECONST(&RIGHT, LEFT))) goto L_049F; INVERT = INVERT ^ 1; return; L_049F: LOAD(LEFT, 26); LOAD(&RIGHT, 26); PLANT8(244379920, LEFT->BASE, RIGHT); } /* COMPAREFLOATING */ void COMPARE(struct STACKFM * LEFT, struct STACKFM * RIGHT) { int LAB; struct STACKFM *W; void DOCONST(struct STACKFM * A, struct STACKFM * B) { int N; int OP; int V; LOADUP(&A); V = B; if (V < 0) goto L_04A0; N = IMMEDIATE(V); OP = 22020096; goto L_04A1; L_04A0: N = IMMEDIATE(-V); OP = 24117248; L_04A1: if (N >= 0) goto L_04A2; LOADUP(&B); N = JUST(B); OP = 22020096; L_04A2: PLANT1(OP, A, 0, N); if (PENDING != 35) goto L_04A3; PENDINGKNOWNREGISTER = A; PENDINGKNOWN = 0; PENDINGKNOWN.DISP = V; PENDINGKNOWN.TYPE = 1; L_04A3: } /* DOCONST */ PENDINGKNOWNREGISTER = 0; if (CODE == 128 + 63) goto L_04A4; if (CODE == 128 + 34) goto L_04A4; UNSIGNED = 0; L_04A4: if (PENDINGTAG == 0) goto L_04A5; LAB = PENDINGTAG; PENDINGTAG = 0; W = LITERAL(PENDINGLIT); if (PENDING == 62) goto L_04A6; if (PENDING != 41) goto L_04A7; L_04A6: if (RIGHT < PENDINGLIT) goto L_04A7; if (ICONST(&RIGHT)) goto L_04A8; L_04A7: LOADUP(LEFT); COMPARE(LEFT, W); RELEASEANDDROP(W); JUMPFORWARD(LAB, 2); goto L_04A9; L_04A8: UNSIGNED = 10; OPERATE(5, LEFT, W); RIGHT = RIGHT - PENDINGLIT; L_04A9: L_04A5: if (LEFT->TYPE == 8) goto L_04AA; if (RIGHT == 8) goto L_04AA; if (LEFT->OPER == 22) goto L_04AA; if (RIGHT != 22) goto L_04AB; L_04AA: COMPARESTRINGS(LEFT, &RIGHT); return; L_04AB: if (LEFT->TYPE == 9) goto L_04AC; if (LEFT->TYPE == 13) goto L_04AC; if (RIGHT == 9) goto L_04AC; if (RIGHT != 13) goto L_04AD; L_04AC: COMPARERECORDS(LEFT, &RIGHT); return; L_04AD: if (!(ICONST(&RIGHT))) goto L_04AE; if (FLOATING(LEFT)) goto L_04AF; TRYFORZERO(&RIGHT, 1); L_04AF: if (!(ICONST(LEFT))) goto L_04B0; SETPENDINGFOR(LEFT->DISP - RIGHT); return; L_04B0: if (RIGHT != 0) goto L_04B1; TESTZERO(LEFT); return; L_04B1: goto L_04B2; L_04AE: if (!(ICONST(LEFT))) goto L_04B3; if (FLOATING(&RIGHT)) goto L_04B4; TRYFORZERO(LEFT, -1); L_04B4: if (LEFT->DISP != 0) goto L_04B5; TESTZERO(&RIGHT); INVERT = INVERT ^ 1; return; L_04B5: L_04B3: L_04B2: if (FLOATING(LEFT)) goto L_04B6; if (!(FLOATING(&RIGHT))) goto L_04B7; L_04B6: COMPAREFLOATING(LEFT, &RIGHT); goto L_04B8; L_04B7: if (!(ICONST(&RIGHT))) goto L_04B9; DOCONST(LEFT, &RIGHT); goto L_04BA; L_04B9: if (!(ICONST(LEFT))) goto L_04BB; DOCONST(&RIGHT, LEFT); INVERT = INVERT ^ 1; goto L_04BA; L_04BB: LOADUP(LEFT); LOADUP(&RIGHT); LOADUP(LEFT); PLANT1(22020096, LEFT->BASE, 0, JUST(RIGHT)); L_04BA: L_04B8: } /* COMPARE */ void COMPAREVALUES(void) { struct STACKFM *L; struct STACKFM *R; R = STACK; L = &R->STACK; STACK = &L->STACK; COMPARE(L, R); RELEASEANDDROPPAIR(L, R); } /* COMPAREVALUES */ void COMPAREDOUBLE(void) { struct STACKFM *L; struct STACKFM *R; R = STACK; L = &R->STACK; R->STACK = &L->STACK; if (R->OPER == 0) goto L_04BC; if (R->OPER != 22) goto L_04BD; EVALUATESTRINGEXPRESSION(R); goto L_04BE; L_04BD: LOADUP(R); L_04BE: L_04BC: if (PENDING != 62) goto L_04BF; if (L->DISP < 0) goto L_04BF; if (!(ICONST(L))) goto L_04BF; if (R->TYPE > 5) goto L_04BF; _imp_READSYMBOL(&PENDING); PENDINGLIT = L->DISP; PENDINGTAG = TAG(); goto L_04C0; L_04BF: COMPARE(L, R); L_04C0: RELEASEANDDROP(L); } /* COMPAREDOUBLE */ void COMPAREADDRESSES(void) { struct STACKFM *L; struct STACKFM *R; R = STACK; L = &R->STACK; STACK = &L->STACK; AMAP(L); AMAP(R); COMPARE(L, R); RELEASEANDDROPPAIR(L, R); } /* COMPAREADDRESSES */ void STACKCONDITION(void) { int CC; struct STACKFM *L; struct STACKFM *R; R = STACK; L = &R->STACK; STACK = &L->STACK; COMPARE(L, R); RELEASEANDDROPPAIR(L, R); if (PENDING != 61) goto L_04C1; CC = 1; goto L_04C2; L_04C1: if (PENDING != 60) goto L_04C3; CC = 2; goto L_04C2; L_04C3: if (PENDING != 40) goto L_04C4; CC = 3; goto L_04C2; L_04C4: if (PENDING != 62) goto L_04C5; CC = 4; goto L_04C2; L_04C5: if (PENDING != 41) goto L_04C6; CC = 5; goto L_04C2; L_04C6: if (PENDING != 35) goto L_04C7; CC = 6; goto L_04C2; L_04C7: if (PENDING != 116) goto L_04C8; CC = 8; goto L_04C2; L_04C8: if (PENDING != 102) goto L_04C9; CC = 9; goto L_04C2; L_04C9: if (PENDING != 70) goto L_04CA; CC = 7; goto L_04C2; L_04CA: if (PENDING != 128 + 48) goto L_04CB; CC = 0; goto L_04C2; L_04CB: FAIL(_imp_str_literal("Bad CC")); L_04C2: _imp_READSYMBOL(&PENDING); if (INVERT == 0) goto L_04CC; CC = REVERSE[CC]; INVERT = 0; L_04CC: STACKTRUEORFALSE(CC); } /* STACKCONDITION */ void GENERALCOMPARE(void) { int OP; struct STACKFM *RIGHT; struct STACKFM *LEFT; struct STACKFM *RLEN; struct STACKFM *LLEN; RLEN = STACK; LLEN = &RLEN->STACK; RIGHT = &LLEN->STACK; LEFT = &RIGHT->STACK; STACK = &LEFT->STACK; if (!(ICONST(RLEN))) goto L_04CD; if (ICONST(LLEN)) goto L_04CE; L_04CD: FAIL(_imp_str_literal("variable compare")); L_04CE: if (RLEN->DISP != LLEN->DISP) goto L_04CF; AMAP(LEFT); AMAP(RIGHT); LOADTRIO(LEFT, 2, RIGHT, 3, RLEN, 1); PRIM(40); goto L_04D0; L_04CF: NOTINYET(); L_04D0: RELEASEANDDROPPAIR(RLEN, LLEN); RELEASEANDDROPPAIR(RIGHT, LEFT); } /* GENERALCOMPARE */ void GENERALMOVE(void) { struct STACKFM *F; struct STACKFM *T; struct STACKFM *FLEN; struct STACKFM *TLEN; FLEN = STACK; TLEN = &FLEN->STACK; F = &TLEN->STACK; T = &F->STACK; STACK = &T->STACK; LOADPAIR(TLEN, 4, FLEN, 5); LOADPAIR(T, 2, F, 3); LOADPAIR(TLEN, 4, FLEN, 5); LOADPAIR(T, 2, F, 3); RELEASEANDDROPPAIR(FLEN, TLEN); RELEASEANDDROPPAIR(F, T); PRIM(7); FORGETEVERYTHING(); } /* GENERALMOVE */ void RECORDASSIGN(struct STACKFM * FROM, struct STACKFM * TO) { int LENL; int LENR; int INC; int MOD; int LOAD; int R; int ALIGNED; ALIGNED = 1; int ZERO; void RECORDOP(void) { if (R >= 0) goto L_04D1; R = GPR(); L_04D1: if (LOAD == 0) goto L_04D2; PLANT2(68157440 | MOD, R, FROM); L_04D2: PLANT2(67108864 | MOD, R, TO); } /* RECORDOP */ LENL = ITEMSIZE(TO->FORMAT); LENR = ITEMSIZE(FROM->FORMAT); if (LENL == 0) goto L_04D3; if (LENR == 0) goto L_04D4; if (LENR >= LENL) goto L_04D4; L_04D3: LENL = LENR; L_04D4: if (LENL > 0) goto L_04D5; return; L_04D5: if (LENL & 3 != 0) goto L_04D6; if (PROPERLYALIGNED(TO, 3)) goto L_04D7; L_04D6: ALIGNED = 0; L_04D7: ZERO = 0; if (!(ICONST(FROM))) goto L_04D8; ZERO = 1; goto L_04D9; L_04D8: if (PROPERLYALIGNED(FROM, 3)) goto L_04DA; ALIGNED = 0; L_04DA: L_04D9: FORGETDESTINATION(TO); MAKEAUTOI(TO, 1); LOAD = 1; INC = 4; MOD = 0; if (ALIGNED != 0) goto L_04DB; INC = 1; MOD = 4194304; TO->TYPE = 4; L_04DB: if (ZERO == 0) goto L_04DC; LOAD = 0; LOADUP(FROM); R = FROM->BASE; goto L_04DD; L_04DC: MAKEAUTOI(FROM, TO->TYPE); R = -1; L_04DD: REPEAT(RECORDOP, LITERAL(LENL), INC, 6); } /* RECORDASSIGN */ void SETASSIGN(struct STACKFM * FROM, struct STACKFM * DEST) { struct MEMBERFM *M; struct MEMBERFM *X; int OP; OP = FROM->OPER; int FN; struct STACKFM *W; struct STACKFM *INDEX; struct STACKFM *TO; TO = COPY(DEST); if (&FROM->MEMBERS == NIL) goto L_04DE; BUILDSET(FROM); L_04DE: W = &FROM->LINK; if (W == NIL) goto L_04DF; FROM->LINK = NIL; FROM->OPER = 0; if (FROM->FLAGS & 16384 == 0) goto L_04E0; FROM = W; goto L_04E1; L_04E0: if (OP == 25) goto L_04E2; if (OP == 26) goto L_04E2; if (OP == 27) goto L_04E2; FAIL(_imp_str_literal("Bad set operator")); L_04E2: if (W->FLAGS & 16384 != 0) goto L_04E3; if (SAME(FROM, TO)) goto L_04E4; FROM->OPER = OP; FROM->LINK = W; LOADUP(FROM); SETASSIGN(FROM, TO); RELEASEANDDROP(TO); return; L_04E4: if (&W->MEMBERS == NIL) goto L_04E5; if (W->MEMBERS > 2) goto L_04E6; if (OP != 27) goto L_04E5; L_04E6: BUILDSET(W); L_04E5: LOADADDRESS(TO, 9); if (OP == 27) goto L_04E7; if (&W->MEMBERS == NIL) goto L_04E7; M = &W->MEMBERS; W->MEMBERS = NIL; L_04E8: if (M == NIL) goto L_04E9; X = M; M = &M->LINK; LOADPAIR(TO, 9, &X->A, 2); if (&X->B == NIL) goto L_04EA; LOAD(&X->B, 1); LOADPAIR(TO, 9, &X->A, 2); RELEASEANDDROP(&X->B); if (OP != 25) goto L_04EB; FN = 28; goto L_04EC; L_04EB: FN = 35; L_04EC: goto L_04ED; L_04EA: if (OP != 25) goto L_04EE; FN = 20; goto L_04ED; L_04EE: FN = 25; L_04ED: RELEASEANDDROP(&X->A); _imp_DISPOSE(X); PRIM(FN); goto L_04E8; L_04E9: RELEASEANDDROPPAIR(W, TO); goto L_04EF; L_04E7: AMAP(W); LOADPAIR(TO, 9, W, 12); RELEASEANDDROP(W); if (OP != 25) goto L_04F0; FN = 29; goto L_04F1; L_04F0: if (OP != 26) goto L_04F2; FN = 30; goto L_04F1; L_04F2: FN = 31; L_04F1: PRIM(FN); RELEASEANDDROP(TO); L_04EF: return; L_04E3: L_04E1: L_04DF: if (W == NIL) goto L_04F3; RELEASEANDDROP(W); L_04F3: FORGETDESTINATION(TO); if (FROM->FLAGS & 16384 == 0) goto L_04F4; void ZERO(int R) { struct STACKFM *W; W = LITERAL(0); LOAD(W, R); RELEASEANDDROP(W); } /* ZERO */ LOADADDRESS(TO, 9); ZERO(1); ZERO(2); ZERO(3); ZERO(4); PLANT4(134217728 | 8388608 | 2097152, TO->BASE, 15); PLANT4(134217728 | 8388608, TO->BASE, 15); goto L_04F5; L_04F4: LOADADDRESS(FROM, 12); LOADADDRESS(TO, 9); HAZARD(1); HAZARD(2); HAZARD(3); HAZARD(4); HAZARD(5); HAZARD(6); HAZARD(7); HAZARD(8); PLANT4(135266304 | 8388608, FROM->BASE, 255); PLANT4(134217728 | 8388608, TO->BASE, 255); FORGET(1); FORGET(2); FORGET(3); FORGET(4); FORGET(5); FORGET(6); FORGET(7); FORGET(8); L_04F5: RELEASEANDDROP(TO); } /* SETASSIGN */ void RESOLVE(int FLAG) { int LAB; int INLAB; INLAB = 0; int PEND; int N; struct STACKFM *S; struct STACKFM *A; struct STACKFM *B; struct STACKFM *C; N = 0; if (*FLAG & 1 == 0) goto L_04F6; C = STACK; STACK = &STACK->STACK; goto L_04F7; L_04F6: N = N | 1; C = NIL; L_04F7: B = STACK; STACK = &STACK->STACK; if (*FLAG & 2 == 0) goto L_04F8; A = STACK; STACK = &STACK->STACK; goto L_04F9; L_04F8: N = N | 2; A = NIL; L_04F9: S = STACK; STACK = &STACK->STACK; if (B->OPER == 0) goto L_04FA; EVALUATESTRINGEXPRESSION(B); L_04FA: if (B->TYPE > 5) goto L_04FB; FIXTOSTRING(B); L_04FB: AMAP(S); AMAP(B); LOADPAIR(S, 2, B, 3); RELEASEANDDROPPAIR(S, B); PRIM(3); if (*FLAG & 4 != 0) goto L_04FC; PRIM(12); goto L_04FD; L_04FC: if (PENDING == 116) goto L_04FE; if (PENDING == 107) goto L_04FE; FAIL(_imp_str_literal("corrupt resolution")); L_04FE: PEND = PENDING; _imp_READSYMBOL(&PENDING); INLAB = TAG(); if (PEND != 116) goto L_04FF; LAB = NEWLABEL(); JUMPTO(LAB, 6); goto L_0500; L_04FF: JUMPFORWARD(INLAB, 6); INLAB = 0; L_0500: L_04FD: CLAIM(2); CLAIM(8); CLAIM(4); CLAIM(7); if (A == NIL) goto L_0501; LOADADDRESS(A, 3); PRIM(18); RELEASEANDDROP(A); L_0501: if (C == NIL) goto L_0502; LOADADDRESS(C, 3); PRIM(24); RELEASEANDDROP(C); L_0502: RELEASE(2); RELEASE(8); RELEASE(4); RELEASE(7); if (INLAB == 0) goto L_0503; JUMPFORWARD(INLAB, 7); DEFINELABEL(LAB); L_0503: } /* RESOLVE */ void EVALUATESTRINGEXPRESSION(struct STACKFM * V) { struct STACKFM *W; W = CLAIMWORKAREA(256, 8); STRINGASSIGN(V, W); REPLACE(V, W); } /* EVALUATESTRINGEXPRESSION */ void STRINGASSIGN(struct STACKFM * R, struct STACKFM * L) { struct STACKFM *W; struct STACKFM *LL; struct STACKFM *DELAYV; struct STACKFM *Z; int CONCLENGTH; CONCLENGTH = 1; int ALLCONST; ALLCONST = 1; int REG; int DELAY; DELAY = 0; int LEN; LEN = 0; int HERE; int LAB; int N; _imp_string255 VAL; VAL = _imp_str_literal(""); int SAFE(struct STACKFM * TARGET, struct STACKFM * CHAIN) { L_0504: CONCLENGTH = CONCLENGTH + 1; if (CHAIN <= 5) goto L_0505; CONCLENGTH = -1000; L_0505: if (ICONSTITEM(&CHAIN)) goto L_0506; ALLCONST = 0; L_0506: if (ALLCONST == 0) goto L_0507; VAL = _imp_join((_imp_string)(VAL), (_imp_string)(_imp_TOSTRING(CHAIN & 255))); L_0507: if (SAME(&TARGET, &CHAIN)) goto L_0508; if (&TARGET == NIL) goto L_0509; if (&CHAIN == NIL) goto L_0509; L_0508: return 0 /*FALSE*/; L_0509: CHAIN = &CHAIN; if (&CHAIN == NIL) goto L_050A; goto L_0504; L_050A: return 1 /*TRUE*/; } /* SAFE */ void MOVE1(void) { FORGET(L->BASE); FORGET(R->BASE); SIMPLE(R, L); } /* MOVE1 */ FORGETDESTINATION(L); if (R->OPER != 0) goto L_050B; N = R->BIAS; if (N == 0) goto L_050C; if (N != 1) goto L_050D; L = COPY(L); L->TYPE = 4; R = LITERAL(0); SIMPLE(R, L); goto L_050E; L_050D: if (N >= 0) goto L_050F; U_100C: L = COPY(L); ADVANCE(L, 4, 1); SIMPLE(R, L); R = LITERAL(1); ADVANCE(L, 4, -1); SIMPLE(R, L); goto L_050E; L_050F: L = COPY(L); MAKEAUTOI(L, 4); R = COPY(R); MAKEAUTOI(R, 4); REPEAT(MOVE1, LITERAL(N), 1, 6); L_050E: RELEASEANDDROPPAIR(L, R); goto L_0510; L_050C: if (R->TYPE > 5) goto L_0511; if (!(ICONSTITEM(R))) goto L_0512; goto U_100C; L_0512: W = COPY(L); ADVANCE(W, 4, 1); SIMPLE(R, W); RELEASEANDDROP(W); L = COPY(L); L->TYPE = 4; MOVELITERAL(1, L); RELEASEANDDROP(L); goto L_0510; L_0511: L = COPY(L); MAKEAUTOI(L, 4); R = COPY(R); MAKEAUTOI(R, 4); W = COPY(R); W->FORM = 1; REPEAT(MOVE1, W, 1, 5); RELEASEANDDROPPAIR(L, R); L_0510: return; L_050B: void ASSIGNVIAWORK(void) { struct STACKFM *W; W = CLAIMWORKAREA(255, 8); STRINGASSIGN(R, W); STRINGASSIGN(W, L); RELEASEANDDROP(W); } /* ASSIGNVIAWORK */ W = &R->LINK; if (SAFE(L, W)) goto L_0513; ASSIGNVIAWORK(); return; L_0513: R->OPLINK = 0; if (CONCLENGTH <= 0) goto L_0514; if (R->TYPE > 5) goto L_0514; L = COPY(L); if (ICONSTITEM(R)) goto L_0515; ALLCONST = 0; L_0515: if (ALLCONST == 0) goto L_0516; VALUE.STRING = _imp_join((_imp_string)(_imp_TOSTRING(R->DISP & 255)), (_imp_string)(VAL)); Z = CONSTSTRING(); STRINGASSIGN(Z, L); RELEASEANDDROP(Z); goto L_0517; L_0516: MAKEAUTOI(L, 4); MOVELITERAL(CONCLENGTH, L); L_0517: void ASSIGNPART(void) { R->OPLINK = 0; if (ALLCONST != 0) goto L_0514; SIMPLE(R, L); L_0514: } /* ASSIGNPART */ ASSIGNPART(); L_0518: R = W; W = &R->LINK; ASSIGNPART(); RELEASEANDDROP(R); if (W == NIL) goto L_0519; goto L_0518; L_0519: RELEASEANDDROP(L); return; L_051A: void CONCAT(struct STACKFM * SOURCE) { struct STACKFM *DEST; SOURCE = 0; if (SOURCE > 5) goto L_051A; DEST = REGISTER(3); DEST->TYPE = 4; DEST->FORM = 2; SIMPLE(&SOURCE, DEST); RELEASEANDDROP(DEST); return; L_051A: LOADADDRESS(&SOURCE, 4); PRIM(8); } /* CONCAT */ LL = COPY(L); AMAP(LL); if (!(SAME(L, R))) goto L_051B; if (&W->LINK != NIL) goto L_051C; if (W->TYPE > 5) goto L_051C; LOADUP(LL); LL->TYPE = 4; LL->FORM = 1; R = COPY(LL); Z = COPY(LL); OPERATE(4, Z, LITERAL(1)); LOADUP(Z); LL->INDEX = COPY(Z); LL->XSIZE = 1; SIMPLE(W, LL); SIMPLE(Z, R); RELEASEANDDROPPAIR(W, Z); RELEASEANDDROPPAIR(LL, R); return; L_051C: LOAD(LL, 3); Z = COPY(LL); Z->TYPE = 4; Z->FORM = 2; LOAD(Z, 2); R = COPY(LL); LOAD(R, 1); DROP(R); LL->INDEX = Z; LL->XSIZE = 1; LOAD(LL, 3); RELEASE(3); FORGET(3); ACTIVITY[3] = -1; LL->BASE = 1; goto L_051D; L_051B: DELAYV = NIL; L_051E: if (R->TYPE > 5) goto L_051F; DELAY = DELAY + 1; R->OPER = 0; R->LINK = DELAYV; DELAYV = R; R = W; W = &W->LINK; goto L_051E; L_051F: OPERATE(4, LL, LITERAL(DELAY + 1)); LOAD(LL, 3); LOAD(LL, 1); FORGET(3); ACTIVITY[3] = -1; if (R == NIL) goto L_0520; CONCAT(R); RELEASE(R->BASE); R->BASE = 0; if (DELAY == 0) goto L_0521; DROP(R); L_0521: goto L_0522; L_0520: LEN = DELAY; L_0522: L_051D: L_0523: if (W == NIL) goto L_0524; R = W; W = &R->LINK; CONCAT(R); RELEASEANDDROP(R); goto L_0523; L_0524: LL->TYPE = 4; LL->FORM = 3; L_0525: if (DELAY == 0) goto L_0526; DELAY = DELAY - 1; R = DELAYV; DELAYV = &R->LINK; R->LINK = NIL; SIMPLE(R, LL); if (DELAY == 0) goto L_0527; RELEASEANDDROP(R); L_0527: goto L_0525; L_0526: if (LEN != 0) goto L_0528; PLANT1(4194304, 3, 3, JUST(1)); PLANT2(67108864, 3, LL); RELEASEANDDROP(LL); LL = COPY(L); LL->TYPE = 4; REMEMBER(3, LL); goto L_0529; L_0528: MOVELITERAL(LEN, LL); L_0529: RELEASEANDDROP(LL); ACTIVITY[3] = 0; } /* STRINGASSIGN */ void STORE(struct STACKFM * R, struct STACKFM * L) { if (R->OPER != 0) goto L_052A; if (SAME(L, R)) goto L_052B; L_052A: if (L->TYPE != 9) goto L_052C; RECORDASSIGN(R, L); goto L_052D; L_052C: if (L->TYPE != 8) goto L_052E; STRINGASSIGN(R, L); goto L_052D; L_052E: if (L->TYPE != 13) goto L_052F; SETASSIGN(R, L); goto L_052D; L_052F: MOVE(R, L); L_052D: L_052B: } /* STORE */ void ASSIGNPROCEDURE(struct STACKFM * R, struct STACKFM * L) { int MASK; struct STACKFM *W; struct STACKFM *V; if (R->FLAGS & 1024 == 0) goto L_0530; HAZARD(3); DIR2(19, R->DISP); REFS = REFS + 1; *CA = *CA + 4; R = REGISTER(14); goto L_0531; L_0530: if (R->FLAGS & 4 == 0) goto L_0532; R->TYPE = 1; R->FORM = 1; R->AREA = 0; R = COPY(R); goto L_0531; L_0532: if (R->FLAGS & 16777216 == 0) goto L_0533; HAZARD(14); DIR2(18, R->DISP); REFS = REFS + 1; *CA = *CA + 4; R = REGISTER(14); goto L_0531; L_0533: HAZARD(14); DIR2(18, R->DISP); *CA = *CA + 4; REFS = REFS + 1; CLAIM(14); MASK = 9216; W = NIL; if (R->FLAGS & 65536 == 0) goto L_0534; FRAME = FRAME - 4; W = LITERAL(LOCALDISPLAY); W->BASE = *LOCAL; LOAD(W, 15); MASK = 25600; L_0534: FRAME = (FRAME & (~3)) - 8; R = LOCALINTEGER(FRAME); LOADUPADDRESS(R); PLANT4(134217728 | 8388608, R->BASE, MASK); RELEASE(14); if (W == NIL) goto L_0535; RELEASEANDDROP(W); L_0535: L_0531: L->TYPE = 1; SIMPLE(R, L); RELEASEANDDROP(R); } /* ASSIGNPROCEDURE */ void ASSIGNARRAYNAME(struct STACKFM * ARRAY, struct STACKFM * TO) { struct STACKFM *DOPEVECTOR; ARRAY->TYPE = 1; TO = 1; if (ARRAY->FLAGS & (64 | 32) != 0) goto L_0536; if (&ARRAY->ADATA != NIL) goto L_0537; DOPEVECTOR = LITERAL(0); goto L_0538; L_0537: DOPEVECTOR = LITERAL(ARRAY->ADATA); DOPEVECTOR->AREA = 512; L_0538: AMAP(ARRAY); goto L_0539; L_0536: DOPEVECTOR = COPY(ARRAY); ADVANCE(DOPEVECTOR, 1, 4); L_0539: SIMPLIFY(&TO); ADVANCE(&TO, 1, 4); SIMPLE(DOPEVECTOR, &TO); RELEASEANDDROP(DOPEVECTOR); ADVANCE(&TO, 1, -4); SIMPLE(ARRAY, &TO); } /* ASSIGNARRAYNAME */ int SELECTBEST(struct STACKFM * FROM, struct STACKFM * TO, int DEFAULT) { struct STACKFM *W; int REG; if (!(INREG(FROM))) goto L_053A; return *DEFAULT; L_053A: W = COPY(&TO); OPTIMISE(W, 1); if (!(INREG(W))) goto L_053B; if (ACTIVITY[W->BASE] != 1) goto L_053B; REG = W->BASE; goto L_053C; L_053B: REG = *DEFAULT; L_053C: RELEASEANDDROP(W); return REG; } /* SELECTBEST */ void MOVE(struct STACKFM * FROM, struct STACKFM * TO) { struct STACKFM *BF1; struct STACKFM *BF2; struct STACKFM *BT1; struct STACKFM *BT2; struct STACKFM *W; int R; int PA; int N; int BEST; int OP; if (FROM->OPER != 4) goto L_053D; if (PENDINGAUTO == 0) goto L_053D; W = &FROM->LINK; if (!(ICONST(W))) goto L_053E; if (-4095 > W->DISP) goto L_053E; if (W->DISP > 4095) goto L_053E; FROM->OPER = 0; FROM->LINK = NIL; PA = PENDINGAUTO; OPTIMISE(FROM, 1); if (!(INREG(FROM))) goto L_053F; if (FROM->BASE != PA) goto L_053F; if (PENDINGAUTON == 0) goto L_0540; if (_imp_IMOD((unsigned int)W->DISP >> 2) > 255) goto L_053F; L_0540: DIR3(16, *CA - PENDINGAUTOCA, (unsigned int)W->DISP >> PENDINGAUTON); FORGET(PA); DROP(W); goto L_0541; L_053F: FROM->OPER = 4; FROM->LINK = W; L_0541: L_053E: L_053D: if (FROM->TYPE != 2) goto L_0542; if (FROM->OPER == 9) goto L_0543; if (FROM->OPER != 12) goto L_0542; L_0543: if (TO != 1) goto L_0542; if (!(ICONST(&FROM->LINK))) goto L_0542; N = FROM->LINK; if (FROM->OPER != 12) goto L_0544; N = (~N); L_0544: if (N & -65536 != 0) goto L_0545; RELEASEANDDROP(&FROM->LINK); FROM->OPER = 0; FROM->LINK = NIL; if (N > 255) goto L_0546; ADVANCE(FROM, 4, 0); if (N == 255) goto L_0547; OPERATE(9, FROM, LITERAL(N)); L_0547: goto L_0548; L_0546: if (N & 255 != 0) goto L_0549; RELEASEANDDROP(&FROM->LINK); FROM->OPER = 0; FROM->LINK = 0; ADVANCE(FROM, 4, 1); if ((unsigned int)N >> 8 == 255) goto L_054A; OPERATE(9, FROM, LITERAL((unsigned int)N >> 8)); L_054A: OPERATE(14, FROM, LITERAL(8)); goto L_0548; L_0549: BEST = SELECTBEST(FROM, &TO, 17); BF2 = COPY(FROM); ADVANCE(BF2, 4, 1); if ((unsigned int)N >> 8 == 255) goto L_054B; OPERATE(9, BF2, LITERAL((unsigned int)N >> 8)); L_054B: ADVANCE(FROM, 4, 0); if (N & 255 == 255) goto L_054C; OPERATE(9, FROM, LITERAL(N & 255)); L_054C: LOADUP(BF2); LOADSAFELY(FROM, BEST); LOADUP(BF2); LOADSAFELY(FROM, BEST); PLANT1(25165824, FROM->BASE, FROM->BASE, ISHIFT(BF2->BASE, 8, 0)); RELEASEANDDROP(BF2); L_0548: L_0545: L_0542: if (TO != 2) goto L_054D; if (!(ICONST(FROM))) goto L_054E; BF1 = LITERAL(FROM->DISP & 255); BF2 = LITERAL((unsigned int)FROM->DISP >> 8 & 255); goto L_054F; L_054E: if (FROM->TYPE != 2) goto L_0550; if (FROM->OPER != 0) goto L_0550; if (&FROM->INDEX != NIL) goto L_0551; if (&FROM->RECORD == NIL) goto L_0552; L_0551: LOADUPADDRESS(FROM); FROM->TYPE = 2; FROM->FORM = 1; L_0552: BF1 = COPY(FROM); ADVANCE(BF1, 4, 0); BF2 = COPY(FROM); ADVANCE(BF2, 4, 1); goto L_054F; L_0550: if (FROM->TYPE != 4) goto L_0553; if (FROM->OPER != 0) goto L_0553; BF1 = COPY(FROM); ADVANCE(BF1, 4, 0); BF2 = LITERAL(0); goto L_054F; L_0553: LOADUP(FROM); BF1 = COPY(FROM); BF2 = COPY(FROM); OPERATE(15, BF2, LITERAL(8)); L_054F: BT1 = COPY(&TO); ADVANCE(BT1, 4, 0); BT2 = COPY(&TO); ADVANCE(BT2, 4, 1); MOVE(BF2, BT2); MOVE(BF1, BT1); RELEASEANDDROPPAIR(BF1, BT1); RELEASEANDDROPPAIR(BF2, BT2); goto L_0554; L_054D: if (TO != 4) goto L_0555; if (FROM->OPER != 0) goto L_0556; if (FROM->TYPE != 2) goto L_0556; FROM->TYPE = 4; L_0556: SIMPLIFY(&TO); LOADUP(FROM); PLANT2(67108864 | 4194304, FROM->BASE, &TO); goto L_0554; L_0555: if (TO != 7) goto L_0557; BEST = SELECTBEST(FROM, &TO, 26); SIMPLIFY(&TO); LOAD(FROM, BEST); PLANT6(201359616, FROM->BASE, &TO); goto L_0554; L_0557: if (TO != 6) goto L_0558; if (!(ICONST(FROM))) goto L_0559; if (-5 > FROM->DISP) goto L_055A; if (FROM->DISP <= 5) goto L_055B; L_055A: if (FROM->DISP == 10) goto L_055B; if (FROM->DISP != -10) goto L_0559; L_055B: OP = 234914176; N = FROM->DISP; if (N >= 0) goto L_055C; OP = 235962752; N = -N; L_055C: if (N != 10) goto L_055D; N = 7; L_055D: R = FPR(); PLANT9(OP | 8, 0, R, N); PLANT6(201326848, R, &TO); goto L_055E; L_0559: if (FROM->FORM != 1) goto L_055F; if (FROM->OPER != 0) goto L_055F; if (FROM->TYPE != 6) goto L_055F; TO = COPY(&TO); TO = 1; FROM = COPY(FROM); FROM->TYPE = 1; MOVE(FROM, &TO); FORGET(FROM->BASE); RELEASEANDDROPPAIR(FROM, &TO); goto L_055E; L_055F: SIMPLIFY(&TO); LOAD(FROM, 26); PLANT6(201326848, FROM->BASE, &TO); L_055E: goto L_0554; L_0558: BEST = SELECTBEST(FROM, &TO, 17); SIMPLIFY(&TO); LOAD(FROM, BEST); PLANT2(67108864, FROM->BASE, &TO); L_0554: } /* MOVE */ void MOVELITERAL(int VALUE, struct STACKFM *TO) { struct STACKFM *W; W = LITERAL(*VALUE); SIMPLE(W, &TO); RELEASEANDDROP(W); } /* MOVELITERAL */ void MOVEBIASED(struct STACKFM * FROM, struct STACKFM * TO, int BIAS) { FROM = COPY(&FROM); TO = COPY(TO); if (FROM != 1) goto L_0560; ADVANCE(&FROM, 1, *BIAS); L_0560: ADVANCE(TO, 1, *BIAS); MOVE(&FROM, TO); RELEASEANDDROPPAIR(&FROM, TO); } /* MOVEBIASED */ void STOREADDRESS(struct STACKFM * R, struct STACKFM * L, int *EXTRA) { struct STACKFM *W; int RT; int FORMAT; if (L->TYPE != 10) goto L_0561; L->TYPE = 1; if (L->FORM == 3) goto L_0562; AMAP(L); L_0562: FORMAT = R; RT = R; AMAP(&R); if (RT != 10) goto L_0563; MOVEBIASED(&R, L, 4 * 2); MOVEBIASED(&R, L, 4 * 1); MOVE(&R, L); goto L_0564; L_0563: W = LITERAL(TYPECODE[RT]); MOVEBIASED(W, L, 4 * 2); RELEASEANDDROP(W); if (RT != 8) goto L_0565; if (R != 1) goto L_0565; if (FORMAT != 1) goto L_0565; MOVEBIASED(&R, L, 4); MOVE(&R, L); goto L_0566; L_0565: W = LITERAL(ITEMSIZE(FORMAT)); MOVEBIASED(W, L, 4); RELEASEANDDROP(W); MOVE(&R, L); L_0566: L_0564: *EXTRA = *EXTRA + 12; goto L_0567; L_0561: if (L->FORM != 4) goto L_0568; ASSIGNPROCEDURE(&R, L); *EXTRA = *EXTRA + 4; goto L_0567; L_0568: if (L->FLAGS & 64 == 0) goto L_0569; ASSIGNARRAYNAME(&R, L); *EXTRA = *EXTRA + 8; goto L_0567; L_0569: if (L->TYPE != 8) goto L_056A; if (L->FORMAT != 1) goto L_056A; N = R; AMAP(L); AMAP(&R); if (N != 1) goto L_056B; if (R == 0) goto L_056B; MOVEBIASED(&R, L, 4); MOVE(&R, L); goto L_056C; L_056B: W = LITERAL(N); MOVEBIASED(W, L, 4); RELEASEANDDROP(W); MOVE(&R, L); L_056C: *EXTRA = *EXTRA + 8; goto L_0567; L_056A: if (L->FORM != 3) goto L_056D; L->TYPE = 1; goto L_056E; L_056D: AMAP(L); L_056E: AMAP(&R); STORE(&R, L); *EXTRA = *EXTRA + 4; L_0567: } /* STOREADDRESS */ void JAMTRANSFER(struct STACKFM * L, struct STACKFM * R) { int N; int TYPE; struct STACKFM *M; TYPE = L->TYPE; if (TYPE == 8) goto L_056F; JAMIT = 1; STORE(R, L); JAMIT = 0; FORGETDESTINATION(L); goto L_0570; L_056F: N = L->FORMAT - 1; if (R->OPER == 0) goto L_0571; EVALUATESTRINGEXPRESSION(R); L_0571: AMAP(L); AMAP(R); if (N > 0) goto L_0572; M = COPY(L); M->DISP = M->DISP + 4; M->TYPE = 1; goto L_0573; L_0572: M = LITERAL(N + 1); L_0573: LOADTRIO(L, 3, R, 2, M, 1); PRIM(10); RELEASEANDDROP(M); L_0570: } /* JAMTRANSFER */ void ASSIGN(int HOW) { int X; X = 0; struct VARFM *V; struct STACKFM *L; struct STACKFM *R; R = STACK; L = &R->STACK; STACK = &L->STACK; if (DIAG & 32 == 0) goto L_0574; MONITOR(L, _imp_str_literal("A-L")); MONITOR(R, _imp_str_literal("A-R")); L_0574: if (*HOW != 0) goto L_0575; STORE(R, L); goto L_0576; L_0575: if (*HOW != 1) goto L_0577; STOREADDRESS(R, L, &X); goto L_0576; L_0577: JAMTRANSFER(L, R); L_0576: if (ASSIGNLOCK == 0) goto L_0578; if (L->VARNO == 0) goto L_0578; V = VAR(L->VARNO); V->FLAGS = V->FLAGS | 128; L_0578: RELEASEANDDROPPAIR(R, L); } /* ASSIGN */ void ASSIGNPARAMETER(void) { struct STACKFM *PAR; PAR = STACK; STACK = &PAR->STACK; PAR->PARAMS = &STACK->PARAMS; STACK->PARAMS = PAR; if (STACK->EXTRA == 0) goto L_0579; STACK->EXTRA = STACK->EXTRA - 1; L_0579: PAR->VARNO = STACK->EXTRA; } /* ASSIGNPARAMETER */ struct STACKFM *TOTEMP(struct STACKFM * V, int SIZE) { struct STACKFM *W; W = CLAIMWORKAREA(*SIZE, 8); STRINGASSIGN(V, W); RELEASEANDDROP(V); return W; } /* TOTEMP */ struct STACKFM *PROCEDUREITEMS(struct STACKFM * R) { int MASK; struct STACKFM *EP; struct STACKFM *ENV; ENV = NIL; if (R->FLAGS & 1024 == 0) goto L_057A; MINSB = MINSB - 4; EP = LOCALINTEGER(MINSB); EP->BASE = 10; DIR3(19, R->DISP, EP->DISP); goto L_057B; L_057A: if (R->FLAGS & 4 == 0) goto L_057C; R->TYPE = 1; R->FORM = 1; R->AREA = 0; ENV = COPY(R); EP = COPY(ENV); ADVANCE(EP, 1, 4); goto L_057B; L_057C: if (R->FLAGS & 16777216 != 0) goto L_057D; if (R->FLAGS & 65536 == 0) goto L_057D; ENV = LOCALINTEGER(LOCALDISPLAY); AMAP(ENV); L_057D: MINSB = MINSB - 4; EP = LOCALINTEGER(MINSB); EP->BASE = 10; DIR3(18, R->DISP, EP->DISP); REFS = REFS + 1; L_057B: if (ENV != NIL) goto L_057E; ENV = LITERAL(0); L_057E: ENV->PRIM = 1; EP->PRIM = 1; ENV->PARAMS = EP; EP->PARAMS = NIL; return ENV; } /* PROCEDUREITEMS */ struct STACKFM *ARRAYNAMEITEMS(struct STACKFM * ARRAY) { struct STACKFM *DOPEVECTOR; ARRAY = COPY(&ARRAY); ARRAY = 1; if (ARRAY & (64 | 32) != 0) goto L_057F; if (&ARRAY != NIL) goto L_0580; DOPEVECTOR = LITERAL(0); goto L_0581; L_0580: DOPEVECTOR = LITERAL(ARRAY); DOPEVECTOR->AREA = 512; L_0581: AMAP(&ARRAY); goto L_0582; L_057F: DOPEVECTOR = COPY(&ARRAY); ADVANCE(DOPEVECTOR, 1, 4); L_0582: ARRAY = 1; DOPEVECTOR->PRIM = 1; ARRAY = DOPEVECTOR; DOPEVECTOR->PARAMS = NIL; return &ARRAY; } /* ARRAYNAMEITEMS */ struct STACKFM *ADDRESSITEMS(struct STACKFM * PAR, struct STACKFM * FORMAL) { struct STACKFM *W; struct STACKFM *X; struct STACKFM *Y; struct STACKFM *Z; int RT; int FORMAT; if (FORMAL->FORM != 4) goto L_0583; return PROCEDUREITEMS(PAR); L_0583: if (FORMAL->FLAGS & 64 == 0) goto L_0584; return ARRAYNAMEITEMS(PAR); L_0584: X = COPY(PAR); AMAP(X); X->PRIM = 1; X->PARAMS = NIL; FORMAT = PAR->FORMAT; if (FORMAL->TYPE != 10) goto L_0585; RT = PAR->TYPE; if (RT != 10) goto L_0586; ADVANCE(X, 1, 0); Y = COPY(X); ADVANCE(Y, 1, 4); Z = COPY(X); ADVANCE(Z, 1, 4 * 2); goto L_0587; L_0586: Z = LITERAL(TYPECODE[RT]); if (RT != 8) goto L_0588; if (X->FORM != 1) goto L_0588; if (FORMAT != 1) goto L_0588; Y = COPY(X); ADVANCE(Y, 1, 4); goto L_0589; L_0588: Y = LITERAL(ITEMSIZE(FORMAT)); L_0589: L_0587: Y->PRIM = 1; Z->PRIM = 1; X->PARAMS = Y; Y->PARAMS = Z; Z->PARAMS = NIL; goto L_058A; L_0585: if (FORMAL->TYPE != 8) goto L_058B; if (FORMAL->FORMAT != 1) goto L_058B; if (FORMAT != 1) goto L_058C; if (X->FORM == 0) goto L_058C; Y = COPY(X); ADVANCE(Y, 1, 4); goto L_058D; L_058C: Y = LITERAL(FORMAT); L_058D: Y->PRIM = 1; X->PARAMS = Y; Y->PARAMS = NIL; L_058B: L_058A: return X; } /* ADDRESSITEMS */ void PASSPARAMETERS(struct STACKFM * V, int *EXTRA, int BASEREG) { int COMPLETED; struct STACKFM *PAR; struct STACKFM *FORMAL; struct STACKFM *HEAD; struct STACKFM *L; struct STACKFM *ITEMS; struct STACKFM *REST; struct STACKFM *X; struct STACKFM *Y; struct RPFM { union { struct { struct STACKFM *P; }; }; }; struct RPFM REGINFO[4]; static struct STACKFM SPMARK; *EXTRA = 0; HEAD = &V->PARAMS; if (HEAD != NIL) goto L_058E; return; L_058E: ITEMS = NIL; L_058F: if (HEAD == NIL) goto L_0590; PAR = HEAD; HEAD = &HEAD->PARAMS; STACKVAR(PAR->VARNO); FORMAL = STACK; STACK = &FORMAL->STACK; if (FORMAL->FLAGS & 4 == 0) goto L_0591; X = PROCEDUREITEMS(PAR); goto L_0592; L_0591: if (FORMAL->FLAGS & 64 == 0) goto L_0593; X = ARRAYNAMEITEMS(PAR); goto L_0592; L_0593: if (FORMAL->FLAGS & 131072 == 0) goto L_0594; if (PAR->OPER != 22) goto L_0595; PAR = TOTEMP(PAR, 256); goto L_0596; L_0595: if (FORMAL->TYPE != 8) goto L_0597; if (PAR->TYPE == 8) goto L_0597; if (!(ICONST(PAR))) goto L_0598; FIXUNITARYSTRING(PAR); goto L_0599; L_0598: PAR = TOTEMP(PAR, 2); L_0599: goto L_0596; L_0597: if (PAR->TYPE != 8) goto L_059A; if (PAR->BIAS != 1) goto L_059A; FIXUNITARYSTRING(PAR); goto L_0596; L_059A: if (PAR->TYPE != 13) goto L_059B; if (PAR->OPER == 0) goto L_059C; LOADUP(PAR); goto L_059D; L_059C: if (&PAR->MEMBERS == NIL) goto L_059E; BUILDSET(PAR); L_059E: L_059D: L_059B: L_0596: X = ADDRESSITEMS(PAR, FORMAL); goto L_0592; L_0594: X = COPY(PAR); X->PRIM = FORMAL->TYPE; X->PARAMS = NIL; L_0592: RELEASEANDDROPPAIR(PAR, FORMAL); Y = X; L_059F: if (&Y->PARAMS == NIL) goto L_05A0; Y = &Y->PARAMS; goto L_059F; L_05A0: Y->PARAMS = ITEMS; ITEMS = X; goto L_058F; L_0590: void COMPLETEREGISTERPROCESSING(void) { int R; int N; int MASK; struct STACKFM *V; if (COMPLETED == 0) goto L_05A1; return; L_05A1: COMPLETED = 1; if (DIAG & 8 == 0) goto L_05A2; MONITORN(0, _imp_str_literal("+complete")); L_05A2: R = 0; /*%for R = 1, 1, 4 %cycle*/ L_05A3: if (R == 4) goto L_05A4; R += 1; V = ®INFO[R].P; if (V == NIL) goto L_05A6; if (V != &SPMARK) goto L_05A7; L_05A6: goto L_05A5; L_05A7: if (V->OPER == 0) goto L_05A8; LOAD(V, R); goto L_05A9; L_05A8: SIMPLIFY(V); L_05A9: L_05A5: goto L_05A3; L_05A4: R = 0; /*%for R = 1, 1, 4 %cycle*/ L_05AA: if (R == 4) goto L_05AB; R += 1; V = ®INFO[R].P; if (V == NIL) goto L_05AD; if (V != &SPMARK) goto L_05AE; L_05AD: goto L_05AC; L_05AE: if (ACTIVITY[R] != 0) goto L_05AF; if (KTIMES[R] != 0) goto L_05AF; LOAD(V, R); L_05AF: L_05AC: goto L_05AA; L_05AB: R = 0; /*%for R = 1, 1, 4 %cycle*/ L_05B0: if (R == 4) goto L_05B1; R += 1; V = ®INFO[R].P; if (V == NIL) goto L_05B3; if (V != &SPMARK) goto L_05B4; L_05B3: goto L_05B2; L_05B4: if (ACTIVITY[R] != 0) goto L_05B5; LOAD(V, R); L_05B5: L_05B2: goto L_05B0; L_05B1: N = 0; R = 0; /*%for R = 1, 1, 4 %cycle*/ L_05B6: if (R == 4) goto L_05B7; R += 1; V = ®INFO[R].P; if (V == NIL) goto L_05B9; if (V != &SPMARK) goto L_05BA; L_05B9: goto L_05B8; L_05BA: LOAD(V, R); N = N + 1; L_05B8: goto L_05B6; L_05B7: if (ACTIVEREGISTERS == N) goto L_05BB; R = 0; /*%for R = 1, 1, 4 %cycle*/ L_05BC: if (R == 4) goto L_05BD; R += 1; V = ®INFO[R].P; if (V == NIL) goto L_05BF; if (V != &SPMARK) goto L_05C0; L_05BF: HAZARD(R); L_05C0: goto L_05BC; L_05BD: HAZARD(5); HAZARD(6); HAZARD(7); HAZARD(8); if (ACTIVEREGISTERS == N) goto L_05C1; HAZARD(9); HAZARD(12); HAZARD(15); if (ACTIVEREGISTERS == N) goto L_05C2; HAZARD(18); HAZARD(19); HAZARD(20); HAZARD(21); if (ACTIVEREGISTERS == N) goto L_05C3; HAZARD(22); HAZARD(23); HAZARD(24); HAZARD(25); L_05C3: L_05C2: L_05C1: L_05BB: MASK = 0; N = 1; R = 0; /*%for R = 1, 1, 4 %cycle*/ L_05C4: if (R == 4) goto L_05C5; R += 1; if (®INFO[R].P != &SPMARK) goto L_05C7; *EXTRA = *EXTRA - 4; MASK = MASK | N; L_05C7: N = N << 1; goto L_05C4; L_05C5: if (MASK == 0) goto L_05C8; PLANT4(135266304 | 8388608 | 2097152, 13, MASK); L_05C8: R = 0; /*%for R = 1, 1, 4 %cycle*/ L_05C9: if (R == 4) goto L_05CA; R += 1; V = ®INFO[R].P; if (V == NIL) goto L_05BE; if (V != &SPMARK) goto L_05CB; L_05BE: goto L_05C6; L_05CB: RELEASEANDDROP(V); L_05C6: goto L_05C9; L_05CA: if (DIAG & 8 == 0) goto L_05CC; MONITORN(0, _imp_str_literal("+complete")); L_05CC: } /* COMPLETEREGISTERPROCESSING */ void PUSH(struct STACKFM * V, int TYPE) { struct STACKFM SPV; SPV = 0; SPV.TYPE = TYPE; SPV.FORM = 3; SPV.BASE = 13; if (TYPE != 1) goto L_05CD; LOAD(&V, 17); PLANT2(67108864, V, &SPV); goto L_05CE; L_05CD: if (TYPE != 7) goto L_05CF; LOAD(&V, 26); PLANT6(201359616, V, &SPV); *EXTRA = *EXTRA + 4; goto L_05CE; L_05CF: if (TYPE != 6) goto L_05D0; LOAD(&V, 26); PLANT6(201326848, V, &SPV); goto L_05CE; L_05D0: FAIL(_imp_str_literal("Bad push type")); L_05CE: *EXTRA = *EXTRA + 4; RELEASEANDDROP(&V); } /* PUSH */ void PROCESS(struct STACKFM * V, int RN) { struct STACKFM *NEXT; if (&V != NIL) goto L_05D1; return; L_05D1: NEXT = &V; if (RN <= 4) goto L_05D2; PROCESS(NEXT, 5); PUSH(&V, V); goto L_05D3; L_05D2: if (V != 1) goto L_05D4; REGINFO[RN].P = &V; PROCESS(NEXT, RN + 1); goto L_05D3; L_05D4: if (V != 6) goto L_05D5; SIMPLIFY(&V); if (V == 6) goto L_05D6; if (V == 7) goto L_05D6; LOAD(&V, 26); L_05D6: if (V != 1) goto L_05D7; V = 1; REGINFO[RN].P = &V; PROCESS(NEXT, RN + 1); goto L_05D8; L_05D7: PROCESS(NEXT, RN + 1); PUSH(&V, 6); REGINFO[RN].P = &SPMARK; L_05D8: goto L_05D3; L_05D5: if (V != 7) goto L_05D9; SIMPLIFY(&V); if (V == 7) goto L_05DA; LOAD(&V, 26); L_05DA: if (V != 1) goto L_05DB; if (RN != 4) goto L_05DC; PROCESS(NEXT, RN + 2); PUSH(&V, 7); REGINFO[RN].P = &SPMARK; goto L_05DD; L_05DC: V = 1; X = COPY(&V); ADVANCE(X, 1, 4); REGINFO[RN + 0].P = &V; REGINFO[RN + 1].P = X; PROCESS(NEXT, RN + 2); L_05DD: goto L_05DE; L_05DB: PROCESS(NEXT, RN + 2); PUSH(&V, 7); if (RN != 4) goto L_05DF; REGINFO[RN + 0].P = &SPMARK; goto L_05E0; L_05DF: REGINFO[RN + 0].P = &SPMARK; REGINFO[RN + 1].P = &SPMARK; L_05E0: L_05DE: goto L_05D3; L_05D9: FAIL(_imp_str_literal("Bad process type")); L_05D3: } /* PROCESS */ REGINFO[1].P = NIL; REGINFO[2].P = NIL; REGINFO[3].P = NIL; REGINFO[4].P = NIL; COMPLETED = 0; PROCESS(ITEMS, *BASEREG); COMPLETEREGISTERPROCESSING(); } /* PASSPARAMETERS */ void ARRAYINDEX(void) { struct STACKFM *X; struct STACKFM *END; X = STACK; STACK = &STACK->STACK; END = STACK; L_05E1: if (&END->PARAMS == NIL) goto L_05E2; END = &END->PARAMS; goto L_05E1; L_05E2: END->PARAMS = X; X->PARAMS = NIL; STACK->OPER = STACK->OPER + 1; } /* ARRAYINDEX */ void ARRAYACCESS(void) { int N; int LIM; int FLAG; int TYPE; int FORMAT; int XSIZE; int SCALENEEDED; SCALENEEDED = 0; int MULOP; struct STACKFM *X; struct STACKFM *ALL; struct STACKFM *NEXT; struct STACKFM *MULT; struct STACKFM *SCALE; void SETUPMULT(void) { MULT = COPY(&X->STACK); ADVANCE(MULT, 1, 4); LOADUP(MULT); MULT->DISP = 20; MULT->FORM = 1; } /* SETUPMULT */ SCALE = NIL; X = STACK; FLAG = X->STACK; MULOP = 6; if (FLAG & 8 != 0) goto L_05E3; if (X->STACK != 8) goto L_05E4; if (X->STACK == 1) goto L_05E5; L_05E4: if (X->STACK != 9) goto L_05E6; if (X->STACK != 0) goto L_05E6; L_05E5: SCALENEEDED = 1; L_05E6: L_05E3: LIM = 1; if (X->STACK == 0) goto L_05E7; ARRAYINDEX(); NEXT = &STACK->PARAMS; ALL = LITERAL(0); LIM = STACK->OPER; STACK->OPER = 0; if (FLAG & 64 == 0) goto L_05E8; SETUPMULT(); L_05E8: N = 0; /*%for N = 1, 1, LIM %cycle*/ L_05E9: if (N == LIM) goto L_05EA; N += 1; X = NEXT; NEXT = &X->PARAMS; X->PARAMS = NIL; if (N == 1) goto L_05EC; if (FLAG & 64 == 0) goto L_05ED; OPERATE(MULOP, ALL, COPY(MULT)); MULT->DISP = MULT->DISP + 12; goto L_05EE; L_05ED: OPERATE(MULOP, ALL, LITERAL(STACK->ADATA[N - 1])); L_05EE: L_05EC: OPERATE(4, ALL, X); goto L_05E9; L_05EA: if (NEXT == NIL) goto L_05EF; FAIL(_imp_str_literal("Corrupt array index")); L_05EF: X = ALL; if (FLAG & 2 != 0) goto L_05F0; if (SCALENEEDED == 0) goto L_05F1; SCALE = MULT; goto L_05F2; L_05F1: RELEASEANDDROP(MULT); L_05F2: L_05F0: goto L_05F3; L_05E7: if (SCALENEEDED == 0) goto L_05F4; SETUPMULT(); SCALE = MULT; L_05F4: STACK = &X->STACK; L_05F3: TYPE = STACK->TYPE; STACK->TYPE = 1; FORMAT = STACK->FORMAT; if (FLAG & 64 == 0) goto L_05F5; VMAP(STACK, 1); L_05F5: if (FLAG & 8 == 0) goto L_05F6; XSIZE = 4; if (TYPE != 8) goto L_05F7; if (FORMAT != 1) goto L_05F7; XSIZE = 2 * 4; L_05F7: goto L_05F8; L_05F6: if (SCALE == NIL) goto L_05F9; OPERATE(MULOP, X, SCALE); XSIZE = 1; goto L_05F8; L_05F9: XSIZE = ITEMSIZE(FORMAT); L_05F8: STACK->FLAGS = STACK->FLAGS | FLAG; APPLYINDEX(STACK, X, XSIZE); if (FLAG & 8 == 0) goto L_05FA; VMAP(STACK, TYPE); goto L_05FB; L_05FA: STACK->TYPE = TYPE; L_05FB: STACK->FORMAT = FORMAT; STACK->FLAGS = STACK->FLAGS & ~(32 | 2 | 64); if (DIAG & 8 == 0) goto L_05FC; MONITOR(STACK, _imp_str_literal("Array")); L_05FC: } /* ARRAYACCESS */ void UPDATELINE(int THISLINE) { if (STACK == NIL) goto L_05FD; FAIL(_imp_str_literal("Stack")); L_05FD: if (ACTIVEREGISTERS == 0) goto L_05FE; FAIL(_imp_str_literal("Registers")); L_05FE: if (USING == NIL) goto L_05FF; FAIL(_imp_str_literal("Descriptors")); L_05FF: if (REGV[17].BASE != 17) goto L_0600; if (REGV[26].BASE == 26) goto L_0601; L_0600: FAIL(_imp_str_literal("Corrupt")); L_0601: if (THISLINE == CURRENTLINE) goto L_0602; CURRENTLINE = THISLINE; if (COMPILINGPRIM != 0) goto L_0603; DIR2(3, CURRENTLINE); L_0603: L_0602: if (DIAG & 64 == 0) goto L_0604; _imp_SELECTOUTPUT(0); _imp_PRINTSTRING(_imp_str_literal("Line:")); _imp_WRITE(THISLINE, 1); _imp_NEWLINE(); _imp_SELECTOUTPUT(2); L_0604: if (DIAG & 128 == 0) goto L_0605; DISPLAYKNOWLEDGE(); L_0605: WORKVALIDITY = WORKVALIDITY + 1; VALUE = DEFAULTVALUE; } /* UPDATELINE */ void TERMINATEBLOCK(void) { int J; int N; int M; struct VARFM *V; if (AMODE >= 0) goto L_0606; if (AMODE == -16) goto L_0606; FALIGN = ALTALIGN; N = 0; if (FALIGN != (~0)) goto L_0607; N = FRAMEEXTRA; goto L_0608; L_0607: if (FALIGN != (~1)) goto L_0609; N = FRAMEEXTRA & 2; L_0609: L_0608: M = N; if (N == 0) goto L_060A; J = PARMS - 1; /*%for J = PARMS, 1, FIRSTALT %cycle*/ L_060B: if (J == FIRSTALT) goto L_060C; J += 1; V = VAR(J); V->DISP = V->DISP - N; goto L_060B; L_060C: MAXFRAME = MAXFRAME - N; FRAME = FRAME - N; L_060A: if (MAXFRAME <= FRAME) goto L_060E; FRAME = MAXFRAME; L_060E: if (AMODE != -2) goto L_060F; OLDFRAME = FRAME; goto L_0610; L_060F: AVAR = (~FALIGN); FRAME = FRAME + (~FALIGN) & FALIGN; AVAR = FRAME; DIR1(6); L_0610: L_0606: FRAME = OLDFRAME; } /* TERMINATEBLOCK */ void COPYOLDDISPLAY(void) { int T; int J; void COPY(int FLAG, int TO) { struct STACKFM *F; struct STACKFM *T; F = LITERAL(0); if (FLAG >= 0) goto L_0611; F->BASE = *LOCAL; goto L_0612; L_0611: F->BASE = 9; F->FORM = 2; CLAIM(F->BASE); LOADUP(F); L_0612: T = LOCALINTEGER(TO); PLANT2(67108864, F->BASE, T); RELEASEANDDROPPAIR(F, T); } /* COPY */ T = LOCALDISPLAY; J = DANGERLEVEL - 1; /*%for J = DANGERLEVEL, 1, *LOCAL - 1 %cycle*/ L_0613: if (J == *LOCAL - 1) goto L_0614; J += 1; COPY(0, T); T = T + 4; goto L_0613; L_0614: COPY(-1, T); } /* COPYOLDDISPLAY */ int FINISHPARAMS(void) { int J; int MOD; MOD = 0; int TYPE; int A; int N; struct VARFM *AP; struct VARFM *FP; struct VARFM *V; struct STACKFM *S; PARAMETERREGS = 0; *PARAMETERLIST = 0; if (AMODE >= 0) goto L_0616; FLUSHDIAGS(); return 1 /*TRUE*/; L_0616: PARAMETERFRAME = FRAME; if (AVAR->P & 524288 == 0) goto L_0617; if (AVAR->P & 8 != 0) goto L_0617; if (AVAR == 8) goto L_0615; if (AVAR != 9) goto L_0617; L_0615: PARAMETERFRAME = PARAMETERFRAME + 4; STRINGRESULT = 4; MOD = MOD + 4; L_0617: if (AMODE != 0) goto L_0618; N = 1; A = 4; L_0619: if (A >= PARAMETERFRAME) goto L_061A; S = LOCALINTEGER(A); REMEMBER(N, S); DROP(S); PARAMETERREGS = PARAMETERREGS + 1; A = A + 4; if (N != 4) goto L_061B; goto L_061A; L_061B: N = N + 1; goto L_0619; L_061A: L_0618: FRAME = -20; if (VARBASE == *VARS) goto L_061C; AVAR = PARMS; AVAR = PARAMETERFRAME; J = VARBASE + 1 - 1; /*%for J = VARBASE + 1, 1, *VARS %cycle*/ L_061D: if (J == *VARS) goto L_061E; J += 1; AP = VAR(J); PARMS = PARMS - 1; FP = VAR(PARMS); AP->BASE = *LOCAL; *FP = *AP; FP->BASE = 13; FP->FORM = 3; FP->DISP = 0; AP->DISP = AP->DISP + MOD; FP->FLAGS = FP->FLAGS | 128; if (AP->FORM == 1) goto L_061F; FP->FLAGS = FP->FLAGS | 131072; L_061F: if (FP->TYPE == 4) goto L_060D; if (FP->TYPE != 2) goto L_0620; L_060D: FP->TYPE = 1; L_0620: if (AP->FLAGS & 131072 == 0) goto L_0621; if (AMODE != 0) goto L_0621; if (AP->FORM == 4) goto L_0621; AP->FLAGS = AP->FLAGS - 131072; V = VAR(2000); *V = *AP; FRAME = FRAME - ITEMSIZE(AP->FORMAT); V->BASE = *LOCAL; V->DISP = FRAME; STACKVAR(2000); STACKVAR(J); TYPE = STACK->TYPE; STACK->TYPE = 1; VMAP(STACK, TYPE); ASSIGN(0); *AP = *V; L_0621: if (AP->FLAGS & 4 != 0) goto L_0622; AP->FLAGS = AP->FLAGS | 128; L_0622: goto L_061D; L_061E: FLUSHDIAGS(); L_061C: if (AMODE == 0) goto L_0623; return 1 /*TRUE*/; L_0623: if (DANGERMARKER == 0) goto L_0624; if (DANGERLEVEL != 32767) goto L_0625; DANGERLEVEL = *LOCAL; L_0625: L_0624: if (DANGERLEVEL == 32767) goto L_0626; FRAME = (FRAME & (~3)) - 4 * (*LOCAL - DANGERLEVEL + 1); LOCALDISPLAY = FRAME; ATTRIBUTES = ATTRIBUTES | 128 | 256; L_0626: if (LOCALDISPLAY == 0) goto L_0627; COPYOLDDISPLAY(); L_0627: return 0 /*FALSE*/; } /* FINISHPARAMS */ int TAG(void) { int N; _imp_READSYMBOL(&N); N = (PENDING << 8) + N; _imp_READSYMBOL(&PENDING); return N; } /* TAG */ void GETSTRING(_imp_string * TEXT) { int J; int SYM; int LIMIT; LIMIT = _imp_SIZEOF(&TEXT) - 1; TEXT = _imp_str_literal(""); J = PENDING + 1; /*%for J = PENDING, -1, 1 %cycle*/ L_0628: if (J == 1) goto L_0629; J -= 1; _imp_READSYMBOL(&SYM); if (*_imp_LENGTH(&TEXT) >= LIMIT) goto L_062B; TEXT = _imp_join((_imp_string)(TEXT), (_imp_string)(_imp_TOSTRING(SYM))); L_062B: goto L_0628; L_0629: _imp_READSYMBOL(&PENDING); } /* GETSTRING */ int ONIEEE(void) { int MONE; MONE = -1; double M; M = MONE; unsigned char B; B = *_imp_BYTEINTEGER(_imp_ADDR(&M)); if (B == 0) goto L_062A; if (B != 191) goto L_062C; L_062A: return 1 /*TRUE*/; L_062C: return 0 /*FALSE*/; } /* ONIEEE */ void CONVERTFORMAT(struct STACKFM * V, int TYPE) { float SINGLE; int A; A = V; int B; B = V; int FH; int FL; int S; int X; if (A != 0) goto L_062D; if (0 == B) goto L_062E; L_062D: if (ONIEEE()) goto L_062E; FH = (A & 127) << 16 | (unsigned int)A >> 16; FL = (B & 65535) << 16 | (unsigned int)B >> 16; X = (unsigned int)A >> 7; X = (X & 255) - 128; S = (unsigned int)A >> 15 & 1; if (TYPE != 7) goto L_062F; X = X + 1023 - 1 & 2047; B = (FH & 7) << 29 | (unsigned int)FL >> 3; A = (S << 31) + (X << 20) + ((unsigned int)FH >> 3 & 1048575); goto L_0630; L_062F: X = X + 127 - 1 & 255; A = (S << 31) + (X << 23) + FH; B = 0; L_0630: goto L_0631; L_062E: if (TYPE != 6) goto L_0632; SINGLE = V; A = *_imp_INTEGER(_imp_ADDR(&SINGLE)); B = 0; L_0632: L_0631: V = A; V = B; } /* CONVERTFORMAT */ void TOSHORTREAL(struct STACKFM * V) { int X; int Y; int EXP; int S; if (V != 0) goto L_0633; if (0 != V) goto L_0633; return; L_0633: if (!(ONIEEE())) goto L_0634; *_imp_REAL(_imp_ADDR(&V)) = V; goto L_0635; L_0634: X = V; S = X; Y = V; EXP = ((unsigned int)X >> 20 & 2047) - 1023 + 1; EXP = EXP + 127 - 1; X = (X & 1048575) << 3; X = X | (unsigned int)Y >> 32 - 3; if (Y & 268435456 == 0) goto L_0636; X = X + 1; L_0636: if (X & 8388608 == 0) goto L_0637; X = (unsigned int)X >> 1; EXP = EXP + 1; L_0637: X = X | (EXP & 255) << 23; if (S >= 0) goto L_0638; X = X | -2147483648; L_0638: V = X; V = 0; L_0635: } /* TOSHORTREAL */ double REALCONSTANT(void) { extern double TEXTTOFLOATING(_imp_string255 S, int EXP) __asm__("3L___text_to_float"); int EXP; int J; double VALUE; _imp_string255 S; if (!_imp_on_event(1, 4)) goto L_0639; if (_imp_EVENT().EVENT != 1) goto L_063A; FAIL(_imp_str_literal("overflow while processing real constant")); L_063A: if (_imp_EVENT().EVENT != 4) goto L_063B; FAIL(_imp_str_literal("error in real constant")); L_063B: FAIL(_imp_str_literal("Bad signal")); L_0639: S = _imp_str_literal(""); EXP = 0; J = 0; /*%for J = 1, 1, TAG() %cycle*/ L_063C: if (J == TAG()) goto L_063D; J += 1; if (PENDING != 64) goto L_063F; _imp_READSYMBOL(&PENDING); EXP = TAG(); if (EXP & -32768 == 0) goto L_0640; EXP = EXP | -32768; L_0640: goto L_063D; L_063F: S = _imp_join((_imp_string)(S), (_imp_string)(_imp_TOSTRING(PENDING))); _imp_READSYMBOL(&PENDING); goto L_063C; L_063D: VALUE = TEXTTOFLOATING(S, EXP); if (PENDING != 85) goto L_0641; VALUE = -VALUE; _imp_READSYMBOL(&PENDING); L_0641: return VALUE; } /* REALCONSTANT */ int FOURBYTES(void) { int A; int B; int C; int D; A = PENDING; _imp_READSYMBOL(&B); _imp_READSYMBOL(&C); _imp_READSYMBOL(&D); _imp_READSYMBOL(&PENDING); return (((A << 8) + B << 8) + C << 8) + D; } /* FOURBYTES */ void INPUTINTEGERVALUE(int BYTE) { CONSTANTTYPE = 1; if (BYTE != 0) goto L_0642; VALUE.INTEGER = FOURBYTES(); goto L_0643; L_0642: VALUE.INTEGER = PENDING; _imp_READSYMBOL(&PENDING); L_0643: if (PENDING != 85) goto L_0644; VALUE.INTEGER = -VALUE.INTEGER; _imp_READSYMBOL(&PENDING); goto L_0645; L_0644: if (PENDING != 92) goto L_0646; VALUE.INTEGER = (~VALUE.INTEGER); _imp_READSYMBOL(&PENDING); L_0646: L_0645: if (PENDING == 65) goto L_0647; STACKINTEGER(VALUE.INTEGER); L_0647: } /* INPUTINTEGERVALUE */ void INPUTREALVALUE(void) { CONSTANTTYPE = 6; VALUE.REAL = REALCONSTANT(); if (PENDING == 65) goto L_0648; if (PENDING == 36) goto L_0648; STACKINTEGER(0); if (VALUE.REAL != 0) goto L_05EB; if (PENDING == 83) goto L_0649; if (PENDING == 63) goto L_0649; L_05EB: STACK->TYPE = 7; STACK->RVAL = VALUE.REAL; CONVERTFORMAT(STACK, 7); L_0649: L_0648: } /* INPUTREALVALUE */ void INPUTSTRINGVALUE(void) { struct STACKFM *W; CONSTANTTYPE = 8; GETSTRING(&VALUE.STRING); if (PENDING == 36) goto L_063E; if (PENDING != 65) goto L_064A; L_063E: return; L_064A: if (*_imp_LENGTH(&VALUE.STRING) != 1) goto L_064B; STACKINTEGER(*_imp_CHARNO(&VALUE.STRING, 1)); STACK->BIAS = -1; goto L_064C; L_064B: W = CONSTSTRING(); W->STACK = STACK; STACK = W; L_064C: } /* INPUTSTRINGVALUE */ int INREG(struct STACKFM * V) { if (V == NIL) goto L_064D; if (V->FORM != 0) goto L_064D; if (V->DISP != 0) goto L_064D; if (V->BASE == 0) goto L_064D; if (V->AREA != 0) goto L_064D; if (V->OPER != 0) goto L_064D; if (&V->INDEX != NIL) goto L_064D; if (&V->RECORD == NIL) goto L_064E; L_064D: return 0 /*FALSE*/; L_064E: return 1 /*TRUE*/; } /* INREG */ int FLOATING(struct STACKFM * V) { if (6 > V->TYPE) goto L_064F; if (V->TYPE <= 7) goto L_0650; L_064F: if (V->OPER < 23) goto L_0651; L_0650: return 1 /*TRUE*/; L_0651: return 0 /*FALSE*/; } /* FLOATING */ int SAME(struct STACKFM * A, struct STACKFM * B) { if (A != &B) goto L_0652; return 1 /*TRUE*/; L_0652: if (A == NIL) goto L_0653; if (&B != NIL) goto L_0654; L_0653: return 0 /*FALSE*/; L_0654: if (A->DISP != B) goto L_0655; if (A->BASE != B) goto L_0655; if (A->TYPE != B) goto L_0655; if (A->FORM != B) goto L_0655; if (A->EXTRA != B) goto L_0655; if (A->AREA == B) goto L_0656; L_0655: return 0 /*FALSE*/; L_0656: if (&A->INDEX == NIL) goto L_0657; if (&B == NIL) goto L_0658; if (A->XSIZE != B) goto L_0658; if (!(SAME(&A->INDEX, &B))) goto L_0658; if (A->INDEX != B) goto L_0658; if (SAME(&A->INDEX, &B)) goto L_0659; L_0658: return 0 /*FALSE*/; L_0659: goto L_065A; L_0657: if (&B == NIL) goto L_065B; return 0 /*FALSE*/; L_065B: L_065A: if (&A->RECORD == NIL) goto L_065C; if (&B == NIL) goto L_065D; if (!(SAME(&A->RECORD, &B))) goto L_065D; if (A->RECORD != B) goto L_065D; if (SAME(&A->RECORD, &B)) goto L_065E; L_065D: return 0 /*FALSE*/; L_065E: goto L_065F; L_065C: if (&B == NIL) goto L_0660; return 0 /*FALSE*/; L_0660: L_065F: return 1 /*TRUE*/; } /* SAME */ int CONST(struct STACKFM * V) { if (V->FORM != 0) goto L_0661; if (V->BASE != 0) goto L_0661; if (V->OPER != 0) goto L_0661; if (&V->INDEX != NIL) goto L_0661; if (&V->RECORD != NIL) goto L_0661; if (V->AREA == 0) goto L_0662; L_0661: return 0 /*FALSE*/; L_0662: return 1 /*TRUE*/; } /* CONST */ int ICONST(struct STACKFM * V) { if (V == NIL) goto L_0663; if (V->FORM != 0) goto L_0663; if (V->BASE != 0) goto L_0663; if (V->OPER != 0) goto L_0663; if (&V->INDEX != NIL) goto L_0663; if (&V->RECORD != NIL) goto L_0663; if (V->TYPE > 5) goto L_0663; if (V->AREA == 0) goto L_0664; L_0663: return 0 /*FALSE*/; L_0664: return 1 /*TRUE*/; } /* ICONST */ int ICONSTITEM(struct STACKFM * V) { if (V == NIL) goto L_0665; if (V->FORM != 0) goto L_0665; if (V->BASE != 0) goto L_0665; if (&V->INDEX != NIL) goto L_0665; if (&V->RECORD != NIL) goto L_0665; if (V->TYPE > 5) goto L_0665; if (V->AREA == 0) goto L_0666; L_0665: return 0 /*FALSE*/; L_0666: return 1 /*TRUE*/; } /* ICONSTITEM */ int POWER(int N) { int P; int MASK; if (*N <= (unsigned int)~((unsigned int)-1 >> 1) >> 1) goto L_0667; return -1; L_0667: MASK = 1; P = 0; L_0668: if (MASK != *N) goto L_0669; return P; L_0669: if (MASK <= *N) goto L_066A; return -1; L_066A: MASK = MASK << 1; P = P + 1; goto L_0668; } /* POWER */ int ITEMSIZE(int F) { if (*F < 0) goto L_066B; return *F; L_066B: return VAR(-*F)->FORMAT; } /* ITEMSIZE */ struct STACKFM *CLAIMWORKAREA(int BYTES, int TYPE) { struct STACKFM *T; struct WORKFM *W; struct WORKFM *BEST; BEST = NIL; int P; if (*BYTES > 0) goto L_066C; FAIL(_imp_str_literal("claim work area/1")); L_066C: P = WORKBASE; L_066D: if (P != LASTWORK) goto L_066E; if (BEST != NIL) goto L_066F; LASTWORK = LASTWORK + 1; BEST = WORKAREA(LASTWORK); FRAME = FRAME - *BYTES & (~3); BEST->SIZE = *BYTES; BEST->DISPLACEMENT = FRAME; L_066F: W = BEST; goto L_0670; L_066E: P = P + 1; W = WORKAREA(P); if (DIAG & 2 == 0) goto L_0671; MONITORN(P, _imp_str_literal("try work")); L_0671: if (W->VALIDITY >= WORKVALIDITY) goto L_0672; if (W->SIZE < *BYTES) goto L_0672; if (W->SIZE != *BYTES) goto L_0673; goto L_0670; L_0673: if (BEST == NIL) goto L_0674; if (BEST->SIZE <= W->SIZE) goto L_0675; L_0674: BEST = W; L_0675: L_0672: goto L_066D; L_0670: W->VALIDITY = WORKVALIDITY; if (DIAG & 2 == 0) goto L_0676; MONITORN(W->DISPLACEMENT, _imp_str_literal("temporary")); L_0676: T = LITERAL(W->DISPLACEMENT); T->BASE = *LOCAL; T->TYPE = TYPE; T->FORM = 1; T->FORMAT = *BYTES; return T; } /* CLAIMWORKAREA */ void CONSTANTBOUNDS(void) { VUB = POPPEDVALUE(); VLB = POPPEDVALUE(); } /* CONSTANTBOUNDS */ void SETCD(int VALUE, int *CD) { if (*VALUE & 49152 != 2 << 14) goto L_0677; *CD = *VALUE & 16383; L_0677: } /* SETCD */ int ALTERNATEFORMAT(int CODE) { int ATTR; ATTR = 0; struct VARFM DUMMY; if (*CODE != 65) goto L_0678; ASSEMBLE(&DUMMY, -2, *VARS, *LOCAL, -1, &ATTR); ALTALIGN = ALTALIGN & FALIGN; goto L_0679; L_0678: if (*CODE != 67) goto L_067A; if (FRAME <= MAXFRAME) goto L_067B; MAXFRAME = FRAME; L_067B: FRAME = FRAMEBASE; goto L_0679; L_067A: if (*CODE != 66) goto L_067C; if (MAXFRAME <= FRAME) goto L_067D; FRAME = MAXFRAME; L_067D: FALIGN = ALTALIGN; return 1 /*TRUE*/; L_067C: FAIL(_imp_join((_imp_string)(_imp_str_literal("Format ")), (_imp_string)(_imp_ITOS(*CODE, 0)))); L_0679: return 0 /*FALSE*/; } /* ALTERNATEFORMAT */ void COMPILEBEGIN(void) { int MAINEP; MAINEP = 0; struct VARFM B; B = 0; B.TYPE = 10; B.DISP = NEWLABEL(); B.BASE = 0; if (*LOCAL == 128) goto L_067E; STACKINTEGER(B.DISP); if (*LOCAL < DANGERLEVEL) goto L_067F; STACK->FLAGS = STACK->FLAGS | 65536; L_067F: CALL(0); OSTATE = 0; goto L_0680; L_067E: OSTATE = 3; EXTERNALID = _imp_str_literal("3L___main_program"); ENTRYPOINT = EXTERNALNO + 1; MAINEP = 1; L_0680: INTERNALID = _imp_str_literal("block"); if (_imp_strcmp(ALIAS, _imp_str_literal("")) == 0) goto L_0681; INTERNALID = ALIAS; ALIAS = _imp_str_literal(""); L_0681: ASSEMBLE(&B, 0, *VARS, *LOCAL + 1, 0, &ATTRIBUTES); } /* COMPILEBEGIN */ void CLEARVARS(int LIMIT) { if (LIMIT < PARMS) goto L_0682; FAIL(_imp_str_literal("Too many objects")); L_0682: L_0683: if (*VARS >= LIMIT) goto L_0684; *VARS = *VARS + 1; *VAR(*VARS) = 0; goto L_0683; L_0684: } /* CLEARVARS */ void DIRSTRING(int OP, _imp_string *S) { int L; L = *_imp_LENGTH(&S); int J; if (OP < 0) goto L_0685; DIR1(OP); L_0685: DIR1(L); J = 0; /*%for J = 1, 1, L %cycle*/ L_0686: if (J == L) goto L_0687; J += 1; DIR1(*_imp_CHARNO(&S, J)); goto L_0686; L_0687: } /* DIRSTRING */ void DUMPEXTERNAL(int CODE, struct VARFM *V) { EXTERNALNO = EXTERNALNO + 1; if (CODE & 1 != 0) goto L_0689; if (V.FORM != 4) goto L_068A; V.AREA = 23; V.DISP = EXTERNALNO; goto L_068B; L_068A: V.AREA = -EXTERNALNO; V.DISP = 0; L_068B: L_0689: if (CODE & 2 == 0) goto L_068C; if (V.FLAGS & 256 == 0) goto L_068C; CODE = CODE | 4; L_068C: DIRSTRING(21, &EXTERNALID); DIR2(CODE, V.DISP); } /* DUMPEXTERNAL */ void PLANTDIAG(struct DIAGFM * D) { int DISP; int TYPE; int IND; int BASE; int BTYPE; int PTYPE; struct AFM *DV; if (D.PRIM & 64 == 0) goto L_068D; if (D.FORM & 65535 != 0) goto L_068D; return; L_068D: DISP = D.BASE; if (D.RVAR == 0) goto L_068E; DISP = D.RVAR; L_068E: TYPE = (unsigned int)D.PRIM >> 2 & 15; if (INTERFACE->OPTIONS & 4 == 0) goto L_068F; if (TYPE == 14) goto L_068F; DIRSTRING(2, &D.DISP); DUMPENCODED(D.PRIM); DUMPENCODED(D.TYPE); DUMPENCODED(D.BASE); if (D.PRIM & 64 == 0) goto L_0690; DUMPENCODED(D.FORM & 65535); L_0690: L_068F: if (DEBUG == 0) goto L_0691; BASE = D.PRIM & 3; IND = (unsigned int)D.PRIM >> 7; BTYPE = D.TYPE & 15; PTYPE = (unsigned int)D.TYPE >> 4 & 15; if (TYPE != 14) goto L_0692; DIRSTRING(33, &D.DISP); DV = &D.BASE; DUMPENCODED(DV->BOUND[1]); DUMPENCODED(DV->BOUND[1]); DUMPENCODED(DV->TOTALSIZE); DUMPENCODED(BTYPE); DUMPENCODED(D.FORM & 65535); goto L_0693; L_0692: if (BASE == 1) goto L_0694; if (BASE == 2) goto L_0694; return; L_0694: DIRSTRING(34, &D.DISP); DUMPENCODED(TYPE); DUMPENCODED(IND); DUMPENCODED(BASE); DUMPENCODED(BTYPE); DUMPENCODED(PTYPE); DUMPENCODED(D.BASE); DUMPENCODED(D.FORM & 65535); DUMPENCODED(ITEMSIZE(D.BASE)); L_0693: L_0691: } /* PLANTDIAG */ void DUMPDIAG(int BASE, struct QFM *Q) { struct DIAGFM D; struct DIAGFM *ND; if (COMPILINGPRIM == 0) goto L_0695; return; L_0695: D.LINK = DIAGLIST; D.ID = INTERNALID; D.XTYPE = 0; D.EXT = 0; if (BASE != 17) goto L_0696; if (*PARAMETERLIST != 0) goto L_0697; return; L_0697: BASE = 0; D.XTYPE = (unsigned int)Q >> 2 & 15; Q = 14 << 2; goto L_0698; L_0696: if (BASE != *LOCAL) goto L_0699; BASE = 1; goto L_0698; L_0699: if (BASE != 10) goto L_069A; BASE = 2; goto L_0698; L_069A: if (BASE >= 0) goto L_069B; D.EXT = -BASE; BASE = 3; goto L_0698; L_069B: BASE = 0; L_0698: if (&Q != NIL) goto L_069C; D.X = 0; D.FORMAT = 0; goto L_069D; L_069C: D.FORMAT = Q; if (&Q == NIL) goto L_069E; D.XTYPE = (unsigned int)Q >> 2 | ((unsigned int)Q >> 2 & 15) << 4; Q = Q | 15 << 2 | Q & 64; D.FORMAT = Q; L_069E: D.X = Q << 7 | Q | BASE; L_069D: D.VAR = DEFV; if (D.FORMAT != 0) goto L_069F; if (D.X & 64 == 0) goto L_069F; return; L_069F: if (*PARAMETERLIST != 0) goto L_06A0; PLANTDIAG(&D); goto L_06A1; L_06A0: ND = _imp_NEW(DIAGFMTYPE); U_100D: *ND = D; DIAGLIST = ND; L_06A1: } /* DUMPDIAG */ void FLUSHDIAGS(void) { void FLUSH(struct DIAGFM * D) { if (&D != NIL) goto L_06A2; return; L_06A2: FLUSH(&D); PLANTDIAG(&D); _imp_DISPOSE(&D); } /* FLUSH */ FLUSH(DIAGLIST); DIAGLIST = NIL; } /* FLUSHDIAGS */ void DEFINEVAR(void) { int DECL; int TF; int NEWV; int AREA; int EXTERNALMODE; int *AT; int SPEC; int OFLAGS; int N; int TYPE; int FORM; int FORMAT; struct VARFM *FV; struct QFM Q; struct QFM PQ; struct STACKFM *VV; const unsigned char FORMMAP[16] = {0, 1, 15, 0, 0, 0, 0, 4, 4, 4, 4, 1, 1, 1, 1, 0}; void ENCODETYPE(int TYPE, int FORMAT, struct QFM *Q) { static const void *T[14] = {&&case_T_M3, &&case_T_M2, &&case_T_M1, &&case_T_0, &&case_T_1, &&case_T_2, &&case_T_3, &&case_T_4, &&case_T_5, &&case_T_6, &&case_T_7, &&case_T_8, &&case_T_9, &&case_T_10}; const short int DIAGMAP[14] = {20, 12, 8, 0, 4, 16, 24, 92, 32, 52, 104, 108, 48, 36}; const unsigned char TYPEMAP[14] = {7, 4, 2, 10, 1, 6, 8, 9, 4, 13, 4, 2, 1, 4}; const unsigned char SIZEMAP[14] = {8, 1, 2, 12, 4, 4, 0, 0, 1, 32, 1, 2, 4, 1}; const unsigned char ALGNMAP[14] = {3, 0, 1, 3, 3, 3, 0, 0, 0, 3, 0, 1, 3, 0}; if (TYPE != 1) goto L_06A3; if (FORMAT != 2) goto L_06A4; TYPE = -2; goto L_06A5; L_06A4: if (FORMAT != 3) goto L_06A6; TYPE = -1; L_06A6: L_06A5: goto L_06A7; L_06A3: if (TYPE != 2) goto L_06A8; if (FORMAT != 4) goto L_06A9; TYPE = -3; L_06A9: L_06A8: L_06A7: if (-3 > TYPE) goto L_0688; if (TYPE <= 10) goto L_06AA; L_0688: FAIL(_imp_str_literal("Unknown type")); L_06AA: Q = TYPEMAP[TYPE]; Q = SIZEMAP[TYPE]; DEFV->FORMAT = Q; Q = ALGNMAP[TYPE]; Q = 0; Q = DIAGMAP[TYPE]; Q = 0; Q = FORMAT; Q = 1; Q = 0; Q = NIL; goto *T[TYPE + 3]; /*TO DO*/ case_T_0:; Q = 0; return; case_T_M3:; case_T_1:; case_T_2:; case_T_5:; DEFV->FLAGS = DEFV->FLAGS | 1048576; case_T_M1:; case_T_M2:; case_T_10:; return; case_T_3:; Q = FORMAT + 1; DEFV->FORMAT = Q; return; case_T_4:; FV = VAR(FORMAT); if (FORMAT <= *VARS) goto L_06AC; CLEARVARS(FORMAT); INTERFACE->FORMATS = INTERFACE->FORMATS + 1; FV->AREA = INTERFACE->FORMATS; goto L_06AD; L_06AC: Q = FV->FORMAT; L_06AD: DEFV->FORMAT = -FORMAT; Q = FV->DISP; Q = FV->AREA; case_T_7:; Q = VAR(FORMAT)->AREA; return; case_T_8:; Q = VAR(FORMAT)->AREA; return; case_T_9:; DEFV->FLAGS = DEFV->FLAGS | 1048576; case_T_6:; if (&Q == &PQ) goto L_06AE; ENCODETYPE(Q, FORMAT, &PQ); DEFV->FORMAT = SIZEMAP[TYPE]; Q = &PQ; goto L_06AF; L_06AE: Q = 0; L_06AF: if (TYPE != 6) goto L_06B0; DEFV->FLAGS = DEFV->FLAGS & (~1048576); L_06B0: return; } /* ENCODETYPE */ NEWV = 1; DECL = TAG(); if (DECL == 0) goto L_06B1; if (DECL > *VARS) goto L_06B2; NEWV = 0; L_06B2: DEFV = VAR(DECL); CLEARVARS(DECL); goto L_06B3; L_06B1: PARMS = PARMS - 1; DEFV = VAR(PARMS); *DEFV = 0; L_06B3: if (PARMS > *VARS) goto L_06B4; FAIL(_imp_str_literal("Too many objects")); L_06B4: INTERNALID = _imp_str_literal(""); L_06B5: if (PENDING == 44) goto L_06B6; if (*_imp_LENGTH(&INTERNALID) == 127) goto L_06B7; INTERNALID = _imp_join((_imp_string)(INTERNALID), (_imp_string)(_imp_TOSTRING(PENDING))); L_06B7: _imp_READSYMBOL(&PENDING); goto L_06B5; L_06B6: _imp_READSYMBOL(&PENDING); TF = TAG(); FORMAT = TAG(); OSTATE = TAG(); Q.DIM = (unsigned int)OSTATE >> 8; SPEC = OSTATE & 8; OFLAGS = OSTATE & 240; OSTATE = OSTATE & 7; if (OSTATE != 5) goto L_06B8; OSTATE = 3; L_06B8: TYPE = (unsigned int)TF >> 4 & 15; FORM = TF & 15; if (_imp_strcmp(ALIAS, _imp_str_literal("")) == 0) goto L_06B9; if (OSTATE != 4) goto L_06BA; OSTATE = 3; L_06BA: EXTERNALID = ALIAS; ALIAS = _imp_str_literal(""); goto L_06BB; L_06B9: if (OSTATE != 4) goto L_06BC; OSTATE = 3; EXTERNALID = _imp_join((_imp_string)(_imp_str_literal("$")), (_imp_string)(INTERNALID)); goto L_06BB; L_06BC: EXTERNALID = INTERNALID; L_06BB: EXTERNALMODE = OSTATE; if (FORM != 0) goto L_06BD; if (DECL != 0) goto L_06BD; PARMS = PARMS + 1; DUMPDIAG(0, NIL); return; L_06BD: ENCODETYPE(TYPE, FORMAT, &Q); if (_imp_strcmp(INTERNALID, _imp_str_literal("")) != 0) goto L_06BE; Q.DIAGS = 0; L_06BE: DEFV->TYPE = Q.TYPE; if (OFLAGS & 16 == 0) goto L_06BF; DEFV->TYPE = 1; DEFV->FORMAT = 4; Q.IND = 1; Q.SIZE = 4; Q.ROUND = 3; Q.BIAS = 0; FORM = 1; L_06BF: if (FORM == 1) goto L_06C0; Q.BIAS = 0; L_06C0: if (OFLAGS & 32 == 0) goto L_06C1; DEFV->FLAGS = DEFV->FLAGS | 1048576; L_06C1: DECLSIZE = Q.SIZE; DEFV->FORM = FORMMAP[FORM]; if (FORM != 4) goto L_06C2; DEFV->EXTRA = PARMS; PARAMETERMODE = -1; BLOCKTYPE = -1; if (DEFV->AREA != 0) goto L_06C3; INTERFACE->FORMATS = INTERFACE->FORMATS + 1; DEFV->AREA = INTERFACE->FORMATS; L_06C3: return; L_06C2: if (FORM != 3) goto L_06C4; SETUSERLABEL(DECL); if (LANGUAGEFLAGS & 1 == 0) goto L_06C5; if (WSPSAVE != 0) goto L_06C6; SAVEWSP(); L_06C6: DEFV->EXTRA = WSPSAVE; L_06C5: goto L_06C7; L_06C4: if (FORM != 6) goto L_06C8; DEFV->AREA = FREELABEL - VLB + 1; DEFV->DISP = VLB; DEFV->EXTRA = VUB; N = FREELABEL + 1; FREELABEL = N + VUB - VLB; CONSTANTBASE = CONSTANTBASE + 3 & (~3); SELECTCONSTANTAREA(); DEFV->FORMAT = *CA; DUMPWORD(VUB); DUMPWORD(VLB); DIR3(28, N, FREELABEL); CONSTANTBASE = CONSTANTBASE + 4 * (VUB - VLB + 1); SELECTCODEAREA(); goto L_06C7; L_06C8: if (7 > FORM) goto L_06C9; if (FORM > 10) goto L_06C9; PARAMETERMODE = 1; BLOCKTYPE = SPEC; if (8 > FORM) goto L_06CA; if (FORM > 9) goto L_06CA; DEFV->FLAGS = DEFV->FLAGS | 524288; if (FORM != 9) goto L_06CB; DEFV->FLAGS = DEFV->FLAGS | 8; goto L_06CC; L_06CB: if (DEFV->TYPE > 5) goto L_06CD; DEFV->TYPE = 1; L_06CD: L_06CC: goto L_06CE; L_06CA: if (FORM != 10) goto L_06CF; DEFV->FLAGS = DEFV->FLAGS | 2097152; L_06CF: L_06CE: if (EXTERNALMODE != 1) goto L_06D0; EXTERNALMODE = 3; OSTATE = 3; DEFV->FLAGS = DEFV->FLAGS | 32768; goto L_06D1; L_06D0: if (EXTERNALMODE < 6) goto L_06D2; if (EXTERNALMODE != 6) goto L_06D3; DEFV->FLAGS = DEFV->FLAGS | 512; DEFV->PRIM = Q.DIM; goto L_06D4; L_06D3: DEFV->FLAGS = DEFV->FLAGS | 256; L_06D4: EXTERNALMODE = 3; OSTATE = 3; L_06D2: L_06D1: if (*PARAMETERLIST <= 0) goto L_06D5; DANGERMARKER = 1; FRAME = FRAME + 3 & (~3); DEFV->DISP = FRAME; DEFV->BASE = *LOCAL; DEFV->FLAGS = DEFV->FLAGS | 4; FRAME = FRAME + 4 * 2; goto L_06D6; L_06D5: if (*LOCAL < DANGERLEVEL) goto L_06D7; DEFV->FLAGS = DEFV->FLAGS | 65536; L_06D7: L_06D6: goto L_06C7; L_06C9: if (FORM == 11) goto L_06D8; if (FORM != 13) goto L_06D9; L_06D8: Q.DIAGS = 0; if (FORM != 13) goto L_06DA; DECLSIZE = 4; if (Q.TYPE != 8) goto L_06DB; if (Q.SIZE != 1) goto L_06DB; DECLSIZE = 4 * 2; L_06DB: DEFV->FLAGS = 8; Q.ROUND = 3; L_06DA: Q.SIZE = 0; goto L_06DC; L_06D9: if (FORM != 2) goto L_06DD; Q.IND = 1; Q.ROUND = 3; if (Q.TYPE == 10) goto L_06DE; DECLSIZE = 4; if (Q.TYPE != 8) goto L_06DF; if (Q.SIZE != 1) goto L_06DF; DECLSIZE = 4 * 2; L_06DF: Q.SIZE = DECLSIZE; L_06DE: goto L_06DC; L_06DD: if (FORM != 1) goto L_06E0; if (*PARAMETERLIST <= 0) goto L_06E1; if (Q.TYPE == 8) goto L_06E2; if (Q.TYPE == 9) goto L_06E2; if (Q.TYPE != 13) goto L_06E1; L_06E2: Q.SIZE = 4; if (OFLAGS & 16 != 0) goto L_06E3; DEFV->FLAGS = DEFV->FLAGS | 131072; L_06E3: L_06E1: goto L_06DC; L_06E0: Q.DIAGS = 0; Q.ROUND = 3; Q.SIZE = 4 * 2; if (FORM != 14) goto L_06E4; DEFV->FLAGS = 8; L_06E4: DEFV->FLAGS = DEFV->FLAGS | 64; L_06DC: if (EXTERNALMODE != 0) goto L_06E5; DEFV->BASE = *LOCAL; if (DECL != 0) goto L_06E6; FRAME = FRAME + Q.ROUND & (~Q.ROUND); DEFV->DISP = FRAME; FRAME = FRAME + Q.SIZE; goto L_06E7; L_06E6: if (*PARAMETERLIST <= 0) goto L_06E8; if (Q.ROUND >= 3) goto L_06E9; Q.ROUND = 3; L_06E9: if (Q.SIZE >= 4) goto L_06EA; Q.SIZE = 4; L_06EA: FRAME = FRAME + 3 & (~3); DEFV->DISP = FRAME; FRAME = FRAME + Q.SIZE; goto L_06E7; L_06E8: if (Q.SIZE <= 256) goto L_06EB; Q.IND = 1; FRAME = (FRAME & (~3)) - 4; DEFV->DISP = FRAME; DEFV->FORM = 15; DEFV->FLAGS = DEFV->FLAGS & (~1048576); N = Q.SIZE + 3 & (~3); ATTRIBUTES = ATTRIBUTES | 32; if (UNASSIGNED == 0) goto L_06EC; ATTRIBUTES = ATTRIBUTES | 4; VV = LITERAL(N); LOAD(VV, 5); RELEASEANDDROP(VV); PRIM(56); goto L_06ED; L_06EC: VV = LOCALINTEGER(-N); VV->BASE = 13; VV->FORM = 0; LOAD(VV, 13); DROP(VV); L_06ED: VV = LOCALINTEGER(FRAME); PLANT2(67108864, 13, VV); RELEASEANDDROP(VV); if (WSPSAVE == 0) goto L_06EE; SAVEWSP(); L_06EE: goto L_06EF; L_06EB: FRAME = (FRAME & (~Q.ROUND)) - Q.SIZE; DEFV->DISP = FRAME; L_06EF: L_06E7: if (TF & 256 == 0) goto L_06F0; DEFV->FLAGS = DEFV->FLAGS | 128; L_06F0: if (Q.DIAGS == 0) goto L_06F1; if (AMODE > 0) goto L_06F1; DUMPDIAG(*LOCAL, &Q); L_06F1: goto L_06F2; L_06E5: OWNEXTRA = 0; if (SPEC != 0) goto L_06F3; INITFLAG = 0; OWNTYPE = Q.TYPE; OWNFORM = FORM; if (EXTERNALMODE != 2) goto L_06F4; if (FORM == 2) goto L_06F5; if (FORM == 12) goto L_06F5; if (FORM != 14) goto L_06F6; L_06F5: DEFV->FORM = 1; INITFLAG = -1; return; L_06F6: CONSTANTBASE = CONSTANTBASE + 3 & (~3); AREA = 512; AT = &CONSTANTBASE; DEFV->AREA = 512; Q.DIAGS = 0; goto L_06F7; L_06F4: AREA = 256; AT = &OWNBASE; DEFV->BASE = 10; if (FORM == 11) goto L_06F8; if (FORM != 13) goto L_06F9; L_06F8: OWNARRAYBASE = OWNARRAYBASE + 3 & (~3); AREA = 768; AT = &OWNARRAYBASE; OSTATE = 255; L_06F9: L_06F7: if (OWNFORM == 12) goto L_06FA; if (OWNFORM != 14) goto L_06FB; L_06FA: OWNEXTRA = 1; L_06FB: if (OWNTYPE != 8) goto L_06FC; if (DEFV->FORMAT != 1) goto L_06FC; if (OWNFORM == 2) goto L_06FD; if (OWNFORM != 13) goto L_06FC; L_06FD: OWNEXTRA = 1; L_06FC: if (OWNFORM == 1) goto L_06FE; if (OWNFORM == 11) goto L_06FE; OWNTYPE = 1; Q.ROUND = 3; L_06FE: *AT = *AT + Q.ROUND & (~Q.ROUND); DEFV->DISP = *AT; if (FORM == 11) goto L_06FF; if (FORM != 13) goto L_0700; L_06FF: DEFV->FLAGS = DEFV->FLAGS | 64; N = DEFV->DISP - VLB * DECLSIZE; OWNBASE = OWNBASE + 3 & (~3); DEFV->BASE = 10; DEFV->DISP = OWNBASE; DEFV->AREA = 0; SELECTOWNAREA(); DIR4(17, (unsigned int)AREA >> 8, N, 0); *CA = *CA + 8; SELECTCODEAREA(); VALUE = DEFAULTVALUE; INITFLAG = 1; DEFV->ADATA = _imp_NEW(ATYPE); U_100E: DEFV->ADATA = 0; L_0700: if (EXTERNALMODE != 3) goto L_0701; DUMPEXTERNAL(1, DEFV); DEFV->AREA = 0; DEFV->FLAGS = DEFV->FLAGS & (~8388608); L_0701: if (Q.DIAGS == 0) goto L_0702; DUMPDIAG(DEFV->BASE, &Q); L_0702: goto L_0703; L_06F3: DEFV->FLAGS = DEFV->FLAGS | 8388608; if (FORM == 11) goto L_0704; if (FORM != 13) goto L_0705; L_0704: DEFV->FLAGS = DEFV->FLAGS | 64; L_0705: DUMPEXTERNAL(0, DEFV); L_0703: L_06F2: L_06C7: ALTALIGN = ALTALIGN & (~Q.ROUND); ROUND = Q.ROUND; DTYPE = Q.DTYPE; } /* DEFINEVAR */ void DUMPTEXT(int MAX) { int J; int LEN; LEN = *_imp_LENGTH(&VALUE.STRING); if (MAX != 0) goto L_0706; MAX = LEN; goto L_0707; L_0706: if (LEN <= MAX) goto L_0708; LEN = MAX; WARN(0, _imp_str_literal("String truncated")); L_0708: L_0707: DUMPBYTE(LEN); J = 0; /*%for J = 1, 1, MAX %cycle*/ L_0709: if (J == MAX) goto L_070A; J += 1; if (J <= LEN) goto L_070C; DUMPBYTE(0); goto L_070D; L_070C: DUMPBYTE(*_imp_CHARNO(&VALUE.STRING, J)); L_070D: goto L_0709; L_070A: } /* DUMPTEXT */ void ADUMP(void) { struct STACKFM RV; int J; int DISP; int KEY; if (OWNTYPE == 1) goto L_070B; if (OWNTYPE != 5) goto L_070E; L_070B: if (STACK != NIL) goto L_070F; DUMPWORD(VALUE.INTEGER); goto L_0710; L_070F: if (&STACK->RECORD == NIL) goto L_0711; FAIL(_imp_str_literal("Adump/0")); L_0711: SIMPLIFY(STACK); DISP = STACK->DISP; if (&STACK->RECORD != NIL) goto L_0712; if (&STACK->INDEX == NIL) goto L_0713; L_0712: FAIL(_imp_str_literal("Adump/1")); L_0713: if (STACK->FORM != 0) goto L_0714; if (STACK->BASE != 10) goto L_0715; KEY = 0; goto L_0716; L_0715: if (STACK->BASE != 0) goto L_0717; if (STACK->AREA != 512) goto L_0718; KEY = -1; goto L_0719; L_0718: KEY = -STACK->AREA; if (KEY > 0) goto L_071A; FAIL(_imp_str_literal("Adump/4")); L_071A: L_0719: goto L_0716; L_0717: FAIL(_imp_str_literal("Adump/2")); L_0716: DIR3(30, KEY, DISP); goto L_071B; L_0714: FAIL(_imp_str_literal("Adump/3")); L_071B: *CA = *CA + 4; POPRELEASEANDDROP(); L_0710: goto L_071C; L_070E: if (OWNTYPE == 4) goto L_071D; if (OWNTYPE != 12) goto L_071E; L_071D: if (0 > VALUE.INTEGER) goto L_071F; if (VALUE.INTEGER <= 255) goto L_0720; L_071F: WARN(0, _imp_str_literal("value truncated to 8 bits unsigned")); L_0720: DUMPBYTE(VALUE.INTEGER); goto L_071C; L_071E: if (OWNTYPE != 2) goto L_0721; if (-32768 > VALUE.INTEGER) goto L_0722; if (VALUE.INTEGER <= 32767) goto L_0723; L_0722: WARN(0, _imp_str_literal("value truncated to 16 bits signed")); L_0723: DUMPHALF(VALUE.INTEGER); goto L_071C; L_0721: if (OWNTYPE == 6) goto L_0724; if (OWNTYPE != 7) goto L_0725; L_0724: RV.RVAL = VALUE.REAL; CONVERTFORMAT(&RV, OWNTYPE); DUMPWORD(RV.RHIGH); if (OWNTYPE != 7) goto L_0726; DUMPWORD(RV.RLOW); L_0726: goto L_071C; L_0725: if (OWNTYPE != 8) goto L_0727; DUMPTEXT(DECLSIZE - 1); goto L_071C; L_0727: if (OWNTYPE == 9) goto L_0728; if (OWNTYPE != 13) goto L_0729; L_0728: J = 0; /*%for J = 1, 1, DECLSIZE %cycle*/ L_072A: if (J == DECLSIZE) goto L_072B; J += 1; DUMPBYTE(0); goto L_072A; L_072B: goto L_071C; L_0729: FAIL(_imp_str_literal("Init")); L_071C: L_072D: if (OWNEXTRA <= 0) goto L_072E; DUMPWORD(0); OWNEXTRA = OWNEXTRA - 1; goto L_072D; L_072E: } /* ADUMP */ void INIT(int N) { if (STACK == NIL) goto L_072F; if (!(ICONST(STACK))) goto L_072F; VALUE.INTEGER = STACK->DISP; CONSTANTTYPE = 1; POPRELEASEANDDROP(); L_072F: if (6 > OWNTYPE) goto L_0730; if (OWNTYPE > 7) goto L_0730; if (CONSTANTTYPE != 1) goto L_0731; VALUE.REAL = VALUE.INTEGER; L_0731: L_0730: if (INITFLAG >= 0) goto L_0732; DEFV->DISP = VALUE.INTEGER; goto L_0733; L_0732: if (OSTATE != 2) goto L_0734; SELECTCONSTANTAREA(); goto L_0735; L_0734: if (OSTATE != 255) goto L_0736; SELECTOWNARRAYAREA(); goto L_0735; L_0736: SELECTOWNAREA(); L_0735: L_0737: if (N <= 0) goto L_0738; N = N - 1; ADUMP(); goto L_0737; L_0738: SELECTCODEAREA(); L_0733: VALUE = DEFAULTVALUE; DEFV->FLAGS = DEFV->FLAGS | 128; } /* INIT */ void DIMENSION(int DIM, int N) { int X; int STATICARRAY; STATICARRAY = 0; int J; struct VARFM *V; struct AFM DOPE; struct STACKFM *B; struct STACKFM *TOTAL; struct STACKFM *DOPEVECTOR; struct STACKFM *ZERO; struct STACKFM *HEADER; struct STACKFM *L1; struct STACKFM *L2; struct STACKFM *U1; struct STACKFM *U2; struct STACKFM *M1; struct STACKFM *M2; struct QFM Q; int ALLCONST(void) { struct STACKFM *P; struct BOUNDFM *B; int J; int N; P = STACK; N = DECLSIZE; J = DIM + 1; /*%for J = DIM, -1, 1 %cycle*/ L_0739: if (J == 1) goto L_073A; J -= 1; B = &DOPE.BOUND[J]; if (ICONST(P)) goto L_073C; return 0 /*FALSE*/; L_073C: B->UPPER = P->DISP; P = &P->STACK; if (ICONST(P)) goto L_073D; return 0 /*FALSE*/; L_073D: B->LOWER = P->DISP; P = &P->STACK; B->MULT = N; N = B->UPPER - B->LOWER + 1; if (N >= 0) goto L_073E; FAIL(_imp_str_literal("Array inside-out")); L_073E: goto L_0739; L_073A: DOPE.TOTALSIZE = N; DOPE.BASE = *LOCAL; DOPE.DIMENSION = DIM; DOPE.ZERODISPLACEMENT = 0; N = 0; J = 0; /*%for J = 1, 1, DIM %cycle*/ L_073F: if (J == DIM) goto L_0740; J += 1; B = &DOPE.BOUND[J]; DOPE.ZERODISPLACEMENT = DOPE.ZERODISPLACEMENT * N - B->LOWER; N = B->MULT; DOPE.TOTALSIZE = DOPE.TOTALSIZE * N; goto L_073F; L_0740: DOPE.ZERODISPLACEMENT = DOPE.ZERODISPLACEMENT * N; J = 0; /*%for J = 1, 1, DIM * 2 %cycle*/ L_0741: if (J == DIM * 2) goto L_0742; J += 1; POPRELEASEANDDROP(); goto L_0741; L_0742: STATICARRAY = 1; CONSTANTBASE = CONSTANTBASE + 3 & -4; DOPE.DV = CONSTANTBASE; if (*PARAMETERLIST != 0) goto L_0743; DOPE.TOTALSIZE = DOPE.TOTALSIZE + 3 & (~3); L_0743: SELECTCONSTANTAREA(); DUMPWORD(DIM); DUMPWORD(DOPE.TOTALSIZE); DUMPWORD(DOPE.ZERODISPLACEMENT); J = 0; /*%for J = 1, 1, DIM %cycle*/ L_0744: if (J == DIM) goto L_0745; J += 1; B = &DOPE.BOUND[J]; DUMPWORD(B->LOWER); DUMPWORD(B->UPPER); DUMPWORD(B->MULT); goto L_0744; L_0745: SELECTCODEAREA(); return 1 /*TRUE*/; } /* ALLCONST */ ATTRIBUTES = ATTRIBUTES | 32; if (!(ALLCONST())) goto L_0746; if (N != 0) goto L_0747; return; L_0747: if (*PARAMETERLIST == 0) goto L_0748; X = PARMS + N; FRAME = FRAME + ROUND & (~ROUND); L_0749: if (N <= 0) goto L_074A; N = N - 1; X = X - 1; V = VAR(X); V->DISP = FRAME + DOPE.ZERODISPLACEMENT; FRAME = FRAME + DOPE.TOTALSIZE; V->FORM = 1; V->FLAGS = V->FLAGS | 2; V->ADATA = _imp_NEW(ATYPE); U_100F: V->ADATA = DOPE; if (DEBUG == 0) goto L_074B; Q.DFORM = 0; if (V->FORMAT >= 0) goto L_074C; Q.DFORM = VAR(-V->FORMAT)->AREA; L_074C: Q.POINTED = NIL; Q.IND = 0; Q.DTYPE = DTYPE; DEFV = V; DUMPDIAG(17, &Q); L_074B: goto L_0749; L_074A: return; L_0748: ZERO = NIL; if (DOPE.ZERODISPLACEMENT == 0) goto L_074D; ZERO = LITERAL(DOPE.ZERODISPLACEMENT); L_074D: TOTAL = LITERAL(DOPE.TOTALSIZE); DOPEVECTOR = LITERAL(DOPE.DV); DOPEVECTOR->FORM = 0; DOPEVECTOR->AREA = 512; LOAD(DOPEVECTOR, 4); if (ZERO == NIL) goto L_074E; LOAD(ZERO, 3); L_074E: LOAD(TOTAL, 2); goto L_074F; L_0746: if (DIM != 1) goto L_0750; U1 = STACK; STACK = &U1->STACK; L1 = STACK; STACK = &L1->STACK; M1 = LITERAL(DECLSIZE); LOADTRIO(U1, 5, L1, 4, M1, 6); RELEASEANDDROPPAIR(L1, U1); RELEASEANDDROP(M1); PRIM(43); goto L_0751; L_0750: if (DIM != 2) goto L_0752; U2 = STACK; STACK = &U2->STACK; L2 = STACK; STACK = &L2->STACK; M2 = LITERAL(DECLSIZE); U1 = STACK; STACK = &U1->STACK; L1 = STACK; STACK = &L1->STACK; LOADPAIR(U1, 5, L1, 4); LOADTRIO(U2, 8, L2, 7, M2, 9); LOADPAIR(U1, 5, L1, 4); LOADTRIO(U2, 8, L2, 7, M2, 9); RELEASEANDDROPPAIR(L1, U1); RELEASEANDDROPPAIR(L2, U2); RELEASEANDDROP(M2); PRIM(44); goto L_0751; L_0752: X = DECLSIZE; J = 0; /*%for J = 1, 1, DIM %cycle*/ L_0753: if (J == DIM) goto L_0754; J += 1; PUSHLITERAL(X); X = 0; B = STACK; STACK = &B->STACK; PUSH(B); RELEASEANDDROP(B); B = STACK; STACK = &B->STACK; PUSH(B); RELEASEANDDROP(B); goto L_0753; L_0754: PUSHLITERAL(0); PUSHLITERAL(0); PUSHLITERAL(DIM); PRIM(17); L_0751: TOTAL = REGISTER(2); ZERO = REGISTER(3); DOPEVECTOR = REGISTER(4); L_074F: FRAME = FRAME & (~3); HEADER = LOCALINTEGER(FRAME - 4); LOADADDRESS(HEADER, 5); X = *VARS - N; L_0756: if (N <= 0) goto L_0757; N = N - 1; X = X + 1; V = VAR(X); FRAME = FRAME - 2 * 4; V->DISP = FRAME; V->FLAGS = V->FLAGS | 128 | 64; V->FORM = 1; PLANT1(4194304, 13, 13, JUST(2)); if (ZERO != NIL) goto L_0758; PLANT1(27262976, 0, 1, JUST(13)); goto L_0759; L_0758: PLANT1(8388608, 13, 1, JUST(3)); L_0759: PLANT4(134217728 | 2097152, 5, 9); goto L_0756; L_0757: RELEASEANDDROP(TOTAL); if (ZERO == NIL) goto L_075A; RELEASEANDDROP(ZERO); L_075A: RELEASEANDDROP(DOPEVECTOR); RELEASEANDDROP(HEADER); } /* DIMENSION */ void SWOP(void) { struct STACKFM *T; T = STACK; STACK = &T->STACK; T->STACK = &STACK->STACK; STACK->STACK = T; } /* SWOP */ void DEFINERANGE(void) { int T; struct VARFM *V; T = TAG(); V = VAR(T); CLEARVARS(T); CONSTANTBOUNDS(); V->DISP = VLB; V->EXTRA = VUB; V->FORMAT = -1; } /* DEFINERANGE */ void TESTRANGE(struct STACKFM * S, struct VARFM * V) { struct STACKFM *R; struct STACKFM *L; struct STACKFM *U; struct STACKFM *LOW; struct STACKFM *HIGH; if (INTERFACE->OPTIONS & 128 != 0) goto L_075B; return; L_075B: if (S != 13) goto L_075C; LOW = LITERAL(V->DISP); HIGH = LITERAL(V->EXTRA); if (S == 0) goto L_075D; LOADUP(&S); L_075D: if (&S == NIL) goto L_075E; BUILDSET(&S); L_075E: R = COPY(&S); AMAP(R); LOADTRIO(LOW, 2, HIGH, 3, R, 1); PRIM(46); RELEASEANDDROPPAIR(LOW, HIGH); RELEASEANDDROP(R); return; L_075C: if (!(ICONST(&S))) goto L_075F; if (V->DISP > S) goto L_0760; if (S > V->EXTRA) goto L_0760; return; L_0760: WARN(1, _imp_str_literal("Range violation")); L_075F: LOADUP(&S); R = COPY(&S); U = LITERAL(V->EXTRA); if (V->DISP == 0) goto L_0761; L = LITERAL(V->DISP); LOADTRIO(R, 2, L, 3, U, 4); PRIM(16); RELEASEANDDROP(L); goto L_0762; L_0761: LOADPAIR(R, 2, U, 4); PRIM(33); L_0762: RELEASEANDDROPPAIR(R, U); } /* TESTRANGE */ void DUPLICATE(void) { struct STACKFM *V; V = COPY(STACK); V->STACK = STACK; STACK = V; } /* DUPLICATE */ void STACKWORKVARIABLE(void) { int T; struct VARFM *V; T = TAG(); V = VAR(T); CLEARVARS(T); if (V->BASE != 0) goto L_0763; FRAME = (FRAME & -4) - 4; V->TYPE = 1; V->FORM = 1; V->BASE = *LOCAL; V->DISP = FRAME; V->FLAGS = 128; L_0763: STACKVAR(T); } /* STACKWORKVARIABLE */ void CLAIMWITH(int N) { int FORMAT; struct WITHFM *W; W = _imp_NEW(WITHFMTYPE); W->LINK = WITHS; WITHS = W; W->KEY = *N; if (&STACK->INDEX != NIL) goto L_073B; if (&STACK->RECORD != NIL) goto L_073B; if (STACK->FORM != 1) goto L_073B; if (LOCKED(STACK->BASE)) goto L_0764; L_073B: FORMAT = STACK->FORMAT; AMAP(STACK); STAB(STACK); STACK->FORMAT = FORMAT; STACK->FLAGS = STACK->FLAGS | 4194304; L_0764: W->DATA = STACK->DATA; POPRELEASEANDDROP(); } /* CLAIMWITH */ void RELEASEWITH(int N) { struct WITHFM BASE; struct WITHFM *W; W = &BASE; struct WITHFM *X; BASE.LINK = WITHS; L_0765: if (&W->LINK == NIL) goto L_0766; if (W->LINK != N) goto L_0767; X = &W->LINK; W->LINK = &X->LINK; WITHS = &BASE.LINK; _imp_DISPOSE(X); return; L_0767: W = &W->LINK; goto L_0765; L_0766: FAIL(_imp_str_literal("No use")); } /* RELEASEWITH */ void USEWITH(int N) { int FORMAT; struct WITHFM *W; W = WITHS; L_0768: if (W == NIL) goto L_0769; if (W->KEY != N) goto L_076A; STACKINTEGER(0); STACK->DATA = W->DATA; if (STACK->FLAGS & 4194304 == 0) goto L_076B; FORMAT = STACK->FORMAT; VMAP(STACK, 1); STACK->FORMAT = FORMAT; L_076B: return; L_076A: W = &W->LINK; goto L_0768; L_0769: FAIL(_imp_str_literal("No use")); } /* USEWITH */ void BUILDSET(struct STACKFM * S) { struct STACKFM *W; struct STACKFM *Z; struct STACKFM *OLDLINK; struct MEMBERFM *M; struct MEMBERFM *X; struct CSETFM { union { struct { unsigned char SET[32]; }; }; }; struct CSETFM C; int DUMPED; DUMPED = 0; int MARKED; MARKED = 0; int INWORK; INWORK = 0; int LOW; int HIGH; int OP; int OLDOPER; void DUMPSET(void) { int J; DUMPED = 1; CONSTANTBASE = CONSTANTBASE + 3 & (~3); S = 13; S = CONSTANTBASE; S = 1; S = 512; SELECTCONSTANTAREA(); J = -1; /*%for J = 0, 1, 31 %cycle*/ L_076C: if (J == 31) goto L_076D; J += 1; DUMPBYTE(C.SET[J]); goto L_076C; L_076D: SELECTCODEAREA(); } /* DUMPSET */ void MARK(int N) { int W; if (0 > N) goto L_076E; if (N <= 255) goto L_076F; L_076E: WARN(1, _imp_join((_imp_string)(_imp_str_literal("Set element out of range ")), (_imp_string)(_imp_ITOS(N, 0)))); return; L_076F: W = (unsigned int)N >> 3; C.SET[W] = C.SET[W] | 1 << (N & 7); MARKED = 1; } /* MARK */ if (DIAG & 8 == 0) goto L_0770; MONITOR(&S, _imp_str_literal("Bset->")); L_0770: OLDLINK = &S; S = NIL; OLDOPER = S; S = 0; C = 0; M = &S; S = NIL; S.LINK = S.LINK & (~16384); L_0771: if (M == NIL) goto L_0772; X = M; M = &M->LINK; if (X->CONST == 0) goto L_0773; HIGH = X->A; DROP(&X->A); if (&X->B != NIL) goto L_0774; MARK(HIGH); goto L_0775; L_0774: LOW = X->B; DROP(&X->B); L_0776: if (LOW > HIGH) goto L_0777; MARK(LOW); LOW = LOW + 1; goto L_0776; L_0777: L_0775: goto L_0778; L_0773: if (INWORK != 0) goto L_0779; W = CLAIMWORKAREA(32, 13); if (MARKED == 0) goto L_077A; if (DUMPED != 0) goto L_077B; DUMPSET(); L_077B: SETASSIGN(&S, W); RELEASE(S); MARKED = 0; goto L_077C; L_077A: Z = LITERAL(0); Z->FLAGS = 16384; SETASSIGN(Z, W); RELEASEANDDROP(Z); L_077C: S.DATA = W->DATA; DROP(W); DUMPED = 1; INWORK = 1; L_0779: AMAP(&S); LOADPAIR(&S, 9, &X->A, 2); if (&X->B != NIL) goto L_077D; OP = 20; goto L_077E; L_077D: LOADTRIO(&X->B, 1, &S, 9, &X->A, 2); RELEASEANDDROP(&X->B); OP = 28; L_077E: PRIM(OP); VMAP(&S, 13); S.LINK = S.LINK | 262144; RELEASEANDDROP(&X->A); L_0778: _imp_DISPOSE(X); goto L_0771; L_0772: if (DUMPED != 0) goto L_077F; DUMPSET(); L_077F: S = OLDLINK; S = OLDOPER; if (DIAG & 8 == 0) goto L_0780; MONITOR(&S, _imp_str_literal("Bset<-")); L_0780: } /* BUILDSET */ void COMPILEIN(int STACKIT) { int N; struct STACKFM *V; struct STACKFM *SET; struct STACKFM *C; SET = STACK; V = &SET->STACK; STACK = &V->STACK; if (&SET->MEMBERS == NIL) goto L_0781; BUILDSET(SET); L_0781: if (SET->OPER == 0) goto L_0782; LOADUP(SET); L_0782: if (SET->FLAGS & 16384 == 0) goto L_0783; if (*STACKIT == 0) goto L_0784; C = LITERAL(0); C->STACK = STACK; STACK = C; goto L_0785; L_0784: DUMPWORD(-514850816); L_0785: RELEASEANDDROP(SET); RELEASEANDDROP(V); return; L_0783: if (!(ICONST(V))) goto L_0786; if (0 > V->DISP) goto L_0786; if (V->DISP > 255) goto L_0786; ADVANCE(SET, 1, (unsigned int)V->DISP >> 5 << 2); OPERATE(9, SET, LITERAL(1 << (V->DISP & 31))); TESTZERO(SET); goto L_0787; L_0786: AMAP(SET); LOADPAIR(V, 2, SET, 3); PRIM(11); L_0787: RELEASEANDDROPPAIR(SET, V); if (*STACKIT == 0) goto L_0788; STACKTRUEORFALSE(6); L_0788: } /* COMPILEIN */ void ADDMEMBER(int N) { struct MEMBERFM BASE; struct MEMBERFM *M; struct MEMBERFM *P; struct STACKFM *A; struct STACKFM *B; B = NIL; int ITEMS; ITEMS = 0; A = STACK; STACK = &A->STACK; if (N == 0) goto L_0789; B = STACK; STACK = &B->STACK; if (!(ICONST(A))) goto L_078A; if (!(ICONST(B))) goto L_078A; if (A->DISP >= B->DISP) goto L_078A; DROP(A); DROP(B); return; L_078A: L_0789: M = _imp_NEW(MEMBERFMTYPE); M->A = A; M->B = B; if (&STACK->MEMBERS == NIL) goto L_078B; ITEMS = STACK->MEMBERS; L_078B: if (!(ICONST(A))) goto L_078C; if (B == NIL) goto L_078D; if (!(ICONST(B))) goto L_078C; L_078D: M->CONST = 1; M->LINK = &STACK->MEMBERS; STACK->MEMBERS = M; goto L_078E; L_078C: M->CONST = 0; BASE.LINK = &STACK->MEMBERS; P = &BASE; L_078F: if (&P->LINK == NIL) goto L_0790; if (P->LINK == 0) goto L_0790; P = &P->LINK; goto L_078F; L_0790: M->LINK = &P->LINK; P->LINK = M; STACK->MEMBERS = &BASE.LINK; L_078E: STACK->MEMBERS = ITEMS + 1; STACK->FLAGS = STACK->FLAGS & (~16384); } /* ADDMEMBER */ void STACKDATASIZE(void) { int T; int N; T = PENDING; _imp_READSYMBOL(&PENDING); if (T != 0) goto L_0791; T = TAG(); N = VAR(T)->FORMAT; if (N >= 0) goto L_0792; N = VAR(-N)->FORMAT; L_0792: goto L_0793; L_0791: if (0 > T) goto L_0794; if (T > 13) goto L_0794; N = TYPESIZE[T]; goto L_0795; L_0794: N = 0; L_0795: if (N != 0) goto L_0796; FAIL(_imp_str_literal("Unknown type")); L_0796: L_0793: STACKINTEGER(N); } /* STACKDATASIZE */ void TESTFORNIL(void) { if (UNASSIGNED == 0) goto L_0797; STACK->FLAGS = STACK->FLAGS | 128; LOAD(STACK, 2); PRIM(13); L_0797: } /* TESTFORNIL */ void SETVARIANTCOUNT(int N) { struct STACKFM *V; V = COPY(STACK); struct STACKFM *COUNT; VMAP(V, 2); COUNT = LITERAL(*N); SIMPLE(COUNT, V); RELEASEANDDROPPAIR(COUNT, V); } /* SETVARIANTCOUNT */ void TESTVARIANTCOUNT(int N) { struct STACKFM *V; V = COPY(STACK); struct STACKFM *COUNT; COUNT = LITERAL(*N); VMAP(V, 2); LOADPAIR(V, 4, COUNT, 1); PRIM(36); RELEASEANDDROPPAIR(V, COUNT); } /* TESTVARIANTCOUNT */ void CHECKNOTLONGNEW(void) { struct STACKFM *V; V = COPY(STACK); AMAP(V); VMAP(V, 2); TESTZERO(V); INVERT = 0; PRIM(26); RELEASEANDDROP(V); } /* CHECKNOTLONGNEW */ void CHECKDYNAMICBOUNDS(void) { struct STACKFM *LOWER; struct STACKFM *UPPER; UPPER = STACK; LOWER = &UPPER->STACK; STACK = &LOWER->STACK; LOADTRIO(STACK, 2, LOWER, 3, UPPER, 4); PRIM(16); RELEASEANDDROPPAIR(LOWER, UPPER); } /* CHECKDYNAMICBOUNDS */ void LOCALISE(void) { struct STACKFM *LOC; struct STACKFM *SIZE; struct STACKFM *ZERO; ZERO = STACK; SIZE = &ZERO->STACK; LOC = &SIZE->STACK; STACK = &LOC->STACK; FORGETDESTINATION(LOC); AMAP(LOC); LOADTRIO(SIZE, 1, ZERO, 2, LOC, 3); PRIM(14); ATTRIBUTES = ATTRIBUTES | 32; RELEASEANDDROPPAIR(SIZE, ZERO); RELEASEANDDROP(LOC); } /* LOCALISE */ void ENDOFBLOCK(void) { if (*LOCAL == 128) goto L_0798; if (UNCONDJUMP == *CA) goto L_0799; if (AVAR != 10) goto L_0799; if (AVAR->P & 256 != 0) goto L_0799; RETURN(0); L_0799: L_0798: } /* ENDOFBLOCK */ void PROCESSINCLUDEFILE(void) { GETSTRING(&INCLUDEFILE); DIRSTRING(4, &INCLUDEFILE); } /* PROCESSINCLUDEFILE */ static const void *C[256] = { &&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_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_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_default, &&case_C_default, &&case_C_default, &&case_C_33, &&case_C_34, &&case_C_35, &&case_C_36, &&case_C_37, &&case_C_38, &&case_C_39, &&case_C_40, &&case_C_41, &&case_C_42, &&case_C_43, &&case_C_default, &&case_C_45, &&case_C_46, &&case_C_47, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_58, &&case_C_59, &&case_C_60, &&case_C_61, &&case_C_62, &&case_C_63, &&case_C_64, &&case_C_65, &&case_C_66, &&case_C_67, &&case_C_68, &&case_C_69, &&case_C_70, &&case_C_71, &&case_C_72, &&case_C_73, &&case_C_74, &&case_C_75, &&case_C_76, &&case_C_77, &&case_C_78, &&case_C_79, &&case_C_80, &&case_C_81, &&case_C_82, &&case_C_83, &&case_C_84, &&case_C_85, &&case_C_86, &&case_C_87, &&case_C_88, &&case_C_default, &&case_C_90, &&case_C_91, &&case_C_92, &&case_C_93, &&case_C_94, &&case_C_95, &&case_C_default, &&case_C_97, &&case_C_98, &&case_C_99, &&case_C_100, &&case_C_101, &&case_C_102, &&case_C_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, &&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_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_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_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_162, &&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_172, &&case_C_default, &&case_C_default, &&case_C_175, &&case_C_176, &&case_C_177, &&case_C_178, &&case_C_179, &&case_C_180, &&case_C_181, &&case_C_182, &&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_191, &&case_C_192, &&case_C_193, &&case_C_194, &&case_C_195, &&case_C_196, &&case_C_197, &&case_C_198, &&case_C_default, &&case_C_default, &&case_C_201, &&case_C_default, &&case_C_default, &&case_C_204, &&case_C_205, &&case_C_206, &&case_C_207, &&case_C_208, &&case_C_default, &&case_C_210, &&case_C_211, &&case_C_212, &&case_C_213, &&case_C_214, &&case_C_215, &&case_C_216, &&case_C_default, &&case_C_218, &&case_C_219, &&case_C_default, &&case_C_221, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_226, &&case_C_227, &&case_C_default, &&case_C_229, &&case_C_230, &&case_C_231, &&case_C_default, &&case_C_233, &&case_C_default, &&case_C_default, &&case_C_default, &&case_C_237, &&case_C_238, &&case_C_239, &&case_C_240, &&case_C_default, &&case_C_242, &&case_C_243, &&case_C_244, &&case_C_default, &&case_C_246, &&case_C_247, &&case_C_default, &&case_C_default, &&case_C_250, &&case_C_251, &&case_C_252, &&case_C_253, &&case_C_default, &&case_C_default}; AT = 0; PENDINGAUTO = 0; OLDFRAME = FRAME; if (AMODE < -1) goto L_079A; FRAME = 0; if (AMODE < 0) goto L_079B; FRAME = 4; if (AVAR->P & 1024 == 0) goto L_079C; AVAR->P = AVAR->P - 1024; AVAR = 0; L_079C: if (AVAR != 0) goto L_079D; if (7 == OSTATE) goto L_079E; if (OSTATE != 3) goto L_0755; L_079E: if (AMODE != 0) goto L_079D; L_0755: AVAR = NEWLABEL(); L_079D: if (AMODE != 0) goto L_079F; if (*LOCAL <= 128 + 17) goto L_07A0; FAIL(_imp_str_literal("Subroutines nested too deeply")); L_07A0: UNCONDJUMP = -1; FORGETEVERYTHING(); DIR2(1, AVAR); BLOCKS = BLOCKS + 1; DIRSTRING(-1, &INTERNALID); FMARK = FMARK + 1; FRAMEUSE[*LOCAL] = FMARK; if (DEBUG == 0) goto L_07A1; DIR3(35, 0, CURRENTLINE); L_07A1: L_079F: if (OSTATE != 3) goto L_07A2; if (AMODE == 0) goto L_07A3; AVAR->P = AVAR->P | 1024; DUMPEXTERNAL(2, AVAR); goto L_07A4; L_07A3: AVAR->P = AVAR->P | 16777216; N = 3; if (AVAR->P & 32768 == 0) goto L_07A5; N = 3 | 1 << 4; L_07A5: DUMPEXTERNAL(N, AVAR); ATTRIBUTES = ATTRIBUTES | 16; if (AVAR->P & 256 == 0) goto L_07A6; ATTRIBUTES = ATTRIBUTES | 8; L_07A6: L_07A4: L_07A2: goto L_07A7; L_079B: DIR2(5, AVAR); L_07A7: L_079A: FRAMEEXTRA = FRAME; FRAME = FRAME + 3 & -4; FRAMEEXTRA = FRAME - FRAMEEXTRA; FRAMEBASE = FRAME; MYMARK = FMARK; MAXFRAME = 0; ALTALIGN = (~0); PENDINGKNOWNREGISTER = 0; PENDINGAUTO = 0; if (CODE != 72) goto L_07A8; goto *C[125]; /*TO DO*/ L_07A8: L_07A9: CODE = PENDING; _imp_READSYMBOL(&PENDING); goto *C[CODE]; /*TO DO*/ case_C_33:; OPERATION(10); goto L_07AA; case_C_34:; COMPAREDOUBLE(); goto L_07AA; case_C_35:; JUMPFORWARD(TAG(), 6); goto L_07AA; case_C_36:; DEFINEVAR(); goto L_07AA; case_C_37:; OPERATION(11); goto L_07AA; case_C_38:; OPERATION(9); goto L_07AA; case_C_39:; INPUTSTRINGVALUE(); goto L_07AA; case_C_40:; JUMPFORWARD(TAG(), 3); goto L_07AA; case_C_41:; JUMPFORWARD(TAG(), 5); goto L_07AA; case_C_42:; OPERATION(6); goto L_07AA; case_C_43:; OPERATION(4); goto L_07AA; case_C_45:; OPERATION(5); goto L_07AA; case_C_46:; OPERATION(22); goto L_07AA; case_C_47:; OPERATION(7); goto L_07AA; case_C_58:; DEFINECOMPILERLABEL(TAG()); goto L_07AA; case_C_59:; ENDOFBLOCK(); goto L_07AB; case_C_60:; JUMPFORWARD(TAG(), 2); goto L_07AA; case_C_61:; JUMPFORWARD(TAG(), 1); goto L_07AA; case_C_62:; JUMPFORWARD(TAG(), 4); goto L_07AA; case_C_63:; COMPAREVALUES(); goto L_07AA; case_C_64:; STACKVAR(TAG()); goto L_07AA; case_C_65:; INIT(TAG()); goto L_07AA; case_C_66:; JUMPBACKWARD(TAG()); goto L_07AA; case_C_67:; COMPAREADDRESSES(); goto L_07AA; case_C_68:; INPUTREALVALUE(); goto L_07AA; case_C_69:; CALL(0); goto L_07AA; case_C_70:; JUMPFORWARD(TAG(), 7); goto L_07AA; case_C_71:; GETSTRING(&ALIAS); goto L_07AA; case_C_72:; COMPILEBEGIN(); goto L_07AA; case_C_73:; _imp_SELECTINPUT(2); _imp_READSYMBOL(&PENDING); goto L_07AA; case_C_74:; USERJUMP(TAG()); goto L_07AA; case_C_75:; RETURN(2); goto L_07AA; case_C_76:; DEFINEUSERLABEL(TAG()); goto L_07AA; case_C_77:; RETURN(-2); goto L_07AA; case_C_78:; INPUTINTEGERVALUE(0); goto L_07AA; case_C_79:; UPDATELINE(TAG()); goto L_07AA; case_C_80:; DUMPBYTE(POPPEDVALUE() & 255); goto L_07AA; case_C_81:; OPERATION(28); goto L_07AA; case_C_82:; RETURN(0); goto L_07AA; case_C_83:; ASSIGN(0); goto L_07AA; case_C_84:; RETURN(1); goto L_07AA; case_C_85:; OPERATE(2, STACK, NIL); goto L_07AA; case_C_86:; RETURN(-1); goto L_07AA; case_C_87:; SWITCHJUMP(TAG()); goto L_07AA; case_C_88:; OPERATION(8); goto L_07AA; case_C_90:; ASSIGN(1); goto L_07AA; case_C_91:; OPERATION(14); goto L_07AA; case_C_92:; OPERATE(1, STACK, NIL); goto L_07AA; case_C_93:; OPERATION(15); goto L_07AA; case_C_94:; STACK->FORMAT = -TAG(); goto L_07AA; case_C_95:; SWITCHLABEL(TAG()); goto L_07AA; case_C_97:; ARRAYACCESS(); goto L_07AA; case_C_98:; CONSTANTBOUNDS(); goto L_07AA; case_C_99:; SECTION = 1; GETSTRING(&SECTIONID); goto L_07AB; case_C_100:; D = TAG(); N = TAG(); DIMENSION(D, N); goto L_07AA; case_C_101:; SIGNALEVENT(TAG()); goto L_07AA; case_C_102:; COMPILEFOR(TAG()); goto L_07AA; case_C_103:; TESTFORNIL(); goto L_07AA; case_C_104:; SPECIALCALL(TAG()); goto L_07AA; case_C_105:; ARRAYINDEX(); goto L_07AA; case_C_106:; ASSIGN(-1); goto L_07AA; case_C_107:; JUMPFORWARD(TAG(), 9); goto L_07AA; case_C_108:; LANGUAGEFLAGS = TAG(); goto L_07AA; case_C_109:; DO(MONITORID, &MONITOREP, 0); goto L_07AA; case_C_110:; SELECT(TAG()); goto L_07AA; case_C_111:; EVENTTRAP(TAG()); goto L_07AA; case_C_112:; ASSIGNPARAMETER(); goto L_07AA; case_C_113:; PROCESSINCLUDEFILE(); goto L_07AA; case_C_114:; RESOLVE(TAG()); goto L_07AA; case_C_115:; TOSTORE(TAG()); goto L_07AA; case_C_116:; JUMPFORWARD(TAG(), 8); goto L_07AA; case_C_117:; AOP(); goto L_07AA; case_C_118:; OPERATE(3, STACK, NIL); goto L_07AA; case_C_119:; MACHINECODE(); FORGETEVERYTHING(); goto L_07AA; case_C_120:; OPERATION(29); goto L_07AA; case_C_121:; SETCD(TAG(), &DIAG); goto L_07AA; case_C_122:; SETCD(TAG(), &CONTROL); goto L_07AA; case_C_123:; ASSEMBLE(DEFV, BLOCKTYPE, *VARS, *LOCAL + 1, PARAMETERMODE, &ATTRIBUTES); goto L_07AA; case_C_125:; if (!(FINISHPARAMS())) goto L_07AC; goto L_07AB; L_07AC: if (INTERFACE->OPTIONS & 1048576 == 0) goto L_07AD; DO(_imp_str_literal("3L___stack_check"), &STACKCHECK, 0); L_07AD: goto L_07AA; case_C_126:; N = PENDING; _imp_READSYMBOL(&PENDING); if (!(ALTERNATEFORMAT(N))) goto L_07AE; goto L_07AB; L_07AE: goto L_07AA; case_C_162:; UNSIGNED = 10; STACKCONDITION(); goto L_07AA; case_C_191:; UNSIGNED = 10; COMPAREVALUES(); goto L_07AA; case_C_172:; if (FRAME <= MAXFRAME) goto L_07AF; MAXFRAME = FRAME; L_07AF: FRAME = FRAMEBASE; goto L_07AA; case_C_176:; N = TAG(); goto L_07AA; case_C_177:; ADDMEMBER(0); goto L_07AA; case_C_178:; ADDMEMBER(1); goto L_07AA; case_C_179:; SETVARIANTCOUNT(TAG()); goto L_07AA; case_C_180:; TESTVARIANTCOUNT(TAG()); goto L_07AA; case_C_181:; CHECKNOTLONGNEW(); goto L_07AA; case_C_182:; CHECKDYNAMICBOUNDS(); goto L_07AA; case_C_175:; OPERATION(19); goto L_07AA; case_C_252:; OPERATION(20); goto L_07AA; case_C_192:; if (DIAG & 1 == 0) goto L_07B0; DECODE(0, -1); L_07B0: CURRENTLINE = TAG(); goto L_07AA; case_C_193:; AMAP(STACK); goto L_07AA; case_C_194:; if (PENDING != 116) goto L_07B1; PENDING = 35; goto L_07B2; L_07B1: PENDING = 61; L_07B2: TESTZERO(STACK); POPRELEASEANDDROP(); goto L_07AA; case_C_195:; UNSIGNED = 0; STACKCONDITION(); goto L_07AA; case_C_196:; DUPLICATE(); goto L_07AA; case_C_197:; if (STACK->FORM != 0) goto L_072C; if (!(LOCKED(STACK->BASE))) goto L_072C; if (&STACK->RECORD != NIL) goto L_072C; if (&STACK->INDEX == NIL) goto L_07B3; L_072C: LOADUP(STACK); L_07B3: goto L_07AA; case_C_198:; STACK->FORMAT = -TAG(); goto L_07AA; case_C_201:; COMPILEIN(1); goto L_07AA; case_C_204:; LOCALISE(); goto L_07AA; case_C_205:; OPERATION(17); goto L_07AA; case_C_206:; OPERATION(16); goto L_07AA; case_C_207:; APPLYROUND(STACK); goto L_07AA; case_C_208:; POPRELEASEANDDROP(); goto L_07AA; case_C_210:; DEFINERANGE(); goto L_07AA; case_C_211:; SWOP(); goto L_07AA; case_C_212:; APPLYTRUNC(STACK); goto L_07AA; case_C_213:; USEWITH(TAG()); goto L_07AA; case_C_214:; VMAP(STACK, TAG()); goto L_07AA; case_C_215:; STACKWORKVARIABLE(); goto L_07AA; case_C_216:; if (STACK->TYPE == 7) goto L_07B4; LOADUP(STACK); L_07B4: goto L_07AA; case_C_218:; STACKINTEGER(0); STACK->TYPE = 13; STACK->FLAGS = 16384; goto L_07AA; case_C_219:; CLAIMWITH(TAG()); goto L_07AA; case_C_221:; RELEASEWITH(TAG()); goto L_07AA; case_C_226:; INPUTINTEGERVALUE(1); goto L_07AA; case_C_227:; GENERALCOMPARE(); goto L_07AA; case_C_229:; N = STACK->TYPE; AMAP(STACK); if (STACK->FORM != 0) goto L_07B5; if (!(LOCKED(STACK->BASE))) goto L_07B5; if (&STACK->INDEX != NIL) goto L_07B5; if (&STACK->RECORD == NIL) goto L_07B6; L_07B5: LOADUP(STACK); L_07B6: VMAP(STACK, N); goto L_07AA; case_C_230:; FORRANGE = VAR(TAG()); goto L_07AA; case_C_231:; CALL(1); goto L_07AA; case_C_233:; COMPILEIN(0); goto L_07AA; case_C_238:; APPLYINT(STACK); goto L_07AA; case_C_237:; GENERALMOVE(); goto L_07AA; case_C_239:; OWNTYPE = TAG(); goto L_07AA; case_C_240:; FMAP(TAG()); goto L_07AA; case_C_242:; TESTRANGE(STACK, VAR(TAG())); goto L_07AA; case_C_243:; SETSIZEORTYPE(1, STACK); goto L_07AA; case_C_244:; SETSIZEORTYPE(2, STACK); goto L_07AA; case_C_246:; COMPAREVALUES(); PRIM(36); goto L_07AA; case_C_247:; APPLYINTPT(STACK); goto L_07AA; case_C_250:; STACKDATASIZE(); goto L_07AA; case_C_251:; NN = 0; ASSEMBLE(&ALTV, -2, *VARS, *LOCAL, -1, &NN); ALTALIGN = ALTALIGN & FALIGN; goto L_07AA; case_C_253:; if (MAXFRAME <= FRAME) goto L_07B7; FRAME = MAXFRAME; L_07B7: FALIGN = ALTALIGN; goto L_07AB; L_07AA: goto L_07A9; L_07AB: *GLOBALATTRIBUTES = *GLOBALATTRIBUTES | ATTRIBUTES & 512; if (AMODE & 8 != 0) goto L_07B8; if (FRAMEUSE[*LOCAL] == MYMARK) goto L_07B9; ATTRIBUTES = ATTRIBUTES | 2; L_07B9: if (DEBUG == 0) goto L_07BA; DIR2(36, CURRENTLINE); L_07BA: DIR1(32); DUMPENCODED((FRAME & -4) - AFRAME); DUMPENCODED(CODEBASE); DUMPENCODED(PARAMETERFRAME); DUMPENCODED(PARAMETERREGS); DUMPENCODED(DISPLAYVECTOR[*LOCAL]); DUMPENCODED(LOCALDISPLAY); DUMPENCODED(ARRAYBASE); DUMPENCODED(ATTRIBUTES); DUMPENCODED(ENTRYMASK); DUMPENCODED(EVENTBITS & 65535); DUMPENCODED(EVENTLABEL); DUMPENCODED(EVENTBODY); FORGETEVERYTHING(); AVAR->P = AVAR->P | OPEN; L_07B8: TERMINATEBLOCK(); if (*LOCAL == 145) goto L_07BB; DISPLAYVECTOR[*LOCAL + 1] = 0; L_07BB: if (DANGERLEVEL != *LOCAL) goto L_07BC; DANGERLEVEL = 32767; L_07BC: PENDINGKNOWNREGISTER = 0; PENDINGAUTO = 0; LASTWORK = WORKBASE; return; case_C_default:; FAIL(_imp_join((_imp_string)(_imp_str_literal("Code ")), (_imp_string)(_imp_ITOS(CODE, 0)))); } /* ASSEMBLE */ ACTIVITY[13] = -1; ACTIVITY[11] = -1; ACTIVITY[10] = -1; COMPILINGPRIM = INTERFACE->PRIM; UNASSIGNED = INTERFACE->OPTIONS & 32; DEBUG = INTERFACE->OPTIONS & 8388608; if (UNASSIGNED == 0) goto L_07BD; OWNBASE = 16; L_07BD: J = -1; /*%for J = 0, 1, 31 %cycle*/ L_07BE: if (J == 31) goto L_07BF; J += 1; PVAR[J].P = NIL; goto L_07BE; L_07BF: J = -1; /*%for J = 0, 1, (unsigned int)8191 >> 8 %cycle*/ L_07C1: if (J == (unsigned int)8191 >> 8) goto L_07C2; J += 1; ILABELS[J].LABEL = NIL; goto L_07C1; L_07C2: _imp_SELECTINPUT(1); _imp_READSYMBOL(&PENDING); *VAR(0) = 0; DEFAULTVALUE = 0; VALUE = DEFAULTVALUE; void INITIALISE(struct STACKFM * V, int BASE, int FORM) { V = 0; V = *BASE; V = 1; V = *FORM; V = 128; } /* INITIALISE */ INITIALISE(&UAPAT, 10, 1); INITIALISE(&ZERO, 0, 0); INITIALISE(&ONE, 0, 0); ONE.DISP = 1; INITIALISE(&SPV, 13, 0); { /*%begin*/ int J; struct STACKFM *R; J = 0; /*%for J = 1, 1, 26 %cycle*/ L_07C3: if (J == 26) goto L_07C4; J += 1; R = ®V[J]; *R = 0; R->BASE = J; R->TYPE = 1; R->FORM = 0; R->FORMAT = 4; if (J < 18) goto L_07C5; R->TYPE = 7; R->FORMAT = 4 * 2; L_07C5: goto L_07C3; L_07C4: } KNOWING = NIL; KASL = NIL; _imp_SELECTOUTPUT(2); PARMS = 2000; CONSTANTBASE = 0; FREELABEL = 0; SECTION = 0; ASSEMBLE(VAR(0), -16, 0, 128, 0, &J); DUMPENCODED(ENTRYPOINT); DUMPENCODED(CONTROL); DUMPENCODED(MINSB); INTERFACE->REFCOUNT = REFS; INTERFACE->DEFCOUNT = FREELABEL; INTERFACE->BLOCKCOUNT = BLOCKS; INTERFACE->EXTERNALCOUNT = EXTERNALNO; INTERFACE->GLOBALSIZE = OWNBASE; INTERFACE->GLOBALARRAYSIZE = OWNARRAYBASE; INTERFACE->CONSTANTSIZE = CONSTANTBASE; { /*%begin*/ void MONITOR(_imp_string255 TEXT) { _imp_SELECTOUTPUT(0); _imp_PRINTSTRING(*TEXT); _imp_NEWLINE(); } /* MONITOR */ struct VVFM *V; if (DIAG & 64 == 0) goto L_07C6; MONITOR(_imp_str_literal("Dispose Vars")); L_07C6: L_07C7: if (VARLIST == NIL) goto L_07C8; V = VARLIST; VARLIST = &VARLIST->LINK; _imp_DISPOSE(V); goto L_07C7; L_07C8: struct KNOWFM *K; if (DIAG & 64 == 0) goto L_07C9; MONITOR(_imp_str_literal("Dispose Kasl")); L_07C9: L_07CA: if (KASL == NIL) goto L_07CB; K = KASL; KASL = &KASL->LINK; _imp_DISPOSE(K); goto L_07CA; L_07CB: struct ILABELFM *I; if (DIAG & 64 == 0) goto L_07CC; MONITOR(_imp_str_literal("Dispose Labels")); L_07CC: L_07CD: if (ILABELLIST == NIL) goto L_07CE; I = ILABELLIST; ILABELLIST = &I->LINK; _imp_DISPOSE(I); goto L_07CD; L_07CE: struct WORKVFM *W1; struct WORKVFM *W2; W2 = &WORKLIST.LINK; if (DIAG & 64 == 0) goto L_07CF; MONITOR(_imp_str_literal("Dispose Work")); L_07CF: L_07D0: if (W2 == NIL) goto L_07D1; W1 = W2; W2 = &W2->LINK; _imp_DISPOSE(W1); goto L_07D0; L_07D1: if (DIAG & 64 == 0) goto L_07D2; MONITOR(_imp_str_literal("Disposed")); L_07D2: } return; } /* %endoffile */