#include <perms.h>
// Edinburgh IMP77 Compiler - Version 8.4
//
// 1 !! 28-JAN-81
// 2 ! **************************************************************
// 3 ! * *
// 4 ! * PERKIN-ELMER 32-BIT SERIES IMP COMPILER *
// 5 ! * INTERMEDIATE CODE ASSEMBLER *
// 6 ! * *
// 7 ! * (GENERAL SERVICE VERSION) *
// 8 ! * *
// 9 ! * C.H. WHITFIELD *
// 10 ! * 19, REDFORD TERRACE *
// 11 ! * COLINTON, *
// 12 ! * EDINBURGH EH13-0BT *
// 13 ! * *
// 14 ! * COPYRIGHT (c) MAY 1ST. 1980 *
// 15 ! * ALL RIGHTS RESERVED *
// 16 ! * *
// 17 ! **************************************************************
// 18
// 19
// 20 ! Pass 3 for 7/32 Imp
// 21
// 22 ! ===========
// 23 ! N.B. All loader-visible addresses generated by pass2 are in units
// 24 ! of halfwords.
// 25 ! ===========
// 26
// 27 ! ****Compatibility header: to disappear with old-format EXE files
// 28 %constinteger h8 = 8
// 29
// 30 !
// 31 %begin
int main(int argc, char **argv) { /*%begin*/
_imp_initialise(argc, argv);
// 32 !!%include "Sysinc:Com.inc"
// 33 {Include file for compiler communication}
// 34 %recordformat impcomfm(%integer statements, flags, code, gla, diags, perm,
struct IMPCOMFM {
union {
struct {
int STATEMENTS;
int FLAGS;
int CODE;
int GLA;
int DIAGS;
int PERM;
_imp_string31 FILE;
_imp_string63 OPTION;
};
};
};
// 35+ %string(31) file,
// 36+ %string(63) Option)
// 37 %externalrecord(impcomfm)%spec IMPCOM
extern struct IMPCOMFM IMPCOM;
// 38 !%endoffile
// 39 %constinteger direct=1, object=2
// 40 %constinteger report=0
// 41
// 42 ! N.B. <0 for diagnostic tracing, >0 for extra details of dumped code
// 43 %constinteger diagnostic = 0
// 44
// 45 %constinteger register template = x'7DEF'; ! wsp, code, gla, link
// 46
// 47 %constinteger max tag=2050
// 48 %constinteger max ref=2900
// 49 %constinteger max proc=255
// 50
// 51 %constinteger bmax = 8; ! no. of DA buffers available to phase 2
// 52 %constinteger safe pc rel = 6500; ! 'SAFE' limit in stretch routines q.v.
// 53
// 54
// 55 ! Parameters related to diagnostic table generation
// 56 %constinteger indirect = x'4000'
// 57 %constinteger line diag limit = 31
// 58 %constinteger proc header=1, diag entry=0, linkage name=-1; ! 'descriptions'
// 59 %constinteger none = 0, partial = 1, full = 2
// 60 %owninteger diags = full, hide = 0
static int DIAGS = 2;
static int HIDE = 0;
// 61
// 62 %constinteger main prog = x'4000'; ! main program marker in event chain
// 63 %conststring(3) main ep = "%GO"; ! must match pass 2
const _imp_string3 MAINEP = _imp_str_init("%GO");
// 64 %conststring(6) trace ep = "$TRACE"; ! likewise
const _imp_string6 TRACEEP = _imp_str_init("$TRACE");
// 65 %constinteger init lit = 4; ! halfwords: must not exceed pass 2 value
// 66
// 67
// 68 !********
// 69 %constshortinteger max prim = 52
// 70 %constshortintegerarray prim(1:1018) = %c
const short int PRIM[1018] = {
623, 533, 548, 53, 100, 135, 215, 346, 193, 562, 666, 352, 691, 711, 743, 778,
453, 501, 427, 821, 682, 660, 654, 632, 648, 789, 392, 404, 674, 81, 593, 613,
580, 414, 943, 973, 988, 1004, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
924, 931, 824, 831, 27, 18447, 0, 8499, 13314, 37888, 37632, 54065, 0, 50480, 128, 8504,
54321, 1, 8501, 9224, 9233, 34947, 52, 1283, 9093, 9217, 9239, 34947, 52, 9970, 34952, 30,
18, 1298, 831, 54065, 0, 37939, 13379, 63536, 65280, 1, 54017, 17408, 0, 53762, 17408, 0,
2627, 8327, 783, 34, 18447, 0, 8499, 13314, 37888, 37632, 54065, 0, 50480, 128, 8504, 54321,
1, 8501, 9224, 9233, 34947, 52, 9280, 1283, 9091, 2096, 8964, 54017, 17408, 0, 53762, 17408,
0, 9793, 10033, 8728, 17167, 2, 57, 18447, 0, 8499, 13314, 37888, 37632, 54065, 0, 50480,
128, 8504, 54321, 1, 8501, 9224, 9233, 34947, 52, 54082, 0, 50496, 128, 8500, 54338, 1,
8763, 2627, 50496, 256, 8581, 9217, 9235, 34947, 52, 2820, 8981, 9217, 9239, 34947, 52, 53826,
0, 2883, 2626, 9296, 8968, 54017, 17664, 1, 53764, 17664, 1, 9809, 10033, 8728, 17167, 2,
21, 9281, 54065, 0, 54018, 0, 2864, 8987, 2563, 8969, 54097, 17408, 0, 54354, 17408, 0,
575, 9793, 9985, 8729, 2099, 783, 130, 29535, 0, 37989, 4184, 8499, 13394, 37973, 37717, 4200,
8499, 13412, 37990, 37734, 53431, 0, 54195, 0, 50608, 128, 8500, 54451, 1, 9017, 54017, 0,
50432, 128, 8504, 54273, 1, 8501, 9224, 9233, 34947, 52, 2992, 16912, 32936, 9408, 2048, 17200,
32824, 54017, 1, 54275, 19456, 1, 9017, 9921, 1468, 8838, 17152, 32906, 54017, 1, 8711, 2275,
2796, 54225, 0, 10193, 54030, 19712, 1, 54273, 19712, 1, 8254, 10193, 8232, 2082, 9012, 1372,
17024, 32866, 2268, 2116, 9018, 54017, 0, 2752, 54243, 0, 3052, 1390, 17024, 32842, 2082, 9020,
53970, 0, 8967, 54019, 19712, 1, 53762, 19712, 1, 10193, 8727, 2116, 17200, 32796, 53988, 0,
2755, 9424, 8968, 54028, 19712, 1, 53764, 19712, 1, 9937, 10209, 8728, 9473, 53687, 0, 17167,
2, 9216, 8709, 53687, 0, 9217, 9239, 34947, 52, 5, 575, 9223, 9232, 34947, 52, 39,
54017, 0, 50432, 128, 8504, 54273, 1, 8501, 9224, 9233, 34947, 52, 2082, 8998, 1283, 8580,
52018, 65535, 8982, 2115, 9221, 9236, 34947, 52, 2593, 51223, 0, 53809, 0, 8967, 54018, 17152,
0, 53761, 17152, 1, 10033, 8727, 783, 11, 4402, 8967, 22529, 17152, 0, 20482, 17152, 0,
10036, 8727, 783, 9, 4402, 9216, 8964, 20482, 17152, 0, 10036, 8724, 783, 12, 2884, 54017,
17408, 0, 54274, 17408, 0, 575, 9793, 1347, 8249, 783, 25, 2097, 18738, 2, 8492, 19250,
0, 8473, 2611, 29491, 16896, 4, 9017, 2611, 2622, 771, 2081, 9222, 9235, 34947, 52, 2081,
9224, 9234, 34947, 52, 47, 53399, 0, 9265, 9232, 18591, 0, 2228, 18607, 2, 22731, 8,
23499, 4, 9921, 16912, 32816, 20683, 0, 7180, 23323, 4, 7212, 9916, 10129, 8255, 20651, 0,
7178, 7210, 9779, 50224, 65532, 18639, 0, 20676, 0, 53655, 0, 17167, 4, 2123, 53655, 0,
9221, 9235, 34947, 52, 31, 2055, 2563, 22797, 0, 8997, 9218, 9233, 34947, 52, 2673, 20594,
0, 20546, 4, 9768, 2160, 22542, 12, 62720, 32896, 32896, 575, 9296, 2899, 831, 20487, 17664,
0, 9812, 8244, 783, 14, 2082, 8981, 9221, 9234, 34947, 52, 9217, 9233, 8962, 7171, 10017,
8722, 34952, 21, 13, 9217, 12032, 2049, 8982, 11522, 10272, 9216, 51969, 1, 831, 11266, 9985,
8707, 32784, 10242, 8468, 27136, 32784, 8965, 27392, 32778, 27168, 32778, 10240, 11040, 783, 17920, 0,
16656, 0, 0, 32780, 10274, 8468, 27168, 32780, 8963, 27424, 32774, 11794, 783, 0, 16512, 0,
19, 18447, 0, 8499, 13313, 37888, 37632, 2082, 9000, 1282, 8582, 58897, 16896, 0, 17167, 2,
9222, 9237, 34947, 52, 9, 22557, 0, 51991, 512, 799, 9218, 9233, 34947, 52, 8, 575,
9224, 9233, 34947, 52, 0, 32896, 32896, 15, 2082, 9018, 2832, 2049, 60928, 31, 7426, 2065,
8467, 2048, 831, 9221, 9233, 34947, 52, 5, 831, 9220, 9234, 34947, 52, 5, 831, 9217,
9237, 34947, 52, 5, 847, 9217, 9237, 34947, 52, 7, 54273, 0, 911, 9217, 9239, 34947,
52, 7, 49952, 65504, 831, 9221, 9238, 34947, 52, 8, 2048, 831, 9729, 831, 9217, 9233,
34947, 52, 19, 22563, 4, 22802, 4, 8473, 22802, 8, 8486, 23554, 12, 23059, 0, 783,
2114, 2081, 9222, 9234, 34947, 52, 31, 22595, 4, 22804, 4, 16912, 32808, 22804, 8, 16928,
32800, 23556, 12, 22820, 16, 8474, 22820, 20, 8487, 2578, 23556, 24, 23059, 0, 783, 2066,
9804, 2081, 9222, 9234, 34947, 52, 34, 22611, 4, 22597, 0, 10049, 4418, 2626, 2049, 9232,
10052, 22789, 4, 16912, 32796, 22789, 8, 8492, 2576, 23557, 12, 9820, 22532, 0, 1346, 8847,
23059, 0, 783, 2117, 2080, 9222, 9234, 34947, 52, 10, 22595, 4, 23556, 12, 2578, 23556,
24, 23059, 0, 783, 31, 2119, 18511, 0, 29487, 2, 4386, 2882, 2599, 22589, 0, 50482,
512, 9093, 9218, 9233, 34947, 52, 9972, 2162, 63536, 32896, 32896, 21822, 12, 575, 20535, 17408,
0, 9796, 8740, 783, 2, 34947, 52, 6, 53255, 44, 2151, 51824, 108, 33026, 92, 53255,
44, 22605, 8, 9015, 20484, 0, 20500, 4, 20516, 8, 51367, 64, 2064, 9281, 60737, 0,
2067, 16672, 32860, 2133, 8981, 2111, 2067, 16672, 32848, 18470, 2, 37714, 4434, 22618, 17919, 65516,
2082, 16912, 32802, 29462, 8, 2577, 2590, 2353, 9004, 18454, 4, 1044, 9016, 53626, 8, 29462,
6, 2577, 2590, 769, 49952, 16384, 8504, 22581, 40, 22757, 36, 2213, 17152, 65456, 53511, 44,
33025, 29550, 16639, 65534, 2662, 2846, 29446, 19968, 0, 2560, 2134, 2896, 2326, 8483, 2325, 8488,
2149, 8731, 53511, 44, 9216, 9247, 33025, 2133, 530, 2670, 770, 6, 22589, 4, 2248, 387,
2188, 783, 11, 18543, 0, 9970, 2143, 53335, 0, 53725, 34951, 2095, 2293, 770, 29, 9216,
51248, 28, 22593, 17152, 0, 22610, 17152, 0, 2149, 1124, 2404, 9011, 50688, 1, 2405, 9011,
50688, 2, 10036, 17168, 65498, 9312, 17679, 0, 8498, 9313, 17167, 2, 14, 51248, 28, 22529,
17152, 0, 22018, 17152, 0, 20481, 17152, 0, 10036, 8730, 783, 15, 51248, 28, 9473, 22274,
17152, 0, 21505, 17152, 0, 20481, 17152, 0, 10036, 8731, 783, 14, 51248, 28, 22529, 17152,
0, 21506, 17152, 0, 20481, 17152, 0, 10036, 8730, 783};
// 71+ x'026F',x'0215',x'0224',x'0035',x'0064',x'0087',x'00D7',x'015A',x'00C1',
// 72+ x'0232',x'029A',x'0160',x'02B3',x'02C7',x'02E7',x'030A',x'01C5',x'01F5',
// 73+ x'01AB',x'0335',x'02AA',x'0294',x'028E',x'0278',x'0288',x'0315',x'0188',
// 74+ x'0194',x'02A2',x'0051',x'0251',x'0265',x'0244',x'019E',x'03AF',x'03CD',
// 75+ x'03DC',x'03EC',x'0000',x'0000',x'0000',x'0000',x'0000',x'0000',x'0000',
// 76+ x'0000',x'0000',x'0000',x'039C',x'03A3',x'0338',x'033F',x'001B',x'480F',
// 77+ x'0000',x'2133',x'3402',x'9400',x'9300',x'D331',x'0000',x'C530',x'0080',
// 78+ x'2138',x'D431',x'0001',x'2135',x'2408',x'2411',x'8883',x'0034',x'0503',
// 79+ x'2385',x'2401',x'2417',x'8883',x'0034',x'26F2',x'8888',x'001E',x'0012',
// 80+ x'0512',x'033F',x'D331',x'0000',x'9433',x'3443',x'F830',x'FF00',x'0001',
// 81+ x'D301',x'4400',x'0000',x'D202',x'4400',x'0000',x'0A43',x'2087',x'030F',
// 82+ x'0022',x'480F',x'0000',x'2133',x'3402',x'9400',x'9300',x'D331',x'0000',
// 83+ x'C530',x'0080',x'2138',x'D431',x'0001',x'2135',x'2408',x'2411',x'8883',
// 84+ x'0034',x'2440',x'0503',x'2383',x'0830',x'2304',x'D301',x'4400',x'0000',
// 85+ x'D202',x'4400',x'0000',x'2641',x'2731',x'2218',x'430F',x'0002',x'0039',
// 86+ x'480F',x'0000',x'2133',x'3402',x'9400',x'9300',x'D331',x'0000',x'C530',
// 87+ x'0080',x'2138',x'D431',x'0001',x'2135',x'2408',x'2411',x'8883',x'0034',
// 88+ x'D342',x'0000',x'C540',x'0080',x'2134',x'D442',x'0001',x'223B',x'0A43',
// 89+ x'C540',x'0100',x'2185',x'2401',x'2413',x'8883',x'0034',x'0B04',x'2315',
// 90+ x'2401',x'2417',x'8883',x'0034',x'D242',x'0000',x'0B43',x'0A42',x'2450',
// 91+ x'2308',x'D301',x'4500',x'0001',x'D204',x'4500',x'0001',x'2651',x'2731',
// 92+ x'2218',x'430F',x'0002',x'0015',x'2441',x'D331',x'0000',x'D302',x'0000',
// 93+ x'0B30',x'231B',x'0A03',x'2309',x'D351',x'4400',x'0000',x'D452',x'4400',
// 94+ x'0000',x'023F',x'2641',x'2701',x'2219',x'0833',x'030F',x'0082',x'735F',
// 95+ x'0000',x'9465',x'1058',x'2133',x'3452',x'9455',x'9355',x'1068',x'2133',
// 96+ x'3464',x'9466',x'9366',x'D0B7',x'0000',x'D3B3',x'0000',x'C5B0',x'0080',
// 97+ x'2134',x'D4B3',x'0001',x'2339',x'D301',x'0000',x'C500',x'0080',x'2138',
// 98+ x'D401',x'0001',x'2135',x'2408',x'2411',x'8883',x'0034',x'0BB0',x'4210',
// 99+ x'80A8',x'24C0',x'0800',x'4330',x'8038',x'D301',x'0001',x'D403',x'4C00',
// 100+ x'0001',x'2339',x'26C1',x'05BC',x'2286',x'4300',x'808A',x'D301',x'0001',
// 101+ x'2207',x'08E3',x'0AEC',x'D3D1',x'0000',x'27D1',x'D30E',x'4D00',x'0001',
// 102+ x'D401',x'4D00',x'0001',x'203E',x'27D1',x'2028',x'0822',x'2334',x'055C',
// 103+ x'4280',x'8062',x'08DC',x'0844',x'233A',x'D301',x'0000',x'0AC0',x'D3E3',
// 104+ x'0000',x'0BEC',x'056E',x'4280',x'804A',x'0822',x'233C',x'D2D2',x'0000',
// 105+ x'2307',x'D303',x'4D00',x'0001',x'D202',x'4D00',x'0001',x'27D1',x'2217',
// 106+ x'0844',x'4330',x'801C',x'D2E4',x'0000',x'0AC3',x'24D0',x'2308',x'D30C',
// 107+ x'4D00',x'0001',x'D204',x'4D00',x'0001',x'26D1',x'27E1',x'2218',x'2501',
// 108+ x'D1B7',x'0000',x'430F',x'0002',x'2400',x'2205',x'D1B7',x'0000',x'2401',
// 109+ x'2417',x'8883',x'0034',x'0005',x'023F',x'2407',x'2410',x'8883',x'0034',
// 110+ x'0027',x'D301',x'0000',x'C500',x'0080',x'2138',x'D401',x'0001',x'2135',
// 111+ x'2408',x'2411',x'8883',x'0034',x'0822',x'2326',x'0503',x'2184',x'CB32',
// 112+ x'FFFF',x'2316',x'0843',x'2405',x'2414',x'8883',x'0034',x'0A21',x'C817',
// 113+ x'0000',x'D231',x'0000',x'2307',x'D302',x'4300',x'0000',x'D201',x'4300',
// 114+ x'0001',x'2731',x'2217',x'030F',x'000B',x'1132',x'2307',x'5801',x'4300',
// 115+ x'0000',x'5002',x'4300',x'0000',x'2734',x'2217',x'030F',x'0009',x'1132',
// 116+ x'2400',x'2304',x'5002',x'4300',x'0000',x'2734',x'2214',x'030F',x'000C',
// 117+ x'0B44',x'D301',x'4400',x'0000',x'D402',x'4400',x'0000',x'023F',x'2641',
// 118+ x'0543',x'2039',x'030F',x'0019',x'0831',x'4932',x'0002',x'212C',x'4B32',
// 119+ x'0000',x'2119',x'0A33',x'7333',x'4200',x'0004',x'2339',x'0A33',x'0A3E',
// 120+ x'0303',x'0821',x'2406',x'2413',x'8883',x'0034',x'0821',x'2408',x'2412',
// 121+ x'8883',x'0034',x'002F',x'D097',x'0000',x'2431',x'2410',x'489F',x'0000',
// 122+ x'08B4',x'48AF',x'0002',x'58CB',x'0008',x'5BCB',x'0004',x'26C1',x'4210',
// 123+ x'8030',x'50CB',x'0000',x'1C0C',x'5B1B',x'0004',x'1C2C',x'26BC',x'2791',
// 124+ x'203F',x'50AB',x'0000',x'1C0A',x'1C2A',x'2633',x'C430',x'FFFC',x'48CF',
// 125+ x'0000',x'50C4',x'0000',x'D197',x'0000',x'430F',x'0004',x'084B',x'D197',
// 126+ x'0000',x'2405',x'2413',x'8883',x'0034',x'001F',x'0807',x'0A03',x'590D',
// 127+ x'0000',x'2325',x'2402',x'2411',x'8883',x'0034',x'0A71',x'5072',x'0000',
// 128+ x'5042',x'0004',x'2628',x'0870',x'580E',x'000C',x'F500',x'8080',x'8080',
// 129+ x'023F',x'2450',x'0B53',x'033F',x'5007',x'4500',x'0000',x'2654',x'2034',
// 130+ x'030F',x'000E',x'0822',x'2315',x'2405',x'2412',x'8883',x'0034',x'2401',
// 131+ x'2411',x'2302',x'1C03',x'2721',x'2212',x'8888',x'0015',x'000D',x'2401',
// 132+ x'2F00',x'0801',x'2316',x'2D02',x'2820',x'2400',x'CB01',x'0001',x'033F',
// 133+ x'2C02',x'2701',x'2203',x'8010',x'2802',x'2114',x'6A00',x'8010',x'2305',
// 134+ x'6B00',x'800A',x'6A20',x'800A',x'2800',x'2B20',x'030F',x'4600',x'0000',
// 135+ x'4110',x'0000',x'0000',x'800C',x'2822',x'2114',x'6A20',x'800C',x'2303',
// 136+ x'6B20',x'8006',x'2E12',x'030F',x'0000',x'4080',x'0000',x'0013',x'480F',
// 137+ x'0000',x'2133',x'3401',x'9400',x'9300',x'0822',x'2328',x'0502',x'2186',
// 138+ x'E611',x'4200',x'0000',x'430F',x'0002',x'2406',x'2415',x'8883',x'0034',
// 139+ x'0009',x'581D',x'0000',x'CB17',x'0200',x'031F',x'2402',x'2411',x'8883',
// 140+ x'0034',x'0008',x'023F',x'2408',x'2411',x'8883',x'0034',x'0000',x'8080',
// 141+ x'8080',x'000F',x'0822',x'233A',x'0B10',x'0801',x'EE00',x'001F',x'1D02',
// 142+ x'0811',x'2113',x'0800',x'033F',x'2405',x'2411',x'8883',x'0034',x'0005',
// 143+ x'033F',x'2404',x'2412',x'8883',x'0034',x'0005',x'033F',x'2401',x'2415',
// 144+ x'8883',x'0034',x'0005',x'034F',x'2401',x'2415',x'8883',x'0034',x'0007',
// 145+ x'D401',x'0000',x'038F',x'2401',x'2417',x'8883',x'0034',x'0007',x'C320',
// 146+ x'FFE0',x'033F',x'2405',x'2416',x'8883',x'0034',x'0008',x'0800',x'033F',
// 147+ x'2601',x'033F',x'2401',x'2411',x'8883',x'0034',x'0013',x'5823',x'0004',
// 148+ x'5912',x'0004',x'2119',x'5912',x'0008',x'2126',x'5C02',x'000C',x'5A13',
// 149+ x'0000',x'030F',x'0842',x'0821',x'2406',x'2412',x'8883',x'0034',x'001F',
// 150+ x'5843',x'0004',x'5914',x'0004',x'4210',x'8028',x'5914',x'0008',x'4220',
// 151+ x'8020',x'5C04',x'000C',x'5924',x'0010',x'211A',x'5924',x'0014',x'2127',
// 152+ x'0A12',x'5C04',x'0018',x'5A13',x'0000',x'030F',x'0812',x'264C',x'0821',
// 153+ x'2406',x'2412',x'8883',x'0034',x'0022',x'5853',x'0004',x'5845',x'0000',
// 154+ x'2741',x'1142',x'0A42',x'0801',x'2410',x'2744',x'5905',x'0004',x'4210',
// 155+ x'801C',x'5905',x'0008',x'212C',x'0A10',x'5C05',x'000C',x'265C',x'5804',
// 156+ x'0000',x'0542',x'228F',x'5A13',x'0000',x'030F',x'0845',x'0820',x'2406',
// 157+ x'2412',x'8883',x'0034',x'000A',x'5843',x'0004',x'5C04',x'000C',x'0A12',
// 158+ x'5C04',x'0018',x'5A13',x'0000',x'030F',x'001F',x'0847',x'484F',x'0000',
// 159+ x'732F',x'0002',x'1122',x'0B42',x'0A27',x'583D',x'0000',x'C532',x'0200',
// 160+ x'2385',x'2402',x'2411',x'8883',x'0034',x'26F4',x'0872',x'F830',x'8080',
// 161+ x'8080',x'553E',x'000C',x'023F',x'5037',x'4400',x'0000',x'2644',x'2224',
// 162+ x'030F',x'0002',x'8883',x'0034',x'0006',x'D007',x'002C',x'0867',x'CA70',
// 163+ x'006C',x'8102',x'005C',x'D007',x'002C',x'584D',x'0008',x'2337',x'5004',
// 164+ x'0000',x'5014',x'0004',x'5024',x'0008',x'C8A7',x'0040',x'0810',x'2441',
// 165+ x'ED41',x'0000',x'0813',x'4120',x'805C',x'0855',x'2315',x'083F',x'0813',
// 166+ x'4120',x'8050',x'4826',x'0002',x'9352',x'1152',x'585A',x'45FF',x'FFEC',
// 167+ x'0822',x'4210',x'8022',x'7316',x'0008',x'0A11',x'0A1E',x'0931',x'232C',
// 168+ x'4816',x'0004',x'0414',x'2338',x'D17A',x'0008',x'7316',x'0006',x'0A11',
// 169+ x'0A1E',x'0301',x'C320',x'4000',x'2138',x'5835',x'0028',x'58E5',x'0024',
// 170+ x'08A5',x'4300',x'FFB0',x'D107',x'002C',x'8101',x'736E',x'40FF',x'FFFE',
// 171+ x'0A66',x'0B1E',x'7306',x'4E00',x'0000',x'0A00',x'0856',x'0B50',x'0916',
// 172+ x'2123',x'0915',x'2128',x'0865',x'221B',x'D107',x'002C',x'2400',x'241F',
// 173+ x'8101',x'0855',x'0212',x'0A6E',x'0302',x'0006',x'583D',x'0004',x'08C8',
// 174+ x'0183',x'088C',x'030F',x'000B',x'486F',x'0000',x'26F2',x'085F',x'D057',
// 175+ x'0000',x'D1DD',x'8887',x'082F',x'08F5',x'0302',x'001D',x'2400',x'C830',
// 176+ x'001C',x'5841',x'4300',x'0000',x'5852',x'4300',x'0000',x'0865',x'0464',
// 177+ x'0964',x'2333',x'C600',x'0001',x'0965',x'2333',x'C600',x'0002',x'2734',
// 178+ x'4310',x'FFDA',x'2460',x'450F',x'0000',x'2132',x'2461',x'430F',x'0002',
// 179+ x'000E',x'C830',x'001C',x'5801',x'4300',x'0000',x'5602',x'4300',x'0000',
// 180+ x'5001',x'4300',x'0000',x'2734',x'221A',x'030F',x'000F',x'C830',x'001C',
// 181+ x'2501',x'5702',x'4300',x'0000',x'5401',x'4300',x'0000',x'5001',x'4300',
// 182+ x'0000',x'2734',x'221B',x'030F',x'000E',x'C830',x'001C',x'5801',x'4300',
// 183+ x'0000',x'5402',x'4300',x'0000',x'5001',x'4300',x'0000',x'2734',x'221A',
// 184+ x'030F'
// 185
// 186 !********
// 187
// 188 ! ==== control codes ====
// 189 %constinteger tag defn = 1
// 190 %constinteger r ref = 2
// 191 %constinteger p ref = 3
// 192 %constinteger sw ref = 4
// 193 %constinteger j ref = 5
// 194 %constinteger c ref = 6
// 195 %constinteger code item = 7
// 196 %constinteger gla item = 8
// 197 %constinteger line diag = 9
// 198 %constinteger line reset = 10
// 199 %constinteger var diag = 11
// 200 %constinteger code area = 12
// 201 %constinteger lit area = 13
// 202 %constinteger lit org = 14
// 203 %constinteger frame patch = 15
// 204 %constinteger proc head = 16
// 205 %constinteger proc end = 17
// 206 %constinteger prog end = 18
// 207 %constinteger code rel = 19
// 208 %constinteger gla rel = 20
// 209 %constinteger extern = 21
// 210
// 211 ! external reference sub-types
// 212 %constinteger data spec = 4, data defn = 5
// 213 %constinteger ep spec = 6, ep defn = 7
// 214
// 215
// 216 ! ======== constants associated with code generation ========
// 217 %constinteger align=3; ! single word alignment (literal area)
// 218 %constinteger emark = x'8880', tmark = x'8887'
// 219 %constinteger backwards = X'0100'; ! short jump modifier
// 220 %constinteger code base = 14; ! code base register
// 221
// 222 %constinteger BZ = X'433E', BZS = X'2330'
// 223 %constinteger BNZ = X'423E', BNZS = X'2130'
// 224 %constinteger BM = X'421E', BMS = X'2110'
// 225 %constinteger BP = X'422E', BPS = X'2120'
// 226 %constinteger BNP = X'432E', BNPS = X'2320'
// 227 %constinteger BNM = X'431E', BNMS = X'2310'
// 228 %constinteger JMP = X'430E', JMPS = X'2300'
// 229 %constinteger BAL = X'410E'
// 230
// 231 %constshortintegerarray short jump(0:12) =
const short int SHORTJUMP[13] = {9008, 8496, 8464, 8480, 8992, 8976, 8496, 9008, 8480, 8464, 8976, 8992, 8960};
// 232+ BZS, BNZS, BMS, BPS, BNPS, BNMS,
// 233+ BNZS, BZS, BPS, BMS, BNMS, BNPS, JMPS
// 234 %constshortintegerarray long jump(0:12) =
const short int LONGJUMP[13] = {17214, 16958, 16926, 16942, 17198, 17182, 16958,
17214, 16942, 16926, 17182, 17198, 17166};
// 235+ BZ, BNZ, BM, BP, BNP, BNM,
// 236+ BNZ, BZ, BP, BM, BNM, BNP, JMP
// 237
// 238 ! == flag bits used in 'REF' table ==
// 239 %constinteger short=1
// 240 %constinteger long=2
// 241 %constinteger pc rel=4
// 242 %constinteger very=8
// 243 %constinteger invert=16
// 244 %constinteger remove=32
// 245 %constinteger rcall=64
// 246 %constinteger safe=128
// 247 %constinteger conditional=256
// 248
// 249
// 250 ! == values used in code generation phase ( reftype(k)=0 -> 'REMOVE' ) ==
// 251 %constinteger sf=1
// 252 %constinteger rx1=2
// 253 %constinteger rx2=3
// 254 %constinteger rx3=4
// 255
// 256 %constinteger sign bit = x'80000000'
// 257 %constinteger halfword sign = x'FFFF8000'
// 258
// 259 ! ** Purely for accumulating jump instruction statistics
// 260 %owninteger sfjump=0, rx1jump=0, rx2jump=0, rx13jump=0
static int SFJUMP = 0;
static int RX1JUMP = 0;
static int RX2JUMP = 0;
static int RX13JUMP = 0;
// 261 ! ** For accumulating counts in various bits of program
// 262 %owninteger localtot=0,localnonsafe=0, globaltot=0,globalnonsafe=0
static int LOCALTOT = 0;
static int LOCALNONSAFE = 0;
static int GLOBALTOT = 0;
static int GLOBALNONSAFE = 0;
// 263 %owninteger buff miss1=0, buff miss2=0, buff miss3=0
static int BUFFMISS1 = 0;
static int BUFFMISS2 = 0;
static int BUFFMISS3 = 0;
// 264 ! ** for recording timings
// 265 %integer t0,t1,t2; ! phase 1, phase 2 timing
int T0;
int T1;
int T2;
// 266 %integer t10, t11, t12; ! local, global stretch timing (inside phase 1)
int T10;
int T11;
int T12;
// 267
// 268
// 269
// 270 %recordformat reffm(%shortinteger tag, link, flags, ca)
struct REFFM {
union {
struct {
short int TAG;
short int LINK;
short int FLAGS;
short int CA;
};
};
};
// 271 %recordformat deffm(%record(deffm)%name link, %shortinteger proc,ca)
struct DEFFM {
union {
struct {
struct DEFFM *LINK;
short int PROC;
short int CA;
};
};
};
// 272 %recordformat procfm(%record(procfm)%name link,
struct PROCFM {
union {
struct {
struct PROCFM *LINK;
struct REFFM *REFLIST;
struct DEFFM *DEFLIST;
short int BASE;
short int CA;
short int STATICFRAME;
short int EVENTMASK;
short int DISPLAYREG;
short int EVENTSTART;
short int EVENTFINISH;
short int LDBASE;
short int LDSIZE;
short int VDBASE;
short int VDSIZE;
short int ME;
};
};
};
// 273+ %record(reffm)%name ref list,
// 274+ %record(deffm)%name def list,
// 275+ %shortinteger base, ca,
// 276+ static frame, event mask,
// 277+ display reg, event start,
// 278+ event finish, ld base,
// 279+ ld size, vd base,
// 280+ vd size, Me)
// 281
// 282 %record(procfm)%array proc(1:max proc)
struct PROCFM PROC[255];
// 283 %record(deffm)%array tagdef(1:max tag)
struct DEFFM TAGDEF[2050];
// 284 %byteintegerarray reftype(1:max ref)
unsigned char REFTYPE[2900];
// 285 %owninteger refs = 0
static int REFS = 0;
// 286 %constrecord(*)%name null == (0)
const struct ME *NULL = 0;
// 287
// 288 %record(procfm)%name proc1, last proc; ! ** N.B. proc1 ultimately is prim **
struct PROCFM *PROC1;
struct PROCFM *LASTPROC;
// 289 %shortintegerarray prim entry(1:max prim)
short int PRIMENTRY[52];
// 290 %integer header size, gla size, code size, literal size
int HEADERSIZE;
int GLASIZE;
int CODESIZE;
int LITERALSIZE;
// 291 %integer var diags, line diags
int VARDIAGS;
int LINEDIAGS;
// 292 %owninteger defns = 0, specs = 0, relocations = 0
static int DEFNS = 0;
static int SPECS = 0;
static int RELOCATIONS = 0;
// 293 %integer current line, line incr, ca incr
int CURRENTLINE;
int LINEINCR;
int CAINCR;
// 294 %integer j,k,l
int J;
int K;
int L;
// 295 tagdef(j) = 0 %for j = 1,1,max tag
// %for J = 1, 1, 2050 %cycle
{
J = 0;
L_0001:
if (J == 2050) goto L_0002;
J += 1;
TAGDEF[J - 1] = (struct DEFFM){0};
goto L_0001;
}
L_0002:;
// 296 prim entry(j) = -1 %for j = 1,1,max prim
// %for J = 1, 1, 52 %cycle
{
J = 0;
L_0004:
if (J == 52) goto L_0005;
J += 1;
PRIMENTRY[J - 1] = -1;
goto L_0004;
}
L_0005:;
// 297 proc1 == proc(1); proc1 = 0
PROC1 = (struct PROCFM *)/*?*/ &PROC[0];
*PROC1 = (struct PROCFM){0};
// 298 last proc == proc1
LASTPROC = (struct PROCFM *)PROC1;
// 299
// 300 %routine phex(%shortinteger n)
void PHEX(short int N) {
// 301 %integer j,k
int J;
int K;
// 302 %for j = 12,-4,0 %cycle
// %for J = 12, -4, 0 %cycle
{
J = 16;
L_0006:
if (J == 0) goto L_0007;
J -= 4;
// 303 k = (n>>j)&15
K = (unsigned int)N >> J & 15;
// 304 %if k < 10 %then k = k+'0' %else k = k-10+'A'
if (K >= 10) goto L_0008;
K = K + 48;
goto L_0009;
L_0008:;
K = K - 10 + 65;
L_0009:;
// 305 print symbol(k)
_imp_PRINTSYMBOL(K);
// 306 %repeat
goto L_0006;
}
L_0007:;
// 307 %end
return;
} /* end of PHEX */
// 308
// 309 %routine error(%integer n,p)
void ERROR(int N, int P) {
// 310 select output(report)
_imp_SELECTOUTPUT(0);
// 311 print string("*ERROR"); write(n,1)
_imp_PRINTSTRING(_imp_str_literal("*ERROR"));
_imp_WRITE(N, 1);
// 312 print symbol(':'); write(p,4)
_imp_PRINTSYMBOL(58);
_imp_WRITE(P, 4);
// 313 newline
_imp_NEWLINE();
// 314 %signal 15,15
_imp_signal(15, 15, 0, "");
// 315 %end
return;
} /* end of ERROR */
// 316
// 317 %routine get(%integername n)
void GET(int *N) {
// 318 %integer j,k
int J;
int K;
// 319 read symbol(j); read symbol(K)
_imp_READSYMBOL(/*?*/ &J);
_imp_READSYMBOL(/*?*/ &K);
// 320 n = j<<8 ! k
*N = J << 8 | K;
// 321 %end
return;
} /* end of GET */
// 322
// 323
// 324 %routine phase one; ! Input directives and expand jumps
void PHASEONE(void) {
// 325 %record(reffm)%array ref(1:max ref)
struct REFFM REF[2900];
// 326 %record(procfm)%name pp, qq
struct PROCFM *PP;
struct PROCFM *QQ;
// 327 %integer procs; procs = 0
int PROCS;
PROCS = 0;
// 328 %integer ca total; ca total = 0
int CATOTAL;
CATOTAL = 0;
// 329 %integer extra, n
int EXTRA;
int N;
// 330 %integer j
int J;
// 331
// 332 %routine input directives
void INPUTDIRECTIVES(void) {
// 333 %owninteger depth = 0
static int DEPTH = 0;
// 334 %owninteger code = 0, n = 0, ca = 0
static int CODE = 0;
static int N = 0;
static int CA = 0;
// 335 %record(reffm)%name r
struct REFFM *R;
// 336 %record(deffm)%name d, dd
struct DEFFM *D;
struct DEFFM *DD;
// 337 %record(procfm)%name p
struct PROCFM *P;
// 338 %integer last ref, this proc, last line
int LASTREF;
int THISPROC;
int LASTLINE;
// 339 %switch dir(1:extern)
int DIR_index;
int DIR_line;
char *DIR_file;
static const void *DIR[21] = {&&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing,
&&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing,
&&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing,
&&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing,
&&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing, &&case_DIR_missing,
&&case_DIR_missing};
// 340 depth = depth+1
DEPTH = DEPTH + 1;
// 341 procs = procs+1
PROCS = PROCS + 1;
// 342 this proc = procs; p == proc(procs); p = 0
THISPROC = PROCS;
P = (struct PROCFM *)/*?*/ &PROC[PROCS - 1];
*P = (struct PROCFM){0};
// 343 P_Me = This proc
P->ME = THISPROC;
// 344 p_ld size = diags; ! FRIG: 0 = none, 1 = partial, 2 full
P->LDSIZE = DIAGS;
// 345 ! 0 + ( ( line org + ( link )? )?
// 346 p_vd size = 0
P->VDSIZE = 0;
// 347 %if diags > none %start; ! p_vd size set = zero above
if (DIAGS <= 0) goto L_000A;
// 348 p_vd size = 4; ! procedure identifier
P->VDSIZE = 4;
// 349 p_vd size = 5 %if diags = full; ! link required as well
if (DIAGS != 2) goto L_000B;
P->VDSIZE = 5;
L_000B:;
// 350 %finish
L_000A:;
// 351 last line = current line; ! ???????
LASTLINE = CURRENTLINE;
// 352 last ref = 0; r == null
LASTREF = 0;
R = (struct REFFM *)NULL;
// 353 %cycle
L_000C:;
// 354 read symbol(code)
_imp_READSYMBOL(/*?*/ &CODE);
// 355 -> dir(code) %if 0 < code <= extern
{
// Double-sided test on CODE (Part I)
int tmp;
if (0 >= (tmp = CODE)) goto L_000D;
// Double-sided test on CODE (Part II)
if (tmp > 21) goto L_000D;
}
DIR_line = __LINE__;
DIR_file = __FILE__;
DIR_index = CODE;
goto case_DIR_dispatch;
L_000D:;
// 356 !!dir(*):
// 357 error(0,code)
ERROR(0, CODE);
// 358
// 359 dir(proc head): ! <proc index>
case_DIR_16:;
// 360 read symbol(n); error(1,n) %unless n = procs
_imp_READSYMBOL(/*?*/ &N);
if (N == PROCS) goto L_000F;
ERROR(1, N);
L_000F:;
// 361 input directives
INPUTDIRECTIVES();
// 362 %continue
goto L_0003;
// 363
// 364 dir(proc end): ! <code size> <no. var diags> <static frame size>
case_DIR_17:;
// 365 ! <local display register> <event mask> <event start> <event finish>
// 366 get(ca)
GET(/*?*/ &CA);
// 367 get(n)
GET(/*?*/ &N);
// 368 p_vd size = p_vd size + n %if diags = full; ! header+local idents
if (DIAGS != 2) goto L_0010;
P->VDSIZE = P->VDSIZE + N;
L_0010:;
// 369 get(n); p_static frame <- n
GET(/*?*/ &N);
P->STATICFRAME = (int)(N);
// 370 p_display reg = next symbol; skip symbol; ! avoid any limited 'read symbol'
P->DISPLAYREG = _imp_NEXTSYMBOL();
_imp_SKIPSYMBOL();
// 371 get(n); p_event mask <- n
GET(/*?*/ &N);
P->EVENTMASK = (int)(N);
// 372 get(n); p_event start = n; ! tag no
GET(/*?*/ &N);
P->EVENTSTART = N;
// 373 get(n); p_event finish = n; ! tag no
GET(/*?*/ &N);
P->EVENTFINISH = N;
// 374 depth = depth-1; %return %if depth = 0
DEPTH = DEPTH - 1;
if (DEPTH != 0) goto L_0011;
return;
L_0011:;
// 375 p_ca = ca+2; ! size + basic event header
P->CA = CA + 2;
// 376 p_ca = p_ca+3 %if p_event mask # 0; ! full form required
if (P->EVENTMASK == 0) goto L_0012;
P->CA = P->CA + 3;
L_0012:;
// 377 ca total = ca total + ca
CATOTAL = CATOTAL + CA;
// 378 ! *** reverse reference list - should grow it forwards ***
// 379 %if %not r == null %start
if (_imp_ADDR((void *)(R)) == _imp_ADDR((void *)(NULL))) goto L_0013;
// 380 n = last ref; last ref = 0
N = LASTREF;
LASTREF = 0;
// 381 %while n # 0 %cycle
L_0014:;
if (N == 0) goto L_0015;
// 382 r == ref(n)
R = (struct REFFM *)/*?*/ &REF[N - 1];
// 383 k = r_link; r_link = last ref
K = R->LINK;
R->LINK = LASTREF;
// 384 last ref = n
LASTREF = N;
// 385 n = k
N = K;
// 386 %repeat
goto L_0014;
L_0015:;
// 387 %finish
L_0013:;
// 388 p_ref list == r
P->REFLIST = (struct PROCFM *)R;
// 389 last proc_link == p; last proc == p
LASTPROC->LINK = (struct PROCFM *)P;
LASTPROC = (struct PROCFM *)P;
// 390 %return
return;
// 391
// 392 dir(tag defn): ! <tag no> <ca> *N.B. switch defns. have x'8000' bit set*
case_DIR_1:;
// 393 get(j); get(ca)
GET(/*?*/ &J);
GET(/*?*/ &CA);
// 394 n = j&x'7FFF'; ! mask out 'switch' bit
N = J & 32767;
// 395 error(3,n) %unless 0 < n <= max tag
{
// Double-sided test on N (Part I)
int tmp;
if (0 >= (tmp = N)) goto L_0016;
// Double-sided test on N (Part II)
if (tmp <= 2050) goto L_0017;
}
L_0016:;
ERROR(3, N);
L_0017:;
// 396 d == tag def(n)
D = (struct DEFFM *)/*?*/ &TAGDEF[N - 1];
// 397 %if %not d_link == null %start; ! already defined
if (_imp_ADDR((void *)(D->LINK)) == _imp_ADDR((void *)(NULL))) goto L_0018;
// 398 error(4,n) %if j&x'8000' = 0; ! not a switch tag so it's an error
if (J & 32768 != 0) goto L_0019;
ERROR(4, N);
L_0019:;
// 399 ! remove existing entry so it can be redefined
// 400 %if %not p_def list == d %start
if (_imp_ADDR((void *)(P->DEFLIST)) == _imp_ADDR((void *)(D))) goto L_001A;
// 401 dd == p_def list
DD = (struct DEFFM *)P->DEFLIST;
// 402 dd == dd_link %while %not dd_link == d
L_001B:;
if (_imp_ADDR((void *)(DD->LINK)) == _imp_ADDR((void *)(D))) goto L_001C;
DD = (struct DEFFM *)DD->LINK;
goto L_001B;
L_001C:;
// 403 dd_link == d_link
DD->LINK = (struct DEFFM *)D->LINK;
// 404 %else
goto L_001D;
L_001A:;
// 405 p_def list == d_link
P->DEFLIST = (struct PROCFM *)D->LINK;
// 406 %finish
L_001D:;
// 407 %finish
L_0018:;
// 408 d_proc = this proc; d_ca = ca
D->PROC = THISPROC;
D->CA = CA;
// 409 d_link == p_def list
D->LINK = (struct DEFFM *)P->DEFLIST;
// 410 p_def list == d
P->DEFLIST = (struct PROCFM *)D;
// 411 %continue
goto L_0003;
// 412
// 413 dir(r ref): ! <n> <ca>
case_DIR_2:;
// 414 code = r call + long; -> ref ref
CODE = 64 + 2;
goto U_1000;
// 415 dir(j ref):
case_DIR_5:;
// 416 code = short; -> ref ref
CODE = 1;
goto U_1000;
// 417 dir(c ref):
case_DIR_6:;
// 418 code = short + conditional
CODE = 1 + 256;
// 419 ref ref:
U_1000:;
// 420 get(n); get(ca)
GET(/*?*/ &N);
GET(/*?*/ &CA);
// 421 error(5,n) %unless 0 < n <= max tag
{
// Double-sided test on N (Part I)
int tmp;
if (0 >= (tmp = N)) goto L_001E;
// Double-sided test on N (Part II)
if (tmp <= 2050) goto L_001F;
}
L_001E:;
ERROR(5, N);
L_001F:;
// 422 error(6,n) %if refs = max ref
if (REFS != 2900) goto L_0020;
ERROR(6, N);
L_0020:;
// 423 refs = refs+1
REFS = REFS + 1;
// 424 r == ref(refs)
R = (struct REFFM *)/*?*/ &REF[REFS - 1];
// 425 r_link = last ref; last ref = refs
R->LINK = LASTREF;
LASTREF = REFS;
// 426 r_tag = n
R->TAG = N;
// 427 r_ca = ca
R->CA = CA;
// 428 r_flags = code
R->FLAGS = CODE;
// 429 %continue
goto L_0003;
// 430
// 431 dir(sw ref): ! <n> <ca> * * * IGNORED * * *
case_DIR_4:;
// 432 get(n); get(ca)
GET(/*?*/ &N);
GET(/*?*/ &CA);
// 433 %continue
goto L_0003;
// 434
// 435 dir(p ref): ! <n> <ca>
case_DIR_3:;
// 436 get(n); get(ca)
GET(/*?*/ &N);
GET(/*?*/ &CA);
// 437 prim entry(n) = -2
PRIMENTRY[N - 1] = -2;
// 438 %continue
goto L_0003;
// 439
// 440 dir(line reset):
case_DIR_10:;
// 441 get(n); current line = n-1
GET(/*?*/ &N);
CURRENTLINE = N - 1;
// 442 dir(line diag):
case_DIR_9:;
// 443 current line = current line+1
CURRENTLINE = CURRENTLINE + 1;
// 444 %if diags = full %start
if (DIAGS != 2) goto L_0021;
// 445 p_ld size = p_ld size + 1
P->LDSIZE = P->LDSIZE + 1;
// 446 p_ld size = p_ld size + 1 %unless %c
{
// Double-sided test on CURRENTLINE - LASTLINE (Part I)
int tmp;
if (0 > (tmp = CURRENTLINE - LASTLINE)) goto L_0022;
// Double-sided test on CURRENTLINE - LASTLINE (Part II)
if (tmp <= 31) goto L_0023;
}
L_0022:;
P->LDSIZE = P->LDSIZE + 1;
L_0023:;
// 447+ 0 <= current line-last line <= line diag limit
// 448 %finish
L_0021:;
// 449 last line = current line
LASTLINE = CURRENTLINE;
// 450 %continue
goto L_0003;
// 451
// 452 %repeat
L_0003:;
goto L_000C;
// 453
// 454 %end; ! input directives
case_DIR_dispatch:
if (DIR_index < 1 || DIR_index > 21)
_imp_signalf(6, 3, DIR_index, "->DIR(%d) out of bounds at %s line %d", DIR_index, DIR_file, DIR_line);
goto *DIR[DIR_index - 1];
case_DIR_missing:
_imp_signalf(8, 2, DIR_index, "switch jump to undefined label DIR(%d): at %s line %d", DIR_index, DIR_file,
DIR_line);
} /* end of INPUTDIRECTIVES */
// 455
// 456 %routine set prim(%integer n)
void SETPRIM(int N) {
// 457 %integer a,j,k,base,to
int A;
int J;
int K;
int BASE;
int TO;
// 458 error(9,n) %unless 0 < n <= max prim
{
// Double-sided test on N (Part I)
int tmp;
if (0 >= (tmp = N)) goto L_0024;
// Double-sided test on N (Part II)
if (tmp <= 52) goto L_0025;
}
L_0024:;
ERROR(9, N);
L_0025:;
// 459 %return %if prim entry(n) >= 0
if (PRIMENTRY[N - 1] < 0) goto L_0026;
return;
L_0026:;
// 460 base = proc1_ca; ! current size of prim package
BASE = PROC1->CA;
// 461 j = prim(n); ! entry to pointer table
J = PRIM[N - 1];
// 462 k = prim(j); ! size of this prim routine
K = PRIM[J - 1];
// 463 %if k&x'8000' # 0 %start; ! routine to be full-word aligned
if (K & 32768 == 0) goto L_0027;
// 464 base = (base+1)&(\1)
BASE = BASE + 1 & (~1);
// 465 %finish
L_0027:;
// 466 k = k & x'7FFF'; ! strip 'align' bit
K = K & 32767;
// 467 prim entry(n) = base
PRIMENTRY[N - 1] = BASE;
// 468 proc1_ca = base + k*(2//2); ! halfwords
PROC1->CA = BASE + K * (((long)2 / (long)2));
// 469 to = j+k; ! N.B. j+1:to inclusive
TO = J + K;
// 470 %while j # to %cycle
L_0028:;
if (J == TO) goto L_0029;
// 471 j = j+1; a = prim(j)&x'FFFF'
J = J + 1;
A = PRIM[J - 1] & 65535;
// 472 %if a&x'FFF0' = emark %and a # tmark %start
if (A & 65520 != 34944) goto L_002A;
if (A == 34951) goto L_002A;
// 473 j = j+1; a = prim(j)
J = J + 1;
A = PRIM[J - 1];
// 474 set prim(a) %if prim entry(a) < 0
if (PRIMENTRY[A - 1] >= 0) goto L_002B;
SETPRIM(A);
L_002B:;
// 475 %finish
L_002A:;
// 476 %repeat
goto L_0028;
L_0029:;
// 477 %end; ! set prim
return;
} /* end of SETPRIM */
// 478
// 479 %routine local stretch(%record(procfm)%name p)
void LOCALSTRETCH(struct PROCFM * P) {
// 480 %record(deffm)%name d,dd
struct DEFFM *D;
struct DEFFM *DD;
// 481 %record(reffm)%name r
struct REFFM *R;
// 482 %integer j,n,mod
int J;
int N;
int MOD;
// 483 %return %if p_ref list == null; ! no references !!
if (_imp_ADDR((void *)(P->REFLIST)) != _imp_ADDR((void *)(NULL))) goto L_002C;
return;
L_002C:;
// 484 %cycle
L_002D:;
// 485 n = 0; mod = 0
N = 0;
MOD = 0;
// 486 r == p_ref list
R = (struct REFFM *)P->REFLIST;
// 487 %cycle
L_002E:;
// 488 local tot = local tot+1; ! *** monitoring only ***
LOCALTOT = LOCALTOT + 1;
// 489 r_ca = r_ca + mod
R->CA = R->CA + MOD;
// 490 %if r_flags&(long!rcall!safe) = 0 %start
if (R->FLAGS & (2 | 64 | 128) != 0) goto L_002F;
// 491 local nonsafe = local nonsafe+1; ! *** monitoring only ***
LOCALNONSAFE = LOCALNONSAFE + 1;
// 492 d == tagdef(r_tag)
D = (struct DEFFM *)/*?*/ &TAGDEF[R->TAG - 1];
// 493 j = r_ca
J = R->CA;
// 494 %unless j-30//2 <= d_ca <= j+30//2 %start
{
// Double-sided test on D->CA (Part I)
int tmp;
if (J - ((long)30 / (long)2) > (tmp = D->CA)) goto L_0030;
// Double-sided test on D->CA (Part II)
if (tmp <= J + ((long)30 / (long)2)) goto L_0031;
}
L_0030:;
// 495 n = 1; mod = mod + (2//2)
N = 1;
MOD = MOD + ((long)2 / (long)2);
// 496 p_ca = p_ca + (2//2)
P->CA = P->CA + ((long)2 / (long)2);
// 497 r_flags = r_flags ! long
R->FLAGS = R->FLAGS | 2;
// 498 %if j+2-16384//2 <= d_ca <= j+2+16384//2-1 %start
{
// Double-sided test on D->CA (Part I)
int tmp;
if (J + 2 - ((long)16384 / (long)2) > (tmp = D->CA)) goto L_0032;
// Double-sided test on D->CA (Part II)
if (tmp > J + 2 + ((long)16384 / (long)2) - 1) goto L_0032;
}
// 499 r_flags = r_flags ! pc rel
R->FLAGS = R->FLAGS | 4;
// 500 r_flags = r_flags ! safe %if |(j-d_ca)| <= safe pc rel
if (_imp_IMOD(J - D->CA) > 6500) goto L_0033;
R->FLAGS = R->FLAGS | 128;
L_0033:;
// 501 %finish
L_0032:;
// 502 dd == p_def list
DD = (struct DEFFM *)P->DEFLIST;
// 503 %cycle
L_0034:;
// 504 %exit %if dd == null %or dd_ca <= r_ca
if (_imp_ADDR((void *)(DD)) == _imp_ADDR((void *)(NULL))) goto L_0035;
if (DD->CA > R->CA) goto L_0036;
L_0035:;
goto L_0037;
L_0036:;
// 505 dd_ca = dd_ca+(2//2)
DD->CA = DD->CA + ((long)2 / (long)2);
// 506 dd == dd_link
DD = (struct DEFFM *)DD->LINK;
// 507 %repeat
goto L_0034;
L_0037:;
// 508 %finish
L_0031:;
// 509 %finish
L_002F:;
// 510 %exit %if r_link = 0
if (R->LINK != 0) goto L_0038;
goto L_0039;
L_0038:;
// 511 r == ref(r_link)
R = (struct REFFM *)/*?*/ &REF[R->LINK - 1];
// 512 %repeat
goto L_002E;
L_0039:;
// 513 %exit %if n = 0
if (N != 0) goto L_003A;
goto L_003B;
L_003A:;
// 514 %repeat
goto L_002D;
L_003B:;
// 515 %end; ! local stretch
return;
} /* end of LOCALSTRETCH */
// 516
// 517 %routine global stretch(%record(procfm)%name p, %integername extra)
void GLOBALSTRETCH(struct PROCFM * P, int *EXTRA) {
// 518 %record(procfm)%name pp
struct PROCFM *PP;
// 519 %record(deffm)%name d,dd
struct DEFFM *D;
struct DEFFM *DD;
// 520 %record(reffm)%name r
struct REFFM *R;
// 521 %integer j,k,x,n,mod,me
int J;
int K;
int X;
int N;
int MOD;
int ME;
// 522 extra = 0 %and %return %if p_ref list == null
if (_imp_ADDR((void *)(P->REFLIST)) != _imp_ADDR((void *)(NULL))) goto L_003C;
*EXTRA = 0;
return;
L_003C:;
// 523 x = 0
X = 0;
// 524 %cycle
L_003D:;
// 525 n = 0; mod = 0
N = 0;
MOD = 0;
// 526 r == p_ref list; Me = P_Me
R = (struct REFFM *)P->REFLIST;
ME = P->ME;
// 527 %cycle
L_003E:;
// 528 global tot = global tot+1; ! *** monitoring only ***
GLOBALTOT = GLOBALTOT + 1;
// 529 r_ca = r_ca + mod
R->CA = R->CA + MOD;
// 530 %if r_flags&(safe!very) = 0 %start
if (R->FLAGS & (128 | 8) != 0) goto L_003F;
// 531 global nonsafe = global nonsafe+1; ! *** monitoring only ***
GLOBALNONSAFE = GLOBALNONSAFE + 1;
// 532 d == tagdef(r_tag)
D = (struct DEFFM *)/*?*/ &TAGDEF[R->TAG - 1];
// 533 j = p_base + r_ca
J = P->BASE + R->CA;
// 534 ! ****** This wants cleaning up ******
// 535 %if D_Proc # Me %or R_Flags&rcall # 0 %start
if (D->PROC != ME) goto L_0040;
if (R->FLAGS & 64 == 0) goto L_0041;
L_0040:;
// 536 k = proc(d_proc)_base + d_ca
K = PROC[D->PROC - 1].BASE + D->CA;
// 537 %if j+2-16384//2 <= k <= j+2+16384//2-1 %start
{
// Double-sided test on K (Part I)
int tmp;
if (J + 2 - ((long)16384 / (long)2) > (tmp = K)) goto L_0042;
// Double-sided test on K (Part II)
if (tmp > J + 2 + ((long)16384 / (long)2) - 1) goto L_0042;
}
// 538 r_flags = r_flags ! pc rel
R->FLAGS = R->FLAGS | 4;
// 539 r_flags = r_flags ! safe %if |(j-k)| <= safe pc rel
if (_imp_IMOD(J - K) > 6500) goto L_0043;
R->FLAGS = R->FLAGS | 128;
L_0043:;
// 540 -> NEXT %if R_Flags&Long # 0
if (R->FLAGS & 2 == 0) goto L_0044;
goto U_1001;
L_0044:;
// 541 %finish
L_0042:;
// 542 %else
goto L_0045;
L_0041:;
// 543 k = p_base + d_ca
K = P->BASE + D->CA;
// 544 %finish
L_0045:;
// 545 -> NEXT %if j-30//2 <= k <= j+30//2; ! short form adequate
{
// Double-sided test on K (Part I)
int tmp;
if (J - ((long)30 / (long)2) > (tmp = K)) goto L_0046;
// Double-sided test on K (Part II)
if (tmp > J + ((long)30 / (long)2)) goto L_0046;
}
goto U_1001;
L_0046:;
// 546 %if r_flags&long = 0 %start
if (R->FLAGS & 2 != 0) goto L_0047;
// 547 r_flags = r_flags ! long
R->FLAGS = R->FLAGS | 2;
// 548 %if j+2-16384//2 <= k <= j+2+16384//2-1 %start
{
// Double-sided test on K (Part I)
int tmp;
if (J + 2 - ((long)16384 / (long)2) > (tmp = K)) goto L_0048;
// Double-sided test on K (Part II)
if (tmp > J + 2 + ((long)16384 / (long)2) - 1) goto L_0048;
}
// 549 r_flags = r_flags ! pc rel
R->FLAGS = R->FLAGS | 4;
// 550 r_flags = r_flags ! safe %if |(j-k)| <= safe pc rel
if (_imp_IMOD(J - K) > 6500) goto L_0049;
R->FLAGS = R->FLAGS | 128;
L_0049:;
// 551 %finish
L_0048:;
// 552 %else %if (r_flags & pc rel = 0 %and %not 0 <= k <= 16383//2) %c
goto L_004A;
L_0047:;
if (R->FLAGS & 4 != 0) goto L_004B;
{
// Double-sided test on K (Part I)
int tmp;
if (0 > (tmp = K)) goto L_004C;
// Double-sided test on K (Part II)
if (tmp > ((long)16383 / (long)2)) goto L_004C;
}
L_004B:;
if (R->FLAGS & 4 == 0) goto L_004D;
{
// Double-sided test on K (Part I)
int tmp;
if (J + 2 - ((long)16384 / (long)2) > (tmp = K)) goto L_004C;
// Double-sided test on K (Part II)
if (tmp <= J + 2 + ((long)16384 / (long)2) - 1) goto L_004D;
}
L_004C:;
// 553+ %or (r_flags & pc rel # 0 %c
// 554+ %and %not j+2-16384//2 <= k <= j+2+16384//2-1)
// 555 %if 0 <= k <= 16383//2 %start
{
// Double-sided test on K (Part I)
int tmp;
if (0 > (tmp = K)) goto L_004E;
// Double-sided test on K (Part II)
if (tmp > ((long)16383 / (long)2)) goto L_004E;
}
// 556 r_flags = r_flags & (\pc rel)
R->FLAGS = R->FLAGS & (~4);
// 557 -> NEXT
goto U_1001;
// 558 %finish
L_004E:;
// 559 r_flags = r_flags ! very
R->FLAGS = R->FLAGS | 8;
// 560 %else
goto L_004A;
L_004D:;
// 561 -> NEXT
goto U_1001;
// 562 %finish
L_004A:;
// 563 !************************************
// 564 n = 1; x = x+(2//2); mod = mod+(2//2)
N = 1;
X = X + ((long)2 / (long)2);
MOD = MOD + ((long)2 / (long)2);
// 565 p_ca = p_ca + (2//2)
P->CA = P->CA + ((long)2 / (long)2);
// 566 dd == p_def list
DD = (struct DEFFM *)P->DEFLIST;
// 567 %cycle
L_004F:;
// 568 %exit %if dd_ca <= r_ca
if (DD->CA > R->CA) goto L_0050;
goto L_0051;
L_0050:;
// 569 dd_ca = dd_ca + (2//2)
DD->CA = DD->CA + ((long)2 / (long)2);
// 570 dd == dd_link
DD = (struct DEFFM *)DD->LINK;
// 571 %repeat
goto L_004F;
L_0051:;
// 572 pp == p
PP = (struct PROCFM *)P;
// 573 %cycle
L_0052:;
// 574 pp == pp_link; %exit %if pp == null
PP = (struct PROCFM *)PP->LINK;
if (_imp_ADDR((void *)(PP)) != _imp_ADDR((void *)(NULL))) goto L_0053;
goto L_0054;
L_0053:;
// 575 pp_base = pp_base+(2//2)
PP->BASE = PP->BASE + ((long)2 / (long)2);
// 576 %repeat
goto L_0052;
L_0054:;
// 577 %finish
L_003F:;
// 578 NEXT:
U_1001:;
// 579 %exit %if r_link = 0
if (R->LINK != 0) goto L_0055;
goto L_0056;
L_0055:;
// 580 r == ref(r_link)
R = (struct REFFM *)/*?*/ &REF[R->LINK - 1];
// 581 %repeat
goto L_003E;
L_0056:;
// 582 %exit %if n = 0
if (N != 0) goto L_0057;
goto L_0058;
L_0057:;
// 583 %repeat
goto L_003D;
L_0058:;
// 584 extra = x
*EXTRA = X;
// 585 %end; ! global stretch
return;
} /* end of GLOBALSTRETCH */
// 586
// 587 %routine condense
void CONDENSE(void) {
// 588 %constbyteintegerarray m(0:15) =
const unsigned char M[16] = {1, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
// 589+ SF, SF,
// 590+ ! 0 1
// 591+ RX1, RX1,
// 592+ ! 2 3
// 593+ RX2, RX2, RX2, RX2,
// 594+ ! 4 5 6 7
// 595+ RX3, RX3, RX3, RX3, RX3, RX3, RX3, RX3
// 596 ! 8 9 10 11 12 13 14 15
// 597 %integer j,f
int J;
int F;
// 598 %for j = 1,1,refs %cycle
// %for J = 1, 1, REFS %cycle
{
int _final = REFS;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, REFS");
J = 0;
L_0059:
if (J == _final) goto L_005A;
J += 1;
// 599 f = ref(j)_flags
F = REF[J - 1].FLAGS;
// 600 %if f&remove # 0 %start
if (F & 32 == 0) goto L_005C;
// 601 reftype(j) = 0
REFTYPE[J - 1] = 0;
// 602 %else
goto L_005D;
L_005C:;
// 603 reftype(j) = m(f&15) ! ( f & (invert+rcall) )
REFTYPE[J - 1] = M[F & 15] | F & 16 + 64;
// 604 %finish
L_005D:;
// 605 %repeat
goto L_0059;
}
L_005A:;
// 606 %if diagnostic < 0 %start
if (0 >= 0) goto L_005E;
// 607 %for j = 1,1,refs %cycle
// %for J = 1, 1, REFS %cycle
{
int _final = REFS;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, REFS");
J = 0;
L_005F:
if (J == _final) goto L_0060;
J += 1;
// 608 %if (j-1)&15 = 0 %start
if (J - 1 & 15 != 0) goto L_0062;
// 609 newline; write(j,-4); print string(": ")
_imp_NEWLINE();
_imp_WRITE(J, -4);
_imp_PRINTSTRING(_imp_str_literal(": "));
// 610 %finish
L_0062:;
// 611 write(reftype(j),2)
_imp_WRITE(REFTYPE[J - 1], 2);
// 612 %repeat
goto L_005F;
}
L_0060:;
// 613 newlines(2)
_imp_NEWLINES(2);
// 614 %finish
L_005E:;
// 615 %end; ! condense
return;
} /* end of CONDENSE */
// 616
// 617 ! === for diagnostics only ===
// 618 %routine dump tags
void DUMPTAGS(void) {
// 619 %integer k
int K;
// 620 %integerfn tagno(%record(deffm)%name d)
int TAGNO(struct DEFFM * D) {
// 621 %integer k
int K;
// 622 %for k = 1,1,max tag %cycle
// %for K = 1, 1, 2050 %cycle
{
K = 0;
L_0063:
if (K == 2050) goto L_0064;
K += 1;
// 623 %result = k %if tagdef(k) == d
if (_imp_ADDR((void *)(/*?*/ &TAGDEF[K - 1])) != _imp_ADDR((void *)(D))) goto L_0065;
return K;
L_0065:;
// 624 %repeat
goto L_0063;
}
L_0064:;
// 625 %signal 15,15
_imp_signal(15, 15, 0, "");
// 626 %end
_imp_signal(8, 4, 0, "result missing");
} /* end of TAGNO */
// 627 %routine dump proc(%integer n)
void DUMPPROC(int N) {
// 628 %record(procfm)%name p
struct PROCFM *P;
// 629 %record(deffm)%Name d
struct DEFFM *D;
// 630 %integer k; k = 0
int K;
K = 0;
// 631 p == proc(n)
P = (struct PROCFM *)/*?*/ &PROC[N - 1];
// 632 print string(" base"); write(p_base,1)
_imp_PRINTSTRING(_imp_str_literal(" base"));
_imp_WRITE(P->BASE, 1);
// 633 print string(" size"); write(p_ca,1)
_imp_PRINTSTRING(_imp_str_literal(" size"));
_imp_WRITE(P->CA, 1);
// 634 newline
_imp_NEWLINE();
// 635 d == p_deflist
D = (struct DEFFM *)P->DEFLIST;
// 636 %while %not d == null %cycle
L_0066:;
if (_imp_ADDR((void *)(D)) == _imp_ADDR((void *)(NULL))) goto L_0067;
// 637 write(tagno(d),3); print symbol(':')
_imp_WRITE(TAGNO(D), 3);
_imp_PRINTSYMBOL(58);
// 638 write(d_ca,0)
_imp_WRITE(D->CA, 0);
// 639 k = k+1
K = K + 1;
// 640 newline %if k&7 = 0
if (K & 7 != 0) goto L_0068;
_imp_NEWLINE();
L_0068:;
// 641 d == d_link
D = (struct DEFFM *)D->LINK;
// 642 %repeat
goto L_0066;
L_0067:;
// 643 newline %if k&7 # 0
if (K & 7 == 0) goto L_0069;
_imp_NEWLINE();
L_0069:;
// 644 %end
return;
} /* end of DUMPPROC */
// 645 %for k = 1,1,procs %cycle
// %for K = 1, 1, PROCS %cycle
{
int _final = PROCS;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle K = 1, 1, PROCS");
K = 0;
L_006A:
if (K == _final) goto L_006B;
K += 1;
// 646 newline; print string("proc"); write(k,1)
_imp_NEWLINE();
_imp_PRINTSTRING(_imp_str_literal("proc"));
_imp_WRITE(K, 1);
// 647 dump proc(k)
DUMPPROC(K);
// 648 %repeat
goto L_006A;
}
L_006B:;
// 649 %end; ! dump tags
return;
} /* end of DUMPTAGS */
// 650
// 651 select input(direct)
_imp_SELECTINPUT(1);
// 652 current line = 0
CURRENTLINE = 0;
// 653 input directives
INPUTDIRECTIVES();
// 654 last proc_link == null
LASTPROC->LINK = (struct PROCFM *)NULL;
// 655 readsymbol(j)
_imp_READSYMBOL(/*?*/ &J);
// 656 error(-1, j) %unless j = prog end
if (J == 18) goto L_006C;
ERROR(-1, J);
L_006C:;
// 657 ! read next six halfwords defining various sizes for last block:
// 658 ! <code size> <literal size> <gla size> <defns> <specs> <relocations>
// 659 !===== size in halfwords
// 660 get(code size); get(literal size); get(gla size)
GET(/*?*/ &CODESIZE);
GET(/*?*/ &LITERALSIZE);
GET(/*?*/ &GLASIZE);
// 661 !===== no. of items
// 662 get(defns); get(specs); get(relocations)
GET(/*?*/ &DEFNS);
GET(/*?*/ &SPECS);
GET(/*?*/ &RELOCATIONS);
// 663 error(8,ca total) %if code size # ca total
if (CODESIZE == CATOTAL) goto L_006D;
ERROR(8, CATOTAL);
L_006D:;
// 664
// 665 %for j = 1,1,max prim %cycle
// %for J = 1, 1, 52 %cycle
{
J = 0;
L_006E:
if (J == 52) goto L_006F;
J += 1;
// 666 set prim(j) %if prim entry(j) = -2
if (PRIMENTRY[J - 1] != -2) goto L_0070;
SETPRIM(J);
L_0070:;
// 667 %repeat
goto L_006E;
}
L_006F:;
// 668 proc1_ca = proc1_ca+2; !event marker+link
PROC1->CA = PROC1->CA + 2;
// 669
// 670 dump tags %if diagnostic < 0
if (0 >= 0) goto L_0071;
DUMPTAGS();
L_0071:;
// 671
// 672 t10 = cpu time; ! *** monitoring only ***
T10 = _imp_CPUTIME();
// 673
// 674 ! Initial stretching and block allocation
// 675 ! no diags in perm == proc1
// 676 !!! proc1_ld size = 0
// 677 !!! proc1_vd size = 0
// 678 pp == proc1
PP = (struct PROCFM *)PROC1;
// 679 %cycle
L_0072:;
// 680 qq == pp_link; %exit %if qq == null
QQ = (struct PROCFM *)PP->LINK;
if (_imp_ADDR((void *)(QQ)) != _imp_ADDR((void *)(NULL))) goto L_0073;
goto L_0074;
L_0073:;
// 681 local stretch(qq)
LOCALSTRETCH(QQ);
// 682 qq_base = qq_base + pp_base + pp_ca
QQ->BASE = QQ->BASE + PP->BASE + PP->CA;
// 683 qq_ld base = pp_ld base + pp_ld size
QQ->LDBASE = PP->LDBASE + PP->LDSIZE;
// 684 qq_vd base = pp_vd base + pp_vd size
QQ->VDBASE = PP->VDBASE + PP->VDSIZE;
// 685 pp == qq
PP = (struct PROCFM *)QQ;
// 686 %repeat
goto L_0072;
L_0074:;
// 687
// 688 dump tags %if diagnostic < 0
if (0 >= 0) goto L_0075;
DUMPTAGS();
L_0075:;
// 689
// 690 t11 = cpu time; ! *** monitoring only ***
T11 = _imp_CPUTIME();
// 691
// 692 ! Routine calls and final stretch
// 693 %cycle
L_0076:;
// 694 n = 0
N = 0;
// 695 pp == proc1
PP = (struct PROCFM *)PROC1;
// 696 %cycle
L_0077:;
// 697 pp == pp_link; %exit %if pp == null
PP = (struct PROCFM *)PP->LINK;
if (_imp_ADDR((void *)(PP)) != _imp_ADDR((void *)(NULL))) goto L_0078;
goto L_0079;
L_0078:;
// 698 global stretch(pp,extra)
GLOBALSTRETCH(PP, /*?*/ &EXTRA);
// 699 %if extra # 0 %start
if (EXTRA == 0) goto L_007A;
// 700 n = n+1
N = N + 1;
// 701 pp_ca = pp_ca + extra
PP->CA = PP->CA + EXTRA;
// 702 qq == pp
QQ = (struct PROCFM *)PP;
// 703 %cycle
L_007B:;
// 704 qq == qq_link; %exit %if qq == null
QQ = (struct PROCFM *)QQ->LINK;
if (_imp_ADDR((void *)(QQ)) != _imp_ADDR((void *)(NULL))) goto L_007C;
goto L_007D;
L_007C:;
// 705 qq_base = qq_base + extra
QQ->BASE = QQ->BASE + EXTRA;
// 706 %repeat
goto L_007B;
L_007D:;
// 707 %finish
L_007A:;
// 708 %repeat
goto L_0077;
L_0079:;
// 709 %exit %if n = 0
if (N != 0) goto L_007E;
goto L_007F;
L_007E:;
// 710 %repeat
goto L_0076;
L_007F:;
// 711
// 712 dump tags %if diagnostic < 0
if (0 >= 0) goto L_0080;
DUMPTAGS();
L_0080:;
// 713
// 714 t12 = cputime; ! *** monitoring only ***
T12 = _imp_CPUTIME();
// 715
// 716 condense; ! from ref(k)_flags -> reftype(k)
CONDENSE();
// 717
// 718 line diags = last proc_ld base + last proc_ld size
LINEDIAGS = LASTPROC->LDBASE + LASTPROC->LDSIZE;
// 719 var diags = last proc_vd base + last proc_vd size
VARDIAGS = LASTPROC->VDBASE + LASTPROC->VDSIZE;
// 720 code size = last proc_base + last proc_ca
CODESIZE = LASTPROC->BASE + LASTPROC->CA;
// 721
// 722 %end; ! phase one
return;
} /* end of PHASEONE */
// 723
// 724 %routine phase two
void PHASETWO(void) {
// 725 ! generate final object file using 'tag defn' and 'ref type' tables
// 726 %recordformat bfm(%record(bfm)%name link, %integer block, %c
struct BFM {
union {
struct {
struct BFM *LINK;
int BLOCK;
short int B[256];
};
};
};
// 727+ %shortintegerarray b(0:255))
// 728 %recordformat sfm(%integer zero addr, lower, upper, ca)
struct SFM {
union {
struct {
int ZEROADDR;
int LOWER;
int UPPER;
int CA;
};
};
};
// 729 %record(sfm) code, gla, ldiag, vdiag, reloc, defn, spec
struct SFM CODE;
struct SFM GLA;
struct SFM LDIAG;
struct SFM VDIAG;
struct SFM RELOC;
struct SFM DEFN;
struct SFM SPEC;
// 730 %constinteger bmax = 8; ! no. of da buffers (at least 2 !!)
// 731 %record(bfm)%array buffpool(1:bmax)
struct BFM BUFFPOOL[8];
// 732 %record(bfm)%name buff list, bp
struct BFM *BUFFLIST;
struct BFM *BP;
// 733
// 734 %recordformat hdfm(%shortinteger p1,p2)
struct HDFM {
union {
struct {
short int P1;
short int P2;
};
};
};
// 735 %recordformat headerfm(%shortinteger pure size,gla size, code disp, %c
struct HEADERFM {
union {
struct {
short int PURESIZE;
short int GLASIZE;
short int CODEDISP;
short int LITDISP;
short int REGISTERS;
short int MAINEP;
struct HDFM RELOC;
struct HDFM DEFN;
struct HDFM SPEC;
struct HDFM LDIAG;
struct HDFM VDIAG;
};
};
};
// 736+ lit disp, registers, main ep, %c
// 737+ %record(hdfm) reloc, defn, spec, ldiag, vdiag)
// 738 %record(headerfm) header; %constinteger basic header=18; ! ** halfwords **
struct HEADERFM HEADER;
// 739
// 740 ! formats associated with external linkage
// 741 %recordformat namefm(%shortinteger n1a,n1b,n2a,n2b)
struct NAMEFM {
union {
struct {
short int N1A;
short int N1B;
short int N2A;
short int N2B;
};
};
};
// 742 %recordformat xdeffm(%record(namefm) n, %integer ep)
struct XDEFFM {
union {
struct {
struct NAMEFM N;
int EP;
};
};
};
// 743 %recordformat specfm(%integer code, gla, link)
struct SPECFM {
union {
struct {
int CODE;
int GLA;
int LINK;
};
};
};
// 744 %recordformat descriptionfm(%integer base,disp,type,size,form,otype, %c
struct DESCRIPTIONFM {
union {
struct {
int BASE;
int DISP;
int TYPE;
int SIZE;
int FORM;
int OTYPE;
int DATASIZE;
short int IDENTLEN;
_imp_string12 SYM;
};
};
};
// 745+ data size, %shortinteger ident len, %string(12) sym)
// 746 %record(descriptionfm) xd
struct DESCRIPTIONFM XD;
// 747
// 748 %integer this proc; this proc = 0
int THISPROC;
THISPROC = 0;
// 749 %integer total blocks
int TOTALBLOCKS;
// 750 %integer op, cond, tag, extra
int OP;
int COND;
int TAG;
int EXTRA;
// 751 %integer ref; ref = 0
int REF;
REF = 0;
// 752 %integer event link, ldiag link, vdiag link, defn link, spec link, asynch link
int EVENTLINK;
int LDIAGLINK;
int VDIAGLINK;
int DEFNLINK;
int SPECLINK;
int ASYNCHLINK;
// 753 %integer trace patch = 0; ! point in perm to patch in jump to $TRACE
int TRACEPATCH;
TRACEPATCH = 0;
// 754 %integer j,k,l
int J;
int K;
int L;
// 755
// 756 ! =================== SYSTEM DEPENDENT =====================
// 757 %recordformat parmfm(%shortinteger dsno,dact,ssno,sact, %c
struct PARMFM {
union {
struct {
short int DSNO;
short int DACT;
short int SSNO;
short int SACT;
int P1;
int P2;
int P3;
int P4;
int P5;
int P6;
};
};
};
// 758+ %integer p1,p2,p3,p4,p5,p6)
// 759 %owninteger da key = 0
static int DAKEY = 0;
// 760 %constinteger da read = 9, da write = 10
// 761
// 762
// 763 %routine svc(%integer svc no, %record(parmfm) p)
void SVC(int SVCNO, struct PARMFM P) {
// 764 print string("Calling svc "); write(svc no, 0); newline
_imp_PRINTSTRING(_imp_str_literal("Calling svc "));
_imp_WRITE(SVCNO, 0);
_imp_NEWLINE();
// 765 %end
return;
} /* end of SVC */
// ?P unused
// 766
// 767 %routine open da(%string(31)%name fd, %integer blocks)
void OPENDA(_imp_string31 * FD, int BLOCKS) {
// 768 %record(parmfm) p,q
struct PARMFM P;
struct PARMFM Q;
// 769 string(addr(p_sact)) = fd; svc(17,p); ! pack
*_imp_STRING(_imp_ADDR(/*?*/ &P.SACT)) = *FD;
SVC(17, P);
// 770 %if p_p2 < 0 %start
if (P.P2 >= 0) goto L_0081;
// 771 print string(fd."?"); newline
_imp_PRINTSTRING(
*({
__typeof__(_imp_string255) tmp = **({
_imp_string255 tmp = _imp_join(({
__typeof__(_imp_string31) tmp; /*D*/
tmp = *FD;
(void *)&tmp;
}),
(_imp_string *)/*?*/ _imp_str_literal_ptr("?"));
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_NEWLINE();
// 772 %stop
_imp_stop(0);
// 773 %finish
L_0081:;
// 774 q = p
Q = P;
// 775 p_dact = 14; svc(20,p); ! delete
P.DACT = 14;
SVC(20, P);
// 776 p = q; p_p5 = blocks
P = Q;
P.P5 = BLOCKS;
// 777 p_dact = 2; svc(20,p); ! create
P.DACT = 2;
SVC(20, P);
// 778 %if p_p6 >= 0 %start
if (P.P6 < 0) goto L_0082;
// 779 p = q
P = Q;
// 780 p_p5 = 1; !permit write
P.P5 = 1;
// 781 p_dact = 6; svc(20,p); ! open da
P.DACT = 6;
SVC(20, P);
// 782 da key = p_p5 %and %return %if p_p6 >= 0
if (P.P6 < 0) goto L_0083;
DAKEY = P.P5;
return;
L_0083:;
// 783 %finish
L_0082:;
// 784 print string("open da: ".string(addr(p_p1))); newline
_imp_PRINTSTRING(
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("open da: "), ({
__typeof__(_imp_string255) tmp; /*E*/
tmp = *_imp_STRING(_imp_ADDR(/*?*/ &P.P1));
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_NEWLINE();
// 785 %stop
_imp_stop(0);
// 786 %end
} /* end of OPENDA */
// 787
// 788 %routine close da
void CLOSEDA(void) {
// 789 %record(parmfm) p
struct PARMFM P;
// 790 p_p5 = da key
P.P5 = DAKEY;
// 791 p_dact = 11; svc(20,p)
P.DACT = 11;
SVC(20, P);
// 792 da key = 0
DAKEY = 0;
// 793 %return %if p_p6 >= 0
if (P.P6 < 0) goto L_0084;
return;
L_0084:;
// 794 print string("close da: ".string(addr(p_p1))); newline
_imp_PRINTSTRING(
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("close da: "), ({
__typeof__(_imp_string255) tmp; /*E*/
tmp = *_imp_STRING(_imp_ADDR(/*?*/ &P.P1));
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_NEWLINE();
// 795 %stop
_imp_stop(0);
// 796 %end
} /* end of CLOSEDA */
// 797 %routine block io(%record(bfm)%name block, %integer iofn)
void BLOCKIO(struct BFM * BLOCK, int IOFN) {
// 798 %record(parmfm) p
struct PARMFM P;
// 799 p_p4 = addr(block_b(0))
P.P4 = _imp_ADDR(/*?*/ &BLOCK->B[0]);
// 800 p_p5 = da key
P.P5 = DAKEY;
// 801 p_p6 = block_block; ! block number req'd
P.P6 = BLOCK->BLOCK;
// 802 p_dact = iofn; svc(20,p)
P.DACT = IOFN;
SVC(20, P);
// 803 %return %if p_p6 >= 0
if (P.P6 < 0) goto L_0085;
return;
L_0085:;
// 804 print string("block io: ".string(addr(p_p1))); write(block_block,1)
_imp_PRINTSTRING(
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp = _imp_join((_imp_string *)/*?*/ _imp_str_literal_ptr("block io: "), ({
__typeof__(_imp_string255) tmp; /*E*/
tmp = *_imp_STRING(_imp_ADDR(/*?*/ &P.P1));
(void *)&tmp;
}));
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_WRITE(BLOCK->BLOCK, 1);
// 805 newline
_imp_NEWLINE();
// 806 %signal 15,15
_imp_signal(15, 15, 0, "");
// 807 %end
return;
} /* end of BLOCKIO */
// 808 ! ==========================================================
// 809
// 810 ! Initialise buffer pool
// 811 buff list == null
BUFFLIST = (struct BFM *)NULL;
// 812 %for j = 1,1,bmax %cycle
// %for J = 1, 1, 8 %cycle
{
J = 0;
L_0086:
if (J == 8) goto L_0087;
J += 1;
// 813 bp == buff list
BP = (struct BFM *)BUFFLIST;
// 814 buff list == buffpool(j)
BUFFLIST = (struct BFM *)/*?*/ &BUFFPOOL[J - 1];
// 815 buff list_block = -1; buff list_link == bp
BUFFLIST->BLOCK = -1;
BUFFLIST->LINK = (struct BFM *)BP;
// 816 %repeat
goto L_0086;
}
L_0087:;
// 817
// 818 ! Initialise control records
// 819 %routine set section(%record(sfm)%name sect, %integer sect size, %c
void SETSECTION(struct SFM * SECT, int SECTSIZE, struct HDFM *HD) {
// 820+ %record(hdfm)%name hd)
// 821 sect_zero addr = header size; header size = header size + sect size
SECT->ZEROADDR = HEADERSIZE;
HEADERSIZE = HEADERSIZE + SECTSIZE;
// 822 sect_lower = 0
SECT->LOWER = 0;
// 823 sect_upper = sect size
SECT->UPPER = SECTSIZE;
// 824 sect_ca = 0
SECT->CA = 0;
// 825 hd_p1 = sect_zero addr; hd_p2 = 0
HD->P1 = SECT->ZEROADDR;
HD->P2 = 0;
// 826 %end; ! set section
return;
} /* end of SETSECTION */
// 827
// 828
// 829 header size = basic header
HEADERSIZE = 18;
// 830 defns = defns*(3*2); ! 3 fullwords each
DEFNS = DEFNS * (3 * 2);
// 831 specs = specs*(2*2); ! 2 fullwords each
SPECS = SPECS * (2 * 2);
// 832 relocations = relocations*((2//2)); ! 1 halfword each
RELOCATIONS = RELOCATIONS * (((long)2 / (long)2));
// 833 literal size = (literal size + 3)&(\3); ! double word align
LITERALSIZE = LITERALSIZE + 3 & (~3);
// 834 code size = code size + proc1_ca; ! allow for prim
CODESIZE = CODESIZE + PROC1->CA;
// 835
// 836 ! N.B. == defn and spec are fullword aligned in output file ==
// 837 set section(defn,defns,header_defn)
SETSECTION(/*?*/ &DEFN, DEFNS, /*?*/ &HEADER.DEFN);
// 838 set section(spec,specs,header_spec)
SETSECTION(/*?*/ &SPEC, SPECS, /*?*/ &HEADER.SPEC);
// 839 set section(reloc,relocations,header_reloc)
SETSECTION(/*?*/ &RELOC, RELOCATIONS, /*?*/ &HEADER.RELOC);
// 840 set section(ldiag,line diags,header_ldiag)
SETSECTION(/*?*/ &LDIAG, LINEDIAGS, /*?*/ &HEADER.LDIAG);
// 841 set section(vdiag,var diags,header_vdiag)
SETSECTION(/*?*/ &VDIAG, VARDIAGS, /*?*/ &HEADER.VDIAG);
// 842
// 843 header size = (header size+3)&(\3); ! align literals + code
HEADERSIZE = HEADERSIZE + 3 & (~3);
// 844
// 845 code_zero addr = header size + literal size
CODE.ZEROADDR = HEADERSIZE + LITERALSIZE;
// 846 code_lower = -literal size
CODE.LOWER = -LITERALSIZE;
// 847 code_upper = code size
CODE.UPPER = CODESIZE;
// 848 code_ca = 0
CODE.CA = 0;
// 849
// 850 gla_zero addr = (code_zero addr + code size + h8 + 255)&(\255); ! block align
GLA.ZEROADDR = CODE.ZEROADDR + CODESIZE + 8 + 255 & (~255);
// 851 gla_lower = 0
GLA.LOWER = 0;
// 852 gla_upper = gla size
GLA.UPPER = GLASIZE;
// 853 gla_ca = 0
GLA.CA = 0;
// 854
// 855 header_registers = register template
HEADER.REGISTERS = 32239;
// 856 header_main ep = -1; ! default: reset if a main program
HEADER.MAINEP = -1;
// 857 header_code disp = code_zero addr; ! within-file disp.
HEADER.CODEDISP = CODE.ZEROADDR;
// 858 header_lit disp = header size; ! within-file disp.
HEADER.LITDISP = HEADERSIZE;
// 859 header_pure size = code_zero addr + code size
HEADER.PURESIZE = CODE.ZEROADDR + CODESIZE;
// 860 header_gla size = gla size
HEADER.GLASIZE = GLASIZE;
// 861
// 862 total blocks = (gla_zero addr + gla size + 255) >> 8
TOTALBLOCKS = (unsigned int)GLA.ZEROADDR + GLASIZE + 255 >> 8;
// 863
// 864 header_reloc_p2 = relocations; ! no. of halfwords
HEADER.RELOC.P2 = RELOCATIONS;
// 865 header_defn_p2 = defns
HEADER.DEFN.P2 = DEFNS;
// 866
// 867
// 868 %record(bfm)%map buff(%integer addr)
struct BFM *BUFF(int ADDR)
{
// 869 %record(bfm)%name this,last
struct BFM *THIS;
struct BFM *LAST;
// 870 %integer block
int BLOCK;
// 871 block = addr>>8; ! ** N.B. halfword addressing units, 512 byte block **
BLOCK = (unsigned int)ADDR >> 8;
// 872 %result == buff list %if block = buff list_block
if (BLOCK != BUFFLIST->BLOCK) goto L_0088;
return BUFFLIST;
L_0088:;
// 873 buff miss1 = buff miss1+1; ! *** monitoring only ***
BUFFMISS1 = BUFFMISS1 + 1;
// 874 %if diagnostic < 0 %start
if (0 >= 0) goto L_0089;
// 875 printstring("block"); write(block,1); newline
_imp_PRINTSTRING(_imp_str_literal("block"));
_imp_WRITE(BLOCK, 1);
_imp_NEWLINE();
// 876 %finish
L_0089:;
// 877 last == buff list
LAST = (struct BFM *)BUFFLIST;
// 878 %cycle
L_008A:;
// 879 buff miss3 = buff miss3+1; ! *** monitoring only ***
BUFFMISS3 = BUFFMISS3 + 1;
// 880 this == last_link
THIS = (struct BFM *)LAST->LINK;
// 881 -> promote %if this_block = block
if (THIS->BLOCK != BLOCK) goto L_008B;
goto U_1002;
L_008B:;
// 882 %exit %if this_link == null
if (_imp_ADDR((void *)(THIS->LINK)) != _imp_ADDR((void *)(NULL))) goto L_008C;
goto L_008D;
L_008C:;
// 883 last == this
LAST = (struct BFM *)THIS;
// 884 %repeat
goto L_008A;
L_008D:;
// 885 %if this_block < 0 %start; ! buffer still free
if (THIS->BLOCK >= 0) goto L_008E;
// 886 this_block = block
THIS->BLOCK = BLOCK;
// 887 %else
goto L_008F;
L_008E:;
// 888 block io(this,da write)
BLOCKIO(THIS, 10);
// 889 this_block = block
THIS->BLOCK = BLOCK;
// 890 block io(this,da read)
BLOCKIO(THIS, 9);
// 891 buff miss2 = buff miss2+1; ! *** monitoring only ***
BUFFMISS2 = BUFFMISS2 + 1;
// 892 %finish
L_008F:;
// 893 promote:
U_1002:;
// 894 last_link == this_link
LAST->LINK = (struct BFM *)THIS->LINK;
// 895 this_link == buff list
THIS->LINK = (struct BFM *)BUFFLIST;
// 896 buff list == this
BUFFLIST = (struct BFM *)THIS;
// 897 %result == buff list
return BUFFLIST;
// 898 %end; ! of 'buff'
} /* end of BUFF */
// 899
// 900 %routine flush buffers
void FLUSHBUFFERS(void) {
// 901 %record(bfm)%name this
struct BFM *THIS;
// 902 %integer k
int K;
// 903 this == buff(0)
THIS = (struct BFM *)BUFF(0);
// 904 %if h8 # 0 %start
if (8 == 0) goto L_0090;
// 905 this_b(0) = (header_pure size + h8 + 255)//256
THIS->B[0] = ((long)(HEADER.PURESIZE + 8 + 255) / (long)256);
// 906 this_b(1) = (header_gla size + 255)//256
THIS->B[1] = ((long)(HEADER.GLASIZE + 255) / (long)256);
// 907 this_b(2) = x'4321'; ! new format identifier
THIS->B[2] = 17185;
// 908 this_b(3) = 0; this_b(4) = 0; this_b(5) = 0
THIS->B[3] = 0;
THIS->B[4] = 0;
THIS->B[5] = 0;
// 909 this_b(6) = 0; ! flags
THIS->B[6] = 0;
// 910 this_b(7) = 0; ! stack
THIS->B[7] = 0;
// 911 %finish
L_0090:;
// 912 %for k = 0,1,basic header-1 %cycle
// %for K = 0, 1, 18 - 1 %cycle
{
int _final = 18 - 1;
if (invalid_for_loop(0, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle K = 0, 1, 18 - 1");
K = -1;
L_0091:
if (K == _final) goto L_0092;
K += 1;
// 913 this_b(k+h8) = short integer(addr(header)+k*2)
THIS->B[K + 8] = *_imp_SHORTINTEGER(_imp_ADDR(/*?*/ &HEADER) + K * 2);
// 914 %repeat
goto L_0091;
}
L_0092:;
// 915 this == buff list
THIS = (struct BFM *)BUFFLIST;
// 916 %cycle
L_0093:;
// 917 block io(this,da write) %if this_block >= 0
if (THIS->BLOCK < 0) goto L_0094;
BLOCKIO(THIS, 10);
L_0094:;
// 918 this == this_link
THIS = (struct BFM *)THIS->LINK;
// 919 %exit %if this == null
if (_imp_ADDR((void *)(THIS)) != _imp_ADDR((void *)(NULL))) goto L_0095;
goto L_0096;
L_0095:;
// 920 %repeat
goto L_0093;
L_0096:;
// 921 %end; ! flush buffers
return;
} /* end of FLUSHBUFFERS */
// 922
// 923 %routine origin(%record(sfm)%name section, %integer org)
void ORIGIN(struct SFM * SECTION, int ORG) {
// 924 %if diagnostic < 0 %start
if (0 >= 0) goto L_0097;
// 925 %if diagnostic <= -2 %start
if (0 > -2) goto L_0098;
// 926 print string("ORG:"); write(org,1)
_imp_PRINTSTRING(_imp_str_literal("ORG:"));
_imp_WRITE(ORG, 1);
// 927 write(section_lower,6); write(section_upper,1)
_imp_WRITE(SECTION->LOWER, 6);
_imp_WRITE(SECTION->UPPER, 1);
// 928 newline
_imp_NEWLINE();
// 929 %finish
L_0098:;
// 930 %finish
L_0097:;
// 931 section_ca = org %and %return %if section_lower <= org <= section_upper
{
// Double-sided test on ORG (Part I)
int tmp;
if (SECTION->LOWER > (tmp = ORG)) goto L_0099;
// Double-sided test on ORG (Part II)
if (tmp > SECTION->UPPER) goto L_0099;
}
SECTION->CA = ORG;
return;
L_0099:;
// 932 error(25,org)
ERROR(25, ORG);
// 933 %end
return;
} /* end of ORIGIN */
// 934
// 935 %routine put(%record(sfm)%name section, %shortinteger item)
void PUT(struct SFM * SECTION, short int ITEM) {
// 936 %record(bfm)%name bp
struct BFM *BP;
// 937 %integer addr
int ADDR;
// 938 %owninteger last = -1
static int LAST = -1;
// 939 addr = section_zero addr + section_ca
ADDR = SECTION->ZEROADDR + SECTION->CA;
// 940 addr = addr + h8 %unless section == gla
if (_imp_ADDR((void *)(SECTION)) == _imp_ADDR((void *)(/*?*/ &GLA))) goto L_009A;
ADDR = ADDR + 8;
L_009A:;
// 941 %if diagnostic < 0 %start
if (0 >= 0) goto L_009B;
// 942 %if diagnostic < -2 %start; ! two-stage test for speed
if (0 >= -2) goto L_009C;
// 943 newline %if addr # last+1
if (ADDR == LAST + 1) goto L_009D;
_imp_NEWLINE();
L_009D:;
// 944 last = addr
LAST = ADDR;
// 945 write(addr,4); print string(": "); phex(item)
_imp_WRITE(ADDR, 4);
_imp_PRINTSTRING(_imp_str_literal(": "));
PHEX(ITEM);
// 946 newline
_imp_NEWLINE();
// 947 %finish
L_009C:;
// 948 %finish
L_009B:;
// 949 bp == buff(addr)
BP = (struct BFM *)BUFF(ADDR);
// 950 bp_b(addr&255) = item
BP->B[ADDR & 255] = ITEM;
// 951 section_ca = section_ca + 1
SECTION->CA = SECTION->CA + 1;
// 952 %end; ! of 'put'
return;
} /* end of PUT */
// 953
// 954 %routine put name(%record(sfm)%name sect)
void PUTNAME(struct SFM * SECT) {
// 955 %integer j; %shortinteger half
int J;
short int HALF;
// 956 %integerfn ch(%integer sym)
int CH(int SYM) {
// 957 %result = sym-'A'+1 %if 'A' <= sym <= 'Z'
{
// Double-sided test on SYM (Part I)
int tmp;
if (65 > (tmp = SYM)) goto L_009E;
// Double-sided test on SYM (Part II)
if (tmp > 90) goto L_009E;
}
return SYM - 65 + 1;
L_009E:;
// 958 %result = sym-'a'+1 %if 'a' <= sym <= 'z'; ! ** lower case alphabet **
{
// Double-sided test on SYM (Part I)
int tmp;
if (97 > (tmp = SYM)) goto L_009F;
// Double-sided test on SYM (Part II)
if (tmp > 122) goto L_009F;
}
return SYM - 97 + 1;
L_009F:;
// 959 %result = sym-'0'+27 %if '0' <= sym <= '9'
{
// Double-sided test on SYM (Part I)
int tmp;
if (48 > (tmp = SYM)) goto L_00A0;
// Double-sided test on SYM (Part II)
if (tmp > 57) goto L_00A0;
}
return SYM - 48 + 27;
L_00A0:;
// 960 %result = sym-'#'+37 %if '#' <= sym <= '%'; ! 37='#', 38='$', 39='%'
{
// Double-sided test on SYM (Part I)
int tmp;
if (35 > (tmp = SYM)) goto L_00A1;
// Double-sided test on SYM (Part II)
if (tmp > 37) goto L_00A1;
}
return SYM - 35 + 37;
L_00A1:;
// 961 %result = 0 %if sym = ' '
if (SYM != 32) goto L_00A2;
return 0;
L_00A2:;
// 962 %result = -1
return -1;
// 963 %end; ! ch
} /* end of CH */
// 964 %routine pack3(%integer k, %shortintegername n)
void PACK3(int K, short int *N) {
// 965 %integer p,q,r
int P;
int Q;
int R;
// 966 p = charno(xd_sym,k); q = charno(xd_sym,k+1); r = charno(xd_sym,k+2)
P = *_imp_CHARNO((_imp_string255 *)/*p*/ /*?*/ &XD.SYM, K);
Q = *_imp_CHARNO((_imp_string255 *)/*p*/ /*?*/ &XD.SYM, K + 1);
R = *_imp_CHARNO((_imp_string255 *)/*p*/ /*?*/ &XD.SYM, K + 2);
// 967 n <- ( (ch(p)*40 + ch(q))*40 + ch(r) ); ! ugh!!!
*N = (short int)((CH(P) * 40 + CH(Q)) * 40 + CH(R));
// 968 %end; ! pack3
return;
} /* end of PACK3 */
// 969 charno(xd_sym,j) = ' ' %for j = length(xd_sym)+1,1,xd_ident len
// %for J = *_imp_LENGTH((_imp_string255 *)/*p*//*?*/&XD.SYM) + 1, 1, XD.IDENTLEN %cycle
{
int _initial = *_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &XD.SYM) + 1, _final = XD.IDENTLEN;
if (invalid_for_loop(_initial, 1, _final))
_imp_signal(5, 1, 0,
"Illegal cycle J = *_imp_LENGTH((_imp_string255 *)/*p*//*?*/&XD.SYM) + 1, 1, XD.IDENTLEN");
J = _initial - (1);
L_00A3:
if (J == _final) goto L_00A4;
J += 1;
*_imp_CHARNO((_imp_string255 *)/*p*/ /*?*/ &XD.SYM, J) = 32;
goto L_00A3;
}
L_00A4:;
// 970 %for j = 1,3,xd_identlen-2 %cycle
// %for J = 1, 3, XD.IDENTLEN - 2 %cycle
{
int _final = XD.IDENTLEN - 2;
if (invalid_for_loop(1, 3, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 3, XD.IDENTLEN - 2");
J = -2;
L_00A5:
if (J == _final) goto L_00A6;
J += 3;
// 971 pack3(j,half); put(sect,half)
PACK3(J, /*?*/ &HALF);
PUT(SECT, HALF);
// 972 %repeat
goto L_00A5;
}
L_00A6:;
// 973 %end; ! put name
return;
} /* end of PUTNAME */
// 974
// 975 %routine set description(%integer desc type)
void SETDESCRIPTION(int DESCTYPE) {
// 976 %integer sym,j,k,l, char
int SYM;
int J;
int K;
int L;
int CHAR;
// 977 read symbol(k)
_imp_READSYMBOL(/*?*/ &K);
// 978 l = k; l = 12 %if l > 12
L = K;
if (L <= 12) goto L_00A7;
L = 12;
L_00A7:;
// 979 length(xd_sym) = l
*_imp_LENGTH((_imp_string255 *)/*p*/ /*?*/ &XD.SYM) = L;
// 980 %for j = 1,1,l %cycle
// %for J = 1, 1, L %cycle
{
int _final = L;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, L");
J = 0;
L_00A8:
if (J == _final) goto L_00A9;
J += 1;
// 981 readsymbol(char)
_imp_READSYMBOL(/*?*/ &CHAR);
// 982 char = char - 'a' + 'A' %if %c
{
// Double-sided test on CHAR (Part I)
int tmp;
if (97 > (tmp = CHAR)) goto L_00AA;
// Double-sided test on CHAR (Part II)
if (tmp > 122) goto L_00AA;
}
CHAR = CHAR - 97 + 65;
L_00AA:;
// 983+ 'a' <= char <= 'z'
// 984 charno(xd_sym,j) = char
*_imp_CHARNO((_imp_string255 *)/*p*/ /*?*/ &XD.SYM, J) = CHAR;
// 985 %repeat
goto L_00A8;
}
L_00A9:;
// 986 k = k-l
K = K - L;
// 987 skip symbol %and k = k-1 %while k > 0
L_00AB:;
if (K <= 0) goto L_00AC;
_imp_SKIPSYMBOL();
K = K - 1;
goto L_00AB;
L_00AC:;
// 988 xd_ident len = 12; ! assume full 12-character ident.
XD.IDENTLEN = 12;
// 989 %return %if desc type = proc header; ! only ident. present
if (DESCTYPE != 1) goto L_00AD;
return;
L_00AD:;
// 990 xd_identlen = 6 %if l <= 6 %and desc type = diag entry
if (L > 6) goto L_00AE;
if (DESCTYPE != 0) goto L_00AE;
XD.IDENTLEN = 6;
L_00AE:;
// 991 read symbol(xd_otype)
_imp_READSYMBOL(/*?*/ &XD.OTYPE);
// 992 read symbol(k)
_imp_READSYMBOL(/*?*/ &K);
// 993 xd_type = k>>4; xd_form = k&15
XD.TYPE = (unsigned int)K >> 4;
XD.FORM = K & 15;
// 994 read symbol(j); get(k)
_imp_READSYMBOL(/*?*/ &J);
GET(/*?*/ &K);
// 995 xd_base = j>>4
XD.BASE = (unsigned int)J >> 4;
// 996 xd_disp = (j&15)<<16 + (k&x'FFFF')
XD.DISP = ((J & 15) << 16) + (K & 65535);
// 997 %if diagnostic < 0 %start
if (0 >= 0) goto L_00AF;
// 998 print string(xd_sym.": "); write(xd_identlen,1)
_imp_PRINTSTRING(
*({
__typeof__(_imp_string255) tmp = *({
_imp_string255 tmp =
_imp_join((_imp_string *)/*?*/ &XD.SYM, (_imp_string *)/*?*/ _imp_str_literal_ptr(": "));
(_imp_string255 *)&tmp;
}) /*q*/;
(_imp_string255 *)&tmp;
})
);
_imp_WRITE(XD.IDENTLEN, 1);
// 999 write(xd_base,1); write(xd_disp,4)
_imp_WRITE(XD.BASE, 1);
_imp_WRITE(XD.DISP, 4);
// 1000 write(xd_type,3); write(xd_form,1); write(xd_otype,1)
_imp_WRITE(XD.TYPE, 3);
_imp_WRITE(XD.FORM, 1);
_imp_WRITE(XD.OTYPE, 1);
// 1001 newline
_imp_NEWLINE();
// 1002 %finish
L_00AF:;
// 1003 %end;
return;
} /* end of SETDESCRIPTION */
// ?SYM unused
// 1004 ; ! set description
// 1004
// 1005 %routine insert prims
void INSERTPRIMS(void) {
// 1006 %integer j,k,l,m,to
int J;
int K;
int L;
int M;
int TO;
// 1007 %for j = 1,1,max prim %cycle
// %for J = 1, 1, 52 %cycle
{
J = 0;
L_00B0:
if (J == 52) goto L_00B1;
J += 1;
// 1008 k = prim entry(j)
K = PRIMENTRY[J - 1];
// 1009 %if k >= 0 %start
if (K < 0) goto L_00B2;
// 1010 %if diagnostic < 0 %start
if (0 >= 0) goto L_00B3;
// 1011 print string("prim"); write(j,1); print symbol(' '); phex(k)
_imp_PRINTSTRING(_imp_str_literal("prim"));
_imp_WRITE(J, 1);
_imp_PRINTSYMBOL(32);
PHEX(K);
// 1012 newline
_imp_NEWLINE();
// 1013 %finish
L_00B3:;
// 1014 origin(code,proc1_base + prim entry(j))
ORIGIN(/*?*/ &CODE, PROC1->BASE + PRIMENTRY[J - 1]);
// 1015 k = prim(j)
K = PRIM[J - 1];
// 1016 to = k + prim(k) & x'7FFF'; ! strip 'align' bit
TO = K + (PRIM[K - 1] & 32767);
// 1017 %while k # to %cycle
L_00B4:;
if (K == TO) goto L_00B5;
// 1018 k = k+1; m = prim(k)&x'FFFF'
K = K + 1;
M = PRIM[K - 1] & 65535;
// 1019 %if m&x'FFF0' # emark %start
if (M & 65520 == 34944) goto L_00B6;
// 1020 put(code,m)
PUT(/*?*/ &CODE, M);
// 1021 %else %if m = tmark; ! trace routine external call
goto L_00B7;
L_00B6:;
if (M != 34951) goto L_00B8;
// 1022 trace patch = code_ca
TRACEPATCH = CODE.CA;
// 1023 put(code,m)
PUT(/*?*/ &CODE, M);
// 1024 %else
goto L_00B7;
L_00B8:;
// 1025 %if m&15 = 8 %start
if (M & 15 != 8) goto L_00B9;
// 1026 put(code, jmp)
PUT(/*?*/ &CODE, 17166);
// 1027 %else
goto L_00BA;
L_00B9:;
// 1028 put(code, bal + (m&15)<<4)
PUT(/*?*/ &CODE, 16654 + ((M & 15) << 4));
// 1029 %finish
L_00BA:;
// 1030 k = k+1; m = prim(k)
K = K + 1;
M = PRIM[K - 1];
// 1031 l = prim entry(m); ! pointer to referenced routine
L = PRIMENTRY[M - 1];
// 1032 error(15,j) %if l < 0
if (L >= 0) goto L_00BB;
ERROR(15, J);
L_00BB:;
// 1033 put(code,(proc1_base+l)*2); ! byte displacement
PUT(/*?*/ &CODE, (PROC1->BASE + L) * 2);
// 1034 %finish
L_00B7:;
// 1035 %repeat
goto L_00B4;
L_00B5:;
// 1036 %finish
L_00B2:;
// 1037 %repeat
goto L_00B0;
}
L_00B1:;
// 1038 asynch link = prim entry(max prim); ! *** must be last entry in perms ***
ASYNCHLINK = PRIMENTRY[51];
// 1039 %end; ! 'insert prims'
return;
} /* end of INSERTPRIMS */
// 1040
// 1041 %routine plant code ref
void PLANTCODEREF(void) {
// 1042 %integer j,k,l,t,there
int J;
int K;
int L;
int T;
int THERE;
// 1043 %record(deffm)%name d
struct DEFFM *D;
// 1044 %switch format(SF:RX3)
int FORMAT_index;
int FORMAT_line;
char *FORMAT_file;
static const void *FORMAT[4] = {&&case_FORMAT_missing, &&case_FORMAT_missing, &&case_FORMAT_missing,
&&case_FORMAT_missing};
// 1045 ref = ref+1; t = reftype(ref)
REF = REF + 1;
T = REFTYPE[REF - 1];
// 1046 d == tagdef(tag)
D = (struct DEFFM *)/*?*/ &TAGDEF[TAG - 1];
// 1047 there = proc(d_proc)_base + d_ca + extra
THERE = PROC[D->PROC - 1].BASE + D->CA + EXTRA;
// 1048 cond = cond+6 %if t&invert # 0
if (T & 16 == 0) goto L_00BC;
COND = COND + 6;
L_00BC:;
// 1049 op = long jump(cond) %if t&rcall = 0
if (T & 64 != 0) goto L_00BD;
OP = LONGJUMP[COND];
L_00BD:;
// 1050 -> format(t&7)
FORMAT_line = __LINE__;
FORMAT_file = __FILE__;
FORMAT_index = T & 7;
goto case_FORMAT_dispatch;
// 1051 format(SF): ! short format
case_FORMAT_1:;
// 1052 sfjump = sfjump+1
SFJUMP = SFJUMP + 1;
// 1053 l = 0; k = there-code_ca; ! halfword disp. req'd here
L = 0;
K = THERE - CODE.CA;
// 1054 %if k < 0 %start
if (K >= 0) goto L_00BF;
// 1055 l = backwards; k = -k
L = 256;
K = -K;
// 1056 %finish
L_00BF:;
// 1057 error(200,code_ca) %if k > 15; ! error in reference table
if (K <= 15) goto L_00C0;
ERROR(200, CODE.CA);
L_00C0:;
// 1058 put(code,(short jump(cond) !! l) + k)
PUT(/*?*/ &CODE, (SHORTJUMP[COND] ^ L) + K);
// 1059 %return
return;
// 1060 format(RX1):
case_FORMAT_2:;
// 1061 rx1jump = rx1jump+1
RX1JUMP = RX1JUMP + 1;
// 1062 format(RX3):
case_FORMAT_4:;
// 1063 rx13jump = rx13jump+1
RX13JUMP = RX13JUMP + 1;
// 1064 k = (there - proc1_base)*2; ! byte disp. from code base
K = (THERE - PROC1->BASE) * 2;
// 1065 put(code, op)
PUT(/*?*/ &CODE, OP);
// 1066 %if t&7 = RX3 %start
if (T & 7 != 4) goto L_00C1;
// 1067 put(code, x'4000'!((k>>16)&15))
PUT(/*?*/ &CODE, 16384 | (unsigned int)K >> 16 & 15);
// 1068 %else
goto L_00C2;
L_00C1:;
// 1069 error(201,code_ca) %unless 0 <= k <= 16383
{
// Double-sided test on K (Part I)
int tmp;
if (0 > (tmp = K)) goto L_0061;
// Double-sided test on K (Part II)
if (tmp <= 16383) goto L_00C3;
}
L_0061:;
ERROR(201, CODE.CA);
L_00C3:;
// 1070 %finish
L_00C2:;
// 1071 put(code,k&x'FFFF')
PUT(/*?*/ &CODE, K & 65535);
// 1072 %return
return;
// 1073 format(RX2):
case_FORMAT_3:;
// 1074 rx2jump = rx2jump+1
RX2JUMP = RX2JUMP + 1;
// 1075 k = (there - (code_ca+4//2))*2
K = (THERE - (CODE.CA + ((long)4 / (long)2))) * 2;
// 1076 error(202,code_ca) %unless -16384 <= k <= 16383
{
// Double-sided test on K (Part I)
int tmp;
if (-16384 > (tmp = K)) goto L_005B;
// Double-sided test on K (Part II)
if (tmp <= 16383) goto L_00C4;
}
L_005B:;
ERROR(202, CODE.CA);
L_00C4:;
// 1077 put(code, op&(\15))
PUT(/*?*/ &CODE, OP & (~15));
// 1078 put(code,halfword sign ! k)
PUT(/*?*/ &CODE, (-32768) | K);
// 1079 %end;
return;
case_FORMAT_dispatch:
if (FORMAT_index < 1 || FORMAT_index > 4)
_imp_signalf(6, 3, FORMAT_index, "->FORMAT(%d) out of bounds at %s line %d", FORMAT_index, FORMAT_file,
FORMAT_line);
goto *FORMAT[FORMAT_index - 1];
case_FORMAT_missing:
_imp_signalf(8, 2, FORMAT_index, "switch jump to undefined label FORMAT(%d): at %s line %d", FORMAT_index,
FORMAT_file, FORMAT_line);
} /* end of PLANTCODEREF */
// ?J unused
// 1080 ; ! 'plant code ref'
// 1080
// 1081 %routine dump code
void DUMPCODE(void) {
// 1082 %owninteger depth = 0
static int DEPTH = 0;
// 1083 %integer last line, last ca
int LASTLINE;
int LASTCA;
// 1084 %integer code reset
int CODERESET;
// 1085 %owninteger lit reset; ! no recursion!! - literals are not exbedded
static int LITRESET;
// 1086 %owninteger last spec = 0, gla skip = 0
static int LASTSPEC = 0;
static int GLASKIP = 0;
// 1087 %record(procfm)%name p
struct PROCFM *P;
// 1088 %integer cca, lca, vca
int CCA;
int LCA;
int VCA;
// 1089 %integer k,c,half
int K;
int C;
int HALF;
// 1090 %switch dir(1:extern)
int DIR_index;
int DIR_line;
char *DIR_file;
static const void *DIR[21] = {&&case_DIR_missing, &&case_DIR_2, &&case_DIR_3, &&case_DIR_4, &&case_DIR_5,
&&case_DIR_6, &&case_DIR_7, &&case_DIR_8, &&case_DIR_9, &&case_DIR_10,
&&case_DIR_11, &&case_DIR_12, &&case_DIR_13, &&case_DIR_14, &&case_DIR_15,
&&case_DIR_16, &&case_DIR_17, &&case_DIR_missing, &&case_DIR_19, &&case_DIR_20,
&&case_DIR_21};
// 1091 depth = depth+1
DEPTH = DEPTH + 1;
// 1092 this proc = this proc+1
THISPROC = THISPROC + 1;
// 1093 p == proc(this proc)
P = (struct PROCFM *)/*?*/ &PROC[THISPROC - 1];
// 1094 origin(code,p_base); origin(ldiag,p_ldbase); origin(vdiag,p_vdbase)
ORIGIN(/*?*/ &CODE, P->BASE);
ORIGIN(/*?*/ &LDIAG, P->LDBASE);
ORIGIN(/*?*/ &VDIAG, P->VDBASE);
// 1095 last ca = code_ca; last line = 0
LASTCA = CODE.CA;
LASTLINE = 0;
// 1096 %if this proc # 1 %start; ! its a recursive call
if (THISPROC == 1) goto L_00C5;
// 1097 ! DIAGS: dump procedure line origin and identifier
// 1098 get(last line); set description(proc header)
GET(/*?*/ &LASTLINE);
SETDESCRIPTION(1);
// 1099 %if diags # none %start
if (DIAGS == 0) goto L_00C6;
// 1100 k = last line
K = LASTLINE;
// 1101 k = 0 %if hide # 0
if (HIDE == 0) goto L_00C7;
K = 0;
L_00C7:;
// 1102 put(ldiag,k); put name(vdiag)
PUT(/*?*/ &LDIAG, K);
PUTNAME(/*?*/ &VDIAG);
// 1103 %finish
L_00C6:;
// 1104 %else; ! initial (non-recursive) call
goto L_00C8;
L_00C5:;
// 1105 %if diags # none %start
if (DIAGS == 0) goto L_00C9;
// 1106 xd_sym = "PERM"; xd_identlen = 12
_imp_strncpy(/*?*/ &XD.SYM, ({
__typeof__(_imp_string255) tmp; /*B*/
tmp = _imp_str_literal("PERM");
(void *)&tmp;
}),
/*max:*/ 255);
XD.IDENTLEN = 12;
// 1107 put(ldiag,0); put name(vdiag)
PUT(/*?*/ &LDIAG, 0);
PUTNAME(/*?*/ &VDIAG);
// 1108 %finish
L_00C9:;
// 1109 insert prims
INSERTPRIMS();
// 1110 origin(code,proc1_base+proc1_ca-2)
ORIGIN(/*?*/ &CODE, PROC1->BASE + PROC1->CA - 2);
// 1111 put(code,code_ca - event link); ! link round perm
PUT(/*?*/ &CODE, CODE.CA - EVENTLINK);
// 1112 event link = code_ca - 1
EVENTLINK = CODE.CA - 1;
// 1113 put(code,x'8000'); ! dummy event mask
PUT(/*?*/ &CODE, 32768);
// 1114 %finish
L_00C8:;
// 1115
// 1116 %cycle
L_00CA:;
// 1117 read symbol(c)
_imp_READSYMBOL(/*?*/ &C);
// 1118 -> dir(c) %if 0 < c <= extern
{
// Double-sided test on C (Part I)
int tmp;
if (0 >= (tmp = C)) goto L_00CB;
// Double-sided test on C (Part II)
if (tmp > 21) goto L_00CB;
}
DIR_line = __LINE__;
DIR_file = __FILE__;
DIR_index = C;
goto case_DIR_dispatch;
L_00CB:;
// 1119 !!dir(*):
// 1120 error(12,c)
ERROR(12, C);
// 1121
// 1122 dir(proc head):
case_DIR_16:;
// 1123 read symbol(k); error(13,k) %unless k = this proc
_imp_READSYMBOL(/*?*/ &K);
if (K == THISPROC) goto L_00CD;
ERROR(13, K);
L_00CD:;
// 1124 cca = code_ca; lca = ldiag_ca; vca = vdiag_ca
CCA = CODE.CA;
LCA = LDIAG.CA;
VCA = VDIAG.CA;
// 1125 dump code
DUMPCODE();
// 1126 origin(code,cca); origin(ldiag,lca); origin(vdiag,vca)
ORIGIN(/*?*/ &CODE, CCA);
ORIGIN(/*?*/ &LDIAG, LCA);
ORIGIN(/*?*/ &VDIAG, VCA);
// 1127 %continue
goto L_00CE;
// 1128 dir(proc end):
case_DIR_17:;
// 1129 depth = depth-1
DEPTH = DEPTH - 1;
// 1130 %if depth # 0 %start; !not in perm
if (DEPTH == 0) goto L_00CF;
// 1131 ! dump event chain
// 1132 put(code,code_ca-event link); ! here relative link to preceding block
PUT(/*?*/ &CODE, CODE.CA - EVENTLINK);
// 1133 event link = code_ca-1
EVENTLINK = CODE.CA - 1;
// 1134 %if p_event mask = 0 %start
if (P->EVENTMASK != 0) goto L_00D0;
// 1135 put(code,p_display reg ! halfword sign)
PUT(/*?*/ &CODE, P->DISPLAYREG | (-32768));
// 1136 %else
goto L_00D1;
L_00D0:;
// 1137 put(code,p_display reg)
PUT(/*?*/ &CODE, P->DISPLAYREG);
// 1138 put(code,p_event mask)
PUT(/*?*/ &CODE, P->EVENTMASK);
// 1139 put(code,tagdef(p_event start)_ca + p_base)
PUT(/*?*/ &CODE, TAGDEF[P->EVENTSTART - 1].CA + P->BASE);
// 1140 put(code,tagdef(p_event finish)_ca + p_base)
PUT(/*?*/ &CODE, TAGDEF[P->EVENTFINISH - 1].CA + P->BASE);
// 1141 %finish
L_00D1:;
// 1142 %finish
L_00CF:;
// 1143 ! dump line diag. table link
// 1144 !!!!!!!!!! last line = -line diag limit-1
// 1145 %if diagnostic < 0 %start
if (0 >= 0) goto L_00D2;
// 1146 write(ldiag_ca,1)
_imp_WRITE(LDIAG.CA, 1);
// 1147 write(p_ldbase,1); write(p_ldsize,1); newline
_imp_WRITE(P->LDBASE, 1);
_imp_WRITE(P->LDSIZE, 1);
_imp_NEWLINE();
// 1148 %finish
L_00D2:;
// 1149 %if diags = full %start
if (DIAGS != 2) goto L_00D3;
// 1150 %if depth = 0 %start; !special for perm
if (DEPTH != 0) goto L_00D4;
// 1151 put(ldiag, proc1_ldsize)
PUT(/*?*/ &LDIAG, PROC1->LDSIZE);
// 1152 put(vdiag, proc1_vdsize)
PUT(/*?*/ &VDIAG, PROC1->VDSIZE);
// 1153 %else
goto L_00D5;
L_00D4:;
// 1154 put(ldiag, ldiag_ca-ldiag link); ! relative to here
PUT(/*?*/ &LDIAG, LDIAG.CA - LDIAGLINK);
// 1155 ldiag link = ldiag_ca - 1
LDIAGLINK = LDIAG.CA - 1;
// 1156 put(vdiag, vdiag_ca-vdiag link); ! ... ditto ...
PUT(/*?*/ &VDIAG, VDIAG.CA - VDIAGLINK);
// 1157 vdiag link = vdiag_ca - 1
VDIAGLINK = VDIAG.CA - 1;
// 1158 %finish
L_00D5:;
// 1159 k = p_ld base + p_ld size; put(ldiag,0) %while ldiag_ca # k; ! zero
K = P->LDBASE + P->LDSIZE;
L_00D6:;
if (LDIAG.CA == K) goto L_00D7;
PUT(/*?*/ &LDIAG, 0);
goto L_00D6;
L_00D7:;
// 1160 %finish
L_00D3:;
// 1161 %return
return;
// 1162 dir(code area):
case_DIR_12:;
// 1163 lit reset = code_ca
LITRESET = CODE.CA;
// 1164 code_ca = code reset
CODE.CA = CODERESET;
// 1165 %continue
goto L_00CE;
// 1166 dir(lit area):
case_DIR_13:;
// 1167 code reset = code_ca
CODERESET = CODE.CA;
// 1168 code_ca = lit reset
CODE.CA = LITRESET;
// 1169 %continue
goto L_00CE;
// 1170 dir(lit org):
case_DIR_14:;
// 1171 get(half)
GET(/*?*/ &HALF);
// 1172 lit reset = -half
LITRESET = -HALF;
// 1173 %continue
goto L_00CE;
// 1174 dir(code item):
case_DIR_7:;
// 1175 get(half)
GET(/*?*/ &HALF);
// 1176 put(code,half)
PUT(/*?*/ &CODE, HALF);
// 1177 %continue
goto L_00CE;
// 1178 dir(gla item):
case_DIR_8:;
// 1179 get(half)
GET(/*?*/ &HALF);
// 1180 gla skip = gla skip-1 %and %continue %if gla skip # 0
if (GLASKIP == 0) goto L_00D8;
GLASKIP = GLASKIP - 1;
goto L_00CE;
L_00D8:;
// 1181 put(gla,half)
PUT(/*?*/ &GLA, HALF);
// 1182 %continue
goto L_00CE;
// 1183 dir(gla rel):
case_DIR_20:;
// 1184 ! Assumed to immediately follow the dumping of the GLA full-word to
// 1185 ! which it refers.
// 1186 put(reloc,gla_ca-2); ! N.B. -2 halfwords = -4 bytes
PUT(/*?*/ &RELOC, GLA.CA - 2);
// 1187 %continue
goto L_00CE;
// 1188 dir(code rel):
case_DIR_19:;
// 1189 ! As for GLA REL but modifies a word in gla according to the value of
// 1190 ! code base at load time
// 1191 put(reloc,(gla_ca-2)+1); ! N.B ** odd-numbered halfword => code seg **
PUT(/*?*/ &RELOC, GLA.CA - 2 + 1);
// 1192 %continue
goto L_00CE;
// 1193 dir(frame patch):
case_DIR_15:;
// 1194 origin(code,code_ca-1)
ORIGIN(/*?*/ &CODE, CODE.CA - 1);
// 1195 put(code,p_static frame); ! bytes if TRUSTED else fullwords
PUT(/*?*/ &CODE, P->STATICFRAME);
// 1196 %continue
goto L_00CE;
// 1197 dir(c ref):
case_DIR_6:;
// 1198 dir(j ref): ! jumps
case_DIR_5:;
// 1199 skip symbol; ! 'code item'
_imp_SKIPSYMBOL();
// 1200 get(half)
GET(/*?*/ &HALF);
// 1201 cond = half&15; tag = half>>4
COND = HALF & 15;
TAG = (unsigned int)HALF >> 4;
// 1202 extra = 0; ! to match r ref path!!
EXTRA = 0;
// 1203 plant code ref
PLANTCODEREF();
// 1204 %continue
goto L_00CE;
// 1205 dir(r ref): ! procedure calls (including %begin-%end blocks)
case_DIR_2:;
// 1206 get(tag)
GET(/*?*/ &TAG);
// 1207 skip symbol; ! 'code item'
_imp_SKIPSYMBOL();
// 1208 get(op)
GET(/*?*/ &OP);
// 1209 skip symbol; ! 'code item'
_imp_SKIPSYMBOL();
// 1210 get(extra)
GET(/*?*/ &EXTRA);
// 1211 cond = 0
COND = 0;
// 1212 plant code ref
PLANTCODEREF();
// 1213 %continue
goto L_00CE;
// 1214 dir(p ref): ! prim call
case_DIR_3:;
// 1215 skip symbol; ! 'code item'
_imp_SKIPSYMBOL();
// 1216 get(op)
GET(/*?*/ &OP);
// 1217 skip symbol; ! 'code item'
_imp_SKIPSYMBOL();
// 1218 get(k)
GET(/*?*/ &K);
// 1219 error(15,k) %unless 0 < k <= max prim
{
// Double-sided test on K (Part I)
int tmp;
if (0 >= (tmp = K)) goto L_00D9;
// Double-sided test on K (Part II)
if (tmp <= 52) goto L_00DA;
}
L_00D9:;
ERROR(15, K);
L_00DA:;
// 1220 put(code,op)
PUT(/*?*/ &CODE, OP);
// 1221 put(code,prim entry(k)*2 ); ! byte disp.
PUT(/*?*/ &CODE, PRIMENTRY[K - 1] * 2);
// 1222 %continue
goto L_00CE;
// 1223 dir(sw ref):
case_DIR_4:;
// 1224 skip symbol; ! 'code item'
_imp_SKIPSYMBOL();
// 1225 get(tag)
GET(/*?*/ &TAG);
// 1226 k = tag def(tag)_ca; k = k + p_base %if k # 0
K = TAGDEF[TAG - 1].CA;
if (K == 0) goto L_00DB;
K = K + P->BASE;
L_00DB:;
// 1227 put(code,k); ! N.B. halfwords relative to code base
PUT(/*?*/ &CODE, K);
// 1228 %continue
goto L_00CE;
// 1229
// 1230 dir(line reset):
case_DIR_10:;
// 1231 get(half)
GET(/*?*/ &HALF);
// 1232 current line = half-1; ! * see below *
CURRENTLINE = HALF - 1;
// 1233 dir(line diag):
case_DIR_9:;
// 1234 current line = current line + 1
CURRENTLINE = CURRENTLINE + 1;
// 1235 %if diagnostic < 0 %start
if (0 >= 0) goto L_00DC;
// 1236 print string("line"); write(current line,1); write(code_ca,1)
_imp_PRINTSTRING(_imp_str_literal("line"));
_imp_WRITE(CURRENTLINE, 1);
_imp_WRITE(CODE.CA, 1);
// 1237 newline
_imp_NEWLINE();
// 1238 %finish
L_00DC:;
// 1239 ca incr = code_ca - last ca
CAINCR = CODE.CA - LASTCA;
// 1240 %continue %if ca incr = 0
if (CAINCR != 0) goto L_00DD;
goto L_00CE;
L_00DD:;
// 1241 line incr = current line - last line
LINEINCR = CURRENTLINE - LASTLINE;
// 1242 %unless 0 <= line incr <= line diag limit %start
{
// Double-sided test on LINEINCR (Part I)
int tmp;
if (0 > (tmp = LINEINCR)) goto L_00DE;
// Double-sided test on LINEINCR (Part II)
if (tmp <= 31) goto L_00DF;
}
L_00DE:;
// 1243 put(ldiag, (current line-1) ! halfword sign ) %if diags = full
if (DIAGS != 2) goto L_00E0;
PUT(/*?*/ &LDIAG, CURRENTLINE - 1 | (-32768));
L_00E0:;
// 1244 line incr = 1
LINEINCR = 1;
// 1245 %finish
L_00DF:;
// 1246 put(ldiag, ca incr*(line diag limit+1) + line incr) %if diags = full
if (DIAGS != 2) goto L_00E1;
PUT(/*?*/ &LDIAG, CAINCR * (31 + 1) + LINEINCR);
L_00E1:;
// 1247 last line = current line
LASTLINE = CURRENTLINE;
// 1248 last ca = code_ca
LASTCA = CODE.CA;
// 1249 %continue
goto L_00CE;
// 1250
// 1251 dir(var diag):
case_DIR_11:;
// 1252 set description(diag entry)
SETDESCRIPTION(0);
// 1253 %if diags = full %start
if (DIAGS != 2) goto L_00E2;
// 1254 k = ((xd_type&7)<<4 + xd_base&15)<<4 + (xd_disp>>16)
K = (((XD.TYPE & 7) << 4) + (XD.BASE & 15) << 4) + ((unsigned int)XD.DISP >> 16);
// 1255 k = k!halfword sign %if xd_identlen # 12; ! ...%if a short ident
if (XD.IDENTLEN == 12) goto L_00E3;
K = K | (-32768);
L_00E3:;
// 1256 k = k!indirect %if xd_form = 2; ! %name variable
if (XD.FORM != 2) goto L_00E4;
K = K | 16384;
L_00E4:;
// 1257 k = k!x'2000' %if xd_type&8 # 0
if (XD.TYPE & 8 == 0) goto L_00E5;
K = K | 8192;
L_00E5:;
// 1258 put(vdiag,k); put(vdiag,xd_disp&x'FFFF')
PUT(/*?*/ &VDIAG, K);
PUT(/*?*/ &VDIAG, XD.DISP & 65535);
// 1259 put name(vdiag)
PUTNAME(/*?*/ &VDIAG);
// 1260 %finish
L_00E2:;
// 1261 %continue
goto L_00CE;
// 1262
// 1263 dir(extern):
case_DIR_21:;
// 1264
// 1265 ! <=== word 1 =====> <======== word 2 ======> <== word 3 =>
// 1266 ! ------------------ ------------ ----------- -------------
// 1267 ! Proc spec: | link to previous | identifier : self-link | x'00000000' |
// 1268 ! ------------------ ------------ ----------- -------------
// 1269
// 1270 ! ------------------ ------------ ----------- -------------
// 1271 ! Data spec | link to previous | identifier : ????????? | x'80000000' |
// 1272 ! ------------------ ------------ ----------- -------------
// 1273
// 1274 read symbol(c); ! type of cross reference
_imp_READSYMBOL(/*?*/ &C);
// 1275 get(xd_data size)
GET(/*?*/ &XD.DATASIZE);
// 1276 set description(linkage name)
SETDESCRIPTION(-1);
// 1277 gla skip = 0
GLASKIP = 0;
// 1278 %if c = ep defn %or c = data defn %start
if (C == 7) goto L_00E6;
if (C != 5) goto L_00E7;
L_00E6:;
// 1279 k = xd_disp
K = XD.DISP;
// 1280 %if c = ep defn %start
if (C != 7) goto L_00E8;
// 1281 k = code_ca
K = CODE.CA;
// 1282 %if xd_sym = main ep %start
if (_imp_strcmp((_imp_string *)/*?*/ &XD.SYM, (_imp_string *)/*?*/ &MAINEP) != 0) goto L_00E9;
// 1283 p_display reg = p_display reg ! main prog
P->DISPLAYREG = P->DISPLAYREG | 16384;
// 1284 header_main ep = k
HEADER.MAINEP = K;
// 1285 %finish
L_00E9:;
// 1286 %finish
L_00E8:;
// 1287 put(defn, defn link); defn link = header_defn_p1 + defn_ca-1; ! file relative
PUT(/*?*/ &DEFN, DEFNLINK);
DEFNLINK = HEADER.DEFN.P1 + DEFN.CA - 1;
// 1288 put(defn, k)
PUT(/*?*/ &DEFN, K);
// 1289 put name(defn)
PUTNAME(/*?*/ &DEFN);
// 1290 %else %if c = ep spec %or c = data spec
goto L_00EA;
L_00E7:;
if (C == 6) goto L_00EB;
if (C != 4) goto L_00EC;
L_00EB:;
// 1291 %if trace patch # 0 %and xd_sym = trace ep %start
if (TRACEPATCH == 0) goto L_00ED;
if (_imp_strcmp((_imp_string *)/*?*/ &XD.SYM, (_imp_string *)/*?*/ &TRACEEP) != 0) goto L_00ED;
// 1292 c = code_ca
C = CODE.CA;
// 1293 origin(code,trace patch)
ORIGIN(/*?*/ &CODE, TRACEPATCH);
// 1294 put(code,gla_ca*2); !halfwords note.
PUT(/*?*/ &CODE, GLA.CA * 2);
// 1295 origin(code,c)
ORIGIN(/*?*/ &CODE, C);
// 1296 %finish
L_00ED:;
// 1297 k = header_spec_p1 + spec_ca; ! file relative
K = HEADER.SPEC.P1 + SPEC.CA;
// 1298 put name(spec)
PUTNAME(/*?*/ &SPEC);
// 1299 put(gla,spec link>>16); put(gla,spec link); ! gla relative back link
PUT(/*?*/ &GLA, (unsigned int)SPECLINK >> 16);
PUT(/*?*/ &GLA, SPECLINK);
// 1300 spec link = gla_ca - 2
SPECLINK = GLA.CA - 2;
// 1301 put(gla,k)
PUT(/*?*/ &GLA, K);
// 1302 put(gla,gla_ca-3); ! halfword disp. of this block into GLA
PUT(/*?*/ &GLA, GLA.CA - 3);
// 1303 %if c = data spec %start
if (C != 4) goto L_00EE;
// 1304 put(gla, -1); put(gla, -1)
PUT(/*?*/ &GLA, -1);
PUT(/*?*/ &GLA, -1);
// 1305 %else
goto L_00EF;
L_00EE:;
// 1306 put(gla, 0); put(gla, 0)
PUT(/*?*/ &GLA, 0);
PUT(/*?*/ &GLA, 0);
// 1307 %finish
L_00EF:;
// 1308 gla skip = 6; ! half words
GLASKIP = 6;
// 1309 %else
goto L_00EA;
L_00EC:;
// 1310 error(170,c)
ERROR(170, C);
// 1311 %finish
L_00EA:;
// 1312 %continue
goto L_00CE;
// 1313
// 1314 %repeat
L_00CE:;
goto L_00CA;
// 1315 %end;
case_DIR_dispatch:
if (DIR_index < 1 || DIR_index > 21)
_imp_signalf(6, 3, DIR_index, "->DIR(%d) out of bounds at %s line %d", DIR_index, DIR_file, DIR_line);
goto *DIR[DIR_index - 1];
case_DIR_missing:
_imp_signalf(8, 2, DIR_index, "switch jump to undefined label DIR(%d): at %s line %d", DIR_index, DIR_file,
DIR_line);
} /* end of DUMPCODE */
// ?LASTSPEC unused
// 1316 ; ! of 'dump code'
// 1316
// 1317 select input(object)
_imp_SELECTINPUT(2);
// 1318 open da(IMPCOM_file,total blocks)
OPENDA((_imp_string31 *)/*p*/ /*?*/ &IMPCOM.FILE, TOTALBLOCKS);
// 1319 !!!! read symbol(j); put(gla,x'7FFF') %for j = 1,1,j; ! init gla
// 1320 ! Dual standard meantime for first words in gla
// 1321 read symbol(j); put(gla,x'7FFF') %for j = 1,1,j-2
_imp_READSYMBOL(/*?*/ &J);
// %for J = 1, 1, J - 2 %cycle
{
int _final = J - 2;
if (invalid_for_loop(1, 1, _final)) _imp_signal(5, 1, 0, "Illegal cycle J = 1, 1, J - 2");
J = 0;
L_00F0:
if (J == _final) goto L_00F1;
J += 1;
PUT(/*?*/ &GLA, 32767);
goto L_00F0;
}
L_00F1:;
// 1322 put(gla,0); put(gla,0)
PUT(/*?*/ &GLA, 0);
PUT(/*?*/ &GLA, 0);
// 1323
// 1324 read symbol(j); error(17,j) %if j < init lit; ! pass2 INIT LIT value
_imp_READSYMBOL(/*?*/ &J);
if (J >= 4) goto L_00F3;
ERROR(17, J);
L_00F3:;
// 1325 current line = 0
CURRENTLINE = 0;
// 1326 event link = -1
EVENTLINK = -1;
// 1327 ldiag link = proc1_ldsize-1
LDIAGLINK = PROC1->LDSIZE - 1;
// 1328 vdiag link = proc1_vdsize-1
VDIAGLINK = PROC1->VDSIZE - 1;
// 1329 defn link = 0
DEFNLINK = 0;
// 1330 spec link = 0
SPECLINK = 0;
// 1331 dump code
DUMPCODE();
// 1332 readsymbol(j)
_imp_READSYMBOL(/*?*/ &J);
// 1333 error(-2,j) %unless j = prog end
if (J == 18) goto L_00F4;
ERROR(-2, J);
L_00F4:;
// 1334 origin(code,-init lit); ! = -4: must always dump the exact number
ORIGIN(/*?*/ &CODE, -4);
// 1335 put(code,0); ! *** padding ***
PUT(/*?*/ &CODE, 0);
// 1336 put(code,asynch link); ! signal relative to code base
PUT(/*?*/ &CODE, ASYNCHLINK);
// 1337 put(code,header_code disp); ! code base addr - file start addr
PUT(/*?*/ &CODE, HEADER.CODEDISP);
// 1338 put(code,event link)
PUT(/*?*/ &CODE, EVENTLINK);
// 1339 %if diags # full %start; ! no links embedded in tables!!!
if (DIAGS == 2) goto L_00F5;
// 1340 %if diags = partial %start
if (DIAGS != 1) goto L_00F6;
// 1341 header_ldiag_p1 = header_ldiag_p1 ! halfword sign
HEADER.LDIAG.P1 = HEADER.LDIAG.P1 | (-32768);
// 1342 ldiag link = this proc*(2//2); ! halfword size: for use below
LDIAGLINK = THISPROC * (((long)2 / (long)2));
// 1343 vdiag link = this proc*8//2; ! ditto
VDIAGLINK = ((long)(THISPROC * 8) / (long)2);
// 1344 %else; ! 'none'
goto L_00F7;
L_00F6:;
// 1345 header_ldiag_p1 = 0; ! no diag tables present
HEADER.LDIAG.P1 = 0;
// 1346 %finish
L_00F7:;
// 1347 %finish
L_00F5:;
// 1348 header_ldiag_p2 = ldiag link; ! ldiag_p1+ldiag_p2 => start of chain
HEADER.LDIAG.P2 = LDIAGLINK;
// 1349 header_vdiag_p2 = vdiag link
HEADER.VDIAG.P2 = VDIAGLINK;
// 1350 header_spec_p2 = spec link; ! GLA relative
HEADER.SPEC.P2 = SPECLINK;
// 1351 header_defn_p2 = defn link; ! N.B. FILE relative
HEADER.DEFN.P2 = DEFNLINK;
// 1352 flush buffers
FLUSHBUFFERS();
// 1353 close da
CLOSEDA();
// 1354 %end;
return;
} /* end of PHASETWO */
// ?L unused
// ?K unused
// ?SPECFM unused
// ?XDEFFM unused
// 1355 ; ! phase two
// 1355
// 1356 !========================================================================
// 1357 diags = (IMPCOM_flags >> 8)&7; ! * * * * SYSTEM DEPENDENT * * * *
DIAGS = (unsigned int)IMPCOM.FLAGS >> 8 & 7;
// 1358 hide = IMPCOM_flags&x'0800'
HIDE = IMPCOM.FLAGS & 2048;
// 1359 !========================================================================
// 1360
// 1361
// 1362 select output(report)
_imp_SELECTOUTPUT(0);
// 1363 t0 = cpu time; ! *** monitoring only ***
T0 = _imp_CPUTIME();
// 1364 diags = full %if diags > full
if (DIAGS <= 2) goto L_00F8;
DIAGS = 2;
L_00F8:;
// 1365 phase one
PHASEONE();
// 1366 t1 = cpu time; ! *** monitoring only ***
T1 = _imp_CPUTIME();
// 1367 phase two
PHASETWO();
// 1368 t2 = cpu time; ! *** monitoring only ***
T2 = _imp_CPUTIME();
// 1369 IMPCOM_code = (code size+literal size-proc1_ca)*2
IMPCOM.CODE = (CODESIZE + LITERALSIZE - PROC1->CA) * 2;
// 1370 IMPCOM_perm = proc1_ca*2
IMPCOM.PERM = PROC1->CA * 2;
// 1371 IMPCOM_gla = gla size*2
IMPCOM.GLA = GLASIZE * 2;
// 1372 IMPCOM_diags = (line diags+var diags)*2
IMPCOM.DIAGS = (LINEDIAGS + VARDIAGS) * 2;
// 1373
// 1374 ! print string("Jumps:")
// 1375 ! write(sfjump,1); print string(" SF +")
// 1376 ! write(rx1jump,1); print string(" RX1 +")
// 1377 ! write(rx2jump,1); print string(" RX2 +")
// 1378 ! write(rx13jump-rx1jump,1); print string(" RX3 =")
// 1379 ! write(sfjump+rx2jump+rx13jump,1)
// 1380 ! newline; print string("Diagnostic Tables (bytes):")
// 1381 ! print string(" line"); write(line diags*2,1)
// 1382 ! print string(", ident"); write(var diags*2,1)
// 1383 ! newlines(2)
// 1384 ! print string("Millisecs: phase1 "); write(t1-t0,1)
// 1385 ! print string(" phase2"); write(t2-t1,1)
// 1386 ! newline
// 1387 ! %if local tot # 0 %and global tot # 0 %start
// 1388 ! print string("Stretching - safe/total (%) local:")
// 1389 ! write( (local tot-local nonsafe)*100//local tot, 4)
// 1390 ! print string(" global:")
// 1391 ! write( (global tot-global nonsafe)*100//global tot,4)
// 1392 ! newline
// 1393 ! %finish
// 1394 ! spaces(15)
// 1395 ! print string("millisecs:"); write(t11-t10,14); write(t12-t11,13)
// 1396 ! newline
// 1397 ! print string("Total output (halfwords):")
// 1398 ! write(code size+literal size+gla size+var diags+line diags, 1)
// 1399 ! newline
// 1400 ! print string("Disc buffer: searches"); write(buff miss1,1)
// 1401 ! print string(" cache misses"); write(buff miss2,1)
// 1402 ! newline
// 1403 ! print string("Mean search length="); print(buff miss3/buff miss1,1,2)
// 1404 ! newline
// 1405
// 1406 %endofprogram
_imp_stop(0);
return 0;
end_0:;
}