abs_io_.pl1 08/11/87 1003.9r w 08/11/87 0926.1 257877 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style3,idind30,ll122,ifthenstmt */ abs_io_$abs_io_attach: procedure (P_iocb_ptr, P_attach_args, P_report_switch, P_status); /****^ HISTORY COMMENTS: 1) change(86-03-01,Gilcrease), approve(86-03-27,MCR7370), audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082): Dummy comment for hcom. Initial coding: 25 June 1979 by J. Spencer Love -no_set_bit_count implemented 07/29/81 S. Herbst -login_channel November 1981 Benson I. Margulies Added $allocate_abs_data & $initialize_abs_data to be called by absentee_listen_$execute_handler 01/07/83 S. Herbst Added -trace, -no_trace, -trace_default to the exec_com command 03/20/84 S. Herbst 2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7370), audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082): Add -truncate to absout files. SCP 6297. 3) change(86-11-11,Gilcrease), approve(86-11-11,PBF7370), audit(86-11-12,Fawcett), install(86-11-12,MR12.0-1214): PBF: user_info_ should not be called if abs_io_ invoked as exec_com. END HISTORY COMMENTS */ /* Parameters */ declare P_iocb_ptr ptr parameter, P_attach_args (*) char (*) varying parameter, P_report_switch bit (1) aligned parameter, P_opening_mode fixed bin parameter, P_abs_data_ptr ptr parameter, P_status fixed bin (35) parameter; /* Builtins */ declare (addr, addrel, divide, empty, hbound, index, length, ltrim, maxlength, min, null, reverse, rtrim, search, size, stackbaseptr, string, substr, unspec, verify) builtin; declare (any_other, area, bad_area_format, bad_area_initialization, cleanup) condition; /* Automatic */ declare abs_entry bit (1) aligned, arg_count fixed bin, arg_str char (100), attach_description_ptr ptr, first_arg fixed bin, idx fixed bin, initialized bit (1), iocb_ptr ptr, login_channel_sw bit (1), mask bit (36), masked_sw bit (1) init ("0"b), no_set_bc_sw bit (1), output_arg fixed bin, path_arg fixed bin, status fixed bin (35), whoami char (32) varying; declare 1 area_data aligned like area_info; %page; /* Constants */ declare NL char (1) static options (constant) initial (" "); declare WHITE char (5) static options (constant) initial (" "); /* FF VT NL TAB SPACE */ /* Static */ declare 1 unable_to_do_io aligned static, 2 version fixed bin initial (0), 2 status_code fixed bin (35); /* Based */ declare attach_descrip char (400) varying; declare attach_description char (length (attach_descrip)) varying based (attach_description_ptr) initial (attach_descrip); declare allocated_chars char (abs_data.allocated_chars_len) based (abs_data.allocated_chars_ptr); declare ec_path char (abs_data.ec_path_len) based (abs_data.ec_path_ptr); declare input_file char (input_string.len) based (input_string.ptr); declare sys_area area based (get_system_free_area_ ()); /* External */ declare abs_io_data_chain_ptr_ ptr external init (null ()); declare ( error_table_$noalloc, error_table_$notalloc, error_table_$bad_mode, error_table_$badopt, error_table_$badpath, error_table_$entlong, error_table_$inconsistent, error_table_$noarg, error_table_$not_detached, error_table_$unable_to_do_io, error_table_$unimplemented_version ) fixed bin (35) external; %page; declare abs_io_control entry (ptr, char (*), ptr, fixed bin (35)); declare abs_io_control$close entry (ptr); declare abs_io_control$set_arguments entry (ptr, (*) char (*) varying, fixed bin, fixed bin (35)); declare abs_io_put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); declare abs_io_put_chars$close entry (ptr, fixed bin (35)); declare abs_io_put_chars$open entry (ptr, char (*), char (*), bit (1), bit (1), fixed bin (35)); declare abs_io_v1_get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); declare abs_io_v2_get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); declare cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); declare cu_$set_cl_intermediary entry (entry); declare define_area_ entry (ptr, fixed bin (35)); declare expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); declare get_system_free_area_ entry () returns (ptr); declare hcs_$initiate_count entry options (variable); declare hcs_$reset_ips_mask entry (bit (36), bit (36)); declare hcs_$set_ips_mask entry (bit (36), bit (36)); declare hcs_$set_max_length_seg entry (pointer, fixed bin (19), fixed bin (35)); declare hcs_$terminate_noname entry (ptr, fixed bin (35)); declare iox_$destroy_iocb entry (ptr, fixed bin (35)); declare iox_$propagate entry (ptr); declare pathname_ entry (char (*), char (*)) returns (char (168)); declare release_area_ entry (ptr); declare requote_string_ entry (char (*)) returns (char (*)); declare user_info_$absout entry (char (*)); declare user_info_$absin entry (char (*)); declare user_info_$login_arg_count entry (fixed bin, fixed bin (21), fixed bin (21)); declare user_info_$login_arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); %page; /* abs_io_$abs_io_attach: procedure (P_iocb_ptr, P_attach_args, P_report_switch, P_status) */ abs_entry = "1"b; whoami = "abs_io_"; go to COMMON; ec_input_$ec_input_attach: entry (P_iocb_ptr, P_attach_args, P_report_switch, P_status); abs_entry = "0"b; whoami = "ec_input_"; COMMON: if unable_to_do_io.status_code = 0 then unable_to_do_io.status_code = error_table_$unable_to_do_io; abs_data_ptr = null (); /* Preset automatic before installing cleanup handler */ initialized = "0"b; mask = ""b; on cleanup call clean_up (); call allocate_abs_data; %page; /* Fill in all pointers as null before enabling cleanup of things within abs_data */ call initialize_abs_data; abs_data.allocated_chars_ptr, abs_data.else_clause_ptr, abs_data.chars_ptr = null; abs_data.instance_chain.prev_ptr, abs_data.instance_chain.next_ptr = null; abs_data.expand_data_ptr, abs_data.ec_data_ptr, abs_data.variables_ptr = null; abs_data.command_line.iocb, abs_data.comment_line.iocb, abs_data.control_line.iocb, abs_data.input_line.iocb = null; abs_data.output_file.fcb_ptr, abs_data.output_file.seg_ptr, abs_data.input_string.ptr = null; arg_info.arg_ptr, arg_info.default_arg_ptr, arg_info.ec_name_ptr, arg_info.ec_path_ptr = null; initialized = "1"b; %page; /* Get some of the arguments */ arg_count = hbound (P_attach_args, 1); /* get size of option array */ first_arg, output_arg, path_arg = 0; login_channel_sw, no_set_bc_sw = "0"b; do idx = 1 to arg_count while (first_arg = 0); arg_str = P_attach_args (idx); if index (arg_str, "-") = 1 then do; /* control arg */ if arg_str = "-argument" | arg_str = "-ag" then first_arg = idx + 1; else if arg_str = "-no_set_bit_count" | arg_str = "-nsbc" then no_set_bc_sw = "1"b; else if arg_str = "-set_bit_count" | arg_str = "-sbc" then no_set_bc_sw = "0"b; else if abs_entry & arg_str = "-login_channel" then login_channel_sw = "1"b; else if arg_str = "-output_file" | arg_str = "-of" then if output_arg ^= 0 then call error (0, whoami, "-output_file specified twice."); else if idx = arg_count then call error (0, whoami, "No value specified for -output_file"); else output_arg, idx = idx + 1; else if arg_str = "-pathname" | arg_str = "-pn" then if path_arg ^= 0 then call error (0, whoami, "More than one pathname specified."); else if idx = arg_count then call error (0, whoami, "No value specified for -pathname"); else path_arg, idx = idx + 1; else if abs_entry & (arg_str = "-single_segment_file" | arg_str = "-ssf") then open_data.ssf = "1"b; else if abs_entry & (arg_str = "-truncate" | arg_str = "-tc") then open_data.truncate = "1"b; else call error (error_table_$badopt, whoami, "^a", arg_str); end; else if path_arg = 0 then path_arg = idx; else first_arg = idx; end; if login_channel_sw then if path_arg > 0 | first_arg > 0 | output_arg > 0 then call error (error_table_$inconsistent, whoami, "-login_channel and other arguments."); else ; else if path_arg = 0 then call error (error_table_$noarg, whoami, "Input file pathname."); if first_arg = 0 then first_arg = arg_count + 1; on area call error (error_table_$noalloc, whoami, "In per-invocation area."); if abs_entry then do; if login_channel_sw then call initiate_input_file_login_channel; else do; if first_arg > arg_count then call error (error_table_$noarg, whoami, "Input file."); call initiate_input_path (first_arg); first_arg = first_arg + 1; end; end; else call initiate_input_path (path_arg); /* Determine version of input file */ if substr (input_file, 1, min (8, input_string.len)) ^= "&version" | search (input_file, WHITE) ^= 9 then do; open_data.parser_version = 1 /* Default_version */; input_string.start, input_string.limit = 0; end; else do; idx = index (substr (input_file, 9), NL); if idx = 0 then call error (error_table_$unimplemented_version, whoami, "Newline must end &version statement."); if verify (substr (input_file, 9, idx - 1), WHITE) = 0 then call error (error_table_$unimplemented_version, whoami, "No version given in &version statement."); open_data.parser_version = cv_dec_check_ (ltrim (rtrim (substr (input_file, 10, idx - 2), WHITE), WHITE), status); if status ^= 0 | open_data.parser_version < 1 /* Lowest_version */ | open_data.parser_version > 2 /* Highest_version */ then call error (error_table_$unimplemented_version, whoami, "&version ""^a""", substr (input_file, 10, idx - 2)); if open_data.parser_version = 1 then input_string.start, input_string.limit = idx + 8; else input_string.start, input_string.limit = idx + 9; /* v2 likes to start at first char */ end; %page; if ^login_channel_sw then if first_arg > 0 & first_arg <= arg_count then do; call abs_io_control$set_arguments (abs_data_ptr, P_attach_args (*), first_arg, status); if status ^= 0 then call error (status, whoami, "Setting arguments:^vs^(^/^a^)", first_arg - 1, P_attach_args (*)); end; else ; else call process_login_arguments; /* Fill in defaults */ abs_data.absentee = abs_entry; abs_data.login_channel = login_channel_sw; open_data.sio = abs_data.absentee; open_data.si = ^abs_data.sio; call set_trace_defaults (); /* generate attach description */ attach_descrip = whoami; if ^login_channel_sw then attach_descrip = attach_descrip || " " || requote_string_ (ec_path); if output_arg > 0 then do; attach_descrip = attach_descrip || " -of "; if abs_data.output_dir ^= ">" then attach_descrip = attach_descrip || rtrim (abs_data.output_dir); attach_descrip = attach_descrip || ">"; attach_descrip = attach_descrip || rtrim (abs_data.output_entry); end; if open_data.truncate then attach_descrip = attach_descrip || " -truncate"; if open_data.ssf then attach_descrip = attach_descrip || " -ssf"; if login_channel_sw then attach_descrip = attach_descrip || " -login_channel"; allocate attach_description in (abs_data.work_area); revert area; %page; /* Now mask down and diddle with IOCB... */ on any_other call any_other_handler; call hcs_$set_ips_mask (mask, mask); masked_sw = "1"b; revert cleanup; iocb_ptr = P_iocb_ptr; if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then call error (error_table_$not_detached, whoami, "IOCB ""^a"" at ^p already attached.", iocb_ptr -> iocb.name, iocb_ptr); iocb_ptr -> iocb.attach_data_ptr = abs_data_ptr; iocb_ptr -> iocb.control = abs_io_control; iocb_ptr -> iocb.attach_descrip_ptr = attach_description_ptr; /* When this is done, we are attached, sort of */ instance_chain.next_ptr = null (); instance_chain.prev_ptr = abs_io_data_chain_ptr_; abs_io_data_chain_ptr_ = abs_data_ptr; if instance_chain.prev_ptr = null () then instance_chain.level = 1; else do; instance_chain.prev_ptr -> instance_chain.next_ptr = abs_data_ptr; instance_chain.level = instance_chain.prev_ptr -> instance_chain.level + 1; end; if no_set_bc_sw then do; status = 0; call abs_io_control (iocb_ptr, "no_set_bc", null (), status); if status ^= 0 then call error (status); end; iocb_ptr -> iocb.open = abs_io_$abs_io_open; iocb_ptr -> iocb.detach_iocb = abs_io_$abs_io_detach; call iox_$propagate (iocb_ptr); /* Tell the world we are attached */ call hcs_$reset_ips_mask (mask, mask); P_status = 0; EGRESS: return; %page; abs_io_$abs_io_open: entry (P_iocb_ptr, P_opening_mode, P_report_switch, P_status); mask = ""b; on any_other call any_other_handler; call hcs_$set_ips_mask (mask, mask); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr; if ^((P_opening_mode = Stream_input & open_data.si) | (P_opening_mode = Stream_input_output & open_data.sio)) then call error (error_table_$bad_mode); if P_opening_mode = Stream_input_output then do; call abs_io_put_chars$open (abs_data_ptr, open_data.output_dir, open_data.output_entry, (open_data.truncate), ^open_data.ssf, status); if status ^= 0 then call error (status); open_data.truncate = "0"b; /* Only truncate on first opening for stream_input_output */ end; if abs_data.allocated_chars_ptr ^= null () then free allocated_chars; unspec (abs_data.if_info) = "0"b; abs_data.chars_ptr, abs_data.else_clause_ptr, abs_data.prev_if_ptr = null (); abs_data.allocated_chars_len, abs_data.chars_len, abs_data.else_clause_len = 0; input_string.position = input_string.start; abs_data.unique_name = ""; iocb_ptr -> iocb.close = abs_io_$abs_io_close; if open_data.parser_version = 1 then iocb_ptr -> iocb.get_line = abs_io_v1_get_line; else iocb_ptr -> iocb.get_line = abs_io_v2_get_line; if P_opening_mode = Stream_input_output then iocb_ptr -> iocb.put_chars = abs_io_put_chars; abs_data.open_description = iox_modes (P_opening_mode); iocb_ptr -> iocb.open_descrip_ptr = addr (abs_data.open_description); /* When this is done, we are open */ call iox_$propagate (iocb_ptr); /* So tell the world, already */ call hcs_$reset_ips_mask (mask, mask); P_status = 0; if abs_data.absentee & abs_data.login_channel then begin; /* do special absentee environment stuff */ declare print_abs_msg_$login entry; call print_abs_msg_$login; call hcs_$set_max_length_seg (stackbaseptr (), (248 * 1024), (0)); call cu_$set_cl_intermediary (reenter_environment); end; return; %page; abs_io_$abs_io_close: entry (P_iocb_ptr, P_status); mask = ""b; on any_other call any_other_handler; call hcs_$set_ips_mask (mask, mask); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr; if output_file.seg_ptr ^= null () then do; call abs_io_put_chars$close (abs_data_ptr, status); if status ^= 0 then call error (status); end; if abs_data.attach.target_ptr ^= null () then call abs_io_control$close (abs_data_ptr); abs_data.active, abs_data.eof = "0"b; /* Reinit per opening variables in case new opening */ abs_data.nest_level, abs_data.expected_nest_level = 0; /* for Version 1 &if-&then-&else nesting */ iocb_ptr -> iocb.open = abs_io_$abs_io_open; iocb_ptr -> iocb.detach_iocb = abs_io_$abs_io_detach; iocb_ptr -> iocb.open_descrip_ptr = null (); /* When this is done, we are closed */ call iox_$propagate (iocb_ptr); /* So tell the world, already */ call hcs_$reset_ips_mask (mask, mask); P_status = 0; return; %page; abs_io_$abs_io_detach: entry (P_iocb_ptr, P_status); mask = ""b; on any_other call any_other_handler; call hcs_$set_ips_mask (mask, mask); iocb_ptr = P_iocb_ptr; abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr; iocb_ptr -> iocb.attach_descrip_ptr = null (); /* When this is done, we are detached */ call iox_$propagate (iocb_ptr); /* So tell the world, already */ if instance_chain.prev_ptr ^= null () then instance_chain.prev_ptr -> instance_chain.next_ptr = instance_chain.next_ptr; if instance_chain.next_ptr ^= null () then instance_chain.next_ptr -> instance_chain.prev_ptr = instance_chain.prev_ptr; else abs_io_data_chain_ptr_ = instance_chain.prev_ptr; initialized = "1"b; /* For clean_up */ on cleanup call clean_up (); /* Do BEFORE unmasking to prevent race window */ call hcs_$reset_ips_mask (mask, mask); call clean_up (); P_status = 0; return; %page; abs_io_$allocate_abs_data: entry (P_abs_data_ptr); call allocate_abs_data; P_abs_data_ptr = abs_data_ptr; return; abs_io_$initialize_abs_data: entry (P_abs_data_ptr); abs_data_ptr = P_abs_data_ptr; whoami = "ec_input_"; call initialize_abs_data; return; %page; reenter_environment: entry; call reenter (); return; %page; allocate_abs_data: proc; on area call error (error_table_$noalloc, whoami, "In system area."); on bad_area_format call error (error_table_$notalloc, whoami, "In system area."); on bad_area_initialization call error (error_table_$notalloc, whoami, "In system area."); allocate abs_data in (sys_area); revert area; revert bad_area_format; revert bad_area_initialization; unspec (abs_data) = "0"b; abs_data.version = abs_data_version_1; /* This is version of STRUCTURE */ end allocate_abs_data; %page; any_other_handler: procedure (); declare continue_to_signal_ entry (fixed bin (35)); declare terminate_process_ entry (char (*), ptr); if substr (mask, 36, 1) then call terminate_process_ ("fatal_error", addr (unable_to_do_io)); else call continue_to_signal_ ((0)); return; end any_other_handler; %page; clean_up: procedure (); declare p ptr; if abs_data_ptr ^= null () then do; if initialized then do; if abs_data.attach.save_ptr ^= null () then call iox_$destroy_iocb (abs_data.attach.save_ptr, status); p = input_string.ptr; /* TEMP: this can be removed when terminate_noname is fixed */ input_string.ptr = null (); if p ^= null () then call hcs_$terminate_noname (p, status); call release_area_ (addr (abs_data.work_area)); end; free abs_data; end; return; end clean_up; %page; error: procedure () options (variable); declare status_ptr ptr; declare status_arg fixed bin (35) based (status_ptr); declare arg_list_arg_count fixed bin; declare message character (256); declare com_err_ entry () options (variable); declare sub_err_ entry () options (variable); declare ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary, bit (1) aligned, bit (1) aligned); declare cu_$arg_count entry (fixed bin, fixed bin (35)); declare cu_$arg_list_ptr entry () returns (ptr); declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); declare cu_$generate_call entry (entry, ptr); if masked_sw then call hcs_$reset_ips_mask (mask, mask); /* prevent calling com_err_ while masked */ call cu_$arg_ptr (1, status_ptr, (0), (0)); call cu_$arg_count (arg_list_arg_count, (0)); P_status = status_arg; if arg_list_arg_count = 1 & P_report_switch then call com_err_ (P_status, whoami); else if P_report_switch then call cu_$generate_call (com_err_, cu_$arg_list_ptr ()); else do; call ioa_$general_rs (cu_$arg_list_ptr (), 3, 4, message, (0), "1"b, "0"b); call sub_err_ (P_status, (whoami), "s", null (), (0), "^a", message); end; call clean_up (); go to EGRESS; end error; %page; initialize_abs_data: proc; dcl (user_info_$absentee_restarted, user_info_$absout_truncation) entry (bit (1) aligned); dcl (restarted, truncate) bit (1) aligned; /* Initializes just the things that need to be initialized for any ec execution, including the execution of an &on unit by absentee_listen_$execute_handler. */ abs_data.io_module_name = whoami; abs_data.labels_ptr, abs_data.first_xlabel_ptr, abs_data.last_xlabel_ptr = null; abs_data.current_lex_block_ptr, abs_data.current_proc_block_ptr = null; abs_data.last_block_ptr, abs_data.current_loop_ptr, abs_data.last_loop_ptr, abs_data.saved_state_ptr = null; abs_data.attach.target_ptr, abs_data.attach.victim_ptr, abs_data.attach.save_ptr = null; abs_data.cleanup_handler_ptr, abs_data.first_handler_ptr = null; if abs_entry then do; /* Only call user_info_ if not exec_com invocation */ call user_info_$absentee_restarted (restarted); call user_info_$absout_truncation (truncate); if truncate then if ^restarted then abs_data.truncate = "1"b; end; /* Fill in structure for call to make abs_data.work_area extensible */ area_data.version = area_info_version_1; string (area_data.control) = ""b; area_data.extend = "1"b; area_data.zero_on_free = "1"b; area_data.owner = whoami; area_data.size = Work_area_size; area_data.areap = addr (abs_data.work_area); call define_area_ (addr (area_data), status); if status ^= 0 then call error (status, whoami, "Initializing work area."); end initialize_abs_data; %page; initiate_input_path: procedure (path_idx); declare path_idx fixed bin parameter; declare absin_len fixed bin, arg_len fixed bin (21), arg_ptr ptr, arg char (arg_len) based (arg_ptr), bit_count fixed bin (24), input_dir char (168), input_dir_len fixed bin (21), input_entry char (32), input_entry_len fixed bin (21); arg_ptr = addrel (addr (P_attach_args (path_idx)), 1); arg_len = length (rtrim (P_attach_args (path_idx))); if arg_len = 0 then call error (error_table_$badpath, whoami, "Input filename blank."); call expand_pathname_ (arg, input_dir, input_entry, status); if status ^= 0 then call error (status, whoami, "Input file: ^a", arg); go to common; initiate_input_file_login_channel: entry; declare absin_path character (168); call user_info_$absin (absin_path); call expand_pathname_ (absin_path, input_dir, input_entry, status); if status ^= 0 then call error (status, whoami, "Input file: ^a", absin_path); common: call hcs_$initiate_count (input_dir, input_entry, "", bit_count, 0, input_string.ptr, status); if input_string.ptr = null () then call error (status, whoami, "Input file: ^a", pathname_ (input_dir, input_entry)); input_string.len = divide (bit_count, 9, 21, 0); /* Fill in &ec_path (&0), &ec_name */ abs_data.ec_path_quotes, abs_data.ec_name_quotes = -1; input_dir_len = length (rtrim (input_dir)); input_entry_len = length (rtrim (input_entry)); if input_dir_len = 1 then abs_data.ec_path_len = 1 + input_entry_len; else abs_data.ec_path_len = input_dir_len + 1 + input_entry_len; allocate ec_path in (abs_data.work_area); substr (ec_path, 1, input_dir_len) = substr (input_dir, 1, input_dir_len); if input_dir_len > 1 then do; substr (ec_path, input_dir_len + 1, 1) = ">"; input_dir_len = input_dir_len + 1; end; abs_data.ec_name_ptr = addr (substr (ec_path, input_dir_len + 1)); substr (ec_path, input_dir_len + 1, input_entry_len) = substr (input_entry, 1, input_entry_len); input_dir_len = input_dir_len + input_entry_len; abs_data.ec_name_len = input_entry_len - index (reverse (substr (input_entry, 1, input_entry_len)), "."); if abs_data.ec_name_len = 0 then call error (error_table_$badpath, whoami); /* Fill in pathname of output file, in case needed. */ if abs_entry then if login_channel_sw | output_arg > 0 then do; if output_arg > 0 then call expand_pathname_ ((P_attach_args (output_arg)), open_data.output_dir, open_data.output_entry, status); else do; call user_info_$absout (absin_path); call expand_pathname_ (absin_path, open_data.output_dir, open_data.output_entry, status); end; if status ^= 0 then call error (status, whoami, "Output file ""^a""", P_attach_args (output_arg)); end; else do; abs_data.output_dir = input_dir; input_entry_len = input_entry_len - index (reverse (substr (input_entry, 1, input_entry_len)), "."); absin_len = length (".absin"); if input_entry_len > absin_len then /* prevent name.absin.absout */ if substr (input_entry, input_entry_len - absin_len + 1, absin_len) = ".absin" then input_entry_len = input_entry_len - absin_len; if input_entry_len + length (".absout") > maxlength (input_entry) then call error (error_table_$entlong, whoami); substr (open_data.output_entry, 1, input_entry_len) = substr (input_entry, 1, input_entry_len); substr (open_data.output_entry, input_entry_len + 1) = ".absout"; end; else open_data.output_dir, open_data.output_entry = ""; return; end initiate_input_path; %page; process_login_arguments: procedure; declare n_args fixed bin; declare arg_len fixed bin (21); declare max_arg_len fixed bin (21); declare argx fixed bin; call user_info_$login_arg_count (n_args, max_arg_len, (0)); if n_args = 0 then return; /* Nuthin to do */ begin; declare args (n_args) char (max_arg_len) varying; declare arg_ptr pointer; declare arg character (arg_len) based (arg_ptr); do argx = 1 to n_args; call user_info_$login_arg_ptr (argx, arg_ptr, arg_len, (0)); args (argx) = arg; end; call abs_io_control$set_arguments (abs_data_ptr, args, 1, status); if status ^= 0 then call error (status, whoami, "Setting arguments:^(^/^a^)", args); end; end process_login_arguments; %page; reenter: procedure; /* this procedure intercepts all attempts to reenter the environment in an absentee process, the process is logged out with a special message */ /* THERE IS CODE HERE COPIED FROM LOGOUT */ /* so that the special error code can be put in the structures. */ /* someday there should be logout_ */ declare error_table_$abs_reenter fixed bin (35) ext; declare convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned); declare execute_epilogue_ entry (bit (1) aligned); declare print_abs_msg_$logout entry; declare ioa_ entry () options (variable); declare terminate_process_ entry (character (*), pointer); declare signal_ entry options (variable); declare try_message bit (1) aligned internal static init ("1"b); declare long character (100) aligned; declare 1 FINISH_INFO aligned like finish_info; dcl 1 term_structure aligned, /* action for process termination */ 2 version fixed bin init (0), /* indicates version of structure */ 2 ec fixed bin (35); if try_message then do; try_message = "0"b; call convert_status_code_ (error_table_$abs_reenter, "", long); call ioa_ ("^/^a", long); call print_abs_msg_$logout; end; FINISH_INFO.length = size (FINISH_INFO); FINISH_INFO.version = 1; FINISH_INFO.info_string = ""; unspec (FINISH_INFO.action_flags) = ""b; FINISH_INFO.status_code = error_table_$abs_reenter; call signal_ ("finish", null (), addr (FINISH_INFO)); call execute_epilogue_ ("0"b); /* The "0"b says not just a run unit */ term_structure.ec = error_table_$abs_reenter; call terminate_process_ ("fatal_error", addr (term_structure)); /* log the process out */ end reenter; %page; set_trace_defaults: proc; /* Fills in default tracing modes */ dcl default_mode bit (1); if abs_data.ec_data_ptr = null then default_mode = "1"b; else if abs_data.ec_data_ptr -> ec_data.active_function then default_mode = "0"b; else default_mode = "1"b; call set_default (abs_data.command_line, default_mode, EXPANDED); call set_default (abs_data.comment_line, "0"b, UNEXPANDED); call set_default (abs_data.control_line, "0"b, UNEXPANDED); call set_default (abs_data.input_line, default_mode, EXPANDED); return; set_default: proc (P_line, P_mode, P_expand); dcl 1 P_line aligned like abs_data.command_line; dcl P_mode bit (1); dcl P_expand fixed bin; P_line.on = P_mode; P_line.expand = P_expand; P_line.prefix = ""; end set_default; end set_trace_defaults; %page; %include abs_io_data; %page; %include area_info; %page; %include condition_info_header; %page; %include ec_data; %page; %include finish_info; %page; %include iocb; %page; %include iox_modes; end abs_io_$abs_io_attach;  abs_io_control.pl1 08/11/87 1003.9r w 08/11/87 0925.9 150966 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style3,idind30,ll122,ifthenstmt */ abs_io_control: procedure (P_iocb_ptr, P_order, P_info_ptr, P_status); /* Initial coding: 25 June 1979 by J. Spencer Love */ /* Modified: 12 June 1980 by J. Spencer Love to add sleep and close entrypoints, and to handle io_call orders */ /* Control order "no_set_bc" added for "ear -no_set_bit_count" 07/29/81 S. Herbst */ /* Incorrect COMMAND and FUNCTION labels sorted out 07/28/82 S. Herbst */ /* Recompiled for changed abs_data structure 04/12/83 S. Herbst */ /* Added "set_trace" control order to implement ec -trace 05/03/84 S. Herbst */ /* Parameters */ declare P_iocb_ptr ptr parameter, P_attach_data_ptr ptr parameter, P_order char (*) parameter, P_arg_array (*) char (*) varying parameter, P_info_ptr ptr parameter, P_first_arg fixed bin parameter, P_status fixed bin (35) parameter; /* Builtin */ declare (addr, fixed, hbound, lbound, length, null, substr, unspec) builtin; declare (area, any_other, bad_area_format, bad_area_initialization) condition; /* Automatic */ declare arg_array_ptr ptr, arg_array_size fixed bin, arg_idx fixed bin, factor float bin, first_arg fixed bin, info_ptr ptr, iocb_ptr ptr, mask bit (36), order fixed bin, sleep_time fixed bin (71), status fixed bin (35); /* External */ declare ( error_table_$badcall, error_table_$badopt, error_table_$no_operation, error_table_$noalloc, error_table_$notalloc, error_table_$unable_to_do_io, error_table_$undefined_order_request ) fixed bin (35) external, iox_$user_input ptr external; %page; /* Based */ declare attach_descrip char (256) varying based; declare 1 timed_input based (info_ptr), 2 low_sleep_time fixed bin (35), 2 sleep_time_range fixed bin (35), 2 seed fixed bin (35); declare 1 arg_array (arg_array_size) aligned based (arg_array_ptr), 2 ptr ptr, 2 len fixed bin (21), 2 quotes fixed bin (21); declare arg_string char (arg_array (arg_idx).len) based (arg_array (arg_idx).ptr); declare 1 set_args aligned based (info_ptr), 2 count fixed bin, 2 e (0 refer (set_args.count)), 3 ptr ptr unaligned, 3 len fixed bin (21); %page; /* Constants */ declare Orders (11) char (32) varying static options (constant) initial ("attach", "detach", "set_ec_data_ptr", "set_argument_ptrs", "set_arguments", "timed_input", "io_call", "io_call_af", "no_set_bc", "set_bc", "set_trace"); declare Active (11) bit (1) aligned static options (constant) initial ((3) ("1"b), (2) ("0"b), (6) ("1"b)); declare Open (11) bit (1) aligned static options (constant) initial ((11) ("1"b)); declare Closed (11) bit (1) aligned static options (constant) initial ((2) ("0"b), (9) ("1"b)); declare Info (0:11) bit (1) aligned static options (constant) initial ((3) ("0"b), (9) ("1"b)); declare Null (0:11) bit (1) aligned static options (constant) initial ((4) ("1"b), (5) ("0"b), (2) ("1"b), "0"b); declare Command (0:11) bit (1) aligned static options (constant) initial ((3) ("1"b), (2) ("0"b), (7) ("1"b)); declare Function (0:11) bit (1) aligned static options (constant) initial ("1"b, (6) ("0"b), (5) ("1"b)); /* Entries */ declare continue_to_signal_ entry (fixed bin (35)), hcs_$reset_ips_mask entry (bit (36), bit (36)), hcs_$set_ips_mask entry (bit (36), bit (36)), iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)), iox_$detach_iocb entry (ptr, fixed bin (35)), iox_$find_iocb entry (char (*), ptr, fixed bin (35)), iox_$move_attach entry (ptr, ptr, fixed bin (35)), random_$uniform entry (fixed bin (35), float bin), terminate_process_ entry (char (*), ptr), timer_manager_$sleep entry (fixed bin (71), bit (2)); %page; /* abs_io_control: procedure (P_iocb_ptr, P_order, P_info_ptr, P_status); */ iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr; ec_data_ptr = abs_data.ec_data_ptr; info_ptr = P_info_ptr; mask = ""b; status = 0; order = interpret_order (P_order); if (info_ptr ^= null () & Info (order)) | (info_ptr = null () & Null (order)) then go to ORDER (order); ORDER (0): /* 0 subscript is for undefined order */ COMMAND (0): FUNCTION (0): COMMAND (7): /* io_call order may not specify io_call or io_call_af */ FUNCTION (7): COMMAND (8): /* io_call_af order may not specify io_call or io_call_af */ FUNCTION (8): FUNCTION (9): FUNCTION (10): NO_OPERATION: /* Come here if operation cannot be performed now */ status = error_table_$no_operation; go to EGRESS; CALL_BACK_LATER: status = error_table_$undefined_order_request; go to EGRESS; BAD_CALL: /* Come here to reject input data structure */ status = error_table_$badcall; go to EGRESS; AREA_FULL: /* come here for area condition */ status = error_table_$noalloc; go to EGRESS; BAD_AREA: /* come here for bad_area_format or bad_area_initialization */ status = error_table_$notalloc; EGRESS: if substr (mask, 36, 1) then call hcs_$reset_ips_mask (mask, mask); P_status = status; return; %page; interpret_order: procedure (P_order) returns (fixed bin); declare P_order char (*), order fixed bin; do order = lbound (Orders, 1) to hbound (Orders, 1); if Orders (order) = P_order then if (iocb_ptr -> iocb.open_descrip_ptr = null () & ^Closed (order)) | (iocb_ptr -> iocb.open_descrip_ptr ^= null () & ^abs_data.active & ^Open (order)) | (abs_data.active & ^Active (order)) then return (0); else return (order); end; return (0); end interpret_order; %page; /* ORDER = "set_ec_data_ptr" This order is used to estabish communication between listeners and abs_io_. */ ORDER (3): if info_ptr ^= null then do; if info_ptr -> ec_data.version ^= ec_data_version_1 then go to BAD_CALL; if info_ptr -> ec_data.version_id ^= ec_data_version_id then go to BAD_CALL; end; abs_data.ec_data_ptr = info_ptr; go to EGRESS; %page; /* ORDER = "timed_input" This is used to simulate interactive usage by going blocked on each get_line call */ ORDER (6): if timed_input.sleep_time_range < 0 then go to BAD_CALL; abs_data.timed_input = (timed_input.low_sleep_time + timed_input.sleep_time_range > 0); if ^abs_data.timed_input then go to EGRESS; abs_data.low_sleep_time = timed_input.low_sleep_time; abs_data.sleep_time_range = timed_input.sleep_time_range; abs_data.seed = timed_input.seed; go to EGRESS; COMMAND (6): if io_call_info.nargs ^= 1 then do; call io_call_info.error (0, io_call_info.caller_name, "One of ""-on"" or ""-off"" must be given."); go to EGRESS; end; if io_call_info.args (1) = "-off" then abs_data.timed_input = "0"b; else if io_call_info.args (1) = "-on" then abs_data.timed_input = (abs_data.low_sleep_time + abs_data.sleep_time_range > 0); else call io_call_info.error (error_table_$badopt, io_call_info.caller_name, "^a", io_call_info.args (1)); go to EGRESS; /* This entrypoint is used to simulate interactive waits. Waits are uniformly distributed over a range. The range can overlap zero so that some specified percentage of calls will result in no wait (to simulate type ahead). The only thing it lacks is the priority boost that is caused by a real interaction. This feature is used for benchmarking. */ abs_io_control$sleep: entry (P_attach_data_ptr); abs_data_ptr = P_attach_data_ptr; call random_$uniform (abs_data.seed, factor); sleep_time = fixed (factor * abs_data.sleep_time_range, 71) + abs_data.low_sleep_time; if sleep_time > 0 then call timer_manager_$sleep (sleep_time, "10"b); return; %page; attach: entry (P_attach_data_ptr, P_info_ptr, P_status); abs_data_ptr = P_attach_data_ptr; ec_data_ptr = abs_data.ec_data_ptr; info_ptr = P_info_ptr; mask = ""b; status = 0; ORDER (1): on any_other call any_other_handler (); call hcs_$set_ips_mask (mask, mask); if ec_data_ptr = null () then go to NO_OPERATION; if abs_data.attach.target_ptr ^= null () then go to NO_OPERATION; if abs_data.attach.save_ptr = null () then do; call iox_$find_iocb (ec_data.id_string || "." || abs_data.io_module_name, abs_data.attach.save_ptr, status); if status ^= 0 then go to EGRESS; end; abs_data.attach.victim_ptr = iox_$user_input; call iox_$move_attach (abs_data.attach.victim_ptr, abs_data.attach.save_ptr, status); if status ^= 0 then go to EGRESS; abs_data.attach.target_ptr = ec_data.switch_ptr; call iox_$attach_ptr (abs_data.attach.victim_ptr, "syn_ " || abs_data.attach.target_ptr -> iocb.name, null (), status); if status ^= 0 then do; call iox_$move_attach (abs_data.attach.save_ptr, abs_data.attach.victim_ptr, (0)); abs_data.attach.target_ptr = null (); go to EGRESS; end; call hcs_$reset_ips_mask (mask, mask); go to EGRESS; COMMAND (1): if io_call_info.nargs > 0 then do; call io_call_info.error (0, io_call_info.caller_name, "No arguments are permitted for ""attach""."); go to EGRESS; end; go to ORDER (1); %page; abs_io_control$detach: entry (P_attach_data_ptr, P_info_ptr, P_status); abs_data_ptr = P_attach_data_ptr; info_ptr = P_info_ptr; mask = ""b; status = 0; ORDER (2): on any_other call any_other_handler (); call hcs_$set_ips_mask (mask, mask); status = detach (); call hcs_$reset_ips_mask (mask, mask); go to EGRESS; COMMAND (2): /* "io control &ec_switch detach" */ if io_call_info.nargs > 0 then do; call io_call_info.error (0, io_call_info.caller_name, "No arguments are permitted for ""detach""."); go to EGRESS; end; on any_other call any_other_handler (); call hcs_$set_ips_mask (mask, mask); status = detach (); call hcs_$reset_ips_mask (mask, mask); if status ^= 0 then call io_call_info.error (status, io_call_info.caller_name, "Detaching."); status = 0; go to EGRESS; abs_io_control$close: entry (P_attach_data_ptr); abs_data_ptr = P_attach_data_ptr; status = detach (); call iox_$detach_iocb (abs_data.attach.save_ptr, (0)); return; %page; detach: procedure () returns (fixed bin (35)); if abs_data.attach.target_ptr = null () then return (error_table_$no_operation); if abs_data.attach.victim_ptr -> iocb.attach_descrip_ptr -> attach_descrip ^= "syn_ " || abs_data.attach.target_ptr -> iocb.name then return (error_table_$badcall); call iox_$detach_iocb (abs_data.attach.victim_ptr, status); if status ^= 0 then return (status); call iox_$move_attach (abs_data.attach.save_ptr, abs_data.attach.victim_ptr, status); if status ^= 0 then do; call iox_$attach_ptr (abs_data.attach.victim_ptr, "syn_ " || abs_data.attach.target_ptr -> iocb.name, null (), (0)); return (status); end; abs_data.attach.target_ptr, abs_data.attach.victim_ptr = null (); return (0); end detach; %page; /* ORDER = "set_argument_ptrs" Set ptrs and lengths of arguments from info structure without copying for efficiency */ ORDER (4): call release_args (); arg_array_size = set_args.count; call allocate_arg_array (); arg_array (*).len = set_args (*).len; arg_array (*).ptr = set_args (*).ptr; arg_array (*).quotes = -1; abs_data.arg_count = arg_array_size; abs_data.args_copied = "0"b; abs_data.arg_ptr = arg_array_ptr; go to EGRESS; /* ORDER = "set_arguments" Used to set arguments from structure of pointers and lengths, copying them into work_area */ ORDER (5): call release_args (); arg_array_size = set_args.count; call allocate_arg_array (); do arg_idx = 1 to arg_array_size; arg_array (arg_idx).len = set_args (arg_idx).len; arg_array (arg_idx).quotes = -1; allocate arg_string in (abs_data.work_area); arg_string = set_args (arg_idx).ptr -> arg_string; end; abs_data.arg_count = arg_array_size; abs_data.args_copied = "1"b; abs_data.arg_ptr = arg_array_ptr; go to EGRESS; COMMAND (5): call release_args (); arg_array_size = io_call_info.nargs; call allocate_arg_array (); do arg_idx = 1 to arg_array_size; arg_array (arg_idx).len = length (io_call_info.args (arg_idx)); arg_array (arg_idx).quotes = -1; allocate arg_string in (abs_data.work_area); arg_string = io_call_info.args (arg_idx); end; abs_data.arg_count = arg_array_size; abs_data.args_copied = "1"b; abs_data.arg_ptr = arg_array_ptr; go to EGRESS; %page; /* This entrypoint is used by abs_io_attach to set arguments which are given on in the attach description */ set_arguments: entry (P_attach_data_ptr, P_arg_array, P_first_arg, P_status); abs_data_ptr = P_attach_data_ptr; first_arg = P_first_arg; mask = ""b; status = 0; if first_arg <= 0 then go to EGRESS; call release_args (); arg_array_size = hbound (P_arg_array, 1) - first_arg + 1; call allocate_arg_array (); do arg_idx = 1 to arg_array_size; arg_array (arg_idx).len = length (P_arg_array (arg_idx + first_arg - 1)); arg_array (arg_idx).quotes = -1; allocate arg_string in (abs_data.work_area); arg_string = P_arg_array (arg_idx + first_arg - 1); end; abs_data.arg_count = arg_array_size; abs_data.args_copied = "1"b; abs_data.arg_ptr = arg_array_ptr; go to EGRESS; %page; /* This internal procedure is used to allocate argument info with condition handlers */ allocate_arg_array: procedure (); if arg_array_size <= 0 then go to EGRESS; on area go to AREA_FULL; on bad_area_format go to BAD_AREA; on bad_area_initialization go to BAD_AREA; allocate arg_array in (abs_data.work_area); return; end allocate_arg_array; /* This internal procedure is used by the argument setting routines to release storage that previously held arguments */ release_args: procedure (); arg_array_ptr = abs_data.arg_ptr; arg_array_size = abs_data.arg_count; abs_data.arg_ptr = null (); abs_data.arg_count = 0; if abs_data.args_copied then do arg_idx = 1 to arg_array_size; free arg_string; end; if arg_array_ptr ^= null () then free arg_array; return; end release_args; %page; /* ORDER = "io_call" */ ORDER (7): io_call_infop = info_ptr; if io_call_info.version ^= 1 then go to NO_OPERATION; order = interpret_order ((io_call_info.order_name)); if Command (order) then go to COMMAND (order); go to CALL_BACK_LATER; /* ORDER = "io_call_af" */ ORDER (8): io_call_infop = info_ptr; if io_call_info.version ^= 1 then go to NO_OPERATION; order = interpret_order ((io_call_info.order_name)); if Function (order) then go to FUNCTION (order); go to CALL_BACK_LATER; %page; /* ORDER = "no_set_bc" */ ORDER (9): COMMAND (9): abs_data.open_data.no_set_bc = "1"b; go to EGRESS; /* ORDER = "set_bc" */ ORDER (10): COMMAND (10): abs_data.open_data.no_set_bc = "0"b; go to EGRESS; %page; /* ORDER = "set_trace" */ ORDER (11): call set_trace (info_ptr -> ec_trace_info.command_line, abs_data.command_line); call set_trace (info_ptr -> ec_trace_info.comment_line, abs_data.comment_line); call set_trace (info_ptr -> ec_trace_info.control_line, abs_data.control_line); call set_trace (info_ptr -> ec_trace_info.input_line, abs_data.input_line); go to EGRESS; %page; set_trace: proc (P_info_line, P_abs_line); /* This internal procedure copies the elements of ec_trace_info into the trace portion of abs_data trace */ dcl 1 P_info_line aligned like ec_trace_info.command_line; dcl 1 P_abs_line aligned like abs_data.command_line; if ^P_info_line.explicit_sw then return; /* nothing to set for this type of line */ P_abs_line.by_control_arg = "1"b; P_abs_line.on = P_info_line.on; P_abs_line.expand = P_info_line.expand; if unspec (P_info_line.iocb) = "0"b then P_abs_line.iocb = null; else P_abs_line.iocb = P_info_line.iocb; P_abs_line.prefix = P_info_line.prefix; end set_trace; %page; any_other_handler: procedure (); declare 1 ts aligned, 2 version fixed bin, 2 status_code fixed bin (35); if substr (mask, 36, 1) then do; ts.version = 0; ts.status_code = error_table_$unable_to_do_io; call terminate_process_ ("fatal_error", addr (ts)); end; call continue_to_signal_ ((0)); /* We don't want it; pass it on */ return; end any_other_handler; %page; %include abs_io_data; %page; %include ec_data; %page; %include ec_trace_info; %page; %include io_call_info; %page; %include iocb; end abs_io_control;  abs_io_expand_.pl1 05/17/90 1515.5rew 05/17/90 1510.3 680211 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-03-13,Herbst), approve(86-04-17,MCR7376), audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041): Fixed bug causing extra null arg for "&||[af_returning_null_string]". 2) change(86-04-23,Herbst), approve(86-04-23,MCR7376), audit(86-04-25,Kissel), install(86-04-29,MR12.0-1041): Fixed to consider open and closed parens inside a quoted string as literal characters unless a ")" closes a "&(" since variable references &(...) are expanded even in quoted strings. Did the same for brackets and "&[". 3) change(86-04-30,Herbst), approve(86-04-30,MCR7376), audit(86-04-30,Kissel), install(86-05-01,MR12.0-1052): Fixed ")" inside quoted string to close &q(1) as well as &(foo). 4) change(86-05-22,Herbst), approve(86-05-22,MCR7376), audit(86-05-16,Kissel), install(86-05-22,MR12.0-1058): Backed out previous changes to () and [] handling recognizing that all except &() and &[] should be ignored by exec_com itself. 5) change(87-02-16,Parisek), approve(87-07-23,MCR7716), audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080): If abs_data.noabort is ON then update next statement data. 6) change(87-08-18,Parisek), approve(87-08-18,PBF7716), audit(87-09-03,Farley), install(87-09-10,MR12.1-1104): Conditionally get next ec statement when noabort flag is on. 7) change(89-12-04,LZimmerman), approve(89-12-04,MCR8145), audit(89-12-08,Kallstrom), install(90-05-17,MR12.4-1009): Add literal &CR. END HISTORY COMMENTS */ /* format: off */ abs_io_expand_: proc (A_xd, A_code); /* Written 09/05/80 by Steve Herbst */ /* Fixed to return blank lines 10/07/81 S. Herbst */ /* Changed &set to see quotes, added &r(var) etc., added &print_switch{_nnl} 10/20/81 S. Herbst */ /* Fixed &q(1) bug, &then&quit bug 02/04/82 S. Herbst */ /* Modified: 16 February 1982 by G. Palter to call ec_data.eval_string when appropriate */ /* Fixed it to handle &ready_proc (as well as &ready), and reject &thenquit but not &then&quit 03/24/82 S. Herbst */ /* Fixed &if-&then-&else to be impervious to recursive get_line 04/20/82 S. Herbst */ /* Removed 1000-char limit on &[...] strings 06/01/82 S. Herbst */ /* Fixed to ignore trailing white space 07/08/82 S. Herbst */ /* Sped up the label search, changed to use addcharno 10/06/82 S. Herbst */ /* Fixed &set foo "" and arg parsing with &+ 12/07/82 */ /* Fixed &+ continuation interrupted by one or more comment lines 12/14/82 S. Herbst */ /* Fixed fault taken parsing white space 01/03/83 S. Herbst */ /* Fixed get_next_statement to skip leading white space on line after &-comment 02/07/83 S. Herbst */ /* Fixed not to skip every other blank line 02/10/83 S. Herbst */ /* Fixed to skip trailing white space before returning, to distinguish it from blank line 02/24/83 S. Herbst */ /* Fixed to not rtrim variable values 03/01/83 S. Herbst */ /* Fixed to handle &then || NL || &+ 03/07/83 S. Herbst */ /* Added keywords &on, &begin, &revert, etc. 04/07/83 S. Herbst */ /* Changed to look at abs_data.trim_whitespace_sw for input lines (&attach &trim off) 06/02/83 S. Herbst */ /* Added &list_variables (&lsv) 06/07/83 S. Herbst */ /* Fixed to recognize &"" as a null string arg, as in: &set a &"" b &"" 11/18/83 S. Herbst */ /* Fixed bug making it possible to overflow allocated region for expansion 12/28/83 S. Herbst */ /* Fixed expansion bug caused by freeing allocated buffer used by pushed state 01/24/84 S. Herbst */ /* Fixed to allocate variables in abs_data.work_area, not system free area 05/16/84 S. Herbst */ /* Fixed to preserve &"" and "" as null arguments 07/18/84 S. Herbst */ /* Fixed to accept &end on same line as handler text 08/10/84 S. Herbst */ /* Fixed to compute quotes for &r and &q correctly when nested inside parens 08/14/84 S. Herbst */ /* Fixed to ignore mismatch of non-ec parentheses, as in (...) 08/20/84 S. Herbst */ /* Fixed bug causing extra null arg parsing 'one &[string " two"]' 08/20/84 S. Herbst */ dcl 1 state, 2 keyword, 3 name char (32) varying, 3 number fixed bin, 3 paren_sw bit (1) unaligned, 3 bracket_sw bit (1) unaligned, 3 af_type fixed bin, 3 name_switches unaligned, 4 control_word_sw bit (1), 4 allow_arg_sw bit (1), 4 require_arg_sw bit (1), 4 require_number_sw bit (1), 4 digit_arg_sw bit (1), 3 param_switches, 4 f_sw bit (1), 4 n_sw bit (1), 4 q_sw bit (1), 4 r_sw bit (1), 2 quote_factor fixed bin, /* 2**(quote depth up to state.qscan_start)-1 for doubling */ 2 qscan_start fixed bin (21), 2 iafter_pos fixed bin (21), /* for tracing */ 2 optr_len, 3 optr ptr, 3 omax_len fixed bin (21), 3 olen fixed bin (21), 3 opos fixed bin (21); dcl 1 state_stack (100) like state; dcl 1 alloc_info aligned, /* for allocating long lines */ 2 allocated_sw bit (1) aligned, 2 alloc_ptr ptr, 2 alloc_len fixed bin (21); dcl 1 alloc_stack (100) aligned, 2 allocated_sw_stack bit (1) aligned, 2 alloc_ptr_stack ptr, 2 alloc_len_stack fixed bin (21); %page; dcl 1 PARAM_KEYWORD int static options (constant), 2 name char (32) varying init ("&"), 2 number fixed bin init (1), 2 paren_sw bit (1) unaligned init ("0"b), 2 bracket_sw bit (1) unaligned init ("0"b), 2 af_type fixed bin init (0), 2 name_switches unaligned, 3 control_word_sw bit (1) init ("0"b), 3 allow_arg_sw bit (1) init ("1"b), 3 require_arg_sw bit (1) init ("1"b), 3 require_number_sw bit (1) init ("1"b), 3 digit_arg_sw bit (1) init ("0"b), 2 param_switches unaligned, 3 f_sw bit (1) init ("0"b), 3 n_sw bit (1) init ("0"b), 3 q_sw bit (1) init ("0"b), 3 r_sw bit (1) init ("0"b); dcl (A_pos, A_len) fixed bin (21); /* for $expand_label */ dcl A_label_val_ptr ptr; /* for $expand_label */ dcl A_label_val_len fixed bin (21); /* for $expand_label */ dcl A_vars_ptr ptr; /* for $set */ dcl (A_var, A_val) char (*); /* for $set */ dcl A_code fixed bin (35); dcl 1 A_xd aligned like expand_data; %page; /* Based */ dcl xd_area area based (A_xd.area_ptr); dcl 1 iptr_len, 2 iptr ptr, 2 ilen fixed bin (21), 2 ipos fixed bin (21); dcl input_overlay char (overlay_len) based (overlay_ptr); dcl input char (ilen) based (iptr); dcl output char (state.olen) based (state.optr); dcl saved_arg char (saved_arg_len) varying based (saved_arg_ptr); dcl alloc_string char (alloc_len) based (alloc_ptr); dcl allocated_buffer char (A_xd.allocated_buffer_len) based (A_xd.allocated_ptr); dcl caller_buffer char (A_xd.caller_buffer_len) based (A_xd.caller_buffer_ptr); dcl 1 command_args (command_args_count) based (command_args_ptr), 2 ptr ptr, 2 len fixed bin (21), 2 quote_count fixed bin (21); dcl command_arg char (command_args (arg_index).len) based (command_args (arg_index).ptr); dcl ec_name char (arg_info.ec_name_len) based (arg_info.ec_name_ptr); dcl ec_path char (arg_info.ec_path_len) based (arg_info.ec_path_ptr); dcl parsed_arg char (parsed_args.len (parsed_arg_index)) based (parsed_args.ptr (parsed_arg_index)); /* Constants */ dcl TF (0:1) char (8) varying int static options (constant) init ("false", "true"); dcl DEFAULT_ARG char (1) int static options (constant) init (" "); /* no arg specified to a keyword */ dcl (CONTROL init ("1"b), NONCONTROL init ("0"b)) bit (1) int static options (constant); dcl (QDOUBLE init ("0"b), REQUOTE init ("1"b)) bit (1) int static options (constant); dcl UNDEFINED fixed bin int static options (constant) init (-1); dcl (BK_TYPE init (1), BAR_BK_TYPE init (2), BAR_BAR_BK_TYPE init (3)) fixed bin int static options (constant); dcl (PARAM_REF init (1), VAR_REF init (2), AF_REF init (3), MAX_KEY init (100)) fixed bin int static options (constant); dcl DIGITS char (10) int static options (constant) init ("0123456789"); dcl ALPHA char (27) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz_"); dcl DELIMS char (4) int static options (constant) init ("() "); dcl SP char (1) int static options (constant) init (" "); dcl HT char (1) int static options (constant) init (" "); dcl BS char (1) int static options (constant) init (""); dcl NL char (1) int static options (constant) init (" "); dcl VT char (1) int static options (constant) init (" "); dcl FF char (1) int static options (constant) init (" "); dcl CR char (1) int static options (constant) init (" "); /* The control statement keywords */ /* NOTE: Do not change this array without changing the ACTION() and SKIP() labels in abs_io_v2_get_line */ /* Also change abs_io_v2_get_line vars ELSE_ACTION, IF_ACTION, and THEN_ACTION */ dcl STMTS_STRING char (STMTS_LEN) aligned based (addr (STMTS)); dcl STMTS (39) char (32) aligned int static options (constant) init ("&attach", "&begin", "&call", "&default", "&detach", "&do", "&else", "&end", "&exit", "&entry", "&function", "&goto", "&if", "&label", "&leave", "&list_variables", "&lsv", "&on", "&print", "&print_nnl", "&print_switch", "&print_switch_nnl","&procedure", "&proc", "&quit", "&ready", "&ready_mode", "&ready_proc", "&repeat", ""/*"&resignal*/, "&return", "&revert", "&set", "&signal", "&then", "&trace", "&until", "&version", "&while"); dcl STMT_SWITCHES (39) bit (3) int static options (constant) init /* parse_args, no_args, then_else_allowed */ ("100"b, "110"b, "100"b, "100"b, "100"b, "110"b, "010"b, "110"b, "100"b, "100"b, "100"b, "000"b, "001"b, "000"b, "100"b, "100"b, "100"b, "100"b, "000"b, "000"b, "000"b, "000"b, "100"b, "100"b, "010"b, "100"b, "100"b, "100"b, "100"b, "100"b, "000"b, "100"b, "100"b, "000"b, "011"b, "100"b, "100"b, "100"b, "100"b); dcl 1 STMT_SW_OVERLAY (39) based (addr (STMT_SWITCHES)), 2 (PARSE_ARGS_SW, NO_ARGS_SW, THEN_ELSE_ALLOWED_SW) bit (1) unaligned; /* The expandable keywords */ /* NOTE: Do not change this array without changing the labels in expand internal procedure */ dcl NAMES_STRING char (NAMES_LEN) aligned based (addr (NAMES)); dcl NAMES (38) char (32) aligned int static options (constant) init ("&condition_info_ptr", "&cond_info_ptr", "&condition_name", "&cond_name", "&ec_dir", "&ec_name", "&ec_path", "&ec_switch", "&handlers", "&in_handler", "&is_absin", "&is_active_function", "&is_af", "&is_attached", "&is_defined", "&is_input_line", "&n", ""/*"e*/, ""/*&requote*/, ""/*&unquote*/, "&was_attached", "&", "&BS", "&CR", "&FF", "&HT", "&LF", "&NL", "&NP", "&QT", "&SP", "&VT", "&begin", "&do", "&else", "&end", "&if", "&then"); dcl NAME_SWITCHES (38) bit (5) int static options (constant) init /* control_wd, allow_arg, require_arg, require_num, digit_ok (params) */ ( "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "01100"b, "00000"b, "00000"b, "01100"b, "01100"b, "01100"b, "00000"b, "01010"b, "01010"b, "01010"b, "01010"b, "01010"b, "01010"b, "01010"b, "01010"b, "01010"b, "01010"b, "01010"b, "10000"b, "10000"b, "10000"b, "10000"b, "10000"b, "10000"b); /* The &words not to be expanded (stmt control-args) */ dcl DONT_EXPAND_STRING char (DONT_EXPAND_LEN) aligned based (addr (DONT_EXPAND)); dcl DONT_EXPAND (22) char (32) aligned int static options (constant) init ("&all", "&both", "&command", "&comment", "&continue", "&control", "&ex", "&exclude", "&expanded", "&input", "&match", "&osw", "&output_switch", "&prefix", "&trim", "&undef", "&undefined", "&unexpanded", "&val", "&value", "&var", "&variable"); /* The parameter prefixes */ dcl PARAMS_STRING char (PARAMS_LEN) aligned based (addr (PARAMS)); dcl PARAMS (10) char (8) aligned int static options (constant) init ("&q", "&qf", "&q&n", "&qf&n", "&r", "&rf", "&r&n", "&rf&n", "&f", "&f&n"); dcl PARAM_SWITCHES (10) bit (4) int static options (constant) init /* f, n, q, r */ ("0010"b, "1010"b, "0110"b, "1110"b, "0001"b, "1001"b, "0101"b, "1101"b, "1000"b, "1100"b); /* Static */ dcl WHITE char (4) int static; /* to be initialized to SP || HT || VT || FF */ dcl init_sw bit (1) int static init ("0"b); dcl MAX_CHARS fixed bin (21) int static options (constant) init (261120 * 4); /* max chars in a seg */ dcl (DONT_EXPAND_LEN, NAMES_LEN, PARAMS_LEN, STMTS_LEN) fixed bin int static; dcl (ELSE_ACTION, IF_ACTION, SET_ACTION, THEN_ACTION) fixed bin int static; /* Automatic */ dcl 1 trace aligned like abs_data.command_line; dcl (auto_saved_arg, trace_buffer) char (1000) varying; dcl search_chars char (12) varying; dcl tf_string char (8) varying; dcl char5 char (5); dcl char3 char (3); dcl char2 char (2); dcl (next_char, next_next_char, searched_char) char (1); dcl (added_arg_inside_quotes_sw, control_line_sw, delete_sw, eof_sw, expand_label_sw, found_sw) bit (1); dcl (got_next_stmt, inside_quotes_sw, label_search_sw, no_args_sw, null_arg_sw, parse_args_sw, saved_arg_allocated_sw) bit (1); dcl (skip_sw, then_else_allowed_sw, trace_sw) bit (1); dcl (command_args_ptr, overlay_ptr, saved_arg_ptr) ptr; dcl (arg_index, arg_limit, arg_max, arg_start, command_args_count, nest_level, parsed_arg_index) fixed bin; dcl (i, istart, j, no_args_ipos, overlay_len, saved_arg_len, saved_ilen, saved_ipos, skip_count) fixed (21); dcl (temp_i, temp_istart, temp_white_len, white_len) fixed bin (21); dcl ic (6) fixed bin (21); dcl code fixed bin (35); dcl error_table_$badsyntax fixed bin (35) ext; dcl error_table_$command_line_overflow fixed bin (35) ext; dcl error_table_$end_of_info fixed bin (35) ext; dcl error_table_$oldnamerr fixed bin (35) ext; dcl iox_$user_output ptr ext; dcl cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) varying, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl (ioa_$ioa_switch_nnl, ioa_$rsnnl) entry options (variable); dcl requote_string_ entry (char(*)) returns(char(*)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl value_$defined entry (ptr, bit (36), char (*), fixed bin (35)) returns (bit (1) aligned); dcl value_$delete entry (ptr, bit (36), char (*), fixed bin (35)); dcl value_$get_alloc entry (ptr, bit (36), char (*), ptr, ptr, fixed bin (21), fixed bin (35)); dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35)); dcl value_$set entry options (variable); dcl (addcharno, addr, codeptr, copy, divide, fixed, hbound, index, length) builtin; dcl (max, maxlength, min, mod, null, rtrim, search, substr, unspec, verify) builtin; dcl (area, bad_area_format, bad_area_initialization) condition; %page; trace_sw = "1"b; expand_label_sw, got_next_stmt, label_search_sw, skip_sw = "0"b; go to COMMON; expand_label: entry (A_xd, A_pos, A_len, A_label_val_ptr, A_label_val_len, A_code); /* expands a &label for search */ expand_label_sw = "1"b; got_next_stmt, label_search_sw, skip_sw, trace_sw = "0"b; A_code = 0; abs_data_ptr = A_xd.abs_data_ptr; overlay_ptr = input_string.ptr; overlay_len = input_string.len; iptr = addcharno (overlay_ptr, A_pos + length ("&label ") - 1); /* position to rest of line */ ilen = A_len - length ("&label "); ipos, istart, nest_level = 1; no_args_sw, parse_args_sw = "0"b; state.optr = A_xd.caller_buffer_ptr; state.omax_len = A_xd.caller_buffer_len; state.olen = 0; go to START_EXPANDING; label_search: entry (A_xd, A_code); label_search_sw = "1"b; /* executing a &goto */ expand_label_sw, got_next_stmt, skip_sw, trace_sw = "0"b; go to COMMON; skip: entry (A_xd, A_code); skip_sw = "1"b; /* skipping &then or &else clause */ expand_label_sw, label_search_sw, trace_sw = "0"b; COMMON: if ^init_sw then do; init_sw = "1"b; STMTS_LEN = length (STMTS (1)) * hbound (STMTS, 1); NAMES_LEN = length (NAMES (1)) * hbound (NAMES, 1); DONT_EXPAND_LEN = length (DONT_EXPAND (1)) * hbound (DONT_EXPAND, 1); PARAMS_LEN= length (PARAMS (1)) * hbound (PARAMS, 1); IF_ACTION = lookup_stmt ("&if"); THEN_ACTION = lookup_stmt ("&then"); ELSE_ACTION = lookup_stmt ("&else"); SET_ACTION = lookup_stmt ("&set"); WHITE = SP || HT || VT || FF; /* white space */ end; A_code = 0; nest_level, state.quote_factor, state.qscan_start = 1; added_arg_inside_quotes_sw, inside_quotes_sw, null_arg_sw, parse_args_sw = "0"b; abs_data_ptr = A_xd.abs_data_ptr; ec_data_ptr = abs_data.ec_data_ptr; saved_arg_ptr = addr (auto_saved_arg); saved_arg_len = maxlength (auto_saved_arg); saved_arg_allocated_sw = "0"b; overlay_ptr = input_string.ptr; overlay_len = input_string.len; SKIP_LOOP: /* label for $skip to ignore some keywords */ iptr = addcharno (overlay_ptr, A_xd.input_pos - 1); ilen = overlay_len - A_xd.input_pos + 1; i = index (input, NL); /* skip prev line's trailing whitespace and NL */ if i ^= 0 then do; if i = 1 then skip_count = 0; /* just a blank line; don't skip it */ else if verify (substr (input, 1, i - 1), WHITE) = 0 then skip_count = i; else skip_count = 0; A_xd.input_pos = A_xd.input_pos + skip_count; iptr = addcharno (iptr, skip_count); ilen = ilen - skip_count; end; if ilen = 0 then do; A_code = error_table_$end_of_info; return; end; if label_search_sw then do; char3 = substr (input, 1, 3); if char3 ^= "&be" & char3 ^= "&do" & char3 ^= "&en" & char3 ^= "&la" then do; /* not at a &begin, &do, &end or &label stmt */ call find_next_occurrence ("&begin", A_xd.next_begin_pos, ic (1)); call find_next_occurrence ("&do", A_xd.next_do_pos, ic (2)); call find_next_occurrence ("&end", A_xd.next_end_pos, ic (3)); call find_next_occurrence ("&label", A_xd.next_label_pos, ic (4)); call find_next_occurrence ("&""", A_xd.next_quote_pos, ic (5)); call find_next_occurrence ("&-", A_xd.next_comment_pos, ic (6)); i = MAX_CHARS; do j = 1 to hbound (ic, 1); if ic (j) ^= 0 then i = min (i, ic (j)); end; if i = 0 | i = MAX_CHARS then NO_LABEL: if abs_data.in_handler_sw then do; A_code = error_table_$end_of_info; go to RETURN; end; else do; A_xd.this_statement.pos = abs_data.goto_statement_pos; A_xd.this_statement.len = abs_data.goto_statement_len; call error ("Searching for label """ || rtrim (A_xd.searching_for) || """"); end; char3 = substr (input_overlay, i, 3); if substr (char3, 1, 2) = "&""" then do; /* skip &"..." */ inside_quotes_sw = "1"b; i = i + 2; /* first skip the &" */ do while (inside_quotes_sw); j = index (substr (input_overlay, i), """"); if j = 0 then call error ("Missing end quote for &"""); if substr (input_overlay, i + j, 1) = """" then /* imbedded double quote */ i = i + j + 1; /* skip over it and continue inside string */ else inside_quotes_sw = "0"b; end; end; else if substr (char3, 1, 2) = "&-" then do; /* skip comment */ j = index (substr (input_overlay, i + 1), NL); /* skip past end of line */ if j = 0 then go to NO_LABEL; i = i + j; end; A_xd.input_pos = i; go to SKIP_LOOP; end; end; istart = 1; A_xd.this_statement.pos = A_xd.input_pos; abs_data.next_action = UNDEFINED; NL_LOOP: i = index (substr (input, istart), NL); /* find end of this line */ if i = 0 then if abs_data.in_handler_sw then i = ilen; /* tolerate partial line in handler; must be followed by &end */ else call error ("Last line does not end in newline; ignored."); else if i = 1 then do; /* null line */ A_xd.input_pos = A_xd.input_pos + 1; A_xd.caller_actual_len, A_xd.this_statement.len = 0; RETURN_NULL_LINE: if trace_sw & command_line.on then call print_trace ("", command_line, NONCONTROL); abs_data.this_action = 0; go to GET_NEXT_STMT; end; else if i + istart + 1 < ilen then do; /* not the last line */ if substr (input, i + istart - 1, 1) = NL then do; /* include continuation lines */ white_len = verify (substr (input, i + istart), WHITE) - 1; if white_len = -1 then white_len = 0; char2 = substr (input, i + istart + white_len, 2); if char2 = "&-" then do; /* might be continuation broken by comment line */ temp_istart = istart; temp_i = i; temp_white_len = white_len; do while (char2 = "&-"); /* or any number of comment lines */ temp_istart = temp_istart + temp_i + temp_white_len; temp_i = index (substr (input, temp_istart), NL); temp_white_len = verify (substr (input, temp_i + temp_istart), WHITE) - 1; if temp_white_len = -1 then temp_white_len = 0; char2 = substr (input, temp_i + temp_istart + temp_white_len, 2); end; if char2 = "&+" then do; /* yes, it is part of a continuation */ istart = temp_istart; i = temp_i; white_len = temp_white_len; end; end; if char2 = "&+" then do; istart = istart + i + white_len; /* skip to after the &+ */ go to NL_LOOP; end; end; end; saved_ilen = ilen; ilen = i + istart - 2; /* leave off last NL */ if A_xd.is_input & ^abs_data.trim_whitespace_sw then ipos = 1; else do; ipos = verify (input, WHITE); /* skip leading whitespace */ if ipos = 0 then do; /* all whitespace */ A_xd.input_pos = A_xd.input_pos + ilen + 1; A_xd.caller_actual_len, A_xd.this_statement.len = ilen; substr (caller_buffer, 1, ilen) = substr (input, 1, ilen); go to RETURN_NULL_LINE; end; end; A_xd.this_statement.pos = A_xd.input_pos; A_xd.this_statement.len = ilen; state.optr = A_xd.caller_buffer_ptr; state.omax_len = A_xd.caller_buffer_len; state.olen = 0; allocated_sw = "0"b; /* Find out whether it's a control line */ if substr (input, ipos, 1) = "&" then /* begins with & */ if ilen = ipos then do; /* & on line by itself = error */ state.keyword.name = "&"; go to BAD_AMP_WORD; end; else if substr (input, ipos + 1, 1) = "&" then do; /* && = & */ call add_output (state.optr_len, "&"); ipos = ipos + 2; abs_data.this_action = 0; go to NOT_CONTROL; end; else if substr (input, ipos + 1, 1) = "-" then do; /* &- (comment) */ if abs_data.comment_line.on & trace_sw & ipos + 1 < ilen then call trace_comment (substr (input, ipos + 2)); A_xd.input_pos = A_xd.input_pos + ilen + 1; go to SKIP_LOOP; end; else do; state.keyword.name = "&"; /* prepare to look up a stmt keyword */ do i = ipos + 1 to ilen while (index (WHITE || "&", substr (input, i, 1)) = 0); state.keyword.name = state.keyword.name || substr (input, i, 1); abs_data.this_action = lookup_stmt ((state.keyword.name)); if abs_data.this_action ^= 0 then go to CONTROL_STMT; /* yes, a statement keyword */ end; go to NOT_CONTROL; /* A control statement */ CONTROL_STMT: /* So far we only know it STARTS with a valid control word; it might be the &ready of &ready_proc, or &thenfoo */ state.keyword.name = "&"; /* make sure we get the whole keyword */ do i = ipos + 1 to ilen while (index (ALPHA, substr (input, i, 1)) ^= 0); state.keyword.name = state.keyword.name || substr (input, i, 1); end; abs_data.this_action = lookup_stmt ((state.keyword.name)); if abs_data.this_action = 0 then /* could be "&thenfoo", for example */ call error ("Invalid statement keyword " || state.keyword.name); control_line_sw = CONTROL; trace = abs_data.control_line; /* get trace info for control lines */ ipos = ipos + length (state.keyword.name); /* skip the control statement keyword */ i = verify (substr (input, ipos), WHITE); /* and the following whitespace */ if i = 0 then do; /* done (no args) */ ipos, no_args_ipos = ilen + 1; CONTROL_NOARG: if trace_sw & trace.on & (trace.expand = UNEXPANDED | trace.expand = BOTH) then call trace_unexpanded (input, trace); go to RETURN_STRING; end; ipos = ipos + i - 1; /* skip the whitespace */ if i = 1 then no_args_ipos = ipos - 1; /* no white space following control word */ else no_args_ipos = ipos - 2; /* restore later if no_args_sw */ no_args_sw = NO_ARGS_SW (abs_data.this_action); /* whether no args is acceptable for this stmt */ if no_args_sw & (abs_data.this_action = THEN_ACTION | abs_data.this_action = ELSE_ACTION) then go to CONTROL_NOARG; /* don't even look for a comment */ then_else_allowed_sw = THEN_ELSE_ALLOWED_SW (abs_data.this_action); /* whether this stmt can be followed by &then or &else */ if trace_sw & abs_data.if_sw then do; /* test whether to trace */ if (abs_data.this_action = THEN_ACTION & ^abs_data.true_sw) /* don't trace &then after "&if false" */ | (abs_data.this_action = ELSE_ACTION & abs_data.true_sw) then /* don't trace &else after "&if true" */ trace_sw = "0"b; end; parse_args_sw = ^skip_sw & PARSE_ARGS_SW (abs_data.this_action); if parse_args_sw then do; /* parse args separated by whitespace */ parsed_args_count = 20; /* grow later if necessary */ if A_xd.area_ptr = null then A_xd.area_ptr = get_system_free_area_ (); allocate parsed_args in (xd_area) set (parsed_args_ptr); parsed_args.count = 0; A_xd.parsed_args_ptr = parsed_args_ptr; end; else A_xd.parsed_args_ptr, A_xd.arg_ptr = null; /* take rest of line as single arg */ end; else do; abs_data.this_action = 0; NOT_CONTROL: /* either command line, input line, or comment */ no_args_sw, parse_args_sw = "0"b; A_xd.parsed_args_ptr, A_xd.arg_ptr = null; trace = A_xd.trace_lines; control_line_sw = NONCONTROL; end; if parse_args_sw | then_else_allowed_sw then search_chars = "&()[]" || NL || WHITE; else search_chars = "&()[]" || NL; inside_quotes_sw = "0"b; if abs_data.this_action = SET_ACTION then search_chars = search_chars || """"; /* see quotes only for &set statement */ if trace_sw & trace.on then do; if trace.iocb = null then trace.iocb = iox_$user_output; if trace.expand = UNEXPANDED | trace.expand = BOTH then call trace_unexpanded (input, trace); end; START_EXPANDING: A_xd.expanded_sw = "0"b; /* assume until var or param is expanded */ eof_sw, null_arg_sw = "0"b; do while (^eof_sw); i = search (substr (input, ipos), search_chars); /* next & ) NL also WHITE if parsing args */ if i = 0 then do; /* no more ampersands */ if nest_level > 1 then /* see if any unclosed construct */ do j = nest_level - 1 by -1 to 1; if state_stack (j).keyword.number ^= 0 then if state_stack (j).keyword.number = AF_REF then call error ("No closing bracket."); else call error ("No closing parenthesis."); end; if ipos <= ilen then call add_output (state.optr_len, substr (input, ipos)); ipos = ilen + 1; go to RETURN_STRING; end; if i > 1 then call add_output (state.optr_len, substr (input, ipos, i - 1)); ipos = ipos + i; searched_char = substr (input, ipos - 1, 1); if searched_char = NL then do; /* NL || &+ */ CONTIN: ipos = ipos + verify (substr (input, ipos), WHITE) - 1; /* skip white space on next line before &+ or &- */ if substr (input, ipos, 2) = "&+" then ipos = ipos + 2; /* if it's &+, skip that too */ end; else if searched_char = """" then do; /* only for parsing &set args */ if nest_level > 1 then call add_output (state.optr_len, """"); /* only strip quotes from &set args */ if ^inside_quotes_sw then do; inside_quotes_sw = "1"b; added_arg_inside_quotes_sw = "0"b; end; else if substr (input, ipos, 1) = """" then do; /* double quote is a " inside string */ call add_output (state.optr_len, """"); ipos = ipos + 1; end; else do; /* single quote ends it */ if output = "" & parse_args_sw & ^added_arg_inside_quotes_sw then null_arg_sw = "1"b; inside_quotes_sw, added_arg_inside_quotes_sw = "0"b; end; end; else if searched_char = ")" then do; if nest_level = 1 then call add_output (state.optr_len, ")"); else do; call save_arg; /* allocate bigger if necessary */ call pop_state (nest_level, state); if state.keyword.number = 0 then call add_output (state.optr_len, saved_arg || ")"); /* just (...) */ else if state.keyword.number = AF_REF then /* &[...) */ call error ("Mismatched brackets."); else do; /* &(...) or &keyword(...) */ EXPAND_ONE: if trace.on then state.iafter_pos = ipos; if ^skip_sw then call expand (state, saved_arg); /* add expansion to output */ end; end; end; else if searched_char = "]" then do; /* end of &[...] or [...] */ if nest_level = 1 then call add_output (state.optr_len, "]"); else do; call save_arg; /* allocate bigger if necessary */ call pop_state (nest_level, state); if state.keyword.number = 0 then call add_output (state.optr_len, saved_arg || "]"); /* just [...] */ else if nest_level < 1 then call error ("Excess right bracket."); else if state.keyword.number = AF_REF then go to EXPAND_ONE; /* &[...] */ else call error ("Mismatched bracket."); end; end; else if searched_char = "(" then do; /* just plain (...) */ unspec (state.keyword) = "0"b; state.keyword.number = 0; /* not an exec_com construct */ /* but have to parse it because ) closes either it or &( */ call push_state (nest_level, state); call add_output (state.optr_len, "("); end; else if searched_char = "[" then do; /* just plain [...] */ unspec (state.keyword) = "0"b; state.keyword.number = 0; /* not an exec_com construct */ /* but we have to parse it because ] closes either it or &[ */ call push_state (nest_level, state); call add_output (state.optr_len, "["); end; else if searched_char = "&" then do; /* start of a stmt or expandable construct */ if i >= ilen then call error ("Invalid construct ""&"""); state.keyword.paren_sw = "0"b; /* assume till ( encountered */ if trace.on then do; state.iafter_pos = ipos - 1; end; next_char = substr (input, ipos, 1); if next_char = "-" then do; /* &- (comment) */ if ipos > 2 & state.olen > 0 & (^A_xd.is_input | abs_data.trim_whitespace_sw) then /* strip preceding whitespace from expanded line */ state.olen = length (rtrim (output, WHITE)); i = index (substr (input, ipos + 1), NL); /* end of line */ if i = 0 then do; /* no continuation */ if abs_data.comment_line.on & trace_sw then call trace_comment (substr (input, ipos + 1)); ipos = ilen + 1; /* skip over comment */ go to RETURN_STRING; end; else do; /* continued on next line */ if abs_data.comment_line.on & trace_sw then call trace_comment (substr (input, ipos + 1, i - 1)); ipos = ipos + i + 1; /* position of the &+ or &- */ go to CONTIN; end; end; /* Not a comment */ if no_args_sw then go to RETURN_STRING; else if next_char = """" then do; /* &"..." */ ipos = ipos + 1; /* position to after first quote */ if trace_sw & trace.on & trace.expand = ALL then do; /* trace before expanding quoted string */ call trace_expanded (state, trace_buffer); trace_buffer = trace_buffer || substr (input, state.iafter_pos); call print_trace ((trace_buffer), trace, control_line_sw); end; call get_quoted_string (input, iptr_len.ipos, state, "0"b); end; else if next_char = "&" then do; /* && */ if trace.on & trace.expand = ALL then do; /* trace before expanding && */ if state.olen > 0 then /* not beginning of line */ trace_buffer = output || substr (input, state.iafter_pos); else trace_buffer = substr (input, state.iafter_pos); call print_trace ((trace_buffer), trace, control_line_sw); end; call add_output (state.optr_len, "&"); /* translates to a single ; */ ipos = ipos + 1; end; else if next_char = "!" then do; /* &! = unique name, same for every instance */ if abs_data.unique_name = "" then abs_data.unique_name = rtrim (unique_chars_ ("0"b)); call add_output (state.optr_len, (abs_data.unique_name)); ipos = ipos + 1; end; else do; /* &CONSTRUCT */ if next_char = "(" then do; /* &(...) */ unspec (state.keyword) = "0"b; state.keyword.number = VAR_REF; state.keyword.name = "&"; OPEN_PAREN: ipos = ipos + 1; /* skip the ( */ state.keyword.paren_sw = "1"b; call push_state (nest_level, state); end; else if next_char = "[" then do; /* &[...] */ ipos = ipos + 1; /* skip past it */ unspec(state.keyword) = "0"b; state.keyword.af_type = BK_TYPE; OPEN_AF: state.keyword.number = AF_REF; state.keyword.name = "&"; state.keyword.bracket_sw = "1"b; call push_state (nest_level, state); end; else if next_char = "|" then do; /* might be &|[ or &||[ */ if ipos = ilen then go to BAD_AMP_WORD; /* just &| by itself */ next_next_char = substr (input, ipos + 1, 1); if next_next_char = "[" then do; /* &|[ */ ipos = ipos + 2; /* skip past it */ unspec (state.keyword) = "0"b; state.keyword.af_type = BAR_BK_TYPE; go to OPEN_AF; end; else if next_next_char = "|" then /* &||... */ if ipos + 2 <= ilen then if substr (input, ipos + 2, 1) = "[" then do; /* &||[ */ ipos = ipos + 3; /* skip past it */ unspec (state.keyword) = "0"b; state.keyword.af_type = BAR_BAR_BK_TYPE; go to OPEN_AF; end; go to BAD_AMP_WORD; /* some other &|string */ end; else do; if index (DIGITS, next_char) ^= 0 then do; /* &1, &2, etc. */ ipos, state.iafter_pos = ipos + 1; state.keyword = PARAM_KEYWORD; saved_arg = next_char; go to EXPAND_ONE; end; else if index ("fqr", next_char) ^= 0 then do; /* &q1, &rf&n, etc. */ i = search (substr (input, ipos), DIGITS || "( " || DELIMS || NL); if i = 0 then do; state.keyword.name = substr (input, ipos - 1); i = ilen - ipos + 2; end; else state.keyword.name = substr (input, ipos - 1, i); if known_param (state.keyword, (state.keyword.name)) then do; ipos, state.iafter_pos = ipos + i - 1; if state.n_sw then /* &q&n, &rf&n, etc. */ go to EXPAND_ONE; /* no need to get numeric arg */ next_char = substr (input, ipos, 1); if index (DIGITS, next_char) ^= 0 then do; /* &qf1, etc. */ saved_arg = next_char; ipos, state.iafter_pos = ipos + 1; /* skip the digit */ go to EXPAND_ONE; end; else go to KNOWN; end; end; state.keyword.name = "&"; /* &keyword to look up a char at a time */ saved_ipos = ipos - 2; /* to be restored if keyword is &then, &else, etc. */ found_sw = "0"b; do while (^found_sw); state.keyword.name = state.keyword.name || next_char; ipos = ipos + 1; if known_dont_expand (state.keyword.name) then do; /* an &word that's a stmt control-arg */ call add_output (state.optr_len, (state.keyword.name)); go to END_AMP_WORD; end; if known (state.keyword) then found_sw = "1"b; else do; if ipos > ilen then BAD_AMP_WORD: if index (STMTS_STRING, state.keyword.name || " ") ^= 0 then call error ("Misused statement keyword """ || state.keyword.name || """"); else call error ("Unrecognized keyword """ || state.keyword.name || """"); next_char = substr (input, ipos); if index (DELIMS, next_char) ^= 0 then go to BAD_AMP_WORD; end; end; if state.keyword.control_word_sw then do; /* another stmt on line: &then, &else, &do */ if nest_level > 1 then call error ("Nested control statement keyword """ || state.keyword.name || """"); abs_data.next_action = lookup_stmt ((state.keyword.name)); A_xd.next_statement.pos = saved_ipos + 1; A_xd.next_statement.len, A_xd.next_statement.keyword_len = length (state.keyword.name); ipos = saved_ipos; /* save next stmt for next call to abs_io_expand_ */ go to RETURN_STRING; end; KNOWN: if ^state.keyword.allow_arg_sw then do; /* don't look for an argument */ NO_ARG: saved_arg = DEFAULT_ARG; go to EXPAND_ONE; end; else if ipos > ilen then if state.keyword.require_arg_sw then MISSING_ARG: call error ("Missing argument for """ || state.keyword.name || """"); else go to NO_ARG; else if substr (input, ipos, 1) = "(" then go to OPEN_PAREN; /* argument in parens */ else if state.keyword.digit_arg_sw then /* accepts a single digit arg: q1, f1, etc. */ if index (DIGITS, next_char) ^= 0 then do; saved_arg = next_char; ipos = ipos + 1; go to EXPAND_ONE; end; else go to MISSING_ARG; else if ^state.keyword.require_arg_sw then go to NO_ARG; else go to MISSING_ARG; end; END_AMP_WORD: end; end; /* end of (searched_char = "&") case */ else do; /* white space; we're parsing args or finding &then */ if no_args_sw then go to RETURN_STRING; i = verify (substr (input, ipos - 1), WHITE); if i ^= 0 then if substr (input, ipos + i - 2, 1) = NL then do; /* end of line before &+ */ ipos = ipos + i - 2; /* just skip white space, don't end arg */ go to NEXT_DELIM; end; else if ilen > ipos + i then if substr (input, ipos + i - 2, 2) = "&-" & /* before comment */ index (substr (input, ipos + i), NL) ^= 0 then do; /* followed by &+ */ ipos = ipos + i - 2; /* same: skip white space and don't end arg */ go to NEXT_DELIM; end; if nest_level = 1 & ^inside_quotes_sw then do; /* outside (), [], or "", this whitesp delimits an arg */ if i = 0 then do; /* end of statement */ if ipos - 2 < ilen & A_xd.is_input & ^abs_data.trim_whitespace_sw then call add_output (state.optr_len, substr (input, ipos - 1)); ipos = ilen + 1; /* else just skip the trailing whitespace */ eof_sw = "1"b; end; else do; if then_else_allowed_sw & ipos + i + 1 < ilen then do; /* room for &then or &else */ char5 = substr (input, ipos + i - 2, 5); if (char5 = "&then" | char5 = "&else") & /* IS then or else followed by white */ (ipos + i + 2 = ilen | index (WHITE, substr (input, ipos + i + 3, 1)) ^= 0) then do; ipos = ipos + i - 3; /* skip whitespace before &then or &else */ if char5 = "&then" then abs_data.next_action = THEN_ACTION; else abs_data.next_action = ELSE_ACTION; if nest_level > 1 then /* not valid inside () or [] */ if state.keyword.number = AF_REF then call error ("Missing right bracket."); else call error ("Missing right parenthesis."); if state.quote_factor > 1 then call error ("Unbalanced quotes."); go to RETURN_STRING; end; end; if parse_args_sw then do; /* if separating args */ ipos = ipos + i - 2; /* skip white space */ if nest_level = 1 & state.quote_factor = 1 /* outside () [] "" */ then do; call add_arg (state); /* pick up the arg we have delimited */ null_arg_sw = "0"b; end; end; else do; /* pick up whitespace */ ADD_SPACE: call add_output (state.optr_len, substr (input, ipos - 1, i - 1)); ipos = ipos + i - 2; end; end; end; else if i > 0 then go to ADD_SPACE; /* leave white space intact inside () [] */ NEXT_DELIM: end; end; RETURN_STRING: if inside_quotes_sw then call error ("Unbalanced quotes in &set statement."); do while (nest_level > 1 & state.keyword.number = 0); /* still inside non-ec construct like ( or [ */ saved_arg = output; call pop_state (nest_level, state); call add_output (state.optr_len, (saved_arg)); end; if nest_level > 1 then do j = nest_level - 1 by -1 to 1; if state_stack (j).keyword.number ^= 0 then if state_stack (j).keyword.number = AF_REF then call error ("Missing right bracket."); else call error ("Missing right parenthesis."); end; if expand_label_sw then do; A_label_val_ptr = state.optr; A_label_val_len = state.olen; end; if no_args_sw then do; /* we were just looking for comments */ ipos = no_args_ipos; parse_args_sw = "0"b; state.olen = 0; state.quote_factor, state.qscan_start = 1; end; if trace_sw & trace.on & trace.expand ^= UNEXPANDED & abs_data.this_action ^= THEN_ACTION & abs_data.this_action ^= ELSE_ACTION then if parse_args_sw then do; /* have to print already parsed args too */ trace_buffer = ""; if A_xd.parsed_args_ptr ^= null then do parsed_arg_index = 1 to A_xd.parsed_args_ptr -> parsed_args.count; trace_buffer = trace_buffer || parsed_arg || " "; end; call print_trace (trace_buffer || output, trace, control_line_sw); end; else call print_trace (output, trace, control_line_sw); if parse_args_sw then do; if state.olen > 0 then call add_arg (state); /* there is a last unsaved arg in output buffer */ else if null_arg_sw then do; /* there is an unsaved null arg */ null_arg_sw = "0"b; call add_arg (state); end; end; else do; /* the one arg is all of output */ if abs_data.this_action = IF_ACTION & skip_sw & state.olen = 0 then /* didn't expand skipped &if clause, so fake it */ call add_output (state.optr_len, "false"); /* otherwise, caller will say "Malformed conditional" */ A_xd.arg_ptr = state.optr; A_xd.arg_len = state.olen; end; if allocated_sw then /* not using caller's buffer anymore */ if abs_data.this_action ^= 0 then do; /* have to preserve args */ A_xd.caller_actual_len = 0; /* return only allocated storage */ A_xd.allocated_ptr = alloc_ptr; A_xd.allocated_buffer_len = alloc_len; A_xd.allocated_len = state.olen; end; else do; /* command or input line; can copy back */ if state.olen <= A_xd.caller_buffer_len then do; /* will all fit in caller's buffer */ A_xd.caller_actual_len = state.olen; A_xd.allocated_ptr = null; A_xd.allocated_buffer_len, A_xd.allocated_len = 0; end; else do; /* part in caller's part in allocated */ A_xd.caller_actual_len = A_xd.caller_buffer_len; /* as much in caller's as fits */ A_xd.allocated_buffer_len, A_xd.allocated_len = state.olen - A_xd.caller_actual_len; allocate allocated_buffer in (xd_area) set (A_xd.allocated_ptr); allocated_buffer = substr (output, A_xd.caller_actual_len + 1); end; substr (caller_buffer, 1, A_xd.caller_actual_len) = substr (alloc_string, 1, A_xd.caller_actual_len); free alloc_string in (xd_area); /* done with our own copy */ end; else A_xd.caller_actual_len = state.olen; /* no copying necessary */ if ^expand_label_sw then do; A_xd.input_pos = A_xd.input_pos + ipos; /* Skip trailing white space if any */ if substr (input_overlay, A_xd.input_pos - 1, 1) ^= NL then /* not at end of line */ if ^A_xd.is_input | abs_data.trim_whitespace_sw then do; i = index (substr (input_overlay, A_xd.input_pos), NL); if i = 1 then A_xd.input_pos = A_xd.input_pos + 1; /* one char to skip, must be white space */ else if i ^= 0 then if verify (substr (input_overlay, A_xd.input_pos, i - 1), WHITE) = 0 then A_xd.input_pos = A_xd.input_pos + i; /* skip however much white space */ end; /* Skip continuation sequence if any */ i = verify (substr (input_overlay, A_xd.input_pos), WHITE); if i ^= 0 then if substr (input_overlay, A_xd.input_pos + i - 1, 1) = "&" then if substr (input_overlay, A_xd.input_pos + i, 1) = "+" then A_xd.input_pos = A_xd.input_pos + i + 1; end; GET_NEXT_STMT: if abs_data.next_action = UNDEFINED & A_xd.input_pos + 1 < input_string.len then do; /* look-ahead for abs_io_v2_get_line's sake */ call get_next_stmt (input_string.ptr, input_string.len, A_xd.input_pos, A_xd.next_statement); abs_data.next_action = A_xd.next_statement.action; end; RETURN: if saved_arg_allocated_sw then free saved_arg_ptr -> saved_arg in (xd_area); if ^got_next_stmt & abs_data.noabort then do; call get_next_stmt (input_string.ptr, input_string.len, A_xd.input_pos, A_xd.next_statement); end; return; %page; add_arg: proc (P_state); /* Adds another parsed_arg to the structure */ dcl 1 P_state like state; dcl temp_ptr ptr; if parsed_args.count >= parsed_args_count then call grow_parsed_args; parsed_args.count = parsed_args.count + 1; parsed_args.ptr (parsed_args.count) = P_state.optr; parsed_args.len (parsed_args.count) = P_state.olen; temp_ptr = P_state.optr; /* avoids PL/1 addcharno bug involving parameters */ P_state.optr = addcharno (temp_ptr, P_state.olen); P_state.omax_len = P_state.omax_len - P_state.olen; /* stay within allocated range */ P_state.olen = 0; P_state.quote_factor, P_state.qscan_start = 1; if inside_quotes_sw then added_arg_inside_quotes_sw = "1"b; end add_arg; %page; add_output: proc (P_ptr_len, P_str); /* Appends another parsed part (P_str) to the output buffer */ dcl 1 P_ptr_len like state.optr_len; dcl P_str char (*); dcl output char (P_ptr_len.olen) based (P_ptr_len.optr); dcl str_len fixed bin; if skip_sw & abs_data.this_action ^= IF_ACTION then return; str_len = length (P_str); if P_ptr_len.olen + str_len > P_ptr_len.omax_len then do; /* need to allocate bigger buffer */ alloc_len = P_ptr_len.omax_len + str_len + 200; allocate alloc_string in (xd_area) set (alloc_ptr); substr (alloc_string, 1, P_ptr_len.olen) = substr (output, 1, P_ptr_len.olen); /* if allocated_sw then free P_ptr_len.optr -> alloc_string; */ /* might destroy pushed state */ allocated_sw = "1"b; P_ptr_len.optr = alloc_ptr; P_ptr_len.omax_len = alloc_len; end; P_ptr_len.olen = P_ptr_len.olen + str_len; substr (output, P_ptr_len.olen - str_len + 1, str_len) = P_str; end add_output; %page; add_quoted_output: proc (P_ptr_len, P_str, P_requote_sw); /* Same as add_output but quotes or requotes P_str */ dcl 1 P_ptr_len like state.optr_len; dcl P_str char (*); dcl P_requote_sw bit (1); dcl (quote_len, quote_pos, scan_len) fixed bin (21); if skip_sw then return; /* Bring quote-level scan up to date first */ if state.qscan_start <= state.olen then do; /* quote-level scan not up to date yet */ if state.qscan_start = 1 & nest_level > 1 then /* recurse to scan outer level */ state.quote_factor = compute_nested_quote_factor (nest_level - 1); call compute_quote_factor (state); /* now compute factor at current level */ end; /* Now knowing the quote level at which P_str is to be inserted, modify P_str */ if P_requote_sw = REQUOTE then do; /* insert right number of leading quotes */ call add_output (P_ptr_len, copy ("""", state.quote_factor)); state.quote_factor = 2 * state.quote_factor; /* up one for open quote */ end; scan_len = 0; DOUBLE_LOOP: /* perform quote doubling while appending P_str */ quote_pos = index (substr (P_str, scan_len + 1), """"); if quote_pos > 0 then do; call add_output (P_ptr_len, substr (P_str, scan_len + 1, quote_pos - 1)); scan_len = scan_len + quote_pos; /* repeat next quote the right number of times */ call add_output (P_ptr_len, copy ("""", state.quote_factor)); if scan_len < length (P_str) then go to DOUBLE_LOOP; else go to CLOSE_REQUOTE; end; quote_pos = length (P_str) - scan_len; /* length of string yet to be added */ if quote_pos > 0 then call add_output (P_ptr_len, substr (P_str, scan_len + 1, quote_pos)); /* rest of string */ CLOSE_REQUOTE: if P_requote_sw = REQUOTE then do; state.quote_factor = divide (state.quote_factor, 2, 17, 0); /* down one for close quote */ /* append right number of trailing quotes */ call add_output (P_ptr_len, copy ("""", state.quote_factor)); end; state.qscan_start = state.olen + 1; /* scan is up to date */ return; compute_nested_quote_factor: proc (P_level) returns (fixed bin); /* This internal procedure completes the quote scan up through nest level P_level */ dcl P_level fixed bin; if P_level = 0 then return (1); /* should never happen */ if state_stack (P_level).qscan_start <= state_stack (P_level).olen then do; /* not up to date */ if state_stack (P_level).qscan_start = 1 & P_level > 1 then /* recurse */ state_stack (P_level).quote_factor = compute_nested_quote_factor (P_level - 1); call compute_quote_factor (state_stack (P_level)); end; return (state_stack (P_level).quote_factor); end compute_nested_quote_factor; compute_quote_factor: proc (P_state); /* This internal procedure does the actual scan for a given level */ dcl 1 P_state like state; dcl local_output char (P_state.olen) based (P_state.optr); COUNT_LOOP: quote_pos = index (substr (local_output, P_state.qscan_start), """"); if quote_pos > 0 then do; P_state.qscan_start = P_state.qscan_start + quote_pos - 1; quote_len = verify (substr (local_output, P_state.qscan_start), """") - 1; /* number of consecutive quotes */ if quote_len < 0 then quote_len = P_state.olen - P_state.qscan_start + 1; P_state.qscan_start = P_state.qscan_start + quote_len; if mod (quote_len, P_state.quote_factor) = 0 then /* if a multiple of the depth, then */ /* keep incrementing depth (doubling factor) */ do while (mod (quote_len, 2 * P_state.quote_factor) ^= 0); quote_len = quote_len - P_state.quote_factor; P_state.quote_factor = 2 * P_state.quote_factor; end; else do while (quote_len ^= 0); /* else keep decrementing depth (undoubling) */ P_state.quote_factor = divide (P_state.quote_factor, 2, 17, 0); quote_len = mod (quote_len, P_state.quote_factor); end; go to COUNT_LOOP; end; else P_state.qscan_start = P_state.olen + 1; end compute_quote_factor; end add_quoted_output; %page; error: proc (P_string); /* Causes abs_io_v2_get_line to print error message and abort ec */ dcl P_string char (*); A_code = error_table_$badsyntax; A_xd.error_msg = P_string; go to RETURN; end error; %page; expand: proc (P_state, P_arg); dcl 1 P_state like state; dcl P_arg char (*) varying; dcl value_str char (value_len) based (value_ptr); dcl value_var_str char (value_len) varying based (value_ptr); dcl based_area area based (A_xd.area_ptr); dcl value_buffer char (1000) varying; dcl path_string char (168); dcl short_string char (32) varying; dcl switch_name char (32); dcl (alloc_err_sw, traced_sw) bit (1); dcl (p, value_ptr) ptr; dcl value_len fixed bin (21); dcl (i, numeric_arg) fixed bin; if P_state.keyword.number > MAX_KEY then go to BAD_AMP_WORD; traced_sw = "0"b; START: if P_state.keyword.require_number_sw & ^P_state.keyword.n_sw then do; /* requires numeric arg */ if P_arg = DEFAULT_ARG then numeric_arg = 1; /* default for &, etc. */ else do; numeric_arg = cv_dec_check_ ((P_arg), code); if code ^= 0 then if P_state.keyword.number = PARAM_REF then if P_state.keyword.f_sw then call error ("Invalid parameter number """ || P_arg || """"); else go to VAR_REF; /* &r(var), &q(var) */ else call error ("Invalid numeric argument """ || P_arg || """ for " || P_state.keyword.name); end; end; if trace_sw & trace.on & trace.expand = ALL & ^traced_sw then do; /* trace before each expansion */ traced_sw = "1"b; call trace_expanded (P_state, trace_buffer); /* start with what's already been expanded */ trace_buffer = trace_buffer || P_state.keyword.name; if P_arg ^= DEFAULT_ARG then /* some arg was specified */ if P_state.keyword.paren_sw then /* arg is enclosed in parens */ trace_buffer = trace_buffer || "(" || P_arg || ")"; else if P_state.keyword.bracket_sw then do; /* arg is enclosed in brackets &[...] */ if P_state.keyword.af_type = BAR_BAR_BK_TYPE then short_string = "||["; else if P_state.keyword.af_type = BAR_BK_TYPE then short_string = "|["; else short_string = "["; trace_buffer = trace_buffer || short_string || P_arg || "]"; end; else trace_buffer = trace_buffer || P_arg; if P_state.iafter_pos <= ilen then /* not end of line */ trace_buffer = trace_buffer || substr (input, P_state.iafter_pos); call print_trace ((trace_buffer), trace, control_line_sw); end; go to EXPAND (P_state.keyword.number); EXPAND (1): /* parameter reference */ A_xd.expanded_sw = "1"b; /* OBSOLETE if P_arg = "0" then do; (This is the V1 meaning) if P_state.q_sw | P_state.r_sw then call add_quoted_output (P_state.optr_len, ec_path, P_state.r_sw); else call add_output (P_state.optr_len, ec_path); return; end; END OF OBSOLETE */ if P_arg = "0" then /* &0 is invalid in Version 2 */ call error ("Invalid parameter &0"); arg_max = max (abs_data.arg_count, abs_data.default_arg_count); if P_state.n_sw then arg_start = arg_max; /* &n = last arg */ else do; arg_start = numeric_arg; if arg_start > arg_max then return; /* no arg => null string */ end; if P_state.f_sw & ^P_state.n_sw then arg_limit = arg_max; else arg_limit = arg_start; command_args_ptr = abs_data.arg_ptr; command_args_count = abs_data.arg_count; do arg_index = arg_start to arg_limit; /* append each ec arg in range */ /* arg_limit = max (#args, #defaults) */ if arg_index > abs_data.arg_count then do; /* see if default is defined */ command_args_ptr = abs_data.default_arg_ptr; command_args_count = abs_data.default_arg_count; if command_args (arg_index).ptr = null then /* &undefined = no default value */ go to NEXT_ARG; end; if P_state.r_sw then call add_quoted_output (P_state.optr_len, command_arg, P_state.r_sw); else call parse_value (P_state, command_arg); if arg_index < arg_limit then call parse_value (P_state, " "); NEXT_ARG: end; return; EXPAND (2): /* variable reference */ VAR_REF: A_xd.expanded_sw = "1"b; if P_arg = "" then call error ("Invalid variable reference ""&()"""); if verify (P_arg, DIGITS) = 0 & P_arg ^= "" then do; /* &(3), etc. */ P_state.keyword = PARAM_KEYWORD; go to START; /* convert numeric arg and retry as parameter */ end; if abs_data.variables_ptr = null then abs_data.variables_ptr = init_variables (); /* this ec's value seg */ call value_$get_alloc (abs_data.variables_ptr, "01"b, /* call this entry because it allocates */ (P_arg), A_xd.area_ptr, value_ptr, value_len, code); if code ^= 0 then if code ^= error_table_$oldnamerr then do; A_code = code; A_xd.error_msg = "Error in local value assignments."; go to RETURN; end; else if P_arg = "" then call error ("No value for null string."); else call error ("No value for """ || P_arg || """"); if P_state.q_sw | P_state.r_sw then call add_quoted_output (P_state.optr_len, value_str, P_state.r_sw); else call add_output (P_state.optr_len, value_str); if value_str = "" & parse_args_sw then null_arg_sw = "1"b; free value_str in (xd_area); return; EXPAND (3): /* active function reference &[...] */ A_xd.expanded_sw = "1"b; value_ptr = addr (value_buffer); /* start with this and see if big enough */ value_len = maxlength (value_buffer); CALL_EVALUATE: if ec_data_ptr ^= null () then if codeptr (ec_data.eval_string) ^= null () then do; /* an af evaluation routine was specified */ call ec_data.eval_string (null, (P_arg), P_state.keyword.af_type, value_var_str, code); go to EVALUATE_CALLED; end; call cu_$evaluate_active_string (null, (P_arg), P_state.keyword.af_type, value_var_str, code); EVALUATE_CALLED: if code ^= 0 then do; if code = error_table_$command_line_overflow then do; if value_len > maxlength (value_buffer) then free value_var_str in (based_area); value_len = value_len * 2; alloc_err_sw = "0"b; on area alloc_err_sw = "1"b; on bad_area_format alloc_err_sw = "1"b; on bad_area_initialization alloc_err_sw = "1"b; allocate value_var_str in (based_area) set (value_ptr); revert area; revert bad_area_format; revert bad_area_initialization; if ^alloc_err_sw then go to CALL_EVALUATE; end; A_code = code; A_xd.error_msg = "Evaluating active function."; go to RETURN; end; if P_state.keyword.af_type = BAR_BAR_BK_TYPE then if value_var_str = "" & nest_level = 1 then call add_arg (P_state); else call add_output (P_state.optr_len, rtrim (value_var_str)); else call parse_value (P_state, rtrim (value_var_str)); if value_len > maxlength (value_buffer) then free value_var_str in (based_area); return; EXPAND (4): /* &condition_info_ptr */ go to COND_INFO_PTR; EXPAND (5): /* &cond_info_ptr */ COND_INFO_PTR: call ioa_$rsnnl ("^p", switch_name, i, abs_data.condition_info.info_ptr); call add_output (P_state.optr_len, substr (switch_name, 1, i)); return; EXPAND (6): /* &condition_name */ go to COND_NAME; EXPAND (7): /* &cond_name */ COND_NAME: if abs_data.on_info.in_handler_sw then /* null string if not in &on unit */ call add_output (P_state.optr_len, rtrim (abs_data.on_info.condition_name)); return; EXPAND (8): /* &ec_dir */ call hcs_$fs_get_path_name (input_string.ptr, path_string, i, (""), code); call add_quoted_output (P_state.optr_len, substr (path_string, 1, i), QDOUBLE); return; EXPAND (9): /* &ec_name */ call add_quoted_output (P_state.optr_len, ec_name, QDOUBLE); return; EXPAND (10): /* &ec_path */ call add_quoted_output (P_state.optr_len, ec_path, QDOUBLE); return; EXPAND (11): /* &ec_switch */ if ec_data.switch_ptr = null then switch_name = "user_i/o"; else switch_name = ec_data.switch_ptr -> iocb.name; call add_quoted_output (P_state.optr_len, rtrim (switch_name), QDOUBLE); return; EXPAND (12): /* &handlers */ if abs_data.cleanup_handler_ptr ^= null then value_buffer = """cleanup"""; else value_buffer = ""; do p = abs_data.first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null); if value_buffer ^= "" then value_buffer = value_buffer || " "; value_buffer = value_buffer || requote_string_ (rtrim (p -> handler_node.condition_name)); end; call add_output (P_state.optr_len, (value_buffer)); return; EXPAND (13): /* &in_handler (NOT IMPLEMENTED) */ go to BAD_AMP_WORD; EXPAND (14): /* &is_absin */ call add_output (P_state.optr_len, (TF (fixed (A_xd.is_absin)))); return; EXPAND (15): /* &is_active_function */ go to IS_AF; EXPAND (16): /* &is_af */ IS_AF: call add_output (P_state.optr_len, (TF (fixed (A_xd.is_af)))); return; EXPAND (17): /* &is_attached */ call add_output (P_state.optr_len, (TF (fixed (abs_data.attach.victim_ptr ^= null)))); return; EXPAND (18): /* &is_defined */ if verify (P_arg, DIGITS) = 0 & P_arg ^= "" then do; /* for number: true if ec arg or defined by &default */ numeric_arg = cv_dec_check_ ((P_arg), code); if code ^= 0 then go to IS_VAR; if numeric_arg <= abs_data.arg_count then tf_string = "true"; else if numeric_arg > abs_data.default_arg_count then tf_string = "false"; else do; command_args_ptr = abs_data.default_arg_ptr; command_args_count = abs_data.default_arg_count; if command_args (numeric_arg).ptr = null then tf_string = "false"; else tf_string = "true"; end; call add_output (P_state.optr_len, (tf_string)); return; end; IS_VAR: /* for non-numeric: true if defined by &set */ if abs_data.variables_ptr = null then abs_data.variables_ptr = init_variables (); call add_output (P_state.optr_len, (TF (fixed (value_$defined (abs_data.variables_ptr, "01"b, (P_arg), code))))); if code ^= 0 then call error ("Format error in variables."); return; EXPAND (19): /* &is_input_line */ call add_output (P_state.optr_len, (TF (fixed (A_xd.is_input)))); return; EXPAND (20): /* &n */ call ioa_$rsnnl ("^d", short_string, 32, abs_data.arg_count); call add_output (P_state.optr_len, (short_string)); return; EXPAND (21): /* "e (...) (NOT IMPLEMENTED) */ /* call add_quoted_output (P_state.optr_len, (P_arg), QDOUBLE); */ go to BAD_AMP_WORD; EXPAND (22): /* &requote (...) (NOT IMPLEMENTED) */ /* call add_quoted_output (P_state.optr_len, (P_arg), REQUOTE); */ go to BAD_AMP_WORD; EXPAND (23): /* &unquote (...) (NOT IMPLEMENTED) */ go to BAD_AMP_WORD; EXPAND (24): /* &was_attached */ call add_output (P_state.optr_len, (TF (fixed (abs_data.in_handler_sw & abs_data.was_attached_sw)))); return; EXPAND (25): /* & */ call add_output (P_state.optr_len, copy ("&", numeric_arg)); return; EXPAND (26): /* &BS */ call add_output (P_state.optr_len, copy (BS, numeric_arg)); return; EXPAND (27): /* &CR */ call add_output (P_state.optr_len, copy (CR, numeric_arg)); return; EXPAND (28): /* &FF, &NP */ call add_output (P_state.optr_len, copy (FF, numeric_arg)); return; EXPAND (29): /* &HT */ call add_output (P_state.optr_len, copy (" ", numeric_arg)); return; EXPAND (30): /* &LF */ call add_output (P_state.optr_len, copy (NL, numeric_arg)); return; EXPAND (31): /* &NL */ call add_output (P_state.optr_len, copy (NL, numeric_arg)); return; EXPAND (32): /* &NP = &FF */ call add_output (P_state.optr_len, copy (FF, numeric_arg)); return; EXPAND (33): /* &QT */ call add_output (P_state.optr_len, copy ("""", numeric_arg)); return; EXPAND (34): /* &SP */ call add_output (P_state.optr_len, copy (" ", numeric_arg)); return; EXPAND (35): /* &VT */ call add_output (P_state.optr_len, copy (VT, numeric_arg)); return; end expand; %page; find_next_occurrence: proc (P_str, P_saved_pos, P_pos); /* Find the next occurrence P_pos of the string P_str starting at A_xd.input_pos. P_saved_pos is one of the saved "next occurrence" values in A_xd, e.g. A_xd.next_do_pos. If the value of P_saved_pos is already beyond A_xd.input_pos, just set P_pos = P_saved_pos. Otherwise, compute P_pos and set P_saved_pos = P_pos. */ dcl P_str char (*); dcl (P_pos, P_saved_pos, i) fixed bin (21); if P_saved_pos >= A_xd.input_pos then P_pos = P_saved_pos; else do; i = index (input, P_str); if i = 0 then P_pos = MAX_CHARS; /* agreed meaning is "no more left" */ else P_pos = A_xd.input_pos + i - 1; P_saved_pos = P_pos; end; end find_next_occurrence; %page; get_next_stmt: proc (A_ptr, A_len, A_pos, A_stmt); /* For abs_io_v2_get_line's look-ahead: type, po & length of next stmt keyword */ dcl A_ptr ptr; dcl (A_len, A_pos) fixed bin (21); dcl 1 A_stmt aligned like expand_data.this_statement; dcl str char (A_len) based (A_ptr); dcl key_name char (32); dcl (i, j, k) fixed bin (21); got_next_stmt = "1"b; if abs_data.noabort then do; i = index ( substr (str, A_pos), NL) + A_pos - 1; j = i + 1; abs_data.position = j; abs_data.limit = i; end; i = verify (substr (str, A_pos), WHITE || NL); if i = 0 then do; NO_NEXT: A_stmt.action = UNDEFINED; /* no next statement */ A_stmt.pos, A_stmt.len, A_stmt.keyword_len = 0; return; end; j = A_pos + i - 1; SEE_NEXT: if substr (str, j, 1) ^= "&" then do; /* a non-control line */ A_stmt.action, A_stmt.len, A_stmt.keyword_len = 0; return; end; if substr (str, j + 1, 1) = "-" then do; /* skip &- comment line */ k = index (substr (str, j), NL); if k = 0 then go to NO_NEXT; j = j + k; j = j + verify (substr (str, j), WHITE) - 1; /* skip leading white space */ go to SEE_NEXT; end; else do; k = search (substr (str, j), WHITE || NL || "("); /* find end of next token (stmt keyword?) */ if k = 0 then key_name = substr (str, j); else key_name = substr (str, j, k - 1); A_stmt.action = lookup_stmt (key_name); if A_stmt.action ^= 0 then A_stmt.len, A_stmt.keyword_len = length (rtrim (key_name)); else A_stmt.len, A_stmt.keyword_len = 0; /* non-control line */ end; A_stmt.pos = j; end get_next_stmt; %page; get_quoted_string: proc (P_str, P_ipos, P_state, P_q_sw); /* Called at &", finds matching end quote and saves string */ dcl P_str char (*); dcl P_ipos fixed bin (21); dcl 1 P_state like state; dcl P_q_sw bit (1); dcl inside_quotes_sw bit (1); dcl (i, ipos) fixed bin (21); inside_quotes_sw = "1"b; /* caller saw the &" */ ipos = P_ipos; do while (inside_quotes_sw); i = index (substr (P_str, ipos), """"); if i = 0 then call error ("Missing end quote for &"""); if ipos + i <= length (P_str) & substr (P_str, ipos + i, 1) = """" then do; /* imbedded double quote (= 1 quote) */ if P_q_sw then call add_quoted_output (P_state.optr_len, substr (P_str, ipos, i - 1) || """", "0"b); else call add_output (P_state.optr_len, substr (P_str, ipos, i - 1) || """"); ipos = ipos + i + 1; end; else do; /* single quote: closes string */ if P_q_sw then call add_quoted_output (P_state.optr_len, substr (P_str, ipos, i - 1), "0"b); else call add_output (P_state.optr_len, substr (P_str, ipos, i - 1)); P_ipos = ipos + i; inside_quotes_sw = "0"b; end; end; if output = "" & parse_args_sw then null_arg_sw = "1"b; end get_quoted_string; %page; grow_parsed_args: proc; /* Allocates more room for the parsed_args structure */ /* Implicit arguments are parsed_args_ptr and parsed_args_count */ dcl old_parsed_args_ptr ptr; old_parsed_args_ptr = parsed_args_ptr; parsed_args_count = parsed_args_count * 2; /* more room */ allocate parsed_args in (xd_area) set (parsed_args_ptr); parsed_args_ptr -> parsed_args.count = old_parsed_args_ptr -> parsed_args.count; parsed_args_ptr -> parsed_args = old_parsed_args_ptr -> parsed_args; A_xd.parsed_args_ptr = parsed_args_ptr; free old_parsed_args_ptr -> parsed_args in (xd_area); end grow_parsed_args; %page; init_variables: proc returns (ptr); /* Gets ptr to this ec's private "value seg" */ dcl value_header (72) fixed aligned based; dcl variables_ptr ptr; dcl code fixed bin (35); allocate value_header in (abs_data.work_area) set (variables_ptr); call value_$init_seg (variables_ptr, 1 /* non-shareable */, addr (abs_data.work_area), 0, code); if code ^= 0 then call error ("Unable to allocate variables."); return (variables_ptr); end init_variables; %page; known: proc (P_keyword) returns (bit (1)); /* TRUE & fills in P_keyword if P_keyword.name is found in NAMES */ dcl 1 P_keyword like state.keyword; dcl i fixed bin; i = index (NAMES_STRING, P_keyword.name || " "); if i = 0 then return ("0"b); i = divide (i + length (NAMES (1)), length (NAMES (1)), 17, 0); P_keyword.number = i + 3; /* 1 = PARAM; 3 = VAR; 3 = AF */ unspec (P_keyword.name_switches) = NAME_SWITCHES (i); unspec (P_keyword.param_switches) = "0"b; return ("1"b); end known; %page; known_dont_expand: proc (P_name) returns (bit (1)); /* TRUE if P_name is found in DONT_EXPAND (a &keyword that's a stmt control-arg) */ dcl P_name char (32) varying; dcl i fixed bin; i = index (DONT_EXPAND_STRING, P_name || " "); return (i ^= 0); end known_dont_expand; %page; known_param: proc (P_keyword, P_name) returns (bit (1)); /* TRUE & fills in P_keyword for parameter prefixes &q, &r, etc. */ dcl 1 P_keyword like state.keyword; dcl P_name char (32) varying; dcl i fixed bin; i = index (PARAMS_STRING, P_keyword.name || " "); if i = 0 then return ("0"b); i = divide (i + length (PARAMS (1)), length (PARAMS (1)), 17, 0); P_keyword = PARAM_KEYWORD; P_keyword.name = P_name; unspec (P_keyword.param_switches) = PARAM_SWITCHES (i); return ("1"b); end known_param; %page; lookup_stmt: proc (A_key_name) returns (fixed bin); /* Sees whether A_key_name is a beginning-of-stmt keyword */ dcl A_key_name char (32); return (divide (index (STMTS_STRING, A_key_name) + length (STMTS (1)) - 1, length (STMTS (1)), 17, 0)); end lookup_stmt; %page; parse_value: proc (P_state, P_str); /* Adds to the output string, meanwhile parsing into arguments */ dcl 1 P_state like state; dcl P_str char (*); dcl (vbreak, vstart) fixed bin (21); if parse_args_sw & nest_level < 2 & P_state.quote_factor = 1 & ^inside_quotes_sw then do; vstart = 1; PARSE_ARG: vbreak = search (substr (P_str, vstart), WHITE || "&"""); if vbreak ^= 0 then do; call add (substr (P_str, vstart, vbreak - 1)); if substr (P_str, vstart + vbreak - 1, 1) = "&" then if substr (P_str, vstart + vbreak, 1) = """" then do; /* &"..." */ vstart = vstart + vbreak + 1; call get_quoted_string (P_str, vstart, P_state, P_state.q_sw); end; else vstart = vstart + vbreak; /* continue searching */ else if substr (P_str, vstart + vbreak - 1, 1) = """" then do; /* handle regular "..." too */ vstart = vstart + vbreak; /* position past the first quote */ call get_quoted_string (P_str, vstart, P_state, P_state.q_sw); end; else do; if verify (output, WHITE) ^= 0 then call add_arg (P_state); vbreak = vstart + vbreak - 1; /* actual position of the start of the white space */ vstart = verify (substr (P_str, vbreak), WHITE); if vstart ^= 0 then do; vstart = vbreak + vstart - 1; go to PARSE_ARG; end; end; end; else call add (substr (P_str, vstart)); end; else call add (P_str); add: proc (P_str); /* Appends the string either quote_doubled or plain depending on P_state.q_sw */ dcl P_str char (*); if P_state.q_sw then call add_quoted_output (P_state.optr_len, P_str, "0"b); else call add_output (P_state.optr_len, P_str); end add; end parse_value; %page; pop_state: proc (P_nest_level, P_state); /* Process close paren */ dcl P_nest_level fixed bin; dcl 1 P_state like state; P_nest_level = max (P_nest_level - 1, 1); P_state = state_stack (P_nest_level); alloc_info = alloc_stack (P_nest_level); end pop_state; %page; print_trace: proc (P_str, P_trace, P_control_sw); dcl P_str char (*); dcl 1 P_trace aligned like abs_data.command_line; dcl P_control_sw bit (1); dcl control_word char (32) varying; if ^trace_sw then return; if P_control_sw = CONTROL then control_word = rtrim (STMTS (abs_data.this_action)) || " "; else control_word = ""; if P_trace.iocb = null then P_trace.iocb = iox_$user_output; call ioa_$ioa_switch_nnl (P_trace.iocb, P_trace.prefix || control_word || "^a^/", P_str); end print_trace; %page; push_state: proc (P_nest_level, P_state); /* Processes open paren */ dcl P_nest_level fixed bin; dcl 1 P_state like state; state_stack (P_nest_level) = P_state; alloc_stack (P_nest_level) = alloc_info; P_nest_level = P_nest_level + 1; state.optr = addcharno (state.optr, state.olen); state.omax_len = state.omax_len - state.olen; /* stay within allocated range */ state.olen = 0; state.quote_factor, state.qscan_start = 1; end push_state; %page; save_arg: proc; /* This procedure allocates a bigger saved_arg buffer if necessary to hold a long &[...] or other arg */ if state.olen > saved_arg_len then do; if saved_arg_allocated_sw then free saved_arg_ptr -> saved_arg in (xd_area); saved_arg_len = state.olen; if A_xd.area_ptr = null then A_xd.area_ptr = get_system_free_area_ (); allocate saved_arg in (xd_area) set (saved_arg_ptr); saved_arg_allocated_sw = "1"b; end; saved_arg = output; end save_arg; %page; trace_comment: proc (P_str); dcl P_str char (*); if abs_data.comment_line.prefix = "" then call print_trace ("&-" || P_str, abs_data.comment_line, NONCONTROL); else call print_trace (P_str, abs_data.comment_line, NONCONTROL); end trace_comment; %page; trace_expanded: proc (P_state, P_buffer); dcl 1 P_state like state; dcl P_buffer char (*) varying; dcl open_char char (4) varying; dcl i fixed bin; P_buffer = ""; if parse_args_sw then do; /* have to print parsed args too */ if A_xd.parsed_args_ptr ^= null then do parsed_arg_index = 1 to A_xd.parsed_args_ptr -> parsed_args.count; /* traced &set line should show arg grouping */ if search (parsed_arg, """" || WHITE) ^= 0 & abs_data.this_action = SET_ACTION then P_buffer = P_buffer || requote_string_ (parsed_arg) || " "; else P_buffer = P_buffer || parsed_arg || " "; end; end; do i = 1 to nest_level - 1; /* pick up expanded text of each nesting */ if state_stack (i).olen > 0 then P_buffer = P_buffer || substr (state_stack (i).optr -> output, 1, state_stack (i).olen); if state_stack (i).keyword.number = 0 then open_char = ""; else if state_stack (i).keyword.number = AF_REF then if state_stack (i).keyword.af_type = BAR_BAR_BK_TYPE then open_char = "||["; else if state_stack (i).keyword.af_type = BAR_BK_TYPE then open_char = "|["; else open_char = "["; else open_char = "("; P_buffer = P_buffer || state_stack (i).keyword.name || open_char; end; if P_state.olen > 0 then P_buffer = P_buffer || output; end trace_expanded; %page; trace_unexpanded: proc (P_str, P_trace); dcl P_str char (*); dcl 1 P_trace aligned like abs_data.command_line; if substr (P_str, 1, 5) = "&then" | substr (P_str, 1, 5) = "&else" | P_str = " &do" then return; if P_trace.iocb = null then P_trace.iocb = iox_$user_output; call ioa_$ioa_switch_nnl (P_trace.iocb, P_trace.prefix || "^a^/", P_str); end trace_unexpanded; %page; /* OTHER EXTERNAL ENTRIES TO abs_io_expand_ */ set: entry (A_vars_ptr, A_var, A_val, A_code); /* Called by abs_io_v2_get_line to perform &set using abs_data.variables_ptr */ delete_sw = "0"b; SET: if verify (A_var, DIGITS) = 0 & A_var ^= "" then /* parameter reference */ call error ("Attempt to &set the value of an argument."); else do; if A_vars_ptr = null then A_vars_ptr = init_variables (); if delete_sw then call value_$delete (A_vars_ptr, "01"b, A_var, A_code); else call value_$set (A_vars_ptr, "01"b, A_var, A_val, "", A_code); end; return; /* end of abs_io_expand_$set */ delete: entry (A_vars_ptr, A_var, A_val, A_code); /* Called by abs_io_v2_get_line to implement "&set var_name &undefined" */ /* NOTE: calling sequence has to be the same as $set to use common code. */ delete_sw = "1"b; go to SET; /* end of abs_io_expand_$delete */ %page; %include abs_io_data; %page; %include abs_io_expand; %page; %include abs_io_handler_node; %page; %include ec_data; %page; %include iocb; end abs_io_expand_;  abs_io_list_vars.pl1 08/11/87 1003.9r w 08/11/87 0925.7 54135 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ abs_io_list_vars: proc (A_abs_data_ptr, A_parsed_args_ptr, A_error_msg, A_code); /* Does &list_variables for abs_io_v2_get_line. Similar to the logic in the value_list command. */ /* Written 06/07/83 by Steve Herbst */ /* Parameters */ dcl (A_abs_data_ptr, A_parsed_args_ptr) ptr; dcl A_error_msg char (*); dcl A_code fixed bin (35); /* Based */ dcl arg char (arg_len) based (arg_ptr); dcl based_area area based (area_ptr); /* Automatic */ dcl (default_sw, exclude_first_sw, match_arg_sw, match_sw, val_sw, var_sw) bit (1) aligned; dcl (area_ptr, arg_ptr) ptr; dcl (i, name_index) fixed bin; dcl arg_len fixed bin (21); dcl code fixed bin (35); /* External */ dcl error_table_$badstar fixed bin (35) ext; dcl error_table_$badsyntax fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; /* Entries */ dcl check_star_name_$entry entry (char(*), fixed bin(35)); dcl get_system_free_area_ entry returns (ptr); dcl (ioa_, ioa_$nnl) entry options (variable); dcl requote_string_ entry (char(*)) returns(char(*)); dcl value_$list entry (ptr, bit(36) aligned, ptr, ptr, ptr, fixed bin(35)); /* Builtins */ dcl (index, null, substr, unspec) builtin; /* Conditions */ dcl cleanup condition; %page; abs_data_ptr = A_abs_data_ptr; parsed_args_ptr = A_parsed_args_ptr; A_code = 0; match_info_ptr, value_list_info_ptr = null; exclude_first_sw, match_sw, match_arg_sw, val_sw, var_sw = "0"b; alloc_name_count, alloc_max_name_len = 0; if parsed_args_ptr ^= null then do i = 1 to parsed_args.count; arg_ptr = parsed_args.ptr (i); arg_len = parsed_args.len (i); if index (arg, "&") = 1 then if arg = "&exclude" | arg = "&ex" | arg = "&match" then do; i = i + 1; if i > parsed_args.count then call error ("No value specified for " || arg); if ^match_sw & (arg = "&exclude" | arg = "&ex") then exclude_first_sw = "1"b; match_sw = "1"b; if arg = "&match" then match_arg_sw = "1"b; arg_ptr = parsed_args.ptr (i); arg_len = parsed_args.len (i); NAME: alloc_name_count = alloc_name_count + 1; alloc_max_name_len = max (alloc_max_name_len, arg_len); end; else if arg = "&value" | arg = "&val" then val_sw = "1"b; else if arg = "&variable" | arg = "&var" then var_sw = "1"b; else call error ("Invalid &list_variables control argument " || arg); else do; match_sw, match_arg_sw = "1"b; go to NAME; end; end; if ^val_sw & ^var_sw then val_sw, var_sw = "1"b; /* default is to print both var name and value */ default_sw = (alloc_name_count = 0); if default_sw then do; alloc_name_count = 1; alloc_max_name_len = 2; end; else if exclude_first_sw then alloc_name_count = alloc_name_count + 1; /* if &exclude is first, start by matching "**" */ /* Allocate and fill the match structure */ area_ptr = get_system_free_area_ (); on cleanup call clean_up; allocate match_info in (based_area) set (match_info_ptr); unspec (match_info) = "0"b; match_info.version = match_info_version_1; match_info.name_count = alloc_name_count; match_info.max_name_len = alloc_max_name_len; if default_sw | exclude_first_sw then do; name_index = 1; match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b; match_info.name (1) = "**"; end; else name_index = 0; if ^default_sw then do i = 1 to parsed_args.count; arg_ptr = parsed_args.ptr (i); arg_len = parsed_args.len (i); if index (arg, "&") = 1 then do; if arg = "&exclude" | arg = "&ex" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "1"b; MATCH_ARG: i = i + 1; MATCH_NAME: arg_ptr = parsed_args.ptr (i); arg_len = parsed_args.len (i); if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" & arg ^= "/" then do; match_info.regexp_sw (name_index) = "1"b; match_info.name (name_index) = substr (arg, 2, arg_len - 2); end; else do; call check_star_name_$entry (arg, code); if code = error_table_$badstar then call error ("Invalid starname arg to &list_variables: " || arg); match_info.regexp_sw (name_index) = "0"b; match_info.name (name_index) = arg; end; end; else if arg = "&match" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "0"b; go to MATCH_ARG; end; end; else do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "0"b; go to MATCH_NAME; end; end; call value_$list (abs_data.variables_ptr, "01"b, match_info_ptr, area_ptr, value_list_info_ptr, code); if code ^= 0 then if code = error_table_$nomatch then call ioa_ ("No variables set."); else do; A_error_msg = ""; A_code = code; end; /* Print the results */ else do i = 1 to value_list_info.pair_count; if var_sw then call ioa_$nnl ("^2x^a^[^30t^]", substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)), val_sw); if val_sw then call ioa_ ("^a", requote_string_ ( substr (value_list_info.chars, value_list_info.value_index (i), value_list_info.value_len (i)))); else call ioa_ (""); end; RETURN: call clean_up; return; %page; clean_up: proc; if match_info_ptr ^= null then free match_info_ptr -> match_info in (based_area); if value_list_info_ptr ^= null then free value_list_info_ptr -> value_list_info in (based_area); end clean_up; %page; error: proc (P_str); dcl P_str char (*); A_error_msg = P_str; A_code = error_table_$badsyntax; go to RETURN; end error; %page; %include abs_io_data; %page; %include abs_io_expand; %page; %include value_structures; end abs_io_list_vars;  abs_io_put_chars.pl1 08/11/87 1003.9r w 08/11/87 0925.5 159345 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style3,idind30,ll122,ifthenstmt */ abs_io_put_chars: procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_status); /* Initial coding: 25 June 1979 by J. Spencer Love as specified in MCR 3958 */ /* Changed to always set absout bc unless "ear -no_set_bit_count" 07/29/81 S. Herbst */ /* Fixed bug setting bit count one line early 03/19/82 S. Herbst */ /* Recompiled for changed abs_data structure 04/12/83 S. Herbst */ /* Changed to turn on absout safety switch while running 05/16/83 S. Herbst */ /* Changed to create absouts through links 11/14/84 Steve Herbst */ /* Parameters */ declare P_iocb_ptr ptr parameter, P_buffer_ptr ptr parameter, P_buffer_len fixed bin (21) parameter, P_attach_data_ptr ptr parameter, P_dir_name char (*) parameter, P_entry_name char (*) parameter, P_truncate bit (1) aligned parameter, P_MSF bit (1) aligned parameter, P_status fixed bin (35) parameter; /* Builtins */ declare (addr, binary, divide, length, max, min, mod, null, rtrim, substr) builtin; declare any_other condition; /* Automatic */ declare buffer_len fixed bin (21), buffer_ptr ptr, create_dir_name char (168), create_entry_name char (32), iocb_ptr ptr, mask bit (36), pad_len fixed bin (21), rest_of_buffer_len fixed bin (21), safety_switch bit (1) aligned, seg_max_len fixed bin (19), status fixed bin (35); declare 1 branch aligned like status_branch; /* Based */ declare buffer char (buffer_len) based (buffer_ptr), output_seg char (output_file.max_len) based (output_file.seg_ptr); /* Static */ declare max_buffer_size fixed bin (21) static; declare 1 file_is_full aligned static, 2 version fixed bin initial (0), 2 status_code fixed bin (35); declare 1 unable_to_do_io aligned static like file_is_full; %page; /* Constants */ declare NULL char (1) aligned static options (constant) initial (""); /* External Constants */ declare error_table_$buffer_big fixed bin (35) external, error_table_$dirseg fixed bin (35) external, error_table_$file_is_full fixed bin (35) external, error_table_$moderr fixed bin (35) external, error_table_$no_s_permission fixed bin (35) external, error_table_$unable_to_do_io fixed bin (35) external, sys_info$max_seg_size fixed bin (35) external; /* Entries */ declare continue_to_signal_ entry (fixed bin (35)), hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)), hcs_$get_safety_sw_seg entry (ptr, bit (1) aligned, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$reset_ips_mask entry (bit (36), bit (36)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$set_ips_mask entry (bit (36), bit (36)), hcs_$set_safety_sw_seg entry (ptr, bit (1) aligned, fixed bin (35)), hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)), msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)), msf_manager_$get_ptr entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35)), msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)), msf_manager_$close entry (pointer), terminate_process_ entry (char (*), ptr); %page; /* abs_io_put_chars: procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_status); */ iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; /* get our IOCB, so we can get attach data block. */ abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr; buffer_ptr = P_buffer_ptr; /* copy parameters so we can play with them */ buffer_len = P_buffer_len; if buffer_len < 0 | buffer_len > max_buffer_size then do; /* Punt if given invalid buffer size. */ P_status = error_table_$buffer_big; return; end; mask = ""b; /* zero mask if we need to switch output segments */ /* The following block ensures that no more data will ever get written into a component than will fit. The block will not be executed if the output segment is exactly filled, or if P_buffer_len is zero. It will only be executed if another output component is required. Note that the max_length of the output segment(s) is picked up at open time; if it is decreased we will take a fault before this code will be executed, and if it is increased, we will never take advantage of the additional space. */ do while (buffer_len + output_file.current_len > output_file.max_len); pad_len = output_file.max_len - output_file.current_len; rest_of_buffer_len = buffer_len - pad_len; /* PL/I compiler doesn't notice common subexpression */ buffer_len = pad_len; call write (); /* write as much as will fit in current component */ buffer_ptr = addr (substr (buffer, buffer_len + 1)); buffer_len = rest_of_buffer_len; call get_next_MSF_component (); /* get next MSF component if possible */ end; call write (); P_status = 0; return; %page; /* This entrypoint is called by abs_io_open if the opening mode is stream_input_output. It opens the specified output file. It is called with the IPS mask set to zero to prevent interruption. An any_other handler in abs_io_open will terminate the process if anything goes wrong. If the file is already an MSF, it is opened using msf_manager_, otherwise it is opened with a call to hcs_$make_seg, which creates it if it does not exist. The first call is to hcs_$status_long because the current length and effective mode are needed, otherwise it would have to make an additional call. In the MSF case, this call is not necessary and will have to be repeated on an MSF component, but it isn't known that hcs_$status_minf would suffice until too late. */ open: entry (P_attach_data_ptr, P_dir_name, P_entry_name, P_truncate, P_MSF, P_status); abs_data_ptr = P_attach_data_ptr; output_file.seg_ptr, output_file.fcb_ptr = null (); output_file.may_be_MSF = P_MSF; call hcs_$status_long (P_dir_name, P_entry_name, 1, addr (branch), null (), status); if branch.type = Link & (status = 0 | status = error_table_$no_s_permission) then do; /* chase link with nonexistent target */ call hcs_$get_link_target (P_dir_name, P_entry_name, create_dir_name, create_entry_name, status); if create_dir_name = "" then do; P_status = status; return; end; end; else do; create_dir_name = P_dir_name; create_entry_name = P_entry_name; end; if (status ^= 0 & status ^= error_table_$no_s_permission) | (branch.type ^= Segment & branch.type ^= Directory) then do; /* File does not exist. We will try to create it. */ branch.type = Segment; branch.mode = "01010"b; /* rw access for check later */ branch.bit_count, branch.current_length = 0; end; else if branch.type = Directory & branch.bit_count = 0 then do; /* File is a directory. Punt. */ P_status = error_table_$dirseg; return; end; if branch.type = Segment then call open_segment (); else call open_MSF (); file_is_full.status_code = error_table_$file_is_full; unable_to_do_io.status_code = error_table_$unable_to_do_io; P_status = 0; return; PUNT: /* Target for non-local goto's */ P_status = status; /* Error occured during open or close. */ return; %page; /* The following entrypoint is called by abs_io_close when output_file.seg_ptr ^= null (). It is called with the IPS mask set to zero; an any_other handler in abs_io_close will terminate the process if anything goes wrong. */ close: entry (P_attach_data_ptr, P_status); abs_data_ptr = P_attach_data_ptr; if output_file.turn_off_ssw then call hcs_$set_safety_sw_seg (output_file.seg_ptr, "0"b, (0)); pad_len = mod (-output_file.current_len, 4096); if pad_len ^= 0 then do; call hcs_$set_bc_seg (output_file.seg_ptr, 9 * output_file.current_len, status); if status ^= 0 then go to PUNT; /* Something very badly wrong. Punt immediately. */ end; if output_file.fcb_ptr = null () then do; /* File was SSF. */ call hcs_$terminate_noname (output_file.seg_ptr, (0)); output_file.seg_ptr = null (); /* TEMP: can go away when terminate_noname is fixed */ end; else do; /* File was opened as MSF. */ output_file.seg_ptr = null (); /* msf_manager_ will terminate this. */ call msf_manager_$close (output_file.fcb_ptr); end; P_status = 0; return; %page; /* The following procedure is used by abs_io_put_chars to actually transfer data into the current output segment. If a new page is touched, the bit count of the segment is set to the end of the page. Thus, data is never present beyond the end of file indicated by the bit count. The call to set the bit count MUST precede the code which does the actual transfer of output, so that data will never be lost. It is the reponsibility of the caller to determine that the data in buffer will fit in the output segment. */ write: procedure (); substr (output_seg, output_file.current_len + 1, buffer_len) = buffer; output_file.current_len = output_file.current_len + buffer_len; if ^abs_data.open_data.no_set_bc then do; call hcs_$set_bc_seg (output_file.seg_ptr, 9 * output_file.current_len, status); if status ^= 0 then go to PUNT; end; return; end write; %page; /* The following procedure is called when the segment which abs_io_put_chars is currently using is filled. If the file was opened as a single segment file, it is terminated and reopened as a multi-segment file. If -single_segment_file (-ssf) was specified at attach time, the process is terminated instead with error_table_$file_is_full as the reason. If anything goes wrong while we are switching output segments, there is nowhere for output to go from error handlers, so we terminate the process with the reason error_table_$unable_to_do_io. The output file may have been opened as an MSF and then truncated. In this case, it is still open as an MSF and msf_manager_ will automatically convert it back to an MSF. This is done because we can't depend on the MSF becoming an SSF when truncated since it might be upgraded. The whole operation is done with an IPS mask of zero so nothing can interrupt us. */ get_next_MSF_component: procedure (); declare dir_name char (168), entry_name char (32); on any_other begin; if substr (mask, 36, 1) then call terminate_process_ ("fatal_error", addr (unable_to_do_io)); else call continue_to_signal_ ((0)); end; call hcs_$set_ips_mask (mask, mask); if output_file.fcb_ptr = null () then do; /* Convert from SSF to MSF */ if ^output_file.may_be_MSF then call terminate_process_ ("fatal_error", addr (file_is_full)); call hcs_$fs_get_path_name (output_file.seg_ptr, dir_name, (0), entry_name, status); if status ^= 0 then go to PUNT_MASKED; if output_file.turn_off_ssw then do; call hcs_$set_safety_sw_seg (output_file.seg_ptr, "0"b, (0)); output_file.turn_off_ssw = "0"b; end; call hcs_$terminate_noname (output_file.seg_ptr, (0)); call msf_manager_$open (dir_name, entry_name, output_file.fcb_ptr, status); if status ^= 0 then go to PUNT_MASKED; output_file.MSF_seg_idx = 1; end; else output_file.MSF_seg_idx = output_file.MSF_seg_idx + 1; call msf_manager_$get_ptr (output_file.fcb_ptr, output_file.MSF_seg_idx, "1"b, output_file.seg_ptr, (0), status) ; if status ^= 0 then go to PUNT_MASKED; output_file.current_len = 0; /* start over at base of new component */ call hcs_$reset_ips_mask (mask, mask); return; PUNT_MASKED: call terminate_process_ ("fatal_error", addr (unable_to_do_io)); end get_next_MSF_component; %page; /* This entrypoint is called by abs_io_put_chars$open to open an output file which is a segment, which includes the case where the output file does not exist. It checks that rw access is available, makes it known, gets the max length and adjusts the length as specified. The other entrypoint, open_MSF, is described below. The two entrypoints are merged to reduce the number of non-quick internal procedure calls, and are declared options (non-quick) to keep the stack frame small for calls to abs_io_put_chars */ open_segment: procedure () options (non_quick); if (branch.mode & "01010"b) ^= "01010"b then do; /* We must have rw access on the file */ status = error_table_$moderr; go to PUNT; end; call hcs_$make_seg (create_dir_name, create_entry_name, "", 1010b, output_file.seg_ptr, status); if output_file.seg_ptr = null () then go to PUNT; /* We couldn't create the file. Punt. */ call get_max_len (); /* Needed by abs_io_put_chars and adjust_length */ if P_truncate then do; if branch.current_length ^= 0 then do; call hcs_$truncate_seg (output_file.seg_ptr, 0, status); if status ^= 0 then go to PUNT; end; if branch.bit_count ^= 0 then do; call hcs_$set_bc_seg (output_file.seg_ptr, 0, status); if status ^= 0 then go to PUNT; end; end; else call adjust_length (); call hcs_$get_safety_sw_seg (output_file.seg_ptr, safety_switch, status); if status = 0 & ^safety_switch then do; output_file.turn_off_ssw = "1"b; call hcs_$set_safety_sw_seg (output_file.seg_ptr, "1"b, status); end; return; %page; /* The following entrypoint is called by abs_io_put_chars$open to open an MSF for output. There are two separate tracks which are followed depending on whether truncation is required. In the non-truncation case, the length of the last component is adjusted by the same procedure used for SSF's. This necessitates another call to hcs_$status_long to acertain the effective mode and the current length of the component. The index of the last component is one less than the bit count of the MSF directory. In the truncation case, the length of the file is adjusted by a call to msf_manager_$adjust; it is assumed that rw access is present on the MSF if this call succeeds. The current length and last component index are known to be zero. */ open_MSF: entry (); declare dir_name char (168), entry_name char (32); call msf_manager_$open (P_dir_name, P_entry_name, output_file.fcb_ptr, status); if status ^= 0 then go to PUNT; if P_truncate then do; call msf_manager_$adjust (output_file.fcb_ptr, 0, 0, "110"b, status); if status ^= 0 then go to PUNT; call msf_manager_$get_ptr (output_file.fcb_ptr, 0, "1"b, output_file.seg_ptr, (0), status); if status ^= 0 then go to PUNT; call get_max_len (); output_file.MSF_seg_idx, output_file.current_len = 0; end; else do; output_file.MSF_seg_idx = branch.bit_count - 1; call msf_manager_$get_ptr (output_file.fcb_ptr, output_file.MSF_seg_idx, "1"b, output_file.seg_ptr, (0), status); if status ^= 0 then go to PUNT; call hcs_$fs_get_path_name (output_file.seg_ptr, dir_name, (0), entry_name, (0)); call hcs_$status_long (dir_name, entry_name, 1, addr (branch), null (), (0)); if (branch.mode & "01010"b) ^= "01010"b then do; status = error_table_$moderr; go to PUNT; end; call get_max_len (); call adjust_length (); end; return; end open_segment; %page; /* This procedure is called by open_segment and open_MSF to initialize output_file.max_len, which is needed by abs_io_put_chars and adjust_len, and max_buffer_size, which is needed by abs_io_put_chars. If the maximum length of the output component is zero, the file cannot be opened. */ get_max_len: procedure (); call hcs_$get_max_length_seg (output_file.seg_ptr, seg_max_len, status); if status ^= 0 then go to PUNT; if seg_max_len <= 0 then do; status = error_table_$file_is_full; go to PUNT; end; output_file.max_len = 4 * seg_max_len; max_buffer_size = 4 * sys_info$max_seg_size; return; end get_max_len; /* The following procedure is called by abs_io_put_chars$open to position the logical length of the file just beyond the end of valid data. All entrypoints in this external block cooperate to ensure that data can never be lost. get_max_len must be called before this procedure is called. */ adjust_length: procedure (); declare bc fixed bin (24); output_file.current_len = length (rtrim (substr (output_seg, 1, 4096 * binary (branch.current_length)), NULL)); pad_len = min (output_file.max_len, divide (max (0, branch.bit_count), 9, 21, 0)); if mod (output_file.current_len, 4096) = 0 then output_file.current_len = max (output_file.current_len, pad_len); else output_file.current_len = max (output_file.current_len, pad_len - 4095); bc = 9 * (output_file.current_len + pad_len); if bc ^= branch.bit_count then do; call hcs_$set_bc_seg (output_file.seg_ptr, bc, status); if status ^= 0 then go to PUNT; end; return; end adjust_length; %page; %include abs_io_data; %page; %include iocb; %page; %include status_structures; end abs_io_put_chars;  abs_io_v1_get_line.pl1 09/10/87 1500.1rew 09/10/87 1445.1 452628 /****^ *********************************************************** * * * 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(87-03-05,Parisek), approve(87-07-23,MCR7716), audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080): Continue execution with next exec_com line when abs_io_data.noabort is ON. 2) change(87-09-02,Parisek), approve(87-09-02,PBF7716), audit(87-09-03,Farley), install(87-09-10,MR12.1-1104): Handle a nobort operation only if severity 1 errors occur. END HISTORY COMMENTS */ /* Original coding: 25 June 1979 by J. Spencer Love Modified: 19 August 1981 by Steve Herbst not to loop if &detach gets an error. Modified: 14 February 1982 by Gary Palter for new calling sequence of ec_data.eval_string and to convert from command_processor_$af to cu_$evaluate_active_string. Modified: 7 June 1982 by J. Spencer Love to improve error checking for &then and &else clauses. */ /* Recompiled for changes to abs_data structure 04/12/83 S. Herbst */ /* format: style3,ifthenstmt,indcomtxt,indproc,idind30 */ abs_io_v1_get_line: procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status); declare P_iocb_ptr ptr, /* ptr to IOCB of abs_io_ or syn_ attached to abs_io_ */ P_buffer_ptr ptr, /* ptr to caller's input buffer */ P_buffer_len fixed bin (21), /* maximum length (in chars) of caller's buffer */ P_actual_len fixed bin (21), /* length of data actually returned */ P_status fixed bin (35); /* standard system error code */ declare (addr, binary, char, codeptr, copy, divide, index, length, ltrim, max, min, mod, null, rank, rtrim, search, string, substr, unspec, verify) builtin; declare (area, cleanup) condition; declare IS char (input_string.len) based (input_string.ptr), old_IS_pos fixed bin (21); declare CL_len fixed bin (21), CL_pos fixed bin (21), CL_ptr ptr, CL char (CL_len) based (CL_ptr), not_in_CL bit (1) aligned, old_CL_pos fixed bin (21); declare RS_len fixed bin (21), RS_pos fixed bin (21), RS_ptr ptr, RS char (RS_len) based (RS_ptr), old_RS_len fixed bin (21); %page; declare arg_idx fixed bin, break fixed bin, buffer_allocated bit (1) aligned, buffer_len fixed bin (21), buffer_ptr ptr, control fixed bin, copy_len fixed bin (21), from_sw bit (1) aligned, get_next_line local label variable, hash fixed bin, input_reset_sw bit (1) aligned, iocb_ptr ptr, len fixed bin (21), quote_modifier fixed bin, start fixed bin (21), state fixed bin, saved_hash fixed bin, saved_label_ptr ptr, saved_state fixed bin, scanning_clause bit (1) aligned, status fixed bin (35), test bit (1) aligned, twoL fixed bin (21), width fixed bin; declare 1 ready_mode aligned, 2 flag bit (1) unaligned, 2 pad bit (35) unaligned; declare ec_name char (arg_info.ec_name_len) based (arg_info.ec_name_ptr), ec_path char (arg_info.ec_path_len) based (arg_info.ec_path_ptr), P_buffer char (P_actual_len) based (P_buffer_ptr), allocated_chars char (abs_data.allocated_chars_len) based (abs_data.allocated_chars_ptr), return_arg char (ec_data.return_len) varying based (ec_data.return_ptr); declare arg_string char (arg_array (arg_idx).len) based (arg_array (arg_idx).ptr); declare 1 arg_array (abs_data.arg_count) aligned based (abs_data.arg_ptr), 2 ptr ptr, 2 len fixed bin (21), 2 quotes fixed bin (21); %page; declare INIT bit (1) aligned static options (constant) initial ("0"b), UPDATE bit (1) aligned static options (constant) initial ("1"b); declare NL char (1) static options (constant) initial (" "); declare NL_THEN_AMP char (2) static options (constant) initial (" &"); declare SPACE char (1) static options (constant) initial (" "), TRUE char (4) static options (constant) initial ("true"), FALSE char (5) static options (constant) initial ("false"), TRACE_THEN char (6) static options (constant) initial ("&then "), TRACE_ELSE char (6) static options (constant) initial ("&else "); declare RANK_ZERO fixed bin static options (constant) initial (48), RANK_AMP_ADJ fixed bin static options (constant) initial (-10), RANK_F_ADJ fixed bin static options (constant) initial (54); declare NONE fixed bin static options (constant) initial (0), QUOTE fixed bin static options (constant) initial (1), REQUOTE fixed bin static options (constant) initial (2); declare NORMAL fixed bin static options (constant) initial (0), SEARCHING_FOR_LABEL fixed bin static options (constant) initial (1), MUST_BE_LABEL fixed bin static options (constant) initial (2), MUST_BE_THEN fixed bin static options (constant) initial (3), SKIPPING_CLAUSE fixed bin static options (constant) initial (4); declare DATA fixed bin static options (constant) initial (-1), COMMENT fixed bin static options (constant) initial (0), ELSE fixed bin static options (constant) initial (6), GOTO fixed bin static options (constant) initial (7), LABEL fixed bin static options (constant) initial (10), THEN fixed bin static options (constant) initial (16); declare LOW (12) fixed bin static options (constant) initial (1, 2, 5, 6, 7, 8, 10, 11, 12, 13, 16, 17); declare HIGH (12) fixed bin static options (constant) initial (1, 4, 5, 6, 7, 9, 10, 11, 12, 15, 16, 17); declare KEYWORD (17) char (12) varying static options (constant) initial ("attach", "command_line", "comment_line", "control_line", "detach", "else", "goto", "if", "input_line", "label", "print", "quit", "ready", "ready_proc", "return", "then", "version"); declare TRACE (-1:17) bit (1) aligned static options (constant) initial ("0"b, "0"b, (5) ("1"b), "0"b, "1"b, "0"b, (7) ("1"b), "0"b, "0"b); declare SKIPABLE (-1:17) bit (1) aligned static options (constant) initial ("1"b, "0"b, (5) ("1"b), "0"b, "1"b, "0"b, "1"b, "0"b, (5) ("1"b), "0"b, "1"b); declare WHITE char (5) static options (constant) initial (" "); /* FF VT NL HT SP */ declare ( error_table_$noalloc, error_table_$command_line_overflow, error_table_$end_of_info, error_table_$long_record ) fixed bin (35) external, iox_$user_output ptr external, iox_$user_input ptr external; declare abs_io_control$attach entry (ptr, ptr, fixed bin (35)), abs_io_control$detach entry (ptr, ptr, fixed bin (35)), abs_io_control$sleep entry (ptr), active_fnc_err_ entry () options (variable), com_err_ entry () options (variable), cu_$arg_list_ptr entry () returns (ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)), cu_$set_ready_mode entry (1 aligned like ready_mode), hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)), ioa_$nnl entry options (variable), iox_$find_iocb entry (char (*), ptr, fixed bin (35)), iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)), logout entry options (variable), signal_io_error_ entry (char (*), ptr, fixed bin (35)); %page; /* abs_io_v1_get_line: procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status); */ call get_ptrs (INIT); /* the usual housekeeping to interface to the I/O system */ input_reset_sw = "0"b; /* recursion check. used to protect against &if [io get_line &ec_switch] (e.g., &if [query ...] in absentee) */ do while (abs_data.active); /* Loop until bit is cleared asynchronously, if set */ if attachedp () then do; /* Not our problem; we can offload this request to attachee */ call iox_$get_line (abs_data.attach.save_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status) ; return; end; call signal_io_error_ ("Attempt to invoke parser recursively. Check for invalid ""&if"" test.", iocb_ptr, 0); call get_ptrs (INIT); /* world may have changed, so reinit our view of it */ end; on cleanup abs_data.active = "0"b; /* Protect against non-local goto */ abs_data.active = "1"b; /* Prevent recursive invocation of this I/O switch */ /* Handle abnormal situations: no data left, or partial line remaining. Initialize for exit paths as needed. */ if abs_data.eof then go to END_OF_FILE; /* No data left, just exit without doing any work */ if abs_data.chars_len > 0 then go to CONTINUE_LONG_RECORD; /* Timed input mode: used in absentee processes to simulate interactive usage patterns */ if abs_data.timed_input then call abs_io_control$sleep (abs_data_ptr); /* Now initialize variables for the scan... */ width = 0; /* width of modifier field, e.g., f, q, r, qf, rf, f&n, etc */ quote_modifier = NONE; /* quote processing to be done to current parameter */ from_sw = "0"b; /* current parameter doesn't (yet) have f as in &f */ saved_hash = -1; /* used by &goto... valid range 0:60 */ /* Hack nested &if statements where we returned something and have to skip the rest of a compound statement */ if abs_data.nest_level > abs_data.expected_nest_level then state = SKIPPING_CLAUSE; /* In the middle of an &if: if we're here, skip the rest */ else state = NORMAL; if abs_data.else_clause_len > 0 then go to CONTINUE_WITH_PENDING_ELSE_CLAUSE; /* not finished with last line, can't expand another yet */ buffer_allocated = "0"b; /* Initially expanding into P_buffer */ get_next_line = EXPAND_NEXT_LINE; /* Normal setting. Used by &if nesting get control back. */ CL_len = 0; /* No statements scanned yet, so don't skip anything */ %page; EXPAND_NEXT_LINE: input_string.position = input_string.position + CL_len; /* Position to the beginning of the next statement */ if input_string.position >= input_string.len then go to END_OF_FILE; /* If we've gone too far, punt now */ CL_ptr = addr (substr (IS, input_string.position + 1)); CL_len = index (substr (IS, input_string.position + 1), NL); if CL_len = 0 then go to NO_NEW_LINE; /* Must be at end of file, print warning and &quit */ not_in_CL = "0"b; /* Use original line in input seg, no expansions so far */ scanning_clause = "0"b; /* We are not currently within an &then or &else clause */ CL_pos = index (CL, "&") - 1; /* Find the first ampersand in the current line */ if CL_pos < 0 then go to COPY_REST; /* No ampersands in line. Skip expansion loop. */ RS_len, old_CL_pos, old_RS_len = 0; /* So far we've expanded nothing */ RS_ptr = buffer_ptr; /* We will expand to here, if necessary */ twoL = 1; /* This is 2**(quote depth), used for requoting */ if CL_pos = 0 then do; /* First char is ampersand. Special case for fast comments */ break = index ("0123456789efinqracdglptv", substr (CL, 2, 1)) - 1; if break < 0 then go to COMMENT_LINE; /* If it's a comment, we needn't expand it or return it */ if break < 10 then go to EXPAND_ARG_NUMBER; /* A digit. Get whole number and expand argument */ if break < 16 then go to EXPAND (break);/* Might be expandable, investigate further */ go to EXPAND_AGAIN; /* This might be a keyword, but we can't handle it now. */ end; %page; /* This is the loop which expands lines from the input segment. It is entered here if the first character on the line is not an ampersand. If the first character is an ampersand, it will have been handled on the previous page as a performance hack to not expand comment lines. If no expandable constructs are encountered, the line will still be in the input segment. If expansion is done, it is initially into the caller-provided buffer, but if that is too small, a larger buffer will be allocated and expansion will use it until the next line is returned to the caller. */ EXPAND_LOOP: break = index ("0123456789efinqr", substr (CL, CL_pos + 2, 1)) - 1; if break < 0 then go to EXPAND_AGAIN; /* Not expandable. skip it */ if break < 10 then go to EXPAND_ARG_NUMBER; /* A digit. Get whole number and expand argument */ go to EXPAND (break); /* Might be expandable... investigate further */ EXPAND (10): /* &e */ if substr (CL, CL_pos + 3, 1) ^= "c" then go to EXPAND_AGAIN; /* performance hack for &else */ if substr (CL, CL_pos + 4, min (CL_len, 5)) = "_name" then call emit_ec_name (); else if substr (CL, CL_pos + 4, min (CL_len - 3, 4)) = "_dir" then call emit_ec_dir (); else if substr (CL, CL_pos + 4, min (CL_len - 3, 7)) = "_switch" then call emit_ec_switch (); go to EXPAND_AGAIN; EXPAND (11): /* &f */ from_sw = "1"b; go to EXPAND_MODIFIER; EXPAND (12): /* &i */ if substr (CL, CL_pos + 3, 1) ^= "s" then go to EXPAND_AGAIN; /* Performance hack for &if */ if substr (CL, CL_pos + 4, min (CL_len - 3, 6)) = "_absin" then call predicate (abs_data.absentee, 8); else if substr (CL, CL_pos + 4, min (CL_len - 3, 16)) = "_active_function" then call predicate (functionp (), 18); else if substr (CL, CL_pos + 4, min (CL_len - 3, 3)) = "_af" then call predicate (functionp (), 5); else if substr (CL, CL_pos + 4, min (CL_len - 3, 9)) = "_attached" then call predicate (attachedp (), 11); else if substr (CL, CL_pos + 4, min (CL_len - 3, 11)) = "_input_line" then call predicate (input_linep (), 13); go to EXPAND_AGAIN; EXPAND (13): /* &n: The number of arguments given for substitution */ call emit_arg_count (); go to EXPAND_AGAIN; EXPAND (14): /* &q */ quote_modifier = QUOTE; go to EXPAND_MODIFIER; EXPAND (15): /* &r */ quote_modifier = REQUOTE; EXPAND_MODIFIER: width = width + 1; break = rank (substr (CL, CL_pos + width + 2, 1)) - RANK_ZERO; if break = RANK_F_ADJ & ^from_sw then do; from_sw = "1"b; go to EXPAND_MODIFIER; end; if break = RANK_AMP_ADJ then if substr (CL, CL_pos + width + 3, 1) = "n" then do; /* &..&n: Appropriately modified last argument */ arg_idx = abs_data.arg_count; width = width + 2; go to COPY_ARG; end; if break < 0 | break > 9 then do; /* Construct isn't really a parameter, skip it */ width = 0; /* Reset these to default values, save the work elsewhere */ quote_modifier = NONE; from_sw = "0"b; go to EXPAND_AGAIN; end; EXPAND_ARG_NUMBER: arg_idx = 0; do break = break repeat (rank (substr (CL, CL_pos + width + 2, 1)) - RANK_ZERO) while (break >= 0 & break <= 9); if arg_idx <= abs_data.arg_count then arg_idx = 10 * arg_idx + break; width = width + 1; end; COPY_ARG: call copy_up_to_ampersand (width); /* Skip construct (width chars long) */ width = 0; if from_sw then do; /* User specified range of arguments to expand */ from_sw = "0"b; do arg_idx = max (1, arg_idx) to abs_data.arg_count; call copy_string (arg_string, quote_modifier); if arg_idx ^= abs_data.arg_count then call copy_string (SPACE, NONE); end; end; else if arg_idx = 0 then call copy_string (ec_path, quote_modifier); else if arg_idx <= abs_data.arg_count then call copy_string (arg_string, quote_modifier); quote_modifier = NONE; EXPAND_AGAIN: CL_pos = CL_pos + 1; /* Skip ampersand */ break = index (substr (CL, CL_pos + 1), "&") - 1; if break >= 0 then do; /* Any more ampersands in line? */ CL_pos = CL_pos + break; go to EXPAND_LOOP; end; COPY_REST: if not_in_CL then do; /* Copy rest of line if any expansions */ copy_len = CL_len - old_CL_pos; call check_len (copy_len); substr (RS, RS_len - copy_len + 1, copy_len) = substr (CL, old_CL_pos + 1, copy_len); end; else do; /* Use unexpanded string, we may not need to copy it */ RS_len = CL_len; RS_ptr = CL_ptr; end; %page; /* We come here to identify the current request line as a statement, command, or expansion to be returned. We can get here by falling through from expansion, or to identify an &then or &else clause. */ CHECK_CONTROL: if substr (RS, 1, min (1, RS_len)) = "&" then do; /* If first char is ampersand, hash on second char */ break = index ("acdegilpqrtv", substr (RS, 2, 1)); if break = 0 then go to COMMENT_LINE; len = search (substr (RS, 3), WHITE); /* Get length of possible keyword */ do control = LOW (break) to HIGH (break); if KEYWORD (control) = substr (RS, 2, len) then do; /* Got a match! so just space RS_pos over it */ RS_pos = verify (substr (RS, len + 3), WHITE) + len + 1; if RS_pos = len + 1 then RS_pos = RS_len; go to STATE (state); /* And we're off to an action routine (of some sort) */ end; end; if len > 4 then if break = 4 then if substr (RS, 2, 4) = "else" then call warning (0, "Whitespace must follow the ""&else"" keyword or the line is a comment."); else ; else if break = 11 then if substr (RS, 2, 4) = "then" then call warning (0, "Whitespace must follow the ""&then"" keyword or the line is a comment."); COMMENT_LINE: control = COMMENT; /* We have a leading ampersand but no keyword. Ignore it */ end; else control = DATA; /* No ampersand so this line can be returned to user */ go to STATE (state); /* Off to the wars (someone will handle this line) */ STATE (0): /* NORMAL: we come here if not in search or conditional */ if TRACE (control) then call trace_output (abs_data.control_line, RS); go to CONTROL (control); /* This is where we really head off to the action routine */ %page; CONTINUE_LONG_RECORD: buffer_allocated = "1"b; /* Tell exit routine to take data out of buffer */ CL_len = 0; /* Don't skip over statement since we did no expansion */ scanning_clause = "0"b; /* Init this for tastefulness sake */ not_in_CL = "1"b; /* Not from input segment */ RS_len = abs_data.chars_len; /* set RS to pending string */ RS_ptr = abs_data.chars_ptr; CONTROL (-1): /* DATA = data to return to caller */ if not_in_CL & ^buffer_allocated & ^scanning_clause then P_actual_len = RS_len; /* All done since all data is already in caller's buffer */ else do; /* Otherwise copy as much as will fit */ P_actual_len = min (P_buffer_len, RS_len); P_buffer = RS_ptr -> P_buffer; /* If it doesn't all fit, stash the rest for later calls */ if P_actual_len < RS_len then if not_in_CL then do; /* We have an allocated buffer, and characters in it */ abs_data.chars_ptr = addr (substr (RS, P_actual_len + 1)); abs_data.chars_len = RS_len - P_actual_len; end; else do; /* this means no pending &else clause or full buffer */ RS_ptr = addr (substr (RS, P_actual_len + 1)); abs_data.chars_len, RS_len = RS_len - P_actual_len; call allocate_buffer (RS_len); abs_data.chars_ptr = RS_ptr; end; else abs_data.chars_len = 0; end; if abs_data.allocated_chars_ptr ^= null () & abs_data.chars_len <= 0 & abs_data.else_clause_len <= 0 then free allocated_chars; /* We don't need the buffer anymore so we can dump it */ input_string.position = input_string.position + CL_len; /* Step over statement so we will get next one later */ if input_linep () then call trace_output (abs_data.input_line, P_buffer); else call trace_output (abs_data.command_line, P_buffer); if abs_data.chars_len > 0 then P_status = error_table_$long_record; /* Pending chars exist so tell caller */ else P_status = 0; EGRESS: abs_data.active = "0"b; return; %page; NO_NEW_LINE: if state = SEARCHING_FOR_LABEL then go to STATE (SEARCHING_FOR_LABEL); /* &goto should field this */ if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited his ec */ call warning (0, "The last line did not end in a newline and was ignored."); END_OF_FILE: if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited his ec. */ if state = MUST_BE_THEN then call error (0, "The end of file was encountered when a ""&then"" statement was expected."); abs_data.eof = "1"b; /* Make sure that end of file is remembered */ if ^input_reset_sw then do; /* Mustn't leave &attach in effect */ input_reset_sw = "1"b; call reset_input (); end; if abs_data.absentee then call logout (); P_actual_len = 0; /* Tell user what happened and how much data he got */ P_status = error_table_$end_of_info; go to EGRESS; /* Only one exit allowed for cleanup purposes */ %page; /* The following small serving of spaghetti is used to implement &goto and &label. Labels are kept in chained buckets in a small hash table. Buckets are allocated the first time a label is seen, whether it it in a &label or a &goto. There is no limit on the length of labels and the characters in a label, except that leading and trailing whitespace are removed from them. The blank label is allowed. Label search is defined to find the first instance of a label starting from the top of the file, so duplicate instances of the same label are ignored. The hashed label scheme is a large performance improvement in big exec_coms. */ CONTROL (7): /* &goto */ abs_data.nest_level = 0; /* reset nest state, so parser doesn't think we are */ abs_data.else_clause_len = 0; /* still in if statement or have else clause pending. */ get_next_line = EXPAND_NEXT_LINE; /* also set scanner back to normal */ input_string.limit = max (input_string.limit, input_string.position + CL_len); /* save farthest point in case backward branch */ go to GET_CURRENT_LABEL; /* now go parse statement */ CONTROL (10): /* &label */ if scanning_clause then call error (0, "A label may not follow ""&then"" or ""&else""."); if input_string.limit > input_string.position then go to get_next_line; /* Have we seen this label already? */ GET_CURRENT_LABEL: current_label_ptr = addr (substr (RS, RS_pos + 1)); current_label_len = length (rtrim (substr (RS, RS_pos + 1), WHITE)); hash = mod (binary (unspec (char (substr (current_label, 1, min (2, current_label_len)), 2)), 18) + current_label_len, 61); if hash = saved_hash /* cheap test -- saved_hash = -1 if not looking */ then if current_label = saved_label_ptr -> label.name then do; saved_hash = -1; /* reset saved_hash to illegal value for test */ if state = MUST_BE_LABEL then do; /* Label found in hash table has been verified */ state = NORMAL; go to get_next_line; end; state = NORMAL; /* reset from SEARCHING_FOR_LABEL */ label_ptr = saved_label_ptr; /* so saved block will be threaded properly */ go to THREAD_IN_LABEL; end; if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited the input file. */ if abs_data.labels_ptr = null () then call allocate_hash_table (); do label_ptr = abs_data.labels_ptr -> hash_table (hash) repeat (label.next_ptr) while (label_ptr ^= null ()); if current_label = label.name /* if match then three possible actions */ then if control = LABEL /* for label we just go to next line, which in */ then if state = NORMAL /* search mode calls for special action to */ then go to get_next_line; /* only scan control lines for efficiency */ else go to GET_NEXT_LABEL_LINE; else do; saved_hash = hash; saved_label_ptr = label_ptr; old_IS_pos = input_string.position; input_string.position = label.statement_pos; if input_string.position > 0 then if substr (IS, input_string.position, 1) ^= NL then go to UNSTUCK_LABEL; state = MUST_BE_LABEL; CL_len = 0; go to get_next_line; end; end; on area call error (error_table_$noalloc, "Allocating label ""^a"".", current_label); allocate label in (abs_data.work_area); /* we need a new label cell since we now know this label */ /* has never been seen before. length is arbitrary */ revert area; if control = GOTO then do; saved_hash = hash; /* we do this for cheap compare above */ saved_label_ptr = label_ptr; /* we will need this later for compare and threading in */ old_IS_pos = input_string.position; /* this is for line number in error message */ state = SEARCHING_FOR_LABEL; /* set state to ignore everything but labels */ input_string.position = input_string.limit - CL_len; go to GET_NEXT_LABEL_LINE; /* start search beyond what we've already seen */ end; THREAD_IN_LABEL: label.statement_pos = input_string.position; /* set label to beginning of its line */ label.next_ptr = abs_data.labels_ptr -> hash_table (hash); abs_data.labels_ptr -> hash_table (hash) = label_ptr; if state = NORMAL then go to get_next_line; /* We are done unless still skipping */ GET_NEXT_LABEL_LINE: input_string.position = input_string.position + CL_len; CL_len = index (substr (IS, input_string.position), NL_THEN_AMP) - 1; /* search for next control string */ if CL_len >= 0 then go to get_next_line; /* Found something; check it out */ input_string.position = old_IS_pos; /* Restore position for error message. */ call error (0, "Label ""^a"" not found.", saved_label_ptr -> label.name); STATE (1): /* SEARCHING_FOR_LABEL */ if control = LABEL then go to GET_CURRENT_LABEL; /* in this state we ignore everything but &label lines */ else go to GET_NEXT_LABEL_LINE; /* since efficient label search is critical */ STATE (2): /* MUST_BE_LABEL */ if control = LABEL then go to GET_CURRENT_LABEL; UNSTUCK_LABEL: input_string.position = old_IS_pos; state = NORMAL; call error (0, "Label ""^a"" is unstuck. Active programs may not be edited.", saved_label_ptr -> label.name); %page; CONTROL (0): /* COMMENT LINE */ if scanning_clause then call error (0, "A comment may not follow ""&then"" or ""&else""."); call trace_output (abs_data.comment_line, CL); go to get_next_line; CONTROL (11): /* &print */ call ioa_$nnl (substr (RS, min (RS_pos + 1, RS_len))); go to get_next_line; CONTROL (12): /* &quit */ if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&quit""."); go to END_OF_FILE; CONTROL (15): /* &return */ if RS_pos = RS_len then RS_pos = RS_pos - 1; /* Newline at end of null return string is not white space */ RS_ptr = addr (substr (RS, RS_pos + 1)); /* Adjust RS to only be argument of statement */ RS_len = RS_len - RS_pos; if functionp () then do; RS_len = RS_len - 1; /* Don't return newline at end for active function */ if RS_len > ec_data.return_len then call warning (error_table_$command_line_overflow, "Expanded value length of ^d characters exceeds return argument length of ^d characters.", RS_len, ec_data.return_len); return_arg = RS; end; else call iox_$put_chars (iox_$user_output, RS_ptr, RS_len, status); go to END_OF_FILE; CONTROL (17): call error (0, "The ""&version"" statement may only be the first line of the program."); %page; CONTROL (1): /* &attach */ if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&attach""."); if ec_data_ptr ^= null () & ^attachedp () then do; call abs_io_control$attach (abs_data_ptr, null (), status); if status ^= 0 then call error (status, "Error while performing ""&attach""."); end; go to get_next_line; CONTROL (5): /* &detach */ if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&detach""."); input_string.position = input_string.position + CL_len; /* Adjust position in case call to reset_input fails */ CL_len = 0; /* Make sure that it isn't adjusted twice if it doesn't */ call reset_input (); /* Do &detach, call get_line for saved switch if input line */ go to get_next_line; reset_input: procedure (); if attachedp () then do; call abs_io_control$detach (abs_data_ptr, null (), status); if status ^= 0 then call error (status, "Error while performing ""&detach""."); if input_linep () then do; call iox_$get_line (iox_$user_input, P_buffer_ptr, P_buffer_len, P_actual_len, P_status); go to EGRESS; end; end; return; end; %page; CONTROL (13): /* &ready */ string (ready_mode) = ""b; ready_mode.flag = trace_mode (); if ec_data_ptr ^= null () then if codeptr (ec_data.set_ready_mode) ^= null () then call ec_data.set_ready_mode (ready_mode); else call cu_$set_ready_mode (ready_mode); else call cu_$set_ready_mode (ready_mode); go to get_next_line; CONTROL (14): /* &ready_proc */ test = trace_mode (); if ec_data_ptr ^= null () then ec_data.call_ready_proc = test; go to get_next_line; trace_mode: procedure () returns (bit (1) aligned); if RS_len = RS_pos then do; call warning (0, "Missing keyword in mode statement. ""on"" assumed."); return ("1"b); end; RS_len = length (rtrim (RS, WHITE)); if substr (RS, RS_pos + 1) = "on" | substr (RS, RS_pos + 1) = "true" then return ("1"b); if substr (RS, RS_pos + 1) = "off" | substr (RS, RS_pos + 1) = "false" then return ("0"b); call warning (0, "Illegal keyword in mode statement. ""on"" assumed."); return ("1"b); end; %page; CONTROL (2): /* &command_line */ call trace_control (abs_data.command_line); go to get_next_line; CONTROL (3): /* &comment_line */ call trace_control (abs_data.comment_line); go to get_next_line; CONTROL (4): /* &control_line */ call trace_control (abs_data.control_line); go to get_next_line; CONTROL (9): /* &input_line */ call trace_control (abs_data.input_line); go to get_next_line; trace_control: procedure (trace_structure); declare 1 trace_structure aligned like abs_data.command_line; if RS_len = RS_pos then do; call warning (0, "Missing keyword in tracing statement. ""on"" assumed."); trace_structure.on = "1"b; return; end; len = search (substr (RS, RS_pos + 2), WHITE); /* Find end of keyword */ RS_len = length (rtrim (RS, WHITE)); /* Find end of tokens on line */ if substr (RS, RS_pos + 1) = "on" | substr (RS, RS_pos + 1) = "true" then trace_structure.on = "1"b; else if substr (RS, RS_pos + 1) = "off" | substr (RS, RS_pos + 1) = "false" then trace_structure.on = "0"b; else if substr (RS, RS_pos + 1, len) = "output_switch" | substr (RS, RS_pos + 1, len) = "osw" then if RS_pos + len >= RS_len then trace_structure.iocb = null (); else do; RS_pos = RS_pos + len + verify (substr (RS, RS_pos + len + 2), WHITE); call iox_$find_iocb (substr (RS, RS_pos + 1), trace_structure.iocb, status); if status ^= 0 then call error (status, "Finding stream ""^a"".", substr (RS, RS_pos + 1)); end; else do; call warning (0, "Invalid keyword in tracing statement. ""on"" assumed."); trace_structure.on = "1"b; end; return; end trace_control; %page; trace_output: procedure (trace_structure, line); declare 1 trace_structure aligned like abs_data.command_line, line char (*); declare switch ptr; do while (trace_structure.on); /* Do this only if tracing is enabled. */ if trace_structure.iocb = null () then switch = iox_$user_output; /* Default */ else switch = trace_structure.iocb; call iox_$put_chars (switch, addr (line), length (line), status); if status = 0 then return; /* Exit if line successfully traced */ call signal_io_error_ ("Unable to do trace output. Correct I/O attachments and type ""start"".", switch, status); call get_ptrs (UPDATE); /* Make sure user didn't do too good a job of "correction" */ end; return; end trace_output; /* This procedure copies parameters and gets pointers to our databases. It is called when abs_io_v1_get_line is entered and after calling signal_io_error_ to make sure that nothing has changed that we care about. */ get_ptrs: procedure (update); declare update bit (1) aligned; iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; if update then do; do while (abs_data_ptr ^= iocb_ptr -> iocb.attach_data_ptr); call signal_io_error_ ("Attachment of " || abs_data.io_module_name || " has been moved.", P_iocb_ptr, 0); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; end; return; end; abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr; ec_data_ptr = abs_data.ec_data_ptr; buffer_ptr = P_buffer_ptr; buffer_len = P_buffer_len; return; end get_ptrs; %page; CONTROL (8): /* &if */ start = find_clause ("&then"); if RS_len = RS_pos | start = RS_pos then call error (0, "Missing conditional in ""&if"" statement."); if start >= 0 then do; old_RS_len = RS_len; /* Save for locating &then clause */ RS_len = start; /* Delay assignment for benefit of error message routine. */ end; RS_len = length (rtrim (RS, WHITE)); abs_data.nest_level = abs_data.nest_level + 1; if state = NORMAL then do; call trace_output (abs_data.control_line, RS); call trace_output (abs_data.control_line, NL); abs_data.expected_nest_level = abs_data.nest_level; if ^conditional () then state = SKIPPING_CLAUSE; end; if start < 0 then do; saved_state = state; state = MUST_BE_THEN; go to EXPAND_NEXT_LINE; /* Go direct, don't mess around. This state is indivisible */ end; RS_ptr = addr (substr (RS, start + 1)); RS_len = old_RS_len - start; RS_pos = verify (substr (RS, 6), WHITE) + 4; /* Find beginning of clause beyond "&then" */ if RS_pos = 4 then RS_pos = RS_len; %page; CONTINUE_THEN: if abs_data.else_clause_len <= 0 then do; /* maybe we even have the &else */ start = find_clause ("&else"); if start >= 0 then do; /* We do. Copy the whole line into an allocated buffer */ if ^not_in_CL | ^buffer_allocated then call allocate_buffer (RS_len); abs_data.else_clause_len = RS_len - start; abs_data.else_clause_ptr = addr (substr (RS, start + 1)); RS_len = length (rtrim (substr (RS, 1, start), WHITE)) + 1; substr (RS, RS_len, 1) = NL; /* Break the line. We'll get rest of the line next time */ get_next_line = GET_PENDING_ELSE_CLAUSE; end; end; if RS_pos >= RS_len then RS_pos = RS_len - 1; /* Newline at end of null line is not white space */ RS_ptr = addr (substr (RS, RS_pos + 1)); /* Step over &then or &else and following whitespace */ RS_len = RS_len - RS_pos; if state = NORMAL then do; /* This clause will be executed. First, we trace ourself. */ if control = THEN then call trace_output (abs_data.control_line, TRACE_THEN); else call trace_output (abs_data.control_line, TRACE_ELSE); abs_data.expected_nest_level = 0; /* After taking this clause we skip until back at top level */ if abs_data.else_clause_len = 0 & abs_data.nest_level > 0 then get_next_line = ENTER_SKIPPING_CLAUSE_STATE; end; /* Arrange to set state to skipping after taking clause */ scanning_clause = "1"b; /* Comments and labels are forbidden in clauses */ go to CHECK_CONTROL; /* Prepare to execute clause */ STATE (3): /* MUST_BE_THEN */ if control = COMMENT then go to get_next_line; /* comments are allowed between &if and &else statements */ if control ^= THEN then call error (0, "Missing ""&then"" keyword following ""&if"" statement."); state = saved_state; /* pop state saved in &if (NORMAL or SKIPPING_CLAUSE) */ go to CONTINUE_THEN; CONTROL (16): /* &then: this can't be reached by a legitimate clause */ call error (0, "Unexpected ""&then"" statement."); %page; CONTINUE_WITH_PENDING_ELSE_CLAUSE: buffer_allocated = "1"b; /* We have just reentered, so initialize--this must be */ CL_len = 0; /* We haven't done any expansion this time, so don't skip */ not_in_CL = "1"b; /* in an allocated buffer, not in the input file */ GET_PENDING_ELSE_CLAUSE: RS_len = abs_data.else_clause_len; /* Set RS to pending &else clause in allocated buffer */ RS_ptr = abs_data.else_clause_ptr; abs_data.else_clause_len = 0; /* Unmark pending &else clause storage */ RS_pos = verify (substr (RS, 6), WHITE) + 4; /* Set RS_pos as if we came from CHECK_CONTROL */ if RS_pos = 4 then RS_pos = RS_len; /* Locate it at first non-white char or at end of line */ get_next_line = EXPAND_NEXT_LINE; /* Reset this since we don't want to come back here */ control = ELSE; /* This is the only kind of statement that is ever pending */ CONTROL (6): /* &else */ if abs_data.nest_level <= 0 then call error (0, "Unexpected ""&else"" statement."); abs_data.nest_level = abs_data.nest_level - 1; /* Implement nesting here */ if abs_data.nest_level < abs_data.expected_nest_level then state = NORMAL; else state = SKIPPING_CLAUSE; go to CONTINUE_THEN; STATE (4): /* SKIPPING_CLAUSE */ if ^scanning_clause then if control = ELSE | control = COMMENT then go to CONTROL (control); /* &else or comments are part of nested compound statement */ else do; /* anything else ends compound statement */ scanning_clause = "0"b; /* comments and &labels are legal again */ state = NORMAL; /* nested statement must end here */ abs_data.nest_level = 0; /* so reset back to top level */ go to STATE (NORMAL); end; if SKIPABLE (control) then go to get_next_line; else go to CONTROL (control); ENTER_SKIPPING_CLAUSE_STATE: state = SKIPPING_CLAUSE; /* We have taken a clause, so we skip rest of if statement */ get_next_line = EXPAND_NEXT_LINE; /* Reset this, we don't need to come here again */ go to EXPAND_NEXT_LINE; %page; /* This function is called from &if to find &then and from &then or &else to find an &else which follows on the same line. The contract of the function is to return the length of the string preceding the keyword, which must be delimited on BOTH sides by whitespace. If it is followed by a newline, that is considered whitespace. If the clause is not found, the -1 is returned. */ find_clause: procedure (keyword) returns (fixed bin (21)); declare keyword char (*), keyword_pos fixed bin (21), start_keyword fixed bin (21); keyword_pos = RS_pos; /* start with first unidentified character */ start_keyword = index (substr (RS, RS_pos + 1), keyword) - 1; if start_keyword < 0 then return (-1); keyword_pos = RS_pos + start_keyword; if index (WHITE, substr (RS, keyword_pos + length (keyword) + 1, 1)) - 1 < 0 | index (WHITE, substr (RS, keyword_pos, 1)) - 1 < 0 then call warning (0, "Whitespace must surround the ""^a"" keyword.", keyword); return (keyword_pos); end find_clause; %page; /* This procedure implements knowledge of the syntax of &if conditionals (except for detection of missing conditionals, which is done in &if). The forms accepted are "true", "false", "[...]", "|[...]", and "||[...]". The forms containing brackets are evaluated by calling cu_$evaluate_active_string with the string contained between them. A zero error code must be returned, and the returned value must be either "true" or "false". */ conditional: procedure () returns (bit (1) aligned); declare AF_len fixed bin (21), AF_ptr ptr, AF char (AF_len) based (AF_ptr), bars_len fixed bin, value char (8) varying; if substr (RS, RS_pos + 1) = "true" then return ("1"b); if substr (RS, RS_pos + 1) = "false" then return ("0"b); if substr (RS, RS_pos + 1, 1) = "|" then if substr (RS, RS_pos + 2, 1) = "|" then bars_len = 2; else bars_len = 1; else bars_len = 0; if substr (RS, RS_pos + bars_len + 1, 1) ^= "[" | substr (RS, RS_len) ^= "]" then call error (0, "Malformed conditional in ""&if"" statement."); AF_ptr = addr (substr (RS, RS_pos + bars_len + 2)); AF_len = RS_len - RS_pos - bars_len - 2; /* do not pass brackets surrounding if expression */ if ec_data_ptr ^= null () then if codeptr (ec_data.eval_string) ^= null () then call ec_data.eval_string (null (), AF, (bars_len + 1), value, status); else call cu_$evaluate_active_string (null (), AF, (bars_len + 1), value, status); else call cu_$evaluate_active_string (null (), AF, (bars_len + 1), value, status); if status ^= 0 then call error (status, "Evaluating ""&if"" clause."); if value = "true" then return ("1"b); if value = "false" then return ("0"b); call error (0, "Illegal value ""^a"" returned by active function.", value); end conditional; %page; /* This utility predicate knows how to determine if some switch is &attached. It has been designed to be easily extended to other cases than the usual &attach in exec_com using the io_call command or iox_$control */ attachedp: procedure () returns (bit (1) aligned); return (abs_data.attach.target_ptr ^= null ()); end attachedp; /* This utility predicate knows how to determine if the current line is an input line */ input_linep: procedure () returns (bit (1) aligned); if ec_data_ptr = null () then return ("0"b); /* Can't be input unless someone tells us so */ return (ec_data.input_line); end input_linep; /* This utility predicate knows how to tell if we were invoked as an active function */ functionp: procedure () returns (bit (1) aligned); if ec_data_ptr = null () then return ("0"b); /* Can't return a value if we don't have a place to put it */ else return (ec_data.active_function); end functionp; %page; emit_ec_name: procedure (); /* &ec_name: The entryname of the input file, sans suffix */ call copy_up_to_ampersand (7); call copy_string (ec_name, QUOTE); end emit_ec_name; emit_ec_dir: procedure (); /* &ec_dir: The dir containing the input file */ /* This is used to simulate referencing_dir */ declare ec_dir_buf char (168), ec_dir_len fixed bin, ec_dir char (ec_dir_len) based (addr (ec_dir_buf)); call copy_up_to_ampersand (6); call hcs_$fs_get_path_name (input_string.ptr, ec_dir_buf, ec_dir_len, (""), (0)); call copy_string (ec_dir, QUOTE); end emit_ec_dir; emit_ec_switch: procedure (); /* &ec_switch: The I/O switch to read input lines from */ declare ec_switch char (ec_switch_len) based, ec_switch_len fixed bin; call copy_up_to_ampersand (9); if ec_data_ptr = null () then do; ec_switch_len = length (rtrim (iocb_ptr -> iocb.name)); call copy_string (addr (iocb_ptr -> iocb.name) -> ec_switch, QUOTE); end; else do; ec_switch_len = length (rtrim (ec_data.switch_ptr -> iocb.name)); call copy_string (addr (ec_data.switch_ptr -> iocb.name) -> ec_switch, QUOTE); end; end emit_ec_switch; %page; emit_arg_count: procedure (); declare arg_count_pic picture "zzzzzzzz9", arg_count_len fixed bin, arg_count char (arg_count_len) based (addr (substr (arg_count_pic, 10 - arg_count_len))); call copy_up_to_ampersand (1); arg_count_pic = abs_data.arg_count; arg_count_len = length (ltrim (arg_count_pic)); call copy_string (arg_count, NONE); end emit_arg_count; predicate: procedure (test, width); declare test bit (1) aligned, width fixed bin; call copy_up_to_ampersand (width); if test then call copy_string (TRUE, NONE); else call copy_string (FALSE, NONE); return; end predicate; copy_up_to_ampersand: procedure (width); declare width fixed bin; len = CL_pos - old_CL_pos; if len > 0 then do; call check_len (len); substr (RS, RS_len - len + 1, len) = substr (CL, old_CL_pos + 1, len); end; CL_pos = CL_pos + width; old_CL_pos = CL_pos + 1; not_in_CL = "1"b; /* Make sure that we know some expansion was encountered */ return; end copy_up_to_ampersand; %page; copy_string: procedure (arg_string, quote_modifier); declare arg_string char (*), quote_modifier fixed bin; declare (arg_pos, quote_pos, quote_len) fixed bin (21); if quote_modifier = NONE then do; call check_len (length (arg_string)); substr (RS, RS_len - length (arg_string) + 1) = arg_string; return; end; arg_pos = 0; QLOOP: quote_len = index (substr (RS, old_RS_len + 1), """") - 1; if quote_len >= 0 then do; old_RS_len = old_RS_len + quote_len; quote_len = verify (substr (RS, old_RS_len + 1), """") - 1; if quote_len < 0 then quote_len = RS_len - old_RS_len; old_RS_len = old_RS_len + quote_len; if mod (quote_len, twoL) = 0 then do while (mod (quote_len, 2 * twoL) ^= 0); quote_len = quote_len - twoL; twoL = 2 * twoL; end; else do while (quote_len ^= 0); twoL = divide (twoL, 2, 17, 0); quote_len = mod (quote_len, twoL); end; go to QLOOP; end; else old_RS_len = RS_len; if quote_modifier = REQUOTE then do; /* insert quotes if requoting */ call check_len (twoL); substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL); twoL = 2 * twoL; /* increase quote depth by one */ end; DBL_LOOP: quote_pos = index (substr (arg_string, arg_pos + 1), """") - 1; if quote_pos >= 0 then do; call check_len (quote_pos); substr (RS, RS_len - quote_pos + 1, quote_pos) = substr (arg_string, arg_pos + 1, quote_pos); arg_pos = arg_pos + quote_pos + 1; call check_len (twoL); substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL); if arg_pos < length (arg_string) then go to DBL_LOOP; else go to APPEND; end; quote_pos = length (arg_string) - arg_pos; if quote_pos > 0 then do; /* something after last quote in arg */ call check_len (quote_pos); substr (RS, RS_len - quote_pos + 1, quote_pos) = substr (arg_string, arg_pos + 1, quote_pos); end; APPEND: if quote_modifier = REQUOTE then do; /* append quotes if requoting */ twoL = divide (twoL, 2, 17, 0); call check_len (twoL); substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL); end; old_RS_len = RS_len; return; end copy_string; %page; check_len: proc (len); /* routine to make sure we don't overflow input buffer */ declare len fixed bin (21), new_RS_len fixed bin (21); new_RS_len = RS_len + len; if new_RS_len > buffer_len then call allocate_buffer (new_RS_len); RS_len = new_RS_len; return; end check_len; allocate_buffer: procedure (required_len); declare required_len fixed bin (21), new_RS_ptr ptr, new_RS char (buffer_len) based (new_RS_ptr); not_in_CL = "1"b; /* RS will not be eq to CL after this */ buffer_allocated = "1"b; if abs_data.allocated_chars_ptr ^= null () then if required_len <= abs_data.allocated_chars_len then do; /* Reuse allocated buffer if possible */ abs_data.allocated_chars_ptr -> RS = RS; buffer_ptr, RS_ptr = abs_data.allocated_chars_ptr; return; end; buffer_len = divide (16 * required_len + 15, 8, 21, 0); if buffer_len > 1044320 then if required_len > 1044320 then call error (0, "Expanded line exceeds implementation restriction of 1044320 characters in length."); else buffer_len = 1044320; /* Biggest string that can fit in an extensible area */ on area call error (error_table_$noalloc, "Allocating buffer (^d words).", required_len); allocate new_RS in (abs_data.work_area); revert area; new_RS_ptr -> RS = RS; if abs_data.allocated_chars_ptr ^= null () then free allocated_chars; abs_data.allocated_chars_ptr, buffer_ptr, RS_ptr = new_RS_ptr; abs_data.allocated_chars_len = buffer_len; return; end allocate_buffer; %page; allocate_hash_table: procedure (); on area call error (error_table_$noalloc, "Allocating label hash table."); allocate hash_table set (abs_data.labels_ptr) in (abs_data.work_area); revert area; end allocate_hash_table; %page; error: procedure () options (variable); declare complain entry () variable options (variable), line_len fixed bin (21), line_number fixed bin (21), line_ptr ptr, line_start fixed bin (21), line char (line_len) based (line_ptr), message char (256), severity bit (1), status_ptr ptr, status fixed bin (25) based (status_ptr), who char (72) varying; severity = "1"b; go to ERROR_COMMON; warning: entry options (variable); severity = "0"b; ERROR_COMMON: call cu_$arg_ptr (1, status_ptr, (0), (0)); call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, message, (0), "1"b, "0"b); line_number = 0; do line_start = 0 repeat (line_start + line_len + 1) while ((line_start <= input_string.position) & (line_start < input_string.len)); line_len = index (substr (IS, line_start + 1), NL) - 1; if line_len < 0 then line_len = input_string.len - line_start; line_number = line_number + 1; line_ptr = addr (substr (IS, line_start + 1)); end; if ec_data_ptr = null () then do; complain = com_err_; who = rtrim (abs_data.io_module_name); end; else do; if codeptr (ec_data.error) = null () then if ec_data.active_function then complain = active_fnc_err_; else complain = com_err_; else complain = ec_data.error; who = ec_data.who_am_i; end; call complain (status, who, "^[^/^]^[Error^;Warning^] on line #^d of ^a:^/^a^/SOURCE:^-^a", status ^= 0, severity, line_number, ec_path, message, line); if ^severity then return; if abs_data.noabort then do; get_next_line = EXPAND_NEXT_LINE; go to get_next_line; end; state = NORMAL; /* Prevent looping if state is a MUST_BE state. */ go to END_OF_FILE; end error; %page; %include abs_io_data; %page; %include abs_io_hash; %page; %include ec_data; %page; %include iocb; end abs_io_v1_get_line;  abs_io_v2_get_line.pl1 10/04/88 1315.2rew 10/04/88 1311.8 583938 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-03-13,Herbst), approve(86-04-17,MCR7376), audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041): Fixed bug where null &else failed to close an &if-&then-&else. 2) change(87-06-04,Parisek), approve(87-07-23,MCR7716), audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080): Continue execution with next exec_com line when abs_io_data.noabort is ON. 3) change(87-09-18,Parisek), approve(87-09-18,PBF7716), audit(87-09-21,Farley), install(87-09-21,MR12.1-1111): Set end_ec & goto ERROR_RETURN label when noabort is ON if error occurs on the last line of the exec_com. 4) change(88-08-08,TLNguyen), approve(88-08-08,MCR7934), audit(88-09-15,Parisek), install(88-09-16,MR12.2-1111): Make the &exit statement and the &goto LABEL statement constructed within the &on unit work as documented. Also fixed a size condition and stringrange condition raised while fixing errors. 5) change(88-09-29,TLNguyen), approve(88-09-29,PBF7934), audit(88-09-30,Parisek), install(88-10-04,MR12.2-1128): Remove unnessesary label searching within the &label block, and make more extensive checks for the value of goto_entry_sw and abs_data.label_search_sw in determining what action to take when inside an &on unit block in the exec_com/absin. END HISTORY COMMENTS */ /* format: off */ abs_io_v2_get_line: proc (A_iocb_ptr, A_buffer_ptr, A_buffer_len, A_return_len) returns (fixed (35)); /* Implements &version 2 exec_com language; reads and executes control lines from an input file until it encounters a non-control line, then returns this expanded line. */ /* Added &print_switch{_nnl} 10/20/81 Steve Herbst */ /* Modified: 15 February 1982 by G. Palter for new calling sequence of ec_data.eval_string */ /* Fixed &if-&then-&else to be impervious to imbedded get_line 04/20/82 Steve Herbst */ /* Fixed to detect all cases of null &then and &else clauses 07/19/82 Steve Herbst */ /* Fixed to detect missing &quit statement 07/28/82 Steve Herbst */ /* Changed to zero xd.label_search_values to be filled in by abs_io_expand_ 10/06/82 Steve Herbst */ /* Fixed &label inside &do group to not destroy block info 11/15/82 Steve Herbst */ /* Fixed &is_af and "Missing &quit statement" line number 12/07/82 Steve Herbst */ /* Fixed &goto to position correctly to 1st char in target line 02/24/83 Steve Herbst */ /* Added &on, &begin, &revert, etc., also added $goto for handler's nonlocal &goto 04/07/83 Steve Herbst */ /* Added &attach &trim on/off 06/02/83 Steve Herbst */ /* Added &list_variables (&lsv) 06/07/83 Steve Herbst */ /* Fixed &if...&then...BLANK LINE&else... 07/22/83 Steve Herbst */ /* Fixed bug causing &on unit to screw up later &if's 10/13/83 Steve Herbst */ /* Fixed &else&if to be a null &else rather than an &else &if 10/13/83 Steve Herbst */ /* Changed to set abs_data.goto_pl1_label for absentee_listen_, doing &goto from an &on unit 11/17/83 Steve Herbst */ /* Fixed not to wait until non-ctl line to set abs_data.(position limit) 11/30/83 Steve Herbst */ /* Removed useless and undocumented "Missing &quit statement" warning 11/30/83 Steve Herbst */ /* Made &on accept commas as well as white space between condition names 01/25/84 Steve Herbst */ /* Made ec -trace, -no_trace override &trace statements 03/20/84 Steve Herbst */ /* Added &all_types, &all_expansions keywords to &trace 05/03/84 Steve Herbst */ /* Fixed &revert, &signal, &trace to parse result of expansion yielding "token1 token2" 07/18/84 Steve Herbst */ /* Fixed bug that stopped skipping while inside skipped &do-&end 08/03/84 Steve Herbst */ /* Fixed bug where a handler's &end fouled up later &if-&then skipping 08/10/84 Steve Herbst */ /* Fixed &list_variables bug that used default value seg if no variables set 08/10/84 Steve Herbst */ /* Fixed end-of-file processing to log out an absentee only if not executing an &on unit 09/17/84 Steve Herbst */ /* Fixed $goto to record found label in hash table 01/02/85 Steve Herbst */ /* Fixed &on-&end to not require the &end to be followed by a newline character 01/03/85 Steve Herbst */ /* Fixed &goto not to allocate storage if label has already been parsed 02/15/85 Steve Herbst */ /* Fixed to free parsed_args structure allocated by abs_io_expand_ 02/19/85 Steve Herbst */ /* Parameters */ dcl A_goto_label char (*); dcl (A_iocb_ptr, iocb_ptr) ptr; /* ptr to IOCB of abs_io_ or syn_ attached to abs_io_ */ dcl (A_abs_data_ptr, A_ec_data_ptr) ptr; /* ptr to caller's info structures (for $goto) */ dcl (A_buffer_ptr, buffer_ptr) ptr; /* ptr to caller's input buffer */ dcl (A_buffer_len, buffer_len) fixed bin (21); /* max length (in chars) of caller's buffer */ dcl (A_return_len, actual_len) fixed bin (21); /* length of data actually returned */ dcl A_code fixed bin (35); /* standard status code */ %page; /* Constants */ /* NOTE: These next five values depend on the values of the STMTS array in abs_io_expand_ */ dcl BEGIN_ACTION fixed bin int static options (constant) init (2); dcl DO_ACTION fixed bin int static options (constant) init (6); dcl ELSE_ACTION fixed bin int static options (constant) init (7); dcl IF_ACTION fixed bin int static options (constant) init (13); dcl THEN_ACTION fixed bin int static options (constant) init (35); dcl DO_TYPE fixed bin int static options (constant) init (0); dcl BEGIN_TYPE fixed bin int static options (constant) init (1); dcl THEN_TYPE fixed bin int static options (constant) init (2); dcl ELSE_TYPE fixed bin int static options (constant) init (3); dcl NO_UPDATE bit (1) int static options (constant) init ("0"b); dcl ALPHA char (52) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"); dcl DIGITS char (10) int static options (constant) init ("0123456789"); dcl LABEL fixed bin int static options (constant) init (1); dcl NL char (1) int static options (constant) init (" "); dcl WHITE_SPACE char (4) int static options (constant) init (" "); /* SP HT VT FF */ /* Based */ dcl condition_array (condition_count) char (32) based (condition_array_ptr); dcl 1 saved_if_info aligned like abs_data.if_info based; dcl 1 default_args (abs_data.default_arg_count) based (abs_data.default_arg_ptr), 2 ptr ptr, 2 len fixed bin (21), 2 quote_count fixed bin (21); dcl default_values_ptr ptr; dcl default_values (abs_data.default_arg_count) char (max_default_len) based (default_values_ptr); dcl allocated_chars char (abs_data.allocated_chars_len) based (abs_data.allocated_chars_ptr); dcl ec_path char (arg_info.ec_path_len) based (arg_info.ec_path_ptr); dcl allocated_buffer char (alloc_len) based (xd.allocated_ptr); dcl arg char (xd.arg_len) based (xd.arg_ptr); dcl buffer char (buffer_len) based (buffer_ptr); dcl goto_name char (goto_name_len) based (goto_name_ptr); dcl input_string char (input_string.len) based (input_string.ptr); dcl label_val char (label_val_len) based (label_val_ptr); dcl remainder char (abs_data.chars_len) based (abs_data.chars_ptr); dcl return_arg char (ec_data.return_len) varying based (ec_data.return_ptr); dcl val_string char (val_len) based (val_ptr); dcl var_string char (var_len) based (var_ptr); dcl based_area area based (area_ptr); dcl xd_area area based (xd.area_ptr); /* Automatic */ dcl 1 xd aligned like expand_data; dcl (message, switch_name) char (168); dcl token char (128) varying; dcl token32 char (32); dcl (begin_line_sw, goto_entry_sw, nnl_sw, skipping_handler_sw, some_left_sw) bit (1); dcl area_ptr ptr init (null); dcl (condition_array_ptr, goto_name_ptr, handler_ptr, label_val_ptr, last_node_ptr, lastp) ptr; dcl (on_saved_if_ptr, p, saved_if_ptr, saved_label_ptr, test_ptr, val_ptr, var_ptr) ptr; dcl (active_string_pos, alloc_len, cond_string_len, goto_name_len, handler_len, handler_start) fixed bin (21); dcl (label_val_len, max_default_len, name_len, saved_goto_pos) fixed bin (21); dcl (saved_statement_len, saved_statement_pos, tpos, val_len, var_len) fixed bin (21); dcl (condition_count, hash, i, saved_hash, saved_skip_block_level, search_type) fixed bin; dcl code fixed bin (35); dcl (area, bad_area_format, bad_area_initialization, cleanup) condition; /* External */ dcl error_table_$badsyntax fixed bin (35) ext; dcl error_table_$command_line_overflow fixed bin (35) ext; dcl error_table_$end_of_info fixed bin (35) ext; dcl error_table_$long_record fixed bin (35) ext; dcl error_table_$noalloc fixed bin (35); dcl error_table_$notalloc fixed bin (35) ext; dcl abs_io_control$attach entry (ptr, ptr, fixed bin (35)); dcl abs_io_control$detach entry (ptr, ptr, fixed bin (35)); dcl abs_io_expand_ entry (1 aligned like expand_data, fixed bin (35)); dcl abs_io_expand_$expand_label entry (1 aligned like expand_data, fixed (21), fixed (21), ptr, fixed (21), fixed (35)); dcl (abs_io_expand_$delete, abs_io_expand_$set) entry (ptr, char (*), char (*), fixed bin (35)); dcl abs_io_expand_$label_search entry (1 aligned like expand_data, fixed bin (35)); dcl abs_io_expand_$skip entry (1 aligned like expand_data, fixed bin (35)); dcl abs_io_list_vars entry (ptr, ptr, char (*), fixed bin (35)); dcl (active_fnc_err_, com_err_) entry options (variable); dcl cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) varying, fixed bin (35)); dcl cu_$arg_list_ptr entry returns (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$set_ready_mode entry (1 aligned like ready_mode); dcl get_system_free_area_ entry returns (ptr); dcl (ioa_, ioa_$nnl, ioa_$general_rs, ioa_$ioa_switch, ioa_$ioa_switch_nnl) entry options (variable); dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$user_input ptr ext; dcl logout entry; dcl signal_ entry options (variable); dcl signal_io_error_ entry (char (*), ptr, fixed bin (35)); dcl 1 ready_mode aligned, 2 flag bit (1) unaligned, 2 pad bit (35) unaligned; dcl input_linep bit (1) aligned; dcl (addcharno, addr, binary, char, charno, codeptr, index, length, max, mod, null) builtin; dcl (reverse, rtrim, search, substr, translate, unspec, verify) builtin; %page; START: goto_entry_sw, skipping_handler_sw = "0"b; A_code = 0; call get_data_ptrs (NO_UPDATE); if abs_data.active then if abs_data.attach.save_ptr ^= null then do; /* use previous attachment */ call iox_$get_line (abs_data.attach.save_ptr, A_buffer_ptr, A_buffer_len, A_return_len, A_code); return (A_code); end; else call recurse_error; abs_data.active = "1"b; if ^abs_data.in_handler_sw then abs_data.get_line_pl1_label = START; /* target for &goto from inside &on unit invoked while inside this program */ if abs_data.ec_data_ptr = null () then input_linep = "0"b; else input_linep = abs_data.ec_data_ptr -> ec_data.input_line; if abs_data.chars_len > 0 then do; /* pending chars to return */ if input_linep ^= abs_data.last_input_line_sw then do; /* changed input/command mode in mid-line */ abs_data.chars_len = 0; free allocated_chars; go to EXPAND_NEXT_STMT; /* flush the rest of the old line */ end; if abs_data.chars_len > A_buffer_len then do; /* return as much as will fit */ some_left_sw = "1"b; actual_len = buffer_len; end; else do; /* return it all */ some_left_sw = "0"b; actual_len = abs_data.chars_len; end; substr (buffer, 1, actual_len) = substr (remainder, 1, actual_len); if some_left_sw then do; abs_data.chars_ptr = addr (substr (remainder, actual_len + 1)); abs_data.chars_len = abs_data.chars_len - actual_len; A_code = error_table_$long_record; end; else do; abs_data.chars_len = 0; free allocated_chars; end; RETURN: abs_data.last_input_line_sw = input_linep; abs_data.active = "0"b; if ^goto_entry_sw then A_return_len = actual_len; return (A_code); end; /* Initialize local expand_data */ call init_xd (); EXPAND_NEXT_STMT: if ^goto_entry_sw then do; xd.caller_buffer_ptr = A_buffer_ptr; /* expanded line will be returned in caller's buffer */ xd.caller_buffer_len = A_buffer_len; end; xd.allocated_ptr = null; xd.allocated_len = 0; if input_linep then xd.trace_lines = abs_data.input_line; else xd.trace_lines = abs_data.command_line; if abs_data.if_sw then call test_end_of_if (); MIGHT_SKIP: if xd.parsed_args_ptr ^= null then free xd.parsed_args_ptr -> parsed_args in (xd_area); unspec (xd.expander_output) = "0"b; xd.arg_ptr, xd.parsed_args_ptr = null; /* Call the expander */ saved_statement_pos = xd.this_statement.pos; /* in case we run off end with no &quit */ i = 0; /* in case it doesn't get set below we can avoid stringrange error */ if xd.input_pos > 1 then /* to avoid stringrange condition raised when finding the substring */ /* does the input substring characters begin with NL? */ i = verify (substr (input_string, xd.input_pos - 1), NL || WHITE_SPACE); if i < 2 then begin_line_sw = "0"b; /* no, the input substring characters does not start with NL */ else begin_line_sw = (index (substr (input_string, xd.input_pos - 1, i - 1), NL) ^= 0); if begin_line_sw & abs_data.next_action = IF_ACTION then do; /* &if always starts a new &if statement */ abs_data.if_sw = "0"b; if ^skipping_handler_sw & abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b; end; if abs_data.label_search_sw then do; call abs_io_expand_$label_search (xd, code); if code ^= 0 then if code = error_table_$end_of_info then go to END_OF_FILE; /* label not found */ else call error (code, xd.error_msg); end; else if abs_data.skip_sw then /* after &if FALSE &then, skip to &else */ call abs_io_expand_$skip (xd, code); else call abs_io_expand_ (xd, code); if code ^= 0 then if code = error_table_$end_of_info then do; if saved_statement_pos ^= 0 then xd.this_statement.pos = saved_statement_pos; else if xd.this_statement.pos = 0 then xd.this_statement.pos = abs_data.input_string.len - 1; go to END_OF_FILE; end; else call error (code, xd.error_msg); input_string.limit = max (input_string.limit, xd.input_pos - 1); /* how far parsed by abs_io_expand_ */ input_string.position = xd.input_pos; parsed_args_ptr = xd.parsed_args_ptr; if abs_data.if_sw & begin_line_sw & /* previous &then or &else clause */ abs_data.this_action ^= THEN_ACTION & /* and current stmt is neither &then nor &else */ abs_data.this_action ^= ELSE_ACTION then if abs_data.this_action = 0 & /* except for blank line followed by &then or &else */ (abs_data.next_action = THEN_ACTION | abs_data.next_action = ELSE_ACTION) then; else do; /* force end of &if construct */ abs_data.if_sw = "0"b; if abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b; end; if abs_data.skip_sw then go to SKIP (abs_data.this_action); if abs_data.this_action = 0 then do; if abs_data.label_search_sw then go to END_OF_FILE; /* label search failed (no more &label stmts) */ RETURN_LINE: if xd.caller_actual_len >= xd.caller_buffer_len then do; /* no room to append NL */ if xd.allocated_ptr = null then do; alloc_len = 1; allocate allocated_buffer in (abs_data.work_area) set (xd.allocated_ptr); xd.allocated_buffer_len = 1; xd.allocated_len = 0; end; xd.allocated_len = xd.allocated_len + 1; /* append NL */ substr (allocated_buffer, xd.allocated_len, 1) = NL; actual_len = xd.caller_actual_len; abs_data.allocated_chars_ptr, abs_data.chars_ptr = xd.allocated_ptr; abs_data.allocated_chars_len, abs_data.chars_len = xd.allocated_len; A_code = error_table_$long_record; end; else do; /* fits in caller's buffer */ substr (buffer, xd.caller_actual_len + 1, 1) = NL; actual_len = xd.caller_actual_len + 1; A_code = 0; end; go to RETURN; end; else go to ACTION (abs_data.this_action); %page; goto: entry (A_abs_data_ptr, A_ec_data_ptr, A_goto_label) returns (fixed bin (35)); /* Called by absentee_listen_$execute_handler if the handler did a nonlocal &goto */ goto_entry_sw = "1"b; abs_data_ptr = A_abs_data_ptr; ec_data_ptr = A_ec_data_ptr; call init_xd (); xd.caller_buffer_ptr, xd.allocated_ptr = null; unspec (xd.trace_lines) = "0"b; /* save the location and the length of the line containing "&goto LABEL_NAME" */ /* for later referenced in the error message when LABEL_NAME not found */ xd.this_statement.pos = abs_data.goto_statement_pos; xd.this_statement.len = abs_data.goto_statement_len; goto_name_len = length (rtrim (A_goto_label, WHITE_SPACE)); allocate goto_name in (abs_data.work_area) set (goto_name_ptr); goto_name = A_goto_label; go to GOTO_STMT; %page; ACTION (0): /* end of the input file */ END_OF_FILE: call reset_input (); /* implicit &detach at end of file */ if abs_data.label_search_sw then do; if abs_data.in_handler_sw & ^goto_entry_sw then do; /* nonlocal &goto out of &on unit */ if abs_data.condition_name = "cleanup" then call error (0, "Attempted nonlocal &goto from inside cleanup handler."); abs_data.goto_sw, abs_data.exit_sw = "1"b; abs_data.goto_label_ptr = addr (saved_label_ptr -> label.name); abs_data.goto_label_len = saved_label_ptr -> label.len; go to ERROR_RETURN; end; xd.this_statement.pos = saved_goto_pos; xd.this_statement.len = saved_statement_len; if search_type = LABEL then message = "Label ""^a"" not found."; else message = "Search failed for ""^a""."; call error (0, message, saved_label_ptr -> label.name); end; ERROR_RETURN: abs_data.eof = "1"b; if ^goto_entry_sw then A_return_len = 0; if abs_data.absentee & ^abs_data.in_handler_sw then call logout; else return (error_table_$end_of_info); %page; /* NOTE: These labels correspond to the STMTS array in abs_io_expand_ */ ACTION (1): /* &attach */ if ec_data_ptr ^= null & ^attachedp () then do; call abs_io_control$attach (abs_data_ptr, null, code); if code ^= 0 then call error (code, "Error while performing &attach."); end; if parsed_args_ptr = null then abs_data.trim_whitespace_sw = "1"b; else if parsed_args.count = 0 then abs_data.trim_whitespace_sw = "1"b; else do; xd.arg_ptr = parsed_args.ptr (1); xd.arg_len = parsed_args.len (1); if arg ^= "&trim" then call error (0, "Invalid &attach control argument " || arg || "."); if parsed_args.count = 1 then abs_data.trim_whitespace_sw = "1"b; else if parsed_args.count > 2 then call error (0, "Too many arguments for &attach."); else do; xd.arg_ptr = parsed_args.ptr (2); xd.arg_len = parsed_args.len (2); if arg = "on" | arg = "true" then abs_data.trim_whitespace_sw = "1"b; else if arg = "off" | arg = "false" then abs_data.trim_whitespace_sw = "0"b; else call error (0, "Invalid argument to &attach &trim: " || arg); end; end; SET_INPUT_LIMIT: /* done expanding and executing this control stmt */ input_string.limit = max (input_string.limit, xd.input_pos - 1); /* how far parsed by abs_io_expand_ */ go to EXPAND_NEXT_STMT; ACTION (2): /* &begin */ if abs_data.label_search_sw then do; call execute_begin (); go to SET_INPUT_LIMIT; end; else call error (0, "&begin not preceded by &on."); ACTION (3): /* &call (UNIMPLEMENTED) */ BAD_KEY: call error (0, "Invalid keyword ^a", substr (input_string, xd.this_statement.pos, xd.this_statement.keyword_len)); ACTION (4): /* &default */ call set_defaults (xd.parsed_args_ptr); go to SET_INPUT_LIMIT; ACTION (5): /* &detach */ call reset_input (); go to SET_INPUT_LIMIT; ACTION (6): /* &do */ call execute_do (); go to EXPAND_NEXT_STMT; ACTION (7): /* &else */ abs_data.clause_type = ELSE_TYPE; call execute_else (); go to SET_INPUT_LIMIT; ACTION (8): /* &end */ END_STMT: call execute_end (); go to SET_INPUT_LIMIT; ACTION (9): /* &exit */ if ^abs_data.in_handler_sw then call error (0, "&exit is allowed only inside an &on unit."); if parsed_args_ptr ^= null then do; do i = 1 to parsed_args.count; xd.arg_ptr = parsed_args.ptr (i); xd.arg_len = parsed_args.len (i); if arg = "&continue" then abs_data.on_info.continue_to_signal_sw = "1"b; else call error (0, "Invalid &exit control argument " || arg || "."); end; end; go to END_OF_FILE; ACTION (10): /* &entry (UNIMPLEMENTED) */ go to BAD_KEY; ACTION (11): /* &function (UNIMPLEMENTED) */ /* block_ptr = allocate_block (); block.containing_lex_block_ptr = null; block.containing_proc_block_ptr = current_proc_block_ptr; block.args_ptr = xd.parsed_args_ptr; block.identifier = FUNCTION_TYPE; current_proc_block_ptr = block_ptr; current_lex_block_ptr = null; go to EXPAND_NEXT_STMT; */ go to BAD_KEY; ACTION (12): /* &goto */ abs_data.goto_statement_pos = xd.this_statement.pos; abs_data.goto_statement_len = xd.this_statement.len; goto_name_len, xd.arg_len = length (rtrim (arg, WHITE_SPACE)); allocate goto_name in (abs_data.work_area) set (goto_name_ptr); goto_name = arg; GOTO_STMT: label_ptr = lookup_label (abs_data.labels_ptr, goto_name, hash); /* see if the right &label was seen */ if label_ptr ^= null then do; /* already compiled label */ xd.input_pos = label.statement_pos + label.statement_len + 1; if label.lex_block_ptr ^= null then do; /* target is inside a &do group */ abs_data.if_info = label.lex_block_ptr -> block.if_info; /* Check for &goto into a &do group (not allowed). When &proc's are added, check for &goto's into &proc's too. */ do test_ptr = abs_data.current_lex_block_ptr repeat (test_ptr -> block.containing_lex_block_ptr) while (test_ptr ^= label.lex_block_ptr); if test_ptr = null then call error (0, "&goto into a &do group"); end; end; abs_data.current_lex_block_ptr = label.lex_block_ptr; free goto_name in (abs_data.work_area); if goto_entry_sw then do; input_string.limit = max (input_string.limit, xd.input_pos - 1); input_string.position = xd.input_pos; return (0); /* return from $goto */ end; else go to EXPAND_NEXT_STMT; /* start executing after the label stmt */ end; saved_label_ptr = allocate_label (goto_name); /* create a node for the &label when found */ saved_hash = hash; /* save everything */ saved_goto_pos = xd.this_statement.pos; saved_statement_len = xd.this_statement.len; abs_data.label_search_sw = "1"b; unspec (xd.label_search_values) = "0"b; /* next &do, &end, etc. for searching */ xd.searching_for = goto_name; /* for error message */ search_type = LABEL; free goto_name in (abs_data.work_area); go to EXPAND_NEXT_STMT; ACTION (13): /* &if */ call execute_if (); go to SET_INPUT_LIMIT; ACTION (14): /* &label */ xd.arg_len = length (rtrim (arg, WHITE_SPACE)); if abs_data.label_search_sw & search_type = LABEL then if arg = saved_label_ptr -> label.name then do; /* the one we want */ label_ptr = saved_label_ptr; hash = saved_hash; xd.input_pos = xd.this_statement.pos + xd.this_statement.len + 1; /* begin executing from here */ abs_data.label_search_sw = "0"b; go to GOT_LABEL; end; label_ptr = allocate_label (arg); hash = mod (binary (unspec (char (arg, 2)), 18) + length (arg), 61); GOT_LABEL: /* compile label for finding later */ label.lex_block_ptr = abs_data.current_lex_block_ptr; /* &goto to here restores all of this stuff */ label.statement_pos = xd.this_statement.pos; label.statement_len = xd.this_statement.len; if goto_entry_sw & ^abs_data.label_search_sw then do; input_string.limit = max (input_string.limit, xd.input_pos - 1); input_string.position = xd.input_pos; end; else input_string.limit = xd.input_pos; if xd.expanded_sw then do; /* was an expandable label */ /* thread into xlabel chain */ if abs_data.first_xlabel_ptr = null then abs_data.first_xlabel_ptr = label_ptr; if abs_data.last_xlabel_ptr ^= null then abs_data.last_xlabel_ptr -> label.next_ptr = label_ptr; abs_data.last_xlabel_ptr = label_ptr; label.next_ptr = null; /* last in chain */ end; else do; /* else thread into hash tree of constant labels */ if abs_data.labels_ptr = null then abs_data.labels_ptr = allocate_hash_table (); label.next_ptr = abs_data.labels_ptr -> hash_table (hash); abs_data.labels_ptr -> hash_table (hash) = label_ptr; /* thread in as first node for hash */ end; if goto_entry_sw & ^abs_data.label_search_sw then return (0); /* return from $goto */ else go to EXPAND_NEXT_STMT; ACTION (15): /* &leave (UNIMPLEMENTED) */ go to BAD_KEY; ACTION (16): /* &list_variables */ LIST_VARIABLES_STMT: if abs_data.variables_ptr = null then call ioa_ ("No variables set."); else do; call abs_io_list_vars (abs_data_ptr, parsed_args_ptr, message, code); if code ^= 0 then call error (code, message); end; go to SET_INPUT_LIMIT; ACTION (17): /* &lsv (synonym for &list_variables) */ go to LIST_VARIABLES_STMT; ACTION (18): /* &on */ if parsed_args_ptr = null then NO_ON_ARGS: call error (0, "No condition names specified for &on statement."); if parsed_args.count = 0 then go to NO_ON_ARGS; if abs_data.next_action ^= BEGIN_ACTION then NO_BEGIN: call error (0, "&on statement not followed by &begin"); cond_string_len = 0; do i = 1 to parsed_args.count; cond_string_len = cond_string_len + parsed_args.len (i) + 1; end; begin; dcl cond_string char (cond_string_len) varying; cond_string = ""; do i = 1 to parsed_args.count; xd.arg_ptr = parsed_args.ptr (i); xd.arg_len = parsed_args.len (i); cond_string = cond_string || arg || " "; end; cond_string = translate (cond_string, " ", ","); condition_count = 0; i = verify (cond_string, " "); do while (i > 0 & i < cond_string_len); condition_count = condition_count + 1; i = i + index (substr (cond_string, i), " ") - 1; if verify (substr (cond_string, i), " ") = 0 then i = cond_string_len; else i = i + verify (substr (cond_string, i), " ") - 1; end; allocate condition_array in (abs_data.work_area) set (condition_array_ptr); condition_count = 0; i = verify (cond_string, " "); do while (i > 0 & i < cond_string_len); name_len = index (substr (cond_string, i), " ") - 1; if name_len > 32 then call error (0, "Condition name ^a longer than 32 characters.", substr (cond_string, i, name_len)); condition_count = condition_count + 1; condition_array (condition_count) = substr (cond_string, i, name_len); i = i + name_len; if verify (substr (cond_string, i), " ") = 0 then i = cond_string_len; else i = i + verify (substr (cond_string, i), " ") - 1; end; end; i = index (substr (input_string, xd.input_pos), "&begin"); if i = 0 then go to NO_BEGIN; xd.input_pos = xd.input_pos + i + length ("&begin") - 1; /* position past &begin */ if substr (input_string, xd.input_pos, 1) = NL then xd.input_pos = xd.input_pos + 1; /* and newline */ handler_start = xd.input_pos; handler_ptr = addcharno (input_string.ptr, xd.input_pos - 1); call execute_begin (); allocate saved_if_info in (abs_data.work_area) set (on_saved_if_ptr); on_saved_if_ptr -> saved_if_info = abs_data.if_info; saved_skip_block_level = abs_data.skip_block_level; abs_data.skip_block_level = 1; abs_data.skip_sw, skipping_handler_sw = "1"b; go to SET_INPUT_LIMIT; GOT_HANDLER: do i = xd.input_pos by -1 to 1 while (substr (input_string, i, 4) ^= "&end"); end; if i = 0 then NO_ON_END: call error (0, "Missing &end following &on...&begin."); else if index (ALPHA, substr (input_string, i + 4, 1)) ^= 0 then go to NO_ON_END; handler_len = i - handler_start; /* length of handler text not including &end */ if substr (input_string,xd.input_pos, 1) = NL then xd.input_pos = xd.input_pos + 1; /* and trailing newline */ do i = 1 to condition_count; if condition_array (i) = "cleanup" then do; /* treat cleanup special */ if abs_data.cleanup_handler_ptr = null then do; allocate handler_node in (abs_data.work_area) set (abs_data.cleanup_handler_ptr); abs_data.cleanup_handler_ptr -> handler_node.condition_name = "cleanup"; abs_data.cleanup_handler_ptr -> handler_node.next_ptr = null; end; abs_data.cleanup_handler_ptr -> handler_node.ptr = handler_ptr; abs_data.cleanup_handler_ptr -> handler_node.len = handler_len; end; else do; /* Is there already a handler for this condition? */ if abs_data.first_handler_ptr = null then do; /* no handlers at all */ allocate handler_node in (abs_data.work_area) set (handler_node_ptr); handler_node.condition_name = condition_array (i); handler_node.next_ptr = null; abs_data.first_handler_ptr = handler_node_ptr; end; else do; do handler_node_ptr = abs_data.first_handler_ptr repeat (handler_node.next_ptr) while (handler_node_ptr ^= null); if handler_node.condition_name = condition_array (i) then go to SET_HANDLER; last_node_ptr = handler_node_ptr; end; allocate handler_node in (abs_data.work_area) set (handler_node_ptr); handler_node.condition_name = condition_array (i); handler_node.next_ptr = null; last_node_ptr -> handler_node.next_ptr = handler_node_ptr; end; SET_HANDLER: handler_node.ptr = handler_ptr; handler_node.len = handler_len; end; end; abs_data.if_info = on_saved_if_ptr -> saved_if_info; free on_saved_if_ptr -> saved_if_info in (abs_data.work_area); go to SET_INPUT_LIMIT; ACTION (19): /* &print */ call ioa_ ("^a", arg); go to SET_INPUT_LIMIT; ACTION (20): /* &print_nnl */ call ioa_$nnl ("^a", arg); go to SET_INPUT_LIMIT; ACTION (21): /* &print_switch */ nnl_sw = "0"b; PRINT_SWITCH: i = search (arg, WHITE_SPACE); if i = 0 then i = xd.arg_len + 1; switch_name = substr (arg, 1, i - 1); call iox_$look_iocb (switch_name, iocb_ptr, code); if code ^= 0 then call error (code, "^a", switch_name); if nnl_sw then call ioa_$ioa_switch_nnl (iocb_ptr, "^a", substr (arg, i + 1)); else call ioa_$ioa_switch (iocb_ptr, "^a", substr (arg, i + 1)); go to SET_INPUT_LIMIT; ACTION (22): /* &print_switch_nnl */ nnl_sw = "1"b; go to PRINT_SWITCH; ACTION (23): /* &procedure (UNIMPLEMENTED)*/ PROC_STMT: /* block_ptr = allocate_block (); block.containing_lex_block_ptr = null; block.containing_proc_block_ptr = current_proc_block_ptr; block.args_ptr = xd.parsed_args_ptr; block.identifier = PROC_TYPE; current_proc_block_ptr = block_ptr; current_lex_block_ptr = null; go to EXPAND_NEXT_STMT; */ go to BAD_KEY; ACTION (24): /* &proc (synonym for &procedure) */ go to PROC_STMT; ACTION (25): /* &quit */ if xd.caller_actual_len ^= 0 then call warning (0, "&quit accepts no arguments."); go to END_OF_FILE; ACTION (26): /* &ready */ READY_STMT: ready_mode.flag = get_ready_mode (); ready_mode.pad = "0"b; if ec_data_ptr ^= null then if codeptr (ec_data.set_ready_mode) ^= null then do; /* ready proc specified (e.g., by absentee) */ call ec_data.set_ready_mode (ready_mode); go to SET_INPUT_LIMIT; end; call cu_$set_ready_mode (ready_mode); go to SET_INPUT_LIMIT; ACTION (27): /* &ready_mode (synonym for &ready) */ go to READY_STMT; ACTION (28): /* &ready_proc */ if ec_data_ptr ^= null then ec_data.call_ready_proc = get_ready_mode (); go to SET_INPUT_LIMIT; ACTION (29): /* &repeat (UNIMPLEMENTED) */ go to BAD_KEY; ACTION (30): /* &resignal */ /* THIS IS THE WRONG IMPLEMENTATION BECAUSE IT RE-INVOKES HANDLERS ABOVE THIS ONE. if ^abs_data.in_handler_sw then call error (0, "&resignal is allowed only inside an &on unit."); saved_condition_name = abs_data.handler_node_ptr -> handler_node.condition_name; abs_data.handler_node_ptr -> handler_node.condition_name = ""; temp. disable handler for this cond call signal_ ((abs_data.condition_name), abs_data.mc_ptr, abs_data.info_ptr, abs_data.wc_ptr); abs_data.handler_node_ptr -> handler_node.condition_name = saved_condition_name; */ go to BAD_KEY; ACTION (31): /* &return */ if functionp () then do; /* called as [exec_com] */ if xd.arg_len > ec_data.return_len then call warning (error_table_$command_line_overflow, "Expanded value length of ^d characters exceeds return argument length of ^d characters.", xd.arg_len, ec_data.return_len); return_arg = arg; end; else call ioa_ ("^a", arg); /* called as a command */ go to END_OF_FILE; ACTION (32): /* &revert */ if abs_data.in_handler_sw then call error (0, "Cannot execute &revert inside an &on unit."); if parsed_args_ptr = null then call error (0, "No argument specified for &revert."); do i = 1 to parsed_args.count; xd.arg_ptr = parsed_args.ptr (i); xd.arg_len = parsed_args.len (i); do token = first_token (arg, tpos) repeat (next_token (arg, tpos)) while (token ^= ""); if token = "cleanup" then if abs_data.cleanup_handler_ptr = null then NO_HANDLER: call warning (0, "(&revert) No &on unit for " || arg); else abs_data.cleanup_handler_ptr = null; else do; p = abs_data.first_handler_ptr; lastp = null; do while (p ^= null); if p -> handler_node.condition_name = token then do; /* free the node */ if lastp = null then abs_data.first_handler_ptr = p -> handler_node.next_ptr; else lastp -> handler_node.next_ptr = p -> handler_node.next_ptr; free p -> handler_node in (abs_data.work_area); go to END_REVERT_LOOP; end; else do; lastp = p; p = p -> handler_node.next_ptr; end; end; end; END_REVERT_LOOP: end; end; go to SET_INPUT_LIMIT; ACTION (33): /* &set */ if parsed_args_ptr = null then NO_SET_ARGS: call error (0, "No arguments specified for &set."); if parsed_args.count = 0 then go to NO_SET_ARGS; if mod (parsed_args.count, 2) ^= 0 then do; /* odd number of args */ var_ptr = parsed_args.ptr (parsed_args.count); var_len = parsed_args.len (parsed_args.count); call error (0, "Missing last value; no value set for ""^a"".", var_string); end; do i = 1 by 2 to parsed_args.count - 1; /* test all args first to rule out integers */ var_ptr = parsed_args.ptr (i); var_len = parsed_args.len (i); if verify (var_string, DIGITS || WHITE_SPACE) = 0 then call error (0, "Invalid syntax in var name ""^a""; all white space and digits.", var_string); end; do i = 1 by 2 to parsed_args.count - 1; var_ptr = parsed_args.ptr (i); var_len = parsed_args.len (i); val_ptr = parsed_args.ptr (i + 1); val_len = parsed_args.len (i + 1); if val_string = "&undefined" | val_string = "&undef" then call abs_io_expand_$delete (abs_data.variables_ptr, var_string, "", code); else call abs_io_expand_$set (abs_data.variables_ptr, var_string, val_string, code); if code ^= 0 then call error (code, xd.error_msg); end; go to SET_INPUT_LIMIT; ACTION (34): /* &signal */ token = first_token (arg, tpos); if next_token (arg, tpos) ^= "" then call error (0, "&signal accepts only one condition name: " || rtrim (arg)); if abs_data.in_handler_sw & token = abs_data.condition_name then call error (0, "Attempt to &signal " || rtrim (token) || " from within " || rtrim (token) || " &on unit."); abs_data.input_string.position = xd.input_pos; token32 = token; call signal_ (token32); xd.input_pos = abs_data.input_string.position; /* a handler's &goto may have changed it */ go to SET_INPUT_LIMIT; ACTION (35): /* &then */ abs_data.clause_type = THEN_TYPE; call execute_then (); go to SET_INPUT_LIMIT; ACTION (36): /* &trace */ call set_trace; go to SET_INPUT_LIMIT; ACTION (37): /* &until (UNIMPLEMENTED) */ go to BAD_KEY; ACTION (38): /* &version */ call error (0, "The ""&version"" statement can only be the first line of the program."); ACTION (39): /* &while (UNIMPLEMENTED) */ go to BAD_KEY; %page; /* NOTE: These labels (except 0) correspond to the STMTS array in abs_io_expand_ */ SKIP (0): /* non-control stmt */ SKIP_TEST: if abs_data.if_sw then call test_end_of_if (); /* done skipping? */ else if abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b; if ^abs_data.skip_sw & skipping_handler_sw then do; skipping_handler_sw = "0"b; abs_data.skip_block_level = saved_skip_block_level; go to GOT_HANDLER; end; else go to MIGHT_SKIP; /* loop to call abs_io_expand_ again */ SKIP (1): go to SKIP_TEST; SKIP (2): /* &begin */ call execute_begin (); abs_data.skip_block_level = abs_data.skip_block_level + 1; go to SKIP_TEST; SKIP (3): SKIP (4): SKIP (5): go to SKIP_TEST; SKIP (6): /* &do */ call execute_do (); abs_data.skip_block_level = abs_data.skip_block_level + 1; go to SKIP_TEST; SKIP (7): /* &else */ abs_data.clause_type = ELSE_TYPE; call execute_else (); go to SKIP_TEST; SKIP (8): /* &end */ call execute_end (); go to SKIP_TEST; SKIP (9): SKIP (10): SKIP (11): SKIP (12): go to SKIP_TEST; SKIP (13): /* &if */ call execute_if (); go to SKIP_TEST; SKIP (14): SKIP (15): SKIP (16): SKIP (17): SKIP (18): SKIP (19): SKIP (20): SKIP (21): SKIP (22): SKIP (23): SKIP (24): SKIP (25): SKIP (26): SKIP (27): SKIP (28): SKIP (29): SKIP (30): SKIP (31): SKIP (32): SKIP (33): SKIP (34): go to SKIP_TEST; SKIP (35): /* &then */ abs_data.clause_type = THEN_TYPE; call execute_then (); go to SKIP_TEST; SKIP (36): SKIP (37): SKIP (38): SKIP (39): go to SKIP_TEST; %page; /**/ allocate_block: proc returns (ptr); dcl block_ptr ptr; on area call error (error_table_$noalloc, "Allocating program block."); on bad_area_format call error (error_table_$notalloc, "Allocating program block."); on bad_area_initialization call error (error_table_$notalloc, "Allocating program block."); allocate block in (abs_data.work_area) set (block_ptr); block_ptr -> block.prev_block_ptr = abs_data.last_block_ptr; abs_data.last_block_ptr = block_ptr; block_ptr -> block.keyword_pos = xd.this_statement.pos; block_ptr -> block.if_info = abs_data.if_info; block_ptr -> block.statement_end_pos = 0; return (block_ptr); end allocate_block; /**/ %page; allocate_hash_table: proc returns (ptr); /* Allocates a labels hash table for use by lookup_label */ dcl labels_ptr ptr; on area call error (error_table_$noalloc, "Allocating label hash table."); on bad_area_format call error (error_table_$notalloc, "Allocating label hash table."); on bad_area_initialization call error (error_table_$notalloc, "Allocating label hash table."); allocate hash_table in (abs_data.work_area) set (labels_ptr); revert area; revert bad_area_format; revert bad_area_initialization; return (labels_ptr); end allocate_hash_table; %page; allocate_label: proc (P_label_name) returns (ptr); /* allocates a single label node to be threaded by the caller */ dcl P_label_name char (*); dcl label_ptr ptr; on area call error (error_table_$noalloc, "Allocating label ""^a""", P_label_name); on bad_area_format call error (error_table_$notalloc, "Allocating label ""^a""", P_label_name); on bad_area_initialization call error (error_table_$notalloc, "Allocating label ""^a""", P_label_name); current_label_ptr = addr (P_label_name); current_label_len = length (P_label_name); allocate label in (abs_data.work_area) set (label_ptr); revert area; revert bad_area_format; revert bad_area_initialization; label_ptr -> label.name = P_label_name; label_ptr -> label.statement_pos = input_string.position; label_ptr -> label.statement_len = 0; /* until set by caller */ label_ptr -> label.next_ptr = null; return (label_ptr); end allocate_label; %page; attachedp: proc returns (bit (1) aligned); /* TRUE if input is being read from the file (&attach) */ if abs_data_ptr = null then return ("0"b); else return (abs_data.attach.target_ptr ^= null); end attachedp; %page; conditional: proc returns (bit (1) aligned); /* TRUE if expanded string = "true", FALSE if "false", otherwise strip off brackets and evaluate by calling the command processor to expand an active string */ dcl active_string char (active_string_len) based (active_string_ptr); dcl (active_string_len, temp_len) fixed bin (21); dcl (active_string_ptr, saved_ptr, temp_ptr) ptr; dcl bars_len fixed bin (21); dcl free_sw bit (1); dcl temp_string char (temp_len) based (temp_ptr); dcl value char (8) varying; if xd.allocated_ptr ^= null then do; /* rest-of-line allocated, have to copy */ active_string_len = xd.caller_actual_len + xd.allocated_len; if area_ptr = null then area_ptr = get_system_free_area_ (); free_sw = "1"b; on cleanup free active_string in (area_ptr -> based_area); allocate active_string in (area_ptr -> based_area) set (active_string_ptr); temp_ptr = xd.caller_buffer_ptr; temp_len = xd.caller_actual_len; substr (active_string, 1, temp_len) = temp_string; temp_ptr = xd.allocated_ptr; temp_len = xd.allocated_len; substr (active_string, xd.caller_actual_len + 1, temp_len) = temp_string; end; else do; free_sw = "0"b; active_string_ptr = xd.arg_ptr; active_string_len = xd.arg_len; end; active_string_pos = verify (active_string, WHITE_SPACE); active_string_len = active_string_len - verify (reverse (active_string), WHITE_SPACE) + 1; if active_string = "true" then return ("1"b); else if active_string = "false" then return ("0"b); /* Also accept [...], |[...], ||[...] for compatibility */ if substr (active_string, active_string_pos, 1) = "|" then if substr (active_string, active_string_pos + 1, 1) = "|" then bars_len = 2; /* ||[ */ else bars_len = 1; /* |[ */ else bars_len = 0; if substr (active_string, active_string_pos + bars_len, 1) ^= "[" | substr (active_string, active_string_len, 1) ^= "]" then call error (0, "Malformed conditional in ""&if"" statement."); saved_ptr = active_string_ptr; active_string_ptr = addr (substr (active_string, active_string_pos + bars_len + 1)); active_string_len = active_string_len - bars_len - 2; if ec_data_ptr ^= null then if codeptr (ec_data.eval_string) ^= null then do; /* an af evaluation routine was specified */ call ec_data.eval_string (null, active_string, bars_len + 1, value, code); go to EVALUATED; end; call cu_$evaluate_active_string (null, active_string, bars_len + 1, value, code); EVALUATED: if free_sw then do; active_string_ptr = saved_ptr; free active_string in (area_ptr -> based_area); end; if code ^= 0 then call error (code, "Evaluating ""&if"" clause."); if value = "true" then return ("1"b); else if value = "false" then return ("0"b); else call error (0, "Invalid ""&if"" value ""^a""; must be true or false.", value); end conditional; %page; error: proc options (variable); /* Prints an error message (ec syntax or whatever) and skips to end of file */ dcl based_ec_string char (based_ec_len) based (based_ec_ptr); dcl based_ec_ptr ptr; dcl based_ec_len fixed bin (21); dcl (error_pos, line_len, line_number, line_start) fixed bin (21); dcl complain entry variable options (variable); dcl statement_ptr ptr; dcl statement char (xd.this_statement.len) based (statement_ptr); dcl message char (4096); dcl who char (72) varying; dcl severity_sw bit (1); /* ON for skip to end of file, OFF for warning only */ dcl end_ec bit (1); /* Note end of file */ dcl status_ptr ptr; dcl status fixed bin (25) based (status_ptr); severity_sw = "1"b; /* skip to end of file after printing error */ go to ERROR_COMMON; warning: entry options (variable); /* Prints a warning message and returns */ severity_sw = "0"b; ERROR_COMMON: end_ec = "0"b; call cu_$arg_ptr (1, status_ptr, (0), (0)); call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, message, (0), "1"b, "0"b); if abs_data.in_handler_sw & ^goto_entry_sw then do; /* count line numbers in parent ec if inside &on unit */ based_ec_ptr = abs_data.parent_abs_data_ptr -> abs_data.input_string.ptr; based_ec_len = abs_data.parent_abs_data_ptr -> abs_data.input_string.len; error_pos = xd.this_statement.pos + charno (abs_data.handler_node_ptr -> handler_node.ptr) - charno (based_ec_ptr); end; else do; based_ec_ptr = abs_data.input_string.ptr; based_ec_len = abs_data.input_string.len; error_pos = xd.this_statement.pos; end; line_number = 0; /* calculate line number of error */ do line_start = 0 repeat (line_start + line_len + 1) while (line_start <= error_pos); line_len = index (substr (based_ec_string, line_start + 1), NL) - 1; if line_len < 0 then do; end_ec = "1"b; line_len = error_pos - line_start; end; line_number = line_number + 1; end; if ec_data_ptr = null then do; complain = com_err_; who = rtrim (abs_data.io_module_name); end; else do; if codeptr (ec_data.error) = null then if ec_data.active_function then complain = active_fnc_err_; else complain = com_err_; else complain = ec_data.error; who = ec_data.who_am_i; end; if status = error_table_$badsyntax then status = 0; statement_ptr = addr (substr (input_string, xd.this_statement.pos)); call complain (status, who, "^[^/^]^[Error^;Warning^] on line #^d of ^a:^/^a^/SOURCE:^-^a", status ^= 0, severity_sw, line_number, ec_path, message, statement); if severity_sw then do; if end_ec then go to ERROR_RETURN; if abs_data.noabort then do; actual_len = 0; A_code = 0; go to RETURN; end; else go to ERROR_RETURN; end; end error; %page; execute_begin: proc; block_ptr = allocate_block (); block.containing_lex_block_ptr = abs_data.current_lex_block_ptr; block.containing_proc_block_ptr = abs_data.current_proc_block_ptr; block.args_ptr = null; block.identifier = BEGIN_TYPE; block.if_info = abs_data.if_info; abs_data.if_sw = "0"b; abs_data.prev_if_ptr = null; abs_data.current_lex_block_ptr = block_ptr; end execute_begin; %page; execute_do: proc; block_ptr = allocate_block (); block.containing_lex_block_ptr = abs_data.current_lex_block_ptr; block.containing_proc_block_ptr = abs_data.current_proc_block_ptr; block.args_ptr = null; if abs_data.clause_type = THEN_TYPE | abs_data.clause_type = ELSE_TYPE then block.identifier = abs_data.clause_type; else block.identifier = DO_TYPE; block.if_info = abs_data.if_info; abs_data.if_sw = "0"b; abs_data.prev_if_ptr = null; abs_data.current_lex_block_ptr = block_ptr; end execute_do; %page; execute_else: proc; if ^abs_data.if_sw | abs_data.got_else_sw then call error (0, "&else not preceded by &if"); abs_data.got_else_sw = "1"b; if abs_data.skip_block_level = 0 then /* Unless inside an &if being skipped in its entirety (abs_data.prev_if_ptr -> saved_if_info.skip_sw is ON), or inside a &do-&end block being skipped (abs_data.skip_block_level > 0), decide whether to skip this &else clause depending on value of the &if conditional. */ if abs_data.prev_if_ptr = null then call set_skip (abs_data.true_sw); else if ^abs_data.prev_if_ptr -> saved_if_info.skip_sw then call set_skip (abs_data.true_sw); end execute_else; %page; execute_end: proc; dcl (saved_this_action, saved_next_action) fixed bin; block_ptr = abs_data.current_lex_block_ptr; if block_ptr = null then call error (0, "&end not preceded by &do or &on...&begin"); saved_this_action = abs_data.this_action; /* don't restore these from block */ saved_next_action = abs_data.next_action; abs_data.if_info = block.if_info; abs_data.this_action = saved_this_action; abs_data.next_action = saved_next_action; if abs_data.current_lex_block_ptr = null then call error (0, "&end not preceded by &do"); block.statement_end_pos = xd.this_statement.pos; if abs_data.next_action = ELSE_ACTION then block.else_clause_pos = xd.next_statement.pos; else block.else_clause_pos = 0; abs_data.current_lex_block_ptr = block.containing_lex_block_ptr; end execute_end; %page; execute_if: proc; if abs_data.next_action ^= THEN_ACTION & abs_data.next_action ^= ELSE_ACTION then call error (0, "Missing &then or &else following &if"); if abs_data.if_sw then do; /* already inside an &if */ on area call error (error_table_$noalloc, "Allocating &if statement information."); on bad_area_format call error (error_table_$notalloc, "Allocating &if statement information."); on bad_area_initialization call error (error_table_$notalloc, "Allocating &if statement information."); allocate saved_if_info in (abs_data.work_area) set (saved_if_ptr); saved_if_ptr -> saved_if_info = abs_data.if_info; abs_data.prev_if_ptr = saved_if_ptr; end; abs_data.if_sw = "1"b; abs_data.got_then_sw, abs_data.got_else_sw = "0"b; if abs_data.skip_sw then abs_data.true_sw = "1"b; else abs_data.true_sw = conditional (); end execute_if; %page; execute_then: proc; if ^abs_data.if_sw | abs_data.got_then_sw | abs_data.got_else_sw then call error (0, "&then not preceded by &if"); abs_data.got_then_sw = "1"b; /* Unless inside an &if being skipped in its entirety (abs_data.prev_if_ptr -> saved_if_info.skip_sw is ON), or inside a &do-&end block being skipped (abs_data.skip_block_level > 0), decide whether to skip this &then clause based on the value of the &if conditional. */ if abs_data.skip_block_level = 0 then if abs_data.prev_if_ptr = null then call set_skip (^abs_data.true_sw); else if ^abs_data.prev_if_ptr -> saved_if_info.skip_sw then call set_skip (^abs_data.true_sw); end execute_then; %page; first_token: proc (P_str, P_pos) returns (char (128) varying); dcl P_str char (*); dcl (P_pos, i, j) fixed bin (21); if length (P_str) = 0 then return (""); i = search (P_str, WHITE_SPACE); if i = 0 then do; P_pos = length (P_str) + 1; return (P_str); end; j = verify (substr (P_str, i + 1), WHITE_SPACE); if i = 1 then do; if j = 0 then return (""); P_pos = j + 1; return (next_token (P_str, P_pos)); end; if j = 0 then do; P_pos = length (P_str) + 1; return (substr (P_str, 1)); end; else do; P_pos = i + j; return (substr (P_str, 1, i - 1)); end; end first_token; %page; functionp: proc returns (bit (1) aligned); /* TRUE if exec_com was invoked as an active function */ if ec_data_ptr = null then return ("0"b); /* unusual case */ else return (ec_data.active_function); end functionp; %page; get_data_ptrs: proc (P_update_sw); /* Copies parameters and gets pointers to the various databases. It is called with P_update_sw = "0"b when abs_io_v2_get_line is entered, and with P_update_sw = "1"b after calling signal_io_error_ to make sure that nothing has changed that we care about. */ dcl P_update_sw bit (1); iocb_ptr = A_iocb_ptr -> iocb.actual_iocb_ptr; /* chase syn's */ if P_update_sw then do; do while (abs_data_ptr ^= iocb_ptr -> iocb.attach_data_ptr); /* something's wrong */ call signal_io_error_ ("Attachment of " || abs_data.io_module_name || " has been moved.", A_iocb_ptr, 0); iocb_ptr = A_iocb_ptr -> iocb.actual_iocb_ptr; end; return; end; buffer_ptr = A_buffer_ptr; buffer_len = A_buffer_len; abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr; ec_data_ptr = abs_data.ec_data_ptr; end get_data_ptrs; %page; get_ready_mode: proc returns (bit (1)); /* TRUE if "on" or "true" is the argument, FALSE if "off" or "false" */ dcl arg char (arg_len) based (arg_ptr); dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl mode_sw bit (1); if parsed_args_ptr = null then NO_READY_ARGS: call warning (0, "Missing argument to &ready; ""on"" assumed."); if parsed_args.count = 0 then go to NO_READY_ARGS; arg_ptr = parsed_args.ptr (1); arg_len = parsed_args.len (1); if arg = "on" | arg = "true" then mode_sw = "1"b; else if arg = "off" | arg = "false" then mode_sw = "0"b; else do; call warning (0, "Invalid argument ""^a"" to ready statement; ""on"" assumed.", arg); mode_sw = "1"b; end; if parsed_args.count > 1 then call warning (0, "Ready statement accepts only one argument; extra args ignored."); return (mode_sw); end get_ready_mode; %page; init_xd: proc; /* Initializes much of the auto (in the external proc) xd structure. */ unspec (xd) = "0"b; xd.version = expand_data_version_2; xd.abs_data_ptr = abs_data_ptr; xd.expand_data_ptr = addr (xd); xd.area_ptr = addr (abs_data.work_area); xd.parsed_args_ptr = null; xd.next_expand_data_ptr, xd.last_expand_data_ptr, xd.allocated_ptr = null; xd.first_loop_ptr, xd.first_block_ptr = null; xd.is_absin = abs_data.absentee; xd.is_af = functionp (); xd.is_input = input_linep; xd.input_pos = input_string.position; end init_xd; %page; lookup_label: proc (P_labels_ptr, P_name, P_hash) returns (ptr); /* Sets P_last_node_info from tree of defined labels and returns either ptr to requested label node or null */ dcl P_labels_ptr ptr; dcl P_name char (*); dcl P_hash fixed bin; dcl (found_label_ptr, label_ptr) ptr; dcl limit_pos fixed bin (21); if P_labels_ptr = null then P_labels_ptr = allocate_hash_table (); /* no tree of labels allocated yet */ P_hash = mod (binary (unspec (char (P_name, 2)), 18) + length (P_name), 61); do label_ptr = P_labels_ptr -> hash_table (P_hash) repeat (label_ptr -> label.next_ptr) while (label_ptr ^= null); if label_ptr -> label.name = P_name then do; found_label_ptr = label_ptr; limit_pos = label_ptr -> label.statement_pos + label_ptr -> label.statement_len; go to CHECK_EXPANDABLES; end; end; found_label_ptr = null; /* no matching constant label in table */ limit_pos = xd.this_statement.pos; CHECK_EXPANDABLES: /* loop through expandables (e.g., &label &(foo)) */ if abs_data.first_xlabel_ptr ^= null & unspec (abs_data.first_xlabel_ptr) ^= "0"b then do label_ptr = abs_data.first_xlabel_ptr repeat (label_ptr -> label.next_ptr) while (label_ptr ^= null); if label_ptr -> label.statement_pos >= limit_pos then return (found_label_ptr); call abs_io_expand_$expand_label (xd, label_ptr -> label.statement_pos, label_ptr -> label.statement_len, label_val_ptr, label_val_len, 0); if label_val = P_name then return (label_ptr); end; return (found_label_ptr); end lookup_label; %page; next_token: proc (P_str, P_pos) returns (char (128) varying); dcl P_str char (*); dcl (P_pos, i, j, start_pos) fixed (21); start_pos = P_pos; if start_pos > length (P_str) then return (""); i = search (substr (P_str, start_pos), WHITE_SPACE); if i = 0 then do; P_pos = length (P_str) + 1; return (substr (P_str, start_pos)); end; j = verify (substr (P_str, start_pos + i), WHITE_SPACE); if j = 0 then do; P_pos = length (P_str) + 1; return (substr (P_str, start_pos)); end; else do; P_pos = start_pos + i + j - 1; return (substr (P_str, start_pos, i - 1)); end; end next_token; %page; recurse_error: proc; /* Aborts recursive $get_line invocation since there's no previous attachment to use */ dcl complain entry variable options (variable); dcl who char (72) varying; if ec_data_ptr = null then do; complain = com_err_; who = rtrim (abs_data.io_module_name); end; else do; if codeptr (ec_data.error) = null then if ec_data.active_function then complain = active_fnc_err_; else complain = com_err_; else complain = ec_data.error; who = ec_data.who_am_i; end; call complain (0, who, "Attempt to read recursively from the exec_com."); go to END_OF_FILE; end recurse_error; %page; reset_input: proc; /* Performs &detach */ if attachedp () then do; call abs_io_control$detach (abs_data_ptr, null, code); if code ^= 0 then call error (code, "Error while performing ""&detach""."); if input_linep then do; /* return a line from the prior user_input instead */ call iox_$get_line (iox_$user_input, buffer_ptr, buffer_len, actual_len, A_code); input_string.limit = max (input_string.limit, xd.input_pos - 1); go to RETURN; end; end; end reset_input; %page; set_defaults: proc (P_args_ptr); /* Sets default values for the first N arguments to exec_com */ dcl P_args_ptr ptr; dcl i fixed bin; if unspec (P_args_ptr) = "0"b then return; else if P_args_ptr = null then return; else parsed_args_ptr = P_args_ptr; abs_data.default_arg_count = parsed_args.count; max_default_len = 0; do i = 1 to parsed_args.count; /* compute max string len to allocate values */ max_default_len = max (max_default_len, parsed_args.len (i)); end; on area call error (error_table_$noalloc, "Allocating &default args."); on bad_area_format call error (error_table_$notalloc, "Allocating &default args."); on bad_area_initialization call error (error_table_$notalloc, "Allocating &default args."); allocate default_values in (abs_data.work_area) set (default_values_ptr); allocate default_args in (abs_data.work_area) set (abs_data.default_arg_ptr); revert area; revert bad_area_format; revert bad_area_initialization; do i = 1 to parsed_args.count; /* copy &default statement args */ val_ptr = parsed_args.ptr (i); val_len = parsed_args.len (i); if val_string = "&undefined" | val_string = "&undef" then default_args (i).ptr = null; else do; default_values (i) = val_string; default_args (i).ptr = addr (default_values (i)); default_args (i).len = val_len; default_args (i).quote_count = parsed_args.quote_count (i); end; end; end set_defaults; %page; set_skip: proc (P_sw); dcl P_sw bit (1) aligned; if substr (input_string, xd.input_pos - 1, 1) = NL & /* &then or &else ends line and */ abs_data.next_action ^= IF_ACTION then /* not nested &if means */ abs_data.skip_sw = /* null &then or &else, hence end of &if construct */ (abs_data.skip_block_level > 0); else abs_data.skip_sw = P_sw; end set_skip; %page; set_trace: proc; /* Reads arguments to &trace and decides how and what to trace */ dcl 1 tracing, 2 types, 3 (command, input, control, comment) bit (1), 2 (on, off, output_switch, prefix_sw) bit (1), 2 expand fixed bin, 2 prefix char (32) varying, 2 iocb ptr; dcl arg char (arg_len) based (arg_ptr); dcl switch_name char (32); dcl token char (128) varying; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl i fixed bin; dcl pos fixed bin (21); unspec (tracing) = "0"b; if unspec (xd.parsed_args_ptr) = "0"b then go to NO_TRACE_ARG; else if xd.parsed_args_ptr = null then go to NO_TRACE_ARG; else parsed_args_ptr = xd.parsed_args_ptr; if parsed_args.count = 0 then do; NO_TRACE_ARG: call warning (0, "Missing &trace keyword; ""&command on"" assumed."); tracing.command, tracing.on = "1"b; end; else do i = 1 to parsed_args.count; arg_ptr = parsed_args.ptr (i); arg_len = parsed_args.len (i); do token = first_token (arg, pos) repeat (next_token (arg, pos)) while (token ^= ""); if token = "&command" then tracing.command = "1"b; else if token = "&input" then tracing.input = "1"b; else if token = "&control" then tracing.control = "1"b; else if token = "&comment" then tracing.comment = "1"b; else if token = "&all_types" then tracing.command, tracing.comment, tracing.control, tracing.input = "1"b; else if token = "on" | token = "true" then do; tracing.on = "1"b; tracing.off = "0"b; end; else if token = "off" | token = "false" then do; tracing.off = "1"b; tracing.on = "0"b; end; else if token = "&unexpanded" then do; tracing.on = "1"b; tracing.expand = UNEXPANDED; end; else if token = "&expanded" then do; tracing.on = "1"b; tracing.expand = EXPANDED; end; else if token = "&all" | token = "&all_expansions" then do; tracing.on = "1"b; tracing.expand = ALL; end; else if token = "&both" then do; tracing.on = "1"b; tracing.expand = BOTH; end; else if token = "&prefix" then do; tracing.prefix_sw = "1"b; tracing.prefix = get_value ("&prefix"); end; else if token = "&output_switch" | token = "&osw" then do; switch_name = get_value ("&output_switch"); call iox_$find_iocb (switch_name, tracing.iocb, code); if code ^= 0 then call error (code, "Finding I/O switch ""^a""", switch_name); tracing.output_switch = "1"b; end; else call error (0, "Invalid &trace keyword ^a", token); end; end; if ^tracing.on & ^tracing.off then tracing.on = "1"b; if unspec (tracing.types) = "0"b then unspec (tracing.types) = "1111"b; if tracing.command then call set_one_trace (abs_data.command_line, "COMMAND"); if tracing.input then call set_one_trace (abs_data.input_line, "INPUT"); if tracing.control then call set_one_trace (abs_data.control_line, "CONTROL"); if tracing.comment then call set_one_trace (abs_data.comment_line, "COMMENT"); get_value: proc (P_arg_name) returns (char (128) varying); dcl P_arg_name char (*); token = next_token (arg, pos); do while (token = ""); i = i + 1; if i > parsed_args.count then call error (0, "No value specified for &trace " || P_arg_name); arg_ptr = parsed_args (i).ptr; arg_len = parsed_args (i).len; token = first_token (arg, pos); end; return (token); end get_value; set_one_trace: proc (P_line, P_type); dcl 1 P_line aligned like abs_data.command_line; dcl P_type char (*); if P_line.by_control_arg then return; /* ec control args override &trace */ if tracing.on then do; P_line.on = "1"b; if P_line.expand = 0 then /* apply defaults for tracing mode */ if xd.is_absin then P_line.expand = EXPANDED; /* expanded for absentee */ else if P_type = "COMMENT" | P_type = "CONTROL" then P_line.expand = UNEXPANDED; else P_line.expand = EXPANDED; /* expanded for comand and input lines */ end; if tracing.off then P_line.on = "0"b; if tracing.expand ^= 0 then P_line.expand = tracing.expand; if tracing.prefix_sw then P_line.prefix = tracing.prefix; if tracing.output_switch then P_line.iocb = tracing.iocb; end set_one_trace; end set_trace; %page; test_end_of_if: proc; dcl (saved_this_action, saved_next_action) fixed bin; saved_this_action = abs_data.this_action; saved_next_action = abs_data.next_action; TEST: if (abs_data.clause_type = ELSE_TYPE & (saved_this_action ^= ELSE_ACTION | saved_next_action = ELSE_ACTION)) /* statement following an &else */ | (abs_data.clause_type = THEN_TYPE & saved_this_action ^= THEN_ACTION & saved_next_action ^= ELSE_ACTION) then do; /* or stmt following &then, not followed by &else */ if saved_this_action = IF_ACTION | saved_this_action = DO_ACTION then return; /* More nesting: &then &if, &then &do, same for &else */ /* End of the &if-&then-&else compound statement */ if abs_data.prev_if_ptr ^= null then do; /* nested inside another &if */ abs_data.if_info = abs_data.prev_if_ptr -> saved_if_info; go to TEST; /* see if the outer &if is ended too, and so on */ end; else do; abs_data.if_sw = "0"b; /* back to normal text */ abs_data.clause_type = 0; /* we have seen the stmt after the &then or &else */ if abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b; /* stop skipping unless inside a &do being skipped */ end; end; end test_end_of_if; %page; %include abs_io_block; %page; %include abs_io_data; %page; %include abs_io_expand; %page; %include abs_io_handler_node; %page; %include abs_io_hash; %page; %include ec_data; %page; %include iocbx; end abs_io_v2_get_line;  absentee_listen_.pl1 10/04/88 1315.2rew 10/04/88 1312.5 360324 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-03-13,Herbst), approve(86-04-17,MCR7376), audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041): Fixed bug where &goto from &on unit was not resetting auto_in_handler_sw. 2) change(87-02-20,Parisek), approve(87-07-23,MCR7716), audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080): If caller of exec_com_ is call_ec_ then turn on the exec_com_info.noabort flag for subsequent notification to subroutines to not abort after an ec severity 1 error. 3) change(88-08-08,TLNguyen), approve(88-08-08,MCR7934), audit(88-08-26,Parisek), install(88-09-16,MR12.2-1111): Make the &exit statement and the &goto LABEL statement constructed within the &on unit work as documented. 4) change(88-09-29,TLNguyen), approve(88-09-29,PBF7934), audit(88-09-29,Parisek), install(88-10-04,MR12.2-1128): Add the local turned_on_in_handler_sw flag in the invoke_handler internal procedure. This flag is used to control how abs_data.in_handler_sw gets set/reset based on its current state (ie, ON if OFF; OFF if ON). Remove setting/resetting of abs_data.in_handler_sw within the any_other handler. END HISTORY COMMENTS */ /* format: off */ absentee_listen_: procedure (P_initial_command_line); /* Initial coding: 25 June 1979 by J. Spencer Love */ /* Modified: 8 June 1980 by J. Spencer Love for exec_com_ and absentee_listen_ */ /* Added get_ec_version_ 07/28/81 S. Herbst */ /* Modified for new abs_io_, April 1982, E. N. Kittlitz */ /* Fixed get_ec_version_ to use uniquely-named IO switch 05/24/82 S. Herbst */ /* Changed wording of "not found using search list" message 07/26/82 S. Herbst */ /* Added $execute_handler and code to execute an &on unit 01/06/83 S. Herbst */ /* Fixed to turn off ec_data.input_line while executing handler 06/03/83 S. Herbst */ /* Fixed so that all entry points initialize "initialized" and "state" 10/05/83 S. Herbst */ /* Fixed to do a PL/1 nonlocal goto to parent ec's stack frame for &goto inside an &on unit 11/17/83 S. Herbst */ /* Fixed get_ec_version_ to return the right character position 11/30/83 S. Herbst */ /* Changed to support exec_com command control args -trace, -no_trace, -trace_default 03/22/84 S. Herbst */ /* Fixed $exec_com to initialize exec_com_info_ptr to null 08/10/84 S. Herbst */ /* Fixed $absentee_listen_ to set ec_info.switch_ptr = iox_$user_io instead of null 09/17/84 Steve Herbst */ /* Fixed &on any_other, ec_data.input_line="0"b executing cleanup handler 10/25/84 Steve Herbst */ /* Changed $absentee_listen_ to call listen_, which knows about release/start, etc. 12/03/84 Steve Herbst */ /* Changed all entry points to deal with release/start as listen_ does 12/07/84 Steve Herbst */ /* Commented out support for release/start except via $absentee_listen_ 12/12/84 Steve Herbst */ /* Fixed any_other handler to use auto recursion flag in case user_i/o detached 01/04/85 Steve Herbst */ /* Fixed bug where revert_output or discard_output turns off abs_data.in_handler_sw 01/14/85 Steve Herbst */ declare P_abs_data_ptr ptr parameter, P_caller char (*) parameter, P_code fixed bin (35) parameter, P_condition_info_ptr ptr parameter, P_continue_to_signal_sw bit (1) aligned parameter, P_dn char (*) parameter, P_ec_info_ptr ptr parameter, P_en char (*) parameter, P_exec_com_info_ptr ptr parameter, P_goto_label_len fixed bin (21) parameter, P_goto_label_ptr ptr parameter, P_handler_node_ptr ptr parameter, P_initial_command_line char (*) varying parameter, P_initial_string char (*) parameter, P_pathname char (*) parameter, P_search_list char (*) parameter, P_search_name char (*) parameter, P_subsystem_dir_ptr ptr parameter, P_suffix char (*) parameter, P_text_pos fixed bin (21) parameter, P_version fixed bin parameter; declare (addr, addrel, baseno, charno, clock, codeptr, copy, index, length, null, rtrim, stackframeptr, string, substr, unspec) builtin; declare (any_other, cleanup, stringsize) condition; declare auto_in_handler_sw bit (1) aligned, /* to prevent looping of any_other handler */ auto_cond_name char (32); declare arg_count fixed bin, arg_len fixed bin (21), arg_ptr ptr, arg char (arg_len) based (arg_ptr), arg_list_ptr ptr, actual_len fixed bin (21), buffer char (512), command_sw bit (1) aligned, cond_name char (32), continue_to_signal_sw bit (1) aligned, entry_point_name char (32), goto_label char (goto_label_len) based (goto_label_ptr), goto_label_len fixed bin (21), goto_label_ptr ptr, handler_found_sw bit (1) aligned, i fixed bin, initialized bit (1) aligned, p ptr, path char (168), path_arg_pos fixed bin, read_len fixed bin (21), read_ptr ptr, ready_procedure entry (1 aligned like ready_mode) variable, saved_abs_data_ptr ptr, saved_in_handler_sw bit (1), seg_ptr ptr, spno bit (18) aligned, state fixed bin, status fixed bin (35), X_status fixed bin (35), whoami char (32), work_len fixed bin (21), work_ptr ptr, work_string char (work_len) based (work_ptr); declare 1 listener_control aligned like based_listener_control; declare 1 ec_info aligned like ec_data; declare 1 trace_info aligned like ec_trace_info; declare 1 local_condition_info aligned like condition_info; declare 1 ready_mode aligned, 2 flag bit (1) unaligned, 2 pad bit (35) unaligned; declare (TRACE_OFF init ("1"b), TRACE_ON init ("0"b)) bit (1) int static options (constant); declare ( IN_OUTER_PROC init (0), IN_INITIALIZE_EC_INFO init (1), IN_FIND_EC init (-1) ) fixed bin int static options (constant); declare stream_input fixed bin static options (constant) initial (1); declare ( error_table_$badopt, error_table_$end_of_info, error_table_$long_record, error_table_$not_act_fnc, error_table_$pathlong ) fixed bin (35) external, iox_$user_io ptr external, sys_info$max_seg_size fixed bin (35) external; dcl abs_io_$allocate_abs_data entry (ptr); dcl abs_io_$initialize_abs_data entry (ptr); dcl abs_io_v2_get_line$goto entry (ptr, ptr, char (*)) returns (fixed bin (35)); dcl absentee_listen_$execute_handler entry (ptr, ptr, ptr, ptr, ptr, ptr, fixed bin (21), bit (1) aligned, fixed bin (35)); declare active_fnc_err_ entry options (variable), active_fnc_err_$af_suppress_name entry options (variable), com_err_ entry options (variable), com_err_$suppress_name entry options (variable), continue_to_signal_ entry (fixed bin (35)), cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr), cu_$arg_list_ptr entry () returns (ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr), cu_$generate_call entry (entry, ptr), cu_$cp entry (ptr, fixed bin (21), fixed bin (35)), cu_$ready_proc entry () options (variable), expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)), find_condition_info_ entry (ptr, ptr, fixed bin (35)), get_temp_segment_ entry (char (*), ptr, fixed bin (35)), iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$detach_iocb entry (ptr, fixed bin (35)), iox_$destroy_iocb entry (ptr, fixed bin (35)), iox_$find_iocb entry (char (*), ptr, fixed bin (35)), iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), release_temp_segment_ entry (char (*), ptr, fixed bin (35)), request_id_ entry (fixed bin (71)) returns (char (19)), requote_string_ entry (char (*)) returns (char (*)), signal_io_error_ entry (char (*), ptr, fixed bin (35)), unique_chars_ entry (bit (*)) returns (char (15)); %page; /* Called by initialize_process_, this entry point is the listener for an absentee process. */ /* absentee_listen_: procedure (P_initial_command_line); */ entry_point_name = "absentee_listen_"; exec_com_info_ptr = null; state = IN_OUTER_PROC; /* Tell cleanup handler we have nothing for it to do */ initialized = "0"b; on cleanup call clean_up (); call initialize_ec_info (); ec_info.who_am_i, whoami = "Absentee facility"; ec_info.switch_ptr = iox_$user_io; abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr; initialized = "1"b; call iox_$control (iox_$user_io, "set_ec_data_ptr", addr (ec_info), status); if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting ec data."); unspec (listener_control) = "0"b; listener_control.prev_ptr = null; listener_control.level = 1; sp = stackframeptr (); /* count the stack frame number */ spno = baseno (sp); i = 0; do while (baseno (sp -> stack_frame.prev_sp) = spno & sp ^= null); i = i + 1; sp = sp -> stack_frame.prev_sp; end; listener_control.frame = i; listener_control.release_all, listener_control.release, listener_control.new_release = RELEASE_LABEL; listener_control.start = START_LABEL; listen_static_data_.control_ptr = addr (listener_control); abs_data.listener_pl1_label, abs_data.get_line_pl1_label = CONTINUE; call cu_$cp (addrel (addr (P_initial_command_line), 1), length (P_initial_command_line), status); if status ^= 0 & status ^= 100 then call complain (status, ec_info.who_am_i, "Executing initial command line."); go to COMMON; %page; exec_com_: entry (P_pathname, P_initial_string, P_caller, P_exec_com_info_ptr, P_code); entry_point_name = "exec_com_"; exec_com_info_ptr = P_exec_com_info_ptr; state = IN_OUTER_PROC; initialized = "0"b; on cleanup call clean_up; call initialize_ec_info (); if unspec (exec_com_info.error) ^= ""b & codeptr (exec_com_info.error) ^= null () then ec_info.error = exec_com_info.error; if unspec (exec_com_info.eval_string) ^= ""b & codeptr (exec_com_info.eval_string) ^= null () then ec_info.eval_string = exec_com_info.eval_string; if unspec (exec_com_info.execute_line) ^= ""b & codeptr (exec_com_info.execute_line) ^= null () then ec_info.execute_line = exec_com_info.execute_line; if unspec (exec_com_info.ready) ^= ""b & codeptr (exec_com_info.ready) ^= null () then ready_procedure = exec_com_info.ready; if unspec (exec_com_info.set_ready_mode) ^= ""b & codeptr (exec_com_info.set_ready_mode) ^= null () then ec_info.set_ready_mode = exec_com_info.set_ready_mode; ec_info.call_ready_proc = "0"b; ec_info.who_am_i = P_caller; whoami = "exec_com_"; call attach_ec ("ec_input_", P_pathname); initialized = "1"b; arg_list_ptr = exec_com_info.arg_list_ptr; call check_arg_list (exec_com_info.arg_list_ptr); call set_args (exec_com_info.first_arg); if ec_info.who_am_i = "call_ec_" then abs_data.switches.noabort = "1"b; else abs_data.switches.noabort = ""b; if codeptr (exec_com_info.execute_line) ^= null () & unspec (exec_com_info.execute_line) ^= ""b then call exec_com_info.execute_line (addr (P_initial_string), length (P_initial_string), status); else call cu_$cp (addr (P_initial_string), length (P_initial_string), status); if status ^= 0 & status ^= 100 then call complain (status, ec_info.who_am_i, "Executing initial command line."); abs_data.listener_pl1_label, abs_data.get_line_pl1_label = CONTINUE; go to COMMON; %page; exec_com: ec: entry () options (variable); entry_point_name = "exec_com"; exec_com_info_ptr = null; state = IN_OUTER_PROC; initialized = "0"b; on cleanup call clean_up (); call initialize_ec_info (); command_sw = "1"b; ec_info.set_ready_mode = set_ready_mode; ec_info.who_am_i, whoami = "exec_com"; arg_list_ptr = cu_$arg_list_ptr (); call check_arg_list (arg_list_ptr); if arg_count < 1 then do; COMMAND_USAGE: if ec_info.active_function then call active_fnc_err_$af_suppress_name (0, whoami, "Usage: [ec {-control_args} path {ec_args}]"); else call com_err_$suppress_name (0, whoami, "Usage: ec {-control_args} path {ec_args}"); go to EGRESS; end; path_arg_pos = 0; do i = 1 to arg_count while (path_arg_pos = 0); call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") = 1 then do; if arg = "-no_trace" | arg = "-trace" then do; i = i + 1; if i > arg_count then do; call com_err_ (0, ec_info.who_am_i, "No value specified for ^a", arg); go to EGRESS; end; end; else if arg = "-trace_default" then; else do; call com_err_ (error_table_$badopt, ec_info.who_am_i, "^a", arg); go to EGRESS; end; end; else path_arg_pos = i; end; if path_arg_pos = 0 then go to COMMAND_USAGE; call cu_$arg_ptr_rel (path_arg_pos, arg_ptr, arg_len, (0), arg_list_ptr); call attach_ec ("ec_input_", find_ec ("ec", "exec_com", null ())); initialized = "1"b; unspec (trace_info) = "0"b; do i = 1 to path_arg_pos - 1; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); if index (arg, "-") = 1 then do; if arg = "-no_trace" then do; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); call set_trace (TRACE_OFF, arg); end; else if arg = "-trace" then do; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, (0)); call set_trace (TRACE_ON, arg); end; else if arg = "-trace_default" then unspec (trace_info) = "0"b; end; end; call iox_$control (ec_info.switch_ptr, "set_trace", addr (trace_info), status); if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting -trace information."); call set_args (path_arg_pos + 1); if ec_info.active_function then ec_info.call_ready_proc = "0"b; status = 100; /* Suppress initial call to ready proc */ abs_data.listener_pl1_label, abs_data.get_line_pl1_label = CONTINUE; go to COMMON; %page; execute_handler: entry (P_exec_com_info_ptr, P_ec_info_ptr, P_abs_data_ptr, P_handler_node_ptr, P_condition_info_ptr, P_goto_label_ptr, P_goto_label_len, P_continue_to_signal_sw, P_code); /* This entry point executes the text of an &on unit as if it were a separate exec_com, remembering whether it has exited by means of a nonlocal &goto */ entry_point_name = "execute_handler"; P_goto_label_ptr = null; state = IN_OUTER_PROC; initialized = "0"b; exec_com_info_ptr = P_exec_com_info_ptr; ec_info = P_ec_info_ptr -> ec_data; handler_node_ptr = P_handler_node_ptr; /* Set up a new abs_data for executing the handler */ abs_data_ptr = null; on cleanup call clean_up; call abs_io_$allocate_abs_data (abs_data_ptr); abs_data = P_abs_data_ptr -> abs_data; /* will use some old information */ abs_data.active = "0"b; call abs_io_$initialize_abs_data (abs_data_ptr); /* and some new information */ initialized = "1"b; /* Set defaults for an &on handler */ abs_data.io_module_name = "abs_io_"; abs_data.input_string.ptr = handler_node.ptr; abs_data.input_string.len = handler_node.len; abs_data.input_string.start, abs_data.input_string.position = 1; abs_data.input_string.limit = 0; abs_data.active, abs_data.label_search_sw = "0"b; abs_data.command_line.on, abs_data.comment_line.on, abs_data.control_line.on, abs_data.input_line.on = "0"b; unspec (abs_data.if_info) = "0"b; abs_data.prev_if_ptr = null; unspec (abs_data.on_info) = "0"b; abs_data.cleanup_handler_ptr, abs_data.first_handler_ptr, abs_data.goto_label_ptr = null; abs_data.on_info.in_handler_sw = "1"b; abs_data.on_info.handler_node_ptr = P_handler_node_ptr; abs_data.on_info.condition_name = P_condition_info_ptr -> condition_info.condition_name; abs_data.on_info.mc_ptr = P_condition_info_ptr -> condition_info.mc_ptr; abs_data.on_info.info_ptr = P_condition_info_ptr -> condition_info.info_ptr; abs_data.on_info.wc_ptr = P_condition_info_ptr -> condition_info.wc_ptr; abs_data.on_info.was_attached_sw = (P_abs_data_ptr -> abs_data.attach.victim_ptr ^= null); abs_data.work_area = P_abs_data_ptr -> abs_data.work_area; /* use the same area; copy it back when done */ saved_abs_data_ptr, abs_data.on_info.parent_abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr; ec_info.switch_ptr -> iocb.attach_data_ptr = abs_data_ptr; ec_info.call_ready_proc = "0"b; go to COMMON; %page; COMMON: /* Handle all conditions. This is for the benefit of &on and, in the case of cleanup, for popping a listener level. */ auto_in_handler_sw = "0"b; auto_cond_name = ""; on any_other begin; call find_condition_info_ (null, addr (local_condition_info), 0); cond_name = local_condition_info.condition_name; if cond_name = "cleanup" then do; /* pop listener level */ listen_static_data_.control_ptr = listen_static_data_.control_ptr -> based_listener_control.prev_ptr; if listen_static_data_.control_ptr = null then listen_static_data_.first_level_sw = "1"b; end; if ^auto_in_handler_sw | cond_name ^= auto_cond_name then do; /* prevent looping */ auto_in_handler_sw = "1"b; auto_cond_name = cond_name; continue_to_signal_sw = "1"b; /* default if no handlers invoked */ handler_found_sw = "0"b; p = abs_data.on_info.first_handler_ptr; do while (p ^= null); /* walk down to chain of handler nodes to find a matching condition name */ if p -> handler_node.condition_name = cond_name then do; handler_found_sw = "1"b; call invoke_handler (p); /* execute the text of a specified condition handler (&on unit) */ end; else p = p -> handler_node.next_ptr; end; if ^handler_found_sw then do; /* look for an any_other handler */ p = abs_data.on_info.first_handler_ptr; do while (p ^= null); if p -> handler_node.condition_name = "any_other" then do; call invoke_handler (p); end; else p = p -> handler_node.next_ptr; end; end; if continue_to_signal_sw then call continue_to_signal_ ((0)); /* very important! */ auto_in_handler_sw = "0"b; end; end; %page; LISTENER_LOOP: /* The following routine reads lines from the input file and passes them on to the command processor. It communicates with abs_io_ through the attach_data block (it gets a pointer to this via a control order) in order to determine when command vs. input lines are being read and what the ready mode is. */ do while ("1"b); if ec_info.call_ready_proc & status ^= 100 then call invoke_ready_procedure (); ec_info.input_line = "0"b; read_ptr, work_ptr = addr (buffer); read_len = length (buffer); work_len = 0; do while (status ^= 0 | work_len = 0); call iox_$get_line (ec_info.switch_ptr, read_ptr, read_len, actual_len, status); work_len = work_len + actual_len; if status ^= 0 then if status = error_table_$end_of_info then if work_len = 0 then go to EGRESS; /* all done */ else status = 0; /* abs_io_ wont do this, but if there is a partial line... */ else if status = error_table_$long_record & seg_ptr = null () then do; /* too big; get a temp segment and put it there instead */ call get_temp_segment_ (whoami, seg_ptr, X_status); if X_status ^= 0 then call complain (X_status, ec_info.who_am_i, "Getting temp segment."); work_ptr = seg_ptr; work_string = substr (buffer, 1, work_len); read_ptr = addr (substr (work_string, work_len + 1)); read_len = (sys_info$max_seg_size * 4) - work_len; end; else call signal_io_error_ ("Error while reading command line.", ec_info.switch_ptr, status); end; ec_info.input_line = "1"b; /* anything read after this point is an input line */ saved_in_handler_sw = abs_data.in_handler_sw; /* I don't know why, but a revert_output or discard_output zeroes this flag! */ if codeptr (ec_info.execute_line) ^= null () then call ec_info.execute_line (work_ptr, work_len, status); else call cu_$cp (work_ptr, work_len, status); abs_data.in_handler_sw = saved_in_handler_sw; CONTINUE: if seg_ptr ^= null () then call release_temp_segment_ (whoami, seg_ptr, status); end; go to EGRESS; %page; RELEASE_LABEL: /* transferred to by the release command */ abs_data.active = "0"b; go to LISTENER_LOOP; START_LABEL: /* transferred to by the start command */ listen_static_data_.control_ptr = listen_static_data_.control_ptr -> based_listener_control.prev_ptr; return; %page; get_ec_version_: entry (P_dn, P_en, P_version, P_text_pos, P_code); /* Returns version number of ec and position of first character following the "&version N" stmt if any. Called by program that adds copyright notices to exec_com's. */ state = IN_OUTER_PROC; initialized = "0"b; call initialize_ec_info (); on cleanup begin; if ec_info.switch_ptr ^= null () then do; call iox_$detach_iocb (ec_info.switch_ptr, (0)); call iox_$destroy_iocb (ec_info.switch_ptr, (0)); end; end; if P_dn = ">" then path = ">" || P_en; else path = rtrim (P_dn) || ">" || P_en; call iox_$attach_name (unique_chars_ ("0"b), ec_info.switch_ptr, "ec_input_ " || requote_string_ (rtrim (path)), codeptr (exec_com), status); if status ^= 0 then do; P_code = status; if ec_info.switch_ptr ^= null () then call iox_$destroy_iocb (ec_info.switch_ptr, (0)); return; end; abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr; initialized = "1"b; P_version = abs_data.open_data.parser_version; P_text_pos = abs_data.input_string.start; if P_version = 1 then /* version 1 positions to newline after the "&version 1" */ P_text_pos = P_text_pos + 1; /* user wants position of char after newline */ P_code = 0; call iox_$detach_iocb (ec_info.switch_ptr, status); if status = 0 then call iox_$destroy_iocb (ec_info.switch_ptr, status); return; %page; invoke_handler: proc (P_node_ptr); dcl P_node_ptr ptr; dcl (goto_sw, saved_input_line_sw, turned_on_in_handler_sw) bit (1) aligned; saved_input_line_sw = ec_info.input_line; ec_info.input_line = "0"b; turned_on_in_handler_sw = "0"b; if ^abs_data.in_handler_sw then /* turn on, if not already on */ abs_data.in_handler_sw, turned_on_in_handler_sw = "1"b; call absentee_listen_$execute_handler (exec_com_info_ptr, addr (ec_info), abs_data_ptr, P_node_ptr, addr (local_condition_info), goto_label_ptr, goto_label_len, continue_to_signal_sw, 0); if goto_label_ptr ^= null then do; goto_sw = "1"b; status = abs_io_v2_get_line$goto (abs_data_ptr, addr (ec_info), goto_label); if status ^= 0 then go to EGRESS; end; else goto_sw = "0"b; ec_info.input_line = saved_input_line_sw; if turned_on_in_handler_sw then /* only turn off, if we turned it on */ abs_data.in_handler_sw = "0"b; if goto_sw then do; abs_data.active, auto_in_handler_sw = "0"b; /* Implementing nonlocal &goto from inside an &on unit (handler). This is done by a PL/1 nonlocal goto so that interrupted actions are not continued. If the handler was invoked while in abs_io_v2_get_line, the target of the goto is that procedure's START: label, to process the &label statement. If the handler was invoked while inside cu_$cp (ec_info.input_line = "1"b), the target of the goto is absentee_listen_'s CONTINUE: label, to put us back in the listener loop. */ if ec_info.input_line then go to abs_data.listener_pl1_label; else go to abs_data.get_line_pl1_label; end; P_node_ptr = null; /* handler invoked; stop the caller's loop */ return; end invoke_handler; %page; invoke_ready_procedure: procedure (); if codeptr (ready_procedure) ^= null () then call ready_procedure (ready_mode); /* This case is for exec_com_, if given a value */ else if command_sw then call cu_$ready_proc (ready_mode); /* This case is for the exec_com command */ else call cu_$ready_proc (); /* This case is for absentee, or exec_com_ default */ return; end invoke_ready_procedure; set_ready_mode: procedure (P_ready_mode); declare 1 P_ready_mode aligned like ready_mode; ready_mode = P_ready_mode; return; end set_ready_mode; %page; complain: procedure () options (variable); declare arg_list_ptr ptr, based_status_ptr ptr, based_status fixed bin (35) based (based_status_ptr); arg_list_ptr = cu_$arg_list_ptr (); if state = IN_FIND_EC then do; /* In exec_com_$find_ec. Set return values and punt */ P_pathname = ""; call cu_$arg_ptr (1, based_status_ptr, (0), (0)); P_code = based_status; end; else if codeptr (ec_info.error) ^= null () then call cu_$generate_call (ec_info.error, arg_list_ptr); else if ec_info.active_function then call cu_$generate_call (active_fnc_err_, arg_list_ptr); else call cu_$generate_call (com_err_, arg_list_ptr); go to EGRESS; end complain; EGRESS: call finish_up (); return; %page; clean_up: procedure (); dcl saved_input_line_sw bit (1) aligned; saved_input_line_sw = ec_info.input_line; ec_info.input_line = "0"b; if initialized then if abs_data.on_info.cleanup_handler_ptr ^= null then /* there is an "&on cleanup" */ if abs_data.on_info.cleanup_handler_ptr -> handler_node.condition_name = "cleanup" then do; /* and it's not disabled by &resignal */ local_condition_info.condition_name = "cleanup"; local_condition_info.mc_ptr, local_condition_info.info_ptr, local_condition_info.wc_ptr = null; call absentee_listen_$execute_handler (exec_com_info_ptr, addr (ec_info), abs_data_ptr, abs_data.on_info.cleanup_handler_ptr, addr (local_condition_info), null, 0, "0"b, 0); /* don't honor any nonlocal &goto inside it */ end; ec_info.input_line = saved_input_line_sw; call finish_up (); end clean_up; %page; finish_up: procedure (); dcl goto_label char (abs_data.goto_label_len) based (abs_data.goto_label_ptr); declare status fixed bin (35); declare iox_$close entry (ptr, fixed bin (35)); if state = IN_INITIALIZE_EC_INFO then do; /* clean up after initialize_ec_info */ if ec_info.switch_ptr ^= null & abs_data_ptr ^= null then if ^abs_data.in_handler_sw then do; call iox_$control (ec_info.switch_ptr, "handle_cleanup", addr (ec_info), status); call iox_$close (ec_info.switch_ptr, status); call iox_$detach_iocb (ec_info.switch_ptr, status); call iox_$destroy_iocb (ec_info.switch_ptr, status); end; if seg_ptr ^= null () then call release_temp_segment_ (whoami, seg_ptr, status); end; if initialized then if abs_data_ptr ^= null then if entry_point_name = "execute_handler" then do; P_continue_to_signal_sw = abs_data.on_info.continue_to_signal_sw; if abs_data.goto_sw then do; /* leaving &on unit via &goto */ /* label must be allocated in parent's area */ allocate goto_label in (saved_abs_data_ptr -> abs_data.work_area) set (P_goto_label_ptr); /* set args of absentee_listen_$execute_handler */ P_goto_label_ptr -> goto_label = abs_data.goto_label_ptr -> goto_label; P_goto_label_len = abs_data.goto_label_len; saved_abs_data_ptr -> abs_data.goto_statement_pos = abs_data.goto_statement_pos + charno (abs_data.input_string.ptr) - charno (saved_abs_data_ptr -> abs_data.input_string.ptr); saved_abs_data_ptr -> abs_data.goto_statement_len = abs_data.goto_statement_len; end; saved_abs_data_ptr -> abs_data.output_file = abs_data.output_file; saved_abs_data_ptr -> abs_data.variables_ptr = abs_data.variables_ptr; free abs_data; /* free the &on unit's private abs_data */ /* and restore the parent's: */ abs_data_ptr, ec_info.switch_ptr -> attach_data_ptr = saved_abs_data_ptr; end; return; end finish_up; %page; initialize_ec_info: procedure (); declare null_entry_value entry variable; unspec (null_entry_value) = copy (unspec (null ()), 2); ready_procedure = null_entry_value; string (ready_mode) = ""b; command_sw = "0"b; seg_ptr = null (); ec_info.version_id = ec_data_version_id; ec_info.version = ec_data_version_1; ec_info.active_function = "0"b; ec_info.return_len = 0; ec_info.return_ptr = null (); ec_info.execute_line = null_entry_value; ec_info.eval_string = null_entry_value; ec_info.set_ready_mode = null_entry_value; ec_info.error = null_entry_value; ec_info.switch_ptr = null (); ec_info.id_string = request_id_ (clock ()); ec_info.input_line = "1"b; ec_info.call_ready_proc = "1"b; abs_data_ptr = null; state = IN_INITIALIZE_EC_INFO; return; end initialize_ec_info; %page; attach_ec: procedure (P_switch_name, P_path); dcl (P_switch_name, P_path) char (*); declare code fixed bin (35); declare sub_error_ condition; condition_info_ptr = addr (local_condition_info); on sub_error_ begin; call find_condition_info_ (null (), condition_info_ptr, code); if code = 0 then do; sub_error_info_ptr = condition_info.info_ptr; call complain (sub_error_info.status_code, ec_info.who_am_i, "^a", sub_error_info.info_string); end; else call continue_to_signal_ ((0)); end; call iox_$attach_name (ec_info.id_string || "." || rtrim (whoami), ec_info.switch_ptr, rtrim (P_switch_name) || " " || requote_string_ (rtrim (P_path)), codeptr (exec_com) /* Pick up bound-in version by default */, status); if status ^= 0 then call complain (status, ec_info.who_am_i, "Attaching ^a.", P_path); call iox_$open (ec_info.switch_ptr, stream_input, "0"b, status); if status ^= 0 then call complain (status, ec_info.who_am_i, "Opening ^a.", P_path); revert sub_error_; call iox_$control (ec_info.switch_ptr, "set_ec_data_ptr", addr (ec_info), status); if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting ec data."); abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr; return; end attach_ec; %page; check_arg_list: procedure (P_arg_list_ptr); declare P_arg_list_ptr ptr; call cu_$af_return_arg_rel (arg_count, ec_info.return_ptr, ec_info.return_len, status, P_arg_list_ptr); if status = 0 then ec_info.active_function = "1"b; else if status ^= error_table_$not_act_fnc then call complain (status, ec_info.who_am_i, "Getting argument list."); return; end check_arg_list; set_args: procedure (first_arg); declare (first_arg, args_index, i) fixed bin; declare 1 args aligned, /* adjustable automatic storage */ 2 count fixed bin, 2 e (arg_count - first_arg + 1), 3 ptr ptr unaligned, 3 len fixed bin (21); args.count = arg_count - first_arg + 1; args_index = 0; do i = first_arg to arg_count; call cu_$arg_ptr_rel (i, arg_ptr, arg_len, status, arg_list_ptr); args_index = args_index + 1; args (args_index).ptr = arg_ptr; args (args_index).len = arg_len; end; call iox_$control (ec_info.switch_ptr, "set_argument_ptrs", addr (args), status); if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting arguments."); return; end set_args; %page; exec_com_$find_ec: entry (P_search_name, P_suffix, P_search_list, P_subsystem_dir_ptr, P_pathname, P_code); state = IN_FIND_EC; /* Tell complain that we are find_ec */ initialized = "0"b; arg_ptr = addr (P_search_name); /* find_ec uses based variable "arg" as input */ arg_len = length (rtrim (P_search_name)); on stringsize go to PATHNAME_TOO_LONG; /* Complain if "returns (char (*))" result too big */ (stringsize): P_pathname = find_ec (P_suffix, P_search_list, P_subsystem_dir_ptr); P_code = 0; /* find_ec aborted through complain if it failed */ return; PATHNAME_TOO_LONG: P_pathname = ""; P_code = error_table_$pathlong; return; %page; find_ec: procedure (suffix, search_list, subsystem_dir_ptr) returns (char (*)); declare suffix char (*) parameter, search_list char (*) parameter, subsystem_dir_ptr ptr parameter; declare (length, null, reverse, rtrim, search) builtin; declare dirname char (168), entryname char (32), entryname_len fixed bin (21), must_search bit (1) aligned, path_len fixed bin (21), path char (path_len) based (arg_ptr), pathname char (169 + arg_len) varying, search_dirname char (168), subsystem_dir char (168); declare ( error_table_$badpath, error_table_$no_search_list ) fixed bin (35) external; declare hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35)); must_search = "0"b; path_len = arg_len; entryname_len = search (reverse (arg), "<>") - 1; if entryname_len < 0 then do; entryname_len = arg_len; if search_list ^= "" then must_search = "1"b; end; else if entryname_len = 0 then call complain (error_table_$badpath, ec_info.who_am_i, "No file name given. ^a", arg); call expand_pathname_$add_suffix (path, suffix, dirname, entryname, status); if status ^= 0 then call complain (status, ec_info.who_am_i, "^a", path); if must_search then do; if subsystem_dir_ptr = null () then subsystem_dir = ""; else do; call hcs_$fs_get_path_name (subsystem_dir_ptr, subsystem_dir, (0), (""), status); if status ^= 0 then subsystem_dir = ""; end; call search_paths_$find_dir (search_list, null (), entryname, subsystem_dir, search_dirname, status); if status = 0 then dirname = search_dirname; else if status ^= error_table_$no_search_list then call complain (status, ec_info.who_am_i, "^a using ^a search list.", entryname, search_list); end; pathname = rtrim (dirname); if length (pathname) ^= 1 then pathname = pathname || ">"; pathname = pathname || entryname; return (pathname); end find_ec; %page; set_trace: proc (P_off_sw, P_str); /* Parses list of trace terms separated by commas and does the work. */ dcl P_off_sw bit (1); dcl P_str char (*); dcl (i, str_len) fixed bin (21); dcl 1 tracing, 2 types, 3 (command, comment, control, input) bit (1) unaligned, 2 (on, off, output_switch, prefix_sw) bit (1) unaligned, 2 expand fixed bin, 2 prefix char (32) varying, 2 iocb ptr; unspec (tracing) = "0"b; str_len = length (P_str); begin; dcl buffer char (str_len) varying; buffer = P_str; do while (buffer ^= ""); i = index (buffer, ","); if i = 0 then do; call set_term (P_off_sw, (buffer)); buffer = ""; end; else do; call set_term (P_off_sw, substr (buffer, 1, i - 1)); buffer = substr (buffer, i + 1); end; end; if ^tracing.on & ^tracing.off then tracing.on = "1"b; if unspec (tracing.types) = "0"b then unspec (tracing.types) = "1111"b; if tracing.command then call set_one_trace (trace_info.command_line, "COMMAND"); if tracing.input then call set_one_trace (trace_info.input_line, "INPUT"); if tracing.control then call set_one_trace (trace_info.control_line, "CONTROL"); if tracing.comment then call set_one_trace (trace_info.comment_line, "COMMENT"); end; return; set_one_trace: proc (P_line, P_type); dcl 1 P_line aligned like ec_trace_info.command_line; dcl P_type char (*); P_line.explicit_sw = "1"b; if tracing.on then do; P_line.on = "1"b; if P_line.expand = 0 then /* apply defaults for expansion tracing */ if abs_data.absentee then P_line.expand = EXPANDED; else if P_type = "COMMENT" | P_type = "CONTROL" then P_line.expand = UNEXPANDED; else P_line.expand = EXPANDED; end; if tracing.off then P_line.on = "0"b; if tracing.expand ^= 0 then P_line.expand = tracing.expand; if tracing.prefix_sw then P_line.prefix = tracing.prefix; if tracing.output_switch then P_line.iocb = tracing.iocb; end set_one_trace; %page; /* More procs internal to set_trace */ set_term: proc (P_off_sw, P_str); /* Handles a single trace keyword or keyword pair ("prefix=STR"). */ dcl P_off_sw bit (1); dcl P_str char (*); dcl i fixed bin; i = index (P_str, "="); if i ^= 0 then call set_keyword (P_off_sw, substr (P_str, 1, i - 1), "1"b, substr (P_str, i + 1)); else call set_keyword (P_off_sw, P_str, "0"b, ""); return; set_keyword: proc (P_off_sw, P_keyword, P_value_sw, P_value); /* Does the work for a single trace keyword or keyword pair. */ dcl (P_off_sw, P_value_sw) bit (1); dcl (P_keyword, P_value) char (*); if P_keyword = "command" then if P_value_sw then do; BAD_TRACE_SYNTAX: call complain (0, ec_info.who_am_i, "Syntax error in argument to -^[no_^]trace", P_off_sw); go to EGRESS; end; else tracing.command = "1"b; else if P_keyword = "comment" then if P_value_sw then go to BAD_TRACE_SYNTAX; else tracing.comment = "1"b; else if P_keyword = "control" then if P_value_sw then go to BAD_TRACE_SYNTAX; else tracing.control = "1"b; else if P_keyword = "input" then if P_value_sw then go to BAD_TRACE_SYNTAX; else tracing.input = "1"b; else if P_keyword = "all_types" then if P_value_sw then go to BAD_TRACE_SYNTAX; else tracing.command, tracing.comment, tracing.control, tracing.input = "1"b; else if P_off_sw | open_data.parser_version <= 1 then do; call complain (0, ec_info.who_am_i, "Invalid keyword specified for ^[-no_^]trace", P_off_sw); go to EGRESS; end; if P_keyword = "command" | P_keyword = "comment" | P_keyword = "control" | P_keyword = "input" then do; if P_off_sw then tracing.off = "1"b; end; else if P_keyword = "unexpanded" then if P_value_sw then go to BAD_TRACE_SYNTAX; else if abs_data.parser_version = 1 then do; BAD_V1_TRACE_MODE: call complain (0, ec_info.who_am_i, "Invalid trace mode ""^a"" for a Version 1 ec.", P_keyword); go to EGRESS; end; else tracing.expand = UNEXPANDED; else if P_keyword = "expanded" then if P_value_sw then go to BAD_TRACE_SYNTAX; else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE; else tracing.expand = EXPANDED; else if P_keyword = "all" | P_keyword = "all_expansions" then if P_value_sw then go to BAD_TRACE_SYNTAX; else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE; else tracing.expand = ALL; else if P_keyword = "both" then if P_value_sw then go to BAD_TRACE_SYNTAX; else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE; else tracing.expand = BOTH; else if P_keyword = "prefix" then if ^P_value_sw then go to BAD_TRACE_SYNTAX; else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE; else do; tracing.prefix_sw = "1"b; tracing.prefix = P_value; end; else if P_keyword = "output_switch" | P_keyword = "osw" then if ^P_value_sw then go to BAD_TRACE_SYNTAX; else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE; else do; call iox_$find_iocb (P_value, tracing.iocb, status); if status ^= 0 then do; call complain (status, ec_info.who_am_i, "Finding I/O switch ""^a""", P_value); go to EGRESS; end; tracing.output_switch = "1"b; end; else do; call complain (0, ec_info.who_am_i, "Invalid -^[no_^]trace keyword ^a", P_off_sw, P_keyword); go to EGRESS; end; end set_keyword; end set_term; end set_trace; %page; %include abs_io_data; %page; %include abs_io_handler_node; %page; %include condition_info; %page; %include condition_info_header; %page; %include ec_data; %page; %include ec_trace_info; %page; %include exec_com_info; %page; %include iocb; %page; %include listener_info; %page; %include stack_frame; %page; %include sub_error_info; end absentee_listen_;  convert_ec.pl1 04/29/86 0941.8rew 04/29/86 0939.6 206820 /****^ *********************************************************** * * * 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-04-14,Herbst), approve(86-04-14,MCR7377), audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041): Fixed to apply equal convention correctly to -of argument. END HISTORY COMMENTS */ /* format: off */ convert_ec: cvec: proc; /* Converts a version 1 exec_com to version 2 */ /* Conversions of note are: leading/trailing whitespace -> &SP, &HT, etc. V2 ignores leading/trailing white & -> &- new comment sequence &if [...] -> &if &[...] af expansion in control lines &&...& -> &&&&...&& double strings of 2 or more &'s &(...) -> &&(...) do command kludge &0 -> &ec_path &0 is obsolete in V2 &NN -> &(NN) 2 or more digit params &command_line -> &trace &command &comment_line -> &trace &comment &control_line -> &trace &control &input_line -> &trace &input &unknown (beginning of line) -> comment line (causes warning unless -bf) &unknown -> &&unknown (causes warning unless -bf) /* Written 12/08/80 S. Herbst */ /* Converted to final MCR'd version 05/13/81 */ /* Changed to accept .absin suffix explicitly 12/17/81 S. Herbst */ /* Fixed to restore original if replacement is interrupted 01/03/84 S. Herbst */ /* Constants */ dcl KEYWORDS_STRING char (KEYWORDS_LEN) aligned based (addr (KEYWORDS)); dcl ME char (32) int static options (constant) init ("convert_ec"); dcl KEYWORDS (28) char (32) int static options (constant) init ("&attach", "&command_line", "&comment_line", "&control_line", "&detach", "&ec_dir", "&ec_name", "&ec_switch", "&else", "&f&n", "&goto", "&if", "&input_line", "&is_absin", "&is_active_function", "&is_af", "&is_attached", "&is_input_line", "&label", "&n", "&print", "&q&n", "&quit", "&r&n", "&ready", "&ready_proc", "&return", "&then"); dcl DIGITS char (10) int static options (constant) init ("0123456789"); dcl ALPHABET char (27) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz_"); dcl (BRANCHES init (2), BRANCHES_AND_LINKS init (3)) fixed (2) int static options (constant); dcl WHITE char (4) int static options (constant) init (" "); /* SP HT VT FF */ dcl SP char (1) int static options (constant) init (" "); dcl NL char (1) int static options (constant) init (" "); dcl PREFIXES (10) char (8) varying int static options (constant) init ("q", "r", "f", "qf", "rf", "q&n", "r&n", "f&n", "qf&n", "rf&n"); dcl TAKES_ARG (10) bit (1) int static options (constant) init ("1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b); /* Based */ dcl arg char (arg_len) based (arg_ptr); /* Automatic */ dcl (dn1, dn2, temp_dn) char (168); dcl (en1, en2, suffix, temp_en) char (32); dcl (absin_sw, begin_line_sw, chase_sw, check_sw, force_sw, got_path1_sw, got_path2_sw, star_sw) bit (1); dcl arg_ptr ptr; dcl KEYWORDS_LEN fixed; dcl (arg_count, i, severity) fixed; dcl star_select fixed (2); dcl arg_len fixed (21); dcl code fixed (35); dcl error_table_$action_not_performed fixed (35) ext; dcl error_table_$badopt fixed (35) ext; dcl error_table_$namedup fixed bin (35) ext; dcl error_table_$segknown fixed (35) ext; dcl error_table_$segnamedup fixed (35) ext; dcl iox_$error_output ptr ext; dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl check_star_name_$entry entry (char (*), fixed (35)); dcl cu_$arg_count entry (fixed, fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35)); dcl cv_dec_check_ entry (char (*), fixed (35)) returns (fixed); dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35)); dcl get_equal_name_ entry (char (*), char (*), char (*), fixed (35)); dcl get_pdir_ entry returns (char (168)); dcl get_system_free_area_ entry returns (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed (35)); dcl hcs_$chname_seg entry (ptr, char (*), char (*), fixed (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed, char (*), fixed (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed (24), fixed (2), ptr, fixed (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed (5), ptr, fixed (35)); dcl hcs_$set_bc_seg entry (ptr, fixed (24), fixed (35)); dcl hcs_$star_ entry (char (*), char (*), fixed (2), ptr, fixed, ptr, ptr, fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed (35)); dcl ioa_$ioa_switch entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl nd_handler_ entry (char (*), char (*), char (*), fixed (35)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl release_temp_segment_ entry (char (*), ptr, fixed (35)); dcl (addr, copy, divide, hbound, fixed, index, length, null, rtrim, reverse, search, substr, verify) builtin; dcl cleanup condition; %page; KEYWORDS_LEN = length (KEYWORDS (1)) * hbound (KEYWORDS, 1); call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); return; end; /* Read control args */ chase_sw, check_sw, force_sw = "0"b; got_path1_sw, got_path2_sw = "0"b; severity = 2; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-chase" then chase_sw = "1"b; else if arg = "-check" | arg = "-ck" then check_sw = "1"b; else if arg = "-force" | arg = "-fc" then force_sw = "1"b; else if arg = "-no_chase" then chase_sw = "0"b; else if arg = "-no_check" | arg = "-nck" then check_sw = "0"b; else if arg = "-no_force" | arg = "-nfc" then force_sw = "0"b; else if arg = "-output_file" | arg = "-of" then do; i = i + 1; if i > arg_count then do; call com_err_ (0, ME, "No value specified for -output_file"); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call expand_pathname_ (arg, dn2, en2, code); if code ^= 0 then do; ARG_ERR: call com_err_ (code, ME, "^a", arg); return; end; got_path2_sw = "1"b; end; else if arg = "-severity" | arg = "-sv" then do; i = i + 1; if i > arg_count then do; call com_err_ (0, ME, "No value specified for -severity"); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); severity = cv_dec_check_ (arg, code); if code ^= 0 then go to ARG_ERR; end; else do; call com_err_ (error_table_$badopt, ME, "^a", arg); return; end; else if got_path1_sw then do; USAGE: call com_err_$suppress_name (0, ME, "Usage: convert_ec path {-control_args}"); return; end; else do; suffix = "ec"; if length (arg) > 6 then if substr (arg, length (arg) - 5, 6) = ".absin" then suffix = "absin"; call expand_pathname_$add_suffix (arg, suffix, dn1, en1, code); if code ^= 0 then go to ARG_ERR; call check_star_name_$entry (en1, code); if code ^= 0 then if code = 1 | code = 2 then star_sw = "1"b; else do; call com_err_ (code, ME, "^a", pathname_ (dn2, en2)); return; end; else star_sw = "0"b; got_path1_sw = "1"b; end; end; if ^got_path1_sw then go to USAGE; if got_path2_sw then if star_sw then call convert_stars (dn1, en1, dn2, en2); else call convert_one (dn1, en1, dn2, en2); else if star_sw then call convert_stars (dn1, en1, dn1, "==="); else call convert_one (dn1, en1, dn1, en1); RETURN: return; %page; convert_stars: proc (P_dn1, P_en1, P_dn2, P_en2); dcl (P_dn1, P_en1, P_dn2, P_en2) char (*); dcl 1 entries (entry_count) aligned based (entries_ptr), 2 pad bit (18) unaligned, 2 nindex bit (18) unaligned; dcl names (999) char (32) based (names_ptr); dcl area area based (area_ptr); dcl (area_ptr, entries_ptr, names_ptr) ptr; dcl (entry_count, j) fixed; area_ptr = get_system_free_area_ (); entries_ptr, names_ptr = null; if chase_sw then star_select = BRANCHES_AND_LINKS; else star_select = BRANCHES; on cleanup call star_cleanup; call hcs_$star_ (P_dn1, P_en1, star_select, area_ptr, entry_count, entries_ptr, names_ptr, code); if code ^= 0 then do; call com_err_ (code, ME, "^a^[>^]^a", P_dn1, P_dn1 ^= ">", P_en1); return; end; do j = 1 to entry_count; call convert_one (P_dn1, names_ptr -> names (fixed (entries_ptr -> entries (j).nindex)), P_dn2, P_en2); end; call star_cleanup; return; star_cleanup: proc; if entries_ptr ^= null then free entries in (area); if names_ptr ^= null then free names in (area); end star_cleanup; end convert_stars; %page; convert_one: proc (P_dn1, P_en1, P_dn2, P_en2); dcl (P_dn1, P_en1, P_dn2, P_en2) char (*); dcl seg1 char (len1) based (ptr1); dcl seg2 char (len2) based (ptr2); dcl (digit_str, target_en) char (32); dcl keyword_name char (32) varying; dcl next_char char (1); dcl (errors_sw, found_sw, replacing_orig_sw) bit (1); dcl (ptr1, ptr2, safe_copy_ptr, target_ptr) ptr; dcl bit_count fixed (24); dcl (len1, len2, pos1) fixed (21); dcl (i, line_number) fixed; dcl (code, safe_copy_code) fixed (35); call get_equal_name_ (P_en1, P_en2, target_en, code); if code ^= 0 then do; call com_err_ (code, ME, "^a for ^a", P_en2, P_en1); go to RETURN; end; /* Add suffix if necessary to target entry name */ call expand_pathname_$add_suffix (target_en, suffix, (""), target_en, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", target_en); go to RETURN; end; ptr1, ptr2, safe_copy_ptr, target_ptr = null; replacing_orig_sw = "0"b; on cleanup call clean_up; call hcs_$initiate_count (P_dn1, P_en1, "", bit_count, 0, ptr1, code); if ptr1 = null then do; call com_err_ (code, ME, "^a", pathname_ (P_dn1, P_en1)); return; end; RETRY: if ^check_sw then do; call hcs_$make_seg (P_dn2, target_en, "", 01010b, target_ptr, code); if target_ptr = null then do; call com_err_ (code, ME, "^a", pathname_ (P_dn2, target_en)); go to RETURN; end; else if (code = error_table_$namedup | code = error_table_$segknown) & target_ptr ^= ptr1 then do; call nd_handler_ (ME, dn2, target_en, code); if code = error_table_$action_not_performed then return; else go to RETRY; end; end; len1 = divide (bit_count, 9, 21, 0); line_number = 1; pos1 = verify (seg1, WHITE); len2 = 0; if substr (seg1, pos1, 8) = "&version" then do; pos1 = pos1 + 8; if substr (seg1, pos1, 1) ^= SP then do; BAD_VERSION: call com_err_ (0, ME, "Invalid &version statement on first line."); CLEANUP_TARGET: if target_ptr ^= null & target_ptr ^= ptr1 then call hcs_$delentry_seg (target_ptr, code); go to RETURN; end; i = verify (substr (seg1, pos1), WHITE); if i = 0 then go to BAD_VERSION; pos1 = pos1 + i - 1; if substr (seg1, pos1, 1) = NL then go to BAD_VERSION; /* no number */ if index (WHITE || NL, substr (seg1, pos1 + 1, 1)) = 0 then go to BAD_VERSION; /* not 1 char */ if substr (seg1, pos1, 1) = "2" then do; call com_err_ (0, ME, "Segment is already version 2. ^a", pathname_ (P_dn1, P_dn2)); go to CLEANUP_TARGET; end; else if substr (seg1, pos1, 1) ^= "1" then go to BAD_VERSION; pos1 = pos1 + verify (substr (seg1, pos1 + 1), WHITE || NL); /* skip the &version stmt */ end; else pos1 = 1; /* if no &version 1, don't strip leading white space */ if ^check_sw then do; call get_temp_segment_ (ME, ptr2, code); if code ^= 0 then do; call com_err_ (code, ME, "Temp segment."); go to CLEANUP_TARGET; end; end; call output ("&version 2" || NL); /* Convert the segment */ errors_sw = "0"b; i = verify (seg1, WHITE); /* look for initial leading whitespace */ if i > 1 then do; call convert_white (substr (seg1, 1, i - 1)); pos1 = i; end; do while (pos1 <= len1); i = search (substr (seg1, pos1), "&" || NL); if i = 0 then do; if index (WHITE, substr (seg1, len1, 1)) ^= 0 then call convert_trailing_white (substr (seg1, pos1)); else call output (substr (seg1, pos1)); go to COPY_SEG; end; if substr (seg1, pos1 + i - 1, 1) = NL then do; /* NL */ if i > 1 then /* some text in between */ if index (WHITE, substr (seg1, pos1 + i - 2, 1)) ^= 0 then call convert_trailing_white (substr (seg1, pos1, i - 1)); else call output (substr (seg1, pos1, i - 1)); call output (NL); line_number = line_number + 1; pos1 = pos1 + i; /* position past the NL */ i = verify (substr (seg1, pos1), WHITE); /* look for leading whitespace */ if i > 1 then do; call convert_white (substr (seg1, pos1, i - 1)); pos1 = pos1 + i - 1; end; go to NEXT; end; /* & */ if i > 1 then call output (substr (seg1, pos1, i - 1)); /* copy up to the & */ pos1 = pos1 + i - 1; /* position of the & */ if pos1 = len1 | index (WHITE || NL, substr (seg1, pos1 + 1, 1)) ^= 0 then do; /* comment */ i = index (substr (seg1, pos1), NL); /* take whole comment line */ if i = 0 then do; call warn (3, "Segment does not end in newline."); if pos1 = len1 then call output ("&-"); else call output ("&-" || substr (seg1, pos1 + 1)); go to COPY_SEG; end; else if pos1 = 1 then do; GOOD_COMMENT: call output ("&-" || substr (seg1, pos1 + 1, i - 1)); line_number = line_number + 1; pos1 = pos1 + i; end; else if substr (seg1, pos1 - 1, 1) = NL then go to GOOD_COMMENT; else do; call warn (1, "& does not begin line; converted to &&"); call output ("&& "); pos1 = pos1 + 2; end; end; else if substr (seg1, pos1 + 1, 1) = "&" then do; /* double 2 or more &'s */ i = verify (substr (seg1, pos1), "&") - 1; if i = -1 then i = len1 - pos1 + 1; call output (copy ("&", i * 2)); pos1 = pos1 + i; end; else do; /* &keyword */ if substr (seg1, pos1 + 1, 1) = "(" then do; /* the do command kludge */ /* change &(1) -> &&(1) */ call output ("&" || substr (seg1, pos1, 2)); pos1 = pos1 + 2; end; else do; if pos1 = 1 then begin_line_sw = "1"b; else if substr (seg1, pos1 - 1, 1) = NL then begin_line_sw = "1"b; else begin_line_sw = "0"b; pos1 = pos1 + 1; next_char = substr (seg1, pos1, 1); if index (DIGITS, next_char) ^= 0 then do; /* &1 parameter */ call output ("&"); PARAM: i = verify (substr (seg1, pos1), DIGITS); if i = 0 then do; call warn (3, "Segment does not end in newline."); digit_str = substr (seg1, pos1); end; else digit_str = substr (seg1, pos1, i - 1); if length (rtrim (digit_str)) = 1 then if digit_str = "0" then call output ("ec_path"); else call output (rtrim (digit_str)); else call output ("(" || rtrim (digit_str) || ")"); /* &12 -> &(12) */ pos1 = pos1 + length (rtrim (digit_str)); end; else do; /* some &keyword */ if index ("fqr", next_char) ^= 0 then do; /* might be &r, &q, &f something */ do i = hbound (PREFIXES, 1) by -1 to 1 while (index (substr (seg1, pos1), PREFIXES (i)) ^= 1); end; if i ^= 0 then do; /* it is */ if TAKES_ARG (i) then do; if pos1 < len1 & index (DIGITS, substr (seg1, pos1 + length (PREFIXES (i)), 1)) ^= 0 then do; call output ("&" || PREFIXES (i)); pos1 = pos1 + length (PREFIXES (i)); go to PARAM; end; end; else do; /* &f&n, &r&n, &q&n, &rf&n, &qf&n */ call output ("&" || PREFIXES (i)); pos1 = pos1 + length (PREFIXES (i)); go to NEXT; end; end; end; keyword_name = "&"; found_sw = "0"b; do while (^found_sw); keyword_name = keyword_name || next_char; pos1 = pos1 + 1; if known (keyword_name) then do; found_sw = "1"b; if keyword_name = "&command_line" then call output ("&trace &command"); else if keyword_name = "&input_line" then call output ("&trace &input"); else if keyword_name = "&comment_line" then call output ("&trace &comment"); else if keyword_name = "&control_line" then call output ("&trace &control"); else do; call output ((keyword_name)); if keyword_name = "&if" then do; /* &if [ -> &if &[ */ pos1 = pos1 + verify (substr (seg1, pos1), WHITE) - 1; if substr (seg1, pos1, 1) = "[" then do; pos1 = pos1 + 1; call output (" &["); end; else call output (" "); end; else if keyword_name = "&print" then do; /* look for &print ^-^/^x etc. */ i = index (substr (seg1, pos1), NL); if i = 0 then i = len1 - pos1 + 1; if index (substr (seg1, pos1, i), "^") ^= 0 then call warn (3, "ioa_ controls in &print statement: " || rtrim (substr (seg1, pos1 + 1, i - 1), NL) || NL || "Should be replaced by literals such as &SP"); end; end; end; else do; if pos1 > len1 | index (ALPHABET, substr (seg1, pos1, 1)) = 0 then do; found_sw = "1"b; /* stop the loop */ if begin_line_sw then do; /* &word begins line; convert line to comment */ call warn (2, "Invalid stmt " || keyword_name || " converted to comment."); i = index (substr (seg1, pos1), NL); if i = 0 then call output ("&-" || keyword_name || substr (seg1, pos1)); else do; call output ("&-" || keyword_name || substr (seg1, pos1, i - 1)); pos1 = pos1 + i - 1; /* skip to NL at end of line */ end; end; else do; call warn (1, "Invalid keyword " || keyword_name || " converted to literal string."); call output ("&" || keyword_name); /* convert to literal &&string */ end; end; else next_char = substr (seg1, pos1, 1); end; end; end; end; end; NEXT: end; COPY_SEG: if ^check_sw then do; /* write the converted seg */ if errors_sw & ^force_sw then do; call hcs_$set_bc_seg (ptr2, len2 * 9, 0); call hcs_$fs_get_path_name (ptr2, temp_dn, 0, temp_en, code); if code ^= 0 then do; temp_dn = get_pdir_ (); go to TERMINATE; end; RENAME_TEMP: call hcs_$chname_seg (ptr2, temp_en, target_en, code); if code ^= 0 then do; if code = error_table_$namedup | code = error_table_$segnamedup then do; call com_err_ (0, ME, "Errors found."); call nd_handler_ (ME, temp_dn, target_en, code); if code = 0 then go to RENAME_TEMP; if code = error_table_$action_not_performed then go to DELETE_OFILE; end; call com_err_ (code, ME, "Errors found; unable to rename temp copy in ^[^a^;[pd]^]", temp_dn ^= get_pdir_ (), temp_dn); end; else do; TERMINATE: call hcs_$terminate_noname (ptr2, code); ptr2 = null; /* so release_temp_segments_ doesn't get it */ call com_err_ (code, ME, "Errors found; look for copy ^[^a;^s[pd]>^a^]", temp_dn ^= get_pdir_ (), pathname_ (temp_dn, temp_en), temp_en); end; DELETE_OFILE: if target_ptr ^= null & target_ptr ^= ptr1 then do; call delete_$ptr (target_ptr, "000100"b, ME, 0); target_ptr = null; end; end; else do; call get_temp_segment_ (ME, safe_copy_ptr, safe_copy_code); /* keep copy of orig */ if code = 0 then safe_copy_ptr -> seg1 = ptr1 -> seg1; /* in case replacement is interrupted */ else safe_copy_ptr = null; replacing_orig_sw = "1"b; target_ptr -> seg2 = ptr2 -> seg2; call hcs_$set_bc_seg (target_ptr, len2 * 9, code); end; end; call finish_up; return; %page; convert_trailing_white: proc (P_str); /* Outputs up to the trailing whitespace, then outputs literals instead of the trailing whitespace */ dcl P_str char (*); dcl white_len fixed; if length (P_str) = 0 then return; white_len = verify (reverse (P_str), WHITE) - 1; if white_len = -1 then white_len = length (P_str); call output (substr (P_str, 1, length (P_str) - white_len)); call convert_white (substr (P_str, length (P_str) - white_len + 1)); end convert_trailing_white; %page; convert_white: proc (P_str); /* P_str is all whitespace; output as literals */ dcl P_str char (*); dcl LITERAL (4) char (2) int static options (constant) init ("SP", "HT", "VT", "FF"); dcl literal_string char (32) varying; dcl (count, i, type, type2) fixed; if length (P_str) = 0 then return; type = index (WHITE, substr (P_str, 1, 1)); count = 1; do i = 2 to length (P_str); type2 = index (WHITE, substr (P_str, i, 1)); if type2 = type then count = count + 1; else do; ADD_LITERAL: call ioa_$rsnnl ("&^a(^d)", literal_string, length (literal_string), LITERAL (type), count); call output ((literal_string)); type = type2; count = 1; if i >= length (P_str) then return; end; end; go to ADD_LITERAL; end convert_white; %page; clean_up: proc; if target_ptr ^= null & target_ptr ^= ptr1 then do; call delete_$ptr (target_ptr, "000100"b, ME, 0); target_ptr = null; end; if replacing_orig_sw then if safe_copy_ptr = null then call com_err_ (safe_copy_code, ME, "Unable to get temp seg; can't restore original."); else ptr1 -> seg1 = safe_copy_ptr -> seg1; call finish_up (); end clean_up; finish_up: proc; if ptr1 ^= null then call hcs_$terminate_noname (ptr1, 0); if ptr2 ^= null then call release_temp_segment_ (ME, ptr2, 0); if safe_copy_ptr ^= null then call release_temp_segment_ (ME, safe_copy_ptr, 0); if target_ptr ^= null then call hcs_$terminate_noname (target_ptr, 0); ptr1, ptr2, safe_copy_ptr, target_ptr = null; replacing_orig_sw = "0"b; end finish_up; output: proc (P_str); dcl P_str char (*); dcl i fixed; if check_sw then return; i = length (P_str); len2 = len2 + i; substr (seg2, len2 - i + 1) = P_str; end output; warn: proc (P_severity, P_str); dcl P_severity fixed; dcl P_str char (*); if P_severity >= 2 then errors_sw = "1"b; if P_severity < severity then return; call ioa_$ioa_switch (iox_$error_output, "(sv ^d) Line ^d: ^a", P_severity, line_number, P_str); end warn; end convert_one; %page; known: proc (P_keyword) returns (bit (1)); dcl P_keyword char (*) varying; dcl i fixed; i = index (KEYWORDS_STRING, P_keyword || " "); return (i > 0); end known; end convert_ec;  signal_io_error_.pl1 11/04/82 1933.2rew 11/04/82 1618.0 12807 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3,idind30,ll122,ifthenstmt */ signal_io_error_: procedure (message, switch, status); declare message char (*), switch ptr, status fixed bin (35); declare signal_ entry () options (variable); declare 1 io_error_info aligned, 2 length fixed bin, 2 version fixed bin initial (1), 2 action_flags, 3 cant_restart bit (1) unaligned initial ("0"b), 3 default_restart bit (1) unaligned initial ("0"b), 3 pad bit (34) unaligned initial (""b), 2 info_string char (256) varying initial (message), 2 status_code fixed bin (35) initial (status), 2 stream char (32) initial (switch -> iocb.name), 2 io_status bit (72) initial (""b); %include iocb; io_error_info.length = size (io_error_info); /* Compiler won't allow this as initial attribute */ call signal_ ("io_error", null (), addr (io_error_info)); return; end signal_io_error_;  value_.pl1 10/03/86 1244.3rew 10/02/86 1512.2 513315 /****^ *********************************************************** * * * 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-08-18,JSLove), approve(86-08-18,MCR7518), audit(86-08-18,Parisek), install(86-10-02,MR12.0-1175): Changed to call match_star_name_ instead of value_match_. Value_match_ was deleted when the new match_star_name_ was installed. END HISTORY COMMENTS */ value_: proc; /* Written 11/17/80 by Steve Herbst */ /* Fixed to catch deleted default value seg 08/81/81 Steve Herbst */ /* Fixed for $set to create default seg unless -pp specified 12/01/81 Steve Herbst */ /* Fixed to truncate value seg after compaction 02/01/82 Steve Herbst */ /* Fixed value_$list_data_names to return word lengths 03/20/82 Steve Herbst */ /* Modified: 29 March 1982 by G. Palter to garbage collect after adding/replacing values, to not release write lock in the middle of deleting a push-down list of nodes, and to free the temporary segment used for garbage collection if the user releases during GCing */ /* Fixed value_$list to free allocated things on cleanup 05/24/82 Steve Herbst */ /* Fixed value_$list to work on nonshareable value seg like exec_com uses 06/08/83 Steve Herbst */ /* Fixed $get_path to notice hcs_$fs_get_path_name error 02/07/84 Steve Herbst */ /* Fixed $list to return pushed values latest to earliest 07/26/84 Steve Herbst */ /* Optimize var-setting to reuse old node if same length and type 02/15/85 Steve Herbst */ /* The value database */ dcl 1 seg aligned based (seg_ptr), /* value segment (shareable) */ 2 header, 3 version fixed bin, 3 banner bit (36), /* identifying decoration (= BANNER) */ 3 ht_size fixed bin, /* for later modifications */ 3 region_size fixed bin, /* explicit size or rest of seg */ 3 remote_area_ptr ptr, /* null=>use seg.node_region, alloc by addrel, salvage */ 3 lock bit (36), /* standard interprocess lock */ 3 salvaging_sw bit (1), /* ON while locked for salvage */ 3 change_count fixed bin (35), /* incremented by writer when data is changed */ 3 next_free_offset bit (18), /* for next node allocation in seg.node_region */ 3 trash_count fixed bin, /* number of nodes freed before salvage */ 3 offset_ht (0:60) bit (18), /* hash table of offsets into region */ 2 node_region (seg_region_size refer (seg.region_size)) fixed bin; /* to contain nodes */ dcl 1 pp aligned based (pp_ptr), /* perprocess value database */ 2 version fixed bin, 2 banner bit (36), /* = PP_BANNER to distinguish from shareable seg */ 2 ht_size fixed bin, 2 remote_area_ptr ptr, /* non-null: points to an area for node allocation */ 2 pad (2) fixed bin, 2 ptr_ht (0:60) ptr unaligned; /* hash table of pointers */ dcl 1 node_header aligned based, /* to be used in node structure */ 2 version fixed bin, 2 banner bit (36), /* for recognizing a node when salvaging (=BANNER) */ 2 next_offset bit (18), /* forward offset, for seg (shared) */ 2 next_ptr ptr unaligned, /* forward ptr, for pp (perprocess) */ 2 switches, 3 pp_sw bit (1) unaligned, /* ON for perprocess values */ 3 data_sw bit (1) unaligned, /* ON only for values set by $set_data etc. */ 3 push_sw bit (1) unaligned, /* ON if $push'ed on top of another value */ 3 pad bit (33) unaligned, 2 name_len fixed bin (21), /* length of variable name */ 2 value_len fixed bin (21); /* length of value string */ dcl 1 node aligned based (node_ptr), /* a single name-value pair */ 2 header like node_header, 2 name char (node_name_len refer (node.name_len)) varying, 2 value char (node_value_len refer (node.value_len)) varying; dcl 1 old_node_format aligned based, /* vestige from before version number */ 2 banner bit (36), /* for recognizing a node when salvaging (=BANNER) */ 2 next_offset bit (18), /* forward offset, for seg (shared) */ 2 next_ptr ptr unaligned, /* forward ptr, for pp (perprocess) */ 2 name_len fixed bin (21), /* length of variable name */ 2 value_len fixed bin (21), /* length of value string */ 2 name char (node_name_len refer (old_node_format.name_len)), 2 value char (node_value_len refer (old_node_format.value_len)); /* Other structures */ %include value_structures; dcl 1 name_info aligned, /* pointer and length of variable name_info */ 2 ptr ptr, 2 len fixed bin (21); dcl 1 value_info aligned, /* pointer and length of value string */ 2 ptr ptr, 2 len fixed bin (21), 2 seg_ptr ptr, /* for unlocking */ 2 change_count fixed bin; /* for unlocking */ dcl 1 new_value_info aligned like value_info; /* value to be set */ dcl 1 old_value_info aligned like value_info; /* to test against existing value */ dcl 1 alloc_info aligned, /* for freeing char string copy of value arg */ 2 ptr ptr, 2 len fixed bin (21), 2 area_ptr ptr; dcl 1 node_ptrs aligned, 2 this ptr, /* pointer to current (found) node */ 2 last ptr, /* pointer to previous node */ 2 segp ptr, /* pointer to seg or pp header */ 2 hash fixed bin; /* hash table index */ dcl 1 sort_array aligned based (sort_array_ptr), /* for sorting var names for value_$list */ 2 count fixed bin, 2 name_ptr (sort_array.count) ptr unaligned; dcl 1 sort_entry aligned based (sort_entry_ptr), 2 node_ptr ptr, 2 sort_field, 3 length fixed bin, /* simulate a varying string */ 3 name char (node.name_len) unaligned, 3 sequence pic"999999" unaligned, 2 next_entry ptr; /* Constants */ dcl MAX_TRASH_COUNT fixed bin int static options (constant) init (512); dcl BANNER bit (36) int static options (constant) init ("707070707070"b3); dcl PP_BANNER bit (36) int static options (constant) init ("070707070707"b3); dcl HT_SIZE fixed int static options (constant) init (61); dcl value_version_1 fixed bin int static options (constant) init (1); dcl (PERMANENT init (0), PERPROCESS init (1)) fixed bin int static options (constant); dcl (PERMANENT_SW init ("01"b), PERPROCESS_SW init ("10"b)) bit (2) int static options (constant); dcl SUFFIX char (6) int static options (constant) init (".value"); dcl SUFFIX_LEN fixed bin int static options (constant) init (6); dcl BIT_TYPE fixed bin int static options (constant) init (19); dcl CHAR_TYPE fixed bin int static options (constant) init (21); dcl FIXED_BIN_TYPE fixed bin int static options (constant) init (1); dcl PTR_TYPE fixed bin int static options (constant) init (13); dcl VARYING_CHAR_TYPE fixed bin int static options (constant) init (22); dcl WHITE char (2) int static options (constant) init (" "); /* SP HT */ /* Static */ dcl perprocess_seg_ptr ptr int static init (null); /* pointer to pp seg in process_dir */ dcl default_seg_ptr ptr int static init (null); /* pointer to default value seg used by commands */ /* Arguments */ dcl (A_path, A_name) char (*); dcl A_switches bit (36) aligned; dcl A_create_sw bit (1); dcl (A_area_ptr, A_data_ptr, A_new_data_ptr, A_old_data_ptr, A_remote_area_ptr, A_seg_ptr, A_value_ptr) ptr; dcl (A_match_info_ptr, A_value_list_info_ptr) ptr; dcl A_seg_type fixed bin; dcl (A_data_size, A_new_data_size, A_old_data_size) fixed bin (18); dcl A_region_size fixed bin (19); dcl A_value_len fixed bin (21); dcl A_code fixed bin (35); /* Global arg info for options (variable) entries */ dcl options_var_sw bit (1) aligned; dcl arg_list_ptr ptr; dcl (code_arg_index, old_value_arg_index) fixed bin; /* Based */ dcl char8 char (8) based; dcl name_string char (name_info.len) based (name_info.ptr); dcl value_string char (value_info.len) based (value_info.ptr); dcl new_value_string char (new_value_info.len) based (new_value_info.ptr); dcl old_value_string char (old_value_info.len) based (old_value_info.ptr); dcl alloc_string char (alloc_info.len) based (alloc_info.ptr); dcl based_area area based; dcl bits bit (99 /* indefinite */) aligned based; /* for copying data */ dcl 1 seg_mode_bits unaligned based (addr (seg_mode)), 2 pad bit (32) unaligned, 2 (R_BIT, E_BIT, W_BIT, pad1) bit (1) unaligned; /* Automatic */ dcl (dn, path) char (168); dcl en char (32); dcl number_picture picture"999999"; dcl switches bit (36); dcl pp_sw_arg bit (1) defined (switches) position (1); dcl seg_sw_arg bit (1) defined (switches) position (2); dcl node_offset bit (18); dcl (alloc_entrypoint_sw, function_entrypoint_sw, pop_sw, push_sw, set_entrypoint_sw) bit (1) aligned init ("0"b); dcl (data_entrypoint_sw, found_one_sw, local_pp_sw, locked_sw, test_entrypoint_sw) bit (1) aligned; dcl (area_ptr, new_node_ptr, node_ptr, old_node_ptr, pp_ptr, seg_ptr) ptr; dcl (sort_array_ptr, sort_entries_ptr, sort_entry_ptr, where_ptr) ptr; dcl seg_mode fixed bin (5); dcl (begin_change_count, i, saved_sort_count, sequential_number, sort_field_offset) fixed bin; dcl (chars_index, node_name_len, node_value_len, saved_chars_len) fixed bin (21); dcl (code, seg_code) fixed bin (35); dcl error_table_$action_not_performed fixed bin (35) ext; dcl error_table_$bad_conversion fixed bin (35) ext; dcl error_table_$badcall fixed bin (35) ext; dcl error_table_$boundviol fixed bin (35) ext; dcl error_table_$invalid_lock_reset fixed bin (35) ext; dcl error_table_$locked_by_this_process fixed bin (35) ext; dcl error_table_$lower_ring fixed bin (35) ext; dcl error_table_$noalloc fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl error_table_$oldnamerr fixed bin (35) ext; dcl error_table_$no_r_permission fixed bin (35) ext; dcl error_table_$no_w_permission fixed bin (35) ext; dcl error_table_$not_seg_type fixed bin (35) ext; dcl error_table_$out_of_sequence fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (24) ext; dcl assign_ entry (ptr, fixed bin, fixed bin (21), ptr, fixed bin, fixed bin (21)); dcl cu_$arg_list_ptr entry returns (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed (35)); dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl release_temp_segment_ entry (char (*), ptr, fixed (35)); dcl search_file_ entry (ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (35)); dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl sort_items_$varying_char entry (ptr); dcl user_info_ entry options (variable); dcl user_info_$homedir entry (char (*)); dcl (addr, addrel, baseno, bit, currentsize, divide, fixed) builtin; dcl (length, mod, null, pointer, rel, rtrim, substr, unspec, wordno) builtin; dcl (any_other, area, cleanup, conversion, no_write_permission, not_in_write_bracket, sub_error) condition; %page; defined: entry (A_seg_ptr, A_switches, A_name, A_code) returns (bit (1) aligned); data_entrypoint_sw, options_var_sw = "0"b; function_entrypoint_sw = "1"b; call copy_args; A_code = 0; call get_ptrs (seg_ptr, pp_ptr); if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then return ("1"b); else return ("0"b); %page; delete: entry (A_seg_ptr, A_switches, A_name, A_code); data_entrypoint_sw, options_var_sw = "0"b; A_code = 0; call copy_args; call get_ptrs (seg_ptr, pp_ptr); call lock_for_write (seg_ptr); on cleanup call unlock_for_write (seg_ptr); found_one_sw = "0"b; DELETE: if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then do; found_one_sw = "1"b; push_sw = node_ptrs.this -> node.push_sw; call delete_node (node_ptrs); if push_sw then go to DELETE; /* delete all pushed values and the original */ end; else if ^found_one_sw then A_code = error_table_$oldnamerr; call unlock_for_write (seg_ptr); return; %page; delete_data: entry (A_seg_ptr, A_switches, A_name, A_code); options_var_sw = "0"b; data_entrypoint_sw = "1"b; A_code = 0; call copy_args; call get_ptrs (seg_ptr, pp_ptr); call lock_for_write (seg_ptr); on cleanup call unlock_for_write (seg_ptr); found_one_sw = "0"b; go to DELETE; %page; get: entry options (variable); /* call value_$get (seg_ptr, switches, name, value_arg, code); */ options_var_sw = "1"b; code_arg_index = 5; /* global; used by return_code */ arg_list_ptr = cu_$arg_list_ptr (); call get_options_var_args (arg_list_ptr); data_entrypoint_sw = "0"b; GET: call get_ptrs (seg_ptr, pp_ptr); if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then do; FOUND1: call set_value_arg (arg_list_ptr, 4, value_info); /* return the value */ if value_info.seg_ptr ^= null then /* unlock for read */ if value_info.seg_ptr -> seg.change_count ^= value_info.change_count then do; if find_in (value_info.seg_ptr, name_info, value_info, node_ptrs) then go to FOUND1; /* retry */ else go to NOT_FOUND1; end; call return_code (0); /* zero status code */ end; else NOT_FOUND1: call return_code (error_table_$oldnamerr); RETURN: if function_entrypoint_sw then return ("0"b); /* value_$defined */ else return; %page; get_alloc: entry (A_seg_ptr, A_switches, A_name, A_area_ptr, A_value_ptr, A_value_len, A_code); alloc_entrypoint_sw = "1"b; data_entrypoint_sw = "0"b; go to GET_DATA; %page; get_data: entry (A_seg_ptr, A_switches, A_name, A_area_ptr, A_data_ptr, A_data_size, A_code); data_entrypoint_sw = "1"b; GET_DATA: options_var_sw = "0"b; if A_area_ptr = null then call return_code (error_table_$noalloc); call copy_args; go to GET; %page; get_path: entry (A_path, A_code); A_code = 0; options_var_sw = "0"b; if default_seg_ptr ^= null then call hcs_$fs_get_path_name (default_seg_ptr, dn, 0, en, A_code); else call get_default_path (dn, en); if A_code = 0 then A_path = pathname_ (dn, en); call return_code (A_code); %page; init_seg: entry (A_seg_ptr, A_seg_type, A_remote_area_ptr, A_region_size, A_code); /* See if already initiated */ options_var_sw = "0"b; if A_seg_ptr -> seg.banner = BANNER then if A_seg_type ^= PERMANENT then call return_code (error_table_$not_seg_type); else if A_remote_area_ptr ^= null then call return_code (error_table_$out_of_sequence); else call return_code (0); else if A_seg_ptr -> pp.banner = PP_BANNER then if A_seg_type ^= PERPROCESS then call return_code (error_table_$not_seg_type); else if A_remote_area_ptr ^= null then call return_code (error_table_$out_of_sequence); else call return_code (0); call init_seg (A_seg_ptr); if A_seg_type = PERPROCESS then do; A_seg_ptr -> pp.banner = PP_BANNER; do i = 0 to A_seg_ptr -> pp.ht_size - 1; /* fill hash table with null ptrs */ A_seg_ptr -> pp.ptr_ht (i) = null; end; if A_remote_area_ptr ^= null then A_seg_ptr -> pp.remote_area_ptr = A_remote_area_ptr; else A_seg_ptr -> pp.remote_area_ptr = get_system_free_area_ (); end; else do; A_seg_ptr -> seg.banner = BANNER; /* shareable seg */ unspec (A_seg_ptr -> seg.offset_ht) = "0"b; if A_region_size > 0 then A_seg_ptr -> seg.region_size = A_region_size; end; call return_code (0); %page; list: entry (A_seg_ptr, A_switches, A_match_info_ptr, A_area_ptr, A_value_list_info_ptr, A_code); /* Using A_match_info_ptr->match_info to select, returns names/values for matching variables */ data_entrypoint_sw = "0"b; LIST: options_var_sw = "0"b; A_code = 0; seg_ptr = A_seg_ptr; switches = A_switches; match_info_ptr = A_match_info_ptr; area_ptr = A_area_ptr; if area_ptr = null then area_ptr = get_system_free_area_ (); call get_ptrs (seg_ptr, pp_ptr); sort_entries_ptr, sort_array_ptr, value_list_info_ptr = null; on cleanup call list_cleanup; call get_temp_segment_ ("value_$list", sort_array_ptr, code); call get_temp_segment_ ("value_$list", sort_entries_ptr, code); sort_entry_ptr = sort_entries_ptr; sort_field_offset = wordno (addr (sort_entry)) - wordno (addr (sort_entry.sort_field)); sort_array.count, alloc_chars_len, sequential_number = 0; if pp_ptr ^= null then do; /* search perprocess values */ call list_pp (pp_ptr); end; if seg_ptr ^= null then if seg_ptr -> seg.banner = PP_BANNER then call list_pp (seg_ptr); /* a private nonshareable value seg, as for exec_com */ else do; /* a real value seg */ saved_chars_len = alloc_chars_len; /* in case we have to retry */ saved_sort_count = sort_array.count; SEARCH_SEG: call lock_for_read (seg_ptr, begin_change_count); do node_ptrs.hash = 0 to seg.ht_size - 1; if seg.offset_ht (node_ptrs.hash) ^= "0"b then do; node_ptrs.this = pointer (seg_ptr, seg.offset_ht (node_ptrs.hash)); node_ptrs.last = null; do while (node_ptrs.this ^= null); if node_ptrs.this -> old_node_format.banner = BANNER then do; /* COMPATIBILITY */ old_node_ptr = node_ptrs.this; node_ptrs.this = add_node (seg_ptr, node_ptrs.this -> old_node_format.name_len, node_ptrs.this -> old_node_format.value_len, node_ptrs); call copy_old_format_node (old_node_ptr, node_ptrs.this); end; if node_ptrs.this -> node.data_sw = data_entrypoint_sw then call match_one (node_ptrs.this); node_ptrs.last = node_ptrs.this; node_offset = node_ptrs.this -> node.next_offset; if node_offset = "0"b then node_ptrs.this = null; else node_ptrs.this = pointer (seg_ptr, node_offset); end; end; end; if seg.change_count ^= begin_change_count then do; /* changed while listing */ alloc_chars_len = saved_chars_len; sort_array.count = saved_sort_count; go to SEARCH_SEG; /* retry the seg */ end; end; if sort_array.count = 0 then do; A_code = error_table_$nomatch; go to LIST_RETURN; end; /* Sort the found var names alphabetically */ call sort_items_$varying_char (sort_array_ptr); alloc_pair_count = sort_array.count; allocate value_list_info in (area_ptr -> based_area) set (value_list_info_ptr); value_list_info.version = value_list_info_version_1; chars_index = 1; do i = 1 to value_list_info.pair_count; sort_entry_ptr = addrel (sort_array.name_ptr (i), sort_field_offset); /* sort_array.name(i) is addr of sort_entry.sort_field */ node_ptr = sort_entry.node_ptr; if node_ptr -> node.pp_sw then value_list_info.type_switches (i) = PERPROCESS_SW; else value_list_info.type_switches (i) = PERMANENT_SW; value_list_info.name_index (i) = chars_index; value_list_info.name_len (i) = node_ptr -> node.name_len; substr (value_list_info.chars, chars_index, value_list_info.name_len (i)) = node_ptr -> node.name; chars_index = chars_index + value_list_info.name_len (i); if data_entrypoint_sw then do; /* return word length only for data entry */ value_list_info.value_index (i) = 0; value_list_info.value_len (i) = divide (node_ptr -> node.value_len + 3, 4, 21, 0); end; else do; /* return char value otherwise */ value_list_info.value_index (i) = chars_index; value_list_info.value_len (i) = node_ptr -> node.value_len; substr (value_list_info.chars, chars_index, value_list_info.value_len (i)) = node_ptr -> node.value; chars_index = chars_index + value_list_info.value_len (i); end; end; value_list_info.chars_len = chars_index - 1; A_value_list_info_ptr = value_list_info_ptr; A_code = 0; LIST_RETURN: call release_temp_segment_ ("value_$list", sort_array_ptr, code); call release_temp_segment_ ("value_$list", sort_entries_ptr, code); return; list_cleanup: proc; if sort_array_ptr ^= null then call release_temp_segment_ ("value_$list", sort_array_ptr, code); if sort_entries_ptr ^= null then call release_temp_segment_ ("value_$list", sort_entries_ptr, code); if value_list_info_ptr ^= null then free value_list_info in (area_ptr -> based_area); end list_cleanup; %page; list_data_names: entry (A_seg_ptr, A_switches, A_match_info_ptr, A_area_ptr, A_value_list_info_ptr, A_code); /* Same as value_$list, but works on data values (value_$set_data) and returns only names */ data_entrypoint_sw = "1"b; go to LIST; %page; pop: entry options (variable); /* call value_$pop (seg_ptr, switches, name, old_value, code); */ pop_sw = "1"b; old_value_arg_index = 4; code_arg_index = 5; go to VALUE_SET; %page; push: entry options (variable); /* call value_$push (seg_ptr, switches, name, new_value, old_value, code); */ push_sw = "1"b; old_value_arg_index = 5; code_arg_index = 6; go to VALUE_SET; %page; set: entry options (variable); /* call value_$set (seg_ptr, switches, name, new_value, old_value, code); */ seg_code = 0; old_value_arg_index = 5; code_arg_index = 6; VALUE_SET: options_var_sw = "1"b; arg_list_ptr = cu_$arg_list_ptr (); call get_options_var_args (arg_list_ptr); data_entrypoint_sw, test_entrypoint_sw = "0"b; SET: set_entrypoint_sw = "1"b; call get_ptrs (seg_ptr, pp_ptr); /* Pick up value to be set, convert to allocated char string */ alloc_info.ptr = null; alloc_info.area_ptr = get_system_free_area_ (); locked_sw = "0"b; on cleanup begin; if alloc_info.ptr ^= null then free alloc_info.ptr -> alloc_string in (alloc_info.area_ptr -> based_area); if locked_sw then call unlock_for_write (seg_ptr); end; if data_entrypoint_sw then do; /* value_$set_data */ if A_new_data_ptr = null then do; /* delete existing value */ call lock_for_write (seg_ptr); locked_sw = "1"b; if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then call delete_node (node_ptrs); call unlock_for_write (seg_ptr); call return_code (0); end; new_value_info.ptr = A_new_data_ptr; new_value_info.len = A_new_data_size * 4; end; else if ^pop_sw then call get_value_arg (arg_list_ptr, 4, new_value_info, alloc_info); /* convert from caller's type */ call lock_for_write (seg_ptr); locked_sw = "1"b; if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then do; if test_entrypoint_sw then do; /* compare old value to argument */ if value_info.len < old_value_info.len then TEST_FAIL: call return_code (error_table_$action_not_performed); if old_value_info.len ^= 0 then if substr (value_string, 1, old_value_info.len) ^= substr (old_value_string, 1, old_value_info.len) then go to TEST_FAIL; end; else call set_value_arg (arg_list_ptr, old_value_arg_index, value_info); /* return old value */ if pop_sw then do; /* delete current node only */ call delete_node (node_ptrs); go to SET_RETURN; end; where_ptr = node_ptrs.segp; if push_sw then go to ADD_NODE; /* add before current node */ if where_ptr ^= null then do; /* optimization: reuse old node if possible */ local_pp_sw = (where_ptr -> seg.banner = PP_BANNER); if node_ptrs.this -> node.value_len = new_value_info.len & /* reuse old node if same length and */ node_ptrs.this -> node.pp_sw = local_pp_sw & /* same class (perprocess vs value seg) and */ node_ptrs.this -> node.data_sw = data_entrypoint_sw then do; /* same type (data vs char) */ node_ptrs.this -> node.value = new_value_string; go to SET_RETURN; end; end; end; else do; /* no old value */ if pop_sw then call return_code (error_table_$oldnamerr); /* no previous value */ if test_entrypoint_sw then go to TEST_FAIL; /* test fails if no old value */ /* No old value: first choice is to set in value segment */ if seg_ptr ^= null then where_ptr = seg_ptr; else if seg_sw_arg then call return_code (seg_code); /* return code from get_ptrs */ else where_ptr = pp_ptr; node_ptrs.this = null; /* to be sure no old node for add_node */ value_info.ptr = where_ptr; value_info.len = 0; call set_value_arg (arg_list_ptr, old_value_arg_index, value_info); /* return zero-length string */ end; ADD_NODE: new_node_ptr = add_node (where_ptr, name_info.len, new_value_info.len, node_ptrs); new_node_ptr -> node.name = name_string; new_node_ptr -> node.value = new_value_string; SET_RETURN: if alloc_info.ptr ^= null then free alloc_info.ptr -> alloc_string in (alloc_info.area_ptr -> based_area); if seg_ptr ^= null () then /* check if we should GC a permanent value segment */ if (4 * seg.trash_count > fixed (seg.next_free_offset, 18, 0)) | (seg.trash_count > MAX_TRASH_COUNT) then call compact_trash (seg_ptr); call unlock_for_write (seg_ptr); /* IMPROVE LOCKING STRATEGY (pp?) */ call return_code (0); %page; set_data: entry (A_seg_ptr, A_switches, A_name, A_new_data_ptr, A_new_data_size, A_area_ptr, A_data_ptr, A_data_size, A_code); options_var_sw = "0"b; call copy_args; alloc_info.ptr = null; data_entrypoint_sw = "1"b; test_entrypoint_sw = "0"b; go to SET; %page; set_path: entry (A_path, A_create_sw, A_code); options_var_sw = "0"b; if A_path = "" then do; call get_default_path (dn, en); if dn = ">" then path = ">" || en; else path = rtrim (dn) || ">" || en; end; else path = A_path; call hcs_$initiate (add_suffix (path), "", "", 0, 0, seg_ptr, code); if code = error_table_$noentry & A_create_sw then do; call expand_pathname_ (add_suffix (path), dn, en, code); if code ^= 0 then call return_code (code); call hcs_$make_seg (dn, en, "", 01010b /* rw */, seg_ptr, code); if seg_ptr = null then call return_code (code); call init_seg (seg_ptr); seg_ptr -> seg.banner = BANNER; unspec (seg_ptr -> seg.offset_ht) = "0"b; end; if seg_ptr = null then call return_code (code); on cleanup call hcs_$terminate_noname (seg_ptr, code); call hcs_$fs_get_mode (seg_ptr, seg_mode, code); if code ^= 0 then call return_code (code); /* no r: don't set */ if ^addr (seg_mode) -> R_BIT then call return_code (error_table_$no_r_permission); if ^addr (seg_mode) -> W_BIT then code = error_table_$no_w_permission; /* no w: set anyway but return code */ call set_seg (seg_ptr); call return_code (code); %page; test_and_set: entry options (variable); /* call value_$test_and_set (seg_ptr, switches, name, new_value, old_value, code); */ options_var_sw = "1"b; code_arg_index = 6; arg_list_ptr = cu_$arg_list_ptr (); call get_options_var_args (arg_list_ptr); alloc_info.ptr = null; alloc_info.area_ptr = get_system_free_area_ (); call get_value_arg (arg_list_ptr, 5, old_value_info, alloc_info); test_entrypoint_sw = "1"b; data_entrypoint_sw = "0"b; go to SET; %page; test_and_set_data: entry (A_seg_ptr, A_switches, A_name, A_new_data_ptr, A_new_data_size, A_old_data_ptr, A_old_data_size, A_code); options_var_sw = "0"b; call copy_args; old_value_info.ptr = A_old_data_ptr; old_value_info.len = A_old_data_size * 4; alloc_info.ptr = null; data_entrypoint_sw, test_entrypoint_sw = "1"b; go to SET; %page; add_node: proc (P_ptr, P_name_len, P_value_len, P_node_ptrs) returns (ptr); /* Adds a new node in place of P_node_ptrs.this -> node if any, returns ptr to new node */ dcl P_ptr ptr; /* INPUT: ptr to segment (seg or pp) */ dcl (P_name_len, P_value_len) fixed bin (21); /* INPUT: lengths for allocation */ dcl 1 P_node_ptrs aligned like node_ptrs; /* INPUT: old and previous old nodes for threading */ dcl (area_ptr, new_node_ptr) ptr; dcl new_node_offset bit (18); dcl next_free_word fixed bin (18); if P_ptr -> seg.banner = PP_BANNER then do; /* perprocess-type header */ area_ptr = P_ptr -> pp.remote_area_ptr; node_name_len = P_name_len; node_value_len = P_value_len; on area call return_code (error_table_$noalloc); allocate node in (area_ptr -> based_area) set (new_node_ptr); new_node_ptr -> node.version = value_version_1; new_node_ptr -> node.banner = BANNER; /* for the hell of it, like in seg */ unspec (new_node_ptr -> node.switches) = "0"b; new_node_ptr -> node.pp_sw = "1"b; if data_entrypoint_sw then new_node_ptr -> node.data_sw = "1"b; if P_ptr -> pp.ptr_ht (P_node_ptrs.hash) = P_node_ptrs.this then P_ptr -> pp.ptr_ht (P_node_ptrs.hash) = null; if P_node_ptrs.this ^= null then /* old node exists */ if push_sw then do; /* inserting a new node before current one */ new_node_ptr -> node.push_sw = "1"b; new_node_ptr -> node.next_ptr = P_node_ptrs.this; end; else new_node_ptr -> node.next_ptr = P_node_ptrs.this -> node.next_ptr; /* else use its fwd thread */ else new_node_ptr -> node.next_ptr = null; /* else end of chain */ if P_node_ptrs.last ^= null then /* previous node in chain exists */ P_node_ptrs.last -> node.next_ptr = new_node_ptr; else P_ptr -> pp.ptr_ht (P_node_ptrs.hash) = new_node_ptr; /* else thread off hash table */ if P_node_ptrs.this ^= null then if push_sw then do; new_node_ptr -> node.push_sw = "1"b; new_node_ptr -> node.next_ptr = P_node_ptrs.this; end; else free P_node_ptrs.this -> node in (area_ptr -> based_area); /* else free old node */ end; else do; /* shareable seg */ new_node_offset = P_ptr -> seg.next_free_offset; /* use next block of node_region */ new_node_ptr = pointer (P_ptr, new_node_offset); new_node_ptr -> node.version = value_version_1; new_node_ptr -> node.banner = BANNER; /* so it's findable by salvage */ unspec (new_node_ptr -> node.switches) = "0"b; if data_entrypoint_sw then new_node_ptr -> node.data_sw = "1"b; new_node_ptr -> node.name_len = P_name_len; new_node_ptr -> node.value_len = P_value_len; next_free_word = fixed (new_node_offset) + currentsize (new_node_ptr -> node); if next_free_word >= sys_info$max_seg_size then /* past end of segment */ call return_code (error_table_$boundviol); P_ptr -> seg.next_free_offset = bit (next_free_word, 18); /* skip enough room for node */ if P_node_ptrs.this ^= null then /* old node exists */ if push_sw then do; /* inserting a node before current node */ new_node_ptr -> node.push_sw = "1"b; new_node_ptr -> node.next_offset = rel (P_node_ptrs.this); end; else do; /* replacing current node */ if P_node_ptrs.this -> old_node_format.banner = BANNER then do; new_node_ptr -> node.next_offset = P_node_ptrs.this -> old_node_format.next_offset; P_ptr -> seg.trash_count = P_ptr -> seg.trash_count + currentsize (P_node_ptrs.this -> old_node_format); end; else do; new_node_ptr -> node.next_offset = P_node_ptrs.this -> node.next_offset; /* use its fwd thread */ P_ptr -> seg.trash_count = P_ptr -> seg.trash_count + /* increment # of freed words */ currentsize (P_node_ptrs.this -> node); /* for later compacting of segment */ end; end; else new_node_ptr -> node.next_offset = "0"b; /* else end of chain */ if P_node_ptrs.last ^= null then /* previous node in chain exists */ P_node_ptrs.last -> node.next_offset = new_node_offset; else P_ptr -> seg.offset_ht (P_node_ptrs.hash) = new_node_offset; /* else thread off hash table */ end; return (new_node_ptr); end add_node; %page; add_suffix: proc (P_en) returns (char (*)); /* Appends .value suffix to an entryname if not already there */ dcl P_en char (*); /* INPUT: entryname */ dcl entry_len fixed bin; entry_len = length (rtrim (P_en)); if entry_len < SUFFIX_LEN + 1 then return (rtrim (P_en) || SUFFIX); else if substr (P_en, entry_len - SUFFIX_LEN + 1, SUFFIX_LEN) ^= SUFFIX then return (rtrim (P_en) || SUFFIX); else return (P_en); end add_suffix; %page; compact_trash: proc (P_ptr); dcl P_ptr ptr; dcl (last_node_ptr, old_node_ptr, temp_node_ptr, temp_ptr) ptr; dcl (next_node_offset, next_word_offset) bit (18); dcl next_free_word fixed (18) unaligned unsigned; dcl (i, saved_region_size) fixed; if P_ptr -> seg.banner ^= BANNER then return; /* not shareable value seg */ call get_temp_segment_ ("value_", temp_ptr, code); if code ^= 0 then return; call hcs_$truncate_seg (temp_ptr, 0, code); if code ^= 0 then return; on cleanup call release_temp_segment_ ("value_", temp_ptr, (0)); P_ptr -> seg.salvaging_sw = "1"b; temp_ptr -> seg.header = P_ptr -> seg.header; temp_ptr -> seg.trash_count = 0; temp_ptr -> seg.next_free_offset = rel (addr (P_ptr -> seg.node_region)); next_word_offset = temp_ptr -> seg.next_free_offset; do i = 0 to temp_ptr -> seg.ht_size - 1; /* for each hash table bucket */ if temp_ptr -> seg.offset_ht (i) ^= "0"b then do; /* some nodes for this bucket */ temp_ptr -> seg.offset_ht (i) = next_word_offset; temp_node_ptr = pointer (temp_ptr, next_word_offset); last_node_ptr = null; next_node_offset = "1"b; /* dummy ^= 0 for first time through loop */ do old_node_ptr = pointer (P_ptr, P_ptr -> seg.offset_ht (i)) repeat (pointer (P_ptr, next_node_offset)) while (next_node_offset ^= "0"b); if old_node_ptr -> old_node_format.banner = BANNER then call copy_old_format_node (old_node_ptr, temp_node_ptr); else do; temp_node_ptr -> node.name_len = old_node_ptr -> node.name_len; temp_node_ptr -> node.value_len = old_node_ptr -> node.value_len; temp_node_ptr -> node = old_node_ptr -> node; end; if last_node_ptr ^= null then last_node_ptr -> node.next_offset = next_word_offset; next_free_word = fixed (next_word_offset) + currentsize (temp_node_ptr -> node); next_word_offset = bit (next_free_word, 18); last_node_ptr = temp_node_ptr; temp_node_ptr = pointer (temp_ptr, next_word_offset); next_node_offset = old_node_ptr -> node.next_offset; end; last_node_ptr -> node.next_offset = "0"b; /* last node in chain */ end; end; temp_ptr -> seg.next_free_offset = next_word_offset; /* Copy back to the original */ saved_region_size = temp_ptr -> seg.region_size; temp_ptr -> seg.region_size, P_ptr -> seg.region_size = fixed (next_word_offset); P_ptr -> seg = temp_ptr -> seg; P_ptr -> seg.region_size = saved_region_size; P_ptr -> seg.salvaging_sw = "0"b; call hcs_$truncate_seg (P_ptr, fixed (next_word_offset, 19), 0); call release_temp_segment_ ("value_", temp_ptr, (0)); end compact_trash; %page; copy_args: proc; /* Copies input args for non - options(var) entrypoints */ A_code = 0; seg_ptr = A_seg_ptr; switches = A_switches; name_info.ptr = addr (A_name); name_info.len = length (rtrim (A_name)); if name_info.len = 0 then call signal_error; end copy_args; %page; copy_old_format_node: proc (P_old_ptr, P_new_ptr); /* Converts an old pre-version node to the current version */ dcl (P_old_ptr, P_new_ptr) ptr; P_new_ptr -> node.version = value_version_1; P_new_ptr -> node.banner = P_old_ptr -> old_node_format.banner; P_new_ptr -> node.next_offset = P_old_ptr -> old_node_format.next_offset; P_new_ptr -> node.next_ptr = P_old_ptr -> old_node_format.next_ptr; unspec (P_new_ptr -> node.switches) = "0"b; P_new_ptr -> node.name_len = P_old_ptr -> old_node_format.name_len; P_new_ptr -> node.value_len = P_old_ptr -> old_node_format.value_len; P_new_ptr -> node.name = P_old_ptr -> old_node_format.name; P_new_ptr -> node.value = P_old_ptr -> old_node_format.value; end copy_old_format_node; %page; delete_node: proc (P_node_ptrs); /* Deletes (unthreads and frees/marks free) the node pointed to by P_node_ptrs.this */ dcl 1 P_node_ptrs aligned like node_ptrs; dcl pp_sw bit (1); dcl area_ptr ptr; pp_sw = (P_node_ptrs.segp -> seg.banner = PP_BANNER); if pp_sw then do; /* perprocess: ptrs */ if P_node_ptrs.last ^= null then /* previous node in chain exists */ P_node_ptrs.last -> node.next_ptr = P_node_ptrs.this -> node.next_ptr; else P_node_ptrs.segp -> pp.ptr_ht (P_node_ptrs.hash) = P_node_ptrs.this -> node.next_ptr; area_ptr = P_node_ptrs.segp -> pp.remote_area_ptr; free P_node_ptrs.this -> node in (area_ptr -> based_area); end; else do; /* permanent: offsets */ if P_node_ptrs.last ^= null then /* previous node in chain exists */ P_node_ptrs.last -> node.next_offset = P_node_ptrs.this -> node.next_offset; else P_node_ptrs.segp -> seg.offset_ht (P_node_ptrs.hash) = P_node_ptrs.this -> node.next_offset; P_node_ptrs.segp -> seg.trash_count = P_node_ptrs.segp -> seg.trash_count + currentsize (P_node_ptrs.this -> node); /* for later compaction of seg */ if (4 * P_node_ptrs.segp -> seg.trash_count > fixed (P_node_ptrs.segp -> seg.next_free_offset, 18, 0)) | (P_node_ptrs.segp -> seg.trash_count > MAX_TRASH_COUNT) then call compact_trash (P_node_ptrs.segp); end; end delete_node; %page; find: proc (P_pp_ptr, P_seg_ptr, P_name_info, P_value_info, P_node_ptrs) returns (bit (1)); /* Looks first in perprocess if appropriate, then in value segment. Returns "1"b if found */ dcl (P_pp_ptr, P_seg_ptr) ptr; /* INPUT: header pointers */ dcl 1 P_name_info aligned like name_info; /* INPUT: variable name */ dcl 1 P_value_info aligned like value_info; /* OUTPUT: value string */ dcl 1 P_node_ptrs aligned like node_ptrs; /* OUTPUT: ptrs to current (found) and previous nodes */ if P_pp_ptr ^= null then do; /* looking in perprocess */ if find_in (P_pp_ptr, P_name_info, P_value_info, P_node_ptrs) then return ("1"b); end; if P_seg_ptr ^= null then do; if find_in (P_seg_ptr, P_name_info, P_value_info, P_node_ptrs) then return ("1"b); end; return ("0"b); end find; %page; find_in: proc (P_ptr, P_name_info, P_value_info, P_node_ptrs) returns (bit (1)); /* Looks for the name in a specified segment; returns true if FOUND */ dcl P_ptr ptr; /* INPUT: segment to look in */ dcl 1 P_name_info aligned like name_info; /* INPUT: variable name */ dcl 1 P_value_info aligned like value_info; /* OUTPUT: value string */ dcl 1 P_node_ptrs aligned like node_ptrs; /* OUTPUT: ptrs to current (found) and previous nodes */ dcl name_str char (P_name_info.len) based (P_name_info.ptr); dcl hash_str char (8); dcl next_node_offset bit (18); dcl pp_sw bit (1); dcl (begin_change_count, hash_index, i) fixed bin; dcl (first_node_ptr, old_node_ptr) ptr; pp_sw = (P_ptr -> seg.banner = PP_BANNER); FIND: if ^pp_sw then call lock_for_read (P_ptr, begin_change_count); i = length (rtrim (name_str, WHITE)); if i > 8 then hash_str = substr (name_str, i - 7, 8); else hash_str = name_str; hash_index = mod (fixed (unspec (rtrim (hash_str, WHITE))), P_ptr -> seg.ht_size); P_node_ptrs.this, P_node_ptrs.last = null; /* initialize to not found */ P_node_ptrs.segp = P_ptr; P_node_ptrs.hash = hash_index; if pp_sw then do; first_node_ptr = P_ptr -> pp.ptr_ht (hash_index); if baseno (first_node_ptr) = "0"b | first_node_ptr = null then return ("0"b); end; else if P_ptr -> seg.offset_ht (hash_index) = "0"b then return ("0"b); if pp_sw then P_node_ptrs.this = P_ptr -> pp.ptr_ht (hash_index); else P_node_ptrs.this = pointer (P_ptr, P_ptr -> seg.offset_ht (hash_index)); do while (P_node_ptrs.this ^= null); /* search the list */ if P_node_ptrs.this -> old_node_format.banner = BANNER then do; /* COMPATIBILITY */ old_node_ptr = P_node_ptrs.this; P_node_ptrs.this = add_node (P_ptr, P_node_ptrs.this -> old_node_format.name_len, P_node_ptrs.this -> old_node_format.value_len, P_node_ptrs); call copy_old_format_node (old_node_ptr, P_node_ptrs.this); end; if P_node_ptrs.this -> node.name = name_str & P_node_ptrs.this -> node.data_sw = data_entrypoint_sw then do; /* FOUND */ P_value_info.ptr = addrel (addr (P_node_ptrs.this -> node.value), 1); /* var string's text */ P_value_info.len = P_node_ptrs.this -> node.value_len; if ^pp_sw then do; /* if a shared segment */ /* make sure another process has not changed seg meanwhile */ if P_ptr -> seg.change_count ^= begin_change_count then go to FIND; /* retry */ P_value_info.change_count = begin_change_count; /* for later unlocking */ P_value_info.seg_ptr = P_ptr; end; else P_value_info.seg_ptr = null; return ("1"b); end; P_node_ptrs.last = P_node_ptrs.this; if pp_sw then P_node_ptrs.this = P_node_ptrs.this -> node.next_ptr; else do; next_node_offset = P_node_ptrs.this -> node.next_offset; if next_node_offset = "0"b then P_node_ptrs.this = null; else P_node_ptrs.this = pointer (P_ptr, next_node_offset); end; end; return ("0"b); end find_in; %page; get_default_path: proc (A_dn, A_en); dcl (A_dn, A_en) char (*); dcl person_id char (22); call user_info_$homedir (A_dn); call user_info_ (person_id); A_en = rtrim (person_id) || ".value"; end get_default_path; %page; get_default_ptr: proc () returns (ptr); /* Returns a pointer to the current default value seg */ dcl dn char (168); dcl en char (32); if default_seg_ptr = null then do; INITIATE: call get_default_path (dn, en); call hcs_$initiate (dn, en, "", 0, 0, default_seg_ptr, code); end; else do; on any_other go to INITIATE; if default_seg_ptr -> seg.banner ^= BANNER & default_seg_ptr -> seg.banner ^= PP_BANNER then go to INITIATE; revert any_other; end; return (default_seg_ptr); end get_default_ptr; %page; get_options_var_args: proc (P_arg_list_ptr); /* Reads the argument list and returns the values of selected arguments */ dcl P_arg_list_ptr ptr; /* INPUT: ptr to argument list */ dcl arg char (arg_len) based (arg_ptr); dcl based_bit36 bit (36) based; dcl based_packed_ptr ptr unaligned based; dcl based_ptr ptr aligned based; dcl based_varying_string char (261120 /* max chars in a segment */) varying based; dcl (packed_sw, varying_sw) bit (1) aligned; dcl arg_ptr ptr; dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin; /* Argument 1 */ call decode_descriptor_ (P_arg_list_ptr, 1, arg_type, packed_sw, ndims, arg_size, arg_scale); if arg_type ^= PTR_TYPE | ndims > 1 then call signal_error; call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, P_arg_list_ptr); if packed_sw then seg_ptr = arg_ptr -> based_packed_ptr; else seg_ptr = arg_ptr -> based_ptr; /* Argument 2 */ call decode_descriptor_ (P_arg_list_ptr, 2, arg_type, packed_sw, ndims, arg_size, arg_scale); if arg_type ^= BIT_TYPE | ndims > 1 then call signal_error; call cu_$arg_ptr_rel (2, arg_ptr, arg_len, code, P_arg_list_ptr); unspec (switches) = "0"b; substr (switches, 1, arg_size) = substr (arg_ptr -> based_bit36, 1, arg_size); /* Argument 3 */ call decode_descriptor_ (P_arg_list_ptr, 3, arg_type, packed_sw, ndims, arg_size, arg_scale); if ndims > 1 then call signal_error; else if arg_type = VARYING_CHAR_TYPE then varying_sw = "1"b; else do; if arg_type ^= CHAR_TYPE then call signal_error; varying_sw = "0"b; end; call cu_$arg_ptr_rel (3, arg_ptr, arg_len, code, P_arg_list_ptr); if varying_sw then do; name_info.ptr = arg_ptr; name_info.len = length (addrel (arg_ptr, -1) -> based_varying_string); end; else do; name_info.ptr = arg_ptr; name_info.len = length (rtrim (arg)); end; end get_options_var_args; %page; get_ptrs: proc (P_seg_ptr, P_pp_ptr); /* Depending on the value of switches: gets ptr to the perprocess value segment or returns null. validates seg_ptr or sets it to null (pointer to the value seg) */ dcl P_seg_ptr ptr; /* INPUT/OUTPUT: ptr to value segment */ dcl P_pp_ptr ptr; /* OUTPUT: ptr to perprocess value segment */ dcl (pp_sw, seg_sw) bit (1); if ^pp_sw_arg & ^seg_sw_arg then call return_code (error_table_$badcall); else do; /* explicitly specified which to use */ pp_sw = pp_sw_arg; seg_sw = seg_sw_arg; end; if pp_sw then do; /* using perprocess */ if perprocess_seg_ptr = null then do; /* first time for process */ call get_temp_segment_ ("value_", perprocess_seg_ptr, code); if code ^= 0 then call return_code (code); perprocess_seg_ptr -> pp.version = value_version_1; perprocess_seg_ptr -> pp.banner = PP_BANNER; perprocess_seg_ptr -> pp.ht_size = HT_SIZE; do i = 0 to HT_SIZE-1; perprocess_seg_ptr -> ptr_ht (i) = null; end; perprocess_seg_ptr -> pp.remote_area_ptr = get_system_free_area_ (); end; P_pp_ptr = perprocess_seg_ptr; end; else P_pp_ptr = null; if seg_sw then do; /* using value segment */ if P_seg_ptr = null then do; /* default value seg */ P_seg_ptr = get_default_ptr (); if P_seg_ptr = null then do; /* no default value seg */ seg_code = code; if pp_sw then return; /* otherwise OK unless asking for permanent only */ else call return_code (code); end; end; if P_seg_ptr -> seg.banner ^= BANNER & P_seg_ptr -> seg.banner ^= PP_BANNER then call return_code (error_table_$not_seg_type); end; else P_seg_ptr = null; end get_ptrs; %page; get_value_arg: proc (P_arg_list_ptr, P_arg_index, P_value_info, P_alloc_info); /* Converts caller's input value argument to ptr and length of allocated char string copy */ dcl P_arg_list_ptr ptr; /* INPUT: ptr to argument list */ dcl P_arg_index fixed bin; /* INPUT: which arg to get */ dcl 1 P_value_info aligned like value_info; /* OUTPUT: structure containing ptr and length */ dcl 1 P_alloc_info aligned like alloc_info; /* OUTPUT: where char string has been allocated */ dcl alloc_string char (P_alloc_info.len) based (P_alloc_info.ptr); dcl based_varying_string char (261120 /* max chars in a segment */) varying based; dcl packed_sw bit (1) aligned; dcl arg_ptr ptr; dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin; call decode_descriptor_ (P_arg_list_ptr, P_arg_index, arg_type, packed_sw, ndims, arg_size, arg_scale); if ndims > 1 then call signal_error; call cu_$arg_ptr_rel (P_arg_index, arg_ptr, arg_len, code, P_arg_list_ptr); /* Compute length for allocating a char string copy */ if arg_type = CHAR_TYPE then P_alloc_info.len = arg_len; else if arg_type = VARYING_CHAR_TYPE then do; arg_ptr = addrel (arg_ptr, -1); P_alloc_info.len = length (arg_ptr -> based_varying_string); end; else P_alloc_info.len = 64; /* arbitrary: 16 words ought to be enough */ allocate alloc_string in (alloc_info.area_ptr -> based_area) set (P_alloc_info.ptr); on conversion call return_code (error_table_$bad_conversion); call assign_ (P_alloc_info.ptr, CHAR_TYPE * 2, P_alloc_info.len, /* to target string */ arg_ptr, arg_type * 2 + fixed (packed_sw, 1), (arg_size)); /* from caller's arg */ P_value_info.ptr = P_alloc_info.ptr; P_value_info.len = length (alloc_string); end get_value_arg; %page; init_seg: proc (P_ptr); /* Initializes the segment pointed to by P_ptr as a value segment */ dcl P_ptr ptr; /* INPUT: ptr to value segment */ on not_in_write_bracket call return_code (error_table_$lower_ring); on no_write_permission call return_code (error_table_$no_w_permission); P_ptr -> seg.version = value_version_1; P_ptr -> seg.ht_size = HT_SIZE; P_ptr -> seg.remote_area_ptr = null; P_ptr -> seg.next_free_offset = rel (addr (P_ptr -> seg.node_region)); P_ptr -> seg.region_size = sys_info$max_seg_size - fixed (P_ptr -> seg.next_free_offset); /* rest of segment */ end init_seg; %page; list_pp: proc (P_ptr); /* Does value_$list stuff for a nonshareable value seg, perprocess or otherwise (using ptrs rather than offsets) */ dcl P_ptr ptr; do node_ptrs.hash = 0 to P_ptr -> pp.ht_size - 1; do node_ptrs.this = P_ptr -> pp.ptr_ht (node_ptrs.hash) repeat (node_ptrs.this -> node.next_ptr) while (node_ptrs.this ^= null); if node_ptrs.this -> node.data_sw = data_entrypoint_sw then call match_one (node_ptrs.this); end; end; end list_pp; %page; lock_for_read: proc (P_ptr, P_change_count); /* Locks a copy of the value seg's lock word, then returns seg.change_count */ dcl P_ptr ptr; /* INPUT: ptr to value seg */ dcl P_change_count fixed bin; /* OUTPUT: seg.change_count at lock time */ dcl i fixed bin; if P_ptr -> seg.salvaging_sw then do; /* seg in use */ do i = 1 to 10; /* try 10 times to catch seg unlocked */ P_change_count = P_ptr -> seg.change_count; call set_lock_$lock ((P_ptr -> seg.lock), 0, code); /* see if seg is locked (look at copy) */ if code = 0 | code = error_table_$invalid_lock_reset | code = error_table_$locked_by_this_process then return; end; call return_code (code); /* give up */ end; else P_change_count = P_ptr -> seg.change_count; /* no need to lock except for salvage */ end lock_for_read; %page; lock_for_write: proc (P_ptr); /* Locks the value seg's lock word and increments seg.change_count */ dcl P_ptr ptr; /* INPUT: ptr to value seg */ if P_ptr = null then return; if P_ptr -> seg.banner = PP_BANNER then return; on not_in_write_bracket call return_code (error_table_$lower_ring); on no_write_permission call return_code (error_table_$no_w_permission); call set_lock_$lock (P_ptr -> seg.lock, 1, code); if code ^= 0 & code ^= error_table_$invalid_lock_reset & code ^= error_table_$locked_by_this_process then call return_code (code); if P_ptr -> seg.change_count > 10000 then P_ptr -> seg.change_count = 1; else P_ptr -> seg.change_count = P_ptr -> seg.change_count + 1; end lock_for_write; %page; match_one: proc (P_ptr); /* Adds P_ptr->node.name to the sort array if it matches what's in match_info. Global vars used: alloc_chars_len, data_entrypoint_sw, match_info_ptr, sort_entry_ptr, sequential_number, sort_array_ptr */ dcl P_ptr ptr; dcl based_fb35 fixed bin (35) aligned based; dcl (excluded_sw, matched_sw) bit (1); dcl i fixed; dcl code fixed (35); excluded_sw, matched_sw = "0"b; do i = 1 to match_info.name_count; if match_info.name (i) = P_ptr -> node.name then go to MATCH; else if match_info.regexp_sw (i) then call search_file_ (addrel (addr (match_info.name (i)), 1), 1, length (match_info.name (i)), addrel (addr (P_ptr -> node.name), 1), 1, P_ptr -> node.name_len, 0, 0, code); else call match_star_name_ ((P_ptr -> node.name), (match_info.name (i)), code); if code = 0 then do; MATCH: if match_info.exclude_sw (i) then excluded_sw = "1"b; else matched_sw = "1"b; end; end; if excluded_sw | ^matched_sw then return; /* Append a sort_entry structure to the sort_entries temp seg, describing this node */ node_ptr = P_ptr; /* for sort_entry.name's length */ sort_entry.node_ptr = P_ptr; sort_entry.name = P_ptr -> node.name; sort_entry.length = P_ptr -> node.name_len + length (sort_entry.sequence); /* include sequential number to be included */ /* Append a sequential number in char string form to the name, so that the order of multiple (pushed) values with the same name will be preserved by the sort */ sequential_number = sequential_number + 1; sort_entry.sequence = sequential_number; /* picture assignment, converted to char */ /* Add this entry to the sort_array passed to sort_items_$varying_char */ sort_array.count = sort_array.count + 1; sort_array.name_ptr (sort_array.count) = addr (sort_entry.sort_field); /* Bump sort_entry_ptr for the next entry, past end of this entry */ sort_entry_ptr = addr (sort_entry.next_entry); /* Reserve room for the output name */ alloc_chars_len = alloc_chars_len + P_ptr -> node.name_len; if ^data_entrypoint_sw then alloc_chars_len = alloc_chars_len + P_ptr -> node.value_len; end match_one; %page; return_code: proc (P_code); /* Sets the value of the code argument and returns from the outer procedure */ /* options_var_sw and code_arg_index are global variables set by the entry points */ dcl P_code fixed bin (35); /* INPUT: status code value */ dcl based_fb35 fixed bin (35) based; dcl packed_sw bit (1) aligned; dcl arg_ptr ptr; dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin; if ^options_var_sw then do; A_code = P_code; go to RETURN; end; call decode_descriptor_ (arg_list_ptr, code_arg_index, arg_type, packed_sw, ndims, arg_size, arg_scale); if arg_type = FIXED_BIN_TYPE then do; call cu_$arg_ptr_rel (code_arg_index, arg_ptr, arg_len, 0, arg_list_ptr); arg_ptr -> based_fb35 = P_code; end; go to RETURN; end return_code; %page; set_seg: proc (P_ptr); /* Sets the default value seg to P_ptr, or to [hd]>[user name].value if P_ptr = null */ dcl P_ptr ptr; /* INPUT: ptr to value seg */ if P_ptr = null then do; default_seg_ptr = null; P_ptr = get_default_ptr (); end; else do; if P_ptr -> seg.banner ^= BANNER then call return_code (error_table_$not_seg_type); default_seg_ptr = P_ptr; end; end set_seg; %page; set_value_arg: proc (P_arg_list_ptr, P_arg_index, P_value_info); /* Converts ptr and length of string to value_arg argument */ dcl P_arg_list_ptr ptr; /* INPUT: ptr to argument list */ dcl P_arg_index fixed bin; /* INPUT: which arg to set */ dcl 1 P_value_info aligned like value_info; /* INPUT: structure containing ptr and length */ dcl value_string char (P_value_info.len) based (P_value_info.ptr); dcl alloc_value char (A_value_len) based (A_value_ptr); dcl alloc_data (A_data_size) fixed bin aligned based (A_data_ptr); /* for allocation */ dcl packed_sw bit (1) aligned; dcl arg_ptr ptr; dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin; dcl bit_size fixed bin (24); if alloc_entrypoint_sw then do; /* value_$get_alloc */ A_value_len = P_value_info.len; if A_area_ptr ^= null then do; /* wants it returned */ on area call return_code (error_table_$noalloc); allocate alloc_value in (A_area_ptr -> based_area) set (A_value_ptr); substr (alloc_value, 1, A_value_len) = substr (value_string, 1, A_value_len); end; return; end; if data_entrypoint_sw then do; /* value_$get_data, value_$set_data */ A_data_size = divide (P_value_info.len + 3, 4, 17, 0); if A_area_ptr ^= null then do; /* wants it returned */ on area call return_code (error_table_$noalloc); allocate alloc_data in (A_area_ptr -> based_area) set (A_data_ptr); bit_size = A_data_size * 36; substr (A_data_ptr -> bits, 1, bit_size) = substr (P_value_info.ptr -> bits, 1, bit_size); end; return; end; call decode_descriptor_ (P_arg_list_ptr, P_arg_index, arg_type, packed_sw, ndims, arg_size, arg_scale); if ndims > 1 then call signal_error; if arg_type = VARYING_CHAR_TYPE & arg_size = 0 then return; /* caller testing whether defined */ call cu_$arg_ptr_rel (P_arg_index, arg_ptr, arg_len, code, P_arg_list_ptr); if arg_type = VARYING_CHAR_TYPE then arg_ptr = addrel (arg_ptr, -1); /* point to length word */ on conversion call return_code (error_table_$bad_conversion); call assign_ (arg_ptr, arg_type * 2, (arg_size), /* to caller's argument */ P_value_info.ptr, CHAR_TYPE * 2, P_value_info.len); /* from value in node */ end set_value_arg; %page; signal_error: proc; /* Signals nonrestartable sub_error (a better one someday?) because of bad args in value_ call */ do while ("1"b); signal sub_error; end; end signal_error; %page; unlock_for_write: proc (P_ptr); /* Unlock the value segment */ dcl P_ptr ptr; /* INPUT: ptr to value seg */ if P_ptr = null then return; if P_ptr -> seg.banner = PP_BANNER then return; call set_lock_$unlock (P_ptr -> seg.lock, code); call hcs_$set_bc_seg (P_ptr, fixed (P_ptr -> seg.next_free_offset, 18) * 36, code); end unlock_for_write; %page; end value_;  value_defined.pl1 11/04/82 1933.2rew 11/04/82 1618.1 43749 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ value_defined: vdf: proc; /* Written 11/17/80 by S. Herbst */ dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); dcl name char (name_len) based (name_ptr); dcl (seg_dn, seg_path) char (168); dcl seg_en char (32); dcl ME char (32) int static options (constant) init ("value"); dcl call_switches bit (36) aligned; dcl (af_sw, defined_sw, got_name_sw, path_sw) bit (1); dcl (arg_ptr, name_ptr, return_ptr, seg_ptr) ptr; dcl (arg_len, name_len, return_len) fixed (21); dcl (arg_count, i) fixed; dcl (code, code1) fixed (35); dcl error_table_$badopt fixed (35) ext; dcl error_table_$not_act_fnc fixed (35) ext; dcl error_table_$oldnamerr fixed (35) ext; 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, ptr, fixed (21), fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl ioa_ entry options (variable); dcl value_$defined entry (ptr, bit (36) aligned, char (*), fixed (35)) returns (bit (1)); dcl value_$get_path entry (char (*), fixed (35)); dcl (index, null, substr) builtin; %page; 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_; end; else do; af_sw = "1"b; complain = active_fnc_err_; end; got_name_sw, path_sw = "0"b; call_switches = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-name" | arg = "-nm" then do; i = i + 1; if i > arg_count then do; call complain (0, ME, "No value specified for -name."); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); got_name_sw = "1"b; name_ptr = arg_ptr; name_len = arg_len; end; else if arg = "-pathname" | arg = "-pn" then do; i = i + 1; if i > arg_count then do; call complain (0, ME, "No value specified for -pathname."); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code); if code ^= 0 then do; call complain (code, ME, "^a", arg); return; end; path_sw = "1"b; end; else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b; else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b; else do; call complain (error_table_$badopt, ME, "^a", arg); return; end; else if got_name_sw then do; USAGE: if af_sw then call active_fnc_err_$suppress_name (0, ME, "Usage: [value_defined name {-control_args}]"); else call com_err_$suppress_name (0, ME, "Usage: value_defined name {-control_args}"); return; end; else do; got_name_sw = "1"b; name_ptr = arg_ptr; name_len = arg_len; end; end; if ^got_name_sw then go to USAGE; if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b; /* default is both */ if path_sw then do; call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code); if seg_ptr = null then do; call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); return; end; end; else seg_ptr = null; /* default: user's default seg if -perm */ /* Do the work */ defined_sw = value_$defined (seg_ptr, call_switches, name, code); if code ^= 0 then do; if code = error_table_$oldnamerr then call complain (code, ME, "^a", name); else if seg_ptr = null then do; call value_$get_path (seg_path, code1); if code1 ^= 0 then seg_path = ""; call complain (code, ME, "Default value segment ^a", seg_path); end; else call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); return; end; if af_sw then if defined_sw then return_arg = "true"; else return_arg = "false"; else call ioa_ ("^[true^;false^]", defined_sw); return; end value_defined;  value_delete.pl1 09/24/92 2252.0r w 09/24/92 2237.3 90279 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(91-10-25,Schroth), approve(91-11-28,MECR0015), audit(91-11-25,WAAnderson), install(91-11-28,MR12.5-1001): Correct MR12.4 source code corruption. 2) change(92-05-14,Schroth), approve(91-11-25,MCR8251), audit(92-09-22,WAAnderson), install(92-09-24,MR12.5-1016): Replace MECR0015: Correct MR12.4 source code corruption. END HISTORY COMMENTS */ value_delete: vdl: proc; /* Written 11/18/80 by S. Herbst */ /* Added -all, -brief, -data, -long 04/04/83 S. Herbst */ /* Fixed to reject name arg along with -match or -exclude 05/08/84 S. Herbst */ %include value_structures; dcl ME char (32) int static options (constant) init ("value_delete"); dcl (REGULAR init ("0"b), DATA init ("1"b)) bit (1) int static options (constant); dcl arg char (arg_len) based (arg_ptr); dcl name char (name_len) based (name_ptr); dcl based_area area based (area_ptr); dcl (seg_dn, seg_path) char (168); dcl seg_en char (32); dcl call_switches bit (36) aligned; dcl (all_sw, brief_sw, data_only_sw, got_name_sw, match_sw, match_arg_sw, path_sw, some_matches) bit (1); dcl (name_ctl_arg_sw, name_nonctl_arg_sw) bit (1); dcl (found_data, found_regular) bit (1); dcl (area_ptr, arg_ptr, name_ptr, seg_ptr) ptr; dcl (arg_len, name_len) fixed (21); dcl (arg_count, i, name_index) fixed; dcl (code, code1) fixed (35); dcl error_table_$badopt fixed (35) ext; dcl error_table_$nomatch fixed (35) ext; dcl error_table_$not_act_fnc fixed (35) ext; dcl error_table_$oldnamerr fixed (35) ext; dcl active_fnc_err_ entry options (variable); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl value_$delete entry (ptr, bit (36) aligned, char (*), fixed (35)); dcl value_$delete_data entry (ptr, bit (36) aligned, char (*), fixed (35)); dcl value_$get_path entry (char (*), fixed (35)); dcl value_$list entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35)); dcl value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35)); dcl (index, max, null, rtrim, substr, unspec) builtin; %page; call cu_$af_return_arg (arg_count, null, 0, code); if code ^= error_table_$not_act_fnc then do; call active_fnc_err_ (0, ME, "Cannot be called as an active function."); return; end; all_sw, brief_sw, data_only_sw, got_name_sw, match_sw, match_arg_sw, path_sw = "0"b; name_ctl_arg_sw, name_nonctl_arg_sw = "0"b; call_switches = "0"b; alloc_name_count, alloc_max_name_len = 0; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-all" | arg = "-a" then do; all_sw = "1"b; data_only_sw = "0"b; end; else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b; else if arg = "-data" then do; data_only_sw = "1"b; all_sw = "0"b; end; else if arg = "-exclude" | arg = "-ex" | arg = "-match" then do; name_ctl_arg_sw = "1"b; if arg = "-match" then match_arg_sw = "1"b; i = i + 1; if i > arg_count then do; NO_CONTROL_VALUE: call com_err_ (0, ME, "No value specified for ^a", arg); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); got_name_sw, match_sw = "1"b; alloc_name_count = alloc_name_count + 1; alloc_max_name_len = max (alloc_max_name_len, arg_len); end; else if arg = "-long" | arg = "-lg" then brief_sw = "0"b; else if arg = "-name" | arg = "-nm" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; call cu_$arg_ptr (i, arg_ptr, arg_len, code); got_name_sw, name_nonctl_arg_sw = "1"b; name_ptr = arg_ptr; name_len = arg_len; end; else if arg = "-pathname" | arg = "-pn" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); return; end; path_sw = "1"b; end; else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b; else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b; else do; call com_err_ (error_table_$badopt, ME, "^a", arg); return; end; else if got_name_sw then do; USAGE: call com_err_$suppress_name (0, ME, "Usage: value_delete {name} {-control_args}"); return; end; else do; got_name_sw, name_nonctl_arg_sw = "1"b; name_ptr = arg_ptr; name_len = arg_len; end; end; if ^got_name_sw then go to USAGE; if name_ctl_arg_sw & name_nonctl_arg_sw then do; call com_err_ (0, ME, "Name argument is incompatible with -match and -exclude."); return; end; if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b; /* default is both */ if path_sw then do; call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code); if seg_ptr = null then do; call com_err_ (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); return; end; end; else seg_ptr = null; /* Do the work */ if ^match_sw then do; if ^data_only_sw then call delete_one (name, REGULAR, found_regular); else found_regular = "0"b; if all_sw | data_only_sw then call delete_one (name, DATA, found_data); else found_data = "0"b; if ^found_regular & ^found_data then call com_err_ (error_table_$oldnamerr, ME, "^a", name); end; else do; /* -match or -exclude specified */ /* if only -exclude's specified, start by matching "**" */ if ^match_arg_sw then alloc_name_count = alloc_name_count + 1; /* Allocate and fill the match structure */ area_ptr = get_system_free_area_ (); allocate match_info in (based_area) set (match_info_ptr); unspec (match_info) = "0"b; match_info.version = match_info_version_1; match_info.name_count = alloc_name_count; match_info.max_name_len = alloc_max_name_len; name_index = 0; if ^match_arg_sw then do; name_index = 1; match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b; match_info.name (1) = "**"; end; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if arg = "-exclude" | arg = "-ex" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "1"b; MATCH_NAME: i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" then do; match_info.regexp_sw (name_index) = "1"b; match_info.name (name_index) = substr (arg, 2, arg_len - 2); end; else do; match_info.regexp_sw (name_index) = "0"b; /* starname */ match_info.name (name_index) = arg; end; end; else if arg = "-match" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "0"b; go to MATCH_NAME; end; end; some_matches = "0"b; if data_only_sw then go to DELETE_DATA; call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code); if code ^= 0 then do; if code ^= error_table_$nomatch then do; LIST_ERROR: if seg_ptr = null then call value_$get_path (seg_path, (0)); else if seg_dn = ">" then seg_path = ">" || seg_en; else seg_path = rtrim (seg_dn) || ">" || seg_en; call com_err_ (code, ME, "^a", seg_path); return; end; end; else do; some_matches = "1"b; do i = 1 to value_list_info.pair_count; call delete_one (substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)), REGULAR, "0"b); end; end; DELETE_DATA: if all_sw | data_only_sw then do; call value_$list_data_names (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code); if code ^= 0 then do; if code ^= error_table_$nomatch then go to LIST_ERROR; end; else do; some_matches = "1"b; do i = 1 to value_list_info.pair_count; call delete_one (substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)), DATA, "0"b); end; end; end; if ^some_matches & ^brief_sw then call com_err_ (0, ME, "No matching names."); end; RETURN: return; %page; delete_one: proc (P_name, P_data_sw, P_found_sw); dcl P_name char (*); dcl (P_data_sw, P_found_sw) bit (1); if P_data_sw then call value_$delete_data (seg_ptr, call_switches, P_name, code); else call value_$delete (seg_ptr, call_switches, P_name, code); if code = 0 then P_found_sw = "1"b; else if code = error_table_$oldnamerr then P_found_sw = "0"b; else do; /* a problem with the value seg */ if seg_ptr = null then do; call value_$get_path (seg_path, code1); if code1 ^= 0 then seg_path = ""; call com_err_ (code, ME, "Default value segment ^a", seg_path); end; else call com_err_ (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); go to RETURN; end; end delete_one; end value_delete;  value_get.pl1 05/31/88 1417.5rew 05/31/88 1406.1 76752 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ value_get: vg: proc; /* Written 11/17/80 by S. Herbst */ /* Added -call 07/14/81 S. Herbst */ /* Changed to allow user to set value and restart if no value defined 01/25/82 S. Herbst */ /* Changed -df to -dft as short for -default 05/13/82 S. Herbst */ /* Added -pop 05/23/83 S. Herbst */ /****^ HISTORY COMMENTS: 1) change(88-01-01,Gilcrease), approve(88-01-27,MCR7832), audit(88-05-25,Hunter), install(88-05-31,MR12.2-1049): Add -data control argument, to extract data-type names. END HISTORY COMMENTS */ dcl arg char (arg_len) based (arg_ptr); dcl call_string char (call_len) based (call_ptr); dcl return_arg char (return_len) varying based (return_ptr); dcl default_value char (default_value_len) based (default_value_ptr); dcl name char (name_len) based (name_ptr); dcl data char (data_size * 4) based (data_ptr); dcl (seg_dn, seg_path) char (168); dcl seg_en char (32); dcl ME char (32) int static options (constant) init ("value_get"); dcl call_switches bit (36) aligned; dcl (af_sw, call_sw, got_name_sw, default_sw, path_sw, pop_sw, data_sw) bit (1); dcl (arg_ptr, call_ptr, default_value_ptr, name_ptr, return_ptr, seg_ptr, area_ptr, data_ptr) ptr; dcl (arg_len, call_len, default_value_len, name_len, return_len) fixed (21); dcl data_size fixed binary (18); dcl (arg_count, i) fixed; dcl (code, code1) fixed (35); dcl error_table_$argerr fixed bin(35) ext static; dcl error_table_$badopt fixed (35) ext; dcl error_table_$not_act_fnc fixed (35) ext; dcl error_table_$oldnamerr fixed (35) ext; 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, ptr, fixed (21), fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35)); dcl cu_$evaluate_active_string entry (ptr, char (*), fixed, char (*) varying, fixed (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed (35)); dcl get_system_free_area_ entry() returns(ptr); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl release_temp_segment_ entry (char (*), ptr, fixed (35)); dcl value_$get entry options (variable); dcl value_$get_path entry (char (*), fixed (35)); dcl value_$pop entry options (variable); dcl value_$set entry options (variable); dcl value_$get_data entry options (variable); dcl (index, length, null, substr) builtin; dcl cleanup condition; %page; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = 0 then do; af_sw = "1"b; complain = active_fnc_err_; end; else if code = error_table_$not_act_fnc then do; af_sw = "0"b; complain = com_err_; code = 0; end; else do; call com_err_ (code, ME); return; end; call_sw, default_sw, got_name_sw, path_sw, pop_sw, data_sw = "0"b; call_switches = "0"b; area_ptr, data_ptr = null (); do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-call" then do; i = i + 1; if i > arg_count then do; NO_CONTROL_VALUE: call complain (0, ME, "No value specified for ^a", arg); return; end; call_sw = "1"b; call cu_$arg_ptr (i, call_ptr, call_len, code); end; else if arg = "-default" | arg = "-dft" | arg = "-df" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; default_sw = "1"b; call cu_$arg_ptr (i, default_value_ptr, default_value_len, code); end; else if arg = "-name" | arg = "-nm" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; got_name_sw = "1"b; call cu_$arg_ptr (i, name_ptr, name_len, code); end; else if arg = "-pathname" | arg = "-pn" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; call cu_$arg_ptr (i, arg_ptr, arg_len, code); /* How about a utility someday to find the dn>en */ /* Maybe search rules, at least naming conventions */ call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code); if code ^= 0 then do; call complain (code, ME, "^a", arg); return; end; path_sw = "1"b; end; else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b; else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b; else if arg = "-pop" then pop_sw = "1"b; else if arg = "-data" then data_sw = "1"b; else do; call complain (error_table_$badopt, ME, "^a", arg); return; end; else if got_name_sw then do; USAGE: if af_sw then call active_fnc_err_$suppress_name (0, ME, "Usage: [value_get name {-control_args}]"); else call com_err_$suppress_name (0, ME, "Usage: value_get name {-control_args}"); return; end; else do; got_name_sw = "1"b; name_ptr = arg_ptr; name_len = arg_len; end; end; if ^got_name_sw then go to USAGE; if data_sw & (pop_sw | call_sw | default_sw | substr (call_switches, 1, 1)) = "1"b then do; call complain (error_table_$argerr, ME, " The -data argument is incompatible with -default, -perprocess, -pop or -call."); return; end; if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b; /* default is both */ if call_sw & default_sw then do; call complain (0, ME, "-call incompatible with -default."); return; end; seg_ptr = null; /* default: user's default seg if -perm */ on cleanup begin; if ^af_sw then call release_temp_segment_ ("value_get", return_ptr, code); if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, 0); end; if path_sw then do; call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code); if seg_ptr = null then do; call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); return; end; end; /* Do the work */ if ^af_sw then do; call get_temp_segment_ ("value_get", return_ptr, code); return_len = WORDS_PER_SEGMENT; end; GET: if pop_sw then call value_$pop (seg_ptr, call_switches, name, return_arg, code); else if ^data_sw then call value_$get (seg_ptr, call_switches, name, return_arg, code); else do; area_ptr = get_system_free_area_ (); call value_$get_data (seg_ptr, call_switches, name, area_ptr, data_ptr, data_size, code); end; if code ^= 0 then if call_sw then do; call cu_$evaluate_active_string (null, call_string, NORMAL_ACTIVE_STRING, return_arg, code); if code ^= 0 then do; call complain (code, ME, "Evaluating -call"); go to RETURN; end; call value_$set (seg_ptr, call_switches, name, substr (return_arg, 1, length (return_arg)), "", code); if code ^= 0 then call complain (code, ME, "Setting value with -call"); end; else if default_sw then return_arg = default_value; else do; if code = error_table_$oldnamerr then do; call complain (code, ME, "^a", name); if af_sw then go to GET; /* in case user set a value while interrupted */ end; else if seg_ptr = null then do; call value_$get_path (seg_path, code1); if code1 ^= 0 then seg_path = ""; call complain (code, ME, "Default value segment ^a", seg_path); end; else call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); go to RETURN; end; if data_sw then return_arg = data; if ^af_sw then call ioa_ ("^a", return_arg); RETURN: if ^af_sw then call release_temp_segment_ ("value_get", return_ptr, code); if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, 0); return; %page; %include cp_active_string_types; %page; %include system_constants; end value_get;  value_list.pl1 02/27/89 1056.8rew 02/27/89 1051.4 159507 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-01-19,TLNguyen), approve(89-01-19,MCR8051), audit(89-02-03,Parisek), install(89-02-27,MR12.3-1015): Accept a starname whose length is longer than 32 characters (entryname length) when specifying the -match or -exclude control argument. END HISTORY COMMENTS */ value_list: vls: proc; /* Written 04/15/81 by S. Herbst */ /* Fixed bug in vls -all 06/02/82 S. Herbst */ /* Added -depth, changed to omit pushed values by default 07/26/84 S. Herbst */ /* Added -brief, changed to report nomatch's for individual args 07/27/84 S. Herbst */ /* Fixed -data erroneous "not found" error message 12/17/84 Steve Herbst */ %include check_star_name; %include value_structures; /* Constants */ dcl ME char (32) aligned int static options (constant) init ("value_list"); dcl PERPROCESS_SW bit (36) int static options (constant) init ("100000000000000000000000000000000000"b); /* Based */ dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); /* Automatic */ dcl based_area area based (area_ptr); dcl (seg_dn, seg_path) char (168); dcl seg_en char (32); dcl num_str char (16); dcl call_switches bit (36) aligned; dcl (af_sw, all_sw, bad_starname_sw, brief_sw, data_only_sw, default_sw, exclude_first_sw) bit (1); dcl (listed_data_sw, listed_sw, match_sw, match_arg_sw, path_sw, some_sw, some_data_sw, val_sw, var_sw) bit (1); dcl (area_ptr, arg_ptr, return_ptr, seg_ptr) ptr; dcl (arg_count, i, j, k, name_index) fixed bin; dcl (bottom_index, more_count, print_count, push_depth, same_count, top_index) fixed bin; dcl starname_type fixed bin (2); dcl (arg_len, return_len) fixed bin (21); dcl code fixed bin (35); dcl complain entry variable options (variable); /* External */ dcl error_table_$bad_conversion fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl error_table_$oldnamerr fixed bin (35) ext; dcl active_fnc_err_ entry options (variable); dcl check_star_name_ entry (char (*), bit (36) aligned, fixed bin (2), fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl (ioa_, ioa_$rsnnl) entry options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl value_$get_path entry (char (*), fixed bin (35)); dcl value_$list entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35)); dcl value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35)); dcl (index, length, max, min, null, rtrim, substr, unspec) builtin; dcl cleanup condition; %page; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = 0 then do; af_sw = "1"b; complain = active_fnc_err_; end; else if code = error_table_$not_act_fnc then do; af_sw = "0"b; complain = com_err_; code = 0; end; else do; call com_err_ (code, ME); return; end; area_ptr = get_system_free_area_ (); match_info_ptr, seg_ptr, value_list_info_ptr = null; on cleanup call clean_up (); all_sw, brief_sw, data_only_sw, exclude_first_sw, match_sw, match_arg_sw, path_sw, val_sw, var_sw = "0"b; call_switches = "0"b; push_depth = 1; /* default = list latest only */ alloc_name_count, alloc_max_name_len = 0; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-all" | arg = "-a" then all_sw = "1"b; else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b; else if arg = "-data" then data_only_sw = "1"b; else if arg = "-depth" | arg = "-dh" then do; i = i + 1; if i > arg_count then call give_up ("No value specified for " || arg); call cu_$arg_ptr (i, arg_ptr, arg_len, code); push_depth = cv_dec_check_ (arg, code); if code ^= 0 then do; call complain (error_table_$bad_conversion, ME, "-depth value ^a", arg); return; end; end; else if arg = "-exclude" | arg = "-ex" | arg = "-match" then do; i = i + 1; if i > arg_count then call give_up ("No value specified for " || arg); if ^match_sw & (arg = "-exclude" | arg = "-ex") then exclude_first_sw = "1"b; match_sw = "1"b; if arg = "-match" then match_arg_sw = "1"b; NAME_NEXT: call cu_$arg_ptr (i, arg_ptr, arg_len, code); NAME: alloc_name_count = alloc_name_count + 1; alloc_max_name_len = max (alloc_max_name_len, arg_len); end; else if arg = "-long" | arg = "-lg" then brief_sw = "0"b; else if arg = "-name" | arg = "-nm" then do; i = i + 1; if i > arg_count then call give_up ("No value specified for -name"); match_sw, match_arg_sw = "1"b; go to NAME_NEXT; end; else if arg = "-pathname" | arg = "-pn" then do; i = i + 1; if i > arg_count then call give_up ("No value specified for -pathname"); call cu_$arg_ptr (i, arg_ptr, arg_len, code); call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code); if code ^= 0 then do; call complain (code, ME, "^a", arg); return; end; path_sw = "1"b; end; else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b; else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b; else if arg = "-value" | arg = "-val" then val_sw = "1"b; else if arg = "-variable" | arg = "-var" then var_sw = "1"b; else do; call complain (error_table_$badopt, ME, "^a", arg); return; end; else do; /* individual name to be matched */ match_sw, match_arg_sw = "1"b; go to NAME; end; end; if ^val_sw & ^var_sw then if af_sw then call give_up ("Either -var or -val required to the active function."); else var_sw, val_sw = "1"b; if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b; /* default is both */ if path_sw then do; call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code); if seg_ptr = null then do; call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); return; end; end; default_sw = (alloc_name_count = 0); if default_sw then do; alloc_name_count = 1; alloc_max_name_len = 2; end; else if exclude_first_sw then alloc_name_count = alloc_name_count + 1; /* if -exclude is first, start by matching "**" */ /* Allocate and fill the match structure */ allocate match_info in (based_area) set (match_info_ptr); unspec (match_info) = "0"b; match_info.version = match_info_version_1; match_info.name_count = alloc_name_count; match_info.max_name_len = alloc_max_name_len; name_index = 0; if default_sw | exclude_first_sw then do; name_index = 1; match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b; match_info.name (1) = "**"; end; bad_starname_sw = "0"b; if ^default_sw then do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then do; if arg = "-exclude" | arg = "-ex" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "1"b; MATCH_NAME: i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" & arg ^= "/" then do; /* The specified STR for -ex is a qedx regular expression */ match_info.regexp_sw (name_index) = "1"b; match_info.name (name_index) = substr (arg, 2, arg_len - 2); end; else do; /* The specified STR for either -ex or -match is a starname. */ /* We allow lengths of longer than 32 chars. */ call check_star_name_ (arg, (CHECK_STAR_IGNORE_LENGTH), starname_type, code); if code ^= 0 then do; bad_starname_sw = "1"b; call complain (code, ME, "^a", arg); end; match_info.regexp_sw (name_index) = "0"b; /* a starname */ match_info.name (name_index) = arg; end; end; else if arg = "-match" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "0"b; go to MATCH_NAME; end; else if arg = "-name" | arg = "-nm" then do; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); PLAIN_NAME: name_index = name_index + 1; match_info.exclude_sw (name_index), match_info.regexp_sw (name_index) = "0"b; match_info.name (name_index) = arg; end; else if arg = "-depth" | arg = "-dh" | arg = "-pathname" | arg = "-pn" then i = i + 1; end; else go to PLAIN_NAME; end; if bad_starname_sw then go to RETURN; listed_data_sw, listed_sw = "0"b; if data_only_sw then go to LIST_DATA; call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code); if code ^= 0 then do; ERROR: if code = error_table_$nomatch then if all_sw & ^listed_data_sw then go to LIST_DATA; else if af_sw then return; /* return null string */ else call complain (0, ME, "No matching names."); else do; if seg_ptr = null then call value_$get_path (seg_path, (0)); else seg_path = pathname_ (seg_dn, seg_en); call complain (code, ME, "^a", seg_path); end; go to RETURN; end; listed_sw = "1"b; /* Note that we have had data to list. */ /* Show the results */ do i = 1 to value_list_info.pair_count; do j = i to value_list_info.pair_count while (substr (value_list_info.chars, value_list_info.name_index (j), value_list_info.name_len (j)) = substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i))); end; same_count = j - i; /* number of pushed values for same var name */ if same_count > 1 then do; /* some pushed values */ top_index = i; print_count = min (same_count, push_depth); more_count = same_count - print_count; bottom_index = top_index + print_count - 1; do k = top_index to bottom_index; call print_one (k, top_index, bottom_index, more_count); end; i = j - 1; end; else call print_one (i, i, i, 0); end; if ^all_sw then go to DONE_LISTING; /* Don't list data variables unless requested. */ free value_list_info_ptr -> value_list_info in (based_area); LIST_DATA: listed_data_sw = "1"b; call value_$list_data_names (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code); if code ^= 0 then if listed_sw & code = error_table_$nomatch then go to RETURN; else go to ERROR; do i = 1 to value_list_info.pair_count; do j = i to value_list_info.pair_count while (substr (value_list_info.chars, value_list_info.name_index (j), value_list_info.name_len (j)) = substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i))); end; same_count = j - i; /* number of pushed values for same var name */ if same_count > 1 then do; /* some pushed values */ top_index = i; print_count = min (same_count, push_depth); more_count = same_count - print_count; bottom_index = top_index + print_count - 1; do k = top_index to bottom_index; call print_one_data (k, top_index, bottom_index, more_count); end; i = j - 1; end; else call print_one_data (i, i, i, 0); end; DONE_LISTING: if ^brief_sw then do; /* check for individual match failures */ match_info.name_count = 1; /* do this name by name */ match_info.exclude_sw (1) = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, 0); if index (arg, "-") = 1 then do; if arg = "-depth" | arg = "-dh" | arg = "-exclude" | arg = "-ex" | /* ignore the -exclude and -match names */ arg = "-match" | arg = "-pathname" | arg = "-pn" then i = i + 1; end; else do; match_info.name (1) = arg; some_sw, some_data_sw = "0"b; if ^data_only_sw then do; if value_list_info_ptr ^= null then free value_list_info in (based_area); call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code); some_sw = (code = 0); end; if all_sw | data_only_sw then do; if value_list_info_ptr ^= null then free value_list_info in (based_area); call value_$list_data_names (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code); some_data_sw = (code = 0); end; if ^some_sw & ^some_data_sw then do; call check_star_name_$entry (arg, code); if code = 0 then call complain (error_table_$oldnamerr, ME, "^a", arg); else call complain (error_table_$nomatch, ME, "^a", arg); end; end; end; end; RETURN: call clean_up; return; %page; clean_up: proc; if match_info_ptr ^= null then free match_info_ptr -> match_info in (based_area); if value_list_info_ptr ^= null then free value_list_info_ptr -> value_list_info in (based_area); if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, 0); end clean_up; give_up: proc (P_str); dcl P_str char (*); call complain (0, ME, "^a", P_str); go to RETURN; end give_up; %page; print_one: proc (P_index, P_top_index, P_bottom_index, P_more_count); dcl (P_index, P_top_index, P_bottom_index, P_more_count) fixed; if af_sw then do; if var_sw then do; if length (return_arg) > 0 then return_arg = return_arg || " "; return_arg = return_arg || requote_string_ ( substr (value_list_info.chars, value_list_info.name_index (P_index), value_list_info.name_len (P_index))); end; if val_sw then do; if length (return_arg) > 0 then return_arg = return_arg || " "; return_arg = return_arg || requote_string_ ( substr (value_list_info.chars, value_list_info.value_index (P_index), value_list_info.value_len (P_index))); end; end; else call ioa_ ("^[^[PP^]^5t^a^[^31.2t^a^]^;^3s^a^]^a", var_sw, value_list_info.type_switches (P_index) & PERPROCESS_SW, substr (value_list_info.chars, value_list_info.name_index (P_index), value_list_info.name_len (P_index)), val_sw, requote_string_ ( substr (value_list_info.chars, value_list_info.value_index (P_index), value_list_info.value_len (P_index))), pushed_message (P_index, P_top_index, P_bottom_index, P_more_count)); end print_one; %page; print_one_data: proc (P_index, P_top_index, P_bottom_index, P_more_count); dcl (P_index, P_top_index, P_bottom_index, P_more_count) fixed bin; if af_sw then do; if var_sw then do; if length (return_arg) > 0 then return_arg = return_arg || " "; return_arg = return_arg || requote_string_ ( substr (value_list_info.chars, value_list_info.name_index (P_index), value_list_info.name_len (P_index))); end; if val_sw then do; /* give length in words rather than the value */ if length (return_arg) > 0 then return_arg = return_arg || " "; call ioa_$rsnnl ("^d", num_str, length (num_str), value_list_info.value_len (P_index)); return_arg = return_arg || rtrim (num_str); end; end; else call ioa_ ("^[^[PP^]^5t^a^[^31.2t^]^;^3s^]^[(^d word^[s^])^]^a", var_sw, value_list_info.type_switches (P_index) & PERPROCESS_SW, substr (value_list_info.chars, value_list_info.name_index (P_index), value_list_info.name_len (P_index)), val_sw, val_sw, value_list_info.value_len (P_index), value_list_info.value_len (P_index) ^= 1, pushed_message (P_index, P_top_index, P_bottom_index, P_more_count)); end print_one_data; %page; pushed_message: proc (P_index, P_top_index, P_bottom_index, P_more_count) returns (char (32) varying); dcl (P_index, P_top_index, P_bottom_index, P_more_count) fixed; dcl message char (32) varying; message = ""; if P_top_index ^= P_bottom_index then do; if P_index = P_top_index then message = " (current value)"; else if P_index = P_bottom_index then if P_more_count > 0 then call ioa_$rsnnl (" (^d more pushed value^[s^])", message, length (message), P_more_count, P_more_count > 1); else message = " (earliest value)"; end; else if P_more_count > 0 then call ioa_$rsnnl (" (^d pushed value^[s^])", message, length (message), P_more_count, P_more_count > 1); return (message); end pushed_message; end value_list;  value_path.pl1 11/04/82 1933.2rew 11/04/82 1618.2 17208 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ value_path: vp: proc; /* Constants */ dcl ME char (32) int static options (constant) init ("value_path"); /* Based */ dcl return_arg char (return_len) varying based (return_ptr); /* Automatic */ dcl path char (168); dcl af_sw bit (1) aligned; dcl return_ptr ptr; dcl return_len fixed bin (24); dcl arg_count fixed bin; dcl code fixed bin (35); /* External */ dcl error_table_$not_act_fnc fixed bin (35) ext; 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 (24), fixed bin (35)); dcl ioa_ entry options (variable); dcl value_$get_path entry (char (*), fixed bin (35)); dcl rtrim builtin; %page; 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; end; else do; af_sw = "1"b; return_arg = ""; end; if arg_count ^= 0 then do; if af_sw then call active_fnc_err_$suppress_name (0, ME, "Usage: [vp]"); else call com_err_$suppress_name (0, ME, "Usage: vp"); return; end; call value_$get_path (path, code); if code ^= 0 then do; if af_sw then call active_fnc_err_ (code, ME); else call com_err_ (code, ME); return; end; if af_sw then return_arg = rtrim (path); else call ioa_ ("^a", path); end value_path;  value_set.pl1 10/18/84 0853.8rew 10/18/84 0838.1 141786 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ value_set: vs: proc; /* Written 11/17/80 by S. Herbst */ /* Fixed vs -add to correctly return the value set 05/13/82 S. Herbst */ /* Fixed vs -pn not to query if error other than $noentry 02/07/84 S. Herbst */ %include value_structures; %include query_info; dcl ME char (32) int static options (constant) init ("value_set"); dcl PERMANENT fixed int static options (constant) init (0); dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); dcl temp_str char (262114 /* max segment length */) varying based (temp_ptr); dcl if_value char (if_value_len) based (if_value_ptr); dcl name char (name_len) based (name_ptr); dcl value char (value_len) based (value_ptr); dcl based_area area based (area_ptr); dcl (seg_dn, seg_path) char (168); dcl (old_value_num_str, seg_en, value_num_str) char (32); dcl call_switches bit (36) aligned; dcl (add_sw, af_sw, explicit_value_sw, got_name_sw, got_value_sw) bit (1); dcl (if_sw, match_sw, match_arg_sw, path_sw, pop_sw, push_sw, update_sw) bit (1); dcl temp_ptr ptr; dcl (area_ptr, arg_ptr, if_value_ptr, name_ptr, return_ptr, seg_ptr, value_ptr) ptr; dcl add_num fixed (35); dcl (arg_len, if_value_len, name_len, return_len, value_len) fixed (21); dcl (arg_count, i, name_index) fixed; dcl code fixed (35); dcl error_table_$badopt fixed (35) ext; dcl error_table_$bad_conversion fixed (35) ext; dcl error_table_$noentry fixed (35) ext; dcl error_table_$nomatch fixed (35) ext; dcl error_table_$not_act_fnc fixed (35) ext; 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 command_query_ entry options (variable); dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35)); dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35)); dcl cv_dec_check_ entry (char (*), fixed (35)) returns (fixed (21)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed (5), ptr, fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl release_temp_segment_ entry (char (*), ptr, fixed (35)); dcl value_$get entry options (variable); dcl value_$get_path entry (char (*), fixed (35)); dcl value_$init_seg entry (ptr, fixed, ptr, fixed (19), fixed (35)); dcl value_$list entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35)); dcl value_$pop entry options (variable); dcl value_$push entry options (variable); dcl value_$set entry options (variable); dcl value_$test_and_set entry options (variable); dcl (addr, index, length, ltrim, max, null, rtrim, substr, unspec) builtin; dcl cleanup condition; %page; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = 0 then do; af_sw = "1"b; complain = active_fnc_err_; end; else if code = error_table_$not_act_fnc then do; af_sw = "0"b; complain = com_err_; code = 0; end; else do; call com_err_ (code, ME); return; end; add_sw, explicit_value_sw, got_name_sw, got_value_sw, if_sw, match_sw, match_arg_sw, path_sw, update_sw = "0"b; pop_sw, push_sw = "0"b; call_switches = "0"b; alloc_name_count, alloc_max_name_len = 0; do i = 1 to arg_count; /* if -match etc. given, don't look for name arg */ call cu_$arg_ptr (i, arg_ptr, arg_len, code); if arg = "-match" | arg = "-exclude" | arg = "-ex" then got_name_sw = "1"b; end; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-add" then do; i = i + 1; if i > arg_count then do; NO_CONTROL_VALUE: call complain (0, ME, "No value specified for ^a", arg); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); add_num = cv_dec_check_ (arg, code); if code ^= 0 then do; call complain (code, ME, "^a", arg); return; end; add_sw, got_value_sw = "1"b; value_ptr = arg_ptr; value_len = arg_len; end; else if arg = "-exclude" | arg = "-ex" | arg = "-match" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; match_sw = "1"b; match_arg_sw = (arg = "-match"); call cu_$arg_ptr (i, arg_ptr, arg_len, code); alloc_name_count = alloc_name_count + 1; alloc_max_name_len = max (alloc_max_name_len, arg_len); end; else if arg = "-if" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if_sw = "1"b; if_value_ptr = arg_ptr; if_value_len = arg_len; end; else if arg = "-name" | arg = "-nm" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if got_value_sw & got_name_sw then go to USAGE; else if got_name_sw then do; explicit_value_sw, got_value_sw = "1"b; value_ptr = arg_ptr; value_len = arg_len; end; else do; got_name_sw = "1"b; name_ptr = arg_ptr; name_len = arg_len; end; end; else if arg = "-pathname" | arg = "-pn" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code); if code ^= 0 then do; call complain (code, ME, "-pathname arg ^a", arg); return; end; path_sw = "1"b; end; else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b; else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b; else if arg = "-pop" then pop_sw = "1"b; else if arg = "-push" then push_sw = "1"b; else if arg = "-update" | arg = "-ud" then update_sw = "1"b; else if arg = "-no_update" | arg = "-nud" then update_sw = "0"b; else if arg = "-value" | arg = "-val" then do; i = i + 1; if i > arg_count then go to NO_CONTROL_VALUE; call cu_$arg_ptr (i, arg_ptr, arg_len, code); explicit_value_sw, got_value_sw = "1"b; value_ptr = arg_ptr; value_len = arg_len; end; else do; call complain (error_table_$badopt, ME, "^a", arg); return; end; else if got_value_sw & got_name_sw then do; USAGE: if af_sw then call active_fnc_err_$suppress_name (0, ME, "Usage: [value_set {name} {value} {-control_args}]"); else call com_err_$suppress_name (0, ME, "Usage: value_set {name} {value} {-control_args}"); return; end; else if got_name_sw then do; explicit_value_sw, got_value_sw = "1"b; value_ptr = arg_ptr; value_len = arg_len; end; else do; got_name_sw = "1"b; name_ptr = arg_ptr; name_len = arg_len; end; end; if ^got_name_sw then go to USAGE; if pop_sw & got_value_sw then do; call complain (0, ME, "-pop is incompatible with specifying a value."); return; end; else if pop_sw then do; /* set up a dummy for calling value_set_push_pop */ value_ptr = name_ptr; value_len = name_len; end; else if ^got_value_sw then go to USAGE; if if_sw & (pop_sw | push_sw) then do; call complain (0, ME, "-if is incompatible with -push or -pop"); return; end; if pop_sw & push_sw then do; call complain (0, ME, "-push is incompatible with -pop"); return; end; if add_sw & explicit_value_sw then do; call complain (0, ME, "-add incompatible with specifying a value."); return; end; if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b; /* default is both */ match_info_ptr, seg_ptr, temp_ptr, value_list_info_ptr = null (); on cleanup begin; if temp_ptr ^= null () then call release_temp_segment_ ("value_set", temp_ptr, code); if match_info_ptr ^= null () then free match_info in (based_area); if value_list_info_ptr ^= null () then free value_list_info in (based_area); if seg_ptr ^= null () then call hcs_$terminate_noname (seg_ptr, 0); end; if path_sw then do; /* user_specified value segment */ call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code); if seg_ptr = null then do; if code = error_table_$noentry then do; if query_create (seg_dn, seg_en, seg_ptr) then go to SEG_OK; end; else call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); return; end; end; if af_sw & match_sw then do; /* more than one return value to concatenate */ call get_temp_segment_ ("value_set", temp_ptr, code); end; /* Do the work */ SEG_OK: if ^match_sw then call set_value (name, ""); else do; /* -match or -exclude specified */ /* if only -exclude's specified, start by matching "**" */ if ^match_arg_sw then alloc_name_count = alloc_name_count + 1; /* Allocate and fill the match structure */ area_ptr = get_system_free_area_ (); allocate match_info in (based_area) set (match_info_ptr); unspec (match_info) = "0"b; match_info.version = match_info_version_1; match_info.name_count = alloc_name_count; match_info.max_name_len = alloc_max_name_len; name_index = 0; if ^match_arg_sw then do; name_index = 1; match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b; match_info.name (1) = "**"; end; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if arg = "-exclude" | arg = "-ex" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "1"b; MATCH_NAME: i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" then do; match_info.regexp_sw (name_index) = "1"b; match_info.name (name_index) = substr (arg, 2, arg_len - 2); end; else do; match_info.regexp_sw (name_index) = "0"b; /* starname */ match_info.name (name_index) = arg; end; end; else if arg = "-match" then do; name_index = name_index + 1; match_info.exclude_sw (name_index) = "0"b; go to MATCH_NAME; end; end; call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code); if code ^= 0 then do; if code = error_table_$nomatch then call complain (0, ME, "No matching names."); else do; if seg_ptr = null then call value_$get_path (seg_path, (0)); else if seg_dn = ">" then seg_path = ">" || seg_en; else seg_path = rtrim (seg_dn) || ">" || seg_en; call complain (code, ME, "^a", seg_path); end; return; end; do i = 1 to value_list_info.pair_count; call set_value ( substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)), substr (value_list_info.chars, value_list_info.value_index (i), value_list_info.value_len (i))); end; end; RETURN: if temp_ptr ^= null () then call release_temp_segment_ ("value_set", temp_ptr, code); if match_info_ptr ^= null () then free match_info in (based_area); if value_list_info_ptr ^= null () then free value_list_info in (based_area); if seg_ptr ^= null () then call hcs_$terminate_noname (seg_ptr, 0); %page; query_create: proc (A_dn, A_en, A_seg_ptr) returns (bit (1)); dcl (A_dn, A_en) char (*); dcl A_seg_ptr ptr; dcl 1 qi aligned like query_info; dcl answer char (32) varying; dcl code fixed (35); unspec (qi) = "0"b; qi.version = query_info_version_5; qi.yes_or_no_sw = "1"b; qi.question_iocbp, qi.answer_iocbp = null; call command_query_ (addr (qi), answer, ME, "Do you want to create the value segment ^a^[>^]^a ?", A_dn, A_dn ^= ">", A_en); if answer = "no" then go to RETURN; call hcs_$make_seg (A_dn, A_en, "", 01010b, A_seg_ptr, code); if code ^= 0 then do; ERR: call complain (code, ME, "^a^[>^]^a", A_dn, A_dn ^= ">", A_en); go to RETURN; end; call value_$init_seg (A_seg_ptr, PERMANENT, null, 0, code); if code ^= 0 then go to ERR; return ("1"b); end query_create; %page; set_value: proc (P_name, P_old_value); /* Sets a single value, modified by the control argument options. */ dcl (P_name, P_old_value) char (*); dcl old_value_num fixed (35); RETRY: if add_sw then do; if match_sw then old_value_num_str = P_old_value; else do; call value_$get (seg_ptr, call_switches, name, old_value_num_str, code); if code ^= 0 then do; BAD_OLD: call complain (code, ME, "^a", P_name); return; end; end; if update_sw & af_sw then return_arg = rtrim (old_value_num_str); old_value_num = cv_dec_check_ (old_value_num_str, code); if code ^= 0 then do; code = error_table_$bad_conversion; go to BAD_OLD; end; call ioa_$rsnnl ("^d", value_num_str, length (value_num_str), old_value_num + add_num); call value_$test_and_set (seg_ptr, call_switches, name, rtrim (value_num_str), rtrim (old_value_num_str), code); value_ptr = addr (value_num_str); value_len = length (rtrim (value_num_str)); go to TEST_CODE; end; if if_sw then if match_sw then do; if if_value ^= P_old_value then return; end; else do; call value_$test_and_set (seg_ptr, call_switches, name, value, if_value, code); go to TEST_CODE; end; if update_sw & af_sw then if match_sw then do; call value_set_push_pop (seg_ptr, call_switches, P_name, value, temp_str, code); return_arg = ltrim (return_arg || " " || temp_str); end; else call value_set_push_pop (seg_ptr, call_switches, P_name, value, return_arg, code); else call value_set_push_pop (seg_ptr, call_switches, P_name, value, "", code); TEST_CODE: if code ^= 0 then do; if ^path_sw then do; call value_$get_path (seg_path, (0)); call expand_pathname_ (seg_path, seg_dn, seg_en, (0)); end; if code = error_table_$noentry then do; if query_create (seg_dn, seg_en, seg_ptr) then go to RETRY; end; else call complain (code, ME, "^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en); return; end; if af_sw & ^update_sw then if match_sw then return_arg = ltrim (return_arg || " " || value); else return_arg = value; return; %page; value_set_push_pop: proc (P_seg_ptr, P_switches, P_name, P_value, P_old_value, P_code); dcl P_seg_ptr ptr; dcl P_switches bit (36) aligned; dcl (P_name, P_value) char (*); dcl P_old_value char (*) varying; dcl P_code fixed (35); if pop_sw then call value_$pop (P_seg_ptr, P_switches, P_name, P_old_value, P_code); else if push_sw then call value_$push (P_seg_ptr, P_switches, P_name, P_value, P_old_value, P_code); else call value_$set (P_seg_ptr, P_switches, P_name, P_value, P_old_value, P_code); end value_set_push_pop; end set_value; end value_set;  value_set_path.pl1 11/04/82 1933.2rew 11/04/82 1618.3 24705 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ value_set_path: vsp: proc; /* Written 03/06/81 by S. Herbst */ /* Changed to use default value seg when invoked with no args 08/18/81 S. Herbst */ /* Constants */ dcl ME char (32) int static options (constant) init ("value_set_path"); dcl CREATE bit (1) aligned int static options (constant) init ("1"b); /* Based */ dcl arg char (arg_len) based (arg_ptr); /* Automatic */ dcl (expanded_path, path) char (168); dcl (brief_sw, got_path_sw) bit (1) aligned; dcl arg_ptr ptr; dcl arg_len fixed bin (24); dcl (arg_count, i) fixed bin; dcl code fixed bin (35); /* External */ dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$no_w_permission fixed bin (35) ext; dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry options (variable); dcl value_$set_path entry (char (*), bit (1) aligned, fixed bin (35)); dcl index builtin; %page; call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); return; end; got_path_sw, brief_sw = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if index (arg, "-") = 1 then if arg = "-brief" | arg = "-bf" then brief_sw = "1"b; else do; call com_err_ (error_table_$badopt, ME, "^a", arg); return; end; else if got_path_sw then do; USAGE: call com_err_$suppress_name (0, ME, "Usage: vsp {path} {-brief}"); return; end; else do; got_path_sw = "1"b; path = arg; end; end; if ^got_path_sw | path = "" then expanded_path = ""; else do; call absolute_pathname_ (path, expanded_path, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", path); return; end; end; call value_$set_path (expanded_path, CREATE, code); if code ^= 0 then if code = error_table_$no_w_permission then do; if ^brief_sw then call ioa_ ("Warning: You lack write access on value segment ^a", expanded_path); end; else call com_err_ (code, ME, "Value segment ^a", expanded_path); end value_set_path; 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