1 /****^ ****************************************************** 2 * * 3 * Copyright (c) 1986 by Massachusetts Institute of * 4 * Technology and Honeywell Information Systems, Inc. * 5 * * 6 * Copyright (c) 1972 by Massachusetts Institute of * 7 * Technology and Honeywell Information Systems, Inc. * 8 * * 9 ****************************************************** */ 10 11 12 /****^ HISTORY COMMENTS: 13 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), 14 audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212): 15 Added PASCAL entry points parsing. 16 END HISTORY COMMENTS */ 17 18 /* Procedure to get a pointer to the runtime symbol block for a PL/I 19 program given a pointer to its stack frame and optionally an execution loc 20 21 modified: 06 Oct 78 by James R. Davis for separate static begin blocks, greater cleanliness 22 and not assume ic is in frame owners block 23 Modified: 25 Aug 79 by JRD to find symbol section header by object info, not link 24 Modified: JMAthane, September 82 to add PASCAL entry points 25 */ 26 get_block: proc (stack_pt, header_pt, block_pt); 27 28 dcl (stack_pt ptr, /* points at stack frame (input) */ 29 header_pt ptr, /* set to point at symbol header */ 30 block_pt ptr) parameter; /* set to point at symbol block */ 31 32 dcl p ptr, /* into object seg */ 33 sp ptr, /* copy of stack_pt */ 34 ic fixed bin, /* offset of execution, or -1 if not supplied */ 35 i fixed bin, 36 based_ptr based ptr, 37 based_word bit (36) based, /* for search for instructions */ 38 rel_to_next bit (18), /* self relative offset for symbol table search */ 39 bitcount fixed bin (24), 40 code fixed bin (35), 41 trans fixed bin; /* translator that produced object seg */ 42 43 dcl 1 oi aligned like object_info; 44 45 dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); 46 dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); 47 dcl (addr, addrel, fixed, null, pointer) builtin; 48 49 dcl 1 structure aligned based, /* two words placed by PL/I in entry sequence */ 50 2 ignore bit (36), /* various flags we dont care about */ 51 2 head_offset bit (18) unal, /* offset in linkage sec of ptr to header */ 52 2 block_offset bit (18) unal; /* offset from header to frame owner block node */ 53 54 %page; 55 56 /* no location available with this entry */ 57 58 ic = -1; 59 60 join: sp = stack_pt; 61 header_pt, block_pt = null; /* assume the worst */ 62 if sp = null then return; /* cant find translator or entry ptr, give up */ 63 64 trans = fixed (sp -> frame.translator_id, 18); /* who made this seg? */ 65 if trans = 0 then do; /* PL/I version 2 */ 66 p = addrel (sp -> frame.entry, 1); 67 if p -> based_word ^= "000614272100"b3 /* tsp2 pr0|614 enter_begin */ 68 & p -> based_word ^= "001376272100"b3 /* tsp2 pr0|1376 ss_enter_begin */ 69 then p = addrel (p, 2); /* not a begin block, so skip two instructions */ 70 end; 71 else if trans = 2 then do; /* PL/I version 1 */ 72 p = addrel (p, 3); 73 74 /* in version 1 the header and block offsets are marked by a preceeding 75 tra 2,ic instruction, which is anywhere from 3 to 8 words past the address 76 pointed to by the entry pointer */ 77 78 do i = 3 to 8; 79 if p -> based_word = "000002710004"b3 then goto found_tra; 80 p = addrel (p, 1); 81 end; 82 return; /* fell through, its not there ! */ 83 found_tra: end; /* of version one */ 84 else if trans = 8 then do; /* Grenoble University PASCAL */ 85 p = addrel (sp -> frame.entry, 2); /* 3rd word */ 86 if (p -> based_word ^= "000001273100"b3) /* tsp3 0|1 : old internal */ 87 & (p -> based_word ^= "000064273100"b3) /* tsp3 0|52 : internal */ 88 & (p -> based_word ^= "000131273100"b3) /* tsp3 0|89 : v7 int_entry */ 89 then do; 90 p = addrel (p, 2); /* 5th word */ 91 if (p -> based_word ^= "500002273100"b3) /* tsp3 5|2 : old exportable */ 92 & (p -> based_word ^= "500055273100"b3) /* tsp3 5|45 : old exportable fast */ 93 & (p -> based_word ^= "500065273100"b3) /* tsp3 5|53 : exportable */ 94 & (p -> based_word ^= "500067273100"b3) /* tsp3 5|55 : exportable fast */ 95 then do; 96 p = addrel (p, 1); /* 6th word */ 97 if (p -> based_word ^= "200117273100"b3) /* tsp3 2|79 : v7 MAIN_entry */ 98 & (p -> based_word ^= "200130273100"b3) /* tsp3 2|88 : v7 ext_entry */ 99 then do; 100 p = addrel (p, 2); /* 8th word */ 101 if (p -> based_word ^= "500000273100"b3) /* tsp3 5|0 : old MAIN */ 102 & (p -> based_word ^= "500054273100"b3) /* tsp3 5|44 : old MAIN_fast */ 103 & (p -> based_word ^= "500063273100"b3) /* tsp3 5|51 : MAIN */ 104 & (p -> based_word ^= "500066273100"b3) /* tsp3 5|54 MAIN fast */ 105 then return; 106 end; 107 end; 108 end; 109 p = addrel (p, 1); 110 end; 111 else return; /* no other language is supported */ 112 113 /* now p points to the two word structure where symbol table ptrs are */ 114 115 if p -> structure.head_offset = (18)"0"b then return; /* no symbol table */ 116 117 /* in former days, we got a pointer to the symbol section header by snapping the link *symbol, 118 which is found at offselt {p -> structure.head_offset} in the linkage section 119 120 This is not a good idea though, because a run unit may have been entered since the time 121 that the program called out, which means that snapping links will not work. Run units 122 work by setting up a whole new name space. 123 */ 124 125 call hcs_$status_mins (pointer (p, 0), (0), bitcount, code); 126 if code ^= 0 then return; 127 oi.version_number = object_info_version_2; 128 call object_info_$brief (pointer (p, 0), bitcount, addr (oi), code); 129 if code ^= 0 then return; 130 header_pt = oi.symbp; 131 132 /* if the seg is bound, then header_pt is to header of the whole seg. Thats OK, because the 133 have the offset relative to the header of the block node we are interested in. From that block node 134 we can get the ptr to the header we want. 135 */ 136 137 138 block_pt = addrel (header_pt, p -> structure.block_offset); 139 140 if ^block_pt -> runtime_block.flag then return; /* not modern symbol table, can do no more */ 141 142 if ic < 0 then return; /* cant be a quick block */ 143 144 /* get pointer to the root symbol_block for this seg. The seg may be bound, we cant trust 145 header_pt, as it may be the header for the bound seg as a whole. Find the header for the component */ 146 147 p = addrel (block_pt, block_pt -> runtime_block.header); /* point to header */ 148 block_pt = addrel (p, p -> std_symbol_header.area_pointer); /* point to pl1 symbol block */ 149 block_pt = addrel (p, block_pt -> pl1_symbol_block.root); /* point at first block */ 150 block_pt = addrel (block_pt, block_pt -> runtime_block.son); /* skip the root, its useless */ 151 152 /* now search from the first block (root) for the smallest block that contains ic */ 153 154 rel_to_next = "1"b; /* make sure we enter loop */ 155 do p = block_pt repeat addrel (p, rel_to_next) while (rel_to_next ^= (18)"0"b); 156 if ic >= fixed (addrel (p, p -> runtime_block.first) -> statement_map.location, 18) 157 & ic <= fixed (addrel (p, p -> runtime_block.last) -> statement_map.location, 18) 158 then do; 159 block_pt = p; /* we are in this block */ 160 rel_to_next = p -> runtime_block.son; /* search son if there is one */ 161 end; 162 else rel_to_next = p -> runtime_block.brother; /* else brother */ 163 end; 164 return; 165 166 get_runtime_block: entry (stack_pt, header_pt, block_pt, loc); 167 168 dcl loc fixed bin parameter; 169 170 /* this entry is called when a location in the object seg is available 171 One should not expect stu_ to do without the stack_pt, 172 even though stu could find the symbol information without it. It is up to 173 the caller to get it */ 174 175 ic = loc; 176 goto join; 177 %page; 178 %include stu_frame; 179 %include runtime_symbol; 180 %include std_symbol_header; 181 %include pl1_symbol_block; 182 %include statement_map; 183 %include object_info; 184 185 end get_block;