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;