abbrev.pl1 04/12/90 1638.8rew 04/12/90 1539.5 973845 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ /* The Multics standard abbreviation processor */ /* Created: February 1982 by G. Palter based on various previous versions */ /****^ HISTORY COMMENTS: 1) change(86-05-01,Gilcrease), approve(86-05-10,MCR7409), audit(86-08-01,GWMay), install(86-08-04,MR12.0-1112): (old history comments) Modified: 7 March 1982 to insure that set_profile_ptr is quick, move special requests check into standard request checking code, and add the following warning Modified: 12 March 1982 by G. Palter to set the bit count on the profile segment after an add request Modified: 18 March 1982 by G. Palter to terminate the old profile when appropriate after a ".u" request Modified: 30 July 1982 by G. Palter to make abbrev as an active function return true/flase if expansion is enabled/disabled, respectively Modified: April 1983 by G. Palter for version 1.2: (1) Added initial support for multiple character break sequences and defined "::" as a break sequence; (2) Added the ".rename" request to allow users to rename old abbreviations whose names contain "::" Modified: 29 February 1984 by G. Palter for version 1.2a which fixes the following bugs: #0052: If abbrev has to reinitialize the default profile, it will erroneously state that it created the profile. In addition, abbrev will always initiate the default profile twice. #0053: If the last character of the line to be expanded is the first character of a multi-character break sequence, abbrev will loop indefinitely Modified: January 1983 by G. Palter for version 3.0: (1) Added the ".edit" request to allow editing the definition of an abbreviation using qedx_; (2) Added the ".switch_on" and ".switch_off" requests to manipulate an abbreviation's beginning-of-line switch; (3) Renamed the ".call_debug" request to ".debug" and the ".call_probe" request to ".probe" (Version 2 was the "Goldman" abbrev which lived in EXL on MIT and System-M for many, many years) 2) change(86-05-01,Gilcrease), approve(86-05-10,MCR7409), audit(86-08-01,GWMay), install(86-08-04,MR12.0-1112): (more old history comments) Modified: March 1983 by G. Palter for version 3.1: (1) Changed the ".edit" request to print the abbreviation's definition and a prompt before invoking qedx_ and to query if overwriting an existing abbreviation (if not the "default pathname"); (2) Added the ".escape" request and the "-escape" abbrev control argument to set the character used to identify abbrev request lines; (3) Added the "-on", "-off", and "-profile" control arguments for compatibility with the standard abbrev subsystem request Modified: 6 August 1985 by G. Palter for version 3.1a which fixes the following bugs: #0092: If the ".use" request is used in a subsystem which is using the same profile as Multics command level, abbrev will incorrectly terminate the profile which will cause subsequent command lines to fault until the ".quit" request is issued. #0107: If the new name given for an abbreviation by the ".rename" request is too long (i.e., more than 8 characters), the error message printed by abbrev includes 32 random characters instead of the supplied name 3) change(86-05-01,Gilcrease), approve(86-05-10,MCR7409), audit(86-08-01,GWMay), install(86-08-04,MR12.0-1112): Call ioa_ rather than com_err_ on "Profile create" message. (command_environment 123), and implement .? request, install version 3.1a abbrev. 4) change(86-05-17,GDixon), approve(86-05-17,MCR7357), audit(86-07-10,Farley), install(86-07-18,MR12.0-1098): Change call to tct_ to reference find_char_$first_in_table instead. The tct_ subroutines were renamed. 5) change(86-10-10,Gilcrease), approve(87-02-27,MCR7626), audit(87-03-09,Parisek), install(87-03-20,MR12.1-1005): Add version 2 list requests. 6) change(87-06-20,Gilcrease), approve(87-07-15,MCR7738), audit(87-07-16,Parisek), install(87-07-17,MR12.1-1042): Fix bug in .lx request. 7) change(87-07-01,GWMay), approve(87-07-01,MCR7730), audit(87-08-10,JRGray), install(87-09-10,MR12.1-1104): Added the pipe token combination ";|" and the left bracket "[" to the list of beginning of line breaks. Fixed a minor bug with the .lx request. 8) change(87-10-16,TLNguyen), approve(87-10-16,MCR7778), audit(87-12-02,Farley), install(87-12-07,MR12.2-1009): - Make the abbrev .use request strip one level of quotes from the pathname, if specified. - Add the new entry point named abbrev_$expand_line which will be like the "abbrev_$expanded_line" current entry point; however, this new entry point will have one new argument to say what kind of abbrevs to expand. This argument can be EXPAND_BOL_ONLY (1), or EXPAND_INTERNAL_ONLY (2), or EXPAND_BOTH (3). For solving the TR #14559, the EXPAND_INTERNAL_ONLY (2) constant will be used. - Clear out errors found at run time after compiled with -prefix size,strg,strz,subrg. 9) change(90-03-15,Vu), approve(90-03-15,MCR8161), audit(90-03-19,Kallstrom), install(90-04-12,MR12.4-1002): The abbrev command .lx should not limit its argument's length. END HISTORY COMMENTS */ /* Note: In order to insure that the main path through the command/request line expander does not entail the overhead of calls to non-quick procedures, two internal procedures, set_profile_ptr and lookup_abbrev, are duplicated. One version appears either in the expand_line procedure or as a top-level internal procedure; the other version appears as an internal procedure of the begin block in the process_request_line internal procedure. Anyone modifying either of these two procedures should be certain to modify both copies of the procedure. (An attempt will be made at a future date to eliminate the need for two copies of these procedures) */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ abbrev: ab: procedure () options (variable); /* Parameters */ dcl P_code fixed binary (35) parameter; dcl P_command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable parameter; /* set_cp: the command processor to always invoke */ dcl P_breaks character (*) parameter; /* set_break, reset_break: the break chars to add/delete */ dcl P_abbrev_type fixed bin; /* = 1 expand beginning-of-line (bol) abbrevs only. = 2 expand internal (non-bol) abbrevs only. = 3 expand both bol and non-bol abbrevs */ dcl P_input_line_ptr pointer parameter; /* abbrev_processor, expanded_line: -> line to expand */ dcl P_input_line_lth fixed binary (21) parameter; /* abbrev_processor, expanded_line: length of the line */ dcl P_subsystem_name character (*) parameter; /* subsys_process_line: name of the subsystem */ dcl P_sci_ptr pointer parameter; /* subsys_process_line: -> the subsystem's control data */ dcl P_execute_request entry () variable parameter; /* subsys_process_line: entry to invoke a single request */ dcl P_subsys_cp_info_ptr pointer parameter; /* subsys_process_line: -> data of subsys request processor */ dcl P_subsys_cp entry (character (*), pointer, entry, pointer, character (*), fixed binary (35)) variable parameter; /* subsys_process_line: the subsystem request processor */ dcl P_default_profile_ptr pointer parameter; /* subsys_process_line: -> default profile segment */ dcl P_profile_ptr pointer parameter; /* subsys_process_line: -> current profile segment */ dcl P_request_line character (*) parameter; /* subsys_process_line: the request line itself */ dcl P_workspace_ptr pointer parameter; /* expanded_line: -> buffer where expansion is placed */ dcl P_workspace_lth fixed binary (21) parameter; /* expanded_line: length of the buffer */ dcl P_output_line_ptr pointer parameter; /* expanded_line: set -> the expansion */ dcl P_output_line_lth fixed binary (21) parameter; /* expanded_line: set to length of the expansion */ /* Local copies of parameters */ dcl abbrev_type fixed bin; /* = 1 expand beginning-of-line (bol) abbrevs only. = 2 expand internal (non-bol) abbrevs only. = 3 expand both bol and non-bol abbrevs */ dcl input_line character (input_line_lth) based (input_line_ptr); dcl input_line_lth fixed binary (21); dcl input_line_ptr pointer; dcl P_output_line character (P_output_line_lth) based (P_output_line_ptr); dcl code fixed binary (35); /* Remaining declarations */ dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl expanded_line character (expanded_line_lth) based (expanded_line_ptr); dcl expanded_line_lth fixed binary (21); dcl expanded_line_ptr pointer; dcl expansion_stack_space_lth fixed binary (21); dcl expansion_stack_space_ptr pointer; dcl extended_stack bit (1) aligned; /* ON => expansion is in the stack extension */ dcl expansion_temp_segment character (4 * sys_info$max_seg_size) based (expansion_temp_segment_ptr); dcl expansion_temp_segment_ptr pointer; dcl used_temp_segment bit (1) aligned; /* ON => expansion is in a temporary segment */ dcl based_word fixed binary (35) based; dcl (subsystem_entry, return_expansion, allow_request_lines, have_return_code, null_line) bit (1) aligned; dcl start fixed binary (21); dcl cp_variable entry (pointer, fixed binary (21), fixed binary (35)) variable; dcl ABBREV character (32) static options (constant) initial ("abbrev"); dcl EXPAND_BOL_ONLY fixed bin static options (constant) initial (1); /* expand beginning-of-line (bol) abbrevs only */ dcl EXPAND_INTERNAL_ONLY fixed bin static options (constant) initial (2); /* expand internal (non-bol) abbrevs only */ dcl EXPAND_BOTH fixed bin static options (constant) initial (3); /* expand both bol and non-bol abbrevs */ dcl MAX_STACK_EXTENSION fixed binary (18) static options (constant) initial (16384); /* grow the stack no more than 16K characters */ dcl WHITE_SPACE character (4) static options (constant) initial (" "); /* SP HT VT FF */ dcl WHITE_SPACE_AND_NL character (5) static options (constant) initial (" "); /* SP HT VT FF NL */ dcl DEFAULT_ABBREV_ESCAPE_CHARACTER character (1) static options (constant) initial ("."); dcl DEFAULT_BREAKS character (21) static options (constant) initial (" ""$'().:;<>[]`{|}"); /* HT NL VT FF SP QUOTE, etc: must be in collating sequence */ dcl SP character (1) static options (constant) initial (" "); dcl NL character (1) static options (constant) initial (" "); dcl LEFT_BRACKET character (1) static options (constant) initial ("["); dcl SEMICOLON character (1) static options (constant) initial (";"); dcl VERTICAL_BAR character (1) static options (constant) initial ("|"); dcl QUOTE character (1) static options (constant) initial (""""); dcl abbrev_data_$version character (32) unaligned external; dcl abbrev_data_$default_breaks_list bit (36) aligned external; dcl abbrev_data_$default_breaks_tct_table character (512) unaligned external; /* format: off */ dcl (error_table_$badopt, error_table_$bad_segment, error_table_$bad_subr_arg, error_table_$command_line_overflow, error_table_$moderr, error_table_$noarg, error_table_$noentry, error_table_$not_act_fnc, error_table_$request_not_recognized, error_table_$unbalanced_quotes, error_table_$unimplemented_version) fixed binary (35) external; /* format: on */ dcl sys_info$max_seg_size fixed binary (19) external; dcl active_fnc_err_$suppress_name entry () options (variable); dcl com_err_ entry () options (variable); dcl com_err_$suppress_name entry () options (variable); dcl command_processor_ entry (pointer, fixed binary (21), fixed binary (35)); dcl command_query_$yes_no entry () options (variable); dcl cu_$af_return_arg_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer); dcl cu_$cp entry (pointer, fixed binary (21), fixed binary (35)); dcl cu_$get_command_processor entry (entry (pointer, fixed binary (21), fixed binary (35))); dcl cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35)); dcl cu_$set_command_processor entry (entry (pointer, fixed binary (21), fixed binary (35))); dcl cu_$shrink_stack_frame entry (pointer, fixed binary (35)); dcl debug entry () options (variable); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl probe entry () options (variable); dcl get_system_free_area_ entry () returns (pointer); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl hcs_$fs_get_mode entry (pointer, fixed binary (5), fixed binary (35)); dcl hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl initiate_file_$create entry (character (*), character (*), bit (*), pointer, bit (1) aligned, fixed binary (24), fixed binary (35)); dcl ioa_ entry () options (variable); dcl ioa_$nnl entry () options (variable); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl qedx_ entry (pointer, fixed binary (35)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl sort_items_$char entry (pointer, fixed binary (24)); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl find_char_$first_in_table entry (char (*), char (512) aligned) returns (fixed bin (21)) reducible; dcl user_info_ entry (character (*)); dcl user_info_$homedir entry (character (*)); dcl cleanup condition; dcl (addcharno, addr, after, baseptr, before, codeptr, currentsize, divide, fixed, hbound, high, index, lbound, length, low, ltrim, max, mod, null, pointer, rank, rel, reverse, rtrim, search, string, substr, verify) builtin; %page; /* State of abbreviation processing in this process */ dcl first_call bit (1) aligned static initial ("1"b); dcl 1 abbrev_state aligned static, 2 command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable, 2 previous_command_processor entry (pointer, fixed binary (21), fixed binary (35)) variable, 2 profile_ptr pointer, /* -> profile in use at command level */ 2 remembered_line, /* data about the last expansion we did ... */ 3 remembered_line_buffer_ptr pointer, /* ... -> buffer used to hold the lines */ 3 remembered_line_buffer_lth fixed binary (21), /* ... length of the buffer */ 3 remembered_line_lth fixed binary (21), /* ... length of line currently saved therein */ 2 escape_character character (1) aligned, /* character used to trigger request line processing */ 2 flags, 3 set_cp bit (1) unaligned, /* ON => we have established ourselves as the CP */ 3 set_cp_explicit bit (1) unaligned, /* ON => abbrev_$set_cp was called */ 3 remember_lines bit (1) unaligned, /* ON => remember last expanded line */ 3 default_breaks bit (1) unaligned, /* ON => using default break characters */ 3 pad bit (32) unaligned, 2 breaks_info, /* data used to find break sequences ... */ 3 user_breaks character (128) varying, /* ... 1st characters of all sequences if not default */ 3 tct_table character (512), /* ... used to search for above sequences if not default */ 3 breaks_list_ptr pointer; /* ... -> breaks_list defining the sequences */ dcl abbrev_state_tct_table_as_binary (0:511) fixed binary (9) unaligned unsigned based (addr (abbrev_state.tct_table)); dcl 1 breaks_list aligned based (abbrev_state.breaks_list_ptr), 2 n_break_sequences fixed binary, /* # of distinct break sequences */ 2 break_strings_lth fixed binary, /* combined length of all break sequences */ 2 break_sequences (breaks_list_n_break_sequences refer (breaks_list.n_break_sequences)), 3 start fixed binary, /* ... index in break_strings where this sequence starts */ 3 lth fixed binary, /* ... how long this sequence actually is */ 2 break_strings character (breaks_list_break_strings_lth refer (breaks_list.break_strings_lth)) unaligned; dcl (breaks_list_n_break_sequences, breaks_list_break_strings_lth) fixed binary; dcl remembered_line_buffer character (abbrev_state.remembered_line_buffer_lth) based (abbrev_state.remembered_line_buffer_ptr); dcl remembered_line character (abbrev_state.remembered_line_lth) based (abbrev_state.remembered_line_buffer_ptr); dcl debug_entry_variable entry () options (variable) variable static; dcl probe_entry_variable entry () options (variable) variable static; %page; dcl abbrev_rqd (87) char (72) static options (constant) /* For the .? abbrev request */ init (".", /* Three lines of print, 3rd line */ " displays the current version of abbrev.", /* "" if not needed */ "", /* ( as for this "." request) */ ".? ...", " describes the function and usage of the given abbrev control", " request(s). If none are given, all abbrev requests are described.", ".LINE", /* can't be individually displayed */ " passes LINE directly to the current command processor without", " expanding any embedded abbreviations.", ".a name LINE, .af name LINE", " adds LINE as the definition of a new abbreviation with the given", " name to the current profile. '.af' adds with no query.", ".ab name LINE, .abf name LINE", " adds LINE as the definition of a new abbreviation with the given", " name to the current profile. '.abf' adds with no query.", ".debug", " invokes debug.", "", ".delete names, .dl names, .d names", " deletes the given abbreviations from the current profile.", "", ".edit name", " invokes the qedx editor to edit the given abbreviation's", " definition.", ".escape {STR}, .esc {STR}", " changes the escape character which is used to indicate that a", " command line is actually an abbrev request line. ", ".forget, .f", " disables remember mode. ", "", ".l {names}", " displays the names, switches, and definitions of the given", " abbreviations in alphabetic order.", ".la STRs", " displays the names, switches, and definitions of any abbreviations", " whose name starts with one of the given strings.", ".lab STRs, .la^b STRs", " displays beginning-line (.lab) or not-beginning-line (.la^b)", " information for abbreviations beginning with STRs.", ".lb {names}", " displays information on beginning-of-line abbreviations which", " match {names}, or if no {names}, all bol abreviations.", ".l^b {names}", " displays information on not-beginning-of-line abbreviations which", " which match {name}, or if no {names}, all not-bol abbreviaions.", ".ls STRs", " displays the names, switches, and definitions of any abbreviations", " which contain STRs.", ".lsb STRs, .ls^b STRs", " displays beginning-of-line (.lsb) or not-beginning-of-line ", " information of abbreviations which contain STRs.", ".lx STRs", " displays information of abbreviation expansions which contain", " STRs.", ".lxb STRs, .lx^b STRs", " displays information of beginning-line abbreviation expansions", " (.lxb) or not-beginning-line (.lx^b) containing STRs.", ".probe", " invokes probe.", "", ".profile, .p", " prints the pathname of the profile segment presently being used to", " expand abbreviations.", ".quit, .q", " disables abbreviation processing of subsequent command lines.", "", ".remember, .r", " enables remember mode. In remember mode, abbrev saves the expansion", " of the last line that it has processed. See the '.show' request.", ".rename old_name1 new_name1 ..., .rn old_name1 new_name1...", " renames the given abbreviations. If an abbreviation is already", " defined, abbrev will query for permission to replace it.", ".show {LINE}, .s {LINE}", " if LINE is given, displays the expansion of that line without", " executing it. If LINE is not given, displays the last line expanded.", ".switch_on switch_name names, .swn switch_name names", " turns on the given switch in the definitions of the given", " abbreviations. See the 'abbrev' online help file for more details.", ".switch_off switch_name names, .swf switch_name names", " turns off the given switch in the definitions of the given", " abbreviations. See the 'abbrev' online help file for more details.", ".terminate_process", " causes a fatal process error. This request is intended for use ", " only under special conditions. See the 'abbrev' online help file.", ".use {path}, .u {path}", " changes the pathname of the profile segment. The 'profile' suffix", " is assumed. If no {path} given, the default profile is used."); dcl ard (46) char (19) varying static options (constant) init /* control request literals table */ (".", ".?", ". ", ".a", ".af", ".ab", ".abf", ".debug", ".delete", ".dl", ".d", ".edit", ".escape", ".esc", ".forget", ".f", ".l", ".la", ".lab", ".la^b", ".lb", ".l^b", ".ls", ".lsb", ".ls^b", ".lx", ".lxb", ".lx^b", ".probe", ".profile", ".p", ".quit", ".q", ".remember", ".r", ".rename", ".rn", ".show", ".s", ".switch_on", ".swn", ".switch_off", ".swf", ".terminate_process", ".use", ".u"); dcl ardx (46) fixed bin static options (constant) init /* corresponding index into abbrev_rqd table */ (1, 4, 7, 10, 10, 13, 13, 16, 19, 19, 19, 22, 25, 25, 28, 28, 31, 34, 37, 37, 40, 43, 46, 49, 49, 52, 55, 55, 58, 61, 61, 64, 64, 67, 67, 70, 70, 73, 73, 76, 76, 79, 79, 82, 85, 85); %page; %page; /* abbrev command/AF: As a command, establishes ourself as the command processor; as an active function, returns true/false if command line expansion is enabled/disabled, respectively. If enabling abbrev and there was a previous call to set_cp_explicit, assume that the caller always wants us to call whatever command processor he provided */ /* abbrev: ab: entry () options (variable); */ if first_call then /* be sure static is setup */ call initialize_abbrev_state (); call process_abbrev_command_or_af (cu_$arg_list_ptr ()); return; /* Does the actual work of the abbrev command/AF to keep the main stack frame as small as possible */ process_abbrev_command_or_af: procedure (p_argument_list) options (non_quick); dcl p_argument_list pointer parameter; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl return_string character (return_string_max_lth) varying based (return_string_ptr); dcl return_string_max_lth fixed binary (21); dcl return_string_ptr pointer; dcl active_function bit (1) aligned; dcl enable_abbrev bit (1) aligned; dcl new_escape_character character (1) aligned; dcl new_profile_dirname character (168); dcl new_profile_ename character (32); dcl new_profile_ptr pointer; dcl created_here bit (1) aligned; dcl try_to_create bit (1); call cu_$af_return_arg_rel (n_arguments, return_string_ptr, return_string_max_lth, code, p_argument_list); if code = 0 then active_function = "1"b; else if code = error_table_$not_act_fnc then active_function = "0"b; else do; /* something wrong with the argument list header */ call com_err_ (code, ABBREV); return; end; if active_function then do; /* tell user if abbrev is on/off */ if n_arguments = 0 then /* ... but only if properly invoked */ if abbrev_state.set_cp then return_string = "true"; else return_string = "false"; else call active_fnc_err_$suppress_name (0, ABBREV, "Usage: [^a]", ABBREV); return; end; /* Here iff invoked as a command */ enable_abbrev = "1"b; /* turn abbreviation processing on by default */ new_escape_character = abbrev_state.escape_character; new_profile_ptr = null (); /* for cleanup handler */ created_here = "0"b; on condition (cleanup) begin; if new_profile_ptr ^= null () then if created_here then call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0)); else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0)); end; do argument_idx = 1 to n_arguments; call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list); if code ^= 0 then do; call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx); go to RETURN_FROM_ABBREV_COMMAND; end; if index (argument, "-") = 1 then /* a control argument ... */ if argument = "-on" then enable_abbrev = "1"b; else if argument = "-off" then enable_abbrev = "0"b; else if (argument = "-escape") | (argument = "-esc") then if argument_idx = n_arguments then do; call com_err_ (error_table_$noarg, ABBREV, "Escape character after ""^a"".", argument); go to RETURN_FROM_ABBREV_COMMAND; end; else do; /* ... there is something following it */ argument_idx = argument_idx + 1; call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list); if code ^= 0 then do; call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx); go to RETURN_FROM_ABBREV_COMMAND; end; if length (rtrim (argument)) > length (abbrev_state.escape_character) then do; call com_err_ (0, ABBREV, "The escape sequence must be a single character; not ""^a"".", argument); go to RETURN_FROM_ABBREV_COMMAND; end; new_escape_character = argument; end; else if (argument = "-profile") | (argument = "-pf") then if argument_idx = n_arguments then do; call com_err_ (error_table_$noarg, ABBREV, "Profile pathname after ""^a"".", argument); go to RETURN_FROM_ABBREV_COMMAND; end; else do; argument_idx = argument_idx + 1; call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, p_argument_list); if code ^= 0 then do; call com_err_ (code, ABBREV, "Fetching argument #^d.", argument_idx); go to RETURN_FROM_ABBREV_COMMAND; end; call expand_pathname_$add_suffix (argument, "profile", new_profile_dirname, new_profile_ename, code); if code ^= 0 then do; call com_err_ (code, ABBREV, "^a", argument); go to RETURN_FROM_ABBREV_COMMAND; end; if new_profile_ptr ^= null () then if created_here then /* ... there was a previous use of -profile ... */ call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0)); else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0)); created_here = "0"b; call initiate_file_ (new_profile_dirname, new_profile_ename, R_ACCESS, new_profile_ptr, (0), code); if code ^= 0 then /* couldn't find it */ if code = error_table_$noentry then do; call command_query_$yes_no (try_to_create, 0, ABBREV, "", "Profile ^a not found. Do you want to create it?", pathname_ (new_profile_dirname, new_profile_ename)); if try_to_create then call initiate_file_$create (new_profile_dirname, new_profile_ename, RW_ACCESS, new_profile_ptr, created_here, (0), code); else go to RETURN_FROM_ABBREV_COMMAND; /* user doesn't want to try */ end; if new_profile_ptr = null () then do; call com_err_ (code, ABBREV, "^a", pathname_ (new_profile_dirname, new_profile_ename)); go to RETURN_FROM_ABBREV_COMMAND; end; end; else do; call com_err_ (error_table_$badopt, ABBREV, """^a""", argument); go to RETURN_FROM_ABBREV_COMMAND; end; else do; call com_err_$suppress_name (0, ABBREV, "Usage: ^a {-control_args}", ABBREV); go to RETURN_FROM_ABBREV_COMMAND; end; end; /* Here iff all arguments are OK: enable/disable abbrev and switch profiles as requested */ abbrev_state.escape_character = new_escape_character; if enable_abbrev then /* turn on abbreviation processing ... */ if ^abbrev_state.set_cp then do; /* ... if it wasn't already in use */ call cu_$get_command_processor (cp_variable); if cp_variable ^= abbrev_processor then do; /* ... avoid infinite recursion if we're already enabled */ abbrev_state.previous_command_processor = cp_variable; if ^abbrev_state.set_cp_explicit then abbrev_state.command_processor = cp_variable; /* ... don't override the explicitly set processor */ call cu_$set_command_processor (abbrev_processor); abbrev_state.set_cp = "1"b; /* ... have set ourselves up now */ end; end; else ; /* ... it was already on so this is a no-op */ else do; /* turn abbrev off ... */ if abbrev_state.set_cp then do; /* ... and we are the command processor */ call cu_$set_command_processor (abbrev_state.previous_command_processor); abbrev_state.set_cp = "0"b; end; if abbrev_state.profile_ptr ^= null () then /* ... don't need it any more */ call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0)); end; if new_profile_ptr ^= null () then do; /* switch to the requested profile */ if abbrev_state.profile_ptr ^= null () then call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0)); abbrev_state.profile_ptr, ap_ptr = new_profile_ptr; new_profile_ptr = null (); /* avoid accidently terminating what is now the profile */ expansion_temp_segment_ptr = null (); /* in case initialize_profile fails ... */ have_return_code = "0"b; /* ... */ call initialize_profile (^created_here, created_here); end; RETURN_FROM_ABBREV_COMMAND: if new_profile_ptr ^= null () then if created_here then call terminate_file_ (new_profile_ptr, 0, TERM_FILE_DELETE, (0)); else call terminate_file_ (new_profile_ptr, 0, TERM_FILE_TERM, (0)); return; end process_abbrev_command_or_af; %page; /* Return the current version of abbrev for use by use_exl_abbrev */ get_version: entry () returns (character (32)); return (abbrev_data_$version); %page; /* Provide an explicit entry for abbrev to use as the command processor: overrides whatever entry the abbrev command establishes as the previous command processor */ set_cp: entry (P_command_processor); if first_call then call initialize_abbrev_state (); if codeptr (P_command_processor) = null () then /* use the default command processor */ abbrev_state.command_processor = command_processor_; else abbrev_state.command_processor = P_command_processor; abbrev_state.set_cp_explicit = "1"b; /* override the abbrev command */ return; %page; /* Adds the given characters as break characters */ set_break: entry (P_breaks); if first_call then call initialize_abbrev_state (); call add_breaks (P_breaks); return; /* Do the actual work in an internal procedure to save space on the main procedure's stack */ add_breaks: procedure (p_breaks) options (non_quick); dcl p_breaks character (*) parameter; dcl current_breaks character (128) varying; dcl break_character character (1) aligned; dcl (idx, jdx) fixed binary (21); dcl added bit (1) aligned; if abbrev_state.default_breaks then /* everything but "::" due to deficiencies of the interface */ current_breaks = before (DEFAULT_BREAKS, ":") || after (DEFAULT_BREAKS, ":"); else current_breaks = abbrev_state.user_breaks; do idx = 1 to length (p_breaks); break_character = substr (p_breaks, idx, 1); if break_character <= high (1) then do; /* only if it's ASCII ... */ added = "0"b; do jdx = 1 to length (current_breaks) while (^added); if substr (current_breaks, jdx, 1) = break_character then added = "1"b; else if substr (current_breaks, jdx, 1) > break_character then do; current_breaks = substr (current_breaks, 1, (jdx - 1)) || break_character || substr (current_breaks, jdx); added = "1"b; end; end; if ^added then /* wasn't added in the middle: stick it on the end */ current_breaks = current_breaks || break_character; end; end; call set_user_breaks (current_breaks); return; end add_breaks; %page; /* Deletes the given characters from the list of break characters */ reset_break: entry (P_breaks); if first_call then call initialize_abbrev_state (); call delete_breaks (P_breaks); return; /* Do the actual work in an internal procedure to save space on the main procedure's stack */ delete_breaks: procedure (p_breaks) options (non_quick); dcl p_breaks character (*) parameter; dcl current_breaks character (128) varying; dcl break_character character (1) aligned; dcl (idx, jdx) fixed binary (21); dcl deleted bit (1) aligned; if abbrev_state.default_breaks then /* everything but "::" due to deficiencies of the interface */ current_breaks = before (DEFAULT_BREAKS, ":") || after (DEFAULT_BREAKS, ":"); else current_breaks = abbrev_state.user_breaks; do idx = 1 to length (p_breaks); break_character = substr (p_breaks, idx, 1); deleted = "0"b; do jdx = 1 to length (current_breaks) while (^deleted); if substr (current_breaks, jdx, 1) = break_character then do; current_breaks = substr (current_breaks, 1, (jdx - 1)) || substr (current_breaks, (jdx + 1)); deleted = "1"b; end; end; end; call set_user_breaks (current_breaks); /* still not the default: build the appropriate TCT table */ return; end delete_breaks; %page; /* Sets the break sequences used by abbrev to the individual characters in the supplied string */ set_user_breaks: procedure (p_new_breaks) options (non_quick); dcl p_new_breaks character (128) varying parameter; dcl idx fixed binary; system_area_ptr = get_system_free_area_ (); if ^abbrev_state.default_breaks then free breaks_list in (system_area); breaks_list_n_break_sequences, breaks_list_break_strings_lth = length (p_new_breaks); allocate breaks_list in (system_area) set (abbrev_state.breaks_list_ptr); /* nothing but single character break sequences */ abbrev_state.user_breaks, breaks_list.break_strings = p_new_breaks; abbrev_state.tct_table = low (length (abbrev_state.tct_table)); do idx = 1 to length (abbrev_state.user_breaks); abbrev_state_tct_table_as_binary (rank (substr (abbrev_state.user_breaks, idx, 1))) = idx; breaks_list.break_sequences (idx).start = idx; breaks_list.break_sequences (idx).lth = 1; end; abbrev_state.default_breaks = "0"b; /* no longer using the default */ return; end set_user_breaks; %page; /* Initialize abbrev's internal state */ initialize_abbrev_state: procedure () /* options (quick) */; code = codeptr (debug) -> based_word; /* snap the links */ debug_entry_variable = debug; code = codeptr (probe) -> based_word; /* ... in case the linker gets wedged */ probe_entry_variable = probe; string (abbrev_state.flags) = ""b; /* turn them all off ... */ abbrev_state.default_breaks = "1"b; /* ... except that we use the default breaks */ abbrev_state.profile_ptr = null (); abbrev_state.remembered_line_buffer_ptr = null (); abbrev_state.remembered_line_buffer_lth, abbrev_state.remembered_line_lth = 0; abbrev_state.escape_character = DEFAULT_ABBREV_ESCAPE_CHARACTER; abbrev_state.tct_table = abbrev_data_$default_breaks_tct_table; abbrev_state.breaks_list_ptr = addr (abbrev_data_$default_breaks_list); first_call = "0"b; return; end initialize_abbrev_state; %page; /* Command processor interface: called via cu_$cp to process a command line */ abbrev_: abbrev_processor: entry (P_input_line_ptr, P_input_line_lth, P_code); abbrev_type = EXPAND_BOTH; input_line_ptr = P_input_line_ptr; input_line_lth = P_input_line_lth; subsystem_entry = "0"b; return_expansion = "0"b; allow_request_lines, have_return_code = "1"b; go to EXPAND_COMMON; /* Subsystem request processor interface: called directly by ssu_$listen to expand and execute a subsystem request line */ subsys_process_line: entry (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr, P_subsys_cp, P_default_profile_ptr, P_profile_ptr, P_request_line, P_code); abbrev_type = EXPAND_BOTH; input_line_ptr = addr (P_request_line); input_line_lth = length (P_request_line); subsystem_entry = "1"b; return_expansion = "0"b; allow_request_lines, have_return_code = "1"b; go to EXPAND_COMMON; /* Expand only a selected abbrev type and return it to the caller */ abbrev_$expand_line: entry (P_abbrev_type, P_input_line_ptr, P_input_line_lth, P_workspace_ptr, P_workspace_lth, P_output_line_ptr, P_output_line_lth); abbrev_type = P_abbrev_type; goto EXPANDED_LINE; /* Expand a line and return it to the caller */ abbrev_$expanded_line: /* avoids PL/I naming rules */ entry (P_input_line_ptr, P_input_line_lth, P_workspace_ptr, P_workspace_lth, P_output_line_ptr, P_output_line_lth); abbrev_type = EXPAND_BOTH; EXPANDED_LINE: input_line_ptr = P_input_line_ptr; input_line_lth = P_input_line_lth; subsystem_entry = "0"b; return_expansion = "1"b; allow_request_lines, have_return_code = "0"b; go to EXPAND_COMMON; /* Actual expansion starts here */ EXPAND_COMMON: if first_call then call initialize_abbrev_state (); if ^abbrev_state.set_cp & ^abbrev_state.set_cp_explicit then call cu_$get_command_processor (abbrev_state.command_processor); /* no one had yet set a command processor to call */ code = 0; /* assume success */ system_area_ptr = get_system_free_area_ (); extended_stack, used_temp_segment, null_line = "0"b; expansion_stack_space_lth = 0; /* haven't extended the stack ... */ expansion_temp_segment_ptr = null (); /* ... or used a temp seg yet */ if input_line_lth = 0 then do; /* special case zero-length lines: avoids faults... */ null_line = "1"b; /* don't remember this line if in ".r" mode */ EXPANSION_IS_INPUT_LINE: expanded_line_ptr = input_line_ptr; expanded_line_lth = input_line_lth; go to EXPANSION_COMPLETED; end; start = verify (input_line, WHITE_SPACE_AND_NL); /* "strip" leading white space */ if start = 0 then do; /* all whitespace ... */ null_line = "1"b; go to EXPANSION_IS_INPUT_LINE; end; /* format: off */ /* Check for the ".." escape here as the user might have changed the escape character: "..": pass the rest of the line to the current command processor; this request allows typeahead of command lines when one isn't sure if a subsystem or Multics proper will read the line in question */ /* format: on */ if allow_request_lines & ^subsystem_entry then /* only if we'll call cu_$cp eventually ... */ if input_line_lth > (start + 1) then /* ... and there's enough on the line to allow ".." ... */ if substr (input_line, start, 2) = ".." then do; call cu_$cp (addcharno (input_line_ptr, (start + 1)), (input_line_lth - start - 1), code); go to RETURN_FROM_ABBREV_PROCESSOR;/* ... reflect execution's error code to caller */ end; /* Check for and process abbrev request lines */ if (substr (input_line, start, 1) = abbrev_state.escape_character) then /* a request line ... */ if allow_request_lines then do; /* ... and request lines are OK */ call process_request_line (); code = 0; /* requests ALWAYS "work" */ go to RETURN_FROM_ABBREV_PROCESSOR; end; else go to EXPANSION_IS_INPUT_LINE; /* ... no request lines: just give it back */ /* Non-request line: expand the line, remember it (if appropriate), and execute/return it */ call set_profile_ptr (return_expansion); /* will need the profile for certain now */ if return_expansion & (ap_ptr = null ()) then /* no profile to expand the line with ... */ go to EXPANSION_IS_INPUT_LINE; on condition (cleanup) begin; if expansion_temp_segment_ptr ^= null () then call release_temp_segment_ (ABBREV, expansion_temp_segment_ptr, (0)); end; call expand_line (abbrev_type, start); /* grows our stack frame */ EXPANSION_COMPLETED: if return_expansion then do; /* expanded_line entry ... */ if expanded_line_lth <= P_workspace_lth then /* ... fits into caller's buffer */ P_output_line_ptr = P_workspace_ptr; else allocate expanded_line in (system_area) set (P_output_line_ptr); P_output_line_lth = expanded_line_lth; P_output_line = expanded_line; go to RETURN_FROM_ABBREV_PROCESSOR; end; if abbrev_state.remember_lines & ^null_line then do; if abbrev_state.remembered_line_buffer_lth < expanded_line_lth then do; if abbrev_state.remembered_line_buffer_ptr ^= null () then free remembered_line_buffer in (system_area); abbrev_state.remembered_line_buffer_lth = 128 * divide (expanded_line_lth + 127, 128, 21, 0); allocate remembered_line_buffer in (system_area) set (abbrev_state.remembered_line_buffer_ptr); end; abbrev_state.remembered_line_lth = expanded_line_lth; remembered_line = expanded_line; end; if subsystem_entry then call P_subsys_cp (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr, expanded_line, code); else call abbrev_state.command_processor (expanded_line_ptr, expanded_line_lth, code); RETURN_FROM_ABBREV_PROCESSOR: if expansion_temp_segment_ptr ^= null () then call release_temp_segment_ (ABBREV, expansion_temp_segment_ptr, (0)); if have_return_code then /* let the caller know how we did */ P_code = code; return; %page; /* Returns the pathname of a profile */ profile_pathname: procedure () returns (character (168)) options (non_quick); dcl profile_dirname character (168); dcl profile_ename character (32); call hcs_$fs_get_path_name (ap_ptr, profile_dirname, (0), profile_ename, (0)); return (pathname_ (profile_dirname, profile_ename)); end profile_pathname; /* Aborts abbrev with the given error message: if command level is using the profile identified by ap_ptr, abbreviation processing is turned off as this entry is only called when said profile is unusable */ abort_abbrev_processor: procedure (p_code, p_message, p_pathname) options (non_quick); dcl p_code fixed binary (35) parameter; dcl (p_message, p_pathname) character (*) parameter; if ap_ptr = abbrev_state.profile_ptr then do; /* command level was using this profile */ if abbrev_state.set_cp then do; /* ... and we are the command processor */ call cu_$set_command_processor (abbrev_state.previous_command_processor); abbrev_state.set_cp = "0"b; end; if ap_ptr ^= null () then /* ... don't need it any more */ call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0)); abbrev_state.profile_ptr = null (); /* ... no longer have a profile */ end; call com_err_ (p_code, ABBREV, p_message, p_pathname); code = p_code; /* make sure right error gets back to caller */ go to RETURN_FROM_ABBREV_PROCESSOR; end abort_abbrev_processor; %page; /* Sets ap_ptr to locate the proper profile to be used for expansion in this case: initializes the profile if necessary; two versions of this procedure exist to insure that this one is quick */ set_profile_ptr: procedure (p_dont_create_profile) /* options (quick) */; dcl p_dont_create_profile bit (1) aligned; ap_ptr = null (); /* start somewhere */ if subsystem_entry then /* subsystems use arbitrary profiles */ if (P_default_profile_ptr = null ()) & (P_profile_ptr = null ()) then /* ... use same profile as Multics command level */ if abbrev_state.profile_ptr = null () then call get_default_profile (p_dont_create_profile); /* ... need not succeed if called at expanded_line entry */ else ap_ptr = abbrev_state.profile_ptr; else do; /* subsystem supplied the profile */ if P_profile_ptr ^= null () then ap_ptr = P_profile_ptr; else ap_ptr = P_default_profile_ptr; call initialize_profile ("1"b, "0"b); /* ... make sure it's good */ end; else do; /* command level invocation */ if abbrev_state.profile_ptr = null () then call get_default_profile (p_dont_create_profile); /* ... need not succeed if called at expanded_line entry */ else ap_ptr = abbrev_state.profile_ptr; end; return; end set_profile_ptr; %page; /* Sets the profile used by Multics command level to the default profile segment (Person.profile in the home directory): creates the profile if request or prints an error message and disables abbrev processing if invoked to expand and execute a command/request line */ get_default_profile: procedure (p_dont_create_profile) options (non_quick); dcl p_dont_create_profile bit (1) aligned parameter; dcl profile_dirname character (168); dcl (profile_ename, person_id) character (32); dcl created_here bit (1) aligned; call user_info_ (person_id); call user_info_$homedir (profile_dirname); profile_ename = rtrim (person_id) || ".profile"; created_here = "0"b; call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, abbrev_state.profile_ptr, (0), code); if code = error_table_$noentry then /* not found ... */ if p_dont_create_profile then return; /* ... but that's OK */ else do; /* ... must be able to create it */ call initiate_file_$create (profile_dirname, profile_ename, RW_ACCESS, abbrev_state.profile_ptr, created_here, (0), code); if code ^= 0 then call abort_abbrev_processor (code, "Profile ^a could not be created.", pathname_ (profile_dirname, profile_ename)); end; else if code ^= 0 then /* wrong access, etc... */ call abort_abbrev_processor (code, "^a", pathname_ (profile_dirname, profile_ename)); ap_ptr = abbrev_state.profile_ptr; /* got it */ call initialize_profile ("1"b, created_here); /* make sure it's OK */ return; end get_default_profile; %page; /* Insure that a profile segment has been properly initialized */ initialize_profile: procedure (p_announce, p_created_or_initialized) options (non_quick); dcl p_announce bit (1) aligned parameter; dcl p_created_or_initialized bit (1) aligned parameter; dcl profile_mode fixed binary (5); if abbrev_profile.version > 127 then /* older style: garbage collection will fix it */ call compact_profile (); call hcs_$fs_get_mode (ap_ptr, profile_mode, code); if code ^= 0 then /* have to be able to determine our access */ call abort_abbrev_processor (code, "Can not determine access to profile ^a", profile_pathname ()); if abbrev_profile.next_free = 0 then /* freshly created profile */ if (profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN) then do; if p_announce then call ioa_ ("^a: Profile ^a ^[created^;initialized^].", ABBREV, profile_pathname (), p_created_or_initialized); abbrev_profile.version = ABBREV_PROFILE_VERSION_1; abbrev_profile.next_free = fixed (rel (addr (abbrev_profile.data_space)), 18, 0); call terminate_file_ (ap_ptr, (36 * abbrev_profile.next_free), TERM_FILE_TRUNC_BC, (0)); end; /* truncate and set bit count in case it contained garbage */ else call abort_abbrev_processor (error_table_$moderr, "Can not complete initialization of profile ^a", profile_pathname ()); else if abbrev_profile.version = 0 then /* simple upgrade to version 1 */ if (profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN) then abbrev_profile.version = ABBREV_PROFILE_VERSION_1; return; end initialize_profile; %page; /* Expands a line: if any expansion actually occurs, the caller's stack frame is expanded to hold the result; if the expanded string exceeds 16K characters, it is placed in a temporary segment instead */ expand_line: procedure (p_abbrev_type, p_start) /* options (quick) */; dcl p_abbrev_type fixed bin; /* get the type of abbreviations to expand */ dcl p_start fixed binary (21) parameter; /* where in line to start expansion */ dcl abbrev_name character (8) aligned; dcl break_character character (1) aligned; dcl (recognize_bol_abbrevs, need_break_sequence, found_end) bit (1) aligned; dcl (start, last_copied_idx, last_expanded_idx, last_quote_idx, break_idx, idx) fixed binary (21); dcl break_lth fixed binary; expanded_line_ptr = input_line_ptr; /* assume we don't have to copy/expand it at all */ expanded_line_lth = input_line_lth; last_copied_idx = 0; /* haven't copied any of the line yet */ last_expanded_idx = 0; recognize_bol_abbrevs = "1"b; start = p_start; do while (start <= input_line_lth); begin; dcl rest_of_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start); need_break_sequence = "1"b; /* find next break sequence */ break_idx, break_lth = 0; /* no break sequence yet */ do while (need_break_sequence & (break_idx <= length (rest_of_line))); begin; dcl rest_of_rest_of_line character (length (rest_of_line) - break_idx) unaligned defined (input_line) position (start + break_idx); if abbrev_state.default_breaks then idx = search (rest_of_rest_of_line, DEFAULT_BREAKS); else idx = find_char_$first_in_table (rest_of_rest_of_line, abbrev_state.tct_table); end; if idx = 0 then /* no more break sequences present */ break_idx = length (rest_of_line) + 1; else do; /* a possibility */ break_idx = break_idx + idx; break_character = substr (rest_of_line, break_idx, 1); /* format: off */ do idx = abbrev_state_tct_table_as_binary (rank (break_character)) to breaks_list.n_break_sequences while (need_break_sequence & (substr (breaks_list.break_strings, breaks_list.break_sequences (idx).start, 1) = break_character)); if (break_idx + breaks_list.break_sequences (idx).lth - 1) <= length (rest_of_line) then if substr (rest_of_line, break_idx, breaks_list.break_sequences (idx).lth) = substr (breaks_list.break_strings, breaks_list.break_sequences (idx).start, breaks_list.break_sequences (idx).lth) then do; /* found it */ need_break_sequence = "0"b; break_lth = breaks_list.break_sequences (idx).lth; end; end; /* format: on */ end; end; if break_idx > 1 then do; /* check for an abbreviation */ if break_idx <= (length (ape.name) + 1) then do; abbrev_name = substr (rest_of_line, 1, (break_idx - 1)); ape_ptr = lookup_abbrev (); if ape_ptr ^= null () then /* found one */ if (recognize_bol_abbrevs & ape.bol & (p_abbrev_type ^= EXPAND_INTERNAL_ONLY)) | (^ape.bol & (p_abbrev_type ^= EXPAND_BOL_ONLY)) then do; begin; dcl uncopied_text character (start - last_copied_idx - 1) unaligned defined (input_line) position (last_copied_idx + 1); call make_space (length (uncopied_text) + ape.value_lth); expanded_line_lth = expanded_line_lth + length (uncopied_text); substr (expanded_line, (last_expanded_idx + 1), length (uncopied_text)) = uncopied_text; last_expanded_idx = last_expanded_idx + length (uncopied_text); last_copied_idx = last_copied_idx + length (uncopied_text); end; /* just copied in the previously uncopied text */ expanded_line_lth = expanded_line_lth + ape.value_lth; substr (expanded_line, (last_expanded_idx + 1), ape.value_lth) = ape.value; last_expanded_idx = last_expanded_idx + ape.value_lth; expanded_line_lth = last_expanded_idx; last_copied_idx = last_copied_idx + break_idx - 1; end; /* just "copied" in the abbrev */ end; recognize_bol_abbrevs = "0"b; /* not anymore */ end; end; start = start + break_idx + break_lth - 1; /* to character after the break sequence */ if start <= input_line_lth then do; /* something left on line: check special characters */ if ape_ptr ^= null () then do; if substr (ltrim (reverse (expanded_line)), 1, length (SEMICOLON)) = SEMICOLON | substr (ltrim (reverse (expanded_line)), 1, length (LEFT_BRACKET)) = LEFT_BRACKET | substr (ltrim (reverse (expanded_line)), 1, length (VERTICAL_BAR || SEMICOLON)) = VERTICAL_BAR || SEMICOLON then recognize_bol_abbrevs = "1"b; end; if (start - 1) > 0 then /* ... don't reference off the end */ break_character = substr (input_line, (start - 1), 1); else break_character = SP; /* ... assume a space before the line */ if (break_character = NL) | (break_character = SEMICOLON) | (break_character = LEFT_BRACKET) then recognize_bol_abbrevs = "1"b; else if (break_character = VERTICAL_BAR) then do; if substr (input_line, (start - length (SEMICOLON || VERTICAL_BAR)), length (SEMICOLON)) = SEMICOLON then recognize_bol_abbrevs = "1"b; end; else recognize_bol_abbrevs = recognize_bol_abbrevs & (index (WHITE_SPACE, break_character) ^= 0); if break_character = QUOTE then do; begin; dcl rest_of_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start); found_end = "0"b; /* a quoted string: ignore everything inside it */ last_quote_idx = 0; do while (^found_end); begin; dcl rest_of_rest_of_line character (length (rest_of_line) - last_quote_idx) unaligned defined (input_line) position (start + last_quote_idx); idx = index (rest_of_rest_of_line, QUOTE); if idx = 0 then idx = length (rest_of_rest_of_line) + 1; if (idx + 1) <= length (rest_of_rest_of_line) then if substr (rest_of_rest_of_line, (idx + 1), 1) = QUOTE then last_quote_idx = last_quote_idx + idx + 1; else do; last_quote_idx = last_quote_idx + idx; found_end = "1"b; end; else do; /* unbalanced quotes */ last_quote_idx = length (rest_of_line) + 1; found_end = "1"b; end; end; end; end; start = start + last_quote_idx; end; end; end; if extended_stack | used_temp_segment then do; /* had to copy user's input */ begin; dcl uncopied_text character (input_line_lth - last_copied_idx) unaligned defined (input_line) position (last_copied_idx + 1); call make_space (length (uncopied_text)); expanded_line_lth = expanded_line_lth + length (uncopied_text); substr (expanded_line, (last_expanded_idx + 1), length (uncopied_text)) = uncopied_text; last_expanded_idx = last_expanded_idx + length (uncopied_text); end; expanded_line_lth = last_expanded_idx; end; return; %page; /* Searches the profile for an abbreviation (internal to expand_line): two versions of this procedure exist to insure that this one is quick */ lookup_abbrev: procedure () returns (pointer) /* options (quick) */; dcl offset fixed binary (18); do offset = abbrev_profile.hash_table (rank (substr (abbrev_name, 1, 1))) repeat (ape.next) while (offset ^= 0); ape_ptr = pointer (ap_ptr, offset); if ape.name = abbrev_name then return (ape_ptr); end; return (null ()); /* here iff not found */ end lookup_abbrev; %page; /* Insures that there is sufficient room either in the stack extension or in the temporary segment to add the requested number of characters to the current expansion of the command/request line (internal to expand_line) */ make_space: procedure (p_amount) /* options (quick) */; dcl p_amount fixed binary (21) parameter; dcl extension_ptr pointer; dcl new_size fixed binary (21); dcl amount_to_grow fixed binary (18); new_size = last_expanded_idx + p_amount; if (new_size <= MAX_STACK_EXTENSION) & ^used_temp_segment then if new_size > expansion_stack_space_lth then do; amount_to_grow = /* double extension or enough room to cover the new piece */ 16 * divide ((max (expansion_stack_space_lth, p_amount) + 63), 64, 18, 0); call cu_$grow_stack_frame (amount_to_grow, extension_ptr, code); if code ^= 0 then go to USE_TEMP_SEGMENT; if ^extended_stack then do; /* first time: don't set these variables unless ... */ extended_stack = "1"b; /* ... cu_$grow_stack_frame succeeds */ expansion_stack_space_ptr, expanded_line_ptr = extension_ptr; expanded_line_lth = 0; end; expansion_stack_space_lth = expansion_stack_space_lth + (4 * amount_to_grow); end; else ; /* already using stack extension and its still big enough */ else if new_size <= length (expansion_temp_segment) then USE_TEMP_SEGMENT: /* try to use a segment for the expansion */ if ^used_temp_segment then do; /* ... first time: get the segment ... */ call get_temp_segment_ (ABBREV, expansion_temp_segment_ptr, code); if code ^= 0 then go to RETURN_FROM_ABBREV_PROCESSOR; if extended_stack then do; /* ... and copy whatever was on the stack */ substr (expansion_temp_segment_ptr -> expanded_line, 1, last_expanded_idx) = substr (expansion_stack_space_ptr -> expanded_line, 1, last_expanded_idx); call cu_$shrink_stack_frame (expansion_stack_space_ptr, (0)); extended_stack = "0"b; end; expanded_line_ptr = expansion_temp_segment_ptr; used_temp_segment = "1"b; end; else ; /* already using the temporary segment */ else do; /* expansion won't fit into a segment */ code = error_table_$command_line_overflow; go to RETURN_FROM_ABBREV_PROCESSOR; end; return; end make_space; end; %page; /* Process an abbrev request line */ process_request_line: procedure () options (non_quick); dcl profile_dirname character (168); dcl (request_name, token, profile_ename) character (32); dcl new_escape_character character (1) aligned; dcl used fixed binary (21); start = start + 1; /* pass over the request character */ input_line_lth = length (rtrim (input_line, WHITE_SPACE_AND_NL)); /* strip trailing whitespace */ begin; dcl request_line character (input_line_lth - start + 1) unaligned defined (input_line) position (start); /* the request line (without the request character) */ /* Self-identify request ("."): not accepted in subsystems where there is usually a "." request which identifies the subsystem itself */ if length (request_line) = 0 then if subsystem_entry then do; null_line = "1"b; /* don't bother to remember this request line */ go to EXPANSION_IS_INPUT_LINE; end; else do; call ioa_ ("^a ^a", ABBREV, abbrev_data_$version); return; end; /* Quit abbrev: doesn't require the profile to exist; not accepted in subsystems */ if (request_line = "quit") | (request_line = "q") then do; if subsystem_entry then call com_err_ (0, ABBREV, """^aq"" is not valid within subsystems.", abbrev_state.escape_character); else do; /* Multics command level */ if abbrev_state.set_cp then do; /* ... we were the command processor: reset it */ call cu_$set_command_processor (abbrev_state.previous_command_processor); abbrev_state.set_cp = "0"b; end; if abbrev_state.profile_ptr ^= null () then call terminate_file_ (abbrev_state.profile_ptr, 0, TERM_FILE_TERM, (0)); end; /* ... and we no longer know where the profile is */ return; end; /* ". ": pass the rest of the line to the previous command processor without expansion or remembering */ if substr (request_line, 1, 1) = " " then begin; dcl rest_of_line character (length (request_line) - 1) unaligned defined (input_line) position (start + 1); if subsystem_entry then call P_subsys_cp (P_subsystem_name, P_sci_ptr, P_execute_request, P_subsys_cp_info_ptr, rest_of_line, code); else call abbrev_state.command_processor (addr (rest_of_line), length (rest_of_line), code); go to RETURN_FROM_ABBREV_PROCESSOR; /* reflect execution's error code to caller */ end; /* Remaining requests use the parsed version of the request line */ used = 0; /* haven't look at the line yet */ request_name = get_token (); /* get the request name */ if (request_name = "use") | (request_name = "u") then do; call do_use_request (); /* switch profiles */ return; end; else if request_name = "terminate_process" then do; call validate_no_arguments ("terminate_process"); code = pointer (baseptr (-2), "400000"b3) -> based_word; end; /* terminates the process without prejudice */ else if request_name = "debug" then do; call validate_no_arguments ("debug"); call ioa_ ("debug:"); call debug_entry_variable (); /* invokes debug in a possibly damaged process */ return; end; else if request_name = "probe" then do; call validate_no_arguments ("probe"); call probe_entry_variable (); /* invokes probe in a possibly damaged process */ return; end; else if request_name = "?" then do; /* display request list */ call do_help_request (); return; end; call set_profile_ptr ("0"b); /* all other requests require that the profile exist */ /* Print the pathname of the current profile */ if (request_name = "profile") | (request_name = "p") then do; call validate_no_arguments ("p"); /* use short name for compatibility with documentation */ call hcs_$fs_get_path_name (ap_ptr, profile_dirname, (0), profile_ename, (0)); call ioa_ ("^a", pathname_ (profile_dirname, profile_ename)); end; /* Set/reset remember mode: in remember mode, abbrev will save the expansion of the last command/request line executed */ else if (request_name = "remember") | (request_name = "r") then do; call validate_no_arguments ("r"); abbrev_state.remember_lines = "1"b; /* just set the flag */ end; else if (request_name = "forget") | (request_name = "f") then do; call validate_no_arguments ("f"); abbrev_state.remember_lines = "0"b; /* stop remembering and get rid of old remembered line ... */ if abbrev_state.remembered_line_buffer_ptr ^= null () then free remembered_line_buffer in (system_area); abbrev_state.remembered_line_buffer_ptr = null (); abbrev_state.remembered_line_buffer_lth, abbrev_state.remembered_line_lth = 0; end; /* Set the escape character which is the trigger for request lines */ else if (request_name = "escape") | (request_name = "esc") then do; token = get_token (); /* is there a new request character? */ if token ^= "" then /* ... yes: make sure it's not too long */ if length (rtrim (token)) > length (abbrev_state.escape_character) then call com_err_ (0, ABBREV, "The escape sequence must be a single character; not ""^a"".", token); else do; /* ... length is OK */ new_escape_character = substr (token, 1, 1); token = get_token (); if token = "" then /* ... nothing else on the line */ abbrev_state.escape_character = new_escape_character; else call com_err_ (0, ABBREV, "Only one escape character may be specified. ""^a""", token); end; else call ioa_ ("Abbrev escape character: ^a", abbrev_state.escape_character); end; /* Following requests are all complex enough that they are each implemented as separate internal procedures */ else if (request_name = "show") | (request_name = "s") then call do_show_request (); /* show an expansion */ else if (request_name = "l") | (request_name = "la") | (request_name = "lab") | (request_name = "la^b") | (request_name = "lb") | (request_name = "l^b") | (request_name = "ls") | (request_name = "lsb") | (request_name = "ls^b") | (request_name = "lx") | (request_name = "lxb") | (request_name = "lx^b") then call do_list_request (); /* list one or more abbrev definitions */ else if (request_name = "a") | (request_name = "af") | (request_name = "ab") | (request_name = "abf") then call do_add_request (); /* define a new abbreviation */ else if (request_name = "delete") | (request_name = "dl") | (request_name = "d") then call do_delete_request (); /* delete one or more abbreviations */ else if (request_name = "rename") | (request_name = "rn") then call do_rename_request (); /* rename one or more abbreviations */ else if request_name = "edit" then call do_edit_request (); /* edit the definition of an abbreviation */ else if (request_name = "switch_on") | (request_name = "swn") then call do_switch_request ("1"b); /* turn on switches for one or more abbreviations */ else if (request_name = "switch_off") | (request_name = "swf") then call do_switch_request ("0"b); /* turn off switches for one or more abbreviations */ /* Here iff the request is not recognized */ else call com_err_ (error_table_$request_not_recognized, ABBREV, """^a^a""", abbrev_state.escape_character, request_name); return; %page; /* Switch to another profile (internal to process_request_line begin block): if no profile pathname is given, reverts to the default profile; otherwise, the given pathname is abbrev expanded (if possible) before we actually try to use it as a convenience */ do_use_request: procedure (); dcl expanded_pathname_buffer character (256); dcl expanded_pathname character (expanded_pathname_lth) based (expanded_pathname_ptr); dcl expanded_pathname_lth fixed binary (21); dcl expanded_pathname_ptr pointer; dcl new_profile_dirname character (168); dcl (new_profile_ename) character (32); dcl new_profile_ptr pointer; dcl created_here bit (1) aligned; dcl try_to_create bit (1); /* command_query_$yes_no is declared wrong... */ call skip_whitespace (); /* find start of pathname */ begin; dcl original_pathname character (length (request_line) - used) unaligned defined (input_line) position (start + used); new_profile_ptr = null (); /* haven't gotten it yet */ call set_profile_ptr ("1"b); /* try to get the current profile */ if original_pathname = "" then do; /* reset to default profile */ call terminate_old_profile (); if subsystem_entry then /* ... reset to default for this invocation */ P_profile_ptr = null (); else call get_default_profile ("1"b); return; end; if abbrev_state.profile_ptr = null () then do; expanded_pathname_ptr = addr (original_pathname); expanded_pathname_lth = length (original_pathname); end; else call abbrev_$expand_line (EXPAND_INTERNAL_ONLY, addr (original_pathname), length (original_pathname), addr (expanded_pathname_buffer), length (expanded_pathname_buffer), expanded_pathname_ptr, expanded_pathname_lth); if substr (expanded_pathname, 1, length (QUOTE)) = QUOTE then if substr (expanded_pathname, expanded_pathname_lth, length (QUOTE)) = QUOTE then expanded_pathname = substr (expanded_pathname, 2, expanded_pathname_lth - 2); /* remove one level of quotes */ else do; call com_err_ (error_table_$unbalanced_quotes, ABBREV, expanded_pathname); return; end; else ; call expand_pathname_$add_suffix (expanded_pathname, "profile", new_profile_dirname, new_profile_ename, code); if code ^= 0 then /* before we release the storage */ call com_err_ (code, ABBREV, "^a", expanded_pathname); if (expanded_pathname_ptr ^= addr (original_pathname)) & (expanded_pathname_ptr ^= addr (expanded_pathname_buffer)) then free expanded_pathname in (system_area); if code ^= 0 then return; /* ... message already printed */ created_here = "0"b; /* assume we find it */ call initiate_file_ (new_profile_dirname, new_profile_ename, R_ACCESS, new_profile_ptr, (0), code); if code ^= 0 then if code = error_table_$noentry then do; call command_query_$yes_no (try_to_create, 0, ABBREV, "", "Profile ^a not found. Do you want to create it?", pathname_ (new_profile_dirname, new_profile_ename)); if try_to_create then call initiate_file_$create (new_profile_dirname, new_profile_ename, RW_ACCESS, new_profile_ptr, created_here, (0), code); else return; /* user doesn't want to try */ end; if code ^= 0 then do; call com_err_ (code, ABBREV, "^a", pathname_ (new_profile_dirname, new_profile_ename)); return; /* couldn't switch ... */ end; call terminate_old_profile (); if subsystem_entry then /* change this invocation's profile */ P_profile_ptr, ap_ptr = new_profile_ptr; else abbrev_state.profile_ptr, ap_ptr = new_profile_ptr; /* change command level's profile */ call initialize_profile (^created_here, created_here); return; end; /* Terminate the old profile segment (internal to do_use_request) */ terminate_old_profile: procedure (); if ap_ptr ^= null () then /* terminate the old profile ... */ if subsystem_entry then /* ... but only if not the subsystem's default profile */ if (ap_ptr ^= P_default_profile_ptr) & ((P_default_profile_ptr ^= null ()) | ((P_default_profile_ptr = null ()) & (P_profile_ptr ^= null ()))) then call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0)); else ; else call terminate_file_ (ap_ptr, 0, TERM_FILE_TERM, (0)); return; end terminate_old_profile; end do_use_request; %page; /* Show an expansion (internal to process_request_line begin block): if anything else is present on the line, expand it; otherwise, show the last expansion if remember mode is set */ do_show_request: procedure (); dcl result_line character (result_line_lth) based (result_line_ptr); dcl result_line_lth fixed binary (21); dcl result_line_ptr pointer; call skip_whitespace (); /* skip to request line (if any) */ if used < length (request_line) then begin; dcl rest_of_line character (length (request_line) - used) unaligned defined (input_line) position (start + used); call abbrev_$expanded_line (addr (rest_of_line), length (rest_of_line), null (), 0, result_line_ptr, result_line_lth); call ioa_ ("^a", result_line); free result_line in (system_area); /* guarenteed to have been allocated */ end; else if abbrev_state.remember_lines then if abbrev_state.remembered_line_lth > 0 then call ioa_$nnl ("^a^[^/^]", remembered_line, (substr (remembered_line, abbrev_state.remembered_line_lth, 1) ^= NL)); else call com_err_ (0, ABBREV, "Nothing has been remembered yet."); else call com_err_ (0, ABBREV, "Remember mode is not enabled."); return; end do_show_request; %page; /* List one or more abbreviation definitions (internal to process_request_line begin block): options are to list all abbrevs, specific abbrevs, or all abbrevs which start with a given character sequence */ do_list_request: procedure (); dcl 1 list aligned based (list_segment_ptr), 2 n_abbrevs fixed binary, 2 pad bit (36), 2 abbrevs (0 refer (list.n_abbrevs)) like lae; dcl list_segment_ptr pointer; dcl 1 lae aligned based, 2 name character (8), 2 ptr pointer; dcl 1 list_sort_list aligned based (list_sort_list_ptr), 2 n fixed binary, 2 ptrs (0 refer (list.n_abbrevs)) pointer unaligned; dcl list_sort_list_ptr pointer; dcl offset fixed binary (18); dcl (hash_slot, previous_n_abbrevs, token_lth, idx) fixed binary; dcl exact_match bit (1) aligned; dcl (la, ls, lx, bol, nbol) bit (1); dcl emessage char (64); call skip_whitespace (); /* ".la" requires some arguments */ if used = length (request_line) & request_name ^= "l" & request_name ^= "lb" & request_name ^= "l^b" then do; call com_err_ (0, ABBREV, " Usage: ^a^a STRs", abbrev_state.escape_character, request_name); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; call get_temp_segment_ (ABBREV, list_segment_ptr, code); if code ^= 0 then do; call com_err_ (code, ABBREV, "Getting sorting space for listing abbreviations."); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; on condition (cleanup) begin; if list_segment_ptr ^= null () then call release_temp_segment_ (ABBREV, list_segment_ptr, (0)); end; exact_match = request_name = "l" | request_name = "lb" | request_name = "l^b"; la = substr (request_name, 1, 2) = "la"; ls = substr (request_name, 1, 2) = "ls"; lx = substr (request_name, 1, 2) = "lx"; bol = index (request_name, "b") ^= 0 & index (request_name, "^") = 0; nbol = index (request_name, "b") ^= 0 & index (request_name, "^") ^= 0; if exact_match & (used = length (request_line)) then do; list.n_abbrevs = 0; /* list all abbreviations */ do hash_slot = lbound (abbrev_profile.hash_table, 1) to hbound (abbrev_profile.hash_table, 1); do offset = abbrev_profile.hash_table (hash_slot) repeat (ape.next) while (offset ^= 0); ape_ptr = pointer (ap_ptr, offset); if ape.name ^= "" then do; if request_name = "l" then call set_list_entry (); if request_name = "lb" then do; if ape.bol then call set_list_entry (); end; if request_name = "l^b" then do; if ^ape.bol then call set_list_entry (); end; end; end; end; if list.n_abbrevs = 0 then do; call com_err_ (0, ABBREV, "No abbreviations defined."); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; /* cleanup handler gets the temp segment */ end; else if exact_match then do; /* list explicit abbreviations */ list.n_abbrevs = 0; do token = get_token () repeat (get_token ()) while (token ^= ""); if length (rtrim (token)) > length (ape.name) then call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""", length (ape.name), token); else do; ape_ptr = lookup_abbrev (token); if ape_ptr = null () then /* not found */ call com_err_ (0, ABBREV, """^a"" is not defined.", token); else do; if request_name = "l" then call set_list_entry (); if request_name = "lb" then do; if ape.bol then call set_list_entry (); end; if request_name = "l^b" then do; if ^ape.bol then call set_list_entry (); end; end; end; end; if list.n_abbrevs = 0 then go to RETURN_FROM_PROCESS_REQUEST_LINE; end; /* didn't find any at all */ else do; /* list all abbreviations starting with the given string */ list.n_abbrevs = 0; do token = get_token () repeat (get_token ()) while (token ^= ""); previous_n_abbrevs = list.n_abbrevs; token_lth = length (rtrim (token)); if (token_lth > length (ape.name)) & ^lx then call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""", length (ape.name), token); else do; do hash_slot = lbound (abbrev_profile.hash_table, 1) to hbound (abbrev_profile.hash_table, 1); do offset = abbrev_profile.hash_table (hash_slot) repeat (ape.next) while (offset ^= 0); ape_ptr = pointer (ap_ptr, offset); if ape.name ^= "" then do; if ^bol & ^nbol then call set_list_entry (); if bol & ape.bol then call set_list_entry (); else if nbol & ^ape.bol then call set_list_entry (); end; end; end; if previous_n_abbrevs = list.n_abbrevs then do; emessage = ""; if la then emessage = "No abbreviations defined which start with"; else if lx then emessage = "No abbreviation expansions defined which contain"; else emessage = "No abbreviations defined which contain"; call com_err_ (0, ABBREV, "^a ""^a"".", emessage, token); end; end; end; if list.n_abbrevs = 0 then go to RETURN_FROM_PROCESS_REQUEST_LINE; end; list_sort_list_ptr = pointer (list_segment_ptr, currentsize (list)); list_sort_list.n = list.n_abbrevs; do idx = 1 to list_sort_list.n; list_sort_list.ptrs (idx) = addr (list.abbrevs (idx).name); end; call sort_items_$char (list_sort_list_ptr, length (ape.name)); do idx = 1 to list_sort_list.n; ape_ptr = list_sort_list.ptrs (idx) -> lae.ptr; call ioa_ ("^[b^;^x^]^x^a^12t^a", ape.bol, ape.name, ape.value); end; call release_temp_segment_ (ABBREV, list_segment_ptr, (0)); return; set_list_entry: proc (); if ^ls & ^lx & ^la then go to set_entry; if la then do; if token = substr (ape.name, 1, token_lth) then go to set_entry; return; end; if ls then do; if index (ape.name, substr (token, 1, token_lth)) ^= 0 then go to set_entry; return; end; if lx then do; if index (ape.value, substr (token, 1, token_lth)) ^= 0 then go to set_entry; return; end; set_entry: list.n_abbrevs, idx = list.n_abbrevs + 1; list.abbrevs (idx).name = ape.name; list.abbrevs (idx).ptr = ape_ptr; return; end set_list_entry; end do_list_request; %page; /* Defines a new abbreviation (internal to process_request_line begin block): if the abbreviation is already defined and the user did not explicitly request to overwrite it, ask the user if they wish to redefine the abbreviation */ do_add_request: procedure (); dcl last_ape_ptr pointer; dcl abbrev_name character (32); dcl (old_size, hash_slot) fixed binary (18); dcl (force, bol) bit (1) aligned; dcl add_it bit (1); if ^write_access () then do; call com_err_ (error_table_$moderr, ABBREV, "Can not add abbreviations to profile ^a", profile_pathname ()) ; go to RETURN_FROM_PROCESS_REQUEST_LINE; end; token = get_token (); /* pick up name of the abbreviation */ if token = "" then do; /* no abbreviation */ PRINT_ADD_REQUEST_USAGE: call com_err_ (0, ABBREV, " Usage: ^a^a name expansion", abbrev_state.escape_character, request_name); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; abbrev_name = token; /* save it */ if ^validate_abbrev_name (abbrev_name) then go to RETURN_FROM_PROCESS_REQUEST_LINE; call skip_whitespace (); /* find the definition */ if used = length (request_line) then go to PRINT_ADD_REQUEST_USAGE; force = (request_name = "af") | (request_name = "abf"); bol = (request_name = "ab") | (request_name = "abf"); begin; dcl definition character (length (request_line) - used) unaligned defined (input_line) position (start + used); ape_ptr = lookup_abbrev (abbrev_name); /* see if it's already defined */ if ape_ptr ^= null () then /* already defined ... */ if force then do; /* ... and the user wants it redefined */ OVERWRITE_PREVIOUS_DEFINITION: if ape.value_lth >= length (definition) then do; old_size = currentsize (ape); /* ... enough room in old entry for new definition */ ape.bol = bol; /* ... redefinition could change this value */ ape.value_lth = length (definition); ape.value = definition; abbrev_profile.garbage = abbrev_profile.garbage + old_size - currentsize (ape); end; else do; /* ... not enough room: delete it and add to the end */ ape.name = ""; abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape); go to CREATE_NEW_DEFINITION; end; end; else do; /* ... user didn't know it: ask them about it */ call command_query_$yes_no (add_it, 0, ABBREV, "", "Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it?", ape.bol, ape.name, ape.value); if add_it then go to OVERWRITE_PREVIOUS_DEFINITION; end; /* if answer is no we fall through and do nothing */ else do; /* brand new abbreviation ... */ CREATE_NEW_DEFINITION: ape_ptr = pointer (ap_ptr, abbrev_profile.next_free); substr (ape.name, 1, length (ape.name)) = substr (abbrev_name, 1, length (ape.name)); ape.next = 0; /* last abbreviation in this bucket */ string (ape.flags) = ""b; ape.bol = bol; ape.value_lth = length (definition); ape.value = definition; abbrev_profile.next_free = abbrev_profile.next_free + currentsize (ape); hash_slot = rank (substr (abbrev_name, 1, 1)); if abbrev_profile.hash_table (hash_slot) = 0 then abbrev_profile.hash_table (hash_slot) = fixed (rel (ape_ptr), 18, 0); else do; /* add to end of the chain */ do last_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (hash_slot)) repeat (pointer (ap_ptr, last_ape_ptr -> ape.next)) while (last_ape_ptr -> ape.next ^= 0); end; last_ape_ptr -> ape.next = fixed (rel (ape_ptr), 18, 0); end; end; end; call compact_profile_if_needed ("1"b); return; end do_add_request; %page; /* Deletes one or more abbreviation definitions (internal to process_request_line begin block) */ do_delete_request: procedure (); if ^write_access () then do; call com_err_ (error_table_$moderr, ABBREV, "Can not delete abbreviations from profile ^a", profile_pathname ()); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; call skip_whitespace (); /* make sure there are some abbreviations to delete */ if used = length (request_line) then do; call com_err_ (0, ABBREV, " Usage: ^ad names", abbrev_state.escape_character); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; do token = get_token () repeat (get_token ()) while (token ^= ""); if length (rtrim (token)) > length (ape.name) then call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""", length (ape.name), token); else do; /* abbreviation name is the right length at least */ ape_ptr = lookup_abbrev (token); if ape_ptr = null () then call com_err_ (0, ABBREV, """^a"" is not defined.", token); else do; /* found it... */ ape.name = ""; /* ... mark it as deleted */ abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape); end; end; end; call compact_profile_if_needed ("0"b); return; end do_delete_request; %page; /* Renames one or more abbreviations */ do_rename_request: procedure (); dcl (old_abbrev_name, new_abbrev_name) character (32); dcl (old_ape_ptr, new_ape_ptr, the_ape_ptr, prior_ape_ptr) pointer; dcl rename_it bit (1); dcl (old_hash_slot, new_hash_slot) fixed binary; if ^write_access () then do; call com_err_ (error_table_$moderr, ABBREV, "Can not rename abbreviations in profile ^a.", profile_pathname ()); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; old_abbrev_name = get_token (); if old_abbrev_name = "" then do; /* nothing given at all ... */ call com_err_ (0, ABBREV, "Usage: ^arename old_name1 new_name1 {... old_nameN new_nameN}", abbrev_state.escape_character); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; do while (old_abbrev_name ^= ""); /* as long as there's at least one name */ new_abbrev_name = get_token (); if new_abbrev_name = "" then do; /* odd number of arguments */ call com_err_ (error_table_$noarg, ABBREV, "New name for abbreviation ""^a"".", old_abbrev_name); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; old_ape_ptr = lookup_abbrev (old_abbrev_name); if old_ape_ptr ^= null () then /* really is something to rename */ if validate_abbrev_name (new_abbrev_name) then do; new_ape_ptr = lookup_abbrev (new_abbrev_name); if new_ape_ptr = null () then do; /* new name not yet used ... */ RENAME_THE_OLD_ABBREVIATION: /* ... OK to rename */ old_hash_slot = rank (substr (old_abbrev_name, 1, 1)); new_hash_slot = rank (substr (new_abbrev_name, 1, 1)); if old_hash_slot = new_hash_slot then /*** same hash for both names: just rename it */ substr (old_ape_ptr -> ape.name, 1, length (old_ape_ptr -> ape.name)) = substr (new_abbrev_name, 1, length (old_ape_ptr -> ape.name)); else do; /*** different hash: splice the abbrev out of the old chain ... */ prior_ape_ptr = null (); do the_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (old_hash_slot)) repeat (pointer (ap_ptr, the_ape_ptr -> ape.next)) while ((the_ape_ptr ^= old_ape_ptr) & (the_ape_ptr -> ape.next ^= 0)); prior_ape_ptr = the_ape_ptr; end; if the_ape_ptr ^= old_ape_ptr then call abort_abbrev_processor (error_table_$bad_segment, "^a", profile_pathname ()); if prior_ape_ptr = null () then abbrev_profile.hash_table (old_hash_slot) = old_ape_ptr -> ape.next; else prior_ape_ptr -> ape.next = old_ape_ptr -> ape.next; /*** ... and add it to the end of its new chain */ substr (old_ape_ptr -> ape.name, 1, length (old_ape_ptr -> ape.name)) = substr (new_abbrev_name, 1, length (old_ape_ptr -> ape.name)); old_ape_ptr -> ape.next = 0; if abbrev_profile.hash_table (new_hash_slot) = 0 then abbrev_profile.hash_table (new_hash_slot) = fixed (rel (old_ape_ptr), 18, 0); else do; do prior_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (new_hash_slot)) repeat (pointer (ap_ptr, prior_ape_ptr -> ape.next)) while (prior_ape_ptr -> ape.next ^= 0); end; prior_ape_ptr -> ape.next = fixed (rel (old_ape_ptr), 18, 0); end; end; end; else do; /* new name already used: get permission to redefine */ call command_query_$yes_no (rename_it, 0, ABBREV, "", "Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it by renaming:^/^3x^[b^;^x^]^x^a^15t^a^/to ""^a""?", new_ape_ptr -> ape.bol, new_ape_ptr -> ape.name, new_ape_ptr -> ape.value, old_ape_ptr -> ape.bol, old_ape_ptr -> ape.name, old_ape_ptr -> ape.value, new_ape_ptr -> ape.name); if rename_it then do; /* ... delete the old definition */ new_ape_ptr -> ape.name = ""; abbrev_profile.garbage = abbrev_profile.garbage + currentsize (new_ape_ptr -> ape); go to RENAME_THE_OLD_ABBREVIATION; end; end; /* ... a no falls through to do next rename (if any) */ end; else ; /* validate_abbrev_name has already complained */ else call com_err_ (0, ABBREV, """^a"" is not defined.", old_abbrev_name); old_abbrev_name = get_token (); end; call compact_profile_if_needed ("0"b); return; end do_rename_request; %page; /* Edits the definition of one or more abbreviations (internal to process_request_line begin block) via qedx_ */ do_edit_request: procedure (); dcl 1 local_qi aligned, /* data to invoke the editor */ 2 header like qedx_info.header, 2 buffer like qedx_info.buffers; dcl initial_abbrev_name character (32); if ^write_access () then do; call com_err_ (error_table_$moderr, ABBREV, "Can not edit abbreviations in profile ^a.", profile_pathname ()); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; /* Parse arguments: exactly one allowed -- the name of an existing abbreviation */ initial_abbrev_name = get_token (); /* get name of abbreviation to start editing */ if initial_abbrev_name = "" then do; PRINT_EDIT_REQUEST_USAGE: call com_err_ (0, ABBREV, "Usage: ^aedit name", abbrev_state.escape_character); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; token = get_token (); /* shouldn't be anything else... */ if token ^= "" then go to PRINT_EDIT_REQUEST_USAGE; if ^validate_abbrev_name (initial_abbrev_name) then go to RETURN_FROM_PROCESS_REQUEST_LINE; /* invalid name */ ape_ptr = lookup_abbrev (initial_abbrev_name); if ape_ptr = null () then do; /* the abbreviation must exist */ call com_err_ (0, ABBREV, """^a"" is not defined.", initial_abbrev_name); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; /* Print the abbreviation's definition and the editor prompt */ call ioa_ ("^[b^;^x^]^x^a^12t^a", ape.bol, ape.name, ape.value); call ioa_ ("Edit:"); /* Setup and invoke the editor */ local_qi.version = QEDX_INFO_VERSION_1; local_qi.editor_name = ABBREV; local_qi.buffer_io = abbrev_io; /* we will read/write definitions directly */ string (local_qi.header.flags) = ""b; local_qi.query_if_modified, local_qi.caller_does_io = "1"b; local_qi.n_buffers = 1; local_qi.buffer_name = "0"; /* buffer "0": the default buffer */ local_qi.buffer_pathname = initial_abbrev_name; /* ... fill it with definition user wants edited */ string (local_qi.buffer.flags) = ""b; /* ... let the caller switch abbreviations */ call qedx_ (addr (local_qi), (0)); /* do it */ return; /* needn't check the code */ %page; /* Read/write an abbreviation's definition to the editor's buffer (internal to do_edit_request) */ abbrev_io: procedure (p_qbii_ptr, p_ok); dcl p_qbii_ptr pointer parameter; dcl p_ok bit (1) aligned parameter; dcl 1 qbii aligned based (qbii_ptr) like qedx_buffer_io_info; dcl qbii_value character (qbii.buffer_lth) based (qbii.buffer_ptr); dcl last_ape_ptr pointer; dcl (old_size, hash_slot) fixed binary (18); dcl bol bit (1) aligned; dcl redefine_it bit (1); qbii_ptr = p_qbii_ptr; if qbii.version ^= QEDX_BUFFER_IO_INFO_VERSION_1 then do; call com_err_ (error_table_$unimplemented_version, ABBREV, "Buffer I/O from qedx_."); p_ok = "0"b; end; else if qbii.direction = QEDX_READ_FILE then do; /* Fetch abbreviation definition from profile */ if validate_abbrev_name (rtrim (qbii.pathname)) then do; ape_ptr = lookup_abbrev (rtrim (qbii.pathname)); if ape_ptr ^= null () then /* ... it exists */ if (ape.value_lth + 1) <= qbii.buffer_max_lth then do; qbii.buffer_lth = ape.value_lth; qbii_value = ape.value; if substr (qbii_value, qbii.buffer_lth, 1) ^= NL then do; qbii.buffer_lth = qbii.buffer_lth + 1; substr (qbii_value, qbii.buffer_lth, 1) = NL; end; p_ok = "1"b; /* ... success */ end; else do; /* ... won't fit */ call com_err_ (0, qbii.editor_name, "Definition of ""^a"" is too large for the editor.", qbii.pathname); p_ok = "0"b; end; else do; /* ... no such abbreviation */ call com_err_ (0, qbii.editor_name, """^a"" is not defined.", qbii.pathname); p_ok = "0"b; end; end; else p_ok = "0"b; /* ... illegal abbreviation name */ end; else if qbii.direction = QEDX_WRITE_FILE then do; /* Write the editor's buffer as the definition of an abbreviation: if the abbreviation doesn't already exist, it will be created as an expand-anywhere abbrevation */ if validate_abbrev_name (rtrim (qbii.pathname)) then do; if substr (qbii_value, qbii.buffer_lth, 1) = NL then qbii.buffer_lth = qbii.buffer_lth - 1; /* strip trailing newline added for convenience */ ape_ptr = lookup_abbrev (rtrim (qbii.pathname)); if ape_ptr ^= null () then do; /* already defined ... */ bol = ape.bol; /* ... in case we have to move it elsewhere */ if ^qbii.default_pathname then do; /* ... not the abbrev being edited by default: query ... */ call command_query_$yes_no (redefine_it, 0, ABBREV, "", "Abbreviation is already defined as:^/^3x^[b^;^x^]^x^a^15t^a^/Do you wish to redefine it?", ape.bol, ape.name, ape.value); if ^redefine_it then do; /* ... ... user didn't realize and didn't mean it */ p_ok = "0"b; return; end; end; /* ... ...user says it's OK anyway */ if ape.value_lth >= qbii.buffer_lth then do; old_size = currentsize (ape); ape.value_lth = qbii.buffer_lth; ape.value = qbii_value; abbrev_profile.garbage = abbrev_profile.garbage + old_size - currentsize (ape); end; else do; /* ... not enough room: delete it and add to the end */ ape.name = ""; abbrev_profile.garbage = abbrev_profile.garbage + currentsize (ape); go to CREATE_NEW_DEFINITION; end; end; else do; /* ... brand new abbreviation ... */ bol = "0"b; /* ... defaults to anywhere on line expansion */ CREATE_NEW_DEFINITION: ape_ptr = pointer (ap_ptr, abbrev_profile.next_free); substr (ape.name, 1, length (ape.name)) = substr (qbii.pathname, 1, length (ape.name)); ape.next = 0; /* ... last abbreviation in this bucket */ string (ape.flags) = ""b; ape.bol = bol; ape.value_lth = qbii.buffer_lth; ape.value = qbii_value; abbrev_profile.next_free = abbrev_profile.next_free + currentsize (ape); hash_slot = rank (substr (qbii.pathname, 1, 1)); if abbrev_profile.hash_table (hash_slot) = 0 then abbrev_profile.hash_table (hash_slot) = fixed (rel (ape_ptr), 18, 0); else do; /* ... add to end of the chain */ do last_ape_ptr = pointer (ap_ptr, abbrev_profile.hash_table (hash_slot)) repeat (pointer (ap_ptr, last_ape_ptr -> ape.next)) while (last_ape_ptr -> ape.next ^= 0); end; last_ape_ptr -> ape.next = fixed (rel (ape_ptr), 18, 0); end; end; call compact_profile_if_needed ("1"b); p_ok = "1"b; /* success */ end; else p_ok = "0"b; /* ... illegal abbreviation name */ end; else do; /* will never get here, but ... */ call com_err_ (error_table_$bad_subr_arg, qbii.editor_name, "Buffer operation type ^d.", qbii.direction); p_ok = "0"b; end; return; end abbrev_io; end do_edit_request; %page; /* Turns the specified switch of one or more abbreviations on or off (internal to process_request_line begin block) */ do_switch_request: procedure (p_switch_value); dcl p_switch_value bit (1) aligned parameter; /* new value for the switch */ dcl (request_name, the_switch, abbrev_name) character (32); dcl switch_idx fixed binary; dcl (have_switch, first_abbrev) bit (1) aligned; /* format: off */ dcl SWITCH_NAMES (1, 2) character (32) static options (constant) initial ( "beginning_of_line", "bol"); /* format: on */ if ^write_access () then do; call com_err_ (error_table_$moderr, ABBREV, "Can not change abbreviation switches in profile ^a.", profile_pathname ()); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; if p_switch_value then request_name = "switch_on"; else request_name = "switch_off"; /* Get the name of the switch */ the_switch = get_token (); if the_switch = "" then do; PRINT_SWITCH_REQUEST_USAGE: call com_err_ (0, ABBREV, "Usage: ^a^a switch_name abbrev_names", abbrev_state.escape_character, request_name); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; have_switch = "0"b; /* let's lookup the name */ switch_idx = 0; do while (^have_switch & (switch_idx < hbound (SWITCH_NAMES, 1))); switch_idx = switch_idx + 1; /* ... PL/I do loop would do an extra increment */ if (the_switch = SWITCH_NAMES (switch_idx, 1)) | (the_switch = SWITCH_NAMES (switch_idx, 2)) then have_switch = "1"b; /* ... a good name */ end; if ^have_switch then do; /* foo */ call com_err_ (0, ABBREV, "Unrecognized switch name. ""^a""", the_switch); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; /* Now do it to the switch for the specified abbreviations */ first_abbrev = "1"b; /* for error message (later) */ abbrev_name = "foo"; /* PL/I lacks do until */ do while (abbrev_name ^= ""); /* while there are names left on the request line ... */ abbrev_name = get_token (); /* next abbreviation please */ if abbrev_name ^= "" then do; first_abbrev = "0"b; /* won't need a Usage message anymore */ if validate_abbrev_name (abbrev_name) then do; ape_ptr = lookup_abbrev (abbrev_name); if ape_ptr ^= null () then do; go to SET_SWITCH (switch_idx); SET_SWITCH (1): /* beginning of line */ ape.bol = p_switch_value; go to PROCEED_WITH_NEXT_ABBREVIATION; PROCEED_WITH_NEXT_ABBREVIATION: end; else call com_err_ (0, ABBREV, """^a"" is not defined.", abbrev_name); end; end; end; if first_abbrev then go to PRINT_SWITCH_REQUEST_USAGE; return; end do_switch_request; %page; /* Returns "1"b if the user has effective write access to the profile (internal to process_request_line begin block) */ write_access: procedure () returns (bit (1) aligned); dcl profile_mode fixed binary (5); call hcs_$fs_get_mode (ap_ptr, profile_mode, code); if code ^= 0 then do; call com_err_ (code, ABBREV, "Can not determine access to profile ^a", profile_pathname ()); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; return ((profile_mode = RW_ACCESS_BIN) | (profile_mode = REW_ACCESS_BIN)); end write_access; /* Validates that the given abbreviation name is legal */ validate_abbrev_name: procedure (p_abbrev_name) returns (bit (1) aligned); dcl p_abbrev_name character (32) parameter; /* the candidate abbreviation name */ dcl abbrev_name character (32) varying; dcl idx fixed binary; if length (rtrim (p_abbrev_name)) > length (ape.name) then do; call com_err_ (0, ABBREV, "Maximum length of an abbreviation name is ^d characters. ""^a""", length (ape.name), p_abbrev_name); return ("0"b); end; abbrev_name = rtrim (p_abbrev_name); /* copy it to strip trailing whitespace */ do idx = 1 to breaks_list.n_break_sequences; begin; dcl break_sequence character (breaks_list.break_sequences (idx).lth) unaligned defined (breaks_list.break_strings) position (breaks_list.break_sequences (idx).start); if index (abbrev_name, break_sequence) ^= 0 then do; call com_err_ (0, ABBREV, "Abbreviation names may not contain break sequences. ^a in ""^a""", break_sequence, abbrev_name); return ("0"b); end; end; end; return ("1"b); /* it's OK */ end validate_abbrev_name; %page; /* Skips to next non-white character in the request line (internal to process_request_line begin block) */ skip_whitespace: procedure (); dcl idx fixed binary (21); idx = verify (substr (request_line, (used + 1)), WHITE_SPACE_AND_NL); if idx = 0 then /* rest of the line is whitespace */ used = length (request_line); else used = used + idx - 1; /* found something */ return; end skip_whitespace; /* Returns the next token in the request line; tokens are delimited by whitespace (internal to process_request_line begin block) */ get_token: procedure () returns (character (32)); dcl (token_start, token_lth, idx) fixed binary (21); call skip_whitespace (); /* skip any leading whitespace */ if used = length (request_line) then /* nothing left ... */ return (""); idx = search (substr (request_line, (used + 1)), WHITE_SPACE); if idx = 0 then /* rest of the line is the token */ idx = length (request_line) - used + 1; token_start = used + 1; token_lth = idx - 1; used = used + token_lth; /* update amount we've looked at */ return (substr (request_line, token_start, token_lth)); end get_token; %page; /* Sets ap_ptr to locate the proper profile to be used for expansion in this case (internal to process_request_line begin block): initializes the profile if necessary; two versions of this procedure exist to insure that the one used during command/request line expansion is quick */ set_profile_ptr: procedure (p_dont_create_profile) /* options (quick) */; dcl p_dont_create_profile bit (1) aligned; ap_ptr = null (); /* start somewhere */ if subsystem_entry then /* subsystems use arbitrary profiles */ if (P_default_profile_ptr = null ()) & (P_profile_ptr = null ()) then /* ... use same profile as Multics command level */ if abbrev_state.profile_ptr = null () then call get_default_profile (p_dont_create_profile); /* ... need not succeed if called at expanded_line entry */ else ap_ptr = abbrev_state.profile_ptr; else do; /* subsystem supplied the profile */ if P_profile_ptr ^= null () then ap_ptr = P_profile_ptr; else ap_ptr = P_default_profile_ptr; call initialize_profile ("1"b, "0"b); /* ... make sure it's good */ end; else do; /* command level invocation */ if abbrev_state.profile_ptr = null () then call get_default_profile (p_dont_create_profile); /* ... need not succeed if called at expanded_line entry */ else ap_ptr = abbrev_state.profile_ptr; end; return; end set_profile_ptr; /* Searches the profile for an abbreviation (internal to process_request_line begin block): two versions of this procedure exist to insure that the one used by the expand_line procedure is quick */ lookup_abbrev: procedure (p_name) returns (pointer) /* options (quick) */; dcl p_name character (32) parameter; dcl offset fixed binary (18); do offset = abbrev_profile.hash_table (rank (substr (p_name, 1, 1))) repeat (ape.next) while (offset ^= 0); ape_ptr = pointer (ap_ptr, offset); if ape.name = p_name then return (ape_ptr); end; return (null ()); /* here iff not found */ end lookup_abbrev; %page; /* Validates that the remainder of the request line is blank and prints an error if it isn't (internal to process_request_line begin block) */ validate_no_arguments: procedure (p_request_name); dcl p_request_name character (*) parameter; call skip_whitespace (); if used ^= length (request_line) then do; call com_err_ (0, ABBREV, "The ""^a^a"" request does not accept arguments.", abbrev_state.escape_character, p_request_name); go to RETURN_FROM_PROCESS_REQUEST_LINE; end; return; end validate_no_arguments; /* Compact the profile if needed (internal to process_request_line begin block) */ compact_profile_if_needed: procedure (p_set_bit_count); dcl p_set_bit_count bit (1) aligned parameter; if (((4 * abbrev_profile.garbage) > abbrev_profile.next_free) | (abbrev_profile.garbage > 512)) & (abbrev_profile.garbage > mod (abbrev_profile.next_free, 1024)) then call compact_profile (); /* compact at 25% or half page wasted but only if the compaction will make it shorter */ else if p_set_bit_count then /* caller added something to the end: be sure bit count OK */ call terminate_file_ (ap_ptr, (36 * abbrev_profile.next_free), TERM_FILE_BC, (0)); return; end compact_profile_if_needed; %page; do_help_request: proc (); /* The ? (help) request */ dcl (element, ndx) fixed binary; call skip_whitespace (); if used = length (request_line) then do; /* No requests, do all */ call ioa_ ("Abbrev requests:"); do element = 1 to hbound (abbrev_rqd, 1); call display_help_line (abbrev_rqd (element)); end; end; else do token = get_token () repeat (get_token ()) while (token ^= ""); /* request(s) */ do element = 1 to hbound (ard, 1); if ard (element) = rtrim (token) then go to found_request; end; call com_err_ (0, ABBREV, """^a"" is not a legal abbrev request.", token); go to end_request_lookup; found_request: element = ardx (element); do ndx = 0 to 2; call display_help_line (abbrev_rqd (element + ndx)); end; end_request_lookup: end; return; display_help_line: proc (display_line); dcl display_line char (*) parameter; if display_line ^= "" then call ioa_ ("^a", display_line); return; end display_help_line; end do_help_request; end; RETURN_FROM_PROCESS_REQUEST_LINE: return; %page; %include qedx_info; %page; %include qedx_buffer_io_info; end process_request_line; %page; /* Garbage collect a profile */ compact_profile: procedure () options (non_quick); dcl 1 new_profile aligned based (new_profile_ptr) like abbrev_profile; dcl new_profile_ptr pointer; dcl new_profile_words (new_profile.next_free) bit (36) aligned based (new_profile_ptr); dcl 1 new_ape aligned based (new_ape_ptr), 2 header like ape.header, 2 value character (0 refer (new_ape.value_lth)); dcl new_ape_ptr pointer; dcl 1 old_profile aligned based (old_profile_ptr) like abbrev_profile; dcl 1 old_old_profile aligned based (old_profile_ptr), /* prior version */ 2 next_free fixed binary (18), 2 pad (3) bit (36), 2 hash_table (4:127) fixed binary (18); dcl old_profile_ptr pointer; dcl 1 old_ape aligned based (old_ape_ptr), 2 header like ape.header, 2 value character (0 refer (old_ape.value_lth)); dcl old_ape_ptr pointer; dcl old_style_profile bit (1) aligned; dcl old_profile_mode fixed binary (5); dcl (hash_slot, lower_hash_bound) fixed binary; dcl (first_offset, old_offset) fixed binary (18); dcl last_new_ape_ptr pointer; old_profile_ptr = ap_ptr; old_style_profile = (old_profile.version > 127); call hcs_$fs_get_mode (old_profile_ptr, old_profile_mode, code); if code ^= 0 then call abort_abbrev_processor (code, "Can not determine access to profile ^a", profile_pathname ()); if (old_profile_mode ^= RW_ACCESS_BIN) & (old_profile_mode ^= REW_ACCESS_BIN) then if old_style_profile then /* can't upgrade an old profile: can't use it */ call abort_abbrev_processor (error_table_$moderr, "Can not upgrade profile ^a to current version.", profile_pathname ()); else return; /* can't garbage collect it: doesn't matter */ call get_temp_segment_ (ABBREV, new_profile_ptr, code); if code ^= 0 then return; on condition (cleanup) begin; if new_profile_ptr ^= null () then call release_temp_segment_ (ABBREV, new_profile_ptr, code); end; new_profile.version = ABBREV_PROFILE_VERSION_1; new_profile.next_free = fixed (rel (addr (new_profile.data_space)), 18, 0); if old_style_profile then /* get right lower bound; upper bounds are the same */ lower_hash_bound = lbound (old_old_profile.hash_table, 1); else lower_hash_bound = lbound (old_profile.hash_table, 1); do hash_slot = lower_hash_bound to hbound (new_profile.hash_table, 1); last_new_ape_ptr = null (); if old_style_profile then /* get starting offset */ first_offset = old_old_profile.hash_table (hash_slot); else first_offset = old_profile.hash_table (hash_slot); do old_offset = first_offset repeat (old_ape.next) while (old_offset ^= 0); old_ape_ptr = pointer (old_profile_ptr, old_offset); if old_ape.name ^= "" then do; /* copy only if not deleted */ new_ape_ptr = pointer (new_profile_ptr, new_profile.next_free); new_ape.header = old_ape.header; /* makes refer extents work */ new_ape.next = 0; /* but no forward thread yet */ new_ape.value = old_ape.value; new_profile.next_free = new_profile.next_free + currentsize (new_ape); if last_new_ape_ptr = null () then /* first entry in this hash slot */ new_profile.hash_table (hash_slot) = fixed (rel (new_ape_ptr), 18, 0); else last_new_ape_ptr -> new_ape.next = fixed (rel (new_ape_ptr), 18, 0); last_new_ape_ptr = new_ape_ptr; end; end; end; old_profile_ptr -> new_profile_words = new_profile_ptr -> new_profile_words; /* put the new one in place */ call terminate_file_ (old_profile_ptr, (36 * new_profile.next_free), TERM_FILE_TRUNC_BC, (0)); call release_temp_segment_ (ABBREV, new_profile_ptr, (0)); return; end compact_profile; %page; %include "_abbrev_profile"; %page; %include access_mode_values; %include terminate_file; end abbrev;  abbrev_data_.cds 03/20/87 1234.3rew 03/20/87 1233.3 34695 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ /* Constant data used by the Multics abbrevation processor */ /* Created: March 1983 by G. Palter */ /* HISTORY COMMENTS: 1) change(86-06-20,Gilcrease), approve(86-06-25,MCR7409), audit(86-07-29,GWMay), install(86-08-04,MR12.0-1112): For hcom... Modified: June 1984 by G. Palter to add version string 2) change(86-06-20,Gilcrease), approve(86-06-25,MCR7409), audit(86-07-29,GWMay), install(86-08-04,MR12.0-1112): Install version 3.1a abbrev, change version constant. 3) change(86-07-24,Gilcrease), approve(86-06-25,MCR7409), audit(86-07-29,GWMay), install(86-08-04,MR12.0-1112): Update version constnat for find_chars_ rather than tct_, by Margolin emergency fix. 4) change(86-10-10,Gilcrease), approve(87-02-27,MCR7626), audit(87-03-09,Parisek), install(87-03-20,MR12.1-1005): Add version 2 list requests. END HISTORY COMMENTS */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ abbrev_data_: procedure () options (variable); dcl 1 abbrev_data aligned, 2 version character (32) unaligned, 2 default_breaks_list aligned like DEFAULT_BREAKS_LIST, 2 default_breaks_tct_table character (512) unaligned; dcl abbrev_data_default_breaks_tct_table_as_binary (0:511) fixed binary (9) unaligned unsigned based (addr (abbrev_data.default_breaks_tct_table)); dcl DEFAULT_BREAKS character (21) static options (constant) initial (" ""$'().:;<>[]`{|}"); /* HT NL VT FF SP QUOTE, etc: must be in collating sequence */ dcl 1 DEFAULT_BREAKS_LIST aligned static options (constant), 2 n_break_sequences fixed binary initial (21), 2 break_strings_lth fixed binary initial (22), 2 break_sequences (21), 3 start fixed binary initial (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19, 20, 21, 22), 3 lth fixed binary initial (1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1), 2 break_strings character (22) unaligned initial (" ""$'().::;<>[]`{|}"); dcl 1 cds_data aligned like cds_args; dcl code fixed binary (35); dcl idx fixed binary; dcl ABBREV_DATA_ character (32) static options (constant) initial ("abbrev_data_"); dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (pointer, fixed binary (35)); dcl (addr, currentsize, length, low, null, rank, string, substr) builtin; %page; /* Fill in the data structure */ abbrev_data.version = "3.2"; abbrev_data.default_breaks_list = DEFAULT_BREAKS_LIST; abbrev_data.default_breaks_tct_table = low (length (abbrev_data.default_breaks_tct_table)); do idx = 1 to length (DEFAULT_BREAKS); /* exactly one sequence starting with each character */ abbrev_data_default_breaks_tct_table_as_binary (rank (substr (DEFAULT_BREAKS, idx, 1))) = idx; end; /* Set up arguments for call to create_data_segment_ */ cds_data.sections (1).p = addr (abbrev_data); cds_data.sections (1).len = currentsize (abbrev_data); cds_data.sections (1).struct_name = "abbrev_data"; cds_data.seg_name = ABBREV_DATA_; cds_data.num_exclude_names = 0; cds_data.exclude_array_ptr = null (); string (cds_data.switches) = ""b; cds_data.switches.have_text = "1"b; /* only constants */ /* Call create_data_segment_ */ call create_data_segment_ (addr (cds_data), code); if code ^= 0 then call com_err_ (code, ABBREV_DATA_); return; %page; %include cds_args; end abbrev_data_;  get_to_cl_.pl1 01/16/85 1240.7r w 01/16/85 1239.3 45567 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ get_to_cl_: procedure (flags); /* Procedure invoked before calls to the command listener. Called by standard system default error handler when a quit occurs. */ /* Completely re-written 1 December 1980 Richard Mark Soley */ /* Changed to move_attach architecture 3 December 1980 RMSoley */ /* munged for new iox BIM June 1981 */ /* Modified 1984-10-26 BIM to not do control orders under the ips mask. */ /* System Entries */ dcl unique_chars_ entry (bit (*)) returns (character (15)); dcl listen_$release_stack entry (bit (1) aligned); dcl iox_$init_standard_iocbs entry; dcl ( hcs_$set_ips_mask, hcs_$reset_ips_mask ) entry (bit (36) aligned, bit (36) aligned); dcl terminate_process_ entry (character (*), pointer); dcl continue_to_signal_ entry (fixed bin (35)); dcl error_table_$unable_to_do_io fixed bin (35) external static; /* Conditions */ dcl cleanup condition; dcl any_other condition; /* Builtin */ dcl null builtin; /* Automatic */ dcl 1 info aligned automatic, 2 iocb_ptrs (3) pointer, 2 modes character (512) unaligned; dcl ips_mask bit (36) aligned; dcl switch character (32); dcl code fixed bin (35); dcl i fixed bin; dcl temp pointer; dcl 1 flags aligned, 2 reset_sw bit (1) unaligned, 2 pad bit (35) unaligned; dcl restore_attachments bit (1) aligned initial ("1"b); /* Include Files */ %include iox_entries; unclaimed_signal: quit: entry (flags); /* Throw away type-ahead if wanted. */ if flags.reset_sw then call iox_$control (iox_$user_input, "resetread", null (), code); /* Save attachments. */ call save_io; /* Set up cleanup handler. */ on cleanup call free_save_iocbs (); /* Now we can call the actual listener. */ call listen_$release_stack (restore_attachments); /* Control returns here on "start" command. First we avoid lost wakeups, then restore attachments if listen_ wants. */ call iox_$control (iox_$user_io, "start", null (), code); if restore_attachments then call restore_io (); else call free_save_iocbs (); /* Return to whatever we're "start"ing. */ return; save_io: procedure (); /* Procedure to push the current switch attachments on the attachment stack */ ips_mask = ""b; on any_other call fault_while_masked; info.modes = ""; call iox_$modes (iox_$user_io, "default", info.modes, (0)); call hcs_$set_ips_mask (""b, ips_mask); /*** This code should be upgraded to save whatever it finds in the iox_ iocb info for standard attachments. for now, saving the usual 3 will do */ /* Save current attachments. */ i = 0; do temp = iox_$user_input, iox_$user_output, iox_$error_output; i = i + 1; switch = "cl_save_" || unique_chars_ (""b); call iox_$find_iocb (switch, info.iocb_ptrs (i), code); call iox_$move_attach (temp, info.iocb_ptrs (i), code); end; /* Restore default attachments. */ call iox_$init_standard_iocbs; /* Turn on printer. */ call hcs_$reset_ips_mask (ips_mask, ""b); revert any_other; call iox_$control (iox_$user_io, "printer_on", null (), code); end save_io; restore_io: procedure (); /* Procedure to re-instate old saved attachments. */ ips_mask = ""b; on any_other call fault_while_masked; if info.modes ^= "" then call iox_$modes (iox_$user_io, info.modes, (""), (0)); call hcs_$set_ips_mask (""b, ips_mask); i = 0; do temp = iox_$user_input, iox_$user_output, iox_$error_output; i = i + 1; call iox_$close (temp, code); /* will normally fail */ call iox_$detach_iocb (temp, code); call iox_$move_attach (info.iocb_ptrs (i), temp, code); call iox_$destroy_iocb (info.iocb_ptrs (i), code); end; call hcs_$reset_ips_mask (ips_mask, ""b); revert any_other; end restore_io; free_save_iocbs: procedure; /* This is called in the -no_restore case */ do i = 1 to 3; call iox_$detach_iocb (info.iocb_ptrs (i), (0)); call iox_$destroy_iocb (info.iocb_ptrs (i), (0)); end; end free_save_iocbs; fault_while_masked: procedure; dcl 1 ti aligned, 2 version fixed bin, 2 status_code fixed bin (35); if substr (ips_mask, 36, 1) = "0"b then call continue_to_signal_ (0); else do; ti.version = 0; ti.status_code = error_table_$unable_to_do_io; call terminate_process_ ("fatal_error", addr (ti)); end; end fault_while_masked; end get_to_cl_;  listen_.pl1 11/06/86 0757.5r w 11/04/86 1033.9 93429 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ listen_: procedure (initial_command_line); /* Multics Listener */ /* initially coded in June 1969 by R. Daley */ /* converted to pl1 and improved for new command loop in December 1969 by R. Daley */ /* changed to reject input lines that are too long by V. Voydock in April 1970 */ /* changed to truncate the stack on every release on August 12,1970 by V. Voydock */ /* Changed to execute a start up exec_com and print the message of the day on September 4,1970 by R. J. Feiertag */ /* Extensively modified as part of redesign of user ring process initialization by V. Voydock on October 27,1970 */ /* Modified in June 1971 by V. Voydock to call cu_$ready_proc, to add "rl -all", to use "system_free_" instead of "free_", to not blow up if release_stack entry is somehow invoked before listen_ entry, and to make the listen_ entry behave the same way every time it is called in a process */ /* Modified in July 1971 by V. Voydock to make start command have control argument which causes it not to restore the old io attachments */ /* Modified in September 1971 by V. Voydock to not truncate free storage area after a release */ /* Modified in February 1972 by V. Voydock to accept an arbitrarily long command line as input */ /* Extensively modified in May 1972 by V. Voydock as part of fast command loop. Many pieces of listen_ were moved to other procedures */ /* Modified in September 1973 by M. Weaver to add level numbers, eliminate the automatic release, and to make start and release work directly with labels. */ /* Modified in December 1974 by S. Webber to redo the buffering of the input line. */ /* Opened in November 1981 for video system support by Benson I. Margulies */ /* Modified February 1984 by Jim Lippard to fix bug in call to iox_signal_ */ /* Changed to use listener_info.incl.pl1 12/07/84 Steve Herbst */ %page; /* DECLARATIONS */ dcl ( buffer_ptr, /* ptr to first char of workspace used by iox_$get_line */ read_ptr ptr, /* pointer to actual position in input buffer for read */ dummy_ptr ptr, /* dummy return pointer from cu_$grow_stack_frame calls */ old_sp ) pointer aligned; dcl (input_length, buffer_length) fixed bin (21); dcl total_input_length fixed bin (21); dcl entry, /* 0->$listen_, 1->$release_stack */ i fixed bin aligned; dcl code fixed bin (35); dcl initial_command_line char (*) var, /* first command line to be executed */ command_line char (input_length) aligned based (buffer_ptr); dcl spno bit (18) aligned, /* used to store stack segno */ should_restore_attachments bit (1) aligned; dcl 1 x based (buffer_ptr) aligned, 2 ch (0:65536) char (1) unaligned; dcl 1 listener_control aligned like based_listener_control; dcl iox_signal_ entry (ptr, fixed bin (35)); dcl com_err_ entry options (variable); dcl cu_$cp ext entry (ptr, fixed bin (21), fixed bin (35)); dcl cu_$ready_proc ext entry (); dcl cu_$grow_stack_frame entry (fixed bin (21), ptr, fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl (addr, baseno, codeptr, divide, environmentptr, fixed, length, min, null, ptr, rel, stackframeptr, stackbaseptr) builtin; dcl cleanup condition; dcl error_table_$long_record ext static fixed bin (35); %page; /* Establish this frame as the "top" of the listener frame thread, so this frame cannot be "released" around. */ entry = 0; go to re_enter; /* Entry called after processing quit or unclaimed signal: */ release_stack: entry (should_restore_attachments); entry = 1; /* Save pointer to previous listener control information, save return point for subsequent invocations of the listener, and initialize switches */ re_enter: if listen_static_data_.first_level_sw then do; /* no previous invocation to work from */ listener_control.prev_ptr = null; listener_control.level = 1; /* this is first invocation */ sp = stackframeptr (); spno = baseno (sp); /* get segno for comparing */ i = 0; do while (baseno (sp -> stack_frame.prev_sp) = spno & sp ^= null); i = i + 1; sp = sp -> stack_frame.prev_sp; end; listener_control.frame = i; end; else do; /* can use info from previous invocation */ listener_control.prev_ptr = listen_static_data_.control_ptr; listener_control.level = listen_static_data_.control_ptr -> based_listener_control.level + 1; old_sp = environmentptr (listen_static_data_.control_ptr -> based_listener_control.start); sp = stackframeptr (); i = listen_static_data_.control_ptr -> based_listener_control.frame; do while (sp ^= old_sp & sp ^= null); /* find # of intervening frames */ i = i + 1; sp = sp -> stack_frame.prev_sp; /* back ptr is safer to use */ end; listener_control.frame = i; end; /* fill in labels for release and start */ if (entry = 0) | listen_static_data_.first_level_sw then do; listener_control.release_all, listener_control.release, listener_control.new_release = READY_LABEL; listen_static_data_.first_level_sw = "0"b; end; else do; /* will want to release to invocation before this one */ listener_control.release = listen_static_data_.control_ptr -> based_listener_control.new_release; listener_control.new_release = READY_LABEL; listener_control.release_all = listen_static_data_.control_ptr -> based_listener_control.release_all; end; listener_control.start = START_LABEL; listen_static_data_.control_ptr = addr (listener_control); /* have finished getting info from old frame */ listener_control.flags.dont_restore_sw = "0"b; /* set ptrs to current control info and to buffer in which to read in command line */ buffer_length = 32; /* start with 128 char input buffer */ call cu_$grow_stack_frame (buffer_length, buffer_ptr, code); /* get storage for initial buffer */ /* Establish cleanup procedure to restore control structure thread */ on condition (cleanup) begin; listen_static_data_.control_ptr = listen_static_data_.control_ptr -> based_listener_control.prev_ptr; /* pop level */ if listen_static_data_.control_ptr = null then listen_static_data_.first_level_sw = "1"b; /* used mainly in test case */ end; /* If called at the listen_ entry, set up initial command line. */ if entry = 0 then do; if initial_command_line ^= "" then do; if length (initial_command_line) > buffer_length * 4 then do; call com_err_ (0, "listen_", "Initial command line is too long. Max=^d chars.", buffer_length * 4); go to READY_LABEL; end; input_length = length (initial_command_line); command_line = initial_command_line; total_input_length = 0; go to CALL_CP; end; end; %page; /* ******************************START OF BASIC LISTENER LOOP ****************************** */ /* Call the "ready procedure". The standard one prints the ready message. */ /* In case of video system, restore output. */ READY_LABEL: call iox_$control (iox_$user_input, "reset_more", null (), (0)); call cu_$ready_proc (); /* Read the next command line */ readnew: read_ptr = buffer_ptr; total_input_length = 0; /* extra input line character count */ read: call iox_$get_line (iox_$user_input, read_ptr, buffer_length * 4 - total_input_length, input_length, code); if code ^= 0 then do; if code ^= error_table_$long_record then call iox_signal_ (iox_$user_input, code); else do; if input_length < buffer_length * 4 - total_input_length then goto CALL_CP; call cu_$grow_stack_frame (buffer_length, dummy_ptr, code); /* double size of buffer */ buffer_length = buffer_length + buffer_length; read_ptr = addr (read_ptr -> ch (input_length)); total_input_length = total_input_length + input_length; end; goto read; end; CALL_CP: call cu_$cp (buffer_ptr, total_input_length + input_length, code); if code = 100 then go to readnew; /* ignore null command line */ go to READY_LABEL; /* ****************************** END OF BASIC LISTENER LOOP ****************************** */ %page; START_LABEL: /* start command goes here */ if listener_control.flags.dont_restore_sw then should_restore_attachments = "0"b; listen_static_data_.control_ptr = listen_static_data_.control_ptr -> based_listener_control.prev_ptr; return; %page; get_pct: entry (P_listener_control_ptr); dcl P_listener_control_ptr ptr; /* Return pointer to control structure */ P_listener_control_ptr = listen_static_data_.control_ptr; return; %page; get_level: entry (level_no, frame_no); /* return command level number and stack frame number of caller's caller */ dcl (level_no, frame_no) fixed bin; if listen_static_data_.control_ptr = null then do; /* no previous invocation */ level_no = 0; old_sp = stackbaseptr () -> stack_header.stack_begin_ptr; /* in case we're not in highest ring */ frame_no = 0; end; else do; /* count only up to previous listener */ level_no = listen_static_data_.control_ptr -> based_listener_control.level; old_sp = environmentptr (listen_static_data_.control_ptr -> based_listener_control.start); frame_no = listen_static_data_.control_ptr -> based_listener_control.frame; end; sp = stackframeptr () -> stack_frame.prev_sp -> stack_frame.prev_sp; /* want frame no of caller's caller */ do while (sp ^= old_sp); frame_no = frame_no + 1; sp = sp -> stack_frame.prev_sp; end; return; %page; get_area: entry returns (ptr); return (get_system_free_area_ ()); %page; %include iox_entries; %page; %include listener_info; %page; %include stack_frame; %page; %include stack_header; end listen_;  print_ready_message_.pl1 11/04/82 2004.3rew 11/04/82 1610.1 34254 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ print_ready_message_: procedure (flags) options (separate_static); /* The print_ready_message_ procedure is the standard system "ready procedure". It prints the ready message and then returns */ /* Initially coded as an internal procedure of the listener by R. C. Daley in December 1969 */ /* Converted to an external procedure as part of the introduction of cu_$ready_proc by V. L. Voydock in June 1971 */ /* Modified for 6180 to display virtual cpu, memory units, and demand paging by J. Keller, 4/11/73 */ /* Modified to print command level and frame numbers by M. Weaver 9/73 */ /* Steve Herbst 06/25/79 changed msg to: r hh:mm .vcpu dpages {level n} */ /* Modified April 1980 by C. Hornig for per-process time zones */ dcl rdy_string varying char (48) aligned; dcl out_string char (48) aligned; dcl 1 time_picture unaligned, 2 r char (2), 2 hours picture "99", 2 colon char (1), 2 minutes picture "99", 2 sp char (1); dcl vcpu picture "(5)-9v.999"; dcl dpages picture "(8)z9"; dcl level picture "(2)z9"; dcl NLNL char (2) int static options (constant) init (" "); dcl 1 flags aligned, 2 ready_sw bit (1) unaligned, 2 pad bit (35) unaligned; dcl (hour, minute) fixed bin; dcl cpu fixed bin (71); dcl (ec, npages) fixed bin (35); dcl (frame_no, level_no) fixed bin; dcl iox_$user_output ptr ext; dcl (addr, addrel, clock, length, ltrim, string) builtin; dcl decode_clock_value_$time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), char (3), fixed bin (35)); dcl hcs_$get_process_usage entry (ptr, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl listen_$get_level entry (fixed bin, fixed bin); dcl 1 data internal static, 2 wanted fixed bin initial (5), 2 can_get fixed bin, 2 cpu_usage fixed bin (71) init (0), 2 memory fixed bin (71) init (0), 2 demand_page fixed bin (35) init (0), 2 pre_page fixed bin (35) init (0), 2 virtual_cpu fixed bin (71) init (0); /* */ /* If ready messages are turned off, just return */ if ^flags.ready_sw then return; call decode_clock_value_$