full_command_processor_.pl1 09/25/78 1427.2rew 09/25/78 1427.2 208530 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ full_command_processor_: proc(input_linep, input_linel, code); /* initially coded in December 1969 by V Voydock */ /* modified May 1970 by R. Frankston for Limited Service System */ /* Modified to use PL/I quoting convention, call com_err_ on errors and not expect lines to end in new line character in June 1971 by V. Voydock */ /* Modified in November 1971 by V. Voydock to use error_table codes, treat the new line character as the equivalent of the ";" and to fix a few minor bugs */ /* Modified in May 1972 by V. Voydock as part of fast command loop */ /* Modified 25 Aug 1973 by Richard H. Gumpertz to make "a ([x])" work where x returns "" */ dcl (input_linel, /* length of input line passed to command processor */ temp_com_linel, /* length of temporary command line (if it is nec. to build it) */ inl, /* internal copy of input line length (changed during processing) */ i, /* Temporary variable */ j, /* " " */ m, /* " " */ first(0:1) based(fp), /* Index (in command line) of first char of ith argument */ len(0:1) based(lp), /* Length of ith argument */ actual_first(0:26), /* vble "first" is based on this if less than 25 args in line */ actual_len(0:26), /* vble "len" is based on this if less than 25 args in line */ arg_limit, /* max number of args before more space must be allocated */ whereami, /* index of first free character in command line */ lng, /* length of atom returned by special syntactic construct handlers */ inl_left, /* number of chars left to be scanned in input line */ startno, /* index in input line of first char of atom being processed */ argno, /* number of arguments to be passed to command */ atoml, /* space left in temp command line for returned atom */ max_com_line int static init(132), /* maximum size of expanded command line */ end_iter /* 0 if no iteration sets have been found so far 1 if end of an iteration set has been reached 2 if iteration set is being processed, and end has not been reached */ ) fixed bin aligned; dcl (code, error_table_$unbalanced_parentheses external, error_table_$unbalanced_brackets external, error_table_$mismatched_iter external ) fixed bin(35) aligned; dcl (cp_data_$under_lss external, /* true if running under limited service system */ space_not_allocated init("1"b), /* true if space for expanded com line not yet allocated */ processing_active_string, /* true if we are processing an active string */ ignore_brack, /* true if we are not to treat brackets as special chars */ first_parenthesis init("1"b), /* true until first parenthesis is seen */ semicolon_seen init("0"b), /* true if semicolon has been seen while processing com line */ message_not_printed int static, /* true if error message has not yet been printed */ no_work_done init("1"b), /* true if no non-null command has been yet found in line */ in_iteration_set, /* true if processing an iteration set */ argspace_grown init("0"b), /* true if space had to be allocated for array "first" */ special_char_seen /* true if special command lang char has been seen in command */ ) bit(1) aligned; /* */ dcl (input_linep, /* ptr to input line to be processed */ inp, /* ptr to beg of command in input line or temp command line */ inlp, /* ptr to beginning of command in original input line */ fp init(addr(actual_first(0))), /* ptr to space on which "first" array is based */ lp init(addr(actual_len(0))), /* ptr to space on which "len" array is based */ tfp, /* temp copy of fp used by allocation procedure */ tlp, /* temp copy of lp used by allocation procedure */ atomp, /* ptr to "atom" to be processed by spec syntactic subroutines */ temp_com_linep, /* ptr to simple command line being built */ startp, /* ptr to beginning of spec syntactic construct */ cp_data_$command_table_ptr external /* ptr to command table used with limited command systems */ ) ptr aligned; dcl com_line char(temp_com_linel) based(temp_com_linep) aligned, /* input line is copied here piece by piece if '"', '(', or '[' are found in it */ atom char(atoml) based(atomp), input_line char(inl+1) based(inp) aligned, /* input line to be processed */ nl char(1) aligned int static init(" "), /* New line character */ nch char(1) aligned; /* character currently being examined */ dcl cu_$gen_call ext entry(ptr, ptr), cu_$grow_stack_frame ext entry(fixed bin, ptr, fixed bin(35)), cu_$shrink_stack_frame ext entry(ptr, fixed bin(35)), find_command_ ext entry(ptr, fixed bin, ptr, fixed bin(35)), transform_command_ ext entry(ptr, fixed bin, ptr, fixed bin(35)), proc_parens_ ext entry(ptr, fixed bin, fixed bin, ptr, fixed bin, fixed bin, bit(1) aligned, fixed bin(35)), proc_quotes_ ext entry(ptr, fixed bin, fixed bin, ptr, fixed bin, fixed bin, bit(1) aligned, fixed bin(35)), (proc_brackets_$nested_brackets, proc_brackets_) ext entry(ptr, fixed bin, fixed bin, fixed bin, char(*) var, char(*) var, fixed bin(35)), com_err_ ext entry options(variable); dcl (addr, addrel, bin, bit, divide, mod, null, search, string, substr) builtin; /* structure to scan input line */ dcl 1 x based(inp) aligned, 2 ch(0:31) char(1) unaligned; dcl (cleanup, command_abort_) condition; /* */ /* ***********************************START OF SIMPLE COMMAND LOOP*********************************** */ processing_active_string, ignore_brack = "0"b; START: message_not_printed = "1"b; temp_com_linel = input_linel; inl = input_linel-1; inp, inlp = input_linep; NEXT_COMMAND: /* If called to evaluate active function, lower arg_limit to allow for return arg */ if processing_active_string then arg_limit = 25; else arg_limit = 26; NEXT_ITER: len(0), whereami, end_iter, code, startno = 0; in_iteration_set, special_char_seen = "0"b; argno = -1; NEXT_ATOM: /* Skip leading blanks */ do i = startno to inl while(ch(i) = " "); end; j = i; /* Set j = i in case we have line of the form "command; ;" */ /* Check to see if we have reached the end of the command line or the end of the command (the part ended by ";") and then check to see if we must allocate more space for the first and len arrays */ if i>inl then go to SCAN_DONE; nch = ch(i); /* Pick up next character */ if nch = nl then nch = ";"; /* nl < = > ; */ if nch = ";" then do; semicolon_seen = "1"b; go to SCAN_DONE; end; argno = argno+1; if argno>arg_limit then do; tfp, tlp = null; on condition(cleanup) call cleanup_proc; call grow_space; end; /* Set index of first character in the atom. If this is a simple command this index is relative to the original input line, otherwise it is relative to the temporary command line being built */ if special_char_seen then first(argno) = whereami; else first(argno) = i; /* */ /* Scan for next break or special character */ if ignore_brack then j = search(substr(input_line,i+1,inl-i+1)," ;()"" "); else j = search(substr(input_line,i+1,inl-i+1)," ;()[]"" "); if j=0 then do; j = inl+1; go to END_OF_ATOM_FOUND; end; j = j+i-1; nch = ch(j); if nch = " " then do; startno = j+1; go to END_OF_ATOM_FOUND; end; if nch = nl then nch = ";"; /* Treat nl as equivalent to ";" */ if nch = ";" then do; semicolon_seen = "1"b; go to END_OF_ATOM_FOUND; end; if nch = "(" then go to MORE_COMPLICATED; if nch = """" then go to MORE_COMPLICATED; if nch = "[" then go to CALL_PROC_BRACKETS; if nch = ")" then do; code = error_table_$unbalanced_parentheses; go to PRINT_MESSAGE; end; if nch = "]" then do; code = error_table_$unbalanced_brackets; go to PRINT_MESSAGE; end; END_OF_ATOM_FOUND: /* Save length of current atom */ len(argno) = j-i; /* If one of the special command language syntactic characters has been seen then copy the atom from the input line into the temporary command line being built */ if special_char_seen then do; substr(com_line, whereami+1, len(argno)) = substr(input_line, i+1, len(argno)); whereami = whereami+len(argno); end; if nch = " " then go to NEXT_ATOM; SCAN_DONE: /* We have finished parsing a command. Now test for a null command; that is a line consisting of all blanks, or a portion of a line of the form "; ;" etc */ if len(0) = 0 then go to CHECK_FOR_ANOTHER_COMMAND; /* Test for end of iteration group */ if end_iter = 1 then go to CHECK_FOR_ANOTHER_COMMAND; /* Indicate that a non-null command line has been typed */ no_work_done = "0"b; /* If calling active function, set variables so that a varying string return argument will be added to end of argument list */ if processing_active_string then do; argno = argno+1; len(argno), first(argno) = 1; end; /* If a special char was seen, change inp to point to the temporary command line */ if special_char_seen then inp = temp_com_linep; /* */ /* Enter begin block which allocates space for arg list. Set up arg list and call command */ begin; dcl 1 argument_list aligned, 2 dum_ptr ptr, /* dummy ptr used to force arg list to even word boundary */ 2 twice_no_of_args bit(18) unaligned init(bit(bin(argno*2, 18), 18)), 2 tag bit(18) initial("000000000000000100"b) unaligned, 2 twice_no_of_descriptors bit(18) unaligned init(bit(bin(argno*2, 18), 18)), 2 pad bit(18) initial("0"b) unaligned, 2 argument_ptr(argno) ptr, 2 descriptor_ptr(argno) ptr; dcl 1 descriptor(argno) aligned, 2 flag bit(1) unaligned, 2 type bit(6) unaligned, 2 packed bit(1) unaligned, 2 ndims bit(4) unaligned, 2 size bit(24) unaligned; dcl (command_name_ptr initial(addr(ch(first(0)))), /* ptr to name of command to be called */ command_entry_ptr /* ptr to entry pt of command to be called */ ) ptr aligned; /* Build argument list */ do i = 1 to argno; argument_ptr(i) = addr(ch(first(i))); descriptor_ptr(i) = addr(descriptor(i)); string(descriptor(i)) = "1"b; /* init */ descriptor(i).size = bit(bin(len(i), 24)); descriptor(i).type = bit(bin(21, 6)); /* indicates non-varying string */ descriptor(i).packed = "1"b; end; /* If calling active fnc, add varying str return arg to end of arg list */ if processing_active_string then do; workspace = ""; /* default return value is "" (in case act fnc does not return value) */ argument_ptr(argno) = addrel(addr(workspace), 1); descriptor(argno).flag = "1"b; descriptor(argno).ndims = "0000"b; descriptor(argno).size = bit(bin(max_com_line, 24)); descriptor(argno).type = bit(bin(22, 6)); /* indicates varying string */ descriptor(argno).packed = "1"b; end; /* If running Limited Service System see if this is a legal command name */ if cp_data_$under_lss then do; call transform_command_(command_name_ptr, len(0), cp_data_$command_table_ptr, code); if code ^= 0 then return; end; /* Get pointer to command whose name is pointed to by command_name_ptr */ call find_command_(command_name_ptr, len(0), command_entry_ptr, code); if code ^= 0 then do; message_not_printed = "0"b; return; end; /* watch for aborted command */ on condition(command_abort_) go to ABORT_COMMAND; /* Generate a call to the command */ call cu_$gen_call(command_entry_ptr, addr(twice_no_of_args)); ABORT_COMMAND: revert condition(command_abort_); end; /* */ /* Build value to be returned (if any) */ if processing_active_string then ret_string = ret_string||workspace; /* If we are in an iteration set go process next member of set */ if in_iteration_set then do; inp = inlp; go to NEXT_ITER; end; CHECK_FOR_ANOTHER_COMMAND: /* If we had to allocate space for the first and len arrays, free it up */ if argspace_grown then do; free fp->first; free lp->len; fp = addr(actual_first(0)); lp = addr(actual_len(0)); revert condition(cleanup); argspace_grown = "0"b; end; /* If this is the end of the input, check for null command line and return */ if nch ^= ";" then do; if no_work_done then code = 100; return; end; /* We must now process the next command in the input line. We must change inp to point to the first character after the ";". Since inp must point to a word boundary, we must if necessary, blank out the ";" and characters before it and adjust inp */ nch = " "; inp = inlp; j = j+1; i = mod(j, 4); if i>0 then substr(input_line, j-i+1, i) = " "; inp = addr(ch(j-i)); inlp = inp; inl = inl-j+i; /* If we have had to use a temporary command line, deallocate the space */ if ^space_not_allocated then do; call cu_$shrink_stack_frame(temp_com_linep, code); space_not_allocated = "1"b; end; /* Since the input line is shorter, adjust the variable which keeps track of how big a space we must allocate if it is necessary to grow a temporary command line again */ temp_com_linel = inl+1; go to NEXT_COMMAND; /* ***********************************END OF SIMPLE COMMAND LOOP*********************************** */ /* */ /* The following code is only executed if an error occurs or if one of the special command language characters is seen */ MORE_COMPLICATED: m = j-i; if ^special_char_seen then do; if space_not_allocated then do; /* allocate stack space for temporary command line */ m = divide(temp_com_linel, 4, 17, 0)+1; call cu_$grow_stack_frame(m, temp_com_linep, code); if code ^= 0 then go to PRINT_MESSAGE; space_not_allocated = "0"b; end; /* copy constant part of command line into temporary */ if j>0 then substr(com_line, 1, j) = substr(input_line, 1, j); whereami = j; /* index of first free character in command line */ m = 0; special_char_seen = "1"b; end; AGAIN: /* Get ptr to beginning of free space in temporary command line */ atomp = addr(temp_com_linep->x.ch(whereami)); /* Copy part of atom before "(" if any */ if m>0 then do; substr(atom, 1, m) = substr(input_line, i+1, m); whereami = whereami+m; m = 0; go to AGAIN; end; atoml = max_com_line-whereami+1; /* maximum allowable size of returned atom */ startp = addr(ch(j)); /* ptr to beginning of special construction */ inl_left = inl-j; /* number of characters left in input line */ /* Call appropriate special syntactic construct handler */ if nch = "(" then do; in_iteration_set = "1"b; call proc_parens_(startp, inl_left, startno, atomp, atoml, lng, first_parenthesis, code); first_parenthesis = "0"b; end; else if nch = """" then call proc_quotes_(startp, inl_left, startno, atomp, atoml, lng, first_parenthesis, code); /* */ /* Check for various special conditions. The variable "end_iter" describes the state of iteration sets in this command line. If code = 0 and we were processing parens (i.e. nch = "(") then we must check whether there a previous iteration set in this command line was exhausted (e.g. an line of the form "f (a b) (c d e)" ) This is an error and is indicated by end_iter = 1. Next, if the status code = 101 then a quoted string has an iteration set as part of its tail (e. g. a line of the form "f "abd"(de qwer)". If code = 102 a bracket was seen and we must invoke the bracket processor. If code = 103 then we have just found an exhausted iteration set. If a previous iteration set in the command line was not exhausted, indicated by end_iter = 2 this is an error (e.g. a line of the form "f (a b c) (d e)" ) */ if code = 0 then if nch = "(" then if end_iter = 1 then go to MISMATCHED_ITER; else end_iter = 2; else; else if code = 101 then do; code = 0; in_iteration_set = "1"b; end; /* case "abc"(def ghj) */ else if code = 102 then do; j = j+startno; go to CALL_PROC_BRACKETS; end; /* "[" seen */ else if code = 103 then do; if end_iter = 2 then go to MISMATCHED_ITER; end_iter = 1; code = 0; goto UPDATE_STARTNO; end; else do; PRINT_MESSAGE: call com_err_(code, "command_processor_"); message_not_printed = "0"b; return; end; /* If no error has occured in the processing of this special syntactic construct, then go process the next atom */ len(argno) = lng+j-i; whereami = whereami+lng; UPDATE_STARTNO: startno = startno+j; go to NEXT_ATOM; MISMATCHED_ITER: code = error_table_$mismatched_iter; go to PRINT_MESSAGE; /* */ /* BRACKETS SEEN IN COMMAND LINE */ CALL_PROC_BRACKETS: /* Allocate space for returned string if necessary. (Allocation is necessary if this is the first time we are calling proc_brackets_ or if we are processing a line of the form "ff [f x; g [h z]]". In the latter case we need the space for the value returned by the fnc h, since otherwise it would "overwrite" the value already returned by the fnc f) */ if ^processing_active_string then GET_SPACE: begin; dcl (return_string, working_space) char(max_com_line) var init(""); if ^processing_active_string then call proc_brackets_(inp, inl, j, max_com_line, return_string, working_space, code); else do; /* case: "ff [f x; g [h z]]" */ call proc_brackets_$nested_brackets(inp, inl, j, max_com_line, return_string, working_space, code); /* Concatenate the value returned by the fnc g applied to "[h z]" with the value already returned by f */ ret_string = ret_string||return_string; end; end; else if semicolon_seen then go to GET_SPACE; else call proc_brackets_$nested_brackets(inp, inl, j, max_com_line, ret_string, workspace, code); /* Command line with brackets has been processed. Check for nonzero error code. If so, print error message and return. Otherwise, go process next command in input line */ if code ^= 0 then if code ^= 100 then if message_not_printed then go to PRINT_MESSAGE; return; /* */ /* Internal procedure to allocate space for information about the arguments (namely the first and len arrays). It frees up the current arrays, if they were allocated */ grow_space: proc; dcl system_area area based(area_ptr); dcl old_arg_limit fixed bin aligned; dcl area_ptr internal static ptr aligned initial(null); dcl space(0:arg_limit) fixed bin aligned based; dcl get_system_free_area_ ext entry(ptr); /* Get pointer to the system free area in this ring, if we have not already done so */ if area_ptr = null then call get_system_free_area_(area_ptr); /* Save current size of arg info. Increase size (doubling each time called) */ old_arg_limit = arg_limit; arg_limit = arg_limit+2*arg_limit; /* Allocate space for more arg info */ argspace_grown = "1"b; allocate space in (system_area) set (tfp); allocate space in (system_area) set (tlp); /* Copy existing arg info into the newly allocated space */ arg_limit = old_arg_limit; tfp->space = fp->space; tlp->space = lp->space; /* If current arg info was allocated (i. e. not in stack), free it up */ if fp ^= addr(actual_first(0)) then free fp->space; if lp ^= addr(actual_len(0)) then free lp->space; /* Restore arg_limit. If called while evaluating active function, lower arg_limit to allow for return argument. Set pointers, null out tfp and tlp so the cleanup procedure will not get confused if a certain race condition occurs */ arg_limit = arg_limit+2*arg_limit; if processing_active_string then arg_limit = arg_limit-1; fp = tfp; lp = tlp; tfp, tlp = null; return; end grow_space; /* */ /* Cleanup procedure which frees any allocated arg info. */ cleanup_proc: proc; /* If we were interrupted after allocation of new space and before fp and/or lp were set, free up appropriate space */ if tfp ^= null then if tfp ^= fp then free tfp->first; if tlp ^= null then if tlp ^= lp then free tlp->first; /* if fp and lp point to allocated space, free it up */ if fp ^= null then if fp ^= addr(actual_first(0)) then free fp->first; if lp ^= null then if lp ^= addr(actual_len(0)) then free lp->len; end cleanup_proc; /* */ /**********************************************************************************************/ /* Entry point called by proc_brackets_ and proc_brackets_$nested_brackets to invoke active functions and pass back their return strings */ return_val: entry(input_linep, input_linel, iflag, ret_string, workspace, code); dcl iflag bit(1) aligned; /* indicates whether or not brackets should be ignored */ dcl (ret_string, /* ret arg to be passed back to proc_brackets */ workspace /* space in which to store intermediate results */ ) char(*) var; processing_active_string = "1"b; ignore_brack = iflag; go to START; /**********************************************************************************************/ /* This entry is called by proc_brackets after it has built a "bracketless" command line, and wants to execute the result */ ignore_brackets: entry(input_linep, input_linel, iflag, code); processing_active_string = "0"b; ignore_brack = iflag; go to START; /**********************************************************************************************/ /* Entry point to set maximum command line size */ set_line: entry(newsize); dcl newsize fixed bin; max_com_line = newsize; return; /**********************************************************************************************/ /* Entry point to get the current maximum command line size */ get_line: entry(newsize); newsize = max_com_line; return; /**********************************************************************************************/ /* Entry point to cause command processor to check all commands against a given table before invoking them. Used by the Limited Service System and various other limited command systems */ setup_lss: entry(table_ptr); dcl table_ptr ptr; cp_data_$under_lss = "1"b; cp_data_$command_table_ptr = table_ptr; return; /**********************************************************************************************/ /* Entry point to leave "lss mode". Left in for debugging purposes */ reset_lss: entry; cp_data_$under_lss = "0"b; return; end full_command_processor_;  eval_ec_if_test_.pl1 09/25/78 1427.2rew 09/25/78 1427.2 16047 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ eval_ec_if_test_: proc(line_ptr,line_length,index_of_bracket,value,code); dcl line_ptr ptr; dcl code fixed bin(35) aligned; dcl (line_length, index_of_bracket, max_com_line ) fixed bin; dcl value char(8) aligned; dcl full_command_processor_$get_line ext entry(fixed bin); dcl (addr, length, substr, verify) builtin; /* Get size of maximum expanded command line */ code=0; call full_command_processor_$get_line(max_com_line); /* Enter begin block to allocate space for returned value */ begin; dcl pad bit(1) aligned, (i, l) fixed bin; dcl (ret_string, workspace ) char(max_com_line) var; dcl proc_brackets_$return_value ext entry(ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin, char(*) var,char(*) var,fixed bin(35)); /* Call part of command processor to evaluate the active function */ call proc_brackets_$return_value(line_ptr,line_length-1,index_of_bracket-1,pad,max_com_line, ret_string,workspace,code); l = length(ret_string); /* Following code is used to strip off leading blanks from returned value, since proc_brackets_ copies original string (blanks in this case) up to the left bracket */ if l>0 then do; i = verify(ret_string," "); value = substr(ret_string,i,l-i+1); end; else value = ""; end; end eval_ec_if_test_;  set_com_line.pl1 09/25/78 1427.2rew 09/25/78 1427.2 15210 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ set_com_line: scl: procedure; /* initially coded in February 1970 by V. Voydock */ /* modified on February 8, 1970 at 2:45 P. M. by V. Voydock */ /* Modified 761025 by PG to convert to Version 2 PL/I */ /* automatic */ dcl arg_len fixed bin (21), arg_ptr ptr, code fixed bin (35), size fixed bin (21); /* based */ dcl arg_string char (arg_len) based (arg_ptr); /* entries */ dcl com_err_ entry options (variable), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cv_dec_ entry (char (*)) returns (fixed bin (35)), command_processor_$set_line entry (fixed bin (21)), command_processor_$get_line entry (fixed bin (21)), ioa_ entry options (variable); /* program */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then size = 132; else do; size = cv_dec_ (arg_string); if size <= 0 then do; call com_err_ (0, "set_com_line", "Invalid command line size ""^a"".", arg_string); return; end; end; call command_processor_$set_line (size); return; get_com_line: gcl: entry; call command_processor_$get_line (size); call ioa_ ("Maximum expanded command line = ^d characters.", size); return; end;  proc_brackets_.pl1 09/25/78 1427.2rew 09/25/78 1427.2 84582 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ proc_brackets_: proc(inputlinep,inputlinel,brackind,max_com_line,ret_string,workspace,code); /* initially coded in January 1970 by V. Voydock */ /* Modified to handle recursive active functions correctly in all cases in June 1971 by V. Voydock */ /* Modified in April 1972 to handle quoted return strings correctly by V. Voydock */ /* Modified in May 1972 as part of fast command loop */ dcl (inputlinel, brackind, max_com_line, /* maximum expanded command line size */ code, lng, i, should_not_rescan, ind init(brackind), /* index of bracket in inputline */ error_table_$unbalanced_brackets external, error_table_$null_brackets external, error_table_$command_line_overflow external, j, bracketless_str_lng init(0), /* lng of bracketless string before [ or after ] */ built_cline_lng init(1), /* current lng of bracketless command line being built */ first_input_char init(1) /* index of first input char of current bracket pair */ ) fixed bin; dcl (ignoreb init("0"b), not_in_quoted_string ) bit(1) aligned, should_return_value bit(2) aligned; dcl (inputlinep, inp init(inputlinep), clinep ) ptr; dcl ret_string char(*) var, /* string to hold value returned (a parameter) */ workspace char(*) var, /* space in which to store intermediate results */ comline char(max_com_line) aligned, /* bracketless command line being built */ inputline char(inputlinel) based(inp) aligned, nch char(1) aligned; dcl 1 x based(inp) aligned, 2 ch(0:31) char(1) unaligned; dcl full_command_processor_$ignore_brackets ext entry(ptr,fixed bin,bit(1) aligned,fixed bin), full_command_processor_$return_val ext entry(ptr,fixed bin,bit(1) aligned,char(*) var,char(*) var,fixed bin), proc_brackets_$return_value ext entry(ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin, char(*) var,char(*) var,fixed bin); dcl (addr,mod,substr,divide,index,length) builtin; /* */ code=0; should_return_value="00"b; PROCESS_NEXT_BRACKET_PAIR: /* See if "|[" in input line */ if ch(ind-1)="|" then do; ignoreb="1"b; should_not_rescan=1; end; else should_not_rescan=0; /* Calculate lng of bracketless string before next bracket pair */ bracketless_str_lng=ind-should_not_rescan-first_input_char+1; /* Copy the bracketless prefix string into the command line being built */ call copy_bracketless_string(); if code^=0 then return; /* Find the end of the bracket pair being processed */ call find_matching_right_bracket(); if code^=0 then return; /* Calculate the index of the first character of the bracket pair to be evaluated. It must start on a word boundary, so we adjust it if necessary. We then blank out the string which will hold the returned result */ ind=ind+1; i=mod(ind,4); /* find out if ind points to word boundary */ if i>0 then substr(inputline,ind-i+1,i)=" "; ret_string=""; /* */ /* Call command processor to evaluate contents of bracket pair and return value to be inserted in command line being built */ call full_command_processor_$return_val(addr(ch(ind-i)),j-ind+i,"0"b,ret_string,workspace,code); if code^=0 then do; if code=100 then code=error_table_$null_brackets; return; end; lng=length(ret_string); /* Returned string should be inserted into command line being built without scanning it for brackets */ if should_not_rescan=1 then go to ADD_STRING_TO_LINE; /* Returned string should be scanned for brackets. If any are found they must be evaluated and their value inserted into the command line */ if index (ret_string, "[") = 0 then goto ADD_STRING_TO_LINE; /* check if there are any brackets at all */ not_in_quoted_string="1"b; do i=1 to lng; nch=substr(ret_string,i,1); if nch="[" then if not_in_quoted_string then go to BRACKET_FOUND; else; else if nch="""" then if i=lng then not_in_quoted_string=^not_in_quoted_string; else if substr(ret_string,i+1,1)="""" then i=i+1; else not_in_quoted_string=^not_in_quoted_string; end; /* There was no bracket in the string returned by the active function */ go to ADD_STRING_TO_LINE; BRACKET_FOUND: /* Allocate space to copy returned string. */ begin; dcl rescanline char(lng) aligned; /* Copy returned string into temporary */ rescanline=ret_string; /* Clear old returned string and call proc_brackets recursively to determine value of bracketed string that was returned */ ret_string=""; call proc_brackets_$return_value(addr(rescanline),lng-1,i-1,ignoreb,max_com_line,ret_string,workspace,code); end; lng=length(ret_string); ADD_STRING_TO_LINE: if lng>max_com_line-built_cline_lng+1 then do; code=error_table_$command_line_overflow; return; end; substr(comline,built_cline_lng,lng)=ret_string; built_cline_lng=built_cline_lng+lng; /* */ /* We have finished evaluating a bracket pair. Now let us find the next one and process it */ not_in_quoted_string="1"b; do ind=j+1 to inputlinel; nch=ch(ind); if nch="[" then if not_in_quoted_string then do; first_input_char=j+2; go to PROCESS_NEXT_BRACKET_PAIR; end; else; else if nch="""" then if ind=inputlinel then not_in_quoted_string=^not_in_quoted_string; else if ch(ind+1)="""" then ind=ind+1; else not_in_quoted_string=^not_in_quoted_string; end; /* The end of the input line has been reached */ first_input_char=j+2; bracketless_str_lng=inputlinel-j; /* Copy the bracketless suffix string into the command line being built */ call copy_bracketless_string(); if code^=0 then return; /* */ /* We have built a command line which either does not contain brackets or contains brackets which should be ignored. */ built_cline_lng=built_cline_lng-1; /* If the call was via the "return_value" entry, return the command line just built. This is the case of recursive active functions */ if should_return_value="11"b then do; iflag=ignoreb; ret_string=substr(comline,1,built_cline_lng); return; end; /* Otherwise we call the command processor at the appropriate entry */ ret_string=""; clinep=addr(comline); if should_return_value then call full_command_processor_$return_val(clinep,built_cline_lng,ignoreb,ret_string,workspace,code); else call full_command_processor_$ignore_brackets(clinep,built_cline_lng,ignoreb,code); return; /* */ /* This entry is called when a recursive active function is encountered. That is, an active function whose value is another active function. The parameter iflag is necessary so that this entry can tell its caller if a line containing brackets which are to be ignored is being returned. For example if "[f]" returns the value "[h]" which returns the value "|[g]" */ return_value: entry(inputlinep,inputlinel,brackind,iflag,max_com_line,ret_string,workspace,code); dcl iflag bit(1) aligned; code = 0; should_return_value="11"b; go to PROCESS_NEXT_BRACKET_PAIR; /* This entry is called by full_command_processor_$return_val if a nested bracket is encountered. For example the line "[F x [g y] ]" It builds a bracketless command line by evaluating all the nested brackets. It then evaluates this command line and returns its value to its caller. In the example, suppose "[g y]" returns the value "foo" and suppose [f x foo] returns the value "hello", then nested_brackets will return the value "hello" to return_val */ nested_brackets: entry(inputlinep,inputlinel,brackind,max_com_line,ret_string,workspace,code); code = 0; should_return_value="01"b; go to PROCESS_NEXT_BRACKET_PAIR; /* */ /* Internal procedure to copy bracketless strings into command line being built */ copy_bracketless_string: proc; if bracketless_str_lng>max_com_line-built_cline_lng+1 then do; code=error_table_$command_line_overflow; return; end; substr(comline,built_cline_lng,bracketless_str_lng)=substr(inputline,first_input_char,bracketless_str_lng); built_cline_lng=built_cline_lng+bracketless_str_lng; end copy_bracketless_string; /* */ /* Internal procedure to find the right bracket which matches the left bracket of the active string being processed */ find_matching_right_bracket: proc; dcl (lcnt, rcnt ) fixed bin initial(0); not_in_quoted_string="1"b; do j=ind+1 to inputlinel; nch=ch(j); if nch="]" then if not_in_quoted_string then if lcnt=rcnt then return; else rcnt=rcnt+1; else; else if nch="[" then if not_in_quoted_string then lcnt=lcnt+1; else; else if nch="""" then if j=inputlinel then not_in_quoted_string=^not_in_quoted_string; else if ch(j+1)="""" then j=j+1; else not_in_quoted_string=^not_in_quoted_string; end; code=error_table_$unbalanced_brackets; /* Brackets do not balance */ return; end find_matching_right_bracket; end proc_brackets_;  proc_parens_.pl1 09/25/78 1427.2rew 09/25/78 1427.2 126297 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ proc_parens_: proc(input_linep,input_line_lng,last_char_of_iter_set,atomp,atom_buffer_lng,atom_lng,first_call,code); /* initially coded in January 1970 by V. Voydock */ /* modified on February 12, 1970 at 9:15 P. M. by V. Voydock */ /* modified to accept new quoting convention and to not expect lines to end with a new line char in June 1971 by V. Voydock */ /* Extensively reorganized for clarity (taking advantage of fast internal procedures in version 2 pl1) and to fix bug which caused quoted strings to be occasionally ignored in March 1972 by V. Voydock */ /* EIS version S. Herbst 3/4/74 */ dcl (input_line_lng, /* length of input line to be processed (INPUT) */ last_char_of_iter_set, /* index of first char to be scanned when control returns to caller (OUTPUT) */ atom_buffer_lng, /* amt of space avail. to store atom being built by this proc (INPUT) */ atom_lng, /* length of atom built by this procedure (OUTPUT) */ end_of_simple_head, /* index of first char after the end of the simple head (e.g. in (a b) the space immediately following the "a". In (asd(1 2) z) the "(" immediately following the "d" */ first_nonblank, /* index of first nonblank character in input line */ j,k, /* Temporary variables */ last_char_of_head, /* index of the last char in the head of the iteration set. (e. g. in (a(b d) def)x"y"(1 2) the head is (a(b d) def) the tail x"y"(1 2) */ end_of_simple_tail, /* index of first char after simple tail (e. g. in (a b)DEF; the ";" in (a b)DEF(1 2) the "(" immediately after the F */ first_char initial(1), /* index of first char being processed (value changes during processing) */ last_char_of_atom, /* index of current last character in atom being built */ simple_tail_lng, /* length of simple tail part. In (a b)DEF"a c" DEF is s. t. p. */ right_paren_cnt, /* count of number of right parenthesis seen */ left_paren_cnt /* count of number of left parentheses seen */ ) fixed bin aligned; dcl (code, error_table_$mismatched_iter external, error_table_$unbalanced_parentheses external ) fixed bin(35) aligned; dcl (in_quoted_string initial("0"b), /* True if char being scanned is inside quoted string */ nonsimple_tail initial("0"b), /* Indicates (a b)DE"1 2" or (a b)DE(1 2) as opposed to (a b)DE */ quote_inside_parens initial("0"b), /* Indicates ("ABC") as opposed to (ABC)"DEF" */ paren_inside_parens initial("0"b), /* Indicates ( a(b c)) as opposed to (a b)(d e) */ attached_iter_set, /* True if case (a(b ...) ...) or (a ...)bcd(q ...) */ first_call /* True if this is first time procedure was called for this line */ ) bit(1) aligned; dcl (input_linep, /* pointer to input line to be processed (INPUT) */ atomp /* pointer to space in which to store atom being built (INPUT) */ ) ptr aligned; dcl input_line char(input_line_lng+1) based(input_linep), /* based structure to reference input */ atom char(atom_buffer_lng) based(atomp), /* based string to reference atom */ ch(0:31) char(1) unaligned based(input_linep), /* based array to get single chars of input */ nch char(1) aligned, /* character currently being scanned */ nl char(1) aligned internal static initial(" "); /* new line character */ dcl (addr,search,substr) builtin; /* */ code=0; /* If this is first invocation search for "[" in input line. Otherwise the case "(a b) [f x]" will not work. We search to first ";" or to end */ if first_call then if search(input_line,"[]")^=0 then call check_for_bracket; if code^=0 then return; START: last_char_of_atom=0; attached_iter_set="0"b; /* Skip leading blanks */ do first_nonblank=first_char to input_line_lng while(ch(first_nonblank)=" "); end; /* Build "atom" to be returned */ end_of_simple_head = search(substr(input_line,first_nonblank+1,input_line_lng-first_nonblank+1)," ();"" "); if end_of_simple_head=0 then go to UNBALANCED_PARENS; end_of_simple_head = end_of_simple_head + first_nonblank - 1; nch=ch(end_of_simple_head); if nch=" " then /* Case: (ab_ ...) where "_" represents a blank */ do; first_char=end_of_simple_head+1; call find_matching_right_paren; if code^=0 then return; last_char_of_atom=end_of_simple_head-first_nonblank; go to END_PAREN_PAIR; end; if nch=")" then do; nch=ch(end_of_simple_head-1); if nch=" " then go to NULL_ITER_SET; /* Case: ( ) */ if nch="(" then go to NULL_ITER_SET; /* Case: () */ last_char_of_head=end_of_simple_head; /* Case: ( ab) */ last_char_of_atom=end_of_simple_head-first_nonblank; go to END_PAREN_PAIR; end; if nch="(" then /* Case: (ab( ... ) ... ) */ do; attached_iter_set,paren_inside_parens="1"b; PROC_SPEC_CHAR: last_char_of_atom=end_of_simple_head-first_nonblank; call process_special_char(end_of_simple_head); quote_inside_parens,paren_inside_parens="0"b; if code=-1 then do; code=0; go to START; end; /* Case: (ab( ) ... ) */ if code^=0 then return; call find_matching_right_paren; if code^=0 then return; go to END_PAREN_PAIR; end; if nch="""" then do; quote_inside_parens="1"b; go to PROC_SPEC_CHAR; end; /* Case: ("a"...) */ if nch=";" then go to UNBALANCED_PARENS; if nch=nl then go to UNBALANCED_PARENS; /* */ END_PAREN_PAIR: /* Process the "tail". e. g. in "(a b c(d e))fg(h k)" the tail is "fg(h k)" */ end_of_simple_tail = search(substr(input_line,last_char_of_head+2,input_line_lng-last_char_of_head)," ();"" "); if end_of_simple_tail=0 then do; end_of_simple_tail = input_line_lng + 1; go to DO_TAIL; end; end_of_simple_tail = end_of_simple_tail + last_char_of_head; nch=ch(end_of_simple_tail); if nch=" " then go to DO_TAIL; /* Case: (a b)de_ where "_" represents a blank */ if nch=";" then go to DO_TAIL; /* Case: (a b)de; */ if nch=nl then go to DO_TAIL; /* Case: (a b)de% where "%" represents a new line character */ if nch=")" then go to DO_TAIL; /* Case: ((a b)de(f g)) */ if nch="(" then do; nonsimple_tail="1"b; go to DO_TAIL; end; /* Case: (a b)de(f g) */ if nch="""" then do; nonsimple_tail="1"b; go to DO_TAIL; end; /* Case: (a b)de"xyz" */ /* Calculate the length of tail before first special character */ DO_TAIL: simple_tail_lng=end_of_simple_tail-last_char_of_head-1; /* Copy simple portion of the tail (if any) into the atom being built. (e. g. in (a b)DEF"1 2" then tail is DEF"1 2" and the simple portion of the tail is DEF ) */ if simple_tail_lng^=0 then do; substr(atom,last_char_of_atom+1,simple_tail_lng)=substr(input_line,last_char_of_head+2,simple_tail_lng); last_char_of_atom=last_char_of_atom+simple_tail_lng; end; /* If the tail has a special character in it (e.g. (a b)DEF"1 2" or (a b)DEF(1 2) ) then call subroutine to process it */ if nonsimple_tail then do; call process_special_char(end_of_simple_tail); if code^=0 then return; end; else first_char=end_of_simple_tail; /* Now fill in the part of the atom which appears before the first special character. (e g. in (ASDF"1 2")qwer fill in ASDF. Blank it out in the input line unless it is attached to another iteration set (e. g. in (a b(de fgh)) the "a" is not attached and the "b" is. Set variables indicating no errors, the length of the atom being returned, and where the caller should continue the scan of the input line, and return. */ k=end_of_simple_head-first_nonblank; if k>0 then do; substr(atom,1,k)=substr(input_line,first_nonblank+1,k); if ^attached_iter_set then substr(input_line,first_nonblank+1,k)=" "; end; last_char_of_iter_set=first_char; atom_lng=last_char_of_atom; code=0; return; UNBALANCED_PARENS: code=error_table_$unbalanced_parentheses; return; /* */ /* We are processing a null iteration set */ NULL_ITER_SET: left_paren_cnt,right_paren_cnt=0; in_quoted_string="0"b; code=103; /* Find end of null iteration group. i. e. we are cleaning up a case of the ... ( )bc"d e;"( a) ... The variable "in_quoted_string" indicates that we are inside a quoted string and that characters which otherwise would terminate the scan or indicate an error condition should be treated as ordinary characters */ do k = end_of_simple_head+1 to input_line_lng; nch=ch(k); if nch=" " then do; if in_quoted_string then go to END_LOOP; /* case: ( )"abc def" */ if left_paren_cnt=right_paren_cnt then go to END_NULL_ITER_SET; end; else if (nch=";") | (nch=nl) then do; if in_quoted_string then go to END_LOOP; /* case: ( )";" or ( )"nl" */ go to END_NULL_ITER_SET; end; else if nch="""" then if k=input_line_lng then in_quoted_string=^in_quoted_string; else if ch(k+1)="""" then k=k+1; else in_quoted_string=^in_quoted_string; else if nch=")" then do; if in_quoted_string then go to END_LOOP; /* case: ( )")" */ if left_paren_cnt=right_paren_cnt then go to END_NULL_ITER_SET; /* case ( )) e. g. in atom of form: ((( )) abc) */ right_paren_cnt=right_paren_cnt+1; end; else if nch="(" then do; if in_quoted_string then go to END_LOOP; /* case ( )"(" */ left_paren_cnt=left_paren_cnt+1; end; else if left_paren_cnt^=right_paren_cnt then /* case: (ab( )XY(1 2)) */ do; code=error_table_$mismatched_iter; return; end; END_LOOP: end; /* We have found the end of the null iteration set */ END_NULL_ITER_SET: last_char_of_iter_set=k; return; /* */ /* Internal procedure to find the matching right parenthesis in the iteration set we are now processing */ find_matching_right_paren: proc; left_paren_cnt,right_paren_cnt=0; last_char_of_head = first_char-1; FIND_LOOP:j = last_char_of_head; last_char_of_head = search(substr(input_line,j+2,input_line_lng-j),"();"" "); if last_char_of_head=0 then go to BAD; last_char_of_head = last_char_of_head + j; nch=ch(last_char_of_head); if nch=")" then if ^in_quoted_string then if left_paren_cnt=right_paren_cnt then return; else right_paren_cnt=right_paren_cnt+1; else; else if nch="(" then if ^in_quoted_string then left_paren_cnt=left_paren_cnt+1; else; else if (nch=";") | (nch=nl) then if ^in_quoted_string then go to BAD; else; else if nch="""" then if last_char_of_head=input_line_lng then in_quoted_string=^in_quoted_string; else if ch(last_char_of_head+1)="""" then last_char_of_head=last_char_of_head+1; else in_quoted_string=^in_quoted_string; if last_char_of_head < input_line_lng then go to FIND_LOOP; BAD: code=error_table_$unbalanced_parentheses; return; end find_matching_right_paren; /* */ /* Internal procedure to search command line for a left bracket */ check_for_bracket: proc; dcl error_table_$unbalanced_brackets external fixed bin(35) aligned; k = 0; CHECK_LOOP:j = k; k = search(substr(input_line,j+2,input_line_lng-j),"[];"" "); if k=0 then return; k = k+j; nch=ch(k); if nch="""" then if k=input_line_lng then in_quoted_string=^in_quoted_string; else if ch(k+1)="""" then k=k+1; else in_quoted_string=^in_quoted_string; else if nch="[" then if ^in_quoted_string then do; last_char_of_iter_set=k; code=102; return; end; else; else if (nch=";") | (nch=nl) then if ^in_quoted_string then return; else; else if nch="]" then if ^in_quoted_string then do; code=error_table_$unbalanced_brackets; return; end; if k < input_line_lng then go to CHECK_LOOP; end check_for_bracket; /* */ /* Internal procedure to process quoted strings and iteration sets encountered while processing this iteration set */ process_special_char: proc(special_char_index); dcl (startp, atmp ) ptr aligned; dcl (special_char_index, atoml, lng, inl_left ) fixed bin aligned; dcl (proc_parens_, proc_quotes_ ) ext entry(ptr,fixed bin,fixed bin,ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin(35)); /* Set up arguments with which to call special syntatic subroutines */ startp=addr(ch(special_char_index)); atmp=addr(atomp->ch(last_char_of_atom)); atoml=atom_buffer_lng-last_char_of_atom; inl_left=input_line_lng-special_char_index; if nch="(" then call proc_parens_(startp,inl_left,first_char,atmp,atoml,lng,"0"b,code); else call proc_quotes_(startp,inl_left,first_char,atmp,atoml,lng,"0"b,code); if nch="""" then if quote_inside_parens then if code=101 then do; attached_iter_set="1"b; code=0; end; /* case ("ab"(d qwe)) */ else if code=103 then paren_inside_parens="1"b; /* case ("ab"( )) */ else substr(input_line,end_of_simple_head+1,first_char)=" "; /* case ("a" de) or ("a"2 def) */ else if code=101 then code=0; /* case (a b)"def" */ if code^=0 then if code^=103 then return; else if paren_inside_parens then /* Case: (ab( ) d) We must blank out used up set, i.e. ab( ) */ do; substr(input_line,first_nonblank+1,first_char+end_of_simple_head-first_nonblank)=" "; code=-1; return; end; else do; code=error_table_$mismatched_iter; return; end; /* case (ab(cd er)d( ) z) */ first_char=first_char+special_char_index; last_char_of_atom=last_char_of_atom+lng; return; end process_special_char; end proc_parens_;  proc_quotes_.pl1 09/25/78 1427.2rew 09/25/78 1427.2 35235 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ proc_quotes_: proc(a_inp,inl,last_char_scanned,a_atomp,spaceleft,atomlng,first_parenthesis,code); /* initially coded in January 1970 by V. Voydock */ /* Modified to use PL/I quoting convention in June 1971 by V. Voydock */ /* EIS version Steve Herbst 3/4/74 */ dcl (inl, startno, i,j,k, last_char_scanned, length_of_quoted_string initial(0), length_of_tail, lng, spaceleft, atomlng ) fixed bin; dcl (code, error_table_$unbalanced_quotes external, error_table_$unbalanced_brackets external ) fixed bin(35); dcl first_parenthesis bit(1) aligned; dcl (inp initial(a_inp), atomp initial(a_atomp), a_inp, a_atomp ) ptr; dcl nch char(1) aligned, atom char(spaceleft) based(atomp), input_line char(inl+1) based(inp); dcl special char(8) init(" ;()"" []"); dcl proc_parens_ ext entry(ptr,fixed bin,fixed bin,ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin(35)); dcl (addr, index, search, substr) builtin; dcl ich(0:31) char(1) unaligned based(inp), ach(0:31) char(1) unaligned based(atomp); /* */ last_char_scanned,code=0; /* Look for a second quote. If it is followed immediately by another quote, keep on going. Quoted string gets copied into the atom being built. */ LOOP: j = last_char_scanned; again: i = j; j = index(substr(input_line,i+2,inl-i),""""); if j=0 then go to UNBALANCED; j = j+i; if j=inl then do; nch = " "; go to END_QUOTE; end; if ich(j+1)="""" then do; substr(atom,length_of_quoted_string+1,j-i) = substr(input_line,i+2,j-i); length_of_quoted_string = length_of_quoted_string + j - i; j = j+1; go to again; end; else go to END_QUOTE; UNBALANCED: code = error_table_$unbalanced_quotes; return; END_QUOTE:k = j-i-1; if k>0 then substr(atom,length_of_quoted_string+1,k) = substr(input_line,i+2,k); length_of_quoted_string = length_of_quoted_string + k; /* Now see if anything is attached to quoted string (e. g. "abc"(def ghj) ) */ last_char_scanned = search(substr(input_line,j+2,inl-j),special); if last_char_scanned=0 then do; last_char_scanned = inl+1; nch = " "; go to PROC_TAIL; end; last_char_scanned = last_char_scanned + j; nch=ich(last_char_scanned); i = index(special,nch); if i<7 then go to PROC_TAIL; if i=7 then do; code = 102; return; end; else do; code = error_table_$unbalanced_brackets; return; end; PROC_TAIL: /* Compute length of "tail". Then copy it into the atom being built */ length_of_tail=last_char_scanned-j-1; if length_of_tail=0 then go to CHECK; substr(atom,length_of_quoted_string+1,length_of_tail)=substr(input_line,j+2,length_of_tail); /* If paren terminates tail, call paren handler, if quote, loop back, else return */ CHECK: if nch^="(" then if nch^="""" then go to RETURN; else do; length_of_quoted_string=length_of_quoted_string+length_of_tail; go to LOOP; end; /* Call parenthesis handler to take care of rest of atom */ call proc_parens_(addr(ich(last_char_scanned)),inl-last_char_scanned,startno, addr(ach(length_of_quoted_string+length_of_tail)), spaceleft-length_of_quoted_string-length_of_tail,lng,first_parenthesis,code); /* Bump indices, indicate that we are processing iteration set and return */ length_of_tail=length_of_tail+lng; last_char_scanned=last_char_scanned+startno; if code=0 then code=101; RETURN: atomlng=length_of_quoted_string+length_of_tail; return; end proc_quotes_;  full_find_command_.pl1 12/19/78 1859.9rew 12/19/78 1859.9 95085 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ full_find_command_: proc(am_ptr,comp,coml,entry_point_ptr,code); /* find_command_ ..... standard service subroutine to return a pointer to a command entry point, given the command name as it originally appeared in the command line. */ /* Initial coding by R. C. Daley,December 1969 */ /* modified on June 23,1970 at 3:35 P. M. by V. Voydock */ /* Modified in November 1971 by V. Voydock to not blow up if a command of the form "name is typed, to force pathnames to override previously known reference names, and to make the code more readible */ /* Modified in May 1972 by V. Voydock as part of the fast command loop */ /* Modified 6/24/76 by S. Herbst to fix bugs */ /* ******************************************************************************************************* N_O_T_E_: The case of a pathname being passed (ie pointed to by "comp") is not as simple as it may seem. Let X be the reference name (i. e. entry name) portion of the pathname. Several cases may occur. The segment whose pathname was passed may already be known to the process (either by the reference name X or another reference name), or another segment may be known to the process by the reference name X, or X may not be known to the process. In _a_l_l cases, the name X may or may not exists in the AM. This procedure has been carefully coded to account for all these cases. It should not be changed casually ******************************************************************************************************* */ dcl (comp, p, entry_point_ptr, am_ptr, oldp, cp ) ptr; dcl (coml, command_length, ename_length, entry_index initial(0), entry_length initial(0), oldu, aml int static initial(9), /* Size of associative memory */ i, j ) fixed bin; /* */ dcl (pathname_given, print_message, am_entry_exists, term_called, pathname_error ) bit(1) aligned init("0"b); dcl 1 w aligned, /* temporary for high speed comparison */ 2 (c1,c2,c3,c4) fixed bin(71), /* of command name (char(32)),*/ 2 (s1,s2,s3,s4) fixed bin(71); /* and entry name (char(32)). */ dcl 1 cs based(cp) aligned, /* dcl for initialization of above structure */ 2 command char(32), 2 entry char(32); dcl 1 am(0:9) based(am_ptr) aligned, /* declaration of associative memory */ 2 command(2) fixed bin(71), /* space for command name */ 2 entry_point_ptr ptr, /* pointer to command entry */ 2 usage fixed bin; /* usage indicator */ dcl 1 ame based(p) aligned, /* based declaration for entry of assoc. mem. */ 2 command char(16), 2 entry_point_ptr ptr, 2 usage fixed bin; dcl 1 aw based(p) aligned, /* dcl for associative memory lookup */ 2 (c1,c2) fixed bin(71); /* command name (char(32)) */ dcl name char(168) based(p) unaligned, /* based dcl for pickup of command name */ dname char(168), /* for pickup of expanded directory name */ buffer char(168), /* for ename (which might be >32) */ nch char(1) aligned, cname char(coml) based(comp), /* name to be printed on error */ ch(0:167) char(1) unaligned based(p); dcl SPACE char(2) int static options(constant) init(" "); /* blank and tab */ dcl code fixed bin(35) aligned; dcl error_table_$seg_not_found fixed bin(35) ext, /* standard error codes used by find_command_ */ error_table_$namedup fixed bin(35) ext, error_table_$segknown fixed bin(35) ext, error_table_$bad_command_name fixed bin(35) ext, error_table_$dirseg fixed bin(35) ext, error_table_$entlong fixed bin(35) ext, error_table_$noentry fixed bin(35) ext, error_table_$no_ext_sym fixed bin(35) ext; dcl expand_pathname_ entry(char(*),char(*),char(*),fixed bin(35)), term_$no_clear ext entry(char(*) aligned,fixed bin(35)), hcs_$initiate ext entry(char(*) aligned,char(*) aligned,char(*) aligned,fixed bin,fixed bin,ptr,fixed bin(35)), hcs_$make_ptr ext entry(ptr,char(*) aligned,char(*) aligned,ptr,fixed bin(35)), (com_err_, com_err_$suppress_name ) external entry options(variable); dcl (addr, index, length, null, rtrim, substr, verify) builtin; /* */ print_message="1"b; go to START; fc_no_message: entry(am_ptr,comp,coml,entry_point_ptr,code); /* for the use of find_command_$fc_no_message */ print_message = "0"b; go to START; fc_print_message: entry(comp,coml,entry_point_ptr,code); /* this was put in for the use of init_admin */ print_message="0"b; START: if cname=">" then do; /* command name ">" */ code = error_table_$dirseg; go to ERROR; end; if verify(cname,SPACE)=0 then do; /* blank command name */ BLANK: if print_message then call com_err_(0,"command_processor_","Blank command name."); code = error_table_$seg_not_found; return; end; p = comp; command_length=coml; /* Look for pathname and for entry name explicitly specified (i. e. "$") */ do i=0 to command_length-1; nch=ch(i); if nch=">" then pathname_given="1"b; if nch="<" then pathname_given="1"b; if nch="$" then do; command_length=i; /* if entry found,adjust command name length */ if command_length=0 then do; code=error_table_$bad_command_name; go to ERROR; end; entry_index=command_length+2; /* locate first character of entry */ entry_length = length(rtrim(cname))-entry_index+1; /* get length of entry name */ if entry_length=0 then do; ENTNULL: code = error_table_$bad_command_name; go to ERROR; end; if verify(substr(cname,i+2),SPACE)=0 then go to ENTNULL; if entry_length>length(cs.entry) then do; buffer = substr(cname,i+1,entry_length); ENTLONG: code = error_table_$entlong; if print_message then call com_err_(code,"command_processor_","^a",buffer); return; end; go to FIND_IT; /* skip out of character scan */ end; end; /* If a pathname was passed, convert it to an absolute pathname. Otherwise, pick up the simple command name */ FIND_IT: cp=addr(w); if pathname_given then do; call expand_pathname_(substr(name,1,command_length),dname,buffer,code); if code^=0 then go to ERROR; end; else buffer = substr(p->name,1,command_length); if verify(buffer,SPACE)=0 then go to BLANK; ename_length = length (rtrim (buffer)); if ename_length > length(cs.entry) then go to ENTLONG; cp -> cs.command = buffer; /* Now store away the entry name if one was specified. Otherwise the entry name is the same as the command name */ if entry_index^=0 then cp->cs.entry=substr(p->name,entry_index,entry_length); else cp->cs.entry=cp->cs.command; /* If a pathname was passed, initiate it to override the search rules (i. e. "initiated_segments" is the first thing in the search rules). If another segment is already known by the same reference name, we terminate it (and remove it from the AM if it is there) */ if pathname_given then do; LOOP: call hcs_$initiate((dname),cp->cs.command,cp->cs.command,0,0,p,code); if code^=0 then do; if code=error_table_$segknown then go to SEARCH_AM; if term_called then do; pathname_error="1"b; go to SEARCH_AM; end; if code^=error_table_$namedup then go to ERROR; call term_$no_clear(cp->cs.command,code); if code^=0 then go to ERROR; term_called="1"b; go to LOOP; end; end; /* */ SEARCH_AM: if (ename_length>16) | (nch="$") then go to CALL_MP; /* Search associative memory for command/entry name match. The comparison is made using based fixed bin(71) variables to maximize the efficiency of the search. If a match is found and the command was specified by a pathname, then the pathname must overide the associative memory. That is, the AM entry of the old segment is replaced by a pointer to the segment specified by the pathname */ oldu=aml+1; do i=0 to aml; p=addr(am(i)); if p->aw.c1^=w.c1 then go to SKIP; if p->aw.c2^=w.c2 then go to SKIP; p->ame.usage=aml+1; /* entry found,indicate recent usage */ entry_point_ptr=p->ame.entry_point_ptr; /* pick up command entry pointer */ do j=i+1 to aml; /* decrement usage for remaining AM entries */ am(j).usage=am(j).usage-1; end; if pathname_given then /* pathname overrides AM */ do; oldp=p; if pathname_error then go to CLEAR_AME; /* have found entry to clear */ am_entry_exists="1"b; go to CALL_MP; end; code=0; /* set return status code for successful return */ return; SKIP: p->ame.usage=p->ame.usage-1; /* this AM entry does not match,decrement usage */ if p->ame.usageame.usage; /* if so,remember this entry */ oldp=p; end; end; /* Command was not found in associative memory. We must try to snap a link to it */ CALL_MP: call hcs_$make_ptr(null,cp->cs.command,cp->cs.entry,entry_point_ptr,code); if code^=0 then do; if am_entry_exists then go to CLEAR_AME; go to ERROR; end; /* If linking was successful and command name is of correct form, put it in AM */ if ename_length<17 then if nch^="$" then do; oldp->ame.command=cp->cs.command; oldp->ame.entry_point_ptr=entry_point_ptr; oldp->ame.usage=aml+1; end; return; /* return control to caller */ /* */ CLEAR_AME: oldp->aw.c1,oldp->aw.c2=0; ERROR: entry_point_ptr=null; /* Do not print error message if called at fc_no_message entry */ if print_message then do; if code=error_table_$seg_not_found then /* check for segment not found */ NO_SEG: call com_err_$suppress_name(0,"command_processor_","Segment ^R^a^B not found.",cp->cs.command); else if code=error_table_$noentry then go to NO_SEG; else if code=error_table_$no_ext_sym then /* check for entry not found */ call com_err_$suppress_name(0,"command_processor_","Entry point ^R^a^B not found in segment ^R^a^B." ,cp->cs.entry,cp->cs.command); else call com_err_(code,"command_processor_","^R^a^B",cname); end; end full_find_command_;  find_command_error_.pl1 12/19/78 1859.9rew 12/19/78 1859.9 13644 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ find_command_error_: proc(cp,code); /* Initially coded in May 1972 by V. Voydock as part of fast command loop */ dcl cp ptr; dcl (code, error_table_$seg_not_found external, error_table_$noentry external, error_table_$no_ext_sym external ) fixed bin(35); dcl command_name char(32) aligned based(cp); dcl com_err_ ext entry options(variable), com_err_$suppress_name ext entry options(variable); /* */ /* Check for segment not found */ if code=error_table_$seg_not_found then NO_SEG: do; call com_err_$suppress_name(0,"command_processor_","Segment ^R^a^B not found.",cp->command_name); return; end; if code=error_table_$noentry then go to NO_SEG; if code=error_table_$no_ext_sym then /* check for entry not found */ do; call com_err_$suppress_name(0,"command_processor_","Entry point ^R^a^B not found in segment ^R^a^B.", cp->command_name,cp->command_name); return; end; else call com_err_(code,"command_processor_","^R^a^B",cp->command_name); end find_command_error_; 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