bce_exec_com_.pl1 11/11/89 1133.9r w 11/11/89 0826.1 113643 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_exec_com_: procedure (ss_info_ptr); /* Modified from absentee_listen_ to become bootload Multics exec_com by Keith Loepere, April 1983 */ /* Modified August 1983 by Keith Loepere for new bce switches. */ /* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */ declare (addr, addrel, empty, index, length, ltrim, min, null, reverse, rtrim, search, substr, unspec, verify) builtin; declare (cleanup, request_abort_, sub_request_abort_) condition; declare arg_count fixed bin, arg_len fixed bin (21), arg_ptr ptr, arg char (arg_len) based (arg_ptr), arg_list_ptr ptr, actual_len fixed bin (21), bce_data$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) variable external, 1 bce_get_line_entry aligned based (addr (bce_data$get_line)), /* template for an entry variable */ 2 proc ptr, 2 env ptr, bce_data$get_line_data_ptr ptr external, bce_data$subsys_info_ptr ptr external, bce_data$command_abs_data_ptr ptr external, bce_ready entry (char (*)), ec_file_name char (32), 1 my_abs_data aligned like abs_data, old_abs_data_ptr ptr, read_chars char (read_len) based (read_ptr), read_len fixed bin (21), read_ptr ptr, seg_ptr ptr, status fixed bin (35), temp_seg_ptr ptr, whoami char (32), work_len fixed bin (21), work_ptr ptr, work_string char (work_len) based (work_ptr); declare 1 ec_info aligned like ec_data; declare CP_null_line fixed bin init (100) static options (constant); /* cp_ returns this for null line */ declare ( error_table_$badopt, error_table_$badpath, error_table_$end_of_info, error_table_$not_act_fnc, error_table_$unimplemented_version ) fixed bin (35) external, sys_info$max_seg_size fixed bin (18) external; declare active_fnc_err_ entry options (variable), bce_check_abort entry, bce_data$exec_com_get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) variable ext, bce_execute_command_ entry (ptr, char (*), ptr, fixed bin (35)), bootload_fs_$get_ptr entry (char (*), ptr, fixed bin (21), fixed bin (35)), command_processor_$subsys_execute_line entry (char (*), ptr, entry, ptr, char (*), fixed bin (35)), com_err_ entry options (variable), cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr), cu_$arg_list_ptr entry () returns (ptr), cu_$generate_call entry (entry, ptr), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), get_temp_segment_ entry (char (*), ptr, fixed bin (35)), release_temp_segment_ entry (char (*), ptr, fixed bin (35)); %page; %include bce_abs_io_data; %page; %include bce_subsystem_info_; %page; %include ec_data; %page; old_abs_data_ptr = bce_data$command_abs_data_ptr; call initialize_ec_info (); ec_info.who_am_i, whoami = "exec_com"; call check_arg_list (ss_info.arg_list_ptr); if arg_count < 1 then do; if ec_info.active_function then call active_fnc_err_ (0, whoami, "Usage: [ec path {args}]"); else do; call com_err_ (0, whoami, "Usage: ec path {args}"); signal request_abort_; end; go to EGRESS; end; on cleanup call clean_up (); call get_temp_segment_ ((ec_info.who_am_i), temp_seg_ptr, status); if status ^= 0 then call complain (status, ec_info.who_am_i, "Getting temp segment."); call cu_$arg_ptr_rel (1, arg_ptr, arg_len, status, ss_info.arg_list_ptr); if status ^= 0 then call complain (status, ec_info.who_am_i, "Getting first argument."); if substr (arg, 1, min (arg_len, 1)) = "-" then call complain (error_table_$badopt, ec_info.who_am_i, "^a", arg); begin; declare 1 args (arg_count - 1) aligned, 2 ptr ptr, 2 len fixed bin (21), 2 quotes fixed bin (21); call attach_ec (find_ec ()); if ec_info.active_function then ec_info.call_ready_proc = "0"b; status = CP_null_line; /* Suppress initial call to ready proc */ %page; /* The following routine reads lines from the input file and passes them on to the command processor. It communicates with bce_exec_com_input through the attach_data block (found by bce_data$command_abs_data_ptr) in order to determine when command vs. input lines are being read and what the ready mode is. */ do while ("1"b); if ec_info.call_ready_proc & status ^= CP_null_line then call invoke_ready_procedure (); ec_info.input_line = "0"b; read_ptr, work_ptr = temp_seg_ptr; read_len = 4096; /* 1st page */ work_len = 0; do while (status ^= 0 | work_len = 0); on sub_request_abort_ go to EGRESS; call bce_check_abort; call bce_data$exec_com_get_line (addr (bce_data$exec_com_get_line), addr (read_chars), length (read_chars), actual_len, status); revert sub_request_abort_; work_len = work_len + actual_len; if status ^= 0 then if status = error_table_$end_of_info then if work_len = 0 then go to EGRESS; /* I don't know if this is exactly legal, and I know that */ else status = 0; /* bce_exec_com_input wont do this, but if there is a partial line... */ else do; call com_err_ (status, ec_info.who_am_i, "Error while reading command line."); signal request_abort_; end; end; ec_info.input_line = "1"b; /* anything read after this point is an input line */ on request_abort_ go to EGRESS; on sub_request_abort_ go to EGRESS; call command_processor_$subsys_execute_line ("bce", bce_data$subsys_info_ptr, bce_execute_command_, null (), work_string, status); if status ^= 0 then if status ^= CP_null_line then call com_err_ (status, whoami); revert request_abort_; revert sub_request_abort_; end; go to EGRESS; %page; invoke_ready_procedure: procedure (); call bce_ready ("bce (ec)"); return; end invoke_ready_procedure; %page; attach_ec: procedure (pathname); declare NL char (1) static options (constant) init (" "); declare WHITE char (5) static options (constant) initial (" "); /* FF VT NL TAB SPACE */ declare arg_num fixed bin; declare idx fixed bin (21); declare input_file char (abs_data.input_string.len) based (abs_data.input_string.ptr); declare pathname char (*); whoami = "exec_com"; abs_data_ptr = addr (my_abs_data); unspec (abs_data) = "0"b; abs_data.allocated_chars_ptr = addrel (temp_seg_ptr, 1024); abs_data.allocated_chars_len = 4096; /* 2nd page */ abs_data.work_area_ptr = addrel (temp_seg_ptr, 2048); /* rest */ abs_data.work_area_len = sys_info$max_seg_size - 2048; abs_data_work_area = empty (); %page; abs_data.arg_info.arg_ptr, abs_data.input_string.ptr, abs_data.ec_data_ptr = null (); abs_data.else_clause_ptr, abs_data.chars_ptr = null (); abs_data.attach.save_ptr, abs_data.attach.victim_ptr = null (); abs_data.labels_ptr = null (); abs_data.arg_info.ec_name_ptr = null (); %page; call initiate_input_path (pathname); /* Determine version of input file */ if substr (input_file, 1, min (8, abs_data.input_string.len)) ^= "&version" | search (input_file, WHITE) ^= 9 then do; abs_data.input_string.start, abs_data.input_string.limit = 0; end; else do; idx = index (substr (input_file, 9), NL); if idx = 0 then call complain (error_table_$unimplemented_version, whoami, "Newline must end &version statement."); if verify (substr (input_file, 9, idx - 1), WHITE) = 0 then call complain (error_table_$unimplemented_version, whoami, "No version given in &version statement."); if status ^= 0 | cv_dec_check_ (ltrim (rtrim (substr (input_file, 10, idx - 2), WHITE), WHITE), status) ^= 1 /* only version */ then call complain (error_table_$unimplemented_version, whoami, "&version ""^a""", substr (input_file, 10, idx - 2)); abs_data.input_string.start, abs_data.input_string.limit = idx + 8; end; %page; /* ATTACH HERE */ abs_data.comment_line.on, abs_data.control_line.on = "0"b; /* implement tracing defaults */ if ec_info.active_function then abs_data.command_line.on, abs_data.input_line.on = "0"b; else abs_data.command_line.on, abs_data.input_line.on = "1"b; abs_data.active, abs_data.eof = "0"b; unspec (abs_data.if_info) = "0"b; abs_data.chars_ptr, abs_data.else_clause_ptr = null (); abs_data.nest_level, abs_data.expected_nest_level = 0; abs_data.chars_len, abs_data.else_clause_len = 0; abs_data.input_string.position = abs_data.input_string.start; abs_data.ec_data_ptr = addr (ec_info); abs_data.arg_ptr = addr (args); abs_data.arg_count = arg_count - 1; do arg_num = 2 to arg_count; call cu_$arg_ptr_rel (arg_num, args (arg_num - 1).ptr, args (arg_num - 1).len, status, arg_list_ptr); args (arg_num - 1).quotes = -1; end; bce_data$command_abs_data_ptr = abs_data_ptr; return; end attach_ec; %page; find_ec: procedure () returns (char (*)); declare (index, reverse, rtrim) builtin; declare pathname char (32) varying; pathname = arg; if index (reverse (rtrim (pathname)), "ce.") ^= 1 then pathname = rtrim (pathname) || ".ec"; return (pathname); end find_ec; %page; initiate_input_path: procedure (file_name); declare file_name char (*) parameter, input_entry_len fixed bin (21); call bootload_fs_$get_ptr (file_name, abs_data.input_string.ptr, abs_data.input_string.len, status); if abs_data.input_string.ptr = null () then call complain (status, whoami, "Input file: ^a", file_name); /* Fill in &ec_name (&0) */ input_entry_len = length (rtrim (file_name)); abs_data.ec_name_ptr = addr (ec_file_name); substr (ec_file_name, 1, input_entry_len) = substr (file_name, 1, input_entry_len); abs_data.ec_name_len = input_entry_len - index (reverse (substr (file_name, 1, input_entry_len)), "."); if abs_data.ec_name_len = 0 then call complain (error_table_$badpath, whoami); return; end initiate_input_path; end; /* begin block */ EGRESS: call clean_up (); return; %page; initialize_ec_info: procedure (); seg_ptr = null (); ec_info.active_function = "0"b; ec_info.return_len = 0; ec_info.return_ptr = null (); ec_info.input_line = "1"b; ec_info.call_ready_proc = "0"b; return; end initialize_ec_info; %page; check_arg_list: procedure (P_arg_list_ptr); declare P_arg_list_ptr ptr; arg_list_ptr = P_arg_list_ptr; call cu_$af_return_arg_rel (arg_count, ec_info.return_ptr, ec_info.return_len, status, arg_list_ptr); if status = 0 then ec_info.active_function = "1"b; else if status ^= error_table_$not_act_fnc then call complain (status, ec_info.who_am_i, "Getting argument list."); return; end check_arg_list; %page; clean_up: procedure (); if bce_data$command_abs_data_ptr ^= old_abs_data_ptr then do; if bce_data$command_abs_data_ptr = bce_data$get_line_data_ptr then do; /* &attach in effect */ bce_get_line_entry.env = null (); bce_get_line_entry.proc = bce_data$command_abs_data_ptr -> abs_data.victim_ptr; bce_data$get_line_data_ptr = bce_data$command_abs_data_ptr -> abs_data.save_ptr; end; /* now &detach'ed */ bce_data$command_abs_data_ptr = old_abs_data_ptr; end; if temp_seg_ptr ^= null then call release_temp_segment_ ((ec_info.who_am_i), temp_seg_ptr, status); return; end clean_up; %page; complain: procedure () options (variable); declare arg_list_ptr ptr; arg_list_ptr = cu_$arg_list_ptr (); if ec_info.active_function then call cu_$generate_call (active_fnc_err_, arg_list_ptr); else call cu_$generate_call (com_err_, arg_list_ptr); go to EGRESS; end complain; end bce_exec_com_;  bce_exec_com_input.pl1 11/11/89 1133.9r w 11/11/89 0826.1 413577 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_exec_com_input: proc (bce_sw_data_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status); /* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */ /* major part of v1 exec_com converted for bootload Multics by Keith Loepere April 1983 */ /* Modified August 1983 for new bce switches */ declare bce_sw_data_ptr ptr, P_buffer char (P_actual_len) based (P_buffer_ptr), P_buffer_ptr ptr, P_buffer_len fixed bin (21), P_actual_len fixed bin (21), /* length of data actually returned */ P_status fixed bin (35); /* standard system error code */ declare (addr, binary, char, codeptr, copy, divide, index, length, ltrim, max, min, mod, null, rank, rtrim, search, string, substr, unspec, verify) builtin; declare (area, cleanup, request_abort_, sub_request_abort_) condition; declare 1 bce_switch aligned based, /* bce i/o switch */ 2 routine_entry entry, 2 data_ptr ptr; declare 1 bce_get_line_entry aligned based (addr (bce_data$get_line)), /* template for an entry variable */ 2 proc ptr, 2 env ptr; declare IS char (input_string.len) based (input_string.ptr), old_IS_pos fixed bin (21); declare CL_len fixed bin (21), CL_pos fixed bin (21), CL_ptr ptr, CL char (CL_len) based (CL_ptr), not_in_CL bit (1) aligned, old_CL_pos fixed bin (21); declare RS_len fixed bin (21), RS_pos fixed bin (21), RS_ptr ptr, RS char (RS_len) based (RS_ptr), old_RS_len fixed bin (21); %page; declare arg_idx fixed bin, break fixed bin, buffer_allocated bit (1) aligned, buffer_len fixed bin (21), buffer_ptr ptr, control fixed bin, copy_len fixed bin (21), from_sw bit (1) aligned, get_next_line local label variable, hash fixed bin, input_reset_sw bit (1) aligned, len fixed bin (21), quote_modifier fixed bin, start fixed bin (21), state fixed bin, saved_hash fixed bin, saved_label_ptr ptr, saved_state fixed bin, scanning_clause bit (1) aligned, status fixed bin (35), test bit (1) aligned, twoL fixed bin (21), width fixed bin; declare 1 ready_mode aligned, 2 flag bit (1) unaligned, 2 pad bit (35) unaligned; declare ec_name char (arg_info.ec_name_len) based (arg_info.ec_name_ptr), return_arg char (ec_data.return_len) varying based (ec_data.return_ptr); declare arg_string char (arg_array (arg_idx).len) based (arg_array (arg_idx).ptr); declare 1 arg_array (abs_data.arg_count) aligned based (abs_data.arg_ptr), 2 ptr ptr, 2 len fixed bin (21), 2 quotes fixed bin (21); %page; declare NL char (1) static options (constant) initial (" "); declare NL_THEN_AMP char (2) static options (constant) initial (" &"); declare SPACE char (1) static options (constant) initial (" "), TRUE char (4) static options (constant) initial ("true"), FALSE char (5) static options (constant) initial ("false"), TRACE_THEN char (6) static options (constant) initial ("&then "), TRACE_ELSE char (6) static options (constant) initial ("&else "); declare RANK_ZERO fixed bin static options (constant) initial (48), RANK_AMP_ADJ fixed bin static options (constant) initial (-10), RANK_F_ADJ fixed bin static options (constant) initial (54); declare NONE fixed bin static options (constant) initial (0), QUOTE fixed bin static options (constant) initial (1), REQUOTE fixed bin static options (constant) initial (2); declare NORMAL fixed bin static options (constant) initial (0), SEARCHING_FOR_LABEL fixed bin static options (constant) initial (1), MUST_BE_LABEL fixed bin static options (constant) initial (2), MUST_BE_THEN fixed bin static options (constant) initial (3), SKIPPING_CLAUSE fixed bin static options (constant) initial (4); declare DATA fixed bin static options (constant) initial (-1), COMMENT fixed bin static options (constant) initial (0), ELSE fixed bin static options (constant) initial (6), GOTO fixed bin static options (constant) initial (7), LABEL fixed bin static options (constant) initial (10), THEN fixed bin static options (constant) initial (16); declare LOW (12) fixed bin static options (constant) initial (1, 2, 5, 6, 7, 8, 10, 11, 12, 13, 16, 17); declare HIGH (12) fixed bin static options (constant) initial (1, 4, 5, 6, 7, 9, 10, 11, 12, 15, 16, 17); declare KEYWORD (17) char (12) varying static options (constant) initial ("attach", "command_line", "comment_line", "control_line", "detach", "else", "goto", "if", "input_line", "label", "print", "quit", "ready", "ready_proc", "return", "then", "version"); declare TRACE (-1:17) bit (1) aligned static options (constant) initial ("0"b, "0"b, (5) ("1"b), "0"b, "1"b, "0"b, (7) ("1"b), "0"b, "0"b); declare SKIPABLE (-1:17) bit (1) aligned static options (constant) initial ("1"b, "0"b, (5) ("1"b), "0"b, "1"b, "0"b, "1"b, "0"b, (5) ("1"b), "0"b, "1"b); declare WHITE char (5) static options (constant) initial (" "); /* FF VT NL HT SP */ declare ( error_table_$noalloc, error_table_$command_line_overflow, error_table_$end_of_info, error_table_$long_record ) fixed bin (35) external, bce_data$command_abs_data_ptr pointer external, bce_data$get_line_data_ptr pointer external, bce_data$subsys_info_ptr pointer external, bce_data$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) variable ext, bce_data$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) variable ext; declare active_fnc_err_ entry () options (variable), bce_check_abort entry, com_err_ entry () options (variable), cu_$arg_list_ptr entry () returns (ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), command_processor_$subsys_eval_string entry (char (*), ptr, entry, ptr, char (*), fixed bin, char (*) var, fixed bin (35)), bce_execute_command_ entry (ptr, char (*), ptr, fixed bin (35)), ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)), ioa_$nnl entry options (variable); %page; %include bce_abs_io_data; %page; %include abs_io_hash; %page; %include ec_data; %page; /* bce_exec_com_input: procedure (bce_sw_data_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status); */ abs_data_ptr = bce_sw_data_ptr -> bce_switch.data_ptr; ec_data_ptr = abs_data.ec_data_ptr; buffer_ptr = P_buffer_ptr; buffer_len = P_buffer_len; input_reset_sw = "0"b; /* recursion check. used to protect against &if [] */ if abs_data.active then if attachedp () then do; /* Not our problem; we can offload this request to attachee */ call bce_data$get_line (addr (bce_data$get_line), P_buffer_ptr, P_buffer_len, P_actual_len, P_status); return; end; else do; call com_err_ (0, "bce_exec_com_", "Attempt to invoke parser recursively. Check for invalid ""&if"" test."); signal request_abort_; end; on cleanup abs_data.active = "0"b; /* Protect against non-local goto */ abs_data.active = "1"b; /* Prevent recursive invocation of this I/O switch */ /* Handle abnormal situations: no data left, or partial line remaining. Initialize for exit paths as needed. */ if abs_data.eof then go to END_OF_FILE; /* No data left, just exit without doing any work */ if abs_data.chars_len > 0 then go to CONTINUE_LONG_RECORD; /* Now initialize variables for the scan... */ width = 0; /* width of modifier field, e.g., f, q, r, qf, rf, f&n, etc */ quote_modifier = NONE; /* quote processing to be done to current parameter */ from_sw = "0"b; /* current parameter doesn't (yet) have f as in &f */ saved_hash = -1; /* used by &goto... valid range 0:60 */ /* Hack nested &if statements where we returned something and have to skip the rest of a compound statement */ if abs_data.nest_level > abs_data.expected_nest_level then state = SKIPPING_CLAUSE; /* In the middle of an &if: if we're here, skip the rest */ else state = NORMAL; if abs_data.else_clause_len > 0 then go to CONTINUE_WITH_PENDING_ELSE_CLAUSE; /* not finished with last line, can't expand another yet */ buffer_allocated = "0"b; /* Initially expanding into P_buffer */ get_next_line = EXPAND_NEXT_LINE; /* Normal setting. Used by &if nesting get control back. */ CL_len = 0; /* No statements scanned yet, so don't skip anything */ %page; EXPAND_NEXT_LINE: input_string.position = input_string.position + CL_len; /* Position to the beginning of the next statement */ if input_string.position >= input_string.len then go to END_OF_FILE; /* If we've gone too far, punt now */ CL_ptr = addr (substr (IS, input_string.position + 1)); CL_len = index (substr (IS, input_string.position + 1), NL); if CL_len = 0 then go to NO_NEW_LINE; /* Must be at end of file, print warning and &quit */ not_in_CL = "0"b; /* Use original line in input seg, no expansions so far */ scanning_clause = "0"b; /* We are not currently within an &then or &else clause */ CL_pos = index (CL, "&") - 1; /* Find the first ampersand in the current line */ if CL_pos < 0 then go to COPY_REST; /* No ampersands in line. Skip expansion loop. */ RS_len, old_CL_pos, old_RS_len = 0; /* So far we've expanded nothing */ RS_ptr = buffer_ptr; /* We will expand to here, if necessary */ twoL = 1; /* This is 2**(quote depth), used for requoting */ if CL_pos = 0 then do; /* First char is ampersand. Special case for fast comments */ break = index ("0123456789efinqracdglptv", substr (CL, 2, 1)) - 1; if break < 0 then go to COMMENT_LINE; /* If it's a comment, we needn't expand it or return it */ if break < 10 then go to EXPAND_ARG_NUMBER; /* A digit. Get whole number and expand argument */ if break < 16 then go to EXPAND (break); /* Might be expandable, investigate further */ go to EXPAND_AGAIN; /* This might be a keyword, but we can't handle it now. */ end; %page; /* This is the loop which expands lines from the input segment. It is entered here if the first character on the line is not an ampersand. If the first character is an ampersand, it will have been handled on the previous page as a performance hack to not expand comment lines. If no expandable constructs are encountered, the line will still be in the input segment. If expansion is done, it is initially into the caller-provided buffer, but if that is too small, a larger buffer will be allocated and expansion will use it until the next line is returned to the caller. */ EXPAND_LOOP: break = index ("0123456789efinqr", substr (CL, CL_pos + 2, 1)) - 1; if break < 0 then go to EXPAND_AGAIN; /* Not expandable. skip it */ if break < 10 then go to EXPAND_ARG_NUMBER; /* A digit. Get whole number and expand argument */ go to EXPAND (break); /* Might be expandable... investigate further */ EXPAND (10): /* &e */ if substr (CL, CL_pos + 3, 1) ^= "c" then go to EXPAND_AGAIN; /* performance hack for &else */ if substr (CL, CL_pos + 4, min (CL_len, 5)) = "_name" then call emit_ec_name (); go to EXPAND_AGAIN; EXPAND (11): /* &f */ from_sw = "1"b; go to EXPAND_MODIFIER; EXPAND (12): /* &i */ if substr (CL, CL_pos + 3, 1) ^= "s" then go to EXPAND_AGAIN; /* Performance hack for &if */ if substr (CL, CL_pos + 4, min (CL_len - 3, 16)) = "_active_function" then call predicate (functionp (), 18); else if substr (CL, CL_pos + 4, min (CL_len - 3, 3)) = "_af" then call predicate (functionp (), 5); else if substr (CL, CL_pos + 4, min (CL_len - 3, 9)) = "_attached" then call predicate (attachedp (), 11); else if substr (CL, CL_pos + 4, min (CL_len - 3, 11)) = "_input_line" then call predicate (input_linep (), 13); go to EXPAND_AGAIN; EXPAND (13): /* &n: The number of arguments given for substitution */ call emit_arg_count (); go to EXPAND_AGAIN; EXPAND (14): /* &q */ quote_modifier = QUOTE; go to EXPAND_MODIFIER; EXPAND (15): /* &r */ quote_modifier = REQUOTE; EXPAND_MODIFIER: width = width + 1; break = rank (substr (CL, CL_pos + width + 2, 1)) - RANK_ZERO; if break = RANK_F_ADJ & ^from_sw then do; from_sw = "1"b; go to EXPAND_MODIFIER; end; if break = RANK_AMP_ADJ then if substr (CL, CL_pos + width + 3, 1) = "n" then do; /* &..&n: Appropriately modified last argument */ arg_idx = abs_data.arg_count; width = width + 2; go to COPY_ARG; end; if break < 0 | break > 9 then do; /* Construct isn't really a parameter, skip it */ width = 0; /* Reset these to default values, save the work elsewhere */ quote_modifier = NONE; from_sw = "0"b; go to EXPAND_AGAIN; end; EXPAND_ARG_NUMBER: arg_idx = 0; do break = break repeat (rank (substr (CL, CL_pos + width + 2, 1)) - RANK_ZERO) while (break >= 0 & break <= 9); if arg_idx <= abs_data.arg_count then arg_idx = 10 * arg_idx + break; width = width + 1; end; COPY_ARG: call copy_up_to_ampersand (width); /* Skip construct (width chars long) */ width = 0; if from_sw then do; /* User specified range of arguments to expand */ from_sw = "0"b; do arg_idx = max (1, arg_idx) to abs_data.arg_count; call copy_string (arg_string, quote_modifier); if arg_idx ^= abs_data.arg_count then call copy_string (SPACE, NONE); end; end; else if arg_idx = 0 then call copy_string (ec_name, quote_modifier); else if arg_idx <= abs_data.arg_count then call copy_string (arg_string, quote_modifier); quote_modifier = NONE; EXPAND_AGAIN: CL_pos = CL_pos + 1; /* Skip ampersand */ break = index (substr (CL, CL_pos + 1), "&") - 1; if break >= 0 then do; /* Any more ampersands in line? */ CL_pos = CL_pos + break; go to EXPAND_LOOP; end; COPY_REST: if not_in_CL then do; /* Copy rest of line if any expansions */ copy_len = CL_len - old_CL_pos; call check_len (copy_len); substr (RS, RS_len - copy_len + 1, copy_len) = substr (CL, old_CL_pos + 1, copy_len); end; else do; /* Use unexpanded string, we may not need to copy it */ RS_len = CL_len; RS_ptr = CL_ptr; end; %page; /* We come here to identify the current request line as a statement, command, or expansion to be returned. We can get here by falling through from expansion, or to identify an &then or &else clause. */ CHECK_CONTROL: if substr (RS, 1, min (1, RS_len)) = "&" then do; /* If first char is ampersand, hash on second char */ on sub_request_abort_ go to ABORT; call bce_check_abort; /* allow to break out of possible loop in exec_com land */ revert sub_request_abort_; break = index ("acdegilpqrtv", substr (RS, 2, 1)); if break = 0 then go to COMMENT_LINE; len = search (substr (RS, 3), WHITE); /* Get length of possible keyword */ do control = LOW (break) to HIGH (break); if KEYWORD (control) = substr (RS, 2, len) then do; /* Got a match! so just space RS_pos over it */ RS_pos = verify (substr (RS, len + 3), WHITE) + len + 1; if RS_pos = len + 1 then RS_pos = RS_len; go to STATE (state); /* And we're off to an action routine (of some sort) */ end; end; if len > 4 then if break = 4 then if substr (RS, 2, 4) = "else" then call warning (0, "Whitespace must follow the ""&else"" keyword or the line is a comment."); else ; else if break = 11 then if substr (RS, 2, 4) = "then" then call warning (0, "Whitespace must follow the ""&then"" keyword or the line is a comment."); COMMENT_LINE: control = COMMENT; /* We have a leading ampersand but no keyword. Ignore it */ end; else control = DATA; /* No ampersand so this line can be returned to user */ go to STATE (state); /* Off to the wars (someone will handle this line) */ STATE (0): /* NORMAL: we come here if not in search or conditional */ if TRACE (control) then call trace_output (abs_data.control_line, RS); go to CONTROL (control); /* This is where we really head off to the action routine */ %page; CONTINUE_LONG_RECORD: buffer_allocated = "1"b; /* Tell exit routine to take data out of buffer */ CL_len = 0; /* Don't skip over statement since we did no expansion */ scanning_clause = "0"b; /* Init this for tastefulness sake */ not_in_CL = "1"b; /* Not from input segment */ RS_len = abs_data.chars_len; /* set RS to pending string */ RS_ptr = abs_data.chars_ptr; CONTROL (-1): /* DATA = data to return to caller */ if not_in_CL & ^buffer_allocated & ^scanning_clause then P_actual_len = RS_len; /* All done since all data is already in caller's buffer */ else do; /* Otherwise copy as much as will fit */ P_actual_len = min (P_buffer_len, RS_len); P_buffer = RS_ptr -> P_buffer; /* If it doesn't all fit, stash the rest for later calls */ if P_actual_len < RS_len then if not_in_CL then do; /* We have an allocated buffer, and characters in it */ abs_data.chars_ptr = addr (substr (RS, P_actual_len + 1)); abs_data.chars_len = RS_len - P_actual_len; end; else do; /* this means no pending &else clause or full buffer */ RS_ptr = addr (substr (RS, P_actual_len + 1)); abs_data.chars_len, RS_len = RS_len - P_actual_len; call allocate_buffer (RS_len); abs_data.chars_ptr = RS_ptr; end; else abs_data.chars_len = 0; end; input_string.position = input_string.position + CL_len; /* Step over statement so we will get next one later */ if input_linep () then call trace_output (abs_data.input_line, P_buffer); else call trace_output (abs_data.command_line, P_buffer); if abs_data.chars_len > 0 then P_status = error_table_$long_record; /* Pending chars exist so tell caller */ else P_status = 0; EGRESS: abs_data.active = "0"b; return; %page; NO_NEW_LINE: if state = SEARCHING_FOR_LABEL then go to STATE (SEARCHING_FOR_LABEL); /* &goto should field this */ if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited his ec */ call warning (0, "The last line did not end in a newline and was ignored."); END_OF_FILE: if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited his ec. */ if state = MUST_BE_THEN then call error (0, "The end of file was encountered when a ""&then"" statement was expected."); ABORT: abs_data.eof = "1"b; /* Make sure that end of file is remembered */ if ^input_reset_sw then do; /* Mustn't leave &attach in effect */ input_reset_sw = "1"b; call reset_input (); end; P_actual_len = 0; /* Tell user what happened and how much data he got */ P_status = error_table_$end_of_info; go to EGRESS; /* Only one exit allowed for cleanup purposes */ %page; /* The following small serving of spaghetti is used to implement &goto and &label. Labels are kept in chained buckets in a small hash table. Buckets are allocated the first time a label is seen, whether it it in a &label or a &goto. There is no limit on the length of labels and the characters in a label, except that leading and trailing whitespace are removed from them. The blank label is allowed. Label search is defined to find the first instance of a label starting from the top of the file, so duplicate instances of the same label are ignored. The hashed label scheme is a large performance improvement in big exec_coms. */ CONTROL (7): /* &goto */ abs_data.nest_level = 0; /* reset nest state, so parser doesn't think we are */ abs_data.else_clause_len = 0; /* still in if statement or have else clause pending. */ get_next_line = EXPAND_NEXT_LINE; /* also set scanner back to normal */ input_string.limit = max (input_string.limit, input_string.position + CL_len); /* save farthest point in case backward branch */ go to GET_CURRENT_LABEL; /* now go parse statement */ CONTROL (10): /* &label */ if scanning_clause then call error (0, "A label may not follow ""&then"" or ""&else""."); if input_string.limit > input_string.position then go to get_next_line; /* Have we seen this label already? */ GET_CURRENT_LABEL: current_label_ptr = addr (substr (RS, RS_pos + 1)); current_label_len = length (rtrim (substr (RS, RS_pos + 1), WHITE)); hash = mod (binary (unspec (char (substr (current_label, 1, min (2, current_label_len)), 2)), 18) + current_label_len, 61); if hash = saved_hash /* cheap test -- saved_hash = -1 if not looking */ then if current_label = saved_label_ptr -> label.name then do; saved_hash = -1; /* reset saved_hash to illegal value for test */ if state = MUST_BE_LABEL then do; /* Label found in hash table has been verified */ state = NORMAL; go to get_next_line; end; state = NORMAL; /* reset from SEARCHING_FOR_LABEL */ label_ptr = saved_label_ptr; /* so saved block will be threaded properly */ go to THREAD_IN_LABEL; end; if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited the input file. */ if abs_data.labels_ptr = null () then call allocate_hash_table (); do label_ptr = abs_data.labels_ptr -> hash_table (hash) repeat (label.next_ptr) while (label_ptr ^= null ()); if current_label = label.name /* if match then three possible actions */ then if control = LABEL /* for label we just go to next line, which in */ then if state = NORMAL /* search mode calls for special action to */ then go to get_next_line; /* only scan control lines for efficiency */ else go to GET_NEXT_LABEL_LINE; else do; saved_hash = hash; saved_label_ptr = label_ptr; old_IS_pos = input_string.position; input_string.position = label.statement_pos; if input_string.position > 0 then if substr (IS, input_string.position, 1) ^= NL then go to UNSTUCK_LABEL; state = MUST_BE_LABEL; CL_len = 0; go to get_next_line; end; end; on area call error (error_table_$noalloc, "Allocating label ""^a"".", current_label); allocate label in (abs_data_work_area); /* we need a new label cell since we now know this label */ /* has never been seen before. length is arbitrary */ revert area; if control = GOTO then do; saved_hash = hash; /* we do this for cheap compare above */ saved_label_ptr = label_ptr; /* we will need this later for compare and threading in */ old_IS_pos = input_string.position; /* this is for line number in error message */ state = SEARCHING_FOR_LABEL; /* set state to ignore everything but labels */ input_string.position = input_string.limit - CL_len; go to GET_NEXT_LABEL_LINE; /* start search beyond what we've already seen */ end; THREAD_IN_LABEL: label.statement_pos = input_string.position; /* set label to beginning of its line */ label.next_ptr = abs_data.labels_ptr -> hash_table (hash); abs_data.labels_ptr -> hash_table (hash) = label_ptr; if state = NORMAL then go to get_next_line; /* We are done unless still skipping */ GET_NEXT_LABEL_LINE: input_string.position = input_string.position + CL_len; CL_len = index (substr (IS, input_string.position), NL_THEN_AMP) - 1; /* search for next control string */ if CL_len >= 0 then go to get_next_line; /* Found something; check it out */ input_string.position = old_IS_pos; /* Restore position for error message. */ call error (0, "Label ""^a"" not found.", saved_label_ptr -> label.name); STATE (1): /* SEARCHING_FOR_LABEL */ if control = LABEL then go to GET_CURRENT_LABEL; /* in this state we ignore everything but &label lines */ else go to GET_NEXT_LABEL_LINE; /* since efficient label search is critical */ STATE (2): /* MUST_BE_LABEL */ if control = LABEL then go to GET_CURRENT_LABEL; UNSTUCK_LABEL: input_string.position = old_IS_pos; state = NORMAL; call error (0, "Label ""^a"" is unstuck. Active programs may not be edited.", saved_label_ptr -> label.name); %page; CONTROL (0): /* COMMENT LINE */ if scanning_clause then call error (0, "A comment may not follow ""&then"" or ""&else""."); call trace_output (abs_data.comment_line, CL); go to get_next_line; CONTROL (11): /* &print */ call ioa_$nnl (substr (RS, min (RS_pos + 1, RS_len))); go to get_next_line; CONTROL (12): /* &quit */ if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&quit""."); go to END_OF_FILE; CONTROL (15): /* &return */ if RS_pos = RS_len then RS_pos = RS_pos - 1; /* Newline at end of null return string is not white space */ RS_ptr = addr (substr (RS, RS_pos + 1)); /* Adjust RS to only be argument of statement */ RS_len = RS_len - RS_pos; if functionp () then do; RS_len = RS_len - 1; /* Don't return newline at end for active function */ if RS_len > ec_data.return_len then call warning (error_table_$command_line_overflow, "Expanded value length of ^d characters exceeds return argument length of ^d characters.", RS_len, ec_data.return_len); return_arg = RS; end; else call bce_data$put_chars (addr (bce_data$put_chars), addr (RS), length (RS), status); go to END_OF_FILE; CONTROL (17): call error (0, "The ""&version"" statement may only be the first line of the program."); %page; CONTROL (1): /* &attach */ if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&attach""."); if ec_data_ptr ^= null () & ^attachedp () then do; bce_data$command_abs_data_ptr -> abs_data.save_ptr = bce_data$get_line_data_ptr; bce_data$command_abs_data_ptr -> abs_data.victim_ptr = codeptr (bce_data$get_line); bce_data$get_line_data_ptr = bce_data$command_abs_data_ptr; bce_data$get_line = bce_exec_com_input; end; go to get_next_line; CONTROL (5): /* &detach */ if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&detach""."); input_string.position = input_string.position + CL_len; /* Adjust position in case call to reset_input fails */ CL_len = 0; /* Make sure that it isn't adjusted twice if it doesn't */ call reset_input (); /* Do &detach, call get_line for saved switch if input line */ go to get_next_line; reset_input: procedure (); if attachedp () then do; bce_get_line_entry.env = null (); bce_get_line_entry.proc = bce_data$command_abs_data_ptr -> abs_data.victim_ptr; bce_data$get_line_data_ptr = bce_data$command_abs_data_ptr -> abs_data.save_ptr; if input_linep () then do; call bce_data$get_line (addr (bce_data$get_line), P_buffer_ptr, P_buffer_len, P_actual_len, P_status); go to EGRESS; end; end; return; end; %page; CONTROL (13): /* &ready */ string (ready_mode) = ""b; ready_mode.flag = trace_mode (); /* don't do anything, though */ go to get_next_line; CONTROL (14): /* &ready_proc */ test = trace_mode (); if ec_data_ptr ^= null () then ec_data.call_ready_proc = test; go to get_next_line; trace_mode: procedure () returns (bit (1) aligned); if RS_len = RS_pos then do; call warning (0, "Missing keyword in mode statement. ""on"" assumed."); return ("1"b); end; RS_len = length (rtrim (RS, WHITE)); if substr (RS, RS_pos + 1) = "on" | substr (RS, RS_pos + 1) = "true" then return ("1"b); if substr (RS, RS_pos + 1) = "off" | substr (RS, RS_pos + 1) = "false" then return ("0"b); call warning (0, "Illegal keyword in mode statement. ""on"" assumed."); return ("1"b); end; %page; CONTROL (2): /* &command_line */ call trace_control (abs_data.command_line); go to get_next_line; CONTROL (3): /* &comment_line */ call trace_control (abs_data.comment_line); go to get_next_line; CONTROL (4): /* &control_line */ call trace_control (abs_data.control_line); go to get_next_line; CONTROL (9): /* &input_line */ call trace_control (abs_data.input_line); go to get_next_line; trace_control: procedure (trace_structure); declare 1 trace_structure aligned like abs_data.command_line; if RS_len = RS_pos then do; call warning (0, "Missing keyword in tracing statement. ""on"" assumed."); trace_structure.on = "1"b; return; end; len = search (substr (RS, RS_pos + 2), WHITE); /* Find end of keyword */ RS_len = length (rtrim (RS, WHITE)); /* Find end of tokens on line */ if substr (RS, RS_pos + 1) = "on" | substr (RS, RS_pos + 1) = "true" then trace_structure.on = "1"b; else if substr (RS, RS_pos + 1) = "off" | substr (RS, RS_pos + 1) = "false" then trace_structure.on = "0"b; else do; call warning (0, "Invalid keyword in tracing statement. ""on"" assumed."); trace_structure.on = "1"b; end; return; end trace_control; %page; trace_output: procedure (trace_structure, line); declare 1 trace_structure aligned like abs_data.command_line, line char (*); do while (trace_structure.on); /* Do this only if tracing is enabled. */ call bce_data$put_chars (addr (bce_data$put_chars), addr (line), length (line), status); if status = 0 then return; /* Exit if line successfully traced */ call com_err_ (status, "bce_exec_com_", "Unable to do trace output."); signal request_abort_; end; return; end trace_output; %page; CONTROL (8): /* &if */ start = find_clause ("&then"); if RS_len = RS_pos | start = RS_pos then call error (0, "Missing conditional in ""&if"" statement."); if start >= 0 then do; old_RS_len = RS_len; /* Save for locating &then clause */ RS_len = start; /* Delay assignment for benefit of error message routine. */ end; RS_len = length (rtrim (RS, WHITE)); abs_data.nest_level = abs_data.nest_level + 1; if state = NORMAL then do; call trace_output (abs_data.control_line, RS); call trace_output (abs_data.control_line, NL); abs_data.expected_nest_level = abs_data.nest_level; if ^conditional () then state = SKIPPING_CLAUSE; end; if start < 0 then do; saved_state = state; state = MUST_BE_THEN; go to EXPAND_NEXT_LINE; /* Go direct, don't mess around. This state is indivisible */ end; RS_ptr = addr (substr (RS, start + 1)); RS_len = old_RS_len - start; RS_pos = verify (substr (RS, 6), WHITE) + 4; /* Find beginning of clause beyond "&then" */ if RS_pos = 4 then RS_pos = RS_len; %page; CONTINUE_THEN: if abs_data.else_clause_len <= 0 then do; /* maybe we even have the &else */ start = find_clause ("&else"); if start >= 0 then do; /* We do. Copy the whole line into an allocated buffer */ if ^not_in_CL | ^buffer_allocated then call allocate_buffer (RS_len); abs_data.else_clause_len = RS_len - start; abs_data.else_clause_ptr = addr (substr (RS, start + 1)); RS_len = length (rtrim (substr (RS, 1, start), WHITE)) + 1; substr (RS, RS_len, 1) = NL; /* Break the line. We'll get rest of the line next time */ get_next_line = GET_PENDING_ELSE_CLAUSE; end; end; if RS_pos >= RS_len then RS_pos = RS_len - 1; /* Newline at end of null line is not white space */ RS_ptr = addr (substr (RS, RS_pos + 1)); /* Step over &then or &else and following whitespace */ RS_len = RS_len - RS_pos; if state = NORMAL then do; /* This clause will be executed. First, we trace ourself. */ if control = THEN then call trace_output (abs_data.control_line, TRACE_THEN); else call trace_output (abs_data.control_line, TRACE_ELSE); abs_data.expected_nest_level = 0; /* After taking this clause we skip until back at top level */ if abs_data.else_clause_len = 0 & abs_data.nest_level > 0 then get_next_line = ENTER_SKIPPING_CLAUSE_STATE; end; /* Arrange to set state to skipping after taking clause */ scanning_clause = "1"b; /* Comments and labels are forbidden in clauses */ go to CHECK_CONTROL; /* Prepare to execute clause */ STATE (3): /* MUST_BE_THEN */ if control = COMMENT then go to get_next_line; /* comments are allowed between &if and &else statements */ if control ^= THEN then call error (0, "Missing ""&then"" keyword following ""&if"" statement."); state = saved_state; /* pop state saved in &if (NORMAL or SKIPPING_CLAUSE) */ go to CONTINUE_THEN; CONTROL (16): /* &then: this can't be reached by a legitimate clause */ call error (0, "Unexpected ""&then"" statement."); %page; CONTINUE_WITH_PENDING_ELSE_CLAUSE: buffer_allocated = "1"b; /* We have just reentered, so initialize--this must be */ CL_len = 0; /* We haven't done any expansion this time, so don't skip */ not_in_CL = "1"b; /* in an allocated buffer, not in the input file */ GET_PENDING_ELSE_CLAUSE: RS_len = abs_data.else_clause_len; /* Set RS to pending &else clause in allocated buffer */ RS_ptr = abs_data.else_clause_ptr; abs_data.else_clause_len = 0; /* Unmark pending &else clause storage */ RS_pos = verify (substr (RS, 6), WHITE) + 4; /* Set RS_pos as if we came from CHECK_CONTROL */ if RS_pos = 4 then RS_pos = RS_len; /* Locate it at first non-white char or at end of line */ get_next_line = EXPAND_NEXT_LINE; /* Reset this since we don't want to come back here */ control = ELSE; /* This is the only kind of statement that is ever pending */ CONTROL (6): /* &else */ if abs_data.nest_level <= 0 then call error (0, "Unexpected ""&else"" statement."); abs_data.nest_level = abs_data.nest_level - 1; /* Implement nesting here */ if abs_data.nest_level < abs_data.expected_nest_level then state = NORMAL; else state = SKIPPING_CLAUSE; go to CONTINUE_THEN; STATE (4): /* SKIPPING_CLAUSE */ if ^scanning_clause then if control = ELSE | control = COMMENT then go to CONTROL (control); /* &else or comments are part of nested compound statement */ else do; /* anything else ends compound statement */ scanning_clause = "0"b; /* comments and &labels are legal again */ state = NORMAL; /* nested statement must end here */ abs_data.nest_level = 0; /* so reset back to top level */ go to STATE (NORMAL); end; if SKIPABLE (control) then go to get_next_line; else go to CONTROL (control); ENTER_SKIPPING_CLAUSE_STATE: state = SKIPPING_CLAUSE; /* We have taken a clause, so we skip rest of if statement */ get_next_line = EXPAND_NEXT_LINE; /* Reset this, we don't need to come here again */ go to EXPAND_NEXT_LINE; %page; /* This function is called from &if to find &then and from &then or &else to find an &else which follows on the same line. The contract of the function is to return the length of the string preceding the keyword, which must be delimited on BOTH sides by whitespace. If it is followed by a newline, that is considered whitespace. If the clause is not found, the -1 is returned. */ find_clause: procedure (keyword) returns (fixed bin (21)); declare keyword char (*), keyword_pos fixed bin (21), start_keyword fixed bin (21); keyword_pos = RS_pos; /* start with first unidentified character */ start_keyword = index (substr (RS, RS_pos + 1), keyword) - 1; if start_keyword < 0 then return (-1); keyword_pos = RS_pos + start_keyword; if index (WHITE, substr (RS, keyword_pos + length (keyword) + 1, 1)) - 1 < 0 | index (WHITE, substr (RS, keyword_pos, 1)) - 1 < 0 then call warning (0, "Whitespace must surround the ""^a"" keyword.", keyword); return (keyword_pos); end find_clause; %page; /* This procedure implements knowledge of the syntax of &if conditionals (except for detection of missing conditionals, which is done in &if). The forms accepted are "true", "false", "[...]", "|[...]", and "||[...]". The forms containing brackets are evaluated by calling command_processor_$subsys_eval_string with the string contained between them. A zero error code must be returned, and the returned value must be either "true" or "false". */ conditional: procedure () returns (bit (1) aligned); declare AF_len fixed bin (21), AF_ptr ptr, AF char (AF_len) based (AF_ptr), bars_len fixed bin, value char (8) varying; if substr (RS, RS_pos + 1) = "true" then return ("1"b); if substr (RS, RS_pos + 1) = "false" then return ("0"b); if substr (RS, RS_pos + 1, 1) = "|" then if substr (RS, RS_pos + 2, 1) = "|" then bars_len = 2; else bars_len = 1; else bars_len = 0; if substr (RS, RS_pos + bars_len + 1, 1) ^= "[" | substr (RS, RS_len) ^= "]" then call error (0, "Malformed conditional in ""&if"" statement."); AF_ptr = addr (substr (RS, RS_pos + bars_len + 2)); AF_len = RS_len - RS_pos - bars_len - 2; /* do not pass brackets surrounding if expression */ on request_abort_ call error (0, "request_abort_ signalled while evaluating ""&if"" clause."); call command_processor_$subsys_eval_string ("bce", bce_data$subsys_info_ptr, bce_execute_command_, null (), AF, (bars_len + 1), value, status); revert request_abort_; if status ^= 0 then call error (status, "Evaluating ""&if"" clause."); if value = "true" then return ("1"b); if value = "false" then return ("0"b); call error (0, "Illegal value ""^a"" returned by active function.", value); end conditional; %page; /* This utility predicate knows how to determine if some switch is &attached. */ attachedp: procedure () returns (bit (1) aligned); return (bce_data$command_abs_data_ptr = bce_data$get_line_data_ptr); end attachedp; /* This utility predicate knows how to determine if the current line is an input line */ input_linep: procedure () returns (bit (1) aligned); if ec_data_ptr = null () then return ("0"b); /* Can't be input unless someone tells us so */ return (ec_data.input_line); end input_linep; /* This utility predicate knows how to tell if we were invoked as an active function */ functionp: procedure () returns (bit (1) aligned); if ec_data_ptr = null () then return ("0"b); /* Can't return a value if we don't have a place to put it */ else return (ec_data.active_function); end functionp; %page; emit_ec_name: procedure (); /* &ec_name: The entryname of the input file, sans suffix */ call copy_up_to_ampersand (7); call copy_string (ec_name, QUOTE); end emit_ec_name; %page; emit_arg_count: procedure (); declare arg_count_pic picture "zzzzzzzz9", arg_count_len fixed bin, arg_count char (arg_count_len) based (addr (substr (arg_count_pic, 10 - arg_count_len))); call copy_up_to_ampersand (1); arg_count_pic = abs_data.arg_count; arg_count_len = length (ltrim (arg_count_pic)); call copy_string (arg_count, NONE); end emit_arg_count; predicate: procedure (test, width); declare test bit (1) aligned, width fixed bin; call copy_up_to_ampersand (width); if test then call copy_string (TRUE, NONE); else call copy_string (FALSE, NONE); return; end predicate; copy_up_to_ampersand: procedure (width); declare width fixed bin; len = CL_pos - old_CL_pos; if len > 0 then do; call check_len (len); substr (RS, RS_len - len + 1, len) = substr (CL, old_CL_pos + 1, len); end; CL_pos = CL_pos + width; old_CL_pos = CL_pos + 1; not_in_CL = "1"b; /* Make sure that we know some expansion was encountered */ return; end copy_up_to_ampersand; %page; copy_string: procedure (arg_string, quote_modifier); declare arg_string char (*), quote_modifier fixed bin; declare (arg_pos, quote_pos, quote_len) fixed bin (21); if quote_modifier = NONE then do; call check_len (length (arg_string)); substr (RS, RS_len - length (arg_string) + 1) = arg_string; return; end; arg_pos = 0; QLOOP: quote_len = index (substr (RS, old_RS_len + 1), """") - 1; if quote_len >= 0 then do; old_RS_len = old_RS_len + quote_len; quote_len = verify (substr (RS, old_RS_len + 1), """") - 1; if quote_len < 0 then quote_len = RS_len - old_RS_len; old_RS_len = old_RS_len + quote_len; if mod (quote_len, twoL) = 0 then do while (mod (quote_len, 2 * twoL) ^= 0); quote_len = quote_len - twoL; twoL = 2 * twoL; end; else do while (quote_len ^= 0); twoL = divide (twoL, 2, 17, 0); quote_len = mod (quote_len, twoL); end; go to QLOOP; end; else old_RS_len = RS_len; if quote_modifier = REQUOTE then do; /* insert quotes if requoting */ call check_len (twoL); substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL); twoL = 2 * twoL; /* increase quote depth by one */ end; DBL_LOOP: quote_pos = index (substr (arg_string, arg_pos + 1), """") - 1; if quote_pos >= 0 then do; call check_len (quote_pos); substr (RS, RS_len - quote_pos + 1, quote_pos) = substr (arg_string, arg_pos + 1, quote_pos); arg_pos = arg_pos + quote_pos + 1; call check_len (twoL); substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL); if arg_pos < length (arg_string) then go to DBL_LOOP; else go to APPEND; end; quote_pos = length (arg_string) - arg_pos; if quote_pos > 0 then do; /* something after last quote in arg */ call check_len (quote_pos); substr (RS, RS_len - quote_pos + 1, quote_pos) = substr (arg_string, arg_pos + 1, quote_pos); end; APPEND: if quote_modifier = REQUOTE then do; /* append quotes if requoting */ twoL = divide (twoL, 2, 17, 0); call check_len (twoL); substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL); end; old_RS_len = RS_len; return; end copy_string; %page; check_len: proc (len); /* routine to make sure we don't overflow input buffer */ declare len fixed bin (21), new_RS_len fixed bin (21); new_RS_len = RS_len + len; if new_RS_len > buffer_len then call allocate_buffer (new_RS_len); RS_len = new_RS_len; return; end check_len; allocate_buffer: procedure (required_len); declare required_len fixed bin (21); not_in_CL = "1"b; /* RS will not be eq to CL after this */ buffer_allocated = "1"b; if required_len <= abs_data.allocated_chars_len then do; /* Reuse allocated buffer if possible */ abs_data.allocated_chars_ptr -> RS = RS; buffer_ptr, RS_ptr = abs_data.allocated_chars_ptr; return; end; else call error (0, "Expanded line exceeds implementation restriction of ^d characters in length.", abs_data.allocated_chars_len); return; end allocate_buffer; %page; allocate_hash_table: procedure (); on area call error (error_table_$noalloc, "Allocating label hash table."); allocate hash_table set (abs_data.labels_ptr) in (abs_data_work_area); revert area; end allocate_hash_table; %page; error: procedure () options (variable); declare complain entry () variable options (variable), line_len fixed bin (21), line_number fixed bin (21), line_ptr ptr, line_start fixed bin (21), line char (line_len) based (line_ptr), message char (256), severity bit (1), status_ptr ptr, status fixed bin (25) based (status_ptr), who char (72) varying; severity = "1"b; go to ERROR_COMMON; warning: entry options (variable); severity = "0"b; ERROR_COMMON: call cu_$arg_ptr (1, status_ptr, (0), (0)); call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, message, (0), "1"b, "0"b); line_number = 0; do line_start = 0 repeat (line_start + line_len + 1) while ((line_start <= input_string.position) & (line_start < input_string.len)); line_len = index (substr (IS, line_start + 1), NL) - 1; if line_len < 0 then line_len = input_string.len - line_start; line_number = line_number + 1; line_ptr = addr (substr (IS, line_start + 1)); end; if ec_data.active_function then complain = active_fnc_err_; else complain = com_err_; who = ec_data.who_am_i; call complain (status, who, "^[^/^]^[Error^;Warning^] on line #^d of ^a:^/^a^/SOURCE:^-^a", status ^= 0, severity, line_number, ec_name, message, line); if ^severity then return; state = NORMAL; /* Prevent looping if state is a MUST_BE state. */ go to END_OF_FILE; end error; end bce_exec_com_input; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved