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 ent