1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 /* Check the alignment attribute of all short string parameters in the called
 12    and calling program and insure that the attributes match.  This is done
 13    only if the argument is a member of a structure and starts on a word
 14    boundary.  This tool only checks programs for some cases of invalid PL/I
 15    that happened to work before PL/I Release 26, but will no longer work
 16    starting with PL/I Release 26.
 17 
 18    Written 2 June 1980 by PCK.
 19    Modified 16 June 1980 by M. N. Davidoff to invoke the compiler.
 20    Modified 7 July 1980 by M. N. Davidoff to check if get_entry_arg_descs_ returns a zero code and null pointers.
 21    Modified 9 July 1980 by M. N. Davidoff to add ALLOW_EXL.
 22 */
 23 /* format: style3 */
 24 check_short_strings:
 25      procedure options (variable);
 26 
 27 /* automatic */
 28 
 29 dcl       arg_count           fixed bin;
 30 dcl       arg_length          fixed bin (21);
 31 dcl       arg_ptr             ptr;
 32 dcl       argument_no         fixed bin;
 33 dcl       argx                fixed bin;
 34 dcl       1 auto_area_info    aligned like area_info;
 35 dcl       code                fixed bin (35);
 36 dcl       source_dname        char (168);
 37 dcl       source_ename        char (32);
 38 
 39 /* based */
 40 
 41 dcl       arg_string          char (arg_length) based (arg_ptr);
 42 
 43 /* builtin */
 44 
 45 dcl       (after, addr, before, codeptr, hbound, index, mod, null, reverse, rtrim, unspec)
 46                               builtin;
 47 
 48 /* condition */
 49 
 50 dcl       cleanup             condition;
 51 
 52 /* internal static */
 53 
 54 dcl       ALLOW_EXL           bit (1) aligned internal static options (constant) initial ("0"b);
 55 dcl       command             char (19) internal static options (constant) initial ("check_short_strings");
 56 
 57 /* external static */
 58 
 59 dcl       error_table_$badopt fixed bin (35) external static;
 60 dcl       pl1$pl1_release     char (3) varying external static;
 61 dcl       pl1_stat_$root      ptr external static;
 62 dcl       sys_info$max_seg_size
 63                               fixed bin (19) external static;
 64 
 65 /* entry */
 66 
 67 dcl       change_wdir_        entry (char (168) aligned, fixed bin (35));
 68 dcl       com_err_            entry options (variable);
 69 dcl       com_err_$suppress_name
 70                               entry options (variable);
 71 dcl       cu_$arg_count       entry (fixed bin);
 72 dcl       cu_$arg_ptr         entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 73 dcl       define_area_        entry (ptr, fixed bin (35));
 74 dcl       delete_$path        entry (char (*), char (*), bit (6), char (*), fixed bin (35));
 75 dcl       expand_pathname_$add_suffix
 76                               entry (char (*), char (*), char (*), char (*), fixed bin (35));
 77 dcl       get_entry_arg_descs_
 78                               entry (ptr, fixed bin, (*) ptr, fixed bin (35));
 79 dcl       get_pdir_           entry () returns (char (168));
 80 dcl       get_wdir_           entry () returns (char (168));
 81 dcl       hcs_$make_ptr       entry (ptr, char (*), char (*), ptr, fixed bin (35));
 82 dcl       ioa_                entry options (variable);
 83 dcl       pl1                 entry options (variable);
 84 dcl       pl1$clean_up        entry options (variable);
 85 dcl       release_area_       entry (ptr);
 86 ^L
 87 %include block;
 88 %include statement;
 89 %include operator;
 90 %include reference;
 91 %include symbol;
 92 %include nodes;
 93 %include token;
 94 %include op_codes;
 95 %include list;
 96 %include cgsystem;
 97 %include area_info;
 98 %include arg_descriptor;
 99 ^L
100 /* program */
101 
102           if rtrim (pl1$pl1_release, "abcdefghijklmnopqrstuvwxyz") ^= "26" & (^ALLOW_EXL | pl1$pl1_release ^= "EXL")
103           then do;
104                     call com_err_ (0, command, "Only PL/I Release 26^[ or EXL PL/I^] may be used. PL/I ^a", ALLOW_EXL,
105                          pl1$pl1_release);
106                     return;
107                end;
108 
109           call cu_$arg_count (arg_count);
110           argument_no = 0;
111           do argx = 1 to arg_count;
112                call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
113                if code ^= 0
114                then do;
115                          call com_err_ (code, command, "Argument ^d.", argx);
116                          return;
117                     end;
118 
119                if index (arg_string, "-") = 1
120                then do;
121                          call com_err_ (error_table_$badopt, command, "^a", arg_string);
122                          return;
123                     end;
124 
125                else do;
126                          argument_no = argument_no + 1;
127 
128                          if argument_no = 1
129                          then do;
130                                    call expand_pathname_$add_suffix (arg_string, "pl1", source_dname, source_ename, code);
131                                    if code ^= 0
132                                    then do;
133                                              call com_err_ (code, command, "^a", arg_string);
134                                              return;
135                                         end;
136                               end;
137                     end;
138           end;
139 
140           if argument_no ^= 1
141           then do;
142                     call com_err_$suppress_name (0, command, "Usage: ^a path", command);
143                     return;
144                end;
145 
146           unspec (auto_area_info) = ""b;
147           auto_area_info.version = area_info_version_1;
148           auto_area_info.owner = command;
149           auto_area_info.areap = null;
150           auto_area_info.no_freeing = "1"b;
151           auto_area_info.size = sys_info$max_seg_size;
152 
153           on cleanup call cleanup_procedure;
154 
155           call define_area_ (addr (auto_area_info), code);
156           if code ^= 0
157           then do;
158                     call com_err_ (code, command, "From define_area_.");
159                     return;
160                end;
161 
162           call ioa_ ("Checking ^a", source_ename);
163 
164           call compile_program (code);
165           if code ^= 0
166           then do;
167                     call cleanup_procedure;
168                     return;
169                end;
170 
171           call traverse_blocks (pl1_stat_$root);
172 
173           call cleanup_procedure;
174 
175           return;
176 ^L
177 /* Compile the program in the process directory. */
178 
179 compile_program:
180      procedure (code);
181 
182 dcl       code                fixed bin (35);               /* (Output) */
183 
184 dcl       object_seg_ename    char (32);
185 dcl       working_dir         char (168) aligned;
186 dcl       process_dir         char (168) internal static initial ("");
187 
188           code = 0;
189 
190           if process_dir = ""
191           then process_dir = get_pdir_ ();
192 
193           object_seg_ename = reverse (after (reverse (rtrim (source_ename)), reverse (".pl1")));
194           working_dir = get_wdir_ ();
195 
196           on cleanup
197                begin;
198                     call change_wdir_ (working_dir, code);
199                     call delete_$path (process_dir, object_seg_ename, "000100"b, command, code);
200                end;
201 
202           call change_wdir_ ((process_dir), code);
203           if code ^= 0
204           then do;
205                     call com_err_ (code, command, "Changing working directory to ^a.", process_dir);
206                     return;
207                end;
208 
209           call pl1 (rtrim (source_dname) || ">" || rtrim (source_ename), "-debug");
210 
211           call change_wdir_ (working_dir, code);
212           if code ^= 0
213           then do;
214                     call com_err_ (code, command, "Changing working directory to ^a.", working_dir);
215                     return;
216                end;
217 
218           call delete_$path (process_dir, object_seg_ename, "000100"b, command, code);
219           if code ^= 0
220           then do;
221                     call com_err_ (code, command, "Deleting ^a>^a.", process_dir, object_seg_ename);
222                     return;
223                end;
224      end compile_program;
225 ^L
226 /* Walk block tree */
227 
228 traverse_blocks:
229      procedure (P_cur_block);
230 
231 dcl       P_cur_block         ptr;                          /* (Input) */
232 
233 dcl       cur_block           ptr;
234 
235           cur_block = P_cur_block;
236 
237           call traverse_statements (cur_block -> block.prologue);
238           call traverse_statements (cur_block -> block.main);
239 
240           do cur_block = cur_block -> block.son repeat cur_block -> block.brother while (cur_block ^= null);
241                call traverse_blocks (cur_block);
242           end;
243 
244           return;
245 
246 /* Walk a list of statements */
247 
248 traverse_statements:
249      procedure (P_cur_statement);
250 
251 dcl       P_cur_statement     ptr unaligned;                /* (Input) */
252 
253 dcl       cur_statement       ptr;
254 
255           do cur_statement = P_cur_statement repeat cur_statement -> statement.next while (cur_statement ^= null);
256                call traverse_computation_tree (cur_statement -> statement.root);
257           end;
258 
259           return;
260 ^L
261 /* Walk computation tree */
262 
263 traverse_computation_tree:
264      procedure (tree);
265 
266 dcl       tree                ptr unaligned;                /* (Input) */
267 
268 dcl       operand_index       fixed bin;
269 
270           if tree = null
271           then return;
272 
273           if tree -> node.type = operator_node
274           then if tree -> operator.op_code = std_call
275                then call check_call_operator (tree);
276 
277                else do operand_index = 1 to tree -> operator.number;
278                          call traverse_computation_tree (tree -> operator.operand (operand_index));
279                     end;
280 
281           else if tree -> node.type = reference_node
282           then do;
283                     call traverse_computation_tree (tree -> reference.offset);
284                     call traverse_computation_tree (tree -> reference.length);
285                     call traverse_computation_tree (tree -> reference.qualifier);
286                end;
287 
288           return;
289 ^L
290 /* Check the call operator for any short unaligned strings in a structure that
291    are passed by reference */
292 
293 check_call_operator:
294      procedure (tree);
295 
296 dcl       tree                ptr unaligned;                /* (Input) */
297 
298 dcl       s                   ptr;
299 
300 /* exclude entry valued functions */
301 
302           if tree -> operator.operand (2) -> node.type ^= reference_node
303           then return;
304 
305           s = tree -> operator.operand (2) -> reference.symbol;
306 
307 /* exclude entry variables, internal procedures, and options(variable) procedures */
308 
309           if s -> symbol.variable | s -> symbol.internal | s -> symbol.options & s -> symbol.variable_arg_list
310           then return;
311 
312           if tree -> operator.operand (3) = null
313           then return;
314 
315           call check_arg_list (tree -> operator.operand (3) -> operator.operand (2));
316 
317           return;
318 
319 /* Check argument list for unaligned short strings passed by reference with
320    fractional offsets of zero that are members of structures */
321 
322 check_arg_list:
323      procedure (arg_list);
324 
325 dcl       arg_list            ptr unaligned;                /* (Input) */
326 
327 dcl       argument            ptr;
328 dcl       arg_index           fixed bin;
329 
330           do arg_index = 1 to arg_list -> list.number;
331                argument = arg_list -> list.element (arg_index);
332 
333                if argument -> node.type = reference_node
334                then if (argument -> reference.symbol -> symbol.bit | argument -> reference.symbol -> symbol.char)
335                          & argument -> reference.symbol -> symbol.non_varying
336                          & argument -> reference.symbol -> symbol.unaligned & argument -> reference.symbol -> symbol.member
337                          & ^argument -> reference.symbol -> symbol.temporary & ^argument -> reference.long_ref
338                          & mod (argument -> reference.c_offset, units_per_word (argument -> reference.units)) = 0
339                     then call check_parameter;
340           end;
341 
342           return;
343 ^L
344 /* Check parameter, if possible, for called entry */
345 
346 check_parameter:
347      procedure;
348 
349 /* automatic */
350 
351 dcl       entry_name          char (32);
352 dcl       entry_point_name    char (256);
353 dcl       entry_point_ptr     ptr;
354 
355 /* based */
356 
357 dcl       cst_storage         area (auto_area_info.size) based (auto_area_info.areap);
358 dcl       1 expected          aligned based,
359             2 no_args         fixed bin,
360             2 descs           (64) ptr;
361 
362 /* symbol.reserved_1 and symbol.reserved_2 are just unused bits in the symbol node that we are borrowing.  They are guaranteed
363    to be zero by pl1_nodes_template_ when we start. */
364 
365           if s -> symbol.reserved_2
366           then return;
367 
368           if ^s -> symbol.reserved_1
369           then do;
370                     entry_name = before (s -> symbol.token -> token.string, "$");
371 
372                     entry_point_name = after (s -> symbol.token -> token.string, "$");
373                     if entry_point_name = ""
374                     then entry_point_name = entry_name;
375 
376                     call hcs_$make_ptr (codeptr (check_short_strings), entry_name, entry_point_name, entry_point_ptr, code);
377                     if code ^= 0
378                     then do;
379                               s -> symbol.reserved_2 = "1"b;
380                               call com_err_ (code, command, "Getting a pointer to ^a.", s -> symbol.token -> token.string);
381                               return;
382                          end;
383 
384                     allocate expected in (cst_storage) set (s -> symbol.general);
385 
386                     call get_entry_arg_descs_ (entry_point_ptr, s -> symbol.general -> expected.no_args,
387                          s -> symbol.general -> expected.descs, code);
388                     if code ^= 0
389                     then do;
390                               s -> symbol.reserved_2 = "1"b;
391                               call com_err_ (code, command, "Getting entry descriptors for ^a.",
392                                    s -> symbol.token -> token.string);
393                               return;
394                          end;
395 
396                     s -> symbol.reserved_1 = "1"b;
397                end;
398 
399           if arg_index > s -> symbol.general -> expected.no_args
400           then do;
401                     s -> symbol.reserved_2 = "1"b;
402                     call com_err_ (0, command, "Call of ^a has too many arguments.", s -> symbol.token -> token.string);
403                     return;
404                end;
405 
406           if arg_index > hbound (s -> symbol.general -> expected.descs, 1)
407           then do;
408                     call com_err_ (0, command, "Call of ^a exceeds internal limit of ^d arguments.",
409                          s -> symbol.token -> token.string, hbound (s -> symbol.general -> expected.descs, 1));
410                     return;
411                end;
412 
413           if s -> symbol.general -> expected.descs (arg_index) = null
414           then do;
415                     s -> symbol.reserved_2 = "1"b;
416                     call com_err_ (0, command, "Obsolete object segment format. ^a", s -> symbol.token -> token.string);
417                     return;
418                end;
419 
420 /* Verify that the descriptors are version 2 (version 1 is no problem) */
421 
422           if ^s -> symbol.general -> expected.descs (arg_index) -> arg_descriptor.flag
423           then return;
424 
425 /* Check to see that the called program expects an unaligned (packed) string */
426 
427           if ^s -> symbol.general -> expected.descs (arg_index) -> arg_descriptor.packed
428           then do;
429                     s -> symbol.reserved_2 = "1"b;
430                     call com_err_ (0, command, "Call of ^a has a short string parameter mismatch.",
431                          s -> symbol.token -> token.string);
432                     return;
433                end;
434      end check_parameter;
435 
436      end check_arg_list;
437 
438      end check_call_operator;
439 
440      end traverse_computation_tree;
441 
442      end traverse_statements;
443 
444      end traverse_blocks;
445 
446 /* Free temporary storage. */
447 
448 cleanup_procedure:
449      procedure;
450 
451           call pl1$clean_up;
452           call release_area_ (auto_area_info.areap);
453      end cleanup_procedure;
454 
455      end check_short_strings;