convert_sfl_.pl1 07/06/83 0936.2r w 06/29/83 1541.3 115101 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ convert_sfl_: proc(input_value, precision) returns(char(*)); dcl F(-128:127) fixed bin(35) int static init( /* -128 */ 2938735877, /* -127 */ 5877471754, /* -126 */ 11754943508, /* -125 */ 2350988701, /* -124 */ 4701977403, /* -123 */ 9403954806, /* -122 */ 1880790961, /* -121 */ 3761581922, /* -120 */ 7523163845, /* -119 */ 1504632769, /* -118 */ 3009265538, /* -117 */ 6018531076, /* -116 */ 1203706215, /* -115 */ 2407412430, /* -114 */ 4814824860, /* -113 */ 9629649721, /* -112 */ 1925929944, /* -111 */ 3851859888, /* -110 */ 7703719777, /* -109 */ 1540743955, /* -108 */ 3081487911, /* -107 */ 6162975822, /* -106 */ 1232595164, /* -105 */ 2465190328, /* -104 */ 4930380657, /* -103 */ 9860761315, /* -102 */ 1972152263, /* -101 */ 3944304526, /* -100 */ 7888609052, /* -99 */ 1577721810, /* -98 */ 3155443620, /* -97 */ 6310887241, /* -96 */ 1262177448, /* -95 */ 2524354896, /* -94 */ 5048709793, /* -93 */ 10097419586, /* -92 */ 2019483917, /* -91 */ 4038967834, /* -90 */ 8077935669, /* -89 */ 1615587133, /* -88 */ 3231174267, /* -87 */ 6462348535, /* -86 */ 1292469707, /* -85 */ 2584939414, /* -84 */ 5169878828, /* -83 */ 10339757656, /* -82 */ 2067951531, /* -81 */ 4135903062, /* -80 */ 8271806125, /* -79 */ 1654361225, /* -78 */ 3308722450, /* -77 */ 6617444900, /* -76 */ 1323488980, /* -75 */ 2646977960, /* -74 */ 5293955920, /* -73 */ 10587911840, /* -72 */ 2117582368, /* -71 */ 4235164736, /* -70 */ 8470329472, /* -69 */ 1694065894, /* -68 */ 3388131789, /* -67 */ 6776263578, /* -66 */ 1355252715, /* -65 */ 2710505431, /* -64 */ 5421010862, /* -63 */ 10842021724, /* -62 */ 2168404344, /* -61 */ 4336808689, /* -60 */ 8673617379, /* -59 */ 1734723475, /* -58 */ 3469446951, /* -57 */ 6938893903, /* -56 */ 1387778780, /* -55 */ 2775557561, /* -54 */ 5551115123, /* -53 */ 11102230246, /* -52 */ 2220446049, /* -51 */ 4440892098, /* -50 */ 8881784197, /* -49 */ 1776356839, /* -48 */ 3552713678, /* -47 */ 7105427357, /* -46 */ 1421085471, /* -45 */ 2842170943, /* -44 */ 5684341886, /* -43 */ 11368683772, /* -42 */ 2273736754, /* -41 */ 4547473508, /* -40 */ 9094947017, /* -39 */ 1818989403, /* -38 */ 3637978807, /* -37 */ 7275957614, /* -36 */ 1455191522, /* -35 */ 2910383045, /* -34 */ 5820766091, /* -33 */ 11641532182, /* -32 */ 2328306436, /* -31 */ 4656612873, /* -30 */ 9313225746, /* -29 */ 1862645149, /* -28 */ 3725290298, /* -27 */ 7450580596, /* -26 */ 1490116119, /* -25 */ 2980232238, /* -24 */ 5960464477, /* -23 */ 1192092895, /* -22 */ 2384185791, /* -21 */ 4768371582, /* -20 */ 9536743164, /* -19 */ 1907348632, /* -18 */ 3814697265, /* -17 */ 7629394531, /* -16 */ 1525878906, /* -15 */ 3051757812, /* -14 */ 6103515625, /* -13 */ 1220703125, /* -12 */ 2441406250, /* -11 */ 4882812500, /* -10 */ 9765625000, /* -9 */ 1953125000, /* -8 */ 3906250000, /* -7 */ 7812500000, /* -6 */ 1562500000, /* -5 */ 3125000000, /* -4 */ 6250000000, /* -3 */ 1250000000, /* -2 */ 2500000000, /* -1 */ 5000000000, /* 0 */ 10000000000, /* 1 */ 2000000000, /* 2 */ 4000000000, /* 3 */ 8000000000, /* 4 */ 1600000000, /* 5 */ 3200000000, /* 6 */ 6400000000, /* 7 */ 1280000000, /* 8 */ 2560000000, /* 9 */ 5120000000, /* 10 */ 10240000000, /* 11 */ 2048000000, /* 12 */ 4096000000, /* 13 */ 8192000000, /* 14 */ 1638400000, /* 15 */ 3276800000, /* 16 */ 6553600000, /* 17 */ 1310720000, /* 18 */ 2621440000, /* 19 */ 5242880000, /* 20 */ 10485760000, /* 21 */ 2097152000, /* 22 */ 4194304000, /* 23 */ 8388608000, /* 24 */ 1677721600, /* 25 */ 3355443200, /* 26 */ 6710886400, /* 27 */ 1342177280, /* 28 */ 2684354560, /* 29 */ 5368709120, /* 30 */ 10737418240, /* 31 */ 2147483648, /* 32 */ 4294967296, /* 33 */ 8589934592, /* 34 */ 1717986918, /* 35 */ 3435973836, /* 36 */ 6871947673, /* 37 */ 1374389534, /* 38 */ 2748779069, /* 39 */ 5497558138, /* 40 */ 10995116277, /* 41 */ 2199023255, /* 42 */ 4398046511, /* 43 */ 8796093022, /* 44 */ 1759218604, /* 45 */ 3518437208, /* 46 */ 7036874417, /* 47 */ 1407374883, /* 48 */ 2814749767, /* 49 */ 5629499534, /* 50 */ 11258999068, /* 51 */ 2251799813, /* 52 */ 4503599627, /* 53 */ 9007199254, /* 54 */ 1801439850, /* 55 */ 3602879701, /* 56 */ 7205759403, /* 57 */ 1441151880, /* 58 */ 2882303761, /* 59 */ 5764607523, /* 60 */ 11529215046, /* 61 */ 2305843009, /* 62 */ 4611686018, /* 63 */ 9223372036, /* 64 */ 1844674407, /* 65 */ 3689348814, /* 66 */ 7378697629, /* 67 */ 1475739525, /* 68 */ 2951479051, /* 69 */ 5902958103, /* 70 */ 1180591620, /* 71 */ 2361183241, /* 72 */ 4722366482, /* 73 */ 9444732965, /* 74 */ 1888946593, /* 75 */ 3777893186, /* 76 */ 7555786372, /* 77 */ 1511157274, /* 78 */ 3022314549, /* 79 */ 6044629098, /* 80 */ 1208925819, /* 81 */ 2417851639, /* 82 */ 4835703278, /* 83 */ 9671406556, /* 84 */ 1934281311, /* 85 */ 3868562622, /* 86 */ 7737125245, /* 87 */ 1547425049, /* 88 */ 3094850098, /* 89 */ 6189700196, /* 90 */ 1237940039, /* 91 */ 2475880078, /* 92 */ 4951760157, /* 93 */ 9903520314, /* 94 */ 1980704062, /* 95 */ 3961408125, /* 96 */ 7922816251, /* 97 */ 1584563250, /* 98 */ 3169126500, /* 99 */ 6338253001, /* 100 */ 1267650600, /* 101 */ 2535301200, /* 102 */ 5070602400, /* 103 */ 10141204801, /* 104 */ 2028240960, /* 105 */ 4056481920, /* 106 */ 8112963841, /* 107 */ 1622592768, /* 108 */ 3245185536, /* 109 */ 6490371073, /* 110 */ 1298074214, /* 111 */ 2596148429, /* 112 */ 5192296858, /* 113 */ 10384593717, /* 114 */ 2076918743, /* 115 */ 4153837486, /* 116 */ 8307674973, /* 117 */ 1661534994, /* 118 */ 3323069989, /* 119 */ 6646139978, /* 120 */ 1329227995, /* 121 */ 2658455991, /* 122 */ 5316911983, /* 123 */ 10633823966, /* 124 */ 2126764793, /* 125 */ 4253529586, /* 126 */ 8507059173, /* 127 */ 1701411834); dcl E(-128:127) fixed bin int static init( /* -128 */ -59, /* -127 */ -59, /* -126 */ -59, /* -125 */ -58, /* -124 */ -58, /* -123 */ -58, /* -122 */ -57, /* -121 */ -57, /* -120 */ -57, /* -119 */ -56, /* -118 */ -56, /* -117 */ -56, /* -116 */ -55, /* -115 */ -55, /* -114 */ -55, /* -113 */ -55, /* -112 */ -54, /* -111 */ -54, /* -110 */ -54, /* -109 */ -53, /* -108 */ -53, /* -107 */ -53, /* -106 */ -52, /* -105 */ -52, /* -104 */ -52, /* -103 */ -52, /* -102 */ -51, /* -101 */ -51, /* -100 */ -51, /* -99 */ -50, /* -98 */ -50, /* -97 */ -50, /* -96 */ -49, /* -95 */ -49, /* -94 */ -49, /* -93 */ -49, /* -92 */ -48, /* -91 */ -48, /* -90 */ -48, /* -89 */ -47, /* -88 */ -47, /* -87 */ -47, /* -86 */ -46, /* -85 */ -46, /* -84 */ -46, /* -83 */ -46, /* -82 */ -45, /* -81 */ -45, /* -80 */ -45, /* -79 */ -44, /* -78 */ -44, /* -77 */ -44, /* -76 */ -43, /* -75 */ -43, /* -74 */ -43, /* -73 */ -43, /* -72 */ -42, /* -71 */ -42, /* -70 */ -42, /* -69 */ -41, /* -68 */ -41, /* -67 */ -41, /* -66 */ -40, /* -65 */ -40, /* -64 */ -40, /* -63 */ -40, /* -62 */ -39, /* -61 */ -39, /* -60 */ -39, /* -59 */ -38, /* -58 */ -38, /* -57 */ -38, /* -56 */ -37, /* -55 */ -37, /* -54 */ -37, /* -53 */ -37, /* -52 */ -36, /* -51 */ -36, /* -50 */ -36, /* -49 */ -35, /* -48 */ -35, /* -47 */ -35, /* -46 */ -34, /* -45 */ -34, /* -44 */ -34, /* -43 */ -34, /* -42 */ -33, /* -41 */ -33, /* -40 */ -33, /* -39 */ -32, /* -38 */ -32, /* -37 */ -32, /* -36 */ -31, /* -35 */ -31, /* -34 */ -31, /* -33 */ -31, /* -32 */ -30, /* -31 */ -30, /* -30 */ -30, /* -29 */ -29, /* -28 */ -29, /* -27 */ -29, /* -26 */ -28, /* -25 */ -28, /* -24 */ -28, /* -23 */ -27, /* -22 */ -27, /* -21 */ -27, /* -20 */ -27, /* -19 */ -26, /* -18 */ -26, /* -17 */ -26, /* -16 */ -25, /* -15 */ -25, /* -14 */ -25, /* -13 */ -24, /* -12 */ -24, /* -11 */ -24, /* -10 */ -24, /* -9 */ -23, /* -8 */ -23, /* -7 */ -23, /* -6 */ -22, /* -5 */ -22, /* -4 */ -22, /* -3 */ -21, /* -2 */ -21, /* -1 */ -21, /* 0 */ -21, /* 1 */ -20, /* 2 */ -20, /* 3 */ -20, /* 4 */ -19, /* 5 */ -19, /* 6 */ -19, /* 7 */ -18, /* 8 */ -18, /* 9 */ -18, /* 10 */ -18, /* 11 */ -17, /* 12 */ -17, /* 13 */ -17, /* 14 */ -16, /* 15 */ -16, /* 16 */ -16, /* 17 */ -15, /* 18 */ -15, /* 19 */ -15, /* 20 */ -15, /* 21 */ -14, /* 22 */ -14, /* 23 */ -14, /* 24 */ -13, /* 25 */ -13, /* 26 */ -13, /* 27 */ -12, /* 28 */ -12, /* 29 */ -12, /* 30 */ -12, /* 31 */ -11, /* 32 */ -11, /* 33 */ -11, /* 34 */ -10, /* 35 */ -10, /* 36 */ -10, /* 37 */ -9, /* 38 */ -9, /* 39 */ -9, /* 40 */ -9, /* 41 */ -8, /* 42 */ -8, /* 43 */ -8, /* 44 */ -7, /* 45 */ -7, /* 46 */ -7, /* 47 */ -6, /* 48 */ -6, /* 49 */ -6, /* 50 */ -6, /* 51 */ -5, /* 52 */ -5, /* 53 */ -5, /* 54 */ -4, /* 55 */ -4, /* 56 */ -4, /* 57 */ -3, /* 58 */ -3, /* 59 */ -3, /* 60 */ -3, /* 61 */ -2, /* 62 */ -2, /* 63 */ -2, /* 64 */ -1, /* 65 */ -1, /* 66 */ -1, /* 67 */ 0, /* 68 */ 0, /* 69 */ 0, /* 70 */ 1, /* 71 */ 1, /* 72 */ 1, /* 73 */ 1, /* 74 */ 2, /* 75 */ 2, /* 76 */ 2, /* 77 */ 3, /* 78 */ 3, /* 79 */ 3, /* 80 */ 4, /* 81 */ 4, /* 82 */ 4, /* 83 */ 4, /* 84 */ 5, /* 85 */ 5, /* 86 */ 5, /* 87 */ 6, /* 88 */ 6, /* 89 */ 6, /* 90 */ 7, /* 91 */ 7, /* 92 */ 7, /* 93 */ 7, /* 94 */ 8, /* 95 */ 8, /* 96 */ 8, /* 97 */ 9, /* 98 */ 9, /* 99 */ 9, /* 100 */ 10, /* 101 */ 10, /* 102 */ 10, /* 103 */ 10, /* 104 */ 11, /* 105 */ 11, /* 106 */ 11, /* 107 */ 12, /* 108 */ 12, /* 109 */ 12, /* 110 */ 13, /* 111 */ 13, /* 112 */ 13, /* 113 */ 13, /* 114 */ 14, /* 115 */ 14, /* 116 */ 14, /* 117 */ 15, /* 118 */ 15, /* 119 */ 15, /* 120 */ 16, /* 121 */ 16, /* 122 */ 16, /* 123 */ 16, /* 124 */ 17, /* 125 */ 17, /* 126 */ 17, /* 127 */ 18); dcl input_value float bin(27), precision fixed bin, 1 b_value based(addr(input_value)), 2 e fixed bin(7) unal, 2 bmantissa fixed bin(27) unal, mantissa fixed bin(28), two27 fixed bin(35) int static init(134217728), multiply builtin, divide builtin, v fixed bin(63), v1 fixed bin(63), factor fixed bin(63), round_factor fixed bin(35), two26 fixed bin(35) int static init(67108864), trail fixed bin, mostsig fixed bin, i fixed bin, n fixed bin, mod builtin, digits(0:9) char(1) int static init("0","1","2","3","4","5","6","7","8","9"), digit(11) char(1), Expt fixed bin, point fixed bin, min builtin, value char(32) var, substr builtin; if bmantissa=0 then return("0.0"); if bmantissa<0 then mantissa = - bmantissa; else mantissa = bmantissa; v = divide(multiply(mantissa, F(e), 63, 0) + two26, two27, 63, 0); factor = 1; do i = 1 to precision; factor = factor * 10; if factor>v then go to rounded; end; factor = factor * 10; round_factor = 5; do i = 1 to 10 while (factor<=v); factor = factor * 10; round_factor = round_factor * 10; end; v = v + round_factor; v = v - mod(v, 2*round_factor); rounded: trail, mostsig = 0; do i = 1 to 11; n = mod(v, 10); if n=0 then if mostsig=0 then trail = i; else; else mostsig = i; digit(i) = digits(n); v = divide(v, 10, 63, 0); end; Expt = E(e) + 11; point = mostsig + Expt; value = ""; if point<=precision & (-Expt-trail)<=precision then do; do i = max(mostsig, -Expt) to min(trail+1, -Expt) by -1; if i=-Expt then value = value||"."; if imostsig then value = value||"0"; else value = value||digit(i); end; if substr(value,1,1)="." then value = "0"||value; else if i=mostsig-point then value = value||".0"; if bmantissa<0 then value = "-"||value; return(value); end; value = value || digit(mostsig); do i = mostsig-1 to trail+1 by -1; if i=mostsig-1 then value = value || "."; value = value || digit(i); end; value = value || "e"; point = point - 1; if point<0 then do; value = value || "-"; point = - point; end; if point<10 then value = value || digits(point); else value = value || digits(divide(point, 10, 17, 0)) || digits(mod(point, 10)); if bmantissa<0 then value = "-" || value; return(value); end convert_sfl_;  dump_lisp_code_.pl1 07/06/83 0936.2r w 06/29/83 1541.3 84618 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* protect old protection notice */ /* (c) Copyright 1973, Massachusetts Institute of Technology. All rights reserved. */ dump_lisp_code_: proc (start, length, stream, tablep); /* modified 73.11.24 by DAM for new subr blocks */ dcl start fixed bin, length fixed bin, stream ptr, estimated_number_of_labels fixed bin, tablep pointer; dcl make_ioa_not_lose fixed bin(35); /* I have to do this because someone gratuitously changed ioa_ so that it no longer works properly */ dcl (convert, addr, divide, fixed, hbound, min, substr, unspec) builtin; /* declare various tables which are based on tablep */ dcl 1 table aligned structure based(tablep), 2 stack_height fixed bin(17), /* add to ap offset to get 2 * temp number */ 2 atom_table_size fixed bin, /* size of atom_table array */ 2 link_table_ptr unaligned pointer, /* -> array of itp link info */ 2 link_table_lbound fixed bin(18), /* first lp| offset of itp link */ 2 link_table_hbound fixed bin(18), /* last lp| offset of itp link */ 2 array_link_table_ptr unaligned pointer, /* -> array of array_link control words */ 2 array_link_table_lbound fixed bin(18), /* first lp| offset of array link */ 2 array_link_table_hbound fixed bin(18), /* last lp| offset of array link */ 2 definition_table_size fixed bin, /* size of definition_table array */ 2 constant_table_size fixed bin, /* size of constant_table array */ 2 constant_table_lbound fixed bin(18), /* first lp| offset of constant */ 2 constant_table_hbound fixed bin(18), /* last lp| offset of constant */ 2 bind_stack_ptr fixed bin, /* index of first unused entry in bind_stack */ 2 arg_twiddle fixed bin(18), /* eax5 hacker */ 2 seg_ptr unaligned pointer, /* -> text section */ 2 bind_stack (100) fixed bin, /* table of sizes of nested binding blocks */ 2 atom_table (0 refer(atom_table_size)), /* pointers to atomic symbols */ 3 ptr_to_name unaligned pointer, /* -> varying string */ 2 definition_table(0 refer(definition_table_size)), /* entries defined... */ 3 arg_pdl bit(18) unaligned, /* number of pdl cells occupied by args */ 3 entrypoint bit(18) unaligned, /* location of entry */ 3 ptr_to_name unaligned pointer, /* -> varying string */ 2 constant_table(0 refer(constant_table_size)), 3 atom_table_index fixed bin; /* 0 if this constant not an atom */ %include lisp_nums; /* first pass - construct table of all locations referenced by transfer instructions. Since we don't know how big to make this table, we guess and allocate it in a begin block. If it turns out to be too small, which shouldn't happen very often, we will have to escape from the begin block, and start over with a bigger table */ estimated_number_of_labels = 1 + divide(length, 10, 17, 0); go to allocate_tra_table; reallocate_tra_table: /* come here if it proved to be too small */ estimated_number_of_labels = estimated_number_of_labels * 2; allocate_tra_table: begin; dcl 1 tra_table aligned automatic structure, 2 number_of_labels fixed bin init(0), /* number of entries in use */ 2 label(estimated_number_of_labels) structure,/* array of entries */ 3 address fixed bin(18), /* location of label */ 3 stack_ht fixed bin(18), /* value of stack_height ta tra to label, -1 if not yet known */ 3 tra_from fixed bin(18), /* location that transfers to this label */ 3 save_bind_stack_ptr fixed bin, /* Value of binding stack ptr */ 3 tra_from_others bit(1); /* 1 => it is not the only one */ dcl words(0:start+length-1) bit(36) aligned based(base), 1 word_structure(0:start+length-1) aligned based(base), 2 bit3 bit(3) unal, 2 addr1 fixed bin(14) unal, 2 addr2 fixed bin(17) unal, addrf fixed bin(17) unaligned based(addr(words(ic))), /* address field of current instruction */ tag1 fixed bin, address_1 fixed bin, address_2 fixed bin, base pointer init(table.seg_ptr), mll_internal_error condition, curlabx fixed bin, /* index in tra_table of next label we expect to see */ curlabaddr fixed bin(18), /* address of that label */ others char(8), ioa_$ioa_switch entry options(variable), convert_sfl_ entry(bit(36) aligned, fixed bin) returns(char(*)), dump_lisp_instruction_ entry(bit(36) aligned, fixed bin(18), pointer, pointer) returns(char(*)), dump_lisp_binding_word_ entry(bit(36) aligned, fixed bin(18), pointer) returns(char(*)), bind_operator int static bit(36) init("001000000000010000010111010001010000"b), bb_size fixed bin(18), ref fixed bin(18), (labu, labx, labh) fixed bin, /* for binary seach of label table */ ic fixed bin(18); do ic = start repeat(ic+1) while(ic <= start+length-1); if (substr(words(ic), 19, 18) & "111111000011111111"b) = "110000000000000100"b /* conditional transfer,ic */ | substr(words(ic), 19, 18) = "111001000000000100"b then do; /* unconditional transfer,ic */ ref = ic + addrf; /* location transferred to */ /* search label array for previous instance or place to put this one */ labu = 1; labh = number_of_labels; do while(labh >= labu); labx = labu + divide(labh-labu, 2, 17, 0); if label(labx).address = ref then go to found_label; else if label(labx).address < ref then labu = labx+1; else labh = labx-1; end; /* now labh < label < labu */ number_of_labels = number_of_labels + 1; /* create new lanbel */ if number_of_labels > hbound(label, 1) then go to reallocate_tra_table; /* go get bigger table */ do labx = number_of_labels by -1 while(labx > labu); /* move upper part of table up 1 to open new slot in right place */ unspec(label(labx)) = unspec(label(labx-1)); end; /* fill in new label */ label(labx).address = ref; label(labx).stack_ht = -1; /* not yet known */ label(labx).save_bind_stack_ptr = -1; /* ditto */ label(labx).tra_from = ic; label(labx).tra_from_others = "0"b; go to nextloop; found_label: /* another reference to previously-noted label */ label(labx).tra_from_others = "1"b; nextloop: end; else; /* ignore instructions other than transfer instructions */ end; /* second pass - scan through code and display it */ curlabx = 1; if number_of_labels = 0 then curlabaddr = -1; else curlabaddr = label(1).address; do ic = start repeat(ic+1) while(ic <= start+length-1); /* insert a label if one is called for */ if ic = curlabaddr then do; if label(curlabx).stack_ht >= 0 then stack_height = label(curlabx).stack_ht; if label(curlabx).save_bind_stack_ptr >= 0 then bind_stack_ptr = label(curlabx).save_bind_stack_ptr; if label(curlabx).tra_from_others then others = ", et al."; else others = ""; call ioa_$ioa_switch(stream, "tra from ^o^a", label(curlabx).tra_from, others); curlabx = curlabx + 1; if curlabx <= number_of_labels then curlabaddr = label(curlabx).address; else curlabaddr = -1; end; if words(ic) = ""b then call ioa_$ioa_switch(stream, "^6o^-^w", ic, words(ic)); else if words(ic) = fixnum_type then do; call ioa_$ioa_switch(stream, "^6o^-^w^-"" fixed constant", ic, words(ic)); call ioa_$ioa_switch(stream, "^6o^-^w^-dec ^d", fixed(ic+1,17,0), words(ic+1), convert(make_ioa_not_lose, words(ic+1))); ic = ic + 1; end; else if words(ic) = flonum_type then do; call ioa_$ioa_switch(stream, "^6o^-^w^-"" float constant", ic, words(ic)); call ioa_$ioa_switch(stream, "^6o^-^w^-dec ^a", fixed(ic+1,17,0), words(ic+1), convert_sfl_(words(ic+1), 8)); ic = ic+1; end; else do; call ioa_$ioa_switch(stream, "^6o^-^w^-^a", ic, words(ic), dump_lisp_instruction_(words(ic), ic, tablep, addr(tra_table))); if words(ic) = bind_operator then if ic < start+length then do; /* adjust stack height and push bind stack */ bb_size = fixed(substr(words(ic+1), 1, 18), 18); stack_height = stack_height + bb_size; if bind_stack_ptr > hbound(bind_stack, 1) then signal mll_internal_error; bind_stack(bind_stack_ptr) = bb_size; bind_stack_ptr = bind_stack_ptr + 1; call ioa_$ioa_switch (stream, "^6o^-^w", fixed(ic+1,17,0), words(ic+1)); do ic = ic + 2 to min(start+length-1,fixed(substr(words(ic+1),1,16),17,0)+ic+1); tag1 = fixed(word_structure(ic).bit3, 3, 0); address_1 = word_structure(ic).addr1; address_2 = word_structure(ic).addr2; call ioa_$ioa_switch(stream, "^6o^-^1o ^5a ^6a^-^a", ic, tag1, substr(cv_word(address_1),8,5), substr(cv_word(address_2),7,6), dump_lisp_binding_word_(words(ic), ic, tablep)); end; ic = ic - 1; /* undo do loop slightly. */ end; end; end; return; cv_word: proc(word) returns(char(12)); dcl ioa_$rsnpnnl entry options(variable), word fixed bin, temp char(12), templ fixed bin; call ioa_$rsnpnnl("^w",temp,templ,word); return (temp); end cv_word; end allocate_tra_table; end dump_lisp_code_;  dump_lisp_instruction_.pl1 07/06/83 0936.2r w 06/29/83 1541.3 226458 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* protect old protection notice */ /* (c) Copyright 1973, Massachusetts Institute of Technology. All rights reserved. */ dump_lisp_instruction_: proc(a_word, ic, a_tablep, a_tra_table_p) returns(char(*)); /* modified 73.11.28 by DAM for new subr blocks */ /* modified '78 by BSG for unwind-protect ops */ dcl a_word bit(36) aligned parameter, a_tablep pointer parameter, ic fixed bin(18) parameter, a_tra_table_p pointer parameter; dcl abr bit(1) unal defined(word) pos(30), addr builtin, addrb bit(18) unal defined(word) pos(1), addrf fixed bin(17) unal based(addr(word)), base bit(3) unal defined(word) pos(1), bin builtin, dl bit(6) int static init("000111"b), du bit(6) int static init("000011"b), mod bit(6) unal defined(word) pos(31), offsetb bit(15) unal defined(word) pos(4), offsetf fixed bin(14) unal based(addr(offsetb)), opcode bit(9) unal defined(word) pos(19), hopcode bit(1) unal defined (word) pos(28), /* opcode extension */ output char(64) var, operator fixed bin, atom_name_ptr unaligned pointer, atom_name char(10000) varying aligned based(atom_name_ptr), link_info (1000) bit(27) aligned based, 1 link aligned automatic structure, /* lisp itp link */ 2 address fixed bin(14) unaligned, 2 snap bit(1) unaligned, 2 constant bit(1) unaligned, 2 f bit(1) unaligned, 2 nargs bit(9) unaligned, array_link_control_word(100) bit(36) aligned based, 1 array_link aligned automatic structure, 2 type fixed bin(8) unaligned, 2 ndims fixed bin(8) unaligned, 2 address fixed bin(17) unaligned, (comment_sw, atom_sw, link_sw, tempf) bit(1) aligned, lbound builtin, hbound builtin, substr builtin, convert_sfl_ entry(float bin(27), fixed bin) returns(char(*)), word bit(36) init(a_word); dcl (mll_internal_error, mll_internal_error_2) condition; dcl tablep pointer init(a_tablep); /* table of all locations referenced by transfer instructions */ dcl tra_table_p pointer init(a_tra_table_p), 1 tra_table aligned based(tra_table_p), 2 number_of_labels fixed bin, 2 label(0 refer(number_of_labels)) structure, /* sorted by address */ 3 address fixed bin(18), /* location labelled */ 3 stack_ht fixed bin(18), /* stack_height at tra here, -1 if not known yet */ 3 tra_from fixed bin(18), /* loc of tra to here */ 3 save_bind_stack_ptr fixed bin, /* Value of binding stack ptr */ 3 tra_from_others bit(1); /* 1 -> tra_from is not only place that tras here */ dcl constp pointer, 1 word_pair aligned based, 2 (w1, w2) fixed bin(35); /* declare various tables which are based on tablep */ dcl 1 table aligned structure based(tablep), 2 stack_height fixed bin(17), /* add to ap offset to get 2 * temp number */ 2 atom_table_size fixed bin, /* size of atom_table array */ 2 link_table_ptr unaligned pointer, /* -> array of itp link info */ 2 link_table_lbound fixed bin(18), /* first lp| offset of itp link */ 2 link_table_hbound fixed bin(18), /* last lp| offset of itp link */ 2 array_link_table_ptr unaligned pointer, /* -> array of array_link control words */ 2 array_link_table_lbound fixed bin(18), /* first lp| offset of array link */ 2 array_link_table_hbound fixed bin(18), /* last lp| offset of array link */ 2 definition_table_size fixed bin, /* size of definition_table array */ 2 constant_table_size fixed bin, /* size of constant_table array */ 2 constant_table_lbound fixed bin(18), /* first lp| offset of constant */ 2 constant_table_hbound fixed bin(18), /* last lp| offset of constant */ 2 bind_stack_ptr fixed bin, /* index of first unused entry in bind_stack */ 2 arg_twiddle fixed bin(18), /* eax5 hacker */ 2 seg_ptr unaligned pointer, /* -> text section */ 2 bind_stack (100) fixed bin, /* table of sizes of nested binding blocks */ 2 atom_table (0 refer(atom_table_size)), /* pointers to atomic symbols */ 3 ptr_to_name unaligned pointer, /* -> varying string */ 2 definition_table(0 refer(definition_table_size)), /* entries defined... */ 3 arg_pdl bit(18) unaligned, /* number of pdl cells occupied by args */ 3 entrypoint bit(18) unaligned, /* location of entry */ 3 ptr_to_name unaligned pointer, /* -> varying string */ 2 constant_table(0 refer(constant_table_size)), 3 atom_table_index fixed bin, /* 0 if this constant not an atom */ traref fixed bin(18), (labu, labx, labh) fixed bin; dcl absolute(0:1023) bit(1) int static init( (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"1"b, /* cnaxN */ (5)(1)"0"b, "1"b, "1"b, "0"b, /* cnaa, cnaq */ (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"1"b, /* orxN */ (5)(1)"0"b, "1"b, "1"b, "0"b, /* ora, orq */ (8)(1)"1"b, /* canxN */ (5)(1)"0"b, "1"b, "1"b, "0"b, /* cana, canq */ (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"1"b, /* anxN */ (5)(1)"0"b, "1"b, "1"b, "0"b, /* ana, anq */ (160)(1)"0"b, (8)(1)"0"b, (8)(1)"0"b, (8)(1)"1"b, /* erxN */ (5)(1)"0"b, "1"b, "1"b, "0"b, /* era, erq */ (64)(1)"0"b, (512)(1)"0"b); dcl bases(0:8) char(3) aligned int static init( "ms|", "op|", "tp|", "cp|", "lp|", "rp|", "sp|", "sb|", "us|"); dcl op_names(4:52) char(25) varying static init( "old array store ptr", "nil", "t", "bad addr?", "bind operator", "unbind operator", "errset operator 1", "errset operator 2", "errset remover", "call operator", "catch operator 1", "catch operator 2", "catch remover", "bad addr?", "bad addr?", "iog binding operator", "bad goto operator", "throw operator 1", "throw operator 2", "set indicators from sign", "fixtype,flotype", "return operator", "err operator", "pl1-interface operator", "pl1-l-interface operator", "cons operator", "ncons operator", "xcons operator", "begin list operator", "append list operator", "terminate list operator", "numeric compare operator", "bad addr?", "array reference op?", "dead array ref op?", "store operator", "flonum store operator", "bad addr?", "bad addr?", "array link snap opr?", "create string descriptor", "create array descriptor", "pl1 call operator", "cons string operator", "create var string desc op", "unwind protect operator 1", "unwind protect operator 2", "unwind protect epilogue", "interrupt restore return"); dcl op_stack_adj(4:52) fixed bin static init( /* stack adjustments of these operators */ 0, 0, 0, 0, 0, /* bind is special */ 0, /* unbind is special */ 2, /* errset1 */ 0, /* errset2 */ -2, /* unerrset */ 0, /* call is special */ 2, /* catch1 */ 0, /* catch2 */ -2, /* uncatch */ 0, /* prologue interpreter?? */ 0, /* ?? */ 16, /* iogbind */ 0, /* unseen go tag */ 0, /* throw1 (never returns) */ 0, /* throw2 (never returns) */ 0, /* signp */ 0, /* ?? */ 0, /* return (never returns) */ 0, /* err (never returns) */ 0, /* ?? */ 0, /* ?? */ 0, /* cons */ 0, /* ncons */ 0, /* xcons */ 2, /* list1 */ 0, /* list2 */ -2, /* list3 */ 0, /* compare */ 0,0,0,0,0,0,0,0, /* array oprs */ 0,0,0,0, /* defpl1 operators */ 0,0,0,0,0 /* var string desc and unm_prots */ ); dcl op_special (4:52) fixed bin static init( /* special action code */ 0, 0, 0, 0, 0, /* bind */ 1, /* unbind */ 0, 0, 0, 3, /* call */ 0, 0, 0, 0, 0, 2, /* iog bind */ (33)0); dcl tags(0:63) char(4) aligned int static init( ",00", ",au ", ",qu ", ",du ", ",ic ", ",al ", ",ql ", ",dl ", ",x0 ", ",x1 ", ",x2 ", ",x3 ", ",x4 ", ",x5 ", ",x6 ", ",x7 ", ",* ", ",au*", ",qu*", ",23 ", ",ic*", ",al*", ",ql*", ",27 ", ",x0*", ",x1*", ",x2*", ",x3*", ",x4*", ",x5*", ",x6*", ",x7*", ",ft1", ",itb", ",42 ", ",its", ",sd ", ",scr", ",ft2", ",ft3", ",ci ", ",i ", ",sc ", ",ad ", ",di ", ",dir", ",id ", ",idc", ",*n ", ",*au", ",*qu", ",*du", ",*ic", ",*al", ",*ql", ",*dl", ",*x0", ",*x1", ",*x2", ",*x3", ",*x4", ",*x5", ",*x6", ",*x7"); dcl op_codes(0:1023) char(8) aligned int static init( "arg ", "mme ", "drl ", "*** ", "mme2 ", "mme3 ", "*** ", "mme4 ", "*** ", "nop ", "*** ", "*** ", "*** ", "cioc ", "*** ", "*** ", "adlx0", "adlx1", "adlx2", "adlx3", "adlx4", "adlx5", "adlx6", "adlx7", "*** ", "*** ", "ldqc ", "adl ", "ldac ", "adla ", "adlq ", "adlaq", "asx0 ", "asx1 ", "asx2 ", "asx3 ", "asx4 ", "asx5 ", "asx6 ", "asx7 ", "adwpms", "adwpop", "adwptp", "adwpcp", "aos ", "asa ", "asq ", "*** ", "adx0 ", "adx1 ", "adx2 ", "adx3 ", "adx4 ", "adx5 ", "adx6 ", "adx7 ", "*** ", "awca ", "awcq ", "lreg ", "*** ", "ada ", "adq ", "adaq ", "cmpx0", "cmpx1", "cmpx2", "cmpx3", "cmpx4", "cmpx5", "cmpx6", "cmpx7", "*** ", "cwl ", "*** ", "*** ", "*** ", "cmpa ", "cmpq ", "cmpaq", "sblx0", "sblx1", "sblx2", "sblx3", "sblx4", "sblx5", "sblx6", "sblx7", "*** ", "*** ", "*** ", "*** ", "*** ", "sbla ", "sblq ", "sblaq", "ssx0 ", "ssx1 ", "ssx2 ", "ssx3 ", "ssx4 ", "ssx5 ", "ssx6 ", "ssx7 ", "adwplp", "adwprp", "adwpsp", "adwpsb", "sdbr ", "ssa ", "ssq ", "zam ", "sbx0 ", "sbx1 ", "sbx2 ", "sbx3 ", "sbx4 ", "sbx5 ", "sbx6 ", "sbx7 ", "*** ", "swca ", "swcq ", "ldb ", "*** ", "sba ", "sbq ", "sbaq ", "cnax0", "cnax1", "cnax2", "cnax3", "cnax4", "cnax5", "cnax6", "cnax7", "*** ", "cmk ", "absa ", "epaq ", "sznc ", "cnaa ", "cnaq ", "cnaaq", "ldx0 ", "ldx1 ", "ldx2 ", "ldx3 ", "ldx4 ", "ldx5 ", "ldx6 ", "ldx7 ", "*** ", "rsw ", "ldbr ", "rmcm ", "szn ", "lda ", "ldq ", "ldaq ", "orsx0", "orsx1", "orsx2", "orsx3", "orsx4", "orsx5", "orsx6", "orsx7", "sprims", "spbpms", "spritp", "spbptp", "spri ", "orsa ", "orsq ", "lam ", "orx0 ", "orx1 ", "orx2 ", "orx3 ", "orx4 ", "orx5 ", "orx6 ", "orx7 ", "tspms", "tspop", "call ", "tspcp", "*** ", "ora ", "orq ", "oraq ", "canx0", "canx1", "canx2", "canx3", "canx4", "canx5", "canx6", "canx7", "eawpms", "easpms", "eawptp", "easptp", "*** ", "cana ", "canq ", "canaq", "lcx0 ", "lcx1 ", "lcx2 ", "lcx3 ", "lcx4 ", "lcx5 ", "lcx6 ", "lcx7 ", "eawplp", "easplp", "eawpsp", "easpsp", "*** ", "lca ", "lcq ", "lcaq ", "ansx0", "ansx1", "ansx2", "ansx3", "ansx4", "ansx5", "ansx6", "ansx7", "eppms", "epbpop", "epptp", "epbpcp", "stac ", "ansa ", "ansq ", "stcd ", "anx0 ", "anx1 ", "anx2 ", "anx3 ", "anx4 ", "anx5 ", "anx6 ", "anx7 ", "epplp", "epbprp", "eppsp", "epbpsb", "*** ", "ana ", "anq ", "anaq ", "*** ", "mpf ", "mpy ", "*** ", "*** ", "cmg ", "*** ", "*** ", "*** ", "lde ", "*** ", "*** ", "*** ", "ade ", "*** ", "*** ", "*** ", "ufm ", "*** ", "dufm ", "*** ", "fcmg ", "*** ", "dfcmg", "fszn ", "fld ", "*** ", "dfld ", "*** ", "ufa ", "*** ", "dufa ", "sxl0 ", "sxl1 ", "sxl2 ", "sxl3 ", "sxl4 ", "sxl5 ", "sxl6 ", "sxl7 ", "stz ", "smic ", "*** ", "lacl ", "stt ", "fst ", "ste ", "dfst ", "*** ", "fmp ", "*** ", "dfmp ", "*** ", "*** ", "*** ", "*** ", "fstr ", "*** ", "*** ", "*** ", "*** ", "fad ", "*** ", "dfad ", "rpl ", "*** ", "*** ", "*** ", "*** ", "bcd ", "div ", "dvf ", "*** ", "*** ", "ldcf ", "fneg ", "*** ", "fcmp ", "*** ", "dfcmp", "rpt ", "*** ", "*** ", "*** ", "*** ", "fdi ", "*** ", "dfdi ", "*** ", "neg ", "cam ", "negl ", "*** ", "ufs ", "*** ", "dufs ", "sprpms", "sprpop", "sprptp", "sprpcp", "sprplp", "sprprp", "sprpsp", "sprpsb", "*** ", "stba ", "stbq ", "smcm ", "stc1 ", "*** ", "*** ", "sam ", "rpd ", "*** ", "*** ", "*** ", "*** ", "fdv ", "*** ", "dfdv ", "*** ", "*** ", "*** ", "fno ", "*** ", "fsb ", "*** ", "dfsb ", "tze ", "tnz ", "tnc ", "trc ", "tmi ", "tpl ", "*** ", "ttf ", "rtcd ", "*** ", "*** ", "rcu ", "teo ", "teu ", "dis ", "tov ", "eax0 ", "eax1 ", "eax2 ", "eax3 ", "eax4 ", "eax5 ", "eax6 ", "eppus ", "ret ", "*** ", "*** ", "rccl ", "ldi ", "eaa ", "eaq ", "ldt ", "ersx0", "ersx1", "ersx2", "ersx3", "ersx4", "ersx5", "ersx6", "ersx7", "sprilp", "spbplp", "sprisp", "spbpsp", "*** ", "ersa ", "ersq ", "scu ", "erx0 ", "erx1 ", "erx2 ", "erx3 ", "erx4 ", "erx5 ", "erx6 ", "erx7 ", "tsplp", "tsprp", "tspsp", "tspsb", "*** ", "era ", "erq ", "eraq ", "tsx0 ", "tsx1 ", "tsx2 ", "tsx3 ", "tsx4 ", "tsx5 ", "tsx6 ", "tsx7 ", "tra ", "*** ", "*** ", "callsp","*** ", "tss ", "xec ", "xed ", "lxl0 ", "lxl1 ", "lxl2 ", "lxl3 ", "lxl4 ", "lxl5 ", "lxl6 ", "lxl7 ", "*** ", "ars ", "qrs ", "lrs ", "*** ", "als ", "qls ", "lls ", "stx0 ", "stx1 ", "stx2 ", "stx3 ", "stx4 ", "stx5 ", "stx6 ", "stx7 ", "stc2 ", "stca ", "stcq ", "sreg ", "sti ", "sta ", "stq ", "staq ", "lprpms", "lprpop", "lprptp", "lprpcp", "lprplp", "lprprp", "lprpsp", "lprpsb", "*** ", "arl ", "qrl ", "lrl ", "gtb ", "alr ", "qlr ", "llr ", (64)(1)"***", "mlr ", (63)(1)"***", (32)(1)"***", (9)(1)"***", "spriop","***","spricp",(4)(1)"***", (16)(1)"***", (32)(1)"***", (9)(1)"***","eppop","***","eppcp",(4)(1)"***", (9)(1)"***","epprp","***","eppsb",(4)(1)"***", (64)(1)"***", (64)(1)"***", (4)(1)"***","tmoz","tpnz","ttn",(9)(1)"***", (16)(1)"***", (9)(1)"***","sprirp","***","sprisb",(4)(1)"***", (16)(1)"***", (64)(1)"***"); %include lisp_nums; comment_sw, atom_sw, link_sw, tempf = "0"b; if word = "000140100540"b3 /* hee hee */ then return ("mlr (pr,rl),(pr,rl)"); /* this hack is so we can remember eax5 instructions in case an lsubr later gets called. */ if opcode = "110010101"b /* eax5 */ then arg_twiddle = addrf; output = op_codes(bin(hopcode||opcode)); if abr then do; if base = "001"b then do; if mod = "17"b3 | mod = "37"b3 /* ab|n,x7 is special us ptr */ then do; output = output || bases(8); output = output || cv_octal((offsetf)); if mod & "010000"b then output = output || ",*"; return(output); end; end; output = output || bases(bin(base)); output = output || cv_octal((offsetf)); if base = "001"b /* ab| some offset... */ then do; operator = divide(offsetf,2,17,0); if operator >= lbound(op_names,1) then if operator <= hbound(op_names,1) then comment_sw = "1"b; end; else if base = "000"b then /* ms */ if opcode = "011101000"b then do; /* eppms instruction */ stack_height = stack_height + offsetf; end; else do; /* reference to a temporary cell */ tempf = "1"b; end; else if base = "100"b then do; /* reference to data in subr block */ if offsetf >= constant_table_lbound then if offsetf <= constant_table_hbound then if constant_table(divide(offsetf-constant_table_lbound, 2, 18, 0)+1).atom_table_index ^= 0 then do; atom_name_ptr = atom_table(constant_table(1+divide(offsetf-constant_table_lbound, 2, 18, 0)).atom_table_index).ptr_to_name; atom_sw = "1"b; end; if offsetf >= link_table_lbound then if offsetf <= link_table_hbound then link_sw = "1"b; end; end; else if (mod=dl)|(absolute(bin(hopcode||opcode))&mod=du) then output = output || cv_octal(bin(addrb)); else if (mod=du)&(substr(output,1,1)="f") then output = output || cv_float((addrb)); else output = output || cv_octal((addrf)); if substr(word, 19, 18) = "000101000000000011"b /* adwpms n,du */ then stack_height = stack_height + addrf; else if mod = "000100"b then do; /* ,ic */ output = output || ",ic "; output = output || cv_octal(ic+addrf); constp = addrel(seg_ptr, ic+addrf); /* attempt to display the value of the constant referenced */ if opcode = "001001111"b /* cmpaq */ | opcode = "010011111"b then do; /* ldaq */ output = output || " = "; if constp -> fixnum_fmt.type_info = fixnum_type then do; output = output || "fixnum "; output = output || cv_dec((constp -> fixedb)); output = output || "."; /* indicate decimal */ end; else if constp -> flonum_fmt.type_info = flonum_type then do; output = output || "flonum "; output = output || convert_sfl_(constp -> floatb, 7); end; else do; /* something random */ output = output || cv_octal_word(constp -> w1); output = output || " "; output = output || cv_octal_word(constp -> w2); end; end; else if (opcode & "100001100"b) = "000001100"b then do; /* fixed point add subtract */ output = output || " = "; output = output || cv_dec(constp -> w1); end; else if (opcode & "111110000"b) = "110000000"b | (opcode & "111110000"b) = "111000000"b then; /* transfer */ else do; /* Some random instruction, put it in octal */ output = output || " = "; output = output || cv_octal_word(constp -> w1); end; end; else if mod^=""b then do; output = output || tags(bin(mod)); end; /* check for transfer +n,ic instructions. If we find one, update its entry in label table to contain current stack_height */ if (rt_half & "111111000011111111"b) = "110000000000000100"b /* conditional tra,ic */ | rt_half = "111001000000000100"b then do; traref = ic + addrf; labu = 1; labh = number_of_labels; do while(labh >= labu); labx = labu + divide(labh-labu, 2, 17, 0); if label(labx).address = traref then do; label(labx).stack_ht = stack_height; label(labx).save_bind_stack_ptr = bind_stack_ptr; go to end_tra_loop; end; else if label(labx).address < traref then labu = labx+1; else labh = labx-1; end; /* shouldn't come out this way (label not found) */ end_tra_loop: /* should come out this way */ end; /* end of tra code */ if comment_sw then do; output = output || " "; output = output || op_names(operator); stack_height = stack_height + op_stack_adj(operator); go to ophack(op_special(operator)); ophack(0): go to exit; /* default case */ ophack(1): /* unbind */ bind_stack_ptr = bind_stack_ptr - 1; if bind_stack_ptr <= 0 then signal mll_internal_error; stack_height = stack_height - bind_stack(bind_stack_ptr); go to exit; ophack(2): /* iog bind */ if bind_stack_ptr > hbound(bind_stack, 1) then signal mll_internal_error; bind_stack(bind_stack_ptr) = 16; bind_stack_ptr = bind_stack_ptr + 1; go to exit; ophack(3): /* call */ if ^ link_sw then output = output || " ?????"; /* you have lost badly */ exit: end; else if tempf then do; /* put comment for reference to temporary */ output = output || " temp "; output = output || cv_dec(divide(offsetf+stack_height, 2, 18, 0)); end; else if atom_sw then do; /* display name of referenced atom */ output = output || " "; if substr(word, 31, 2) = "00"b /* not indirect */ then output = output || "'"; /* flag constant rather than variable */ output = output || atom_name_ptr -> atom_name; end; else if link_sw then do; /* decode a link */ output = output || " "; unspec(link) = link_table_ptr -> link_info(divide(offsetf-link_table_lbound, 2, 18, 0)+1); if ^ link.constant then do; output = output || "ms|"; output = output || cv_octal((link.address)); output = output || " (temp "; output = output || cv_dec(divide(link.address+stack_height, 2, 18, 0)); output = output || ")"; end; else do; if link.address >= constant_table_lbound then if link.address <= constant_table_hbound then if constant_table(1+divide(link.address-constant_table_lbound, 2, 18, 0)).atom_table_index ^= 0 then do; /* atomic function */ output = output || atom_table(constant_table(1+divide(link.address-constant_table_lbound, 2, 18, 0)).atom_table_index).ptr_to_name -> atom_name; go to exitgroup; end; /* nonatomic function */ call lphack((link.address)); exitgroup: end; /* special flags */ if link.f then output = output || " [F]"; if link.snap = "0"b then output = output || " [nosnap]"; /* adjust stack height according to number of arguments */ if link.f then stack_height = stack_height - 2; else if link.nargs = "111111111"b then stack_height = stack_height + arg_twiddle; else stack_height = stack_height - 2*fixed(link.nargs, 9); end; else if abr then if base = "100"b then if opcode = "111001110"b then do; /* xec of an array link */ unspec(array_link) = array_link_table_ptr -> array_link_control_word( divide(offsetf-array_link_table_lbound, 4, 17, 0)+1); output = output || " array "; if array_link.address >= constant_table_lbound then if array_link.address <= constant_table_hbound then if constant_table(1+divide(array_link.address-constant_table_lbound, 2, 17, 0)).atom_table_index ^= 0 then do; output = output || atom_table(constant_table(1+divide(array_link.address-constant_table_lbound, 2, 17, 0)).atom_table_index).ptr_to_name -> atom_name; end; end; return(output); dump_lisp_binding_word_: entry(a_word, ic, a_tablep) returns(char(*)); dcl bind_class (0:7) char(5) varying static init( "op|", "ms|", "lp|", "", "ms|", "C(x5)", "ms|", "lp|"), bind_tags (0:7) char(3) varying static init( "", "", "", ",ic", "", "", ",*", ",*"), rt_half bit(18) unal defined(word) pos(19), rt_half_fb fixed bin(17) unal based(addr(rt_half)); output = "bind "; if base = "100"b then output = output || """argatom"""; else do; /* binding atom, discover its name */ if offsetf >= constant_table_lbound then if offsetf <= constant_table_hbound then if constant_table(1+divide(offsetf-constant_table_lbound, 2, 18, 0)).atom_table_index ^= 0 then output = output || atom_table(constant_table(1+divide(offsetf-constant_table_lbound,2 , 18, 0)).atom_table_index).ptr_to_name -> atom_name; else call lphack((offsetf)); else call lphack((offsetf)); else call lphack((offsetf)); end; output = output || " to "; output = output || bind_class(fixed(base,3)); if base ^= "101"b then do; output = output || cv_octal((rt_half_fb)); output = output || bind_tags(fixed(base, 3)); end; if base = "000"b /* stack constant... */ then do; operator = divide(rt_half_fb,2,17,0); if operator >= lbound(op_names,1) & operator<= hbound(op_names,1) then do; if length(output) < 16 then output = output || " "; output = output || " "; output = output || op_names(operator); end; end; else if base = "001"b | base = "110"b | base = "100"b then do; /* ms| */ if length(output) < 16 then output = output || " "; output = output || " temp "; output = output || cv_dec(divide(rt_half_fb+stack_height, 2, 18, 0)); end; else if base = "010"b | base = "111"b then do; /* lp| */ if length(output) < 16 then output = output || " "; output = output || " "; if rt_half_fb >= constant_table_lbound then if rt_half_fb <= constant_table_hbound then if constant_table(1+divide(rt_half_fb-constant_table_lbound, 2, 18, 0)).atom_table_index ^= 0 then output = output || atom_table(constant_table(1+divide(rt_half_fb-constant_table_lbound, 2, 18, 0)).atom_table_index).ptr_to_name -> atom_name; else call lphack((rt_half_fb)); else call lphack((rt_half_fb)); else call lphack((rt_half_fb)); end; else if base = "011"b then do; /* ,ic */ if length(output) < 16 then output = output || " "; output = output || " "; output = output || cv_octal(rt_half_fb+ic); end; return (output); lphack: proc(xx); dcl xx fixed bin (17) parameter; output = output || "lp|"; output = output || cv_octal((xx)); end lphack; cv_dec: proc(value) returns(char(*)); dcl value fixed bin(35), convert_binary_integer_$decimal_string entry(fixed bin(35)) returns(char(12) varying); return(convert_binary_integer_$decimal_string(value)); end; cv_octal: proc(value) returns(char(*)); dcl convert_binary_integer_$octal_string entry(fixed bin(35)) returns(char(13) var), value fixed bin(35); return(convert_binary_integer_$octal_string(value)); end; cv_float: proc(value) returns(char(*)); dcl fnum float bin(27), unspec builtin, value bit(*); unspec(fnum) = value; return(convert_sfl_(fnum, 4)); end; cv_octal_word: procedure(value) returns(char(12)); dcl value fixed bin(35), bits bit(36) aligned, i fixed bin, (unspec, string, substr) builtin, results (12) char(1) unaligned, Zero bit(6) static init("000110"b); bits = unspec(value); do i = 1 to 12; unspec(results(i)) = Zero || substr(bits, 3*i-2, 3); end; return(string(results)); end; end;  get_alm_op_.pl1 07/06/83 0936.2r w 06/29/83 1541.3 24111 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1974 * * * ************************************************************** */ /* Procedure to look up a symbol in alm's symbol table Part of Multics LISP Assembly Program 75.01.23 DAM */ get_alm_op_: procedure(a_symbol, value); dcl a_symbol char(*), /* symbol to be looked up, no padding */ value fixed bin(35); /* its value, -1 if not found in table */ /* -2 if takes register number */ dcl 1 alm$opcode_table aligned external structure, 2 number_of_symbols fixed bin(35,1), /* word contains 2*hbound of symbols array */ 2 symbols_relp bit(18) unaligned, /* relative pointer to symbols array */ 2 values_relp bit(18) unaligned, /* relative pointer to values array */ symbols_ptr pointer init(addrel(addr(alm$opcode_table),symbols_relp)), alm_nsymbol(0:number_of_symbols) fixed bin(71) aligned based(symbols_ptr), values_ptr pointer init(addrel(addr(alm$opcode_table), values_relp)), 1 alm_values_table (0:number_of_symbols) aligned structure based(values_ptr), 2 pseudo bit(18) unaligned, /* pseudo op status */ 2 opcode bit(10) unaligned, 2 opclass fixed bin(7) unaligned; dcl symbol char(8) aligned based(addr(nsymbol)); /* symbol munged into fortran format */ dcl nsymbol fixed bin(71); /* for comparison */ dcl (A9BD_TYPE init("000000000000110101"b), PTRN_TYPE init("000000000000101100"b), NDXN_TYPE init("000000000000101011"b) ) bit(18) static; /* interesting values of pseudo field */ dcl (i, j, k) fixed bin; dcl (addr, addrel, unspec, substr, length, divide) builtin; unspec(symbol) = ""b; /* so as to pad with null characters */ substr(symbol, 1, length(a_symbol)) = a_symbol; j = 1; k = number_of_symbols; /* binary search */ do while(j <= k); i = j + divide(k-j, 2, 17, 0); /* probing point */ if alm_nsymbol(i) = nsymbol then do; if opclass(i) = 1 then go to lose; /* old */ if opclass(i) = 4 then go to lose; /* old */ if pseudo(i) = ""b then value = fixed(opcode(i)||"00000000"b, 18); else if pseudo(i) = A9BD_TYPE then value = fixed(opcode(i)||"00000000"b, 18); else if pseudo(i) = PTRN_TYPE then value = -2; /* op ptr,addr */ else if pseudo(i) = NDXN_TYPE then value = -2; /* op xr,addr */ else go to lose; /* not interesting */ return; end; else if alm_nsymbol(i) < nsymbol then j = i+1; else k = i-1; end; lose: value = -1; /* not found */ return; end;  lap_.lisp 07/06/83 0936.2r w 06/29/83 1541.3 431856 ;;; ************************************************************** ;;; * * ;;; * Copyright, (C) Massachusetts Institute of Technology, 1974 * ;;; * * ;;; ************************************************************** ;;;;;; ;;;;;; Multics Lisp Assembly Program (LAP) ;;;;;; ;;;;;; Written July 1974 by D Reed ;;;;;; Modified January 1975 by D Moon for bugs + features galore (declare (special pc ; actual pc of code generated. codelist ; list of internal code representations, reverse order of generation. constant-list ; list of all constants referenced by program, maintained by get-const. constant-size ; space occupied by all constants referenced by program. literal-list ; list of all literal constants referenced by program, maintained by get-const. literal-size ; space occupied by all literal constants referred to in code. max-literal-bound ; maximum boundary required by literals literal-start ; offset of literals from where we originally expected them to be...kept by ; pass2 and initialize slot-types, used by pass2. in-literal ; flag for assembling a literal entry-list functions-called ; list of names for functions called within compiled code. fcn-size ; counter used in allocating space for function links. pl1-link-list ; list of "foo$bar" links pl1-link-size ; next available address in linkage section array-type ; type of array just referenced. array-links ; list of array links. array-size ; counter used in allocating array-link space. functions-defined ; list of name-entrypoint pairs for functions compiled. relocation ; aux result from laprel1 text-relocation ; count of text relocations link-relocation ; .. link .. static-relocation ; .. static .. barfp ; used to detect compiler errors in debug mode. dataerrp nowarn first-eof messioc current-function seg-name ; free variable passed from pass 1, contains name of segment. time-option total-time ; on if times are to be printed on console... base ; good old output base... *nopoint ; and format controller...we must force base 10 output sometimes. lapreadtable ; readtable for lap code. being-compiled errflag source-map ) (array* (notype (fcn-table ?) (const-table ?))) (fixnum pc relocation text-relocation link-relocation static-relocation constant-size literal-size fcn-size array-size base) (do i (read) (read) (equal i ''END) (eval i)) ; read up compile time operations. ) ; compile time operations: (sstatus macro /! '(lambda () (list 'quote ((lambda (x) (or (get x '/!) (error "undefined compile time constant" x))) (read)) ))) (setq vertical-status (status macro /|)) (sstatus macro /| nil) (defun setm fexpr (l) (do x l (cddr x) (null x) (putprop (car x) (cadr x) '/!))) (setm bit29 100 * 20 lpI -377777777700 abIx7 100000000117 abInil 100012000100 abIt 100014000100 ic 4 Text18 20 ;relocation codes -Text18 21 Link18 22 -Link18 23 Link15 24 Static18 30 Static15 31 fixnum-type 40047 flonum-type 20047 const-table-size 111. ; size of constant hash table. fcn-table-size 111. ; size of function hash table, used to detect identical calls. ) 'END ; end of compile time operations. (setq time-option nil total-time nil ) (array const-table t !const-table-size) (array fcn-table t !fcn-table-size) (declare (defpl1 cg-util "lisp_cg_utility_" (char(*)) (lisp) (char(*)) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp))) (declare (defpl1 make_lisp_listing "" (char(*)) )) (declare (defpl1 get_alm_op_ "" (char(*)) (return fixed bin(35.)) )) (%include compiler-macros) ;get macros common to pass 1 and pass 2 (defun logor macro (x) (displace x (cons 'boole (cons 7 (cdr x))))) (defun logand macro (x) (displace x (cons 'boole (cons 1 (cdr x))))) (defun left macro (x) (displace x (list 'lsh (cadr x) 18.))) ;;; functions to assign addresses to literals and constants referenced by the code. (defun get-literal-addr (const) (or (car const) ;literal has address or nil in car (barf const "literal has not had address assigned" barf))) ;address supposed to be assigned by make-literal (defun get-constant-addr (const) ; takes arg in standard "uniquized" representation for constant, returns addr. (cond ((cddr const)) ; cddr is address if already assigned. (t (rplacd (cdr const) constant-size) ; assign new address (setq constant-size (+ 2 constant-size) ; and up the length of constants. constant-list (cons const constant-list)) (cddr const)))) (defun get-fcn-addr (const) ; assign address for function link, if not already assigned. (cond ((cddddr (cdr const))) ; if already assigned, address is cdddddr of function representation. (t (rplacd (cddddr const) fcn-size) ; put new address in representation for future use. (setq fcn-size (+ fcn-size 2) ; 2 words allocated for link. functions-called (cons const functions-called)) ; note that we have to make the link later. (- fcn-size 2)))) ; return the address of the link. (defun get-array-link-addr (x) ;assign address for array link (cond ((cddddr (cdr x))) ;already assigned. (t (rplacd (cddddr x) array-size) ;insert address (setq array-size (+ array-size 4)) ;allow for 4-word block. (setq array-links (cons x array-links)) (- array-size 4)))) ;return the address of the array-link. (defun get-pl1-link (name) ((lambda (address) (setq pl1-link-size (+ address 2)) (push name pl1-link-list) (list address '*link)) ;return relocatable address pl1-link-size)) (defun get-function (x snap? type nargs) ; function to maintain unique function representation. ((lambda (hash bucket) ; some temp variables. (setq bucket (fcn-table hash)) (do ((scan bucket (cdr scan))) ((null scan) (store (fcn-table hash) (cons (setq x (list 'function x snap? type nargs)) ; make unique representation if not found bucket)) x) (and (eq x (cadar scan)) ; if all 4 components are eq, then use this existing representation. (eq snap? (caddar scan)) (eq type (cadddr (car scan))) (eq nargs (cadddr (cdar scan))) (return (car scan))))) (abs (\ (cond ((eq (car x) 'temp) (cadr x)) ; if in a temp, hash by temp offset. (t (sxhash (cadr x)))) ; otherwise, must be (quote < > ), hash by object. !fcn-table-size)) nil)) (defun make-const (x) ; function to uniquize the representation of a constant. (cond ((eq x nil) '(quote nil)) ((eq x t) '(quote t)) (t ((lambda (hash bucket) ; some temporary variables. (setq bucket (const-table hash)) ; get hash table bucket. (do ((scan bucket (cdr scan))) ; look down bucket for already created representation. ((null scan) ; when no more... (store (const-table hash) (cons (setq x (list 'quote x)) bucket)) ; put newly created representation in bucket. x) ; return new representation. (cond ((equal (cadar scan) x) (return (car scan)))))) (abs (\ (sxhash x) !const-table-size)) nil)))) (defun get-const (const) ; given (quote ), get unique representation. (cond ((smallnump (setq const (cadr const))) (make-literal (list nil 2 !fixnum-type const))) ((floatp const) (make-literal (list nil 2 !flonum-type const))) (t (make-const const)) )) (defun make-literal (x) ;literals are: (address boundary . data-list) ;note - cadr is a smallnum which fakes out lapinst (setq max-literal-bound (max max-literal-bound (cadr x))) (do ((l literal-list (cdr l)) (loc 0 (1+ loc))) ((= loc literal-size) ;see if can overlap with existing literals (do () ((zerop (\ loc (cadr x)))) (rplacd (last literal-list) (list 0)) (setq loc (1+ loc))) (setq literal-size (+ loc (length (cddr x)))) (setq literal-list (nconc literal-list (append (cddr x) nil))) (rplaca x loc) x) (and (zerop (\ loc (cadr x))) ;if on right boundary, (list-equal (cddr x) l) ;and same data (return (rplaca x loc))) )) ;then put it here ;Note this doesn't catch the case where ;and initial segment of it ends literal-list (defun list-equal (x y) ;compare two lists of numbers. eq because could be fix or flo. (cond ((null x) ;first list ends, count as a match t) ((null y) ;second list ends before first, no match nil) ((eq (car x) (car y)) (list-equal (cdr x) (cdr y)) ))) ;sure wish this lisp had a jcall... (defun make-call-link (fn-name snap? type nargs) (logor (cond ((eq (car fn-name) 'temp) (lsh (cadr fn-name) 12.)) ((logor 2000 (lsh (+ 1 (get-constant-addr fn-name)) 12.)) )) ; constant-list munged by now. (cond (snap? 4000) (t 0)) (cond ((eq type 'fsubr) 1001) ((eq type 'lsubr) 777) (t nargs)))) (defun make-array-link (array type ndims) (get-function (make-const array) type 'array ndims)) (defun add-right-half (x y) ; add x to right halfword of y, returning left half of y logor result of add. (logor (logand 777777_18. y) (logand 777777 (+ x y)))) ;(defun clear-out-useless-fns () ; gets rid of functional temp references... ; (do i 0 (1+ i) (= i !fcn-table-size) ; (mapc '(lambda (x) (and (eq (caadr x) 'temp) ; is temp. ; (rplacd (cddddr x) nil) ; forget we had one. ; )) ; (fcn-table i)))) (defun make-array-link-control-word (array type ndims) (logor (lsh (cond ((eq type 'fixnum) 2) ((eq type 'flonum) 3) (t 0)) 27.) ;type code (lsh ndims 18.) ;number of dimensions (1+ (get-constant-addr array)))) (defun finish-code () (prog (function-rel array-link-rel type-list def-length intime) (setq intime (runtime)) (setq function-rel 0 def-length 0 type-list (subst nil nil '((fixnum) (flonum) (string) (bignum) (symbol)(list)))) (map '(lambda (l) (setq function-rel (1+ function-rel)) (rplaca l (analyze (cadar l) type-list))) constant-list) (mapc '(lambda (x) (rplaca x (cdr (assq (car x) '((nil . 0) (expr . 1_18.) (lexpr . 2_18.) (fexpr . 3_18.))))) (rplacd x (analyze (cdr x) type-list)) (setq def-length (1+ def-length))) functions-defined) (fix-type-list type-list) (setq array-link-rel (+ function-rel (length entry-list) (length functions-called))) (map '(lambda (l) (rplaca l (get-object-offset (car l)))) constant-list) (map '(lambda (l) (rplaca l (logor (caar l) (get-object-offset (cdar l))))) functions-defined) (map '(lambda (l) (and (not (atom (car l))) (cond ((eq (caar l) 'function) (rplaca l (+ (cdar l) (lsh function-rel 19.)))) ((eq (caar l) 'array) (rplaca l (+ (cdar l) (lsh array-link-rel 19.))))))) codelist) (cg-util seg-name (cdr (nreverse codelist)) "Multics LISP Assembly Program, Version 1.1, January 1975" (cons (length source-map) (nreverse source-map)) (car type-list) (cadr type-list) (caddr type-list) (cadddr type-list) (car (cddddr type-list)) (cadr (cddddr type-list)) (cons (length entry-list) (nreverse entry-list)) (cons function-rel (nreverse constant-list)) (cons (length functions-called) (nreverse functions-called)) (cons def-length (nreverse functions-defined)) (cons (length array-links) (nreverse array-links)) (cons (length pl1-link-list) (nreverse pl1-link-list)) ) (and total-time (iog vt (terpri) (princ "Object creation time = ") (prin1 (//$ (float (- (runtime) intime)) 1000000.0)) (terpri))))) (defun init-code-generator () (setq constant-size 0 fcn-size 0 array-size 0 functions-defined nil array-links nil pl1-link-list nil pl1-link-size 10 functions-called nil entry-list nil constant-list nil) (fillarray 'fcn-table '(nil)) (fillarray 'const-table '(nil)) (setq pc 0 codelist (ncons nil))) ;;; function to analyze constants referenced by lisp compiled code (defun analyze (x type-lists) ;; x is the object, type-lists is a list of the form ;; ((fixnum ...) ;; (flonum ...) ;; (string ...) ;; (bignum ...) ;; (symbol ...) ;; (list ..)) ((lambda (type) ((lambda (l) (cons type ; returns ( .) (cond ((eq type 'nil) 0) ((eq type 'list) (do ((scan (cdr l) (cdr scan)) (last l scan) (i 1 (1+ i))) ((null scan) (list-analyze x i last type-lists)) (cond ((eq x (caar scan)) (return i))))) (t (do ((scan (cdr l) (cdr scan)) (last l scan) (i 1 (1+ i))) ((null scan) (rplacd last (ncons x)) i) (cond ((equal x (car scan)) (return i)))))))) (assq type type-lists))) (and x (typep x)))) ;;; function to insert list-type objects into type-lists. ;;; relies on the fact that sublists are not eq to existing lists. ;;; thus inserts all of the skeleton into the type-list and analyze's only ;;; the fringes. (declare (special list-offset list-last)) (defun list-analyze (x list-offset list-last type-lists) (setq x (ncons (cons x (cons (lanalyze (car x) type-lists) (lanalyze (cdr x) type-lists))))) ; changes list-last, list-offset. (rplacd list-last x) list-offset) (defun lanalyze (x type-lists) ; basic analyzer (cond ((atom x) (analyze x type-lists)) ; if atomic, use ordinary analyzer. (t (setq x (ncons (cons nil (cons (lanalyze (car x) type-lists) (lanalyze (cdr x) type-lists))))) ;; note that we forget the value of x here, unlike in list-analyze, because ;; we know that its value will never be eq to any other list we will see. (rplacd list-last x) (prog2 (setq list-last (cdr list-last)) ; update the end of the list pointer (cons 'list list-offset) (setq list-offset (+ list-offset 1)))))) ; update the count of items. (declare (special type-offsets)) (defun fix-type-list (type-list) ;; takes type-list, and rplaca's lengths into type buckets, and ;; fixes up the cons list to be a list of 36 bit numbers. ;; generates the special variable type-offsets for use by ;; get-object-offset ((lambda (base-offset) (setq type-offsets (ncons (cons nil 0))) (mapc '(lambda (tl) (setq type-offsets (cons (cons (car tl) base-offset) type-offsets)) (cond ((eq (car tl) 'list) (map '(lambda (x) (rplaca x (logor (lsh (get-object-offset (cadar x)) 18.) (get-object-offset (cddar x))))) (cdr tl)))) (setq base-offset (+ (car (rplaca tl (length (cdr tl)))) base-offset))) type-list)) 0)) (defun get-object-offset (x) ;; returns absolute offset in constant table of object (+ (cdr x) (cdr (assq (car x) type-offsets)))) (defun lapup (fn-name type nargs) ; main lap interface.... ((lambda (intime literal-size max-literal-bound in-literal literal-start literal-list readtable) ; (clear-out-useless-fns) ; not needed because no temp-size reloc (setq entry-list (cons (logor (left nargs) pc) entry-list)) (setq functions-defined (cons (cons (cdr (assq type '((subr . expr) (lsubr . lexpr) (fsubr . fexpr)))) fn-name) functions-defined)) (setq codelist (cons nil codelist)) ; mark our entry point. (do word (read) (read) (null word) (lapword word)) ; gobble down words (cond (literal-list ; put literals (do () ((zerop (\ pc max-literal-bound))) (push 0 codelist) (setq pc (1+ pc))) (setq literal-start pc) (setq codelist (nreconc literal-list codelist)) (setq pc (+ pc literal-size)) )) (do scan functions-called (cdr scan) (or (null scan) (fixp (car scan))) (rplaca scan (make-call-link (car (setq type (cdar scan))) (cadr type) (caddr type) (cadddr type)))) (do scan array-links (cdr scan) (or (null scan) (fixp (car scan))) (rplaca scan (make-array-link-control-word (car (setq type (cdar scan))) (cadr type) (cadddr type)))) (do ((code codelist (cdr code)) (word)) ((null (setq word (car code))) ; if found the beginning of this function... ; delete out the nil. (rplaca code (cadr code)) (rplacd code (cddr code))) ; splice in code to init types (cond ((numberp word)) ((eq (car word) 'literal) ((lambda (word) (or (= (logand word 17) !ic) ;if not ,ic reference, (setq word (cons !Text18 word))); is relocatable (rplaca code word)) (+ (cdr word) (left literal-start)))) ((eq (car word) 'relocate) (rplaca code (lapreloc (cadr word) (caddr word) (cdddr word) 0))) ((eq (car word) 'function) ) ((eq (car word) 'array) ) ((eq (car word) 'bindliteral) (rplaca code (add-right-half literal-start (cdr word)))))) (flushsyms) (and time-option (iog vt (princ "LAP Assembly time for ") (prin1 fn-name) (princ ":") (princ (quotient (- (runtime) intime) 1.0e6))(terpri))) ) (runtime) 0 0 nil 0 nil lapreadtable)) (defun lapword (word) ; assemble one word ((lambda (tem) (cond ((numberp word) (outwrd (lapeval word))) ((atom word) (and in-literal (warn word "tag in literal")) (lapdefsym word (list pc '*text))) ((eq tem 'defsym) (eval word)) ((eq tem 'equ) (equ| (cdr word))) ((eq tem 'entry) (entry| (cdr word))) ((eq tem 'comment)) ((eq tem 'eval) (mapc (function eval) (cdr word))) ((eq tem 'get-linkage) ; getlp pseudo op except gets lb (outwrd 213000) ; epaq 0 (outwrd -77751012617)) ; lprplb sb|lot_ptr,*au ((eq tem 'block) (block| (cadr word))) ((eq tem 'ascii) (ascii| (cdr word))) ((eq tem 'bind) (bind| (cdr word))) ((eq tem 'sprip) ; should be spri p, addr but for alm deficiency... (lapcode (cons (implode (append '(s p r i) (list (lapregch (cadr word))))) (cddr word)))) ((get tem 'macro) ;expand a macro (mapc 'lapcode (macro-expand word (get tem 'macro)))) ((setq tem (get tem 'EIS)) (lapeis word tem)) (t (lapcode word)))) (or (atom word) (car word)) )) ;bind tem to operation name (defun macro-expand (x f) ;returns expanded macro - x is form, f is functional (macro property) (cond ((errset (setq x (funcall f x))) x) ;win, return expanded result (t (barf x "lisp error during macro expansion" data) ''nil) )) ;again, lose, make result nil ; lisp_cg_utility_ takes relocation bits as follows: ; if codelist contains ( number . number ) then the cdr is the word and ; the car has the du relocation in its dl and the dl relocation in its du (zero=abs) (defun lapreloc (dl du ptr relocation) (setq dl (laprel1 dl) relocation (left relocation) du (laprel1 du)) (setq ptr (cond ((null ptr) (logor (logand dl 777777) (left du))) (t (setq relocation (cond ((= relocation !Link18) !Link15) ((= relocation !Static18) !Static15) ((= relocation 0) 0) (t (barf nil "improper relocation" data)))) (logor (lsh (laprel1 ptr) 33.) (logand dl 777777) (left (logand du 77777)))))) (cond ((zerop relocation) ptr) ;non relocatable word ((cons relocation ptr)))) ;relocatable word (defun laprel1 (reloc) ((lambda (text-relocation link-relocation static-relocation) (prog2 nil (cond ((numberp reloc) reloc) ((+ (car reloc) (- (lapsymsum (cadr reloc) 1) (lapsymsum (cddr reloc) -1))))) (setq relocation (logor relocation (cond ((not (zerop text-relocation)) (or (zerop (logor link-relocation static-relocation)) (barf nil "mixed relocation" data)) (cond ((= text-relocation 1) !Text18) ((= text-relocation -1) !-Text18) ((barf text-relocation "multiple relocation" data)))) ((not (zerop link-relocation)) (or (zerop static-relocation) (barf nil "mixed relocation" data)) (cond ((= link-relocation 1) !Link18) ((= link-relocation -1) !-Link18) ((barf link-relocation "multiple relocation" data)))) ((not (zerop static-relocation)) (or (= static-relocation 1) (barf static-relocation "multiple relocation" data)) !Static18) (t 0)))))) 0 0 0)) (defun pense-au-relocation (thing direction) (cond ((eq thing '*text) (setq text-relocation (+ text-relocation direction))) ((eq thing '*link) (setq link-relocation (+ link-relocation direction))) ((eq thing '*static) (setq static-relocation (+ static-relocation direction))) ((barf thing "bad relocation" barf)) )) (defun lapsymsum (thing direction) (cond ((null thing) 0) ((fixp thing) thing) ((memq thing '(*text *link *static)) ;relocation flag could be here too (pense-au-relocation thing direction) 0) ((fixp (car thing)) (+ (car thing) (lapsymsum (cdr thing) direction))) ((memq (car thing) '(*text *link *static)) ;relocation flag (pense-au-relocation (car thing) direction) (lapsymsum (cdr thing) direction)) ((+ (lapsymsum (or (get (car thing) 'sym) (prog2 (barf (car thing) " undefined symbol." data) 0)) direction) (lapsymsum (cdr thing) direction))))) (declare (special symlist)) (setq symlist nil) (defun lapevaln (x) ;ensure numeric result ((lambda (xx) (or (smallnump xx) (barf x "cannot be reduced to a number" data)) xx) (lapeval x))) (defun lapeval (x) (cond ((null x) 0) ((eq x '*) pc) ((floatp x) x) ; flonums as words or literals... ((smallnump x) x) ((bigp x) (logor (lsh 1 35.) (haipart x -35.))) ;e.g. 777777777777 -> fixnum -1 ((atom x) (lapsymval x)) ((eq (car x) '+) (lap+l (mapcar 'lapeval (cdr x)))) ((eq (car x) '-) (lap-l (mapcar 'lapeval (cdr x)))) (t (lapeval (cons '+ x))))) (defun lapsymval (name) ((lambda (val) (or val (list 0 (ncons name)))) (get name 'sym))) (defun lap+l (list) (cond ((null list) 0) (t (lap+ (car list) (lap+l (cdr list)))))) (defun lap-l (list) (cond ((null list) 0) ((null (cdr list)) ;(- a) => -a not a (lap- 0 (car list))) (t (lap- (car list) (lap+l (cdr list)))))) (defun lap+ (x y) (cond ((and (fixp x) (fixp y)) (+ x y)) ((fixp x) (cons (+ x (car y)) (cdr y))) ((fixp y) (lap+ y x)) (t (cons (+ (car x) (car y)) (cons (append (cadr x) (cadr y)) (append (cddr x) (cddr y))))))) (defun lap- (x y) (cond ((and (fixp x) (fixp y)) (- x y)) ((fixp x) (cons (- x (car y)) (cons (cddr y) (cadr y)))) ((fixp y) (cons (- (car x) y) (cdr x))) (t (cons (- (car x) (car y)) (cons (append (cadr x) (cddr y)) (append (cddr x) (cadr y))))))) (defun lapdefsym (name val) (putprop name val 'sym) (setq symlist (cons name symlist))) (defun flushsyms () (mapc '(lambda (x) (remprop x 'sym)) symlist)) (defun outlap (dl du) (outwrd (cond ((and (fixp dl) (fixp du)) (logor (logand dl 777777) (left du))) (t (list 'relocate dl du))))) (defun outwrd (wrd) (or in-literal (setq pc (1+ pc))) (push wrd codelist)) (defun lapcode (word) ((lambda (opcode) ;look up in ALM symbol table (cond ((= opcode -1)) ;not known to alm, proceed using lap evaluation ((= opcode -2) ;e.g. epp bp, foo (setq word (cons (intern (make_atom (catenate (car word) (lapregch (cadr word))))) (cddr word)))) (t (rplaca word opcode))) ;ordinary opcode, stick it in (cond ((null (cdr word)) (lapinst (car word) 0 0)) ((null (cddr word)) (lapinst (car word) (cadr word) 0)) ((eq (caddr word) '/|) (lapcode (cons (car word) (cdddr word))) (setq word (lapeval (cadr word))) (rplaca codelist (addbaseref (car codelist) word))) (t (lapinst (car word) (cadr word) (caddr word))))) (cond ((eq (typep (car word)) 'symbol) (get_alm_op_ (car word))) (t -1)) )) (defun lapregch (x) ;make lap expression into character of register number (substr "01234567" (1+ (logand 7 (lapevaln x))) 1)) (defun addbaseref (word ptr) (cond ((and (fixp ptr) (fixp word)) (cond ((minusp ptr) ;us pointer = ab|,x7 (logor !abIx7 (logand word 77777777777))) ((logor (lsh ptr 33.) !bit29 (logand word 77777777777))))) ((fixp word) (cons 'relocate (cons (logor !bit29 (logand 777777 word )) (cons (logand 777777 (lsh word -18.)) ptr)))) (t (cons 'relocate (cons (lap+ !bit29 (cadr word)) (cons (caddr word) ptr)))))) ; this is a pretty poor way to get around this bit 29 loss (defun addbaserefeiskludge (word ptr) (cond ((and (fixp ptr) (fixp word)) (cond ((minusp ptr) ;us pointer = ab|,x7 (barf nil "Sorry, can't have us| in an EIS descriptor." data)) ((logor (lsh ptr 33.) (logand word 77777777777))))) ((fixp word) (cons 'relocate (cons (logand 777777 word ) (cons (logand 777777 (lsh word -18.)) ptr)))) (t (cons 'relocate (cons (cadr word) (cons (caddr word) ptr)))))) ; Assemble a literal (defun lap-literal (x) ((lambda (codelist pc in-literal alignment) ;use regular assembler, different codelist (cond ((eq 'symbol (typep (cadr x))) ;one word literal (lapword (cdr x))) ((mapc 'lapword (cdr x)))) ;multi-word literal (make-literal (cons nil (cons alignment (nreverse codelist))))) nil pc t (cond ((eq (car x) '%) 1) (t 2)) )) (defun lapinst (opc addr tag) (and (eq tag '*) (setq tag 20)) ; * in tag context differs. (cond ((eq tag '$) ; -*,ic reference (setq tag 'ic) (setq addr (list '- addr '*)))) (setq tag (lapeval tag) opc (lap+ (lapeval opc) tag)) (or (fixp tag) (warn tag " strange tag.")) (cond ((fixp addr) (outlap opc addr)) ((floatp addr) (outlap opc (lsh addr -18.))) ;1.0,du ((atom addr) (outlap opc (lapsymval addr))) ((memq (car addr) '(% %%)) ;literal (or (numberp opc) (barf addr " ill literal" data)) (setq addr (get-literal-addr (lap-literal addr))) ;assemble literal (outwrd (cons 'literal (cond ((and (not in-literal) (or (= tag 0) (= tag !*))) ;can use relative addressing (logor opc !ic (left (- addr pc)))) ((logor opc (left addr)))) ))) ;have to use absolute addressing ((eq (car addr) 'quote) (or (and (numberp opc) (zerop tag)) (prog2 (barf addr " illegal quote." data) (setq opc 0))) (setq addr (get-const addr)) ; add addr to tables. (cond ((eq (cadr addr) nil) (outwrd (logor opc !abInil))) ((eq (cadr addr) t) (outwrd (logor opc !abIt))) ((or (smallnump (cadr addr)) (floatp (cadr addr))) (outwrd (cons 'literal (logor opc !ic (left (- (get-literal-addr addr) pc)))))) ((outwrd (logor opc !lpI (left (1+ (get-constant-addr addr)))))))) ((eq (car addr) 'special) (or (and (fixp opc) (eq (typep (cadr addr)) 'symbol) (= tag 0)) (prog2 (barf addr " illegal special reference." data) (setq opc 0))) (outwrd (logor opc !* !lpI (left (1+ (get-constant-addr (make-const (cadr addr)))))))) ((eq (car addr) 'array) (or (and (fixp opc) (= tag 0) (eq (typep (cadr addr)) 'symbol) (memq (caddr addr) '(t nil fixnum flonum)) (fixp (cadddr addr))) (barf addr " illegal array reference" data)) (outwrd (cons 'array (logor opc !lpI !* (left (1+ (get-array-link-addr (make-array-link (cadr addr) (caddr addr) (cadddr addr))))))))) ((and (eq (car addr) 'function) (eq (caddr addr) '/|)) ;temp function (or (and (fixp opc) (= tag 0)) (barf addr "illegal temp function reference" data)) (or (signp e (lapeval (cadr addr))) ;base better be ap (barf addr "temp function reference not to marked stack" data)) (or (signp l (setq tag (lapeval (cadddr addr)))) ;offset from ap (barf addr "illegal temp function reference" data)) (outwrd (cons 'function (logor opc !lpI !* (left (1+ (get-fcn-addr (get-function (list 'temp tag) nil (car (cddddr addr)) (cadr (cddddr addr)) )))))))) ((eq (car addr) 'function) (or (and (fixp opc) (= tag 0) (eq (typep (cadr addr)) 'symbol)) (prog2 (barf addr " illegal function reference." data) (setq opc 0))) (outwrd (cons 'function (logor opc !lpI !* (left (1+ (get-fcn-addr (get-function (make-const (cadr addr)) t (caddr addr) (cadddr addr))))))))) ((eq (car addr) 'external) (or (and (fixp opc) (= tag 0) (eq (typep (cadr addr)) 'string)) (barf addr " illegal external reference" data)) (outlap (logor opc !*) (get-pl1-link (cadr addr))) (rplaca codelist (addbaseref (car codelist) 5))) ;lb -> linkage ((get (car addr) 'macro) (lapinst opc (macro-expand addr (get (car addr) 'macro)) 0)) (t (outlap opc (lapeval addr))))) (defun lapeis (word prop) (cond ((eq (car prop) 'inst) (lapeisinst word (cadr prop) (caddr prop))) ((eq (car prop) 'desc) (lapeisdesc word (cadr prop) (caddr prop) (cadddr prop))) ((barf word "bad EIS operation" barf)))) (defun lapeisdesc (word codebits bytesize type) (prog (ptr addr offset length scale) (setq addr (lapeval (cadr word)) word (cddr word)) (and (eq (car word) '/|) (setq ptr addr addr (lapeval (cadr word)) word (cddr word))) (cond ((not (atom (car word))) ;(offset) (setq offset (lapeval (caar word))) (setq word (cdr word))) ((setq offset 0))) (setq length (lapevaln (car word)) word (cdr word)) (setq scale 0) (and word (setq scale (lapevaln (car word)))) (setq length (logand length 7777) scale (logand scale 77)) (setq word (cond ((eq type 'bit) (logor length ;make RH of desc (lsh (// offset 9) 16.) (lsh (\ offset 9) 12.))) ((eq type 'char) (and (= bytesize 9) (setq offset (* 2 offset))) (logor length (lsh offset 15.) codebits)) ((eq type 'num) (and (= bytesize 9) (setq offset (* 2 offset))) (logor length (lsh scale 6) (lsh offset 15.) codebits)) (t (barf type "bad EIS desc type" barf) 0))) (outlap word addr) (and ptr (rplaca codelist (addbaserefeiskludge (car codelist) ptr))) )) (defun lapeisinst (word opc type) (prog (mfctr item tem) (setq mfctr 0) ;next modifier field a (cond ((null (setq word (cdr word))) (outwrd opc) (return nil) )) (setq item (car word)) (setq opc (logor opc ;or in cruft from next item (cond ((or (null item) (not (atom item))) ;mf (setq item (lapevaln (sublis '((pr . 100) (rl . 40) (id . 20)) item))) (lsh (logand item 177) (cond ((= (setq mfctr (1+ mfctr)) 1) 0) ((= mfctr 2) 18.) (t 27.) )) ) ((eq item 'ascii) (lsh 1 35.)) ;flags ((eq item 'enablefault) (lsh 1 26.)) ((eq item 'round) (lsh 1 25.)) ((setq tem (assq item '((mask 777 27.) (bool 17 27.) (fill 777 27.)))) (and (eq item 'fill) (eq type 'bit) (setq tem '(fill 1 35.))) ;kludge (setq word (cdr word) item (lapevaln (car word))) (lsh (logand item (cadr tem)) (caddr tem))) ((barf item "bad field in EIS instruction" data)) ))) (go a))) (defun defsym fexpr (l) (do l l (cddr l) (null l) (putprop (car l) (eval (cadr l)) 'sym) )) (defun equ| (l) (do l l (cddr l) (null l) (putprop (car l) (lapevaln (cadr l)) 'sym) )) (defun lap fexpr (l) ((lambda (f type nargs being-compiled source-map) (init-code-generator) (lapup f type nargs) ((lambda (seg-name) (finish-code) (load seg-name)) (catenate "[pd]>" f ".fasl"))) (car l) (cadr l) (caddr l) (car l) nil)) (defun entry| expr (l) ((lambda (fn-name type nargs) (setq entry-list (cons (logor (left nargs) pc) entry-list)) (setq functions-defined (cons (cons (cdr (assq type '((subr.expr) (lsubr.lexpr) (fsubr.fexpr)))) fn-name) functions-defined)) ) (car l) (cadr l) (caddr l))) (defun block| (n) (do n n (1- n) (signp le n) (outwrd 0) )) (defun ascii| (l) (do l (mapcan (function exploden) l) ;get list of chars (cddddr l) (null l) ;and take 4 at a time (cdr nil=nil) (outwrd (do ((i 4 (1- i)) (l l (cdr l)) (w 0)) ((zerop i) w) (setq w (logor w (lsh (or (car l) 0) (- (* i 9.) 9.))))) ))) (defun bind| (l) (prog (type symb offset) (or (eq 'symbol (typep (setq symb (car l)))) (barf symb "cannot bind symbol" data)) (setq l (cdr l)) (setq symb (get-const (list 'quote symb))) ;get address of var to be bound (cond ((cdr l) ;p|q (or (= 0 (lapeval (car l))) ;better be ap| (barf l "illegal bind word" data)) (or (eq '/| (cadr l)) (barf l "illegal bind word" data)) (setq l (cddr l)) (cond ((null l) ;no tag (setq type 1)) (t (or (eq '* (cadr l)) (barf (cadr l) "illegal modifier in bind word" data)) (setq type 6))) ;temp indirect (setq offset (lapeval (car l)))) ((eq (car l) t) ;other random things to bind to... (setq type 0 offset 14)) ((eq (car l) nil) (setq type 0 offset 12)) ((eq (car l) '*nargs) (setq type 5 offset 0)) ((eq (car l) '*argatom) (setq type 4 offset 0)) ((atom (car l)) ;special var (setq type 7 offset (1+ (get-constant-addr (get-const (list 'quote (car l))))))) ((eq (caar l) 'quote) ;constant or literal (setq offset (get-const (car l))) (cond ((or (smallnump (cadr offset)) (floatp (cadr offset))) (setq type 3 offset (cons 'bindliteral (- (get-literal-addr offset) pc)))) ((setq type 2 offset (1+ (get-constant-addr offset)))))) ((barf l "unrecognized expression in binding word" data))) (outlap offset (logor (lsh type 15.) (logand symb 77777))) )) (defsym ; Symbols not defined by ALM sprpms 540000 sprpop 541000 sprptp 542000 sprpcp 543000 sprprp 545000 adwpms 050000 adwpop 051000 adwptp 052000 adwpcp 053000 adwprp 151000 call 272000 ;=tspbp tspms 270000 tspop 271000 tsptp 272000 tspcp 273000 tsprp 675000 sprims 250000 spbpms 250400 spriop 251400 spbpop 251000 spritp 252000 spbptp 252400 spricp 253400 spbpcp 253000 sprirp 651400 spbprp 651000 eawpms 310000 easpms 310400 eawpop 311400 easpop 311000 eawptp 312000 easptp 312400 eawpcp 313400 easpcp 313000 eawprp 331400 easprp 331000 eppus 627000 ;=eax7 eppms 350000 epbpms 350400 eppop 351400 epbpop 351000 epptp 352000 epbptp 352400 eppcp 353400 epbpcp 353000 epprp 371400 epbprp 371000 lprpms 760000 lprpop 761000 lprptp 762000 lprpcp 763000 lprprp 765000 n 0 au 1 qu 2 du 3 ic 4 al 5 ql 6 dl 7 x0 10 x1 11 x2 12 x3 13 x4 14 x5 15 x6 16 x7 17 * 20 au* 21 qu* 22 ic* 24 al* 25 ql* 26 x0* 30 x1* 31 x2* 32 x3* 33 x4* 34 x5* 35 x6* 36 x7* 37 f1 40 itp 41 its 43 sd 44 scr 45 f2 46 f3 47 ci 50 i 51 sc 52 ad 53 di 54 dic 55 id 56 idc 57 *n 60 *au 61 *qu 62 *du 63 *ic 64 *al 33 *ql 66 *dl 67 *x0 70 *x1 71 *x2 72 *x3 73 *x4 74 *x5 75 *x6 76 *x7 77 ap 0 ab 1 bp 2 bb 3 lp 4 lb 5 sp 6 sb 7 ms 0 ;in case he reads lisp listings op 1 tp 2 cp 3 ; lp 4 rp 5 ; sp 6 ; sb 7 us -1 ;special unmkd kludge nil-offset 12 t-offset 14 bind 020 unbind 022 errset1 024 errset2 026 unerrset 030 catch1 034 catch2 036 uncatch 040 iogbind 046 badgo 050 throw1 052 throw2 054 signp 056 type-fields 060 return 062 err 064 cons 072 ncons 074 xcons 076 begin-list 100 append-list 102 terminate-list 104 store-op 116 float-store-op 120 create-string-desc 130 create-array-desc 132 pl1-call 134 cons-string 136 create-varying-string 140 compare 106 fixnum-type 40047 flonum-type 20047 fixtype 400_24. flotype 200_24. bigtype 010_24. numtype 610_24. atomtype 770_24. strtype 40_24. subrtype 20_24. ) ; EIS instructions and descriptors (mapc '(lambda (x) (putprop (car x) (cons 'desc (cdr x)) 'EIS)) '( (descb 000000 1 bit) (desc9a 000000 9 char) (desc6a 020000 6 char) (desc4a 040000 4 char) (desc9fl 000000 9 num) (desc9ls 010000 9 num) (desc9ts 020000 9 num) (desc9ns 030000 9 num) (desc4fl 040000 4 num) (desc4ls 050000 4 num) (desc4ts 060000 4 num) (desc4ns 070000 4 num) )) (mapc '(lambda (x) (putprop (car x) (list 'inst (cadr x) (or (caddr x) 'char)) 'EIS)) '( (mve 020400) (mvne 024400) (csl 060400 bit) (csr 061400 bit) (sztl 064400 bit) (sztr 065400 bit) (cmpb 066400 bit) (mlr 100400) (mrl 101400) (cmpc 106400) (scd 120400) (scdr 121400) (scm 124400) (scmr 125400) (mvt 160400) (tct 164400) (tctr 165400) (ad2d 202400) (sb2d 203400) (mp2d 206400) (dv2d 207400) (ad3d 222400) (sb3d 223400) (mp3d 226400) (dv3d 227400) (mvn 300400) (btd 301400) (cmpn 303400) (dtb 305400) )) (defun cmp1 nil ; translate a file compiling those S-expressions which try to define functions. (catch (prog (form tem being-compiled) a (or (errset (setq form (read))) first-eof (progn (printmes nil "There is probably a missing "")""." nil) (or (null current-function) (equal current-function '(nil)) (printmes current-function "was the last thing compiled." nil)) (return nil))) (setq current-function '(nil) being-compiled nil) b (cond ((atom form)) ;ignore atoms since no side effects to evaluation ((eq (car form) '%include) ;interpreter %include statement is changed to compiler include dcl. (cond ((errset ((lambda (errset) (eval form)) nil)) (push (namestring (names infile)) source-map) (eoffn infile ;succeeded - set up eoffn (function (lambda (a1 a2) ;check for eof-in-object, pop back to prev file (cond (first-eof (setq first-eof nil) a1 a2;hack for no msg t) ;go back & check for eof in the middle of an object. (t (setq first-eof t) ;really done nil) )))) ) ;cause (inpush -1) and continue ((printmes form "include file not found." 'data)) )) ((or (and (eq (car form) 'defprop) (eq (caddr form) 'macro)) (and (eq (car form) 'defun) (eq (cadr form) 'macro)) (and (eq (car form) 'defun) (eq (caddr form) 'macro))) (eval form)) ;do macro definition now ((setq tem (get (car form) 'macro)) ;do macro & rescan (or (setq tem (errset (funcall tem form))) (go c)) (setq form (car tem)) (go b)) ((eq (car form) 'declare) (setq current-function '(declare)) (and (null (errset (mapc (function eval) (cdr form)))) ;unless declarations lose, do them (go c)) ;and go to next expression in file (go a)) ((eq (car form) 'lap) (lapup (setq current-function (cadr form) being-compiled current-function) (caddr form) (cadddr form)) (go a)) ((eq (car form) 'comment)) ;no need to keep comments around (t (put-in-tree form))) (go a) c (prog (^r ^w) (setq ^r nil ^w t) (apply 'ioc messioc) (princ " lap: lisp error during declaration at top level; the losing form is ") (prinb form 5. 20.) ;display the losing form but limit the amount of typeout (terpri) (cond (dataerrp (princ "Please correct and type $p") (break dataerrp t) )) ) (go a)) e-o-f) ;end of catch way back there (finish-code) t) (defun cf (x) ;compile a file (prog (start-time start-runtime start-paging line tem ^w ^q ^r current-function pc codelist constant-list functions-called functions-defined) (setq infile (openi x)) (setq first-eof t) (setq source-map (list (namestring (names infile)))) (eoffn infile (function (lambda (a1 a2) (cond (first-eof (setq first-eof nil) a1 a2 t) ;retry in case eof in obj ((throw nil e-o-f)) )))) (setq seg-name (get_pname (cadr (names infile)))) (setq start-time (status daytime)) (setq start-runtime (status runtime) start-paging (status paging)) (ioc q) (init-code-generator) c (cond ((atom (setq tem (errset (cmp1)))) ;compile some function definitions (setq ^q t ^w t ^r t line (cons current-function line)) (cond ((null tem) ((lambda (^r ^w) (apply 'ioc messioc) (princ " *** LISP ERROR WHILE ASSEMBLING ") (princ current-function) (princ " The error message from Lisp appears above. ") (break barfp barfp) ;in debug mode , let user fiddle. (go c)) nil t) )) (go c))) ;keep on compiling the file (ioc svt) ;switch all i/o to tty (and line (printmes (sort line 'alphalessp) "- failed to assemble." nil)) (close infile) (and total-time (prog (base *nopoint) ;print compiling statistics (setq base 10.) (setq *nopoint t) (princ " Assembly finished. Elapsed time = ") (pr-time (prog (a b c) (setq a (mapcar 'difference (status daytime) start-time)) (setq c (caddr a) b (cadr a) a (car a)) (and (minusp c) (setq c (+ c 60.) b (1- b))) (and (minusp b) (setq b (+ b 60.) a (1- a))) (and (minusp a) (setq a (+ a 24.))) ;if we crossed a midnight, patch it up. ;;3-day compilations will still lose. (return (list a b c)))) (princ ", runtime = ") (prin1 (//$ (float (setq start-runtime (difference (status runtime) start-runtime))) 1000000.0)) (princ ", paging = ") (prin1 (car (setq tem (mapcar (function difference) (status paging) start-paging)))) (princ " + ") (prin1 (cadr tem)) (princ " ") (prin1 (list (// (* (cadr tem) 1000000.) start-runtime))) ;paging rate in parentheses (princ ", gc time = ") (prin1 (//$ (float (status gctime)) 1000000.0)) (princ " (") (prin1 (// (* 100. (status gctime)) start-runtime)) (princ "%)") (terpri))) )) (defun pr-time(3list) ;routine to print out a time ;called with base = 10., (status *nopoint) = t (pr-tim1 (car 3list)) (tyo 72) ; ":" (pr-tim1 (cadr 3list)) (tyo 72) (pr-tim1 (caddr 3list)) ) (defun pr-tim1(x) ;print 2 digit number with leading zero (and (lessp x 10.) (tyo 60)) ;put leading zero if needed (prin1 x)) (defun command-interface nil ;interpret the arguments of the 'lap xxx -opt' command (setq errlist '((init1))) ;we only want to get called once (terpri) (prog (i arg file hold listing-desired seg-name) (setq i 1) nextarg (or (setq arg (status arg i)) (go last-arg)) ;go if no more arguments to do (cond ((equal (substr (get_pname arg) 1 1) "-") ;process an option (cond ((memq arg '(-pathname -pn -p)) (setq file (status arg (setq i (1+ i))))) ((eq arg '-eval) (eval (readlist (exploden (status arg (setq i (1+ i))))))) ((memq arg '(-tm -time -times)) (setq time-option t total-time t)) ((memq arg '(-tt -total -total_time)) (setq total-time t)) ((memq arg '(-nw -nowarn)) (setq nowarn t)) ((eq arg '-ioc) (eval (list 'ioc (status arg (setq i (1+ i)))))) ((memq arg '(-list -ls)) (setq listing-desired t)) ((memq arg '(-hd -hold)) (setq hold t)) ;remain in lisp after compiling (t (princ "lap: Unrecognized control argument ") (princ arg) (princ " has been ignored.") (terpri)) )) ((null file) (setq file (mergef arg '(*.lap)))) ;read pathname, put .lap on end. (use -pn if you don't want .lap) (t (princ "lap: extra argument has been ignored: ") (princ arg) (terpri) )) (setq i (1+ i)) (go nextarg) last-arg (and (null file) (return nil)) ;if no file specified, enter lisp so he can use cf (princ "LISP Assembly Program ") ;announce ourselves (cf file) ;compile file (and listing-desired ;if -list option used, call make_lisp_listing (make_lisp_listing seg-name)) (or hold (quit)) ;quit unless -hd option was given )) (defun printmes(w msg warn) (or (and nowarn ;suppress warning s if called with the -nowarn option (or (null warn) (eq warn 'warn))) ((lambda (^r ^w) (apply 'ioc messioc) (or warn (setq ^r nil)) ;suppress output of random msgs to the defsubr file (and warn being-compiled (progn (terpri) (princ "*** DIAGNOSTICS FOR ") (princ being-compiled) (terpri) (setq being-compiled nil))) ;so this header is only printed once per function in error. (or (= (chrct (car outfiles)) (linel (car outfiles))) (terpri)) ;get to left margin. (princ (cdr (assq warn '( ;put message prefix (warn . "Warning: ") (nonfatal . "Error: ") (data . "Severe Error: ") (barf . "LAP Internal Error: ") (nil . "lap: ") )))) (cond (w (cond (warn (prinb w 5. 20.)) ((prin1 w))) (tyo 40))) ;if there is a datum, print it ;but limit the length of the output. (princ msg) ;print out the message (terpri) (cond ((and warn (not (eq warn 'warn))) (cond ((eq warn 'data) (and dataerrp (princ "; data error - to proceed type $p ") (break data t)) (err 'data)) ; ??????? ((eq warn 'nonfatal) (setq errflag t) ;so pass2 will be suppressed (and dataerrp (princ ";data error - to proceed type $p ") (break data t))) (t (princ " %%%%%%%% lap error - contact the lap maintenance persons %%%%%%%%") (break barf barfp) (err 'barf))))) nil ;no value in particular ) nil t))) (defun prinb(x nlevels atom-cnt) ;print with limited output - for printmes (cond ((atom x) (prin-atom x) (setq atom-cnt (1- atom-cnt))) ((zerop nlevels) (princ "(...)") ;suppress if too deep in nesting (setq atom-cnt (1- atom-cnt))) ;count as atom since takes up space on printout (t (princ "(") ;output a list... (catch (map '(lambda (x) (cond ((zerop atom-cnt) (princ "...") ;if end of output, (throw nil)) ;tell user & leave (t (setq atom-cnt (prinb (car x) (1- nlevels) atom-cnt)) (and (cdr x) (tyo 40) ;if more, space (atom (cdr x)) (progn ;dotted pair (princ ". ") (cond ((zerop atom-cnt) (princ "...")) (t (prin-atom (cdr x)) (setq atom-cnt (1- atom-cnt)))) (throw nil) ))))) x)) (princ ")") )) atom-cnt) ;must return this to caller, so he can update his copy. (defun prin-atom(x) ;routine to print an atom for printmes - knows about renaming. ((lambda (y) (and y (progn ;x is renamed version of y (and barfp ;in debug mode,... (princ x) ;explain what's going on. (princ '=)) (setq x y)))) ;and change atom to print to user's name for it (get x 'rename)) (prin1 x)) (defun put-in-tree(x) (push (cons nil x) functions-defined)) ; initialize environment. (declare (eval (read))) (progn (setsyntax '/! '/$ nil) (sstatus macro /| vertical-status)) (setq lapreadtable (array nil readtable t)) ((lambda (readtable) (setsyntax '/| 'single nil)) lapreadtable) (setq errlist '((command-interface) (init1))) (defun init1 () (ioc stev) (terpri) (princ "At LISP top level: ") nil) (sstatus interrupt 0 (function (lambda (args) (iog vt (prin1 current-function) (terpri))))) (sstatus charmode nil) (setq messioc '(vt) seg-name nil barfp nil dataerrp nil time-option nil total-time nil nowarn nil )  lcp_cg_.lisp 07/06/83 0936.2r w 06/29/83 1541.4 1213299 ;;; ************************************************************** ;;; * * ;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 * ;;; * * ;;; ************************************************************** ;;;(c) Copyright 1973, Massachusetts Institute of Technology. ;;; All rights reserved. ;; ;; pass 2 of the Multics LISP Compiler. ;; ;; Performs the necessary tasks of code generation required by the ;; LISP compiler to generate code for the Multics LISP environment. ;; ;; David Reed,October 1972. ;; Subsequently maintained by Moon, then by Greenberg. ;; ;; Modified 10/09/82 by Richard Lamson to optimize first, second, ..., ;; rest1, et al., same as car/cdr ;;; (declare (special bindtag errtag catchtag progtag unwptag ; special markers appearing on framel framel ; list of frames which have been pushed on unmkd stack. arg-height ; height ap has been bumped for argument lists and binding blocks. bump-arg-height ; height we want to bump ap for arg lists, ; which we defer until an arg is actually to be stored... temp-size ; actual length in words of slots on marked stack used for temporaries. locvars ; assoc list of local variables with cnt of last usage in functions bvars ; list of local bound variables. exit ; push-down list of labels for current prog return. vgol ; "push down" list of labels for variable go feature. slotlist ; list of contents of stack temporary slots, ; nil in slot means it is free, t is reserved, ; (var .home) is home of local variable, ; (....) is temporary value, ; (var . idup) is a copy of a variable made before a setq. slot-types ; list, corresponding to slotlist, of types of slots ; in slotlist...if nil, any type storable here, if fixnum, ; type field has been initted to fixnum, same for flonum. loadlist ; list of values computed, but not yet used. gofoo ; magic frob for load-time constants null-var-list ; list of names of variables which have been bound to nil but not yet ; used. This only affects local variables, and is a hack. cnt ; time in compilation. slotx ; pointer at free temporary used by freetemp. useless-code ; switch controlling whether code is put out, turned on by ; unconditional jumps, off by label definition. pc ; actual pc of code generated. codelist ; list of internal code representations, reverse order of generation. AQ ; contains value representation of that which is in AQ. AQ-state ; if non-nil, current value in AQ is a numeric intermediate ; result. If the Q contains the value, AQ-state = 'Q ; if the A contains the value, AQ-state = 'A BB ; contents of pr3, in which cons-results are returned. constant-list ; list of all constants referenced by program, maintained by get-const. constant-size ; space occupied by all constants referenced by program. literal-list ; list of all literal constants referenced by program, maintained by get-const. literal-size ; space occupied by all literal constants referred to in code. literal-start ; offset of literals from where we originally expected them to be...kept by ; pass2 and initialize slot-types, used by pass2. entry-list functions-called ; list of names for functions called within compiled code. fcn-size ; counter used in allocating space for function links. pl1-link-list ; list of links for defpl1 pl1-link-size ; next available address in linkage section array-type ; type of array just referenced. array-links ; list of array links. array-size ; counter used in allocating array-link space. functions-defined ; list of name-entrypoint pairs for functions compiled. static ; The static stuff. effs ; indicates whether compiling for effect or value. prog-for-effs ; indicates whether prog is being compiled for effect or value. labels-to-define ; list of labels to be defined to point to next instruction. carlist ;car-cdr deflist last-tra-target ; pc or gensym target of last tra barfp ; used to detect compiler errors in debug mode. seg-name ; free variable passed from pass 1, contains name of segment. defdat ; free variable again...used to generate putprop. time-option total-time ; on if times are to be printed on console... arrays ; list of arrays defined by calls to array in file. source-map ; list of source pathnames generated by input reader compiler-version ; string of compiler version base ; good old output base... *nopoint ; and format controller...we must force base 10 output sometimes. ) (array* (notype (fcn-table ?) (const-table ?))) (fixnum arg-height bump-arg-height temp-size cnt pc constant-size literal-size fcn-size array-size base) (do i (read) (read) (equal i ''END) (eval i)) ; read up compile time operations. ) ; compile time operations: (sstatus macro /! '(lambda () (list 'quote ((lambda (x) (or (get x '/!) (error "undefined compile time constant " x))) (read)) ))) (sstatus macro /| nil) (defun setm fexpr (l) (do x l (cddr x) (null x) ((lambda (thing) (putprop (car x) thing '/!)) (cond ((bigp (setq thing (cadr x))) (setq thing (boole 7 (lsh 1 35.) (haipart thing -35.)))) (t thing)) ))) (setm ; set opcodes and other manifest constants. szn 234000 lda 235000 ldq 236000 ldaq 237000 sta 755000 stq 756000 staq 757000 fdi 525000 fneg 513000 lde 411000 fad 475000 ufa 435000 fsb 575000 fld 431000 fst 455000 fcmp 515000 cmpa 115000 cmpq 116000 cmpaq 117000 cana 315000 eppbp 352000 eppbb 353400 eppbb-bb* 300000353520 epplb 371400 eppap 350000 tralink 400000713120 ;callsp lp|0,* eaa 635000 eaq 636000 orq 276000 lxl0 720000 eax0 620000 eax5 625000 eax7 627000 neg 531000 negl 533000 ada 075000 adq 076000 sba 175000 sbq 176000 mpy 402000 div 506000 arl 771000 qrl 772000 als 735000 qls 736000 alr 775000 qlr 776000 lrl 773000 llr 777000 lls 737000 lcq 336000 spribp 252000 spribb 253400 sprilp 650000 sprilb 651400 sprpbp 542000 lprpbp 762000 tmi 604000 tnz 601000 tpl 605000 tpnz 605400 tmoz 604400 tra 710000 tspbp 272000 tze 600000 xec 716000 asq 056000 stz 450000 orsq 256000 orsa 255000 ersq 656000 ersa 655000 erq 676000 era 675000 anq 376000 ana 375000 asa 055000 aos 054000 canq 316000 ssa 155000 ssq 156000 easpbp 313000 eawpbp 312000 stca 751000 stcq 752000 stbq 552000 stba 551000 ansa 355000 ansq 356000 mlr 100400 * 20 ic 4 ql 06 qu 02 au 01 al 05 x0 10 x5 15 x7* 37 x7 17 du 3 dl 7 pr-rl-pr-rl 000140000140 xrfield 17 address-part -777601 ;777777000177 opcode-part 000000777400 ab| 100000000100 ab|2 100002000100 ab|-2 177776000100 ap| 000000000100 ap|-2 077776000100 bp| 200000000100 bp|0 200000000100 bp|1 200001000100 bp|2 200002000100 bp|-2 277776000100 bb|0 300000000100 bb|1 300001000100 lb|2 -277775777700 bb|2 300002000100 bb|-1 377777000100 lp| -377777777700 ab-x7 100000000117 ab-x7* 100000000137 nil-offset 12 t-offset 14 ab|store-ptr 100010000100 ab|store-op 100116000100 ab|float-store-op 100120000100 ab|nil 100012000100 ab|t 100014000100 ab|bind 100020000100 ab|unbind 100022000100 ab|errset1 100024000100 call-op 000032000020 ab|errset2 100026000100 ab|unerrset 100030000100 ab|catch1 100034000100 ab|catch2 100036000100 ab|uncatch 100040000100 ab|prolog 100042000100 ab|iogbind 100046000100 ab|badgo 100050000100 ab|throw1 100052000100 ab|throw2 100054000100 ab|signp 100056000100 ab|type-fields 100060000100 ab|return 100062000100 ab|err 100064000100 ab|cons 100072000100 ab|ncons 100074000100 ab|xcons 100076000100 ab|begin-list 100100000100 ab|append-list 100102000100 ab|terminate-list 100104000100 ab|compare 100106000100 ab|cons-string-op 100136000100 ab|create-string-descrip-op 100130000100 ab|create-varying-string-op 100140000100 ab|create-array-descrip-op 100132000100 ab|pl1-call-op 100134000100 ab|unwp1 100142000100 ab|unwp2 100144000100 ;for catch/errset compat. ab|ununwp 100146000100 ab|irest-return 100150000100 ;interrupt-restoring return. ab|pl1-call-nopop-op 100152000100 ;pl1 call, dont pop pl1 ab|rcv-char-*-op 100154000100 ;move in result, pop stack ; instructions for jump testing for plus, minus, equal, not equal. jump-tests ((l . 605000) (le . 605400) (g . 604400) (ge . 604000) (n . 600000) (e . 601000)) \-ops ((Q 506000 A) (nil 506000 A)) ; opcode table for remainder. +-ops ((Q 076000 Q) (nil 076000 nil) (A 075000 A)) --ops ((Q 176000 Q) (nil 176000 nil) (A 175000 A)) *-ops ((Q 402000 Q) (nil 402000 Q)) ; can't multiply number in A. //-ops ((Q 506000 Q) (nil 506000 Q)) ; can't divide number in A. logand-ops ((Q 376000 Q) (nil 376000 nil) (A 375000 A)) logor-ops ((Q 276000 Q) (nil 276000 nil) (A 275000 A)) xor-ops ((Q 676000 Q) (nil 676000 nil) (A 675000 A)) +$-ops ((475000) (475000)) ;fad, fad -$-ops ((575000) (575000 513000)) ; fsb, fsb-fneg *$-ops ((461000) (461000)) ; fmp, fmp //$-ops ((565000) (525000)) ; fdv, fdi lsubrhack 100116000000 ; special constant for lsubr arg binding. fixnum type shifted left 19. =71b25 216000000000 float-exponent 106000000000 =0/.0 -400000000000 fixnum-type 40047 flonum-type 20047 fixtype 400_24. flotype 200_24. atsymtype 100_24. filetype 1_24. bigtype 010_24. numtype 610_24. arraytype 2_24. atomtype 770_24. strtype 40_24. subrtype 20_24. bindargatom 4_33. bindab 0_33. bindtemp 1_33. bindliteral 3_33. bindquote 2_33. bindspecial 7_33. bindnargs 5_33. Link18 22 ;Link18 relocation code Link15 24 ;Link15 relocation code const-table-size 111. ; size of constant hash table. fcn-table-size 111. ; size of function hash table, used to detect identical calls. ) 'END ; end of compile time operations. (setq arrays nil) (setq bindtag (ncons 'bindtag) unwptag (ncons 'unwptag) errtag (ncons 'errtag) catchtag(ncons 'catchtag) progtag (ncons 'progtag) time-option nil prog-for-effs nil ) (array const-table t !const-table-size) (array fcn-table t !fcn-table-size) (putprop 'abs$ (get 'abs 'subr) 'subr) (putprop 'absfix/! (get 'abs 'subr) 'subr) (putprop 'expt$ (get 'expt 'subr) 'subr) ; declare lisp_cg_utility_ (declare (defpl1 cg-util "lisp_cg_utility_" (char(*)) (lisp) (char(*)) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp) (lisp))) (%include compiler-macros) ;get macros common to pass 1 and pass 2 (%include compiler-badfns) ; include list of functions which set special variables (defun unsysp macro (x)(list 'getl (cadr x) ''(*expr *fexpr *lexpr *macro))) (defun choose-opc macro (x) (displace x (list 'cond (list '(eq AQ-state 'A) (cadr x)) (list 't (caddr x))))) (defun >3 macro (x) (displace x (list 'and (list '> (cadr x) (caddr x)) (list '> (caddr x) (cadddr x))))) (defun logor macro (x) (displace x (cons 'boole (cons 7 (cdr x))))) (defun logand macro (x) (displace x (cons 'boole (cons 1 (cdr x))))) (defun left macro (x) (displace x (list 'lsh (cadr x) 18.))) ; macro to cause output of instruction with tag specified. instruction and tag are normally constants, ; but may be expressions which evaluate to numbers. Hopefully logor will be computed at compile teim for constatns. (defun outinstag macro (x) (displace x (list 'outinst (list 'logor (cadr x) (cadddr x)) (caddr x)))) (defun outjumptag macro (x) (displace x (list 'outjump (cadr x)(list 'logor (caddr x) (cadddr x))))) (defun clearaq () ; clear the AQ, saving it if necessary. (storeaq?) ; store aq if necessary. (setq AQ nil AQ-state nil)) (defun storeaq? () ; function to see if staq temp is needed, and do it if so. (or (null AQ) ; if already clear, just do nothing. (and (not (atom (cdr AQ))) (eq (car AQ) 'quote)) ; if constant that can be easily reloaded. (memq AQ slotlist) ; or if already on stack (cond ((numberp (cdr AQ)) (damned-variable AQ)) ((eq (cdr AQ) 'idup) (damned-variable (cons (car AQ) cnt))) ; if idup is in AQ, treat it as cur var. ((not (memq AQ loadlist)))) ; if not to be loaded, or already used-up value. (saveaq)) nil) (defun put-type-in-aq () ; make sure the value in AQ is a lisp object, not numeric result. (and AQ AQ-state ; if a value is in AQ, and the state is non-nil, must load type field. (progn (cond ((eq AQ-state 'Q) (outinstag !lda (left !fixnum-type) !dl)) ((eq AQ-state 'A) (outinst !lrl (left 36.)) (outinstag !lda (left !fixnum-type) !dl)) ((eq AQ-state 'EAQ) (cv-float-to-typed)) (t (barf AQ-state "is impossible AQ-state" barf))) (setq AQ-state nil)))) ; finally, note that AQ is now a normal lisp number with type. (defun damned-variable (x) ; determine if varaible is to die now or later. (prog (temp) (setq temp -1) (mapc '(lambda (y) (and y (numberp (cdr y)) (eq (car x) (car y)) (>3 (cdr x) (cdr y) temp) (setq temp (cdr y)))) ; find most recent competing value for this var on slotlist. slotlist) (mapc '(lambda (y) (and y (numberp (cdr y)) (eq (car y) (car x)) (< temp (cdr y)) (not (> (cdr y) (cdr x))) (return nil))) loadlist) (return t))) (defun clearslotlist () ; make slotlist clear of garbage results....which might be freed soon. (mapcar '(lambda (x) (cond ((freeable x) nil) (x))) slotlist)) (defun freeable (x) ; if temp is not useful, returns t. (cond ((null x)) ; if nothing there yet, of course it is. ((atom x) nil) ; if marked by atom as already reserved. ((eq (cdr x) 'home) (and (> cnt (cdr (assq (car x) locvars))) (damned-variable (cons (car x) cnt)))) ((memq x loadlist) nil) ((numberp (cdr x)) (damned-variable x)) ((eq (cdr x) 'idup) (damned-variable (cons (car x) cnt))) (t))) (defun freetemp macro (form) (subst nil nil '(findtemp nil))) ; free, general-type temporary (defun findtemp (type) ; get a temporary of type type. (do ((tempi 0 (+ tempi 2)) (slot (or slotlist (setq slotlist (ncons nil))) ; if nothing on slotlist, must start it up (or (cdr slot) (cdr (rplacd slot (ncons nil))))) ; handle end of slotlist. (types (or slot-types (setq slot-types (ncons nil))) ; handle null slot-types. (or (cdr types) (cdr (rplacd types (ncons type)))))) ; and end of slot-types. ((and (eq (car types) type) ; must be of right type (freeable (car slot))) ; and freeable (setq slotx (rplaca slot t)) ; rplaca out whatever's there. (setq temp-size (max temp-size (+ 2 tempi))) tempi))) (defun saveaq () ; save contents of AQ in temporary. (prog (slotx ; special which is munged by findtemp. opc offset type) ; for particular store to use. (cond ((null AQ-state) (setq opc !staq offset 0 type nil)) ((eq AQ-state 'A) (setq opc !sta offset 1 type 'fixnum)) ((eq AQ-state 'Q) (setq opc !stq offset 1 type 'fixnum)) ((eq AQ-state 'EAQ) (setq opc !fst offset 1 type 'flonum)) ((barf AQ-state "is bad state for AQ to be in at this point" barf))) (outinst opc (list 'temp (+ offset (- (findtemp type) arg-height)))) (rplaca slotx AQ))) (defun clearbb () ; makes sore bb is clobberable (storebb?) (setq BB nil)) (defun storebb? () ; makes sure bb is stored on stack somewhere if necessary. (or (null BB) ; nothing in it, return (memq BB slotlist) ; already stored, return (not (memq BB loadlist)) ; not needed in future, return. (assumes only gensym results in BB) (savebb))) ; we have to save it, so do so. (defun savebb () ((lambda (slotx temp) ; for findtemp (setq temp (freetemp)) ; get a free temporary. (rplaca slotx BB) ; mark it with what we're storing (outinst !spribb (list 'temp (- temp arg-height)))) nil nil)) (defun in-aq (x) ; check to see if value is in AQ now. (or (and (numberp (cdr x)) (eq (locvalue x) 'AQ)) ; if variable value which is in AQ, then true, else (eq x AQ))) ; if the value is in AQ. (defun in-Q (x) (and (in-aq x) (memq AQ-state '(nil Q)))) (defun in-bb macro (x) ; macro, because simple. (displace x (list 'eq (cadr x) 'BB))) ; just check if BB is eq to result needed. (defun iloc (x) ; internally locate value, return address info. (cond ((numberp (cdr x)) (locvalue x)) ; locate variable value. ((eq x AQ) 'AQ) ; if already in AQ, say so. ((eq (car x) 'quote) x) ; if constant, it is trivially addressed. (t (and (eq x BB) (storebb?)) ; make sure BB contents in storage. (do ((slot slotlist (cdr slot)) (tempi 0 (+ 2 tempi))) ; scan over slots in stack. ((or (and (null slot)(barf x "lost value" barf)) (eq (car slot) x)) (list 'temp (- tempi arg-height))))))) (defun locvalue (x) ; locate variable value, searching for best value... (do ((slot slotlist (cdr slot)) (bestim nil) (besti nil) (i 0 (+ 2 i))) ((null slot) ; end of temps, see if AQ is better value. (cond ((betterval x AQ bestim) 'AQ) ; it is! (besti (list 'temp (- besti arg-height))) ; found good temp. (t (make-const (car x)) (list 'special (car x))))) ; else it must have been special (unless a bug happened) (cond ((betterval x (car slot) bestim) (setq besti i) (setq bestim (cond ((numberp (cdar slot)) (cdar slot)) (cnt))))))) (defun betterval (val place oldbestim) ; better representation of variable value checker. (and (not (atom place)) ; if place is a value. ((lambda (time placetime) ; time is value time, palcetime is checked time. (cond ((or (eq placetime 'home) (eq placetime 'dup) ; if dup in AQ, better value. (eq placetime 'idup)) ; copied out value due to a setq. (setq placetime cnt))) ; time then is current time. (and (numberp placetime) ; if a variable value, (eq (car val) (car place)) ; and this variable's value also, (not (< placetime time)) ; and is a possible candidate for having the right value, (or (null oldbestim) (not (> placetime oldbestim))))) ; and is a better candidate than the last one found, ; then it is a better value. (cdr val) (cdr place)))) (defun ilocs (x) ;locate value, which must be in storage. ;will force a staq if value is only in AQ. ((lambda (loc) ; loc is iloc(x). (cond ((eq loc 'AQ) ; and if in AQ, (storeaq?) ; make sure it is stored. ((lambda (AQ) ; now rebind AQ to nil, and iloc will find the value in storage. (iloc x)) nil)) (t loc))) (iloc x))) (defun outinst (opc oper) ; output instruction. (or (and useless-code (prog2 (tra-adjust) (not labels-to-define))) ; inhibit code here? (cond ((numberp oper) (outwrd (logor opc oper))) ((atom oper) ((lambda (lvalue) ; check to see if label already defined. (cond ((null lvalue)(outwrd (logor (left (minus pc)) !ic opc)) ;Not defined (putprop oper (cons codelist (get oper 'references)) 'references)) ((atom lvalue) ;ic-rel tag (outwrd (logor (left (- lvalue pc)) !ic opc))) (t (outwrd (logor opc (car lvalue)))))) ;absolute place (get oper 'lvalue))) ((eq (car oper) 'quote) (outwrd (cond ((eq (cadr oper) nil) (logor opc !ab|nil)) ((eq (cadr oper) t) (logor opc !ab|t)) ((or (smallnump (cadr oper)) (floatp (cadr oper))) (cons 'literal (logor opc !ic (left (- (get-literal-addr oper) pc))))) ( (logor opc !lp| (left (+ 1 (get-constant-addr oper)))))))) ((eq (car oper) 'special) (outwrd (logor opc !* !lp| (left (+ 1 (get-constant-addr (make-const (cadr oper)))))))) ((eq (car oper) 'function) (cond ((eq (cadddr oper) 'array) ;array-link (outwrd (cons 'array (logor opc !lp| (left (+ 1 (get-array-link-addr oper))))))) (t (outwrd (cons 'function (logor opc !lp| !* (left (+ 1 (get-fcn-addr oper))))))))) ((eq (car oper) 'temp) (outwrd (cons 'temp (logor opc !ap| (left (cadr oper)))))) (t (barf oper "illegal operand in instruction" barf))))) (defun outbindwrd (x y) (setq x (left (+ 1 (get-constant-addr x)))) ; get address of bound atom. (cond ((eq y 'nargs) (outwrd (logor !bindnargs x))) ((eq (car y) 'temp) (outwrd (cons 'bindtemp (logor !bindtemp x (logand 777777 (cadr y)))))) ((eq (car y) 'quote) (cond ((eq (cadr y) nil) (outwrd (logor !bindab x !nil-offset))) ((eq (cadr y) t) (outwrd (logor !bindab x !t-offset))) ((or (smallnump (cadr y)) (floatp (cadr y))) (outwrd (cons 'bindliteral (logor !bindliteral x (logand 777777 (- (get-literal-addr y) pc)))))) (t (outwrd (logor !bindquote x (+ 1 (get-constant-addr y))))))) ((eq (car y) 'special) (outwrd (logor !bindspecial x (+ 1 (get-constant-addr (make-const (cadr y))))))))) (defun tra-adjust nil ; fix t** * + 2 (and (cddr codelist) ; gotta be that long (= (logand (car codelist) !opcode-part) !tra) ; last was uncond tra (do ((x labels-to-define(cdr x)) ;scan labels (y (cdr codelist))(z)) ((null x)) (setq z (get (car x) 'references)) (cond ((memq codelist z) ; tra * + 1 (putprop (car x)(delq codelist z) 'references) (setq codelist (cdr codelist) pc (1- pc)) (return nil))) (cond ((memq y z) ;; and branching here.. (putprop (car x)(delq y z) 'references) (return t)))) (progn ;now delete the tra (setq pc (1- pc)) ; back up pc (setq codelist (cdr codelist)) ; destroy tra (cond ((numberp last-tra-target) ; was defined (rplaca codelist (logor (left (1+ (- last-tra-target pc))) (boole 1 (car codelist) 777777)))) ((atom last-tra-target) ;tag, not yet defined (putprop last-tra-target (cons codelist (get last-tra-target 'references)) 'references)) (t (rplaca codelist (logor (logand (car codelist) !opcode-part) ;absolute place (car last-tra-target))))) (rplaca codelist (boole 6 (car codelist) 1000))))) ; invert test (defun outjump (opc oper) ; special case jumps... (and (fixp oper) ;absolute jump ((lambda (sym) (putprop sym (ncons oper) 'lvalue) (setq oper sym)) (gensym))) (and (= opc !tra) ((lambda (lvalue) (cond ((null lvalue) (putprop oper (nconc labels-to-define (get oper 'synonyms)) 'synonyms) (or useless-code (setq last-tra-target oper))) (t (mapc '(lambda (x) (fix-refs x lvalue)) labels-to-define) (or useless-code (setq last-tra-target lvalue)))) ; save loc (setq labels-to-define nil)) (get oper 'lvalue))) (outinst opc oper) ; first output the code, (and (= opc !tra) (setq useless-code t))) ; and then check to see if we should inhibit code to next label... (defun outwrd (wrd) ; output any type of code word. (mapc '(lambda (x) (fix-refs x pc)) labels-to-define) (cond (labels-to-define (setq labels-to-define nil useless-code nil))) (setq pc (1+ pc)) (setq codelist (cons wrd codelist))) (defun define-tag (tag) ; define the value of a tag, to be the current pc. (cond ((and useless-code (not labels-to-define)) ; if preceded by unconditional transfer, ignore state of machine. (setq slotlist (get tag 'level) AQ-state (get tag 'AQ-state) AQ (get tag 'AQ) BB (get tag 'BB)) (setq slotlist (nconc slotlist (do ((i (- (lsh temp-size -1) (length slotlist)) (1- i)) (val nil (cons nil val))) ((= i 0) val))))) (t (or (and (eq AQ (get tag 'AQ)) (eq AQ-state (get tag 'AQ-state))) ; set AQ from combined states of all jumps to label, and current . (setq AQ nil AQ-state nil)) (or (eq BB (get tag 'BB)) ; set BB from combination of all jumps to tag. (setq BB nil)) ((lambda (tagl) ; tagl = (get tag 'level) (setq slotlist (or slotlist (and tagl (ncons nil)))) ; make sure slotlist has elements if ; tag level does... (do ((slot slotlist ; force slotlist to intersection of states. (cdr (cond ((and (cdr slot1) (null (cdr slot))) (rplacd slot (ncons nil))) ; lengthen short slotlist (t slot)))) ; otherwise go down it. (slot1 tagl (cdr slot1))) ((null slot1) (map '(lambda (x) (rplaca x nil)) slot)) ; nil-ify rest of slotlist. (or (eq (car slot) (car slot1)) (rplaca slot nil)))) (get tag 'level)))) ; (cond ((not (= (length slotlist) (lsh temp-size -1))) (barf temp-size "wrong slotlist size - define-tag" barf))) ; above line did not work when slotlist was too short...which can occur. (setq labels-to-define (cons tag labels-to-define))) ; push tag on labels-to-define, not bumping pc. (defun fix-refs (lab val) (prog (references synonyms) (setq references (get lab 'references)) (setq synonyms (get lab 'synonyms)) (and references (prog2 (cond ((atom val) ;ic-rel tag (mapc '(lambda (x) (rplaca x (+ (car x) (left val)))) references)) (t (mapc '(lambda (x)(rplaca x (logor (car val)(logand (car x) !opcode-part)))) references))) (remprop lab 'references))) (and synonyms (prog2 (mapc '(lambda (x) (fix-refs x val)) synonyms) (remprop lab 'synonyms))) (return (putprop lab val 'lvalue)))) (defun get-pl1-link (name) ((lambda (address) (setq pl1-link-size (+ address 2)) (setq pl1-link-list (cons name pl1-link-list)) (cons 'pl1-link (logor !tralink (left address)) )) ; go there (operator sets lp) pl1-link-size)) ;;; functions to assign addresses to literals and constants referenced by the code. (defun get-literal-addr (const) ; takes arg in standard "uniquized" representation for constant, returns addr. (cond ((cddr const)) ; cddr is address if already assigned. (t (rplacd (cdr const) literal-size) ; assign new address (setq literal-size (+ 2 literal-size) ; and up the length of literals. literal-list (cons const literal-list)) (cddr const)))) (defun get-constant-addr (const) ; takes arg in standard "uniquized" representation for constant, returns addr. (cond ((cddr const)) ; cddr is address if already assigned. (t (rplacd (cdr const) constant-size) ; assign new address (setq constant-size (+ 2 constant-size) ; and up the length of constants. constant-list (cons const constant-list)) (cddr const)))) (defun get-fcn-addr (const) ; assign address for function link, if not already assigned. (cond ((cddddr (cdr const))) ; if already assigned, address is cdddddr of function representation. (t (rplacd (cddddr const) fcn-size) ; put new address in representation for future use. (setq fcn-size (+ fcn-size 2) ; 2 words allocated for link. functions-called (cons const functions-called)) ; note that we have to make the link later. (- fcn-size 2)))) ; return the address of the link. (defun get-array-link-addr (x) ;assign address for array link (cond ((cddddr (cdr x))) ;already assigned. (t (rplacd (cddddr x) array-size) ;insert address (setq array-size (+ array-size 4)) ;allow for 4-word block. (setq array-links (cons x array-links)) (- array-size 4)))) ;return the address of the array-link. ;;; routines for the compilation of arithmetic functions. ;;; generation of inline arithmetic requires special handling. (defun outarith (opc addr) ; output arithmetic instruction...specialized operand handling. (and useless-code (tra-adjust)) (outwrd (cond ((eq (car addr) 'quote) ; literal operands can be handled very neatly, often. ((lambda (num) (cond ((not (smallnump num)) (barf addr "bad fixnum function operand" data)) ((= 0 (logand 777777 num)) (logor opc !du num)) ; du-type operand ((= 0 (logand (left 777777) num)) (logor opc !dl (left num)));dl-type (t (cons 'literal (logor opc !ic (left (- (get-literal-addr addr) pc -1))))))) (cadr addr))) ((eq (car addr) 'special) ; set up special value. (outinst !eppbp addr) ; get pointer to it (logor opc !bp|1)) ((eq (car addr) 'temp) ; temporary location. (cons 'temp (logor opc !ap| (left (1+ (cadr addr)))))) (t (barf addr "illegal arithmetic operand" barf))))) (defun get-fixnum (x) ; get fixnum value into register. ((lambda (locx) (cond ((not (eq locx 'AQ)) (loadarith x locx))) ; if not in register load it. (remove x)) (iloc x))) (defun get-fixnum-commu (x y) ; get fixnum for commutative function. ((lambda (locx locy) (cond ((eq locx 'AQ)) ; in register, do nothing. ((eq locy 'AQ) (setq x (prog2 nil y (setq y x)))) ; y in reg, remove y, give x ; avoid loading x if it is constant - less code to load var. ((and (not (atom locx))(eq (car locx) 'quote)) (loadarith y locy)(setq x (prog2 nil y (setq y x)))) (t (loadarith x locx))) ; neither in register, get x in register. (remove x) y) ; return unloaded value name (iloc x) (iloc y))) (defun loadarith (x locx) ; load arithmentic typ value into AQ from storage. (clearaq) ; first make sure nothing important in AQ. (cond ((eq (car locx ) 'special) ; if special, best load is ldaq. (outinst !ldaq locx) (setq AQ (cons (car x) 'dup))); AQ-state was set to nil by clearaq. ((progn (outarith !ldq locx) (setq AQ-state 'Q) (eq (car locx) 'temp)) (setq AQ (contents (+ (cadr locx) arg-height)))) (t (setq AQ x)))) ; if not temp, set value name. (defun comparith (commu optable args) ; commutative switch, table of operations, arguments. (cond ((null (cdr args)) ; if no arguments but 1, return argument. (setq args (comp (car args))) (remove args) ; make sure result not on loadlist. args) ((do ((result (comp (car args))) ; first result is the car of the arguments. (args (cddr args) (cdr args)) ; move down arg list one at a time. (newarg (comp (cadr args)) (comp (car args)))) (nil) ; no end test at beginning of loop. (cond (commu (setq newarg (get-fixnum-commu result newarg))) ; if either in aq, get other into newarg. (t (get-fixnum result))) ; if not commutative, must get first arg. (storeaq?) ; make sure necessary copies of result are in storage. (cond ((setq result (assq AQ-state optable))) ; get proper operation from optable and AQ-state. ((eq (car (setq result (car optable))) ; if not in ok state, get preferred target state. 'Q) ; if Q, assume fixnum operand. (cond ((null AQ-state)) ; nil is essentially equal to Q. ((eq AQ-state 'A) (outinst !lrl (left 36.))) (t (barf AQ-state "cannot be made into fixnum!" barf)))) ((eq (car result) 'A) ; require that result be in A. (cond ((or (null AQ-state) (eq AQ-state 'Q)) (outinst !lls (left 36.))) (t (barf AQ-state "cannot be made into fixnum!" barf)))) (t (barf AQ-state "cannot be made into fixnum!" barf))) (outarith (cadr result) (ilocs newarg)) ; put out instruction from optable. (remove newarg) (setq AQ-state (caddr result)) ; get new AQ-state from optable. (setq result (ncons (gensym)) AQ result) (putprop (car result) 'fixnum 'number) (and (null args) (return result)) (setq loadlist (cons result loadlist)))))) ; make sure result stays around till needed. ;;; routine to negate a fixnum correctly... (defun negate-fixnum (x) ; gets name for result to be negated. ((lambda (locx) (cond ((eq locx 'AQ) (remove x) ; once in AQ, don't need it here anymore. (storeaq?) (cond ((not (eq AQ-state 'A)) (outinst !lls (left 36.)))) (setq AQ-state 'A) (outinstag !neg 0 !du)) (t (clearaq) (outarith !lcq locx) ; negate from storage. (remove x) (setq AQ-state 'Q)))) (iloc x)) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) AQ) ;;; routine to compile lsh and rot inline... (defun compshift (lsh? val shift) ; lsh/rot switch, value to be shifted, amount. (cond ((and (eq (car shift) 'quote) ; check for constant second operand. (not (smallnump (cdr shift)))) (remove shift) ; don't need to load shift in constant case. (get-fixnum val) ; get the value to be shifted in a register. (storeaq?) ; make sure it is mungable (setq shift (cadr shift)); get shift amount (cond ((or (not (smallnump shift)) ; make sure amount is allowable shift amount (> shift 36.) (< shift -36.)) (barf shift "excessive shift. Max = 36." data)) (lsh? (cond ((< shift 0) (setq shift (- 0 shift) ; negative shift direction... val (choose-opc !arl !qrl))) ; get right opcode (t (setq val (choose-opc !als !qls))))) (t (cond ((< shift 0) (setq shift (+ shift 36.)))) (setq val (choose-opc !alr !qlr)))) (outinst val (left shift))) ; finally, output the right instruction. (t (setq shift (prog2 0 (iloc shift) (remove shift))) ; locate shift, remove from loadlist (cond ((eq shift 'AQ) ; if shift value in AQ, move to x0 (cond ((eq AQ-state 'A) (outinstag !eax0 0 !al)) ; from A, (t (outinstag !eax0 0 !ql)))) ; or from Q as necessary. (t (outarith !lxl0 shift))) ; otherwise, load from storage... (get-fixnum val) ; get value into AQ (storeaq?) ; make sure it is unshared (cond (lsh? (cond ((eq AQ-state 'A) (outinstag !ldq 0 !dl)) ; move value into A, zero Q. (t (outinst !lls (left 36.)))) (setq AQ-state 'Q) ; after shift, value will be in Q, type bits destroyed. (outinstag !llr (left 36.) !x0)) ; takes care of negative values, as well as positive (t (outinstag (choose-opc !alr !qlr) (left 36.) !x0))))) ; and so does this. (setq AQ (ncons (gensym))) ; return name for result in AQ. (putprop (car AQ) 'fixnum 'number) AQ) ;;; functions which handle floating point computations. (defun outfloat (opc addr) ; outputs a floating point instruction. (and useless-code (tra-adjust)) (outwrd (cond ((and (eq (car addr) 'quote)(numberp (cadr addr))) (cons 'literal (logor opc !ic (left (- (get-literal-addr addr) pc -1))))) ((eq (car addr) 'special) (outinst !eppbp addr) ; make float number addressable (logor opc !bp|1)) ((eq (car addr) 'temp) (cons 'temp (logor opc !ap| (left (1+ (cadr addr)))))) ((barf addr "illegal float operand" barf))))) (defun get-flonum (x) ((lambda (locx) (cond ((not (eq locx 'AQ)) (loadfloat x locx)) ((not (eq AQ-state 'EAQ)) (loadfloat x (ilocs x)))) ; if not in float format, get it from storage. (remove x)) (iloc x))) (defun loadfloat (x locx) ; output a load instruction to locx. (clearaq) (outfloat !fld locx) ; the instruction. (setq AQ-state 'EAQ) (cond ((eq (car locx) 'special) (setq AQ (cons (car x) 'dup))) ((eq (car locx) 'temp) (setq AQ (contents (+ (cadr locx) arg-height)))) (t (setq AQ x)))) (defun compfloat (optable args) ; output code for most floating point operations. (cond ((null (cdr args)) (setq args (comp (car args))) (remove args) args) ((do ((result (comp (car args))) (table (car optable) (car optable)) (args (cddr args) (cdr args)) (newarg (comp (cadr args)) (comp (car args)))) (nil) (cond ((and (in-aq result) (eq AQ-state 'EAQ))) ((and (in-aq newarg) (eq AQ-state 'EAQ)) (setq result (prog2 nil newarg (setq newarg result)) table (cadr optable))) (t (loadfloat result (ilocs result)))) (remove result) (storeaq?) (outfloat (car table) (ilocs newarg)) (and (cdr table) (outinst (cadr table) 0)) (remove newarg) (setq result (ncons (gensym))) (putprop (car result) 'flonum 'number) (setq AQ result) (and (null args) (return result)) (setq loadlist (cons result loadlist)))))) (defun negate-flonum (x) (get-flonum x) ; get it in EAQ. (storeaq?) (outinst !fneg 0) (remove x) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) (defun cv-float-to-typed () ; function to convert float in EAQ to typed number in AQ. ((lambda (aq-cont) (setq loadlist (cons aq-cont loadlist)) ; make sure we are known to need aq. (outinst !ldaq (ilocs aq-cont)) (remove aq-cont) ; pop back off loadlist. (setq AQ-state nil)) (cond ((memq (cdr AQ) '(dup idup)) (cons (car AQ) cnt)) ; make sure ok to put away. (t AQ)))) (defun gotvalue (x) ; predicate to test to see if variable value x has alreayd been gotten. (do ((slot slotlist (cdr slot))) ((null slot) (goodval x AQ)) ; if not on slotlist, check AQ. (and (goodval x (car slot)) (return t)))) ; hack used here -- if any value for variable ; has been saved since it was referenced, a good value ; must exist, so don't have to check as much. (defun goodval (x y) ; see if y contains a value for x which is later in time than x referenced. (and y (eq (car y) (car x)) (or (memq (cdr y) '(idup dup)) ; (idup dup) must be later. (and (numberp (cdr y)) ; else must be a saved value (not (< (cdr y) (cdr x))))))) ; which is later in time. (defun cleanup-var-loads () ; makes sure all variables mentioned on loadlist have been put on slotlist or in AQ. (do ((x loadlist (cdr x))) ((null x)) (and (numberp (cdar x)) ; if load value is variable value. (not (gotvalue (car x))) ; and haven't loaded it yet (savevalue (car x)))) ; then must save it. (fixidups)) ; fix up idups, thus closing off past time section. (defun cleanup-special-var-loads () ; makes sure all special variables mentioned on loadlist have been put on slotlist or in AQ. (do ((x loadlist (cdr x))) ((null x)) (and (numberp (cdar x)) ; if load value is variable value. (specialp (caar x)) ; and is that of a special var, (not (gotvalue (car x))) ; and haven't loaded it yet (savevalue (car x)))) ; then must save it. (fix-special-idups)) ; fix up idups, thus closing off past time section. (defun savevalue (x) ; save variable value. (clearaq) (setq x (car x)) (or (and (eq (car AQ) x) (eq (cdr AQ) 'dup)) ; if just a duplicate of home is in AQ, don't have to do anything. (do ((slot slotlist (cdr slot)) (tempi 0 (+ 2 tempi))) ((null slot) (outinstag !ldaq (make-const x) !*)) (and (car slot) (eq (caar slot) x) (eq (cdar slot) 'home) (return (outinst !ldaq (list 'temp (- tempi arg-height))))))) (setq AQ (cons x 'idup))) ; AQ-state has been set by clearaq, to nil. (defun fixidups () ; turn all idup's into numeric indicators = to cnt. (mapc '(lambda (x) (and (not (atom x)) (eq (cdr x) 'idup) (rplacd x cnt))) slotlist) (and AQ (memq (cdr AQ) '(idup dup)) (rplacd AQ cnt))) (defun fix-special-idups () ; turn all special-idup's into numeric indicators = to cnt. (mapc '(lambda (x) (and (not (atom x)) (eq (cdr x) 'idup) (specialp (car x)) (rplacd x cnt))) slotlist) (and AQ (memq (cdr AQ) '(idup dup)) (specialp (car AQ)) (rplacd AQ cnt))) (defun cleanup-var-load (x) ; cleanup loadlist references to variable value x. (mapc '(lambda (y) (and (numberp (cdr y)) (eq (car y) x) (or (gotvalue y) (savevalue y)))) loadlist) ; make sure all refs to x on loadlist are satisfied now. (mapc '(lambda (y) (and (not (atom y)) (eq (car y) x) (eq (cdr y) 'idup) (rplacd y cnt))) slotlist) (and AQ (eq (car AQ) x) (memq (cdr AQ) '(idup dup)) (rplacd AQ cnt))) ; function to make a call to a lisp function. (defun make-call (functional fntype args) ; apply functional to args... (prog (nargs cargs temp snap? type) ; cargs = compiled args. nargs, temp tempoararies. (cond ((eq fntype 'fsubr) (setq nargs 2) (setq bump-arg-height (+ bump-arg-height 2)) ; more space for args needed (get-in-aq (comp (list 'quote args))) (storearg -2)) (t (setq nargs (lsh (length args) 1)) (setq bump-arg-height (+ bump-arg-height nargs)) (do ((scan args (cdr scan)) (tempi (minus nargs) (+ 2 tempi)) (val)) ((null scan)) ; scan through all args (cond ((and (in-aq (setq val (comp (car scan)))) (not (eq AQ-state 'EAQ))) ; if in AQ, then store it now! (remove val) (storearg tempi)) ((in-bb val) (remove val) (storearg-bb tempi)) ; if in bb register, store now too! ((setq temp (assq val cargs)) ; if val is already the same as before, (remove val) ; remove this entry from loadlist, since one is all we need. (rplacd temp (cons tempi (cdr temp)))) ; add to list of places where val is stored. ((setq cargs (cons (list val tempi) cargs))))) ; else add new val to be stored. (do scan cargs (cdr scan) (null scan) (get-in-aq (caar scan)) ; get val in AQ. (mapc 'storearg (cdar scan))))) ; store the arg that many times. a (cond ((atom functional) (cond ((setq type (get functional 'numfun)) ; if number function, get known type. (setq type (car type)))) (setq temp (make-const functional) snap? t)) (t (cond ((eq (car functional) '*subr-ptr) ;calling a subr pointer (setq type (cadr functional) snap? 'subrcall) (or (eq type 'fixnum) (eq type 'flonum) (setq type nil)) (setq functional (comp (caddr functional))))) (setq temp (iloc functional)) (cond ((eq temp 'AQ) (clearaq) (go a)) ((eq (car temp) 'special) (cleanup-var-load (cadr temp)) (go a))))) (cond ((or (not (atom functional)) ; if function may change special vars, (not (sysp functional)) ; then we want to load any that we are waiting for values of. (memq functional (badfns))) (cleanup-special-var-loads)) ) (clearaq) (clearbb) (cond ((eq fntype 'lsubr) (outinst !eax5 (minus (left nargs))))) ; if lsubr, pass arg count. (cond ((eq snap? 'subrcall) ;indirect through subr pointer (cond ((numberp temp) (outinstag !eppbp temp !*)) (t (outinst !eppbp temp) (outinstag !eppbp !bp|0 !*) )) (outinst !tspbp !bp|1)) (t (outinst !tspbp (get-function temp snap? fntype (lsh nargs -1))) )) (setq arg-height (- arg-height nargs)) (cond ((not (atom functional)) (remove functional))) ; if was on loadlist, remove function. (setq AQ (ncons (gensym))) ; AQ-state has been set by clearaq above. (cond (type (putprop (car AQ) type 'number))) ; remember type of result. (return AQ))) (defun get-function (x snap? type nargs) ; function to maintain unique function representation. ((lambda (hash bucket) ; some temp variables. (setq bucket (fcn-table hash)) (do ((scan bucket (cdr scan))) ((null scan) (store (fcn-table hash) (cons (setq x (list 'function x snap? type nargs)) ; make unique representation if not found bucket)) x) (and (eq x (cadar scan)) ; if all 4 components are eq, then use this existing representation. (eq snap? (caddar scan)) (eq type (cadddr (car scan))) (eq nargs (cadddr (cdar scan))) (return (car scan))))) (abs (\ (cond ((eq (car x) 'temp) (cadr x)) ; if in a temp, hash by temp offset. (t (sxhash (cadr x)))) ; otherwise, must be (quote < > ), hash by object. !fcn-table-size)) nil)) (defun storearg (x) (force-arg-height) ; force arg-height to be bumped up... (put-type-in-aq) (outinst !staq (logor !ap| (left (logand x 77777))))) ; store an argument relative to the top of the marked pdl. (defun storearg-bb (x) ; store argument from bb register. (force-arg-height) (outinst !spribb (logor !ap| (left (logand x 77777))))) (defun force-arg-height () ; force arg height to required value... (cond ((not (zerop bump-arg-height)) ; if need to get the space we are to store into... (outinst !eppap (logor !ap| (left (logand 77777 bump-arg-height)))) (setq arg-height (+ arg-height bump-arg-height)) ; now the real arg-height is here. (setq bump-arg-height 0)))) (defun get-in-aq (x) ; force an argument into the aq. ((lambda (y) (cond ((eq y 'AQ) (put-type-in-aq)) ((and (eq (car y) 'quote) ;optimize load of fixnum constant (smallnump (cadr y)) (not AQ-state) ; must be typed (cond ((eq (car AQ) 'quote) (smallnump (cadr AQ))) (t (eq (get (car AQ) 'number) 'fixnum))) (progn (clearaq)(setq AQ y)(outarith !ldq y) t))) ((prog2 (clearaq) (eq (car y) 'special)) (outinst !ldaq y) ; the clearaq sets AQ-state to nil... (setq AQ (cons (car x) 'dup))) ((prog2 (outinst !ldaq y) (eq (car y) 'temp)) (setq AQ (contents (+ (cadr y) arg-height)))) (t (setq AQ x))) (remove x)) ; delete x from loadlist. (iloc x))) (defun remove(x) (setq loadlist (delq x loadlist 1))) (defun contents (x) (do ((i 0 (+ 2 i))(temp slotlist (cdr temp))) ((= i x) (cond ((eq (cdar temp) 'home) (cons (caar temp) 'dup)) (t (car temp)))))) ; get contents of temp at address... (defun comp (x) ((lambda (effs) (comp0 x)) nil)) ; compile for value (free var effs signifies this) (defun compe (x) ((lambda (effs) (comp0 x)) t)) ; compile for effect. (defun comp0 (x) ; first pass of code gen. makes a value descriptor. ((lambda (y) (cond ((atom x) (setq cnt (1+ cnt)) ; update time counter when var is referenced, (cond ((memq x null-var-list) ; if variable is recently bound to nil, just return nil. (and (get x 'number) (barf x "is a number, which has been bound to nil" data)) (and (null effs) (setq y (make-const nil)))) ((null effs) (setq y (cons x cnt))))) ((eq (car x) 'quote) (and (not effs) (setq y (get-const x)))) ; constant value is uniformly represented in pass2 ((setq y (compform (car x) (cdr x))))) (and (not effs) (setq loadlist (cons y loadlist)) y)) nil)) (defun make-const (x) ; function to uniquize the representation of a constant. (cond ((eq x nil) '(quote nil)) ((eq x t) '(quote t)) (t ((lambda (hash bucket) ; some temporary variables. (setq bucket (const-table hash)) ; get hash table bucket. (do ((scan bucket (cdr scan))) ; look down bucket for already created representation. ((null scan) ; when no more... (store (const-table hash) (cons (setq x (list 'quote x)) bucket)) ; put newly created representation in bucket. x) ; return new representation. (cond ((equal (cadar scan) x) (return (car scan)))))) (abs (\ (sxhash x) !const-table-size)) nil)))) (defun get-const (const) ; given (quote ), get unique representation. (make-const (cadr const))) (defun compform (x y) ;compute value of form... ((lambda (fnprop) (cond ((not (atom x)) (cond ((eq (car x) 'lambda) (complambda x y)) ; do lambda compile. ((and (eq (car (setq x (comp x))) 'quote) ; if constant result, (not (smallnump (cdr x))) ; (make sure not (quote . 5) or something) (eq (typep (cadr x)) 'symbol)) ; if other quoted thing, pass 1 has not examined ; it so we can't optimize it here unfortunately. (remove x) ; don't need to load function, so forget that; (compform (cadr x) y)) ; then treat as if it were a form with the fn at car. (t (make-call x 'lsubr y)))) ; make the call as lsubr because best linking can occur. ((setq fnprop (getl x '(subr fsubr lsubr expr fexpr *expr *fexpr *lexpr *array array))) (setq fnprop (car fnprop)) ; get type of function applied. (cond ((and (eq fnprop 'subr) (sysp x)) ; if system subr, check its type... (compsubr x y)) ((and (eq fnprop 'lsubr) (sysp x)) (complsubr x y)) ((and (eq fnprop 'fsubr) (sysp x)) (compfsubr x y)) ((memq fnprop '(array *array)) (comparray x y)) ((memq fnprop '(expr *expr)) (make-call x 'subr y)) ((memq fnprop '(fexpr *fexpr)) (make-call x 'fsubr y)) ((eq fnprop '*lexpr) (make-call x 'lsubr y)) (t (barf x " undefined in pass2" barf)))) ((memq x arrays) ; if array, that was mentined and created at top level. (make-call x 'subr y)) ((get x '*defpl1-internal) (cond ((eq x '*unmkd-push) ; special forms for defpl1 follow... (outinstag !eax7 (left (car y)) !x7)) ((eq x '*unmkd-pop) (outinstag !eax7 (left (- (car y))) !x7)) ((eq x '*cons-string) (comp-cons-string y)) ((eq x '*pack-ptrs) (comp-pack-ptrs y)) ((eq x '*unpack-ptrs) (comp-unpack-ptrs y)) ((eq x '*rcv-char-*) (comp-rcv-char-* (car y)(cadr y))) ((memq x '(*pl1call *pl1call-nopop)) (comp-pl1-call x y)))) ((or (specialp x) (memq x bvars)) ; if functional value of atom, then compile a call... (make-call (comp x) 'subr y)) ; to it as a subr. if it is an fsubr, you lose. (t (barf x "undefined in pass 2" barf)))) ; complain nil)) (defun compsubr (x y) ; compile a call to a system subr. (cond ((eq x 'set) (compset (comp (car y)) (comp (cadr y)))) ; the set function. ((eq x 'rplaca) (comrplaca (comp (car y)) (comp (cadr y)))) ((eq x 'rplacd) (comrplacd (comp (car y)) (comp (cadr y)))) ((eq x 'memq) (compmemq (comp (car y)) (comp (cadr y)))) ((eq x 'return) (compreturn (car y)(cadr y))) ((memq x '(stringp ; predicate...returns arg if true. < > =)) ; or comparison, which might need call. (setq x (compred (cons x y) t t nil)) ; test and load both t forces this to work...see compred. (get-in-aq (comp '(quote nil))) ; alternate result. (define-tag x) (or AQ (setq AQ (ncons (gensym))))) ; AQ-state has been maintained by define-tag. ((memq x '(null eq zerop plusp minusp atom subrp arrayp definedp boundp fixp floatp smallnump bigp numberp symbolp filep)) ; pred, in-line. (setq x (compred (cons x y) nil nil nil)) ; compile the predicate call. (get-in-aq (comp '(quote t))) ; if predicate true, load t. (outjump !tra (setq y (level-tag nil))) ; and jump to end of code for subr. (and x (define-tag x)) ; if jump was to tag, define that tag (get-in-aq (comp '(quote nil))) ; and make sure nil is in AQ. (define-tag y) ; define the end tag, (or AQ (setq AQ (ncons (gensym))))) ; if AQ has good value remember, else new name. ; AQ-state maintained by define-tag. ((get x 'carcdr) (compcarcdr x y)) ((eq x 'ncons) (get-in-aq (comp (car y))) ; load up arg (clearbb) (outinstag !tspbp !ab|ncons !*) (setq BB (ncons (gensym)))) ((eq x 'cons) (get-in-aq (comp (car y))) ; get first arg loaded (clearbb) (outinstag !tspbp !ab|cons !*) (setq x (ncons (gensym)) ; get result name for cons BB x ; remember where it is loadlist (cons x loadlist)) (setq y (comp (cadr y))) ; compute second arg (cond ((in-bb y) ; see if secondd arg inb (outinstag !eppbp (ilocs x) !*) ; get ptr to cons (outinst !spribb !bp|2) ;store second arg in cdr. (remove y)) (t (get-in-aq y) ; load arg by default into aq (cond ((not (in-bb x)) (clearbb) (outinstag !eppbb (ilocs x) !*) (setq BB x))) (outinst !staq !bb|2))) (remove x) x) ((eq x 'xcons) (get-in-aq (comp (car y))) ; get first arg in q (clearbb) (outinstag !tspbp !ab|xcons !*) (setq BB (ncons (gensym)) x BB loadlist (cons x loadlist)) (get-in-aq (comp (cadr y))) (cond ((in-bb x) (outinst !staq !bb|0)) (t (outinstag !staq (ilocs x) !*))) (remove x) x) ((eq x '1+) (get-fixnum (comp (car y))) ; get the value in AQ, no type needed. (storeaq?) ; make sure value is stored. (cond ((eq AQ-state 'A) ; compile the add to the right register. (outinstag !ada 1_18. !dl)) (t (outinstag !adq 1_18. !dl))) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) ; mark value type. AQ) ((eq x '1-) (get-fixnum (comp (car y))) (storeaq?) ; make sure AQ is freeable for new result. (cond ((eq AQ-state 'A) ; if in A, add to A. (outinstag !sba 1_18. !dl)) (t (outinstag !sbq 1_18. !dl))) (setq AQ (ncons (gensym))) ; and return new result. (putprop (car AQ) 'fixnum 'number) ; remember type of this value. AQ) ((eq x '\) ; fixnum only remainder subr. (comparith nil !\-ops y)) ; just use super-good inline code maker. ((eq x 'lsh) ; shifting subr (compshift t (comp (car y)) (comp (cadr y)))) ((eq x 'rot) ; rotating subr (compshift nil (comp (car y)) (comp (cadr y)))) ((eq x 'ifix) (get-flonum (comp (car y))) (storeaq?) (outinstag !ufa !=71b25 !du) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) (setq AQ-state 'Q) AQ) ((eq x '1+$) (get-flonum (comp (car y))) (storeaq?) (outfloat !fad (make-const 1.0)) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) ((eq x '1-$) (get-flonum (comp (car y))) (storeaq?) (outfloat !fsb (make-const 1.0)) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) ((eq x 'minus) ; if know this to be fixnum negation, cna do well. (setq x (comp (car y))) ; compute argument. (cond ((eq (car x) 'quote) (remove x) (make-const (minus (cadr x)))) ((eq 'fixnum (get (car x) 'number)) ; if fixnum result, then... (negate-fixnum x)) ((eq 'flonum (get (car x) 'number)) ; if flonum result, can always win. (negate-flonum x)) (t (call-1-argument-subr x 'minus)))) ((eq x 'float) ; convert to floating (setq x (comp (car y))) (cond ((eq (car x) 'quote) (remove x) (make-const (float (cadr x)))) ((eq 'flonum (setq y (get (car x) 'number))) (remove x) x) ((eq 'fixnum y) ; here is the in-line case. (get-fixnum x) (storeaq?) ; save whatever's about to be clobbered. (cond ((eq AQ-state 'A) (outinstag !ldq 0 !dl)) (t (outinst !lls (left 36.)))) (outinstag !lde !float-exponent !du) (outinstag !fad !=0/.0 !du) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) (setq AQ-state 'EAQ) AQ) (t (setq x (call-1-argument-subr x 'float)) ; call float subr (putprop (car x) 'flonum 'number) x))) ((memq x '(abs abs$ absfix/!)) ; can do absolute value in line. (setq x (comp (car y))) ; compute arg. (cond ((eq (car x) 'quote) (remove x) (make-const (abs (cadr x)))) ; constant result computed now. ((eq 'fixnum (setq y (get (car x) 'number))) (get-fixnum x) ; make it in register (storeaq?) ; and make it clobberable. (cond ((eq AQ-state 'A) (outinstag !cmpa 0 !dl)) ; we want result in A, sign in register. (t (outinst !lls (left 36.)) ; this will handle moving it from Q, setting sign. (setq AQ-state 'A))) (outjump !tpl (setq y (level-tag nil))) ; jump over next inst. (outinst !neg 0) (define-tag y) (setq AQ (ncons (gensym))) (putprop (car AQ) 'fixnum 'number) AQ) ((eq 'flonum y) (get-flonum x) (storeaq?) (outinstag !fcmp !=0/.0 !du) (outjump !tpl (setq y (level-tag nil))) ; jump if positive around negating. (outinst !fneg 0) (define-tag y) (setq AQ (ncons (gensym))) (putprop (car AQ) 'flonum 'number) AQ) (t (call-1-argument-subr x 'abs)))) ((eq x 'expt$) ; special marked expt... always results in flonum (setq x (make-call 'expt 'subr y)) (putprop (car x) 'flonum 'number) x) (t (make-call x 'subr y)))) (defun call-1-argument-subr (arg subr) (get-in-aq arg) (setq bump-arg-height (+ 2 bump-arg-height)) (storearg -2) (clearaq) (clearbb) (outinst !tspbp (get-function (make-const subr) t 'subr 1)) (setq arg-height (- arg-height 2)) ; subr pops off arg. (setq AQ (ncons (gensym)))) (defun complsubr (x y) ; compile a call to a system lsubr... this can be much improved! (cond ((eq x 'progn) ; if progn, can do good job easily. (do ((scan y (cdr scan))) ((null (cdr scan)) (progn (setq scan (comp0 (car scan))) (or effs (remove scan)) scan)) (compe (car scan)))) ((eq x 'prog2) ; prog2 is also easy. (compe (car y)) ; first arg for effect. (setq x (comp0 (cadr y))) ; remember second result. (mapc 'compe (cddr y)) ; compile rest of things for effect. (or effs (remove x)) ; if not for effect, must remove to prevent adding twice to loadlist. x) ; return second result. ((eq x '+) ; fixnum add (cond ((null y) (get-const ''0)) ; no arguments returns identity. (t (comparith t !+-ops y))));let comparith do all the work. ((eq x '-) (cond ((null y) (get-const ''0)) ; no arguments at all. ((null (cdr y)) (negate-fixnum (comp (car y)))) ; one argument to be negated. (t (comparith nil !--ops y)))) ; let comparith work it out. ((eq x '*) (cond ((null y) (get-const ''1)) ; no arguments returns identity. (t (comparith t !*-ops y)))) ((eq x '//) (cond ((null y) (get-const ''1)) ; no arguments returns identity element. ((null (cdr y)) (comparith nil !//-ops (cons ''1 y))) (t (comparith nil !//-ops y)))) ((eq x 'boole) (cond ((or (atom (car y)) ; not a constant argument, let lsubr be called. (not (eq (caar y) 'quote))) (make-call 'boole 'lsubr y)) ((= (setq x (cadar y)) 1) (comparith t !logand-ops (cdr y))) ((= x 6) (comparith t !xor-ops (cdr y))) ((= x 7) (comparith t !logor-ops (cdr y))) (t (barf y "unprocessed boole argument list" barf)))) ((eq x '+$) (cond ((null y) (make-const 0.0)) (t (compfloat !+$-ops y)))) ((eq x '-$) (cond ((null y) (make-const 0.0)) ((null (cdr y)) (negate-flonum (comp (car y)))) (t (compfloat !-$-ops y)))) ((eq x '*$) (cond ((null y) (make-const 1.0)) (t (compfloat !*$-ops y)))) ((eq x '//$) (cond ((null y) (make-const 1.0)) ((null (cdr y)) (compfloat !//$-ops (cons ''1.0 y))) (t (compfloat !//$-ops y)))) ((memq x '(list list*)) ; do in-line expansion of list. (compile-list-and-list* x y (length y))) (t (make-call x 'lsubr y)))) (defun compile-list-and-list* (x y len) (cond ((< len 2)(barf y "less than 2 arg list/list*" barf)) ((= len 2) (and (eq x 'list*)(barf y "2 args to list*" barf)) (get-in-aq (comp (car y))) (clearbb) (outinstag !tspbp !ab|cons !*) (setq x (ncons (gensym)) BB x loadlist (cons x loadlist)) ; preserve result. (get-in-aq (comp (cadr y))) ; compile second arg (clearbb) (outinstag !tspbp !ab|ncons !*) ; generate second cell. (outinstag !eppbp (ilocs x) !*) ; use bp, bb has been lost anyway (outinst !spribb !bp|2) ;store result into cdr of first one. (remove x) ; don't need result no more x) ; unless caller does (t ; list/list* > 2 args (get-in-aq (comp (car y))) ; get first arg (force-arg-height) ; and make sure ap is correct, (clearbb) ; because operator moves it, clobbers bb too. (outinstag !tspbp !ab|begin-list !*) (setq arg-height (+ arg-height 2)) (let ((result (ncons (gensym)))) ; give name to result (setq BB result) ; Result now in BB (setq loadlist (cons result loadlist)) ; Make sure result stays around (do rest (cdr y) (cdr rest) ; do all but last arguments (and (null (cdr rest)) (setq y rest)) (get-in-aq (comp (car rest))) ; get the argument (clearbb) ; get the bb cleared (outinstag !tspbp !ab|append-list !*)) (get-in-aq (comp (car y))) ; get last argument (cond ((eq x 'list) (clearbb) ; operator clobbers bb (outinstag !tspbp !ab|terminate-list !*)) (t ;This is list*... (outinstag !eppbp !ap|-2 !*) ;bp now -> last cons (outinst !staq !bp|2) ; rplacd the last cons (outinst !eppap !ap|-2))) ; and pop the pdl. (setq arg-height (- arg-height 2)) ; pops off 2 words, also. (remove result) result)))) (defun compfsubr (x y) ; compile a call to a system fsubr. (cond ((memq x '(comment declare)) (and (not effs) (make-const 'comment))) ((eq x 'cond) (compcond y)) ((eq x 'prog) (compprog y)) ((eq x 'setq) (compsetq y)) ((eq x 'go) (compgo (car y) (cadr y))) ((memq x '(and or)) (compandor (eq x 'or) y)) ((eq x 'signp) ((lambda (tag endtag) ; two temporaries. (outjump !tra endtag) ; t is in aq from code below. (define-tag tag) ; code for getting nil in aq. (get-in-aq (comp ''nil)) ; get nil in AQ. (define-tag endtag) ; code rejoins here. (setq AQ (ncons (gensym)))) ; and name the result; AQ-state kept by define-tag. (compred (cons x y) nil nil nil) ; cause it to be computed as a predicate. (prog2 (get-in-aq (comp ''t)) ; define label with t in the AQ previously. (level-tag nil))) ) ((eq x 'err) (comperr y)) ; compile an err, which may be compilable in-line. ((eq x 'errset) (comp-catches-and-errsets nil y)) ((eq x 'unwind-protect)(comp-catches-and-errsets 'unwind-protect y)) ((eq x 'catch) (comp-catches-and-errsets t y)) ((eq x 'throw) (compthrow y)) ((memq x '(store nstore)) (compstore y)) ((eq x 'iog) (compiog y)) ((eq x 'subrcall) (make-call (cons '*subr-ptr y) 'subr (cddr y))) ((eq x 'lsubrcall) (make-call (cons '*subr-ptr y) 'lsubr (cddr y))) ((eq x 'arraycall) (setq x (generate-array-reference (cons '*subr-ptr y) (cddr y))) (cond ((numberp x) ;in-line (storeaq?) ;about to load something into AQ (outwrd x) (setq AQ (ncons (gensym))) (putprop (car AQ) array-type 'number) (setq AQ-state (cdr (assq array-type '((fixnum . Q) (flonum . EAQ)(nil . nil))))) AQ) (t ;out of line x))) (t (make-call x 'fsubr y)))) (defun carinit () ; init car cdr optimizer (mapc '(lambda (x)(putprop (car x)(cdr x) 'carcdr)) carlist) (makunbound 'carlist)) (setq carlist '((symeval a) (car a)(cdr d) (caar a a) (cadr a d) (cdar d a) (cddr d d) (caaar a a a) (caadr a a d) (cadar a d a) (caddr a d d) (cdaar d a a) (cdadr d a d) (cddar d d a) (cdddr d d d) (caaaar a a a a) (caaadr a a a d) (caadar a a d a) (caaddr a a d d) (cadaar a d a a) (cadadr a d a d) (caddar a d d a) (cadddr a d d d) (cdaaar d a a a) (cdaadr d a a d) (cdadar d a d a) (cdaddr d a d d) (cddaar d d a a) (cddadr d d a d) (cdddar d d d a) (cddddr d d d d) (first a) (second a d) (third a d d) (fourth a d d d) (rest1 d) (rest2 d d) (rest3 d d d) (rest4 d d d d))) (carinit) ; init car cdr optimizer (defun reduce-cars (x y) ; x fun, y arglist (do ((clist (get x 'carcdr) (append clist z)) (y (car y)(cadr y)) (z)) (nil) (or (and (not (atom y)) (atom (car y)) (setq z (get (car y) 'carcdr)) (not (unsysp (car y)))) (return (cons clist(comp y))))))))))) (defun compcarcdr (x y) ; function which does car cdr compilations. (setq y (reduce-cars x y)) (setq x (car y) y (cdr y)) (clearaq) ; going to clobber AQ. (setq y (prog2 0 (iloc y) (remove y))) ; locate value in storage. remove from load list also. (and (eq (car y) 'special) ; if special, one extra instruction needed. (prog2 (outinst !eppbp y) (setq y !bp|0))) (cond ((and (null (cdr x))(eq (car x) 'a)) (outinstag !ldaq y !*)) ; car is trivial... (t (outinstag !eppbp y !*) (cond ((eq (car x) 'a) (outinstag !ldaq (carcdr (cdr x)) !*)) (t (outinst !ldaq (carcdr x)))))) (setq AQ (ncons (gensym)))) ;AQ-state set by clearaq above. (defun carcdr (x) (and (cdr x) (outinstag !eppbp (carcdr (cdr x)) !*)) (cond ((eq (car x) 'a) !bp|0) (t !bp|2))) ;; setq -- optimized cases as shown: ;; ;; (setq ... v 0 ...) -- stz ;; if v is fixnum var, _a_n_d v is not special (because type field may never have been set) ;; Also, the following RAR cases are recognized if ;; v is not in a register, and y is a constant or a variable: ;; (setq ... v (+ x 1) ...) -- aos ;; (setq ... v (+ x y) ...) -- asa or asq ;; (setq ... v (+ y x) ...) -- ditto ;; (setq ... v (- x y) ...) -- lcq, asq ;; (setq ... v (- y x) ...) -- ssq or ssa (defun compsetq (x) ; compile setq list (do ((xx x (cddr xx))) ((null xx) x) (setq x (do-setq (car xx) (cadr xx))))) (defun do-setq (v e) ; setq var v to expression e (cond ((and (not (atom e)) ; if expression (memq (car e) '(+ -)); with RAR function (cdr e) (cddr e) (null (cdddr e)) ; and exactly 2 args (or (eq v (cadr e)) (eq v (caddr e))) ; and var as an arg. (not (and (not (atom AQ)) (eq (car AQ) v)))) ; not in AQ already (do-rar-setq v (car e) (cadr e) (caddr e)) ; then do RAR (cons v cnt)) (t (setq e (comp e)) (cleanup-var-load v) (setq cnt (+ 2 cnt)) (cond ((in-bb e) (remove e) (storevalue-bb v)) ; store from bb ((and (eq (car e) 'quote) (eq (cadr e) 0) (not (specialp v)) (eq (get v 'number) 'fixnum)) ; stz into fixnum var (remove e) (outarith !stz (cond ((specialp v) (list 'special v)) (t (get-home v))))) (t (cond ((in-aq e) (remove e)) (t (get-in-aq e))) (storeaq?) (storevalue v) (setq AQ (cons v 'dup)))) ; duplicate value in AQ (setq null-var-list (delq v null-var-list 1)) (cons v cnt)))) ;; function to handle RAR setq's. (defun do-rar-setq (v op x y) ; (setq v (op x y)) (cond ((eq op '+) (and (eq v x) (setq x y))) ; x <- amount added ((eq v x) (setq x y)) ; x <- amount subtracted (t (setq op '-reversed))) (setq y (comp v) x (comp x)) ; order of computation doesn't matter (remove y) (cleanup-var-load v) (setq cnt (+ 2 cnt)) (setq null-var-list (delq v null-var-list 1)) (setq v (cond ((specialp v) (list 'special v)) (t (get-home v)))) ; v now has address ov var. (cond ((eq op '+) (cond ((and (eq (car x) 'quote) (eq (cadr x) '1)) (remove x) (outarith !aos v)) (t (get-fixnum x) (outarith (choose-opc !asa !asq) v)))) ((eq op '-) (clearaq) ; will put useless value in AQ. (outarith !lcq (ilocs x)) ; if x (quote n), won't allocate storage (remove x) (outarith !asq v)) ((eq op '-reversed) ; want to subtract value of v from x (get-fixnum x) (outarith (choose-opc !ssa !ssq) v)) (t (barf op "unknown RAR op" barf)))) ; auxiliary storage manipulation functions (defun storevalue (x) ; stores AQ into value cell of variable x. (cond ((specialp x) (put-type-in-aq) (outinstag !staq (make-const x) !*)) (t ((lambda (type) ; get type of local variable... (cond ((eq type 'fixnum) (cond ((eq AQ-state 'A) (outarith !sta (get-home x))) ((eq AQ-state 'Q) (outarith !stq (get-home x))) ((null AQ-state) (outarith !stq (get-home x))) (t (barf x "could no be assigned value of non-fixnum type" data)))) ((eq type 'flonum) (cond ((eq AQ-state 'EAQ) (outfloat !fst (get-home x))) ((null AQ-state) (outfloat !stq (get-home x))) (t (barf x "could not be assigned non-flonum value" data)))) (t (put-type-in-aq) (outinst !staq (get-home x))))) (get x 'number))))) (defun storevalue-bb (x) ; store the value of variable x from bb (cond ((specialp x) (outinstag !spribb (make-const x) !*)) (t (outinst !spribb (get-home x))))) (defun get-home (x) ; get home of local variable x. (do ((slot slotlist (cdr slot)) (tempi 0 (+ 2 tempi))) ((null slot) (barf x "has no home" barf)) ; error if no home! (and (not (atom (car slot))) ; slotlist element must be list, (eq (caar slot) x) ; and have x as car, (eq (cdar slot) 'home) ; and be the home of that var. (return (list 'temp (- tempi arg-height)))))) (defun compset (x y) (cleanup-special-var-loads) ; might be setting one of our current special vars. (comrplaca x y) y) (defun comrplaca (x y) ; store AQ indirect through location of x. (prog (which) ; holds instruction to use. (cond ((in-bb y) (remove y) (setq which !spribb)) (t (get-in-aq y) (setq which !staq))) (cond ((in-bb x) (outinst which !bb|0)) ; if address already available (t (setq y (ilocs x)) ; find x in storage. (cond ((eq (car y) 'special) ; if special value is to be stored through, (outinst !eppbp y) (setq y !bp|0))) ; store through bp. (outinstag which y !*))) (remove x) ; remove x from loadlist. (return x))) ; rplaca returns first arg. (defun comrplacd (x y) ; compile rplacd. (prog (which) ; holds instruction to use. (cond ((in-bb y) (remove y) (setq which !spribb)) (t (get-in-aq y) (setq which !staq))) (cond ((in-bb x) (outinst which !bb|2)) (t (setq y (ilocs x)) ; locate x in storage. (cond ((eq (car y) 'special) ; special value requires additional instruction. (outinst !eppbp y) (setq y !bp|0))) (outinstag !eppbp y !*) ; get pointer to cons. (outinst which !bp|2))) (remove x) ; remove the reference to x. (return x))) (defun compmemq (x y) (clearaq) ((lambda (tag1 tag2) (outinst !eppbp (iloc y)) ; get address of 2nd value in bp, (outinst !eppbp !bp|-2) ; and treat it as cdr of a "fake cons". (define-tag tag1) ; define loop tag. (outinst !ldaq !bp|2) ; check cdr of list for nil, before going down it. (outinst !cmpaq (make-const nil)) (outjump !tze tag2) (outinst !epplb !bp|0) ; remember whose car we are loading. (outinstag !eppbp !bp|2 !*) ; go down cdr of list. (outinst !ldaq !bp|0) ; load car of list. (outinst !cmpaq (iloc x)) ; cnd check for what is searched for. (outjump !tnz tag1) ; jump back to loop. (outinst !ldaq !lb|2) (remove x) ; remove references to first arg. (remove y) ; remove references to y on loadlist. (define-tag tag2) (setq AQ (ncons (gensym)))) ; return result, which is in AQ; AQ-state set by clearaq above. (level-tag nil) (level-tag nil))) (defun level-tag (tag) ; if nil, make a new tag...which can be gone to. (force-arg-height) ; make sure that arg-height is fixed up... (storeaq?) ; if aq must be stored, do it! (storebb?) (cond ((and tag (getl tag '(level))) (or (and (eq AQ (get tag 'AQ)) (eq AQ-state (get tag 'AQ-state))) ; if AQ the same as before, ok. (prog2 (remprop tag 'AQ) ; remove AQ, AQ-state properties... (remprop tag 'AQ-state))) ; effectively sets them to nil. (or (eq BB (get tag 'BB)) ; same thing in BB (remprop tag 'BB)) (do ((slot slotlist (cdr slot)) (slot1 (get tag 'level) (cdr slot1))) ((or (null slot1) (and (null slot) (rplacd slot1 nil)))) (or (eq (car slot1) (car slot)) (rplaca slot1 nil)) ; if not the same, forget possible result. )) (t (putprop (or tag (setq tag (gensym))) (append slotlist nil) 'level) ; save slotlist state. (and AQ-state (putprop tag AQ-state 'AQ-state)) ; save contents of AQ, AQ-state at this time. (and AQ (putprop tag AQ 'AQ)) (and BB (putprop tag BB 'BB)))) tag) (defun testnil (pred test tag) ; test out-of-line predicate, jump on test to tag. (get-in-aq (comp pred)) ; get pred value in aq. (outinst !cmpaq (setq pred (make-const nil))) ; compare with nil. (or test (setq AQ (prog2 (storeaq?) pred (setq pred AQ)))) ; if null test, (storeaq?) will be in AQ at jump target. (setq tag (level-tag tag)) ; merge state with that of tag... (outjump (cond (test !tnz) (t !tze)) tag) ; put out correct jump. (setq AQ pred) ; AQ gets nil if test was for t, else value saved in pred. tag) ; return (possibly newly made) tag. (defun compcond (cl) ; cl is of form: ((...setq-list...) save-special-flag (p1 ...) (p2 ...)) (clear-null-var-list) ; clear up all variables we have yet to bind to nil. ; if we knew some that weren't used yet, could avoid this somewhat. (and (cadr cl) (cleanup-special-var-loads)) ; if any calls, and such, cleanup the references to specials. (mapc 'cleanup-var-load (car cl)) ; get all references to variables that are setq'ed in the cond itself. (do ((cl (cddr cl) (cdr cl)) (endtag) (clv) (nxtag)) ((null (cdr cl)) ;special case last phrase. (progn ; damn do format! (cond ((cdar cl) ; if (pred value) form, (cond ((easygo (cadar cl)) (compred (caar cl) t nil (cadr (cadar cl))) (setq clv (comp0 ''nil))) (t (setq endtag (compred (caar cl) nil (null effs) endtag)) ; do predicate, jump if nil. (setq clv (comp0 (cadar cl)))))) ; get clause value. (t (setq clv (comp0 (caar cl))))) ; get predicate value for form (pred). (or effs (get-in-aq clv)) ; get the clause value in the AQ. (and endtag (define-tag endtag)) ; here is theplace where we go for the end. (setq cnt (+ 2 cnt)) (or AQ (setq AQ (ncons (gensym)))))) ; return AQ, if same value for all clauses, else new ; value description if AQ useless, and put in AQ. (cond ((cdar cl) ; (pred value) format (cond ((easygo (cadar cl)) (compred (caar cl) t nil (cadr (cadar cl)))) (t (setq nxtag (compred (caar cl) nil nil nil)) ; compile predicate. (setq clv (comp0 (cadar cl))) ; compile value. (or effs (get-in-aq clv)) (outjump !tra (setq endtag (level-tag endtag))) ; and put in a jump to the end of cond. (and nxtag (define-tag nxtag))))) ; and then define tag for next clause. (t (setq endtag (compred (caar cl) t (null effs) endtag)))))) ; if (pred) format, jump to end on t... (defun compandor (test cl) ; compile and or or for value or effect. (clear-null-var-list) (and (cadr cl) (cleanup-special-var-loads)) ; if possibitity of setqing specials, load now. (mapc 'cleanup-var-load (car cl)) ; load all variables to be setqed. (do ((cl (cddr cl) (cdr cl)) (tag nil) (load (null effs))) ((null (cdr cl)) (progn (setq load (comp0 (car cl))) ; compute last phrase. (or effs (get-in-aq load)) ; get in aq if for value. (and tag (define-tag tag)) ; put the end tag here. (setq cnt (+ 2 cnt)) (or AQ (setq AQ (ncons (gensym)))))) (setq tag (compred (car cl) test load tag)))) (defun clear-null-var-list () ; generates stores to all variables which are virtually bound to nil. (cond (null-var-list (get-in-aq (comp (make-const nil))) ; get nil into the AQ. (mapc '(lambda (x) (or (get x 'number) (storevalue x))) null-var-list) (setq null-var-list nil)))) ;;; *** is it right to not store at all when numeric??? *** (defun compred (pred test load tag) ; pred is the predicate to be compiled. ; test represents the value to be tested for, and jumped on. ; load=t forces value of pred to be in AQ when jump is done. ; tag=nil causes a new tag to be made, and returned by compred, ; else the specified tag is jumped to and returned as the value of compred. ((lambda (fn) (cond ((or (atom pred) ; if predicate is atom, or load is forced, or a non-system function call (not (atom (car pred))) ; then just compute value, load, and test for nil. (not (sysp (car pred)))) (testnil pred test tag)) ; compute and test predicate value. ((prog2 (setq fn (car pred)) ; fn gets the (atomic) function applied. (eq fn 'progn)) (do ((l (cdr pred) (cdr l))) ((null (cdr l)) (compred (car l) test load tag)) (compe (car l)))) ; compute each clause for effect, except last. ((and (eq fn 'prog2) (null (cdddr pred))) (compe (cadr pred)) (compred (caddr pred) test load tag)) ; special case of prog2. ((eq fn 'quote) (setq fn (comp pred)) ; compute the predicate. (cond ((eq (not test) (not (cadr fn))) ; if testing for the value computed, do jump. (cond (load (get-in-aq fn)) ; if load, load it, else (t (remove fn))) ; remove it, (outjump !tra (setq tag (level-tag tag)))) ; and jump. (t (remove fn))) ; remove value from loadlist. tag) ((memq fn '(= < >)) ; comparison functions of restricted domain. (comp-parison (comp (cadr pred)) (comp (caddr pred)) fn test load tag)) ((eq fn 'memq) ; memq compilable in-line, always loads AQ with predicate value. (setq fn (comp (cadr pred))) ; compile args. (setq pred (comp (caddr pred))) (clearaq) (outinst !eppbp (iloc pred)) ; get address of second val in bp, (outinst !eppbp !bp|-2) ; make believe it is a cons ((lambda (ltag) (define-tag ltag) ; output loop tag, remembering it. (outinst !ldaq !bp|2) ; load the cdr of the current cons. (outinst !cmpaq (setq AQ (make-const nil))) (outjump !tze ; jump if nil to: (cond (test (setq test (level-tag nil))) ; if testing for t, after memq. (t (setq tag (level-tag tag))))) ; else, to the tag we are to jump on nil to. (and test load (outinst !epplb !bp|0)) ; if test is t and want to load, save thing to load. (outinstag !eppbp !bp|2 !*); move down cdr of list. (outinst !ldaq !bp|0) ; check car of list to see if it is the right thing. (outinst !cmpaq (iloc fn)) ; by comparing with the value we had before gotten. (outjump !tnz ltag) ; if not eq, then loop back. (setq AQ fn)) (level-tag nil)) ; get new tag for ltag. (cond (test ; if testing for t, (and load (progn (outinst !ldaq !lb|2) (setq AQ nil))) (outjump !tra (setq tag (level-tag tag))) (define-tag test))) ; define the tag for nil. (remove pred) ; remove references to second val on loadlist. (remove fn) tag) (load (cond ((memq fn '(null eq zerop minusp plusp signp fixp smallnump floatp numberp bigp atom stringp subrp arrayp definedp boundp filep symbolp)) (setq fn (compred pred (not test) nil nil)) (setq pred (comp (cond (test ''t) (t ''nil)))) (get-in-aq pred) (outjump !tra (setq tag (level-tag tag))) (define-tag fn) tag) (t (testnil pred test tag)))) ; could do and, or, cond better than this will do. ((eq fn 'null) (compred (cadr pred) (not test) nil tag)) ; for null, just invert the test. ((eq fn 'eq) (setq fn (comp (cadr pred))) (setq pred (comp (caddr pred))) ; both values are thus computed. (cond ((in-aq fn) (put-type-in-aq) (outinst !cmpaq (ilocs pred)) (remove fn) (remove pred)) ((in-aq pred) (put-type-in-aq) (outinst !cmpaq (ilocs fn)) (remove fn) (remove pred)) ((and (not (atom (cdr fn))) (eq (car fn) 'quote)) ; if fn is constant, (get-in-aq pred) (outinst !cmpaq (ilocs fn)) (remove fn)) (t (get-in-aq fn) (outinst !cmpaq (ilocs pred)) (remove pred))) (cond ((and (not (atom (cdr fn))) (eq (car fn) 'quote)) ; fn is a constant, so make AQ that. (setq load fn)) ((and (not (atom (cdr pred))) (eq (car pred) 'quote)) ; pred is a constant. (setq load pred)) (t (setq load AQ))) (and test (setq AQ (prog2 (storeaq?) load (setq load AQ)))) (outjump (cond (test !tze) (t !tnz)) (setq tag (level-tag tag))) (setq AQ load) tag) ((eq fn 'fixp) (comp-type-test (cadr pred) (logor !fixtype !bigtype) test tag)) ((eq fn 'smallnump) (comp-type-test (cadr pred) !fixtype test tag)) ((eq fn 'bigp) (comp-type-test (cadr pred) !bigtype test tag)) ((eq fn 'floatp) (comp-type-test (cadr pred) !flotype test tag)) ((eq fn 'numberp) (comp-type-test (cadr pred) !numtype test tag)) ((eq fn 'atom) (comp-type-test (cadr pred) !atomtype test tag)) ((eq fn 'filep) (comp-type-test (cadr pred) !filetype test tag)) ((eq fn 'symbolp) (comp-type-test (cadr pred) !atsymtype test tag)) ((eq fn 'stringp) (comp-type-test (cadr pred) !strtype test tag)) ((eq fn 'subrp) (comp-type-test (cadr pred) !subrtype test tag)) ((eq fn 'arrayp)(comp-type-test (cadr pred) !arraytype test tag)) ((eq fn 'zerop) (or (try-comparative-and (cadr pred) test tag) (test-sign (comp (cadr pred)) (cond (test 'n) (t 'e)) tag))) ((eq fn 'minusp) (test-sign (comp (cadr pred)) (cond (test 'ge) (t 'l)) tag)) ((eq fn 'plusp) (test-sign (comp (cadr pred)) (cond (test 'le) (t 'g)) tag)) ((eq fn 'signp) ; generalized sign testing operator... (setq fn (comp (caddr pred))) ; get value of arg. (setq pred (cadr pred)) (cond (test (setq pred (cdr (assq pred '((l . ge) (ge . l) (n . e) (e . n) (le . g) (g . le))))))) (cond ((or (known-fixnum fn) (known-flonum fn)) (test-sign fn pred tag)) ; do special fast test, since is a number. (t (get-in-aq fn) ; must compute the value to be tested. (outinstag !cana !numtype !dl) ; check for number. (setq fn nil) (cond (test (outjump !tze (setq fn (level-tag fn)))) ; if not number jump to end. (t (outjump !tze (setq tag (level-tag tag))))) ; if testing for nil, jump to lab if not num. (outinstag !tspbp !ab|signp !*) ; get the indicators set, regardless of type. (outjump (cdr (assq pred !jump-tests)) (setq tag (level-tag tag))) (and fn (define-tag fn)) tag))) ((memq fn '(boundp definedp)) (clearaq) (setq fn (comp (cadr pred))) (setq pred (ilocs fn)) (cond ((eq (car pred) 'special) (outinstag !eppbp (make-const (cadr pred)) !*) (setq pred !bp|0))) (outinstag !ldaq pred !*) (outjump (cond (test !tnz) (t !tze)) (setq tag (level-tag tag))) (remove fn) tag) ((eq fn 'and) (and (caddr pred) (cleanup-special-var-loads)) (mapc 'cleanup-var-load (cadr pred)) (clear-null-var-list) (do ((clause (cdddr pred) (cdr clause)) (niltag (cond (test nil) (t tag)))) ; if testing for t, get tag later. ((null (cdr clause)) ; last clause treated special. (progn (cond (test (setq tag (compred (car clause) t nil tag)) (and niltag (define-tag niltag))) ; if niltag created, define it. (t (setq tag (compred (car clause) nil nil niltag)))) (setq cnt (+ 2 cnt)) tag)) (setq niltag (compred (car clause) nil nil niltag)))) ; compile all other preds, test for nil. ((eq fn 'or) (and (caddr pred) (cleanup-special-var-loads)) (mapc 'cleanup-var-load (cadr pred)) (clear-null-var-list) (do ((clause (cdddr pred) (cdr clause)) (niltag (cond (test tag) (t nil)))) ; if testing for nil, get tag later. ((null (cdr clause)) ; last clause specially treated. (progn (cond (test (setq tag (compred (car clause) t nil niltag))) (t (setq tag (compred (car clause) nil nil tag)) (and niltag (define-tag niltag)))) (setq cnt (+ 2 cnt)) tag)) (setq niltag (compred (car clause) t nil niltag)))) ((eq fn 'cond) ; cond as a predicate can be distributed! (and (caddr pred) (cleanup-special-var-loads)) (mapc 'cleanup-var-load (cadr pred)) (clear-null-var-list) (do ((cl (cdddr pred) (cdr cl)) (nxtag) (endtag)) ((null (cdr cl)) (progn (cond ((cdar cl) ; two element clause. (cond (test (setq endtag (compred (caar cl) nil nil endtag))) ; if testing for t, jump to end of cond on nil. (t (setq tag (compred (caar cl) nil nil tag)))) ; otherwise, if predicate nil, jump to tag. (setq tag (compred (cadar cl) test nil tag))) (t (setq tag (compred (caar cl) test nil tag)))) (and endtag (define-tag endtag)) (setq cnt (+ 2 cnt)) tag)) (cond ((cdar cl) ; cond with two parts. (setq nxtag (compred (caar cl) nil nil nil)) (setq tag (compred (cadar cl) test nil tag)) ; compile body of clause for jump. (outjump !tra (setq endtag (level-tag endtag))) ; jump to end of cond. (define-tag nxtag)) (test (setq tag (compred (caar cl) test nil tag))) ; if for t, and pred is thus for both. (t (setq endtag (compred (caar cl) t nil endtag)))))) ; if for nil, jump on t to end of this. (t (testnil pred test tag)))) ; if not, give up, and force evaluation for value.! nil)) (defun comp-type-test (val bits test tag) ; compute a test for type. (get-in-aq (comp val)) (outinstag !cana bits !dl) (outjump (cond (test !tnz) (t !tze)) (setq tag (level-tag tag))) tag) (declare (eval (read))) (setm comparison-tests ((= 600000 601000 600000 601000) (< 604000 605000 605400 604400) (> 605400 604400 604000 605000))) ; used by comp-parison to jump on indicators. (defun known-fixnum (val) (cond ((eq (car val) 'quote) (smallnump (cadr val))) ((eq 'fixnum (get (car val) 'number))))) (defun known-flonum (val) (cond ((eq (car val) 'quote) (floatp (cadr val))) ((eq 'flonum (get (car val) 'number))))) (defun comp-parison (val1 val2 fn test load tag) ; compile a compare function. jump on result = ((lambda (jumps) ;test to tag. (cond ((or (known-fixnum val1) (known-fixnum val2)) (cond ((in-aq val1) (remove val1)) ((in-aq val2) (remove val2) (setq jumps (cddr jumps)) (setq val2 val1)) ((eq (car val1) 'quote) (get-fixnum val2) (setq jumps (cddr jumps)) (setq val2 val1)) (t (get-fixnum val1))) (setq val1 (ilocs val2)) (cond ((eq AQ-state 'A) (outarith !cmpa val1)) (t (outarith !cmpq val1)))) ((or (known-flonum val1) (known-flonum val2)) (cond ((and (in-aq val1) (or (eq AQ-state 'EAQ) (eq fn '=))) (remove val1)) ; val1 in aq ok! ((and (in-aq val2) (or (eq AQ-state 'EAQ) (eq fn '=))) (remove val2) (setq jumps (cddr jumps)) (setq val2 val1)) ((eq (car val1) 'quote) (get-flonum val2) (setq jumps (cddr jumps)) (setq val2 val1)) (t (get-flonum val1))) (setq val1 (ilocs val2)) (cond ((eq AQ-state 'EAQ) (outfloat !fcmp val1)) (t (outfloat !cmpq val1)))) (t (cond ((in-aq val1) (remove val1)) ((in-aq val2) (remove val2) (setq jumps (cddr jumps)) (setq val2 val1)) ((eq (car val1) 'quote) (get-in-aq val2) (setq jumps (cddr jumps)) (setq val2 val1)) (t (get-in-aq val1))) (setq val1 (ilocs val2)) (cond ((eq fn '=) (outfloat !cmpq val1)) ; don't have to use op in = case. (t (clearbb) ; we are going to use bb. (outinst !eppbb val1) ; get pointer to other operand. (outinstag !tspbp !ab|compare !*))))) (remove val2) (outjump (cond (load (outjump (cond (test (cadr jumps)) ; must get loaded result in AQ. (t (car jumps))) (setq jumps (level-tag nil))) ; jump to end of pred if not jumping (get-in-aq (comp (make-const test))) ; get value in aq !tra) (test (car jumps)) (t (cadr jumps))) (setq tag (level-tag tag))) (and load (define-tag jumps)) tag) (cdr (assq fn !comparison-tests)))) (defun test-sign (value condition tag) ((lambda (type endtag oldcodelist) ;; test sign of known numeric value of type type, ;; jump if condition (g, ge, l, le, e, n) not true to atag. ;; endtag is used by zerop test, to get to end of code. (cond ((eq type 'fixnum) (get-fixnum value) (cond ((eq AQ-state 'A) (outarith !cmpa (make-const 0))) ((and (eq AQ-state 'Q) (not (eq codelist oldcodelist)))) ;already loaded (t (outarith !cmpq (make-const 0))))) ((eq type 'flonum) (get-flonum value) (outfloat !fcmp (make-const 0.0))) (t (get-in-aq value) ; get typed value (cond ((eq condition 'e) ; these two cases don't need all indicators set. (outinst !cmpaq (make-const 0)) (outjump !tze (setq endtag (level-tag nil))) ; jump to end of zerop test if zero. (outinst !cmpaq (make-const 0.0))) ((eq condition 'n) (outinst !cmpaq (make-const 0)) (outjump !tze (setq tag (level-tag tag))) (outinst !cmpaq (make-const 0.0))) (t (outinstag !tspbp !ab|signp !*))) )) (outjump (cdr (assq condition !jump-tests)) (setq tag (level-tag tag))) (and endtag (define-tag endtag)) ; if we used endtag, define it. tag) (cond ((known-fixnum value) 'fixnum) ; this might be done more efficiently sometime. ((known-flonum value) 'flonum) (t nil)) nil codelist)) (defun try-comparative-and (pred test tag) ; special case (zerop (logand x const)) (and (not (atom pred)) ; pred must be (boole 1 xxx.. ) (eq (car pred) 'boole) (not (unsysp 'boole)) (not (atom (cadr pred))) (eq (caadr pred) 'quote) ; must be constant boolectl (= (cadadr pred) 1) ; better be a # at this point ((lambda (x y) ;compile operands (cond ((eq (car x) 'quote) ;let y be the constant, if any (setq x (prog2 0 y (setq y x))))) (cond ((in-aq y)(setq y (prog2 0 x (setq x y))))) (get-fixnum x) (outarith (choose-opc !cana !canq) (iloc y)) (remove y) ; finished using y ; x remains in AQ (outjump (cdr (assq (cond (test 'n)('e)) !jump-tests)) (setq tag (level-tag tag))) tag) ;return the tag (comp (caddr pred)) (comp (cadddr pred))))) (defun comp-catches-and-errsets (catch? y) ((lambda (tag name offset cont-tag result) (cleanup-var-loads) ; so errors causing random jumps don't foul us up... (clear-null-var-list) ; since we expect random jumps, make sure all vars correctly bound. (storeaq?) ; make sure aq value is stored... (clearbb) (cond ((eq catch? 'unwind-protect) (force-arg-height)) ((cdr y) (setq bump-arg-height (+ bump-arg-height 2)) (setq name (comp (cadr y))) ; note: (catch ... tag) -> (catch ... 'tag) in pass 1. (get-in-aq name) ; if tag were nil for errset, pass1 would have dleted it. (storearg -2)) ; and push it on stack. (t ; catch or errset with only one arg... (force-arg-height) ; make sure arg-height is bumped here. (setq arg-height (+ arg-height 2)))) ; operator pushes 2 words on marked pdl. (setq AQ nil AQ-state nil) ;AQ known to contain nothing good - make it nil since ((lambda (slotlist) ; catch/errset operator will soon mung it. (setq tag (level-tag nil))) ;make a tag with a cleared-up slotlist and AQ. (clearslotlist)) (setq framel (cons (list (cond ((eq catch? 'unwind-protect) unwptag) ((null catch?) errtag) (t name)) arg-height ; must pop off to this location if unwinding through this. tag) framel)) ; push note of this frame onto framel. (outinstag !tspbp (cond ((cdr y) (+ offset 2000000)) (offset)) !*) ; output a call to the correct operator. (outinst !tra tag) ; skipped by operator set up. ; NOTE: this tra is done by outinst, because outjump would cause ; any code following this to be supressed. (setq result (comp0 (car y))) ; Compute the first arg. (cond ((eq catch? 'unwind-protect) ; lotta stuff to do. (clearaq) (clearbb) (cond ((and useless-code (not labels-to-define))(setq cont-tag nil)) ;set flag for no stuff (t ((lambda (slotlist) (setq cont-tag (level-tag nil))) ; make tag for end. (clearslotlist)) (outinstag !tspbp (+ offset 4000000) !*) ;ununwp op (outjump !tra cont-tag))) (define-tag tag) ; This is the handler. ;; This bit of hair prevents the handler from using anything ;; except totally dedicated temporaries. We do not know ;; from where we are being invoked, and the "answer" ;; (consider esp. a nonlocal compiled return) can be ;; just about anywhere. (map '(lambda (x) (cond ((freeable (car x)) (rplaca x 'uwp-saves-pdl)))) slotlist) (mapc 'compe (cdr y)) ; Compile the handler. (outjumptag !tra !ab|irest-return !*) ; Return via Lisp, restoring interrupt system. (and cont-tag (define-tag cont-tag)) ; The continuation (setq framel (cdr framel)) (or effs (remove result)) result) (t (or effs (get-in-aq result)) (define-tag tag) ; put the tag here... (outinstag !tspbp (+ offset 4000000) !*) ; undo the frame. (setq arg-height (- arg-height 2)) ; operator pops this much. (setq framel (cdr framel)) (setq AQ (ncons (gensym)))))) ; return new name, put in AQ too. ; AQ-state maintained by get-in-aq nil catchtag (cond ((eq catch? 'unwind-protect) !ab|unwp1)(catch? !ab|catch1) (t !ab|errset1)) nil nil)) (defun unwind (tag) ; general unwinder of frames, for throw, err, and go. (do ((frame framel (cdr frame))) ((eq (caar frame) tag) ; if at the place we wanted... (progn (popap (cadar frame)) ; pop the ap back to the desired arg-height. (cddar frame))) ; return the rest of the info in the frame list entry. (unwind-one-frame (car frame)))) (defun unwind-one-frame (frame) (cond ((eq (car frame) progtag)) ; if it is a progtag, but not what we are looking for, ignore. ((prog2 (popap (cadr frame)) ; all frames have height to be popped to here. (eq (car frame) bindtag)) ; check for binding frame to be removed. (clearbb) (outinstag !tspbp !ab|unbind !*) (setq arg-height (caddr frame))) ; ap gets popped by unbind operator. ((eq (car frame) errtag) ; must undo an errset. (clearbb) (setq arg-height (- arg-height 2)) ; operator pops off 2 words. (outinstag !tspbp !ab|unerrset !*)) ; call the unerrset operator. ((eq (car frame) unwptag) ; unwind protect (clearaq) (clearbb) (outinstag !tspbp !ab|ununwp !*)) ; Make like finished executing (t (clearbb) (setq arg-height (- arg-height 2)) ; operator pops off 2 words. (outinstag !tspbp !ab|uncatch !*)))) ; uncatch operator. (defun popap (height) (cond ((= arg-height height)) (t (outinst !eppap (logor !ap| (left (logand 77777 (- height arg-height))))) (setq arg-height height)))) (defun compthrow (y) ; compute a throw, trying to do it inline if possible... ((lambda (tag arg-height) (cond ((cdr y) (setq tag (get-const (cadr y))))) ; if named throw, get name of tag thrown to. (setq y (comp (car y))) ; compute value thrown. (cond ((do ((frame framel (cdr frame))) ((null frame) nil) (cond ((eq (caar frame) catchtag) (setq tag catchtag) (return t)) ((eq (caar frame) tag) (return t)))) (setq tag (car (unwind tag))) ; unwind the frames above the catch. (get-in-aq y) ; make sure the value is in the AQ. (outjump !tra tag)) ; finally, jump to the uncatch tag for that catch. (t (get-in-aq y) ; get value in the AQ. (cond ((eq tag catchtag) ; if no-name throw, then use throw op 1. (outinstag !tra !ab|throw1 !*)) (t ; put value on top of stack. (setq bump-arg-height (+ 4 bump-arg-height)) (storearg -2) ; store it on top of the stack. (setq loadlist (cons tag loadlist)) (get-in-aq tag) ; get the tag to thorw to in aq. (outinstag !tra !ab|throw2 !*) (setq arg-height (- arg-height 4)))) ; too bad it doesn't return...but keep things consistent. (setq useless-code t))) ; mask code through the next label. (setq AQ-state nil AQ (ncons (gensym)))) ; return a dummy name for this quantity. catchtag arg-height)) (defun comperr (y) (setq y (comp (car y))) ; compute the value err'd with. ((lambda (tag arg-height) ; working storage...rebind arg-height for unwind (cond ((assq tag framel) ; check for in-line err signal if possible. (setq tag (car (unwind tag))) ; unwind stack...retrns label to jump to to finish off stuff. (get-in-aq y) ; do the jump with aq loaded. (outjump !tra tag)) (t (get-in-aq y) ; set up for err-op call. (outinstag !tra !ab|err !*) ; jump to err op. (setq useless-code t))) ; ignore code to next label. (setq AQ-state nil AQ (ncons (gensym)))) errtag arg-height)) (defun compreturn (x nlevels) ; compile a return from a prog. ((lambda (effs arg-height) ; evaluate argument in prog state of effs... (setq x (comp0 x)) ; compute argument. (unwindgoret nlevels) ; unwind to the specified prog level (or effs (get-in-aq x)) ; get the value returned into the AQ, if needed. (setq x (find-nth exit nlevels)) ; find the exit from the particular prog. (outjump !tra (car (rplaca x (level-tag (car x))))) ;and output a jump to it. (setq AQ-state nil AQ (ncons (gensym)))) ; return a dummy name, and fool compiler into thinking its in AQ. (car (find-nth prog-for-effs nlevels)) arg-height)) (defun compgo (x nlevels) ; compile a goto. ((lambda (arg-height) ; rebind arg-height for unwinding operation. (cond ((atom x) ; normal case. (clear-null-var-list) (unwindgoret nlevels) ; pop back to specified prog level (outjump !tra (level-tag x))) (t ; computed goto. (setq x (comp x)) ; so compute label to go to. (clear-null-var-list) (unwindgoret nlevels) ; pop back to specified prog level (get-in-aq x) ; get tag name in AQ, so computed go subroutine will work. (setq x (find-nth vgol nlevels)) ;find appropriate level in vgol pushdown list (outjump !tra (car (rplaca x (level-tag (car x))))))) ; jump to computed goto subroutine for the current prog. (setq AQ-state nil AQ (ncons (gensym)))) arg-height)) (defun find-nth (x nlevels) (cond ((zerop nlevels) x) ((find-nth (cdr x) (1- nlevels))))) (defun unwindgoret (nlevels) ;version of unwind which unwinds n+1 progtags (do frame framel (cdr frame) (minusp nlevels) (cond ((eq (caar frame) progtag) ;if a prog tag (setq nlevels (1- nlevels)))) ;count the progs (cond ((minusp nlevels)(popap (cadar frame)))) (unwind-one-frame (car frame)))) (defun easygo (x) ; see if value part of cond phrase is an easily done goto. (and (not (atom x)) ; must be form (eq (car x) 'go) ; with function go... (atom (cadr x)) ; with constant label. (= 0 (caddr x)) ; the level must be top-level (eq (caar framel) progtag) (= arg-height (cadar framel)) ; also, no arguments to be popped (= 0 bump-arg-height) ;no subtle hidden args, either (null null-var-list))) ; and no uninitialized variables... (defun compiog (y) ; compile a call to iog, which is an fsubr. (force-arg-height) ; force ap to be in the right place. (clearaq) ; iog bind operator clobbers AQ. (clearbb) (outinstag !tspbp !ab|iogbind !*) ; rebind all iog vars. (setq framel (cons (list bindtag (+ arg-height 16.) arg-height) framel)) (setq arg-height (+ arg-height 16.)) (cond ((car y) (compe (list 'ioc (car y))))) (setq y (comp0 (cadr y))) (clearbb) (outinstag !tspbp !ab|unbind !*) ; unbind. (setq arg-height (- arg-height 16.)) ; size of binding block. (setq framel (cdr framel)) (and (not effs) (remove y)) ; if we added it to loadlist, must delete it so only one copy gets there... y) ;;; array stuff (defun generate-array-reference (array subs) (prog (ndims type temp dimensions hack in-x0 array-ptr-name result) (cond ((atom array) (cond ((setq dimensions (get array 'array*)) (setq ndims (length dimensions) type (car (get array 'numfun))) (or (= ndims (length subs)) (barf (cons array subs) "wrong number of subscripts on array." 'data)) (setq temp (make-array-link array type ndims))) (t ;not declared array* (return (make-array-call array subs))))) ((eq (car array) '*subr-ptr) ;arraycall (setq ndims (length subs) type (cadr array)) (or (eq type 'fixnum) (eq type 'flonum) (setq type nil)) (setq temp (comp (caddr array))) ) (t (return (make-array-call array subs)))) (setq subs (mapcar 'comp subs)) ;find all the subscripts (clearbb) (cond ((atom array) ;pick up array-pointer (outinst !xec temp)) (t (setq temp (prog2 nil (ilocs temp) (remove temp))) (outinstag !eppbb temp !*) (and (eq (car temp) 'special) ;indirection didn't take... (outwrd !eppbb-bb*)))) (setq array-ptr-name (ncons (gensym)) BB array-ptr-name loadlist (cons BB loadlist)) ;make sure BB stays loaded. (and dimensions (not (memq nil dimensions)) (setq hack t)) (and (= ndims 1) (setq hack t)) ;never need multipliers in this case. (or hack (outinstag !eppbb !bb|2 !*)) ;-> array data. (cond ((and type (= ndims 1) (not (in-Q (car subs)))) ;can just lxl0 subscript (setq in-x0 t) (outarith !lxl0 (ilocs (car subs))) (remove (car subs))) ;; *** should do constant subscripts here (t ;compute subscript in q (do ((sub) (mpy nil) (first t nil)) ((null subs)) (setq sub (car subs) subs (cdr subs)) (and dimensions (setq dimensions (cdr dimensions) mpy (car dimensions))) (cond (first (get-fixnum sub) (cond ((eq AQ-state 'A) (outinst !lrl (left 36.)) (setq AQ-state 'Q))) ) (t (and result (remove result)) (storeaq?) (setq result (ncons (gensym)) AQ result AQ-state 'Q) (putprop result 'fixnum 'number) (setq loadlist (cons result loadlist)) (outarith !adq (ilocs sub)) (remove sub))) (or (and (null subs) type) ;going to clobber AQ? (progn ;yes, make new result. (and result (remove result)) (storeaq?) (setq result (ncons (gensym)) AQ result AQ-state 'Q) (putprop result 'fixnum 'number) (setq loadlist (cons result loadlist)) )) (cond ((null subs) ;last, maybe omit multiply (or type (outinst !qls (left 1)))) (mpy ;constant multiplier (do ((z 1 (lsh z 1)) (n 0 (1+ n))) (nil) (cond ((= z mpy) ;power of two. (return (or (zerop n) (outinst !qls (left n))))) ((> n 12.) ;not power of 2 I guess. (return (outinstag !mpy (left mpy) !dl)))))) ((outinst !mpy (- !bb|-1 (lsh (length subs) 19.))))) (or (eq BB array-ptr-name) (barf nil "some villain made off with my BB register!" barf)) ))) (and result (remove result)) ;now we know nothing will happen until BB and Q are picked up by caller (remove BB) (setq BB nil) (setq array-type type) ;pass type out to caller. (ecch) (return (logor ;return the instruction to load from array. (cond ((eq type 'fixnum) !ldq) ((eq type 'flonum) !fld) (t !ldaq)) (cond ((not hack) !bb|0) (t (logor !bb|2 60))) ;indirect postindex (cond (in-x0 !x0) (t !ql)) )))) (defun make-array-call (array subs) (cond ((getl array '(array *array)) (make-call array 'subr subs)) ;array is functional property ((or (specialp array) (memq array bvars)) (make-call (comp array) 'subr subs)) ;array is computed value (t (warn (cons array subs) "questionable array reference") (compform array subs)) )) ;hope for the best (defun comparray (array subs) ((lambda (how) (cond ((numberp how) ;in-line array reference (storeaq?) ;about to load something into AQ (outwrd how) ;code to load from array (setq AQ (ncons (gensym))) (putprop (car AQ) array-type 'number) (setq AQ-state (cdr (assq array-type ;make AQ-state more realistic '((fixnum . Q) (flonum . EAQ) (nil . nil))))) AQ) (t how))) ;out of line - return the result of make-call (generate-array-reference array subs) )) (defun compstore (y) (prog (type val addressibility) (setq val (comp (cadr y))) ;compute second operand first (setq y (cond ((eq (caar y) 'arraycall) (generate-array-reference (cons '*subr-ptr (cdar y)) (cdddar y))) ((generate-array-reference (caar y) (cdar y))))) (cond ((numberp y) ;inline, pick up ptr to where to store (setq addressibility (logand y !address-part)) (cond ((= (logand y !xrfield) !ql) ;ql modifier-- (outinst !eppbb addressibility) (setq addressibility !bb|0))) ;evaluate before changing Q. (setq type array-type) ;inline, store through bb (outinst (cond ((null type) (get-in-aq val) !staq) ((eq type 'fixnum) (get-fixnum val) (cond ((eq AQ-state 'A) !sta) (t !stq))) (t ;flonum (get-flonum val) (cond ((eq AQ-state 'EAQ) !fst) (t !stq))) ) addressibility)) ((and (in-aq val) (eq AQ-state 'EAQ)) ;out of line, floating. (outinstag !tspbp !ab|float-store-op !*) (remove val)) (t (get-in-aq val) (outinstag !tspbp !ab|store-op !*))) ;out of line, use opr. (return val))) (defun make-array-link (array type ndims) (get-function (make-const array) type 'array ndims)) ;; code to handle internal lambda-applications. ;; uses special null-var-list hack. (defun complambda (x y) ; first arg is functional form, second list of value names. (prog (ll bind-size slotx obvars locals speclist) (setq ll (cadr x) ; get lambda list, x (caddr x) ; body of lambda form, bind-size 0 ; space taken by special binding block obvars bvars) ; and save bvars list value at this time. (mapc '(lambda (var val) ; map over lambda list and corresponding values. (setq val (comp val)) ; compute the next value. (cond ((specialp var) (setq speclist (cons (list var val) speclist))) ; remember value to be bound in var. ; save location of value assigned, and value to be removed with var. (t (findtemp (get var 'number)) ; set slotx to point at a free temporary (of correct type) in slotlist (setq locals (cons (car (rplaca slotx (cons var 'home))) locals)) ; and put var's home here, also remembering how to remove it. (cond ((eq val (make-const nil)) ; if nil is to be the bound value, defer binding. (remove val) ; act as if we assigned value. (setq null-var-list (cons var null-var-list))) ((in-bb val) (remove val) (storevalue-bb var)) ((and (eq (car val) 'quote) (eq (cadr val) 0) (eq (get var 'number) 'fixnum)) ; stz into fixnum var. (remove val) (outarith !stz (get-home var))) (t (cond ((in-aq val) (remove val)) (t (get-in-aq val))) (storevalue var) (storeaq?) ; I am not sure this is necessary, but will never hurt code. (setq AQ (cons var 'dup)))))) ; remember what value is in AQ. ; AQ-state set by get-in-aq (setq bvars (cons var bvars))) ll y) (cond (speclist ; if specials to be bound, make a binding block. (force-arg-height) (mapc '(lambda (val) (cleanup-var-load (car val)) (setq bind-size (+ bind-size 4)) (rplacd val (cons (ilocs (cadr val)) (cdr val)))); locate value somewhere in storage. speclist) (clearaq) ; since bind op clobbers AQ. (clearbb) (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)) ; word saying how much space to reserve. (setq arg-height (+ bind-size arg-height)) (mapc '(lambda (val) ; map over speclist. (cond ((eq (caadr val) 'temp) ; if temp, must modify address since specbind addresses ; from the stack height after growing... (rplaca (cdadr val) (- (cadadr val) bind-size)))) (outbindwrd (make-const (car val)) (cadr val)) (remove (caddr val))) ; remove value from load list. speclist) (setq framel (cons (list bindtag arg-height (- arg-height bind-size)) framel)))) ; add a binding frame to unwind list. (setq cnt (1+ cnt)) (setq x (comp0 x)) ; compute value desired of body. ;; handle case where x is a variable. generate a new name, and make sure it is loaded, and on the loadlist. (cond ((and x (numberp (cdr x))) (get-in-aq x) (storeaq?) (setq x (ncons (gensym)) AQ x loadlist (cons x loadlist)))) (cond (speclist (clearbb) (outinstag !tspbp !ab|unbind !*) ; call the unbinder. (setq arg-height (- arg-height bind-size)) (setq framel (cdr framel)))) ;note unbinder must preserve AQ since the result is currently in it. (mapc '(lambda (x) ; map over all locals. (setq null-var-list (delq (car x) null-var-list)) ; if var was bound to nil, never used, this fixes it. (do slot slotlist (cdr slot) (null slot) ; flush variable home. (cond ((eq x (car slot)) (rplaca slot nil) (return nil))))) locals) (and x (remove x)) (setq bvars obvars) ; pop back bvars list. (return x))) ; return computed value. ;; code to implement the prog function. ;; basically similar to the lambda application stuff, ;; but handles labels, and especially the back reference cases. (defun compprog (y) ; argument is the list comprising the prog body. ((lambda (vgol exit) (prog (bindword locals slotx bind-size obvars) (setq obvars bvars ; remember the old bvars list. prog-for-effs (cons effs prog-for-effs)) ; remember what effs is for return's to this prog. (and (cadr y) (cleanup-special-var-loads)) ; if calls-out present, cleanup all references to specials. (mapc 'cleanup-var-load (car y)) ; assume any special vars in the prog var list are here. (setq y (cddr y)) (mapc '(lambda (x) ; map over all vars to be bound. (cond ((specialp x) ; if special variable, (cond ((null bindword) (force-arg-height) (clearaq) ; binding operator clobbers AQ. (clearbb) (outinstag !tspbp !ab|bind !*) (outwrd 000000) ;place holder for binding block size (setq bindword codelist) ;KLUDGE - remember patch loc (setq bind-size 0))) (setq bind-size (+ bind-size 4)) ; four more words pushed on stack. (outbindwrd (make-const x) (make-const nil))) (t (findtemp (get x 'number)) ; gets free temp, slotx points at slot. not bound to nil in case of number. (setq null-var-list (cons x null-var-list)) (setq locals (cons (car (rplaca slotx (cons x 'home))) locals)))) (setq bvars (cons x bvars))) (cadr y)) (cond (bindword (setq framel (cons (list bindtag (+ bind-size arg-height) arg-height) framel) arg-height (+ bind-size arg-height)) (rplaca bindword (left bind-size)))) (force-arg-height) (setq framel (cons (list progtag arg-height effs) framel)) (setq cnt (1+ cnt)) (cond ((car y) ; if tags... (storeaq?) (storebb?) ; clear slotlist must have these stored! ((lambda (sl) (mapc '(lambda (x) (setq x (cdr x)) ; go list is list of pairs. (cond ((get x 'back-reference) (putprop x (append sl nil) 'level) ))) ; AQ-state, AQ properties nil by virtue of non-existence. (car y))) (clearslotlist)))) (mapc '(lambda (x) ; map over all prog body elements. (setq cnt (1+ cnt)) ; just for kicks. (cond ((atom x) ; if a label, (clear-null-var-list) ; if any vars not yet set to nil, do so. (define-tag x)) ; and make this label a tag. (t (compe x)))) (cddr y)) (cond ((car vgol) ; if variable go feature used, (cond ((not useless-code) (compe '(return 'nil)))) ; may need a jump around go code. (define-tag (car vgol)) ; here we are... (mapc '(lambda (x) (outinst !cmpaq (make-const (car x))) (outjump !tze (cdr x))) (car y)) (outinstag !tspbp !ab|badgo !*) (outjump !tra (car vgol))) (t (cond ((and (not effs) (or (not useless-code) labels-to-define)) (get-in-aq (comp ''nil)))))) (cond ((car exit) ; if ever returned from, ;; (cond ((and (not (atom (car codelist))) ; and instruction just outputted was a jump, ;; (eq (caar codelist) !tra) ;; (eq (cadar codelist) (car exit))) ;; (setq codelist (cdr codelist)) ;; (setq pc (1- pc)))) (define-tag (car exit)))) (setq framel (cdr framel)) ; remove prog frame. (cond (bindword (clearbb) (outinstag !tspbp !ab|unbind !*) (setq arg-height (- arg-height bind-size)) (setq framel (cdr framel)))) (mapc '(lambda (x) (setq null-var-list (delq (car x) null-var-list 1)) (do slot slotlist (cdr slot) (null slot) (cond ((eq (car slot) x) (rplaca slot nil) (return nil))))) locals) (setq bvars obvars prog-for-effs (cdr prog-for-effs)) ; pop effs list for progs. (setq cnt (+ 2 cnt)) (clearaq) ; not sure its needed, but be safe here. (return (setq AQ-state nil AQ (ncons (gensym)))))) (cons nil vgol) ;nil means no variable go at this level, may be rplaca'ed to a tag later. (cons nil exit))) ;nil means no returns from this prog, rplaca'ed to a tag if one gets done. ;;; Routines to generate code for defpl1 subrs (defun comp-cons-string (y) ;cons a string of spcified size (clearaq) (clearbb) ;clobbers these regs (outinstag !ldq (left (car y)) !dl) ;get length in q register (outinstag !tspbp !ab|cons-string-op !*);call operator to get the string (setq AQ (ncons (gensym)))) ;and the result is returned in aq (also in bb but we don't need it there) (defun comp-rcv-char-* (symb cell) ;BSG 10/13/80 (setq cell (left (logand 77777 cell))) (clearaq) (clearbb) (outinstag !ldq (+ cell (left 2)) !ab-x7) ;get returned desc (outwrd (get-descriptor-address !anq 000003777777)) ;fixed bin(21) (outinstag !tspbp !ab|cons-string-op !*) ;cons a string (outinst !staq (get-home symb)) (outinstag !epplb cell !ab-x7*) ;point at real string (outinstag !tspbp !ab|rcv-char-*-op !*) ;move result, pop pl1 stack (setq AQ nil AQ-state nil)) (defun comp-pack-ptrs (y) ;y is list of symbols and pdl cells to pack them out of ;i.e. copy ptrs from pdl into packed fixnums (do ((y y (cddr y)) (symb) (cell)) ((null y)) (setq symb (car y) cell (left (logand 77777 (cadr y)))) ; Note that type will already have been set by lambda binding (outinstag !eppbp cell !ab-x7*) (outarith !sprpbp (get-home symb)))) (defun comp-unpack-ptrs (y) ;y is list of symbols and pdl cells to unpack them inot (do ((y y (cddr y)) (symb) (cell)) ((null y)) (setq symb (car y) cell (left (logand 77777 (cadr y)))) (outarith !lprpbp (get-home symb)) ;pick fixnum as a pointer (outinstag !spribp cell !ab-x7) )) ;put down in unpacked format ; Note that the following function does not comp the variables in ; its arguments. This is because pass 1 doesn't either. This stuff ; is not considered to be lisp code, but just special stuff passed between passes (defun comp-pl1-call (fcn y) ;generate code to call a pl1 program (clear-null-var-list) ;make sure all vars possess homes ((lambda (extname arglistcell argdesclist) (do ((argl argdesclist (cdr argl)) (argptrcell (+ 2000000 arglistcell) (+ 2000000 argptrcell)) (descptrcell (+ arglistcell (* 2000000 (1+ (length argdesclist)))) (+ 2000000 descptrcell)) (type) (var) (descrip) (cell)) ((null argl)) (setq type (caar argl) var (cadar argl) descrip (caddar argl) cell (left (logand 77777 (cadddr (car argl))))) (cond ;generate addressing code for arg and descriptor ((or (null type) ;just pass address of lisp object, constant descriptor (eq type '1+)) ;same but pass address + 1 (for number) (cond ((null type) (outinst !eppbp (get-home var))) ((outarith !eppbp (get-home var)))) (outinstag !spribp argptrcell !ab-x7) (outwrd (get-descriptor-address !eppbp descrip)) (outinstag !spribp descptrcell !ab-x7)) ((eq type 'unmkd) ;pass address of unmkd pdl cell, constant descriptor (outinstag !eppbp cell !ab-x7) (outinstag !spribp argptrcell !ab-x7) (outwrd (get-descriptor-address !eppbp descrip)) (outinstag !spribp descptrcell !ab-x7)) ((eq type 'ret-char-*) (outinstag !eppbp cell !ab-x7) (outinstag !spribp argptrcell !ab-x7) (outinstag !eppbp (+ cell (left 2)) !ab-x7) (outinstag !spribp descptrcell !ab-x7)) ((eq type 'string) ;must generate string pointer and descriptor (clearaq) ;pick up string into aq (outinst !ldaq (get-home var)) (clearbb) (outinstag !eppbb cell !ab-x7) ;bb -> where to put the descriptor (outinstag !tspbp !ab|create-string-descrip-op !*) ;store descriptor, set lb to string (outinstag !sprilb argptrcell !ab-x7) ;store argptr (outinstag !eppbp cell !ab-x7) (outinstag !spribp descptrcell !ab-x7)) ;store descptr ((eq type 'varying-string) ;must call operator to set things up (clearaq) (outinst !ldaq (get-home var)) ;string to init from (clearbb) (outinstag !eppbb cell !ab-x7) ;bb -> where to put the descriptor (outinstag !tspbp !ab|create-varying-string-op !*) (outwrd descrip) ;output the length (outinstag !sprilb argptrcell !ab-x7) (outinst !staq (get-home var)) ;note string has been copied (outinstag !eppbp cell !ab-x7) (outinstag !spribp descptrcell !ab-x7)) ((eq type 'array) ;must generate array pointer and descriptor (clearaq) ;pick up array into aq (outinst !ldaq (get-home var)) (clearbb) (outinstag !eppbb cell !ab-x7) ;bb -> where to put the descriptor (outinstag !tspbp !ab|create-array-descrip-op !*) (outwrd descrip) ;output the typeword for operator to check (outinstag !sprilb argptrcell !ab-x7) (outinstag !eppbp cell !ab-x7) (outinstag !spribp descptrcell !ab-x7)) ((barf y "incorrect *pl1-call" barf))) ) ;end of do down arguments ;call pl1-call operator (clearbb) (clearaq) (outinstag !eppbb arglistcell !ab-x7) ;bb -> arglist (outinst !eaa (* 2000000 (length argdesclist))) ;au has 2*argcount (outinstag !tspbp (cond ((eq fcn '*pl1call) !ab|pl1-call-op) (t !ab|pl1-call-nopop-op)) !*) ;make the call (outwrd (get-pl1-link extname)) ;get address of callee, xec'ed by opr ) ;done (cadr y) (left (logand 77777 (car y))) (cddr y))) (defun get-descriptor-address (opc x) ;x is a descriptor image, opc is opcode (setq x (get-literal-addr (make-const x))) ;assign descriptor an address in the text section (cons 'literal (logor opc !ic (left (- x pc -1))))) ;and return code to put address in ptr ;Note this will allocate 2 words for each descriptor (defun pass2 (ll body type fn-name) ; main pass2 interface.... ((lambda (intime codelist arg-height temp-size framel bump-arg-height ll-length literal-size AQ AQ-state BB effs slotlist slot-types useless-code loadlist bvars null-var-list slotx literal-start bind-size cnt p1cnt literal-list) (clear-out-literals) (clear-out-useless-fns) (setq entry-list (cons (logor (left (cdr defdat)) pc) entry-list)) (setq functions-defined (cons (cons type fn-name) functions-defined)) (setq codelist (cons nil codelist)) ; this marks our function's entry point, holding space for an eppap instruction. (mapc '(lambda (x) (and (specialp x) (setq bind-size (+ 4 bind-size)))) ll) (cond ((memq type '(expr fexpr)) ; normal case... (setq ll-length (cond ((and (eq type 'fexpr) ll (cdr ll)) ; fexpr with second formal param (cond ((cddr ll) (barf fn-name "has too many formal parameters to be an fexpr" data))) (outinst !eaq (list 'temp 2)) ; fabricating a pdl pointer (outinst !qrl (left 18.)) (outinstag !orq (left -2) !du) (outinstag !lda (left !fixnum-type) !dl) (outinst !staq (list 'temp 2)) 2.) ((eq type 'fexpr) (or ll (setq temp-size 2)) 2) (t (* (length ll) 2)))) (cond ((not (= bind-size 0)) (setq arg-height (+ arg-height bind-size)) (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)))) (setq bvars (append ll bvars)) ; variables bound are put on bvars. (do ll ll (cdr ll) (null ll) ; scan over lambda list. (cond ((specialp (car ll)) ; if special.... (outbindwrd (make-const (car ll)) (list 'temp (- temp-size bind-size))) ; gen binding from this temp. (setq slot-types (nconc slot-types (ncons (get (car ll) 'number)))) (setq slotlist (nconc slotlist (ncons nil)))) ; free the arg slot. (t (setq slot-types (nconc slot-types (ncons (get (car ll) 'number)))) (setq slotlist (nconc slotlist (ncons (cons (car ll) 'home)))))) (setq temp-size (+ 2 temp-size)))) ((eq type 'lexpr) (setq ll-length 0 bvars (cons (car ll) bvars)) (outinstag !eax7 !ab|2 !x7) ; get room on unmarked stack. (outinstag !eppbp (list 'temp 0) !x5) ; get pointer to beginning of args. (outinstag !spribp !ab|-2 !x7) ; save in space provided. (cond ((specialp (car ll)) (setq bind-size 8. ; above calculation decieving! more bindings than thought of. arg-height bind-size) (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)) (outwrd (cons 'bindtemp !bindargatom)) (outbindwrd (make-const (car ll)) 'nargs)) (t (setq bind-size 4 arg-height bind-size temp-size 2) (setq slotlist (ncons (cons (car ll) 'home))) (outinstag !eaa 0 !x5) (outinstag !neg 0 !du) (outinstag !ldq !lsubrhack !du) ; number type field shifted left 19. (outinst !llr 21000000) ; rotate things around a bit. (outinst !staq (list 'temp 0)) ; and store stuff. (outinstag !tspbp !ab|bind !*) (outinst 0 (left bind-size)) (outwrd (cons 'bindtemp !bindargatom)))))) (get-in-aq (comp body)) ; compute the value... (cond ((not (= bind-size 0)) (outinstag !tspbp !ab|unbind !*))) (cond ((eq type 'lexpr) (outinstag !eppap !ab|-2 !x7*) ; back up stack pointer. (outinstag !eax7 !ab|-2 !x7)) ; and unmarked pointer too. ((plusp temp-size) (outinst !eppap (logor !ap| (left (logand 77777 (minus temp-size))))))) (outjumptag !tra !ab|return !*) ; got to return operator. (cond (loadlist (barf loadlist "left on loadlist" barf))) (or (= p1cnt cnt) (barf (list p1cnt cnt ) "are unequal pass1 and pass2 counts." barf)) (initialize-slot-types) ; set slot-types to list of instructions to init slotlist type fields from. (cond ((not (= ll-length temp-size)) (setq pc (1+ pc) literal-start (1- literal-start)))) ; if we have to add an instruction... (cond (literal-list (cond ((oddp pc) (setq codelist (cons 0 codelist) pc (1+ pc)))) (setq literal-start (+ pc literal-start)) (mapc '(lambda (x) (setq codelist (cons (cadr x) (cons (cond ((fixp (cadr x)) !fixnum-type) (t !flonum-type)) codelist)) pc (+ 2 pc))) (nreverse literal-list)))) (do scan functions-called (cdr scan) (or (null scan) (fixp (car scan))) (rplaca scan (make-call-link (car (setq ll (cdar scan))) (cadr ll) (caddr ll) (cadddr ll)))) (do scan array-links (cdr scan) (or (null scan) (fixp (car scan))) (rplaca scan (make-array-link-control-word (car (setq ll (cdar scan))) (cadr ll) (cadddr ll)))) (do ((code codelist (cdr code)) (word)) ((null (setq word (car code))) ; if found the beginning of this function... (cond ((= ll-length temp-size) ; if no need for room other than the args... (setq slot-types (nconc slot-types (cdr code))) ; slot-types might be nil here. (rplaca code (car slot-types)) (rplacd code (cdr slot-types))) ; splice in code to init types (t (setq slot-types (nconc slot-types (cons (logor !eppap !ap| (left (- temp-size ll-length))) (cdr code)))) (rplaca code (car slot-types)) (rplacd code (cdr slot-types))))) ;spice in code here. (cond ((numberp word)) ((eq (car word) 'temp) (rplaca code (logand 77777777777 (- (cdr word) (left temp-size))))) ((eq (car word) 'literal) (rplaca code (+ (cdr word) (left literal-start)))) ((eq (car word) 'function) ) ((eq (car word) 'array) ) ((eq (car word) 'bindtemp) (rplaca code (add-right-half (minus temp-size) (cdr word)))) ((eq (car word) 'bindliteral) (rplaca code (add-right-half literal-start (cdr word)))))) (and time-option (progn (princ "Code generation time = ") (princ (quotient (- (runtime) intime) 1.0e6))(terpri))) codelist ;return new codelist. if compilation fails ; before this point, codelist will be unchanged. ) (cond (time-option (runtime)) (t 0)) codelist 0 0 nil 0 0 0 nil nil nil nil nil nil nil nil nil nil nil 0 0 1 cnt nil)) (defun add-right-half (x y) ; add x to right halfword of y, returning left half of y logor result of add. (logor (logand 777777_18. y) (logand 777777 (+ x (logand 777777 y))))) (defun clear-out-literals () (do i 0 (1+ i) (= i !const-table-size) (mapc '(lambda (x) (and (or (and (fixp (cadr x)) (smallnump (cadr x))) (floatp (cadr x))) (rplacd (cdr x) nil))) ; forget all literals (const-table i)))) (defun clear-out-useless-fns () ; gets rid of functional temp references... (do i 0 (1+ i) (= i !fcn-table-size) (mapc '(lambda (x) (and (eq (caadr x) 'temp) ; is temp. (rplacd (cddddr x) nil) ; forget we had one. )) (fcn-table i)))) (defun make-array-link-control-word (array type ndims) (logor (lsh (cond ((eq type 'fixnum) 2) ((eq type 'flonum) 3) (t 0)) 27.) ;type code (lsh ndims 18.) ;number of dimensions (1+ (get-constant-addr array)))) (defun initialize-slot-types () ; setq's slot-types to a list of instructions to initialize the types of slots. (setq slot-types (do ((slot slot-types (cdr slot)) (tempi (- temp-size) (+ 2 tempi)) (inst-list nil)) ((null slot) inst-list) (and (car slot) ; if typed item, (prog2 (or inst-list ; check to see if inst-list has been updated. (setq inst-list (list (logor !ldaq !ab|type-fields)) pc (1+ pc) literal-start (1- literal-start))) (setq pc (1+ pc) literal-start (1- literal-start) inst-list (xcons inst-list (logor (cond ((eq (car slot) 'fixnum) !sta) ((eq (car slot) 'flonum) !stq)) !ap| (left (logand 77777 tempi)))))))))) (defun finish-code () (prog (function-rel array-link-rel type-list def-length intime) (setq intime (cond (total-time (runtime)) (t 0))) (setq function-rel 0 def-length 0 type-list (subst nil nil '((fixnum) (flonum) (string) (bignum) (symbol)(list)))) (map '(lambda (l) (setq function-rel (1+ function-rel)) (rplaca l (analyze (cadar l) type-list))) constant-list) (mapc '(lambda (x) (rplaca x (cdr (assq (car x) '((nil . 0) (expr . 1_18.) (lexpr . 2_18.) (fexpr . 3_18.))))) (rplacd x (analyze (cdr x) type-list)) (setq def-length (1+ def-length))) functions-defined) (fix-type-list type-list) (setq array-link-rel (+ function-rel (length entry-list) (length functions-called))) (map '(lambda (l) (rplaca l (get-object-offset (car l)))) constant-list) (map '(lambda (l) (rplaca l (logor (caar l) (get-object-offset (cdar l))))) functions-defined) (map '(lambda (l) (and (not (atom (car l))) (cond ((eq (caar l) 'function) (rplaca l (+ (cdar l) (lsh function-rel 19.)))) ((eq (caar l) 'pl1-link) (rplaca (car l) !Link15)) ;relocatable word ((eq (caar l) 'array) (rplaca l (+ (cdar l) (lsh array-link-rel 19.)))) (t (barf (car l) "funny word - finish-code" barf))))) codelist) (cg-util seg-name (cdr (nreverse codelist)) compiler-version (cons (length source-map) (nreverse source-map)) (car type-list) (cadr type-list) (caddr type-list) (cadddr type-list) (car (cddddr type-list)) (cadr (cddddr type-list)) (cons (length entry-list) (nreverse entry-list)) (cons function-rel (nreverse constant-list)) (cons (length functions-called) (nreverse functions-called)) (cons def-length (nreverse functions-defined)) (cons (length array-links) (nreverse array-links)) (cons (length pl1-link-list) (nreverse pl1-link-list)) ) (and total-time (progn (terpri) (princ "Object creation time = ") (prin1 (//$ (float (- (runtime) intime)) 1000000.0)) (terpri))))) (defun init-code-generator () (setq constant-size 0 fcn-size 0 array-size 0 functions-defined nil array-links nil pl1-link-list nil pl1-link-size 10 functions-called nil entry-list nil constant-list nil) (fillarray 'fcn-table '(nil)) (fillarray 'const-table '(nil)) (setq pc 0 codelist (ncons nil))) (defun make-call-link (fn-name snap? type nargs) (logor (cond ((eq (car fn-name) 'temp) (lsh (- (cadr fn-name) temp-size) 12.)) (t (logor 2000 (lsh (+ 1 (get-constant-addr fn-name)) 12.)))) ; constant-list munged by now. (cond (snap? 4000) (t 0)) (cond ((eq type 'fsubr) 1001) ((eq type 'lsubr) 777) (t nargs)))) ;;; function to analyze constants referenced by lisp compiled code (defun analyze (x type-lists) ;; x is the object, type-lists is a list of the form ;; ((fixnum ...) ;; (flonum ...) ;; (string ...) ;; (bignum ...) ;; (symbol ...) ;; (list ..)) ((lambda (type) ((lambda (l) (cons type ; returns ( .) (cond ((eq type 'nil) 0) ((not (eq type 'list)) (do ((scan (cdr l) (cdr scan)) (last l scan) (i 1 (1+ i))) ((null scan) (rplacd last (ncons x)) i) (cond ((equal x (car scan)) (return i))))) ((eq (cdr x) gofoo) ;load-time evaluated constant (setq type (analyze (car x) type-lists)) (or (eq (car type) 'list) (barf type "bad load-time constant" barf)) (logor (cdr type) 400000)) ;set loadtime bit (t (do ((scan (cdr l) (cdr scan)) (last l scan) (i 1 (1+ i))) ((null scan) (list-analyze x i last type-lists)) (cond ((eq x (caar scan)) (return i))))) ))) (assq type type-lists))) (and x (typep x)))) ;;; function to insert list-type objects into type-lists. ;;; relies on the fact that sublists are not eq to existing lists. ;;; thus inserts all of the skeleton into the type-list and analyze's only ;;; the fringes. (declare (special list-offset list-last)) (defun list-analyze (x list-offset list-last type-lists) (setq x (ncons (cons x (cons (lanalyze (car x) type-lists) (lanalyze (cdr x) type-lists))))) ; changes list-last, list-offset. (rplacd list-last x) list-offset) (defun lanalyze (x type-lists) ; basic analyzer (cond ((atom x) (analyze x type-lists)) ; if atomic, use ordinary analyzer. (t (setq x (ncons (cons nil (cons (lanalyze (car x) type-lists) (lanalyze (cdr x) type-lists))))) ;; note that we forget the value of x here, unlike in list-analyze, because ;; we know that its value will never be eq to any other list we will see. (rplacd list-last x) (prog2 (setq list-last (cdr list-last)) ; update the end of the list pointer (cons 'list list-offset) (setq list-offset (+ list-offset 1)))))) ; update the count of items. (declare (special type-offsets)) (defun fix-type-list (type-list) ;; takes type-list, and rplaca's lengths into type buckets, and ;; fixes up the cons list to be a list of 36 bit numbers. ;; generates the special variable type-offsets for use by ;; get-object-offset ((lambda (base-offset) (setq type-offsets (ncons (cons nil 0))) (mapc '(lambda (tl) (setq type-offsets (cons (cons (car tl) base-offset) type-offsets)) (cond ((eq (car tl) 'list) (map '(lambda (x) (rplaca x (logor (lsh (get-object-offset (cadar x)) 18.) (get-object-offset (cddar x))))) (cdr tl)))) (setq base-offset (+ (car (rplaca tl (length (cdr tl)))) base-offset))) type-list)) 0)) (defun get-object-offset (x) ;; returns absolute offset in constant table of object (+ (cdr x) (cdr (assq (car x) type-offsets)))) (declare (eval (read))) ; do next thing at compile time. (sstatus macro /! nil) ;;; ;;; Eternal compiler history maintained here automatically. ;;; (declare (defun get-compiler-history-variable (x) (let ((obarray obarray)) (use c) (let ((var (intern (copysymbol x nil)))) (cond ((boundp var)(symeval var)) (t nil))))) (read)) ;;interpreter only (defun get-compiler-history-variable (x) 'Interpreter) (defun cg-signature-history-macro macro (x) (list 'setq 'cg-compile-date (list 'quote (list (status date)(status daytime))) 'cg-compiler-history (list 'quote (or (get-compiler-history-variable 'compiler-history) (get-compiler-history-variable 'compiler-version))))) (cg-signature-history-macro)  lcp_historian_.lisp 07/06/83 0936.2r w 06/29/83 1541.4 32373 ;;; ************************************************************** ;;; * * ;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 * ;;; * * ;;; ************************************************************** ;;; ;;; This is the easy end of a hack of prodigious hair. BSG 1/20/80 ;;; (declare (special known-compilers known-segs compiling-compilers)) (declare (*fexpr use)) (setq known-compilers nil compiling-compilers nil known-segs nil) (linel nil 200.) (defun deradix (x) (list (// x (* 64. 64.)) (\ (// x 64.) 64.) (\ x 64.))) (defun dec (x)(let ((base 10.)(*nopoint t))(implode (explodec x)))) (defun cv-date (x) (let ((decdate (mapcar 'dec (deradix x)))) (catenate (cadr decdate) "/" (caddr decdate) "/" (car decdate)))) (defun cv-time (x) (let ((dectime (mapcar 'dec (deradix x)))) (or (= (stringlength (car dectime)) 2) (setq dectime (cons (catenate "0" (car dectime)) (cdr dectime)))) (catenate (car dectime) ":" (cadr dectime) ":" (caddr dectime)))) (defun get-compiler-history-variable (x) (let ((obarray obarray)) (use c) (let ((var (intern (copysymbol x nil)))) (cond ((boundp var)(symeval var)) (t nil))))) (defun historian () (let ((cversion (get-compiler-history-variable 'compiler-version)) (chistory (get-compiler-history-variable 'compiler-history))) (cond ((null chistory) (princ (catenate "The compiler you invoked is " cversion ".")) (terpri) (princ "Its ancestry has not been recorded.")) (t (princ "The version of the compiler you invoked is") (terpri) (environment-historian "" chistory 0))) (terpri))) (defun environment-historian (label hist level) (indent-levels level) (princ (catenate label (cond ((atom hist) hist) (t (car hist))) ",")) (terpri) (indent-levels level) (cond ((member hist compiling-compilers) (princ "which impossibly, inconsistently, and fraudulently") (terpri)(indent-levels level) (print "claims to have participated in its own compilation.") (terpri)) ((member hist known-compilers) (princ "which is described above.") (terpri)) ((atom (prog2 (setq known-compilers (cons hist known-compilers)) hist)) (princ "whose ancestry has not been recorded.") (terpri)) (t (let ((compiling-compilers (cons hist compiling-compilers)) (words (cond ((= level 0) "which consists of ") (t "which consisted of")))) (princ words) (terpri) (do segs (cdr hist)(cdr segs)(null segs) (seg-historian (car segs) (+ level 3))))))) (defun seg-historian (seg level) (indent-levels level) (cond ((let ((dts (cadr seg))) (or (null dts) (and (not (atom dts))(null (cdr dts))) (and (atom dts)(samepnamep dts '??)))) (princ (catenate "A version of " (car seg) " of unknown ancestry.")) (terpri)) (t (princ (catenate (car seg) ", compiled " (cv-date (car (cadr seg))) " at " (cv-time (cdr (cadr seg))) ",")) (terpri) (let ((new-level (+ level 2 (stringlength (car seg))))) (cond ((member seg known-segs) (indent-levels new-level) (princ "which was described above.") (terpri)) (t (setq known-segs (cons seg known-segs)) (environment-historian "by " (caddr seg) new-level))))))) (defun indent-levels (n) (do x n (1- x)(= x 0)(princ " ")))  lcp_init_.lisp 07/06/83 0936.2r w 06/29/83 1541.4 14832 ;;; ************************************************************** ;;; * * ;;; * Copyright, (C) Massachusetts Institute of Technology, 1973 * ;;; * * ;;; ************************************************************** ;;; this segment serves the sole purpose of initializing the ;;; obarray handling mechanism of the Multics LISP compiler. ;;; Coded by D. Reed 11/23/73 ; first, make an obarray to load the compiler in on, and ; an obarray to use to generate new virgin obarrays. (makoblist 'initial-readin-obarray) (makoblist 'compiler-obarray) ; now define a function for convenient obarray switching. (defun use fexpr (x) (setq x (getchar (car x) 1)) ; get the first char of the argument. (cond ((samepnamep x "c") (setq obarray (get 'compiler-obarray 'array)) 'compiler-obarray) ((samepnamep x "w") (setq obarray (get 'obarray 'array)) 'working-obarray) ((samepnamep x "n") (setq obarray (get 'initial-readin-obarray 'array)) (makoblist 'obarray) ; copy it (setq obarray (get 'obarray 'array)) 'new-working-obarray) (t (princ " use: argument must be c, w, or n. ") nil))) (defun global fexpr (x) ((lambda (obarray) (mapc '(lambda (y) (setq x (intern y)) (cond ((eq x y)) ; successful intern (t (remob x) ; force it to be global (intern y) (princ " global: forcing the atom """) (prin1 y) (princ """ to be global by remob'ing one with the same name") ))) x)) (get 'obarray 'array)))  lcp_semant_.lisp 07/06/83 0936.2r w 06/29/83 1541.4 1066194 ;;; ************************************************************** ;;; * * ;;; * Copyright, (C) Massachusetts Institute of Technology, 1982 * ;;; * * ;;; ************************************************************** ;;;(c) Copyright 1973, Massachusetts Institute of Technology. ;;; All rights reserved. ; ; ****************************************************** ; ****************************************************** ; ***** ***** ; **** LISP COMPILER - SEMANTICS ***** ; ***** ***** ; ***** VERSION OF 13 JUNE 1974 - D. A. MOON ***** ; ***** OBSCURELY DERIVED FROM complr.264 ***** ; ***** ***** ; ****************************************************** ; ****************************************************** ; ; Modified April 1981 by Bernard S. Greenberg to use backquote. ; Modified September 1982 by William M. York to fix a bug in compilation of ; (array ...) forms. ; Modified 29 September 1982 by WMY to fix compilation of all forms of (break ...) ; Modified 5 October 1982 by WMY to fix nested "(progn 'compile ...)" forms ; to compile code in the correct order (inmost first), and to ; remove the old three-argument case for (break ...) forms. ; Modified 5 October 1982 by Richard Lamson to add (includef ...) ; Modified 9 October 1982 by Richard Lamson to optimize (nth ...) ; and (nthcdr ...) forms. ; Modified 13 October 1982 by Richard Lamson to fix error messages from ; command interface. ; (cond ((not (boundp 'compiler-revision)) (princ "lisp_compiler: Undefined compiler version.")(terpri) (quit))) (global cf cl pause genprefix nfunvars special fixnum flonum fixsw flosw notype arith array* closed muzzled unspecial reducible irreducible noargs mapex symbols lisp put-in-tree ;request of H. Lieberman expr-hash system-file compile-top-level-forms ;for GSB & BSG 5/4/80 sobarray cobarray eoc-eval compiler-state compile maklap top-level coutput gofoo ;jonl's crocks for owl nocompile -db -debug -eval -tm -time -times -ps -pause -pause_at -mc -macros -gp -gnp -genprefix -nw -nowarn -tt -total -total_time -list -ls -long -lg -all_special -pathname -pn -p -no_compile -ncp -ck -check -ioc -messioc -mioc -hd -hold -pedigree -pdg -brief -bf arith *expr *fexpr *lexpr **array messioc check debug macros dataerrp barfp defpl1 update return ignore fixed bin binary float packed-pointer packed-ptr pointer ptr bit aligned unaligned character varying char lisp array l le g ge n e) ; special tags used by signp! (%include backquote) ;BSG 4/22/81 (declare (genprefix !pass1-genfun) (special defdat ;used by pass 2 codelist ;.. pc ;.. constant-list ;.. vgol ;.. exit ;.. code-list ;.. constants-list ;.. functions-called ;.. functions-defined ;.. labels-to-define ;.. obarray ;declare the 3 obarrays for the function use. compiler-obarray ;which allows the user to switch obarrays easily initial-readin-obarray ;.. sobarray cobarray eoc-eval compiler-state expr-hash system-file errset ;need to shut this interrupt off sometimes seg-name ;name of object segment as string ecrsloss ;assq list of local delarations. first-eof ;used to detect missing ")" - see cf and cmp1 gl ;list of dotted pairs of prog tags and their renamings bvars ;bound variables locvars ;local variables, dotted pairs with cnt of last reference codelist ;list of code put out by pass 2 condp ;t if in a cond, and, or or lmbp ;t if in a lambda progp ;t if in a prog data ;--random-- prssl ;sections of prog are seperated by go's and tag's effs ;t = for effect, nil = for value p1csq ;list of vars setq'ed in cond, and, or or p1lsq ;list of vars setq'ed in lambda p1psq ;list of vars setq'ed in prog mapf ;t if thi s function is the object of a map, causes go and ; return to use a farther-out prog according to p1mapcnt barfp ;if should break on Compiler Error nowarn ;option switch. If t supresses warning messages cnt ;basic-block number currently compiling pvrl ;prog variables p1ll ;lambda list lsubrf ;i.o. rnl ;dotted pairs of duplicated variables and their gensym renamings gofoo ;special mark for prog gone2 ;list of tags that appear as object of go in a prog ffvl ;list of symbols used as "free functional variables." pause ;controls breaks between passes pause-at ;list of functions to stop during compiling of check ;if t, do only pass 1 dev ;KLUDGE: shared by luz, lsub genprefix ;explodec'ed prefix for generated function names gfyc ;numeric suffix for generated function names, incremented each time map-funarg ;special mark for fcn which is object of map map-prog ;special mark for prog generated by map map-do ;special mark for do generated by map, will turn into map-prog p1mapcnt ;count of number of map-prog's before first real prog, used to ; to know where to return or go to in a map-funarg being-compiled ;name of current function being compiled, changed to nil ; after it has been typed out so it won't be typed out more ; than once. current-function ;copy of being-compiled, not set to nil. source-map ;list of pathnames, reverse order compiler-revision ;mod level of compiler compiler-version ;string of compiler version time-option ;t if user wants to se e compilation times total-time ;t if user wants to see total time & paging used by a compilation errflag ;t if errors have occurred in this function - used to suppress pass 2 args ;set to output of pass 1 when pause option is used errsetp ; I don't know. errlist ;used to make complr self-starting macros ;t if macros option was used, output macro defs to defsubr file nocompile ; don't interpret the defun's and defprop's in the file...put it all out. special ;setq'ed by loser to t if all variables are to be special closed ;t => no in-line arithmetic for plus,... noargs ;I don't know undfuns ;list of functions referenced but not yet defined dataerrp ;break if Error barfp ;break if severe Compiler Error indiclist ;dotted pairs of expr and subr forms of P-list indicators p1cof ;call out flag, t if function with side-effects has been called messioc ;(apply 'ioc messioc) is done before printing an error message fixsw ;t means take all arithmetic functions as having fixnum arguments. flosw ;t means take all arithmetic functions as having flonum arguments. fixfns ;assoc list of arithmetic functions and their fixnum forms flofns ;assoc list of arithmetic functions and their flonum forms nfunvars ;special variable which may be declare setq'ed to t to cause ;compiler not to allow special variables as free functional vars. ) (*fexpr **array special *reducible) (*fexpr fixnum flonum notype array*) (*expr finish-code historian init-code-generator pass2 nargs)) ;;; Initialize crocks (setq sobarray (get 'obarray 'array) cobarray (get 'compiler-obarray 'array)) (setq eoc-eval nil compiler-state 'top-level) (defprop coutput put-in-tree expr) ;;;declarations for compiling number compiler with number compiler. (declare (fixnum (nargs notype) cnt gfyc p1mapcnt i)) (declare (eval (read))) (sstatus macro /: (function (lambda nil nil)) splicing) ; listing package (declare (defpl1 make_lisp_listing "" (char(*)) (char(*)) ) ;args are object seg, option (defpl1 absolute_pathname_ "" (char (*)) (return char (168.)) (return fixed bin (35.))) (defpl1 absolute_pathname_$add_suffix "" (char (*)) (char (*)) (return char (168.)) (return fixed bin (35))) (defpl1 com_err_$one-arg "com_err_" (fixed bin (35.)) (char (*)) (char (*)) (char (*))) (defpl1 hcs_$status_minf "" (char (*)) (char (*)) (fixed bin (1)) (return fixed bin (2)) (return fixed bin (24.)) (return fixed bin (21.)))) ;;;get macros used by both parts of compiler (%include compiler-macros) (defun logor macro (x) (displace x (cons 'boole (cons 7 (cdr x))))) ;;;get table of functions that have unpredictable side effects (%include compiler-badfns) (defun p1e: macro (x) (displace x (list (list 'lambda '(effs) (cons 'p1 (cdr x))) t))) (defun p1v: macro (x) (displace x (list (list 'lambda '(effs) (cons 'p1 (cdr x))) nil))) (defun initialize: nil ; stuff having to do with pure and args properties removed. (setq errlist '((command-interface)(init1))) (sstatus interrupt 0 (function (lambda (args) (iog vt (prin1 current-function) (terpri))))) (mapc '(lambda (x) (set x (maknam (exploden x)))) '(gofoo map-funarg map-prog map-do)) (putprop 'do 'doexpander '*macro) (putprop 'let 'let-expander '*macro) (putprop 'prog1 'prog1-expander '*macro) (putprop map-do 'doexpander '*macro) (putprop map-prog t '*macro) (putprop map-funarg t '*macro) (mapc '(lambda (x)(putprop x t '*defpl1-internal)) '(*pl1call *unmkd-push *unmkd-pop *pack-ptrs *unpack-ptrs *cons-string *rcv-char-* *pl1call-nopop)) (setq *nopoint nil) (setq gfyc 0 messioc '(vt) seg-name nil pause nil pause-at nil infile nil instack nil outfiles nil ^q nil genprefix '(/! g) rnl nil barfp nil check nil mapf nil special nil macros nil ffvl nil ecrsloss nil closed nil source-map nil nfunvars nil time-option nil noargs nil total-time nil nocompile nil expr-hash nil system-file nil undfuns nil dataerrp nil nowarn nil base 8. ;ibase ibase fixsw nil flosw nil indiclist '((expr.subr) (fexpr.fsubr) (lexpr.lsubr))) (sstatus feature compiler) (sstatus feature fastarith) (alloc '(list (60000. nil 0.3))) ;set gc parameters by guess (sstatus charmode nil) (**array obarray readtable) ; declare standard reducible functions (*reducible * *$ + +$ - -$ 1+ 1+$ // //$ \ remainder gcd *dif *quo quotient 1- 1-$ < = > CtoI ItoC abs add1 and ascii assoc assq atom boole caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr catenate comment difference eq equal explodec exploden expt fix fixp flatc float floatp get_pname greaterp index last length lessp lsh max min minus minusp nconc not nreverse null numberp or plus plusp prog2 progn rot signp stringlength stringp sub1 subrp substr substr2 times typep zerop member memq ifix fsc first second third fourth rest1 rest2 rest3 rest4 nth nthcdr ) ;establish declarations of built-in special variables. (mapcar '(lambda (x) (mapcar '(lambda (y) (and (memq 'value (status system y)) ;if a special variable built in to LISP, (putprop y t 'special))) ;then declare it to be special x)) (makoblist nil)) t) (defun init1: nil (ioc stev) (terpri) (princ "Multics lisp compiler ") nil) (defun compile-fcn: (name flag exp rnl) ;renamed from compile ;BSG 10/13/80 to keep off user obarray ;in light of progn 'compile (prog (p1mapcnt p1cof locvars cnt lsubrf bvars effs p1ll mapf vgol exit start-runtime condp lmbp p1csq p1lsq progp p1psq gone2 defdat fl spfl errflag pvrl gl ecrsloss compiler-state) (setq compiler-state 'compile) (setq cnt 1 p1mapcnt -1000000000 start-runtime (cond (time-option (runtime)) (t 0))) ;set p1mapcnt funny to avoid hanging go|return's (and (setq fl (getl name '(subr fsubr lsubr))) (sysp name) (not system-file) (warn name "is a system-defined function - please check over your code for bugs!")) (cond ((null (eq (car exp) 'lambda)) (barf exp "is not a function" data)) ((and (cadr exp) (atom (cadr exp))) ; atomic lambda list --> lexpr (cond ((not (eq flag 'expr)) (warn name "lexpr must be defined as expr property.")) ((setq spfl (getl name '(*expr *fexpr))) (wrntyp name '*lexpr spfl))) (putprop name t '*lexpr) (setq lsubrf t flag 'lexpr) (setq exp (cons (car exp) (cons (list (cadr exp)) (cddr exp)))))) ; ***** makes lsubr have (lambda (nargs) body) ; ***** make sure that pass2 knows about this (cond (lsubrf ;this is for lexpr's, which have already been done (setq defdat '('lsubr . 777000))) ;777000=any#args allowed. ((greaterp (setq fl (length (cadr exp))) 510.) (barf name "too many lambda variables" data)) ((cond ((eq flag 'expr) (ckargs name fl t) (setq defdat (cons ''subr fl)) (setq fl '*expr) t) ((eq flag 'fexpr) (setq defdat '('fsubr . 1)) (setq fl '*fexpr) t)) (and (setq spfl (getl name '(*expr *lexpr *fexpr))) (not (eq fl (car spfl))) (wrntyp name fl spfl)) (putprop name t fl))) (setq exp (p1glm (setq p1ll (p1lmbify (cadr exp) name)) (p1localdcl p1ll (cadr exp) (cddr exp)) name)) (uuvp p1ll 'p1ll 'lambda) (progn (cond (time-option (princ " Pass 1 time for ") (princ name) (princ " = ") (prin1 (//$ (float (difference (runtime) start-runtime)) 1e6)) (terpri) ))) ((lambda (args) ;bind special var args to output of pass 1 so user can look at it (and (or pause (memq name pause-at)) (apply 'break (list (list'end-of-pass-1-for name) t)))) exp) (cond (errflag (err 'nonfatal)) ;suppress pass2 if errors occurred (check) ;or -check option was specified (t (setq codelist (pass2 (cadr exp) ;ll (caddr exp) ;body flag ;type name)) ;entry name (and (or pause (memq name pause-at)) (apply 'break (list (list 'end-of-pass-2-for name) t))) )) (return name))) (defun p1: (x) ;x is lisp, return value is semantically-translated version of x. (prog (y z tem) a (cond ((memq (setq z (typep x)) '(fixnum flonum bignum string)) ;literal constant - just quote it and return (return `',x)) ((eq z 'random) (warn x "random piece of data - nil substituted") (return ''nil)) ((eq z 'symbol) ;atomic symbol (cond ((memq x '(t nil)) ;literal constant - quote it. (return `',x)) ((setq z (assq x rnl)) ;variable - if renamed, substitute its renaming (setq x (cdr z)) (go a)) ((p1special x)) ;if special, leave it. ((setq z (assq x locvars)) ;if local, update cnt of last usage of it. (rplacd z (1+ cnt))) ) (setq cnt (1+ cnt)) ;update cnt since variable was seen (return x)) ;and leave as (possibly renamed) variable. ;; x is a list - compile it as a function call. ((eq (setq z (typep (car x))) 'list) ;check the type of the functional (cond ;computed function. ((eq (caar x) 'lambda) (and (cadar x) (atom (cadar x)) (barf x "lexpr not allowed here" data)) (return (p1lam (car x) (cdr x))) ) ;process direct lambda-application. ((eq (caar x) 'label) (putprop (setq y (cadar x)) t 'special) (putprop (setq tem (gen-fcn-name)) t '*expr) (compile-fcn tem 'expr (caddar x) (list (cons y tem))) (return (p1lam (list 'lambda (list y) (cons tem (cdr x))) (list (list 'function tem)) ))) ((or (eq (caar x) 'function) (eq (caar x) 'quote)) (rplaca x (cadar x)) (go a)) (t (return (mapcar (function p1v-fcn) x))) )) ;really a computed function, just eval fcn & args ((not (eq z 'symbol)) ;if functional not list, better be atom. (barf x "bad functional form" data)) ) b ;;;form with atomic function (and (get (car x) '*defpl1-internal) (return x)) ;leave internal frobbies alone (setq z (getl (car x) '(fsubr subr lsubr *fexpr *expr *lexpr *array macro *macro))) (cond ((or (null z) ;not yet seen - variable function or implicit *expr dcl (and (memq (car z) '(fsubr lsubr subr)) (not (sysp (car x))))) (and (setq z (assq (car x) rnl)) (prog2 (setq x (cons (cdr z) (cdr x))) (go b))) (cond ;check for special or bound. ((or (and (not nfunvars) ;if special variables not disallowed, (specialp (car x)) ;free functional variable or bound functional variable. (progn (or (memq (car x) ffvl) ;free fcnl varbl - add to list of such (push (car x) ffvl)))) (memq (car x) bvars)) ;bound fncl varbl. (setq x (cons ((lambda (fn) (or (atom fn) (barf fn "illegal function" data)) ;if not checked here, would get compiler error in pass 2 fn) (p1v (car x))) (cdr x)))) (t (ckargs (car x) (length (cdr x)) nil) ;implicit declaration of user function (remprop (car x) '*expr) ;reorder property list so pass 2 doesn't blow out (putprop (car (setq undfuns (cons (car x) undfuns))) t '*expr))) (setq p1cof t) ;calling some random function that may have side-effects. (setq x (cons (car x) (mapcar (function p1v-fcn) (cdr x)))) ;compile the arguments ) ((memq (car z) '(macro *macro)) ;expand macro and re-process (cond ((not (eq (cadr z) t)) ;if really a macro... ((lambda (f) (and (symbolp f)(getl f '(macro *macro)) (setq f (p1-chase-linked-macros f))) (setq x (macro-expand x f))) ;expand, (cadr z)) (go a)) ;and re-process ((eq (car x) map-prog) ;special kludges... (setq x (p1prog (cdr x) (1+ p1mapcnt)))) ;(falls through) ((eq (car x) map-funarg) (return ((lambda (mapf) ;mapped function gets compiled with mapf on (p1 (cadr x))) t))) ((barf x "bad *macro" barf)) )) ((memq (car z) '(*expr *lexpr *fexpr *array)) ;declared user function (setq p1cof t) ;may have side effects (and (eq (cadr z) 'dcl) (not (eq (car z) '*array)) ;if declared but not defined, remember not defined (prog2 (rplaca (cdr z) 'dcl2) ; (push (car x) undfuns) ;flushed 4/27/80 -BSG 0)) (cond ((eq (car z) '*fexpr)) ;no arg munging for *fexpr's ((eq (car z) '*lexpr) ;*lexpr - just compile args but don't check count (setq x (cons (car x) (mapcar (function p1v-fcn) (cdr x))))) (t ;*expr or *array - check number of args and compile the arguments (and (setq y (nargs (car x))) (not (= y (length (cdr x)))) (prog2 (barf x "wrong number of arguments" nonfatal) (return ''nil))) (setq x (cons (car x) (mapcar (function p1v-fcn) (cdr x)))) ))) ;compile the arguments. ((prog2 ;system function. (and (memq (car x) (badfns)) (setq p1cof t)) ;check for those system functions which can cause random side effects (eq (car z) 'subr)) (setq x (p1subr x))) ((eq (car z) 'fsubr) (setq x (p1fsubr x))) ((eq (car z) 'lsubr) (setq x (p1lsubr x))) ((barf x "lost function in p1" barf))) ;should never get here. ;;;end of giant cond for all those cases of forms with atomic functions ;;;now check for reducible functions (cond ((null (setq y (get (car x) 'reducible)))) ((eq y 'system) ;if a system reducible function... (or (getl (car x) '(*expr *fexpr *lexpr *array)) ;and not redefined... (setq x (p1sysred x (car x))))) ;then let p1sysred transform its constant arguments ((setq x (p1red x (car x))))) ;or if a user reducible function, p1red does it all. ;;;check for arithmetic functions for which we may to substitute a special fixnum or ;;;flonum function for a more general function, according to its arguments and declarations. (and (setq y (get (car x) 'arith)) ;if is to always have another function substituted. (setq x (cons y (cdr x)))) ;then do it. never have to make any number of args, etc. checks (and (not closed) (setq z (get (car x) 'arith-subst)) ;if general function for which function of particular type might be substitued... (cond (fixsw ;if always assume fixnums don't look at args... (and (car z) (setq x (p1arithsubst (car z) (cdr x))))) (flosw ;ditto for case where always assuming flonums (and (cadr z) (setq x (p1arithsubst (cadr z) (cdr x))))) ((not (null (cdr x))) ;make sure no substitute if no arguments. (do ((allfix t) (allflo t) (tem) ;inspect arguments to see if all of same type (undcl? nil) (argl (cdr x) (cdr argl))) ((null argl) (cond ((and allfix (car z)) ;if all args fixnums and can substitute, (setq x (p1arithsubst (car z) (cdr x)))) ((and allflo (cadr z)) ;if all args flonums and can substitute (setq x (p1arithsubst (cadr z) (cdr x)))) ((not undcl?) ;if mixed types, but all were number-declared... (setq x (p1convert-mixed-to-float x z))) ;so put in conversions to float (t) )) ;otherwise, leave it alone. (cond ((eq 'fixnum (setq tem (p1type (car argl)))) (setq allflo nil)) ((eq 'flonum tem) (setq allfix nil)) ((setq allfix nil allflo nil undcl? t))) )))) ;end all nested stuff up to the and...arith-subst ;;;end of pass1 processing (return x) )) (defun p1arithsubst: (f x) ;performs as directed by arith-subst property. (cond ((atom f) (cons f x)) ;usual case just substitutes new function name. ((apply (car f) (list x))))) ;this hack is for zerop - process as a macro. (defun p1convert-mixed-to-float: (x z) ;put in float on all args, since pass 2 can sort out the ;unnecessary ones, and substitute in the flonum version of the fcn. (cond ((cadr z) ;if can substitute flonum version (p1arithsubst (cadr z) (mapcar '(lambda (y) (list 'float y)) (cdr x)))) (x))) ;otherwise leave it alone. ;;;function for determining the type of a piece of output from pass 1 ;;; returns fixnum, flonum, or nil (defun p1type: (x) (cond (closed nil) ;foo. could maybe allow some through, but this is OK. ((atom x) (get x 'number)) ;in pass 1 output, all atoms are variables ((eq (car x) 'quote) ;constant - check its type (cond ((floatp (cadr x)) 'flonum) ((smallnump (cadr x)) 'fixnum) (nil) )) ((eq (car x) 'progn) (p1type (car (last x)))) ((eq (car x) 'prog2) (p1type (caddr x))) ((atom (setq x (car x))) ;function call - check name (and (setq x (get x 'numfun)) (car x))) ((eq 'lambda (car x)) ;lambda-expression, type is type of last form in body. (p1type (car (last x))) ))) ;anything else, return nil ;compile an fsubr (defun p1fsubr: (x) (prog (tem y z fun) (setq fun (car x)) (cond ((eq fun 'quote) (return x)) ((eq fun 'function) ;functional constant gets compiled (return `',(p1gfy (cadr x)))) ((eq fun 'setq) (setq tem nil) (do zz (cdr x) (cddr zz) (null zz) (and (null (cdr zz)) (return (setq tem nil))) (p1special (setq y (cond ((setq z (assq (car zz) rnl)) (cdr z)) ((car zz))))) (setq z (p1v (cadr zz))) (setq cnt (+ 2 cnt)) (p1sqv y) (setq tem (cons z (cons y tem)))) (and (null tem) (go wna)) (return (cons fun (nreverse tem)))) ((eq fun 'prog) (return (p1prog (cdr x) 0))) ;non-mapcar prog. ((eq fun 'cond) (return (p1cond (cdr x)))) ((memq fun '(catch throw)) (setq z (list fun (p1v (cadr x)))) (and (cddr x) (rplacd (cdr z) `(',(caddr x)))) ;if tag is given, quote it (return z)) ((eq fun 'errset) (setq z (list fun (p1v `(list ,(cadr x))))) (and (cddr x) (rplacd (cdr z) (list (p1v (caddr x))))) ;process 2nd arg if given (return z)) ((setq tem (assq fun '((function . quote) (*function . *function)))) (return (list (cdr tem) (p1gfy (cadr x))))) ((or (setq tem (eq fun 'or)) (eq fun 'and)) (cond ((null (cdr x)) (warn x "= vacuous and / or") (return `',(not tem))) ((null (cddr x)) (return (p1 (cadr x)))) ((return (p1and fun (cdr x)))))) ((eq fun 'unwind-protect) (return (cons 'unwind-protect (cons (p1 (cadr x))(mapcar 'p1e (cddr x)))))) ((eq fun 'go) (or (setq y (p1sqg)) (return ''nil)) (return (cond ((atom (cadr x)) (setq gone2 (cons (cadr x) gone2)) (or (setq z (assq (cadr x) gl)) (barf (cadr x) "is an undefined go tag" nonfatal) (return ''nil)) ;;;gets here since barf returns nil (and (get (setq z (cdr z)) 'defined) ;if tag already defined,... (putprop z t 'back-reference)) ;is a backward reference. (list 'go z y)) ;subst (gensym) for tag (t (setq gone2 (cons gofoo gone2)) (list 'go (p1v (cadr x)) y))))) ((eq fun 'signp) (return (list fun (cadr x) (p1v (caddr x))))) ((eq fun 'store) ; nstore removed, DAM (setq z (p1v (caddr x))) (or (getl (caar x) '(fsubr subr lsubr *fexpr *expr *lexpr *array)) (putprop (caar x) 'dcl '*array)) ;implicit declaration (return (list fun (p1v (cadr x)) z))) ((eq fun 'array) (return (p1 `(*array ',(cadr x) ',(caddr x) .,(cdddr x))))) ((eq fun 'iog) (return (list 'iog (cadr x) (p1 (cons 'progn (cddr x))) ))) ((eq fun 'ioc) (return (p1ioc x))) ((eq fun 'err) (return (cond ((null (cdr x)) '(err 'nil)) ((cddr x) (barf x "err with 2 args cannot be compiled -- you lose" data)) ((list 'err (p1v (cadr x)))) ))) ((memq fun '(status sstatus)) (return (p1sts x))) ((eq fun 'break) ; this code -WMY 9/29/82 (and (null (cddr x)) ; handle (break foo) case (return x)) (and (not (null (cdddr x))) (barf x "wrong number of arguments." nonfatal)) ; now (break foo
) case (return (p1 `(and ,(caddr x) (break ,(cadr x)))))) ((memq fun '(subrcall lsubrcall arraycall)) (return (cons fun ;call fcn (cons (cadr x) ;type ((lambda (effs) (mapcar 'p1 (cddr x))) nil) )))) ((eq fun 'declare) (barf x "local declaration not at beginning of body - ignored" nonfatal) (return x)) ;let pass 2 discard it. (?) ((eq fun 'eval-when) (barf x "eval-when not allowed in function bodies - forms ignored" nonfatal) (return ''nil)) (t (return x))) ;random fsubrs simply return their form wna (barf x "wrong number of arguments." nonfatal) (return ''nil))) ;compile an lsubr (defun p1lsubr: (x) (prog (tem z dummy fun) (setq fun (car x)) (cond ((eq fun 'list) (or (cdr x) (return ''nil)) ; list with no args (or (cddr x) (return (list 'ncons (p1v (cadr x))))) ; list with 1 arg ) ; list with more args leave alone. ; turning into bunch of conses is ; a loser on a machine with only ; one accumulator. ((eq fun 'list*) (or (cdr x)(go wna)) ;0 args not legal (or (cddr x)(return (p1v (cadr x)))) ;(list* x) => x (or (cdddr x)(return (p1 (cons 'cons (cdr x))))) (setq z (mapcar 'p1v-fcn (cdr x))) ;Compile up all the args. (setq x (car (last z))) ;Look at last compiled arg... (cond ((atom x)) ;Variable, fall thru. ((and (eq (setq tem (car x)) 'quote)(eq (cadr x) 'nil)) ;list* nil stupid turkey or macro (return (cons 'list (nreverse (cdr (nreverse z)))))) ((getl tem '(*lexpr *fexpr *expr))) ;Fall thru on redefines. ((memq tem '(ncons list)) (return (cons 'list (nconc (nreverse (cdr (nreverse z)))(cdr x))))) ((memq tem '(list* cons)) (return (cons 'list* (nconc (nreverse (cdr (nreverse z)))(cdr x)))))) (return (cons 'list* z))) ((eq fun 'boole) (setq x (p1boole x)))) ;transform to just and, or, xor (setq fun (car x)) ;new ball game now. (cond ((eq fun 'prog2) (and (or (null (cdr x)) (null (cddr x))) (go wna)) (setq z (cons (p1e (cadr x)) (cons (p1 (caddr x)) (mapcar (function p1e-fcn) (cdddr x))))) (return (cons fun z))) ((eq fun 'progn) (return (cons 'progn (maplist '(lambda (x) (cond ((null (cdr x)) ;if last clause. (p1 (car x))) ((p1e (car x))) )) ;if not last, don't need value (cdr x)) ))) ;;; special hack for ;;; (eval (cons 'fsubr list)) or for ;;; (eval (list 'fsubr foo)) ;;; both => (apply 'fsubr list) ((eq fun 'eval) (cond ((cddr x) (warn x "may not work") (return (list 'eval (p1v (cadr x)) (p1v (caddr x)) )))) (setq z (p1v (cadr x))) (cond ((and (not (atom z)) (eq (car z) 'cons) (setq tem (p1f (cadr z) (caddr z)))) (return tem)) ((and (not (atom z)) (eq (car z) 'list) ;;This kludge upon a kludge accounts ;;for the fact that all list/cons coalescing has already been ;; done, and a list of 0 or 1 element output by p1 ;;just isnt supposed to occur. (let ((zl (length (cddr z)))) (let ((p1farg (cond ((= zl 0) nil) ((= zl 1)(cons 'ncons (cddr z))) (t (cons 'list (cddr z)))))) (setq tem (p1f (cadr z) p1farg))))) (return tem)) (t (return (list 'eval z))))) ((eq fun 'apply) (cond ((cdddr x) (warn x "may not work") (return (list 'apply (p1fcnarg (cadr x)) (p1v (caddr x)) (p1v (cadddr x)) )))) (setq tem (p1v (cadr x))) ;compile and investigate first arg ;; now we check for the special case of applying a function ;; which is a subr of known number of arguments or a lambda ;; with a tell-tale argument list. (cond ((and (not (atom tem)) (eq (car tem) 'quote) (or (and (not (atom (setq z (cadr tem)))) ; check for lambda form, non-lexpr (eq (car z) 'lambda) (or (null (setq z (cadr z))) ; arglist must not be atom then! (not (atom z))) (setq z (length z))) ; get number of arguments (and (atom z) ; check for subr (getl z '(subr expr *expr)) (setq z (nargs z))))) ; see if nargs known (return (p1 (cond ((= z 0) ;special case for no arguments (list 'progn (caddr x) ;must eval arglist, surely will be nil. (cdr tem))) ;then call fcn with no args. (t ;regular case, eval arg list + spread args + call (list (list 'lambda (ncons (setq dummy (gensym))) (cons (cadr tem) (p1spread dummy z))) (caddr x))) ))) )) (return (list 'apply (p1fcnarg0 tem) (p1v (caddr x))))) ((setq z (assq fun '((mapcan mapcon car) (mapcon mapcon list) (map map list) (mapc map car) (mapcar maplist car) (maplist maplist list)))) (return (p1 (p1map z (cadr x) (cddr x))))) ((eq fun 'mapatoms) (setq tem (cond ((cddr x) (caddr x)) (t 'obarray))) (setq dummy (gensym)) (setq x (cadr x)) ; get function (cond ((and (not (atom x)) (memq (car x) '(quote function))) (return (p1 (subst (gensym) 'obary (subst dummy 'p (subst (cadr x) 'f (list '(lambda (obary) (do p 0 (1+ p) (= p 511.) (declare (fixnum p)) (mapc (function f) (arraycall t obary p))) (do p 511. (1+ p) (= p (+ 511. 128.)) (declare (fixnum p)) ((lambda (obary) (and obary (f obary))) (arraycall t obary p))) t) tem))))))) (t (return (p1 (subst (gensym) 'obary (subst dummy 'p (subst (gensym) 'f (list '(lambda (obary f) (do p 0 (1+ p) (= p 511.) (declare (fixnum p)) (mapc f (arraycall t obary p))) (do p 511. (1+ p) (= p (+ 511. 128.)) (declare (fixnum p)) ((lambda (obary) (and obary (funcall f obary))) (arraycall t obary p)))) tem x))))))))) ((and (eq fun 'eoffn) (cddr x)) ; eoffn of two args. (return (list 'eoffn (p1v (cadr x)) (p1fcnarg (caddr x))))) ; random lsubr (t (and (setq z (args fun)) (numberp (car z)) (setq tem (length (cdr x))) (or (< tem (car z)) (> tem (cdr z))) (go wna)) (return (cons fun (mapcar 'p1v-fcn (cdr x)))))) ; do p1 to args of lsubr wna (barf x "wrong number of arguments." nonfatal) (return ''nil))) ;compile a subr (defun p1subr: (x) (prog (y z) (and (setq y (nargs (car x))) (not (= y (length (cdr x)))) (go wna)) (cond ((setq z (assq (car x) '((sassoc . assoc)(sassq . assq)))) (cond ((memq (car (cadddr x)) '(quote function)) ;check for (sassoc x y 'f) (return (p1 (list 'cond ;change to: (list (list (cdr z) (cadr x) (caddr x))) ; (cond ((assoc x y)) (list (list 'apply (cadddr x) nil))) ;((apply 'f nil))) ))) (t (setq x (list (list 'lambda (list (setq y (gensym))) ;temp to eval 3rd arg (list 'cond (list (list (cdr z) (cadr x) (list 'prog2 nil (caddr x) (list 'setq y (cadddr x)) ))) (list (list 'apply y nil)) )) nil)) (return (p1 x)))) )) (cond ((eq (car x) 'not) (setq x (cons 'null (cdr x)))) ;; change 1+ and 1- to forms more suitable for optimization ((eq (car x) '1+) (return (p1 (cons '+ (cons '1 (cdr x)))))) ((eq (car x) '1-) (return (p1 (list '- (cadr x) 1)))) ((memq (car x) '(member assoc delete equal memq assq)) (setq z (mapcar (function p1v-fcn) (cdr x))) (cond ((eq (car x) 'equal) (cond ((or (p1type (car z)) (p1type (cadr z))) ; if either arg has a numeric type... (return (cons 'eq z))) ((return (cons 'equal z))) ))) (and (memq (car x) '(member assoc delete)) (or (p1eqqte (car z)) (and (not (atom (cadr z))) (eq (caadr z) 'quote) (not (eq (car x) 'delete)) (not (do y (cadadr z) (cdr y) (null y) (and (not (pnamep (cond ((eq (car x) 'member) (car y)) ((caar y))))) (return t)))))) (setq x (cons (cdr (assq (car x) '((member . memq) (assoc . assq) (delete . delq)))) (cdr x)))) (and effs (eq (car x) 'memq) (not (atom (cadr z))) (eq (car (cadr z)) 'quote) (setq y (cadr z)) (< (length (cadr y)) (memq-max)) ; it is a heuristic that memq of > memq-max things ; isn't worth changing to eq's. (atom (setq data (car z))) (setq z (cons 'or (mapcar (function (lambda (x) (list 'eq data (list 'quote x)))) (cadr y)))) (setq cnt (1- cnt)) (return (p1 z))) (and (eq (car x) 'assq) (not (atom (cadr z))) (eq (car (cadr z)) 'quote) (setq y (cadr z)) (< (length (cadr y))(assq-max)) (atom (setq data (car z))) (setq z (cons 'cond (mapcar (function (lambda (x) (list (list 'eq data (list 'quote (car x))) (list 'quote x)))) (cadr y)))) (setq cnt (1- cnt)) (return (p1 z))) (return (cons (car x) z))) ((memq (car x) '(sort sortcar)) ; sorts take function arg. (return (list (car x) (p1v (cadr x)) (p1fcnarg (caddr x))))) ((and (eq (car x) 'princ) (stringp (cadr x)) (= (stringlength (cadr x)) 1) ;optimize princ of short string into a tyo (return (list 'tyo (list 'quote (CtoI (cadr x))) )) )) ((or (and (eq (car x) 'set) ; this is a pretty useless optimization. (not (atom (cadr x))) (eq (caadr x) 'quote) (setq x (cons 'setq (cons (cadadr x) (cddr x)))) (return (p1 x))) (setq p1cof t)) ; don't know what will be setq'ed... )) (cond ((eq (car x) 'null) (cond ((and (null effs) (bool1able (cadr x)) (not (prog (y) ; don't allow memq as bool1able here (setq y (cadr x)) p (and (eq (car y) 'memq) (return t)) (and (eq (car y) 'progn) (setq y (car (last y))) (go p)) (and (eq (car y) 'prog2) (setq y (cadr y)) (go p))))) (setq z (function p1e-fcn))) (t (setq z (function p1v-fcn)))) (setq z (list (apply z (list (cadr x))))) (return (cons (car x) z))) ((eq (car x) 'expt) (return (xcons (list (setq y (p1v (cadr x))) (p1v (caddr x))) (cond ((eq (p1type y) 'flonum) 'expt$) (t 'expt))))) ((eq (car x) 'return) (or (setq y (p1sqg)) (return ''nil)) (return (list 'return (p1v (cadr x)) y)))) (cond ((eq (car x) 'cons) ;Try nifty cons condensations (let ((opd1 (p1v (cadr x))) ;Compile and condense first. (opd2 (p1v (caddr x)))) ;Second operand is good one... (cond ((atom opd2)) ;Variables, fall thru ((and (eq (setq x (car opd2)) 'quote)(eq (cadr opd2) 'nil)) (return (list 'ncons opd1))) ;cons (1 arg) => ncons ((getl x '(*expr *fexpr *lexpr))) ;Fall thru for *foo.. ((memq x '(cons list*)) (return (cons 'list* (cons opd1 (cdr opd2))))) ((memq x '(list ncons)) (return (cons 'list (cons opd1 (cdr opd2)))))) (return (list 'cons opd1 opd2))))) (cond ((memq (car x) '(< = >)) (return (p1generic x (mapcar 'p1v-fcn (cdr x)))))) (return (cons (car x) (mapcar 'p1v-fcn (cdr x)))) ;random subr - just eval all args wna (barf x "wrong number of arguments." nonfatal) (return ''nil))) ;;; Generic hack BSG 8/6/80 (defun p1generic (form cmpargs) ;args already p1'ed (do ((known-type nil) (fn (car form)) (fargs cmpargs (cdr fargs))) ((null fargs)(cons fn cmpargs)) (let ((arg (car fargs))) (let ((type (cond ((and (not (atom arg))(eq (car arg) 'quote)) (typep (cadr arg))) (t (p1type arg))))) (cond ((not (memq type '(fixnum flonum nil))) (barf (cond ((and (not (atom arg))(eq (car arg) 'quote)) (or (cadr arg) (maknam '(n i l)))) (t arg)) (catenate "Invalid operand for " fn) data)) ((eq known-type type)) ((null type)) ((null known-type)(setq known-type type)) (t (barf form "Inconsistent numeric argument types" nonfatal) (return (cons (cdr (assoc fn '((> . greaterp)(< . lessp)(= . equal)))) cmpargs)))))))) (defun p1and: (f x) ;f is and or or ;x is list of args, at least 2 ;generates e.g. (and (setq-list) call-out-flag transformed-body) ((lambda (p1vars p1cnt) ((lambda (condp p1csq lmbp p1lsq p1cof) (setq x (mapcar (function p1aoc) x)) ; transform the body (setq x (nconc (list f p1csq p1cof) x)) ; make return value ) t nil nil nil nil) (p1bug p1cnt p1vars) (p1setqex (cdr x)) x) locvars cnt)) (defun p1bug: (p1cnt p1vars) ;See if pass 2 really needs this. (setq cnt (1+ cnt)) (do x p1vars (cdr x) (null x) (cond ((greaterp (cdar x) p1cnt) (rplacd (car x) cnt)))) (setq cnt (1+ cnt))) (defun p1aoc: (j) ;$ (comment compile a piece in an and-or clause, or the first part of a cond clause) (cond ((bool1able j) (p1 j)) ((p1v j)))) (defun p1cond: (x) ;x is list of cond clauses ;produces ; (cond (setq-list) call-out-flag ((a b) c) (d)) ;from ; (cond ((a b) c) (t d)) (cond ((null x) (warn nil "vacuous cond - nil generated") ''nil) (((lambda (p1vars p1cnt) ((lambda (condp p1csq lmbp p1lsq p1cof z y) ; make reversed list of processed cond clauses in z. (do x x (cdr x) (null x) (setq y (p1aoc (caar x))) ;compile the antecedent (cond ((and (not (atom y)) ;if the antecedent is a constant, (eq (car y) 'quote)) (and (equal y ''nil) (go next-clause)) ;if nil, delete this clause (cond ((cdar x) (setq y (cons 'progn (cdar x))) ;new improved antecedent (setq y (list (p1aoc y))) ) ;compile the antecedent,listify it. ((setq y (list y)))) ;if (t (x) (y)) change to((progn (x) (y))) ;but leave a clause (t) the way it is. (setq x '(fin))) ;and this is the last clause of this cond ;that can be reached, so delete the rest. (t (setq y (cons y (cdar x))))) ;at this point y is the cond clause, with compiled antecedent (push (cond ((null (cdr y)) y) (t ;if consequents, compile them (list (car y) (p1 (cond ((cddr y) ;make sure only one consequent (cons 'progn (cdr y))) ((cadr y)) ))) )) z) next-clause ) (setq x (nconc (list 'cond p1csq p1cof) (nreverse (or z '(('nil))))))) ;make return value ; ensuring there is at least one clause! t nil nil nil nil nil nil) (p1bug p1cnt p1vars) (p1setqex (cdr x)) x) locvars cnt)) )) (defun p1boole: (x) ;boole transformer. x is a form whose car is boole. ;puts everything in terms of and, ior, xor. I.e. boole 1, 6, or ; 7, or else progn or prog2 for the trivial cases. (prog (y) ;*** only works if boole has 3 or more args. (cond ((and (cdr x) (cddr x) (cdddr x))) (t (barf x "boole with less than 3 args." nonfatal) (go lose)) ) (or (numberp (setq y (cadr x))) (return x)) ;variable boole - leave it alone (setq y (assq y '( ;get characteristics of this boole from first arg, which must be fixnum. (0 con 0) (1) (2 ca 1) (3 spm) (4 cm 1) (5 spa) (6) (7) (10 cr 7) (11 cr 6) (12 ca 3) (13 ca 7) (14 cr 5) (15 cm 7) (16 cr 1) (17 con -1) ))) (and (null y) (barf x "first arg to boole must be a fixnum between 0 and 17" nonfatal) (go lose)) (or (setq y (cdr y)) (return x)) ;if an elementary boole (1, 6, or 7), just leave it. (cond ((eq (car y) 'cr) ;complement result: (return (list 'boole 6 ; by xoring with -1 (p1boole (cons 'boole (cons (cadr y) (cddr x) ))) -1))) ((eq (car y) 'con) ;result is a constant, so make progn to eval args then return constant value (return (cons 'progn (append (cddr x) (list (cadr y))) ))) ((eq (car y) 'spm) ;result is last arg (return (cons 'progn (cddr x)))) ((eq (car y) 'spa) ;result is 2nd arg (return (cons 'prog2 (cons nil (cddr x))))) ((eq (car y) 'ca) ;complement "accumulator" (return (prog (z zz) (setq z (caddr x) ;2nd arg zz (cdddr x)) ;rest of args loop (setq z (list 'boole ;complement result so far (z) (cadr y) ;and apply boole to next arg (list 'boole 6 z -1) (car zz) )) (cond ((setq zz (cdr zz)) (go loop)) ((return z)) ) ))) ((eq (car y) 'cm) ;complement "memory": all opnds except 2nd arg (return (cons 'boole (cons (cadr y) (cons (caddr x) (mapcar '(lambda (z) (list 'boole 6 z -1)) (cdddr x) ))))) )) lose (return ''nil))) ;;;"number compiler" stuff. ;;;set up properties giving relations ;;;of the various arithmetic functions. (mapcar '(lambda (x) (putprop (car x) (cdr x) 'arith-subst) (car x)) '( (abs absfix/! abs$) ; special abs substitution (times * *$) (plus + +$) (difference - -$) (minus - -$) ;works since number of args has been checked (quotient // //$) (add1 1+ 1+$) (sub1 1- 1-$) (lessp (p1lesspcheck) (p1lesspcheck)) (greaterp (p1greaterpcheck) (p1greaterpcheck)) ; (zerop (p1zeropfix) (p1zeropflo)) ; - removed because pass 2 wins on this now (gcd \\ nil) (remainder \ nil))) ;;;functions for macroly expanding zerop, lessp, greaterp into =, <, or > (defun p1lesspcheck: (x) (cond ((null (cddr x)) ;only two args, can substitute. (list '< (car x) (cadr x))) ((cons 'lessp x)) )) ;more than two. Oh, well... (defun p1greaterpcheck: (x) (cond ((null (cddr x)) ;only two args, can substitute. (list '> (car x) (cadr x))) ((cons 'greaterp x)) )) ;more than two. Oh, well... ;;;The properties on atoms derived from declarations are as follows: ;;; args as in the args function, (m.n) or (nil.n) ;;; number declares numeric variable. property is ;;; passed through renaming. value is fixnum, flonum, ;;; or nil. ;;; numfun declares numeric function. value is list whose car ;;; is type of result returned by function (fixnum, flonum, or nil), ;;; and whose cdr is list of argument types which is not ;;; used right now but I suppose might be someday. ;;; arith arith declaration has been used. value of property ;;; is function which should be substituted for this one. ;;; arith-subst property placed on system functions which can get special functions ;;; substituted when arguments are all fixnums or all flonums - value of property is ;;; list of fixnum function and flonum function, with nil where there is not one of the choices ;;;Note: array* arrays have both a *array property and a numfun property. (defun p1red: (x f) ;reduce expression x with reducible function f (prog nil (mapc '(lambda (y) ;make sure all arguments are constants ;Note: this isn't quite right for reducible *fexpr's, but who cares. (and (or (atom y) (not (eq (car y) 'quote))) (return (cons f (cdr x))))) ;non-constant arg seen - leave form alone. (cdr x)) (return (p1ctevq x (cons f (cdr x)))) )) ;all args constant - evaluate at compile time. (defun p1sysred: (x f) ;reduce expression x with reducible system function f. (prog (y const nonconst firstconst boolectl) (cond ((memq f '(+ +$ plus * *$ times)) ;commutative. (return (p1redcomm f (cdr x) x))) ((memq f '(- -$ difference *dif *quo quotient // //$)) ;commutative except for first arg. ;and other funnies (and (null (cdr x)) ; if no args, generate constant result. (return (p1ctevq x x))) (and (not (atom (cadr x))) (eq (car (cadr x)) 'quote) (setq firstconst (cadr x))) (cond ((null (cddr x)) ;if only one arg, is a funny. (cond ((null firstconst) ;if arg not constant, can't reduce (return x)) ((and (zerop (cadr firstconst)) ;be sure not to divide by zero at compile time (memq f '(// //$ quotient))) (return x)) ;but do it at run time. ((return (p1ctevq x (list f firstconst))))) )) (setq y (p1redcomm (cdr (assq f '((- . +) ;reduce 2nd - nth args (-$ . +$) (difference . plus) (*dif . plus) (quotient . times) (*quo . times) (// . *) ;you might not think this one works, but in fact it does. (//$ . *$)) )) (cddr x) x)) (setq boolectl (and (not (atom y)) (eq 'quote (car y)))) ;t if y is a constant (cond ((and (null boolectl) (null firstconst)) (return (cons (car x) (cons (cadr x) (cdr y))))) ;can't do anything. ((and boolectl firstconst) ;if completely constant (and (zerop (cadr y)) ;special check for division by zero. (memq f '(// //$ quotient *quo)) (return (list (car x) firstconst y))) ;not a complete constant (return (p1ctevq x (list f firstconst y)))) (boolectl ;if constant except for 1st, e.g. (- x '4) (return (list (car x) (cadr x) y))) ((and (cdr y) ;1st const. some others const? (not (atom (cadr y))) (eq (caadr y) 'quote) ;yes (not (and (zerop (cadadr y)) ;be sure not to divide by zero at compile time. (memq f '(// //$ quotient *quo)) ))) (return (cons (car x) (cons (p1ctevq x (list f firstconst (cadr y))) (cddr y))))) ;combine the constants. (t ;otherwise, have only first constant so leave it. (return (cons (car x) (cons firstconst (cdr y))))) )) ((eq f 'equal) ;if one arg is nonbignum atomic constant, change to eq (and (not (atom (cadr x))) (eq (car (cadr x)) 'quote) (setq firstconst (cadr x))) (and (not (atom (caddr x))) (eq (car (caddr x)) 'quote) (setq const (caddr x))) (and firstconst (atom (cadr firstconst)) (not (bigp (cadr firstconst))) (not (stringp (cadr firstconst))) ;strings are not really atomic (return (p1red x 'eq)) ) (and const (atom (cadr const)) (not (bigp (cadr const))) (not (stringp (cadr const))) ;strings are not really atomic (return (p1red x 'eq)) ) (return x)) ;can't optimize, leave the way it is. ((and (eq f 'ascii) (not (atom (setq y (cadr x)))) (eq (car (cadr x)) 'quote)) (return (p1ctevq x (list f y)) )) ((eq f 'boole) ;Note: boole has already been transformed to just and, or, and xor (or (and (not (atom (cadr x))) ;make sure type of boole is constant fixnum. (eq (car (cadr x)) 'quote) (smallnump (cadr (setq boolectl (cadr x))))) (return x)) ;not constant type of boole, abandon attempt to optimize (do z (cddr x) (cdr z) (null z) ;look at 2nd and following args (cond ((and (not (atom (car z))) (eq (car (car z)) 'quote)) (push (car z) const)) ((push (car z) nonconst)) )) (and const ;coalesce the constant arguments (cdr const) ;if more than 1 (setq const (list (p1ctevq x (nconc (list 'boole boolectl) const))))) (cond (nonconst ;if not all args were constant, (return (nconc (list 'boole boolectl) const (nreverse nonconst))) ) ((return (car const)))) ;if all args constant, return quoted value ) ((memq f '(nth nthcdr)) (and (not (atom (cadr x))) ; look at count (eq (car (cadr x)) 'quote) ; it's a constant. (smallnump (cadr (cadr x))) ; it's a fixnum. (< (cadr (cadr x)) 20.) ; it's small enough. (return (p1nthred f (cadr (cadr x)) (caddr x) x))) (return x)) ; can't do anything with it. ((memq f '(\ remainder)) ;watch out for division by zero (and (not (atom (caddr x))) ;look at divisor (eq (car (setq const (caddr x))) 'quote)) (and const (zerop (cadr const)) (return x)) ;don't ctev if divisor is 0. (return (p1red x f)) ) ((return (p1red x f))) ) ;not a special case, just do it. (return x) )) ;if fall through from a clause of the above cond, couldn't reduce, so return argument ;;;reduce a commutative function ;;;args == function, arglist, form for p1ctev to use in error message ;;;if all args constant, returns quoted value ;;;otherwise, returns expression with constants combined and moved up to the front. (defun p1redcomm: (f argl errform) (prog (const nonconst) (mapc '(lambda (x) (cond ((atom x) (push x nonconst)) ;atom must be var ((eq (car x) 'quote) (push x const)) ;definite constant ((and (eq (car x) f) ;internal call same f (not (atom (cdr x))) (not (atom (cadr x))) (eq (caadr x) 'quote) ;internal constant can be cumulated (push (cadr x) const) (push (cons f (cddr x)) nonconst))) (t (push x nonconst)))) argl) ;; evaluate cumulated constant (and const (setq const (p1ctevq errform (cons f const)) argl (cadr const))) (and const ;get rid of identities (cond ((or (and (memq f '(+ +$)) (zerop argl)) (and (eq f 'plus) (eq argl 0)) ; only fixnum zero is identity (and (eq f '*) (= argl 1.)) (and (eq f '*$) (= argl 1.0))) (setq const nil)))) (return (cond ((null nonconst) const) ((null const) (cons f (nreverse nonconst))) (t (cons f (cons const (nreverse nonconst)))))))) (defun p1nthred: (fun count form errform) (cond ((eq (car form) 'quote) (p1ctevq `(,fun ,count ,form) errform)) ((= count 0) (cond ((eq fun 'nth) `(car ,form)) (t form))) ((eq fun 'nth) (nth-cdr-ing count 'car form)) (t (nth-cdr-ing (1- count) 'cdr form)))) (defun nth-cdr-ing (n last-op operand) (do ((i n (1- i)) (result operand `(cdr ,result))) ((< i 1) `(,last-op ,result)))) (defun p1ctevq: (x y) (list 'quote (p1ctev x y))) ;same as p1ctev but value is constant (since has already been evaluated) ;use this entry for making results to return from p1red, p1sysred, p1redcomm. (defun p1ctev: (x y) ;compile-time evaluator, x = for err msg, y = exp (cond ((null (errset (setq y (eval y)))) (barf x "lisp error during compile time evaluation." nonfatal) ''nil) (y) )) (defun p1-chase-linked-macros: (f) ;seek out (defprop a b macro)'s (do ((prop))(nil) (setq prop (getl f '(macro *macro))) (or prop (return f)) (or (symbolp (cadr prop))(return (cadr prop))) (setq f (cadr prop)))) (defun macro-expand: (x f) ;returns expanded macro - x is form, f is functional (macro property) (cond ((errset (setq x (funcall f x))) x) ;win, return expanded result ((eq f 'doexpander) (barf x "incorrect do format" nonfatal) ''nil) ;lose, make result be nil ((eq f 'prog1-expander) (barf x "incorrect prog1 format" nonfatal) ''nil) ((eq f 'let-expander) (barf x "incorrect let format" nonfatal) ''nil) ;ditto. (t (barf x "lisp error during macro expansion" nonfatal) ''nil) )) ;again, lose, make result nil (defun p1eqqte: (z) (and (not (atom z)) (eq (car z) 'quote) (pnamep (cadr z)))) (defun p1e-fcn: (x) ((lambda (effs) (p1 x)) t)) (defun p1e1: (x) ; comment called only from p1prog ; tries to factor out a setq from a cond - for example, ; (cond ((and (setq x (foo)) alpha) (return nil))) ; goes into ; (prog2 (setq x (foo)) (cond ((and x alpha) (return nil)))) (cond ((or prssl (not (memq (car x) '(cond and or)))) (p1 x)) (((lambda (data tem f) (and (setq data (p1hunoz (setq tem (cond (f (cadr x)) ((cdr x)))))) (or (memq (cadr data) bvars) (assq (cadr data) rnl)) (p1 (prog2 (setq tem (p1hunoz tem)) (list 'prog2 data (cons (car x) (cond (f (cons tem (cddr x))) (tem)))))))) nil nil (eq (car x) 'cond))) ((p1 x)))) (defun p1hunoz: (y) (cond ((or (atom (car y)) (null (cdar y)) (not (atom (caar y)))) (and data y)) ((eq (caar y) 'setq) (cond (data (cons (p1fv (cdar y)) (cdr y))) (t (car y)))) ((getl (caar y) '(fexpr fsubr *fexpr macro *macro)) (and data y)) (data (cons (cons (caar y) (p1hunoz (cdar y))) (cdr y))) ((p1hunoz (cdar y))))) (defun p1f: (f l) ;; patch up for forms of (eval (cons 'fsubr list)) (cond ((and (not (atom f)) (or (eq (car f) 'quote) (eq (car f) 'function)) (atom (setq f (cadr f))) (getl f '(fexpr fsubr *fexpr))) (list 'apply (list 'quote f) l) ))) (defun p1fv: (x) (cond ((and (cdr x) (cddr x)) (p1fv (cddr x))) ((car x)))) (defun p1fcnarg: (x) ; compile an argument to a functional. (p1fcnarg0 (p1v x))) ;compile argument and process the compiled value (defun p1fcnarg0: (x) ;like p1fcnarg but x is already compiled (cond ((and (not (atom x)) ;see if it turned out to be (quote (lambda ... (eq (car x) 'quote)) (list 'quote (p1gfy (cadr x)))) ;if it did, compile the functional form. (t x))) ;otherwise, return the ordinary value. (defun p1gfy: (x) (cond ((atom x) x) (t (setq x (compile-fcn (gen-fcn-name) 'expr x nil )) x))) (defun gen-fcn-name: nil ;routine to generate a name for compiler-produced function. ((lambda (x) (putprop x t 'dont-intern) x) (maknam (append genprefix (explodec (setq gfyc (1+ gfyc))))))) (defun p1glm: (ll body fl) ; convert (lambda ll body) to (lambda ; ll transformed-body) (cond ((null (cdr body)) (setq body (p1 (car body)))) (t (setq fl nil) (do body body (cdr body) (null body) (push (cond ((null (cdr body)) (p1 (car body))) ;last is for value ((p1e (car body)))) ;others are for effect fl)) (setq body (cons 'progn (nreverse fl))) )) (list 'lambda ll body )) (defun p1ioc: (x) ;compile ioc into setq's when possible ;in certain peculiar cases, will not give same ; result as interpreted ioc. E.g. (ioc gr) ; and (ioc rg) are compiled the same but ; interpreted differently. (prog (z setqs others) (do y (exploden (cadr x)) (cdr y) (null y) (setq z (car y)) (cond ((= z (CtoI "d")) (defprop ^d t special) (push '(^d t) setqs)) ((= z (CtoI "c")) (defprop ^d t special) (push '(^d nil) setqs)) ((= z (CtoI "r")) (defprop ^r t special) (push '(^r t) setqs)) ((= z (CtoI "t")) (defprop ^r t special) (push '(^r nil) setqs)) ((= z (CtoI "v")) (defprop ^w t special) (push '(^w nil) setqs)) ((= z (CtoI "w")) (defprop ^w t special) (push '(^w t) setqs)) ((push z others))) ;can't be done as a setq, have to call the interpreter's ioc. ) (return (cons 'progn (nconc (and setqs (list (p1 (cons 'setq (apply 'append (nreverse setqs)))))) (and others (list (list 'ioc (maknam (nreverse others))))) ))) )) (defun p1lam: (f argl) ((lambda (p1ll rnl bvars condp lmbp p1lsq body ecrsloss) (setq argl (mapcar (function p1v-fcn) argl)) (setq p1ll (p1lmbify (cadr f) (cadr f))) (setq body (p1localdcl p1ll (cadr f) (cddr f))) ;process local declarations, if any (and (not (= (length argl) (length p1ll))) (barf (cons (list 'lambda p1ll '---) argl) "wrong number of args" data)) (setq cnt (1+ cnt)) (setq argl (cons (p1glm p1ll body nil) argl)) (uuvp p1ll 'p1ll 'lambda) (setq f (lsub p1lsq p1ll))) nil rnl bvars nil t nil nil ecrsloss) (p1setqex (list f p1cof)) argl) (defun p1lmbify: (z data) (do ((w) (x z (cdr x)) (y)) ((null x) (nreverse w)) (setq y x) ;simulating maplist here ;make copy since will setq y (cond ((null (car y)) (barf data "- nil not permissible in bound var list" data)) ((memq (car y) (cdr y)) (warn (list (car y) 'from data) "- repeated in bound var list"))) (cond ((specialp (setq y (car y)))) (special (putprop y t 'special)) ;all variables are special in (declare (setq special t)) mode (t (cond ((assq y locvars) (setq y (p1rename y)) (push (cons y 0) locvars)) ((push (cons y 0) locvars))) )) (push y bvars) (setq w (cons y w)) )) ;cons up result for 'maplist' (defun p1localdcl: (lambda-list orignames body) ;pulls local declarations off front of body. (prog () next-body-elem (and (null body) (return body)) ;if reached end of body, return. (or (and (not (atom (car body))) ;else check for declaration (eq (car (car body)) 'declare)) (return body)) ;if not a declaration, return with body proper. ;(car body) is a local declaration. (mapc '(lambda (dcl) ;so scan the declarations (or (memq (car dcl) '(fixnum flonum notype)) (barf dcl "bad local declaration" data)) (mapc '(lambda (item) ;scan the clauses of a declaration (cond ((atom item) ;declaring a local variable (cond ((specialp item) (barf (list (car dcl) item) "implementation restriction: no local declaration of special variables" nonfatal)) (t ;if OK dcl, push onto ecrsloss list (push (cons item (cond ((eq (car dcl) 'notype) nil) ((car dcl)) )) ecrsloss)) )) (t ;declaring a local functional variable. (ecch) (cond ((specialp (car item)) (barf (list (car dcl) item) "implementation restriction: no local declaration of special variables" nonfatal)) (t ;OK dcl, push onto ecrsloss ist (push (cons (car item) (cons (cond ((eq (car dcl) 'notype) nil) ((car dcl)) ) (cdr item))) ecrsloss)) )) )) (cdr dcl))) (cdar body)) (setq body (cdr body)) ;this clause has been processed, discard it and go on the next. (go next-body-elem)) ;;;now perform declarations according to ecrsloss (mapc '(lambda (var rnvar) ;map over var list ((lambda (dcl) ;dcl:=ecrsloss entry for var (and dcl (and (eq var rnvar) ;if not already renamed, rename it. (progn (setq rnvar (p1rename var)) (rplaca (memq var lambda-list) rnvar) (rplaca (memq var bvars) rnvar) (rplaca (assq var locvars) rnvar) )) (putprop rnvar (cdr dcl) (cond ((atom (cdr dcl)) 'number) ( 'numfun ) )))) (assq var ecrsloss))) orignames lambda-list) body) ;return the body with local dcl pulled off the front (defun p1rename: (x) ;gets gensym'ed name for a variable to avoid property-list conflicts ((lambda (gs) (putprop gs x 'rename) ;remember original name for error messages (push (cons x gs) rnl) ;also put entry on rename list so future references will get renamed. (and (setq x (get x 'number)) ;carry over number-variable declaration (putprop gs x 'number)) gs) ;and return the new name (gensym))) ;;;extended p1rename which patches bvars and locvars - used by p1localdcl (KLUDGE) (defun p1renamex: (x) ((lambda (gs) (rplaca (or (memq x bvars) (barf x "not in bvars! - p1renamex" barf)) gs) (rplaca (or (assq x locvars) (barf x "not in locvars! - p1renamex" barf)) gs) gs) (p1rename x))) (defun p1map: (mapx mapfcn maplists) ;to translate the map fcns (prog (mapgensyms mapvalue mapc-for-value z y mapargs maptem1 maptem2) (or effs (progn (setq mapvalue (gensym)) ;if must return a value (and (eq (cadr mapx) 'map) (setq mapc-for-value (gensym) mapvalue nil)))) ;if map or mapc for value, value will be first of maplists (setq y (eq (caddr mapx) 'car)) ;t for mapc,mapcar,mapcan. nil for map,maplist,mapcon (and (or (and (not effs)(eq (cadr mapx) 'maplist)) (memq (cadr mapx) '(mapcan mapcon))) (setq maptem1 (gensym) maptem2 (gensym))) ;construct the do - variables and the arg list for the function being mapped. (do i (length maplists) (1- i) (zerop i) (setq mapgensyms (cons (gensym) mapgensyms)) (setq mapargs (cons (cond (y `(car ,(car mapgensyms))) ((car mapgensyms))) mapargs)) ) (setq y nil) ;see if mapfcn needs to be evaluated (cond ((and (not (atom mapfcn)) (memq (car mapfcn) '(quote function)) (or (atom (cadr mapfcn)) (eq (caadr mapfcn) 'lambda))) (setq mapfcn (cadr mapfcn)) ;mapfcn need not be evaled. (and (atom mapfcn) ;but check for fsubrs. (getl mapfcn '(fsubr *fexpr)) (setq y mapfcn mapfcn nil))) ;special hack - will become (apply 'f (list g1 g2... ((setq y mapfcn mapfcn (gensym)))) ;will have to eval mapfcn, assign to gensym ;generate a do (setq z `(,map-do ;so go and return will get special treatment ,(nconc ;make var list (mapcar (function (lambda (val gs) `(,gs ,(cond ((and mapc-for-value (eq gs (car mapgensyms))) mapc-for-value) ;get first maplist from outer ; lambda which has already evaled it. (t val)) (cdr ,gs)))) maplists mapgensyms) (and mapvalue `((, mapvalue))) (and maptem1 `((,maptem1) (,maptem2)))) ( ;make list of endtest, retval (or . ,(mapcar (function (lambda (gs) `(null ,gs))) mapgensyms)) ,mapvalue ) ;the body of the do is the application of the function ,(cond ((prog2 (setq z (list map-funarg (cond (mapfcn (cons mapfcn mapargs)) ;normal case (`(apply ',y (list .,mapargs))))));fsubr (null mapvalue)) z) ;if value not needed, just call the mapfcn ((eq (cadr mapx) 'maplist) ;value is list of results `(progn (setq ,maptem2 (ncons ,z)) (cond ((null ,mapvalue) ;first time... (setq ,maptem1 (setq ,mapvalue ,maptem2))) (t (rplacd ,maptem1 ,maptem2) (setq ,maptem1 ,maptem2))))) (`(progn ;mapcan or mapcon (setq ,maptem2 ,z) ;compute it (and ,maptem1 (rplacd ,maptem1 ,maptem2)) (or ,mapvalue (setq ,mapvalue ,maptem2)) (setq ,maptem1 (or (last ,maptem2) ,maptem1))))) )) ; now put a lambda around it if the fcn needs to be evaled (and y mapfcn (setq z `((lambda (,mapfcn) ,z) ,y))) ;if it is a map or mapc for value, enclose the code in a lambda to evaluate the first list ;and do the map and then return the first list as the value (and mapc-for-value (setq z `((lambda (,mapc-for-value) ,z ,mapc-for-value) ; <- a gensym ,(car maplists) ))) (return z))) (defun p1prog: (x p1mapcnt) ; change (prog (vars) body) to (prog (setq-list) call-out-flag (tags-gone-to) (vars) transformed-body) (prog2 nil ((lambda (rnl bvars progp gone2 p1psq effs p1cof mapf ecrsloss) (prog (condp p1csq lmbp p1lsq pvrl p1vars gl p1cnt body prssl) (setq pvrl (p1lmbify (car x) (car x))) (setq body (p1localdcl pvrl (car x) (cdr x))) ;process local declarations, if any. (mapc (function (lambda (x) ;put special prog vars on setq list (and (specialp x) (setq p1psq (add x p1psq))))) pvrl) (setq p1vars locvars) (setq p1cnt (setq cnt (1+ cnt))) ;do the tags (mapc (function (lambda (x) (and (atom x) (setq gl (cons (cons x (gensym)) gl))))) body) ;do the body (setq body (mapcar (function (lambda (y) (setq cnt (1+ cnt)) (cond ((atom y) (setq prssl t) (setq y (cdr (assq y gl))) ;subst (gensym) for tag (putprop y t 'defined) ;tag is defined now. y) (t (p1e1 y))))) body)) (p1bug p1cnt p1vars) (uuvp pvrl 'pvrl 'prog) (setq x nil) (cond ((memq gofoo gone2) (mapc (function (lambda (x) (putprop (cdr x) t 'back-reference))) gl)) ;if a computed goto, any tag could ;get back referenced. ; gofoo on gone2 says there is a computed go (t (mapc (function (lambda (tag) (or (memq (car tag) gone2) (prog2 (push (car tag) x) ;remember this unused tag for err msg (putprop (cdr tag) t 'back-reference) ;since there are no go's to this tag, tell ;pass 2 that it has no slotlist. ;but can't delete it from gl. )) )) gl))) (and x (warn x "- unused go tags")) (setq x (list (lsub p1psq pvrl) p1cof)) ; here is return value. (return (nconc (list 'prog p1psq p1cof gl pvrl) body)))) rnl bvars t nil nil t nil nil ecrsloss) (p1setqex x) )) (defun p1special: (x) (cond ((specialp x)) (special (putprop x t 'special)) ;in (declare (setq special t)) mode, everything is special ((not (memq x bvars)) (putprop x t 'special) ;if free and not yet declared, then do so and inform user (or (memq 'value (status system x)) ;if a system global variable, do not barf. (warn x "undeclared - henceforward assumed to be special")) t))) (defun p1spread: (var arglen) ; generate arglen arguments by decomposing a list-valued atom. (cond ((= arglen 0) nil) ((= arglen 1) (list (list 'car var))) (t (do ((arglst (list (list 'cadr var)) (xcons arglst (subst var 'foo '(car (setq foo (cdr foo)))))) (argcnt 2 (1+ argcnt))) ((= argcnt arglen) (cons (list 'car var) arglst)))))) ;;;function to extend setq's from inner prog, cond, or lambda ;;;to outer prog, cond, or lambda. Also extends p1cof. ;;;(replaces old p1sqe) ;;;argument is list of: ;;; setq'ed vars minus those bound at level being exited ;;; p1cof value ;;;p1setqex should be called after the various p1ll, p1psq, ;;;etc. have been unbound so it can mung previous values. (defun p1setqex: (x) (cond ((car x) ;vars to be setq'ed-propagated. (and condp (setq p1csq (ladd (car x) p1csq))) (and lmbp (setq p1lsq (ladd (car x) p1lsq))) (and progp (setq p1psq (ladd (car x) p1psq))) )) (setq p1cof (or p1cof (cadr x))) nil) (defun p1sqg: nil ;called for go, return. (setq prssl t) (cond ((not progp) (barf nil "go or return not in prog" nonfatal)) ;and p1sqg returns nil, which causes the ((not mapf) 0) ;go or return to get changed to 'nil ((plusp p1mapcnt) p1mapcnt) ;inside map (t ;inside map but not inside prog (barf nil "go or return not in prog" nonfatal)) )) (defun p1sqv: (y) (cond (condp (setq p1csq (add y p1csq)))) (cond (lmbp (setq p1lsq (add y p1lsq)))) (cond (progp (setq p1psq (add y p1psq)))) (and (setq y (assq y locvars)) ;if a local variable, update its cnt (rplacd y (cond ((plusp (cdr y)) cnt) ;I.E.: setq is considered to be a reference ((minus cnt))) ))) ;but if never yet referenced, make minus for uuvp (defun p1sts: (x) ;compile a status or sstatus (prog (y z) (setq z (substr (setq z (get_pname (cadr x))) ;get control argument 1 (min 4 (stringlength z)) )) (and (eq (car x) 'sstatus) (go sstat)) ;if sstatus, go to other routine (setq y (assoc z '( ;status - get description of what to do ("chtr" 1 char) ("ioc" 2) ("macr" 3 char) ("synt" 4 char) ("topl" 5) ("urea" 6) ("uwri" 7) ("+" 8.) ("date" 9.) ("dayt" 10.) ("runt" fcn runtime) ("time" 12.) ("inte" 13. eval) ("spcn" 14.) ("crun" 15.) ; ("*nop" var *nopoint) ;flushed ; ("*rse" 17.) ;flushed ("gcti" 18.) ("spcs" 19. eval) ("pdls" 20. eval) ("pdlr" 21. eval) ("pdlm" 22. eval) ("lisp" 23.) ("pagi" 24.) ("unam" 25.) ("jcl" 26.) ("arg" 27. eval) ("terp" 28.) ("_" 29.) ("syst" 31. eval) ("char" 32. eval) ("tabs" constant) ("crfi" 34.) ("ttyr" 35.) ("udir" 36.) ("feat" 37.) ; ("()()" 38.) ;flushed ("uuol" 39.) ("divo" 40.) ("abbr" 41.) ("dow" 42.) ("stat" constant) ("ssta" constant) ("newl" constant) ("nofe" 46.) ("linm" 47.) ("clea" 48.) ("eval" 49.) ("mulq" 50.) ("mulp" 51.) ))) (cond ((null y) (go barf)) ((null (cddr y)) (return x)) ;can leave as fsubr ((eq (cadr y) 'constant) ;can do at compile time (return (list 'quote (eval x)))) ((eq (cadr y) 'var) ;can use value of a special variable (putprop (caddr y) t 'special) (return (p1 (caddr y)))) ((eq (cadr y) 'fcn) ;other function exists (return (p1 (cons (caddr y) (cddr x))))) ((eq (caddr y) 'eval) (go ieval)) ;evaluate all arguments ((eq (caddr y) 'char) ;2nd arg is a char - number or pname (and (pnamep (caddr x)) (rplaca (cddr x) (CtoI (get_pname (caddr x))))) (go ieval)) ) barf (and (cddr x) (warn x "unrecognized status function - left exactly as written.")) ;don't barf if no args (return x) ;;;come here to change to lsubr version ieval (return (p1 (cons (cdr (assq (car x) '((status . *status) (sstatus . *sstatus)) )) (cons (cadr y) ;this number is control argument, goes to tv in lisp_status_fns_ (cddr x))))) ;;;come here to do sstatus function sstat (setq y (assoc z '( ;get description of what to do ("chtr" 1. char) ("ioc" fcn ioc) ("macr" 3 char fcn) ("synt" 4 char) ("topl" 5 eval) ("urea" fcn uread) ("uwri" fcn uwrite) ("+" 8. eval) ("inte" 13. eval fcn) ("crun" fcn crunit) ; ("*nop" var *nopoint) ;flushed ; ("*rse" fcn *rset) ;flushed ("gcti" 18. eval) ("spcs" 19. eval) ("pdls" 20. eval) ("pdlr" 21. eval) ("pdlm" 22. eval) ("terp" 28. eval) ("_" 29. eval) ("char" 32. eval) ("crfi" 34.) ("ttyr" 35. eval) ("feat" 37.) ("uuol" 39. eval) ("divo" 40. eval) ("abbr" 41. eval) ("nofe" 46.) ("clea" 48. eval) ("eval" 49. eval) ("mulq" 50. eval) ("mulp" 51. eval) ))) (cond ((null y) (go barf)) ((null (cddr y)) (return x)) ;can leave as fsubr. ((eq (cadr y) 'var) ;change to setq to special variable (putprop (caddr y) t 'special) (return (p1 (list 'setq (caddr y) (caddr x))))) ((eq (cadr y) 'fcn) ;change to some other fcn (return (p1 (cons (caddr y)(cddr x))))) ((eq (caddr y) 'char) (and (pnamep (caddr x)) (rplaca (cddr x) (CtoI (get_pname (caddr x))))) (go ieval1)) ((eq (caddr y) 'eval) (go ieval1)) ((go barf))) ieval1 (and (eq (cadddr y) 'fcn) ;third argument is functional - use p1gfy on it (not (atom (setq z (cadddr x)))) (memq (car z) '(quote function)) (rplaca (cdddr x) (list 'quote (p1gfy (cadr z))))) (and (= (cadr y) 3) ;sstatus macro has 4th argument, s or nil, default nil. (cond ((null (cddddr x)) (setq x (append x '(nil)))) ;no 4th arg, put in default of nil ((equal "s" (substr (get_pname (car (cddddr x))) 1 1)) (setq x (append x '(t)))) ;4th arg = splicing, put t as 4th arg ((setq x (append x '(nil)))))) ;other 4th arg, change to nil. (go ieval))) (defun p1v-fcn: (x) ((lambda (effs) (p1 x)) nil)) (defun uuvp: (l ll f) (prog (unused set-not-ref) (mapc (function (lambda (x) (and (setq x (assq x locvars)) (cond ((zerop (cdr x))) ((minusp (cdr x)) (rplacd x (minus (cdr x))) ;if setq'ed only, make cnt + for pass 2 t) (nil)) (setq x (cond ((do y rnl (cdr y) (null y) (and (eq x (cdar y)) (return (caar y))) )) ;get variable of which this is the renaming,if there is one. ((car x)))) (cond ((memq x (cond ((eq f 'prog) p1psq) (t p1lsq))) (push x set-not-ref)) ;setq'ed but never referenced (t (push x unused))) ;not referenced at all ))) l) (cond ((eq f 'prog) (and unused (warn unused "- unused prog variables")) (and set-not-ref (warn set-not-ref "- prog variables setq'ed but never referenced"))) (t (and unused (progn (warn unused "- unused lambda variables") (mapc '(lambda (x) (rplacd (assq x locvars) cnt)) unused))) ;put dummy references on unused lambda variables ;to keep pass 2 from barfing. (and set-not-ref (warn set-not-ref "- lambda variables setq'ed but never referenced")))) (set ll (lsub (eval ll) unused)) ;remove unused vars but not setq'ed ^ref vars. )) (defun doexpander: (x) (prog (indxl endtst endval tg1 tg2 vars stepdvars vals prog-fcn declarations body prog-with-initial-values-p) (setq prog-fcn (cond ((eq (car x) map-do) map-prog) (t 'prog))) (cond ((and (car (pop x)) (atom (car x))) ;pop gets rid of "do" ; and checks for indxl of nil!!! (setq indxl (list (list (car x) (cadr x) (caddr x))) endtst (car (setq x (cdddr x))) endval nil)) (t (setq indxl (car x) endtst (car (pop x)) ) ;list of endtst,endval (cond (endtst ;normal 'do'? (setq endval (and (cdr endtst) ;yes, pick up end test and return values (cons 'progn (cdr endtst))) endtst (car endtst))) (t ;no, this is non-iterative do - prog with init values. (setq prog-with-initial-values-p t))) )) (setq stepdvars (mapcan '(lambda (x) (and (cdr x) (cddr x) (list x))) indxl)) (and stepdvars prog-with-initial-values-p (progn (warn stepdvars "will not be incremented because this is a non-iterative do") (setq stepdvars nil))) (pop x) (setq body (do ((bd x (cdr bd))) ((or (null bd) (atom (car bd)) (not (eq (caar bd) 'declare))) bd) (setq declarations (append declarations (cdar bd))))) ;make list of all clauses of all declares (cond ((not prog-with-initial-values-p) (setq tg1 (gentag)) (cond ((null endtst) (and endval (warn endval "will not be returned because of nil end test"))) (t (setq tg2 (gentag)))))) (mapc '(lambda (x) (push (car x) vars) (push (cadr x) vals)) indxl) (return `((lambda ,(nreverse vars) (declare . ,declarations) ;move user's declarations up to here (,prog-fcn () ;prog's lambdalist ,@(and tg2 `((go ,tg2))) ;put test at end ,@(and tg1 `(,tg1)) ,@ body ,@(and stepdvars (list (dostepr stepdvars))) ,@(and tg2 (list tg2)) ,@(and endtst `((cond (,endtst (return ,endval))))) ,@(and tg1 `((go ,tg1))))) . ,(nreverse vals))))) ;generate code to step all variables in parallel. (defun dostepr: (stepdvars) `(setq ,(caar stepdvars) ,(cond ((null (cdr stepdvars)) (caddar stepdvars)) (t `(prog1 ,(caddar stepdvars) ,(dostepr (cdr stepdvars))))))) (defun gentag: nil ((lambda (z) (putprop z t 'compiler-generated) z) (gensym) )) (defun let-expander (x) (nconc (list (append (list 'lambda (mapcar 'car (cadr x)))(cddr x))) (mapcar 'cadr (cadr x))))) (defun prog1-expander (x) (or (cdr x)(error "prog1 must have at least 1 argument" 'fail-act)) (list* 'prog2 ''0 (cdr x))) (defun cmp1: (supplied-forms) ; translate a file compiling those S-expressions which try to define functions. (catch (prog (x dectb fl form irasloss being-compiled compiler-state yet-to-compile fun informs) (setq compiler-state 'maklap informs supplied-forms) (setq irasloss (setq dectb '((*fexpr . fexpr) (*expr . expr) (*lexpr .expr)))) a (or (errset (setq form (cond (yet-to-compile (prog2 nil (car yet-to-compile) (setq yet-to-compile (cdr yet-to-compile)))) (supplied-forms (cond (informs (prog2 0 (car informs) (setq informs (cdr informs)))) (t (return nil)))) ;all done ((read))))) first-eof (progn (printmes nil "There is probably a missing "")""." nil) (or (null current-function) (equal current-function '(nil)) (printmes current-function "was the last thing compiled." nil)) (return nil))) (setq current-function '(nil) being-compiled nil) b (cond ((or nocompile ;dont look for anything (atom form) ;dont compile tl atoms (not (eq (car form) 'defun)) ;"Random" or macro form ;;MUST be defun at this point (getl 'defun '(macro *macro)) ;for Bawden.. let it fall thru to macro stuff )) ((memq (caddr form) '(fexpr expr macro)) (setq form (list 'defprop (cadr form) (cons 'lambda (cdddr form)) (caddr form)))) ((memq (cadr form) '(fexpr expr macro)) ; for alternate form of defun... (setq form (list 'defprop (caddr form) (cons 'lambda (cdddr form)) (cadr form)))) ((setq form (list 'defprop (cadr form) (cons 'lambda (cddr form)) 'expr)))) (cond ((atom form)) ;ignore atoms since no side effects to evaluation ((memq (setq fun (car form)) '(include %include includef)) ;interpreter (include %include) statement is changed to compiler include dcl. (cond (supplied-forms (barf form " - illegal during program-invoked compilation" nonfatal)) ((errset (let ((errset nil)) (eval form))) (push (namestring (names infile)) source-map) (eoffn infile ;succeeded - set up eoffn (function (lambda (a1 a2) ;check for eof-in-object, pop back to prev file (cond (first-eof (setq first-eof nil) a1 a2;hack for no msg t) ;go back & check for eof in the middle of an object. (t (setq first-eof t) ;really done nil) )))) ) ;cause (inpush -1) and continue ((printmes form "include file not found." 'data)) )) ((eq fun 'declare) (let ((current-function '(declare))) ;special (or (errset (mapc (function eval) (cdr form))) ;unless declarations lose, do them (go c))) ;and go to next expression in file (go a)) (nocompile (or (eq fun 'comment) (put-in-tree form))) ; if not compiling, just shove it through. ((and (eq fun 'defprop) (assq (setq fl (cadddr form)) indiclist)) (cond ((atom (setq current-function (cadr form)))) ; atom is ok. ((null (cdr current-function)) (setq current-function (car current-function))) ((null (cddr current-function)) (put-in-tree (cons 'defprop (cons (car current-function) (xcons (ncons (cadr current-function)) (setq current-function (gen-fcn-name))))))) (t (put-in-tree (cons 'defprop (cons (car current-function) (xcons (ncons (caddr current-function)) (setq current-function (gen-fcn-name)))))))) (setq undfuns (delq current-function undfuns)) (and (memq current-function ffvl) (go f)) (cond ((not (atom (caddr form))) (and expr-hash (setq yet-to-compile (cons (list 'defprop (cadr form) (sxhash (caddr form)) 'expr-hash) yet-to-compile))) (compile-fcn (setq being-compiled current-function) fl (caddr form) nil) (go a)) (t (and (setq x (getl current-function '(*expr *fexpr *lexpr))) (not (eq fl (cdr (assq (car x) dectb)))) (wrntyp current-function fl x)) (putprop current-function t (do x dectb (cdr x) (null x) (and (eq fl (cdar x)) (return (caar x))) )) (put-in-tree form)))) ((and (eq fun 'defprop) (eq (cadddr form) 'macro)) (and macros (put-in-tree form)) (cond ((getl (cadr form) '(expr fexpr subr fsubr lsubr *fexpr *expr *lexpr)) (putprop (cadr form) (caddr form) '*macro)) (t (eval form)))) ((cond ((eq fun 'array) (setq fl (cadr form)) t) ((and (eq fun '*array) (p1eqqte (cadr form))) (setq fl (cadadr form)) t)) (putprop fl t '*array) ;give *array property since code to set up array at run time was seen (and (memq (setq current-function fl) ffvl) (go f)) (put-in-tree form)) ((and form (atom fun) (setq fl (cadr (getl fun '(macro *macro))))) (cond ((and (symbolp fl)(cadr (getl fl '(macro *macro)))) (setq fl (p1-chase-linked-macros fl)))) (cond ((or (null (errset (setq irasloss (funcall fl form)))) (eq irasloss dectb)) (go c)) (irasloss (setq form irasloss) (go b)))) ;apply macro property and try again ((eq fun 'comment)) ;no need to keep comments around ((and (eq fun 'progn) (equal (cadr form) ''compile)) ;; tack code on front of list so it will be compiled first (setq yet-to-compile (append (cddr form) yet-to-compile))) ((and (eq fun 'eval-when)(cdr form)) (cond ((memq 'load (cadr form)) ;; tack code on front of list so it will be compiled first (setq yet-to-compile (append (cddr form) yet-to-compile)))) (cond ((memq 'compile (cadr form)) (or (let ((current-function '(eval-when))) (errset (mapc 'eval (cddr form)))) (go c))))) (t (put-in-tree form))) (go a) ;;; ;;; Top level evaluation has lost ;;; c (let ((^r nil)(^w nil)) (apply 'ioc messioc) (princ " lisp_compiler: lisp error during declaration or macro expansion at top level; the losing form is ") (prinb form 5. 20.) ;display the losing form but limit the amount of typeout (terpri) (cond (dataerrp (princ "Please correct and type $p") (break dataerrp t) )) (go a)) f (barf current-function "has previously been compiled as a free functional variable - you will lose!" data)) e-o-f) ;end of catch way back there (or check (finish-code)) ;;;moved to before eoc-eval 5/4/80 (mapc '(lambda (x) (or (errset (eval x)) (barf x " - losing form in eoc-eval." nonfatal))) eoc-eval) t) (defun cl: fexpr (l) ; compile a list of functions given by atom name. (let ((data nil) (barfp t) (eoc-eval nil) (constant-list nil) (pc)(seg-name "[pd]>!lcp-scratch!")(codelist) (functions-called)(functions-defined)(labels-to-define)(being-compiled)) (or check (init-code-generator)) (mapcar (function (lambda (j) (cond ((setq data (getl j '(expr fexpr))) (compile-fcn (setq being-compiled j) (car data) (cadr data) nil))))) l) (or check (finish-code)))) (defun compile-top-level-forms (forms segnam) ;5/4/80 (let ((data nil) (barfp nil) (eoc-eval nil) (constant-list nil) (pc)(seg-name "[pd]>!lcp-scratch!")(codelist)(check check) (functions-called)(functions-defined)(labels-to-define)(being-compiled)) (cond (segnam (setq seg-name segnam))(t (setq check t))) (or check (init-code-generator)) (cmp1 forms))) (defun cf: (x) (prog (start-time start-runtime start-paging line tem ^w ^q ^r current-function eoc-eval pc codelist constant-list functions-called functions-defined labels-to-define) ;for pass 2 (or (errset (setq infile (openi x))) (go nofile)) (setq source-map (list (namestring (names infile)))) (setq first-eof t) (eoffn infile (function (lambda (a1 a2) (cond (first-eof (setq first-eof nil) a1 a2 t) ;retry in case eof in obj ((throw nil e-o-f)) )))) (setq seg-name ; strip ".lisp" suffix (let ((names-infile (names infile))) (cond ((eq (car (last names-infile)) 'lisp) (do ((split (cdr (reverse (cdr names-infile))) (cdr split)) (answer nil (list* "." (car split) answer))) ((null (cdr split)) (apply 'catenate (cons (car split) answer))))) (t (get_pname (cadr names-infile)))))) (setq start-time (status daytime)) (setq start-runtime (cond (total-time (runtime)) (t 0)) start-paging (status paging)) (ioc rq) (or check (init-code-generator)) c (cond ((atom (setq tem (errset (cmp1 nil)))) ;compile some function definitions (setq ^q t ^w nil ^r t line (cons (cond ((symbolp current-function) current-function) (t '-????-)) line)) (cond ((null tem) ((lambda (^r ^w) (apply 'ioc messioc) (princ " *** LISP ERROR WHILE COMPILING ") (princ current-function) (princ " The error message from Lisp appears above. ") (break barfp barfp) ;in debug mode , let user fiddle. (go c)) nil nil) )) (go c))) ;keep on compiling the file (ioc svt) ;switch all i/o to tty (and line (printmes (sort line 'alphalessp) "- failed to compile." nil)) (and undfuns (printmes (sort undfuns 'alphalessp) "- functions referenced but not defined." nil)) (close infile) (and total-time (let ((base 10.)(*nopoint t)) ;print compiling statistics (princ " Compilation finished. Elapsed time = ") (pr-time (let ((a (mapcar 'difference (status daytime) start-time))) (let ((c (caddr a))(b (cadr a))(a (car a))) (and (minusp c) (setq c (+ c 60.) b (1- b))) (and (minusp b) (setq b (+ b 60.) a (1- a))) (and (minusp a) (setq a (+ a 24.))) ;if we crossed a midnight, patch it up. ;;3-day compilations will still lose. (list a b c)))) (princ ", runtime = ") (prin1 (//$ (float (setq start-runtime (difference (runtime) start-runtime))) 1000000.0)) (princ ", paging = ") (prin1 (car (setq tem (mapcar (function difference) (status paging) start-paging)))) (princ " + ") (prin1 (cadr tem)) (princ " ") (prin1 (list (// (* (cadr tem) 1000000.) start-runtime))) ;paging rate in parentheses (princ ", gc time = ") (prin1 (//$ (float (status gctime)) 1000000.0)) (princ " (") (prin1 (// (* 100. (status gctime)) start-runtime)) (princ "%)") (terpri))) (return nil) nofile (barf x " - file not found." nonfatal) )) (defun pr-time: (3list) ;routine to print out a time ;called with base = 10., (status *nopoint) = t (pr-tim1 (car 3list)) (tyo 72) ; ":" (pr-tim1 (cadr 3list)) (tyo 72) (pr-tim1 (caddr 3list)) ) (defun pr-tim1: (x) ;print 2 digit number with leading zero (and (lessp x 10.) (tyo 60)) ;put leading zero if needed (prin1 x)) (defun command-interface: () ; interpret the arguments of the 'lisp_compiler xxx -opt' command (setq errlist '((init1))) ; we only want to get called once (terpri) (prog (i arg file hold listing-desired seg-name long-listing) (setq long-listing "-brief") ; default is short listing (setq i 1) nextarg (or (setq arg (status arg i)) (go last-arg)) ; go if no more arguments to do (cond ((equal (substr (get_pname arg) 1 1) "-") ; process an option (cond ((memq arg '(-pathname -pn -p)) (setq file (absolute_pathname_ (status arg (setq i (1+ i))))) (cond ((= 0 (cadr file)) (setq file (car file))) (t (com_err_$one-arg (cadr file) "lisp_compiler" "^a" (status arg i)) (quit)))) ((memq arg '(-db -debug)) (debug t)) ((eq arg '-eval) (eval (readlist (exploden (status arg (setq i (1+ i))))))) ((memq arg '(-tm -time -times)) (setq time-option t total-time t ^d t)) ((memq arg '(-tt -total -total_time)) (setq total-time t)) ((memq arg '(-ps -pause)) (setq pause t)) ((eq arg '-pause_at) (setq pause-at (readlist (exploden (status arg (setq i (1+ i)))))) (and (atom pause-at) (setq pause-at (ncons pause-at)))) ((memq arg '(-nw -nowarn)) (setq nowarn t)) ((memq arg '(-mc -macros)) (setq macros t)) ((eq arg '-all_special) (setq special t)) ((memq arg '(-gp -gnp -genprefix)) (eval (list 'genprefix (status arg (setq i (1+ i)))))) ((memq arg '(-ck -check)) (setq check t)) ((eq arg '-ioc) (eval (list 'ioc (status arg (setq i (1+ i)))))) ((memq arg '(-list -ls)) (setq listing-desired t)) ((memq arg '(-long -lg)) (setq long-listing "")) ((memq arg '(-messioc -mioc)) (setq messioc (list (status arg (setq i (1+ i)))))) ((memq arg '(-hd -hold)) (setq hold t)) ;remain in lisp after compiling ((memq arg '(-no_compile -ncp)) (setq nocompile t)) ; don't interpret defun's and defprop's in file ((memq arg '(-pedigree -pdg)) (let ((obarray cobarray)) ;for autoload (historian)(quit))) ; print history and exit (t (princ "lisp_compiler: Unrecognized control argument ") (princ arg) (princ " has been ignored.") (terpri)) )) ((null file) (setq file (absolute_pathname_$add_suffix arg "lisp")) (cond ((= 0 (cadr file)) (setq file (car file))) (t (com_err_$one-arg (cadr file) "lisp_compiler" "^a" arg) (quit)))) (t (princ "lisp_compiler: extra argument has been ignored: ") (princ arg) (terpri) )) (setq i (1+ i)) (go nextarg) last-arg (and (null file) (return nil)) ; if no file specified, enter lisp so he can use cf (let ((minf-result (hcs_$status_minf file "" 1))) ; check that file is OK (cond ((not (= 0 (caddr minf-result))) ; not found? (com_err_$one-arg (caddr minf-result) "lisp_compiler" "^a" file) (quit)) ((not (= 1 (car minf-result))) ; a link or directory (com_err_$one-arg 0 "lisp_compiler" "^a is not a file." file) (quit)) ((= 0 (cadr minf-result)) ; bit count zero (com_err_$one-arg 0 "lisp_compiler" "Zero-length file: ^a" file) (quit)))) (princ (catenate "Lisp Compiler " compiler-revision))(terpri) ; announce ourselves (cf file) ; compile file (and listing-desired ; if -list option used, call make_lisp_listing (make_lisp_listing seg-name long-listing)) (or hold (quit)) ; quit unless -hd option was given )) (defun printmes: (w msg warn) (or (and nowarn ;suppress warning s if called with the -nowarn option (or (null warn) (eq warn 'warn))) ((lambda (^r ^w) (apply 'ioc messioc) (or warn (setq ^r nil)) ;suppress output of random msgs to the defsubr file (and warn being-compiled (progn (terpri) (princ "*** DIAGNOSTICS FOR ") (princ (cond ((boundp 'being-compiled) being-compiled) (t '(???)))) (terpri) (setq being-compiled nil))) ;so this header is only printed once per function in error. (or (zerop (charpos t)) (terpri)) ;get to left margin (princ (cdr (assq warn '( ;put message prefix (warn . "Warning: ") (nonfatal . "Error: ") (data . "Severe Error: ") (barf . "Compiler Error: ") (nil . "lisp_compiler: ") )))) (cond (w (cond (warn (prinb w 5. 20.)) ((prin1 w))) (tyo 40))) ;if there is a datum, print it ;but limit the length of the output. (prinst msg) ;print out the message (terpri) (cond ((and warn (not (eq warn 'warn))) (cond ((eq warn 'data) (and dataerrp (princ "; data error - to proceed type $p ") (break data t)) (err 'data)) ; ??????? ((eq warn 'nonfatal) (setq errflag t) ;so pass2 will be suppressed (and dataerrp (princ ";data error - to proceed type $p ") (break data t))) (t (princ " %%%%%%%% compiler error - contact the compiler maintenance persons %%%%%%%%") (break barf barfp) (err 'barf))))) nil ;no value in particular ) nil nil))) (defun prinst: (x) ;print string with line breaking between words (cond ((< (stringlength x) (chrct t)) ;if room on line, (princ x)) ;print it (t ;otherwise, find place to break (do ((a (chrct t) (1- a))) ;which is last space before chrct ((or (signp le a) (= (getcharn x a) 40)) (and (signp g a) (princ (substr x 1 (1- a)))) ;print part on this line (terpri) ;and on next line, (prinst (substr x (1+ a))) ))))) ;the rest (defun prinb: (x nlevels atom-cnt) ;print with limited output - for printmes (cond ((atom x) (prin-atom x) (setq atom-cnt (1- atom-cnt))) ((zerop nlevels) (princ "(...)") ;suppress if too deep in nesting (setq atom-cnt (1- atom-cnt))) ;count as atom since takes up space on printout (t (princ "(") ;output a list... (catch (map '(lambda (x) (cond ((zerop atom-cnt) (princ "...") ;if end of output, (throw nil)) ;tell user & leave (t (setq atom-cnt (prinb (car x) (1- nlevels) atom-cnt)) (and (cdr x) (tyo 40) ;if more, space (atom (cdr x)) (progn ;dotted pair (princ ". ") (cond ((zerop atom-cnt) (princ "...")) (t (prin-atom (cdr x)) (setq atom-cnt (1- atom-cnt)))) (throw nil) ))))) x)) (princ ")") )) atom-cnt) ;must return this to caller, so he can update his copy. (defun prin-atom: (x) ;routine to print an atom for printmes - knows about renaming. ((lambda (y) (and y (progn ;x is renamed version of y (and barfp ;in debug mode,... (princ x) ;explain what's going on. (princ '=)) (setq x y)))) ;and change atom to print to user's name for it (get x 'rename)) (prin1 x)) (defun put-in-tree: (x) (push (cons nil x) functions-defined)) (defun nargs: (name) ((lambda (n) (and n (numberp (cdr n)) (cdr n))) (cond ((get name 'args)) ; if we put an args property on, get it now. ((getl name '(*fexpr *lexpr *expr *array)) nil) ; if user declared the function, don't look at system args \prop. ((sysp name) (args name))) )) ; if system function, get its args property. (defun ckargs (name fl force) ;check out args prop (let ((n (nargs name))) (cond ((null n) (putprop name (cons nil fl) 'args)) ((= n fl)) (force (warn name "has been previously used with the wrong number of arguments") (putprop name (cons nil fl) 'args)) (t (barf name "wrong number of args" data))))) (defun wrntyp: (name def-prop prev-prop-cons) (cond ((not (eq t (cadr prev-prop-cons))) ;if it was explicitly declared (warn (list (car prev-prop-cons) name) "declaration does not agree with definition.")) ((warn (list def-prop name) "declaration required because this function is referenced before it is defined."))) (lremprop name '(*expr *fexpr *lexpr args) )) (defun lremprop: (name l) (mapc '(lambda (x) (remprop name x)) l)) ; functions for declaring variables and specifying compiler options ;;;function to cause the compiler to stop at various places: ;;; nil stop nowhere ;;; t stop everywhere ;;; f00 stop while compiling f00 ;;; (a b c) stop while compiling one of a, b, c. (defun pause: (x) (cond ((null x) (setq pause nil pause-at nil)) ((eq x t) (setq pause t)) ((atom x) (setq pause-at (list x))) (t (setq pause-at x)))) (defun macros: (x) (setq macros x)) ;copy macro definitions into defsubr file (defun noargs: (x) x) ;dummy, for compat. (defun mapex: (x) (cond (x t) ;mapex t is ok. ((warn nil "(mapex nil) is not supported.")))) ;but not mapex nil (defun system-file: (x) (setq system-file x)) (defun expr-hash: (x) (setq expr-hash x)) (defun nocompile: (x) (setq nocompile x)) (defun symbols: fexpr (x) x) ;dummy, for compat. (defun genprefix: fexpr (x) (setq genprefix (exploden (car x)))) ;set prefix for generated fcn names, initially "!g" (defun *declare: (x y) (do x x (cdr x) (null x) (and (memq (car x) undfuns)(setq undfuns (delq (car x) undfuns))) (putprop (car x) 'dcl y))) (defun special: fexpr (x) (*declare x 'special)) (defun unspecial: fexpr (x) (do x x (cdr x) (null x) (remprop (car x) 'special))) (defun reducible: fexpr (x) (*declare x 'reducible)) (defun *reducible: fexpr (x) (mapc '(lambda (x) (putprop x 'system 'reducible)) x) x) ;for default reducible fcns (defun irreducible: fexpr (x) (mapc '(lambda (x) (remprop x 'reducible)) x) x) (defun *expr: fexpr (x) (*declare x '*expr) (*unarith x)) (defun *fexpr: fexpr (x) (*declare x '*fexpr) (*unarith x)) (defun *lexpr: fexpr (x) (*declare x '*lexpr) (*unarith x)) (defun **array: fexpr (x) (*declare x '*array) (*unarith x)) (defun *unarith: (x) (mapc '(lambda (x) (remprop x 'numfun)) x) x) ;;;declarations for the "number compiler." (defun fixnum: fexpr (x) (*arith x 'fixnum)) (defun flonum: fexpr (x) (*arith x 'flonum)) (defun notype: fexpr (x) (*arith x nil)) (defun *arith: (list prop) ;makes number dcls (mapc '(lambda (item) (cond ((atom item) (putprop item prop 'number)) ((and (eq prop 'notype) ;check for undeclaration (null (cdr item))) (remprop (car item) 'numfun)) (t ;declaration of function (putprop (car item) (cons prop (subst nil 'notype (cdr item))) 'numfun) ))) list) t) (defun messioc: fexpr (f) (setq messioc (list (car f)))) (defun check: (x) (setq check x)) (defun debug: (x) ;set flags for debugging compiler (setq dataerrp x barfp x pause x) (setq errset (and x '(lambda (args) (break errset t)))) (*rset x) (nouuo x) (and x (sstatus uuolinks)) ;debug t => want to be able to baktrace ) (defun fixsw: (x) (and (setq fixsw x) (setq flosw nil)) x) ;can't both be on (defun flosw: (x) (and (setq flosw x) (setq fixsw nil)) x) ;can't both be on (defun eoc-eval (x) (setq eoc-eval (cons x eoc-eval))) (defun array*: fexpr (x) ;for declaring "number arrays" (mapc '(lambda (x) ((lambda (type dcls) (or (memq type '(fixnum flonum notype)) (barf x "bad array declaration" data)) (do ((dcl dcls (cdr dcl)) (ndims) (array)) ((null dcl)) (cond ((atom (car dcl)) ;old style (setq array (car dcl) dcl (cdr dcl) ndims (car dcl)) (and (or (not (numberp ndims)) (not (pnamep array))) (barf x "bad array* declaration" data)) ) (t ;new style (setq array (caar dcl) ndims (length (cdar dcl))) (putprop array (mapcar '(lambda (x) (and (numberp x) x)) (cdar dcl)) 'array*))) (putprop array 'dcl '*array) (putprop array (cons nil ndims) 'args) (apply type (list (cons array (n-fixnums ndims)))) ;do fixnum, flonum, or notype declaration (hack) )) ;end do, lambda (car x) (cdr x))) ;end lambda x) ;end mapc t) ;end defun (defun n-fixnums: (n) ;make list of n repetitions of 'fixnum (do ((i n (1- i)) (x nil (cons 'fixnum x))) ((zerop i) x) )) (defun arith: fexpr (x) ;declares intrinsic functions of general arithmetic kind to be of specific kind ;e.g. declares add1 to be like 1+ (mapc '(lambda (x) (or (memq (car x) '(fixnum flonum notype)) (barf (car x) "bad type in arith declaration" data)) (do ((item (cdr x) (cdr item)) (tem)) ((null item)) (cond ((eq (car x) 'notype) (remprop (car item) 'arith)) ((setq tem (assq (car item) fixfns)) (putprop (car item) (cdr tem) 'arith)) ((setq tem (assq (car item) flofns)) (putprop (car item) (cdr tem) 'arith)) ((warn (car item) "non-arithmetic function in arith declaration")) ))) x) t) ;;;more silly number declarations (defun closed: (x) (setq closed x)) (defun muzzled: (x) (warn nil "muzzled declaration not implemented") x) (defun defpl1: fexpr (x) ;the defpl1 declaration compiles a "pl1 subr" (do ((args nil) ;list of gensyms for input/update args (temps nil) ;list of gensyms for return args (values nil) ;initial-values list for temps (*unmkd-push 0) ;number of words used on unmkd pdl (*unpack-ptrs nil) ;list of unmkd cell, arg gensym to unpack into it (*pack-ptrs nil) ;list of unmkd cell, gensym to be packed out of it (*c*ret nil) ;cons of gensym and ret char (*) cell addr (fn (car x)) ;lisp name of the function (extname (cadr x)) ;PL/I name of the function (setqs nil) ;list of temp gensym, special var to setq to it (results nil) ;list of temp gensyms to be returned (argdescs nil) ;list of 4-lists to be passed on to pass 2 ;describing each arg (ermsg) )() (setq undfuns (delq (setq current-function fn) undfuns)) (and (equal extname "") (setq extname (get_pname fn))) (or (stringp extname) (barf extname "is not a valid external name - defpl1" data)) (and (setq ermsg (catch ;catch barfage (do ((x (cddr x) (cdr x)) ;map down the arg dcl's (z (gensym) (gensym)) ;name for arg/temp of this argument (argtype nil nil) ;how passed (datatype nil nil) ;lisp datatype (datalength nil nil) ;precision or length (arraytype nil nil) ;nil if scalar, ndims if array (descrip)) ;PL/I descriptor image ((null x) nil) (do ((xl (car x) (cdr xl)) ;map down arg attributes (last? (cdr x)) (x)) ;x is an attribute ((null xl)) (setq x (car xl)) (cond ((or (eq x 'update) (eq x 'return)) (and (or argtype datatype) (throw "update or return attribute must come first - defpl1")) (setq argtype x x (cadr xl)) ;check for options on how to return (cond ((eq x 'ignore) (setq xl (cdr xl))) ((and (not (atom x)) (eq (car x) 'setq)) (setq xl (cdr xl)) (push (cadr x) setqs) (push z setqs)) ((push z results)))) ((memq x '(fixed float)) (and (or (eq (cadr xl) 'binary) (eq (cadr xl) 'bin)) (setq xl (cdr xl))) ;gobble up bin after fixed (cond ((atom (cadr xl)) ;no more stuff? (setq datalength (cond ((eq x 'fixed) 17.) (t 27.)))) (t ;accept precision attribute (setq datalength (caadr xl) xl (cdr xl)) (and (or (not (smallnump datalength)) (< datalength 1) (> datalength (cond ((eq x 'fixed) 35.) (t 27.) ))) (throw "incorrect arithmetic precision specified - defpl1" barf)))) (setq datatype (cond ((eq x 'fixed) 'fixnum) (t 'flonum))) (setq descrip (logor datalength (lsh (cond ((eq x 'fixed) 1) (3)) 29.)))) ((memq x '(packed-pointer packed-ptr)) (setq datatype 'fixnum descrip (lsh 27. 28.))) ((memq x '(pointer ptr)) (setq datatype 'pointer descrip (lsh 26. 28.)) (setq *unmkd-push (+ 2 *unmkd-push)) ;expansion space (or (eq argtype 'return) ;if input, unpack (progn (push z *unpack-ptrs) (push (- *unmkd-push) *unpack-ptrs))) (and argtype ;if output, pack (progn (push z *pack-ptrs) (push (- *unmkd-push) *pack-ptrs)))) ((eq x 'bit) ;bit string = fixnum (and (or (atom (cadr xl)) ;pick up length (not (smallnump (setq datalength (caadr xl)))) (> datalength 36.)) (throw "incorrect bit string length specified - defpl1" barf)) (setq datatype 'fixnum xl (cdr xl) descrip (logor datalength (lsh 19. 29.)))) ((eq x 'aligned) (setq descrip (boole 4 descrip (lsh 1 28.)))) ;unpacked ((eq x 'unaligned) (setq descrip (logor descrip (lsh 1 28.)))) ;packed ((memq x '(character char)) (setq xl (cdr xl) x (caar xl)) ;fetch length (setq descrip (logor (lsh 21. 29.) (cond ((eq x '*) 77777777) (x)))) (cond ((and (eq x '*) (eq argtype 'return)) (and last? (throw "defpl1- returns char (*) must be last parameter" barf)) (setq datatype 'ret-char-*) (setq *unmkd-push (+ 4 *unmkd-push)) (setq *c*ret (cons z (- *unmkd-push)))) ((eq datatype 'varying-string) (or (numberp x) (throw "for char varying a length must be specified" barf)) (setq datalength x)) (t (setq datatype 'string datalength x)) )) ((eq x 'varying) (cond ((eq datatype 'string) (setq datatype 'varying-string) (or (numberp datalength) (throw "for char varying a length must be specified" barf))) (t (setq datatype 'varying-string)))) ((eq x 'lisp) ;raw lisp object (setq datatype 'lisp descrip 010000000107)) ;looks like fixed bin(71) ((eq x 'array) ;array of other frobs (and argtype (throw "arrays are passed by reference and so may not be update or return - defpl1" barf)) (setq xl (cdr xl)) ;fetch bounds (setq arraytype (length (car xl)))) ;but all we want is ndims ((throw "unrecognized attribute - defpl1" barf))) ;error - bad word ) ;close do (setq descrip (logor descrip (lsh 1 35.))) ;turn on high order bit in descriptor (cond ((eq argtype 'return) ;put z on proper var list (push z temps) (push (cond ((eq datatype 'string) (list '*cons-string datalength)) ((eq datatype 'ret-char-*) "") ((eq datatype 'varying-string) "") ((eq datatype 'fixnum) 0) ((eq datatype 'flonum) 0.0) ((eq datatype 'pointer) 0) (t nil)) values)) (t (push z args))) ; Form an argdesc 4-list out of datatype, datalength, arraytype, and descrip (push (cond ((null arraytype) ;scalar (and (memq datatype '(string varying-string)) ;a string needs a descriptor cell (setq *unmkd-push (+ 2 *unmkd-push))) (list ;first: addressing type (cond ((eq datatype 'pointer) 'unmkd) ;unpacked ptr on pdl ((eq datatype 'string) 'string) ;string - make descr ((eq datatype 'varying-string) 'varying-string) ;varying string make it ((eq datatype 'lisp) nil) ;lisp object - addr ((eq datatype 'ret-char-*) 'ret-char-*) (t '1+)) ;number - addr + 1 z ;second: the local var involved (cond ((eq datatype 'varying-string) datalength) (t descrip)) ;third: the descriptor image ;fourth: unmkd pdl cell (cond ((eq datatype 'pointer) ;pdl cell involved (do x (append *unpack-ptrs *pack-ptrs) (cddr x) (null x) (and (eq (cadr x) z) (return (car x))))) ((eq datatype 'ret-char-*)(cdr *c*ret)) (t (- *unmkd-push))))) (t ;array (setq *unmkd-push (+ *unmkd-push ;alloc space for array descriptor (* 2 (// (+ 2 (* 3 arraytype)) 2)))) (list 'array ;first: addressing type z ;second: local var (logor ;third - typeword image (lsh (cdr (or (assq datatype '((fixnum . 2) (flonum . 3) (lisp . 0))) (throw "non-arrayable type - defpl1" barf))) 18.) arraytype) (- *unmkd-push) ))) ;fourth: the pdl cell argdescs) ;end of moby push ) ;end of mobyier do barf)) ;end of catch (barf x ermsg data)) ; cons up the expression for the interface function and feed it to the compiler (setq *unmkd-push (+ *unmkd-push (+ 2 (* 4 (length argdescs))))) ;alloc space for argument list (compile-fcn (setq being-compiled fn) ;name 'expr ;type (list 'lambda (reverse args) ; the form (cons (append (list 'lambda (reverse temps) ;lambda-bind the result temps ;without generating any code (list '*unmkd-push *unmkd-push) ;allocate unmkd pdl space (and *unpack-ptrs ;prepare any unpacked pointer arguments (cons '*unpack-ptrs (nreverse *unpack-ptrs))) (list* (cond (*c*ret '*pl1call-nopop)(t '*pl1call)) ;make the call (- *unmkd-push) ;(where to put arg list) extname (nreverse argdescs)) (and *pack-ptrs (cons '*pack-ptrs (nreverse *pack-ptrs))) ;prepare any unpacked pointer results (and *c*ret (list '*rcv-char-* (car *c*ret)(cdr *c*ret))) (list '*unmkd-pop *unmkd-push) ;clear unmarked pdl (and setqs (cons 'setq (nreverse setqs)))) ;setq special-var results args ;fake out compiler temps ;unused variable message (cond ((= (length results) 1) results) ;return result, nil, or list of results (t (ncons (cons 'list (nreverse results)))))) (nreverse values))) ;rest of lambda-binding of temps nil) ;last arg to compile is initial rnl (setq being-compiled '(declare)) ) ;end of do to bind variables ) ;end of defun defpl1 ; functions stolen from pass 2 (defun lsub: (l ll) (cond ((null ll) l) (((lambda (dev) (luz l)) ll)))) (defun luz: (x) ;list difference x - dev (cond ((null x) nil) ((memq (car x) dev) (luz (cdr x))) ((cons (car x) (luz (cdr x)))))) (defun bool1able: (x) ;Note: numberp, fixp, floatp should be bool1able when they return t. <, >? (and (not (atom x)) (or (memq (car x) '(and or null not eq = zerop cond memq signp plusp minusp atom stringp subrp)) (and (eq (car x) 'progn) (bool1able (car (last x)))) (and (eq (car x) 'prog2) (null (cdddr x)) (bool1able (caddr x)))))) (defun add: (x y) (cond ((memq x y) y) (t (cons x y)))) (defun ladd: (l ll) (cond ((null l) ll) ((ladd (cdr l) (add (car l) ll))))) ;;;declare numeric-result properties of system functions. (fixnum (*) (+) (-) (//) (1+) (1-) (\) (\\)) (fixnum (CtoI)) (fixnum (absfix/!)) (fixnum (boole)) (fixnum (chrct) (linel) (pagel) (linenum) (pagenum) (charpos)) (fixnum (filepos)) (fixnum (flatc) (flatsize)) (fixnum (index)) (fixnum (isqrt)) (fixnum (length)) (fixnum (lsh)) (flonum (fsc)) (fixnum (ifix flonum)) (fixnum (random)) (fixnum (rot)) (fixnum (stringlength)) (fixnum (sxhash)) (fixnum (runtime)) (fixnum (tyipeek) (listen)) ;can't put in tyi due to end of file kludge (flonum (*$) (+$) (-$) (//$) (1+$) (1-$)) (fixnum (^ fixnum fixnum)) (flonum (^$ flonum flonum)) (flonum (abs$)) (flonum (atan)) (flonum (cos) (sin)) (flonum (exp)) (flonum (expt$)) (flonum (float)) (flonum (log)) (flonum (time)) (flonum (sqrt)) (fixnum (getcharn)) ;;;declare types of system variables (fixnum base ibase) (declare (eval (read))) (sstatus macro /: nil) ;at this point in loading of .defs file, initialize global variables (initialize) (defun cv-date- (x) (do ((ml '(January February March April May June July August September October November December)(cdr ml)) (yr (+ 1900. (car x))) (mx 1 (1+ mx)) (dy (caddr x))) ((= (cadr x) mx) ((lambda (base *nopoint) (catenate (car ml) " " (maknam (exploden dy)) ", " (maknam (exploden yr)))) 10. t)))) (setq compiler-version (catenate "Multics LISP Compiler, Version " compiler-revision ", " (cv-date- (status date)))) ;;; Hack by BSG 1/20/80 inspired by JONL's in COMPLR, to keep ;;; compiler bootstrap history; but mine will live and grow for eternity. (declare (defun get-compiler-history-variable (x) (let ((obarray obarray)) (use c) (let ((var (intern (copysymbol x nil)))) (cond ((boundp var)(symeval var)) (t nil))))) (read)) ;;interpreter only (defun get-compiler-history-variable (x) 'Interpreter) (defun semant-signature-history-macro macro (x) ;backquoted 4/24/81 `(setq semant-compile-date '(,(status date) ,(status daytime)) semant-compiler-history ',(or (get-compiler-history-variable 'compiler-history) (get-compiler-history-variable 'compiler-version)))) (semant-signature-history-macro) (declare (special compiler-history compiler-version semant-compile-date semant-compiler-history cg-compile-date cg-compiler-history)) (defun record-compiler-history () (mapc '(lambda (x)(or (boundp x)(set x '??))) '(semant-compile-date semant-compiler-history cg-compile-date cg-compiler-history)) (setq compiler-history `(,compiler-version ;This save date (lcp_semant_ ,(history-date-encode semant-compile-date) ,semant-compiler-history) (lcp_cg_ ,(history-date-encode cg-compile-date) ,cg-compiler-history)))) (defun history-date-encode (triplet-list) (let ((l (mapcar '(lambda (triplet) (+ (* 64. 64. (car triplet)) (* 64. (cadr triplet)) (caddr triplet))) triplet-list))) (cons (car l)(cadr l))))  lisp_cg_utility_.pl1 07/06/83 0936.2r w 06/29/83 1541.4 255663 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* protect old protection notice */ /* (c) Copyright 1973, Massachusetts Institute of Technology. All rights reserved. */ lisp_cg_utility_: /* procedure to make object segment for lisp compiler */ procedure(a_segname, a_codelist, gen_version, source_seg_list, fixnum_list, flonum_list, string_list, bignum_list, atsym_list, cons_list, entry_list, constant_list, link_list, action_list, array_link_list, pl1_link_list); /* makes the obj seg out of various lists */ /* D. Reed 11/11/72 */ /* Modified 74.06.14 by DAM for new arrays. This adds one more argument */ /* again 74.09.29 by DAM for the defpl1 feature. This provides the ability to create links and have relocatable text */ /* modified 74.11.14 by DAM to make relocation work properly and to be called via defpl1, which eliminates any number of bugs */ dcl a_segname char(*) parameter, segname char(length(a_segname)) init(a_segname), gen_version char(*) parameter, a_codelist fixed bin(71) parameter, a_codelist_p pointer aligned based(addr(a_codelist)), source_seg_list fixed bin(71) parameter, source_seg_list_p pointer aligned based(addr(source_seg_list)), fixnum_list fixed bin(71) parameter, fixnum_list_p pointer aligned based(addr(fixnum_list)), flonum_list fixed bin(71) parameter, flonum_list_p pointer aligned based(addr(flonum_list)), string_list fixed bin(71) parameter, string_list_p pointer aligned based(addr(string_list)), bignum_list fixed bin(71) parameter, bignum_list_p pointer aligned based(addr(bignum_list)), atsym_list fixed bin(71) parameter, atsym_list_p pointer aligned based(addr(atsym_list)), cons_list fixed bin(71) parameter, cons_list_p pointer aligned based(addr(cons_list)), entry_list fixed bin(71) parameter, entry_list_p pointer aligned based(addr(entry_list)), constant_list fixed bin(71) parameter, constant_list_p pointer aligned based(addr(constant_list)), link_list fixed bin(71) parameter, link_list_p pointer aligned based(addr(link_list)), action_list fixed bin(71) parameter, action_list_p pointer aligned based(addr(action_list)), array_link_list fixed bin(71) parameter, array_link_list_p pointer aligned based(addr(array_link_list)), pl1_link_list fixed bin(71) parameter, pl1_link_list_p pointer aligned based(addr(pl1_link_list)); dcl codelist fixed bin(71) automatic, codelist_p pointer aligned based(addr(codelist)); dcl cleanup condition; dcl object_pointer ptr, def_ptr ptr, defsect ptr, link_ptr ptr, link_head_ptr ptr, symbol_ptr ptr, rel_bits_ptr ptr, map_ptr ptr, area_top ptr, blockp ptr, thingp ptr, symrtp ptr, total_objects fixed bin(18), total_block_size fixed bin(18), codeitem fixed bin(71), rh_reloc fixed bin(5), relbits_length fixed bin(18), absolute_counter fixed bin(18), link_list_count fixed bin, link_list_ptr pointer, (segmentname, entryname) char(32) varying, (segmentname_relp, entryname_relp) bit(18), segname_length fixed bin, def_length_in_words fixed bin(18), text_length fixed bin(18), ic fixed bin(18), stat_length fixed bin(18), def_length fixed bin(18), code fixed bin(35), acinfo ptr init(null()), last_def bit(18), next_def bit(18), (lcp_semant_$symbol_table, lcp_cg_$symbol_table) ext fixed bin, text_section dim(0:262143) bit(36) aligned based (object_pointer), 1 word_overlay based aligned, 2 typ_information bit(36) aligned, 2 word bit(36) aligned, 1 def_hdr based(def_ptr) aligned, 2 def_list bit(18) unal, 2 unused bit(36) unal, 2 flags like definition.flags unaligned, 2 the_rest bit(3) unal, 2 end_chain bit(36) unal, /* zero word to end the definition chain. */ 2 segname_def like definition aligned, 1 definition based(def_ptr) aligned, 2 fore_thread bit(18) unal, 2 back_thread bit(18) unal, 2 value bit(18) unal, 2 flags unal, 3 new_format bit(1), 3 ignore bit(1), 3 entrypoint bit(1), 3 retain bit(1), 3 descr_sw bit(1), 3 padding bit(10), 2 class bit(3) unal, 2 symbol_ptr bit(18) unal, 2 segname_ptr bit(18) unal, 2 symbol aligned, 3 len fixed bin(8) unal, 3 acc char(512) unal, /* can't use refer here... */ 1 accstring based aligned like definition.symbol, 1 link_hdr based(link_ptr) aligned, 2 fword bit(36), 2 def_section bit(18) unal, 2 first_reference bit(18) unal, 2 section_thread ptr, 2 linkage_ptr ptr, 2 begin_links bit(18) unal, 2 section_length bit(18) unal, 2 object_seg bit(18) unal, 2 combined_length bit(18) unal, 2 internal_static dim(0:262135) bit(36) aligned, 1 symbol_block based(symbol_ptr) aligned, 2 dcl_vers fixed bin, 2 identifier char(8), 2 gen_version_number fixed bin, 2 gen_creation_time fixed bin(71), 2 object_creation_time fixed bin(71), 2 generator char(8), 2 gen_version_name like stringpointer, 2 userid like stringpointer, 2 comment like stringpointer, 2 text_boundary fixed bin(17) unal, 2 stat_boundary fixed bin(17) unal, 2 source_map bit(18) unal, 2 area_pointer bit(18) unal, 2 sectionbase_backpointer bit(18) unal, 2 block_size bit(18) unal, 2 next_block_thread bit(18) unal, 2 rel_text bit(18) unal, 2 rel_def bit(18) unal, 2 rel_link bit(18) unal, 2 rel_symbol bit(18) unal, 2 default_truncate bit(18) unal, 2 optional_truncate bit(18) unal, 2 user_name char(32), /* userid above locates this */ 2 version_string char(64), /* gen_version_name above locates this */ 1 relocation_bits based(rel_bits_ptr) aligned, 2 dcl_vers fixed bin, 2 relbits bit(131072) varying, /* based varying bit string.... */ 1 object_map based (map_ptr) aligned, 2 dcl_vers fixed bin, 2 identifier char(8), 2 text_offset bit(18) unal, 2 text_length bit(18) unal, 2 definition_offset bit(18) unal, 2 definition_length bit(18) unal, 2 linkage_offset bit(18) unal, 2 linkage_length bit(18) unal, 2 symbol_offset bit(18) unal, 2 symbol_length bit(18) unal, 2 bmap_offset bit(18) unal, 2 bmap_length bit(18) unal, 2 format unal, 3 bound bit(1), 3 relocatable bit(1), 3 procedure bit(1), 3 standard bit(1), 3 unused bit(32), 2 map_offset bit(18) aligned, 1 stringpointer based aligned, 2 offset fixed bin(17) unal, 2 length fixed bin(17) unal; dcl 1 source_map based aligned, 2 version fixed bin, /* 1 */ 2 size fixed bin, /* number of entries to follow */ 2 map( source_map_size refer(source_map.size)), 3 pathname like stringpointer, /* relp/length of pathname string */ 3 uid bit(36) aligned, /* source-segment unique id */ 3 dtm fixed bin(71), /* source-segment dtm */ smdn char(168), smen char(32), smstr char(source_seg_list_p -> cons_ptrs.car -> lisp_string.string_length) unaligned based, source_map_size fixed bin; dcl 1 expression_word based aligned, 2 type_pair_relp bit(18) unaligned, 2 expression fixed bin(17) unaligned, 1 type_pair based aligned, 2 type fixed bin(17) unaligned, 2 trap_relp bit(18) unaligned, 2 segmentname_relp bit(18) unaligned, 2 entryname_relp bit(18) unaligned, 1 link_pair based aligned, 2 header_relp bit(18) unaligned, 2 ignore1 bit(12) unaligned, 2 fault_tag_2 bit(6) unaligned, 2 expression_relp bit(18) unaligned, 2 ignore2 bit(18) unaligned; dcl expression_word_table(100) bit(18) aligned; dcl get_wdir_ entry returns(char(168)aligned), get_pdir_ entry returns(char(168)aligned), get_dir_ entry variable returns(char(168)aligned), get_group_id_ entry returns(char(32) aligned), clock_ entry returns(fixed bin(71)), com_err_ entry options(variable), cu_$cl entry, tssi_$get_segment entry (char(*), char(*), ptr, ptr, fixed bin(35)), tssi_$clean_up_segment entry(ptr), tssi_$finish_segment entry(ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35)), expand_path_ entry(pointer, fixed bin(17), pointer, pointer, fixed bin(35)), hcs_$status_long entry(char(*), char(*), fixed bin(1), pointer, pointer, fixed bin(35)), 1 hcs_status_long_str aligned structure, 2 ( type bit(2), /* 00 link 01 segment 10 directory */ nnames bit(16), /* number of names */ nrp bit(18), /* names rel ptr */ dtm bit(36), /* date time modified */ dtu bit(36), /* date time used */ mode bit(5), /* effective access */ pad1 bit(13), records bit(18), /* records used */ dtd bit(36), /* date time dumped */ dtem bit(36), /* date time entry modified */ pad2 bit(36), curlen bit(12), /* current length */ bitcnt bit(24), /* bit count */ did bit(4), /* device id */ pad3 bit(4), copysw bit(1), /* copy switch */ pad4 bit(9), rbs (0:2) bit(6), /* ring brackets */ uid bit(36) /* unique id */ ) unaligned; dcl (addr, addrel, after, before, bit, divide, fixed, hbound, index, length, max, mod, null, rel, size, string, substr, unspec) builtin; %include lisp_symb_tree; %include lisp_bignum_fmt; %include lisp_nums; %include lisp_ptr_fmt; %include lisp_string_fmt; %include lisp_atom_fmt; %include lisp_cons_fmt; on condition(cleanup) call tssi_$clean_up_segment(acinfo); get_dir_ = get_wdir_; /* usual case */ if length(segname) > 5 then if substr(segname, 1, 5) = "[pd]>" then do; /* special case - put in process dir */ get_dir_ = get_pdir_; segname = substr(segname, 6); end; loop_back: call tssi_$get_segment (get_dir_(), segname, object_pointer, acinfo, code); if object_pointer = null() then do; call com_err_(code, "lisp_cg_utility_", "^a>^a^/Fix it and type start.", get_dir_(), segname); call cu_$cl; /* give loser a chance to recover */ go to loop_back; end; if pl1_link_list_p -> fixedb > hbound(expression_word_table, 1) then do; call com_err_(0, "lisp_cg_utility_", "Too many outbound links. Compilation aborted."); return; end; ic = 0; codelist = a_codelist; /* don't clobber codelist, need later */ do while(addr(codelist) -> lisp_ptr.type = Cons); codeitem = codelist_p -> cons.car; codelist = codelist_p -> cons.cdr; if addr(codeitem) -> lisp_ptr_type & Numeric36 then; else codeitem = addr(codeitem) -> based_ptr -> cons.cdr; /* relocatable */ text_section(ic) = addr(codeitem) -> word_overlay.word; ic = ic + 1; end; ic, text_length = 2*divide(ic+1,2,18,0); defsect, def_ptr = addr(text_section(ic)); /* get pointer to where to put def section*/ /* make definition section */ def_hdr.def_list = "000000000000000011"b; /* def hdr immediately followed by first def */ def_hdr.flags.new_format, def_hdr.flags.ignore = "1"b; /* ignore bit must be on in def header. */ def_hdr.segname_def.symbol.len = length(segname); substr(def_hdr.segname_def.symbol.acc, 1, length(segname)) = segname; def_length_in_words = divide(length(segname),4,17,0) + 7; def_hdr.segname_def.fore_thread = bit(def_length_in_words,18); def_hdr.segname_def.back_thread = "000000000000000010"b; /* pointer to end chain */ def_hdr.segname_def.value = "000000000000000010"b; def_hdr.segname_def.flags.retain, def_hdr.segname_def.flags.new_format = "1"b; def_hdr.segname_def.class = "011"b; /* segname definition */ def_hdr.segname_def.symbol_ptr = "000000000000000110"b; /* 6 offset from beginning of def section */ def_hdr.segname_def.segname_ptr = def_hdr.segname_def.fore_thread; /* defblock ptr actually */ last_def = "000000000000000011"b; def_ptr = addrel(def_ptr, def_length_in_words); /* move on to ename def */ definition.fore_thread = bit(fixed(def_length_in_words+5,18,0),18); definition.back_thread = last_def; definition.value = ""b; definition.flags.new_format, definition.flags.retain = "1"b; definition.class = "000"b; definition.symbol_ptr = bit(fixed(3-text_length+fixed(rel(def_ptr),18,0),18,0),18); definition.segname_ptr = "000000000000000011"b; definition.symbol.len = 7; substr(definition.symbol.acc,1,7) = "*segtop"; last_def = bit(fixed(def_length_in_words,18,0),18); def_length_in_words = 5; def_ptr = addrel(def_ptr, def_length_in_words); /* move along structure */ definition.symbol.len = 12; substr(definition.symbol.acc,1,12) = "symbol_table"; /* the symbol table defn */ definition.fore_thread = "000000000000000010"b; /* points to zero word */ definition.back_thread = last_def; definition.value = ""b; definition.flags.retain, definition.flags.new_format = "1"b; /* all other flags are already zero */ definition.class = "010"b; definition.symbol_ptr = bit(fixed(3-text_length+fixed(rel(def_ptr),18,0),18,0),18); definition.segname_ptr = "000000000000000011"b; /* pointer to segname definition */ def_ptr = addrel(def_ptr, 8); /* make cruft for links - expression words, type pairs, names */ link_list_count = pl1_link_list_p -> fixedb; link_list_ptr = pl1_link_list_p -> cons_ptrs.cdr; do while (link_list_count > 0); /* segmentname = before(link_list_ptr -> cons_ptrs.car -> lisp_string.string, "$"); COMPILER BUG entryname = after(link_list_ptr -> cons_ptrs.car -> lisp_string.string, "$"); */ dcl iiiii fixed bin; entryname = ""; iiiii = index(link_list_ptr -> cons_ptrs.car -> lisp_string.string, "$"); if iiiii = 0 then iiiii = length(link_list_ptr -> cons_ptrs.car -> lisp_string.string)+1; else entryname = substr(link_list_ptr -> cons_ptrs.car -> lisp_string.string, iiiii+1); segmentname = substr(link_list_ptr -> cons_ptrs.car -> lisp_string.string, 1, iiiii-1); def_ptr -> accstring.len = length(segmentname); substr(def_ptr -> accstring.acc, 1, length(segmentname)) = segmentname; segmentname_relp = ptr_sub(def_ptr, defsect); def_ptr = addrel(def_ptr, divide(length(segmentname)+4,4,18,0)); if entryname = "" then entryname_relp = segmentname_relp; else do; def_ptr -> accstring.len = length(entryname); substr(def_ptr -> accstring.acc, 1, length(entryname)) = entryname; entryname_relp = ptr_sub(def_ptr, defsect); def_ptr = addrel(def_ptr, divide(length(entryname)+4,4,18,0)); end; def_ptr -> type_pair.segmentname_relp = segmentname_relp; def_ptr -> type_pair.entryname_relp = entryname_relp; def_ptr -> type_pair.type = 4; def_ptr -> type_pair.trap_relp = ""b; entryname_relp = ptr_sub(def_ptr, defsect); /* save for a second */ def_ptr = addrel(def_ptr, 2); def_ptr -> expression_word.type_pair_relp = entryname_relp; def_ptr -> expression_word.expression = 0; expression_word_table(link_list_count) = ptr_sub(def_ptr, defsect); def_ptr = addrel(def_ptr, 1); link_list_ptr = link_list_ptr -> cons_ptrs.cdr; link_list_count = link_list_count - 1; end; def_length = fixed(rel(def_ptr), 18) - text_length; if mod(def_length, 2) ^= 0 then def_length = def_length + 1; /* put linkage on double word boundary */ /* now make linkage section */ link_ptr = addrel(object_pointer,text_length+def_length); link_ptr -> link_hdr.def_section = bit(text_length,18); stat_length = 8; /* only exists linkage header */ link_ptr -> link_hdr.begin_links, link_ptr -> link_hdr.section_length = bit(stat_length,18); /* no links are present */ link_ptr -> link_hdr.combined_length = ""b; /* obsolete field must be zero or linker screws up */ link_head_ptr = link_ptr; link_ptr = addrel(link_ptr, 8); /* skip link header */ link_list_count = pl1_link_list_p -> fixedb; do while(link_list_count > 0); link_ptr -> link_pair.header_relp = ptr_sub(link_head_ptr, link_ptr); link_ptr -> link_pair.fault_tag_2 = "100110"b; link_ptr -> link_pair.expression_relp = expression_word_table(link_list_count); link_ptr = addrel(link_ptr, 2); link_list_count = link_list_count - 1; end; link_head_ptr -> link_hdr.section_length = ptr_sub(link_ptr, link_head_ptr); /* now make the symbol section, which is the hard part */ symbol_ptr = link_ptr; symbol_block.dcl_vers = 1; symbol_block.identifier = "symbtree"; symbol_block.gen_version_number = 2; symbol_block.gen_creation_time = max(addr(lcp_semant_$symbol_table)->symbol_block.object_creation_time, addr(lcp_cg_$symbol_table)->symbol_block.object_creation_time); symbol_block.object_creation_time = clock_(); symbol_block.generator = "lisp"; symbol_block.gen_version_name.offset = 28; symbol_block.gen_version_name.length = 64; symbol_block.userid.offset = 20; symbol_block.userid.length = 32; symbol_block.comment.offset, symbol_block.comment.length = 0; symbol_block.text_boundary, symbol_block.stat_boundary = 2; symbol_block.sectionbase_backpointer = "0"b; symbol_block.next_block_thread = "0"b; symbol_block.user_name = get_group_id_(); symbol_block.version_string = gen_version; area_top = addrel(symbol_ptr,size(symbol_block)); /* create source map */ source_map_size = source_seg_list_p -> fixedb; thingp = sym_alloc(size(source_map)); symbol_block.source_map = ptr_sub(thingp, symbol_ptr); thingp -> source_map.version = 1; thingp -> source_map.size = source_map_size; ic = 0; do while(source_map_size > 0); /* process source seg list */ source_map_size = source_map_size - 1; ic = ic + 1; source_seg_list = source_seg_list_p -> cons.cdr; call expand_path_(addr(source_seg_list_p -> cons_ptrs.car -> lisp_string.string), source_seg_list_p -> cons_ptrs.car -> lisp_string.string_length, addr(smdn), addr(smen), code); if code ^= 0 then go to source_map_loss; call hcs_$status_long(smdn, smen, 1 /*chase*/, addr(hcs_status_long_str), null, code); if code ^= 0 then go to source_map_loss; thingp -> source_map.map(ic).uid = hcs_status_long_str.uid; thingp -> source_map.map(ic).dtm = fixed(hcs_status_long_str.dtm || (16)"0"b, 52); source_map_loss: symrtp = sym_alloc(divide(source_seg_list_p -> cons_ptrs.car -> lisp_string.string_length+7,8,17,0)*2); thingp -> source_map.map(ic).pathname.offset = fixed(ptr_sub(symrtp, symbol_ptr), 18); thingp -> source_map.map(ic).pathname.length = source_seg_list_p -> cons_ptrs.car -> lisp_string.string_length; symrtp -> smstr = source_seg_list_p -> cons_ptrs.car -> lisp_string.string; end; symrtp = sym_alloc(size(symbol_root)); symbol_block.area_pointer = ptr_sub(symrtp, symbol_ptr); /* now make the lisp symbol tree */ blockp = sym_alloc(fixnum_list_p -> fixedb+1); /* number of fixnums */ blockp -> fixnum_block.count, total_objects = fixnum_list_p -> fixedb; do ic = 1 to blockp -> fixnum_block.count; fixnum_list = fixnum_list_p -> cons.cdr; blockp -> fixnum_block.fixnums(ic) = fixnum_list_p -> fixedb; end; symrtp -> symbol_root.objects.fixnum_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(flonum_list_p -> fixedb+1); /* number of flonums */ blockp -> flonum_block.count = flonum_list_p -> fixedb; total_objects = total_objects + blockp -> flonum_block.count; do ic = 1 to blockp -> flonum_block.count; flonum_list = flonum_list_p -> cons.cdr; blockp -> flonum_block.flonums(ic) = flonum_list_p -> floatb; end; symrtp -> symbol_root.objects.flonum_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(divide(string_list_p ->fixedb+3,2,17,0)); blockp -> string_block.count = string_list_p -> fixedb; total_objects = total_objects + blockp -> string_block.count; do ic = 1 to blockp -> string_block.count; string_list = string_list_p -> cons.cdr; thingp = sym_alloc(divide(string_list_p -> based_ptr -> lisp_string.string_length+7,4,17,0)); blockp -> string_block.string_offset(ic) = ptr_sub(thingp,symrtp); thingp -> string_chars.length = string_list_p -> based_ptr -> lisp_string.string_length; thingp -> string_chars.chars = string_list_p -> based_ptr -> lisp_string.string; end; symrtp -> symbol_root.objects.string_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(divide(bignum_list_p -> fixedb+3,2,18,0)); blockp -> bignum_block.count = bignum_list_p -> fixedb; total_objects = total_objects + blockp -> bignum_block.count; do ic = 1 to blockp -> bignum_block.count; bignum_list = bignum_list_p -> cons.cdr; thingp = sym_alloc(1+bignum_list_p -> based_ptr -> lisp_bignum.prec); blockp -> bignum_block.bignum_offsets(ic) = ptr_sub(thingp,symrtp); thingp -> lisp_bignum.sign = bignum_list_p -> based_ptr -> lisp_bignum.sign; thingp -> lisp_bignum.prec = bignum_list_p -> based_ptr -> lisp_bignum.prec; thingp -> lisp_bignum.words = bignum_list_p -> based_ptr -> lisp_bignum.words; end; symrtp -> symbol_root.objects.bignum_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(divide(atsym_list_p -> fixedb+3,2,17,0)); blockp -> atsym_block.count = atsym_list_p -> fixedb; total_objects = total_objects + blockp -> atsym_block.count; do ic = 1 to blockp -> atsym_block.count; atsym_list = atsym_list_p -> cons.cdr; thingp = sym_alloc(divide(atsym_list_p -> based_ptr -> atom.pnamel+7,4,17,0)); blockp -> atsym_block.atsym_offset(ic) = ptr_sub(thingp,symrtp); thingp -> string_chars.length = atsym_list_p -> based_ptr -> atom.pnamel; thingp -> string_chars.chars = atsym_list_p -> based_ptr -> atom.pname; end; symrtp -> symbol_root.objects.atsym_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(cons_list_p -> fixedb+1); /* size of cons block */ blockp -> cons_block.count = cons_list_p -> fixedb; total_objects = total_objects + blockp -> cons_block.count; do ic = 1 to blockp -> cons_block.count; cons_list = cons_list_p -> cons.cdr; unspec(blockp -> cons_block.conses(ic)) = cons_list_p -> word_overlay.word; end; symrtp -> symbol_root.objects.cons_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(entry_list_p ->fixedb+1); /* size of entry descriptions */ blockp -> entry_block.count, total_block_size = entry_list_p -> fixedb; do ic = 1 to blockp -> entry_block.count; entry_list = entry_list_p -> cons.cdr; string(blockp -> entry_block.entry_info(ic)) = entry_list_p -> word_overlay.word; end; symrtp -> symbol_root.subr_block_items.entry_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(divide(constant_list_p -> fixedb+3,2,17,0)); blockp -> const_block.count = constant_list_p -> fixedb; total_block_size = total_block_size + blockp -> const_block.count; do ic = 1 to blockp -> const_block.count; constant_list = constant_list_p -> cons.cdr; blockp -> const_block.constants(ic) = constant_list_p -> fixedb; end; symrtp -> symbol_root.subr_block_items.const_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(1+link_list_p -> fixedb); blockp -> links_block.count = link_list_p -> fixedb; total_block_size = total_block_size+blockp -> links_block.count; do ic = 1 to blockp -> links_block.count; link_list = link_list_p -> cons.cdr; blockp -> links_block.link_info(ic)= substr(link_list_p -> word_overlay.word,10,27); end; symrtp -> symbol_root.subr_block_items.links_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(1+ action_list_p -> fixedb); blockp -> action_block.count = action_list_p -> fixedb; do ic = 1 to blockp -> action_block.count; action_list = action_list_p -> cons.cdr; unspec(blockp -> action_block.actions(ic)) = action_list_p -> word_overlay.word; end; symrtp -> symbol_root.action_blockp = ptr_sub(blockp,symrtp); blockp = sym_alloc(1 + array_link_list_p -> fixedb); blockp -> array_links_block.count = array_link_list_p -> fixedb; do ic = 1 to blockp -> array_links_block.count; array_link_list = array_link_list_p -> cons.cdr; blockp -> array_links_block.array_link(ic).control_word = array_link_list_p -> word_overlay.word; end; symrtp -> symbol_root.array_links_blockp = ptr_sub(blockp,symrtp); /* now fill in lengths of various items */ symrtp -> symbol_root.version = 2; symrtp -> symbol_root.number_objects = total_objects; symrtp -> symbol_root.subr_block_size = total_block_size; /* now make up the relocation bits */ rel_bits_ptr = area_top; symbol_block.default_truncate, symbol_block.optional_truncate, symbol_block.rel_text = ptr_sub(rel_bits_ptr,symbol_ptr); relocation_bits.dcl_vers = 1; relbits = ""b; absolute_counter = 0; do codelist = a_codelist repeat codelist_p -> cons.cdr while (addr(codelist) -> lisp_ptr.type = Cons); /* process codelist again */ if codelist_p -> cons_types.car then absolute_counter = absolute_counter + 2; else do; call put_rel; /* relocatable word - a cons in codelist */ relbits = relbits || bit(fixed(codelist_p -> cons_ptrs.car -> fixedb, 5), 5); /* put out the relocation */ rh_reloc = divide(codelist_p -> cons_ptrs.car -> fixedb, 262144, 17, 0); if rh_reloc = 0 /* if no rh relocation */ then absolute_counter = 1; /* then is 1 abs for right half */ else relbits = relbits || bit(rh_reloc, 5); /* else put out rh relocation */ end; end; call put_rel; relbits_length = divide(length(relbits)+107,36,35,0); /* length of text relocation bits */ rel_bits_ptr = addrel(rel_bits_ptr,relbits_length); symbol_block.rel_link = ptr_sub(rel_bits_ptr,symbol_ptr); relocation_bits.dcl_vers = 1; relbits = "00100000000000001001010010010010"b; relbits_length = divide(length(relbits)+107,36,35,0); rel_bits_ptr = addrel(rel_bits_ptr, relbits_length); relocation_bits.dcl_vers = 1; relbits = "11110"b || "0000011110"b || "101110"b; /* up to section_base_backptr */ absolute_counter = 2*(fixed(ptr_sub(area_top,symbol_ptr),18,0)-16); /* first 16 words aready encoded */ call put_rel; symbol_block.rel_symbol = ptr_sub(rel_bits_ptr,symbol_ptr); put_rel: proc; /* put out some absolute relocation */ do while(absolute_counter > 1111111111b); /* pack in absolute relocation */ relbits = relbits || "111101111111111"b; /* max length of expanded absolute */ absolute_counter = absolute_counter - 1111111111b; end; if absolute_counter > 0 then do; relbits = relbits || "11110"b; relbits = relbits || bit(fixed(absolute_counter,10,0),10); end; absolute_counter = 0; end; map_ptr = addrel(rel_bits_ptr, divide(length(relbits)+107,36,35,0)); symbol_block.block_size = ptr_sub(map_ptr, symbol_ptr); object_map.dcl_vers = 1; object_map.identifier = "obj_map"; object_map.text_offset = ""b; object_map.text_length = bit(fixed(text_length,18,0),18); object_map.definition_offset = bit(text_length,18); object_map.definition_length = bit(fixed(def_length,18,0),18); object_map.linkage_offset = rel(link_head_ptr); object_map.linkage_length = ptr_sub(link_ptr, link_head_ptr); object_map.symbol_offset = rel(symbol_ptr); object_map.symbol_length = bit(fixed(symbol_block.block_size,18,0),18); object_map.bmap_offset = ""b; object_map.bmap_length = "0"b; object_map.format.bound = "0"b; object_map.format.relocatable, object_map.format.procedure = "1"b; object_map.format.standard = "1"b; object_map.map_offset = rel(map_ptr); call tssi_$finish_segment (object_pointer, 36*(10+fixed(symbol_block.block_size,18,0)+fixed(rel(symbol_ptr), 18)), "1100"b, acinfo, code); return; ptr_sub: proc(ap, bp)returns(bit(18)); /* subtracts bp from ap, returns offset of bp from ap as bit(18) */ dcl (ap, bp) ptr; dcl diff fixed bin(19); diff = fixed(rel(ap), 18) - fixed(rel(bp), 18); if diff < 0 then diff = 262144+diff; /* want 2's complement bitstring */ return (bit(fixed(diff, 18), 18)); end ptr_sub; sym_alloc: proc(space) returns(ptr); dcl space fixed bin(18), tempp ptr; tempp = area_top; area_top = addrel(area_top,space); return(tempp); end sym_alloc; end lisp_cg_utility_;  lisp_compiler.pl1 07/06/83 0936.2r w 06/29/83 1541.4 31518 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* protect old protection notice */ /* (c) Copyright 1973, Massachusetts Institute of Technology All rights rseserved */ lcp: lisp_compiler: proc; /* * This is a command interface to the LISP compiler. * It copies its argument list, putting in a first * argument of the pathname of the compiler saved environment, * which is assumed to be in the same directory as this command. * It calls lisp with these arguments, which causes it * to unsave and run the compiler. * It also initiates the two compiler object segments because * at present the referencing_dir search rule doesn't work right for * lisp links. * * coded 4 May 1973 by D. A. Moon */ declare (i, j, n) fixed bin, cu_$arg_list_ptr entry returns(ptr), old_ap ptr, com_err_ entry options(variable), hcs_$fs_get_path_name entry(ptr, char(*), fixed bin, char(*), fixed bin(35)), hcs_$initiate entry(char(*), char(*), char(*), fixed bin, fixed bin, ptr, fixed bin(35)), (null, addr, index, substr) builtin, pathname char(168), lisp ext entry, cu_$gen_call entry(ptr, ptr), 1 old_argl aligned based(old_ap), 2 argc fixed bin(16) unal, 2 type fixed bin(18) unal, 2 descc fixed bin(16) unal, 2 ptr(1000) ptr, 1 a1desc unaligned, 2 type bit(9), 2 len fixed bin(26); declare label_me label variable, /* kludge to get ptr to myself */ ptr_to_me ptr aligned based(addr(label_me)); dcl lap_flag bit(1); lap_flag = "0"b; go to join; lap: entry; /* LISP Assembly Program */ lap_flag = "1"b; join: old_ap = cu_$arg_list_ptr(); n = old_argl.argc; if n = 0 then do; if lap_flag then call com_err_(0, "lap", "Correct usage is:^/^-lap pathname -options-^/"); else call com_err_(0, "lisp_compiler", "Correct usage is:^/^-lisp_compiler pathname -options-^/or^-lcp pathname -options-"); return; end; /* find pathname of compiler.sv.lisp */ label_me = label; label: call hcs_$fs_get_path_name(ptr_to_me, pathname, (0), (""), (0)); if lap_flag then call hcs_$initiate(pathname, "lap_", "lap_", 0, 0, (null), (0)); else do; call hcs_$initiate(pathname, "lcp_semant_", "lcp_semant_", 0, 0, (null), (0)); /* can't err */ call hcs_$initiate(pathname, "lcp_cg_", "lcp_cg_", 0, 0, (null), (0)); end; i = index(pathname, " "); if lap_flag then substr(pathname, i, 4) = ">lap"; else substr(pathname, i, 9) = ">compiler"; /* full pn shorn of .sv.lisp extension */ a1desc.type = "101010100"b; /* 524 */ a1desc.len = i+8; begin; /* allocate space for new argument list */ dcl 1 new_argl aligned, 2 argc fixed bin(16) unal, 2 type fixed bin(18) unal, 2 descc fixed bin(16) unal, 2 mbz fixed bin(18) unal, 2 aptr (n+1) ptr, 2 dptr(n+1) ptr; new_argl.argc, new_argl.descc = n+1; new_argl.type = 4; new_argl.mbz = 0; /* set first arg to pathname */ new_argl.aptr(1) = addr(pathname); new_argl.dptr(1) = addr(a1desc); /* copy rest of args */ do i = 1 to n; new_argl.aptr(i+1) = old_argl.ptr(i); if old_argl.type = 4 then new_argl.dptr(i+1) = old_argl.ptr(i+n); else new_argl.dptr(i+1) = old_argl.ptr(i+n+1); end; /* call out */ call cu_$gen_call(addr(lisp), addr(new_argl)); end; end;  make_lisp_listing.pl1 07/06/83 0936.2r w 06/29/83 1542.1 152793 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* protect old protection notice */ /* (c) Copyright 1973, Massachusetts Institute of Technology. All rights reserved. */ make_lisp_listing: mll: procedure; /* modified 15 Nov 73 by DAM for new subr blocks */ dcl cu_$arg_ptr entry(fixed bin, ptr, fixed bin, fixed bin(35)), object_info_$brief entry ( ptr, fixed bin(24), ptr, fixed bin(35)), dump_lisp_code_ entry(fixed bin(18), fixed bin(18), ptr, pointer), make_lisp_xref_ entry(pointer, ptr), iox_$attach_ioname entry(char(*), ptr, char(*), fixed bin(35)), iox_$open entry(ptr, fixed bin, bit(1) unaligned, fixed bin(35)), iox_$close entry(ptr, fixed bin(35)), iox_$detach_iocb entry(ptr, fixed bin(35)), iox_$put_chars entry(ptr, ptr, fixed bin(21), fixed bin(35)), iox_$position entry(ptr, fixed bin, fixed bin(21), fixed bin(35)), hcs_$initiate_count entry(char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)), unique_chars_ entry(bit(*)) returns(char(15)), error_table_$segknown fixed bin(35) external, hcs_$terminate_name entry(char(*), fixed bin(35)), hcs_$terminate_noname entry(pointer, fixed bin(35)), hcs_$make_ptr entry(pointer, char(*), char(*), pointer, fixed bin(35)), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin(35)), date_time_ entry(fixed bin(71), char(*)), bitcount fixed bin (24), segptr ptr, dir char(168), ent char(32), unique_ref_name char(15), sdir char(168), sent char(32), sptr pointer, sbc fixed bin(24), slen fixed bin(21), snameptr pointer, snamelen fixed bin, soff fixed bin(21), nelemt fixed bin(21), s char(1), /* singular/plural hackery */ time_string char(24), based_string char(1000) based aligned, nameptr ptr, namelen fixed bin, name char(namelen) based(nameptr) unal, bword bit(36) aligned based, code fixed bin(35), 1 status aligned, 2 error_code fixed bin(35), 2 statbits bit(36), atom_name char(10000) varying based aligned, listfile char(32), (mll_internal_error, cleanup) condition, size_of_text fixed bin(18), actionsp pointer, sblkp pointer, symrtp pointer, number_of_definitions fixed bin init(0), actionx fixed bin, atomsp pointer, number_of_atoms fixed bin init(0), constp pointer, number_of_constants fixed bin init(0), mll_list_stream ptr, def_ptr ptr, (addr, addrel, substr, null, bit, fixed, multiply, binary, lbound, hbound, length) builtin, 1 acc aligned based, 2 len fixed bin(8) unal, 2 str char(0 refer(acc.len)) unal, com_err_ entry options(variable), ioa_$ioa_switch entry options(variable); dcl brief_opt bit(1) init("0"b), object_opt bit(1) init("0"b), source_opt bit(1) init("0"b), one_fun_opt bit(1) init("0"b), /* 1 => only list one function */ one_fun char(256), /* the one function to list's name. */ not_a_lisp_seg bit(1) init("0"b), argx fixed bin, argptr pointer, arglen fixed bin, arg char(arglen) based(argptr) unaligned, error_table_$badopt fixed bin(35) external; dcl source_map_ptr pointer; dcl source_x fixed bin; dcl source_pathname char(fixed(source_map_ptr -> source_map.pathname(source_x).size, 18)) unaligned based(addrel(sblkp, source_map_ptr -> source_map.pathname(source_x).offset)); %include lisp_symb_tree; %include symbol_block; %include source_map; %include object_info; dcl 1 oi like object_info aligned automatic; /* process arguments */ do argx = 1 by 1; call cu_$arg_ptr(argx, argptr, arglen, code); if code ^= 0 then go to exitloop_get_args; if arg = "" then; /* ignore null args for sake of compiler */ else if substr(arg, 1, 1) = "-" then if arg = "-brief" then brief_opt = "1"b; else if arg = "-bf" then brief_opt = "1"b; else if arg = "-function" | arg = "-fn" then do; one_fun_opt = "1"b; argx = argx + 1; call cu_$arg_ptr(argx, argptr, arglen, code); if code ^= 0 then do; call com_err_(code, "make_lisp_listing", "Function name required after -function."); return; end; one_fun = arg; end; else do; call com_err_(error_table_$badopt, "make_lisp_listing", arg); return; end; else if ^object_opt then do; /* first pathname is object seg */ object_opt = "1"b; nameptr = argptr; namelen = arglen; end; else if ^source_opt then do; /* second pathname is source seg */ source_opt = "1"b; snameptr = argptr; snamelen = arglen; end; else do; /* a third pathname is not allowed */ call com_err_(0, "make_lisp_listing", "^a is an extraneous argument.", arg); return; end; end; exitloop_get_args: if ^object_opt then do; call com_err_(0, "make_lisp_listing", "Usage is: make_lisp_listing object_seg^/ the -brief and -bf options are allowed."); return; end; call expand_path_(nameptr, namelen, addr(dir), addr(ent), code); if code ^= 0 then do; call com_err_ (code, "make_lisp_listing", name); return; end; unique_ref_name = unique_chars_(""b); call hcs_$initiate_count(dir, ent, unique_ref_name, bitcount, 0, segptr, code); if code ^= 0 then if code ^= error_table_$segknown then do; call com_err_(code, "make_lisp_listing", "Cannot initiate ^a>^a.", dir, ent); return; end; /* compute size of text section from rel of def section - needed later */ call object_info_$brief(segptr, bitcount, addr(oi), code); if code ^= 0 then go to bad_code; size_of_text = fixed(rel(oi.defp), 18); /* find symbol section */ call hcs_$make_ptr(null, unique_ref_name, "symbol_table", sblkp, code); if sblkp = null then do; bad_code: call com_err_(code, "make_lisp_listing", "^a>^a.", dir, ent); return; end; if sblkp -> sb.generator ^= "lisp" then do; not_lisp: if brief_opt then do; /* allowed if not looking at code */ not_a_lisp_seg = "1"b; go to skip_lisp_stuff; end; call com_err_(0, "make_lisp_listing", "^a>^a is not an object segment produced by the LISP compiler.", dir, ent); return; end; if sblkp -> sb.area_ptr = ""b then go to not_lisp; /* old format, with .defs file? */ symrtp = addrel(sblkp, sblkp -> sb.area_ptr); /* determine number of functions defined in this object segment by scanning actions */ actionsp = addrel(symrtp, symrtp -> symbol_root.action_blockp); number_of_definitions = 0; do actionx = 1 to actionsp -> action_block.count; if actionsp -> action_block.action_code(actionx) > 0 /* def fcn of one type or another */ then number_of_definitions = number_of_definitions + 1; end; atomsp = addrel(symrtp, symrtp -> symbol_root.atsym_blockp); number_of_atoms = atomsp -> atsym_block.count; constp = addrel(symrtp, symrtp -> symbol_root.const_blockp); number_of_constants = constp -> const_block.count; skip_lisp_stuff: /* enter begin block to allocate various tables */ allocate_various_tables: begin; dcl defx fixed bin, entryp pointer, linksp pointer, atom_lbound fixed bin(18), actionx fixed bin, i fixed bin, codelength fixed bin(18); dcl 1 table aligned automatic structure, 2 stack_height fixed bin(17), /* added to ap offset gives real offset */ 2 atom_table_size fixed bin(17) init(number_of_atoms), 2 link_table_ptr unaligned pointer, /* points at array of itp link info */ 2 link_table_lbound fixed bin(18), /* first lp| offset of itp link */ 2 link_table_hbound fixed bin(18), /* last lp| offset of itp link */ 2 array_link_table_ptr unaligned pointer, /* -> array of array_link control words */ 2 array_link_table_lbound fixed bin(18), /* first lp| offset of array link */ 2 array_link_table_hbound fixed bin(18), /* last lp| offset of array link */ 2 definition_table_size fixed bin init(number_of_definitions), 2 constant_table_size fixed bin(17) init(number_of_constants), 2 constant_table_lbound fixed bin(18), /* first lp| offset of constant */ 2 constant_table_hbound fixed bin(18), /* last lp| offset of constant */ 2 bind_stack_ptr fixed bin, /* index of first unused entry in the bind_stack */ 2 arg_twiddle fixed bin(18), /* eax5 hacker */ 2 seg_ptr unaligned pointer, /* -> object seg text section */ 2 bind_stack (100) fixed bin, /* table of sizes of nested binding blocks */ 2 atom_table (number_of_atoms) structure, /* pointers to atomic symbols */ 3 ptr_to_name unaligned pointer, /* packed pointer to varying string which is name */ 2 definition_table (number_of_definitions) structure, 3 arg_pdl bit(18) unaligned, /* number of pdl cells occupied by args */ 3 entrypoint bit(18) unaligned, /* location of entry */ 3 ptr_to_name unaligned pointer, /* packed pointer to varying string */ 2 constant_table (number_of_constants) structure, 3 atom_table_index fixed bin; /* 0 if this constant not an atom */ if not_a_lisp_seg then seg_ptr = segptr; else do; /* only do lisp stuff if lisp seg */ /* get pointer to text section */ call hcs_$make_ptr(segptr, unique_ref_name, "*segtop", entryp, code); seg_ptr = entryp; /* set up handler for bind_stack overflow/underflow */ on mll_internal_error begin; dcl foo char(5); if bind_stack_ptr <= 0 then foo = "under"; else foo = "over"; call com_err_(0, "make_lisp_listing", "Internal binding stack ^aflow while listing ^a.", foo, definition_table(defx).ptr_to_name -> atom_name); call ioa_$ioa_switch(mll_list_stream, "^/BUST IT! BUST IT!"); /* ?? */ go to flush_this; end; /* fill in the tables: a t o m t a b l e */ do i = lbound(atom_table, 1) to hbound(atom_table, 1); atom_table(i).ptr_to_name = addrel(symrtp, atomsp -> atsym_block.atsym_offset(i)); end; /* l i n k t a b l e */ linksp = addrel(symrtp, symrtp -> symbol_root.links_blockp); link_table_lbound = 1 + 2*number_of_constants; /* lp offset of first link */ link_table_hbound = link_table_lbound + 2*linksp -> links_block.count - 2; /* lp offset of last link */ link_table_ptr = addr(linksp -> links_block.link_info); /* d e f i n i t i o n t a b l e */ atom_lbound = 1 + addrel(symrtp, symrtp -> symbol_root.fixnum_blockp) -> fixnum_block.count + addrel(symrtp, symrtp -> symbol_root.flonum_blockp) -> flonum_block.count + addrel(symrtp, symrtp -> symbol_root.string_blockp) -> string_block.count + addrel(symrtp, symrtp -> symbol_root.bignum_blockp) -> bignum_block.count; defx = 0; entryp = addrel(symrtp, symrtp -> symbol_root.entry_blockp); do actionx = 1 to actionsp -> action_block.count; if actionsp -> action_block.action_code(actionx) > 0 /* defining function */ then do; defx = defx + 1; if actionsp -> action_block.action_code(actionx) = 1 /* subr */ then definition_table(defx).arg_pdl = bit(multiply(2, fixed(entryp -> entry_info(defx).nargs, 18), 18, 0), 18); else if actionsp -> action_block.action_code(actionx) = 2 /* lsubr */ then definition_table(defx).arg_pdl = ""b; else definition_table(defx).arg_pdl = bit(binary(2, 18), 18); /* fsubr */ definition_table(defx).entrypoint = entryp -> entry_info(defx).entrypoint; definition_table(defx).ptr_to_name = atom_table( actionsp -> action_block.actions(actionx).operand - atom_lbound + 1).ptr_to_name; end; end; /* c o n s t a n t t a b l e */ constant_table_lbound = 1; /* lp offset of first constant */ constant_table_hbound = 2*number_of_constants - 1; /* lp offset of last constant */ do i = 1 to number_of_constants; actionx = constp -> const_block.constants(i); if actionx >= atom_lbound then if actionx - atom_lbound + 1 <= atom_table_size then actionx = actionx - atom_lbound + 1; /* constant is atom - this is index in atom table */ else actionx = 0; else actionx = 0; constant_table(i).atom_table_index = actionx; end; /* a r r a y l i n k t a b l e */ if symrtp -> symbol_root.version < 2 then array_link_table_ptr = null; else do; array_link_table_ptr = addrel(symrtp, symrtp -> symbol_root.array_links_blockp); array_link_table_lbound = constant_table_hbound + 2 + 2*entryp -> entry_block.count; array_link_table_hbound = array_link_table_lbound + 4*(array_link_table_ptr -> array_links_block.count-1); array_link_table_ptr = addr(array_link_table_ptr -> array_links_block.array_link(1)); end; end; /* end of lisp only */ /* NOW BEGIN GENERATING LISTING */ listfile = substr(ent, 1, min(27, 1+length(ent)-verify(reverse(ent), " "))) || ".list"; call iox_$attach_ioname("mll."||unique_chars_(""b), mll_list_stream, "vfile_ "||listfile, code); if code ^= 0 then do; call com_err_(code, "make_lisp_listing", "Trying to attach mll_list_stream to ^a.", listfile); return; end; call iox_$open(mll_list_stream, 2, "0"b, code); if code ^= 0 then do; call com_err_(code, "make_lisp_listing", "Trying to open iocb ^p.", mll_list_stream); return; end; on cleanup begin; call iox_$close(mll_list_stream, code); call iox_$detach_iocb(mll_list_stream, code); end; call ioa_$ioa_switch(mll_list_stream, "LISTING FOR ^a>^a", dir, ent); call ioa_$ioa_switch(mll_list_stream, "COMPILED BY ^a", substr(addrel(sblkp, sblkp -> sb.gen_name_offset) ->based_string, 1, fixed(sblkp -> sb.gen_name_length, 18))); call date_time_(sblkp -> sb.obj_creation_time, time_string); call ioa_$ioa_switch(mll_list_stream, "ON ^a", time_string); call ioa_$ioa_switch(mll_list_stream, "IN BEHALF OF ^a^3/", substr(addrel(sblkp, sblkp -> sb.uid_offset) -> based_string, 1, fixed(sblkp -> sb.uid_length, 18))); /* Insert listing of source if we were given a second argument, the source path name */ if source_opt then call insert_source_seg; else if one_fun_opt then; /* suppress source */ else if sb.source_map ^= ""b then do; /* get source from source map */ source_map_ptr = addrel(sblkp, sb.source_map); do source_x = 1 to source_map_ptr -> source_map.number; if source_x > 1 then call ioa_$ioa_switch(mll_list_stream, "INCLUDE FILE ^a^/", source_pathname); snameptr = addr(source_pathname); snamelen = length(source_pathname); call insert_source_seg; end; end; if brief_opt then go to dont_list_the_code; /* list the code: do loop done once for each entry in definition table */ do defx = 1 to number_of_definitions; if one_fun_opt then if definition_table(defx).ptr_to_name -> atom_name ^= one_fun then go to skip_this_definition; if definition_table(defx).arg_pdl = "000000000000000010"b /* 2 */ then s = ""; /* 1 - singular */ else s = "s"; /* anything else - plural */ call ioa_$ioa_switch(mll_list_stream, "FUNCTION ^a^2x(^d arg-temp^a)^2/", definition_table(defx).ptr_to_name -> atom_name, divide(fixed(definition_table(defx).arg_pdl, 18), 2, 17, 0), s); if defx = number_of_definitions then codelength = size_of_text - fixed(definition_table(defx).entrypoint, 18); else codelength = fixed(definition_table(defx+1).entrypoint, 18) - fixed(definition_table(defx).entrypoint, 18); stack_height = 2 + fixed(definition_table(defx).arg_pdl, 18); bind_stack_ptr = 1; call dump_lisp_code_(fixed(definition_table(defx).entrypoint, 18), codelength, mll_list_stream, addr(table)); flush_this: call ioa_$ioa_switch(mll_list_stream, "^|"); skip_this_definition: end; dont_list_the_code: /* now list the functions referenced and defined */ if ^ (not_a_lisp_seg | one_fun_opt) then call make_lisp_xref_(addr(table), mll_list_stream); call iox_$close(mll_list_stream, code); call iox_$detach_iocb(mll_list_stream, code); call hcs_$terminate_name(unique_ref_name, code); return; insert_source_seg: proc; call expand_path_(snameptr, snamelen, addr(sdir), addr(sent), code); if code = 0 then do; call hcs_$initiate_count(sdir, sent, "", sbc, 0, sptr, code); if sptr ^= null then do; slen = divide(sbc, 9, 21, 0); call iox_$put_chars(mll_list_stream, sptr, slen, code); if code ^= 0 then do; call com_err_(code, "make_lisp_listing", "Trying to write source segment ^a.", sent); return; end; call hcs_$terminate_noname(sptr, code); call ioa_$ioa_switch(mll_list_stream, "^|"); end; else; /* source not there, ignore */ end; else; /* crufty pathname, ignore */ end insert_source_seg; end; /* end begin block */ end;  make_lisp_xref_.pl1 07/06/83 0936.2r w 06/29/83 1542.1 63900 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1973 * * * ************************************************************** */ /* protect old protection notice */ /* (c) Copyright 1973, Massachusetts Institute of Technology. All rights reserved. */ make_lisp_xref_: procedure (a_table_p, stream); declare a_table_p pointer parameter, stream ptr parameter; /* this procedure puts useful information about functions defined and referenced at the end of a listing made by make_lisp_listing. Written 1 Dec 1973 by DAM Modified 18 January 1980 by J. Spencer Love for PL/1 compiler changes. */ declare tablep pointer, (i, j, k, m, n) fixed bin, null_name char (4) varying static init (""), tp unaligned pointer, defx fixed bin, linkx fixed bin, num_funs_def fixed bin init (0), num_fns_ref fixed bin init (0); declare 1 name_struc based aligned, 2 len fixed bin, 2 name char (0 refer (len)) unaligned; declare 1 link_info (1000) aligned based (link_table_ptr), 2 address fixed bin (14) unaligned, 2 snap bit (1) unaligned, 2 constant bit (1) unaligned, 2 f bit (1) unaligned, 2 nargs bit (9) unaligned, 2 pad bit (9) unaligned; /* PL/I bug - can take out when EIS compiler is installed */ declare 1 table aligned structure based (tablep), 2 stack_height fixed bin (17), /* add to ap offset to get 2 * temp number */ 2 atom_table_size fixed bin, /* size of atom_table array */ 2 link_table_ptr unaligned pointer, /* -> array of itp link info */ 2 link_table_lbound fixed bin (18), /* first lp| offset of itp link */ 2 link_table_hbound fixed bin (18), /* last lp| offset of itp link */ 2 array_link_table_ptr unaligned pointer, /* -> array of array_link control words */ 2 array_link_table_lbound fixed bin (18), /* first lp| offset of array link */ 2 array_link_table_hbound fixed bin (18), /* last lp| offset of array link */ 2 definition_table_size fixed bin, /* size of definition_table array */ 2 constant_table_size fixed bin, /* size of constant_table array */ 2 constant_table_lbound fixed bin (18), /* first lp| offset of constant */ 2 constant_table_hbound fixed bin (18), /* last lp| offset of constant */ 2 bind_stack_ptr fixed bin, /* index of first unused entry in bind_stack */ 2 arg_twiddle fixed bin (18), /* eax5 hacker */ 2 seg_ptr unaligned pointer, /* -> text section */ 2 bind_stack (100) fixed bin, /* table of sizes of nested binding blocks */ 2 atom_table (0 refer (atom_table_size)), /* pointers to atomic symbols */ 3 ptr_to_name unaligned pointer, /* -> varying string */ 2 definition_table (0 refer (definition_table_size)), /* entries defined... */ 3 arg_pdl bit (18) unaligned, /* number of pdl cells occupied by args */ 3 entrypoint bit (18) unaligned, /* location of entry */ 3 ptr_to_name unaligned pointer, /* -> varying string */ 2 constant_table (0 refer (constant_table_size)), 3 atom_table_index fixed bin; /* 0 if this constant not an atom */ declare (divide, mod, addr, lbound, hbound) builtin; declare ioa_$ioa_switch entry options (variable); /* BEGIN */ tablep = a_table_p; call list_defined_functions (); call list_referenced_functions (); return; list_defined_functions: procedure (); declare (def_sn, def_sv) fixed bin dimension (definition_table_size); /* definitions sorted by (name, value) */ call ioa_$ioa_switch (stream, "^3-Functions Defined^2/Name^3-Offset^2-Offset^2-Name^2/"); /* sort the definitions by name and by value. */ do defx = 1 to hbound (def_sn, 1); def_sn (defx) = defx; def_sv (defx) = defx; end; /* simultaneous shell sort by name (def_sn) and by entry address (def_sv) */ do m = divide (hbound (def_sn, 1), 2, 17, 0) repeat m - 1 while (m > 0); n = hbound (def_sn, 1) - m; do i = lbound (def_sn, 1) by 1 while (i <= n); if definition_table (def_sn (i)).ptr_to_name -> name > definition_table (def_sn (i + m)).ptr_to_name -> name then do; k = def_sn (i); def_sn (i) = def_sn (i + m); def_sn (i + m) = k; end; if definition_table (def_sv (i)).entrypoint > definition_table (def_sv (i + m)).entrypoint then do; k = def_sv (i); def_sv (i) = def_sv (i + m); def_sv (i + m) = k; end; end; end; /* now print it out */ do defx = lbound (def_sn, 1) to hbound (def_sn, 1); call ioa_$ioa_switch (stream, "^29a^4x^o^2-^3x^o^2-^a", definition_table (def_sn (defx)).ptr_to_name -> name, fixed (definition_table (def_sn (defx)).entrypoint, 18), fixed (definition_table (def_sv (defx)).entrypoint, 18), definition_table (def_sv (defx)).ptr_to_name -> name); end; end list_defined_functions; list_referenced_functions: procedure (); /* now we generate a list of all the functions referenced */ declare fn_ref unaligned pointer dimension (3 + divide (link_table_hbound - link_table_lbound + 2, 2, 17, 0)); /* -> names of referenced functions */ call ioa_$ioa_switch (stream, "^5/^3-Functions Referenced^/"); do linkx = lbound (fn_ref, 1) to hbound (fn_ref, 1) - 3; if link_info (linkx).constant then if link_info (linkx).snap then if link_info (linkx).address >= constant_table_lbound then if link_info (linkx).address <= constant_table_hbound then if constant_table (1 + divide (link_info (linkx).address - constant_table_lbound, 2, 17, 0)) .atom_table_index ^= 0 then do; /* if it meets all these conditions, it's OK to list */ num_fns_ref = num_fns_ref + 1; fn_ref (num_fns_ref) = atom_table ( constant_table (1 + divide (link_info (linkx).address - constant_table_lbound, 2, 17, 0)) .atom_table_index).ptr_to_name; end; end; /* we have found the referenced functions. Next step is to sort this list */ do m = divide (num_fns_ref, 2, 17, 0) by -1 while (m > 0); n = num_fns_ref - m; do i = 1 by 1 while (i <= n); if fn_ref (i) -> name > fn_ref (i + m) -> name then do; tp = fn_ref (i); fn_ref (i) = fn_ref (i + m); fn_ref (i + m) = tp; end; end; end; /* now print it out, in three columns */ n = divide (num_fns_ref, 3, 17, 0); go to case (num_fns_ref - 3 * n); case (2): fn_ref (num_fns_ref + 1) = addr (null_name); n = n + 1; go to case_x; case (1): /* need two gaps in table. have to open one up */ n = n + 1; fn_ref (num_fns_ref + 2) = addr (null_name); do i = num_fns_ref + 1 by -1 to 2 * n + 1; fn_ref (i) = fn_ref (i - 1); end; fn_ref (2 * n) = addr (null_name); go to case_x; case (0): case_x: do i = 1 by 1 while (i <= n); call ioa_$ioa_switch (stream, "^38a^2x^38a^2x^a", fn_ref (i) -> name, fn_ref (i + n) -> name, fn_ref ((i + n) + n) -> name); end; end list_referenced_functions; end; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved