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_$time (clock (), hour, minute, (0), (0), (""), ec); string (time_picture) = "r 00:00 "; time_picture.hours = hour; time_picture.minutes = minute; cpu = data.virtual_cpu; /* pick up virtual time, mem units, and paging */ npages = data.demand_page; call hcs_$get_process_usage (addr (data), ec); vcpu = (data.virtual_cpu - cpu) * 1e-6; /* virtual cpu in seconds */ dpages = data.demand_page - npages; /* pages demand paged since last ready */ call listen_$get_level (level_no, frame_no); /* find command level */ rdy_string = string (time_picture); rdy_string = rdy_string || ltrim (vcpu); rdy_string = rdy_string || " "; rdy_string = rdy_string || ltrim (dpages); if level_no > 1 then do; rdy_string = rdy_string || " level "; level = level_no; rdy_string = rdy_string || ltrim (level); end; rdy_string = rdy_string || NLNL; substr (out_string, 1, length (rdy_string)) = rdy_string; call iox_$put_chars (iox_$user_output, addr (out_string), length (rdy_string), ec); return; end print_ready_message_;  release.pl1 12/20/84 0852.4rew 12/20/84 0833.0 30060 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ release: rl: proc; /* This procedure implements the start and release commands. It exists so that the code involved does not have to be in the main body of listen_ */ /* Initially coded in May 1972 by V. Voydock as part of the fast command loop */ /* Fixed to reject extra arguments 06/30/82 S. Herbst */ /* Changed to use listener_info.incl.pl1 12/11/84 Steve Herbst */ dcl ioa_ ext entry options(variable); dcl temp_ptr ptr; dcl arg_count fixed bin; dcl arg_length fixed bin (21); dcl (code, error_table_$badopt external ) fixed bin(35); dcl argument char(arg_length) based(temp_ptr); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl (com_err_, com_err_$suppress_name) ext entry options(variable); dcl (null, substr) builtin; %page; /* If there is no frame to release to, print message and return. */ /* if listen_static_data_.control_ptr -> based_listener_control.prev_ptr=null() then do; call ioa_("""release"" ignored."); return; end; */ /* See if we are to release to "top". That is "rl -all" was typed */ call cu_$arg_count (arg_count); if arg_count > 1 then do; RL_USAGE: call com_err_$suppress_name (0, "release", "Usage: release {-control_arg}"); return; end; call cu_$arg_ptr(1,temp_ptr,arg_length,code); if code=0 then if (argument = "-all") | (argument = "-a") then go to listen_static_data_.control_ptr -> based_listener_control.release_all; else if substr (argument, 1, 1) = "-" then do; call com_err_ (error_table_$badopt, "release", argument); return; end; else go to RL_USAGE; /* Set the release switch */ go to listen_static_data_.control_ptr -> based_listener_control.release; %page; start: sr: entry; /* If there is no frame to "start" to, print message and return */ if listen_static_data_.control_ptr -> based_listener_control.release = listen_static_data_.control_ptr -> based_listener_control.new_release then do; call ioa_("""start"" ignored."); return; end; /* See if we are to not restore io attachments (that is, "start -no_restore" was typed) */ call cu_$arg_count (arg_count); if arg_count > 1 then do; SR_USAGE: call com_err_$suppress_name (0, "start", "Usage: start {-control_arg}"); return; end; call cu_$arg_ptr(1,temp_ptr,arg_length,code); if code=0 then if (argument="-no_restore") | (argument="-nr") then listen_static_data_.control_ptr -> based_listener_control.dont_restore_sw = "1"b; else if substr (argument, 1, 1) = "-" then do; call com_err_ (error_table_$badopt, "start", argument); return; end; else go to SR_USAGE; /* Set the start switch */ go to listen_static_data_.control_ptr -> based_listener_control.start; %page; %include listener_info; end release;  tty_.pl1 10/17/90 0820.5rew 10/17/90 0815.7 352998 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* the user ring tty io module --- tty_ */ /* format: style2 */ tty_: procedure; return; /* iox_ dim for terminal i/o written 1/75 by S.E. Barr */ /* Modified 9/26/75 by S.E. Barr to ensure buffer pointer is word aligned for calls to hardcore. */ /* Modified 760608 by PG to get tty_get_line to work when in raw input mode */ /* Modified 5/31/77 by J. Stern to add set_term_type and send_initial_string orders */ /* Modified 5/4/78 by Robert Coren to call hcs_$tty_get_line and to return whatever's there for get_chars */ /* Modified July 1979 by Larry Johnson to automatically attempt to attach to a new channel if the user's login channel hangs up. Part of process preservation across hangup project. */ /* Modified by C. Hornig for dial_manager_ intelligence */ /* Modified November 1980 by B. Margulies for user event channels and no block */ /* Modified: 12 November 1980 by G. Palter to implement MCS suggestion #65 -- truncate modes string at nearest whole mode if it doesn't fit into the caller's string */ /* Modified December 1980 by B. Margulies for new preservation and general cleanup */ /* Further Modified January 1, 1981 to split tty_ and tty_io_ to reduce gravidity of this program */ /* Modified October 1981 by C. Hornig to allow -dial_id. */ /* Modified March 1982 by C. Hornig to fix hangup_on_detach */ /* Modified August 1982 by E. N. Kittlitz to initialize mask in set_up */ /* Modified April 1983 by Robert Coren to handle -required_access_class */ /* Modified September 1983 by Robert Coren to fix bug that ignored -required_access_class "" */ /* Modified 1984-10-29 BIM to only call dial_manager_ if ring 0 admits that the channel is plausible. */ /* Modified December 1984 by Robert Coren to disable line status for login channel. */ /* Modified January 1985 by G. Palter to establish a handler for signals from the answering service */ /* Modified: 7 February 1985 by G. Palter to not attempt to release the channel if convert_dial_message_$return_io_module reports an error during the attachment */ /* Modified: 19 February 1985 by G. Palter to not try to dial_manager_ release the channel if hcs_$tty_detach fails */ /* Modified: 26 February 1985 by G. Palter to always delete the dial_manager_ IPC channel */ /* Modified: 8 March 1985 by G. Palter to make the close entrypoint not zero event_wait.channel_id(1). See the comment in the code for an explanation */ /****^ HISTORY COMMENTS: 1) change(85-06-23,Negaret), approve(87-07-23,MCR7742), audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055): Handle DSA network connections. 2) change(90-09-20,Bubric), approve(90-10-01,MCR8211), audit(90-10-01,Itani), install(90-10-17,MR12.4-1044): Have the calls to the routine 'nothing' changed to calls to the routine 'null_entry_'. END HISTORY COMMENTS */ /* Parameters */ dcl arg_iocbp ptr; /* ptr to iocb (input) */ dcl code fixed bin (35); /* Multics standard error code (output) */ dcl com_err_switch bit (1); /* ON if should call com_err_ for errors (input) */ dcl extend_bit bit (1); /* Obsolete open argument */ dcl mode fixed bin; dcl option_array (*) char (*) var; dcl arg_event_call_info_ptr pointer parameter; /* Automatic */ dcl access_class bit (72) aligned; /* binary form of required access class */ dcl access_class_range (2) bit (72) aligned; dcl access_class_specified bit (1); /* indicates whether attach description includes access class */ dcl access_class_string char (864); /* access class string passed in attach description */ dcl actual_iocbp ptr; /* copy of iocb.actual_ioc_ptr */ dcl atd char (128) var; dcl billing_id char (12); dcl billing_id_given bit (1); dcl device char (32); dcl dial_id char (32); dcl do_not_block bit (1); dcl dsa_connection_info_ptr ptr; dcl dsa_connection_info_len fixed bin (21); dcl i fixed bin; dcl iocbp ptr; /* copy of arg_iocb_ptr */ dcl hangup bit (1); dcl local_code fixed binary (35); dcl login_channel bit (1); dcl mask bit (36) aligned; /* ips mask */ dcl phone_no char (32); /* phone to which to dial */ dcl password char (12); dcl password_given bit (1); dcl person_id char (12); dcl person_id_given bit (1); dcl project_id char (12); dcl project_id_given bit (1); dcl resource_description character (256); dcl state fixed bin; /* state returned by hcs_$tty_ calls */ dcl suppress_dial_manager bit (1) aligned; /* Automatic Structures */ dcl 1 dma aligned like dial_manager_arg; dcl 1 dm_flags aligned, 2 dialup bit (1) unal, 2 hungup bit (1) unal, 2 control bit (1) unal, 2 pad bit (33) unal; dcl 1 event_message like event_wait_info aligned; dcl 1 ipcas aligned like ipc_create_arg_structure; dcl 1 local_eci aligned like event_call_info; dcl 1 user_id like submitter_id aligned; /* builtins */ dcl (addr, char, hbound, index, lbound, length, null, rtrim, string, substr) builtin; /* Internal Static */ dcl dim_name char (4) int static options (constant) init ("tty_"); /* used by com_err_ and setting attach descrip */ dcl system_free_area_ptr pointer int static init(null); dcl ZERO_BIT bit (1) int static options (constant) init ("0"b); /* Based */ dcl connection_info (dsa_connection_info_len) fixed bin (35) based (dsa_connection_info_ptr); dcl system_free_area area based (system_free_area_ptr); /* External Static */ dcl ( error_table_$action_not_performed, error_table_$bad_mode, error_table_$badopt, error_table_$inconsistent, error_table_$io_no_permission, error_table_$noarg, error_table_$not_detached, error_table_$resource_attached, error_table_$too_many_args, error_table_$wrong_no_of_args ) fixed bin (35) ext; dcl (any_other, cleanup) condition; /* Procedures */ dcl com_err_ entry options (variable); dcl convert_access_class_$from_string entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_dial_message_$return_io_module entry (fixed bin (71), char (*), char (*), fixed bin, 1 structure aligned, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, fixed bin (35)); dcl ( dial_manager_$allow_dials, dial_manager_$dial_out, dial_manager_$privileged_attach, dial_manager_$registered_server, dial_manager_$release_channel, dial_manager_$release_channel_no_hangup, dial_manager_$release_dial_id, dial_manager_$terminate_dial_out ) entry (ptr, fixed bin (35)); dcl dsa_tty_$attach entry (char (*), fixed bin (71), fixed bin (35), fixed bin, fixed bin (35)); dcl dsa_tty_$connect entry (char (*), ptr, fixed bin (71), char (*) var, ptr, char (*), fixed bin (35), ptr, fixed bin (21), char (*) var, (2) bit (72) aligned, fixed bin (35)); dcl dsa_tty_$detach entry (fixed bin (35), fixed bin, fixed bin, fixed bin (35)); dcl dsa_tty_$event entry (fixed bin (35), fixed bin (71), fixed bin, fixed bin (35)); dcl dsa_tty_$order entry (fixed bin (35), character (*), pointer, fixed bin, fixed bin (35)); dcl dsa_tty_io_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl ( dsa_tty_io_$put_chars, dsa_tty_io_$get_chars, dsa_tty_io_$get_line, dsa_tty_io_$modes, dsa_tty_io_$position, dsa_tty_io_$control_not_open ) ext entry; dcl get_process_id_ entry () returns (bit (36)); dcl get_system_free_area_ entry () returns (pointer); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)); dcl ipc_$decl_ev_wait_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl hcs_$delete_channel entry (fixed bin (71), fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$tty_attach entry (char (*), fixed bin (71), fixed bin, fixed bin, fixed bin (35)); dcl hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)); dcl hcs_$tty_order entry (fixed bin, character (*), pointer, fixed bin, fixed bin (35)); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$create_event_channel entry (ptr, fixed bin (71), fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ( ipc_$mask_ev_calls, ipc_$unmask_ev_calls ) entry (fixed bin (35)); dcl null_entry_ entry (); dcl ( tty_io_$put_chars, tty_io_$get_chars, tty_io_$get_line, tty_io_$modes, tty_io_$position, tty_io_$control, tty_io_$control_not_open ) ext entry; dcl user_info_$terminal_data entry (char (*), char (*), char (*), fixed bin, char (*)); /* include files */ %page; /* tty_attach */ tty_attach: entry (arg_iocbp, option_array, com_err_switch, code); code = 0; mask = ""b; iocbp = arg_iocbp; resource_description, device, phone_no, dial_id, access_class_string = ""; password, person_id, billing_id, project_id = ""; password_given, person_id_given, billing_id_given, project_id_given = "0"b; access_class_specified = ""b; login_channel, do_not_block = ""b; hangup = "1"b; /* hangup is default */ suppress_dial_manager = "0"b; attach_data_ptr = null (); on cleanup call clean_up_attach; system_free_area_ptr = get_system_free_area_ (); if hbound (option_array, 1) < 1 then call error (error_table_$noarg, "Usage: tty_ {device} {-control_args}"); if iocbp -> iocb.attach_descrip_ptr ^= null () then call error (error_table_$not_detached, ""); do i = lbound (option_array, 1) to hbound (option_array, 1); if /* case */ index (option_array (i), "-") ^= 1 then do; /* channel name */ if device ^= "" then call error (error_table_$wrong_no_of_args, "Multiple devices specified."); device = option_array (i); end; else if option_array (i) = "-login_channel" then login_channel = "1"b; else if option_array (i) = "-hangup_on_detach" then hangup = "1"b; else if option_array (i) = "-no_hangup_on_detach" then hangup = "0"b; else if option_array (i) = "-resource" | option_array (i) = "-rsc" then do; i = i + 1; if resource_description ^= "" then call error (error_table_$too_many_args, "A second resource description was given."); if i > hbound (option_array, 1) then if char (option_array (i), 1) = "-" then call error (error_table_$noarg, "Control argument found in place of resource description."); else call error (error_table_$noarg, "-resource given without a description."); else ; resource_description = option_array (i); end; else if option_array (i) = "-destination" | option_array (i) = "-ds" then do; i = i + 1; if phone_no ^= "" then call error (error_table_$too_many_args, "Multiple dial_out destinations given."); if i > hbound (option_array, 1) then call error (error_table_$noarg, "Phone number."); phone_no = option_array (i); end; else if option_array (i) = "-password" | option_array (i) = "-pwd" | option_array (i) = "-pw" then do; i = i + 1; if i > hbound (option_array, 1) then call error (error_table_$noarg, "Password."); password = option_array (i); password_given = "1"b; end; else if option_array (i) = "-billing" | option_array (i) = "-bill" | option_array (i) = "-blg" then do; i = i + 1; if i > hbound (option_array, 1) then call error (error_table_$noarg, "Billing."); billing_id = option_array (i); billing_id_given = "1"b; end; else if option_array (i) = "-project" | option_array (i) = "-proj" | option_array (i) = "-pj" then do; i = i + 1; if i > hbound (option_array, 1) then call error (error_table_$noarg, "Project."); project_id = option_array (i); project_id_given = "1"b; end; else if option_array (i) = "-person_id" | option_array (i) = "-prsid" then do; i = i + 1; if i > hbound (option_array, 1) then call error (error_table_$noarg, "Person_id."); person_id = option_array (i); person_id_given = "1"b; end; else if option_array (i) = "-dial_id" then do; i = i + 1; if dial_id ^= "" then call error (error_table_$too_many_args, "Multiple dial ID's given."); if i > hbound (option_array, 1) then call error (error_table_$noarg, "Dial ID."); dial_id = option_array (i); end; else if option_array (i) = "-no_block" then do; do_not_block = "1"b; end; else if option_array (i) = "-required_access_class" then do; i = i + 1; if access_class_specified then call error (error_table_$too_many_args, "Multiple access classes destinations given."); if i > hbound (option_array, 1) then call error (error_table_$noarg, "Access class."); access_class_string = option_array (i); access_class_specified = "1"b; end; else if option_array (i) = "-suppress_dial_manager" then suppress_dial_manager = "1"b; else if option_array (i) = "-no_suppress_dial_manager" then suppress_dial_manager = "0"b; else call error (error_table_$badopt, (option_array (i))); end; if login_channel & ((phone_no ^= "") | (device ^= "") | (resource_description ^= "") | (dial_id ^= "") | (password ^= "") | (billing_id ^= "") | (project_id ^= "") | (person_id ^= "") | access_class_specified) then call error (error_table_$inconsistent, "-login_channel and other control arguments."); if (dial_id ^= "") & ((phone_no ^= "")) then call error (error_table_$inconsistent, "-dial_id and -destination."); if access_class_specified then do; call convert_access_class_$from_string (access_class, access_class_string, code); if code ^= 0 then call error (code, access_class_string); end; if login_channel then call user_info_$terminal_data ("", "", device, (0), ""); tty_max_mode_length = 512; /* probably long enough, but we will check */ allocate attach_data in (system_free_area); string (attach_data.flags) = ""b; attach_data.device_id = device; attach_data.device_used = device; /* unless dm_ changes it */ attach_data.resource_desc = resource_description; attach_data.dial_phone = phone_no; attach_data.phone_given = (phone_no ^= ""); attach_data.dial_id = dial_id; attach_data.accept_dial = (dial_id ^= ""); attach_data.login_channel = login_channel; attach_data.no_block = do_not_block; if login_channel then /* hangup does not apply to login channel. */ attach_data.hangup = "0"b; else attach_data.hangup = hangup; /* DSA: hangup instead of "0"b */ attach_data.operation_hlock = 0; attach_data.tty_index, attach_data.tty_handle, attach_data.event_wait.channel_id (1), attach_data.dial_manager_event.channel_id (1) = 0; %page; /* The network_type is determined by the structure of the channel name. */ /* If "accept_dial" there is no channel name, so we must first call */ /* "try_dial_manager_attach" to obtain a channel name, and then we */ /* can call "try_hcs_attach". */ if attach_data.flags.accept_dial then do; if suppress_dial_manager then call error (code, "hcs_ terminal attachment failed."); call try_dial_manager_attach (code); if code ^= 0 then call error (code, "Could not assign channel."); call try_hcs_attach (code); if code ^= 0 then call error (code, "Could not attach channel."); end; else do; /* If we have a channel name, we always try to get the channel */ /* with hcs_, to avoid changing the dial_manager_ event channel */ /* if we do not have to. All we could do wrong here is successfully */ /* attach a channel with the wrong reservation characteristics etc. */ call try_hcs_attach (code); if code ^= 0 then do; if attach_data.login_channel then call error (code, "Cannot attach login channel."); if suppress_dial_manager then call error (code, "hcs_ terminal attachment failed."); if attach_data.network_type = DSA_NETWORK_TYPE then do; /* Prepare the submitter_id structure */ subidp = addr (user_id); user_id.version = SUBMITTER_ID_V1; user_id.person_id = person_id; user_id.project_id = project_id; user_id.billing_id = billing_id; user_id.password = password; dsa_connection_info_ptr = null; call dsa_tty_$connect (attach_data.device_id, system_free_area_ptr, 0, attach_data.dial_phone, subidp, attach_data.device_used, (0), dsa_connection_info_ptr, dsa_connection_info_len, atd, access_class_range, code); if code ^= 0 then call error (code, "Could not connect channel."); /*** free the connection info */ if dsa_connection_info_ptr ^= null then free connection_info in (system_free_area); end; else do; /* MCS_NETWORK_TYPE */ call try_dial_manager_attach (code); if code ^= 0 then call error (code, "Could not assign channel."); end; call try_hcs_attach (code); if code ^= 0 then call error (code, "Could not attach channel."); end; end; call make_atd; call check_mode_length; /* this may re-allocate the attach_data structure. */ on any_other call handler; /* should be on */ call hcs_$set_ips_mask (""b, mask); iocbp -> iocb.attach_descrip_ptr = addr (attach_data.attach_descrip); iocbp -> iocb.attach_data_ptr = attach_data_ptr; iocbp -> iocb.detach_iocb = tty_detach; iocbp -> iocb.open = tty_open; if attach_data.network_type = DSA_NETWORK_TYPE then iocbp -> iocb.control = dsa_tty_io_$control_not_open; else /* MCS */ iocbp -> iocb.control = tty_io_$control_not_open; call iox_$propagate (iocbp); revert any_other; call hcs_$reset_ips_mask (mask, mask); RETURN: return; make_atd: procedure; /* format: off */ call ioa_$rsnnl ( "^a ^[-login_channel^s^;^a^]^[ -resource ^a^;^s^]^[ -destination ^a^;^s^]" || "^[ -password^;^]^[ -person_id ^a^;^s^]^[ -project ^a^;^s^]" || "^[ -billing ^a^;^s^]^[ -dial_id ^a^;^s^]^[ -no_block^]" || "^[ ^[-no_hangup_on_detach^;-hangup_on_detach^]^]^[ -suppress_dial_manager^]", attach_data.attach_descrip, (0), dim_name, attach_data.login_channel, attach_data.device_used, (attach_data.resource_desc ^= ""), attach_data.resource_desc, attach_data.phone_given, attach_data.dial_phone, password_given, person_id_given, person_id, project_id_given, project_id, billing_id_given, billing_id, attach_data.accept_dial, attach_data.dial_id, attach_data.no_block, ^attach_data.login_channel, ^attach_data.hangup, suppress_dial_manager); /* format: ^off */ end make_atd; /* Error calls com_err_ if the loud switch is set and goes to the attach return */ error: proc (err_code, message); dcl err_code fixed bin (35); /* Multics standard error code */ dcl message char (*); /* Additional error information */ if com_err_switch then call com_err_ (err_code, dim_name, "^a ^a", iocbp -> iocb.name, message); code = err_code; call clean_up_attach; goto RETURN; end error; %page; /* This entry detaches the terminal and frees the information about it. It ignores the code and does the following: 1. The event channel is released. 2. The channel is released if it was attached with dial_manager_. 3. The table space in this dim for the attachment is freed iff the hlock is clear. */ tty_detach: entry (arg_iocbp, code); call set_up; /* set no lock, but get actual_iocb_ptr */ call hcs_detach; call release_channel; /* if we got it with dm_, let it go */ on any_other call handler; /* should be on */ call hcs_$set_ips_mask (""b, mask); actual_iocbp -> iocb.attach_descrip_ptr = null (); actual_iocbp -> iocb.attach_data_ptr = null (); actual_iocbp -> iocb.detach_iocb = iox_$err_not_attached; actual_iocbp -> iocb.open = iox_$err_not_attached; actual_iocbp -> iocb.control = iox_$err_not_attached; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; /* avoid unneccessary fatal errors */ if attach_data.operation_hlock = 0 then free attach_data in (system_free_area); else attach_data.async_detach = "1"b; /* warn other incarnations */ return; %page; /* This entry sets the open description and the legal operation entries in the iocb. The operations permitted: all the time: close, control, modes input: get_chars, get_line, position output: put_chars */ tty_open: entry (arg_iocbp, mode, extend_bit, code); call set_up; if mode = Stream_input | mode = Stream_output | mode = Stream_input_output then attach_data.open_descrip = iox_modes (mode); else do; code = error_table_$bad_mode; return; end; call allocate_ev_channel (code); /* in case user supplied with set_event */ if code ^= 0 then return; call ipc_$mask_ev_calls (code); /* do not let user code run till we are really open */ if code ^= 0 then return; if attach_data.async_hangup then code = error_table_$io_no_permission; /* we lost it during these last few statements */ else do; if attach_data.network_type = DSA_NETWORK_TYPE then call dsa_tty_$event (attach_data.tty_handle, attach_data.event_wait.channel_id (1), (0), code); else /* MCS */ call hcs_$tty_event (attach_data.tty_index, attach_data.event_wait.channel_id (1), (0), code); end; if code ^= 0 then do; call ipc_$unmask_ev_calls ((0)); return; end; on any_other call handler; call hcs_$set_ips_mask (""b, mask); actual_iocbp -> iocb.open_descrip_ptr = addr (attach_data.open_descrip); actual_iocbp -> iocb.detach_iocb = iox_$err_not_closed; actual_iocbp -> iocb.open = iox_$err_not_closed; actual_iocbp -> iocb.close = tty_close; if attach_data.network_type = DSA_NETWORK_TYPE then do; /* DSA */ actual_iocbp -> iocb.modes = dsa_tty_io_$modes; actual_iocbp -> iocb.control = dsa_tty_io_$control; if mode ^= Stream_output then do; actual_iocbp -> iocb.get_line = dsa_tty_io_$get_line; actual_iocbp -> iocb.get_chars = dsa_tty_io_$get_chars; actual_iocbp -> iocb.position = dsa_tty_io_$position; end; if mode ^= Stream_input then actual_iocbp -> iocb.put_chars = dsa_tty_io_$put_chars; end; else do; /* MCS*/ actual_iocbp -> iocb.modes = tty_io_$modes; actual_iocbp -> iocb.control = tty_io_$control; if mode ^= Stream_output then do; actual_iocbp -> iocb.get_line = tty_io_$get_line; actual_iocbp -> iocb.get_chars = tty_io_$get_chars; actual_iocbp -> iocb.position = tty_io_$position; end; if mode ^= Stream_input then actual_iocbp -> iocb.put_chars = tty_io_$put_chars; end; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; call ipc_$unmask_ev_calls ((0)); if attach_data.network_type = DSA_NETWORK_TYPE then call dsa_tty_$order (attach_data.tty_handle, "start", null (), state, code); else /* MCS */ call hcs_$tty_order (attach_data.tty_index, "start", null (), state, code); /* If this is a DSA login connection, the terminal type is already known, */ /* the tables are not initialized for this terminal type; So, we have */ /* to initialize the conversion tables, the TCB, SCB, etc ... as they are */ /* in the login server for this connection. We use a new control order: */ /* init_term_type. */ if attach_data.network_type = DSA_NETWORK_TYPE then do; call dsa_tty_io_$control (actual_iocbp, "init_term_type", null (), code); if code ^= 0 then call error (code, "init_term_type"); end; code = 0; return; %page; /* This procedure closes the io switch and returns a zero code. */ tty_close: entry (arg_iocbp, code); call set_up; if attach_data.operation_hlock ^= 0 then attach_data.async_close = "1"b; /* turn off wakeups from the channel */ if ^attach_data.async_hangup /* don't bother if it's not ours */ then do; if attach_data.network_type = DSA_NETWORK_TYPE then call dsa_tty_$event (attach_data.tty_handle, (0), (0), (0)); else /* MCS */ call hcs_$tty_event (attach_data.tty_index, (0), (0), (0)); end; /*** If tty_ created the event channel, we will now destroy it. However, we do not zero event_wait.channel_id(1) because, if an I/O was in progress on the switch which called ipc_$block and the user disconnects the channel, when he reconnects and types "start", control will return to ipc_$block which will attempt to validate the channel name. If we zero the channel name, this will fail and the restart will not work properly. */ if attach_data.assigned_ev_channel /* fast channel, give back to hardcore */ then do; call hcs_$delete_channel (attach_data.event_wait.channel_id (1), code); attach_data.have_ev_channel, attach_data.assigned_ev_channel = "0"b; end; else if attach_data.created_ev_channel /* we created regular channel */ then do; call ipc_$delete_ev_chn (attach_data.event_wait.channel_id (1), code); attach_data.have_ev_channel, attach_data.created_ev_channel = "0"b; end; else ; /* user supplied event channel remains until detached */ on any_other call handler; /* should be on */ call hcs_$set_ips_mask (""b, mask); actual_iocbp -> iocb.open_descrip_ptr = null; actual_iocbp -> iocb.detach_iocb = tty_detach; actual_iocbp -> iocb.open = tty_open; if attach_data.network_type = DSA_NETWORK_TYPE then actual_iocbp -> iocb.control = dsa_tty_io_$control_not_open; else /* MCS */ actual_iocbp -> iocb.control = tty_io_$control_not_open; actual_iocbp -> iocb.modes = iox_$err_not_open; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, mask); return; %page; /* Internal procedure to handle faults while IPS interrupts are masked. For a fault while masked, the process is terminated (with the reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state. */ handler: procedure options (non_quick); /* visible in azm */ dcl error_table_$unable_to_do_io fixed (35) ext; if mask ^= ""b then call terminate_this_process (error_table_$unable_to_do_io); end handler; terminate_this_process: procedure (cd); dcl cd fixed bin (35); dcl terminate_process_ ext entry (char (*), ptr); dcl 1 ti aligned automatic, 2 version fixed, 2 code fixed (35); ti.version = 0; ti.code = cd; call terminate_process_ ("fatal_error", addr (ti)); end terminate_this_process; %page; allocate_ev_channel: procedure (code); /* Assign event channel */ dcl code fixed binary (35) parameter; code = 0; if attach_data.have_ev_channel /* user supplied a channel via "set_event" order */ then return; /*** Try to get a fast channel, first; */ /*** If no success create an event channel. */ ipcas.version = ipc_create_arg_structure_v1; ipcas.channel_type = FAST_EVENT_CHANNEL_TYPE; ipcas.call_entry = null_entry_; ipcas.call_data_ptr = null (); ipcas.call_priority = 0; call ipc_$create_event_channel (addr (ipcas), attach_data.event_wait.channel_id (1), code); if code = 0 then attach_data.assigned_ev_channel = "1"b; else do; ipcas.channel_type = WAIT_EVENT_CHANNEL_TYPE; call ipc_$create_event_channel (addr (ipcas), attach_data.event_wait.channel_id (1), code); if code = 0 then attach_data.created_ev_channel = "1"b; else return; end; attach_data.have_ev_channel = "1"b; /* here if we created a channel */ return; end allocate_ev_channel; try_hcs_attach: procedure (code); dcl code fixed bin (35); code = 0; /* The network_type is initialized here. */ /* set no event -- it will be set with tty_event at open time */ if substr (device, 1, 4) = "dsa." /* DSA */ then do; attach_data.network_type = DSA_NETWORK_TYPE; call dsa_tty_$attach (attach_data.device_used, 0, attach_data.tty_handle, state, code); end; else do; /* MCS */ attach_data.network_type = MCS_NETWORK_TYPE; call hcs_$tty_attach (attach_data.device_used, 0, attach_data.tty_index, state, code); end; if code = 0 then if attach_data.login_channel then do; if attach_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$order (attach_data.tty_handle, "set_line_status_enabled", addr (ZERO_BIT), state, code); else /* MCS */ call hcs_$tty_order (attach_data.tty_index, "set_line_status_enabled", addr (ZERO_BIT), state, code); end; end try_hcs_attach; %page; try_dial_manager_attach: procedure (code); dcl code fixed bin (35); code = 0; call ipc_$create_ev_chn (attach_data.dial_manager_event.channel_id (1), code); if code ^= 0 then return; dma.version = dial_manager_arg_version_3; dma.dial_channel = attach_data.dial_manager_event.channel_id (1); (nostrz): dma.dial_qualifier = attach_data.dial_id; dma.channel_name = attach_data.device_id; dma.dial_out_destination = attach_data.dial_phone; dma.reservation_string = resource_description; if ^access_class_specified then dma.access_class, dma.access_class_required = "0"b; else do; dma.access_class = access_class; dma.access_class_required = "1"b; end; if attach_data.flags.phone_given then call dial_manager_$dial_out (addr (dma), code); else if attach_data.flags.accept_dial then do; call dial_manager_$registered_server (addr (dma), code); if code ^= 0 then call dial_manager_$allow_dials (addr (dma), code); end; else call dial_manager_$privileged_attach (addr (dma), code); /* If this is a priv_attach, then if we already have it then everything is fine. If user specified the destination, then we must dial to it. */ if (code = error_table_$resource_attached) & ^attach_data.flags.phone_given then do; /*** must release is still "0"b at this point */ code = 0; /* do not go blocked, as has nothing further to say */ return; end; if code ^= 0 /* couldn't get the channel at all */ then do; dm_attachment_failed_: call ipc_$delete_ev_chn (attach_data.dial_manager_event.channel_id (1), (0)); attach_data.dial_manager_event.channel_id (1) = 0; attach_data.flags.must_release = "0"b; return; end; attach_data.flags.must_release = "1"b; /* in case of cleanup during block */ call ipc_$block (addr (attach_data.dial_manager_event), addr (event_message), code); /* wait for news from initializer */ if code ^= 0 then go to dm_attachment_failed_; call convert_dial_message_$return_io_module (event_message.message, device, (""), (0), dm_flags, code); if code ^= 0 then go to dm_attachment_failed_; if ^dm_flags.dialup then do; code = error_table_$action_not_performed; go to dm_attachment_failed_; end; attach_data.flags.must_release = "1"b; attach_data.flags.hangup = hangup; attach_data.device_used = device; /* starnames unstarred here */ if attach_data.flags.accept_dial then do; call dial_manager_$release_dial_id (addr (dma), code); if code ^= 0 /* we still have to release the channel */ then return; end; call ipc_$decl_ev_call_chn (attach_data.dial_manager_event.channel_id (1), tty_as_signal_handler, attach_data_ptr, 1 /* NOTE: what's a reasonable priority? */, code); if code ^= 0 then do; /* this must work for proper operation */ code = error_table_$action_not_performed; return; /* ... but we must still release the channel */ end; return; end try_dial_manager_attach; %page; /* This entrypoint is called whenever an IPC signal is sent by the Answering Service for a channel which we had attached via dial_manager_. We check the message to determine the type of event and, if the event is a hangup, we set the async_hangup flag, disable any subsequent attempts to release the channel as we no longer own it, send a wakeup on the I/O event channel to unblock any interrupted I/O, and invoke the user's hangup procedure (if any). */ tty_as_signal_handler: entry (arg_event_call_info_ptr); event_call_info_ptr = arg_event_call_info_ptr; attach_data_ptr = event_call_info.data_ptr; call convert_dial_message_$return_io_module (event_call_info.message, device, (""), (0), dm_flags, local_code); if local_code ^= 0 /* ignore signals we can't interpret */ then return; if device ^= attach_data.device_used /* ignore signals for other channels */ then return; if ^dm_flags.hungup /* ignore anything other than hangup signals */ then return; attach_data.async_hangup = "1"b; attach_data.must_release = "0"b; /* it's no longer ours */ if attach_data.operation_hlock > 0 /* try to unblock pending I/O */ then call hcs_$wakeup (get_process_id_ (), attach_data.event_wait.channel_id (1), 0, (0)); if attach_data.have_user_hangup_proc /* let the user do his thing */ then do; local_eci = event_call_info; /* ... user needs to get same info but with his data_ptr */ local_eci.data_ptr = attach_data.user_hangup_proc.data_ptr; call attach_data.user_hangup_proc.procedure (addr (local_eci)); end; return; %page; release_channel: procedure; declare code fixed bin (35); if attach_data.flags.must_release then do; dma.version = dial_manager_arg_version_3; dma.channel_name = attach_data.device_used; dma.dial_channel = attach_data.dial_manager_event.channel_id (1); call ipc_$decl_ev_wait_chn (dma.dial_channel, code); if /* case */ attach_data.flags.phone_given then call dial_manager_$terminate_dial_out (addr (dma), code); else if attach_data.flags.hangup then call dial_manager_$release_channel (addr (dma), code); else call dial_manager_$release_channel_no_hangup (addr (dma), code); attach_data.flags.must_release = "0"b; end; if attach_data.dial_manager_event.channel_id (1) ^= 0 then do; call ipc_$delete_ev_chn (attach_data.dial_manager_event.channel_id (1), code); attach_data.dial_manager_event.channel_id (1) = 0; end; return; end release_channel; hcs_detach: procedure; if ((attach_data.tty_index > 0) | (attach_data.tty_handle > 0)) & ^attach_data.async_hangup then do; /* don't bother detaching if it's no longer ours */ if attach_data.network_type = DSA_NETWORK_TYPE then do; /*** If no_hangup_on_detach we just detach in tty_ (dflag = 0); */ /*** else we terminate the session in session control (dflag = 1) */ if attach_data.hangup then call dsa_tty_$detach (attach_data.tty_handle, 1, (0), local_code); else call dsa_tty_$detach (attach_data.tty_handle, 0, (0), local_code); end; else /* MCS */ call hcs_$tty_detach (attach_data.tty_index, 0, (0), local_code); if local_code ^= 0 /* lost the channel after last block */ then attach_data.flags.must_release = "0"b; end; attach_data.tty_index = 0; /* definitely not ours anymore */ end hcs_detach; check_mode_length: procedure; /**** Here we see if the hardcore returns more than our hard-coded guess of the maximum mode length. This code is here to avoid coordinating changes between this program and the hardcore, and to allow sites to have multiplexers that have long mode strings without neccessarily having to change this program. Clearly, having to reallocate all the time would be pretty poor. */ declare 1 very_long_mode_info aligned, 2 max_length fixed bin (21), 2 mode_string char (2000); declare new_attach_data_ptr pointer; very_long_mode_info.max_length = 2000; very_long_mode_info.mode_string = ""; if attach_data.network_type = DSA_NETWORK_TYPE then call dsa_tty_$order (attach_data.tty_handle, "modes", addr (very_long_mode_info), state, local_code); else /* MCS */ call hcs_$tty_order (attach_data.tty_index, "modes", addr (very_long_mode_info), state, local_code); if local_code ^= 0 | length (rtrim (very_long_mode_info.mode_string)) <= attach_data.max_mode_length then return; tty_max_mode_length = length (rtrim (very_long_mode_info.mode_string)) + 100; /* room to grow some */ allocate attach_data in (system_free_area) set (new_attach_data_ptr); new_attach_data_ptr -> attach_data = attach_data; /* copy away */ new_attach_data_ptr -> attach_data.max_mode_length = tty_max_mode_length; free attach_data in (system_free_area); attach_data_ptr = new_attach_data_ptr; return; end check_mode_length; set_up: procedure; code = 0; mask = ""b; actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr; attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr; return; end set_up; clean_up_attach: procedure; if attach_data_ptr = null () then return; if (attach_data.tty_index > 0) | (attach_data.tty_handle > 0) then call hcs_detach; call release_channel (); end clean_up_attach; %page; %include dial_manager_arg; %page; %include dsa_scu_sec_info; %page; %include event_call_info; %page; %include event_wait_info; %page; %include iocb; %page; %include iox_entries; %page; %include iox_modes; %page; %include ipc_create_arg; %page; %include net_event_message; %page; %include set_term_type_info; %page; %include tty_attach_data_; %page; %include tty_states; end tty_;  tty_io_.pl1 08/08/88 1552.2r w 08/08/88 1409.3 348084 /****^ ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1982 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ************************************************************** */ /* tty_io_ is the part of the tty_ io module that is used in actual io operation. */ /****^ HISTORY COMMENTS: 1) change(81-03-17,BMargulies), approve(), audit(), install(): Created. Modified October 1981 by C. Hornig to time out on write_status calls. Modified May 1982 by Robert Coren to accept (set get)_event_channel. Modified 8 Sepctember 1982 by Richard Lamson to add timeout code. Modified June 1983 by Robert Coren to make "get_channel_info" order return device_used rather than device_id. Modified April 1984 by Jon A. Rochlis to special case the "reconnection" control order so tty_ reconnections don't hang with the new reconnection strategy. Modified 1984-10-29 BIM to remove constant non-local gotos. Modified January 1985 by G. Palter for new treatment of dial_manager_ attached channels. Modified 1985-02-01, BIM: fixed timeout not to wait forever. Modified 1985-02-19, BIM: added get_com_channel_info. Modified: 26 February 1985 by G. Palter to fix the "set_event_channel" control order to properly release any created-by-tty_ IPC channel. 2) change(87-03-17,LJAdams), approve(87-04-03,MCR7646), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): Changed ttd_version to ttd_version_3. END HISTORY COMMENTS */ /* format: style2 */ tty_io_: procedure; return; declare ( arg_iocbp pointer, arg_buf_ptr ptr, /* ptr to user buffer (input) */ arg_buf_len fixed bin (21), /* length of user buffer (input) */ (a_new_modes, a_old_modes) char (*), /* arguments to modes operation */ code fixed bin (35), /* the usual */ chars_trans fixed bin (21), /* no. of characters transmitted (output) */ info_ptr ptr, /* ptr to info (input) */ no_of_records fixed bin (21), /* no. of lines to be skipped. tty_position (input) */ order char (*), /* name of order. tty_control (input) */ mode fixed bin /* position mode */ ) parameter; dcl timed_out bit (1) aligned; dcl temp_code fixed bin (35); dcl temp_state fixed bin; dcl create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned); dcl get_com_channel_info_ entry (pointer, fixed binary (35)); dcl hcs_$delete_channel entry (fixed bin (71), fixed bin (35)); dcl ( hcs_$set_ips_mask, hcs_$reset_ips_mask ) entry (bit (36) aligned, bit (36) aligned); dcl hcs_$tty_abort entry (fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)); dcl hcs_$tty_get_line entry (fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (21), bit (1), fixed bin, fixed bin (35)); dcl hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$tty_read entry (fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); dcl hcs_$tty_state entry (fixed bin, fixed bin, fixed bin (35)); dcl hcs_$tty_write entry (fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl timer_manager_$sleep entry (fixed binary (71), bit (2)); dcl tty_$tty_as_signal_handler entry (pointer); dcl ( tty_io_call_control_, tty_io_call_control_$not_open ) entry (ptr, char (*), ptr, fixed bin (35)); dcl ttt_info_$terminal_data entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35)); dcl ttt_info_$initial_string entry (char (*), char (512) varying, fixed bin (35)); dcl ttt_info_$modes entry (char (*), char (*), fixed bin (35)); dcl (addr, addrel, index, length, mod, null, reverse, rtrim, substr, charno, addcharno) builtin; dcl actual_iocbp ptr; /* copy of iocb.actual_ioc_ptr */ dcl buffer_ptr ptr; /* ptr to the base of the segment pointed to by arg_buf_ptr */ dcl control_not_open bit (1); dcl event_channel fixed bin (71) based; dcl event_wait_ptr pointer; dcl (i, amt_trans) fixed bin (21); dcl iox_op_in_progress fixed bin; dcl initial_string char (512) varying;/* terminal initialization string */ dcl ltype fixed bin; dcl modes_ptr ptr; /* points to modes structure for hcs_$tty_order */ dcl modes_need_restoration bit (1) aligned; dcl nl_returned bit (1); dcl num_to_read fixed bin (21); /* chars to request from hcs_$tty_read */ dcl num_read fixed bin (21); /* number of chars returned from ring 0 */ dcl offset fixed bin (21); /* offset from 0 for hcs_$tty_ calls */ dcl Relative_Microseconds bit (2) static init ("10"b) options (constant); dcl scratch_buffer_ptr pointer; dcl scratch_buffer char (2000) aligned based (scratch_buffer_ptr); dcl sis_version fixed bin int static options (constant) init (1); /* version of send_initial_string_info structure */ dcl sus_trm_names (3) char (32) int static options (constant) init ("sus_", "trm_", "alrm"); dcl set_type_order bit (1) aligned; /* ON for set_type order, OFF for set_term_type */ dcl state fixed bin; /* state returned by hcs_$tty_ calls */ declare 1 timeout_event_wait aligned, 2 n_channels fixed binary, 2 padding fixed binary, 2 channel_id (2) fixed binary (71); dcl total_amt_trans fixed bin (21); /* number of characters transferred */ declare old_type fixed bin based (info_ptr); dcl 1 ttd aligned like terminal_type_data; /* info structure for set_terminal_data order (ring 0) */ declare 1 send_initial_string_info aligned like tty_send_initial_string_info based (info_ptr); declare 1 get_channel_info aligned based (info_ptr) like tty_get_channel_info; dcl 1 status_struc aligned based (info_ptr), 2 ev_chn fixed bin (71), 2 data_available bit (1) unaligned; dcl 1 t_info aligned like terminal_info; /* info structure for terminal_info order */ dcl 1 event_message aligned like event_wait_info; dcl based_state fixed bin based; dcl 1 hangup_proc_data aligned based (info_ptr), 2 entry_var entry variable, 2 data_ptr ptr, 2 prior fixed bin; dcl ( error_table_$null_info_ptr, error_table_$action_not_performed, error_table_$timeout, error_table_$out_of_sequence, error_table_$smallarg, error_table_$bad_arg, error_table_$long_record, error_table_$no_operation, error_table_$not_open, error_table_$unimplemented_version, error_table_$undefined_order_request, error_table_$no_initial_string, error_table_$io_no_permission ) fixed bin (35) external static; dcl cleanup condition; %page; /* format: off */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* The new reconnection strategy is described here. At the entry to any of the i/o */ /* entries (all but attach, open, close, detach) we increment */ /* attach_data.operation_hlock. We then check attach_data.async_close and async_detach. */ /* These indicate that we have had our switch removed out from under us. If the hlock is */ /* one, meaning that we are the only operation suspended, and async_detach is on, then */ /* we free the attach data. Otherwise we decrement the hlock. (half lock). Then, if the */ /* iocb is in fact attached and opened, we call iox_ to do our operation on the new */ /* switch, and return that result. There is a race window here, in that the async */ /* operation could happen before we bump the counter. In that case the attach data would */ /* be invalid and unpredictable. This seems unlikely, and is not handled in this */ /* implementation. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* format: ^off */ /* CONVENTIONS: proper_io_return (code) does not return, and should be used to return to caller of tty_io_. check_for_disconnect (code) checks for io_no_permission. If found in goes and does reconnection and does not return. If it does return, the code is the valid error code */ %page; control_not_open: entry (arg_iocbp, order, info_ptr, code); control_not_open = "1"b; goto CONTROL_JOIN; control: entry (arg_iocbp, order, info_ptr, code); control_not_open = ""b; CONTROL_JOIN: if (order = "get_chars_timeout") | (order = "get_line_timeout") | (order = "put_chars_timeout") then do; /* need to initialize output value in info structure */ if info_ptr = null () then call proper_io_return (error_table_$null_info_ptr); if order = "put_chars_timeout" then info_ptr -> output_timeout_info.characters_written = 0; else /*** if (order = "get_chars_timeout") | (order = "get_line_timeout") then */ info_ptr -> input_timeout_info.characters_read = 0; end; call set_up_io (4); /* will abort the operation if there was an async hangup */ on cleanup call clean_up; if order = "reconnection" then call proper_io_return (error_table_$unimplemented_version); if order = "io_call" | order = "io_call_af" then do; if control_not_open then call tty_io_call_control_$not_open (actual_iocbp, order, info_ptr, code); else call tty_io_call_control_ (actual_iocbp, order, info_ptr, code); call proper_io_return (code); end; if order = "set_event" | order = "set_event_channel" then do; /* user wants to get wakeups */ if control_not_open then do; attach_data.event_wait.channel_id = info_ptr -> event_channel; attach_data.have_ev_channel = "1"b; end; else do; /* see tty_ for explanation of this stuff about fast and slow channels */ if attach_data.assigned_ev_channel then do; call hcs_$delete_channel (attach_data.event_wait.channel_id (1), code); attach_data.assigned_ev_channel = "0"b; end; else if attach_data.created_ev_channel then do; call ipc_$delete_ev_chn (attach_data.event_wait.channel_id (1), code); attach_data.created_ev_channel = "0"b; end; attach_data.event_wait.channel_id (1) = info_ptr -> event_channel; call hcs_$tty_event (attach_data.tty_index, attach_data.event_wait.channel_id (1), state, code); if code ^= 0 then call check_for_disconnect (code); call call_order ("start", null (), state, code); if code ^= 0 then call check_for_disconnect (code); end; call proper_io_return (code); end; if order = "get_event" | order = "get_event_channel" then do; if ^attach_data.have_ev_channel then call proper_io_return (error_table_$out_of_sequence); info_ptr -> event_channel = attach_data.event_wait.channel_id (1); call proper_io_return (code); end; if order = "state" then do; if info_ptr = null () then call proper_io_return (error_table_$null_info_ptr); call hcs_$tty_state (attach_data.tty_index, temp_state, temp_code); info_ptr -> based_state = temp_state; call proper_io_return (0); end; if order = "get_com_channel_info" then do; if info_ptr = null () then call proper_io_return (error_table_$null_info_ptr); info_ptr -> as_com_channel_info.channel_name = attach_data.device_used; call get_com_channel_info_ (info_ptr, code); call proper_io_return (code); end; if control_not_open /* no other orders for closed switches */ then call proper_io_return (error_table_$not_open); if order = "modes" then do; /* turn this into a tty_modes call */ call call_order ("modes", info_ptr, state, code); call proper_io_return (code); end; if order = "resetread" then call abort (1, code); /* abort dont return */ if order = "resetwrite" then call abort (2, code); if order = "abort" then call abort (3, code); if order = "get_line_timeout" then do; timeout_info_ptr = info_ptr; call timer_setup (input_timeout_info.timeout); call get_line (input_timeout_info.buffer_pointer, input_timeout_info.buffer_length, input_timeout_info.characters_read, input_timeout_info.timeout); end; if order = "get_chars_timeout" then do; timeout_info_ptr = info_ptr; call timer_setup (input_timeout_info.timeout); call get_chars (input_timeout_info.buffer_pointer, input_timeout_info.buffer_length, input_timeout_info.characters_read, input_timeout_info.timeout); /* And it never returns -- calls proper_io_return */ end; if order = "put_chars_timeout" then do; timeout_info_ptr = info_ptr; call timer_setup (output_timeout_info.timeout); call put_chars (output_timeout_info.buffer_pointer, output_timeout_info.buffer_length, output_timeout_info.characters_written, output_timeout_info.timeout); /* Never returns -- calls proper_io_return */ end; if order = "event_info" then do; info_ptr -> event_channel = attach_data.event_wait.channel_id (1); call proper_io_return (0); end; if order = "set_term_type" then do; sttip = info_ptr; if set_term_type_info.version ^= stti_version_1 then call proper_io_return (error_table_$unimplemented_version); call get_terminal_info; t_info.term_type = set_term_type_info.name; if set_term_type_info.flags.ignore_line_type then ltype = 0; else ltype = t_info.line_type; set_type_order = "0"b; TYPE: ttd.version = ttd_version_3; call ttt_info_$terminal_data (t_info.term_type, ltype, t_info.baud_rate, addr (ttd), code); if code ^= 0 then call proper_io_return (code); call call_order ("set_terminal_data", addr (ttd), state, code); if code ^= 0 then call proper_io_return (code); if set_type_order then call proper_io_return (code); if set_term_type_info.flags.set_modes then do; call set_default_modes ("force,", code); if code ^= 0 then call proper_io_return (code); end; if set_term_type_info.flags.send_initial_string then do; call send_default_initial_string (code); if code ^= 0 then if code = error_table_$no_initial_string then code = 0; end; call proper_io_return (code); end; if order = "set_default_modes" then do; call get_terminal_info; call set_default_modes ("init,force,", code); call proper_io_return (code); end; if order = "send_initial_string" then do; if info_ptr = null () then do; call get_terminal_info; call send_default_initial_string (code); end; else do; if send_initial_string_info.version ^= sis_version then call proper_io_return (error_table_$unimplemented_version); initial_string = send_initial_string_info.initial_string; call send_initial_string (initial_string, code); end; call proper_io_return (code); end; if order = "set_type" | order = "set_terminal_type" /* obsolete, map into set_term_type */ then do; if old_type < 1 | old_type > max_tty_type then call proper_io_return (error_table_$undefined_order_request); call get_terminal_info; t_info.term_type = tty_dev_type (old_type); ltype = 0; set_type_order = "1"b; go to TYPE; end; if order = "get_channel_info" then do; if get_channel_info.version ^= 1 then call proper_io_return (error_table_$unimplemented_version); get_channel_info.devx = attach_data.tty_index; get_channel_info.channel_name = attach_data.device_used; call proper_io_return (0); end; if order = "hangup_proc" then do; if attach_data.dial_manager_event.channel_id (1) = 0 then call proper_io_return (error_table_$action_not_performed); attach_data.user_hangup_proc.procedure = hangup_proc_data.entry_var; attach_data.user_hangup_proc.data_ptr = hangup_proc_data.data_ptr; attach_data.have_user_hangup_proc = "1"b; call ipc_$decl_ev_call_chn (attach_data.dial_manager_event.channel_id (1), tty_$tty_as_signal_handler, attach_data_ptr, hangup_proc_data.prior, code); call proper_io_return (code); /* change the priority to the requested value */ end; do; call call_order (order, info_ptr, state, code); /* see if hardcore knows it */ if code ^= 0 then call proper_io_return (code); if order = "read_status" /* our part of this bargain */ then status_struc.ev_chn = attach_data.event_wait.channel_id (1); if order = "write_status" then do; status_struc.ev_chn = attach_data.event_wait.channel_id (1); if status_struc.data_available then call timer_manager_$alarm_wakeup (1, "11"b, status_struc.ev_chn); end; end; call proper_io_return (code); /* assume hardcore sets code for unknown order */ %page; /* The user makes a modes call with two strings: one for new modes and one for old modes. The hardcore overwrites the new modes with the old modes, so the user's mode string must be copied into a scratch buffer for the hardcore call. */ modes: entry (arg_iocbp, a_new_modes, a_old_modes, code); call set_up_io (6); on cleanup call clean_up; call set_modes ("", a_new_modes, a_old_modes, code); call proper_io_return (code); %page; /* The only request that makes sense for terminals is forward skip of records. mode = 0 skip records no_of_records >= 0 forward skip */ tty_io_$position: entry (arg_iocbp, mode, no_of_records, code); call set_up_io (5); if mode ^= 0 | no_of_records < 0 then call proper_io_return (error_table_$no_operation); on cleanup call clean_up; if no_of_records > 0 then do; allocate scratch_buffer; /* freed by proper_io_return_ */ event_wait_ptr = addr (attach_data.event_wait); i = 0; do while (i < no_of_records); call read (addr (scratch_buffer), length (scratch_buffer), amt_trans, 0, "1"b, code); if code ^= 0 then call proper_io_return (code); if nl_returned then i = i + 1; end; end; call proper_io_return (code); %page; /* This procedure sets the pointer to the actual iocb ptr and sets the attach_data_ptr. */ set_up: procedure; code = 0; actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr; attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr; timeout_info_ptr = null (); modes_need_restoration = "0"b; scratch_buffer_ptr = null (); return; end set_up; set_up_io: procedure (which_op); dcl which_op fixed bin; call set_up; attach_data.operation_hlock = attach_data.operation_hlock + 1; iox_op_in_progress = which_op; /* allow us to retry this op -- see IOX* labels */ call check_async; return; end set_up_io; %page; get_terminal_info: proc; /* performs ring 0 terminal_info order */ t_info.version = terminal_info_version; call call_order ("terminal_info", addr (t_info), state, code); if code ^= 0 then call proper_io_return (code); end get_terminal_info; %page; /* Internal procedure to set default or user-specified modes */ set_default_modes: proc (prefix, code); /* assumes terminal type given by t_info.term_type */ dcl prefix char (*); dcl code fixed bin (35); call ttt_info_$modes (t_info.term_type, attach_data.temp_mode_string, code); /* get default modes */ if code ^= 0 | attach_data.temp_mode_string = "" then return; call set_modes (prefix, attach_data.temp_mode_string, "", code); end set_default_modes; set_modes: procedure (new_mode_prefix, new_modes, old_modes, code); dcl (new_mode_prefix, new_modes, old_modes) char (*); dcl code fixed bin (35); dcl commax fixed bin (21); dcl prefix_in_use bit (1) aligned; /* the prefix arg avoids concatenation stack extensions in our callers */ dcl returned_length fixed bin (21); if new_mode_prefix ^= "" then prefix_in_use = "1"b; else prefix_in_use = "0"b; modes_ptr = addr (attach_data.mode_string_info); if prefix_in_use then attach_data.mode_string_info.mode_string = new_mode_prefix || new_modes; else attach_data.mode_string_info.mode_string = new_modes; call call_order ("modes", modes_ptr, state, code); if code ^= 0 & code ^= error_table_$smallarg then do; old_modes = attach_data.mode_string_info.mode_string; /* the mode(s) in error are in here */ return; end; if length (old_modes) = 0 then do; code = 0; /* censor smallarg on "" old_modes */ return; end; returned_length = length (rtrim (attach_data.mode_string_info.mode_string)); if returned_length = 0 /* nothing in either direction */ then do; code = 0; old_modes = ""; return; end; /* from this point on we can have a smallarg */ code = 0; /* but we do not admit it. */ /**** Note -- attach_data.mode_string is maintained to be long enough for whatever the hardcore could possibly say, unless someone invents a funny mpx that gave wildly different mode string lengths. So we assume that attach_data.mode_string is not truncated, and don't bother checking for the "." So long as the user gave us as much space, we have faith that no manipulations of the string are needed. */ if returned_length <= length (old_modes) then do; old_modes = attach_data.mode_string_info.mode_string; return; end; /**** Here, we want to truncate to the last full mode */ commax = index (reverse (substr (attach_data.mode_string_info.mode_string, 1, length (old_modes))), ","); if commax = 0 /** hmmm, no room for an modes at all */ then old_modes = "."; else do; substr (old_modes, 1, length (old_modes) - commax) = substr (attach_data.mode_string_info.mode_string, 1, length (old_modes) - commax); substr (old_modes, length (old_modes) - commax + 1) = "."; /* fill with spaces */ end; return; end set_modes; /* Internal procedure to set default and user-specified initial_string */ send_default_initial_string: proc (code); /* assumes terminal type given by t_info.term_type */ dcl code fixed bin (35); call ttt_info_$initial_string (t_info.term_type, initial_string, code); if code ^= 0 then return; if length (initial_string) = 0 then do; code = error_table_$no_initial_string; return; end; go to sis_common; send_initial_string: entry (a_initial_string, code); dcl a_initial_string character (*) varying; initial_string = a_initial_string; sis_common: attach_data.temp_mode_string = ""; modes_need_restoration = "1"b; call set_modes ("", "rawo", attach_data.temp_mode_string, code); if code ^= 0 then return; /* Recurse, recurse */ call tty_io_$put_chars (arg_iocbp, addrel (addr (initial_string), 1), length (initial_string), code); /* skip varying string. YCCH */ /* not to mention no_block implications... */ /* this should be coded as call to write_chars, all things considered */ call set_modes ("", attach_data.temp_mode_string, "", (0)); /* best work */ modes_need_restoration = "0"b; return; end send_default_initial_string; %page; /* this procedure is called after any hcs_$tty_ entry. if we are not a login_channel, then we return. if we are, then in the io no permission case, it waits 10 seconds for sus_ to happen. if the async bits are set, then the reconnection came off. if not, we we wait again. using -login_channel if you do not mean it is not recommended, as the async bits would never get set. sus_signal_handler_ will take care of anyone who is attached with -login_channel. */ check_for_disconnect: procedure (code); dcl temp_state fixed bin; dcl temp_code fixed bin (35); dcl mask_to_set bit (36) aligned; dcl mask_to_reset bit (36) aligned; dcl code fixed bin (35); if ^attach_data.login_channel then return; /* not our problem */ if attach_data.async_detach then go to fake_operation_and_return; call hcs_$tty_state (attach_data.tty_index, temp_state, temp_code); /* is it ours? */ if temp_code = 0 then return; /* we still own channel, must be some other error */ /* we dont own channel, but no bits. must be we havent got sus_'ed */ call create_ips_mask_ (addr (sus_trm_names), 3, mask_to_set); /* better include alrm, for timing */ mask_to_set = ^mask_to_set; /* form enable mask */ /* sit in a loop and wait for the answering service to goose us. the answering service should suspend us, and then afterwards take us out. */ call hcs_$set_ips_mask (mask_to_set, mask_to_reset); /* mask to AS signals only */ do while (^attach_data.async_detach); call timer_manager_$sleep (1, "11"b); end; call hcs_$reset_ips_mask (mask_to_reset, (36)"0"b); goto fake_operation_and_return; %page; check_async: entry; if attach_data.async_detach then go to fake_operation_and_return; else if attach_data.async_hangup then call proper_io_return (error_table_$io_no_permission); else return; end check_for_disconnect; fake_operation_and_return: /* label since we really return */ revert cleanup; /* do not try to run unlock_hlock on freed attach data */ if attach_data.operation_hlock = 1 then free attach_data; /* and we are the last */ else call unlock_hlock; goto IOX_OPERATION (iox_op_in_progress); IOX_OPERATION (1): /* get_chars */ call iox_$get_chars (actual_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code); return; IOX_OPERATION (2): /* get_line */ call iox_$get_line (actual_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code); return; IOX_OPERATION (3): /* put_chars */ call iox_$put_chars (actual_iocbp, arg_buf_ptr, arg_buf_len, code); return; IOX_OPERATION (4): /* control */ call iox_$control (actual_iocbp, order, info_ptr, code); return; IOX_OPERATION (5): /* position */ call iox_$position (actual_iocbp, mode, no_of_records, code); return; IOX_OPERATION (6): /* modes */ call iox_$modes (actual_iocbp, a_old_modes, a_new_modes, code); return; %page; unlock_hlock: procedure; attach_data.operation_hlock = attach_data.operation_hlock - 1; end unlock_hlock; proper_io_return: procedure (r_code); declare r_code fixed bin (35); code = r_code; go to proper_io_return_label_; end proper_io_return; proper_io_return_label_: if timeout_info_ptr ^= null () then call timer_cleanup; call modes_cleanup; if scratch_buffer_ptr ^= null () then free scratch_buffer; call unlock_hlock; return; %page; tty_io_$get_chars: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code); chars_trans = 0; /* initialize output value in case set_up_io aborts */ call set_up_io (1); /* manage half-lock and get actual_iocb_ptr, attach_data */ on cleanup call clean_up; /* never freed */ call get_chars (arg_buf_ptr, arg_buf_len, chars_trans, -1); /* It never returns -- calls proper_io_return */ get_chars: procedure (arg_buf_ptr, arg_buf_len, chars_trans, arg_timeout); declare ( arg_buf_ptr pointer, (arg_buf_len, chars_trans) fixed binary (21), arg_timeout fixed binary (71) ) parameter; if arg_timeout < 0 then event_wait_ptr = addr (attach_data.event_wait); else if arg_timeout = 0 then event_wait_ptr = null (); chars_trans = 0; if arg_buf_len < 0 then call proper_io_return (error_table_$bad_arg); buffer_ptr = arg_buf_ptr; offset = mod (charno (buffer_ptr), 4); buffer_ptr = addcharno (buffer_ptr, -offset); call read (buffer_ptr, arg_buf_len, chars_trans, offset, "0"b, code); call proper_io_return (code); end get_chars; %page; tty_io_$get_line: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, chars_trans, code); chars_trans = 0; /* initialize output value in case set_up_io aborts */ call set_up_io (2); on cleanup call clean_up; call get_line (arg_buf_ptr, arg_buf_len, chars_trans, -1); get_line: procedure (arg_buf_ptr, arg_buf_len, chars_trans, arg_timeout); declare ( arg_buf_ptr pointer, (arg_buf_len, chars_trans) fixed binary (21), arg_timeout fixed binary (71) ) parameter; if arg_timeout < 0 then event_wait_ptr = addr (attach_data.event_wait); else if arg_timeout = 0 then event_wait_ptr = null (); /* no blocking */ chars_trans = 0; if arg_buf_len < 0 then call proper_io_return (error_table_$bad_arg); if arg_buf_len = 0 then call proper_io_return (0); buffer_ptr = arg_buf_ptr; offset = mod (charno (buffer_ptr), 4); buffer_ptr = addcharno (buffer_ptr, -offset); num_to_read = arg_buf_len; do while (num_to_read > 0); /* until we get a newline or run out of space */ call read (buffer_ptr, num_to_read, num_read, offset, "1"b, code); chars_trans = chars_trans + num_read; /* BEFORE we check the code, so that long_record and timeout and such correctly return the number we read */ if code ^= 0 then call proper_io_return (code); if nl_returned then call proper_io_return (0); /* ring 0 will say whether it found newline */ if attach_data.no_block | arg_timeout = 0 then call proper_io_return (0); /* nothing counts as a line for get line */ offset = offset + num_read; /* no newline, read some more */ num_to_read = num_to_read - num_read; end; call proper_io_return (error_table_$long_record); /* never got a newline */ end get_line; %page; /* This entry is called to output characters. The hardcore dim may output less than was requested and may have to be called more than once. These conditions may occur if the hardcore did not complete the request: . code = 0 The hardcore was given more characters than it could process; the process goes . blocked and makes another output request after the wakeup. . code ^= 0 The process has lost the attachment to the terminal. The error code no_io_permission is . returned. . state ^= TTY_STATE_DIALED_UP this only will come back in the Real Owner's process, currently the Initializer. The terminal has hungup. The error code no_io_permission is returned. */ tty_io_$put_chars: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, code); call set_up_io (3); on cleanup call clean_up; call put_chars (arg_buf_ptr, arg_buf_len, (0), -1); /* It never returns -- calls proper_io_return */ put_chars: procedure (arg_buf_ptr, arg_buf_len, arg_chars_written, arg_timeout); declare ( arg_buf_ptr pointer, arg_buf_len fixed binary (21), arg_chars_written fixed binary (21), arg_timeout fixed binary (71) ) parameter; if arg_timeout < 0 then event_wait_ptr = addr (attach_data.event_wait); else if arg_timeout = 0 then event_wait_ptr = null (); /*** else set by timer_setup */ if arg_buf_len < 0 then call proper_io_return (error_table_$bad_arg); if arg_buf_len = 0 then call proper_io_return (0); buffer_ptr = arg_buf_ptr; offset = mod (charno (buffer_ptr), 4); buffer_ptr = addcharno (buffer_ptr, -offset); total_amt_trans = 0; timed_out = "0"b; /* we retry the operation after the time out interval even without a detectable wakeup */ do while ("1"b); amt_trans = 0; call write_chars (buffer_ptr, offset, arg_buf_len - total_amt_trans, amt_trans, state, code); if code ^= 0 then do; arg_chars_written = total_amt_trans; call proper_io_return (code); end; total_amt_trans = total_amt_trans + amt_trans; if total_amt_trans >= arg_buf_len then do; arg_chars_written = total_amt_trans; call proper_io_return (0); /* done! */ end; if arg_timeout >= 0 /* timeout requires output args */ then do; arg_chars_written = total_amt_trans; if arg_timeout = 0 | timed_out /* timed_out --> that we timed out already but are just giving one more push */ then call proper_io_return (error_table_$timeout); end; else if attach_data.no_block /* no_block + timeout = block on timer only */ then do; if arg_buf_len > total_amt_trans then code = total_amt_trans - arg_buf_len; /* - (number not transmitted) */ arg_chars_written = total_amt_trans; call proper_io_return (code); end; offset = offset + amt_trans; call ipc_$block (event_wait_ptr, addr (event_message), code); if code ^= 0 then call proper_io_return (code); /* ipc failure? this is bad luck, perhaps should signal */ call check_async (); /* check for having lost the channel while blocked */ if event_message.channel_id ^= attach_data.event_wait.channel_id (1) then timed_out = "1"b; /* attach_data.event_wait.channel_id (1) is ALWAYS the tty itself, and the only other possibility is the timer event */ /* setting this flag causes it to try to write one more time before returning. */ end; end put_chars; %page; write_chars: procedure (bufferp, buffero, n_to_write, n_wrote, statex, code); declare ( bufferp ptr, (buffero, n_to_write, n_wrote) fixed bin (21), statex fixed bin, code fixed bin (35) ) parameter; call hcs_$tty_write (attach_data.tty_index, bufferp, buffero, n_to_write, n_wrote, statex, code); if code ^= 0 then call check_for_disconnect (code); return; end write_chars; %page; /* This procedure reads one line of data or "amt_to_read" characters whichever is smaller. */ read: proc (buffer_ptr, amt_to_read, amt_read, offset, get_line_called, code); dcl buffer_ptr ptr; dcl amt_to_read fixed bin (21); dcl amt_read fixed bin (21); dcl offset fixed bin (21); dcl get_line_called bit (1); dcl code fixed bin (35); amt_read = 0; timed_out = "0"b; do while ("1"b); if get_line_called then call hcs_$tty_get_line (attach_data.tty_index, buffer_ptr, offset, amt_to_read, amt_read, nl_returned, state, code); else call hcs_$tty_read (attach_data.tty_index, buffer_ptr, offset, amt_to_read, amt_read, state, code); if code ^= 0 then do; call check_for_disconnect (code); /* will NOT return if io_no_permission */ return; end; if amt_read > 0 then return; if event_wait_ptr = null () /* 0 timeout */ | timed_out /* we hung out a read, it timed out, we tried one last time, got nothing, and so away we go */ then call proper_io_return (error_table_$timeout); if attach_data.no_block then return; /* the n-chars-read will be zero, no problem, no code needed */ call ipc_$block (event_wait_ptr, addr (event_message), code); if code ^= 0 then return; call check_async (); /* check for having lost the channel while blocked */ if event_message.channel_id ^= attach_data.event_wait.channel_id (1) then timed_out = "1"b; end; end read; %page; timer_setup: procedure (arg_timeout); declare arg_timeout fixed bin (71); declare channel fixed bin (71); if arg_timeout = 0 then return; /* timeout of zero special */ call ipc_$create_ev_chn (channel, code); if code ^= 0 then call proper_io_return (code); if attach_data.no_block then do; timeout_event_wait.channel_id (1) = channel; timeout_event_wait.n_channels = 1; end; else do; timeout_event_wait.channel_id (1) = attach_data.event_wait.channel_id (1); timeout_event_wait.channel_id (2) = channel; timeout_event_wait.n_channels = 2; end; call timer_manager_$alarm_wakeup (arg_timeout, Relative_Microseconds, timeout_event_wait.channel_id (2)); event_wait_ptr = addr (timeout_event_wait); return; end timer_setup; modes_cleanup: procedure; /**** Restore modes by hand to avoid forcing a bunch of useful procedures to be non-quick. */ if ^modes_need_restoration then return; attach_data.mode_string_info.mode_string = attach_data.temp_mode_string; call hcs_$tty_order (attach_data.tty_index, "modes", addr (attach_data.mode_string_info), state, code); return; end modes_cleanup; timer_cleanup: procedure; if timeout_info_ptr = null () then return; call timer_manager_$reset_alarm_wakeup (timeout_event_wait.channel_id (2)); call ipc_$delete_ev_chn (timeout_event_wait.channel_id (2), (0)); return; end timer_cleanup; abort: procedure (abort_type, code); dcl abort_type fixed bin; dcl code fixed bin (35); call hcs_$tty_abort (attach_data.tty_index, (abort_type), state, code); if code ^= 0 then call check_for_disconnect (code); call proper_io_return (code); end abort; call_order: procedure (order, info_ptr, state, code); dcl order char (*); dcl info_ptr ptr; dcl state fixed bin; dcl code fixed bin (35); call hcs_$tty_order (attach_data.tty_index, order, info_ptr, state, code); if code ^= 0 then call check_for_disconnect (code); end call_order; clean_up: procedure; call timer_cleanup; call modes_cleanup; if scratch_buffer_ptr ^= null () then free scratch_buffer; call unlock_hlock; end clean_up; %page; %include as_com_channel_info; %include event_wait_info; %include iocb; %include iox_entries; %include tty_attach_data_; %include tty_read_status_info; %include tty_get_channel_info; %include io_timeout_info; %include tty_control_orders_info; %include terminal_type_data; %include terminal_info; %include set_term_type_info; %include ttyp; end tty_io_;  tty_io_call_control_.pl1 08/08/88 1552.2r w 08/08/88 1409.4 139977 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This procedure sets up info structures to execute tty_ control orders on behalf of the io_call command. */ /* Written April 1976 by Larry Johnson */ /* Modified May 1978 to add suppport for active function and new orders */ /* Modified November 1980 by Benson I. Margulies for set_event_channel */ /* Modified 1985-02-19, BIM: get_com_channel_info */ /* format: style2 */ tty_io_call_control_: proc (iocbp, io_call_order, io_call_infop, code); /* Parameters */ dcl iocbp ptr; /* Pointer to the IOCB */ dcl io_call_order char (*); /* Can be io_call or io_call_af */ dcl code fixed bin (35); /* Standard system status code */ /* Automatic storage */ dcl not_open_sw bit (1); dcl af_sw bit (1); /* Set if doing active function */ dcl i fixed bin; dcl temp_type char (16); dcl new_id char (4); /* Info structure for storeid order */ dcl (err, rpt) entry variable options (variable); dcl caller char (32); dcl order char (32); dcl n_args fixed bin; dcl line_length fixed bin (9); dcl ev_channel fixed bin (71); dcl 1 ascci aligned like as_com_channel_info; dcl 1 read_status aligned like tty_read_status_info; dcl 1 write_status aligned like tty_read_status_info; dcl 1 info aligned like tty_info; dcl new_type fixed bin (35); dcl 1 modes aligned, 2 str_len fixed bin, 2 str char (512); dcl 1 auto_terminal_info like terminal_info automatic; dcl 1 auto_set_term_type_info like set_term_type_info automatic; /* External stuff */ dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, char (*), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl ( error_table_$badopt, error_table_$noarg, error_table_$bad_conversion, error_table_$too_many_args, error_table_$not_open, error_table_$undefined_order_request ) ext fixed bin (35); /* internal static */ /* orders that require info that we will not supply */ dcl info_orders (27) char (32) int static options (constant) init ("set_delay", "get_channel_info", "get_delay", "set_editing_chars", "get_editing_chars", "set_input_translation", "set_input_conversion", "set_output_translation", "set_output_conversion", "get_input_translation", "get_input_conversion", "get_output_translation", "get_output_conversion", "set_special", "get_special", "set_framing_chars", "get_framing_chars", "send_initial_string", "set_default_modes", "set_input_message_size", "get_input_message_size", "input_flow_control_chars", "output_flow_control_chars", "get_echo_break_table", "set_wakeup_table", "set_prompt", "hangup_proc"); declare conversion condition; /* builtins */ dcl (addr, binary, character, hbound, lbound, length, null, rtrim, string, substr, translate, unspec) builtin; %include as_com_channel_info; %include io_call_info; %include tty_read_status_info; %include tty_get_channel_info; %include tty_control_orders_info; %include ttyp; %include terminal_info; %include set_term_type_info; %include line_types; not_open_sw = ""b; goto JOIN; not_open: entry (iocbp, io_call_order, io_call_infop, code); not_open_sw = "1"b; JOIN: af_sw = (io_call_order = "io_call_af"); err = io_call_info.error; rpt = io_call_info.report; order = io_call_info.order_name; n_args = io_call_info.nargs; caller = io_call_info.caller_name; /* not_open orders first */ /* set_event order */ if order = "set_event" then do; if af_sw then go to not_af; if n_args = 0 then do; call err (error_table_$noarg, caller, "Event channel."); code = 0; goto RETURN; end; if n_args > 1 then do; call err (error_table_$too_many_args, caller, "Only an event channel may be given."); code = 0; goto RETURN; end; if substr (io_call_info.args (1), 1, 1) = "-" then do; call err (error_table_$badopt, caller, "^a", io_call_info.args (1)); code = 0; goto RETURN; end; on conversion begin; /* cv_foo_check_ wont do 71 bits */ call err (error_table_$bad_conversion, caller, "Bad event channel ^a.", io_call_info.args (1)); code = 0; goto RETURN; end; ev_channel = binary (io_call_info.args (1)); /* Default is 71, 0 */ call iox_$control (iocbp, "set_event", addr (ev_channel), code); goto RETURN; end; else if order = "get_event" then do; if n_args > 0 then do; call err (error_table_$too_many_args, caller, "The get_event order takes no arguments."); code = 0; goto RETURN; end; call iox_$control (iocbp, "get_event", addr (ev_channel), code); if code ^= 0 then do; call err (code, caller, "No event channel info available."); code = 0; goto RETURN; end; if af_sw then io_call_af_ret = character (ev_channel); /* work in decimal for set_ev and ipc_call */ else call rpt ("^a: Event channel=^d (decimal).", caller, ev_channel); code = 0; goto RETURN; end; else if order = "get_com_channel_info" then do; declare temp_acc char (32); unspec (ascci) = ""b; ascci.version = AS_COM_CHANNEL_INFO_VERSION_1; call iox_$control (iocbp, "get_com_channel_info", addr (ascci), code); if code = 0 then do; call rpt ("^a:^20tchannel:^40t^a", caller, ascci.channel_name); call rpt ("^20taccess_control.login:^40t^[on^;off^]", ascci.access_control.login); call rpt ("^20taccess_control.dial_slave:^40t^[on^;off^]", ascci.access_control.dial_slave); call rpt ("^20taccess_control.priv_attach:^40t^[on^;off^]", ascci.access_control.priv_attach); call rpt ("^20taccess_control.dial_server:^40t^[on^;off^]", ascci.access_control.dial_server); call rpt ("^20taccess_control.dial_out:^40t^[on^;off^]", ascci.access_control.dial_out); call rpt ("^20tattached_to_caller:^40t^[on^;off^]", ascci.attached_to_caller); call rpt ("^20tuser_authenticated:^40t^[on^;off^]", ascci.user_authenticated); call rpt ("^20tdialed_to_caller:^40t^[on^;off^]", ascci.dialed_to_caller); call rpt ("^20tservice_type:^40t^[ANS^;FTP^;MC^;SLAVE^;DIAL^;DIAL_OUT^;MPX^;TANDD^]", ascci.service_type); call rpt ( "^20tcurrent_service_type:^40t^[ANS^;FTP^;MC^;SLAVE^;DIAL^;DIAL_OUT^;MPX^;TANDD^]", ascci.current_service_type); call convert_access_class_$to_string_range_short (ascci.access_class, temp_acc, (0)); if temp_acc = "" then temp_acc = "system_low"; call rpt ("^20taccess_class:^40t^a", temp_acc); call convert_access_class_$to_string_short (ascci.current_access_class, temp_acc, (0)); if temp_acc = "" then temp_acc = "system_low"; call rpt ("^20tcurrent_access_class:^40t^a", temp_acc); call rpt ("^20tauth_user_name:^40t^a", ascci.auth_user_name); end; end; /* end of not_open orders */ else if not_open_sw then do; code = error_table_$not_open; call err (code, caller); go to RETURN; end; /* Info order */ else if order = "info" then do; call iox_$control (iocbp, "info", addr (info), code); if code = 0 then do; if info.type < lbound (tty_dev_type, 1) | info.type > hbound (tty_dev_type, 1) then call ioa_$rsnnl ("type^d", temp_type, (0), info.type); else temp_type = tty_dev_type (info.type); if af_sw then do; if n_args = 0 then io_call_af_ret = rtrim (temp_type); else if io_call_info.args (1) = "id" then io_call_af_ret = rtrim (info.id); else if io_call_info.args (1) = "baud" then call ioa_$rsnnl ("^d", io_call_af_ret, (0), info.baudrate); else if io_call_info.args (1) = "type" then io_call_af_ret = rtrim (temp_type); else call err (error_table_$badopt, caller, "^a", io_call_info.args (1)); end; else call rpt ("^a: Terminal id=""^a"", baud rate=^d, type=^a.", caller, info.id, info.baudrate, temp_type); end; end; /* Read_status order */ else if order = "read_status" then do; call iox_$control (iocbp, "read_status", addr (read_status), code); if code = 0 then do; if af_sw then if read_status.input_pending then io_call_af_ret = "true"; else io_call_af_ret = "false"; else call rpt ("^a: Event channel=^24.3b, input is ^[^;not ^]available.", caller, unspec (read_status.event_channel), read_status.input_pending); end; end; /* Write_status order */ else if order = "write_status" then do; call iox_$control (iocbp, "write_status", addr (write_status), code); if code = 0 then do; if af_sw then if write_status.input_pending then io_call_af_ret = "true"; else io_call_af_ret = "false"; else call rpt ("^a: Event channel=^24.3b, output is ^[^;not ^]pending.", caller, unspec (write_status.event_channel), write_status.input_pending); end; end; /* Store_id order */ else if order = "store_id" then do; if af_sw then do; not_af: call err (0, caller, "The ^a order is not valid as an active function.", order); code = 0; end; if n_args ^> 0 then do; call err (error_table_$noarg, caller, "ID."); code = 0; end; else do; new_id = io_call_info.args (1); call iox_$control (iocbp, "store_id", addr (new_id), code); end; end; /* Set_type order */ else if order = "set_type" | order = "set_terminal_type" then do; if af_sw then go to not_af; if n_args ^> 0 then do; call err (error_table_$noarg, caller, "Type."); code = 0; end; else do; new_type = cv_dec_check_ ((io_call_info.args (1)), i); if i ^= 0 then do; temp_type = translate (io_call_info.args (1), "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); do new_type = lbound (tty_dev_type, 1) to hbound (tty_dev_type, 1); if tty_dev_type (new_type) = temp_type then do; /* Got a match */ call iox_$control (iocbp, "set_type", addr (new_type), code); return; end; end; call err (0, caller, "Invalid type: ^a", io_call_info.args (1)); code = 0; end; else call iox_$control (iocbp, "set_type", addr (new_type), code); end; end; /* Modes order */ else if order = "modes" then do; if af_sw then go to not_af; if n_args ^> 0 then modes.str = ""; else modes.str = io_call_info.args (1); modes.str_len = length (modes.str); call iox_$control (iocbp, "modes", addr (modes), code); if code = 0 then call rpt ("^a: ^a", caller, modes.str); end; /* Set_line_type order */ else if order = "set_line_type" then do; if af_sw then go to not_af; if n_args ^> 0 then do; call err (error_table_$noarg, caller, "Line type."); code = 0; end; else do; temp_type = translate (io_call_info.args (1), "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); do new_type = lbound (line_types, 1) to hbound (line_types, 1); if temp_type = line_types (new_type) then go to set_line_type; end; new_type = cv_dec_check_ ((io_call_info.args (1)), i); if i ^= 0 then do; call err (0, caller, "Invalid line type: ^a", io_call_info.args (1)); code = 0; end; else set_line_type: call iox_$control (iocbp, "set_line_type", addr (new_type), code); end; end; /* Line length order */ else if order = "line_length" then do; if af_sw then go to not_af; if n_args ^> 0 then do; call err (error_table_$noarg, caller, "Line length."); code = 0; end; else do; line_length = cv_dec_check_ ((io_call_info.args (1)), i); if i ^= 0 then do; call err (0, caller, "Invalid line length: ^a", io_call_info.args (1)); code = 0; end; else call iox_$control (iocbp, "line_length", addr (line_length), code); end; end; /* Terminal info order */ else if order = "terminal_info" then do; terminal_info_ptr = addr (auto_terminal_info); terminal_info.version = 1; call iox_$control (iocbp, "terminal_info", terminal_info_ptr, code); if code = 0 then do; if terminal_info.line_type < lbound (line_types, 1) | terminal_info.line_type > hbound (line_types, 1) then call ioa_$rsnnl ("^d", temp_type, (0), terminal_info.line_type); else temp_type = line_types (terminal_info.line_type); if af_sw then do; if n_args = 0 then io_call_af_ret = rtrim (terminal_info.term_type); else if io_call_info.args (1) = "id" then io_call_af_ret = rtrim (terminal_info.id); else if io_call_info.args (1) = "baud" then call ioa_$rsnnl ("^d", io_call_af_ret, (0), terminal_info.baud_rate); else if io_call_info.args (1) = "terminal_type" then io_call_af_ret = rtrim (terminal_info.term_type); else if io_call_info.args (1) = "line_type" then io_call_af_ret = rtrim (temp_type); else call err (error_table_$badopt, caller, "^a", io_call_info.args (1)); end; else call rpt ("^a: Terminal id=""^a"", baud_rate=^d, term type=""^a"", line type=""^a"".", caller, terminal_info.id, terminal_info.baud_rate, terminal_info.term_type, temp_type); end; end; /* Set_term_type order */ else if order = "set_term_type" then do; if af_sw then go to not_af; sttip = addr (auto_set_term_type_info); set_term_type_info.version = 1; set_term_type_info.name = ""; string (set_term_type_info.flags) = "0"b; if n_args = 0 then do; call err (error_table_$noarg, caller, "Terminal type."); code = 0; end; else do; set_term_type_info.name = io_call_info.args (1); do i = 2 to n_args; if io_call_info.args (i) = "-tabs" | io_call_info.args (i) = "-initial_string" | io_call_info.args (i) = "-istr" then set_term_type_info.send_initial_string = "1"b; else if io_call_info.args (i) = "-modes" then set_term_type_info.set_modes = "1"b; else if io_call_info.args (i) = "-ignore_line_type" then set_term_type_info.ignore_line_type = "1"b; else do; call err (error_table_$badopt, caller, "^a", io_call_info.args (i)); code = 0; end; end; call iox_$control (iocbp, "set_term_type", sttip, code); end; end; /* All other orders */ else if af_sw then go to not_af; else do; /* find out if it can just be passed on */ do i = 1 to hbound (info_orders, 1) while (order ^= info_orders (i)); end; if i <= hbound (info_orders, 1) /* on the disapproved list */ then do; call err (error_table_$undefined_order_request, caller, order); code = 0; end; else call iox_$control (iocbp, (order), null (), code); end; RETURN: return; end tty_io_call_control_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved