command_processor_.pl1 11/11/89 1103.4rew 11/11/89 0803.5 1118898 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* The Multics Command Processor */ /* Created: 1 May 1976 by Steve Herbst */ /* Modified and reorganized by Jay Goldman, '77 */ /* Reorganized and fixed bugs: February-March 1978 by Gary Palter */ /* Modified: June 1978 by G. Palter to fix several bugs and implement new definition of |[, ||[, |], and |; */ /* Modified: 5-6 August 1978 by G. Palter to make command_processor_$af work properly */ /* Modified: 13 August 1978 by G. Palter to not forget about temporary segments */ /* Modified: 11 September 1978 by G. Palter to remove definition of |; */ /* Modified: 31 October 1978 by G. Palter to call fc_no_message when invoked as cp_$af */ /* Modified: 29 November 1978 by G. Palter to implement newer definition of |[ */ /* Modified: 23 June 1979 by G. Palter to make null iteration sets within brackets not be considered an error but instead return no value */ /* Modified: 13 July 1979 by G. Palter to fix a bug wherein an &if clause in an exec_com with unbalanced brackets causes a fault in match_iters */ /* Modified: 16 August 1979 by G. Palter to not bother to zero the automatic node block before returning */ /* Modified: 14 March 1980 by G. Palter to add faster simple command processing */ /* Modified: 31 March 1980 by G. Palter to add new directly callable interfaces and the subsystem entries */ /* Modified: 5 May 1980 by G. Palter to change calling sequence of eval_string entries and add include file for active string types */ /* Modified: 7 May 1980 by G. Palter to change calling sequence of subsys* entries to include a subsys_cp_info_ptr; this pointer is presently unused, however */ /* Modified: 3 October 1980 by G. Palter to fix bug #0016 -- the command processor takes an out_of_bounds fault when passed a zero-length input line (TR07834) */ /* Modified: 1 December 1980 by G. Palter to fix bug #0017 -- the command processor may cause the PL/1 free_based operator to take a random fault when processing a null command line */ /* Modified: May-June 1982 by G. Palter to (1) make simple_command_processor a quick block, (2) create the complex_command_processor internal procedure to hold all automatic storage not shared by the simple and complex command processor cases, (3) add support for tailoring the request line language within subsystems (eg: disabling iteration), (4) delete command_processor_$af (finally!), and (5) fix several bugs relating to temporary segment management and treatment of semicolons in active function/request return values (command_processor 5, 21, 22) */ /* Modified: March 1984 by Keith Loepere for non-existant error_table_$bad_subr_call */ /* Modified: July 1984 by G. Palter to use multiple permanent scratch segments in order to improve the performance of recursive invocations of the evaluate_active_string entrypoints such as those made by the LINUS Report Writer */ /****^ HISTORY COMMENTS: 1) change(86-05-17,GDixon), approve(86-05-17,MCR7357), audit(86-06-16,Farley), install(86-07-17,MR12.0-1097): Change call to tct_ to reference find_char_$first_in_table instead. This subroutine has been renamed. 2) change(86-05-17,DGHowe), approve(86-05-15,MCR7375), audit(86-07-15,Schroth), install(86-08-01,MR12.0-1108): added the ability to save the command name given on the command line to simple_command_processor and produce_argument_list. 3) change(87-07-13,GWMay), approve(87-07-13,MCR7730), audit(87-08-10,JRGray), install(87-09-10,MR12.1-1104): Added the ability to pipe data between commands and files. 4) change(87-09-10,GWMay), approve(87-09-10,MCR7730), audit(87-09-10,GDixon), install(87-09-10,MR12.1-1104): Changed position within the code where the pipe structure is suspended and restored. Fixed several problems found by the security auditor. 5) change(87-09-10,GWMay), approve(87-09-10,PBF7730), audit(87-09-14,GDixon), install(87-09-15,MR12.1-1107): Remove extra call to copy_thru_pipe from the process_pipe_command routine. Matching attaches are handled in the process_attach_description code. 6) change(87-12-15,GWMay), approve(87-12-15,MCR7810), audit(87-12-15,GDixon), install(88-01-12,MR12.2-1011): Changed call main error return call to com_err_ to only output a newline when there is error text. 7) change(88-02-03,GWMay), approve(88-02-25,MCR7848), audit(88-02-26,Fawcett), install(88-03-01,MR12.2-1029): Changed pipe facility to allow $ in the name of a command. END HISTORY COMMENTS */ %page; /* LIMITATIONS AN KNOWN BUGS: */ /* 1) Nested iteration sets will not return the expected results. example: string (xxx_(a b) (c d)_yyy zzz) intermixes the inner interation set. 2) The pipe processing code cannot deal with pipes that are embedded as part of an active return string. examples: string "show;|cols";| xx ls;| [contents xx;|] string [[ioa_ "string (ab a bc cd ae ef);|match /a/";|]] Because the pipe code evaluates the command line as it is input, the value returned by the active string will not be diagnosed correctly as a pipe. */ %page; /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ command_processor_: procedure (P_line_ptr, P_line_len, P_code); /* Parameters */ dcl P_line_ptr pointer parameter; /* command_processor_: -> line to process (input) */ dcl P_line_len fixed binary (21) parameter; /* command_processor_: length of line to process (input) */ dcl P_line character (*) parameter; /* *execute_line, *eval_string: line to process (input) */ dcl P_return_value character (*) varying parameter; /* *eval_string: result of evaluation (output) */ dcl P_eval_string_options_ptr pointer parameter; /* eval_string: -> options controlling interpretation of the active string (unused at present) (input) */ dcl P_active_string_type fixed binary parameter; /* *eval_string: type of active string (input) */ dcl P_cp_subsys_info_ptr pointer parameter; /* subsys_*, validate_cp_subsys_info: -> options controlling interpretation of the request line (input) */ dcl P_subsystem_name character (*) parameter; /* subsys_*: the subsystem (input) */ dcl P_subsystem_info_ptr pointer parameter; /* subsys_*: -> data used by the subsystem (input) */ dcl P_execute_request entry (pointer, character (*), pointer, fixed binary (35)) variable parameter; /* subsys_*: procedure to lookup & execute request (input) */ dcl P_old_execute_request entry (character (*), pointer, fixed binary (35)) variable parameter; /* execute_command_line_: same as above (input) */ dcl P_code fixed binary (35) parameter; /* *: status code (output) */ /* Local copies of parameters */ dcl line character (line_len) unaligned based (line_ptr); dcl line_ptr pointer; dcl line_len fixed binary (21); dcl execute_request entry (pointer, character (*), pointer, fixed binary (35)) variable; dcl old_execute_request entry (character (*), pointer, fixed binary (35)) variable; dcl code fixed binary (35); dcl ignore_code fixed bin (35); /* this value is for speed, never check it */ /* Remaining declarations */ dcl multics_cp bit (1) aligned; /* ON => Multics entry; OFF => subsystem entry */ dcl evaluate_string bit (1) aligned; /* ON => called to evaluate an active string */ dcl new_subsystem_call bit (1) aligned; /* ON => new form of execute_request, etc */ dcl null_cl bit (1) aligned; /* ON => command line is only whitspace */ dcl complex_line bit (1) aligned; /* ON => command line contains quoting, iteration, active strings, or commands with more than 32 arguments */ dcl lss_on bit (1) aligned; /* ON => running Limited Service System */ dcl use_standard_language bit (1) aligned; /* ON => can use PL/I builtins for search */ dcl executing bit (1) aligned; /* ON => executing a command at the moment */ dcl abort_command_execution label variable; dcl top_level_string_type fixed binary; /* for evaluating active strings: [], |[], ||[] */ dcl start fixed binary (21); dcl error_message char (256) varying; dcl COMMAND_PROCESSOR_ character (32) static options (constant) initial ("command_processor_"); dcl EXECUTE_COMMAND_LINE_ character (32) static options (constant) initial ("execute_command_line_"); dcl MAX_STACK_EXTENSION fixed binary (21) static options (constant) initial (16384); /* do not extend stack more than 16 pages */ dcl MIN_AF_RETURN_LTH fixed binary (21) static options (constant) initial (32768); /* always give active function at least 32K chars */ /* format: off */ dcl (error_table_$bad_file_name, error_table_$bad_pipe_syntax, error_table_$bad_subr_arg, error_table_$command_line_overflow, error_table_$mismatched_iter, error_table_$null_brackets, error_table_$no_file, error_table_$noentry, error_table_$unbalanced_brackets, error_table_$unbalanced_parentheses, error_table_$unbalanced_quotes, error_table_$unimplemented_version) fixed binary (35) external; /* format: on */ dcl sys_info$max_seg_size fixed binary (19) external; dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl check_star_name_ entry (char (*), bit (36), fixed bin (2), fixed bin (35)); dcl com_err_ entry () options (variable); dcl cu_$gen_call entry (pointer, pointer); dcl cu_$grow_stack_frame entry (fixed binary (21), pointer, fixed binary (35)); dcl find_char_$first_in_table entry (char (*), char (512) aligned) returns (fixed bin (21)) reducible; dcl find_command_ entry (pointer, fixed binary, pointer, fixed binary (35)); dcl find_command_$fc_no_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl get_wdir_ entry () returns (char (168)); dcl hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl pipe_$terminate entry (ptr, ptr, fixed bin (35)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl release_temp_segments_ entry (character (*), (*) pointer, fixed binary (35)); dcl sub_err_ entry () options (variable); dcl transform_command_ entry (pointer, fixed binary, pointer, fixed binary (35)); dcl (cleanup, command_abort_, request_abort_) condition; dcl (addr, addcharno, addrel, after, before, bit, currentsize, dimension, divide, fixed, hbound, index, lbound, length, ltrim, low, max, maxlength, min, mod, null, rank, rtrim, search, stacq, substr, unspec, verify) builtin; %page; /* Various combinations of those characters special to command language: many almost blank listing pages follow ... */ dcl BREAKS character (12) static options (constant) initial (";()[]""| "); /* command language break characters and NL, HT, SP, VT, FF */ dcl TOKEN_BREAKS character (6) static options (constant) initial (""" "); /* breaks for tokens only: " NL HT SP VT FF */ dcl SIMPLE_BREAKS character (6) static options (constant) initial ("; "); /* ; and whitespace (NL HT SP VT FF) */ dcl NON_SIMPLE_BREAKS character (6) static options (constant) initial ("()[]""|"); /* characters requiring special processing */ dcl PIPE_BREAK character (2) static options (constant) initial (";|"); dcl LEFT_BRACKET character (1) static options (constant) initial ("["); dcl RIGHT_BRACKET character (1) static options (constant) initial ("]"); dcl VERTICAL_BAR character (1) static options (constant) initial ("|"); dcl COMMAND_BREAKS character (2) static options (constant) initial ("; "); /* characters which separate command invocations (;, NL) */ dcl SPACE character (1) internal static options (constant) init (" "); %page; /* Execute a Multics command line: this entry is intended to be called only via cu_$cp */ /* command_processor_: entry (P_line_ptr, P_line_len, P_code); */ multics_cp = "1"b; /* not a subsystem invocation */ new_subsystem_call = "0"b; evaluate_string = "0"b; line_ptr = P_line_ptr; line_len = P_line_len; go to CONTINUE_SETUP; /* Evaluate a Multics active string */ eval_string: entry (P_eval_string_options_ptr, P_line, P_active_string_type, P_return_value, P_code); multics_cp = "1"b; /* not a subsystem */ new_subsystem_call = "0"b; evaluate_string = "1"b; top_level_string_type = max (P_active_string_type, NORMAL_ACTIVE_STRING); top_level_string_type = min (top_level_string_type, ATOMIC_ACTIVE_STRING); /* defaults to [] */ go to SETUP; /* Execute a subsystem request line: the caller must supply a procedure which is used to find and execute each request */ subsys_execute_line: entry (P_subsystem_name, P_subsystem_info_ptr, P_execute_request, P_cp_subsys_info_ptr, P_line, P_code); multics_cp = "0"b; /* this is a subsystem */ new_subsystem_call = "1"b; evaluate_string = "0"b; lss_on = "0"b; go to SETUP; /* Execute a subsystem request line: this is an obsolete entry provided for compatibility */ execute_command_line_: entry (P_line, P_old_execute_request, P_code); multics_cp = "0"b; new_subsystem_call = "0"b; /* use old fashioned calling sequence */ evaluate_string = "0"b; lss_on = "0"b; go to SETUP; /* Evaluate a subsystem active string */ subsys_eval_string: entry (P_subsystem_name, P_subsystem_info_ptr, P_execute_request, P_cp_subsys_info_ptr, P_line, P_active_string_type, P_return_value, P_code); multics_cp = "0"b; new_subsystem_call = "1"b; evaluate_string = "1"b; lss_on = "0"b; top_level_string_type = max (P_active_string_type, NORMAL_ACTIVE_STRING); top_level_string_type = min (top_level_string_type, ATOMIC_ACTIVE_STRING); go to SETUP; %page; /* Execute/evaluate the command/request line/active-string: for simplicity, all future references will assume that a Multics command line is being executed */ SETUP: line_ptr = addr (P_line); /* this point is reached by all but command_processor_ */ line_len = length (P_line); CONTINUE_SETUP: /* command_processor_ joins here */ error_message = ""; code = 0; use_standard_language = "1"b; /* until proven otherwise: assume normal case */ if ^multics_cp then /* subsystem entries: check for special request language */ if new_subsystem_call then if P_cp_subsys_info_ptr ^= null () then do; cp_subsys_info_ptr = P_cp_subsys_info_ptr; if cp_subsys_info.version ^= CP_SUBSYS_INFO_VERSION_1 then do; RESIGNAL_INCOMPATIBLE_SUBSYSTEM_INFO: /* wrong version is quite fatal */ call sub_err_ (error_table_$unimplemented_version, COMMAND_PROCESSOR_, ACTION_CANT_RESTART, null (), (0), "^24.3b from subsystem ^a.", unspec (cp_subsys_info.version), P_subsystem_name); go to RESIGNAL_INCOMPATIBLE_SUBSYSTEM_INFO; end; use_standard_language = ^cp_subsys_info.non_standard_language; end; if evaluate_string then P_return_value = ""; /* initialize the return value */ if use_standard_language then do; /* can perform some short cuts for the normal language */ line_len = length (rtrim (line, SIMPLE_BREAKS)); start = verify (line, SIMPLE_BREAKS); /* ... strip leading/trailing whitespace/null commands */ null_cl = (start = 0); if null_cl then do; /* ... the line is empty */ complex_line = "0"b; go to SILENTLY_RETURN_FROM_CP; end; end; else do; /* have no idea what the whitespace characters are ... */ start = 1; /* ... must scan the entire line */ null_cl = "1"b; /* ... until proven otherwise by complex_command_processor */ end; if multics_cp then lss_on = cp_data_$under_lss; /* running under Limited Service System */ else do; /* a subsystem entry: get the appropriate apply procedure */ if new_subsystem_call then execute_request = P_execute_request; else old_execute_request = P_old_execute_request; end; if evaluate_string then /* evaluating an active string: always a complex operation */ complex_line = "1"b; else if use_standard_language then /* standard language: try faster command processor if OK */ /* The pipe token ";|" does not need to be checked here */ /* because "|" is a non-simple break which will set the */ /* complex line switch on. */ complex_line = (search (substr (line, start), NON_SIMPLE_BREAKS) ^= 0); else complex_line = "1"b; /* no idea what the language is like */ if ^complex_line then do; /* first try faster command processor ... */ executing = "0"b; /* ... execution is not in progress */ abort_command_execution = SILENTLY_RETURN_FROM_CP; if multics_cp then /* ... establish appropriate abort handler once */ on condition (command_abort_) begin; if executing then go to abort_command_execution; end; else on condition (request_abort_) begin; if executing then go to abort_command_execution; end; call simple_command_processor (line_ptr, line_len, start, complex_line); if multics_cp then revert condition (command_abort_); else revert condition (request_abort_); end; if complex_line then call complex_command_processor (line_ptr, line_len, start); RETURN_FROM_CP: if (code ^= 0) & ^evaluate_string then if multics_cp then call com_err_ (code, COMMAND_PROCESSOR_, "^[^/^]^a", error_message ^= "", error_message); else if new_subsystem_call then call com_err_ (code, P_subsystem_name, "^/^a", error_message); else call com_err_ (code, EXECUTE_COMMAND_LINE_, "^/^a", error_message); SILENTLY_RETURN_FROM_CP: if (code = 0) & null_cl then code = 100; P_code = code; return; %page; /* Simple command processor: processes command lines which do not contain quoted strings, iteration, or active strings. Argument lists are constructed and commands invoked until either the entire command line is processed or a command invocation if found with more than 32 arguments in which case the full command processor must be used */ simple_command_processor: procedure (p_line_ptr, p_line_lth, p_start, p_complex_line) /* options (quick) */; /* Parameters */ dcl p_line_ptr pointer parameter; /* -> command line to execute */ dcl p_line_lth fixed binary (21) parameter; /* length of above command line */ dcl p_start fixed binary (21) parameter; /* where to start in the command line */ dcl p_complex_line bit (1) aligned parameter; /* set ON => something in this command line was too much to handle -- the normal processor must be used */ /* Local copies of parameters */ dcl line character (line_lth) unaligned based (line_ptr); /* command line being processed */ dcl (line_lth, start) fixed binary (21); dcl line_ptr pointer; /* Remaining declarations */ dcl 1 arg_list aligned, /* the argument list being constructed */ 2 twice_n_arguments fixed binary (18) unaligned unsigned, 2 tag bit (18) unaligned initial ("000004"b3), /* PL/1 */ 2 twice_n_descriptors fixed binary (18) unaligned unsigned, 2 has_command_name bit (1) unal, 2 pad bit (17) unal, 2 arg_ptrs (32) pointer, 2 descriptor_ptrs (32) pointer, 2 name, 3 command_name_ptr pointer, 3 command_name_length fixed bin (21); dcl 1 descriptors (32) aligned, /* descriptions of above arguments */ 2 bits bit (12) unaligned, /* flag(1), type(6), packed(1), ndims(4) */ 2 size fixed binary (24) unaligned unsigned; dcl descriptor_ptrs_for_move bit (72 * n_arguments) aligned based; /* to move descriptor pointers to proper place in arglist */ dcl command_name_for_move bit (144) aligned based; dcl arg_list_overlay (68) bit (72) based (addr (arg_list.arg_ptrs (1))); dcl saved_start fixed binary (21); /* where each command start in case it aborts */ dcl reading_command_name bit (1) aligned; /* ON => picking up command name, not an argument */ dcl end_of_command bit (1) aligned; /* ON => reached the end of a command */ dcl n_arguments fixed binary; /* # of arguments for this command */ dcl (token_lth, next_start) fixed binary (21); dcl command_name character (command_name_lth) unaligned based (command_name_ptr); dcl command_name_ptr pointer; /* -> name of the command to invoke */ dcl command_name_lth fixed binary; dcl command_entry_ptr pointer; /* -> the actual command to be run */ %page; line_ptr = p_line_ptr; line_lth = p_line_lth; start = p_start; abort_command_execution = ABORT_COMMAND_EXECUTION;/* bypass PL/I's lexical scoping rules */ do while (start <= line_lth); saved_start = start; /* save start of command in case not simple */ reading_command_name = "1"b; end_of_command = "0"b; n_arguments = 0; do while (^end_of_command); token_lth = search (substr (line, start), SIMPLE_BREAKS) - 1; if token_lth = -1 then /* rest of the command line */ token_lth = line_lth - start + 1; /* break is one beyond the end */ if reading_command_name then do; command_name_ptr = addr (substr (line, start, 1)); command_name_lth = token_lth; reading_command_name = "0"b; end; else do; n_arguments = n_arguments + 1; if n_arguments > hbound (arg_list.arg_ptrs, 1) then do; p_start = saved_start; /* command has too many arguments: use full processor */ p_complex_line = "1"b; return; end; arg_list.arg_ptrs (n_arguments) = addr (substr (line, start, 1)); arg_list.descriptor_ptrs (n_arguments) = addr (descriptors (n_arguments)); descriptors (n_arguments).bits = "5260"b3; /* unaligned, nonvarying string */ descriptors (n_arguments).size = token_lth; end; start = start + token_lth; /* skip over token to delimiters */ if (start > line_lth) then end_of_command = "1"b; /* entire line used */ else do; /* search for next token and check for end of a command invocation (semicolon or newline in delimiters) */ next_start = verify (substr (line, start), SIMPLE_BREAKS); if (next_start = 0) then do; /* rest of line is delimiters */ next_start = line_lth - start + 2; end_of_command = "1"b; end; else end_of_command = (search (substr (line, start, (next_start - 1)), COMMAND_BREAKS) ^= 0); start = start + next_start - 1; end; end; arg_list.twice_n_arguments, arg_list.twice_n_descriptors = 2 * n_arguments; /* save the name on the current argument list NOTE this is a new structure */ arg_list.has_command_name = "1"b; arg_list.name.command_name_length = command_name_lth; arg_list.name.command_name_ptr = command_name_ptr; if n_arguments < hbound (arg_list.arg_ptrs, 1) then do; /* need to move descriptor pointers down */ addr (arg_list.arg_ptrs (n_arguments + 1)) -> descriptor_ptrs_for_move = addr (arg_list.descriptor_ptrs) -> descriptor_ptrs_for_move; addr (arg_list_overlay (2 * n_arguments + 1)) -> command_name_for_move = addr (arg_list.name) -> command_name_for_move; end; if multics_cp then do; /* executing a Multics command line */ if lss_on then do; /* running within Limited Service System */ call transform_command_ (command_name_ptr, command_name_lth, cp_data_$command_table_ptr, code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; call find_command_ (command_name_ptr, command_name_lth, command_entry_ptr, code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; executing = "1"b; /* handle command_abort_ now */ call cu_$gen_call (command_entry_ptr, addr (arg_list)); end; else if new_subsystem_call /* new type of subsystem request line */ then do; executing = "1"b; /* handler request_abort_ now */ call execute_request (P_subsystem_info_ptr, command_name, addr (arg_list), code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; else do; /* executing an old-fashioned subsystem request line */ executing = "1"b; /* handler request_abort_ now */ call old_execute_request (command_name, addr (arg_list), code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; ABORT_COMMAND_EXECUTION: executing = "0"b; end; return; end simple_command_processor; %page; /* Complex command processor: processes command lines which contain quoted strings, iteration, or active strings. In order to solve several bugs in the command processor, this procedure will have to be rewritten */ complex_command_processor: procedure (p_line_ptr, p_line_len, p_start) options (non_quick); /* Parameters */ dcl p_line_ptr pointer parameter; /* -> the command line/active string */ dcl p_line_len fixed binary (21) parameter; /* length of the line */ dcl p_start fixed binary (21) parameter; /* where in the line to start procesing */ /* Local copies of paramerters */ dcl (line_len, start) fixed binary (21); dcl line_ptr pointer; /* Nodes */ dcl 1 atom aligned based, 2 next pointer unaligned, /* forward thread */ 2 pad1 pointer unaligned, 2 string_ptr pointer unaligned, /* pointer into command line */ 2 type fixed binary, 2 pad2 fixed binary, 2 string_len fixed binary (21), /* length of substring */ 2 flags aligned, 3 space bit (1); /* followed by white space */ dcl 1 iter_begin aligned based, 2 next pointer unaligned, /* forward thread */ 2 end pointer unaligned, /* forward thread to matching ) */ 2 parent pointer unaligned, /* pointer to parent iter or af node */ 2 type fixed binary, 2 delimiter_class fixed binary, /* which of 8 possible end iteration set breaks to match */ 2 pad fixed binary (21), 2 flags aligned, 3 space bit (1); /* this value is ignored */ dcl 1 iter_end aligned based, 2 next pointer unaligned, /* forward thread */ 2 begin pointer unaligned, /* backward thread to matching ( */ 2 parent pointer unaligned, /* pointer to parent iter or af node */ 2 type fixed binary, 2 pad fixed binary, 2 level fixed binary (21), /* number of iter sets not ended */ 2 flags aligned, 3 space bit (1); /* if iteration set is followed by white space */ dcl 1 af aligned based, 2 next pointer unaligned, /* forward thread */ 2 prev pointer unaligned, /* backward thread */ 2 parent pointer unaligned, /* pointer to parent iter or af node */ 2 type fixed binary, 2 delimiter_class fixed binary, /* which of 8 possible end active string breaks to match */ 2 level fixed binary (21), /* iter level at start of af */ 2 flags aligned, 3 space bit (1), /* this value is ignored */ 3 atom_sw bit (1), /* result is to be a single atom */ 3 tokens_sw bit (1), /* result is to be broken into tokens only */ 3 catenate_sw bit (1); /* catenate results of iterations */ dcl 1 node aligned based, 2 next pointer unaligned, /* forward thread */ 2 af_prev pointer unaligned, /* backward thread */ 2 af_iter_parent pointer unaligned, /* pointer to parent iter or af node */ 2 type fixed binary, 2 delimiter_class fixed binary, /* which of 8 possible end iteration/active string breaks */ 2 len_or_level fixed binary (21), /* length of character string for atom nodes, or iter level at start of af or after iter_end */ 2 flags aligned, 3 space bit (1), /* followed by white space */ 3 af_atom_sw bit (1), /* result is a single atom */ 3 af_tokens_sw bit (1), /* result is to be broken into tokens only */ 3 af_catenate_sw bit (1); /* catenate results of iterations */ /* format: off */ dcl (ATOM initial (1), /* a piece of text which will form part of an argument */ BEGIN_ITERATION initial (2), /* start of an iteration set */ END_ITERATION initial (3), /* end of one or more iteration sets */ ACTIVE_STRING initial (4), /* an active string */ END_OF_COMMAND initial (5)) /* a command delimter returned by an active function */ fixed binary static options (constant); /* format: on */ /* Data used for scratch segment management: The command processor maintains two lists of scratch segments -- the "permanent" scratch segments are obtained only once per-process and are shared amongst various invocations of the command processor through the use of a simple locking scheme. (In actuality, the permanent segments will be released every cp_data_$scratch_release_factor uses to help keep process directory usage low). The other list of scratch segments is a per-invocation list of temporary segments which are allocated and then released once per top-level command/request (ie: once per semicolon) */ dcl scratch_lock_id bit (36) aligned; /* unique identifier for acquiring "permanent" segments */ dcl 1 temporary_scratch_segment_list aligned based (temporary_scratch_segment_list_ptr), 2 header, 3 n_allocated fixed binary, /* # of available temporary scratch segments */ 3 n_used fixed binary, /* # actually in use at present */ 2 segment_ptrs (temporary_scratch_segment_list_n_allocated refer (temporary_scratch_segment_list.n_allocated)) pointer; dcl 1 local_temporary_scratch_segment_list aligned, /* initial set of temporary scratch segments */ 2 header like temporary_scratch_segment_list.header, 2 segment_ptrs (8) pointer; dcl temporary_scratch_segment_list_ptr pointer; dcl temporary_scratch_segment_list_n_allocated fixed binary; /* Remaining declarations */ dcl 1 dummy_node aligned like node; dcl 1 dummy_af_node aligned like af; /* top level active string for evaluate entries */ dcl 1 node_block aligned based (block_ptr), /* block of thirty nodes */ 2 array (30) like node, /* four words each */ 2 next pointer; /* forward thread */ dcl block_ptr pointer; dcl last_block_ptr pointer; /* for chaining blocks */ dcl node_index fixed binary (5); /* index of free node in a block */ dcl 1 stack_space like node_block aligned; /* space in stack for first block of nodes */ dcl system_area area based (system_area_ptr); /* area to allocate later blocks if needed */ dcl system_area_ptr pointer; dcl atom_string character (atom_len) based (atom_ptr); dcl atom_len fixed binary (21); dcl atom_ptr pointer; dcl return_string character (return_len) aligned varying based (return_ptr); dcl return_ptr pointer; /* -> AF return string */ dcl return_len fixed binary (21); dcl 1 full_language like cp_data_$standard_language aligned based (full_language_ptr); dcl full_language_ptr pointer; /* defines the full language being interpreted */ dcl 1 token_language like cp_data_$standard_language aligned based (token_language_ptr); dcl token_language_ptr pointer; /* defines the language with non-whitespace, non-quoting special characters treated normally */ dcl using_stack bit (1) aligned; /* ON => arguments are being constructed on the stack */ dcl last_np pointer; dcl (first_node, new_first_node) pointer; /* node pointers for match_iters & read_list */ dcl arg_count fixed binary; /* number of arguments to command/af, set by match_iters */ dcl (count, iter_count, iter_index) fixed binary; /* number of iterations, set by match_iters */ /* format: off */ dcl (command initial ("0"b), /* executing a command */ active_function initial ("1"b)) /* evaluating an active function */ bit (1) aligned static options (constant); /* format: on */ dcl make_list_depth fixed binary; /* recursion depth of make_list procedure */ dcl iter_level fixed binary; /* depth of ()'s in line */ /* for use by the pipe facility only */ dcl command_pipe_control_ptr ptr; dcl 1 command_pipe_control aligned based (command_pipe_control_ptr), 2 Npipes_in_line fixed bin, /* occurances of ;| in a line */ 2 Niters fixed bin, /* iteration level */ 2 niters fixed bin, /* iteration count */ 2 Sevaluate_pipe bit (1) aligned, /* on = processing an active function */ 2 Sbuild_return_string bit (1) aligned, /* on = build the af return str */ 2 Sinclude_NL_in_af_ret_str bit (1) aligned, /* on = do not remove NLs from the ret str */ 2 Sterminate bit (1) aligned, /* on = delete pipe files and free storage */ 2 pipe_input_path char (58), /* built by pipe_$initiate */ 2 pipe_output_path char (58), /* built by pipe_$initiate */ 2 previous_pipe_ptr ptr, /* data before the ;| */ 2 previous_pipe_len fixed bin, 2 current_pipe_ptr ptr, /* current command line */ 2 current_pipe_len fixed bin, 2 next_pipe_ptr ptr, /* data after the next ;| */ 2 next_pipe_len fixed bin, 2 input_ptr ptr, /* input attachment */ 2 output_ptr ptr; /* output attachment */ %page; command_pipe_control_ptr = null; line_ptr = p_line_ptr; line_len = p_line_len; start = p_start; system_area_ptr = get_system_free_area_ (); block_ptr = addr (stack_space); /* initialize node allocation variables */ unspec (node_block) = "0"b; node_block.next = null (); node_index = 0; call initialize_scratch_segments ("1"b); /* setup scratch segment management */ on condition (cleanup) begin; /* non-local goto in progress ... */ if command_pipe_control_ptr ^= null then do; call pipe_$terminate (addr (command_pipe_control.pipe_input_path), addr (command_pipe_control.pipe_output_path), ignore_code); free command_pipe_control in (system_area); command_pipe_control_ptr = null; end; call free_nodes ("1"b); /* ... don't zero automatic storage */ call release_scratch_segments ("1"b); /* ... or setup scratch segments for another pass */ end; if use_standard_language then /* pick up character type from constant definition */ full_language_ptr, token_language_ptr = addr (cp_data_$standard_language); else do; /* strange language: caller has supplied the definitions */ full_language_ptr = addr (cp_subsys_info.full_tct_table); token_language_ptr = addr (cp_subsys_info.tokens_only_tct_table); end; %page; /* Process the line one command at a time -- a command invocation is delimited by non-quoted semicolons and newlines. Evaluating an active string in the command line may return semicolons -- this case is handled by make_list and match_iters */ do while (start > 0); iter_level = 0; /* no unclosed iteration sets */ iter_count = 0; iter_index = 0; make_list_depth = 0; return_ptr = null (); /* no place for return values yet */ using_stack = "1"b; /* read_list will use additional stack space if necessary */ unspec (dummy_node) = "0"b; last_np = addr (dummy_node); dummy_node.next = null (); dummy_node.type = ATOM; if evaluate_string then do; /* evaluating active string: make dummy AF node */ unspec (dummy_af_node) = "0"b; last_np = addr (dummy_af_node); dummy_af_node.type = ACTIVE_STRING; dummy_af_node.prev = addr (dummy_node); /* make sure result is seen */ dummy_af_node.parent = null (); if (top_level_string_type = TOKENS_ONLY_ACTIVE_STRING) then dummy_af_node.tokens_sw = "1"b; /* caller requested |[] */ else if (top_level_string_type = ATOMIC_ACTIVE_STRING) then dummy_af_node.atom_sw = "1"b; /* caller requested ||[] */ end; call make_list (line_ptr, line_len, ("0"b), start, command_pipe_control_ptr); /* parse line up to first explicit semicolon */ do first_node = dummy_node.next /* process this command */ repeat (new_first_node) /* and any within it from AF's */ while (first_node ^= null ()); call match_iters (first_node, evaluate_string, arg_count, iter_count, new_first_node); do iter_index = 1 to iter_count; /* process parentheses */ if command_pipe_control_ptr ^= null then do; command_pipe_control.Niters = iter_count; command_pipe_control.niters = iter_index; end; if ^evaluate_string then call read_list (first_node, evaluate_string, arg_count, command_pipe_control_ptr); else do; /* cp_$af: get list as a string */ call write_list (first_node, evaluate_string, arg_count, command_pipe_control_ptr); if (iter_index < iter_count) | (new_first_node ^= null ()) then P_return_value = P_return_value || ";"; end; /* if not last element of list */ end; end; call free_nodes ((start = 0)); /* forget command but zero automatic only if more to do */ call release_scratch_segments ((start = 0)); if command_pipe_control_ptr ^= null then if command_pipe_control.Sterminate then do; call pipe_$terminate (addr (command_pipe_control.pipe_input_path), addr (command_pipe_control.pipe_output_path), ignore_code); free command_pipe_control in (system_area); command_pipe_control_ptr = null; end; end; return; %page; /* Construct the token list: Evaluates active strings and properly threads parentheses for use by match_iters and read_list */ make_list: procedure (p_line_ptr, p_line_len, p_token_breaks_sw, p_start, p_pipe_control_ptr); dcl p_line_ptr pointer parameter; dcl (p_line_len, p_start) fixed binary (21) parameter; dcl p_token_breaks_sw bit (1) aligned parameter; /* controls if ()[}; recognized */ dcl p_pipe_control_ptr ptr; dcl line_ptr pointer; /* parameter copies */ dcl (line_len, start, pipe_line_pos) fixed binary (21); dcl token_breaks_sw bit (1) aligned; dcl line character (line_len) based (line_ptr); dcl c (line_len) character (1) unaligned based (line_ptr); dcl af_is_atom bit (1) aligned; /* ON => return value is not to be rescanned */ dcl af_is_tokens bit (1) aligned; /* ON => return value should be tokenized only */ dcl catenate_values bit (1) aligned; /* ON => iteration in active string catenates */ dcl semicolon_in_af bit (1) aligned; /* ON => command separator within an active string */ dcl (pp, np, top_level_pp) pointer; dcl processing_type fixed binary (9); dcl (afp, first_node, new_first_node, af_line_ptr) pointer; dcl (the_character, next_character, next_next_character) character (1); dcl continue_scan bit (1) aligned; dcl (arg_count, iter_count, iter_index) fixed binary; dcl (af_line_len, af_start, idx) fixed binary (21); dcl sv_pipe_control_ptr ptr; dcl 1 pipe_control aligned like command_pipe_control based (p_pipe_control_ptr); dcl current_pipe aligned char (pipe_control.current_pipe_len) based (pipe_control.current_pipe_ptr); dcl next_pipe aligned char (pipe_control.next_pipe_len) based (pipe_control.next_pipe_ptr); dcl after_bracket_idx fixed bin (21); make_list_depth = make_list_depth + 1; line_ptr = p_line_ptr; line_len = p_line_len; token_breaks_sw = p_token_breaks_sw; start = p_start; sv_pipe_control_ptr = null; if (make_list_depth = 1) & evaluate_string then do; top_level_pp, pp = addr (dummy_af_node);/* need a psuedo "[" for string evaluation */ semicolon_in_af = "0"b; /* ... and be sure not to confuse it */ afp = null (); end; else pp = null (); %page; /* Main scanning loop */ /* pipe line position offset equals the starting char less 1. */ pipe_line_pos = start - 1; do while (start <= line_len); if token_breaks_sw then /* ignore iteration, active strings, and multiple commands */ if use_standard_language then atom_len = search (substr (line, start), TOKEN_BREAKS) - 1; else atom_len = find_char_$first_in_table (substr (line, start), cp_subsys_info.tokens_only_tct_table) - 1; else do; /* allow all features defined in this language */ if use_standard_language then /* ... default situation: all features are enabled */ atom_len = search (substr (line, start), BREAKS) - 1; else atom_len = find_char_$first_in_table (substr (line, start), cp_subsys_info.full_tct_table) - 1; end; if atom_len = -1 then do; /* rest of line is ordinary characters ... */ atom_len = line_len - start + 1; call get_node (); /* ... so create an ATOM node to represent it */ np -> atom.type = ATOM; np -> atom.string_ptr = addr (c (start)); np -> atom.string_len = atom_len; start = line_len + 1; /* ... and force the scanning loop to terminate */ end; else do; /* have found a character with special meaning ... */ if atom_len > 0 then do; /* ... some ordinary characters in front of it ... */ call get_node (); /* ... ... so create a node to hold onto them */ np -> atom.type = ATOM; np -> atom.string_ptr = addr (c (start)); np -> atom.string_len = atom_len; start = start + atom_len; /* ... and position to the interesting character */ end; af_is_atom = "0"b; /* turn off any active string modifiers */ af_is_tokens = "0"b; catenate_values = "0"b; processing_type = get_type (c (start)); go to PROCESS_CHARACTER (processing_type); /* Determine the processing type of the given character */ get_type: procedure (p_character) returns (fixed binary); dcl p_character character (1) unaligned parameter; if token_breaks_sw then return (token_language.character_types (rank (p_character))); else return (full_language.character_types (rank (p_character))); end get_type; %page; /* Whitespace: separates tokens on the line but is otherwise ignored (space, horizontal/vertical tab, form feed, newline when scanning just for tokens */ PROCESS_WHITESPACE: PROCESS_CHARACTER (1): last_np -> node.space = "1"b; /* separate this token from what (if anything) follows */ go to CONTINUE_SCAN; /* Command separator: separates multiple commands on the line but is */ /* otherwise ignored (semicolon) */ PROCESS_COMMAND_SEPARATOR: PROCESS_CHARACTER (2): /* The pipe facility is activated when the string ";|" exists within a command line. Pipes are not available in limited service subsystems or subsystems that do not use the standard command language. */ if ^use_standard_language | lss_on then go to PROCESS_SEMICOLON; if substr (line, start, length (PIPE_BREAK)) = PIPE_BREAK then do; if p_pipe_control_ptr = null then do; /* init values here to save on performance. */ allocate pipe_control in (system_area) set (p_pipe_control_ptr); pipe_control.Npipes_in_line = 0; pipe_control.Sterminate = "0"b; pipe_control.Sevaluate_pipe = "0"b; pipe_control.Sbuild_return_string = "0"b; pipe_control.Sinclude_NL_in_af_ret_str = "0"b; pipe_control.pipe_input_path = ""; pipe_control.pipe_output_path = ""; pipe_control.previous_pipe_ptr = null; pipe_control.previous_pipe_len = 0; pipe_control.current_pipe_ptr = null; pipe_control.current_pipe_len = 0; pipe_control.next_pipe_ptr = null; pipe_control.next_pipe_len = 0; pipe_control.input_ptr = null; pipe_control.output_ptr = null; end; pipe_control.Npipes_in_line = pipe_control.Npipes_in_line + 1; /* Construct pointers to the previous and current section of the command line delimited by pipe tokens and line extents. */ pipe_control.previous_pipe_ptr = pipe_control.current_pipe_ptr; pipe_control.previous_pipe_len = pipe_control.current_pipe_len; pipe_control.current_pipe_ptr = addcharno (line_ptr, pipe_line_pos); pipe_control.current_pipe_len = start - pipe_line_pos - length (";"); start = start + length (PIPE_BREAK); if pp ^= null () then if pp -> node.type = ACTIVE_STRING then do; /* Position the section pointer after the left bracket so that the pipe processor can figure out the type of thing being done. */ after_bracket_idx = search (current_pipe, LEFT_BRACKET); pipe_control.current_pipe_ptr = addcharno (pipe_control.current_pipe_ptr, after_bracket_idx); pipe_control.current_pipe_len = pipe_control.current_pipe_len - after_bracket_idx; /* Look for the next character. It will be a vertical bar or a right */ /* bracket. If it isn't, an error will be reported when the end of the */ /* active function is processed in PROCESS_END_ACTIVE_FUNCTION below. */ pipe_control.Sevaluate_pipe = "1"b; if substr (line, start, length (VERTICAL_BAR)) = VERTICAL_BAR then do; pipe_control.Sinclude_NL_in_af_ret_str = "1"b; start = start + length (VERTICAL_BAR); end; end; /* Construct pointers to the next section of the command line delimited by pipe tokens and line extents. The value of next_pipe may or may not be the entire contents of the next command or attach description processed. The value will be the entire contents when there are no special characters within it. It is not required for the string to be complete. Using this strategy, the value will contain the first special character. The value is checked a by subroutine of process_pipe below. Whenever a the string contains special characters, a temporary pipe file will be used for output. When the string does not contain special characters and is a valid attach description, then and only then, it is used as the output of the pipe. */ pipe_control.next_pipe_len = search (substr (line, start), COMMAND_BREAKS); if pipe_control.next_pipe_len > 0 then do; pipe_control.next_pipe_ptr = addcharno (line_ptr, start - 1); pipe_control.next_pipe_len = pipe_control.next_pipe_len - 1; end; else do; pipe_control.next_pipe_ptr = addcharno (line_ptr, start - 1); if line_len >= start then pipe_control.next_pipe_len = line_len - (start - 1); else pipe_control.next_pipe_len = 0; end; /* If the pipe is to run as an active function, determine if this is the last section of the active string. If so, setup for the active function return string to be built. If there is an include new line token in the middle of the pipe, report an error. Otherwise, call the active function processor. */ if pipe_control.Sevaluate_pipe then do; if substr (ltrim (next_pipe), 1, length (RIGHT_BRACKET)) = RIGHT_BRACKET then pipe_control.Sbuild_return_string = "1"b; else do; if pipe_control.Sinclude_NL_in_af_ret_str then do; code = error_table_$bad_pipe_syntax; error_message = "The string "";||"" may only appear at the end of pipe active strings."; go to RETURN_FROM_CP; end; end; start = start - 1; /* make_list adds 1 */ pipe_line_pos = start; semicolon_in_af = "1"b; call process_active_function (p_pipe_control_ptr); end; end; /* A regular semicolon was found. If the pipe facility is "on", turn it off */ else do; if p_pipe_control_ptr ^= null then do; pipe_control.Sterminate = "1"b; pipe_control.previous_pipe_ptr = pipe_control.current_pipe_ptr; pipe_control.previous_pipe_len = pipe_control.current_pipe_len; pipe_control.current_pipe_ptr = addcharno (line_ptr, pipe_line_pos); pipe_control.current_pipe_len = start - pipe_line_pos - 1; pipe_control.next_pipe_ptr = null; pipe_control.next_pipe_len = 0; end; PROCESS_SEMICOLON: start = start + 1; /* next command follows the ; */ if (start > 0) & (pp ^= null ()) then if pp -> node.type = ACTIVE_STRING then do; /* Because the return string from a pipe is built at the end of the bracket pair, it is not possible to process active functions after pipe active functions. If this were done, the return string would not be builr in the same sequence as the command line issued them. If this is done, report an error message. */ if p_pipe_control_ptr ^= null then if pipe_control.Sevaluate_pipe then do; code = error_table_$bad_pipe_syntax; error_message = "Nonpipe semicolons cannot appear after pipe breaks in pipe active strings." ; go to RETURN_FROM_CP; end; start = start - 1; /* ... make_list will add 1 */ pipe_line_pos = start; semicolon_in_af = "1"b; call process_active_function (p_pipe_control_ptr); end; /* ... above procedure doesn't return (sigh) */ end; go to RETURN_FROM_MAKE_LIST; /* Command separator or whitespace: separates multiple commands on the line when using the full language but is also recognized when scanning active function return values for tokens as being equivalent to whitespace (new-line) */ PROCESS_CHARACTER (3): if token_breaks_sw then go to PROCESS_WHITESPACE; /* nice and easy ... */ else go to PROCESS_COMMAND_SEPARATOR; %page; /* Single character token: appears as a one character argument to the command even if not surrounded by whitespace */ PROCESS_CHARACTER (4): last_np -> node.space = "1"b; /* forced separation */ call get_node (); /* create an atom node for this character */ np -> atom.type = ATOM; np -> atom.string_ptr = addr (c (start)); np -> atom.string_len = 1; np -> atom.space = "1"b; /* ... and separate it from whatever follows */ go to CONTINUE_SCAN; /* Compound token: appears as an argument to the command even if not surrounded by whitespace; if several of this type of character appear on the line without any intervening characters, they are merged into a single argument (eg: ^=) */ PROCESS_CHARACTER (5): last_np -> node.space = "1"b; /* forced separation */ call get_node (); /* create an atom for this and following compounded chars */ np -> atom.type = ATOM; np -> atom.string_ptr = addr (c (start)); np -> atom.string_len = 0; np -> atom.space = "1"b; /* ... and separate them from whatever follows */ do while (start <= line_len); /* scan until we hit end of compound token characters */ processing_type = get_type (c (start)); if processing_type = COMPOUND_TOKEN then np -> atom.string_len = np -> atom.string_len + 1; else do; /* found a non-compound character */ start = start - 1; /* ... CONTINUE_SCAN label bumps this value */ go to CONTINUE_SCAN; end; start = start + 1; /* move right along */ end; go to RETURN_FROM_MAKE_LIST; /* here iff rest of line was compound tokens */ %page; /* Quote character -- begins and ends a quoted string: only the same character ends the quoted string (ie: "' isn't a completed string if both are quoting characters); within the string, any occurence of this character must be doubled */ PROCESS_CHARACTER (6): the_character = c (start); /* this is the only character that will stop us */ continue_scan = "1"b; /* until we find the closing quote character */ do while (continue_scan); idx = index (substr (line, (start + 1)), the_character); if idx = 0 then do; /* unbalanced quoting characters ... */ code = error_table_$unbalanced_quotes; go to RETURN_FROM_CP; end; call get_node (); /* make an atom for next piece of quoted string */ np -> atom.type = ATOM; np -> atom.string_ptr = addr (c (start + 1)); np -> atom.string_len = idx - 1; start = start + idx; /* skip to next quoting character */ if start < line_len then /* check for literal quoted character within the string */ if substr (line, (start + 1), 1) = the_character then do; np -> atom.string_len = np -> atom.string_len + 1; start = start + 1; /* ... yes: add one to the string and keep scanning */ end; else continue_scan = "0"b; else continue_scan = "0"b; /* ... no: have completed the string */ end; go to CONTINUE_SCAN; /* here iff we have a completed quoted string */ /* Active string modifier: modifies the interpretation of active strings; otherwise, treat as normal character (|) */ PROCESS_CHARACTER (7): the_character = c (start); /* pick up the modifier */ if start < line_len then /* and the following character (if present) */ next_character = substr (line, (start + 1), 1); else next_character = low (1); if start < (line_len - 1) then /* and the character after that ... */ next_next_character = substr (line, (start + 2), 1); else next_next_character = low (1); if (start < (line_len - 1)) & (next_character = the_character) & (get_type (next_next_character) >= BEGIN_ACTIVE_STRING_1) & (get_type (next_next_character) <= BEGIN_ACTIVE_STRING_8) then do; af_is_atom = "1"b; /* ||[ -- do not scan active string result */ start = start + 2; processing_type = get_type (next_next_character); go to PROCESS_BEGIN_ACTIVE_STRING; end; else if (start < line_len) & (get_type (next_character) >= BEGIN_ACTIVE_STRING_1) & (get_type (next_character) <= BEGIN_ACTIVE_STRING_8) then do; af_is_tokens = "1"b; /* |[ -- rescan only for whitespace and quoted strings */ start = start + 1; processing_type = get_type (next_character); go to PROCESS_BEGIN_ACTIVE_STRING; end; else if (start < line_len) & (get_type (next_character) >= END_ACTIVE_STRING_1) & (get_type (next_character) <= END_ACTIVE_STRING_8) then do; catenate_values = "1"b; /* |] -- catenate iterated results */ start = start + 1; processing_type = get_type (next_character); go to PROCESS_END_ACTIVE_STRING; end; else do; /* nothing special about this occurence ... */ call get_node (); /* ... create a node to hold onto the character */ np -> atom.type = ATOM; np -> atom.string_ptr = addr (c (start)); np -> atom.string_len = 1; go to CONTINUE_SCAN; end; %page; /* Begin an iteration set: there may be up to eight different groups of iteration set delimiters (left parenthesis) */ /* format: off */ PROCESS_CHARACTER (17): PROCESS_CHARACTER (18): PROCESS_CHARACTER (19): PROCESS_CHARACTER (20): PROCESS_CHARACTER (21): PROCESS_CHARACTER (22): PROCESS_CHARACTER (23): PROCESS_CHARACTER (24): ; /* format: on */ call get_node (); /* add an iteration node */ np -> iter_begin.type = BEGIN_ITERATION; np -> iter_begin.parent = pp; np -> iter_begin.delimiter_class = processing_type; pp = np; /* push parent */ iter_level = iter_level + 1; go to CONTINUE_SCAN; /* End an iteration set (right parenthesis) */ /* format: off */ PROCESS_CHARACTER (25): PROCESS_CHARACTER (26): PROCESS_CHARACTER (27): PROCESS_CHARACTER (28): PROCESS_CHARACTER (29): PROCESS_CHARACTER (30): PROCESS_CHARACTER (31): PROCESS_CHARACTER (32): ; /* format: on */ if pp = null () then do; /* no matching begin iteration set delimiter */ code = error_table_$unbalanced_parentheses; go to RETURN_FROM_CP; end; else if pp -> node.type ^= BEGIN_ITERATION then do; code = error_table_$unbalanced_brackets; go to RETURN_FROM_CP; /* [) situation */ end; else if pp -> iter_begin.delimiter_class ^= (processing_type - 8) then do; code = error_table_$unbalanced_parentheses; go to RETURN_FROM_CP; /* previous begin iteration is of the wrong class */ end; if last_np -> node.type = END_ITERATION then last_np -> node.space = "0"b; /* multiple end iterations: ignore intervening whitespace */ else do; /* first end iteration so far */ if last_np -> node.type = ATOM then last_np -> node.space = "1"b; call get_node (); /* ... create an end iteration node */ np -> node.type = END_ITERATION; np -> iter_end.begin = pp; end; iter_level = iter_level - 1; /* one less unclosed iteration set */ last_np -> iter_end.level = iter_level; last_np -> iter_end.parent = pp; pp -> iter_begin.end = last_np; /* let begin iteration node know where we are */ pp = pp -> iter_begin.parent; /* pop parent */ go to CONTINUE_SCAN; %page; /* Begin an active string: there may be up to eight different groups of active string delimiters (left bracket) */ /* format: off */ PROCESS_BEGIN_ACTIVE_STRING: PROCESS_CHARACTER (33): PROCESS_CHARACTER (34): PROCESS_CHARACTER (35): PROCESS_CHARACTER (36): PROCESS_CHARACTER (37): PROCESS_CHARACTER (38): PROCESS_CHARACTER (39): PROCESS_CHARACTER (40): ; /* format: on */ call get_node (); /* add an active string node */ np -> af.type = ACTIVE_STRING; np -> af.parent = pp; np -> af.delimiter_class = processing_type; np -> af.atom_sw = af_is_atom; /* record options known so far */ np -> af.tokens_sw = af_is_tokens; np -> af.catenate_sw = "0"b; if evaluate_string & (afp = top_level_pp) then top_level_pp = np; /* new top level of evaluate_active_string */ pp = np; /* push parent */ np -> af.level = iter_level; /* save iteration level */ iter_level = 0; /* iteration sets in an active string are independent */ /* This case label is entered when a left bracket is found and after a semicolon or pipe token pair is found within an active string. The value must be checked. If this is a new active function and if there is a pipe active for the current level, the processing of the string as a pipe must be suspended. Once done, this new active string can be evaluated on its own. Processing of the new active function is ended and the previous pipe is restored when the right bracket is found. */ if p_pipe_control_ptr ^= null then if substr (line, start, length (LEFT_BRACKET)) = LEFT_BRACKET then do; sv_pipe_control_ptr = p_pipe_control_ptr; on condition (cleanup) begin; if p_pipe_control_ptr ^= null then do; call pipe_$terminate (addr (pipe_control.pipe_input_path), addr (pipe_control.pipe_output_path), ignore_code); free pipe_control in (system_area); end; /* Put back the command level pipe info if there is any */ p_pipe_control_ptr = sv_pipe_control_ptr; sv_pipe_control_ptr = null; end; p_pipe_control_ptr = null; end; go to CONTINUE_SCAN; /* End an active string (right bracket) */ /* format: off */ PROCESS_END_ACTIVE_STRING: PROCESS_CHARACTER (41): PROCESS_CHARACTER (42): PROCESS_CHARACTER (43): PROCESS_CHARACTER (44): PROCESS_CHARACTER (45): PROCESS_CHARACTER (46): PROCESS_CHARACTER (47): PROCESS_CHARACTER (48): ; /* format: on */ if pp = null () then do; /* no begin active string */ code = error_table_$unbalanced_brackets; go to RETURN_FROM_CP; end; else if (make_list_depth = 1) & evaluate_string & (pp = top_level_pp) then do; code = error_table_$unbalanced_brackets; go to RETURN_FROM_CP; /* evaluate_active_string: caller should've stripped this */ end; else if pp -> node.type ^= ACTIVE_STRING then do; code = error_table_$unbalanced_parentheses; go to RETURN_FROM_CP; /* (] situation */ end; else if pp -> af.delimiter_class ^= (processing_type - 8) then do; code = error_table_$unbalanced_brackets; go to RETURN_FROM_CP; /* previous begin active string is of the wrong class */ end; if p_pipe_control_ptr ^= null then do; /* If the pipe facility is in use as an active function, check for proper termination of the string. Then, terminate the pipe facility for this active string. */ if return_ptr = null | ^pipe_control.Sbuild_return_string then do; if current_pipe = "" then do; code = error_table_$null_brackets; go to RETURN_FROM_CP; end; else do; code = error_table_$bad_pipe_syntax; error_message = "Pipe active strings must end with "";|]"" or "";||]"""; go to RETURN_FROM_CP; end; end; call pipe_$terminate (addr (pipe_control.pipe_input_path), addr (pipe_control.pipe_output_path), ignore_code); free pipe_control in (system_area); p_pipe_control_ptr = sv_pipe_control_ptr; sv_pipe_control_ptr = null; if p_pipe_control_ptr ^= null then revert cleanup; end; else if return_ptr = null then if pp -> af.next = null () then do; code = error_table_$null_brackets; go to RETURN_FROM_CP; end; if p_pipe_control_ptr = null then do; p_pipe_control_ptr = sv_pipe_control_ptr; sv_pipe_control_ptr = null; end; semicolon_in_af = "0"b; call process_active_function (p_pipe_control_ptr); /* doesn't return */ %page; CONTINUE_SCAN: /* finished processing of special character ... */ start = start + 1; /* ... so move on to the rest of the line (if any) */ end; end; /* End of line */ if p_pipe_control_ptr ^= null then do; pipe_control.Sterminate = "1"b; pipe_control.previous_pipe_ptr = pipe_control.current_pipe_ptr; pipe_control.previous_pipe_len = pipe_control.current_pipe_len; pipe_control.current_pipe_ptr = addcharno (line_ptr, pipe_line_pos); pipe_control.current_pipe_len = start - pipe_line_pos - 1; pipe_control.next_pipe_ptr = null; pipe_control.next_pipe_len = 0; end; start = 0; /* remember no more commands left on this line */ RETURN_FROM_MAKE_LIST: if pp ^= null () then do; /* possibly unbalanced line */ if (make_list_depth = 1) & evaluate_string & (pp = top_level_pp) then call process_active_function (p_pipe_control_ptr); /* end of evaluate_active_string: do it */ if pp -> node.type = BEGIN_ITERATION then code = error_table_$unbalanced_parentheses; else code = error_table_$unbalanced_brackets; go to RETURN_FROM_CP; end; p_start = start; /* set result */ make_list_depth = make_list_depth - 1; return; %page; /* Evaluates part of an active string: Processes a single active function's portion of the active string. The active function may be invoked several times as parentheses may have been used in this portion of the active string */ process_active_function: procedure (pipe_control_ptr); dcl pipe_control_ptr ptr; dcl 1 pipe_control aligned like command_pipe_control based (pipe_control_ptr); dcl nonvarying_return_string character (length (return_string)) unaligned based (addrel (addr (return_string), 1)); last_np -> node.space = "1"b; /* finish last argument to the active function */ afp = pp; /* save pointer to beginning of active function sublist */ pp = afp -> af.parent; /* pop parent */ last_np = afp -> af.prev; /* unthread from list */ last_np -> node.next = null (); afp -> af.catenate_sw = catenate_values;/* ON if |] */ do first_node = afp -> node.next /* process the active function */ repeat (new_first_node) /* ... and any returned command delimiters */ while (first_node ^= null ()); call match_iters (first_node, active_function, arg_count, iter_count, new_first_node); /* pipes as active functions do not use the last argument as the return string so arg_count is reduced by 1. */ if pipe_control_ptr ^= null then if pipe_control.Sevaluate_pipe then if arg_count > 0 then arg_count = arg_count - 1; do iter_index = 1 to iter_count; if pipe_control_ptr = null then call read_list (first_node, active_function, arg_count, null); else if pipe_control.Sevaluate_pipe then do; /* calling a pipe. set the call up as a command */ pipe_control.Niters = iter_count; pipe_control.niters = iter_index; call read_list (first_node, command, arg_count, pipe_control_ptr); end; else /* regular af mixed with pipe af */ call read_list (first_node, active_function, arg_count, null); if return_ptr ^= null then if ((length (return_string) = 0) & ^afp -> af.atom_sw) | (return_string = "" & p_pipe_control_ptr ^= null) then ; /* ignore null return value unless ||[ */ else do; /* may have to process return value */ if ^afp -> af.atom_sw & ^afp -> af.tokens_sw then if use_standard_language then if search (return_string, BREAKS) ^= 0 then call evaluate_af_result (); else call treat_af_result_as_atom (); else if find_char_$first_in_table (nonvarying_return_string, cp_subsys_info.full_tct_table) ^= 0 then call evaluate_af_result (); else call treat_af_result_as_atom (); else if afp -> af.atom_sw then call treat_af_result_as_atom (); else do; /* don't recognize iteration, active strings, etc */ if use_standard_language then if search (return_string, TOKEN_BREAKS) ^= 0 then call evaluate_af_result (); else call treat_af_result_as_atom (); else if find_char_$first_in_table (nonvarying_return_string, cp_subsys_info.tokens_only_tct_table) ^= 0 then call evaluate_af_result (); else call treat_af_result_as_atom (); end; if (iter_index = iter_count) & (new_first_node = null ()) then last_np -> node.space = "0"b; /* last value from active function */ else last_np -> node.space = ^(afp -> af.catenate_sw); /* intermediate value: normally space */ end; end; end; iter_level = afp -> af.level; if semicolon_in_af then do; /* if active string has more sub-parts */ semicolon_in_af = "0"b; af_is_atom = afp -> af.atom_sw; /* "quoting" result applies to all parts */ af_is_tokens = afp -> af.tokens_sw; if pipe_control_ptr = null then last_np -> node.space = "1"b; else if ^pipe_control.Sevaluate_pipe then last_np -> node.space = "1"b; /* always separate sub-parts */ processing_type = afp -> af.delimiter_class; go to PROCESS_BEGIN_ACTIVE_STRING; end; if (make_list_depth = 1) & evaluate_string & (afp = top_level_pp) then go to RETURN_FROM_MAKE_LIST; /* end of an evaluate_string entry */ go to CONTINUE_SCAN; /* Internal to process_active_function: rescans and re-evaluates the active function's return string */ evaluate_af_result: procedure (); dcl pipe_control_ptr ptr; dcl 1 pipe_control aligned like command_pipe_control based (pipe_control_ptr); af_line_ptr = addrel (return_ptr, 1); af_line_len = length (return_string); call return_string_advance (); af_start = 1; pipe_control_ptr = null; on condition (cleanup) begin; if pipe_control_ptr ^= null then do; call pipe_$terminate (addr (pipe_control.pipe_input_path), addr (pipe_control.pipe_output_path), ignore_code); free pipe_control in (system_area); p_pipe_control_ptr = null; end; end; call make_list (af_line_ptr, af_line_len, afp -> af.tokens_sw, af_start, pipe_control_ptr); do while (af_start > 0); /* see if af value had semicolon */ call get_node (); /* sets af_prev of new node */ np -> node.type = END_OF_COMMAND; np -> node.af_prev -> atom.space = "1"b; /* previous node ends list */ call make_list (af_line_ptr, af_line_len, afp -> af.tokens_sw, af_start, pipe_control_ptr); if pipe_control_ptr ^= null then do; call pipe_$terminate (addr (pipe_control.pipe_input_path), addr (pipe_control.pipe_output_path), ignore_code); free pipe_control in (system_area); pipe_control_ptr = null; end; end; return; end evaluate_af_result; /* Internal to process_active_function: makes the active function's return string appear as a single token in the expanded command line */ treat_af_result_as_atom: procedure (); call get_node (); np -> atom.type = ATOM; np -> atom.string_ptr = addrel (return_ptr, 1); np -> atom.string_len = length (return_string); call return_string_advance (); return; end treat_af_result_as_atom; end process_active_function; %page; /* Internal to make_list: "Allocate" a node, obtaining a new node_block if necessary */ get_node: procedure (); null_cl = "0"b; /* has to be something there or we wouldn't be here */ node_index = node_index + 1; if node_index > hbound (node_block.array, 1) then do; /* allocate a new block */ last_block_ptr = block_ptr; allocate node_block in (system_area) set (block_ptr); unspec (node_block) = "0"b; node_block.next = null (); last_block_ptr -> node_block.next = block_ptr; node_index = 1; end; np = addr (node_block.array (node_index)); /* the node starts out as all zeroes */ np -> node.next = null (); np -> node.af_prev = last_np; /* in case node is af node */ np -> node.af_iter_parent = null (); last_np -> node.next = np; last_np = np; end get_node; /* Internal to make_list: Move return_ptr past the string just returned from the current active string invocation so that the result will not be lost */ return_string_advance: procedure (); return_len = return_len - 4 * divide (length (return_string) + 3, 4, 21, 0) - 1; if return_len >= MIN_AF_RETURN_LTH then /* always give AF a certain minimum amount of space */ return_ptr = addrel (return_ptr, divide (length (return_string) + 7, 4, 17, 0)); else return_ptr = null (); /* not enough space left in this segment */ end return_string_advance; end make_list; %page; /* Compute number of iteration and arguments for the command and validate that matching iteration sets contain matching numbers of elements: Two iteration sets are matching if either (1) they are connected (ie: the right parenthesis ending the first is not separated from the left parenthesis of the second by white space) or (2) they are top level iteration sets */ match_iters: procedure (p_first_node, p_command_type, p_arg_count, p_iter_count, p_new_first_node); dcl (p_first_node, p_new_first_node) pointer parameter; dcl p_command_type bit (1) aligned parameter; dcl (p_arg_count, p_iter_count) fixed binary parameter; dcl (p, pp) pointer; dcl first_iter bit (1) aligned; first_iter = "1"b; p_arg_count, p_iter_count = 0; p_new_first_node = null (); /* assume no semicolon left by AF */ p = p_first_node; if p = null () then return; /* empty list */ pp = null (); /* pointer to last outer iteration set to be processed */ do while (p ^= null ()); /* to end of list */ if p -> node.type = BEGIN_ITERATION then do; /* outer iteration set */ pp = p; /* record pointer to iter node of iteration set */ call count_iteration ((p), count, 0, iter_level); /* iter_level should equal 0 */ if first_iter then do; first_iter = "0"b; p_iter_count = count; /* save for later comparison */ end; else if count ^= p_iter_count then do; MISMATCH: code = error_table_$mismatched_iter; go to RETURN_FROM_CP; end; p_arg_count = p_arg_count + 1; /* each outer iteration set is an argument */ if p ^= null () then /* if iteration set does not end node list */ if p -> node.next = null () then /* but node after it does */ p -> atom.space = "1"b; /* list ends with atom */ else ; end; else if p -> node.type = END_OF_COMMAND then do; /* semicolon embedded by an AF */ p_new_first_node = p -> node.next; /* remember where next piece is */ p -> node.af_prev -> node.next = null (); /* remove from chain */ p = null (); /* do not look at rest */ end; else do; /* not ( or ; */ if p -> atom.next = null () then p -> atom.space = "1"b; /* last node in list */ if p -> node.space then p_arg_count = p_arg_count + 1; p = p -> atom.next; end; end; if p_arg_count = 0 then p_iter_count = 0; /* no arguments: this is an empty list */ else do; if p_command_type ^= active_function then p_arg_count = p_arg_count - 1; /* first argument is actually the command/AF name and should not be included in the argument count: however, as AFs have an extra argument (the return value), it isn't necessary to change this value for AFs */ if first_iter then p_iter_count = 1; /* no iterations: read the list once */ end; return; %page; /* Internal to match_iters: processes a single iteration set (and any interation connected to it). For example, (1 2) is a simple iteration set containing two (2) members; while (1 2)x(3 4) is a more complication expression involving two (2) connected iteration sets, but again only containing 2 members (1x3 and 2x4). The iteration set (a (1 2)x(3 4) 5)x is an iteration set which contains four (4) members, namely ax, 1x3x, 2x4x, and 5x. Count_iteration returns the number of members in iteration_count and updates final_level to include all parentheses encountered in any of the nodes processed. The node pointer variable 'p' is alsoupdated to point to the node following the node which ends the iteration set. This is the first node unconnected to the iteration set */ count_iteration: procedure (p_initial_p, p_iteration_count, p_parent_level, p_final_level); dcl p_initial_p pointer parameter; dcl (p_iteration_count, p_parent_level, p_final_level) fixed binary parameter; dcl (sub_count, temp_count) fixed binary; dcl (need_space, first_count) bit (1) aligned; p_iteration_count = 0; p_final_level = p_parent_level + 1; /* count left paren */ p = p_initial_p; /* actually a no-op */ p = p -> node.next; do while (p_final_level > p_parent_level); if p = null () then go to MISMATCH;/* not enough )'s */ need_space = "1"b; /* need to find a node which separates this iteration set from rest of command line */ first_count = "1"b; /* next iteration node begins an imbedded iteration set which is not connected to previous one */ sub_count = 0; do while (need_space); if p -> node.type = END_ITERATION then do; if p -> node.next = null () then p -> node.space = "1"b; pp = p -> iter_end.parent -> iter_begin.parent; p_final_level = p -> iter_end.level; if p_final_level < p_parent_level then do; /* multiple closure, pop one level */ p_final_level = p_parent_level; need_space = "0"b; /* do not advance to next node */ end; else do; /* closing one level */ need_space = ^p -> iter_end.space; p = p -> iter_end.next; end; end; else if p -> node.type = ATOM then do; if p -> atom.space & (p_final_level = (p_parent_level + 1)) then sub_count = sub_count + 1; if p -> node.next = null () then /* if last node in list */ p -> node.space = "1"b; need_space = ^p -> node.space; p = p -> node.next; end; else if p -> node.type = BEGIN_ITERATION then do; /* another iteration set */ if p_final_level = p_parent_level then do; /* this iteration is connected to */ first_count = "0"b; /* initial iteration at p_parent_level+1 */ sub_count = sub_count + p_iteration_count; /* save for later comparison */ p_iteration_count = 0; /* compute iter count for connected iter */ end; /* count the sub iteration */ call count_iteration ((p), temp_count, (p_final_level), p_final_level); if first_count then do; sub_count = temp_count; /* save count of first iteration */ first_count = "0"b; end; else if sub_count ^= temp_count then go to MISMATCH; /* this is count of an iter set connected to the first iter */ need_space = "0"b; end; else do; /* semicolon in AF result embedded in parentheses ... */ code = error_table_$unbalanced_parentheses; go to RETURN_FROM_CP; /* ... is an error */ end; end; p_iteration_count = p_iteration_count + sub_count; /* add to sum for parent iter set */ end; end count_iteration; end match_iters; %page; /* Create a command's argument list and either invoke it or produce a character string representation of the arguments: An argument list is generated (with descriptors) for the node list beginning at p_first_node */ produce_argument_list: procedure (p_first_node, p_command_type, p_arg_count); dcl p_first_node pointer parameter; dcl p_command_type bit (1) aligned parameter; dcl p_arg_count fixed binary parameter; dcl p_pipe_control_ptr ptr; dcl read_list_entry bit (1) aligned; dcl (p, pp) pointer; dcl start_arg bit (1) aligned; dcl null_iter bit (1) aligned; /* ON means a null nested iter was found */ dcl rethreaded bit (1) aligned; /* ON if list already rethreaded */ dcl (saved_level, argument_idx) fixed binary; dcl command_name character (arg_len (0)) unaligned based (command_name_ptr); dcl command_name_ptr pointer; dcl command_entry_ptr pointer; /* command to call */ dcl (extension_size, needed_space) fixed binary (21); dcl (arg_ptr, stack_ptr, space_ptr) pointer; dcl arg_space fixed binary (21); /* number of chars left in space acquired */ dcl object character (object_lth) unaligned based (object_ptr); dcl object_ptr pointer; dcl object_lth fixed binary (21); dcl suffix character (1) varying; dcl current_arg_len fixed binary (21); /* number of chars in (non-simple) arg being developed */ dcl current_arg character (current_arg_len) unaligned based (arg_ptr); dcl arg character (arg_space) unaligned based (arg_ptr); dcl arg_len (0:p_arg_count + 1) fixed binary automatic; dcl 1 arg_list aligned automatic, 2 twice_no_of_args fixed binary (18) unaligned unsigned, 2 tag bit (18) unaligned initial ("000004"b3), 2 twice_no_of_descriptors fixed binary (18) unaligned unsigned, 2 has_command_name bit (1) unal, 2 pad bit (17) unaligned initial ("0"b), 2 arg_ptr (p_arg_count) pointer, 2 descriptor_ptr (p_arg_count) pointer, 2 name, 3 command_name_ptr pointer, 3 command_name_length fixed bin (21); dcl 1 descriptor (p_arg_count) aligned automatic, 2 bits bit (12) unaligned, /* flag(1), type(6), packed(1), and ndims(4) */ 2 size fixed binary (24) unaligned unsigned; %page; /* Construct the argument list and then invoke the command */ read_list: entry (p_first_node, p_command_type, p_arg_count, p_pipe_control_ptr); read_list_entry = "1"b; go to RL_COMMON; /* Construct the argument list and then produce a character string representation of the command invocation */ write_list: entry (p_first_node, p_command_type, p_arg_count, p_pipe_control_ptr); read_list_entry = "0"b; RL_COMMON: count, current_arg_len, arg_space, extension_size = 0; space_ptr = null (); start_arg = "1"b; /* need to get space for arg */ arg_ptr = null (); /* just to catch programming errors */ p = p_first_node; do while (p ^= null ()); /* to end of list */ if p -> node.type = ATOM then do; /* atom */ atom_ptr = p -> atom.string_ptr; atom_len = p -> atom.string_len; if start_arg & p -> atom.space then do; /* single command line token as arg */ arg_len (count) = atom_len; if count = 0 then command_name_ptr = atom_ptr; else arg_list.arg_ptr (count) = atom_ptr; current_arg_len = 0; count = count + 1; start_arg = "1"b; end; else do; call non_simple_arg (); if p -> atom.space then call end_arg (); end; p = p -> atom.next; end; else do; /* iteration set */ rethreaded = "0"b; iter_level = 1; pp = p; /* go inside; set parent pointer */ do p = p -> node.next repeat (p -> node.next) while (iter_level > 0); /* to end of outer iteration set */ if p -> node.type = BEGIN_ITERATION then do; /* nested iteration */ if ^start_arg & rethreaded then rethreaded = "0"b; /* if connected iteration must rethread each iteration set */ iter_level = iter_level + 1; pp = p; if p -> iter_begin.next = p -> iter_begin.end then do; /* null iteration set */ current_arg_len = 0;/* have to begin arg over */ start_arg = "1"b; null_iter = "1"b; rethreaded = "0"b; go to skip_iter; end; end; else do; null_iter = "0"b; atom_ptr = p -> atom.string_ptr; atom_len = p -> atom.string_len; if start_arg & (p -> atom.space) & (pp -> iter_begin.end -> iter_end.space) & (iter_level = 1) then do; /* single command line token as arg */ /* depends upon whether right paren is followed by space */ /* only simple tokens in the outermost iteration set are not copied, to detect simple tokens when additional levels of nesting are involved is quite complicated and not deemed worth the effort for a very unlikely construct */ arg_len (count) = atom_len; if count = 0 then command_name_ptr = atom_ptr; else arg_list.arg_ptr (count) = atom_ptr; current_arg_len = 0; count = count + 1; start_arg = "1"b; end; else call non_simple_arg (); if p -> atom.space then do; /* this atom ends an element of the iteration set */ if ^rethreaded then do; /* rethread next iteration element */ rethreaded = "1"b; /* assume we can do the rethreading */ if p -> atom.next -> node.type ^= END_ITERATION then pp -> iter_begin.next = p -> atom.next; /* if not last element of iteration set */ else if p -> atom.next -> iter_end.space then do; /* if last element of iteration set followed by space */ if iter_level = 1 then p -> atom.next -> iter_end.parent -> iter_begin.next = p -> atom.next; /* and top level */ else pp -> iter_begin.parent -> iter_begin.next = p -> atom.next -> iter_end.next; /* not top level, its done */ end; else rethreaded = "0"b; /* last element of iteration set not followed by space */ /* have to perform rethreading later */ end; /* Skip to the end of this iteration set */ skip_iter: saved_level = iter_level; p = pp -> iter_begin.end; /* move p to ) node */ do while (iter_level > 0); if p -> node.type = BEGIN_ITERATION then do; /* left paren, jump to right paren which matches */ iter_level = iter_level + 1; pp = p; p = pp -> iter_begin.end; end; /* Node must be either an atom or iter_end node */ if p -> node.type = END_ITERATION then do; iter_level = p -> iter_end.level; pp = p -> iter_end.parent -> iter_begin.parent; if iter_level = 0 then if p -> iter_end.space then if ^start_arg then call end_arg (); else ; /* no arg needs to be ended */ else ; /* reached outermost ), but it is connected to something */ else do; /* reached end of nested iteration */ if iter_level >= saved_level then ; /* some other iter set */ else if p -> iter_end.space then if null_iter then go to more_arg; /* finished with stuff connected to null iteration */ else ; /* nested iter, nothing connected to it */ else if null_iter then ; /* end of iter connected to null iter */ else go to more_arg; /* nested iter with something attached */ p = p -> node.next; end; end; else if null_iter & p -> atom.space then go to more_arg; /* reached last node connected to null iteration */ else p = p -> node.next; /* an atom node */ end; end; end; more_arg: end; /* p can be null at this point */ end; end; %page; if read_list_entry then do; /* All arguments have been completed and the command or active function should be called */ if p_command_type = active_function then twice_no_of_args, twice_no_of_descriptors = 2 * count; else twice_no_of_args, twice_no_of_descriptors = 2 * (count - 1); do argument_idx = 1 to count - 1; descriptor_ptr (argument_idx) = addr (descriptor (argument_idx)); descriptor (argument_idx).bits = "5260"b3; descriptor (argument_idx).size = arg_len (argument_idx); end; /* unaligned nonvarying strings */ if p_command_type = active_function then do; call setup_return_string (); /* prepare the return string */ arg_list.arg_ptr (p_arg_count) = addrel (addr (return_string), 1); descriptor_ptr (p_arg_count) = addr (descriptor (p_arg_count)); descriptor (p_arg_count).bits = "5320"b3; /* aligned, varying string */ descriptor (p_arg_count).size = return_len; end; /* save the name on the current argument list NOTE this is a new structure */ arg_list.has_command_name = "1"b; arg_list.name.command_name_length = length (command_name); arg_list.name.command_name_ptr = command_name_ptr; command_entry_ptr = null; if multics_cp then on condition (command_abort_) go to ABORT_EXECUTION; else if p_command_type = command then on condition (request_abort_) go to ABORT_EXECUTION; if p_command_type = active_function | p_pipe_control_ptr = null then do; /* regular command call */ call process_command (command_entry_ptr, code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; else do; /* the pipe facility is invoked */ on condition (cleanup) call process_pipe_cleanup (p_pipe_control_ptr); call process_pipe (p_pipe_control_ptr, command_name, code); if code ^= 0 then go to RETURN_FROM_CP; end; end; %page; else do; /* All arguments have been completed and the list is to be retruned as a character string */ do argument_idx = 0 to count - 1; if (argument_idx ^= count - 1) then suffix = " "; /* more to come */ else suffix = ""; if argument_idx = 0 then object_ptr = command_name_ptr; else object_ptr = arg_list.arg_ptr (argument_idx); object_lth = arg_len (argument_idx); if length (P_return_value) + object_lth + length (suffix) > maxlength (P_return_value) then code = error_table_$command_line_overflow; P_return_value = P_return_value || object; /* two statements generates better code */ P_return_value = P_return_value || suffix; if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; /* failure to fit */ end; end; ABORT_EXECUTION: return; %page; /* Internal to produce_argument_list: moves the atom_string into the current_arg, obtaining more space if necessary */ non_simple_arg: procedure () /* options (quick) */; /* MUST BE A QUICK BLOCK */ if current_arg_len + atom_len > arg_space then do; needed_space = 16 * max (4, divide (currentsize (atom_string) + 15, 16, 21, 0)); extension_size = extension_size + needed_space; if using_stack & (needed_space < 1024) & (extension_size < MAX_STACK_EXTENSION) then do; /* OK to continue extending the stack */ call cu_$grow_stack_frame (needed_space, stack_ptr, ignore_code); /* grow_stack_frame always returns zero code */ if space_ptr = null () then do; space_ptr = stack_ptr; arg_ptr = space_ptr; /* first call, must initialize arg_ptr */ end; arg_space = arg_space + 4 * needed_space; end; else do; /* use space in a temporary segment */ using_stack = "0"b; space_ptr = select_scratch_segment (); arg_space = 4 * sys_info$max_seg_size; if ^start_arg then do; substr (space_ptr -> arg, 1, current_arg_len) = current_arg; arg_space = arg_space - current_arg_len; end; arg_ptr = space_ptr; /* have switched spaces */ end; end; substr (arg, current_arg_len + 1, atom_len) = atom_string; current_arg_len = current_arg_len + atom_len; start_arg = "0"b; /* arg has been started */ arg_space = arg_space - atom_len; end non_simple_arg; %page; /* Internal to produce_argument_list: complete construction of the current argument */ end_arg: procedure (); if count = 0 then command_name_ptr = arg_ptr; else arg_list.arg_ptr (count) = arg_ptr; arg_len (count) = current_arg_len; arg_ptr = addr (substr (arg, current_arg_len + 1, 1)); /* get pointer to char after last char of this arg */ arg_space = arg_space - current_arg_len; count = count + 1; start_arg = "1"b; current_arg_len = 0; end end_arg; /* Internal to produce_argument_list: Prepares the return string for an active function invocation */ setup_return_string: procedure (); if return_ptr = null () then do; /* first active function or last one used too much space */ return_ptr = select_scratch_segment (); return_len = 4 * (sys_info$max_seg_size - 1); end; return_string = ""; return; end setup_return_string; %page; process_command: proc (command_entry_ptr, code); dcl command_entry_ptr ptr, code fixed bin (35); if multics_cp then do; /* executing Multics command line */ if lss_on then do; /* running Limited Service System */ call transform_command_ (command_name_ptr, arg_len (0), cp_data_$command_table_ptr, code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; if command_entry_ptr = null then do; if evaluate_string then /* be silent for cp_$af */ call find_command_$fc_no_message (command_name_ptr, arg_len (0), command_entry_ptr, code); else call find_command_ (command_name_ptr, arg_len (0), command_entry_ptr, code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; call cu_$gen_call (command_entry_ptr, addr (arg_list)); end; else if new_subsystem_call /* executing a new-style subsystem request */ then do; call execute_request (P_subsystem_info_ptr, command_name, addr (arg_list), code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; else do; /* executing an old-style subsystem request */ call old_execute_request (command_name, addr (arg_list), code); if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; end; return; end process_command; %page; /* Internal to produce_argument_list: determines whether the entry is an io attachment or command, then processes accordingly. */ process_pipe: proc (p_pipe_control_ptr, command_name, code); dcl p_pipe_control_ptr ptr parameter, /* (input) - ptr 2 pipe control info */ command_name char (*) parameter, /* (input) - name of the command */ code fixed bin (35) parameter; /* (output)- error status */ dcl aligned_command_name char (32) aligned; dcl pipe_control_ptr ptr; dcl 1 pipe_control aligned like command_pipe_control based (pipe_control_ptr); dcl Satds_match bit (1) aligned; dcl Sdefault_curr_to_vfile bit (1) aligned; dcl attach_description char (1024) aligned; dcl command_entry_ptr ptr; dcl current_pipe aligned char (pipe_control.current_pipe_len) based (pipe_control.current_pipe_ptr); dcl next_pipe aligned char (pipe_control.next_pipe_len) based (pipe_control.next_pipe_ptr); dcl previous_pipe aligned char (pipe_control.previous_pipe_len) based (pipe_control.previous_pipe_ptr); dcl pipeout_file_path char (168) aligned; dcl sv_pipe_path char (58); dcl FALSE bit (1) aligned internal static options (constant) init ("0"b), TRUE bit (1) aligned internal static options (constant) init ("1"b), INPUT bit (1) aligned internal static options (constant) init ("1"b), OUTPUT bit (1) aligned internal static options (constant) init ("0"b); dcl pipe_$initiate entry (ptr), pipe_$copy entry (ptr, ptr, fixed bin (35)), pipe_$attach_pipe entry (char (*) aligned, bit (1) aligned, bit (1) aligned, ptr, fixed bin (35)), pipe_$open_pipe entry (ptr, bit (1) aligned, fixed bin (35)), pipe_$get_return_string_nnl entry (ptr, ptr, fixed bin (21), fixed bin (35)), pipe_$get_return_string entry (ptr, ptr, fixed bin (21), fixed bin (35)); pipe_control_ptr = p_pipe_control_ptr; command_entry_ptr = null; Satds_match = FALSE; if pipe_control.current_pipe_len = 0 then return; if substr (command_name, 1, length (VERTICAL_BAR)) = VERTICAL_BAR then code = error_table_$bad_file_name; else call check_star_name_ (command_name, CHECK_STAR_PROCESS_PATH | CHECK_STAR_REJECT_WILD | CHECK_STAR_IGNORE_ENTRYPOINT, (0), code); if code ^= 0 then do; error_message = command_name; return; end; if pipe_control.Sevaluate_pipe then do; if pipe_control.Sbuild_return_string then return_ptr = null; call setup_return_string (); end; /* only the command name needs to be checked to see if it is an atd */ aligned_command_name = command_name; if element_is_an_atd (aligned_command_name, command_entry_ptr, Sdefault_curr_to_vfile, code) then do; /* This call builds a complete attach description for the current section of the command line. The usage of the value next_pipe is discussed in make_list label PROCESS_CHARACTER (2) above. Because the value may not be complete, it is necessary to build the attachment from the argument list. */ attach_description = make_command_line_attach (); call process_attach_description (return_ptr, return_len, code); end; else call process_pipe_command (command_entry_ptr, command_name, return_ptr, return_len, code); return; %page; /* Internal to process_pipe: processes the current section of the command line if it is an attach description. */ process_attach_description: proc (af_return_str_ptr, af_return_str_len, code); dcl af_return_str_ptr ptr, /* (input/output) ptr to return str */ af_return_str_len fixed bin (21), /* (input/output) len of return str */ code fixed bin (35); /* (output) error status */ code = 0; /* If the element before the ";|" is an attach description, copy its contents to this attach description. */ if pipe_control.previous_pipe_ptr ^= null then do; call copy_thru_pipe (previous_pipe, attach_description, code); if code ^= 0 then return; /* if the previous attach is the same as this one, the data was placed in a temp file. Now copy the data from the temp file to the original */ if Satds_match then do; call copy_thru_pipe (pipe_control.pipe_output_path, attach_description, code); if code ^= 0 then return; end; end; /* next_pipe_ptr is null when the attach description is the last element in an input command line. */ if pipe_control.next_pipe_ptr = null then return; /* build the active function return string when this attach description preceeds the string ";|]" or ";||]". */ if pipe_control.Sbuild_return_string then do; if (pipe_control.niters < pipe_control.Niters) then ; else call build_pipe_return_string (attach_description, af_return_str_ptr, af_return_str_len, code); end; /* If this attach description is the last thing in the line except ";|", use a default output file of "[wd]>pipeout". */ else if next_pipe = "" then do; pipeout_file_path = rtrim (get_wdir_ ()) || ">pipeout"; call copy_thru_pipe (attach_description, pipeout_file_path, code); end; /* if this element is an attach description that does not use any active functions, quotes or parens, do nothing. Otherwise, copy its contents to the next element in the line. This is because when the next pipe element is processed, this value will be the previous pipe value and because it has special characrters in it, the next element will expect a temp file. */ else if element_is_an_atd (current_pipe, null, Sdefault_curr_to_vfile, ignore_code) then ; else do; call copy_thru_pipe (attach_description, ltrim (next_pipe), code); if code ^= 0 then return; if (pipe_control.niters < pipe_control.Niters) then ; else do; /* switch the pathnames of the input and output pipe work files so that the current output file will be used as input to the next element in the command line. */ sv_pipe_path = pipe_control.pipe_input_path; pipe_control.pipe_input_path = pipe_control.pipe_output_path; pipe_control.pipe_output_path = sv_pipe_path; end; end; return; end process_attach_description; %page; /* Internal to process_pipe: processes the current section of the command line if it is a command. */ process_pipe_command: proc (command_entry_ptr, command_name, af_return_str_ptr, af_return_str_len, code); dcl command_entry_ptr ptr, /* (input) - ptr to entry to execute */ command_name char (*), /* (input) - name of command */ af_return_str_ptr ptr, /* (input/output) ptr to return str */ af_return_str_len fixed bin (21), /* (input/output) len of return str */ code fixed bin (35); /* (output)- error status */ code = 0; call attach_input (previous_pipe, pipe_control.input_ptr, code); if code ^= 0 then return; if pipe_control.next_pipe_ptr ^= null then do; if next_pipe = "" then do; pipeout_file_path = rtrim (get_wdir_ ()) || ">pipeout"; call attach_output (previous_pipe, pipeout_file_path, pipe_control.output_ptr, Satds_match, code); end; else call attach_output (previous_pipe, next_pipe, pipe_control.output_ptr, Satds_match, code); if code ^= 0 then return; end; call process_command (command_entry_ptr, code); call process_pipe_cleanup (p_pipe_control_ptr); if (pipe_control.niters < pipe_control.Niters) then ; else do; if pipe_control.Sbuild_return_string then call build_pipe_return_string (pipe_control.pipe_output_path, af_return_str_ptr, af_return_str_len, code); sv_pipe_path = pipe_control.pipe_input_path; pipe_control.pipe_input_path = pipe_control.pipe_output_path; pipe_control.pipe_output_path = sv_pipe_path; end; return; end process_pipe_command; %page; /* Internal to process_pipe: compares two attach descriptions. */ atds_match: proc (attach_description_1, attach_description_2, Sdefault2) returns (bit (1) aligned); dcl attach_description_1 char (*) aligned, /* (input) attach descrip. 1. */ attach_description_2 char (*) aligned, /* (input) attach descrip. 2. */ Sdefault2 bit (1) aligned; /* (input) atd2 is a vfile_ */ dcl Sdefault1 bit (1) aligned, full_path1 char (1024), full_path2 char (1024), match_word1 char (32) varying, match_word2 char (32) varying, word_cnt1 fixed bin, word_cnt2 fixed bin, uid1 bit (36) aligned, uid2 bit (36) aligned; word_cnt1 = 1; word_cnt2 = 1; /* if one of the attach descriptions is blank, they do not match. */ if attach_description_1 = SPACE | attach_description_2 = SPACE then return (FALSE); /* If the first attach is defaulted to a vfile, set the match word to "vfile_". Otherwise, set the match word to the first word in the attach description. */ if element_is_an_atd (attach_description_1, null, Sdefault1, ignore_code) then match_word1 = "vfile_"; else do; match_word1 = get_word (attach_description_1, word_cnt1); word_cnt1 = word_cnt1 + 1; end; /* If the secord attach is defaulted to a vfile, set the match word to "vfile_". Otherwise, set the match word to the first word in the attach description. */ if Sdefault2 then match_word2 = "vfile_"; else do; match_word2 = get_word (attach_description_2, word_cnt2); word_cnt2 = word_cnt2 + 1; end; /* Here, the first words will always be the name of the I/O module used. If they do not match, the attach descriptions do not match. */ if match_word1 ^= match_word2 then return (FALSE); /* If using vfile_, get the uid of the file begin attached to. The uid is the only accurate means of determining if the two paths point to the same file. */ if match_word1 = "vfile_" then do; match_word1 = get_word (attach_description_1, word_cnt1); match_word2 = get_word (attach_description_2, word_cnt2); call absolute_pathname_ ((match_word1), full_path1, ignore_code); call hcs_$get_uid_file (full_path1, "", uid1, code); if code ^= 0 then do; code = 0; uid1 = TRUE; end; call absolute_pathname_ ((match_word2), full_path2, ignore_code); call hcs_$get_uid_file (full_path2, "", uid2, code); if code ^= 0 then do; code = 0; uid2 = FALSE; end; if uid1 = uid2 then return (TRUE); return (FALSE); end; /* Here, all I/O modules that are not vfile_ are checked. If the first arguments to the I/O modules are the same, then return true. */ match_word1 = get_word (attach_description_1, word_cnt1); match_word2 = get_word (attach_description_2, word_cnt2); if match_word1 = match_word2 then return (TRUE); /* Cases that are not handled by this routine include: 1) mtape_ attach descriptions where the volume name is placed into the default arguments value within a value segment. In this case, the attach description is incomplete. Omitting the positional argument is a violation of the standard for I/O modules and mtape_ should be changed to conform. */ return (FALSE); get_word: proc (word_list, word_to_return) returns (char (32) varying); dcl word_list char (*) aligned; dcl word_to_return fixed bin; dcl work_list char (1024) varying; dcl word char (32) varying; dcl i fixed bin; /* If the attach description has a target attach, use only the target. */ work_list = ltrim (after (word_list, "-target ")); if work_list = "" then work_list = ltrim (word_list); do i = 1 to word_to_return; word = before (work_list, SPACE); work_list = after (work_list, SPACE); work_list = ltrim (work_list); end; return (word); end get_word; end atds_match; %page; /* Internal to process_pipe: attaches and opens user_input for use by the caller using the input attachment. */ attach_input: proc (input_atd, input_ptr, code); dcl input_atd char (*) aligned; /* (input) - attach descipt/command */ dcl input_ptr ptr; /* (input/output) - ptr to input pipe info */ dcl code fixed bin (35); /* (output) - error status */ dcl Sdefault_to_vfile bit (1) aligned; /* Attach and open the input based on type */ code = 0; input_ptr = null; if input_atd = "" then return; input_atd = ltrim (input_atd); /* If the input attachment is an attach description, attach and open it. Otherwise, attach and open the pipe input file. If there is no pipe input, there is an error. */ if element_is_an_atd (input_atd, null, Sdefault_to_vfile, ignore_code) then call pipe_$attach_pipe (input_atd, Sdefault_to_vfile, FALSE, input_ptr, code); else do; /* previous entry is a command */ if pipe_control.pipe_input_path = "" then do; code = error_table_$no_file; return; end; else call pipe_$attach_pipe (pipe_control.pipe_input_path, TRUE, FALSE, input_ptr, code); end; if code ^= 0 then do; error_message = "While attaching " || rtrim (input_atd) || "."; return; end; call pipe_$open_pipe (input_ptr, INPUT, code); if code ^= 0 then do; if code = error_table_$noentry then error_message = "Unknown command or file " || input_atd || "."; else error_message = "While opening " || input_atd || " for input."; call process_pipe_cleanup (p_pipe_control_ptr); return; end; return; end attach_input; %page; /* Internal to process_pipe: attaches and opens user_output for use by the caller using the output attachment. */ attach_output: proc (input_atd, output_atd, output_ptr, Satds_match, code); dcl input_atd char (*) aligned; /* (input) - input attachment */ dcl output_atd char (*) aligned; /* (input) - output to be attached */ dcl output_ptr ptr; /* (input/output) - ptr to output pipe info */ dcl Satds_match bit (1) aligned; /* (output) - ON = input matchs output */ dcl code fixed bin (35); /* (output) - error status */ dcl Sdefault_to_vfile bit (1) aligned; code = 0; output_ptr = null; input_atd = ltrim (input_atd); output_atd = ltrim (output_atd); /* If the output attachment is an attach description and does not conflict with the input attachment, attach and open it. Otherwise, attach and open the pipe output file. */ if element_is_an_atd (output_atd, null, Sdefault_to_vfile, ignore_code) then do; if atds_match (input_atd, output_atd, Sdefault_to_vfile) then Satds_match = "1"b; else do; call pipe_$attach_pipe (output_atd, Sdefault_to_vfile, TRUE, output_ptr, code); Satds_match = "0"b; end; end; if output_ptr = null & code = 0 then do; if pipe_control.pipe_output_path = "" then call pipe_$initiate (addr (pipe_control.pipe_output_path)); call pipe_$attach_pipe (pipe_control.pipe_output_path, TRUE, TRUE, output_ptr, code); end; if code ^= 0 then do; error_message = "While attaching " || output_atd || "."; return; end; call pipe_$open_pipe (output_ptr, OUTPUT, code); if code ^= 0 then do; error_message = "While opening " || output_atd || " for output."; call process_pipe_cleanup (p_pipe_control_ptr); return; end; return; end attach_output; %page; /* Internal to process_pipe: adds the information from the file given in the input_atd to the active function return string. */ build_pipe_return_string: proc (input_atd, pipe_return_string_ptr, pipe_return_string_len, code); dcl input_atd char (*) aligned, /* (input) - return string file */ pipe_return_string_ptr ptr, /* (input) - ptr to return string */ pipe_return_string_len fixed bin (21), /* (input) - len of return string */ code fixed bin (35); /* (output) - error status */ call attach_input (input_atd, pipe_control.input_ptr, code); if code ^= 0 then return; if pipe_control.Sinclude_NL_in_af_ret_str then call pipe_$get_return_string (pipe_control.input_ptr, pipe_return_string_ptr, pipe_return_string_len, code); else call pipe_$get_return_string_nnl (pipe_control.input_ptr, pipe_return_string_ptr, pipe_return_string_len, code); call process_pipe_cleanup (p_pipe_control_ptr); return; end build_pipe_return_string; %page; /* Internal to process_pipe: copies the information from the file given in the input atd to the file given in the output atd. */ copy_thru_pipe: proc (copy_input_atd, copy_output_atd, code); dcl copy_input_atd aligned char (*), /* (input) - input attach descript. */ copy_output_atd aligned char (*), /* (input) - output attach descript. */ code fixed bin (35); /* (output)- error status */ call attach_input (copy_input_atd, pipe_control.input_ptr, code); if code = error_table_$no_file then do; code = 0; return; end; if code = 0 then do; call attach_output (copy_input_atd, copy_output_atd, pipe_control.output_ptr, Satds_match, code); if code = 0 then do; call pipe_$copy (pipe_control.input_ptr, pipe_control.output_ptr, code); if code ^= 0 then error_message = "While copying data from " || ltrim (copy_input_atd) || " to " || ltrim (copy_output_atd) || "."; end; end; call process_pipe_cleanup (p_pipe_control_ptr); return; end copy_thru_pipe; %page; /* Internal to process_pipe: determines if the input pipe element is a valid attach description or command. */ element_is_an_atd: proc (pipe_element, p_command_entry_ptr, Sdefault_to_vfile, code) returns (bit (1) aligned); dcl pipe_element char (*) aligned, /* (input) - element who type is to be determined */ p_command_entry_ptr ptr, /* (output)- if a command points to its entrypoint */ Sdefault_to_vfile bit (1) aligned, /* (output)- if an atd on = file name use vfile_ */ code fixed bin (35); /* (output)- error status */ dcl dirname char (168), entryname char (32), io_module_attach_entry char (200); dcl command_entry_ptr ptr; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); Sdefault_to_vfile = FALSE; p_command_entry_ptr = null; if ^multics_cp then return (FALSE); pipe_element = ltrim (pipe_element); if search (pipe_element, NON_SIMPLE_BREAKS) > 0 then return (FALSE); /* If entry already is an entry, it */ /* is not an atd. */ if search (pipe_element, "$") > 0 then return (FALSE); call find_command_$fc_no_message (addr (before (pipe_element, SPACE)), length (before (pipe_element, SPACE)), command_entry_ptr, code); if code = 0 then do; p_command_entry_ptr = command_entry_ptr; return (FALSE); end; call expand_pathname_ (before (pipe_element, SPACE), dirname, entryname, code); /* set the io module name to the entryname portion of the pipe element. If there is a pathname in the line, it is possible that a personal version of an i/o module is being used. */ io_module_attach_entry = before (ltrim (pipe_element), rtrim (entryname)) || rtrim (entryname) || "$" || rtrim (entryname) || "attach"; call find_command_$fc_no_message (addr (io_module_attach_entry), length (io_module_attach_entry), command_entry_ptr, code); if code = 0 then return (TRUE); Sdefault_to_vfile = TRUE; code = 0; return (TRUE); end element_is_an_atd; %page; /* Internal to process_pipe: builds and returns an attach description and arguments using the argument list. */ make_command_line_attach: proc () returns (char (1024) varying); dcl command_line_attach char (1024) varying; command_line_attach = ""; do argument_idx = 0 to count - 1; if (argument_idx ^= count - 1) then suffix = " "; /* more to come */ else suffix = ""; if argument_idx = 0 then object_ptr = command_name_ptr; else object_ptr = arg_list.arg_ptr (argument_idx); object_lth = arg_len (argument_idx); if length (command_line_attach) + object_lth + length (suffix) > maxlength (command_line_attach) then code = error_table_$command_line_overflow; command_line_attach = command_line_attach || object; /* two statements generates better code */ command_line_attach = command_line_attach || suffix; if code ^= 0 then go to SILENTLY_RETURN_FROM_CP; /* failure to fit */ end; return (command_line_attach); end make_command_line_attach; end process_pipe; %page; /* Internal to process_pipe: closes and detaches user_input and user_output. */ process_pipe_cleanup: proc (p_pipe_control_ptr); dcl p_pipe_control_ptr ptr; /* (input) - ptr 2 pipe control info */ dcl 1 pipe_control aligned like command_pipe_control based (p_pipe_control_ptr); dcl pipe_$close_pipe entry (ptr, bit (1) aligned, fixed bin (35)), pipe_$detach_pipe entry (ptr, fixed bin (35)); if pipe_control.input_ptr ^= null then do; call pipe_$close_pipe (pipe_control.input_ptr, pipe_control.niters = pipe_control.Niters, ignore_code); call pipe_$detach_pipe (pipe_control.input_ptr, ignore_code); end; if pipe_control.output_ptr ^= null then do; call pipe_$close_pipe (pipe_control.output_ptr, "0"b, ignore_code); call pipe_$detach_pipe (pipe_control.output_ptr, ignore_code); end; return; end process_pipe_cleanup; end produce_argument_list; %page; /* Initialize scratch segment management */ initialize_scratch_segments: procedure (p_first_call); dcl p_first_call bit (1) aligned parameter; if p_first_call then do; /* only do the following stuff once per invocation ... */ permanent_scratch_segment_list_ptr = addr (cp_data_$permanent_scratch_segment_list); cp_data_$scratch_lock_id = cp_data_$scratch_lock_id + 1; scratch_lock_id = bit (fixed (cp_data_$scratch_lock_id, 36, 0), 36); end; temporary_scratch_segment_list_ptr = addr (local_temporary_scratch_segment_list); temporary_scratch_segment_list.n_allocated = dimension (local_temporary_scratch_segment_list.segment_ptrs, 1); temporary_scratch_segment_list.n_used = 0; /* not using any temporary scratch segments just yet */ temporary_scratch_segment_list.segment_ptrs (*) = null (); return; end initialize_scratch_segments; /* Select the next available scratch segment giving preference to the "permanent" segments */ select_scratch_segment: procedure () returns (pointer); dcl 1 permanent_scratch_segment like permanent_scratch_segment_list.scratch_segments aligned based (permanent_scratch_segment_ptr); dcl (permanent_scratch_segment_ptr, old_temporary_scratch_segment_list_ptr, new_temporary_scratch_segment_list_ptr, segment_ptr) pointer; dcl idx fixed binary; segment_ptr = null (); /* haven't found one yet */ do idx = 1 to permanent_scratch_segment_list.n_scratch_segments while (segment_ptr = null ()); permanent_scratch_segment_ptr = addr (permanent_scratch_segment_list.scratch_segments (idx)); if stacq (permanent_scratch_segment.lock, scratch_lock_id, (36)"0"b) then do; if permanent_scratch_segment.segment_ptr = null () then do; call get_temp_segment_ (COMMAND_PROCESSOR_, permanent_scratch_segment.segment_ptr, code); if code ^= 0 then go to RETURN_FROM_CP; end; permanent_scratch_segment.usage_count = permanent_scratch_segment.usage_count + 1; segment_ptr = permanent_scratch_segment.segment_ptr; end; end; if segment_ptr = null () then do; /* no permanent segments available */ if temporary_scratch_segment_list.n_used = temporary_scratch_segment_list.n_allocated then do; temporary_scratch_segment_list_n_allocated = 2 * temporary_scratch_segment_list.n_allocated; old_temporary_scratch_segment_list_ptr = temporary_scratch_segment_list_ptr; allocate temporary_scratch_segment_list in (system_area) set (new_temporary_scratch_segment_list_ptr); new_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.n_used = old_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.n_used; new_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.segment_ptrs (*) = null (); do idx = 1 to old_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.n_used; new_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.segment_ptrs (idx) = old_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.segment_ptrs (idx); end; temporary_scratch_segment_list_ptr = new_temporary_scratch_segment_list_ptr; if old_temporary_scratch_segment_list_ptr ^= addr (local_temporary_scratch_segment_list) then free old_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list in (system_area); end; temporary_scratch_segment_list.n_used, idx = temporary_scratch_segment_list.n_used + 1; call get_temp_segment_ (COMMAND_PROCESSOR_, temporary_scratch_segment_list.segment_ptrs (idx), code); if code ^= 0 then go to RETURN_FROM_CP; segment_ptr = temporary_scratch_segment_list.segment_ptrs (idx); end; return (segment_ptr); end select_scratch_segment; /* Release any temporary scratch segments and mark all "permanent" segments selected by this invocation as available */ release_scratch_segments: procedure (p_last_call); dcl p_last_call bit (1) aligned parameter; dcl 1 permanent_scratch_segment like permanent_scratch_segment_list.scratch_segments aligned based (permanent_scratch_segment_ptr); dcl permanent_scratch_segment_ptr pointer; dcl idx fixed binary; do idx = 1 to permanent_scratch_segment_list.n_scratch_segments; permanent_scratch_segment_ptr = addr (permanent_scratch_segment_list.scratch_segments (idx)); if permanent_scratch_segment.lock = scratch_lock_id then do; if mod (permanent_scratch_segment.usage_count, cp_data_$scratch_release_factor) = 0 then do; call release_temp_segment_ (COMMAND_PROCESSOR_, permanent_scratch_segment.segment_ptr, ignore_code); permanent_scratch_segment.usage_count = 0; end; if stacq (permanent_scratch_segment.lock, (36)"0"b, scratch_lock_id) then ; end; /* mark it as available */ end; if temporary_scratch_segment_list_ptr ^= null () then if temporary_scratch_segment_list.n_used > 0 then do; call release_temp_segments_ (COMMAND_PROCESSOR_, temporary_scratch_segment_list.segment_ptrs (*), ignore_code); temporary_scratch_segment_list.n_used = 0; if temporary_scratch_segment_list_ptr ^= addr (local_temporary_scratch_segment_list) then do; free temporary_scratch_segment_list in (system_area); temporary_scratch_segment_list_ptr = null (); end; end; if ^p_last_call then /* setup for the next top-level command/request */ call initialize_scratch_segments ("0"b); return; end release_scratch_segments; %page; /* Free all allocated node_blocks */ free_nodes: procedure (p_last_call); dcl p_last_call bit (1) aligned parameter; last_block_ptr = addr (stack_space) -> node_block.next; if last_block_ptr ^= null () then do; do block_ptr = last_block_ptr -> node_block.next repeat (block_ptr -> node_block.next) while (block_ptr ^= null ()); free last_block_ptr -> node_block in (system_area); last_block_ptr = block_ptr; end; free last_block_ptr -> node_block in (system_area); end; if p_last_call then /* prevent attempts to free when nothing to free */ addr (stack_space) -> node_block.next = null (); else do; /* still have work to do */ block_ptr = addr (stack_space); unspec (node_block) = "0"b; node_block.next = null (); node_index = 0; addr (dummy_node) -> node.next = null (); end; end free_nodes; end complex_command_processor; %page; /* Validates a subsystem's request language definition and builds the necessary TCT tables used in make_list above */ validate_cp_subsys_info: entry (P_cp_subsys_info_ptr, P_code); call validate_request_language (P_cp_subsys_info_ptr, P_code); /* use an internal procedure to avoid wasting stack space */ return; /* Internal procedure that does the actual work */ validate_request_language: procedure (p_cp_subsys_info_ptr, p_code) options (non_quick); dcl p_cp_subsys_info_ptr pointer parameter; dcl p_code fixed binary (35) parameter; dcl 1 full_language like cp_data_$standard_language aligned based (addr (cp_subsys_info.full_tct_table)); dcl 1 token_language like cp_data_$standard_language aligned based (addr (cp_subsys_info.tokens_only_tct_table)); dcl (begin_iterations, end_iterations, begin_active_strings, end_active_strings) bit (8); dcl (processing_type, idx) fixed binary; cp_subsys_info_ptr = p_cp_subsys_info_ptr; if cp_subsys_info.version ^= CP_SUBSYS_INFO_VERSION_1 then do; p_code = error_table_$unimplemented_version; return; end; if ^cp_subsys_info.non_standard_language then do; p_code = 0; /* subsystem uses the standard language which is always OK */ return; end; if unspec (cp_subsys_info.full_tct_table) = unspec (cp_data_$standard_language) then do; cp_subsys_info.non_standard_language = "0"b; p_code = 0; /* it is the standard language after all */ return; end; begin_iterations, end_iterations, begin_active_strings, end_active_strings = ""b; do idx = lbound (full_language.character_types, 1) to hbound (full_language.character_types, 1); processing_type = full_language.character_types (idx); if (processing_type < NORMAL_CHARACTER) | ((processing_type > ACTIVE_STRING_MODIFIER) & (processing_type < BEGIN_ITERATION_1)) | (processing_type > END_ACTIVE_STRING_8) then do; p_code = error_table_$bad_subr_arg; return; /* unknown processing type specified */ end; if (processing_type = WHITESPACE) | (processing_type = QUOTE_CHARACTER) then token_language.character_types (idx) = processing_type; else if (processing_type = COMMAND_SEPARATOR_OR_WHITESPACE) then token_language.character_types (idx) = WHITESPACE; else token_language.character_types (idx) = NORMAL_CHARACTER; if (processing_type >= BEGIN_ITERATION_1) & (processing_type <= BEGIN_ITERATION_8) then substr (begin_iterations, (processing_type - BEGIN_ITERATION_1 + 1), 1) = "1"b; if (processing_type >= END_ITERATION_1) & (processing_type <= END_ITERATION_8) then substr (end_iterations, (processing_type - END_ITERATION_1 + 1), 1) = "1"b; if (processing_type >= BEGIN_ACTIVE_STRING_1) & (processing_type <= BEGIN_ACTIVE_STRING_8) then substr (begin_active_strings, (processing_type - BEGIN_ACTIVE_STRING_1 + 1), 1) = "1"b; if (processing_type >= END_ACTIVE_STRING_1) & (processing_type <= END_ACTIVE_STRING_8) then substr (end_active_strings, (processing_type - END_ACTIVE_STRING_1 + 1), 1) = "1"b; end; if begin_iterations ^= end_iterations then p_code = error_table_$unbalanced_parentheses; else if begin_active_strings ^= end_active_strings then p_code = error_table_$unbalanced_brackets; else p_code = 0; /* every begin/end iteration/active string has a match */ return; end validate_request_language; %page; /* Enable the Limited Service Subsystem */ setup_lss: entry (P_table_ptr); dcl P_table_ptr pointer parameter; cp_data_$under_lss = "1"b; cp_data_$command_table_ptr = P_table_ptr; return; /* Disable the Limited Service Subsystem */ reset_lss: entry (); cp_data_$under_lss = "0"b; return; /* Obsolete entry points */ set_line: entry (P_newsize); dcl P_newsize fixed binary (21) parameter; call com_err_ (0, "command_processor_$set_line", "There is no restriction on command line expansion. Call ignored."); return; get_line: entry (P_newsize); call com_err_ (0, "command_processor_$get_line", "There is no restriction on command line expansion."); P_newsize = MIN_AF_RETURN_LTH; return; %page; %include check_star_name; %page; %include cp_data_; %page; %include cp_character_types; %include cp_active_string_types; %include "_cp_subsys_info"; %page; %include sub_err_flags; end command_processor_;  config_deck_data_.cds 11/11/89 1103.4r w 11/11/89 0803.5 95310 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ config_deck_data_: proc (); /* Written August/September of 1984 by Allen Ball to replace old, hard-to-read version. */ /* Modified March 1985 to no longer need bce/Multics versions! Keith Loepere */ /* format: style4,initcol1,indattr,declareind8,dclind4,idind33,ifthenstmt,ifthen,^indproc,delnl,insnl */ dcl Me char (17) static options (constant) init ("config_deck_data_"); dcl PAD (1) char (32) int static options (constant) init ("pad*"); dcl addr builtin; dcl before builtin; dcl card_number fixed bin; dcl code fixed bin (35); dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dimension builtin; dcl field char (12); dcl field_counter fixed bin; dcl field_pos fixed bin; dcl i fixed bin; dcl ioa_ entry () options (variable); dcl j fixed bin; dcl last bit (1) init ("0"b); dcl length builtin; dcl ltrim builtin; dcl number_of_cards fixed bin; dcl number_of_repeats fixed bin; dcl 1 repeating_group (14) aligned, 2 field_name char (12) varying, 2 field_type bit (2); dcl repeating_group_length fixed bin; dcl rtrim builtin; dcl size builtin; dcl substr builtin; dcl test_number fixed bin (35); dcl unspec builtin; dcl valid_deck bit (1) init ("1"b); dcl valid_field bit (1) init ("0"b); /*** First check to see if there are valid types of fields. ***/ number_of_cards = dimension (config_deck_cards, 1); do card_number = 1 to number_of_cards; field_pos = 0; call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); /*** Check and see if this is a valid card name. ***/ do i = 1 to dimension (Card_names, 1); if field = Card_names (i) then valid_field = "1"b; end; if ^valid_field | last then call bad_card; valid_field = "0"b; /* Reset the signal now. */ call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); /*** Check and see if the second field is a valid subname. ***/ do i = 1 to dimension (Card_subnames, 1); if field = Card_subnames (i) then valid_field = "1"b; end; if ^valid_field then call bad_card; valid_field = "0"b; if ^last then do; do while (^last); call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); do i = 1 to dimension (Card_field_names, 1); if field = Card_field_names (i) then valid_field = "1"b; end; if ^valid_field | last then call bad_card; /* At this point there must be an even number of fields. */ valid_field = "0"b; /* Reset before we forget. */ call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); do i = 1 to dimension (Card_data_types, 1); if field = Card_data_types (i) then valid_field = "1"b; end; if ^valid_field then do; test_number = cv_dec_check_ (field, code); if code ^= 0 then call bad_card; /* Not a chance of being valid. */ end; valid_field = "0"b; end; end; end; if ^valid_deck then return; else call ioa_ ("^a: (First pass) This seems to be a valid deck.", Me); %page; /*** Now that we have a seemingly reasonable deck let's fill in the blanks. ***/ begin; dcl 1 cds_data aligned like cds_args; dcl 1 config_deck_data_ aligned, 2 num_described_cards fixed bin aligned init (number_of_cards), 2 Config_card_field_name (number_of_cards, 14) char (12) varying aligned, 2 Config_card_field_type (number_of_cards, 14) bit (2) unaligned, 2 Config_card_group_length (number_of_cards) fixed bin aligned, 2 Config_card_min_specifiable_fields (number_of_cards) fixed bin aligned, 2 Config_card_name (number_of_cards) char (4) aligned, 2 Config_card_num_described_fields (number_of_cards) fixed bin aligned, 2 Config_card_subname (number_of_cards) char (4) varying aligned; unspec (Config_card_field_name) = "0"b; unspec (Config_card_field_type) = "0"b; unspec (Config_card_group_length) = "0"b; unspec (Config_card_min_specifiable_fields) = "0"b; unspec (Config_card_name) = "0"b; unspec (Config_card_num_described_fields) = "0"b; unspec (Config_card_subname) = "0"b; unspec (repeating_group) = "0"b; do card_number = 1 to number_of_cards; field_pos = 0; call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); Config_card_name (card_number) = rtrim (field); call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); if field = "emp" then Config_card_subname (card_number) = ""; else Config_card_subname (card_number) = rtrim (field); if ^last then do; do field_counter = 1 repeat field_counter + 1 while (^last); call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); if field = "repeat" then do; field_counter = field_counter - 1; call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); if last then do; serious_error: call ioa_ ("^a: Serious error in:^/^a", Me, config_deck_cards (card_number)); return; end; number_of_repeats = (cv_dec_check_ (field, code)); if code ^= 0 then goto serious_error; do repeating_group_length = 1 repeat repeating_group_length + 1 while (^last); call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); if field = "minimum" | field = "repeat" then goto serious_error; repeating_group (repeating_group_length).field_name = field; call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); repeating_group (repeating_group_length).field_type = determine_field_type (field, code); if code ^= 0 then goto serious_error; end; Config_card_group_length (card_number) = repeating_group_length - 1; if (Config_card_group_length (card_number) * number_of_repeats) + field_counter > 14 then goto serious_error; do i = 1 to number_of_repeats; do j = 1 to Config_card_group_length (card_number); Config_card_field_name (card_number, field_counter + j + (i - 1) * Config_card_group_length (card_number)) = rtrim (repeating_group (j).field_name); Config_card_field_type (card_number, field_counter + j + (i - 1) * Config_card_group_length (card_number)) = repeating_group (j).field_type; end; end; end; else if field = "minimum" then do; field_counter = field_counter - 1; call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); Config_card_min_specifiable_fields (card_number) = (cv_dec_check_ (field, code)); if code ^= 0 then goto serious_error; end; else do; Config_card_field_name (card_number, field_counter) = rtrim (field); call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last); Config_card_field_type (card_number, field_counter) = determine_field_type (field, code); if code ^= 0 then goto serious_error; end; end; Config_card_num_described_fields (card_number) = field_counter + Config_card_group_length (card_number) * number_of_repeats - 1; end; end; /*** Seems to be completely valid. ***/ call ioa_ ("^a: (Second pass) This is a valid config deck.", Me); cds_data.sections (1).p = addr (config_deck_data_); cds_data.sections (1).len = size (config_deck_data_); cds_data.sections (1).struct_name = Me; cds_data.seg_name = Me; cds_data.num_exclude_names = 1; cds_data.exclude_array_ptr = addr (PAD); string (cds_data.switches) = "0"b; cds_data.switches.have_text = "1"b; call create_data_segment_ (addr (cds_data), code); if code ^= 0 then call com_err_ (code, Me); return; end; %page; bad_card: proc (); call ioa_ ("^a: Bad card. Check '^a' in:", Me, field); call ioa_ ("^a", config_deck_cards (card_number)); valid_deck = "0"b; return; end; %page; determine_field_type: proc (p_string, p_code) returns (bit (2) unaligned); dcl i fixed bin; dcl p_code fixed bin (35) parameter; dcl p_string char (12) parameter; do i = 1 to dimension (Card_data_types, 1); if Card_data_types (i) = p_string then do; p_code = 0; return (Card_data_bit_strings (i)); end; end; p_code = -1; return ("00"b); end; %page; get_next_field: proc (card, previous_field_pos, p_field, new_field_pos, p_last); dcl card char (210) parameter; dcl test_field char (210) init (""); dcl new_field_pos fixed bin parameter; dcl p_last bit (1) parameter; dcl left_over_card char (210); dcl p_field char (12) parameter; dcl previous_field_pos fixed bin parameter; if previous_field_pos = 0 then new_field_pos = 1; /* First field is what he wants. */ else new_field_pos = index (substr (rtrim (card), previous_field_pos), " ") + previous_field_pos; /*** Skip over whitespace. ***/ do new_field_pos = new_field_pos repeat new_field_pos + 1 while (substr (rtrim (card), new_field_pos, 1) = " "); end; left_over_card = substr (rtrim (card), new_field_pos); test_field = before (left_over_card, " "); if index (rtrim (left_over_card), " ") = 0 then p_last = "1"b; else p_last = "0"b; if length (rtrim (test_field)) > 12 then p_field = ""; else p_field = ltrim (test_field); return; end; /* format: off */ %page;%include cds_args; %page;%include config_deck_cards_; %page;%include config_deck_keywords_; end /* config_deck_data_ */;  config_deck_parse_.pl1 11/11/89 1103.4r 11/11/89 0803.5 226098 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ config_deck_parse_: proc; return; /* Routine to convert from ascii to binary forms of config cards with labels. Extracted from config_deck_edit_, February 1984 by Keith Loepere. Modified to handle negative numeric fields, December 1984, Keith Loepere. */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ dcl Bad_decimal_value_a fixed bin static options (constant) init (1); dcl Bad_decimal_value_a_text char (36) static options (constant) init ("^[""^a""^/^;Bad decimal value ""^a""^/^]"); dcl Bad_octal_value_a fixed bin static options (constant) init (2); dcl Bad_octal_value_a_text char (34) static options (constant) init ("^[""^a""^/^;Bad octal value ""^a""^/^]"); dcl Card_name_too_long fixed bin static options (constant) init (3); dcl Card_name_too_long_text char (26) static options (constant) init ("^[^;Card name too long^/^]"); dcl Config_card_name (64) char (4); /* local copy of config_deck_data_$Config_card_name so we can patch last name */ dcl Field_a_not_defined_or_too_many_supplied_for_card fixed bin static options (constant) init (4); dcl Field_a_not_defined_or_too_many_supplied_for_card_text char (66) static options (constant) init ("^[""^a""^/^;Field ""^a"" not defined or too many supplied for card^/^]"); dcl No_card_type_specified fixed bin static options (constant) init (5); dcl No_card_type_specified_text char (30) static options (constant) init ("^[^;No card type specified^/^]"); dcl No_name_follows_dot fixed bin static options (constant) init (6); dcl No_name_follows_dot_text char (27) static options (constant) init ("^[^;No name follows dot^/^]"); dcl No_value_for_a fixed bin static options (constant) init (7); dcl No_value_for_a_text char (31) static options (constant) init ("^[""^a""^/^;No value for ""^a""^/^]"); dcl Some_fields_were_skipped_in_the_card fixed bin static options (constant) init (8); dcl Some_fields_were_skipped_in_the_card_text char (44) static options (constant) init ("^[^;Some fields were skipped in the card^/^]"); dcl Some_required_fields_were_not_supplied fixed bin static options (constant) init (9); dcl Some_required_fields_were_not_supplied_text char (46) static options (constant) init ("^[^;Some required fields were not supplied^/^]"); dcl String_is_more_than_4_characters_a fixed bin static options (constant) init (10); dcl String_is_more_than_4_characters_a_text char (51) static options (constant) init ("^[""^a""^/^;String is more than 4 characters ""^a""^/^]"); dcl Too_many_values_specified_for_card fixed bin static options (constant) init (11); dcl Too_many_values_specified_for_card_text char (42) static options (constant) init ("^[^;Too many values specified for card^/^]"); dcl Value_is_not_a_valid_single_character_a fixed bin static options (constant) init (12); dcl Value_is_not_a_valid_single_character_a_text char (56) static options (constant) init ("^[""^a""^/^;Value is not a valid single character ""^a""^/^]"); dcl Whitespace char (5) static options (constant) init (" "); /* NL HT FF SP VT */ dcl addcharno builtin; dcl addr builtin; dcl ascii_config_card char (256) var parameter; /* work area to develop a card */ dcl 1 binary_card aligned like config_card; dcl card_subname char (4); /* first data field - tells apart prph cards */ dcl card_type fixed bin; dcl config_card_field fixed bin; /* loop index into data fields */ dcl config_card_type fixed bin; /* loop index into types */ dcl cu_$arg_list_ptr entry (ptr); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dimension builtin; dcl error_detected bit (1) aligned; /* error flagged by conversion routines */ dcl error_flagged (12) bit (1) aligned; /* error message n has been flagged and printed before */ dcl index builtin; dcl ioa_ entry () options (variable); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl ioa_$nnl entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl length builtin; dcl ltrim builtin; dcl mod builtin; dcl output_card_num fixed bin parameter; /* used for error messages */ dcl p_cardp ptr parameter; dcl rtrim builtin; dcl search builtin; dcl silent bit (1) aligned; /* don' print errors */ dcl substr builtin; dcl unspec builtin; dcl verify builtin; %page; binary_to_ascii: entry (p_cardp, ascii_config_card); cardp = p_cardp; silent = "1"b; error_flagged (*) = "0"b; /* Make a local copy of names. Patch the last one to be the current card to guarantee a match. */ do card_type = 1 to config_deck_data_$num_described_cards - 1; Config_card_name = config_deck_data_$Config_card_name; end; Config_card_name (config_deck_data_$num_described_cards) = config_card.word; unspec (card_subname) = unspec (config_card.data_field (1)); do config_card_type = 1 to config_deck_data_$num_described_cards while (^card_matches ()); end; call convert_to_type (config_card_type); /* arriving here, the card seems to be of a known type and in good form but the rules may have changed on us. See what we think of the ascii form. If not good, reconvert card as a user format. */ call config_card_major_parse (ascii_config_card, binary_card, 0, error_detected); if error_detected then do; /* aha, not in format we really like - bad values or number of fields or something. To keep us quiet later, lets make this a user card */ call convert_to_type (config_deck_data_$num_described_cards); ascii_config_card = "." || ascii_config_card; end; return; %page; ascii_to_binary: entry (ascii_config_card, p_cardp, output_card_num); cardp = p_cardp; unspec (config_card) = "0"b; silent = "0"b; error_flagged (*) = "0"b; do card_type = 1 to config_deck_data_$num_described_cards; Config_card_name = config_deck_data_$Config_card_name; end; /* We now have local copy of names. Later, we patch the last one to be the current card to guarantee a match. */ call config_card_major_parse (ascii_config_card, config_card, output_card_num, error_detected); return; %page; config_card_major_parse: proc (ascii_config_card, binary_card, output_card_num, error_detected); /* this proc does the major work of parsing the fields into a binary version of a config card. It decides which card this is and uses the descriptions to figure out field names. The idea here is: we grab the labeled fields and find the first place in the card that has such a label (that we haven't filled in with some other value) and place it there. The unlabeled values are then added, in order, to the missing (unfilled) spaces. Thus, an old style card gets parsed as always and a new card gets parsed correctly also without having to be able to tell the difference. */ dcl NO_TYPE bit (2) static options (constant) init ("11"b); /* means no type known for field - we use CONFIG_DECIMAL_TYPE since octal type is used for all generic numeric */ dcl ascii_config_card char (256) var parameter; dcl 1 binary_card aligned like config_card parameter; /* output binary version */ dcl binary_field_num fixed bin; /* which field in binary config_card we are considering */ dcl card_name char (4); /* as in mem, iom, etc */ dcl card_type fixed bin; /* index into card descriptions */ dcl dont_interpret bit (1) aligned; /* => pretend card is of type USER */ dcl error_detected bit (1) aligned parameter; dcl filled_field (14) bit (1); /* => we found a value for corresponding field */ dcl labeled_field_num fixed bin; /* which we are adding now */ dcl 1 labeled_fields aligned, /* list of the fields that had -labels and their values */ 2 number fixed bin, 2 field (16), /* 14 is really the max */ 3 label char (16) var, 3 value char (16) var; dcl output_card_num fixed bin parameter; /* for error messages */ dcl unlabeled_field_num fixed bin; /* which we are adding now */ dcl 1 unlabeled_fields aligned, /* list of fields that had no value */ 2 number fixed bin, 2 value (16) char (16) var; error_detected = "0"b; call separate_config_card_fields (ascii_config_card, unlabeled_fields, labeled_fields); if unlabeled_fields.number = 0 then do; call error (No_card_type_specified, No_card_type_specified_text, error_flagged (No_card_type_specified)); return; end; if substr (unlabeled_fields.value (1), 1, 1) = "." then do; dont_interpret = "1"b; /* .name becomes a user formatted name card */ unlabeled_fields.value (1) = substr (unlabeled_fields.value (1), 2); if length (unlabeled_fields.value (1)) < 1 then call error (No_name_follows_dot, No_name_follows_dot_text, error_flagged (No_name_follows_dot)); end; else dont_interpret = "0"b; if length (unlabeled_fields.value (1)) > 4 then call error (Card_name_too_long, Card_name_too_long_text, error_flagged (Card_name_too_long)); card_name = unlabeled_fields.value (1); Config_card_name (config_deck_data_$num_described_cards) = card_name; /* synthesize, as a last hope, a card type of what the user said */ if dont_interpret then card_type = config_deck_data_$num_described_cards; else do card_type = 1 to config_deck_data_$num_described_cards while (^card_matches ()); end; %page; /* now we actually convert the fields as appropriate */ binary_card.word = card_name; binary_card.data_field (*) = EMPTY_FIELD; filled_field (*) = "0"b; binary_card.pad1 = "0"b; do labeled_field_num = 1 to labeled_fields.number;/* for labeled fields */ do binary_field_num = 1 to config_deck_data_$Config_card_num_described_fields (card_type); /* pick up those that are described */ if ^filled_field (binary_field_num) then if config_deck_data_$Config_card_field_name (card_type, binary_field_num) = labeled_fields.label (labeled_field_num) then do; /* we found an unfilled field of desired name */ call cv_value (labeled_fields.value (labeled_field_num), config_deck_data_$Config_card_field_type (card_type, binary_field_num)); filled_field (binary_field_num) = "1"b; go to next_labeled; end; end; call error (Field_a_not_defined_or_too_many_supplied_for_card, Field_a_not_defined_or_too_many_supplied_for_card_text, error_flagged (Field_a_not_defined_or_too_many_supplied_for_card), labeled_fields.label (labeled_field_num)); /* ran out of fields with known labels */ next_labeled: end; /* consider now the unlabeled fields - fill in missing spaces */ binary_field_num = 1; do unlabeled_field_num = 2 to unlabeled_fields.number; do binary_field_num = binary_field_num to 14 while (filled_field (binary_field_num)); end; /* find an unfilled field */ if binary_field_num > 14 then do; call error (Too_many_values_specified_for_card, Too_many_values_specified_for_card_text, error_flagged (Too_many_values_specified_for_card)); /* ran off end */ go to validate_card; end; if binary_field_num <= config_deck_data_$Config_card_num_described_fields (card_type) then call cv_value (unlabeled_fields.value (unlabeled_field_num), config_deck_data_$Config_card_field_type (card_type, binary_field_num)); /* known type */ else call cv_value (unlabeled_fields.value (unlabeled_field_num), NO_TYPE); /* user supplied type */ filled_field (binary_field_num) = "1"b; end; %page; validate_card: /* now we know that those fields that were are described have good types and values are in order. labeled fields, though, may have skipped a value. Let's see. */ do binary_field_num = 1 to 14 while (filled_field (binary_field_num)); end; /* field number past last contiguous field in */ binary_card.n_fields = binary_field_num - 1; do binary_field_num = binary_field_num + 1 to 14 while (^filled_field (binary_field_num)); end; if binary_field_num <= 14 then /* we found a filled field after unfilled fields */ call error (Some_fields_were_skipped_in_the_card, Some_fields_were_skipped_in_the_card_text, error_flagged (Some_fields_were_skipped_in_the_card)); if binary_card.n_fields < config_deck_data_$Config_card_min_specifiable_fields (card_type) then call error (Some_required_fields_were_not_supplied, Some_required_fields_were_not_supplied_text, error_flagged (Some_required_fields_were_not_supplied)); else if config_deck_data_$Config_card_group_length (card_type) > 0 then if mod (binary_card.n_fields - config_deck_data_$Config_card_min_specifiable_fields (card_type), config_deck_data_$Config_card_group_length (card_type)) ^= 0 then /* card ends in repeating groups but last group was not filled */ call error (Some_required_fields_were_not_supplied, Some_required_fields_were_not_supplied_text, error_flagged (Some_required_fields_were_not_supplied)); /* we can now perform specific to card validations */ return; %page; card_matches: proc () returns (bit (1) aligned); /* determine if this card_type describes the given card */ dcl field fixed bin; if card_name ^= Config_card_name (card_type) then return ("0"b); if length (config_deck_data_$Config_card_subname (card_type)) = 0 then return ("1"b); /* card name alone describes */ do field = 1 to labeled_fields.number; /* see if a labeled field is of type and value for this card type's subname */ if labeled_fields.label (field) = config_deck_data_$Config_card_field_name (card_type, 1) then /* right label */ if index (labeled_fields.value (field), config_deck_data_$Config_card_subname (card_type)) = 1 then return ("1"b); /* value of labeled field is begun by desired card subname */ else return ("0"b); end; /* no labeled field matches subname - maybe the second unlabeled one does */ if unlabeled_fields.number > 1 then if index (unlabeled_fields.value (2), config_deck_data_$Config_card_subname (card_type)) = 1 then return ("1"b); /* labeled field does start as desired */ else return ("0"b); else return ("0"b); end; %page; cv_value: proc (value, type); /* we convert the char string to a config card field value, using the type suggested or guessing one if type = NO_TYPE */ dcl code fixed bin (35); dcl numeric fixed bin (35) aligned; /* area to form numeric types */ dcl string char (4) aligned; /* area to form string type */ dcl type bit (2) parameter; /* type expected */ dcl value char (16) var parameter; /* value to convert */ if type = CONFIG_OCTAL_TYPE | type = NO_TYPE then do; /* any numeric value */ if substr (value, length (value), 1) = "." then do; /* looks like decimal numeric */ numeric = cv_dec_check_ (substr (value, 1, length (value) - 1), code); if code ^= 0 then do; if type = NO_TYPE then go to is_it_octal; /* give another chance */ call error (Bad_decimal_value_a, Bad_decimal_value_a_text, error_flagged (Bad_decimal_value_a), value); call cv_value (value, NO_TYPE); /* use type it seems to be */ end; else do; unspec (binary_card.data_field (binary_field_num)) = unspec (numeric); binary_card.field_type (binary_field_num) = CONFIG_DECIMAL_TYPE; end; end; else do; /* numeric but not decimal => octal */ is_it_octal: numeric = cv_oct_check_ ((value), code); if code ^= 0 then do; if type = NO_TYPE then go to is_it_a_char; call error (Bad_octal_value_a, Bad_octal_value_a_text, error_flagged (Bad_octal_value_a), value); call cv_value (value, NO_TYPE); /* believe user format */ end; else do; unspec (binary_card.data_field (binary_field_num)) = unspec (numeric); binary_card.field_type (binary_field_num) = CONFIG_OCTAL_TYPE; end; end; end; else if type = CONFIG_SINGLE_CHAR_TYPE then do; is_it_a_char: /* maybe it's a single char field */ numeric = index ("abcdefgh", value); if length (value) ^= 1 | numeric = 0 then do; if type = NO_TYPE then go to is_it_a_string; call error (Value_is_not_a_valid_single_character_a, Value_is_not_a_valid_single_character_a_text, error_flagged (Value_is_not_a_valid_single_character_a), value); call cv_value (value, NO_TYPE); end; else do; unspec (binary_card.data_field (binary_field_num)) = unspec (numeric); binary_card.field_type (binary_field_num) = CONFIG_SINGLE_CHAR_TYPE; end; end; else if type = CONFIG_STRING_TYPE then do; is_it_a_string: /* last hope, a char string */ if length (value) > 4 then call error (String_is_more_than_4_characters_a, String_is_more_than_4_characters_a_text, error_flagged (String_is_more_than_4_characters_a), value); string = value; unspec (binary_card.data_field (binary_field_num)) = unspec (string); binary_card.field_type (binary_field_num) = CONFIG_STRING_TYPE; end; return; end; %page; error: proc options (variable); dcl arg_list_ptr ptr; dcl arg1_ptr ptr; dcl arg3_ptr ptr; dcl error_flagged bit (1) aligned based (arg3_ptr); dcl error_num fixed bin based (arg1_ptr); dcl message_buffer char (256); dcl message_len fixed bin (21); dcl message_to_print char (message_len) based (addr (message_buffer)); call cu_$arg_list_ptr (arg_list_ptr); arg1_ptr = arg_list_ptr -> arg_list.arg_ptrs (1); arg3_ptr = arg_list_ptr -> arg_list.arg_ptrs (3); if ^silent then do; call ioa_ ("^/WARNING ^d ON LINE ^d", error_num, output_card_num); call ioa_$general_rs (arg_list_ptr, 2, 3, message_buffer, message_len, "0"b, "0"b); call ioa_$nnl (message_to_print); if ^error_detected then call ioa_ ("SOURCE: ^a", ascii_config_card); end; error_flagged = "1"b; error_detected = "1"b; return; end; %page; separate_config_card_fields: proc (input_card, a_unlabeled_fields, a_labeled_fields); /* this proc separates out the fields in the card. It makes a list of all fields that had no -label, and separately those that did. -labels with no following value are tossed away. */ dcl 1 a_labeled_fields aligned like labeled_fields parameter; dcl 1 a_unlabeled_fields aligned like unlabeled_fields parameter; dcl card_pos fixed bin; /* position to end of field we are surveying */ dcl input_card char (256) var parameter; dcl label char (16) var; /* extracted from card */ dcl temp_card char (256) init (input_card); /* work area */ dcl work_card char (work_card_len) based (work_card_ptr); /* rest of card to look at */ dcl work_card_len fixed bin; dcl work_card_ptr ptr; work_card_len = length (input_card); work_card_ptr = addr (temp_card); /* start looking at whole card */ a_unlabeled_fields.number = 0; a_labeled_fields.number = 0; call pass_whitespace; do while (work_card_len > 0); /* loop, grabbing each field (or pair if labeled) and add to appropriate list */ card_pos = search (work_card, Whitespace) - 1; /* length of field */ if card_pos < 0 then card_pos = work_card_len; if substr (work_card, 1, 1) = "-" then do; /* labeled field */ label = substr (work_card, 1, card_pos); if verify (label, "-0123456789.") = 0 then go to unlabeled; work_card_len = work_card_len - card_pos; work_card_ptr = addcharno (work_card_ptr, card_pos); call pass_whitespace; if work_card_len = 0 then /* last field on card and no value follows */ call error (No_value_for_a, No_value_for_a_text, error_flagged (No_value_for_a), label); else do; /* valid labeled field */ card_pos = search (work_card, Whitespace) - 1; if card_pos < 0 then card_pos = work_card_len; if a_labeled_fields.number < dimension (a_labeled_fields.field, 1) then do; a_labeled_fields.number = a_labeled_fields.number + 1; a_labeled_fields.field (a_labeled_fields.number).label = label; a_labeled_fields.field (a_labeled_fields.number).value = substr (work_card, 1, card_pos); end; else ; /* no need for error on too many fields - we already have too many and someone will notice */ end; end; else do; /* unlabeled field */ unlabeled: if a_unlabeled_fields.number < dimension (a_unlabeled_fields.value, 1) then do; a_unlabeled_fields.number = a_unlabeled_fields.number + 1; a_unlabeled_fields.value (a_unlabeled_fields.number) = substr (work_card, 1, card_pos); end; else ; /* no error like above. By the way, we also don't need to check for strings too long for a similar reason */ end; work_card_len = work_card_len - card_pos; /* advance past fields */ work_card_ptr = addcharno (work_card_ptr, card_pos); call pass_whitespace; end; return; pass_whitespace: proc; card_pos = verify (work_card, Whitespace) - 1; if card_pos < 0 then card_pos = work_card_len; work_card_len = work_card_len - card_pos; work_card_ptr = addcharno (work_card_ptr, card_pos); card_pos = 0; return; end; end; end; %page; card_matches: proc () returns (bit (1) aligned); /* does card_type describe this card */ if Config_card_name (config_card_type) ^= config_card.word then return ("0"b); /* card name doesn't even match */ if config_deck_data_$Config_card_subname (config_card_type) = "" then return ("1"b); /* no subname match needed */ if index (card_subname, config_deck_data_$Config_card_subname (config_card_type)) = 1 then return ("1"b); /* subname matches desired */ return ("0"b); end; %page; convert_to_type: proc (config_card_type); /* we convert the current config card into ascii_config_card for the given type */ dcl config_card_type fixed bin parameter; /* index into descriptions */ ascii_config_card = rtrim (config_card.word) || " "; do config_card_field = 1 to config_deck_data_$Config_card_min_specifiable_fields (config_card_type); /* grab these many no matter what they say */ ascii_config_card = ascii_config_card || config_deck_data_$Config_card_field_name (config_card_type, config_card_field) || " "; call add_value; end; do config_card_field = config_deck_data_$Config_card_min_specifiable_fields (config_card_type) + 1 to 14 while (config_card.data_field (config_card_field) ^= EMPTY_FIELD); /* convert the rest of the fields until we run out */ if config_card_field <= config_deck_data_$Config_card_num_described_fields (config_card_type) then /* we know the name for this field */ ascii_config_card = ascii_config_card || config_deck_data_$Config_card_field_name (config_card_type, config_card_field) || " "; /* unknown field name */ call add_value; end; %page; add_value: proc; /* convert the value to ascii and add to ascii_config_card */ dcl numeric fixed bin (35) aligned; /* overlay for numeric types */ dcl string char (4) aligned; /* overlay for string type */ dcl value char (16) var; /* converted result */ if config_card.field_type (config_card_field) = CONFIG_OCTAL_TYPE then do; unspec (numeric) = unspec (config_card.data_field (config_card_field)); call ioa_$rsnnl ("^o", value, (0), numeric); end; else if config_card.field_type (config_card_field) = CONFIG_DECIMAL_TYPE then do; unspec (numeric) = unspec (config_card.data_field (config_card_field)); call ioa_$rsnnl ("^d.", value, (0), numeric); end; else if config_card.field_type (config_card_field) = CONFIG_STRING_TYPE then do; unspec (string) = unspec (config_card.data_field (config_card_field)); value = ltrim (rtrim (string)); end; else /* CONFIG_SINGLE_CHAR_TYPE */ do; unspec (numeric) = unspec (config_card.data_field (config_card_field)); if numeric < 1 | numeric > 8 then value = "*"; else value = substr ("abcdefgh", numeric, 1); end; ascii_config_card = ascii_config_card || value || " "; end; end; %page; %include arg_list; %page; %include config_deck; %page; %include config_deck_data_; end;  cp_data_.cds 11/11/89 1103.4r 11/11/89 0803.7 44109 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* Static and constant data used by the Multics command processor */ /* Created: January 1981 by Ellie Donner */ /* Modified: June 1982 by G. Palter to add standard command language definition */ /* Modified: July 1984 by G. Palter to add the permanent scratch segment list */ /* Modified: March 1985 by Keith Loepere so that it can reside within bound_multics_bce_. */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ %page; cp_data_: procedure () options (variable); dcl 1 cp_constants aligned, /* constant data: see cp_data_.incl.pl1 for details */ 2 standard_language (0:511) fixed binary (9) unaligned unsigned; dcl 1 cp_static aligned, /* static data: see cp_data_.incl.pl1 for details */ 2 command_table_ptr pointer, 2 under_lss bit (1) aligned, 2 scratch_lock_id fixed binary (35), 2 scratch_release_factor fixed binary, 2 permanent_scratch_segment_list, 3 n_scratch_segments fixed binary, 3 scratch_segments (4), 4 segment_ptr pointer, 4 lock bit (36) aligned, 4 usage_count fixed binary; dcl 1 cds_arguments aligned like cds_args; dcl code fixed binary (35); dcl CP_DATA_ character (8) static options (constant) initial ("cp_data_"); /* format: off */ dcl (SPACE initial (" "), HT initial (" "), /* horizontal tab */ VT initial (" "), /* veritcal tab */ FF initial (" "), /* form feed */ NL initial (" ")) /* new line */ character (1) static options (constant); /* format: on */ dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (pointer, fixed binary (35)); dcl (addr, currentsize, null, rank, string) builtin; %page; /* Define the standard command language */ cp_constants.standard_language (*) = NORMAL_CHARACTER; /* start out by declaring all characters to be normal */ cp_constants.standard_language (rank (SPACE)) = WHITESPACE; cp_constants.standard_language (rank (HT)) = WHITESPACE; cp_constants.standard_language (rank (VT)) = WHITESPACE; cp_constants.standard_language (rank (FF)) = WHITESPACE; cp_constants.standard_language (rank (";")) = COMMAND_SEPARATOR; cp_constants.standard_language (rank (NL)) = COMMAND_SEPARATOR_OR_WHITESPACE; cp_constants.standard_language (rank ("""")) = QUOTE_CHARACTER; cp_constants.standard_language (rank ("(")) = BEGIN_ITERATION_1; cp_constants.standard_language (rank (")")) = END_ITERATION_1; cp_constants.standard_language (rank ("[")) = BEGIN_ACTIVE_STRING_1; cp_constants.standard_language (rank ("]")) = END_ACTIVE_STRING_1; cp_constants.standard_language (rank ("|")) = ACTIVE_STRING_MODIFIER; /* Setup constants and static data related to scratch segment management */ cp_static.scratch_release_factor = 1000; /* release "permanement" scratch segments every 1000 uses */ cp_static.scratch_lock_id = 0; cp_static.permanent_scratch_segment_list.n_scratch_segments = 4; cp_static.permanent_scratch_segment_list.scratch_segments (*).segment_ptr = null (); cp_static.permanent_scratch_segment_list.scratch_segments (*).lock = ""b; cp_static.permanent_scratch_segment_list.scratch_segments (*).usage_count = 0; /* Supply initial values for the remaining static data */ cp_static.under_lss = "0"b; /* no restriction on commands that may be executed */ cp_static.command_table_ptr = null (); /* Fill in CDS description and create the data segment */ cds_arguments.sections (1).p = addr (cp_constants); cds_arguments.sections (1).len = currentsize (cp_constants); cds_arguments.sections (1).struct_name = "cp_constants"; cds_arguments.sections (2).p = addr (cp_static); cds_arguments.sections (2).len = currentsize (cp_static); cds_arguments.sections (2).struct_name = "cp_static"; cds_arguments.seg_name = CP_DATA_; cds_arguments.num_exclude_names = 0; cds_arguments.exclude_array_ptr = null (); string (cds_arguments.switches) = "0"b; cds_arguments.switches.have_text = "1"b; cds_arguments.switches.have_static = "1"b; cds_arguments.switches.separate_static = "1"b; call create_data_segment_ (addr (cds_arguments), code); if code ^= 0 then call com_err_ (CP_DATA_, code); return; %page; %include cp_character_types; %page; %include cds_args; end;  display_disk_label_.pl1 11/11/89 1103.4rew 11/11/89 0803.7 51831 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ display_disk_label_: proc (p_labelp); /* format: style4,initcol1,indattr,declareind8,dclind4,idind35,ifthenstmt,ifthen,^indproc,delnl,insnl */ /**** Written August of 1984 by Allen Ball to display a valid disk label in readable format for display_disk_label and bce_display_disk_label. ****/ /****^ HISTORY COMMENTS: 1) change(86-01-16,Fawcett), approve(86-04-11,MCR7383), audit(86-05-14,Farley), install(86-07-17,MR12.0-1097): Add support for subvolumes, and 512_WORD_IO, 3380 and 3390. 2) change(88-04-12,GWMay), approve(88-04-12,MCR7867), audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061): Changed to display in octal and decminal. Changed to interpret access class. 3) change(88-05-27,GWMay), approve(88-05-27,MCR7883), audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061): Changed to display the status of volume dumper bit maps. END HISTORY COMMENTS */ labelp = p_labelp; call ioa_ ("PVID^-^-^oo", label.pvid); call ioa_ ("Serial^-^-^a", label.mfg_serial); call ioa_ ("Logical Volume^-^a", label.lv_name); call ioa_ ("LVID^-^-^oo^/", label.lvid); if label.number_of_sv ^= 0 then call ioa_ ("Subvolume ^a ^d of ^d", label.sub_vol_name, label.this_sv + 1, label.number_of_sv); call ioa_ ("Registered^-^a", cv_time (label.time_registered)); call ioa_ ("Dismounted^-^a", cv_time (label.time_unmounted)); call ioa_ ("Map Updated^-^a", cv_time (label.time_map_updated)); call ioa_ ("Salvaged^-^-^a", cv_time (label.time_salvaged)); call ioa_ ("Bootload^-^-^a", cv_time (label.time_of_boot)); call ioa_ ("Reloaded^-^-^a", cv_time (label.time_last_reloaded)); call ioa_ (" Dumped Incremental^-^[^a^;Never Been Dumped^s^] Consolidated^-^[^a^;Never Been Dumped^s^] Complete^-^[^a^;Never Been Dumped^s^]", label.time_last_dmp (Incremental) ^= 0, cv_time (label.time_last_dmp (Incremental)), label.time_last_dmp (Consolidated) ^= 0, cv_time (label.time_last_dmp (Consolidated)), label.time_last_dmp (Complete) ^= 0, cv_time (label.time_last_dmp (Complete))); call ioa_ (" The volume dumper bit maps located in the label are ^[NOT ^]consistent.", label.inconsistent_dbm); call ioa_ ("^/Inconsistencies^-^-^d", label.vol_trouble_count); if sys_info$service_system then do; call convert_access_class_$to_string_short (label.min_access_class, access_string, code); call ioa_ ("^/Minimum AIM^-^-^a (^[^[system_low^s^;^s^]^;^s^a^])", display_access_class_ (label.min_access_class), access_string = "", code = 0, access_string); call convert_access_class_$to_string_short (label.max_access_class, access_string, code); call ioa_ ("Maximum AIM^-^-^a (^[^[system_low^s^;^s^]^;^s^a^])", display_access_class_ (label.max_access_class), access_string = "", code = 0, access_string); end; else do; call ioa_ ("^/Minimum AIM^-^-^a", display_access_class_ (label.min_access_class)); call ioa_ ("Maximum AIM^-^-^a", display_access_class_ (label.max_access_class)); end; if label.root.here then do; call ioa_ ("^/Volume contains root (>) at vtocx ^d (^oo)", label.root_vtocx, label.root_vtocx); call ioa_ (" disk_table_ at vtocx ^d (^oo) (uid ^wo)", label.root.disk_table_vtocx, label.root.disk_table_vtocx, label.root.disk_table_uid); end; if label.nparts > 0 then do; call ioa_ ("^/Volume Map from Label"); call ioa_ (" First Record Size"); do parts_index = 1 to label.nparts; call ioa_ ("^8d (^oo)^22t^8d (^oo)^51t^4a Partition", label.parts (parts_index).frec, label.parts (parts_index).frec, label.parts (parts_index).nrec, label.parts (parts_index).nrec, label.parts (parts_index).part); end; end; return; %page; cv_time: proc (date_time) returns (char (*)); dcl date_time fixed bin (71); dcl date_time_string char (24); dcl length builtin; dcl substr builtin; if date_time = 0 then return (""); else do; date_time_string = date_time_$format ("date_time", date_time, "", ""); if substr (date_time_string, 1, length (Null_date_time)) = Null_date_time then return (""); else return (date_time_string); end; end; %page; dcl access_string char (32); dcl code fixed bin (35); dcl Consolidated fixed bin static options (constant) init (2); dcl Complete fixed bin static options (constant) init (3); dcl Incremental fixed bin static options (constant) init (1); dcl Null_date_time char (16) static options (constant) init ("01/01/01 0000.0"); dcl sys_info$service_system bit (1) aligned ext static; dcl convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl display_access_class_ entry (bit (72) aligned) returns (char (32) aligned); dcl ioa_ entry () options (variable); dcl p_labelp pointer parameter; dcl parts_index fixed bin; /* format: ^insnl */ %page; %include aim_template; %page; %include fs_vol_label; end display_disk_label_;  equal.pl1 11/11/89 1103.4r 11/11/89 0803.7 63333 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ equal: proc; /* Comparison and boolean active functions. The following functions compare arbitrary strings by collating sequence: equal A B "true" if A = B, "false" otherwise. less A B "true" if A < B, "false" otherwise. greater A B "true" if A > B, "false" otherwise. The following compare numbers; an error is reported if both arguments are not character string representations of valid PL/I real constants. Comparisons are done using float dec (59) arithmetic. nequal A B "true" if A = B, "false" otherwise. nless A B "true" if A < B, "false" otherwise. ngreater A B "true" if A > B, "false" otherwise. The following perform logical operations on arguments having the values true and false: not A "true" if A = "false", "false" if A = "true". and A1 A2 ... An "true" if all Ai are "true", "false" otherwise. or A1 A2 ... An "true" if any Ai is "true", "false" otherwise. All of these active functions print their result when called as commands. Initial version 3/4/74 by Barry L. Wolman */ /* Time comparison functions added 11/28/78 by Jim Homan */ /* Rewritten 01/18/80 by S. Herbst */ /* Bug fixed in time comparisons 04/14/80 S. Herbst */ /* Changed and, or to accept 0 args or 1 arg 09/16/82 S. Herbst */ /* Added -date to date_time comparison commands 10/26/82 S. Herbst */ /* Fixed dteq and friends to not reject negative times 11/23/82 S. Herbst */ /* Added the date_time_valid function 11/23/82 J. A. Bush */ /* removed a portion, creating date_time_equal.pl1 02/07/84 J A Falksen */ dcl arg1 char (arg_len (1)) based (arg_ptr (1)); dcl arg2 char (arg_len (2)) based (arg_ptr (2)); dcl return_arg char (return_len) varying based (return_ptr); dcl (bad_arg, usage) char (168); dcl myname char (32); dcl arg_ptr (2) ptr; dcl return_ptr ptr; dcl (af_sw, bool_value) bit (1); dcl (number1, number2) float dec (59); dcl arg_len (2) fixed bin; dcl (arg_count, i, return_len) fixed bin; dcl code fixed bin (35); dcl error_table_$not_act_fnc fixed bin (35) ext; dcl get_arg entry (fixed bin, ptr, fixed bin, fixed bin (35))automatic; dcl complain entry variable options (variable); dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl ioa_ entry options (variable); dcl convert builtin; dcl conversion condition; /* */ myname = "equal"; usage = "string1 string2"; call get_args; if arg1 = arg2 then go to TRUE; else go to FALSE; TRUE: if af_sw then return_arg = "true"; else call ioa_ ("true"); return; FALSE: if af_sw then return_arg = "false"; else call ioa_ ("false"); return; USAGE: if af_sw then call active_fnc_err_$suppress_name (0, myname, "Usage: ^a ^a", myname, usage); else call com_err_$suppress_name (0, myname, "Usage: ^a ^a", myname, usage); RETURN: return; less: entry; myname = "less"; usage = "string1 string2"; call get_args; if arg1 < arg2 then go to TRUE; else go to FALSE; greater: entry; myname = "greater"; usage = "string1 string2"; call get_args; if arg1 > arg2 then go to TRUE; else go to FALSE; nequal: entry; myname = "nequal"; usage = "num1 num2"; call get_args; call convert_numbers; if number1 = number2 then go to TRUE; else go to FALSE; nless: entry; myname = "nless"; usage = "num1 num2"; call get_args; call convert_numbers; if number1 < number2 then go to TRUE; else go to FALSE; ngreater: entry; myname = "ngreater"; usage = "num1 num2"; call get_args; call convert_numbers; if number1 > number2 then go to TRUE; else go to FALSE; and: entry; myname = "and"; usage = "true_false_args"; call get_count; if arg_count = 0 then bool_value = "1"b; /* and-identity */ else bool_value = get_boolean (1); do i = 2 to arg_count; bool_value = bool_value & get_boolean (i); end; if bool_value then go to TRUE; else go to FALSE; or: entry; myname = "or"; usage = "true_false_args"; call get_count; if arg_count = 0 then bool_value = "0"b; /* or-identity */ else bool_value = get_boolean (1); do i = 2 to arg_count; bool_value = bool_value | get_boolean (i); end; if bool_value then go to TRUE; else go to FALSE; not: entry; myname = "not"; usage = "true_or_false"; call get_count; if arg_count ^= 1 then go to USAGE; if get_boolean (1) then go to FALSE; else go to TRUE; /* */ get_count: proc; /* This internal procedure tests for af invocation and gets argument count. */ call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = error_table_$not_act_fnc then do; af_sw = "0"b; complain = com_err_; get_arg = cu_$arg_ptr; end; else do; af_sw = "1"b; complain = active_fnc_err_; get_arg = cu_$af_arg_ptr; end; end get_count; get_args: proc; /* This internal procedure gets two arguments. */ dcl j fixed bin; call get_count; j = 0; if arg_count ^= 2 then go to USAGE; call get_arg (1, arg_ptr (1), arg_len (1), code); call get_arg (2, arg_ptr (2), arg_len (2), code); end get_args; get_boolean: proc (arg_index) returns (bit (1) aligned); /* This internal procedure gets a single true or false argument. */ dcl arg_index fixed bin; call get_arg (arg_index, arg_ptr (1), arg_len (1), code); if arg1 = "true" then return ("1"b); else if arg1 = "false" then return ("0"b); else do; call complain (0, myname, "Must be true or false, not ""^a""", arg1); go to RETURN; end; end get_boolean; /* */ convert_numbers: proc; /* This internal procedure converts both arguments to real numbers. */ on conversion begin; bad_arg = arg1; go to BAD; end; number1 = convert (number1, arg1); revert conversion; on conversion begin; bad_arg = arg2; go to BAD; end; number2 = convert (number2, arg2); revert conversion; return; BAD: call complain (0, myname, "Invalid number ^a", bad_arg); go to RETURN; end convert_numbers; end equal;  find_command_.pl1 11/11/89 1103.4rew 11/11/89 0803.7 156420 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): Modified to call object_lib_$initiate to initiate segments and object MSFs when executing commands specified by pathname. END HISTORY COMMENTS */ /* This subroutine interprets a character string as the name of an entrypoint and returns a pointer to that entry. It is intended to be called by command processors to find commands and active functions. An associative memory of recently used commands is maintained in order to avoid using the linker when possible */ /* Initial coding: December 1969 by R. C. Daley */ /* Rewritten: August 1978 by G. Palter to eliminate past changes made for fast command loop */ /* Modified: 8 May 1980 by G. Palter to fix metering to avoid calling hcs_$make_ptr if metering is not enabled when first invoked */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ find_command_: procedure (a_input_name_ptr, a_input_name_lth, a_entrypoint_ptr, a_code); /* Parameters */ dcl a_input_name_ptr pointer; /* -> input string to interpret */ dcl a_input_name_lth fixed binary (21); /* length of same */ dcl a_entrypoint_ptr pointer; /* -> entrypoint found (Output) */ dcl a_code fixed binary (35); dcl a_input_name character (a_input_name_lth) based (a_input_name_ptr); /* Remaining declarations */ dcl input_name character (input_name_lth) based (input_name_ptr); dcl input_name_ptr pointer; dcl input_name_lth fixed binary (21); dcl ( pathname_sw, /* ON if pathname used */ entrypoint_sw, /* ON if entrypoint given */ print_sw ) bit (1) aligned; /* ON if should prin errors */ dcl full_name character (256) varying; /* complete name given */ dcl 1 full_name_value aligned based (addr (full_name)), 2 lth fixed binary (21), 2 str character (0 refer (full_name_value.lth)) unaligned; dcl directory_name character (168); /* directory supplied (if any) */ dcl segment_name character (32); /* segment name given */ dcl entrypoint_name character (32); /* entrypoint suplied or "segment_name" */ dcl code fixed binary (35); dcl segment_ptr pointer; dcl (am_idx, idx) fixed binary; /* The associative memory */ dcl 1 memory aligned internal static, 2 e (0:15), /* 16 entries */ 3 name character (32) initial ((16) ("")), 3 entrypoint_ptr pointer initial ((16) null ()), /* -> entry for this name */ 3 usage fixed binary initial ((16) 0); /* least-recently used counter */ dcl HIT fixed binary static options (constant) initial (16); /* usage counter of just used entry */ dcl SPACES character (2) static options (constant) initial (" "); /* SP HT */ dcl BREAKS character (3) static options (constant) initial ("<>$"); dcl NAME character (18) static options (constant) initial ("command_processor_"); dcl BlankCommand character (19) static options (constant) initial ("Blank command name."); dcl SegNotFound character (21) static options (constant) initial ("Segment ^a not found."); dcl NoEntryPoint character (39) static options (constant) initial ("Entry point ^a not found in segment ^a."); dcl ( error_table_$bad_command_name, error_table_$badpath, error_table_$dirseg, error_table_$entlong, error_table_$namedup, error_table_$no_ext_sym, error_table_$noentry, error_table_$seg_not_found ) fixed binary (35) external; dcl ( com_err_, com_err_$suppress_name ) entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl find_condition_info_ entry (pointer, pointer, fixed binary (35)); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl get_group_id_$tag_star entry () returns (character (32) aligned); dcl hcs_$initiate entry (character (*), character (*), character (*), fixed binary (1), fixed binary (2), pointer, fixed binary (35)); dcl hcs_$make_ptr entry (pointer, character (*), character (*), pointer, fixed binary (35)); dcl hcs_$terminate_noname entry (pointer, fixed binary (35)); dcl object_lib_$init_no_clear entry (char(*), char(*), char(*), bit(1), ptr, fixed bin(24), bit(1), fixed bin(35)); dcl any_other condition; dcl (addr, hbound, lbound, length, null, reverse, rtrim, search, substr) builtin; %page; /* find_command_: procedure (a_input_name_ptr, a_input_name_lth, a_entrypoint_ptr, a_code); */ print_sw = "1"b; go to COMMON; /* This entry is identical to find_command_, but does not print error messages */ fc_no_message: entry (a_input_name_ptr, a_input_name_lth, a_entrypoint_ptr, a_code); print_sw = "0"b; COMMON: a_code = 0; /* initialize it sometime */ input_name_ptr = a_input_name_ptr; /* get input arguments */ input_name_lth = length (rtrim (a_input_name, SPACES)); /* strip trailing whitespace right away */ if input_name_lth = 0 then do; /* blank command name */ if print_sw then call com_err_ (0, NAME, BlankCommand); a_code = error_table_$seg_not_found; /* for lack of something better */ return; end; /* Parse input name into segment name, entrypoint (optional), and pathname (optional) */ if search (input_name, BREAKS) = 0 then do; /* simple case, a segment name only */ if input_name_lth > length (segment_name) then call abort (error_table_$entlong, input_name); pathname_sw, entrypoint_sw = "0"b; segment_name = input_name; /* make compiler generate better code */ entrypoint_name = input_name; full_name = input_name; /* for error messages later on */ end; else call parse_complex_name (); /* out of main path for efficiency */ %page; call meter_usage (segment_name); /* meter its usage whether or not it works */ if ^pathname_sw then /* No pathname was supplied: This is the simple case and is handled completely by the internal procedure search_entry */ call search_entry (); else do; /* A pathname was supplied: It may be necessary to terminate some other segment if the reference name "segment_name" is already in use. In addition, it may be necessary to clear the associative memory to reflect this termination. */ call object_lib_$init_no_clear (directory_name, segment_name, segment_name, ""b, segment_ptr, 0, (""b), code); if code ^= 0 then if code ^= error_table_$namedup then call abort (code, full_name_value.str); else if search_am (segment_name, am_idx) then call set_am (am_idx, "", null (), 0); /* clear this entry */ call search_entry (); /* now try to find the entrypoint */ end; /* Here only if the entrypoint was found */ a_code = 0; /* a_entrypoint_ptr already set */ RETURN: return; %page; /* Clear the associative memory: It should be called after changes are made to the address space */ clear: entry (); do idx = lbound (memory.e, 1) to hbound (memory.e, 1); call set_am (idx, "", null (), 0); end; return; %page; /* This internal procedure parses a command name containing pathnames and entrypoints */ parse_complex_name: procedure (); dcl (entry_idx, segment_lth, entrypoint_idx, entrypoint_lth) fixed binary (21); dcl pathname character (entry_idx + segment_lth - 1) unaligned based (input_name_ptr); entry_idx = search (reverse (input_name), "<>"); /* find end of pathname */ if entry_idx = 0 then do; /* no pathname */ entry_idx = 1; pathname_sw = "0"b; entrypoint_sw = "1"b; /* tentatively must have an entrypoint */ end; else do; /* pathname given */ if entry_idx = 1 then if input_name = ">" then /* trap the root right here */ call abort (error_table_$dirseg, input_name); else call abort (error_table_$badpath, input_name); pathname_sw = "1"b; entry_idx = input_name_lth + 2 - entry_idx; /* index of first char after > */ entrypoint_sw = (search (substr (input_name, entry_idx), "$") ^= 0); end; /* Check validity of syntax of entrypoint and pathname now that it is known what was supplied */ if entrypoint_sw then do; segment_lth = search (substr (input_name, entry_idx), "$") - 1; entrypoint_idx = entry_idx + segment_lth + 1; entrypoint_lth = input_name_lth - entrypoint_idx + 1; if (segment_lth = 0) | (entrypoint_lth = 0) then call abort (error_table_$bad_command_name, input_name); if entrypoint_lth > length (entrypoint_name) then call abort (error_table_$entlong, substr (input_name, (entrypoint_idx - 1))); end; else segment_lth = input_name_lth - entry_idx + 1; if pathname_sw then do; call expand_pathname_ (pathname, directory_name, segment_name, code); /* expand, but exclude entrypoint */ if code ^= 0 then call abort (code, input_name); end; else do; if segment_lth > length (segment_name) then call abort (error_table_$entlong, substr (input_name, 1, segment_lth)); segment_name = substr (input_name, entry_idx, segment_lth); end; /* Fill in the entrypoint name, defaulting to the segment name if necessary */ if entrypoint_sw then do; entrypoint_name = substr (input_name, entrypoint_idx); if search (entrypoint_name, "$") ^= 0 then call abort (error_table_$bad_command_name, input_name); end; else entrypoint_name = segment_name; if entrypoint_name = segment_name then entrypoint_sw = "0"b; /* insure off in case he said foo$foo */ /* Set full name to include the pathname only if pathname explicitly given */ if pathname_sw then if directory_name = ">" then full_name = ">"; else do; full_name = rtrim (directory_name); /* separate for better code */ full_name = full_name || ">"; end; else full_name = ""; if entrypoint_sw then do; /* separate statements for better code */ full_name = full_name || rtrim (segment_name); full_name = full_name || "$"; full_name = full_name || entrypoint_name; end; else full_name = full_name || segment_name; return; end parse_complex_name; %page; /* This internal procedure does the main work of find_command_. It attempts to find the specified entrypoint, first searching the associative memory, if possible */ search_entry: procedure (); dcl am_idx fixed binary; /* Try the assocate memory first */ if ^entrypoint_sw then if search_am (segment_name, am_idx) then do; a_entrypoint_ptr = memory.e (am_idx).entrypoint_ptr; return; end; /* Must call the linker */ call hcs_$make_ptr (null (), segment_name, entrypoint_name, a_entrypoint_ptr, code); if code ^= 0 then call abort (code, full_name_value.str); /* Place entry into associative memory if no entrypoint was given */ if ^entrypoint_sw then call set_am (am_idx, segment_name, a_entrypoint_ptr, HIT); return; end search_entry; %page; /* These two internal procedures manage the associative memory */ /* This internal procedure searches the associative memory, returning "1"b if the given name is in the memory. In all cases it returns an index, which when the entry is not found, is the index of the least-recently used entry */ search_am: procedure (name, am_idx) returns (bit (1) aligned); dcl name character (32); dcl am_idx fixed binary; dcl (oldest, idx, jdx) fixed binary; oldest = hbound (memory.e, 1) + 1; do idx = lbound (memory.e, 1) to hbound (memory.e, 1); if memory.e (idx).name = name then do; am_idx = idx; memory.e (idx).usage = HIT; do jdx = idx + 1 to hbound (memory.e, 1); memory.e (jdx).usage = memory.e (jdx).usage - 1; end; /* decrement usage of rest */ return ("1"b); /* success */ end; memory.e (idx).usage = memory.e (idx).usage - 1; /* miss */ if memory.e (idx).usage < oldest then do; oldest = memory.e (idx).usage; am_idx = idx; end; end; return ("0"b); /* not found */ end search_am; /* This internal procedure sets an entry in the associative memory */ set_am: procedure (am_idx, name, entrypoint_ptr, usage); dcl (am_idx, usage) fixed binary; dcl name character (32); dcl entrypoint_ptr pointer; memory.e (am_idx).name = name; memory.e (am_idx).entrypoint_ptr = entrypoint_ptr; memory.e (am_idx).usage = usage; return; end set_am; %page; /* This internal procedure aborts find_command_, printing an error message if print_sw is ON */ abort: procedure (code, text); dcl code fixed binary (35); dcl text character (*); a_entrypoint_ptr = null (); a_code = code; if print_sw then if (code = error_table_$seg_not_found) | (code = error_table_$noentry) then call com_err_$suppress_name (0, NAME, SegNotFound, segment_name); else if code = error_table_$no_ext_sym then call com_err_$suppress_name (0, NAME, NoEntryPoint, entrypoint_name, segment_name); else call com_err_ (code, NAME, "^a", text); go to RETURN; end abort; %page; /* This internal procedure enters the current segment name into the command usage metering information */ meter_usage: procedure (command_name); dcl command_name character (32); dcl first_call bit (1) aligned internal static initial ("1"b); dcl metering bit (1) aligned internal static initial ("1"b); /* ON => metering still in operation */ dcl user_name character (32) internal static; dcl (usage_list_ptr, usage_totals_ptr) pointer internal static; dcl user_list_ptr pointer; dcl UsageList character (19) static options (constant) initial ("command_usage_list_"); dcl UsageTotals character (21) static options (constant) initial ("command_usage_totals_"); dcl code fixed binary (35); dcl idx fixed binary; dcl found bit (1) aligned; %include command_usage; if ^metering then return; /* metering was turned off */ if first_call then do; /* must initialize */ call hcs_$make_ptr (null (), UsageList, "", usage_list_ptr, code); if code ^= 0 then do; disable_metering: metering = "0"b; /* shut off metering on an error */ return; end; call hcs_$make_ptr (null (), UsageTotals, "", usage_totals_ptr, code); if code ^= 0 then go to disable_metering; user_name = get_group_id_$tag_star (); /* if metering by user name */ first_call = "0"b; /* initialized */ end; /* Search command/alias list to see if this name is being metered */ on any_other call check_for_error (); /* disable metering on faults */ found = "0"b; do idx = 1 to usage_list.n_commands while (^found); if usage_list.commands (idx).name = command_name then found = "1"b; end; if found then idx = idx - 1; /* will be one too large from loop */ else return; /* not being metered */ /* This name is being metered */ if ^usage_list.commands (idx).primary then idx = usage_list.commands (idx).slot; /* this is an alias */ usage_totals (usage_list.commands (idx).slot) = usage_totals (usage_list.commands (idx).slot) + 1; /* count it */ if ^usage_list.commands (idx).count_users then return; /* recording finished */ call hcs_$initiate (usage_list.directory, (usage_list.commands (idx).name || ".usage"), "", 0b, 01b, user_list_ptr, (0)); if user_list_ptr = null () then return; found = "0"b; do idx = 1 to user_list_size while (^found); if user_list (idx).name = user_name then found = "1"b; else if user_list (idx).count = 0 then do; /* not in list, add in new slot */ user_list (idx).name = user_name; found = "1"b; end; end; if found then user_list (idx - 1).count = user_list (idx - 1).count + 1; call hcs_$terminate_noname (user_list_ptr, (0)); return; /* This internal procedure of meter_usage is called on an error to decide if metering should be disabled */ check_for_error: procedure (); dcl code fixed binary (35); dcl 1 info aligned, %include cond_info; info.version = 1; call find_condition_info_ (null (), addr (info), code); if code ^= 0 then go to disable_metering; /* can't get info, bad error */ if (info.condition_name = "alrm") | (info.condition_name = "cput") | (info.condition_name = "finish") | (info.condition_name = "mme2") | (info.condition_name = "program_interrupt") | (info.condition_name = "quit") | (info.condition_name = "trm_") | (info.condition_name = "sus_") then call continue_to_signal_ ((0)); /* these conditions are allright */ go to disable_metering; /* fault: turn of metering */ end check_for_error; end meter_usage; end find_command_;  move_r_or_t_.alm 11/11/89 1103.4r 11/11/89 0803.8 15993 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " This procedure is called by numeric_to_ascii_ to move a float dec(59) " value with rounding or truncation to specified number of digits " " Usage: " dcl move_r_or_t_ entry(float dec(59),float dec(59),fixed bin) " call move_r_or_t_(target,source,precision) " " precision = 0 straight move " < 0 truncate " > 0 round " " This routine runs in the stack frame of its caller. " " Initial Version: 29 January 1974 by Barry L. Wolman " segdef move_r_or_t_ " equ target,2 equ source,4 equ precision,6 " move_r_or_t_: epp1 ap|target,* get target ptr epp2 ap|source,* get source ptr eax0 0 assume rounding lda ap|precision,* get desired precision tze dont_care easy if zero tpl 3,ic skip if rounding eax0 1 set truncate neg 0 and get abs value cmpa 59,dl easy if greater than 59 wanted tpl dont_care ada 2,dl get length for descriptor xec mvn,0 move with round|truncate desc9fl 2|0,61 source desc9fl 1|0,al target mvn (pr,rl),(pr) move back to full length desc9fl 1|0,al desc9fl 1|0,61 short_return " dont_care: mvn (pr),(pr) desc9fl 2|0,61 desc9fl 1|0,61 short_return " mvn: mvn (pr),(pr,rl),round mvn (pr),(pr,rl) end  numeric_to_ascii_.pl1 11/11/89 1103.4r 11/11/89 0803.8 30528 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* General number formatter. This routine returns the ASCII string representation of its input argument, which is float dec(59). The returned varying string has no blanks in it. The returned string is in I-format, F-format, or E-format depending on value of input. The precision argument controls rounding or truncating of input value 0 no action, as many digits as are necessary will appear in final string < 0 truncate to specified number of digits > 0 round to specified number of digits Initial Version: 28 January 1974 by Barry L. Wolman */ numeric_to_ascii_: proc(val,precision,ans); dcl val float dec(59), precision fixed bin, ans char(72) varying; dcl value float dec(59); dcl 1 value_overlay aligned based(addr(value)), 2 sign char(1) unaligned, 2 digits char(59) unaligned, 2 skip bit(1) unaligned, 2 exponent fixed bin(7) unaligned; dcl fixed_dec fixed dec(3); dcl 1 fixed_overlay aligned based(addr(fixed_dec)), 2 sign char(1) unaligned, 2 dig char(3) unaligned; dcl (p,exp,n,nzeros,ndigits) fixed bin; dcl move_r_or_t_ entry(float dec(59),float dec(59),fixed bin); dcl (abs,substr,convert) builtin; p = precision; if p ^= 0 then do; call move_r_or_t_(value,val,p); p = abs(p); end; else do; value = val; p = 59; end; if value = 0 then ans = "0"; else do; if value > 0 then ans = ""; else do; value = abs(value); ans = "-"; end; n = verify(digits,"0"); nzeros = verify(reverse(digits),"0"); ndigits = 61 - n - nzeros; exp = exponent + nzeros - 1; if exp >= 0 then if exp + ndigits > p then call e_format; else do; ans = ans || substr(digits,n,ndigits); if exp > 0 then ans = ans || substr((64)"0",1,exp); end; else do; nzeros = ndigits + exp; if nzeros <= 0 then if ndigits - nzeros > p then call e_format; else do; ans = ans || "0."; if nzeros ^= 0 then ans = ans || substr((64)"0",1,abs(nzeros)); ans = ans || substr(digits,n,ndigits); end; else do; ans = ans || substr(digits,n,nzeros); ans = ans || "."; ans = ans || substr(digits,nzeros+n,ndigits-nzeros); end; end; end; e_format: proc; ans = ans || substr(digits,n,1); ans = ans || "."; ans = ans || substr(digits,n+1,ndigits-1); ans = ans || "e"; exp = exp + ndigits - 1; fixed_dec = convert(fixed_dec,exp); if abs(exp) < 10 then ndigits = 1; else if abs(exp) < 100 then ndigits = 2; else ndigits = 3; if exp < 0 then ans = ans || "-"; ans = ans || substr(fixed_overlay.dig,4-ndigits,ndigits); end; end;  numeric_to_ascii_base_.pl1 11/11/89 1103.4r 11/11/89 0803.8 48168 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ numeric_to_ascii_base_: proc (Aval, Aprec, Base, ans); dcl Aval float dec (59), /* value to be converted. (In) */ Aprec fixed bin, /* precision of result. (In) */ /* 0 ==> as many digits as a required will */ /* appear in final result. */ /* <0 ==> truncate to specified no of digits */ /* >0 ==> round to specified number of digits */ /* see numeric_to_ascii_ for description of */ /* allowed values. */ Base fixed bin, /* base to which conversion is to be done */ ans char (72) varying; /* resulting number. (Out) */ /* This is copied from numeric_to_ascii_ */ /* Modified: 10/24/83 by C Spitzer. phx15636, replace out_of_bounds condition with call to sub_err_ */ dcl (new_quotient, product, quotient, saved_val, val) float dec (59), (Isignificant, exp, n, nzeros, ndigits, prec) fixed bin (17), char1 char (1), chars char (200) varying, char_exp pic "999"; dcl sub_err_ entry() options(variable); dcl dig_ch (0:15) char (1) int static init ( "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f"); dcl base float dec (3); dcl 1 val_overlay aligned based (addr (val)), 2 sign char (1) unal, 2 digits char (59) unal, 2 skip bit (1) unal, 2 exponent fixed bin (7) unal; dcl (abs, divide, index, length, mod, null, reverse, substr, trunc, verify) builtin; dcl move_r_or_t_ entry (float dec (59), float dec (59), fixed bin); %include sub_err_flags; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ if (Base < 2) | (Base > 16) then do; call sub_err_ (0, "numeric_to_ascii_base_", ACTION_CANT_RESTART, null, 0, "The base ""^d"" is outside of the range 2 to 16.", Base); end; base = convert (base, Base); prec = Aprec; if prec ^= 0 then do; call move_r_or_t_ (val, Aval, prec); prec = abs (prec); end; else do; val = Aval; prec = 59; end; if val = 0 then ans = "0"; else do; if val > 0 then ans = ""; else do; val = abs (val); ans = "-"; end; n = verify (digits, "0"); nzeros = verify (reverse (digits), "0"); ndigits = 61 - n - nzeros; exp = exponent + nzeros - 1; if exp >= 0 then do; /* integer value */ quotient = val; chars = ""; do while (quotient >= 1); /* use method of dividing successive */ /* quotients by radix, using remainders as */ /* digits of result (low-order first). */ new_quotient = trunc (divide (quotient, base, 59)); char1 = dig_ch (quotient - (base * new_quotient)); chars = chars || char1; quotient = new_quotient; end; chars = reverse (chars); if length (chars) > prec then call e_format (); else ans = ans || chars; end; else do; /* integer/fractional value */ nzeros = ndigits + exp; if nzeros <= 0 then do; /* fraction only value */ product = val; ans = ans || "0."; do n = 1 to prec; product = base * product; char1 = dig_ch (trunc (product)); product = product - trunc (product); ans = ans || char1; end; n = verify (reverse (ans), "0"); if n > 1 then ans = substr (ans, 1, length (ans) - (n-1)); end; else do; /* both integer and fraction parts */ saved_val = val; substr (val_overlay.digits, nzeros+n) = (59)"0"; quotient = val; chars = ""; do while (quotient >= 1); new_quotient = trunc (divide (quotient, base, 59)); char1 = dig_ch (quotient - (base * new_quotient)); chars = chars || char1; quotient = new_quotient; end; chars = reverse (chars); chars = chars || "."; val = saved_val; substr (val_overlay.digits, 1, nzeros+n-1) = (59)"0"; product = val; do n = 1 to prec - (length (chars)-1); product = base * product; char1 = dig_ch (trunc (product)); product = product - trunc (product); chars = chars || char1; end; n = verify (reverse (chars), "0"); if n > 1 then chars = substr (chars, 1, length (chars) - (n-1)); if length (chars)-1 > prec then call e_format (); else ans = ans || chars; end; end; end; return; e_format: procedure; exp = index (chars, ".") - 1; if exp = -1 then exp = length (chars); else chars = substr (chars, 1, exp) || substr (chars, exp+2); ans = ans || substr (chars, 1, 1); ans = ans || "."; ans = ans || substr (chars, 2, prec-1); ans = ans || "e"; if exp-1 < 0 then ans = ans || "-"; else ans = ans || "+"; char_exp = exp-1; Isignificant = verify (char_exp, "0"); ans = ans || substr (char_exp, Isignificant); end e_format; end numeric_to_ascii_base_;  op_mnemonic_.cds 11/11/89 1103.4r 11/11/89 0803.8 229725 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* op_mnemonic_.cds -- successor to the illegible op_mnemonic.alm */ /* format: style2 */ op_mnemonic_: procedure; /* BIM 12/82 */ /* Modified to not need the bce/Multics versions! March 1985 by Keith Loepere. */ declare create_data_segment_ entry (pointer, fixed binary (35)); declare com_err_ entry() options(variable); declare code fixed bin (35); %include cds_args; %include op_mnemonic_dcl_; declare 1 CDSA aligned like cds_args; declare 1 OI aligned, 2 op_mnemonic bit (0) aligned, /* programs reference this ... */ 2 op_mnemonic_ (0:1023) aligned like op_mnemonic; declare 1 unused aligned like op_mnemonic; unspec (unused) = ""b; unused.name = ".... "; unused.num_words = 1; OI.op_mnemonic_ (*) = unused; call set_opcode (2, "mme1 ", 0, 0, 1); call set_opcode (4, "drl ", 0, 0, 1); call set_opcode (8, "mme2 ", 0, 0, 1); call set_opcode (10, "mme3 ", 0, 0, 1); call set_opcode (14, "mme4 ", 0, 0, 1); call set_opcode (18, "nop ", 0, 0, 1); call set_opcode (20, "puls1 ", 0, 0, 1); call set_opcode (22, "puls2 ", 0, 0, 1); call set_opcode (26, "cioc ", 0, 0, 1); call set_opcode (32, "adlx0 ", 0, 0, 1); call set_opcode (33, "mve ", 0, 3, 4); call set_opcode (34, "adlx1 ", 0, 0, 1); call set_opcode (36, "adlx2 ", 0, 0, 1); call set_opcode (38, "adlx3 ", 0, 0, 1); call set_opcode (40, "adlx4 ", 0, 0, 1); call set_opcode (41, "mvne ", 2, 3, 4); call set_opcode (42, "adlx5 ", 0, 0, 1); call set_opcode (44, "adlx6 ", 0, 0, 1); call set_opcode (46, "adlx7 ", 0, 0, 1); call set_opcode (52, "ldqc ", 0, 0, 1); call set_opcode (54, "adl ", 0, 0, 1); call set_opcode (56, "ldac ", 0, 0, 1); call set_opcode (58, "adla ", 0, 0, 1); call set_opcode (60, "adlq ", 0, 0, 1); call set_opcode (62, "adlaq ", 0, 0, 1); call set_opcode (64, "asx0 ", 0, 0, 1); call set_opcode (66, "asx1 ", 0, 0, 1); call set_opcode (68, "asx2 ", 0, 0, 1); call set_opcode (70, "asx3 ", 0, 0, 1); call set_opcode (72, "asx4 ", 0, 0, 1); call set_opcode (74, "asx5 ", 0, 0, 1); call set_opcode (76, "asx6 ", 0, 0, 1); call set_opcode (78, "asx7 ", 0, 0, 1); call set_opcode (80, "adwp0 ", 0, 0, 1); call set_opcode (82, "adwp1 ", 0, 0, 1); call set_opcode (84, "adwp2 ", 0, 0, 1); call set_opcode (86, "adwp3 ", 0, 0, 1); call set_opcode (88, "aos ", 0, 0, 1); call set_opcode (90, "asa ", 0, 0, 1); call set_opcode (92, "asq ", 0, 0, 1); call set_opcode (94, "sscr ", 0, 0, 1); call set_opcode (96, "adx0 ", 0, 0, 1); call set_opcode (97, "csl ", 1, 2, 3); call set_opcode (98, "adx1 ", 0, 0, 1); call set_opcode (99, "csr ", 1, 2, 3); call set_opcode (100, "adx2 ", 0, 0, 1); call set_opcode (102, "adx3 ", 0, 0, 1); call set_opcode (104, "adx4 ", 0, 0, 1); call set_opcode (105, "sztl ", 1, 2, 3); call set_opcode (106, "adx5 ", 0, 0, 1); call set_opcode (107, "sztr ", 1, 2, 3); call set_opcode (108, "adx6 ", 0, 0, 1); call set_opcode (109, "cmpb ", 1, 2, 3); call set_opcode (110, "adx7 ", 0, 0, 1); call set_opcode (114, "awca ", 0, 0, 1); call set_opcode (116, "awcq ", 0, 0, 1); call set_opcode (118, "lreg ", 0, 0, 1); call set_opcode (122, "ada ", 0, 0, 1); call set_opcode (124, "adq ", 0, 0, 1); call set_opcode (126, "adaq ", 0, 0, 1); call set_opcode (128, "cmpx0 ", 0, 0, 1); call set_opcode (129, "mlr ", 0, 2, 3); call set_opcode (130, "cmpx1 ", 0, 0, 1); call set_opcode (131, "mrl ", 0, 2, 3); call set_opcode (132, "cmpx2 ", 0, 0, 1); call set_opcode (134, "cmpx3 ", 0, 0, 1); call set_opcode (136, "cmpx4 ", 0, 0, 1); call set_opcode (138, "cmpx5 ", 0, 0, 1); call set_opcode (140, "cmpx6 ", 0, 0, 1); call set_opcode (141, "cmpc ", 0, 2, 3); call set_opcode (142, "cmpx7 ", 0, 0, 1); call set_opcode (146, "cwl ", 0, 0, 1); call set_opcode (154, "cmpa ", 0, 0, 1); call set_opcode (156, "cmpq ", 0, 0, 1); call set_opcode (158, "cmpaq ", 0, 0, 1); call set_opcode (160, "sblx0 ", 0, 0, 1); call set_opcode (161, "scd ", 0, 2, 4); call set_opcode (162, "sblx1 ", 0, 0, 1); call set_opcode (163, "scdr ", 0, 2, 4); call set_opcode (164, "sblx2 ", 0, 0, 1); call set_opcode (166, "sblx3 ", 0, 0, 1); call set_opcode (168, "sblx4 ", 0, 0, 1); call set_opcode (169, "scm ", 0, 2, 4); call set_opcode (170, "sblx5 ", 0, 0, 1); call set_opcode (171, "scmr ", 0, 2, 4); call set_opcode (172, "sblx6 ", 0, 0, 1); call set_opcode (174, "sblx7 ", 0, 0, 1); call set_opcode (186, "sbla ", 0, 0, 1); call set_opcode (188, "sblq ", 0, 0, 1); call set_opcode (190, "sblaq ", 0, 0, 1); call set_opcode (192, "ssx0 ", 0, 0, 1); call set_opcode (194, "ssx1 ", 0, 0, 1); call set_opcode (196, "ssx2 ", 0, 0, 1); call set_opcode (198, "ssx3 ", 0, 0, 1); call set_opcode (200, "ssx4 ", 0, 0, 1); call set_opcode (202, "ssx5 ", 0, 0, 1); call set_opcode (204, "ssx6 ", 0, 0, 1); call set_opcode (206, "ssx7 ", 0, 0, 1); call set_opcode (208, "adwp4 ", 0, 0, 1); call set_opcode (210, "adwp5 ", 0, 0, 1); call set_opcode (212, "adwp6 ", 0, 0, 1); call set_opcode (214, "adwp7 ", 0, 0, 1); call set_opcode (216, "sdbr ", 0, 0, 1); call set_opcode (217, "sptr ", 0, 0, 1); call set_opcode (218, "ssa ", 0, 0, 1); call set_opcode (220, "ssq ", 0, 0, 1); call set_opcode (224, "sbx0 ", 0, 0, 1); call set_opcode (225, "mvt ", 0, 2, 4); call set_opcode (226, "sbx1 ", 0, 0, 1); call set_opcode (228, "sbx2 ", 0, 0, 1); call set_opcode (230, "sbx3 ", 0, 0, 1); call set_opcode (232, "sbx4 ", 0, 0, 1); call set_opcode (233, "tct ", 0, 1, 4); call set_opcode (234, "sbx5 ", 0, 0, 1); call set_opcode (235, "tctr ", 0, 1, 4); call set_opcode (236, "sbx6 ", 0, 0, 1); call set_opcode (238, "sbx7 ", 0, 0, 1); call set_opcode (242, "swca ", 0, 0, 1); call set_opcode (244, "swcq ", 0, 0, 1); call set_opcode (246, "lpri ", 0, 0, 1); call set_opcode (247, "lptr ", 0, 0, 1); call set_opcode (250, "sba ", 0, 0, 1); call set_opcode (252, "sbq ", 0, 0, 1); call set_opcode (254, "sbaq ", 0, 0, 1); call set_opcode (256, "cnax0 ", 0, 0, 1); call set_opcode (258, "cnax1 ", 0, 0, 1); call set_opcode (260, "cnax2 ", 0, 0, 1); call set_opcode (261, "ad2d ", 2, 2, 3); call set_opcode (262, "cnax3 ", 0, 0, 1); call set_opcode (263, "sb2d ", 2, 2, 3); call set_opcode (264, "cnax4 ", 0, 0, 1); call set_opcode (266, "cnax5 ", 0, 0, 1); call set_opcode (268, "cnax6 ", 0, 0, 1); call set_opcode (269, "mp2d ", 2, 2, 3); call set_opcode (270, "cnax7 ", 0, 0, 1); call set_opcode (271, "dv2d ", 2, 2, 3); call set_opcode (274, "cmk ", 0, 0, 1); call set_opcode (276, "absa ", 0, 0, 1); call set_opcode (278, "epaq ", 0, 0, 1); call set_opcode (280, "sznc ", 0, 0, 1); call set_opcode (282, "cnaa ", 0, 0, 1); call set_opcode (284, "cnaq ", 0, 0, 1); call set_opcode (286, "cnaaq ", 0, 0, 1); call set_opcode (288, "ldx0 ", 0, 0, 1); call set_opcode (290, "ldx1 ", 0, 0, 1); call set_opcode (292, "ldx2 ", 0, 0, 1); call set_opcode (293, "ad3d ", 2, 3, 4); call set_opcode (294, "ldx3 ", 0, 0, 1); call set_opcode (295, "sb3d ", 2, 3, 4); call set_opcode (296, "ldx4 ", 0, 0, 1); call set_opcode (298, "ldx5 ", 0, 0, 1); call set_opcode (300, "ldx6 ", 0, 0, 1); call set_opcode (301, "mp3d ", 2, 3, 4); call set_opcode (302, "ldx7 ", 0, 0, 1); call set_opcode (303, "dv3d ", 2, 3, 4); call set_opcode (304, "lbar ", 0, 0, 1); call set_opcode (306, "rsw ", 0, 0, 1); call set_opcode (308, "ldbr ", 0, 0, 1); call set_opcode (309, "lsdr ", 0, 0, 1); call set_opcode (310, "rmcm ", 0, 0, 1); call set_opcode (312, "szn ", 0, 0, 1); call set_opcode (314, "lda ", 0, 0, 1); call set_opcode (316, "ldq ", 0, 0, 1); call set_opcode (318, "ldaq ", 0, 0, 1); call set_opcode (320, "orsx0 ", 0, 0, 1); call set_opcode (322, "orsx1 ", 0, 0, 1); call set_opcode (324, "orsx2 ", 0, 0, 1); call set_opcode (326, "orsx3 ", 0, 0, 1); call set_opcode (328, "orsx4 ", 0, 0, 1); call set_opcode (330, "orsx5 ", 0, 0, 1); call set_opcode (332, "orsx6 ", 0, 0, 1); call set_opcode (334, "orsx7 ", 0, 0, 1); call set_opcode (336, "spri0 ", 0, 0, 1); call set_opcode (337, "spbp0 ", 0, 0, 1); call set_opcode (338, "spbp1 ", 0, 0, 1); call set_opcode (339, "spri1 ", 0, 0, 1); call set_opcode (340, "spri2 ", 0, 0, 1); call set_opcode (341, "spbp2 ", 0, 0, 1); call set_opcode (342, "spbp3 ", 0, 0, 1); call set_opcode (343, "spri3 ", 0, 0, 1); call set_opcode (344, "spri ", 0, 0, 1); call set_opcode (345, "ssdr ", 0, 0, 1); call set_opcode (346, "orsa ", 0, 0, 1); call set_opcode (348, "orsq ", 0, 0, 1); call set_opcode (350, "lsdp ", 0, 0, 1); call set_opcode (351, "lptp ", 0, 0, 1); call set_opcode (352, "orx0 ", 0, 0, 1); call set_opcode (354, "orx1 ", 0, 0, 1); call set_opcode (356, "orx2 ", 0, 0, 1); call set_opcode (358, "orx3 ", 0, 0, 1); call set_opcode (360, "orx4 ", 0, 0, 1); call set_opcode (362, "orx5 ", 0, 0, 1); call set_opcode (364, "orx6 ", 0, 0, 1); call set_opcode (366, "orx7 ", 0, 0, 1); call set_opcode (368, "tsp0 ", 0, 0, 1); call set_opcode (370, "tsp1 ", 0, 0, 1); call set_opcode (372, "tsp2 ", 0, 0, 1); call set_opcode (374, "tsp3 ", 0, 0, 1); call set_opcode (378, "ora ", 0, 0, 1); call set_opcode (380, "orq ", 0, 0, 1); call set_opcode (382, "oraq ", 0, 0, 1); call set_opcode (384, "canx0 ", 0, 0, 1); call set_opcode (385, "mvn ", 2, 2, 3); call set_opcode (386, "canx1 ", 0, 0, 1); call set_opcode (387, "btd ", 2, 2, 3); call set_opcode (388, "canx2 ", 0, 0, 1); call set_opcode (390, "canx3 ", 0, 0, 1); call set_opcode (391, "cmpn ", 2, 2, 3); call set_opcode (392, "canx4 ", 0, 0, 1); call set_opcode (394, "canx5 ", 0, 0, 1); call set_opcode (395, "dtb ", 2, 2, 3); call set_opcode (396, "canx6 ", 0, 0, 1); call set_opcode (398, "canx7 ", 0, 0, 1); call set_opcode (400, "eawp0 ", 0, 0, 1); call set_opcode (401, "easp1 ", 0, 0, 1); call set_opcode (402, "easp0 ", 0, 0, 1); call set_opcode (403, "eawp1 ", 0, 0, 1); call set_opcode (404, "eawp2 ", 0, 0, 1); call set_opcode (405, "easp3 ", 0, 0, 1); call set_opcode (406, "easp2 ", 0, 0, 1); call set_opcode (407, "eawp3 ", 0, 0, 1); call set_opcode (410, "cana ", 0, 0, 1); call set_opcode (412, "canq ", 0, 0, 1); call set_opcode (414, "canaq ", 0, 0, 1); call set_opcode (416, "lcx0 ", 0, 0, 1); call set_opcode (418, "lcx1 ", 0, 0, 1); call set_opcode (420, "lcx2 ", 0, 0, 1); call set_opcode (422, "lcx3 ", 0, 0, 1); call set_opcode (424, "lcx4 ", 0, 0, 1); call set_opcode (426, "lcx5 ", 0, 0, 1); call set_opcode (428, "lcx6 ", 0, 0, 1); call set_opcode (430, "lcx7 ", 0, 0, 1); call set_opcode (432, "eawp4 ", 0, 0, 1); call set_opcode (433, "easp5 ", 0, 0, 1); call set_opcode (434, "easp4 ", 0, 0, 1); call set_opcode (435, "eawp5 ", 0, 0, 1); call set_opcode (436, "eawp6 ", 0, 0, 1); call set_opcode (437, "easp7 ", 0, 0, 1); call set_opcode (438, "easp6 ", 0, 0, 1); call set_opcode (439, "eawp7 ", 0, 0, 1); call set_opcode (442, "lca ", 0, 0, 1); call set_opcode (444, "lcq ", 0, 0, 1); call set_opcode (446, "lcaq ", 0, 0, 1); call set_opcode (448, "ansx0 ", 0, 0, 1); call set_opcode (450, "ansx1 ", 0, 0, 1); call set_opcode (452, "ansx2 ", 0, 0, 1); call set_opcode (454, "ansx3 ", 0, 0, 1); call set_opcode (456, "ansx4 ", 0, 0, 1); call set_opcode (458, "ansx5 ", 0, 0, 1); call set_opcode (460, "ansx6 ", 0, 0, 1); call set_opcode (462, "ansx7 ", 0, 0, 1); call set_opcode (464, "epp0 ", 0, 0, 1); call set_opcode (465, "epbp0 ", 0, 0, 1); call set_opcode (466, "epbp1 ", 0, 0, 1); call set_opcode (467, "epp1 ", 0, 0, 1); call set_opcode (468, "epp2 ", 0, 0, 1); call set_opcode (469, "epbp2 ", 0, 0, 1); call set_opcode (470, "epbp3 ", 0, 0, 1); call set_opcode (471, "epp3 ", 0, 0, 1); call set_opcode (472, "stac ", 0, 0, 1); call set_opcode (474, "ansa ", 0, 0, 1); call set_opcode (476, "ansq ", 0, 0, 1); call set_opcode (478, "stcd ", 0, 0, 1); call set_opcode (480, "anx0 ", 0, 0, 1); call set_opcode (482, "anx1 ", 0, 0, 1); call set_opcode (484, "anx2 ", 0, 0, 1); call set_opcode (486, "anx3 ", 0, 0, 1); call set_opcode (488, "anx4 ", 0, 0, 1); call set_opcode (490, "anx5 ", 0, 0, 1); call set_opcode (492, "anx6 ", 0, 0, 1); call set_opcode (494, "anx7 ", 0, 0, 1); call set_opcode (496, "epp4 ", 0, 0, 1); call set_opcode (497, "epbp4 ", 0, 0, 1); call set_opcode (498, "epbp5 ", 0, 0, 1); call set_opcode (499, "epp5 ", 0, 0, 1); call set_opcode (500, "epp6 ", 0, 0, 1); call set_opcode (501, "epbp6 ", 0, 0, 1); call set_opcode (502, "epbp7 ", 0, 0, 1); call set_opcode (503, "epp7 ", 0, 0, 1); call set_opcode (506, "ana ", 0, 0, 1); call set_opcode (508, "anq ", 0, 0, 1); call set_opcode (510, "anaq ", 0, 0, 1); call set_opcode (514, "mpf ", 0, 0, 1); call set_opcode (516, "mpy ", 0, 0, 1); call set_opcode (522, "cmg ", 0, 0, 1); call set_opcode (530, "lde ", 0, 0, 1); call set_opcode (534, "rscr ", 0, 0, 1); call set_opcode (538, "ade ", 0, 0, 1); call set_opcode (546, "ufm ", 0, 0, 1); call set_opcode (550, "dufm ", 0, 0, 1); call set_opcode (554, "fcmg ", 0, 0, 1); call set_opcode (558, "dfcmg ", 0, 0, 1); call set_opcode (560, "fszn ", 0, 0, 1); call set_opcode (562, "fld ", 0, 0, 1); call set_opcode (566, "dfld ", 0, 0, 1); call set_opcode (570, "ufa ", 0, 0, 1); call set_opcode (574, "dufa ", 0, 0, 1); call set_opcode (576, "sxl0 ", 0, 0, 1); call set_opcode (578, "sxl1 ", 0, 0, 1); call set_opcode (580, "sxl2 ", 0, 0, 1); call set_opcode (582, "sxl3 ", 0, 0, 1); call set_opcode (583, "sareg ", 0, 0, 1); call set_opcode (584, "sxl4 ", 0, 0, 1); call set_opcode (586, "sxl5 ", 0, 0, 1); call set_opcode (588, "sxl6 ", 0, 0, 1); call set_opcode (590, "sxl7 ", 0, 0, 1); call set_opcode (591, "spl ", 0, 0, 1); call set_opcode (592, "stz ", 0, 0, 1); call set_opcode (594, "smic ", 0, 0, 1); call set_opcode (596, "scpr ", 0, 0, 1); call set_opcode (600, "stt ", 0, 0, 1); call set_opcode (602, "fst ", 0, 0, 1); call set_opcode (604, "ste ", 0, 0, 1); call set_opcode (606, "dfst ", 0, 0, 1); call set_opcode (610, "fmp ", 0, 0, 1); call set_opcode (614, "dfmp ", 0, 0, 1); call set_opcode (615, "lareg ", 0, 0, 1); call set_opcode (623, "lpl ", 0, 0, 1); call set_opcode (624, "fstr ", 0, 0, 1); call set_opcode (626, "frd ", 0, 0, 1); call set_opcode (628, "dfstr ", 0, 0, 1); call set_opcode (630, "dfrd ", 0, 0, 1); call set_opcode (634, "fad ", 0, 0, 1); call set_opcode (638, "dfad ", 0, 0, 1); call set_opcode (640, "rpl ", 0, 1, 1); call set_opcode (641, "a9bd ", 1, 0, 1); call set_opcode (643, "a6bd ", 1, 0, 1); call set_opcode (645, "a4bd ", 1, 0, 1); call set_opcode (647, "abd ", 1, 0, 1); call set_opcode (650, "bcd ", 0, 0, 1); call set_opcode (652, "div ", 0, 0, 1); call set_opcode (654, "dvf ", 0, 0, 1); call set_opcode (655, "awd ", 1, 0, 1); call set_opcode (662, "fneg ", 0, 0, 1); call set_opcode (666, "fcmp ", 0, 0, 1); call set_opcode (670, "dfcmp ", 0, 0, 1); call set_opcode (672, "rpt ", 0, 1, 1); call set_opcode (673, "s9bd ", 1, 0, 1); call set_opcode (675, "s6bd ", 1, 0, 1); call set_opcode (677, "s4bd ", 1, 0, 1); call set_opcode (679, "sbd ", 1, 0, 1); call set_opcode (682, "fdi ", 0, 0, 1); call set_opcode (686, "dfdi ", 0, 0, 1); call set_opcode (687, "swd ", 1, 0, 1); call set_opcode (690, "neg ", 0, 0, 1); call set_opcode (692, "cams ", 0, 0, 1); call set_opcode (693, "camp ", 0, 0, 1); call set_opcode (694, "negl ", 0, 0, 1); call set_opcode (698, "ufs ", 0, 0, 1); call set_opcode (702, "dufs ", 0, 0, 1); call set_opcode (704, "sprp0 ", 0, 0, 1); call set_opcode (705, "ara0 ", 0, 0, 1); call set_opcode (706, "sprp1 ", 0, 0, 1); call set_opcode (707, "ara1 ", 0, 0, 1); call set_opcode (708, "sprp2 ", 0, 0, 1); call set_opcode (709, "ara2 ", 0, 0, 1); call set_opcode (710, "sprp3 ", 0, 0, 1); call set_opcode (711, "ara3 ", 0, 0, 1); call set_opcode (712, "sprp4 ", 0, 0, 1); call set_opcode (713, "ara4 ", 0, 0, 1); call set_opcode (714, "sprp5 ", 0, 0, 1); call set_opcode (715, "ara5 ", 0, 0, 1); call set_opcode (716, "sprp6 ", 0, 0, 1); call set_opcode (717, "ara6 ", 0, 0, 1); call set_opcode (718, "sprp7 ", 0, 0, 1); call set_opcode (719, "ara7 ", 0, 0, 1); call set_opcode (720, "sbar ", 0, 0, 1); call set_opcode (722, "stba ", 0, 1, 1); call set_opcode (724, "stbq ", 0, 1, 1); call set_opcode (726, "smcm ", 0, 0, 1); call set_opcode (728, "stc1 ", 0, 0, 1); call set_opcode (734, "ssdp ", 0, 0, 1); call set_opcode (735, "sptp ", 0, 0, 1); call set_opcode (736, "rpd ", 0, 1, 1); call set_opcode (737, "aar0 ", 0, 0, 1); call set_opcode (739, "aar1 ", 0, 0, 1); call set_opcode (741, "aar2 ", 0, 0, 1); call set_opcode (743, "aar3 ", 0, 0, 1); call set_opcode (745, "aar4 ", 0, 0, 1); call set_opcode (746, "fdv ", 0, 0, 1); call set_opcode (747, "aar5 ", 0, 0, 1); call set_opcode (749, "aar6 ", 0, 0, 1); call set_opcode (750, "dfdv ", 0, 0, 1); call set_opcode (751, "aar7 ", 0, 0, 1); call set_opcode (758, "fno ", 0, 0, 1); call set_opcode (762, "fsb ", 0, 0, 1); call set_opcode (766, "dfsb ", 0, 0, 1); call set_opcode (768, "tze ", 0, 0, 1); call set_opcode (769, "trtn ", 0, 0, 1); call set_opcode (770, "tnz ", 0, 0, 1); call set_opcode (771, "trtf ", 0, 0, 1); call set_opcode (772, "tnc ", 0, 0, 1); call set_opcode (774, "trc ", 0, 0, 1); call set_opcode (776, "tmi ", 0, 0, 1); call set_opcode (777, "tmoz ", 0, 0, 1); call set_opcode (778, "tpl ", 0, 0, 1); call set_opcode (779, "tpnz ", 0, 0, 1); call set_opcode (781, "ttn ", 0, 0, 1); call set_opcode (782, "ttf ", 0, 0, 1); call set_opcode (784, "rtcd ", 0, 0, 1); call set_opcode (790, "rcu ", 0, 0, 1); call set_opcode (792, "teo ", 0, 0, 1); call set_opcode (794, "teu ", 0, 0, 1); call set_opcode (796, "dis ", 0, 0, 1); call set_opcode (798, "tov ", 0, 0, 1); call set_opcode (800, "eax0 ", 0, 0, 1); call set_opcode (802, "eax1 ", 0, 0, 1); call set_opcode (804, "eax2 ", 0, 0, 1); call set_opcode (806, "eax3 ", 0, 0, 1); call set_opcode (808, "eax4 ", 0, 0, 1); call set_opcode (810, "eax5 ", 0, 0, 1); call set_opcode (812, "eax6 ", 0, 0, 1); call set_opcode (814, "eax7 ", 0, 0, 1); call set_opcode (816, "ret ", 0, 0, 1); call set_opcode (822, "rccl ", 0, 0, 1); call set_opcode (824, "ldi ", 0, 0, 1); call set_opcode (826, "eaa ", 0, 0, 1); call set_opcode (828, "eaq ", 0, 0, 1); call set_opcode (830, "ldt ", 0, 0, 1); call set_opcode (832, "ersx0 ", 0, 0, 1); call set_opcode (833, "arn0 ", 0, 0, 1); call set_opcode (834, "ersx1 ", 0, 0, 1); call set_opcode (835, "arn1 ", 0, 0, 1); call set_opcode (836, "ersx2 ", 0, 0, 1); call set_opcode (837, "arn2 ", 0, 0, 1); call set_opcode (838, "ersx3 ", 0, 0, 1); call set_opcode (839, "arn3 ", 0, 0, 1); call set_opcode (840, "ersx4 ", 0, 0, 1); call set_opcode (841, "arn4 ", 0, 0, 1); call set_opcode (842, "ersx5 ", 0, 0, 1); call set_opcode (843, "arn5 ", 0, 0, 1); call set_opcode (844, "ersx6 ", 0, 0, 1); call set_opcode (845, "arn6 ", 0, 0, 1); call set_opcode (846, "ersx7 ", 0, 0, 1); call set_opcode (847, "arn7 ", 0, 0, 1); call set_opcode (848, "spri4 ", 0, 0, 1); call set_opcode (849, "spbp4 ", 0, 0, 1); call set_opcode (850, "spbp5 ", 0, 0, 1); call set_opcode (851, "spri5 ", 0, 0, 1); call set_opcode (852, "spri6 ", 0, 0, 1); call set_opcode (853, "spbp6 ", 0, 0, 1); call set_opcode (854, "spbp7 ", 0, 0, 1); call set_opcode (855, "spri7 ", 0, 0, 1); call set_opcode (856, "stacq ", 0, 0, 1); call set_opcode (858, "ersa ", 0, 0, 1); call set_opcode (860, "ersq ", 0, 0, 1); call set_opcode (862, "scu ", 0, 0, 1); call set_opcode (864, "erx0 ", 0, 0, 1); call set_opcode (865, "nar0 ", 0, 0, 1); call set_opcode (866, "erx1 ", 0, 0, 1); call set_opcode (867, "nar1 ", 0, 0, 1); call set_opcode (868, "erx2 ", 0, 0, 1); call set_opcode (869, "nar2 ", 0, 0, 1); call set_opcode (870, "erx3 ", 0, 0, 1); call set_opcode (871, "nar3 ", 0, 0, 1); call set_opcode (872, "erx4 ", 0, 0, 1); call set_opcode (873, "nar4 ", 0, 0, 1); call set_opcode (874, "erx5 ", 0, 0, 1); call set_opcode (875, "nar5 ", 0, 0, 1); call set_opcode (876, "erx6 ", 0, 0, 1); call set_opcode (877, "nar6 ", 0, 0, 1); call set_opcode (878, "erx7 ", 0, 0, 1); call set_opcode (879, "nar7 ", 0, 0, 1); call set_opcode (880, "tsp4 ", 0, 0, 1); call set_opcode (882, "tsp5 ", 0, 0, 1); call set_opcode (884, "tsp6 ", 0, 0, 1); call set_opcode (886, "tsp7 ", 0, 0, 1); call set_opcode (888, "lcpr ", 0, 0, 1); call set_opcode (890, "era ", 0, 0, 1); call set_opcode (892, "erq ", 0, 0, 1); call set_opcode (894, "eraq ", 0, 0, 1); call set_opcode (896, "tsx0 ", 0, 0, 1); call set_opcode (898, "tsx1 ", 0, 0, 1); call set_opcode (900, "tsx2 ", 0, 0, 1); call set_opcode (902, "tsx3 ", 0, 0, 1); call set_opcode (904, "tsx4 ", 0, 0, 1); call set_opcode (906, "tsx5 ", 0, 0, 1); call set_opcode (908, "tsx6 ", 0, 0, 1); call set_opcode (910, "tsx7 ", 0, 0, 1); call set_opcode (912, "tra ", 0, 0, 1); call set_opcode (918, "call6 ", 0, 0, 1); call set_opcode (922, "tss ", 0, 0, 1); call set_opcode (924, "xec ", 0, 0, 1); call set_opcode (926, "xed ", 0, 0, 1); call set_opcode (928, "lxl0 ", 0, 0, 1); call set_opcode (930, "lxl1 ", 0, 0, 1); call set_opcode (932, "lxl2 ", 0, 0, 1); call set_opcode (934, "lxl3 ", 0, 0, 1); call set_opcode (936, "lxl4 ", 0, 0, 1); call set_opcode (938, "lxl5 ", 0, 0, 1); call set_opcode (940, "lxl6 ", 0, 0, 1); call set_opcode (942, "lxl7 ", 0, 0, 1); call set_opcode (946, "ars ", 0, 0, 1); call set_opcode (948, "qrs ", 0, 0, 1); call set_opcode (950, "lrs ", 0, 0, 1); call set_opcode (954, "als ", 0, 0, 1); call set_opcode (956, "qls ", 0, 0, 1); call set_opcode (958, "lls ", 0, 0, 1); call set_opcode (960, "stx0 ", 0, 0, 1); call set_opcode (961, "sar0 ", 0, 0, 1); call set_opcode (962, "stx1 ", 0, 0, 1); call set_opcode (963, "sar1 ", 0, 0, 1); call set_opcode (964, "stx2 ", 0, 0, 1); call set_opcode (965, "sar2 ", 0, 0, 1); call set_opcode (966, "stx3 ", 0, 0, 1); call set_opcode (967, "sar3 ", 0, 0, 1); call set_opcode (968, "stx4 ", 0, 0, 1); call set_opcode (969, "sar4 ", 0, 0, 1); call set_opcode (970, "stx5 ", 0, 0, 1); call set_opcode (971, "sar5 ", 0, 0, 1); call set_opcode (972, "stx6 ", 0, 0, 1); call set_opcode (973, "sar6 ", 0, 0, 1); call set_opcode (974, "stx7 ", 0, 0, 1); call set_opcode (975, "sar7 ", 0, 0, 1); call set_opcode (976, "stc2 ", 0, 0, 1); call set_opcode (978, "stca ", 0, 1, 1); call set_opcode (980, "stcq ", 0, 1, 1); call set_opcode (982, "sreg ", 0, 0, 1); call set_opcode (984, "sti ", 0, 0, 1); call set_opcode (985, "sra ", 0, 0, 1); call set_opcode (986, "sta ", 0, 0, 1); call set_opcode (988, "stq ", 0, 0, 1); call set_opcode (990, "staq ", 0, 0, 1); call set_opcode (992, "lprp0 ", 0, 0, 1); call set_opcode (993, "lar0 ", 0, 0, 1); call set_opcode (994, "lprp1 ", 0, 0, 1); call set_opcode (995, "lar1 ", 0, 0, 1); call set_opcode (996, "lprp2 ", 0, 0, 1); call set_opcode (997, "lar2 ", 0, 0, 1); call set_opcode (998, "lprp3 ", 0, 0, 1); call set_opcode (999, "lar3 ", 0, 0, 1); call set_opcode (1000, "lprp4 ", 0, 0, 1); call set_opcode (1001, "lar4 ", 0, 0, 1); call set_opcode (1002, "lprp5 ", 0, 0, 1); call set_opcode (1003, "lar5 ", 0, 0, 1); call set_opcode (1004, "lprp6 ", 0, 0, 1); call set_opcode (1005, "lar6 ", 0, 0, 1); call set_opcode (1006, "lprp7 ", 0, 0, 1); call set_opcode (1007, "lar7 ", 0, 0, 1); call set_opcode (1010, "arl ", 0, 0, 1); call set_opcode (1012, "qrl ", 0, 0, 1); call set_opcode (1014, "lrl ", 0, 0, 1); call set_opcode (1016, "gtb ", 0, 0, 1); call set_opcode (1017, "lra ", 0, 0, 1); call set_opcode (1018, "alr ", 0, 0, 1); call set_opcode (1020, "qlr ", 0, 0, 1); call set_opcode (1022, "llr ", 0, 0, 1); CDSA.sections (1).p = addr (OI); CDSA.sections (1).len = size (OI); CDSA.sections (1).struct_name = "OI"; CDSA.seg_name = "op_mnemonic_"; CDSA.num_exclude_names = 0; CDSA.exclude_array_ptr = null (); string (CDSA.switches) = ""b; CDSA.switches.have_text = "1"b; call create_data_segment_ (addr (CDSA), code); if code ^= 0 then call com_err_ (code, "op_mnemonic_"); return; set_opcode: procedure (Opx, Name, Dtype, Num_descs, Num_words); declare Opx fixed bin; declare Name char (6); declare Dtype fixed bin (2); declare Num_descs fixed bin (5); declare Num_words fixed bin (8); op_mnemonic_ptr = addr (OI.op_mnemonic_ (Opx)); op_mnemonic.name = Name; op_mnemonic.dtype = Dtype; op_mnemonic.num_desc = Num_descs; op_mnemonic.num_words = Num_words; end set_opcode; end;  pl1_decat_char_.pl1 11/11/89 1103.4r 11/11/89 0803.8 11520 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ pl1_decat_char_: proc(s,c,t) returns(char(*)); dcl (s,c) char(*), t bit(3), (i,l) fixed bin(15), (bin,index,length,substr) builtin; l = length(c); if l=0 then if substr(t,3,1) then goto case(7); else goto case(0); i = index(s,c); if i = 0 then if substr(t,1,1) then goto case(7); else goto case(0); goto case(bin(t)); case(0): return(""); case(1): return(substr(s,i+l)); case(2): return(c); case(3): return(substr(s,i)); case(4): return(substr(s,1,i-1)); case(5): return(substr(s,1,i-1) || substr(s,i+l)); case(6): return(substr(s,1,i+l-1)); case(7): return(s); end;  plus.pl1 11/11/89 1103.4r 11/11/89 0803.9 53415 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Arithmetic active functions FUNCTION VALUE plus A1 A2 ... An 0 + A1 + A2 + ... + An minus A1 A2 A1 - A2 or -A1 if A2 is not specified times A1 A2 ... An 1 * A1 * A2 * ... * An divide A1 A2 trunc(A1 / A2) quotient A1 A2 A1 / A2 mod A1 A2 mod(A1,A2) max A1 A2 ... An max(A1,A2, ..., An) min A1 A2 ... An min(A1,A2, ..., An) trunc A1 trunc(A1) floor A1 floor(A1) ceil A1 ceil(A1) Each Ai is the character string representation of a valid PL/I decimal number, either fixed or float. Calculations are performed internally using float dec(59) arithmetic. The result is in I-, F-, or E-format depending on its value. All of these active functions can be called as functions or as commands, in which case they print the result. Initial Version: 27 January 1974 by Barry L. Wolman */ /* Modified 7/8/76 by S. Herbst */ /* Fixed min and others with no args 07/07/81 S. Herbst */ plus: proc; dcl op char(8) aligned, (number1,number2) float dec(59), result char(72) varying, code fixed bin(35), not_active_function bit(1), (i,count) fixed bin, get_arg variable entry(fixed bin,ptr,fixed bin,fixed bin(35)), (ap,ap1) ptr, (al,al1) fixed bin, answer char(al1) varying based(ap1), arg char(al) based(ap), (mod,max,min,fixed,convert,string,trunc,floor,ceil) builtin, (conversion, overflow, underflow, zerodivide) condition; dcl (cu_$arg_ptr,cu_$af_arg_ptr,cu_$af_return_arg) entry(fixed bin,ptr,fixed bin,fixed bin(35)), cu_$arg_count entry returns(fixed bin), numeric_to_ascii_ entry(float dec(59),fixed bin,char(72) varying), (ioa_,com_err_,active_fnc_err_) options(variable); dcl (error_table_$not_act_fnc, error_table_$wrong_no_of_args) fixed bin(35) ext static; dcl 1 op_type, 2 multi bit(1) unaligned, 2 unary bit(1) unaligned; op = "plus"; string(op_type) = "11"b; goto join; minus: entry; op = "minus"; string(op_type) = "00"b; goto join; times: entry; op = "times"; string(op_type) = "11"b; goto join; divide: entry; op = "divide"; string(op_type) = "00"b; goto join; quotient: entry; op = "quotient"; string(op_type) = "00"b; goto join; mod: entry; op = "mod"; string(op_type) = "00"b; goto join; max: entry; op = "max"; string(op_type) = "10"b; goto join; min: entry; op = "min"; string(op_type) = "10"b; goto join; trunc: entry; op = "trunc"; string(op_type) = "01"b; goto join; floor: entry; op = "floor"; string(op_type) = "01"b; goto join; ceil: entry; op = "ceil"; string(op_type) = "01"b; goto join; join: call cu_$af_return_arg(count,ap1,al1,code); not_active_function = code = error_table_$not_act_fnc; if not_active_function then do; count = cu_$arg_count(); get_arg = cu_$arg_ptr; code = 0; end; else do; if code ^= 0 then go to simple_err; get_arg = cu_$af_arg_ptr; end; if count = 0 then do; if op = "plus" | op = "minus" then number1 = 0; else if op = "times" then number1 = 1; else go to wrong_args; go to output; end; if (count ^= 1 & unary & ^ multi) | (count < 2 & ^ unary & op ^= "minus") | (count > 2 & ^ multi) then do; wrong_args: code = error_table_$wrong_no_of_args; simple_err: if not_active_function then call com_err_ (code, op); else call active_fnc_err_ (code, op); go to exit; end; on conversion goto not_numeric; on overflow goto too_big; on underflow goto too_small; on zerodivide goto zero_divide; call get_arg(1,ap,al,code); if code ^= 0 then call gripe(""); number1 = convert(number1,arg); if count = 1 & op = "minus" then number1 = -number1; if unary then do; if op = "trunc" then number1 = trunc(number1); if op = "floor" then number1 = floor(number1); if op = "ceil" then number1 = ceil(number1); end; do i = 2 to count; call get_arg(i,ap,al,code); if code ^= 0 then call gripe(""); number2 = convert(number2,arg); if op = "plus" then number1 = number1 + number2; if op = "minus" then number1 = number1 - number2; if op = "times" then number1 = number1 * number2; if op = "divide" then number1 = trunc (number1 / number2); if op = "quotient" then number1 = number1 / number2; if op = "mod" then number1 = mod(number1, number2); if op = "max" then number1 = max(number1, number2); if op = "min" then number1 = min(number1, number2); end; output: call numeric_to_ascii_(number1,0,result); if substr (result, 1, 1) = "0" & length (result) > 60 then do; /* trim it so it will work better */ result = substr (result, 1, length (result) - 1); end; if not_active_function then call ioa_(result); else answer = result; return; zero_divide: if not_active_function then call com_err_(0,op,"Attempt to divide by zero."); else call active_fnc_err_(0,op,"Attempt to divide by zero."); return; not_numeric: call gripe("""^a"" is non-numeric"); return; too_big: call gripe("overflow"); return; too_small: call gripe("underflow"); return; gripe: proc(s); dcl s char(*); if not_active_function then call com_err_(code,op,s,arg); else call active_fnc_err_(code,op,s,arg); goto exit; end; exit: end;  relocate_instruction_.pl1 11/11/89 1103.4r 11/11/89 0803.8 67995 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ relocate_instruction_: procedure (from, to, code); /* Fixed to relocate tsxN and tspN instructions properly 04/25/84 S. Herbst */ /* Removed above fix, since it causes some after breaks after calls to be ignored 12/04/84 Steve Herbst */ /* Modified to move code into hardcore for bce, Keith Loepere, March 1985. */ dcl (from pointer, /* to instruction to be relocated */ to pointer, /* location to relocate it to */ p_delta fixed bin (17), /* what to add to instr offset */ p_instruction_len fixed bin, /* length, with eis descr */ p_special fixed bin, /* eis descrs */ code fixed bin (35)) parameter; /* error code */ dcl (op_index, tra_index, tra_target) fixed bin; dcl tra_modifier bit (6) unaligned; dcl (op_name, new_op_name) char (6); dcl delta fixed bin (17); /* offset from "from" to "to" */ dcl relocate_sw bit (1); dcl instruction_len fixed bin; dcl special fixed bin; dcl new_operand bit (36) aligned based (addr (operand)); dcl i fixed bin; dcl (high_bound, low_bound) fixed bin; dcl word bit (36) aligned based; dcl 1 instruction aligned, /* overlay for normal instruction */ 2 address fixed bin (17) unaligned, 2 opcode bit (10) unaligned, 2 inst_pad bit (2) unaligned, 2 modifier bit (6) unaligned; dcl 1 eis_mod aligned, /* format of the modifier */ 2 mod_pad bit (2) unaligned, 2 indirect bit (1) unaligned, 2 register bit (4) unaligned; dcl 1 operand aligned, /* overlay for descriptor or indirect word */ 2 operand_addr fixed bin (17) unaligned, 2 op_pad bit (14) unaligned, 2 operand_reg bit (4) unaligned; dcl mod_offset (3) fixed bin internal static options (constant) init (30, 12, 3); /* offset of modifier fields in an EIS inst */ dcl inst_length_ entry (ptr, fixed bin) returns (fixed bin); dcl error_table_$action_not_performed fixed bin (35) external static; dcl (addr, addrel, bin, bit, fixed, hbound, lbound, rel, string, substr, unspec) builtin; delta = fixed (rel (from), 18, 0) - fixed (rel (to), 18, 0); /* compute for later */ instruction_len = inst_length_ (from, special); if instruction_len = 0 then goto arrgh; common: unspec (instruction) = from -> word; op_index = fixed (instruction.opcode, 10, 0); op_name = op_mnemonic_$op_mnemonic (op_index).opcode; if instruction_len = 1 then do; /* normal instruction, check for ic and ic* modifiers */ relocate_sw = "0"b; if special = 0 then do; if instruction.modifier = "110100"b then /* *ic, cannot relocate target */ goto arrgh; if instruction.modifier = "000100"b | instruction.modifier = "010100"b then do; relocate_sw = "1"b; instruction.address = instruction.address + delta; end; end; /* The following code is commented out because it causes breaks after call statements to be ignored. It was originally put here to prevent the following bug: Suppose you - 1. Set a break after a call statement. 2. Execute the call statement and stop in the called program. 3. Reset the break. 4. Return from the call. You return to the instruction in the break code after the instruction in the break code that actually made the call, but the break code is no longer there. This happened in rare cases to users and caused unsightly faults. One way to do a break after a tsxN or tspN instruction is to really set a before break at the next instruction, but mark it with a flag that tells the rest of probe to pretend that it's an after break at the right instruction. I leave this as a future change. Steve Herbst 12/04/84 */ /*OUT if substr (op_name, 1, 3) = "tsp" | substr (op_name, 1, 3) = "tsx" then do; /*OUT tra_target = instruction.address; /* save the computed target of transfer */ /*OUT if relocate_sw then tra_target = tra_target - 1; /*OUT tra_modifier = instruction.modifier; /*OUT if substr (op_name, 1, 3) = "tsp" then new_op_name = "epp" || substr (op_name, 4, 1); /*OUT else new_op_name = "eax" || substr (op_name, 4, 1); /*OUT /*OUT low_bound = lbound (op_mnemonic_$op_mnemonic, 1); /*OUT high_bound = hbound (op_mnemonic_$op_mnemonic, 1); /*OUT /* find out what number a "tra" is */ /*OUT do i = low_bound to high_bound while /*OUT (op_mnemonic_$op_mnemonic (i).opcode ^= "tra"); end; /*OUT if i > high_bound then go to NOT_TS; /* should never happen */ /*OUT tra_index = i; /*OUT /* now find out what number opcode we're creating */ /*OUT do i = low_bound to high_bound while /*OUT (op_mnemonic_$op_mnemonic (i).opcode ^= new_op_name); end; /*OUT if i > high_bound then go to NOT_TS; /* tsxN with unrecognized N? */ /*OUT /*OUT unspec (instruction) = "0"b; /*OUT instruction.opcode = bit (bin (i, 10), 10); /*OUT instruction.address = fixed (rel (from), 18) + 1; /*OUT instruction.modifier = "000000"b; /*OUT to -> word = unspec (instruction); /*OUT /*OUT instruction.opcode = bit (bin (tra_index, 10), 10); /*OUT instruction.address = tra_target; /*OUT instruction.modifier = tra_modifier; /*OUT addrel (to, 1) -> word = unspec (instruction); /*OUT end; /*OUT else OUT*/ NOT_TS: to -> word = unspec (instruction); /* move it to its new home */ end; else do; /* EIS instruction */ to -> word = unspec (instruction); /* first word requires no relocation */ do i = 1 to special; /* process each descriptor */ string (eis_mod) = substr (unspec (instruction), mod_offset (i), 7); string (new_operand) = addrel (from, i) -> word; /* pick up descriptor or indirect word */ if indirect then do; /* indirect word */ if register = "0100"b then /* descriptor will ultimately have an ic mod */ goto arrgh; /* same problem as *ic */ if operand_reg = "0100"b then /* indirect word has an ic modifier */ operand_addr = operand_addr + delta; end; else if register = "0100"b then /* descriptor with ic mod from instruction */ operand_addr = operand_addr + delta; addrel (to, i) -> word = string (new_operand); /* move this operand to new location */ end; do i = special + 1 to instruction_len - 1; /* process non-EIS descriptors, eg.: arg 100,ic */ unspec (instruction) = addrel (from, i) -> word; if instruction.modifier = "110100"b then /* relocate like a simple instruction */ goto arrgh; if instruction.modifier = "000100"b | instruction.modifier = "010100"b then instruction.address = instruction.address + delta; addrel (to, i) -> word = unspec (instruction); end; end; return; arrgh: code = error_table_$action_not_performed; return; %page; bce_relocate_instruction_: entry (from, to, p_delta, p_instruction_len, p_special, code); delta = p_delta; instruction_len = p_instruction_len; special = p_special; go to common; %page; %include op_mnemonic_format; end relocate_instruction_;  substr.pl1 11/11/89 1103.4rew 11/11/89 0803.9 160434 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(80-10-31,Herbst), approve(), audit(), install(): TR6700 Add uppercase -leading 10/31/80 S. Herbst 2) change(83-10-03,Spitzer), approve(), audit(), install(): TR11275 correct error msg for cpch 10/03/83 C. Spitzer 3) change(84-01-03,Loepere), approve(), audit(), install(): use ioa_ for bce compatibility 01/03/84 K. Loepere 4) change(85-01-04,Lippard), approve(85-01-23,MCR7151), audit(85-11-07,Spitzer), install(86-02-21,MR12.0-1024): Add reverse_substr 01/04/85 Jim Lippard END HISTORY COMMENTS */ substr: procedure; dcl Larg (3) fixed bin, Lret fixed bin, Nargs fixed bin, Npic pic "(10)z9", Parg (3) ptr, Pret ptr, Scommand bit (1) aligned, arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)) variable, args_sw bit (1), bit3 bit(3) aligned, bit4 bit(4) aligned, char3 char(3) aligned, char4 char(4) aligned, (cleanup, conversion) condition, code fixed bin(35), e fixed bin, error entry options (variable) variable, (i, j, n) fixed bin, leading_sw bit (1); dcl arg1 char(Larg(1)) based (Parg(1)), arg2 char(Larg(2)) based (Parg(2)), arg3 char(Larg(3)) based (Parg(3)), ret char(Lret) varying based (Pret); dcl (addr, after, before, bit, bool, character, collate, collate9, convert, copy, decat, high, high9, index, length, low, ltrim, min, null, reverse, rtrim, search, substr, translate, verify) builtin; dcl active_fnc_err_ entry options (variable), com_err_ entry options (variable), (cu_$af_return_arg, cu_$af_arg_ptr, cu_$arg_ptr) entry (fixed bin, ptr, fixed bin, fixed bin(35)), cu_$arg_count entry returns (fixed bin), (get_temp_segment_, release_temp_segment_) entry (char(*), ptr, fixed bin(35)), ioa_ entry() options(variable); dcl UP_A char (2) int static options (constant) init ("^a"), UPPERCASE char (26) aligned int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), LOWERCASE char (26) aligned int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"), (error_table_$bad_arg, error_table_$bad_conversion, error_table_$badopt, error_table_$wrong_no_of_args) fixed bin(35) ext static, ep (28) char(15) int static options(constant) init ( "after", /* Name of entry points supported herein. */ "before", "bool", "collate", "collate9", "copy_characters", "decat", "high", "high9", "index", "length", "low", "lower_case", "ltrim", "reverse", "reverse_after", "reverse_before", "reverse_decat", "reverse_index", "reverse_search", "reverse_substr", "reverse_verify", "rtrim", "search", "substr", "translate", "upper_case", "verify"), max_args (28) fixed bin int static options(constant) init ( 2, 2, 3, 0, 0, 2, 3, 1, 1, 2, 1, 1, 999, 2, 1, 2, 2, 3, 2, 2, 3, 2, 2, 2, 3, 3, 999, 2), min_args (28) fixed bin int static options(constant) init ( 2, 2, 3, 0, 0, 2, 3, 1, 1, 2, 1, 1, 1, 1, 1, 2, 2, 3, 2, 2, 2, 2, 1, 2, 2, 2, 1, 2), options (28) char(52) int static options(constant) init ( "source_string indexing_string", "source_string indexing_string", "bit_string bit_string 4_bit_string", "", "", "string number_of_copies", "source_string indexing_string 3_bit_string", "number_of_copies", "number_of_copies", "source_string indexing_string", "string", "number_of_copies", "strings", "source_string search_string", "string", "source_string indexing_string", "source_string indexing_string", "source_string indexing_string 3_bit_string", "source_string indexing_string", "source_string search_string", "string starting_index_number {length}", "source_string verify_string", "source_string search_string", "source_string search_string", "string starting_index_number {length}", "string translate_to_string {translate_from_string}", "strings", "source_string verify_string"), sys_info$max_seg_size fixed bin(35) ext static; dcl TRUE bit (1) aligned internal static options (constant) init ("1"b), FALSE bit (1) aligned internal static options (constant) init ("0"b); /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ e = 25; /* substr */ go to COMMON; after: af: entry; e = 1; go to COMMON; before: be: entry; e = 2; go to COMMON; bool: entry; e = 3; go to COMMON; collate: entry; e = 4; go to COMMON; collate9: entry; e = 5; go to COMMON; copy_characters: cpch: entry; e = 6; go to COMMON; decat: entry; e = 7; go to COMMON; high: entry; e = 8; go to COMMON; high9: entry; e = 9; go to COMMON; index: entry; e = 10; go to COMMON; length: ln: entry; e = 11; go to COMMON; low: entry; e = 12; go to COMMON; lower_case: lowercase: entry; e = 13; go to COMMON; ltrim: entry; e = 14; go to COMMON; reverse: rv: entry; e = 15; go to COMMON; reverse_after: rvaf: entry; e = 16; go to COMMON; reverse_before: rvbe: entry; e = 17; go to COMMON; reverse_decat: rvdecat: entry; e = 18; go to COMMON; reverse_index: rvindex: entry; e = 19; go to COMMON; reverse_search: rvsrh: entry; e = 20; go to COMMON; reverse_substr: rvsubstr: entry; e = 21; go to COMMON; reverse_verify: rvverify: entry; e = 22; go to COMMON; rtrim: entry; e = 23; go to COMMON; search: srh: entry; e = 24; go to COMMON; translate: entry; e = 26; go to COMMON; upper_case: uppercase: entry; e = 27; go to COMMON; verify: entry; e = 28; go to COMMON; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ COMMON: call cu_$af_return_arg (Nargs, Pret, Lret, code); /* get arg count, see how called, get ret val. */ if code = 0 then do; /* called as an active function. */ error = active_fnc_err_; arg_ptr = cu_$af_arg_ptr; Scommand = FALSE; end; else do; /* called as a command. */ error = com_err_; arg_ptr = cu_$arg_ptr; Scommand = TRUE; Nargs = cu_$arg_count(); Pret = null; on cleanup call janitor(); call get_temp_segment_ (ep(e), Pret, code); if code ^= 0 then go to NO_TEMP_SEG; Lret = (sys_info$max_seg_size - 1) * 4; end; if Nargs < min_args(e) then /* too few input arguments. */ go to wnoa; if Nargs > max_args(e) then /* too many input arguments. */ go to wnoa; do i = 1 to min (Nargs, 3); /* address input arguments. */ call arg_ptr (i, Parg(i), Larg(i), code); end; ret = ""; /* clear return arg. */ go to do(e); /* process according to input requirements. */ do( 1): /* after. */ ret = double_quotes(after(arg1,arg2)); go to return; do( 2): /* before */ ret = double_quotes(before (arg1, arg2)); go to return; do( 3): /* bool */ i = verify(arg1, "01"); if i > 0 then do; i = 1; go to bad_conversion; end; i = verify(arg2, "01"); if i > 0 then do; i = 2; go to bad_conversion; end; if Larg(3) ^= 4 then do; i = 4; go to bad_bit_string; end; char4 = arg3; i = verify(char4, "01"); if i > 0 then do; i = 3; go to bad_conversion; end; bit4 = bit(char4, 4); ret = character(bool(bit(arg1), bit(arg2), bit4)); go to return; do( 4): /* collate */ if Scommand then /* when invoked as a command, print collating seq */ ret = collate(); else do; ret = """"; ret = ret || substr (collate(),1,35); ret = ret || substr (collate(),35); /* double the quote in the quoted string. */ ret = ret || """"; end; go to return; do( 5): /* collate9 */ if Scommand then ret = collate9(); else do; ret = """"; ret = ret || substr (collate(),1,35); ret = ret || substr (collate9(),35); ret = ret || """"; end; go to return; do( 6): /* copy */ on conversion begin; i = 2; go to bad_conversion; end; n = convert(n, arg2); revert conversion; if n < 0 then do; i = 2; go to nonnegative_arg; end; else if n = 0 then; else ret = double_quotes(copy (arg1, n)); go to return; do( 7): /* decat */ if Larg(3) ^= 3 then do; i = 3; go to bad_bit_string; end; char3 = arg3; i = verify (char3, "01"); if i > 0 then do; i = 3; go to bad_conversion; end; bit3 = bit(char3, 3); ret = double_quotes(decat (arg1, arg2, bit3)); go to return; do( 8): /* high */ do( 9): /* high9 */ do(12): /* low */ on conversion begin; i = 1; go to bad_conversion; end; n = convert(n, arg1); revert conversion; if n < 0 then do; i = 1; go to nonnegative_arg; end; else if n = 0 then go to return; else go to do_hl(e); do_hl(8): ret = high(n); go to return; do_hl(9): ret = high9(n); go to return; do_hl(12): ret = low(n); go to return; do(10): /* index */ i = index (arg1, arg2); ret_num: Npic = i; ret = ltrim(Npic); go to return; do(11): /* length */ i = Larg(1); go to ret_num; do(13): /* lower_case */ do i = 1 to Nargs; call arg_ptr (i, Parg (1), Larg (1), 0); if ret ^= "" then ret = ret || " "; ret = ret || double_quotes (translate (arg1, LOWERCASE, UPPERCASE)); end; go to return; do(14): /* ltrim */ if Nargs = 2 then ret = double_quotes(ltrim(arg1, arg2)); else ret = double_quotes(ltrim(arg1)); go to return; do(15): /* reverse */ if Larg(1) <= 0 then; else ret = double_quotes(reverse (arg1)); go to return; do(16): /* reverse after */ if index(arg1, arg2) > 0 then ret = double_quotes(reverse(before(reverse(arg1), reverse(arg2)))); else ret = ""; go to return; do(17): /* reverse before */ if index(arg1, arg2) > 0 then ret = double_quotes(reverse(after(reverse(arg1), reverse(arg2)))); else ret = double_quotes(arg1); go to return; do(18): /* reverse decat */ if Larg(3) ^= 3 then do; i = 3; go to bad_bit_string; end; char3 = arg3; i = verify (char3, "01"); if i > 0 then do; i = 3; go to bad_conversion; end; bit3 = bit(char3, 3); if index(arg1, arg2) > 0 then ret = double_quotes(reverse(decat(reverse(arg1), reverse(arg2), reverse(bit3)))); else ret = double_quotes(decat(arg1, arg2, bit3)); go to return; do(19): /* reverse_index */ i = index (reverse(arg1), reverse(arg2)); if i > 0 then i = Larg(1) - i + 2 - Larg(2); go to ret_num; do(20): /* reverse_search */ i = search (reverse(arg1), arg2); if i > 0 then i = Larg(1) - i + 1; go to ret_num; do(21): /* reverse_substr */ on conversion begin; i = 2; go to bad_conversion; end; i = convert(i, arg2); revert conversion; if Nargs = 3 then do; on conversion begin; i = 3; go to bad_conversion; end; j = convert(j, arg3); revert conversion; end; else j = Larg(1); if i <= 0 then do; i = 2; go to positive_arg; end; else if i > Larg(1) then; else if j < 0 then do; i = 3; go to nonnegative_arg; end; else if j = 0 then; else do; if i+j-1 > Larg(1) then j = Larg(1) - i + 1; ret = double_quotes(reverse (substr (reverse (arg1), i, j))); end; go to return; do(22): /* reverse_verify */ i = verify (reverse(arg1), arg2); if i > 0 then i = Larg(1) - i + 1; go to ret_num; do(23): /* rtrim */ if Nargs = 2 then ret = double_quotes(rtrim(arg1, arg2)); else ret = double_quotes(rtrim(arg1)); go to return; do(24): /* search */ i = search (arg1, arg2); go to ret_num; do(25): /* substr */ on conversion begin; i = 2; go to bad_conversion; end; i = convert(i, arg2); revert conversion; if Nargs = 3 then do; on conversion begin; i = 3; go to bad_conversion; end; j = convert(j, arg3); revert conversion; end; else j = Larg(1); if i <= 0 then do; i = 2; go to positive_arg; end; else if i > Larg(1) then; else if j < 0 then do; i = 3; go to nonnegative_arg; end; else if j = 0 then; else do; if i+j-1 > Larg(1) then j = Larg(1) - i + 1; ret = double_quotes(substr (arg1, i, j)); end; go to return; do(26): /* translate */ if Nargs = 2 then ret = double_quotes(translate (arg1, arg2)); else ret = double_quotes(translate (arg1, arg2, arg3)); go to return; do(27): /* upper_case */ args_sw, leading_sw = "0"b; do i = 1 to Nargs; call arg_ptr (i, Parg (1), Larg (1), 0); if ^args_sw & substr (arg1, 1, 1) = "-" then if arg1 = "-leading" then leading_sw = "1"b; else if arg1 = "-arguments" | arg1 = "-ag" then args_sw = "1"b; else do; call error (error_table_$badopt, "uppercase", "^a", arg1); return; end; else do; args_sw = "1"b; if leading_sw then do; if ret ^= "" then ret = ret || " "; ret = ret || double_quotes (arg1); end; else do; if ret ^= "" then ret = ret || " "; ret = ret || double_quotes (translate (arg1, UPPERCASE, LOWERCASE)); end; end; end; if leading_sw then do; substr (ret, 1, 1) = translate (substr (ret, 1, 1), UPPERCASE, LOWERCASE); do i = 2 to length (ret); if index (LOWERCASE, substr (ret, i, 1)) ^= 0 then if index (UPPERCASE || LOWERCASE || "'-", substr (ret, i - 1, 1)) = 0 then /* lowercase alpha preceded by nonalpha -> upper */ substr (ret, i, 1) = translate (substr (ret, i, 1), UPPERCASE, LOWERCASE); end; end; go to return; do(28): /* verify */ i = verify (arg1, arg2); go to ret_num; return: if Scommand then do; call ioa_ (UP_A, ret); call release_temp_segment_ (ep(e), Pret, code); end; return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ positive_arg: j = 1; go to bad_arg; nonnegative_arg: j = 2; bad_arg: Parg(1) = Parg(i); Larg(1) = Larg(i); call error (error_table_$bad_arg, ep(e), " ^a Argument ^d must be a ^[positive^;nonnegative^] integer.", arg1, i, j); call janitor(); return; wnoa: call error (error_table_$wrong_no_of_args, ep(e), " Usage: ^[[^]^a ^a^[]^]", ^Scommand, ep(e), options(e), ^Scommand); call janitor(); return; NO_TEMP_SEG: call error (code, ep(e), "^/While obtaining a temporary segment."); return; bad_bit_string: call error (error_table_$bad_arg, ep(e), " ^a Third argument must be a bit string of length ^d. Usage: ^[[^]^a ^a^[]^]", arg3, i, ^Scommand, ep(e), options(e), ^Scommand); call janitor(); return; bad_conversion: Parg(1) = Parg(i); Larg(1) = Larg(i); call error (error_table_$bad_conversion, ep(e), " ^a Usage: ^[[^]^a ^a^[]^]", arg1, ^Scommand,ep(e), options(e), ^Scommand); call janitor(); return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ double_quotes: procedure (string) returns (char(*) varying); /* internal procedure to double all quotes in */ /* a string. */ dcl string char(*); dcl (i, j) fixed bin; dcl copied_string char(length(string)*2+2) varying; dcl string_begin char(i-1) based (addr(string_array(j))), string_end char(length(string)-(j-1)) based(addr(string_array(j))), string_array (length(string)) char(1) based (addr(string)); if Scommand then return (string); i = search(string,""""); if i = 0 then return("""" || string || """"); j = 1; copied_string = """"; do while (i > 0); copied_string = copied_string || string_begin; copied_string = copied_string || """"""; j = i+j; i = search (string_end, """"); end; copied_string = copied_string || string_end; copied_string = copied_string || """"; return (copied_string); end double_quotes; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ janitor: procedure; if Scommand & Pret ^= null then call release_temp_segment_ (ep(e), Pret, code); end janitor; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ end substr;  pipe_.pl1 11/11/89 1103.4rew 11/11/89 0803.9 214155 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * ******************************************** */ /****^ HISTORY COMMENTS: 1) change(87-07-08,GWMay), approve(87-07-08,MCR7730), audit(87-08-10,JRGray), install(87-09-10,MR12.1-1104): Created as a service routine for "command_processor_". 2) change(87-09-10,GWMay), approve(87-09-10,MCR7730), audit(87-09-10,GDixon), install(87-09-10,MR12.1-1104): Added any_other handlers and ips interrupt masking. Added the get_word function for more complete analysis of the attach description. Simplified the pipe_info structure. Changed the pipe_info structure pointer to be internal static. Combined the get_string routines into one routine with a command branch. END HISTORY COMMENTS */ /* format: off */ %page; pipe_: proc options (main); /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** Name: pipe_ Function: This subroutine supplies a set of I/O service entrypoints for use by the command processor. All iox_ calls needed to provide the Multics pipe_ facility reside within this module. Entrypoints: pipe_$attach_pipe on the first entry per-process, creates the pipe storage area. Initializes variables and calls the iox_ entries that will attach the target attach description given as a parameter. pipe_$close_pipe calls the iox_ entrys to move the standard input or output switch to the attach state they were in before the pipe_$open_pipe entry was called. pipe_$copy performs a simple loop of calls to iox_ entries to get characters from standard input and put characters to standard output. pipe_$detach_pipe calls the iox_ entries that detach and destroy the io control block created by the pipe_$attach_pipe entrypoint. Frees the information that was used to describe the attachment that is being released. pipe_$get_return_string calls iox_ to get characters from the specified input attachment and adds the information as is to a string defined by parameter input. pipe_$get_return_string_nnl same as pipe_$get_return_string except strips new_line characters. pipe_$initiate builds and returns a unique file name for use as a pipe temporary file. pipe_$open_pipe opens the target attachment made by the pipe_$attach_pipe entry, saves the current attachment of the standard switch in use and attaches the standard switch to the target attachment. pipe_$terminate deletes the pipe temporary files named by the pipe_$initiate entry and reinitializes name values ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: attach_pipe syntax: pipe_$attach_pipe (char(*), bit(1) aligned, bit(1) aligned, ptr, fixed bin(35)); summary: 1) If the user is attempting to attach to user_input or user_output, return an error. 2) Create the pipe data area in system free area and set the pointer to it. 3) Allocate and initiate the pipe_info for this attachment. 4) Call iox_ to make the attachment to the parameter attach description. Default to vfile_ or set the -extend argument based on the parameter control. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ attach_pipe: entry (atd, /* (input) - target attachment */ Sdefault_to_vfile, /* (input) - ON = add "vfile_" */ Sextend, /* (input) - ON = odd "-extend" */ Ppipe_info, /* (output) - pointer to pipe_info */ code); /* (output) - error status */ dcl atd char(*) parameter; dcl Sdefault_to_vfile bit (1) aligned parameter; dcl Sextend bit (1) aligned parameter; dcl match_switch char (32) varying; code = 0; Ppipe_info = null; if atd = "" then return; match_switch = get_word (atd, 2); if match_switch = "user_input" | match_switch = "user_output" then do; code = error_table_$cyclic_syn; return; end; pipe_area_info_ptr_ = get_system_free_area_ (); on cleanup call detach_pipe (Ppipe_info, ignore_code); %page; allocate pipe_info in (pipe_storage_area) set (Ppipe_info); pipe_info.old.Piocb = null; pipe_info.old.switch = SPACE; pipe_info.old.Sdo_not_close = FALSE; /* A unique string is used for the pipe switch to make the mechanism resemble the one use by the command environment when pushing an execution level. */ unique_string = unique_chars_ ("0"b); pipe_info.new.Piocb = null; pipe_info.new.switch = "pipe_new_" || unique_string; pipe_info.new.Sdo_not_close = FALSE; pipe_info.save.switch = "pipe_save_" || unique_string; call iox_$find_iocb (pipe_info.save.switch, pipe_info.save.Piocb, code); pipe_info.save.Sdo_not_close = FALSE; pipe_info.Spipe_file = FALSE; if index (atd, "pipe_file_!") > 0 then pipe_info.Spipe_file = TRUE; if Sdefault_to_vfile then do; if Sextend then call iox_$attach_name (pipe_info.new.switch, pipe_info.new.Piocb, "vfile_ " || before (ltrim(atd), SPACE) || " -extend " || after (ltrim(atd), SPACE), null(), code); else call iox_$attach_name (pipe_info.new.switch, pipe_info.new.Piocb, "vfile_ " || ltrim(atd), null(), code); end; else call iox_$attach_name (pipe_info.new.switch, pipe_info.new.Piocb, atd, null(), code); return; %page; /* Internal to attach_pipe. This routine returns a given word in the character string word_list. The string is always a Multics attach description. */ get_word: proc (word_list, word_to_return) returns (char (32) varying); dcl word_list char (*) unaligned, word_to_return fixed bin, work_list char (1024) varying, word char (32) varying, i fixed bin; /* If the attach description has a target attach, use only the target portion of the string. */ work_list = ltrim (after (word_list, "-target ")); if work_list = "" then work_list = ltrim (word_list); do i = 1 to word_to_return; word = before (work_list, SPACE); work_list = after (work_list, SPACE); work_list = ltrim (work_list); end; return (word); end get_word; %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: close_pipe syntax: pipe_$close_pipe (ptr, bit(1) aligned, fixed bin(35)); summary: 1) Mask interrupts because we are moving standard I/O switches. 2) If the standard switch was attached when we started, move it back to where it was before the open. 3) If the target attachment was opened by the pipe_ subroutine, close it. 4) If the attachment is a pipe temporary file and the truncate option is given, truncate the file. 5) Unmask interrupts. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ close_pipe: entry (Ppipe_info, /* (input) - points to pipe_info */ Struncate, /* (input) - ON = truncate pipe file*/ code); /* (output)- error status */ dcl Struncate bit(1) aligned parameter; code = 0; if Ppipe_info = null then return; if pipe_info.old.Piocb = null then return; if (pipe_info.save.Piocb -> iocb.open_descrip_ptr ^= null & pipe_info.old.Piocb -> iocb.open_descrip_ptr ^= null) then do; ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); call iox_$detach_iocb (pipe_info.old.Piocb, ignore_code); call iox_$move_attach (pipe_info.save.Piocb, pipe_info.old.Piocb, ignore_code); call hcs_$reset_ips_mask (ips_mask, ips_mask); end; if pipe_info.new.Sdo_not_close then; else call iox_$close (pipe_info.new.Piocb, code); %page; if code = 0 then do; if pipe_info.Spipe_file & Struncate then do; call iox_$open (pipe_info.new.Piocb, Stream_input_output, FALSE, code); if code = 0 then do; call iox_$position (pipe_info.new.Piocb, 0, 0, code); if code = 0 then call iox_$control (pipe_info.new.Piocb, "truncate", null, ignore_code); call iox_$close (pipe_info.new.Piocb, ignore_code); end; end; end; return; %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: copy syntax: pipe_$copy (ptr, ptr, fixed bin(35)) summary: 1) If the input or output source is missing, return. 2) Get a temp segment to hold the data from the input source. 3) While there is more data available from the input source, get a block of characters from the input source and output it to the output source. 4) Release the temp segment. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ copy: entry (Pinput, /* (input) - ptr pipe_info of input */ Poutput, /* (input) - ptr pipe_info of output*/ code); /* (output)- error status */ code = 0; if Pinput = null | Poutput = null then return; Pbuffer = null; on cleanup call release_temp_segment_ ("pipe_get_string", Pbuffer, ignore_code); call get_temp_segment_ ("pipe_copy", Pbuffer, ignore_code); Lbuffer = CHARS_PER_SEGMENT; EOF = FALSE; %page; do while (code = 0 & ^EOF); call iox_$get_chars (Pinput -> pipe_info.new.Piocb, Pbuffer, Lbuffer, Lrecord, code); if code = error_table_$short_record then code = 0; if code = error_table_$end_of_info then do; code = 0; EOF = TRUE; end; if Lrecord > 0 then /* If the get_chars operation did not return an error write with code and return any write errors. */ if code = 0 then call iox_$put_chars (Poutput -> pipe_info.new.Piocb, Pbuffer, Lrecord, code); /* Otherwise, flush the buffer and return the get_chars error. */ else call iox_$put_chars (Poutput -> pipe_info.new.Piocb, Pbuffer, Lrecord, ignore_code); end; call release_temp_segment_ ("pipe_copy", Pbuffer, ignore_code); return; %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: detach_pipe syntax: pipe_$detach_pipe (ptr, fixed bin(35)) summary: 1) If not attached, return. 2) Detach the target attachment established by the attach_pipe entry. 3) Destroy any work io control blocks. 4) Free the pipe_info structure for the attachment. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ detach_pipe: entry (Ppipe_info, /* (input) - ptr to pipe_info to det*/ code); /* (output)- error status */ code = 0; if Ppipe_info = null then return; if unspec (pipe_info.new.Piocb) ^= ""b then do; if pipe_info.new.Piocb ^= null then do; if pipe_info.new.Piocb -> iocb.attach_descrip_ptr ^= null then call iox_$detach_iocb (pipe_info.new.Piocb, code); call iox_$destroy_iocb (pipe_info.new.Piocb, ignore_code); end; end; if unspec (pipe_info.new.Piocb) ^= ""b then call iox_$destroy_iocb (pipe_info.save.Piocb, ignore_code); free pipe_info in (pipe_storage_area); Ppipe_info = null; return; %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: get_return_string get_return_string_nnl syntax: get_return_string (ptr, ptr, fixed bin(21), fixed bin(35)) get_return_string_nnl (ptr, ptr, fixed bin(21), fixed bin(35)) function: gets characters from an input source and adds them to a character string. summary: 1) Get a temp segment to hold the data from the input source. 2) While there is more data available from the input source, get a block of characters from the input source and, a) If the remove new line control is on remove the new line character from the input string. b) If there is room in the return string, add the input character string. Otherwise, set the error status. 3) Release the temp segment. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ get_return_string: entry (Pinput, /* (input) - ptr to pipe_info of src*/ Pret_string, /* (input) - ptr to string storage */ Lret_string, /* (input) - available length of str*/ code); /* (input) - error status */ Sremove_new_lines = FALSE; go to GET_STRING_COMMON; get_return_string_nnl: entry (Pinput, /* same as get_return_string */ Pret_string, Lret_string, code); Sremove_new_lines = TRUE; %page; GET_STRING_COMMON: code = 0; if Pinput = null then return; Pbuffer = null; on cleanup call release_temp_segment_ ("pipe_get_string", Pbuffer, ignore_code); call get_temp_segment_ ("pipe_get_string", Pbuffer, ignore_code); Lbuffer = CHARS_PER_SEGMENT; EOF = FALSE; do while (code = 0 & ^EOF); call iox_$get_line (Pinput -> pipe_info.new.Piocb, Pbuffer, Lbuffer, Lrecord, code); if code = error_table_$short_record then code = 0; else if code = error_table_$end_of_info then do; code = 0; EOF = TRUE; end; if length(record) > 0 then do; if Sremove_new_lines then do; if length(ret_string) > 0 then ret_string = ret_string || SPACE; if substr (record, length(record), length (NL)) = NL then Lrecord = Lrecord - length (NL); end; if (length(ret_string) + length(record)) > maxlength(ret_string) then code = error_table_$command_line_overflow; else ret_string = ret_string || record; end; end; call release_temp_segment_ ("pipe_get_string", Pbuffer, ignore_code); return; %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: initiate syntax: pipe_$initiate (ptr) summary: 1) Build a unique pipe temporary file name. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ initiate: entry (Ppipe_atd); /* (input) - ptr to storage for the */ /* pipe temp file pathname*/ dcl Ppipe_atd ptr parameter; dcl pipe_atd char(58) based (Ppipe_atd); if Ppipe_atd = null then return; pipe_atd = rtrim(get_pdir_ ()) || ">pipe_file_" || rtrim(unique_chars_ ("0"b)); return; %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: open_pipe syntax: pipe_$open_pipe (ptr, bit(1) aligned, fixed bin(35)) summary: 1) Determine which standard I/O switch to use based on the INPUT control parameter. 2) Locate the io control block of the switch to be opened. If the iocb cannot be located, there is something wrong, return. 3) Open the target attachment. 4) Save the current attach description of the standard switch so that it can restored by the close_pipe entrypoint. 5) Attach the standard switch "syn_" to the target attachment. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ open_pipe: entry (Ppipe_info, /* (input) - ptr to pipe_info of src*/ INPUT, /* (input) - ON = open for input */ code); /* (output)- error status */ dcl INPUT bit(1) aligned parameter; dcl mode fixed bin; code = 0; if Ppipe_info = null then return; if INPUT then do; pipe_info.old.switch = "user_input"; mode = Stream_input; end; else do; pipe_info.old.switch = "user_output"; mode = Stream_output; end; call iox_$look_iocb (pipe_info.old.switch, pipe_info.old.Piocb, code); if code ^= 0 then return; %page; on cleanup call iox_$close(pipe_info.new.Piocb, code); call iox_$open (pipe_info.new.Piocb, mode, "0"b, code); if code = error_table_$file_already_opened | code = error_table_$not_closed then do; pipe_info.new.Sdo_not_close = TRUE; code = 0; end; if code ^= 0 then return; on cleanup call close_pipe (Ppipe_info, FALSE, ignore_code); ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); call iox_$move_attach (pipe_info.old.Piocb, pipe_info.save.Piocb, code); if code = 0 then do; call iox_$attach_ptr (pipe_info.old.Piocb, "syn_ " || pipe_info.new.switch, null(), code); if code ^= 0 then call close_pipe (Ppipe_info, FALSE, ignore_code); revert cleanup; end; else call iox_$close(pipe_info.new.Piocb, code); call hcs_$reset_ips_mask (ips_mask, ips_mask); return; %page; /* *************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- ****************************************************************************** entryname: terminate syntax: pipe_$terminate (ptr, ptr, fixed bin(35)) summary: 1) If there in an input path, expand the pathname and delete it. Set the pathname to SPACE. 2) If there in an output path, expand the pathname and delete it. Set the pathname to SPACE. ****************************************************************************** ----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|--- *************************************************************************** */ terminate: entry (Ppipein_path, /* (input) - ptr to input path */ Ppipeout_path, /* (input) - ptr to output path */ code); /* (output)- error status */ dcl Ppipein_path ptr parameter, Ppipeout_path ptr parameter; dcl pipe_path char (58) based; code = 0; if Ppipein_path ^= null then if Ppipein_path -> pipe_path ^= SPACE then do; call delete_$path (Ppipein_path -> pipe_path, "", FILES_ONLY_FORCE_NO_QUERY, "", code); Ppipein_path -> pipe_path = SPACE; end; if Ppipeout_path ^= null then if Ppipeout_path -> pipe_path ^= SPACE then do; call delete_$path (Ppipeout_path-> pipe_path, "", FILES_ONLY_FORCE_NO_QUERY, "", code); Ppipeout_path -> pipe_path = SPACE; end; return; %page; dcl Lret_string fixed bin parameter, Pinput ptr parameter, Poutput ptr parameter, Pret_string ptr parameter, code fixed bin(35) parameter, Ppipe_info ptr parameter; dcl pipe_area_info_ptr_ ptr internal static init (null), pipe_storage_area area based (pipe_area_info_ptr_); dcl 1 pipe_info aligned based (Ppipe_info), 2 old, 3 Piocb ptr, 3 switch char(32) unaligned, 3 Sdo_not_close bit (1), 2 new aligned like old, 2 save aligned like old, 2 Spipe_file bit (1); dcl ret_string char (Lret_string) varying based (Pret_string); dcl Pbuffer ptr, Lbuffer fixed bin(21), Lrecord fixed bin(21), record char (Lrecord) based (Pbuffer); dcl EOF bit (1) aligned; dcl Sremove_new_lines bit (1) aligned; dcl ignore_code fixed bin (35); dcl ips_mask bit(36) aligned; dcl unique_string char (15); dcl (after, before, index, length, ltrim, maxlength, null, rtrim, substr, unspec) builtin; dcl (any_other, cleanup) condition; dcl FALSE bit (1) aligned internal static options (constant) init ("0"b), NL char (1) aligned internal static options (constant) init (" "), FILES_ONLY_FORCE_NO_QUERY bit (36) aligned internal static options (constant) init ("100100000000000000000000000000000000"b), SPACE char (1) aligned internal static options (constant) init (" "), TRUE bit (1) aligned internal static options (constant) init ("1"b); %page; dcl (error_table_$command_line_overflow, error_table_$cyclic_syn, error_table_$end_of_info, error_table_$file_already_opened, error_table_$not_closed, error_table_$short_record) fixed bin(35) ext static; dcl delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35)), get_pdir_ entry() returns(char(168)), get_system_free_area_ entry() returns(ptr), get_temp_segment_ entry (char(*), ptr, fixed bin(35)), hcs_$reset_ips_mask entry (bit(36) aligned, bit(36) aligned), hcs_$set_ips_mask entry (bit(36) aligned, bit(36) aligned), release_temp_segment_ entry (char(*), ptr, fixed bin(35)), unique_chars_ entry (bit(*)) returns(char(15)); %page; %include iocb; %page; %include iox_dcls; %page; %include iox_modes; %page; %include system_constants; end pipe_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- 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