/* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Check the alignment attribute of all short string parameters in the called and calling program and insure that the attributes match. This is done only if the argument is a member of a structure and starts on a word boundary. This tool only checks programs for some cases of invalid PL/I that happened to work before PL/I Release 26, but will no longer work starting with PL/I Release 26. Written 2 June 1980 by PCK. Modified 16 June 1980 by M. N. Davidoff to invoke the compiler. Modified 7 July 1980 by M. N. Davidoff to check if get_entry_arg_descs_ returns a zero code and null pointers. Modified 9 July 1980 by M. N. Davidoff to add ALLOW_EXL. */ /* format: style3 */ check_short_strings: procedure options (variable); /* automatic */ dcl arg_count fixed bin; dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl argument_no fixed bin; dcl argx fixed bin; dcl 1 auto_area_info aligned like area_info; dcl code fixed bin (35); dcl source_dname char (168); dcl source_ename char (32); /* based */ dcl arg_string char (arg_length) based (arg_ptr); /* builtin */ dcl (after, addr, before, codeptr, hbound, index, mod, null, reverse, rtrim, unspec) builtin; /* condition */ dcl cleanup condition; /* internal static */ dcl ALLOW_EXL bit (1) aligned internal static options (constant) initial ("0"b); dcl command char (19) internal static options (constant) initial ("check_short_strings"); /* external static */ dcl error_table_$badopt fixed bin (35) external static; dcl pl1$pl1_release char (3) varying external static; dcl pl1_stat_$root ptr external static; dcl sys_info$max_seg_size fixed bin (19) external static; /* entry */ dcl change_wdir_ entry (char (168) aligned, fixed bin (35)); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl define_area_ entry (ptr, fixed bin (35)); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_entry_arg_descs_ entry (ptr, fixed bin, (*) ptr, fixed bin (35)); dcl get_pdir_ entry () returns (char (168)); dcl get_wdir_ entry () returns (char (168)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl pl1 entry options (variable); dcl pl1$clean_up entry options (variable); dcl release_area_ entry (ptr); %include block; %include statement; %include operator; %include reference; %include symbol; %include nodes; %include token; %include op_codes; %include list; %include cgsystem; %include area_info; %include arg_descriptor; /* program */ if rtrim (pl1$pl1_release, "abcdefghijklmnopqrstuvwxyz") ^= "26" & (^ALLOW_EXL | pl1$pl1_release ^= "EXL") then do; call com_err_ (0, command, "Only PL/I Release 26^[ or EXL PL/I^] may be used. PL/I ^a", ALLOW_EXL, pl1$pl1_release); return; end; call cu_$arg_count (arg_count); argument_no = 0; do argx = 1 to arg_count; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; if index (arg_string, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg_string); return; end; else do; argument_no = argument_no + 1; if argument_no = 1 then do; call expand_pathname_$add_suffix (arg_string, "pl1", source_dname, source_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a", arg_string); return; end; end; end; end; if argument_no ^= 1 then do; call com_err_$suppress_name (0, command, "Usage: ^a path", command); return; end; unspec (auto_area_info) = ""b; auto_area_info.version = area_info_version_1; auto_area_info.owner = command; auto_area_info.areap = null; auto_area_info.no_freeing = "1"b; auto_area_info.size = sys_info$max_seg_size; on cleanup call cleanup_procedure; call define_area_ (addr (auto_area_info), code); if code ^= 0 then do; call com_err_ (code, command, "From define_area_."); return; end; call ioa_ ("Checking ^a", source_ename); call compile_program (code); if code ^= 0 then do; call cleanup_procedure; return; end; call traverse_blocks (pl1_stat_$root); call cleanup_procedure; return; /* Compile the program in the process directory. */ compile_program: procedure (code); dcl code fixed bin (35); /* (Output) */ dcl object_seg_ename char (32); dcl working_dir char (168) aligned; dcl process_dir char (168) internal static initial (""); code = 0; if process_dir = "" then process_dir = get_pdir_ (); object_seg_ename = reverse (after (reverse (rtrim (source_ename)), reverse (".pl1"))); working_dir = get_wdir_ (); on cleanup begin; call change_wdir_ (working_dir, code); call delete_$path (process_dir, object_seg_ename, "000100"b, command, code); end; call change_wdir_ ((process_dir), code); if code ^= 0 then do; call com_err_ (code, command, "Changing working directory to ^a.", process_dir); return; end; call pl1 (rtrim (source_dname) || ">" || rtrim (source_ename), "-debug"); call change_wdir_ (working_dir, code); if code ^= 0 then do; call com_err_ (code, command, "Changing working directory to ^a.", working_dir); return; end; call delete_$path (process_dir, object_seg_ename, "000100"b, command, code); if code ^= 0 then do; call com_err_ (code, command, "Deleting ^a>^a.", process_dir, object_seg_ename); return; end; end compile_program; /* Walk block tree */ traverse_blocks: procedure (P_cur_block); dcl P_cur_block ptr; /* (Input) */ dcl cur_block ptr; cur_block = P_cur_block; call traverse_statements (cur_block -> block.prologue); call traverse_statements (cur_block -> block.main); do cur_block = cur_block -> block.son repeat cur_block -> block.brother while (cur_block ^= null); call traverse_blocks (cur_block); end; return; /* Walk a list of statements */ traverse_statements: procedure (P_cur_statement); dcl P_cur_statement ptr unaligned; /* (Input) */ dcl cur_statement ptr; do cur_statement = P_cur_statement repeat cur_statement -> statement.next while (cur_statement ^= null); call traverse_computation_tree (cur_statement -> statement.root); end; return; /* Walk computation tree */ traverse_computation_tree: procedure (tree); dcl tree ptr unaligned; /* (Input) */ dcl operand_index fixed bin; if tree = null then return; if tree -> node.type = operator_node then if tree -> operator.op_code = std_call then call check_call_operator (tree); else do operand_index = 1 to tree -> operator.number; call traverse_computation_tree (tree -> operator.operand (operand_index)); end; else if tree -> node.type = reference_node then do; call traverse_computation_tree (tree -> reference.offset); call traverse_computation_tree (tree -> reference.length); call traverse_computation_tree (tree -> reference.qualifier); end; return; /* Check the call operator for any short unaligned strings in a structure that are passed by reference */ check_call_operator: procedure (tree); dcl tree ptr unaligned; /* (Input) */ dcl s ptr; /* exclude entry valued functions */ if tree -> operator.operand (2) -> node.type ^= reference_node then return; s = tree -> operator.operand (2) -> reference.symbol; /* exclude entry variables, internal procedures, and options(variable) procedures */ if s -> symbol.variable | s -> symbol.internal | s -> symbol.options & s -> symbol.variable_arg_list then return; if tree -> operator.operand (3) = null then return; call check_arg_list (tree -> operator.operand (3) -> operator.operand (2)); return; /* Check argument list for unaligned short strings passed by reference with fractional offsets of zero that are members of structures */ check_arg_list: procedure (arg_list); dcl arg_list ptr unaligned; /* (Input) */ dcl argument ptr; dcl arg_index fixed bin; do arg_index = 1 to arg_list -> list.number; argument = arg_list -> list.element (arg_index); if argument -> node.type = reference_node then if (argument -> reference.symbol -> symbol.bit | argument -> reference.symbol -> symbol.char) & argument -> reference.symbol -> symbol.non_varying & argument -> reference.symbol -> symbol.unaligned & argument -> reference.symbol -> symbol.member & ^argument -> reference.symbol -> symbol.temporary & ^argument -> reference.long_ref & mod (argument -> reference.c_offset, units_per_word (argument -> reference.units)) = 0 then call check_parameter; end; return; /* Check parameter, if possible, for called entry */ check_parameter: procedure; /* automatic */ dcl entry_name char (32); dcl entry_point_name char (256); dcl entry_point_ptr ptr; /* based */ dcl cst_storage area (auto_area_info.size) based (auto_area_info.areap); dcl 1 expected aligned based, 2 no_args fixed bin, 2 descs (64) ptr; /* symbol.reserved_1 and symbol.reserved_2 are just unused bits in the symbol node that we are borrowing. They are guaranteed to be zero by pl1_nodes_template_ when we start. */ if s -> symbol.reserved_2 then return; if ^s -> symbol.reserved_1 then do; entry_name = before (s -> symbol.token -> token.string, "$"); entry_point_name = after (s -> symbol.token -> token.string, "$"); if entry_point_name = "" then entry_point_name = entry_name; call hcs_$make_ptr (codeptr (check_short_strings), entry_name, entry_point_name, entry_point_ptr, code); if code ^= 0 then do; s -> symbol.reserved_2 = "1"b; call com_err_ (code, command, "Getting a pointer to ^a.", s -> symbol.token -> token.string); return; end; allocate expected in (cst_storage) set (s -> symbol.general); call get_entry_arg_descs_ (entry_point_ptr, s -> symbol.general -> expected.no_args, s -> symbol.general -> expected.descs, code); if code ^= 0 then do; s -> symbol.reserved_2 = "1"b; call com_err_ (code, command, "Getting entry descriptors for ^a.", s -> symbol.token -> token.string); return; end; s -> symbol.reserved_1 = "1"b; end; if arg_index > s -> symbol.general -> expected.no_args then do; s -> symbol.reserved_2 = "1"b; call com_err_ (0, command, "Call of ^a has too many arguments.", s -> symbol.token -> token.string); return; end; if arg_index > hbound (s -> symbol.general -> expected.descs, 1) then do; call com_err_ (0, command, "Call of ^a exceeds internal limit of ^d arguments.", s -> symbol.token -> token.string, hbound (s -> symbol.general -> expected.descs, 1)); return; end; if s -> symbol.general -> expected.descs (arg_index) = null then do; s -> symbol.reserved_2 = "1"b; call com_err_ (0, command, "Obsolete object segment format. ^a", s -> symbol.token -> token.string); return; end; /* Verify that the descriptors are version 2 (version 1 is no problem) */ if ^s -> symbol.general -> expected.descs (arg_index) -> arg_descriptor.flag then return; /* Check to see that the called program expects an unaligned (packed) string */ if ^s -> symbol.general -> expected.descs (arg_index) -> arg_descriptor.packed then do; s -> symbol.reserved_2 = "1"b; call com_err_ (0, command, "Call of ^a has a short string parameter mismatch.", s -> symbol.token -> token.string); return; end; end check_parameter; end check_arg_list; end check_call_operator; end traverse_computation_tree; end traverse_statements; end traverse_blocks; /* Free temporary storage. */ cleanup_procedure: procedure; call pl1$clean_up; call release_area_ (auto_area_info.areap); end cleanup_procedure; end check_short_strings; */ ----------------------------------------------------------- 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 */