COMPILATION LISTING OF SEGMENT dump_lisp_code_ Compiled by: Multics PL/I Compiler, Release 28b, of April 11, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 06/30/83 0841.9 mst Thu Options: map single_symbol_list 1 /* ************************************************************** 2* * * 3* * Copyright, (C) Massachusetts Institute of Technology, 1973 * 4* * * 5* ************************************************************** */ 6 /* protect old protection notice */ 7 /* (c) Copyright 1973, Massachusetts Institute of Technology. 8* All rights reserved. */ 9 10 dump_lisp_code_: proc (start, length, stream, tablep); 11 12 /* modified 73.11.24 by DAM for new subr blocks */ 13 14 dcl 15 start fixed bin, 16 length fixed bin, 17 stream ptr, 18 estimated_number_of_labels fixed bin, 19 tablep pointer; 20 21 dcl make_ioa_not_lose fixed bin(35); /* I have to do this because someone gratuitously 22* changed ioa_ so that it no longer works properly */ 23 dcl (convert, addr, divide, fixed, hbound, min, substr, unspec) builtin; 24 25 /* declare various tables which are based on tablep */ 26 27 dcl 1 table aligned structure based(tablep), 28 2 stack_height fixed bin(17), /* add to ap offset to get 2 * temp number */ 29 2 atom_table_size fixed bin, /* size of atom_table array */ 30 2 link_table_ptr unaligned pointer, /* -> array of itp link info */ 31 2 link_table_lbound fixed bin(18), /* first lp| offset of itp link */ 32 2 link_table_hbound fixed bin(18), /* last lp| offset of itp link */ 33 2 array_link_table_ptr unaligned pointer, /* -> array of array_link control words */ 34 2 array_link_table_lbound fixed bin(18), /* first lp| offset of array link */ 35 2 array_link_table_hbound fixed bin(18), /* last lp| offset of array link */ 36 2 definition_table_size fixed bin, /* size of definition_table array */ 37 2 constant_table_size fixed bin, /* size of constant_table array */ 38 2 constant_table_lbound fixed bin(18), /* first lp| offset of constant */ 39 2 constant_table_hbound fixed bin(18), /* last lp| offset of constant */ 40 2 bind_stack_ptr fixed bin, /* index of first unused entry in bind_stack */ 41 2 arg_twiddle fixed bin(18), /* eax5 hacker */ 42 2 seg_ptr unaligned pointer, /* -> text section */ 43 2 bind_stack (100) fixed bin, /* table of sizes of nested binding blocks */ 44 2 atom_table (0 refer(atom_table_size)), /* pointers to atomic symbols */ 45 3 ptr_to_name unaligned pointer, /* -> varying string */ 46 2 definition_table(0 refer(definition_table_size)), /* entries defined... */ 47 3 arg_pdl bit(18) unaligned, /* number of pdl cells occupied by args */ 48 3 entrypoint bit(18) unaligned, /* location of entry */ 49 3 ptr_to_name unaligned pointer, /* -> varying string */ 50 2 constant_table(0 refer(constant_table_size)), 51 3 atom_table_index fixed bin; /* 0 if this constant not an atom */ 52 1 1 /* lisp number format -- overlaid on standard its pointer. */ 1 2 1 3 1 4 dcl 1 fixnum_fmt based aligned, 1 5 2 type_info bit(36) aligned, 1 6 2 fixedb fixed bin, 1 7 1 8 1 flonum_fmt based aligned, 1 9 2 type_info bit(36) aligned, 1 10 2 floatb float bin, 1 11 1 12 fixnum_type bit(36) aligned static init("000000000000000000000100000000100111"b), 1 13 flonum_type bit(36) aligned static init("000000000000000000000010000000100111"b); 1 14 1 15 /* end of lisp number format */ 1 16 53 54 55 /* first pass - construct table of all locations referenced 56* by transfer instructions. Since we don't know how big to make this 57* table, we guess and allocate it in a begin block. If it turns 58* out to be too small, which shouldn't happen very often, 59* we will have to escape from the begin block, and start over 60* with a bigger table */ 61 62 estimated_number_of_labels = 1 + divide(length, 10, 17, 0); 63 go to allocate_tra_table; 64 65 reallocate_tra_table: /* come here if it proved to be too small */ 66 67 estimated_number_of_labels = estimated_number_of_labels * 2; 68 69 allocate_tra_table: begin; 70 71 dcl 1 tra_table aligned automatic structure, 72 2 number_of_labels fixed bin init(0), /* number of entries in use */ 73 2 label(estimated_number_of_labels) structure,/* array of entries */ 74 3 address fixed bin(18), /* location of label */ 75 3 stack_ht fixed bin(18), /* value of stack_height ta tra to label, -1 if not yet known */ 76 3 tra_from fixed bin(18), /* location that transfers to this label */ 77 3 save_bind_stack_ptr fixed bin, /* Value of binding stack ptr */ 78 3 tra_from_others bit(1); /* 1 => it is not the only one */ 79 80 dcl 81 words(0:start+length-1) bit(36) aligned based(base), 82 83 1 word_structure(0:start+length-1) aligned based(base), 84 2 bit3 bit(3) unal, 85 2 addr1 fixed bin(14) unal, 86 2 addr2 fixed bin(17) unal, 87 88 addrf fixed bin(17) unaligned based(addr(words(ic))), /* address field of current instruction */ 89 tag1 fixed bin, 90 address_1 fixed bin, 91 address_2 fixed bin, 92 93 base pointer init(table.seg_ptr), 94 95 mll_internal_error condition, 96 97 curlabx fixed bin, /* index in tra_table of next label we expect to see */ 98 curlabaddr fixed bin(18), /* address of that label */ 99 others char(8), 100 101 ioa_$ioa_switch entry options(variable), 102 convert_sfl_ entry(bit(36) aligned, fixed bin) returns(char(*)), 103 dump_lisp_instruction_ entry(bit(36) aligned, fixed bin(18), pointer, pointer) returns(char(*)), 104 dump_lisp_binding_word_ entry(bit(36) aligned, fixed bin(18), pointer) returns(char(*)), 105 106 bind_operator int static bit(36) init("001000000000010000010111010001010000"b), 107 bb_size fixed bin(18), 108 ref fixed bin(18), 109 (labu, labx, labh) fixed bin, /* for binary seach of label table */ 110 ic fixed bin(18); 111 112 do ic = start repeat(ic+1) while(ic <= start+length-1); 113 114 if (substr(words(ic), 19, 18) & "111111000011111111"b) = "110000000000000100"b /* conditional transfer,ic */ 115 | substr(words(ic), 19, 18) = "111001000000000100"b then do; /* unconditional transfer,ic */ 116 117 ref = ic + addrf; /* location transferred to */ 118 119 /* search label array for previous instance or place to put this one */ 120 121 labu = 1; 122 labh = number_of_labels; 123 do while(labh >= labu); 124 labx = labu + divide(labh-labu, 2, 17, 0); 125 if label(labx).address = ref then go to found_label; 126 else if label(labx).address < ref then labu = labx+1; 127 else labh = labx-1; 128 end; 129 /* now labh < label < labu */ 130 131 number_of_labels = number_of_labels + 1; /* create new lanbel */ 132 if number_of_labels > hbound(label, 1) 133 then go to reallocate_tra_table; /* go get bigger table */ 134 135 do labx = number_of_labels by -1 while(labx > labu); /* move upper part of table up 1 to open new slot in right place */ 136 unspec(label(labx)) = unspec(label(labx-1)); 137 end; 138 139 /* fill in new label */ 140 141 label(labx).address = ref; 142 label(labx).stack_ht = -1; /* not yet known */ 143 label(labx).save_bind_stack_ptr = -1; /* ditto */ 144 label(labx).tra_from = ic; 145 label(labx).tra_from_others = "0"b; 146 go to nextloop; 147 148 found_label: /* another reference to previously-noted label */ 149 150 label(labx).tra_from_others = "1"b; 151 152 nextloop: end; 153 154 else; /* ignore instructions other than transfer instructions */ 155 156 end; 157 158 159 /* second pass - scan through code and display it */ 160 161 curlabx = 1; 162 if number_of_labels = 0 then curlabaddr = -1; 163 else curlabaddr = label(1).address; 164 165 do ic = start repeat(ic+1) while(ic <= start+length-1); 166 167 /* insert a label if one is called for */ 168 169 if ic = curlabaddr then do; 170 if label(curlabx).stack_ht >= 0 171 then stack_height = label(curlabx).stack_ht; 172 if label(curlabx).save_bind_stack_ptr >= 0 173 then bind_stack_ptr = label(curlabx).save_bind_stack_ptr; 174 if label(curlabx).tra_from_others then others = ", et al."; 175 else others = ""; 176 call ioa_$ioa_switch(stream, "tra from ^o^a", label(curlabx).tra_from, others); 177 curlabx = curlabx + 1; 178 if curlabx <= number_of_labels then curlabaddr = label(curlabx).address; 179 else curlabaddr = -1; 180 end; 181 182 if words(ic) = ""b then call ioa_$ioa_switch(stream, "^6o^-^w", ic, words(ic)); 183 else if words(ic) = fixnum_type 184 then do; 185 call ioa_$ioa_switch(stream, "^6o^-^w^-"" fixed constant", ic, words(ic)); 186 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))); 187 ic = ic + 1; 188 end; 189 else if words(ic) = flonum_type 190 then do; 191 call ioa_$ioa_switch(stream, "^6o^-^w^-"" float constant", ic, words(ic)); 192 call ioa_$ioa_switch(stream, "^6o^-^w^-dec ^a", fixed(ic+1,17,0), words(ic+1), convert_sfl_(words(ic+1), 8)); 193 ic = ic+1; 194 end; 195 196 else do; 197 call ioa_$ioa_switch(stream, "^6o^-^w^-^a", ic, words(ic), dump_lisp_instruction_(words(ic), ic, tablep, addr(tra_table))); 198 199 if words(ic) = bind_operator 200 then if ic < start+length 201 then do; 202 /* adjust stack height and push bind stack */ 203 204 bb_size = fixed(substr(words(ic+1), 1, 18), 18); 205 stack_height = stack_height + bb_size; 206 if bind_stack_ptr > hbound(bind_stack, 1) then signal mll_internal_error; 207 bind_stack(bind_stack_ptr) = bb_size; 208 bind_stack_ptr = bind_stack_ptr + 1; 209 210 call ioa_$ioa_switch (stream, "^6o^-^w", fixed(ic+1,17,0), words(ic+1)); 211 212 do ic = ic + 2 to min(start+length-1,fixed(substr(words(ic+1),1,16),17,0)+ic+1); 213 tag1 = fixed(word_structure(ic).bit3, 3, 0); 214 address_1 = word_structure(ic).addr1; 215 address_2 = word_structure(ic).addr2; 216 call ioa_$ioa_switch(stream, "^6o^-^1o ^5a ^6a^-^a", 217 ic, tag1, substr(cv_word(address_1),8,5), substr(cv_word(address_2),7,6), 218 dump_lisp_binding_word_(words(ic), ic, tablep)); 219 end; 220 221 ic = ic - 1; /* undo do loop slightly. */ 222 223 end; 224 end; 225 end; 226 227 return; 228 229 cv_word: proc(word) returns(char(12)); 230 231 dcl ioa_$rsnpnnl entry options(variable), 232 word fixed bin, 233 temp char(12), 234 templ fixed bin; 235 236 call ioa_$rsnpnnl("^w",temp,templ,word); 237 return (temp); 238 239 end cv_word; 240 241 end allocate_tra_table; 242 243 end dump_lisp_code_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 06/29/83 1541.3 dump_lisp_code_.pl1 >special_ldd>on>06/27/83>dump_lisp_code_.pl1 53 1 03/27/82 0437.0 lisp_nums.incl.pl1 >ldd>include>lisp_nums.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) addr builtin function dcl 23 ref 117 197 197 addr1 0(03) based fixed bin(14,0) array level 2 packed unaligned dcl 80 ref 214 addr2 0(18) based fixed bin(17,0) array level 2 packed unaligned dcl 80 ref 215 address 1 000100 automatic fixed bin(18,0) array level 3 dcl 71 set ref 125 126 141* 163 178 address_1 000101 automatic fixed bin(17,0) dcl 80 set ref 214* 216* 216* address_2 000102 automatic fixed bin(17,0) dcl 80 set ref 215* 216* 216* addrf based fixed bin(17,0) unaligned dcl 80 ref 117 allocate_tra_table 000124 constant label dcl 69 ref 63 base 000104 automatic pointer initial dcl 80 set ref 80* 114 114 117 182 182 183 185 186 186 186 189 191 192 192 197 197 199 204 210 212 213 214 215 216 bb_size 000120 automatic fixed bin(18,0) dcl 80 set ref 204* 205 207 bind_operator 000000 constant bit(36) initial unaligned dcl 80 ref 199 bind_stack 17 based fixed bin(17,0) array level 2 dcl 27 set ref 206 207* bind_stack_ptr 14 based fixed bin(17,0) level 2 dcl 27 set ref 172* 206 207 208* 208 bit3 based bit(3) array level 2 packed unaligned dcl 80 ref 213 convert builtin function dcl 23 ref 186 186 convert_sfl_ 000012 constant entry external dcl 80 ref 192 curlabaddr 000115 automatic fixed bin(18,0) dcl 80 set ref 162* 163* 169 178* 179* curlabx 000114 automatic fixed bin(17,0) dcl 80 set ref 161* 170 170 172 172 174 176 177* 177 178 178 cv_word 001366 constant entry internal dcl 229 ref 216 216 216 216 divide builtin function dcl 23 ref 62 124 dump_lisp_binding_word_ 000016 constant entry external dcl 80 ref 216 dump_lisp_code_ 000106 constant entry external dcl 10 dump_lisp_instruction_ 000014 constant entry external dcl 80 ref 197 estimated_number_of_labels 000100 automatic fixed bin(17,0) dcl 14 set ref 62* 65* 65 71 fixed builtin function dcl 23 ref 186 186 192 192 204 210 210 212 213 fixnum_fmt based structure level 1 dcl 1-4 fixnum_type constant bit(36) initial dcl 1-4 ref 183 flonum_fmt based structure level 1 dcl 1-4 flonum_type constant bit(36) initial dcl 1-4 ref 189 found_label 000323 constant label dcl 148 ref 125 hbound builtin function dcl 23 ref 132 206 ic 000125 automatic fixed bin(18,0) dcl 80 set ref 112* 112* 114 114 117 117 144* 156 165* 165* 169 182 182* 182 183 185* 185 186 186 186 186 186 187* 187 189 191* 191 192 192 192 192 193* 193 197* 197 197 197* 199 199 204 210 210 210 212* 212 212 212* 213 214 215 216* 216 216* 221* 221* 225 ioa_$ioa_switch 000010 constant entry external dcl 80 ref 176 182 185 186 191 192 197 210 216 ioa_$rsnpnnl 000020 constant entry external dcl 231 ref 236 label 1 000100 automatic structure array level 2 dcl 71 set ref 132 136* 136 labh 000124 automatic fixed bin(17,0) dcl 80 set ref 122* 123 124 127* labu 000122 automatic fixed bin(17,0) dcl 80 set ref 121* 123 124 124 126* 135 labx 000123 automatic fixed bin(17,0) dcl 80 set ref 124* 125 126 126 127 135* 135* 136 136* 141 142 143 144 145 148 length parameter fixed bin(17,0) dcl 14 ref 10 62 112 165 199 212 make_ioa_not_lose automatic fixed bin(35,0) dcl 21 ref 186 186 min builtin function dcl 23 ref 212 mll_internal_error 000106 stack reference condition dcl 80 ref 206 nextloop 000327 constant label dcl 152 ref 146 number_of_labels 000100 automatic fixed bin(17,0) initial level 2 dcl 71 set ref 71* 122 131* 131 132 135 162 178 others 000116 automatic char(8) unaligned dcl 80 set ref 174* 175* 176* reallocate_tra_table 000121 constant label dcl 65 ref 132 ref 000121 automatic fixed bin(18,0) dcl 80 set ref 117* 125 126 141 save_bind_stack_ptr 4 000100 automatic fixed bin(17,0) array level 3 dcl 71 set ref 143* 172 172 seg_ptr 16 based pointer level 2 packed unaligned dcl 27 ref 80 stack_height based fixed bin(17,0) level 2 dcl 27 set ref 170* 205* 205 stack_ht 2 000100 automatic fixed bin(18,0) array level 3 dcl 71 set ref 142* 170 170 start parameter fixed bin(17,0) dcl 14 ref 10 112 112 165 165 199 212 stream parameter pointer dcl 14 set ref 10 176* 182* 185* 186* 191* 192* 197* 210* 216* substr builtin function dcl 23 ref 114 114 204 212 216 216 216 216 table based structure level 1 dcl 27 tablep parameter pointer dcl 14 set ref 10 80 170 172 197* 205 205 206 206 207 207 208 208 216* tag1 000100 automatic fixed bin(17,0) dcl 80 set ref 213* 216* temp 000142 automatic char(12) unaligned dcl 231 set ref 236* 237 templ 000145 automatic fixed bin(17,0) dcl 231 set ref 236* tra_from 3 000100 automatic fixed bin(18,0) array level 3 dcl 71 set ref 144* 176* tra_from_others 5 000100 automatic bit(1) array level 3 dcl 71 set ref 145* 148* 174 tra_table 000100 automatic structure level 1 dcl 71 set ref 197 197 unspec builtin function dcl 23 set ref 136* 136 word parameter fixed bin(17,0) dcl 231 set ref 229 236* word_structure based structure array level 1 dcl 80 words based bit(36) array dcl 80 set ref 114 114 117 182 182* 183 185* 186* 186 186 189 191* 192* 192* 197* 197* 199 204 210* 212 216* STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1536 1560 1442 1546 Length 1760 1442 22 163 73 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME dump_lisp_code_ 65 external procedure is an external procedure. begin block on line 69 224 begin block uses auto adjustable storage. cv_word internal procedure shares stack frame of begin block on line 69. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME begin block on line 69 000100 tag1 begin block on line 69 000100 tra_table begin block on line 69 000101 address_1 begin block on line 69 000102 address_2 begin block on line 69 000104 base begin block on line 69 000114 curlabx begin block on line 69 000115 curlabaddr begin block on line 69 000116 others begin block on line 69 000120 bb_size begin block on line 69 000121 ref begin block on line 69 000122 labu begin block on line 69 000123 labx begin block on line 69 000124 labh begin block on line 69 000125 ic begin block on line 69 000142 temp cv_word 000145 templ cv_word dump_lisp_code_ 000100 estimated_number_of_labels dump_lisp_code_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as enter_begin call_ext_out_desc begin_return return tra_ext alloc_auto_adj signal shorten_stack ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. convert_sfl_ dump_lisp_binding_word_ dump_lisp_instruction_ ioa_$ioa_switch ioa_$rsnpnnl NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 10 000101 62 000113 63 000120 65 000121 69 000124 71 000127 80 000140 176 000145 112 000147 114 000161 117 000176 121 000202 122 000204 123 000206 124 000211 125 000215 126 000223 127 000234 128 000237 131 000240 132 000241 135 000247 136 000255 137 000270 141 000273 142 000300 143 000305 144 000312 145 000317 146 000322 148 000323 156 000327 161 000331 162 000333 163 000340 165 000343 169 000355 170 000360 172 000372 174 000404 175 000413 176 000415 177 000452 178 000453 179 000463 182 000465 183 000524 185 000527 186 000563 187 000633 188 000634 189 000635 191 000640 192 000674 193 000772 194 000774 197 000775 199 001074 204 001107 205 001113 206 001115 207 001125 208 001136 210 001141 212 001177 213 001225 214 001230 215 001235 216 001241 219 001354 221 001357 225 001361 227 001363 241 001365 229 001366 236 001370 237 001417 243 001425 ----------------------------------------------------------- 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