Multics > Library > Source
25 Jan 1977

bound_info_rtns_.s.archive

History | People | Library | Sites | About

This Multics source file was rescued from the messed-up source archive at MIT.

This is an exmaple of an archive of Multics source programs, a small part of the Multics Standard Service System commands. These programs were compiled and their individual object files bound into a single object segment. The individual components and their descriptions are:

check_info_segs (cis)

This command and active function checks to see if any system information segments have changed since the user last looked. The command prints out the names of changed segments; the active function returns their pathnames. Control arguments allow the command invocation to specify another command to be called on each changed segment. Each user has a personal "value segment" used to store various bits of information, and check_info_segs stores the date and time last looked in the value segment.

Original implementation by Tom Van Vleck. It occurs to me, about 30 years after I wrote this command, that it's only useful at a site where info seg updates happen more or less continuously. Customers at Multics sites who got yearly releases would see nothing from this command for a year, and then a huge list of changes once. So, like the who command, this command assumes something about the online community that uses it.

help

The help command prints out system information files. It is similar to the Unix "man" command.

Multics system information segments ("info segments") for standard commands are created by processing the system manual source and extracting the help information: thus, the manuals and the help have a single source, but there is more information in the manual than in the help segments, and the help segments have indexing and structural items added so that help can display summaries, skip sections, and provide better interaction.

help is a wrapper for the help_ subroutine below. The wrapper/guts structure is used in many commands. The wrapper handles the business of being a command, error printing, and so on. The guts does the internals of the processing and may be used by the wrapper and by other subsystems.

Original implementation by Tom Van Vleck.

help_

This subroutine is the guts of the help command.

list_help (lh)

This command and active function lists system information segments that are relevant to a particular topic. (The Unix "man" command has a similar control argument.)

list_ref_names (lrn)

This command lists the reference names by which a segment is initiated.

print_motd (pmotd)

This command prints those lines in the "message of the day" system information segment, motd.info, which have the user has not seen. This command also stores its information in the user's value segment.

resource_usage (ru)

This command prints a table that shows the user's resource limits and usage against these limits.

Original implementation by Tom Van Vleck and Janice Phillipps.

ring0_get_

This subroutine reads information from the supervisor. Only specific values are available to normal user programs.

system_info_

This subroutine reads information about the system.

Original implementation by Tom Van Vleck.

user_info_

This subroutine returns information about the particular logged-in user process.

Original implementation by Tom Van Vleck.

where (wh)

This command and active function uses the system search rules to find a sgment, and prints out its file system pathname.

who, how_many_users (hmu)

This command prints a list of logged in users. The source also implements a related command, "how_many_users (hmu)" that prints out the total number of users currently logged in. These commands merely format and display data placed in a public data segment by the answering service.

See also the writeup of the Who Command, containing a copy of the info seg and a sample of the output.

This command is descended from the WHO command on CTSS. Some versions of Unix have a similar command of the same name.

Original Multics implementation by Tom Van Vleck.

Back to Multics Source index.

\014



            check_info_segs.pl1             02/04/82  1425.6rew 02/04/82  1420.7      179946



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* Check directories for new info segments.

   This command remarks about any file in a directory in the "info_segments"
   search list or in user-supplied directories with the dtem greater than the
   last_time_looked.  The last_time_looked is kept in the user's default
   value segment.

   The active function returns the selected info seg names separated by spaces

   Rewritten 24-Oct-78 by Monte Davidoff.
   Modified February 1979 by Michael R. Jordan for unsigned changes to star_structures.incl.pl1. */
/* No_s bug obtaining dtcm's fixed 12/12/79 S. Herbst */
/* Implement [cis], -absolute_pathname, and fix bugs 06/11/80 S. Herbst */
/* Implement -time_checked Sept 1980  Marshall Presser */
/* Implement discarding of duplicates when same segment identified twice 81/02/11 Paul Benjamin */
/* Modified: 14 January 1982 by G. Palter to convert to using the default value segment */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */

check_info_segs:
cis:
     procedure () options (variable);

dcl  arg_count fixed binary;
dcl  arg_length fixed binary (21);
dcl  arg_ptr pointer;
dcl  argx fixed binary;
dcl  call_str_length fixed binary (21);
dcl  call_str_ptr pointer;
dcl  change_sw bit (1);
dcl  code fixed binary (35);
dcl  complain entry variable options (variable);
dcl  dir_name char (168);
dcl  duplicate bit (1);
dcl  entryname char (32);
dcl  last_time_looked fixed binary (71);
dcl  return_len fixed binary;
dcl  return_ptr pointer;
dcl  uid_list_count fixed binary;
dcl  uid_list_index fixed binary;
dcl  uid_list_ptr ptr;
dcl  1 sw,
       2 absp bit (1),
       2 af bit (1),
       2 brief bit (1),
       2 call bit (1),
       2 long bit (1),
       2 pathname bit (1),
       2 update bit (1),
       2 check_time bit (1);
dcl  time_checked char (24);
dcl  update_time fixed binary (71);

dcl  arg_string char (arg_length) based (arg_ptr);
dcl  return_arg char (return_len) varying based (return_ptr);
dcl  uid_list (uid_list_count) bit (36) based (uid_list_ptr);

dcl  (addr, binary, clock, currentsize, divide, empty, hbound, index, length, null, rtrim) builtin;

dcl  (cleanup, program_interrupt) condition;

dcl  DEFAULT_VALUE_SEGMENT pointer static options (constant) initial (null ());
dcl  PERMANENT_VALUE bit (36) aligned static options (constant) initial ("01"b);
dcl  CIS_VALUE_NAME character (17) static options (constant) initial ("check_info_segs._");

dcl  command char (32) internal static options (constant) initial ("check_info_segs");

dcl  error_table_$badopt fixed binary (35) external static;
dcl  error_table_$no_dir fixed binary (35) external static;
dcl  error_table_$no_s_permission fixed binary (35) external static;
dcl  error_table_$noentry fixed binary (35) external static;
dcl  error_table_$nomatch fixed binary (35) external static;
dcl  error_table_$not_act_fnc fixed binary (35) external static;
dcl  error_table_$oldnamerr fixed binary (35) external static;

dcl  active_fnc_err_ entry () options (variable);
dcl  active_fnc_err_$suppress_name entry () options (variable);
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  convert_date_to_binary_ entry (char (*), fixed binary (71), fixed binary (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  date_time_ entry (fixed binary (71), char (*));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$star_dir_list_
    entry (char (*), char (*), fixed binary (3), pointer, fixed binary, fixed binary, pointer, pointer,
    fixed binary (35));
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  search_paths_$get entry (char (*), bit (36), char (*), pointer, pointer, fixed binary, pointer, fixed binary (35));
dcl  user_info_ entry (char (*));
dcl  user_info_$homedir entry (char (*));
dcl  value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35));
dcl  value_$get_path entry (char (*), fixed bin (35));
dcl  value_$set_data
    entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35));
dcl  value_$set_path entry (char (*), bit (1), fixed bin (35));

/*\014*/

    call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
    if code = error_table_$not_act_fnc then do;
         sw.af = "0"b;
         complain = com_err_;
    end;
    else do;
         sw.af = "1"b;
         complain = active_fnc_err_;
         return_arg = "";
    end;

    sl_info_p = null ();
    star_entry_ptr = null ();
    star_names_ptr = null ();
    uid_list_ptr = null ();

    on cleanup call cleanup_;

    last_time_looked = 0;           /* none yet supplied */
    sw.absp = "0"b;
    sw.brief = "0"b;
    sw.call = "0"b;
    sw.long = "0"b;
    sw.pathname = "0"b;
    sw.check_time = "0"b;
    sw.update = "1"b;
    change_sw = "0"b;
    call_str_length = 0;


    do argx = 1 to arg_count;

         call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
         if code ^= 0 then do;
        call complain (code, command, "Fetching argument #^d.", argx);
        return;
         end;

         if arg_string = "-absolute_pathname" | arg_string = "-absp" then sw.absp = "1"b;

         else if arg_string = "-brief" | arg_string = "-bf" then
        if sw.af then
             go to BAD_OPT;
        else sw.brief = "1"b;

         else if arg_string = "-call" then do;
        if sw.af then go to BAD_OPT;
        sw.call = "1"b;
        argx = argx + 1;
        call cu_$arg_ptr (argx, call_str_ptr, call_str_length, code);
        if code ^= 0 then do;
             call complain (code, command, "Missing command line after -call.");
             return;
        end;
         end;

         else if arg_string = "-date" | arg_string = "-dt" then do;
        sw.update = "0"b;
        argx = argx + 1;
        call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
        if code ^= 0 then do;
             call complain (code, command, "Missing date after -date.");
             return;
        end;

        call convert_date_to_binary_ (arg_string, last_time_looked, code);
        if code ^= 0 then do;
             call complain (code, command, "^a", arg_string);
             return;
        end;
         end;

         else if arg_string = "-long" | arg_string = "-lg" then
        if sw.af then
             go to BAD_OPT;
        else sw.long = "1"b;

         else if arg_string = "-no_update" | arg_string = "-nud" then sw.update = "0"b;

         else if arg_string = "-time_checked" | arg_string = "-tmck" then sw.check_time = "1"b;

         else if arg_string = "-pathname" | arg_string = "-pn" then do;
        sw.pathname = "1"b;
        argx = argx + 1;
        call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
        if code ^= 0 then do;
             call complain (code, command, "Missing star pathname after -pathname.");
             return;
        end;

        call expand_pathname_ (arg_string, dir_name, entryname, code);
        if code ^= 0 then do;
             call complain (code, command, "^a", arg_string);
             return;
        end;
         end;

         else if is_control_arg (arg_string) then do;
BAD_OPT:
        call complain (error_table_$badopt, command, "^a", arg_string);
        return;
         end;

         else do;
        if sw.af then
             call active_fnc_err_$suppress_name (0, command, "Usage:  [^a {-control_args}]", command);
        else call com_err_$suppress_name (0, command, "Usage:  ^a {-control_args}", command);
        return;
         end;
    end;

    if sw.af & sw.check_time then
         if arg_count > 1 then do;
        call complain (0, command, "The -time_checked control argument is incompatible with any others.");
        return;
         end;

/*\014*/

    if last_time_looked = 0 then            /* if user didn't supply a date/time on the command line */
         call get_time (last_time_looked);

    if sw.check_time then do;
         call date_time_ (last_time_looked, time_checked);
         if sw.af then
        if last_time_looked = 0 then do;
             call complain (0, command,
            "There is no initial date in the user profile on when info segments were last checked.");
             return;
        end;
        else do;
             return_arg = requote_string_ (time_checked);
             return;
        end;

         else do;
        if last_time_looked = 0 then do;
             call complain (0, command,
            "There is no initial date in the user profile on when info segments were last checked.");
             return;
        end;
        else call ioa_ ("Info segments were last checked on ^a", time_checked);
        if arg_count = 1 then return;
         end;
    end;

    update_time = clock ();         /* avoids missing segments if -call is used */

    if sw.update & last_time_looked = 0 then do;
         if ^sw.af then
        call ioa_ ("^a: ^a", command,
             "Initializing date stored in default value segment on which info segments were last checked.");
         call put_time (update_time);
         return;
    end;

    call get_temp_segment_ (command, uid_list_ptr, code);
    if code ^= 0 then do;
         call complain (code, command);
         call cleanup_;
         return;
    end;
    uid_list_count = 0;

    if sw.pathname then do;
         do argx = 1 to arg_count;

        call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
        if code = 0 then
             if arg_string = "-pathname" | arg_string = "-pn" then do;
            argx = argx + 1;
            call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
            call expand_pathname_ (arg_string, dir_name, entryname, code);
            call check_directory (dir_name, entryname);
             end;
             else if arg_string = "-call" | arg_string = "-date" | arg_string = "-dt" then argx = argx + 1;
         end;
    end;
    else do;
         call search_paths_$get ("info_segments", sl_control_default, "", null (), get_system_free_area_ (),
        sl_info_version_1, sl_info_p, code);
         if code ^= 0 then do;
        call complain (code, command, "info_segments");
        call cleanup_;
        return;
         end;

         do argx = 1 to sl_info.num_paths;
        call check_directory (sl_info.paths (argx).pathname, "**.info");
         end;
    end;

    if ^change_sw & ^sw.brief & ^sw.af then call ioa_ ("No changed info segments.");

    if sw.update then call put_time (update_time);

RETURN_FROM_CHECK_INFO_SEGS:
    call cleanup_;

    return;

/*\014*/

/* Check a directory for changed info segments */

check_directory:
     procedure (dir_name, star_name);

dcl  dir_name char (*);             /* (Input) directory to search */
dcl  star_name char (*);                /* (Input) star name of segments to check */

dcl  1 branch like status_branch.short aligned;
dcl  target_dn char (168);
dcl  target_en char (32);
dcl  command_line char (call_str_length + 169) aligned;
dcl  entryx fixed binary;

dcl  NO_CHASE fixed binary (1) internal static options (constant) initial (0);

    on program_interrupt goto done_checking_dir;

    star_select_sw = star_ALL_ENTRIES;
    call hcs_$star_dir_list_ (dir_name, star_name, star_select_sw, get_system_free_area_ (), star_branch_count,
         star_link_count, star_list_branch_ptr, star_list_names_ptr, code);

    if code ^= 0 & code ^= error_table_$nomatch & code ^= error_table_$no_dir & ^sw.brief then
         call complain (code, command, "^a^[>^]^a", dir_name, dir_name ^= ">", star_name);
                        /* in particular, >doc>iml_info may be empty or non-existent */

    else do entryx = 1 to hbound (star_links, 1);
         if star_links (entryx).type = star_SEGMENT then
        call check_segment (dir_name, star_list_names (star_dir_list_branch (entryx).nindex), dir_name,
             star_list_names (star_dir_list_branch (entryx).nindex), star_dir_list_branch (entryx).dtem);

         else if star_links (entryx).type = star_LINK then do;
        call hcs_$get_link_target (dir_name, star_list_names (star_links (entryx).nindex), target_dn,
             target_en, code);
        if code = 0 then do;        /* target exists */

             call hcs_$status_ (target_dn, target_en, NO_CHASE, addr (branch), null (), code);
             if code ^= 0 & code ^= error_table_$noentry & code ^= error_table_$no_s_permission then
            call complain (code, command, "Link target ^a^[>^]^a", target_dn, target_dn ^= ">",
                 target_en);

             else if branch.type = Segment then
            call check_segment (target_dn, target_en, dir_name,
                 star_list_names (star_links (entryx).nindex), branch.dtcm);
        end;
         end;
    end;

done_checking_dir:
    if star_list_names_ptr ^= null () then do;
         free star_list_names;
         star_list_names_ptr = null ();
    end;
    if star_list_branch_ptr ^= null () then do;
         free star_links;
         star_list_branch_ptr = null ();
    end;

    return;

/*\014*/

/* Check if a segment has been modified */

check_segment:
    procedure (dir_name, entryname, print_dn, print_en, dtm);

dcl  dir_name char (*);             /* (Input) directory containing the segment */
dcl  entryname char (*);                /* (Input) entryname of the segment */
dcl  print_dn char (*);             /* (Input) directory name of link if link, or seg */
dcl  print_en char (*);             /* (Input) entryname of link if link, or seg */
dcl  dtm bit (36);                  /* (Input) date-time modified */

dcl  name char (168);               /* name as printed */
dcl  pathname char (168);               /* absolute pathname */
dcl  date_time char (16);
dcl  modified_time fixed binary (71);

dcl  call_str char (call_str_length) based (call_str_ptr);

dcl  1 branch like status_branch aligned;
dcl  NO_CHASE fixed bin (1) int static options (constant) init (0);

         modified_time = binary (dtm || (16)"0"b, 71);
         if modified_time >= last_time_looked then do;

        call hcs_$status_long (dir_name, entryname, NO_CHASE, addr (branch), null (), code);

        modified_time = binary (dtcm || (16)"0"b, 71);
                        /* make sure by checking dtcm */
        if modified_time >= last_time_looked then do;

             duplicate = "0"b;

             do uid_list_index = 1 to uid_list_count;
            if uid_list (uid_list_index) = branch.uid then do;
                 duplicate = "1"b;
                 uid_list_index = uid_list_count;
            end;
             end;
             if duplicate = "0"b then do;
            uid_list_count = uid_list_count + 1;
            uid_list (uid_list_count) = branch.uid;
            change_sw = "1"b;       /* something has actually changed */

            if print_dn = ">" then
                 pathname = ">";
            else pathname = rtrim (print_dn) || ">";
            pathname = rtrim (pathname) || print_en;

            if sw.absp then
                 name = pathname;   /* return absolute pathnames */
            else name = print_en;

            if sw.af then do;
                 if return_arg ^= "" then return_arg = return_arg || " ";
                 return_arg = return_arg || requote_string_ (rtrim (name));
            end;
            else if sw.long then do;
                 call date_time_ (modified_time, date_time);
                 call ioa_ ("^a ^a", date_time, name);
            end;
            else if ^sw.brief then call ioa_ ("^a", name);
            if sw.call then do;
                 command_line = call_str || " " || pathname;
                 call cu_$cp (addr (command_line), length (rtrim (command_line)), code);
            end;
             end;
        end;
         end;

         return;

    end check_segment;

     end check_directory;

/*\014*/

/* Check if an argument is a control arg */

is_control_arg:
     procedure (arg) returns (bit (1));

dcl  arg char (*);                  /* (Input) command argument */

    if arg = "" then
         return ("0"b);
    else return (index (arg, "-") = 1);

     end is_control_arg;

/*\014*/

cleanup_:
     procedure ();

    if sl_info_p ^= null () then do;
         free sl_info;
         sl_info_p = null ();
    end;

    if star_names_ptr ^= null () then do;
         free star_list_names;
         star_names_ptr = null ();
    end;

    if star_entry_ptr ^= null () then do;
         free star_links;
         star_entry_ptr = null ();
    end;

    if uid_list_ptr ^= null () then call release_temp_segment_ (command, uid_list_ptr, code);

    return;

     end cleanup_;

/*\014*/

/* Fetch the date/time info segments were last check from the value segment: if the time isn't present in the value
   segment, check the abbrev profile for an old style date/time and copy it to the value segment */

get_time:
     procedure (p_date_time);

dcl  p_date_time fixed binary (71) parameter;

dcl  small_area area (256);
dcl  based_date_time fixed binary (71) based (date_time_ptr);
dcl  date_time_ptr pointer;

    call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (small_area), date_time_ptr,
         (0), code);

    if (code = error_table_$oldnamerr) | (code = error_table_$noentry) then do;
         call get_date_time_from_profile ();
         call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (small_area),
        date_time_ptr, (0), code);
    end;

    if code ^= 0 then               /* couldn't find a date/time anywhere */
         p_date_time = 0;
    else p_date_time = based_date_time;

    return;



/* Internal to get_time: check for an abbrev style profile and, if present, copy the date/time from it */

get_date_time_from_profile:
    procedure ();

dcl  home_dir character (168);
dcl  person_id character (24);
dcl  profile_ename character (32);

dcl  1 old_profile aligned based (profile_ptr),     /* abbrev profile */
       2 version fixed binary,
       2 pad (3) bit (36),
       2 check_info_time fixed binary (71);
dcl  profile_ptr pointer;

         call user_info_$homedir (home_dir);
         call user_info_ (person_id);
         profile_ename = rtrim (person_id) || ".profile";

         profile_ptr = null ();

         on cleanup
        begin;              /* just in case (even with such a small window) */
             if profile_ptr ^= null () then call hcs_$terminate_noname (profile_ptr, (0));
             profile_ptr = null ();
        end;

         call hcs_$initiate (home_dir, profile_ename, "", 0b, 00b, profile_ptr, (0));

         if profile_ptr ^= null () then do;     /* there is a profile */
        if old_profile.version = 1 then /* only new style profile has the cis date/time */
             call put_time (old_profile.check_info_time);
        call hcs_$terminate_noname (profile_ptr, (0));
         end;

         return;

    end get_date_time_from_profile;

     end get_time;

/*\014*/

/* Put the updated date/time into the user's value segment */

put_time:
     procedure (p_date_time);

dcl  p_date_time fixed binary (71) parameter;

    call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (p_date_time),
         currentsize (p_date_time), null (), (null ()), (0), code);

    if code = error_table_$noentry then do;     /* value segment not present: try to create it */
         call create_default_value_segment ();
         call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (p_date_time),
        currentsize (p_date_time), null (), (null ()), (0), code);
    end;

    if code ^= 0 then call com_err_ (code, command, "Attempting to update date/time in default value segment.");

    return;



/* Internal to put_time: create the default value segment (if possible) */

create_default_value_segment:
    procedure ();

dcl  value_segment_path character (168);

         call value_$set_path ("", "1"b, code);

         if code = 0 then do;           /* created it */
        call value_$get_path (value_segment_path, (0));
        call com_err_ (0, command, "Created ^a.", value_segment_path);
         end;

         return;

    end create_default_value_segment;

     end put_time;

/*\014*/

%include sl_info;

%include sl_control_s;
%page;
%include star_structures;
%page;
%include status_structures;

     end check_info_segs;
\014



            help.pl1                        03/27/81  1446.0rew 03/27/81  1444.9      128583



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */


    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Name:    help                                */
    /*                                  */
    /* This is the command interface to the Multics help facility.  It does the following.  */
    /*                                  */
    /* 1) call help_$init to obtain a help_args structure in which arguments and control    */
    /*    arguments can be stored.                      */
    /* 2) process caller-supplied arguments, filling in the help_args structure.        */
    /* 3) call help_ with the help_args structure to actually find and print the info segs. */
    /* 4) call help_$term to release the help_args structure.               */
    /*                                  */
    /* help searches for info segments (having a suffix of info) in the directories given in    */
    /* the search paths of the info_segments (info_segs or infos) search list, which    */
    /* is maintained by the Multics search facility.                    */
    /*                                  */
    /* Status                                   */
    /*                                  */
    /* 0) Created:   November, 1969   by T. H. VanVleck             */
    /* 1) Modified:  February, 1975   by T. H. VanVleck - complete rewrite      */
    /* 2) Modified:  September,1976   by Steve Herbst - accept -pathname ctl_arg        */
    /* 3) Modified:  June, 1977     by Paul Green - diagnose zero-length info segs  */
    /* 4) Modified:  October, 1978    by Gary Dixon - complete rewrite; split into help */
    /*              command and separate help_ subroutine.      */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
\014
help: procedure;

     dcl
         (Iarg_end_ca, Iarg_end_scn, Iarg_start_ca, Iarg_start_scn, Iarg_start_srh)
                fixed bin,
         (Larg, Lop)        fixed bin,
    Nargs           fixed bin,
         (Parg, Pop)        ptr,
    Serror          bit(1) aligned,
         (cleanup, conversion, size)    condition,
    code            fixed bin(35),
    error_type      fixed bin,
         (i, j)         fixed bin;

     dcl
    arg         char(Larg) based(Parg),
    op          char(Lop)  based(Pop);

     dcl (bin, convert, dim, maxlength, null, substr)
                builtin;

     dcl
    com_err_            entry options(variable),
    cu_$arg_count       entry returns(fixed bin),
    cu_$arg_ptr     entry (fixed bin, ptr, fixed bin, fixed bin(35));

     dcl
         (FALSE         init ("0"b),
    TRUE            init ("1"b)) bit(1) aligned int static options(constant),
    ctl_abbrev (10)     char(6) varying int static options(constant) init (
                     "-scn",    /* 1 */
                     "-srh",    /* 2 */
                     "-bf", /* 3 */
                     "-ca", /* 4 */
                     "-ep", /* 5 */
                     "-he", /* 6 */
                     "-bfhe",   /* 7 */
                     "-pn", /* 8 */
                     "-a",  /* 9 */
                     "-title"), /*10 */
    ctl_word (12)       char(13) varying int static options(constant) init (
                     "-section",        /* 1 */
                     "-search",     /* 2 */
                     "-brief",      /* 3 */
                     "-control_arg",    /* 4 */
                     "-entry_point",    /* 5 */
                     "-header",     /* 6 */
                     "-brief_header",   /* 7 */
                     "-pathname",       /* 8 */
                     "-all",        /* 9 */
                     "-titles",     /*10 */
                     "-maxlines",       /*11 */
                     "-minlines"),      /*12 */
\014
    ctl_obsolete (2)        char(3) varying int static options(constant) init (
                     "-sc", /* 1 */
                     "-sh"),    /* 2 */
         (error_table_$bad_arg,
    error_table_$badopt,
    error_table_$bigarg,
    error_table_$inconsistent,
    error_table_$noarg,
          error_table_$noentry,
    error_table_$unimplemented_version)
                fixed bin(35) ext static;
\014
%include help_args_;
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


    Phelp_args = null;
    on cleanup call janitor();          /* Cleanup help arg segment if help aborted.    */
    call help_$init ("help", "info_segments", "", Vhelp_args_1, Phelp_args, code);
    if Phelp_args = null then           /* get help input arguments.            */
         go to ARG_STRUC_ERR;
    if help_args.version ^= Vhelp_args_1 then do;   /* check version of structure for validity. */
         code = error_table_$unimplemented_version;
         go to ARG_STRUC_ERR;
         end;
    Nargs = cu_$arg_count();            /* get count of input arguments.        */

    Serror = FALSE;             /* Remember if error encountered in args.   */
    Iarg_start_srh = Nargs+1;           /* -search not encountered so far.      */
    Iarg_start_ca  = Nargs+1;           /* Same for -control_arg.           */
    Iarg_start_scn = Nargs+1;           /* Same for -section            */
    Iarg_end_ca    = 0;
    Iarg_end_scn   = 0;
    help_args.Sctl.he_pn = TRUE;            /* Output long heading by default.      */
    help_args.Sctl.he_counts = TRUE;
    do i = 1 to Nargs;              /* Process args.                */
         call cu_$arg_ptr (i, Parg, Larg, 0);
         if  Larg>=1  &  substr(arg,1,1) = "-"  then do;
        do j = 1 to dim(ctl_abbrev,1) while (arg ^= ctl_abbrev(j));
             end;
        if j > dim(ctl_abbrev,1) then do;
             do j = 1 to dim(ctl_word,1) while (arg ^= ctl_word(j));
            end;
             if j > dim(ctl_word,1) then do;
            do j = 1 to dim(ctl_obsolete,1) while (arg ^= ctl_obsolete(j));
                 end;
            if j > dim(ctl_obsolete,1) then do;
                 Serror = TRUE;
                 call com_err_ (error_table_$badopt, "help", arg);
                 go to NEXT_ARG;
                 end;
            end;
             end;
        go to DO_ARG(j);
\014
DO_ARG(1):          if i = Nargs then go to NO_OPERAND;
        call cu_$arg_ptr (i+1, Pop, Lop, code);
        if  Lop>=1  then
             if substr(op,1,1) = "-" then go to NO_OPERAND;
        help_args.Sctl.scn = TRUE;
        i = i+1;                /* -section:  next arg guaranteed part of         */
        Iarg_start_scn = i;         /*   section name.                                */
        Iarg_end_scn = i;
        do i = i+1 to Nargs;        /* Remaining args not starting with - are part    */
                        /*   of section name too.                         */
             call cu_$arg_ptr (i, Pop, Lop, 0);
             if  Lop >= 1  then
            if substr(op,1,1) = "-"  then do;
                 i = i - 1;
                 go to NEXT_ARG;
                 end;
             Iarg_end_scn = i;
             end;
        go to NEXT_ARG;
\014
DO_ARG(2):          if i = Nargs then go to NO_OPERAND;
        help_args.Sctl.srh = TRUE;      /* -search:  All remaining args are search        */
                        /*   strings.                                     */
        Iarg_start_srh = i + 1;     /* Remember where search args begin.              */
        i = Nargs;
        go to NEXT_ARG;

DO_ARG(3):          help_args.Sctl.bf = TRUE;       /* -brief                                         */
        go to NEXT_ARG;

DO_ARG(4):          if i = Nargs then go to NO_OPERAND;
        i = i + 1;          /* -control_arg:  args not starting with - are    */
                        /*   control argument names.                      */
        Iarg_start_ca = i;          /* Remember where ca names start.                 */
        Iarg_end_ca = i;            /* Remember where last ca name is.      */
        help_args.Sctl.ca = TRUE;       /* -ca                  */
        do i = i+1 to Nargs;
             call cu_$arg_ptr (i, Pop, Lop, 0);
             if  Lop>=1  then
            if substr(op,1,1) = "-"  then do;
                 i = i - 1;
                 go to NEXT_ARG;
                 end;
             Iarg_end_ca = i;
             end;
        go to NEXT_ARG;
\014
DO_ARG(5):  help_args.Sctl.ep = TRUE;       /* -entry_point             */
        go to NEXT_ARG;

DO_ARG(6):  help_args.Sctl.he_only = TRUE;  /* -header (print only heading)     */
        go to NEXT_ARG;

DO_ARG(7):  help_args.Sctl.he_pn = FALSE;       /* -brief_header (output brief headings)    */
        go to NEXT_ARG;

DO_ARG(8):  if i = Nargs then go to NO_OPERAND; /* -pathname:  following arg is a pathname, */
        i = i + 1;          /*   no matter what it looks like.      */
        call cu_$arg_ptr (i, Pop, Lop, 0);
        j = 1;
        if maxlength(help_args.path(j).value) < Lop then do;
             call com_err_ (error_table_$bigarg, "help", " ^a ^a",
            arg, op);
             Serror = TRUE;
             end;
        else do;
             help_args.Npaths, j = help_args.Npaths + 1;
             help_args.path(j).S = "0"b;
             help_args.path(j).S.pn_ctl_arg = TRUE;
             help_args.path(j).value = op;
             help_args.path(j).info_name = "";
             end;
        go to NEXT_ARG;
\014
DO_ARG(9):  help_args.Sctl.all = TRUE;      /* -all                 */
        go to NEXT_ARG;

DO_ARG(10): help_args.Sctl.title = TRUE;        /* -title                   */
        go to NEXT_ARG;

DO_ARG(11): if i = Nargs then go to NO_OPERAND; /* -maxlines N              */
        i = i + 1;
        call cu_$arg_ptr (i, Pop, Lop, 0);
        on conversion, size go to BAD_OPERAND;
        help_args.min_Lpgh = convert (help_args.min_Lpgh, op);
        revert conversion, size;
        if  help_args.min_Lpgh < 1  |  help_args.min_Lpgh > 50  then
             go to BAD_OPERAND;
        go to NEXT_ARG;

DO_ARG(12): if i = Nargs then go to NO_OPERAND; /* -minlines N              */
        i = i + 1;
        call cu_$arg_ptr (i, Pop, Lop, 0);
        on conversion, size go to BAD_OPERAND;
        help_args.min_Lpgh = convert (help_args.min_Lpgh, op);
        revert conversion, size;
        if  help_args.min_Lpgh < 1  |  help_args.min_Lpgh > 50  then
             go to BAD_OPERAND;
        go to NEXT_ARG;

NO_OPERAND: Serror = TRUE;          /* No operand given with -scn, -srh, -ca, -pn   */
        call com_err_ (error_table_$noarg, "help", "No operand given following ^a.", arg);
        go to NEXT_ARG;

BAD_OPERAND:    Serror = TRUE;          /* Bad numeric operand with -minlines.  */
        call com_err_ (error_table_$bad_arg, "help",
             " ^a^/Operand of ^a must be integer from 1 to 50.", op, arg);

        end;
         else do;
        j = 1;
        if maxlength(help_args.path(j).value) < Larg then do;
             call com_err_ (error_table_$bigarg, "help", " ^a",
            arg);
             Serror = TRUE;
             end;
        else do;
             help_args.Npaths, j = help_args.Npaths + 1;
             help_args.path(j).S = "0"b;
             help_args.path(j).value = arg;
             help_args.path(j).info_name = "";
             end;
        end;
NEXT_ARG:      end;
\014
    if help_args.Sctl.bf then           /* Complain if other ctl_args given with -brief */
         if help_args.Sctl.title |
            help_args.Sctl.all  then do;
        Serror = TRUE;
        call com_err_ (error_table_$inconsistent, "help",
             "^/-brief may not be given with: ^[ -title^]^[ -all^].",
             help_args.Sctl.title, help_args.Sctl.all);
        end;
    if help_args.Sctl.ca then           /* Complain if other ctl_args given with -ca    */
         if help_args.Sctl.title |
            help_args.Sctl.all  then do;
        Serror = TRUE;
        call com_err_ (error_table_$inconsistent, "help",
             "^/-control_arg may not be given with: ^[ -title^]^[ -all^].",
             help_args.Sctl.title, help_args.Sctl.all);
        end;
    if help_args.Sctl.he_only then
         if help_args.Sctl.title |
                    help_args.Sctl.bf |
            help_args.Sctl.all |
            help_args.Sctl.ca   then do;
        Serror = TRUE;
        call com_err_ (error_table_$inconsistent, "help", "
-header may not be given with: ^[ -brief^]^[ -title^]^[ -control_arg^]^[ -all^].",
             help_args.Sctl.bf, help_args.Sctl.title,
             help_args.Sctl.ca, help_args.Sctl.all);
        end;
    if help_args.Npaths = 0 then do;        /* Supply default pathname of help_system.gi.info.  */
         help_args.Npaths = 1;
         help_args.path(1).value = ">doc>info>help_system.gi.info";
                        /* Give info for installed help command.    */
         help_args.path(1).info_name = "";
         help_args.path(1).S = "0"b;
         end;
\014
    do i = Iarg_start_ca to Iarg_end_ca;        /* Add control arg names to arg structure.  */
         call cu_$arg_ptr (i, Parg, Larg, 0);
         j = 1;
         if maxlength (help_args.ca(j)) < Larg then do;
        Serror = TRUE;
        call com_err_ (error_table_$bigarg, "help", " -ca ^a
Maximum length is ^d characters.", arg, maxlength(help_args.ca(j)));
        end;
         else do;
        help_args.Ncas, j = help_args.Ncas + 1;
        help_args.ca(j)   = arg;
        end;
         end;
    do i = Iarg_start_scn to Iarg_end_scn;      /* Add -section substrings to arg structure.    */
         call cu_$arg_ptr (i, Parg, Larg, 0);
         j = 1;
         if maxlength (help_args.scn(j)) < Larg then do;
        Serror = TRUE;
        call com_err_ (error_table_$bigarg, "help", " -scn ^a
Maximum length is ^d characters.", arg, maxlength(help_args.scn(j)));
        end;
         else do;
        help_args.Nscns, j = help_args.Nscns + 1;
        help_args.scn(j)   = arg;
        end;
         end;
    do i = Iarg_start_srh to Nargs;     /* Add -search args to control structure.   */
         call cu_$arg_ptr (i, Parg, Larg, 0);
         j = 1;
         if maxlength (help_args.srh(j)) < Larg then do;
        Serror = TRUE;
        call com_err_ (error_table_$bigarg, "help", " -srh ^a
Maximum length is ^d characters.", arg, maxlength(help_args.srh(j)));
        end;
         else do;
        help_args.Nsrhs, j = help_args.Nsrhs + 1;
        help_args.srh(j)   = arg;
        end;
         end;
    if Serror then do;
         call janitor();
         return;
         end;
\014
    call help_ ("help", Phelp_args, "info", error_type, code);
    go to ERROR (error_type);

ARG_STRUC_ERR:
ERROR(1):                       /* bad help_args version.           */
ERROR(2):                       /* No pathnames given in help_args.     */
    call com_err_ (code, "help", "^/While processing the argument structure used by help_.");
    call janitor();
    return;

ERROR(3):                       /* Error encountered in processing one or more  */
                        /* of the pathnames given in help_args.     */
    do i = 1 to help_args.Npaths;
         if help_args.path(i).code ^= 0 then
        call com_err_ (help_args.path(i).code, "help", " ^[-pn ^]^a",
             help_args.path(i).S.pn_ctl_arg, help_args.path(i).value);
         end;
    call janitor();
    return;

ERROR(5):                       /* If a nonzero error code is returned, it means    */
                        /* than -section and -search failed to find any */
                        /* matching info segs to print.  This error must    */
                        /* be reported to the user.         */
    if code ^= 0 then
         call com_err_ (error_table_$noentry, "help", "
Looking for infos matching info_name^[s^]^[^; and -search criteria^; and -section criteria^;, plus -section and -search criteria^].",
        (help_args.Npaths > 1), (1 + 2*bin(help_args.Sctl.scn,1) + bin(help_args.Sctl.srh,1)));

ERROR(4):                       /* No fatal errors encountered.  Most nonfatal  */
                        /*   errors have been reported by help_.    */
    call janitor();
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


janitor: procedure;

    if Phelp_args ^= null then
         call help_$term ("help", Phelp_args, code);

    end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


    end help;
\014



            help_.pl1                       11/19/82  1015.7rew 11/19/82  0956.4     1507932



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Name:  help_                             */
    /*                                  */
    /* This subroutine implements the help command.  It performs the following functions.   */
    /*                                  */
    /* 1) Finds info segments.                          */
    /* 2) Selects particular infos within multi-info segments.              */
    /* 3) Sorts the list of infos to be processed.                  */
    /* 4) Processes each info, implementing all help control arguments and query responses. */
    /*                                  */
    /* The subroutine may also be used to implement a help-style information facility in    */
    /* other subsystems.  Information segments (with an info suffix or another suffix) are  */
    /* selected and printed, based upon information given primarily in a help_args structure,   */
    /* which is declared in help_args_.incl.pl1.                    */
    /*                                  */
    /* Usage                                    */
    /*                                  */
    /* The help_ subroutine must be invoked by a sequence of calls.         */
    /*                                  */
    /* 1) call help_$init to get temp segment containing help_args structure and stores the     */
    /*    current info_segments search rules in the structure.              */
    /* 2) call help_ one or more times to select and print info segments.           */
    /* 3) call help_$term to release the temp segment.              */
    /*                                  */
    /* Entry:  help_$check_info_segs                        */
    /*                                  */
    /* This subroutine generates the list of info segments to be processed by the       */
    /* check_info_segs command.  It finds info segments modified since a given date, sorts  */
    /* the list and returns it for check_info_segs to process.              */
    /*                                  */
    /* Usage                                    */
    /*                                  */
    /* 1) call help_$init to get temp segment containing help_args and the output list. */
    /* 2) call help_$check_info_segs to build and sort the list of segments to be processed.    */
    /* 3) call help_$term to release the temp segment.              */
    /*                                  */
\014
    /* Status                                   */
    /*                                  */
    /* 0) Created:   November, 1969   by T. H. VanVleck             */
    /* 1) Modified:  February, 1975   by T. H. VanVleck - complete rewrite      */
    /* 2) Modified:  September,1976   by Steve Herbst - accept -pathname ctl_arg        */
    /* 3) Modified:  June, 1977     by Paul Green - diagnose zero-length info segs  */
    /* 4) Modified:  October, 1978    by Gary Dixon - complete rewrite; split into help */
    /*              command and separate help_ subroutine.      */
    /*              Add support for check_info_segs.        */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

\014
help_: procedure (procedure_name, Phelp_args, suffix, progress, Acode);


     dcl                        /*  Parameters          */
    procedure_name      char(*),        /* Caller of help_ and help_$init.      */
                        /*   1) Owns temp segment help_args are stored in.*/
                        /*   2) Name used in error messages.        */
/*  Phelp_args      ptr,        /* ptr to argument struc at base of temp seg.   */
                        /* This is really declared in include seg.  */
    suffix          char(*),        /* Suffix on segs to be processed. Normally "info"*/
                        /* but may be some other suffix or "" to omit   */
                        /* suffix processing.           */
    progress            fixed bin,  /* =1: bad help_args version            */
                        /* =2: no pathnames given.          */
                        /* =3: evaluating pathnames.            */
                        /* =4: finding help segs.           */
                        /* =5: -section/-search & printing help segs.   */
    Acode           fixed bin(35),  /* Return code.             */
    APPDinfo_seg        ptr;        /* Ptr to output structures returned by     */
                        /* help_$check_info_segs            */

     dcl    Loutput_line        fixed bin,  /* Length of terminal user's output line.   */
    Ninfos_printed      fixed bin,  /* Number of infos for which something has printed*/
    Nlast_info_cross_ref    fixed bin,  /* Last info with Scross_ref on.        */
    Nlast_info_no_brief_data    fixed bin,  /* Last info not containing Syntax section, */
                        /* which get_brief_data encountered.        */
    PI_LABEL            label variable,
    PDeps           ptr,
    PDinfo          ptr,
    Pinit_assoc_mem     ptr,
    Pnext_free_space        ptr,        /* ptr to next free word location in temp   */
                        /*   seg containing help_args.      */
    Pquery_answers      ptr,        /* ptr to formatted list of help responses. */
    Ptemp           ptr,
    Sprint_inhibit      bit(1) aligned, /* on if printing stopped by program_interrupt. */
    cleanup         condition,
    code            fixed bin(35),
    fcn         fixed bin,  /* Function to be performed by this invocation. */
       (HELP            init(0),        /*   help_              */
        CIS         init(1))        /*   check_info_segs            */
                     fixed bin int static options(constant),
         (i, j)         fixed bin,
    offset          fixed bin(35),
    program_interrupt       condition;
\014
%include help_cis_args_;
\014
     dcl    1 Dinfo         aligned based(PDinfo),
      2 N           fixed bin,
      2 seg (0 refer (Dinfo.N)) like Dinfo_seg; /* Information about each log. info to be printed.*/

     dcl    1 init_assoc_mem        aligned based(Pinit_assoc_mem),
                        /* Associative memory in which initiated segments   */
      2 N           fixed bin,  /* are stored.              */
      2 seg (50),               /* Allow up to 50 initiated segments at once.   */
        3 dir           char(168) unal,
        3 ent           char(32) unal,
        3 uid           bit(36),
        3 pad           fixed bin,
        3 P         ptr;

     dcl    1 LIST          aligned based,  /* structure used to format list of things to be    */
      2 header,             /* output in columns.           */
        3 N         fixed bin,  /*   number of list elements.           */
        3 Nreal     fixed bin,  /*   number of filled list elements.        */
        3 Npghs     fixed bin,  /*   number of filled paragraphs of formatted out.*/
        3 Nrows     fixed bin,  /*   number of rows in formatted output.    */
        3 Ncols     fixed bin,  /*   number of columns in formatted output. */
        3 ML (6)        fixed bin,  /*   length of longest element in each column.  */
        3 title     char(80) varying,   /*   title of output list.          */
        3 Iunit     fixed bin,  /*   unit no of pgh containing list elements.   */
      2 group (0 refer (LIST.N)),
        3 arg           char(88) varying,   /*   the argument.              */
        3 Snot_found        fixed bin;  /*   = 1 if no match found for the argument.    */

     dcl    1 query_answers     aligned based(Pquery_answers),
      2 header      like LIST.header,
      2 group (0 refer (query_answers.N))
                like LIST.group;

     dcl    responses (21)      char(36) var int static options(constant) init(
                     " yes, y", /* List of allowed responses to questions asked */
                     " rest {-scn},",
                     "    r {-scn}",/*   by help_.              */
                     " no, n",
                     " quit, q",
                     " top, t",
                     " header, he",
                     " title {-top}",
                     " section {STRs} {-top},",
                     "    scn  {STRs} {-top}",
                     " search  {STRs} {-top},",
                     "    srh  {STRs} {-top}",
                     " skip {-scn} {-seen} {-rest} {-ep},",
                     "    s {-scn} {-seen} {-rest} {-ep}",
                     " brief, bf",
                     " control_arg STRs, ca STRs",
                     " entry_point {EP_NAME},",
                     "    ep {EP_NAME}",
                     " ?",
                     " .",
                     " ..");

     dcl    bit36           bit(36) aligned based,
    bit72           bit(72) aligned based;

     dcl (addr, addrel, binary, currentsize, dim, dimension, divide, empty, hbound, index, lbound, length,
    ltrim, max, maxlength, min, mod, null, ptr, rel, reverse, rtrim, search, string, substr, sum,
    translate, verify)
                builtin;


     dcl
    com_err_            entry options(variable),
    command_query_      entry options(variable),
    convert_date_to_binary_     entry (char(*), fixed bin(71), fixed bin(35)),
    get_line_length_$switch entry (ptr, fixed bin(35)) returns(fixed bin),
    get_temp_segment_       entry (char(*), ptr, fixed bin(35)),
    hcs_$get_uid_seg        entry (ptr, bit(36) aligned, fixed bin(35)),
    hcs_$initiate       entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr,
                     fixed bin(35)),
    hcs_$terminate_noname   entry (ptr, fixed bin(35)),
    hcs_$truncate_seg       entry (ptr, fixed bin, fixed bin(35)),
         (ioa_, ioa_$nnl, ioa_$rsnnl)   entry options(variable),
    iox_$control        entry (ptr, char(*), ptr, fixed bin(35)),
    iox_$put_chars      entry (ptr, ptr, fixed bin(21), fixed bin(35)),
    ipc_$block      entry (ptr, ptr, fixed bin(35)),
    match_star_name_        entry (char(*), char(*), fixed bin(35)),
    release_temp_segment_   entry (char(*), ptr, fixed bin(35)),
    search_paths_$get       entry (char(*), bit(36), char(*), ptr, ptr,
                       fixed bin, ptr, fixed bin(35)),
         (sort_items_$bit,
    sort_items_$char)       entry (ptr, fixed bin);

     dcl
    BS_underscore       char(2) aligned int static options(constant) init ("_"),
    FALSE           bit(1) aligned int static options(constant) init ("0"b),
    HELP_LINE_SIZE      fixed bin int static options(constant) init (79),
    HT_SP           char(2) init("   ") int static options(constant),
                        /* Horizontal-tab followed by space.        */
    MAX_HELP_LINE_SIZE      fixed bin int static options(constant) init(136),
    NL          char(1) int static options(constant) init ("
"),
    OLD_HELP_PGH_CHAR       char(1) aligned int static options(constant) init (""),   /* \006  */
    SPACES          char(100) aligned int static options(constant) init((100)" "),
    TRUE            bit(1) int static options(constant) init("1"b),
         (error_table_$badsyntax,
    error_table_$inconsistent,
    error_table_$incorrect_access,
    error_table_$moderr,
    error_table_$no_s_permission,
    error_table_$noarg,
    error_table_$noentry,
    error_table_$nomatch,
    error_table_$unimplemented_version,
    error_table_$zero_length_seg)
                fixed bin(35) ext static,
    iox_$user_output        ptr ext static,
    underscore_BS       char(2) aligned int static options(constant) init ("_");
\014
%include help_args_;

\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */



    fcn = HELP;             /* Perform a help function.         */
    go to COMMON;


check_info_segs: entry (procedure_name, Phelp_args, suffix, progress, Acode, APPDinfo_seg);

    fcn = CIS;              /* Perform a check_info_segs function.      */

COMMON: progress = 1;
    if help_args.version ^= Vhelp_args_1 then do;   /* Validate structure version.      */
         Acode = error_table_$unimplemented_version;
         return;
         end;
    progress = 2;
    if help_args.Npaths ^> 0 then do;        /* Make sure info file names were given.    */
         Acode = error_table_$noarg;
         return;
         end;
    Acode = 0;
    progress = 3;
    do i = 1 to help_args.Npaths;           /* validate input paths.            */
         call evaluate_path (help_args.path(i), suffix);
         if Acode = 0 then
        Acode = help_args.path.code(i);
         end;
    if Acode ^= 0 then return;

    progress = 4;
    Loutput_line = min (MAX_HELP_LINE_SIZE, get_line_length_$switch (iox_$user_output, code));
    if code ^= 0 then  Loutput_line = HELP_LINE_SIZE; /* Get user's terminal line size.     */
    Pquery_answers = set_space_used (Phelp_args, currentsize(help_args));
                        /* Get space for format list of help responses. */
    query_answers.N = 2 * hbound(responses,1);  /* Copy allowed responses into the list.    */
    query_answers.Nreal = query_answers.N;
    query_answers.Nrows = 0;            /* This indicates that list isn't formatted yet.    */
    query_answers.title = "List of Responses";
    do i = lbound(responses,1) to hbound(responses,1);
         query_answers.group(i).arg = responses(i);
         end;
    do i = i to query_answers.N;            /* Struc must be twice size of response array   */
         query_answers.group(i).arg = "";       /*   to allow for extension during formatting.  */
         end;                   /*   Set added elements to null strings.    */

    Pinit_assoc_mem, Pnext_free_space = set_space_used (Pquery_answers, currentsize(query_answers));
                        /* Get space in temp seg for associative memory */
                        /* used to reduce calls to hcs_$initiate.   */
    init_assoc_mem.N = 0;
    on cleanup call janitor();          /* Establish cleanup on unit.           */
\014
    PDinfo, Pnext_free_space = set_space_used (Pnext_free_space, currentsize(init_assoc_mem));
    Dinfo.N = 0;                /* Obtain space for list of info segs to be read.   */
    do i = 1 to help_args.Npaths;           /* Convert input paths to list of info segs.    */
         if help_args.path(i).S.less_greater then
        call get_info_seg_list (procedure_name, suffix, fcn,
                    help_args.path(i).dir(*), help_args.path(i), PDinfo);
         else call get_info_seg_list (procedure_name, suffix, fcn,
                    help_args.search_dirs(*), help_args.path(i), PDinfo);
         end;
    if Dinfo.N <= 0 then do;         /* Stop if no matching segs found.      */
         Acode = error_table_$nomatch;      /*   get_info_seg_list has already complained.  */
         call janitor();
         return;
         end;
\014
    progress = 5;               /* Infos selected by starname.  Any other errors    */
                        /* reported via Acode describe info selection by    */
                        /* -search and -seciton criteria.       */
    PPDinfo_seg, Pnext_free_space = set_space_used (Pnext_free_space, currentsize(Dinfo));
    PDinfo_seg.version = VPDinfo_seg_1;
    PDinfo_seg.N = Dinfo.N;
    do i = 1 to Dinfo.N;            /* Sort listed infos thrice:            */
         PDinfo_seg.P(i) = addr(Dinfo.seg(i).uid);  /*   1st:  sort on  Dinfo.seg.uid/.I combination    */
         end;                   /*   to eliminate duplicate infos.  */
                        /*   2nd:  sort on Dinfo.seg.ent to identify    */
                        /*   versions of info seg in different dirs.*/
    if Dinfo.N > 1 then do;          /*   3rd:  sort on Dinfo.seg.Scross_ref/dir/.ent    */
         call sort_items_$bit (addr(PDinfo_seg.N),72);/*     combination to alphabetize output. */
         offset = binary (rel (addr (Dinfo.seg(1).ent))) -
            binary (rel (addr (Dinfo.seg(1).uid)));
                        /* Compute negative offset to adjust ptrs to    */
                        /* Dinfo.seg.uid to point back to Dinfo.seg.ent.    */
         do i = 1 to Dinfo.N while (PDinfo_seg.P(i)->bit72 = "0"b);
        PDinfo_seg.P(i) = addrel(PDinfo_seg.P(i), offset);
        end;                /* Allow duplicate .uid/.I combos for infos */
                        /* in which errors were encountered.  These errors*/
                        /* must be reported.  get_info_seg_list has set */
                        /* .uid/.I combo to "0"b in these cases.    */
         j = i - 1;
         if i > Dinfo.N-1 then           /* if all info segs are in error, skip the  */
        go to SKIP_ELIMINATION;             /* elimination of duplicates.           */
         go to CHECK(fcn);

CHECK(0):        do i = i to Dinfo.N - 1;           /* Eliminate duplicate .uid/.I combos.      */
        if PDinfo_seg.P(i)->bit72 ^= PDinfo_seg.P(i+1)->bit72 then do;
             j = j + 1;         /*   (Only retain unique .uid/.I combos.)   */
             PDinfo_seg.P(j) = addrel(PDinfo_seg.P(i), offset);
             end;
        else PDinfo_seg.P(i+1) = PDinfo_seg.P(i);
                        /*   (Retain info found earliest in search rules).*/
        end;
         go to END_CHECK;

CHECK(1):        do i = i to Dinfo.N - 1;           /* Eliminate duplicate .uid combos.     */
        if PDinfo_seg.P(i)->bit36 ^= PDinfo_seg.P(i+1)->bit36 then do;
             j = j + 1;         /*   (Only retain unique .uid combos.)      */
             PDinfo_seg.P(j) = addrel(PDinfo_seg.P(i), offset);
             end;
        else PDinfo_seg.P(i+1) = PDinfo_seg.P(i);
                        /*   (Retain info found earliest in search rules).*/
        end;

END_CHECK:     j = j + 1;               /*   (Always retain the last entry in the list.)    */
         PDinfo_seg.P(j) = addrel(PDinfo_seg.P(i), offset);
         PDinfo_seg.N = j;
         end;
    else PDinfo_seg.P(1) = addr(Dinfo.seg(1).ent);
\014
SKIP_ELIMINATION:
    if PDinfo_seg.N > 1 then do;         /* Sort alphabetically by ent to identify info  */
         call sort_items_$char(addr(PDinfo_seg.N),32);/* segments appearing in more than one search dir.*/
         offset = binary (rel (addr (Dinfo.seg(1).Scross_ref))) -
            binary (rel (addr (Dinfo.seg(1).ent)));
                        /* Compute negative offset to adjust ptrs from  */
                        /* Dinfo.seg.ent to point to Dinfo.seg.Scross_ref.*/
         PDinfo_seg.P(1) = addrel(PDinfo_seg.P(1), offset);
         do i = 1 to Dinfo.N - 1;           /* Check for entry of same name in different dirs.*/
        PDinfo_seg.P(i+1) = addrel(PDinfo_seg.P(i+1), offset);
        if  PDinfo_seg.P(i) -> Dinfo_seg.ent  = PDinfo_seg.P(i+1) -> Dinfo_seg.ent &
            PDinfo_seg.P(i) -> Dinfo_seg.uid ^= PDinfo_seg.P(i+1) -> Dinfo_seg.uid &
            PDinfo_seg.P(i) -> Dinfo_seg.uid ^= "0"b  &
                      "0"b ^= PDinfo_seg.P(i+1) -> Dinfo_seg.uid  then do;
             if  binary(rel(PDinfo_seg.P(i)),18) < binary(rel(PDinfo_seg.P(i+1)),18)  then do;
            Ptemp = PDinfo_seg.P(i);    /* Mark all but entry found earliest in search  */
            PDinfo_seg.P(i) = PDinfo_seg.P(i+1);
            PDinfo_seg.P(i+1) = Ptemp;  /* rules with a cross reference flag.       */
            end;
             PDinfo_seg.P(i) -> Dinfo_seg.Scross_ref = TRUE;
             end;
        end;
         end;
    else PDinfo_seg.P(1) = addr(Dinfo.seg(1).Scross_ref);
    if PDinfo_seg.N > 1 then         /* Sort alphabetically by Scross_ref/dir/ent combo*/
         call sort_items_$char (addr(PDinfo_seg.N), 201  /* = 1 + 168 + 32 */);
    if fcn = CIS then do;
         call term_assoc_mem();
         APPDinfo_seg = PPDinfo_seg;
         return;
         end;


    PDeps, Pnext_free_space = set_space_used (Pnext_free_space, currentsize(PDinfo_seg));
                        /* Get space for entry point info descriptors.  */
    Nlast_info_no_brief_data = -1;      /* No info processed yet.           */
    Nlast_info_cross_ref = -1;
    PI_LABEL = PROCESS;             /* Establish pi handler.            */
    on program_interrupt begin;
         Sprint_inhibit = TRUE;
         go to PI_LABEL;
         end;
PROCESS:    Ninfos_printed = 0;
    do i = 1 to PDinfo_seg.N;           /* Process each listed info in alphabetical order.*/
         call process_info_seg (procedure_name, suffix, i, Ninfos_printed, PDinfo_seg.N, 
        Nlast_info_no_brief_data, Nlast_info_cross_ref, PDinfo_seg.P(i) -> Dinfo_seg, PDeps);
NEXT_INFO:     end;
    if Ninfos_printed = 0 then          /* -section and -search didn't find any match.  */
         Acode = error_table_$nomatch;
QUIT:   call janitor();             /* Cleanup and return.  Simple huh!     */
    return;                 /* But wait 'til you see what's below.      */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


evaluate_path: procedure (info_path, suffix);

     dcl    1 info_path         aligned like help_args.path,
    suffix          char(*);

     dcl    i           fixed bin;

     dcl    check_star_name_$entry entry (char(*), fixed bin(35)),
    expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));

    info_path.dir(1) = "";          /* Initialize to unset so caller can depend on  */
    info_path.ent = "";             /* these values.                */
    info_path.ep = "";
    info_path.S.less_greater = (search (info_path.value, "<>") > 0);
                        /* see if user gave more than just an entryname.    */
    i = index(reverse(info_path.value), "$");   /* see if user gave a subr entry point name.    */
    if info_path.S.less_greater then        /*   Must allow $ in entry names forming dir    */
                        /*   part of pathname.          */
         if search(reverse(info_path.value), "<>") < i then
        i = 0;
    if i > 0 then                /* save entry point name given by user in his   */
         info_path.ep = substr (info_path.value, length(info_path.value)-i+2);
    else info_path.ep = "";         /*   pathname argument.         */
    call expand_pathname_$add_suffix (substr (info_path.value, 1, length(info_path.value)-i), suffix,
         info_path.dir(1), info_path.ent, info_path.code);
    if info_path.code ^= 0 then         /* separate pathname into dir/ent parts, add info   */
         return;                /*   suffix.                */
    if info_path.S.pn_ctl_arg then      /* if -pn given, assume relative pathname follows   */
         info_path.S.less_greater = TRUE;       /*   (Note we've already expanded path on this  */
                        /*    assumption.)              */
    if info_path.info_name = "" then do;
         info_path.S.separate_info_name = FALSE;    /* info_name usually = entryname w/o suffix.    */
         if suffix = "" then
        info_path.info_name = info_path.ent;
         else info_path.info_name =
             substr(info_path.ent, 1, 32 - length(suffix) -
             index(reverse(info_path.ent), reverse(suffix)||"."));
         end;
    else info_path.S.separate_info_name = TRUE;
    call check_star_name_$entry (info_path.ent, info_path.code);
    if info_path.code = 0 then do;      /* if no starname given, -ep ctl arg allowed.   */
         info_path.S.starname_ent = FALSE;
         if help_args.Sctl.ep &
            info_path.ep = "" then      /* Default ep name = entryname w/o suffix.  */
        if suffix = "" then
             info_path.ep = info_path.ent;
        else info_path.ep =
            substr(info_path.ent, 1, 32 - length(suffix) -
            index(reverse(info_path.ent), reverse(suffix)||"."));
         end;
    else if info_path.code = 1 |            /* forbid -ep if starname was given.        */
            info_path.code = 2 then do;
         info_path.code = 0;
         info_path.S.starname_ent = TRUE;
         if help_args.Sctl.ep | (info_path.ep ^= "") then
        info_path.code = error_table_$inconsistent;
         end;

    if info_path.code ^= 0 then return;
    if info_path.S.separate_info_name then do;  /* Check star-ness of user-supplied info_name.  */
         if info_path.S.info_name_not_starname then
        info_path.S.starname_info_name = FALSE;
         else do;
        call check_star_name_$entry (info_path.info_name, info_path.code);
        if info_path.code = 1 |
           info_path.code = 2 then  do;
             info_path.code = 0;
             info_path.S.starname_info_name = TRUE;
             end;
        else info_path.S.starname_info_name = FALSE;
        end;
         end;
    else info_path.S.starname_info_name = info_path.S.starname_ent;

    end evaluate_path;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_info_seg_list: procedure (procedure_name, suffix, fcn,
            dirs, info_path, PDinfo_) options (non_quick);
                        /* non_quick so that the large area won't stay around   */
                        /*   all the while help active and take up stack frame  */
                        /*   space.                 */

     dcl    procedure_name      char(*),
    suffix          char(*),
    fcn         fixed bin,
    dirs (*)            char(168) unaligned,
    1 info_path     aligned like help_args.path,
    PDinfo_         ptr;

     dcl    I           fixed bin,
    Lline           fixed bin,
    Lseg            fixed bin(21),
    Nbranches           fixed bin,
    Nentries            fixed bin,
    Nlinks          fixed bin,
    Nentry_names        fixed bin,
    Nstart          fixed bin,
    Pentry          ptr,
    Pentry_name     ptr,
    Pseg            ptr,
    Ptemp           ptr,
    area            area (25000) init(empty()),
    code            fixed bin(35),
         (i, j, k)          fixed bin,
    l           fixed bin(21),
    line            char(Lline) based(Pseg),
    linfo_name      char(32),       /* info name without the suffix.        */
    sinfo_name      char(32),       /* info name with the suffix.           */
    saved_date      fixed bin(71);

     dcl    1 Dinfo_            aligned based(PDinfo_),
      2 N           fixed bin,
      2 seg (0 refer (Dinfo_.N))    like Dinfo_seg;

     dcl    1 branch            aligned,        /* returned by hcs_$status_long     */
     (2 type            bit(2),
      2 pad1            bit(34),
      2 pad2 (2)        fixed bin(35),
      2 mode            bit(5),
      2 pad3            bit(31),
      2 pad4            fixed bin(35),
      2 dtem            bit(36),
      2 pad5            fixed bin(35),
      2 pad6            bit(12),
      2 bit_count       bit(24),
      2 pad7 (2)        fixed bin(35)) unal;
\014
     dcl    1 entry (Nentries)      aligned based (Pentry),
     (2 type            bit(2),     /* returned by hcs_$star_dir_list_      */
      2 nnames      fixed bin(15),
      2 nindex      fixed bin(17),
      2 dtem            bit(36),
      2 pad1            bit(36),
      2 mode            bit(5),
      2 raw_mode        bit(5),
      2 master_dir      bit(1),
      2 bit_count       fixed bin(24)) unal,
    entry_name (Nentry_names)   char(32) aligned based (Pentry_name);

     dcl    seg         char(Lseg) based(Pseg),
                        /* The info segment.  Pseg must be declared in  */
                        /* the external procedure so its on unit    */
                        /* (janitor) can terminate the segment.     */
    seg_char (Lseg)     char(1) based(Pseg);

     dcl    hcs_$star_dir_list_     entry (char(*), char(*), fixed bin(3), ptr,
                fixed bin, fixed bin, ptr, ptr, fixed bin(35)),
    hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
     dcl (DIRECTORY         init ("10"b),
    LINK            init ("00"b),
    SEGMENT         init ("01"b)) bit(2) aligned int static options(constant);



    Nstart = Dinfo_.N;              /* Remember count of info segs found before we  */
                        /*   start.  Then we'll know if we find any.    */
    do i = lbound(dirs,1) to hbound(dirs,1);    /* Apply info path to each dir to be searched.  */
         call hcs_$star_dir_list_ (dirs(i), info_path.ent, 3, addr(area), Nbranches, Nlinks, Pentry, Pentry_name,
        code);
         if code = 0 then do;
        Nentries = Nbranches + Nlinks;
        Nentry_names = entry(Nentries).nnames + entry(Nentries).nindex - 1;
        do j = 1 to Nentries;       /* process entries found in this directory. */
             k, Dinfo_.N = Dinfo_.N + 1;
             Dinfo_.seg(k).Scross_ref = FALSE;
             Dinfo_.seg(k).dir      = dirs(i);
             Dinfo_.seg(k).ent      = entry_name(entry(j).nindex);
             Dinfo_.seg(k).info_name    = "";
             Dinfo_.seg(k).ep       = info_path.ep;
             Dinfo_.seg(k).segment_type = entry(j).type;

                        /* Process each entry according to its type.    */
             if entry(j).type = SEGMENT then do;
            Dinfo_.seg(k).L    = divide(entry(j).bit_count, 9, 24, 0);
            Dinfo_.seg(k).date = numeric_date (entry(j).dtem);
            Dinfo_.seg(k).mode = substr(entry(j).mode,2,3);
            Dinfo_.seg(k).code = 0; /* extract "rew" mode bits from "trewa".    */
            if  Dinfo_.seg(k).L = 0  then
                 Dinfo_.seg(k).code = error_table_$zero_length_seg;
            else if  entry(j).bit_count - 9*Dinfo_.seg(k).L > 0  then
                 Dinfo_.seg(k).code = error_table_$badsyntax;
            end;
             else if entry(j).type = LINK then do;
                        /* Links must be chased, and target examined.   */
            call hcs_$status_long (Dinfo_.seg(k).dir, Dinfo_.seg(k).ent,
                 1, addr(branch), null(), code);
            if  (code = 0)  |  (code = error_table_$no_s_permission)  then do;
                 if branch.type = SEGMENT then do;
                Dinfo_.seg(k).L    = divide( binary(branch.bit_count, 24), 9, 24, 0);
                Dinfo_.seg(k).date = numeric_date (branch.dtem);
                Dinfo_.seg(k).mode = substr(branch.mode,2,3);
                Dinfo_.seg(k).code = 0;
                if  Dinfo_.seg(k).L = 0  then
                     Dinfo_.seg(k).code = error_table_$zero_length_seg;
                else if  binary(branch.bit_count, 24) - 9*Dinfo_.seg(k).L > 0  then
                     Dinfo_.seg(k).code = error_table_$badsyntax;
                end;
                 else if branch.type = LINK then do;
                Dinfo_.seg(k).L    = 0;
                Dinfo_.seg(k).date = 0;
                Dinfo_.seg(k).mode = "0"b;
                Dinfo_.seg(k).code = error_table_$noentry;
                end;
                 else do;       /* Skip matching directories.           */
                Dinfo_.N = Dinfo_.N - 1;
                go to SKIP_ENTRY;   /*   Forget everything we've done for this entry.   */
                end;
                 end;
            else do;            /* Don't have access to the link target.    */
                 Dinfo_.seg(k).L    = 0;
                 Dinfo_.seg(k).date = 0;
                 Dinfo_.seg(k).mode = "0"b;
                 Dinfo_.seg(k).code = code;
                 end;
            end;
             else do;           /* Skip matching directories.           */
            Dinfo_.N = Dinfo_.N - 1;
            go to SKIP_ENTRY;
            end;
             if  Dinfo_.seg(k).code = 0  then
            if  (Dinfo_.seg(k).mode & "100"b)  then
                 if  help_args.min_date_time ^<  Dinfo_.seg(k).date  then
                Dinfo_.N = Dinfo_.N - 1;
                 else;
            else Dinfo_.seg(k).code = error_table_$moderr;
                        /* report error if user can't access info seg.  */
SKIP_ENTRY:      end;

        free entry in (area),       /* free found entry structures.     */
             entry_name in (area);
        end;


         else if code = error_table_$incorrect_access & ^info_path.S.starname_ent then do;
                        /* If user does not have "s" permission to dir, */
                        /* look for a specific help seg.        */
        call hcs_$status_long (dirs(i), info_path.ent, 1, addr(branch), null(), code);
        if  (code = error_table_$no_s_permission)  |  (code = 0)  then do;
             if branch.type ^= DIRECTORY then do;
            k, Dinfo_.N = Dinfo_.N + 1;
            Dinfo_.seg(k).Scross_ref = FALSE;
            Dinfo_.seg(k).dir  = dirs(i);
            Dinfo_.seg(k).ent  = info_path.ent;
            Dinfo_.seg(k).info_name = "";
            Dinfo_.seg(k).ep   = info_path.ep;
            Dinfo_.seg(k).segment_type = branch.type;
            if branch.type = SEGMENT then do;
                 Dinfo_.seg(k).L    = divide( binary(branch.bit_count, 24), 9, 24, 0);
                 Dinfo_.seg(k).date = numeric_date (branch.dtem);
                 Dinfo_.seg(k).mode = substr(branch.mode,2,3);
                 if Dinfo_.seg(k).mode & "100"b then
                Dinfo_.seg(k).code = 0;
                 else Dinfo_.seg(k).code = error_table_$moderr;
                 if  Dinfo_.seg(k).L = 0  then
                Dinfo_.seg(k).code = error_table_$zero_length_seg;
                 else if  binary(branch.bit_count, 24) - 9*Dinfo_.seg(k).L > 0  then
                Dinfo_.seg(k).code = error_table_$badsyntax;
                 else if  code = 0  then
                if  help_args.min_date_time ^<  Dinfo_.seg(k).date  then
                     Dinfo_.N = Dinfo_.N - 1;
                 end;
            else do;            /* Give error for link target being a link. */
                 Dinfo_.seg(k).L    = 0;
                 Dinfo_.seg(k).date = 0;
                 Dinfo_.seg(k).mode = "0"b;
                 Dinfo_.seg(k).code = error_table_$noentry;
                 end;
            end;
             end;
        else if code = error_table_$noentry then;
        else go to DIR_ERROR;
        end;
         else if code = error_table_$nomatch then;
         else do;               /* Fatal error looking in this dir.     */
DIR_ERROR:  call com_err_ (code, procedure_name,
             "^/While looking for info segments in ^a.", dirs(i));
        if dim(dirs,1) = 1 then return; /* Avoid getting nomatch error in addition to   */
        end;                /* this one when only 1 dir to look into.   */
         end;


    if  fcn = CIS  then do;
         do i = Nstart+1 to Dinfo_.N;
        if  Dinfo_.seg(i).code ^= 0  then do;
             Dinfo_.seg(i).uid = "0"b;
             Dinfo_.seg(i).I   = 0;
             end;
        end;
         return;
         end;
    else if  Dinfo_.N = Nstart  then do;
         if info_path.S.starname_ent then
        code = error_table_$nomatch;
         else code = error_table_$noentry;
         call com_err_ (code, procedure_name, 
        "^/Looking for:  ^[-pn ^]^a", info_path.S.pn_ctl_arg, info_path.value);
         end;
    else do i = Nstart+1 to Dinfo_.N;       /* Look for :Info: info dividers.       */
         if Dinfo_.seg(i).code = 0 then do;
        Dinfo_.seg(i).uid = "0"b;       /* We don't know seg's uid yet.     */
        call initiate (Dinfo_.seg(i).dir, Dinfo_.seg(i).ent, Dinfo_.seg(i).uid, Pseg, code);
        if Pseg ^= null then do;
             Lseg = Dinfo_.seg(i).L;
             Dinfo_.seg(i).I = 1;       /* Fill in substring index of 1st       */
                        /* char of physical info seg.           */
             I = verify(seg, "   
");
             if I > 1 then do;       /* Strip HT SP NL from start of info seg.   */
            Pseg = addr(seg_char(I));
            Lseg = Lseg - (I-1);
            end;
             if Lseg > 8 then        /* See if info seg begins with :Info:       */
                        /*   (8 = length(":Info:C:"), C is any char.    */
            if substr(seg,1,6) = ":Info:" then do;
                 Pseg = addr(seg_char(7));
                 Lseg = Lseg - 6;
                 k = i;
                 Dinfo_.seg(k).info_name = info_path.info_name;
                        /* save info_name used to find infos for use in */
                        /* error messages  (without suffix).        */
                 saved_date = Dinfo_.seg(k).date;
                        /* save date assoc with phys info seg in case   */
                        /* some log. infos don't have date in their header*/
                 end;
            else Lseg, k = 0;
             else Lseg, k = 0;
             do while (Lseg > 0);        /* It does contain :Info:.  Look for info(s)    */
            Lline = index(seg, NL); /* which match user-supplied entryname.     */
            if Lline = 0 then  Lline = Lseg;
            linfo_name = find_info_name(line, I);
            do while (I > 0);
                 if info_path.S.starname_info_name then do;
                call match_star_name_ (linfo_name, info_path.info_name, code);
                if code ^= 0 then go to NO_MATCH;
                end;
                 else if linfo_name ^= info_path.info_name then
                go to NO_MATCH;

                 if ^info_path.S.separate_info_name then do;
                        /* POTENTIAL BUG:  Use of assoc. memory for     */
                        /* initiated segs may subvert test to see if    */
                        /* info_name really a name on phys. info seg.   */
                        /* Subsequent attempt to reinitiate may succeed     */
                        /* by uid found in assoc mem, rather than by name   */
                        /* being found on phys. info seg.       */
                if suffix ^= "" then
                     sinfo_name = rtrim(linfo_name) || "." || suffix;
                else sinfo_name = linfo_name;

                        /* Test now to see if log info_name is on seg.  */
                if info_path.S.starname_ent then do;
                     call hcs_$initiate (Dinfo_.seg(k).dir, sinfo_name, "", 0, 0, 
                             Ptemp, code);
                     if Ptemp = null then  go to NO_MATCH;
                     end;
                Dinfo_.seg(k).ent = sinfo_name;
                end;
                        /* This info matches.  Include it in output list.   */
                 j = Lline - index(reverse(line),":") + 2;
                 Dinfo_.seg(k).I = rel_char(addr(seg_char(j))) + 1;
                        /* get index of first char of this info.    */
                        /* 1 is added to the char offset returned by    */
                        /* rel_char to get a char index.        */
                 l = index(seg,"


:Info:");                       /* get info length by finding next info.    */
                 if l > 0 then
                Dinfo_.seg(k).L = l - (j-1);
                 else Dinfo_.seg(k).L = Lseg - (j-1);
                 Pseg = addr(seg_char(j));
                 Lseg = Lseg - (j-1);
                 Lline = Lline - (j-1);
                 j = verify(seg, "   
");
                 if j > 1 then do;   /* Remove leading HT SP NL from log info.   */
                Pseg = addr(seg_char(j));
                Lseg = Lseg - (j-1);
                Lline = index(seg, NL);
                if Lline = 0 then Lline = Lseg;
                end;
                 if Lseg >= Lline+1 then /* Store date assoc with log info.      */
                if seg_char(Lline+1) = NL then do;
                            /* Date comes from 1st field of heading line of */
                        /* log info, which must be followed by blank line.*/
                     Lline = Lline - 1;
                     j = search (line, "     ");
                     if j = 0 then
                    j = Lline;
                     else do;
                    call convert_date_to_binary_ (substr(line,1,j), Dinfo_.seg(k).date, code);
                    if code ^= 0 then
                         Dinfo_.seg(k).date = saved_date;
                    end;
                     end;
                else Dinfo_.seg(k).date = saved_date;
                 else Dinfo_.seg(k).date = saved_date;
                 I = 0;     /* Stop processing this :Info: line (this info).    */
                 if  ^(info_path.S.starname_info_name  |  info_path.S.separate_info_name)  then
                Lseg = 0;       /* If not a starname or separate info_name,     */
                        /* we've found one & only matching log. info    */
                 if help_args.min_date_time ^< Dinfo_.seg(k).date then
                go to MATCH;    /* Info modified before min date; skip it   */
                 Dinfo_.seg(k).info_name = linfo_name;
                        /* Save info_name for use in headings.      */
                 k, Dinfo_.N = Dinfo_.N + 1;
                 Dinfo_.seg(k) = Dinfo_.seg(i);
                 go to MATCH;

NO_MATCH:                Pseg = addr(seg_char(I+1));
                 Lseg = Lseg - I;   /* Look for another name on this info, since    */
                 Lline = Lline - I; /* previous names on it don't match user wants. */
                 linfo_name = find_info_name (line, I);
MATCH:               end;

            I = index(seg, "


:Info:");
            if I = 0 then Lseg = 0;
            else do;
                 Pseg = addr(seg_char(I+9));
                 Lseg = Lseg - (I+8);
                 end;
            end;
             if k = 0 then;         /* No :Info: in phys info seg.      */
             else if k = i then     /* No matching info in phys info seg.       */
            if info_path.S.starname_info_name then
                 Dinfo_.seg(i).code = error_table_$nomatch;
            else Dinfo_.seg(i).code = error_table_$noentry;
             else Dinfo_.N = Dinfo_.N - 1;  /* Matching info found.  We always get one more */
                        /* Dinfo_.seg than we can use.      */
             end;
        else Dinfo_.seg(i).code = code; /* Failed to initiate physical info seg.    */
        end;
         if Dinfo_.seg(i).code ^= 0 then do;
        Dinfo_.seg(i).uid = "0"b;       /* If error occurred during processing, mark    */
        Dinfo_.seg(i).I   = 0;      /* info to cause error message to be printed.   */
        end;
         end;
\014
find_info_name: proc (Aline, Iline) returns(char(32));
          
     dcl  Aline         char(*),        /* unprocessed part of :Info: line (incl NL).   */
          Iline     fixed bin,  /* amount processed while finding this info name. */
    info_name           char(32) varying;   /* the info_name which was found.       */

     dcl (Icolon, Inon_space, Iquote, Iquote_quote)
                    fixed bin,
    Lline           fixed bin,
    Pline           ptr;

     dcl (QUOTE         char(1) init(""""),
    QUOTE_QUOTE     char(2) init("""""")) int static options(constant);

     dcl    line            char(Lline) based(Pline),
    line_char (Lline)       char(1) based(Pline);
          
    Pline = addr(Aline);
    Lline = length(Aline);
    Inon_space = verify (line, HT_SP);      /* Remove leading white space from info name.   */
    if Inon_space > 1 then do;
         Pline = addr(line_char(Inon_space));
         Lline = Lline - (Inon_space-1);
         end;
    else if Inon_space = 0 then do;     /* Remainder of line is empty.      */
ERROR:       Iline = length(Aline);
         return("");
         end;
    
    if line_char(1) = QUOTE then do;        /* Look for quoted info name.           */
         Pline = addr(line_char(length(QUOTE)+1));  /*   Skip the opening quote.            */
         Lline = Lline - length(QUOTE);
         Iquote = index (line, QUOTE);      /*   Search for trailing quote.     */
         if  Iquote=0  |  Iquote+2>Lline  then   /*   Trailing quote is missing.     */
        go to ERROR;
         Iquote_quote = index (line, QUOTE_QUOTE);  /*   Check for doubled quotes.      */
         if Iquote ^= Iquote_quote then     /*   There are none.            */
        info_name = substr (line, 1, Iquote-1);
         else do;               /*   Doubled quotes must be undoubled in info name*/
        info_name = "";
        do while (Iquote = Iquote_quote);
             info_name = info_name || substr (line, 1, Iquote);
             Pline = addr(line_char(Iquote + length(QUOTE_QUOTE)));
             Lline = Lline - (Iquote + length(QUOTE_QUOTE) - 1);
             Iquote = index (line, QUOTE);
             if  Iquote=0  |  Iquote+2>Lline  then go to ERROR;
             Iquote_quote = index (line, QUOTE_QUOTE);
             end;
        info_name = info_name || substr (line, 1, Iquote-1);
        end;
         Pline = addr(line_char(Iquote + length(QUOTE)));
         Lline = Lline - (Iquote + length(QUOTE) - 1);
         Inon_space = verify (line, HT_SP);     /* Remove trailing white space.     */
         if Inon_space > 1 then do;
        Pline = addr(line_char(Inon_space));
        Lline = Lline - (Inon_space-1);
        end;
         else if Inon_space = 0 then go to ERROR;   /* No trailing colon.  Skip last name.      */
         if line_char(1) = ":" then     /* info name found in correct format.       */
        Iline = length(Aline) - (Lline - 1);
         else go to ERROR;          /* No trailing colon.  That's bad;      */
         end;
    else do;                    /* Info name is not quoted.         */
         Icolon = index (line, ":");
         if Icolon = 0 then go to ERROR;        /*   No trailing colon.         */
         info_name = rtrim (substr (line, 1, Icolon-1));
         Iline = length(Aline) - (Lline - Icolon);
         end;
    return (info_name);
    
    end find_info_name;
     









    end get_info_seg_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


initiate: proc (dir, ent, uid, Pseg, code);     /* Provide an associative memory for info segs  */
                        /* to reduce amt. of double initiating each seg.    */

     dcl    dir         char(168) unal,
    ent         char(32) unal,
    uid         bit(36) aligned,
    Pseg            ptr,
    code            fixed bin(35);

     dcl    i           fixed bin;
     dcl    Iempty          fixed bin;

    Iempty = 0;             /* No empty slots in assoc. mem so far.     */
    code = 0;
    Pseg = null;
    do i = 1 to init_assoc_mem.N while (Pseg = null);   /* Look for seg to be initiated in assoc. mem.  */
         if init_assoc_mem.seg(i).uid ^= "0"b then do;/*   Zero uid?  No, we must check the cell.   */
        if uid ^= "0"b then         /*   Can't check if we don't know segs uid. */
             if uid = init_assoc_mem.seg(i).uid then
            Pseg = init_assoc_mem.seg(i).P;
                        /*   Found seg in assoc mem. Got off cheap! */
             else;
        else if  dir = init_assoc_mem.seg(i).dir  &  ent = init_assoc_mem.seg(i).ent  then do;
                        /*   Check segs dir/ent with assoc mem.     */
             uid = init_assoc_mem.seg(i).uid;
             Pseg = init_assoc_mem.seg(i).P;
             end;
        end;
         else if Iempty = 0 then            /* Remember first empty cell in  case seg not   */
        Iempty = i;         /* found in assoc. mem.         */
         end;
    if Pseg ^= null then return;            /* See found in assoc. All done!        */

    call hcs_$initiate (dir, ent, "", 0, 0, Pseg, code);
    if Pseg = null then  return;            /* Have to initiate the segment.        */
    call hcs_$get_uid_seg (Pseg, uid, code);    /* Complain if error.  Otherwise, get seg's uid.    */
    do i = 1 to init_assoc_mem.N while (init_assoc_mem.seg(i).uid ^= uid);
         end;                   /* make sure uid doesn't appear in assoc memory */
    if i <= init_assoc_mem.N then return;        /* under another name.  If so, don't add again. */
    if Iempty = 0 then              /* If no empty cells, must make one.        */
         if init_assoc_mem.N < dimension (init_assoc_mem.seg, 1) then do;
        init_assoc_mem.N = init_assoc_mem.N + 1;
        Iempty = init_assoc_mem.N;      /* Add new cell to the table, if room.      */
        end;
         else do;               /* Must terminate cell member to make room for new*/
        Iempty = init_assoc_mem.N;      /* seg in assoc. mem.           */
        call hcs_$terminate_noname (init_assoc_mem.seg(Iempty).P, code);
        end;
    init_assoc_mem.seg(Iempty).dir = dir;
    init_assoc_mem.seg(Iempty).ent = ent;
    init_assoc_mem.seg(Iempty).uid = uid;
    init_assoc_mem.seg(Iempty).P = Pseg;
    return;
\014
terminate: entry (Pseg, code);

    do i = init_assoc_mem.N to 1 by -1 while (Pseg ^= init_assoc_mem.seg(i).P);
         end;                   /* Start looking at end of assoc. mem. since seg    */
    init_assoc_mem.seg(i).uid = "0"b;       /* is most likely to be there.      */
    if i = init_assoc_mem.N then
         init_assoc_mem.N = init_assoc_mem.N - 1;
    call hcs_$terminate_noname (Pseg, code);

    end initiate;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


janitor: procedure;                 /* terminate known info segs;  truncate temp seg.   */

    call term_assoc_mem();
    call hcs_$truncate_seg (Phelp_args, currentsize(help_args), 0);

    end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


numeric_date: procedure (bit_date) returns (fixed bin(71));
                        /* This procedure converts a file system date   */
                        /* to a numeric clock value.  A file system date    */
                        /* is the high-order 36 bits of a 52 bit clock  */
                        /* value.                   */

     dcl    bit_date        bit(36) unal,
    num_date        fixed bin(71);


    num_date = 0;
    substr(unspec(num_date),21,36) = bit_date;
    return (num_date);

    end numeric_date;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


rel_char: proc (P) returns(fixed bin(21));      /* This procedure converts a pointer value into */
                        /* a character offset from base of segment  */
                        /* pointed to.  We need a PL/I bif to do this.  */
     dcl    P           ptr;

     dcl    I           fixed bin(21),
    P1          ptr,
    i           fixed bin;

     dcl    char_offset (0:3)       char(1) based(P1);

    P1 = ptr(P, rel(P));
    I = 4 * binary(rel(P));
    do i = 0 to 3 while (addr(char_offset(i)) ^= P);
         end;
    I = I + i;
    return(I);

    end rel_char;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


set_space_used: procedure (Pcurrent_space, size_current_space) returns(ptr);
                        /* This procedure returns pointer to next free  */
                        /* word of storage in help_args temp segment.   */
     dcl    Pcurrent_space      ptr,        /* ptr to last space allocated in the seg.  */
    size_current_space      fixed bin(21),  /* amount of space used in structure last alloc.    */
    Pnext_space     ptr;        /* ptr to next free space.          */

    Pnext_space = addrel (Pcurrent_space, size_current_space + mod(size_current_space,2));
    return (Pnext_space);

    end set_space_used;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


term_assoc_mem: procedure;              /* terminate known info segs.           */

    do init_assoc_mem.N = init_assoc_mem.N to 1 by -1;
         if init_assoc_mem.seg(init_assoc_mem.N).uid ^= "0"b then
        call hcs_$terminate_noname (init_assoc_mem.seg(init_assoc_mem.N).P, 0);
         end;

    end term_assoc_mem;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


process_info_seg: procedure (procedure_name, suffix, Iinfo, Ninfos_printed, Ninfos, Nlast_info_no_brief_data,
            Nlast_info_cross_ref, Dinfo_seg_, PDeps);
                        /* This procedure does all the work of printing */
                        /* each info.               */
     dcl    procedure_name      char(*),
    suffix          char(*),
    Iinfo           fixed bin,  /* Number of the info being processed.      */
    Ninfos_printed      fixed bin,  /* Number of infos for which something has printed*/
    Ninfos          fixed bin(24),  /* Number of infos handled during this invocation   */
    Nlast_info_no_brief_data    fixed bin,  /* Last info processed not containing Syntax sect.*/
    Nlast_info_cross_ref    fixed bin,  /* Last info processed with Scross_ref on.  */
                        /* as diagnosed by get_brief_data.      */
    1 Dinfo_seg_        aligned like Dinfo_seg,
    PDeps           ptr;

     dcl    Iep         fixed bin,  /* subscript of current entry point or info */
                        /*   (logical info segment) being processed.    */
    Iunit           fixed bin,  /* subscript of current unit (paragraph).   */
    Iunit_end           fixed bin,
    Iunit_search        fixed bin,  /* searching begins with this unit.     */
    Iunit_syntax (10)       fixed bin,  /* indices of syntax units.         */
    Lcount          fixed bin,
    Linfo_name      fixed bin,
    Loutput         fixed bin,
    Lpath           fixed bin,
    Lpgh            fixed bin,
    Lseg            fixed bin(21),
         (Ncommon_units, Nconsecutive_bad_ops, Nuncommon_units, Nprint_units)
                fixed bin,
         (Nlines, Nlines_titles)    fixed bin,
         (Nlists_of_args, Nlists_of_bf_args)
                fixed bin,
    Nunit_syntax        fixed bin,  /* number of syntax units.          */
         (Plist, Plist_of_titles, Plist_of_cas)
                ptr,
    Pcommon_units       ptr,
    PDlinfo         ptr,
    Plist_base      ptr,
    Plists_of_args (18)     ptr,
    Poutput         ptr,
    Ppgh            ptr,
    Pseg            ptr,
    Sfound          bit(1) aligned,
    Sloop           bit(1) aligned,
         (Snl1,Snl2)        bit(1) aligned, /* Switches used to compute if NL should be output.*/
    ISnl3           fixed bin,
    Ssearch         bit(1) aligned, /* on if -section/-search searching to be done. */
    Sseen           bit(1) aligned, /* on if pgh already seen by user.      */
    answer          char(500) varying,
    ep_name         char(65) varying,
         (i, j)         fixed bin,
    match_result        fixed bin,
      (no_match     init(0),
       match            init(1),
       exact_match      init(2)) fixed bin int static options(constant),
    new_section     char(88) varying,   /* title of new section in which match pgh found    */
    op          fixed bin,
    query           char(200) varying,
    query_type      fixed bin,
      (normal       init(1),
       some_unseen      init(2),
       search_unseen        init(3),
       new_entry        init(4)) fixed bin int static options(constant),
    ref_name            char(32) varying;

     dcl    1 query_info        aligned int static options(constant),
      2 version     fixed bin init(2),
      2 yes_or_no_sw        bit(1) unal init("0"b),
      2 suppress_name_sw    bit(1) unal init("1"b),
      2 CODE            fixed bin(35) init(0),
      2 query_code      fixed bin(35) init(0);

     dcl    1 list_base     aligned based(Plist_base),
                        /* struc locating lists of things to be output. */
      2 N           fixed bin,  /*   number of output lists now allocated.  */
      2 Nmax            fixed bin,  /*   max number of list ptrs allocatable.   */
      2 Ispace_used_set     fixed bin,  /*   index of last list on which space used set.    */
      2 Plists (0 refer(list_base.Nmax))
                ptr;        /*   ptrs to allocated lists.           */

     dcl    1 list          aligned based(Plist),
      2 header      like LIST.header,
      2 group (0 refer (list.N))    like LIST.group;
                        /* struc containing lists of things to be output.   */
     dcl    1 Deps          aligned based (PDeps),
                        /* structure defining all entry points in log info*/
      2 Nlines      fixed bin,  /*   number of lines in log info.       */
      2 N           fixed bin,  /*   total number of entry points in log info.  */
      2 linfo (0: 0 refer (Deps.N)),        /*   description of each entry point.       */
        3 date      fixed bin(71),  /*     binary date assoc with entry point.  */
        3 Nep_names     fixed bin,  /*     number of entry point names.     */
        3 ep_name (20)      char(32) var,   /*     name of the entry point.     */
        3 PDlinfo       ptr,        /*     ptr to paragraph descriptors for this info.*/
        3 Pstart        ptr,        /*     first character of entry point info. */
        3 L         fixed bin,  /*     length (in chars) of entry point info.   */
        3 header        char(88) varying,   /*     its heading line.            */
        3 Nlines        fixed bin,  /*     number of lines in entry point info. */
        3 S,                    /*     switches:                */
         (4 seen_by_user,           /*       this entry point seen by the user. */
          4 old_format)     bit(1) unal,    /*       this entry point contains \006 chars.  */
          4 pad1        bit(34) unal;
\014
     dcl    1 Dlinfo            aligned based (PDlinfo),
                        /* structure defining all paragraphs (units) in */
                        /*   an entry point (misnamed linfo).       */
      2 Nunits      fixed bin,  /*   number of units in this ep.        */
      2 Nsections       fixed bin,  /*   number of units beginning a section.   */
      2 unit (0 refer (Dlinfo.Nunits)),     /*   unit (paragraph) descriptors.      */
        3 Pstart        ptr,        /*     ptr to first char of unit (excl. title). */
        3 title     char(80) varying,   /*     title of the unit.           */
        3 L         fixed bin(21),  /*     length of the unit (in chars).       */
        3 Nlines        fixed bin,  /*     number of lines in the unit.     */
        3 S         aligned,        /*     switches.                */
         (4 scn,                /*       unit begins a new section.     */
          4 seen_by_user,           /*       unit has been seen by user.        */
          4 ep_list,                /*       unit is an entry point list, to be     */
                        /*       generated by help_.            */
          4 arg_list)       bit(1) unal,    /*       unit is Arguments or Control args. */
          4 pad1        bit(14) unal,
        3 Icommon_unit      fixed bin(17) unal; /*     Index of common pgh in common_units. */

     dcl    1 common_units (Ncommon_units) aligned like Dlinfo.unit based(Pcommon_units);

     dcl    1 ca            aligned,        /* current control_arg STRs.            */
      2 header      like LIST.header,
      2 group (100)     like LIST.group,
    1 scn           aligned,        /* current section STRs.            */
      2 header      like LIST.header,
      2 group (100)     like LIST.group,
    1 srh           aligned,        /* current search STRs.         */
      2 header      like LIST.header,
      2 group (100)         like LIST.group;

     dcl    output          char(Loutput) based(Poutput);

     dcl    pgh         char(Lpgh) based(Ppgh);

     dcl    seg_char (Lseg)     char(1)    based(Pseg);

\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* 1) Report any errors encountered while finding physical info segment.        */
    /* 2) Initiate the physical info segment.                   */
    /* 3) Parse up the physical info segment into logical info segments (infos).        */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    PI_LABEL = NEXT_INFO;           /* Before any output starts, a pi skips to next */
                        /* info.                    */
    Sprint_inhibit = FALSE;         /* Printing is not inhibited yet.       */
    ca.N, scn.N, srh.N = 0;         /* No control_arg, search or section args done. */
    ref_name = "";              /* No entry point reference name set yet.   */
    if Dinfo_seg_.code ^= 0 then do;        /* Print any error encountered while finding seg.   */
INIT_ERROR:     call com_err_ (Dinfo_seg_.code, procedure_name,
        "^/While processing ^[link^;segment^;directory^] ^a^[>^]^a^[
Looking for an info matching ^a^].",
        binary (Dinfo_seg_.segment_type, 2) + 1,
        Dinfo_seg_.dir, Dinfo_seg_.dir ^= ">", Dinfo_seg_.ent,
        (Dinfo_seg_.info_name ^= ""), Dinfo_seg_.info_name);
         go to RETURN;
         end;
    call initiate (Dinfo_seg_.dir, Dinfo_seg_.ent, Dinfo_seg_.uid, Pseg, code);
    if Pseg = null then go to INIT_ERROR;       /* Initiate the info segment.           */
    Lseg = Dinfo_seg_.I;            /* Address first char of logical info.      */
    Pseg = addr(seg_char(Dinfo_seg_.I));
    Lseg = Dinfo_seg_.L;            /* Address all/only log info we are printing.   */
    if Lseg = 0 then do;
         code = error_table_$zero_length_seg;
         go to INIT_ERROR;
         end;
    call parse_info_into_entry_points (Pseg, Lseg, PDeps);
                        /* Parse up the log info into entry points. */



    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Various kinds of output (arguments and control arguments, section titles,        */
    /* entry point names, etc) are output in columnar lists.  More than one list        */
    /* may exist at a time.  Initialize array of list pointers to keep track of them.   */
    /* The lists themselves are appended to the end of the segment containing       */
    /* the help_args structure, as are all of the variable size structures used in help_.   */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Pnext_free_space = addrel(PDeps, currentsize(Deps));
                        /* reuse space for lists, etc each time that    */
                        /* process_info_seg is called.      */
    Plist_base = get_list_base (Pnext_free_space, currentsize(Deps), 30);
                        /* get space for gen'l purpose list of lists.   */
\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* 1) Get space for the descriptor of the paragraphs (units) in the common (or only) part   */
    /*     of the logical info.  Parse this common part into pgh units.         */
    /* 2) If there are other entry point descriptions in the log info, then     */
    /*    get space for their paragraph descriptors.                    */
    /*    Parse them up into pghs, and append to their descriptors the common units     */
    /*    (paragraphs included in all entry points) obtained from the common info       */
    /*    descriptors created in step 1 above.                  */
    /*    All entry point parts must be parsed now to get line count of entire info right.  */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Ncommon_units = 0;              /* No common info has been found yet.       */
    PDlinfo = Pnext_free_space;         /* get space for paragraph descriptions of common   */
                        /* or only part of logical info.        */
    call parse_entry_point_into_units (Deps.linfo(0), Pcommon_units, Ncommon_units, PDlinfo);
    Pnext_free_space = set_space_used (PDlinfo, currentsize(Dlinfo));
    if Deps.N > 0 then do;           /* handle log. info w/ several entry point parts.   */
         do Nuncommon_units = 2 to Dlinfo.Nunits
        while (^Dlinfo.unit(Nuncommon_units).S.scn);
                        /* Find paragraphs in common part which are */
                        /* shared by (common to) all entry point parts. */
        end;
         Nuncommon_units = Nuncommon_units - 1;
         Ncommon_units = Dlinfo.Nunits - Nuncommon_units;
         if  (Ncommon_units = 0)  &  (Nuncommon_units = 1)  then
        if length(Dlinfo.unit(1).title) > length("Entry points in") then
        if substr(Dlinfo.unit(1).title,1,length("Entry points in ")) = "Entry points in " then do;
             Nuncommon_units = 0;
             Ncommon_units = 1;
             end;
         if Ncommon_units > 0 then do;
              Pcommon_units = addr (Dlinfo.unit(Nuncommon_units+1));
        end;
         else Pcommon_units = PDlinfo;
         do i = 1 to Ncommon_units;     /* Find section of common part containing   */
                        /*   help-generated list of entry points in info.   */
        if length(common_units(i).title) > 15 then   /* 15 = length("Entry points in "). */
        if substr(common_units(i).title,1,15) = "Entry points in " then do;
             common_units(i).S.ep_list = TRUE;
             j = i;
             do i = i to Ncommon_units; /* Remove any pghs following this special one   */
                        /*   from the common part of the info.      */
            Deps.linfo(0).Nlines = Deps.linfo(0).Nlines -
                 common_units(i).Nlines - 2;
            end;            /* Subtract line count of pghs following the    */
                        /* "Entry points in " section.      */
             Ncommon_units = j;     /* "Entry points in " is last pgh of info.  */
             Dlinfo.Nunits = Nuncommon_units + Ncommon_units;
             end;
        end;
\014
         if Ncommon_units > 0 then
         if common_units(Ncommon_units).S.ep_list then do;
        Plist = get_list (Plist_base);  /* Build entry point list pghs in temp seg. */
        list.title = common_units(Ncommon_units).title;
        if ref_name = "" then
             if suffix = "" then
            ref_name = rtrim(Dinfo_seg_.ent);
             else ref_name = substr(Dinfo_seg_.ent, 1, 32 - length(suffix) -
                      index(reverse(Dinfo_seg_.ent), reverse(suffix) || "."));
        call get_ep_list (ref_name, PDeps, Plist);
        call format_list (Plist, divide(list.N, 5, 17, 0) + 1, 0);
        Ncommon_units = Ncommon_units - 1;  /* Forget about empty entry point list pgh for now*/
        Poutput, Pnext_free_space = set_space_used (Plist, currentsize(list));
        do i = 1 to list.Npghs;     /* Create new entry point list pghs.        */
             call output_list (Plist, i, Poutput, Loutput, Nlines);
             j, Ncommon_units = Ncommon_units + 1;
             common_units(j).Pstart = Poutput;  /*   Add new pghs to end of common units.   */
             common_units(j).L = Loutput;
             common_units(j).Nlines = Nlines;
             Deps.linfo(0).Nlines = Deps.linfo(0).Nlines + Nlines + 2;
             common_units(j).S = "0"b;
             if i = 1 then do;      /*   Include section title for 1st pgh of ep list.*/
            common_units(j).title = list.title;
            common_units(j).S.scn = TRUE;
            end;
             else do;           /*   No section title for subsequent pghs.  */
            common_units(j).title = "";
            end;
             common_units(j).S.ep_list = TRUE;  /*   Remember how pghs got there (for debugging).   */
             Poutput, Pnext_free_space = set_space_used (Poutput, currentsize(output));
             end;               /*   Get space for next pgh.            */
        Dlinfo.Nunits = Nuncommon_units + Ncommon_units;
        list_base.N = list_base.N - 1;  /* Discard list containing entry point names.   */
        end;
         do i = 1 to Ncommon_units;     /* Mark all common units by number.     */
        common_units(i).Icommon_unit = i;   /* This will help avoid seeing common units in  */
        end;                /* every entry point info.          */
         PDlinfo = Pnext_free_space;
         do i = 1 to Deps.N;            /* Parse all other entry points to count lines. */
        call parse_entry_point_into_units (Deps.linfo(i), Pcommon_units, Ncommon_units, PDlinfo);
        PDlinfo, Pnext_free_space = set_space_used (PDlinfo, currentsize(Dlinfo));
        end;                /* Common pghs added to other entries when parsed.*/
         end;
    else do;
         Pcommon_units = PDlinfo;
         Ncommon_units = 0;
         end;
    Deps.Nlines = sum(Deps.linfo.Nlines);       /* Count lines in total info.           */
\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Copy -section and -search control arguments.                 */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if help_args.Sctl.scn then do;      /* Copy -section args to local storage.     */
         do i = 1 to min(help_args.Nscns, dim(scn.arg,1));
        scn.arg(i) = help_args.scn(i);
        end;
         scn.N  = i-1;
         end;
    if help_args.Sctl.srh then do;      /* Copy -search args to local storage.      */
         do i = 1 to min(help_args.Nsrhs, dim(srh.arg,1));
        srh.arg(i) = help_args.srh(i);
        end;
         srh.N = i-1;
         end;
\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Find the correct logical info segment (info), if any was requested by user.      */
    /* If desired info was not found, then any searching required for the           */
    /* -section and -search control arguments cannot and will not be done, though the   */
    /* operands given with these control arguments are stored as the default values to be   */
    /* used with the section and search requests if first issued without operands.      */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if  Dinfo_seg_.ep = ""  then do;        /* if no entry point requested,     */
         if  help_args.min_date_time ^= -1  then do;    /*   process 1st newer than given date/time */
        do Iep = 0 to Deps.N while (help_args.min_date_time ^< Deps.linfo(Iep).date);
             end;               /*   iff a nonzero date/time selector was given.    */
        if  Iep > Deps.N  then  Iep = 0;
        end;
         else if  help_args.Sctl.scn | help_args.Sctl.srh  then do;
        Ssearch = FALSE;            /*   process 1st entry containing matches for   */
        Iunit = 1;          /*   -section and/or -search  ctl_args.     */
        if       help_args.Sctl.scn  &  help_args.Sctl.srh  then do;
             do Iep = 0 to Deps.N while(^Ssearch);
            match_result = find_section (Deps.linfo(Iep).PDlinfo, scn, Iunit);
            if match_result ^= no_match then
                 Ssearch = find_pgh (Deps.linfo(Iep).PDlinfo, srh, Iunit, new_section);
            end;
             end;
        else if  help_args.Sctl.scn  then do;
             do Iep = 0 to Deps.N while(^Ssearch);
            match_result = find_section (Deps.linfo(Iep).PDlinfo, scn, Iunit);
            Ssearch = (match_result ^= no_match);
            end;
             end;
        else do;
             do Iep = 0 to Deps.N while(^Ssearch);
            Ssearch = find_pgh (Deps.linfo(Iep).PDlinfo, srh, Iunit, new_section);
            end;
             end;
        if ^Ssearch then return;
        Iep = Iep - 1;
        end;
         else  Iep = 0;             /* otherwise, process general description.  */
         Ssearch = TRUE;
         end;
\014
    else do;                    /* else search for requested entry point.   */
         Sfound = FALSE;
         do Iep = 1 to Deps.N while (^Sfound);
        do i = 1 to Deps.linfo(Iep).Nep_names while(^Sfound);
             if Dinfo_seg_.ep = Deps.linfo(Iep).ep_name(i) then
            Sfound = TRUE;
             end;
        end;
         if Sfound then do;
        Iep = Iep - 1;
        Ssearch  = TRUE;            /* Do -section/-search matching if user asked.  */
        end;
         else do;               /*   requested ep not found.            */
        if Dinfo_seg_.info_name = "" then
             Linfo_name = 0;
        else Linfo_name = length(rtrim(Dinfo_seg_.info_name)) + length(" ()");
        call com_err_ (error_table_$noentry, procedure_name, 
             "^/Looking for entry point ^a in info^[ ^a^/(^a^[>^]^a)^;^s^/^a^[>^]^a^]",
             Dinfo_seg_.ep, Linfo_name>0, Dinfo_seg_.info_name,
             Dinfo_seg_.dir, Dinfo_seg_.dir^=">", Dinfo_seg_.ent);
        Ssearch = FALSE;            /* Don't do -section/-search matching.      */
        Iep = 0;
        end;
         end;
    PDlinfo = Deps.linfo(Iep).PDlinfo;      /* Address entry point user wants first.    */
\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* When -header is given without other control arguments, generate a heading line   */
    /* containing full pathname of physical info segment, title line from logical       */
    /* info segment, line count of logical info segment, and count of logical info segments */
    /* (infos) in physical info seg (excluding common portion at the beginning).        */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Ninfos_printed = Ninfos_printed + 1;        /* Beyond this point, something must get printed.   */
    if  Dinfo_seg_.Scross_ref then  do;     /* Just remark about existence of other versions    */
                        /* of an info.              */
         if Ninfos_printed = 1 then do;
        call ioa_ ("^a: No infos matching -section and -search control arguments were found.", procedure_name);
        call ioa_ ("However, several infos appear more than once in the search paths.");
        call ioa_ ("The following secondary info(s) match -section and -search control arguments.");
        end;
         else if Nlast_info_cross_ref ^= Iinfo-1 then do;
        call ioa_ ("^v/^a: Other versions of the info^[s^] above were found.  See also:", 
             help_args.Lspace_between_infos, procedure_name, Ninfos_printed>2);
        end;
         call ioa_ ("  ^a^[>^]^a", Dinfo_seg_.dir, Dinfo_seg_.dir^=">", Dinfo_seg_.ent);
         Nlast_info_cross_ref = Iinfo;
         go to RETURN;
         end;
    else if help_args.Sctl.he_only then do;     /* When -header is given without other ctl_args */
                        /*   output the header and return.      */
         call print_header_only();
         go to RETURN;
         end;


    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* The -brief control argument requests that the "Syntax" section (or "Usage" section of    */
    /* old format info segs) be output in full, along with a list of arguments and control  */
    /* arguments from the "Arguments" and "Control arguments" sections.         */
    /* 1) Find "Syntax" or "Usage" sections, and count lines in these sections.     */
    /* 2) Find "Arguments" and "Control arguments" sections, and build lists of arguments.  */
    /*    Count output lines in each list.                      */
    /* 3) Output a header line, optionally given full pathname of physical info seg (-header)   */
    /*    as well as number of lines in the brief output, total lines in the info, and  */
    /*    count of (other) infos in this physical info seg.             */
    /* 4) Output the "Syntax" or "Usage" section.                   */
    /* 5) Output the columnar lists of "Arguments" and "Control arguments".     */
    /* 6) Stop processing this physical info segment, and move on to the next specified */
    /*    by user (if any).                         */
    /*                                  */
    /* When -control_arg is given, output description of all args/ctl_args whose name lines */
    /* contain match for substring identifier(s) given as operands by the user.     */
    /* 1) Find "Argument" and "Control argument" name lines which contain one of the    */
    /*    substrings given by the user after -control_arg.              */
    /* 2) Store those argument description lines in a list.             */
    /* 3) Print the argument description lines in the list after an appropriate heading.    */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
\014
    if help_args.Sctl.bf |
       help_args.Sctl.ca then do;           /* Print argument descriptions when -ca given.  */
         Nlines = 1;                /* Count lines to be output.            */
                        /*   Add 1 line for heading line.       */
         if help_args.Sctl.bf then do;
        call get_brief_data (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
                Plist_base, Dinfo_seg_.dir, Dinfo_seg_.ent, Nlast_info_no_brief_data,
                Iinfo, Ninfos_printed, Iunit_syntax,
                Nunit_syntax, Nlists_of_bf_args, Nlines);
        if Nlines = 1 then go to RETURN;
        end;
         else do;
        Nunit_syntax = 0;
        Nlists_of_bf_args = 0;
        if ^brief_data_ok (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
                     Dinfo_seg_.dir, Dinfo_seg_.ent, Iinfo, Ninfos_printed,
                     Nlast_info_no_brief_data) then go to RETURN;
        end;

         if help_args.Sctl.ca then do;      /* Get control argument descriptions.       */
        Plist, Plist_of_cas = get_list (Plist_base);
        list.N = help_args.Ncas;        /*   Begin by copying user-supplied arg names.  */
        list.arg = help_args.ca;
        list.title = "-control_arg";        /*   Get one list for each section with ctl args.   */
        call get_arg_descriptions (Plist_of_cas, PDlinfo, Plist_base,
             Deps.linfo(Iep).S.old_format, Plists_of_args, Nlists_of_args);
        do i = 1 to Nlists_of_args;     /*   Count output lines in each list.  Lists are    */
             Plist = Plists_of_args(i); /*   separated by 2 1 line, with 1 line for */
             Nlines = Nlines + list.N + 2;  /*   title of section containing the args.  */
             end;
        end;

         if length(Deps.linfo(Iep).header) = 0 then Nlines = Nlines - 2;
                        /* No title?  Remove its line count.        */
         if  Ninfos > 1  then            /* Suppress heading if only 1 info being printed.   */
        call print_header();
         call print_brief_data (PDlinfo, Ninfos>1, Plist_base,
        Iunit_syntax, Nunit_syntax, Nlists_of_bf_args);

         if help_args.Sctl.ca then do;      /* Print ctl arg descriptions, section by sect. */
        do j = 1 to Nlists_of_args;
             Plist = Plists_of_args(j);
             call ioa_ ("^[^/^]^a:", (j>1  |  Ninfos>1  |
            (help_args.Sctl.bf & help_args.Sctl.ca)), list.title);
             do i = 1 to list.N;
            call ioa_ ("^a", list.arg(i));
            end;
             end;
        end;
         go to RETURN;              /*   Stop when -brief or -control_arg given.    */
         end;
\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* When -title is given, output a heading line and titles of paragraph sections.    */
    /* The heading line contains:                           */
    /* 1) The full pathname of the info segment (if -header was given).         */
    /* 2) The primary title line from the info selected by the user.            */
    /* 3) The count of section title lines to be output.                */
    /* 4) Count of total lines in logical info segment.             */
    /* 5) Count of (other) infos in this physical info segment.             */
    /* Output a list of section titles in columnar form.                */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    PI_LABEL = QUERY;               /* once printing starts, pi skips to next query.    */
    Iunit = 0;              /* No pghs printed so far.          */
    if  help_args.Sctl.title  &  
      ((Dlinfo.Nsections > 1)  |
       (Dlinfo.Nsections = 1  &  ^Dlinfo.unit(1).S.scn))
    then do;                    /* Print pgh titles when -title is given only if    */
                        /* more than one title will be printed.     */
         if length(Deps.linfo(Iep).header) > 0 then
        Nlines = 1;
         else Nlines = -1;
         Plist_of_titles = get_list (Plist_base);
         call get_title_list (PDlinfo, Plist_of_titles, 0);
         call format_list (Plist_of_titles, divide(Dlinfo.Nsections,7,17,0)+1, 1);
         Nlines = Nlines + Plist_of_titles->list.Nrows + 1;
         if help_args.Sctl.all then do;
        Nlines = Nlines + Deps.linfo(Iep).Nlines + 2;
        if length(Deps.linfo(Iep).header) > 0 then  Nlines = Nlines - 2;
        end;
         call print_header();
         call print_list(Plist_of_titles, Sprint_inhibit);
         Pnext_free_space = Plist_of_titles;
         list_base.N = list_base.N - 1;     /* Free list of titles.         */
         if help_args.Sctl.all then do;
        do Iunit = 1 to Dlinfo.Nunits;
             call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
             end;
        go to QUERY;
        end;
         end;
\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* When -title not given, begin printing paragraphs.  Normally start with first pgh.    */
    /* However, if -section  is given, search for section whose title contains      */
    /* user-specified substrings.  Print first pgh of this section if found.        */
    /* If -search is given, search for pgh containing user-specified substrings.        */
    /* Start with first matching pgh.  If both -section and -search are given, position to  */
    /* matching section before searching more matching pgh.             */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    else do;
         Iunit = 1;             /* Start searching in first unit.       */
         new_section = "";
         if ^help_args.Sctl.all  & 
            ^help_args.Sctl.title  & 
            (help_args.Sctl.scn |           /* Select pgh when  -section given.     */
             help_args.Sctl.srh)  then do;      /* Select pgh when -search given.       */
        if help_args.Sctl.scn then do;  /* Search all section titles for one containing */
             match_result = find_section (PDlinfo, scn, Iunit);
             if  match_result = no_match  then return;
             end;
        if help_args.Sctl.srh then do;  /* Search subsequent pghs for one containing    */
             Ssearch = find_pgh (PDlinfo, srh, Iunit, new_section);
             if ^Ssearch then return;
             end;
        end;
\014
         if help_args.Sctl.all then do;
        Nlines = Deps.linfo(Iep).Nlines;
        Nprint_units = Dlinfo.Nunits;
        end;
         else do;
              Nlines = Dlinfo.unit(Iunit).Nlines + 2;   /*   Add 2 for entry point heading.     */
        if length(Deps.linfo(Iep).header) = 0 then Nlines = Nlines - 2;
                        /*   However, if no heading, subtract the 2 lines.*/
              if  new_section^=""  & ^Dlinfo.unit(Iunit).S.scn  then
             Nlines = Nlines + 1;       /* Add 1 line for section title of matched pgh. */
              Nprint_units = 1;         /* Print one pgh.  If -section and -search were */
                        /* not given, print more pghs as well so long   */
                        /* as total lines fewer than help_args.max_Lpgh */
                        /* and additional pghs shorter than min_Lpgh.   */
              if ^(help_args.Sctl.scn | help_args.Sctl.srh) then
              do while (Iunit+Nprint_units <= Dlinfo.Nunits & 
           Dlinfo.unit(Iunit+Nprint_units).Nlines < help_args.min_Lpgh & 
           Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines <= help_args.max_Lpgh);
             Nlines = Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines;
             Nprint_units = Nprint_units + 1;
             end;
        end;
         call print_header();
         if  new_section^=""  &  ^Dlinfo.unit(Iunit).S.scn  then do;
        call ioa_ ("^/^a:", new_section);
        call print_pgh_nnl (Dlinfo.unit(Iunit), Sprint_inhibit);
        end;
         else if  ^help_args.Sctl.he_pn  & 
            ^help_args.Sctl.he_info_name  & 
            ^help_args.Sctl.he_counts  & 
            length(Deps.linfo(Iep).header) = 0  then
        call print_pgh_nnl (Dlinfo.unit(Iunit), Sprint_inhibit);
         else call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
         do Iunit = Iunit + 1  to  Iunit + Nprint_units - 1;
        call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
        end;
         Iunit = Iunit - 1;
         end;
\014
QUERY:  Nconsecutive_bad_ops = 0;           /* No errors in responses so far.       */
    Ssearch = FALSE;                /* no searching for matching section/pgh underway.*/
    Sloop = TRUE;               /* Loop through all paragraphs of info.     */
    Iunit = Iunit + 1;              /* Beginning with the next one.     */
    query_type = normal;            /* Print normal section/pgh messages for now.   */

    do while (Sloop);               /* Print remaining pghs under user control. */
         PI_LABEL = ASK;            /* Recompute query after most program_interrupt's.*/
         if Iunit > Dlinfo.Nunits then       /* Detect end_of_info and handle specially, but     */
        go to END_OF_INFO;          /* still remain within do group.        */
ASK:         if  query_type = normal  |
             query_type = some_unseen  |
             query_type = search_unseen  then do;
        Sseen = seen_pgh (Dlinfo.unit(Iunit));  /* Tell user in query if he's already seen pgh. */
        Nlines = Dlinfo.unit(Iunit).Nlines;
        Nprint_units = 1;           /* Normally print one pgh at a time.        */
        if  Dlinfo.unit(Iunit).S.scn  |  Iunit=1  then do;
                        /* However, if pgh begins a section and following   */
             if  Iunit = 1  &  ^Dlinfo.unit(1).S.scn then
                  query = "UNTITLED";
             else query = Dlinfo.unit(Iunit).title;
                        /* pghs are shorter than min_Lpgh, print them   */
             do i = Iunit+Nprint_units by 1 /* as well, until max_Lpgh lines are aggregated.    */
             while (i <= Dlinfo.Nunits  &    /*   When aggregating sections, include all */
             ^Ssearch  &        /*   section titles in the query.       */
              Sseen = seen_pgh (Dlinfo.unit(i))  & 
              Dlinfo.unit(i).Nlines < help_args.min_Lpgh  & 
              Dlinfo.unit(i).Nlines + 2 + Nlines <= help_args.max_Lpgh);
            Nlines = Nlines + Dlinfo.unit(i).Nlines + 2;
                        /*   Must skip 2 lines between pghs to keep line    */
                        /*   count of total info equal to count of all  */
                        /*   printed lines.             */
            if Dlinfo.unit(i).S.scn then  do;
                 query = query || "  &  ";
                 if length (query) + length(Dlinfo.unit(i).title) + 12 > Loutput_line then
                      query = query || NL;/* 12 = length ( "(nnn lines)." )     */
                 query = query || Dlinfo.unit(i).title;
                 end;
            Nprint_units = Nprint_units + 1;
            end;
             end;
        else do;                /* If pgh doesn't begin a section, we can only  */
             do i = Iunit+Nprint_units by 1 /* aggregate pghs in the current section.   */
             while (i <= Dlinfo.Nunits  &    /* Note that, here and above, if current pgh    */
                   ^Dlinfo.unit(i).S.scn  & /* has already been seen, then can only aggregate   */
                   ^Ssearch  &      /* following pgh if it has been seen as well.   */
                    Sseen = seen_pgh (Dlinfo.unit(i))  & 
                    Dlinfo.unit(i).Nlines < help_args.min_Lpgh  & 
                    Dlinfo.unit(i).Nlines + 2 + Nlines <= help_args.max_Lpgh);
                  Nlines = Nlines + Dlinfo.unit(i).Nlines + 2;
                  Nprint_units = Nprint_units + 1;
                  end;
              end;
        end;
\014
         else if  query_type = new_entry  then  do;
        Sseen = Deps.linfo(Iep).S.seen_by_user;
        Nlines = Dlinfo.unit(Iunit).Nlines;
        Nprint_units = 1;
        do while (Iunit+Nprint_units <= Dlinfo.Nunits & 
            Dlinfo.unit(Iunit+Nprint_units).Nlines < help_args.min_Lpgh & 
            Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines <= help_args.max_Lpgh);
             Nlines = Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines;
             Nprint_units = Nprint_units + 1;
             end;
        if Nlines+2 < Deps.linfo(Iep).Nlines then
             Lcount = length("Entry:(99 lines follow;  999 lines in entry point)  More help?");
        else Lcount = length("Entry:(999 lines in entry point)  More help?");
        Snl1 = (Lcount + 2 + length(Deps.linfo(Iep).header) + 3 > Loutput_line);
        end;
RE_ASK:      Ssearch = FALSE;           /* searching for matching section/pgh is done.  */
         PI_LABEL = ASK;            /* Routines branching here set PI_LABEL. Reset it.*/
         Sprint_inhibit = FALSE;
         if  query_type = normal  then
        call command_query_ (addr(query_info), answer, procedure_name,
             "^[^a (^d line^[s^]).^[^/^;  ^]^2s^;^4s^d more line^[s^].  ^]^[Review^;More help^]?",
             Dlinfo.unit(Iunit).S.scn,  query, Nlines, Nlines > 1, (length(query)+24 > Loutput_line),
             Nlines, Nlines > 1,
             Sseen);
         else if  query_type = some_unseen  then
        call command_query_ (addr(query_info), answer, procedure_name,
             "End of info.  Some paragraphs unseen.^/^[^a^;In:  ^a^] (^d line^[s^]).^[^/^;  ^]More help?",
             Dlinfo.unit(Iunit).S.scn, query,
             Nlines, Nlines > 1,
             length(query) + 30 > Loutput_line);
         else if  query_type = search_unseen  then
        call command_query_ (addr(query_info), answer, procedure_name,
             "^[^[^a^;In:  ^a^] (^d line^[s^])^;^2s^d more line^[s^]^].^[^/^;  ^]More help?",
             query ^= "", Dlinfo.unit(Iunit).S.scn, query,
             Nlines, Nlines > 1,
             length(query) + 30 > Loutput_line);
         else if  query_type = new_entry  then
        call command_query_ (addr(query_info), answer, procedure_name,
             "Entry:  ^a^[^/^;   ^](^[^d lines follow;  ^;^s^]^d lines in entry point).  ^[Review^;More help^]?",
             Deps.linfo(Iep).header,
             Snl1,
             (Nlines+2 < Deps.linfo(Iep).Nlines),
            Nlines, Deps.linfo(Iep).Nlines-2,
             Sseen);
PARSE:       call parse_answer (answer, op, ep_name, ca, scn, srh);
         if op = hbound(do,1) + 1 then do;      /* Count consecutive errors user makes in answer.   */
        Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
        go to ERROR;
        end;
         else Nconsecutive_bad_ops = 0;
         go to do(op);              /* Process request at user's beck and call. */
\014
YES:
do(1):       Iunit_end = Iunit + Nprint_units - 1;  /* yes                  */
         PI_LABEL = YES_END;            /* go to pgh user said, even if he pi's.    */
         call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
         do Iunit = Iunit + 1  to  Iunit + Nprint_units - 1;
        call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
        end;
YES_END:         Iunit = Iunit_end;
         go to CONTINUE;

do(2):       go to RETURN;              /* no                   */

do(3):       go to QUIT;                /* quit                 */

do(4):       Iunit = 0;             /* top                  */
         if length(Deps.linfo(Iep).header) > 0 then call ioa_ ("^a", Deps.linfo(Iep).header);
         go to CONTINUE;

do(5):       Nlines_titles = Dlinfo.unit(Iunit).Nlines; /* rest                 */
         do Iunit_end = Iunit + 1 to Dlinfo.Nunits;
        Nlines_titles = Nlines_titles + Dlinfo.unit(Iunit_end).Nlines + 2;
        end;
         Iunit_end = Iunit_end - 1;
REST:        PI_LABEL = REST_END;
         call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
         call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
         do Iunit = Iunit + 1 to Iunit_end;
        call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
        end;
REST_END:        Iunit = Iunit_end;
         go to CONTINUE;

do(6):                      /* rest -scn                */
         Nlines_titles = Dlinfo.unit(Iunit).Nlines;
         do Iunit_end = Iunit + 1 to Dlinfo.Nunits while (^Dlinfo.unit(Iunit_end).S.scn);
        Nlines_titles = Nlines_titles + Dlinfo.unit(Iunit_end).Nlines + 2;
        end;
         Iunit_end = Iunit_end - 1;
         go to REST;

do(7):       go to CONTINUE;            /* skip                 */

do(8):                          /* skip -scn                */
         do Iunit = Iunit + 1 to Dlinfo.Nunits while (^Dlinfo.unit(Iunit).S.scn);
        end;
         Iunit = Iunit - 1;
         go to CONTINUE;

do(9):                      /* skip -ep             */
do(10):                     /* skip -rest               */
         do Iunit = 1 to Dlinfo.Nunits while (^seen_pgh(Dlinfo.unit(Iunit)));
        end;                /* Has user seen any pgh of this entry?     */
         if Iunit > Dlinfo.Nunits then       /* No.                  */
        Sseen = FALSE;
         else Sseen = TRUE;         /* If so, by skip -ep, he's saying he's seen all    */
         go to CHECK_OTHER_ENTRIES;     /* he wants to of this entry.           */
\014
do(11):      new_section  = "";         /* skip -seen               */
         Sfound = FALSE;
         do Iunit = Iunit+1 to Dlinfo.Nunits while(^Sfound);
        if Dlinfo.unit(Iunit).S.scn then
             new_section  = Dlinfo.unit(Iunit).title;
        Sfound = ^seen_pgh(Dlinfo.unit(Iunit));
        end;
         Iunit = Iunit - 1;
         if Sfound then do;
        query = new_section;
        query_type = search_unseen;
        go to ASK;
        end;
         else go to END_OF_INFO;

do(12):      Iunit_search = Iunit - 1;      /* title                    */
TITLE:       PI_LABEL = RE_ASK;
         Plist_of_titles = get_list (Plist_base);
         call get_title_list (PDlinfo, Plist_of_titles, Iunit_search);
         call format_list (Plist_of_titles, divide (Plist_of_titles->list.N, 7, 17, 0)+1, 1);
         Nlines_titles = Plist_of_titles->list.Nrows;
         call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
         call print_list (Plist_of_titles, Sprint_inhibit);
         Pnext_free_space = Plist_of_titles;
         list_base.N = list_base.N - 1;
         go to RE_ASK;

do(13):      Iunit_search = 0;          /* title -top               */
         go to TITLE;
\014
do(14):                     /* entry_point {ep_name}            */
         if ref_name = "" then
        if suffix = "" then
             ref_name = rtrim(Dinfo_seg_.ent);
        else ref_name = substr(Dinfo_seg_.ent, 1, 32 - length(suffix) -
                  index(reverse(Dinfo_seg_.ent), reverse(suffix) || "."));
         if ep_name = "" then           /* Look for main entry point (eg, ioa_$ioa_)    */
        ep_name = ref_name;
         else do;
        i = index(ep_name, "$");        /* Look for hcs_$initiate rather than initiate  */
        if i > 1 then do;            /* Validate given reference name.       */
             if substr(ep_name,1,i-1) ^= ref_name then do;
            call ioa_ ("Reference name  ^a  invalid.  Entry point names must be of the form:
    ^a$ENTRY_POINT_NAME
or just:    ENTRY_POINT_NAME", substr(ep_name,1,i-1), ref_name);
            Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
            go to ERROR;
            end;
             end;
        if i > 0 then
             if i < length(ep_name) then
            ep_name = substr(ep_name,i+1);
             else ep_name = ref_name;
        end;
         Sfound = FALSE;            /* Find the requested entry point.      */
         do i = 1 to Deps.N while (^Sfound);
        do j = 1 to Deps.linfo(i).Nep_names while (^Sfound);
             if ep_name = Deps.linfo(i).ep_name(j) then
            Sfound = TRUE;
             end;
        end;
         if Sfound then do;
        Deps.linfo(Iep).S.seen_by_user = TRUE;  /* user has seen all he wants of this entry point.*/
        Iep = i - 1;
        PDlinfo = Deps.linfo(Iep).PDlinfo;
        Iunit = 1;
        query_type = new_entry;
        go to ASK;
        end;
         else do;
        call ioa_ ("Entry point  ^a$^a  not found.", ref_name, ep_name);
        go to RE_ASK;
        end;
\014
do(15):      Iunit_search = Iunit;          /* section              */
SECTION:         if scn.N = 0 then do;
        call ioa_$nnl ("No search strings given for section request.  ");
        Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
        go to ERROR;
        end;
         match_result = find_section (PDlinfo, scn, Iunit_search);
         if  match_result = exact_match  then do;
        Iunit = Iunit_search;
        Nprint_units = 1;
        call ioa_ ("(^d ^[lines follow^;line follows^])",
             Dlinfo.unit(Iunit).Nlines, Dlinfo.unit(Iunit).Nlines > 1);
        go to YES;
        end;
         else if  match_result = match  then do;
        Iunit = Iunit_search;       /* When found, don't aggregate paragraphs.  */
        Ssearch  = TRUE;
        query_type = normal;
        go to ASK;
        end;
         else do;               /* Search failed?  Paragraphs can be aggregated */
        call ioa_ ("No matching section found.");
        go to RE_ASK;           /* based upon user's next response.     */
        end;

do(16):      Iunit_search = 1;          /* section -top             */
         go to SECTION;

do(17):      Iunit_search = Iunit;          /* search                   */
SEARCH:      if srh.N = 0 then do;
        call ioa_$nnl ("No search strings given for search request.  ");
        Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
        go to ERROR;
        end;
         Ssearch = find_pgh (PDlinfo, srh, Iunit_search, new_section);
         if Ssearch then  do;           /* Found matching pgh?  Print it.       */
        Iunit = Iunit_search;
        Ssearch = FALSE;
        Nlines = Dlinfo.unit(Iunit).Nlines;
        if  new_section^= ""  &  ^Dlinfo.unit(Iunit).S.scn  then do;
             Nlines = Nlines + 1;
             call ioa_ ("(^d lines follow)^2/^a:", Nlines, new_section);
             call print_pgh_nnl (Dlinfo.unit(Iunit), Sprint_inhibit);
             end;
        else do;
             call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines, Nlines>1);
             call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
             end;
        go to CONTINUE;
        end;
         else do;
        call ioa_ ("No matching paragraph found.");
        go to RE_ASK;
        end;

do(18):      Iunit_search  = 1;         /* search  -top             */
         go to SEARCH;
\014
do(19):      Nlines_titles = -1;            /* brief                    */
         call get_brief_data (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
                  Plist_base, Dinfo_seg_.dir, Dinfo_seg_.ent, Nlast_info_no_brief_data,
                 Iinfo, Ninfos_printed, Iunit_syntax,
                 Nunit_syntax, Nlists_of_bf_args, Nlines_titles);
         Nlists_of_bf_args = list_base.N;
         if Nlines_titles > 0 then do;
        call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
        call print_brief_data (PDlinfo, TRUE, Plist_base,
             Iunit_syntax, Nunit_syntax, Nlists_of_bf_args);
        end;
         go to RE_ASK;

do(20):      Nlines_titles = -1;            /* control_arg              */
         if ^brief_data_ok (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
                Dinfo_seg_.dir, Dinfo_seg_.ent, Iinfo, Ninfos_printed,
                Nlast_info_no_brief_data) then;
         else do;
        ca.title = "control_arg";
        call get_arg_descriptions (addr(ca), PDlinfo, Plist_base,
                       Deps.linfo(Iep).S.old_format, Plists_of_args, Nlists_of_args);
        if Nlists_of_args > 0 then  do;
             do i = 1 to Nlists_of_args;
                  Plist = Plists_of_args(i);
                  Nlines_titles = Nlines_titles + list.N + 2;
                  end;
             call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
             do j = 1 to Nlists_of_args;
                  Plist = Plists_of_args(j);
                  call ioa_ ("^/^a:", list.title);
                  do i = 1 to list.N;
                       call ioa_ ("^a", list.arg(i));
                       end;
                  end;
             Pnext_free_space = Plists_of_args(1);
             list_base.N  = 0;
             end;
        else call ioa_ ("No matching control arguments.");
        end;
         go to RE_ASK;

do(21):      call ioa_("^a", procedure_name);       /* . (= print name of caller)           */
         go to RE_ASK;

do(22):      if query_answers.Nrows = 0 then        /* ? (= list responses)         */
        call format_list(addr(query_answers), 5, 1);
         call print_list (addr(query_answers), Sprint_inhibit);
         go to RE_ASK;

do(23):      call print_header_only();      /* header                   */
         go to RE_ASK;
\014
ERROR:
         if Nconsecutive_bad_ops = 1 then do;   /* For first error, omit acceptable response    */
                        /* list, and just print mini query.     */
        call command_query_ (addr(query_info), answer, procedure_name,
             "^d ^[lines follow^;line follows^].  ^[Review^;More help^]?",  Nlines, Nlines>1, Sseen);
        go to PARSE;
        end;
         call ioa_("^/Type ? for a list of allowed responses.");
                            /* But if user errs more than once for given query*/
                        /* tell user how to print responses     */
         if Nconsecutive_bad_ops > 2 then go to RE_ASK;
                        /* If more than 2 consecutive errors, the user  */
                        /* may have forgotten original question.    */
                        /* Repeat it in  its entirety.      */
         else
        call command_query_ (addr(query_info), answer, procedure_name,
             "^d ^[lines follow^;line follows^].  ^[Review^;More help^]?",  Nlines, Nlines>1, Sseen);
         go to PARSE;
\014
END_OF_INFO:   Sseen = TRUE;                /* Examine all pghs looking for unseen pgh. */
         new_section = "UNTITLED";      /* Remember section titles as we examine them.  */
         do Iunit = 1 to Dlinfo.Nunits while (Sseen);
        if Dlinfo.unit(Iunit).S.scn then
             new_section = Dlinfo.unit(Iunit).title;
        Sseen = seen_pgh (Dlinfo.unit(Iunit));
        end;                /* Look for unseen paragraphs.      */
         if ^Sseen then  do;            /* Some were found?             */
        Iunit = Iunit - 1;          /* do group always increments 1 too many.   */
        query = new_section;
        query_type = some_unseen;
        go to ASK;
        end;
         Sseen = TRUE;              /* This entry point has been seen.      */

CHECK_OTHER_ENTRIES:
         if Deps.N = 0 then go to RETURN;       /* Only 1 part in log info?  We're done.    */
         else do;               /* Many entry points.           */
        Deps.linfo(Iep).S.seen_by_user = Sseen; /* Mark whether or not we've seen this entry.   */
        do i = Iep+1 to Deps.N while (Deps.linfo(i).S.seen_by_user  |
                    help_args.min_date_time ^< Deps.linfo(i).date);
             end;               /* Look for unseen entries.         */
        if i > Deps.N then do;       /* All entries seen?            */
             do i = 1 to Iep-1 while (Deps.linfo(i).S.seen_by_user  |
                    help_args.min_date_time ^< Deps.linfo(i).date);
            end;
             if  Deps.linfo(i).S.seen_by_user  |
                 help_args.min_date_time ^< Deps.linfo(i).date  then
            go to RETURN;
             end;
        Iep = i;                /* ith one is unseen.           */
        PDlinfo = Deps.linfo(Iep).PDlinfo;  /* access its paragraph descriptors.        */
        Iunit = 1;
        if help_args.Sctl.all then do;
             Lcount = length("Entry:(999 lines in entry point)");
             Snl1 = (Lcount + 2 + length(Deps.linfo(Iep).header) + 3 > Loutput_line);
             call ioa_ ("^v/Entry:  ^a^[^/^;   ^](^d lines in entry point)",
            help_args.Lspace_between_infos, Deps.linfo(Iep).header, Snl1, Deps.linfo(Iep).Nlines-2);
             Nprint_units = Dlinfo.Nunits;
             go to YES;
             end;
        query_type = new_entry;
        go to ASK;
        end;

CONTINUE:        Iunit = Iunit + 1;         /* Must implement looping ourselves because */
         Sloop = (Iunit <= Dlinfo.Nunits+1); /* Dlinfo.Nunits will change when we switch to a    */
         query_type = normal;           /* new entry point.  Loop would be:     */
         end;                   /*  do Iunit = Iunit+1 to Dlinfo.Nunits;    */

RETURN: PI_LABEL = NEXT_INFO;
    return;
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


find_pgh: procedure (PDlinfo_, Srh, Iunit, new_section) returns (bit(1) aligned);

     dcl    PDlinfo_            ptr;        /* ptr to descriptors for this log info seg.    */
     dcl    1 Dlinfo_           aligned based(PDlinfo_),
      2 Nunits      fixed bin,  /* number of units (pghs) in this log info seg. */
      2 Nsections       fixed bin,  /* number of units having section title.    */
      2 unit (0 refer (Dlinfo_.Nunits))
                like Dlinfo.unit;
     dcl    1 Srh           aligned,        /* Paragraph search args.           */
      2 header      like LIST.header,
      2 group (100)     like LIST.group;
     dcl    Iunit           fixed bin;  /* Pgh to start searching (Input)       */
     dcl    new_section     char(88) varying;   /* Title of new section  in which pgh occurs.   */
                        /* Pgh found. (Output)          */
     dcl    srh (Srh.N)     char(88) varying;   /* translated paragraph search args.        */
     dcl    Ssearch         bit(1) aligned;
     dcl (i, j)             fixed bin;
     dcl    PPgh            ptr,
    LPgh            fixed bin,
    Pgh         char(LPgh) based(PPgh);

    j = 0;                  /* Find length of longest pgh we will examine   */
    if Srh.N = 0 then return(FALSE);        /* If nothing to search for, forget it.     */
    do i = Iunit to Dlinfo_.Nunits;     /* so we can create temp storage into which */
         j = max(j, Dlinfo_.unit(i).L);     /* each pgh can be translated into lowercase.   */
         end;

BLOCK:  begin;
     dcl    pgh         char(j) varying;

    do i = 1 to Srh.N;              /* translate search args to lower case.     */
         srh(i) = translate(Srh.arg(i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
         end;
    Ssearch = FALSE;                /* Search until matching section title found    */
    new_section  = "";
    do Iunit = Iunit to Dlinfo_.Nunits while(^Ssearch);
         if Dlinfo_.unit(Iunit).S.scn then
        new_section = Dlinfo_.unit(Iunit).title;
         PPgh = Dlinfo_.unit(Iunit).Pstart;
         LPgh = Dlinfo_.unit(Iunit).L;
         pgh = translate (Pgh, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
                        /* translate pgh to lower case.     */
         Ssearch = TRUE;            /* Assume title matches until proven otherwise. */
         do i = 1 to dimension(srh, 1) while(Ssearch);
        if index(pgh, srh(i)) = 0 then
             Ssearch = FALSE;
        end;
         end;
    if Ssearch then             /* Match found?             */
         Iunit = Iunit - 1;         /* do-group always increments one too many. */
    return (Ssearch);

    end BLOCK;

    end find_pgh;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


find_section: procedure (PDlinfo_, Scn, Iunit) returns (fixed bin);

     dcl    PDlinfo_            ptr;        /* ptr to descriptors for this log info seg.    */
     dcl    1 Dlinfo_           aligned based(PDlinfo_),
      2 Nunits      fixed bin,  /* number of units (pghs) in this log info seg. */
      2 Nsections       fixed bin,  /* number of units having section title.    */
      2 unit (0 refer (Dlinfo_.Nunits))
                like Dlinfo.unit;
     dcl    1 Scn           aligned,        /* Section title search args.           */
      2 header      like LIST.header,
      2 group (100)     like LIST.group;
     dcl    Iunit           fixed bin;  /* Pgh to start searching (Input)       */
                        /* Pgh found. (Output)          */
     dcl    scn (Scn.N)     char(88) varying;   /* translated section title search args.    */
     dcl    Ssearch         bit(1) aligned;
     dcl    i           fixed bin;
     dcl    result          fixed bin;
     dcl    temp            char(88) varying;
     dcl    title           char(88) varying;

    if Scn.N = 0 then return(no_match);     /* if nothing to search for, forget it.     */
    do i = 1 to Scn.N;              /* translate search args to lower case.     */
         scn(i) = translate(Scn.arg(i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
         end;
    Ssearch = FALSE;                /* Search until matching section title found    */
    do Iunit = Iunit to Dlinfo_.Nunits while(^Ssearch);
         if Dlinfo_.unit(Iunit).S.scn then do;
        title = translate (Dlinfo_.unit(Iunit).title, "abcdefghijklmnopqrstuvwxyz",
                              "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
                        /* translate title to lower case.       */
        Ssearch = TRUE;         /* Assume title matches until proven otherwise. */
        do i = 1 to dimension(scn, 1) while(Ssearch);
             if index(title, scn(i)) = 0 then
            Ssearch = FALSE;
             end;
        end;
         end;
    if Ssearch then do;             /* Match found?             */
         Iunit = Iunit - 1;         /* do-group always increments one too many. */
         temp = scn(1);
         do i = 2 to Scn.N;
        temp = temp || " ";
        temp = temp || scn(i);
        end;
         if temp = title then           /* check for exact match (except for letter case).*/
        result = exact_match;
         else result = match;
         end;
    else result = no_match;
    return (result);

    end find_section;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


format_list: procedure (Plist, Mcols, Mpghs);       /* This procedure formats a list of values. */

     dcl    Plist           ptr,        /* ptr to argument list to be printed.      */
    Mcols           fixed bin,  /* maximum number of columns to be used in format.*/
    Mpghs           fixed bin,  /* maximum pghs to be used. 0 means no limit.   */
    Sprint_inhibit      bit(1) aligned; /* on if printing suppressed by pi.     */


     dcl (Icol, Ipgh, Irow)     fixed bin,
    Pspaces         ptr,
    Lspaces         fixed bin,
    Pmatrix         ptr,
    Sdoes_not_fit       bit(1) aligned,
    i           fixed bin,
    line            char(MAX_HELP_LINE_SIZE) varying,
    spaces          char(Lspaces) based(Pspaces);

     dcl    1 list          aligned based(Plist),
      2 header      like LIST.header,
      2 group (0 refer (list.N)) like LIST.group;

     dcl    1 matrix (list.Npghs, list.Ncols, list.Nrows)
                aligned based(Pmatrix) like LIST.group;

     dcl    1 event_info        aligned,
      2 ev_chan     fixed bin(71),
      2 message     fixed bin(71),
      2 sender      bit(36),
      2 origin,
        3 dev_signal        bit(18) unal,
        3 ring      bit(18) unal,
      2 chan_index      fixed bin;

     dcl    1 wait_list     aligned int static,
      2 N           fixed bin,
      2 ev_chan (1)     fixed bin(71);

     dcl    1 write_status      aligned int static,
      2 ev_chan     fixed bin(71) init(0),
      2 output_pending      bit(1);
\014
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Format the arguments in as many columns as possible to reduce the output lines.  */
    /* However, if the output fits in 2 or more rows, the number of rows is chosen so that  */
    /* all columns but the final one are full.                  */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Pmatrix = addr(list.group);         /* overlay arg list with 3-D matrix.        */
    Sdoes_not_fit = TRUE;           /* Find proper number of columns to put output in.*/
    if Mcols < 1 then                /* Allow caller to limit number of columns. */
         list.Ncols = dimension(list.ML,1);
    else list.Ncols = min(Mcols, dimension(list.ML,1));
    do list.Ncols = list.Ncols to 1 by -1 while (Sdoes_not_fit);
         list.Nrows = divide (list.N + list.Ncols-1, list.Ncols, 17, 0);
                        /* Compute how many rows are required to display    */
                        /*   the args in list.Ncols columns.        */
         if Mpghs = 1 then          /* compute how many paragraphs are needed.  */
        list.Npghs = 1;
         else do;
        list.Npghs = divide (list.Nrows+help_args.max_Lpgh-2, help_args.max_Lpgh-1, 17, 0);
        list.Nrows = divide (list.Nrows+list.Npghs-1, list.Npghs, 17, 0);
        end;
                        /* Make sure that the output matrix is balanced,    */
                        /*   and that only the last column is not full. */
         if  (list.Npghs>1)  |  (list.Nrows*list.Ncols - list.N < list.Nrows) then do;
        list.Nreal = list.N;        /* Make life easier by creating enough empty args   */
                        /*   to fill out a square matrix.       */
        list.N = list.Ncols * list.Nrows * list.Npghs;
        do i = list.Nreal+1 to list.N;
             list.arg(i) = "";
             end;
        list.ML(*) = 0;         /* Find longest arg in each column.     */
        do Icol = 1 to list.Ncols;
             do Ipgh = 1 to list.Npghs;
            do Irow = 1 to list.Nrows;
                 list.ML(Icol) = max(list.ML(Icol), length(matrix.arg(Ipgh, Icol, Irow)));
                 end;
            end;
             end;
        if  sum(list.ML) + (list.Ncols-1)*3  > Loutput_line then
                        /* See if all rows will fit on a line.      */
                        /* Leave 2 spaces between columns.      */
             list.N = list.Nreal;
        else Sdoes_not_fit = FALSE;
        end;
         end;
    list.Ncols = list.Ncols + 1;            /* do-group decrements one too many.        */
    return;
\014
print_list_nnl: entry (Plist, Sprint_inhibit);

    if Sprint_inhibit then return;
    Pmatrix = addr(list.group);
    Pspaces = addr(SPACES);
    if length(list.title) > 0 then
         call ioa_ ("^a:", list.title);
    go to PRINT_LIST;


print_list: entry (Plist, Sprint_inhibit);      /* This entry point prints a list and its title.    */

    if Sprint_inhibit then return;
    Pmatrix = addr(list.group);         /* overlay arg list with 3-D matrix.        */
    Pspaces = addr(SPACES);
    if length(list.title) > 0 then
         call ioa_ ("^/^a:", list.title);
    else call iox_$put_chars(iox_$user_output, addr(NL), length(NL), 0);
PRINT_LIST:
    do Ipgh = 1 to list.Npghs;          /* Output paragraphs, one at a time.        */
         do Irow = 1 to list.Nrows;     /* Output rows, one at a time.      */
        line = "";
        do Icol = 1 to list.Ncols;
             line = line || matrix.arg (Ipgh, Icol, Irow);
             Lspaces = list.ML(Icol) - length(matrix.arg(Ipgh, Icol, Irow)) + 3;
             line = line || spaces;
             end;
        call ioa_ ("^a", line);
        end;
         end;
    return;
\014
output_list: entry (Plist, Apgh, Poutput, Loutput, Nlines);/* output 1 pgh of multipgh list into a string.  */

     dcl    Apgh            fixed bin,  /* Number of pgh to output.         */
    Poutput         ptr,        /* ptr to output string.            */
    Loutput         fixed bin,  /* length of output string.         */
    output          char(Loutput) based(Poutput),
    Nlines          fixed bin;  /* Lines in the output.         */

    Nlines = 0;
    Loutput = 0;
    Pmatrix = addr(list.group);
    Pspaces = addr(SPACES);
    Ipgh = Apgh;
    if Ipgh = 1 then                /* Output NL which would follow section title   */
         if length (list.title) > 0 then do; /* in a regular (non-made-up) section.      */
        call out (NL);
        Nlines = Nlines + 1;
        end;
    do Irow = 1 to list.Nrows;
         do Icol = 1 to list.Ncols;
        call outv (matrix.arg (Ipgh, Icol, Irow));
        Lspaces = list.ML(Icol) - length(matrix.arg(Ipgh, Icol, Irow)) + 3;
        call out(spaces);
        end;
         call out (NL);
         Nlines = Nlines + 1;
         end;
    return;
\014
out: proc (str);

     dcl    str         char(*);

    Loutput = Loutput + length(str);
    substr (output, Loutput-length(str)+1, length(str)) = str;

    end out;


outv: proc (str);

     dcl    str         char(*) var;

    Loutput = Loutput + length(str);
    substr (output, Loutput-length(str)+1, length(str)) = str;

    end outv;


    end format_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_arg_descriptions: procedure (Plist_cas, PDlinfo_, Plist_base,
                Sreally_old_format, Plists_of_args, Nlists_of_args);
                        /* This procedure builds a list of argument */
                        /* descriptions which match user-given arg names.   */

     dcl (Plist_cas, PDlinfo_, Plist_base)
                ptr,
    Sreally_old_format      bit(1),
    Plists_of_args (*)      ptr,
    Nlists_of_args      fixed bin;

     dcl    1 list_cas      aligned based(Plist_cas),
      2 header      like LIST.header,
      2 group (0 refer (list_cas.N))
                like LIST.group;
     dcl    1 Dlinfo_           aligned based (PDlinfo_),
                        /* structure defining all paragraphs (units) in */
                        /*   an entry point (logical info seg - linfo). */
      2 Nunits      fixed bin,  /*   number of units in this ep.        */
      2 Nsections       fixed bin,  /*   number of units beginning a section.   */
      2 unit (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;

     dcl    1 list_base     aligned based(Plist_base),
                        /* struc locating lists of things to be output. */
      2 N           fixed bin,  /*   number of output lists now allocated.  */
      2 Nmax            fixed bin,  /*   max number of list ptrs allocatable.   */
      2 Ispace_used_set     fixed bin,  /*   index of last list on which space used set.    */
      2 Plists (0 refer(list_base.Nmax))
                ptr;        /*   ptrs to allocated lists.           */
                        /*   unit (paragraph) descriptors.      */
     dcl    1 list_args     aligned based(Plist_args),
      2 header      like LIST.header,
      2 group (0 refer (list_args.N))
                like LIST.group;
     dcl    Plist_args      ptr,
    Ppgh            ptr,
    Lpgh            fixed bin,
    Largs           fixed bin,
    args            char(Largs) based(Ppgh),
    pgh         char(Lpgh) based (Ppgh),
    pgh_char (Lpgh)     char(1)    based(Ppgh);

     dcl    Iunit           fixed bin,
    DO_LINE         label local,
    Sconsecutive_arg_lines  bit(1) aligned,
    Sold_format     bit(1) aligned,
         (i, j, k, l)       fixed bin;
\014
    Nlists_of_args = 0;
    list_cas.Snot_found(*) = 1;
    do Iunit = 1 to Dlinfo_.Nunits;
         if Dlinfo_.unit(Iunit).S.arg_list then do;
        if Dlinfo_.unit(Iunit).S.scn then do;
             if Nlists_of_args > 0 then
            if list_args.N = 0 then
                 list_args.title = Dlinfo_.unit(Iunit).title;
            else go to NEXT_LIST;
             else do;
NEXT_LIST:      if Nlists_of_args >= dimension(Plists_of_args,1) then;
            else do;
                 Nlists_of_args = Nlists_of_args + 1;
                 Plist_args, Plists_of_args(Nlists_of_args) = get_list (Plist_base);
                 list_args.title = Dlinfo_.unit(Iunit).title;
                 end;
            end;
             end;
        Ppgh = Dlinfo_.unit(Iunit).Pstart;
        Lpgh = Dlinfo_.unit(Iunit).L;
        i = index(pgh, "
 ");                        /* Old format if some pgh lines don't begin  w/ SP*/
        if i = 0 then
             Sold_format = TRUE;
        else Sold_format = Sreally_old_format;
        DO_LINE = SKIP_LINE;
        do while (Lpgh > 0);     /* Search pgh for arguments.            */
             i = index(pgh, NL);        /* skip blank lines & lines starting with HT SP.    */
             if i > 0 then
            j = verify(substr(pgh,1,i), "    
");
             if  ((i > 0) & (j = 0))  |  (index ("    ", pgh_char(1)) > 0)  then do;
            Sconsecutive_arg_lines = FALSE;
            end;
             else if Sold_format then do;   /* Add arg to list iff it is a control_arg. */
            if pgh_char(1) ^= "-" then go to DO_LINE;
            if i = 0 then i = Lpgh; /* arg name line must begin with -      */
            Largs = index(substr(pgh,1,i), "  ");
            k = index(substr(pgh,1,i), "    ");
            if  (Largs^=0)  &  (k^=0)  then
                 Largs = min(Largs, k);
                        /* arg name ends when first double SP is found, */
            if Largs = 0 then do;   /*   or with first HT or SP char.       */
                 Largs = search(substr(pgh,1,i), "   ");
                 if Largs = 0 then do;  /* No SP/HT in line?  Forget it.        */
                DO_LINE = SKIP_LINE;
                go to SKIP_LINE;
                end;
                 k = index(substr(pgh,1,i), ",");
                 if k = 0 then;     /* Does line contain  a comma?      */
                 else if k = Largs-1 then
                Largs = Largs + search(substr(pgh,Largs+1, i-Largs),"    ");
                        /* Yes, look for "-long, -lg "      */
                 else do;       /* Yes, look for "-pathname path, -pn path "    */
                l = Largs + search(substr(pgh,Largs+1,i-Largs), "    ");
                if  l ^= Largs  &  k = l-1  then do;
                     k = l + search(substr(pgh,l+1,i-l),"    ");
                     if k ^= l then do;
                    l = k + search(substr(pgh,k+1,i-k),"     ");
                    if l ^= k then Largs  = l;
                    end;
                     end;
                end;
                 end;
            do k = 1 to list_cas.N while (index(args, list_cas.arg(k))=0);
                 end;
            if k <= list_cas.N then do;
                 list_cas.Snot_found(k) = 0;
                 DO_LINE = KEEP_LINE;
                 end;
            else DO_LINE = SKIP_LINE;
            end;
             else do;           /* arg name is entire line.         */
            if i = 0 then i = Lpgh;
            k = index(pgh, "  ");
            if k ^= 0 then if k < i then 
                 Largs = k-1;
            else Largs = i-1;
            if  substr(args, Largs, 1) = ","  &  i<Lpgh  then
                 Largs = Largs + index(substr(pgh,i+1, Lpgh-i), NL);
                        /* If arg name line ends with  , then assume it */
                        /* it is continued on next line.        */
            do k = 1 to list_cas.N while (index(args,list_cas.arg(k))=0);
                 end;
            if k <= list_cas.N then do;
                 list_cas.Snot_found(k) = 0;
                 DO_LINE = KEEP_LINE;
                 Largs = length(rtrim(args, "    
"));
                 end;
            else DO_LINE = SKIP_LINE;
            end;
             go to DO_LINE;

KEEP_LINE:       list_args.N = list_args.N + 1;
             if i = 0 then Largs = Lpgh;
             else Largs = i - 1;
             list_args.arg(list_args.N) = args;
SKIP_LINE:       if i = 0 then Lpgh = 0;
             else if i = Lpgh then Lpgh = 0;
             else do;
            Ppgh = addr(pgh_char(i+1));
            Lpgh = Lpgh - i;
            end;
END_LOOP:            end;
        end;
         end;
    if Nlists_of_args > 0 then           /* May have unused list.  If so, free it.   */
         if list_args.N = 0 then do;
        list_base.N = list_base.N - 1;
        Nlists_of_args = Nlists_of_args - 1;
        end;
    if sum(list_cas.Snot_found) > 0 then do; /* Any control arg names given by user unmatched?   */
         if Nlists_of_args = 0 then do;
        Nlists_of_args = Nlists_of_args + 1;
        Plist_args, Plists_of_args(Nlists_of_args) = get_list (Plist_base);
        list_args.title = "NO MATCH FOR " || list_cas.title || " STRINGS";
        end;
         else do;
        list_args.N = list_args.N + 1;
        list_args.arg(list_args.N) = "";
        list_args.N = list_args.N + 1;
        list_args.arg(list_args.N) = "NO MATCH FOR " || list_cas.title || " STRINGS:";
        end;
         do k = 1 to list_cas.N;
        if list_cas.Snot_found(k) > 0 then do;
             list_args.N = list_args.N + 1;
             list_args.arg(list_args.N) = "  ";
             list_args.arg(list_args.N) =
            list_args.arg(list_args.N) || list_cas.arg(k);
             end;
        end;
         end;

    end get_arg_descriptions;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_arg_list: procedure (unit, Plist, Sreally_old_format);  /* This procedure builds a list of arguments.   */

     dcl    1 unit          aligned like Dlinfo.unit,
    Plist           ptr,        /* ptr to space for arg list.           */
    Sreally_old_format      bit(1);     /* on if info segs contains \006 chars.     */

     dcl    1 list          aligned based(Plist),
      2 header      like LIST.header,
      2 group (0 refer (list.N)) like LIST.group;
     dcl    Ppgh            ptr,
    Lpgh            fixed bin,
    Sconsecutive_arg_lines  bit(1) aligned, /* on if info seg is in new format, and if  */
                        /* previous line of pgh was arg line ending with    */
                        /* a comma.             */
    Sold_format     bit(1) aligned, /* on if info seg is old or really old.     */
         (i, j, k, l)       fixed bin,
    pgh         char(Lpgh) based (Ppgh),
    pgh_char (Lpgh)     char(1)    based(Ppgh);

    Ppgh = unit.Pstart;             /* address the paragraph.           */
    Lpgh = unit.L;
    i = index (pgh, "
   ");  if i = 0 then               /* Check for old format info segs.      */
         Sold_format = TRUE;
    else Sold_format = Sreally_old_format;
    do while (Lpgh > 0);         /* search pgh for arguments.            */
         i = index(pgh, NL);            /* skip blank lines.            */
         if i > 0 then
        j = verify(substr(pgh,1,i), "    
");
         if  ((i > 0) & (j = 0))  |  (index ("    ", pgh_char(1)) > 0) then do;
                        /* skip line beginning with SP or HT.       */
        Sconsecutive_arg_lines = FALSE;
SKIP_LINE:  if i = 0 then Lpgh = 0;
        else if i = Lpgh then Lpgh = 0;
        else do;
             Ppgh = addr(pgh_char(i+1));
             Lpgh = Lpgh - i;
             end;
        end;
         else if Sold_format then do;       /* add arg to list if it is control arg.    */
        if pgh_char(1) ^= "-" then  go to SKIP_LINE;
        if i = 0 then i = Lpgh;     /* arg name line must begin with -      */
        j = index(substr(pgh,1,i), "  ");   /* arg name ends when first double SP is found, */
        k = index(substr(pgh,1,i), "    "); /*   or with first HT char.         */
        if  (j^=0)  &  (k^=0)  then
             j = min(j,k);
        if j = 0 then do;           /*   If no double SP, ends with first SP char.  */
             j = search(substr(pgh,1,i), "   ");
             if j = 0 then          /* If no SP or HT, forget it.           */
            go to SKIP_LINE;
             k = index(substr(pgh,1,i), ",");   /* Does comma immediately precede SP/HT?    */
             if k = 0 then;         /* No. We've found arg.         */
             else if k = j-1 then       /* Yes, look for  "-long, -lg "     */
            j = j + search(substr(pgh,j+1, i-j), "   ");
             else do;           /* Comma found in  line.            */
            l = j + search(substr(pgh,j+1,i-j), "    ");
            if  l ^= j  &  k = l-1  then do;
                 k = l + search(substr(pgh,l+1,i-l),"    ");
                 if k ^= l then do; /* Look for "-pathname path, -pn path ".    */
                l = k + search(substr(pgh,k+1,i-k),"     ");
                if l ^= k then j  = l;
                end;
                 end;
            end;
             end;
        list.N = list.N + 1;
        list.arg(list.N) = " ";
        list.arg(list.N) = list.arg(list.N) || substr(pgh,1,j-1);
        if length(list.arg(list.N)) > 18 then do;
             k =index(list.arg(list.N), ",");
             if k > 0 then do;
            list.N = list.N + 1;
            list.arg(list.N) = "    ";
            k = k + 1;
            k = (k-1) + verify(substr(list.arg(list.N-1),k), " ");
            list.arg(list.N) = list.arg(list.N) || substr(list.arg(list.N-1),k);
            list.arg(list.N-1) = rtrim(substr(list.arg(list.N-1),1,k-1));
            end;
             end;
        go to SKIP_LINE;
        end;

         else do;               /* add arg line to list.            */
        if i = 0 then i = Lpgh;
        k = index(pgh, "  ");
        if k ^= 0 then if k < i then i = k-1;
        j, list.N = list.N + 1;     /* arg is everything on the line.       */
        if Sconsecutive_arg_lines then
             list.arg(j) = "    ";
        else list.arg(j) = " ";
        list.arg(j) = list.arg(j) || rtrim(substr (pgh, 1, i), "     
");
        if substr(list.arg(j), length(list.arg(j)), 1) = "," then
             Sconsecutive_arg_lines = TRUE;
        else if length(list.arg(j)) > 18 then do;
             k =index(list.arg(j), ",");
             if k > 0 then do;
            j, list.N = list.N + 1;
            list.arg(j) = "    ";
            k = k + 1;
            k = (k-1) + verify(substr(list.arg(j-1),k), " ");
            list.arg(j) = list.arg(j) || substr(list.arg(j-1),k);
            list.arg(j-1) = rtrim(substr(list.arg(j-1),1,k-1));
            end;
             end;
        go to SKIP_LINE;
        end;
         end;

    end get_arg_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_brief_data: proc (Sold_format, Sheader, PDlinfo_, Plist_base, dir, ent, Nlast_info_no_brief_data,
          Iinfo, Ninfos_printed, Iunit_syntax, Nunit_syntax, Nlists_of_bf_args, Nlines);

     dcl    Sold_format     bit(1) unal,    /* on if log info contains \006 chars.      */
    Sheader         bit(1) unal,    /* on if -header required.          */
    PDlinfo_            ptr,        /* ptr to pgh descriptors of log info.      */
    Plist_base      ptr,        /* ptr to list of lists.            */
    dir         char(168) unal, /* dir part of phys info seg's path.        */
    ent         char(32) unal,  /* ent part of phys info seg's path.        */
    Nlast_info_no_brief_data    fixed bin,  /* Last info processed not containing Syntax sect.*/
    Iinfo           fixed bin,  /* number of the info seg being processed.  */
    Ninfos_printed      fixed bin,  /* number of infos for which something printed. */
    Iunit_syntax (10)       fixed bin,  /* indices of Syntax sections.      */
    Nunit_syntax        fixed bin,  /* count of Syntax sections.            */
    Nlists_of_bf_args       fixed bin,  /* count of sections containing args/ctl_args.  */
        Nlines          fixed bin;

     dcl    1 Dlinfo_           aligned based(PDlinfo_),
      2 Nunits      fixed bin,  /* number of units (pghs) in this log info seg. */
      2 Nsections       fixed bin,  /* number of units having section title.    */
      2 unit (0 refer (Dlinfo_.Nunits))
                like Dlinfo.unit;

     dcl    Iunit           fixed bin,
    Plist           ptr,
    Sfound          bit(1) aligned,
         (i, j)         fixed bin;

     dcl    1 list_base     aligned based(Plist_base),
      2 N           fixed bin,  /* number of lists in this list ptr structure.  */
      2 Nmax            fixed bin,  /* max possible number of lists in structure.   */
      2 Ispace_used_set     fixed bin,  /* index of last list on which space used was set.*/
      2 Plists (0 refer (list_base.Nmax))
                ptr;        /* pointers to list structures.     */

     dcl    1 list          aligned based(Plist),
      2 header      like LIST.header,
      2 group (0 refer (list.N))    like LIST.group;

    if Sold_format then                 /* Be sure "Syntax" section(s) exist.             */
         do Iunit = 1 to Dlinfo_.Nunits while (Dlinfo_.unit(Iunit).title ^= "Usage");
        end;
    else do Iunit = 1 to Dlinfo_.Nunits
        while (substr(Dlinfo_.unit(Iunit).title, 1,
                min(6, length(Dlinfo_.unit(Iunit).title))) ^= "Syntax");
         end;                                   /*   Search for the "Syntax" section.             */
    if Iunit > Dlinfo_.Nunits then do;           /*   Tell user if not found.                      */
         call ioa_ ("^[^v/^;^s^]No brief info available for ^[^a^[>^]^;^2s^]^a.",
        ((Ninfos_printed > 1)  &  help_args.Sctl.bf  &  (Nlast_info_no_brief_data ^= Iinfo-1)),
             help_args.Lspace_between_infos,
        Sheader,  dir, dir^=">", ent);
         Nlast_info_no_brief_data = Iinfo;
         return;
         end;
\014
    do i = 1 to dimension(Iunit_syntax,1) while (Iunit <= Dlinfo_.Nunits);
         Iunit_syntax(i) = Iunit;               /* Find & record location of syntax sections.     */
         Nunit_syntax = i;
         do Iunit = Iunit, Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit(Iunit).S.scn);
        Nlines = Nlines + Dlinfo_.unit(Iunit).Nlines + 1;
        end;                            /* Count lines in each pgh of Syntax section.     */
                            /* Add 1 line for blank line preceding each pgh.  */
         if ^Sold_format then
        do Iunit = Iunit to Dlinfo_.Nunits
             while (substr(Dlinfo_.unit(Iunit).title, 1,
                    min(6, length(Dlinfo_.unit(Iunit).title))) ^= "Syntax");
             end;
         else Iunit = Dlinfo_.Nunits + 1;
         end;

    Iunit = 1;
    do while(Iunit <= Dlinfo_.Nunits);           /* Search for "Arguments" & "Control arguments"   */
                            /*   paragraphs to summarize these arguments.     */
         do Iunit = Iunit to Dlinfo_.Nunits while (^Dlinfo_.unit(Iunit).S.arg_list);
        end;                            /* These units were flagged by                    */
         if Iunit <= Dlinfo_.Nunits then do;     /*   parse_entry_point_into_units.                */
        Plist = get_list (Plist_base);
        if Plist = null() then
             Iunit = Dlinfo_.Nunits + 1;
        else do;
             list.title = Dlinfo_.unit(Iunit).title;
             list.Iunit = Iunit;
             if length(list.title) <= 17 then do;
            list.N = 1;
            list.arg(1) = list.title;
            list.arg(1) = list.arg(1) || ":";
            end;            /* Put title on same line as arg names, unless  */
                        /* title is too long.           */
             do Iunit = Iunit, Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit(Iunit).S.scn);
            call get_arg_list (Dlinfo_.unit(Iunit), Plist, Sold_format);
            end;
             if  list.N > 0  &  list.title = "Arguments"  then do;
                        /* Suppress Arguments list if all arg names */
                        /* appear in Syntax section.            */
            if list.arg(1) = "Arguments:" then
                 i = 2;
            else i = 1;
            Sfound = TRUE;
            do i = i to list.N while(Sfound);
                 do j = 1 to Nunit_syntax while(Sfound);
                Ppgh = Dlinfo_.unit(Iunit_syntax(j)).Pstart;
                Lpgh = Dlinfo_.unit(Iunit_syntax(j)).L;
                if index (pgh, ltrim(rtrim(list.arg(i), ", "))) = 0 then
                     Sfound = FALSE;
                end;
                 end;
            if Sfound then list.N = 0;
            end;
             if list.N = 1 then
            if list.title = substr(list.arg(1),1,length(list.arg(1))-1) then
                 list.N = 0;
\014
             if list.N > 0 then do;
            if list.title = substr(list.arg(1),1,length(list.arg(1))-1) then
                 list.title = "";
            call format_list (Plist, 0, 1);
            if list.Nrows < 3 then do;
                 do i = 2 by 1 while (i <=list.N);
                if length(list.arg(i)) > 4 then
                if substr(list.arg(i),1,4) = "    " then do;
                     list.arg(i-1) = list.arg(i-1) || " ";
                     list.arg(i-1) = list.arg(i-1) || substr(list.arg(i),5);
                     do j = i+1 to list.N;
                    list.arg(j-1) = list.arg(j);
                    end;
                     list.N = list.N - 1;
                     end;
                end;
                 call format_list (Plist, 0, 1);
                 end;
            Nlines = Nlines + list.Nrows + 1;
            if length(list.title) > 0 then
                 Nlines = Nlines + 1;
            end;
             else list_base.N = list_base.N - 1;
             end;
        end;
         end;
         Nlists_of_bf_args = list_base.N;
    return;


print_brief_data: entry (PDlinfo_, Sheader, Plist_base, Iunit_syntax, Nunit_syntax, Nlists_of_bf_args);

         j = 1;             /* For -brief, print Syntax section and list of */
         do i = 1 to Nunit_syntax;      /* ctl args in order that their sections appear */
PRINT_NEXT_LIST:    if j <= Nlists_of_bf_args then do;   /* in the info.             */
             Plist = list_base.Plists(j);   /*   Print lists of args.           */
             if list.Iunit < Iunit_syntax(i) then do;
            call print_list (Plist, FALSE);
            j = j + 1;
            go to PRINT_NEXT_LIST;
            end;
             end;
        do Iunit = Iunit_syntax(i), Iunit+1 to Dlinfo_.Nunits while(^Dlinfo_.unit(Iunit).S.scn);
             if  j = 1  &  Iunit = Iunit_syntax(1)  &  Ninfos=1  &  ^Sheader  then
            call print_pgh_nnl (Dlinfo_.unit(Iunit), FALSE);
             else call print_pgh (Dlinfo_.unit(Iunit), FALSE);
             end;               /* Print syntax sections.           */
        end;
         do j = j to Nlists_of_bf_args;     /* Print remaining lists of ctl args.       */
        call print_list (list_base.Plists(j), FALSE);
        end;
    if Nlists_of_bf_args > 0 then do;
         Pnext_free_space = list_base.Plists(1);
         list_base.N = 0;
         end;
    return;
\014
brief_data_ok: entry (Sold_format, Sheader, PDlinfo_, dir, ent, Iinfo, Ninfos_printed, 
          Nlast_info_no_brief_data) returns(bit(1) aligned);

    if Sold_format then                 /* Be sure "Syntax" section(s) exist.             */
         do Iunit = 1 to Dlinfo_.Nunits while (Dlinfo_.unit(Iunit).title ^= "Usage");
        end;
    else do Iunit = 1 to Dlinfo_.Nunits
        while (substr(Dlinfo_.unit(Iunit).title, 1,
                min(6, length(Dlinfo_.unit(Iunit).title))) ^= "Syntax");
         end;                                   /*   Search for the "Syntax" section.             */
    if Iunit > Dlinfo_.Nunits then do;           /*   Tell user if not found.                      */
         call ioa_ ("^[^v/^;^s^]No control argument info available for ^[^a^[>^]^;^2s^]^a.",
        ((Ninfos_printed > 1)  &  help_args.Sctl.ca  &  (Nlast_info_no_brief_data ^= Iinfo-1)),
             help_args.Lspace_between_infos,
        Sheader,  dir, dir^=">", ent);
         Nlast_info_no_brief_data = Iinfo;
         return (FALSE);
         end;
    return(TRUE);

    end get_brief_data;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_ep_list: procedure (ref_name, PDeps_, Plist);   /* Create list of entry points in this phys. seg.   */

     dcl    ref_name            char(32) varying,
         (PDeps_, Plist)        ptr;

     dcl    1 Deps_         aligned based(PDeps_),
      2 Nlines      fixed bin,
      2 N           fixed bin,
      2 linfo (0: 0 refer (Deps_.N)) like Deps.linfo;
     dcl    1 list          aligned based(Plist),
      2 header      like LIST.header,
      2 group (0 refer (list.N))    like LIST.group;
     dcl (i, j, k)          fixed bin;

    do i = 1 to Deps.N;             /* Build list of all entry point info headers.  */
         k, list.N = list.N + 1;
         if length(Deps_.linfo(i).header) > 0 then do;/* If header already exists, use it.       */
        list.arg(k) = Deps_.linfo(i).header;
        if length(list.arg(k)) > 21 then do; /* Split a long heading into several lines. */
             j = 20 + index (substr(list.arg(k),21), " ");
             do while (j > 20);
            k, list.N = list.N + 1;
            list.arg(k) = "   ";
            j = j + verify(substr(list.arg(k),j), " ");
            list.arg(k) = list.arg(k) || substr(list.arg(k-1), j);
            list.arg(k-1) = rtrim(substr(list.arg(k-1),1,j-1));
            if length(list.arg(k)) > 21 then
                 j = 20 + index(substr(list.arg(k),21), " ");
            else j = 0;
            end;
             end;
        end;
         else do;               /* If doesn't exist, make one up.       */
        list.arg(k) = ref_name;
        list.arg(k) = list.arg(k) || "$";
        list.arg(k) = list.arg(k) || Deps_.linfo(i).ep_name(1);
        do j = 2 to Deps_.linfo(i).Nep_names;
             list.arg(k) = list.arg(k) || ",";
             k, list.N = list.N + 1;
             list.arg(k) = "   ";
             list.arg(k) = list.arg(k) || ref_name;
             list.arg(k) = list.arg(k) || "$";
             list.arg(k) = list.arg(k) || Deps_.linfo(i).ep_name(j);
             end;
        Deps_.linfo(i).header = list.arg(k);    /* Apply fruits of our labor by using header    */
                        /* in entry point info as well.     */
        end;
         end;

    end get_ep_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_list: procedure (Plist_base) returns(ptr);      /* This procedure allocates a new list in   */
                        /*   the help_args segment.         */

     dcl    Plist_base      ptr;

     dcl    1 list_base     aligned based(Plist_base),
      2 N           fixed bin,  /* number of lists in this list ptr structure.  */
      2 Nmax            fixed bin,  /* max possible number of lists in structure.   */
      2 Ispace_used_set     fixed bin,  /* index of last list on which space used was set.*/
      2 Plists (0 refer (list_base.Nmax))
                ptr,        /* pointers to list structures.     */
    Plist           ptr,
    1 list          aligned based(Plist),
      2 header      like LIST.header,
      2 group (0 refer (list.N))    like LIST.group;

    if list_base.N = dimension(list_base.Plists,1) then
         return(null);              /* list of lists full.  Oops!           */
    if list_base.Ispace_used_set > list_base.N then
         list_base.Ispace_used_set = 0;
    if list_base.Ispace_used_set < list_base.N-1 then
         return(null);              /* someone forgot to set space used for a list  */
                        /* other than the last in  list of lists.   */
    if list_base.Ispace_used_set = list_base.N-1 then do;
         Plist = list_base.Plists(list_base.N); /* set space used for last list.        */
         Pnext_free_space = set_space_used(Pnext_free_space, currentsize(list));
         list_base.Ispace_used_set = list_base.N;
         end;
    list_base.N = list_base.N + 1;      /* get new list.                */
    Plist = Pnext_free_space;
    list_base.Plists(list_base.N) = Plist;
    list.N = 0;
    list.Nreal  = 0;
    list.title = "";
    return(Plist);

    end get_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_list_base: procedure (Pnext_free_space, space_used, Nmax) returns (ptr);

     dcl    Pnext_free_space        ptr,        /* ptr to next free word of space in temp seg.  */
    space_used      fixed bin(21),  /* number of words used at that free word loc.  */
    Nmax            fixed bin,  /* number of lists to maintain in list of lists.    */
    Plist_base      ptr;        /* ptr to creates list of lists.        */

     dcl    1 list_base     aligned based(Plist_base),
      2 N           fixed bin,  /* number of lists in this list ptr structure.  */
      2 Nmax            fixed bin,  /* max possible number of lists in structure.   */
      2 Ispace_used_set     fixed bin,  /* index of last list on which space used was set.*/
      2 Plists (0 refer (list_base.Nmax))
                ptr;        /* pointers to list structures.     */

    if space_used ^= 0 then         /* set space used by previous allocation.   */
         Pnext_free_space = set_space_used (Pnext_free_space, space_used);
    Plist_base = Pnext_free_space;      /* get list of lists.           */
    list_base.N = 0;                /* No lists listed yet.         */
    list_base.Ispace_used_set = 0;
    list_base.Nmax = Nmax;
    if Nmax > 0 then             /* Size known?  Set space used.     */
         Pnext_free_space = set_space_used (Pnext_free_space, currentsize(list_base));
    return(Plist_base);

    end get_list_base;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_title_list: procedure (PDlinfo_, Plist, Iunit_start );  /* This entry builds a list of titles.      */

     dcl    PDlinfo_            ptr,
    Plist           ptr,
        Iunit_start     fixed bin;  /* Current unit number.  Get title of following */
                        /* units.                   */

     dcl    Iunit           fixed bin,
    Nlines          fixed bin,
    Nlines_pic      pic "zzzzz9",
         (i, j, k)          fixed bin;
     dcl    1 Dlinfo_           aligned based (PDlinfo_),
                        /* structure defining all paragraphs (units) in */
                        /*   an entry point (logical info seg - linfo). */
      2 Nunits      fixed bin,  /*   number of units in this ep.        */
      2 Nsections       fixed bin,  /*   number of units beginning a section.   */
      2 unit (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;
                        /*   unit (paragraph) descriptors.      */
     dcl    1 list          aligned based(Plist),
      2 header      like LIST.header,
      2 group (0 refer (list.N)) like LIST.group;

    do Iunit = Iunit_start+1 to Dlinfo_.Nunits;
         if  Dlinfo_.unit(Iunit).S.scn  |  Iunit = 1  then do;
        k, list.N = list.N + 1;
        if  Iunit = 1  &  ^Dlinfo_.unit(1).S.scn  then
             list.arg(k) = "UNTITLED";
        else list.arg(k) = Dlinfo_.unit(Iunit).title;
        if length(list.arg(k)) > 21 then do; /* Split a long section title into several lines.   */
             j = 20 + index (substr(list.arg(k),21), " ");
             do while (j > 20);
            k, list.N = list.N + 1;
            list.arg(k) = "   ";
            j = j + verify(substr(list.arg(k),j), " ");
            list.arg(k) = list.arg(k) || substr(list.arg(k-1), j);
            list.arg(k-1) = rtrim(substr(list.arg(k-1),1,j-1));
            if length(list.arg(k)) > 21 then
                 j = 20 + index(substr(list.arg(k),21), " ");
            else j = 0;
            end;
             end;
        Nlines = Dlinfo_.unit(Iunit).Nlines;    /* Count lines in  section.         */
        do i = Iunit+1 to Dlinfo_.Nunits while(^Dlinfo_.unit(i).S.scn);
             Nlines = Nlines + Dlinfo_.unit(i).Nlines + 2;
             end;
        Iunit = i - 1;
        Nlines_pic = Nlines;
        list.arg(k) = list.arg(k) || " (";
        list.arg(k) = list.arg(k) || ltrim(Nlines_pic);
        list.arg(k) = list.arg(k) || ")";
        end;
         end;
\014
    if list.N = 0 then do;
         list.N = 1;
         list.arg(1) = "NO MORE TITLES";
         end;

    end get_title_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


parse_answer: proc (answer, op, ep_name, ca, scn, srh);

     dcl    answer          char(500) varying,
    op          fixed bin,  /* Operation specified by the answer.       */
    ep_name         char(65) varying,   /* Name of entry point given  in ep request.    */
    1 ca            aligned,
      2 header      like LIST.header,
      2 group (100)     like LIST.group,
    1 scn           aligned,
      2 header      like LIST.header,
      2 group (100)     like LIST.group,
    1 srh           aligned,
      2 header      like LIST.header,
      2 group (100)     like LIST.group;


     dcl (i, j, k)          fixed bin,
    operation           char(12) varying,
    operand         char(89) varying;

    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* The tables below define the following combinations of answers and control args.  */
    /*                                  */
    /*    OP_CODE OPERATION   OP_CODE OPERATION   OP_CODE OPERATION         */
    /*   1  yes, y   7  skip, s 14  entry_point {STR}       */
    /*   2  no, n        8  skip -scn       ep {STR}            */
    /*   3  quit, q  9  skip -ep    15  section {STRs}          */
    /*   4  top, t  10  skip -rest      scn {STRs}          */
    /*   5  rest, r 11  skip -seen      sc {STRs}         --obsolete--  */
    /*   6  rest -scn   12  title       16  section {STRs} -top     */
    /*              titles      scn {STRs} -top         */
    /*          13  title -top      sc {STRs} -top    --obsolete--  */
    /*              titles -top                 */
    /*                                  */
    /*  17  search {STRs}           19  brief               */
    /*      srh {STRs}              bf              */
    /*      sh {STRs}   --obsolete--        20  control_arg STRs        */
    /*  18  search {STRs} -top          ca STRs         */
    /*      srh {STRs} -top         21  .               */
    /*      sh {STRs} -top   --obsolete--   22  ?               */
    /*                  23  header          */
    /*                      he              */
    /*                                  */
    /* -scn is the short name for -section.  Both are accepted.             */
    /* sc is obsolete short name for section.  It is still accepted, but -sc is not accept  */
    /*  as control arg in help requests.  It is accepted in command line, however.  */
    /* sh is obsolete short name for search.   It is still accepted.            */
    /* titles is in error, but is a ccommon error for the title request.  Accept it anyway. */
    /* -ep  is the short name for -entry_point.  Both are accepted.         */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
\014
     dcl    defined_ops (30)        char(11) varying int static options(constant) init (
                     "yes",  "y", "no",   "n",  /*  1 to  4 */
                     "quit", "q", "top",  "t",  /*  5 to  8 */
                     "rest", "r", "skip", "s",  /*  9 to 12 */
                     "title", "titles",     /* 13 &  14 */
                     "entry_point", "ep",       /* 15 &  16 */
                     "section", "scn", "sc",        /* 17 to 19 */
                     "search",  "srh", "sh",        /* 20 to 22 */
                     "brief",   "bf",       /* 23 &  24 */
                     "control_arg", "ca",       /* 25 &  26 */
                     ".", "?", "header", "he"), /* 27 to 30 */
    op_code (30)        fixed bin int static options(constant) init(
                      1,  1,  2,  2,  3,
                      3,  4,  4,  5,  5,
                      7,  7, 12, 12, 14,
                     14, 15, 15, 15, 17,
                     17, 17, 19, 19, 20,
                     20, 21, 22, 23, 23); 

    k = 0;                  /* No search  or section operands processed yet.    */
    ca.N = 0;                   /* Control_args must be given  with every ca req.   */
    ep_name = "";
    i = search (answer, "   ");     /* Find end of request name in answer.      */
    if i = 0 then i = length(answer)+1;
    operation = substr(answer,1,i-1);       /* Request name is our operation.       */
    if length(operation) > maxlength(defined_ops(1)) then do;
RESPONSE_UNKNOWN:
         call ioa_$nnl ("Response unknown:  ^a.  ", substr(answer,1,i-1));
ERROR:       op = hbound(parse_operand,1) + 1;      /* Error op code.               */
         return;
         end;
    else if length(operation) = 0 then go to ERROR; /* Just reask question for blank lines.     */
    do j = 1 to dimension(defined_ops,1) while (operation ^= defined_ops(j));
         end;                   /* See if operation defined.            */
    if j > dimension(defined_ops,1) then go to RESPONSE_UNKNOWN;
                        /* No?  Report the error.           */
\014
    op = op_code(j);
    if i >= length(answer) then          /* Remainder of answer is operands.     */
         answer = "";
    else answer = ltrim(substr(answer,i), "  ");    /* Trim leading SP HT from operands.        */
    do while(length(answer) > 0);            /* Process operands.            */
         i = search (answer, "  ");
         if i = 0 then i = length(answer)+1;
         operand = substr(answer,1,i-1);
         go to parse_operand(op);

parse_operand(5):                   /* rest                 */
         if  operand = "-section"  |  operand = "-scn"  then
        op = op + 1;
         else go to BAD_OPERAND;
         go to NEXT_OPERAND;

parse_operand(7):                   /* skip                 */
         if  operand = "-section"  |  operand = "-scn"  then
        op = op + 1;
         else if  operand = "-entry_point"  |  operand = "-ep"  then
        op = op + 2;
         else if  operand = "-rest"  |  operand = "-r"  then
        op = op + 3;
         else if  operand = "-seen"  then
        op = op + 4;
         else go to BAD_OPERAND;
         go to NEXT_OPERAND;

parse_operand(12):                  /* title                    */
         if  operand = "-top"  |  operand = "-t"  then
        op = op + 1;
         else go to BAD_OPERAND;
         go to NEXT_OPERAND;
\014
parse_operand(14):                  /* entry_point or ep            */
         if k > 0 then do;
        call ioa_ ("Only one entry point name can be given in  ^a  response.", operation);
        go to ERROR;
        end;
         if length(operand) > maxlength(ep_name) then do;
        call ioa_ ("Entry point name  ^a  is too long.", operand);
        go to ERROR;
        end;
         ep_name = operand;
         k = 1;
         go to NEXT_OPERAND;

parse_operand(15):                  /* section              */
         if  operand = "-top"  |  operand = "-t"  then
        op = op + 1;
         else do;
parse_operand(16):                  /* section -top             */
        if length(operand) > maxlength(scn.group(1).arg) then do;
             Lcount = 38;       /* 38 = length("Operand    of    response is too long.");   */
             Snl1 = (Lcount + i + length(operation) > Loutput_line);
             call ioa_$nnl ("Operand  ^a^[^/^]  of  ^a  response is too long.  ",
            substr(answer,1,i-1), Snl1, operation);
             go to ERROR;
             end;
        if k = dimension (scn.group, 1) then do;
             call ioa_$nnl ("More than ^d substrings given with  ^a  response.  ",
            dimension(scn.group,1), operation);
             go to ERROR;
             end;
        k, scn.N = k + 1;
        scn.arg(k) = operand;
        end;
         go to NEXT_OPERAND;

parse_operand(17):                  /* search                   */
         if  operand = "-top"  |  operand = "-t"  then
        op = op + 1;
         else do;
parse_operand(18):                  /* search -top              */
        if length(operand) > maxlength(srh.group(1).arg) then do;
             Lcount = 38;       /* 38 = length("Operand    of    response is too long.");   */
             Snl1 = (Lcount + i + length(operation) > Loutput_line);
             call ioa_$nnl ("Operand  ^a^[^/^]  of  ^a  response is too long.  ",
            substr(answer,1,i-1), Snl1, operation);
             go to ERROR;
             end;
        if k = dimension (srh.group, 1) then do;
             call ioa_$nnl ("More than ^d substrings given with  ^a  response.  ",
            dimension(srh.group,1), operation);
             go to ERROR;
             end;
        k, srh.N = k + 1;
        srh.arg(k) = operand;
        end;
         go to NEXT_OPERAND;
\014
parse_operand(20):                  /* control_arg STRs             */
         if length(operand) > maxlength(ca.group(1).arg) then  do;
             Lcount = 38;       /* 38 = length("Operand    of    response is too long.");   */
             Snl1 = (Lcount + i + length(operation) > Loutput_line);
             call ioa_$nnl ("Operand  ^a^[^/^]  of  ^a  response is too long.  ",
            substr(answer,1,i-1), Snl1, operation);
        go to ERROR;
        end;
         if k = dimension (ca.group, 1) then do;
        call ioa_$nnl ("More than  ^d  substrings given with  ^a  response.  ",
             dimension(ca.group, 1), operation);
        go to ERROR;
        end;
         k, ca.N = k + 1;
         ca.arg(k) = operand;
         go to NEXT_OPERAND;

parse_operand(1):                   /* yes                  */
parse_operand(2):                   /* no                   */
parse_operand(3):                   /* quit                 */
parse_operand(4):                   /* top                  */
parse_operand(19):                  /* brief                    */
parse_operand(21):                  /* . (= print "help")           */
parse_operand(22):                  /* ? (= list requests)          */
parse_operand(23):                  /* header                   */
         call ioa_$nnl ("^a  response does not allow operands.  ", operation);
         go to ERROR;

parse_operand(6):                   /* rest -scn                */
parse_operand(8):                   /* skip -scn                */
parse_operand(9):                   /* skip -ep             */
parse_operand(10):                  /* skip -rest               */
parse_operand(11):                  /* skip -seen               */
parse_operand(13):                  /* title -top               */
         call ioa_$nnl ("Invalid combination of operands for  ^a  response.  ", operation);
         go to ERROR;

BAD_OPERAND:   call ioa_$nnl ("Operand  ^a  invalid for  ^a  operation.  ", operand, operation);
         go to ERROR;

NEXT_OPERAND:  if i >= length(answer) then
        answer = "";
         else answer = ltrim (substr(answer,i), "    ");
         end;                   /* Strip leading HT SP from next operand.   */
    if op = 20 then             /* control_arg STRs             */
         if ca.N = 0 then do;
        call ioa_$nnl ("Substrings must be given with the  ^a  response.  ", operation);
        op = hbound(parse_operand,1) + 1;
        end;

    end parse_answer;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


parse_entry_point_into_units: procedure (linfo, Pcommon_units, Ncommon_units, PDlinfo_);
                        /* This procedure parses an entry point (logical    */
                        /*   info segment) into units (paragraphs). */
     dcl    1 linfo         aligned like Deps.linfo,
    Pcommon_units       ptr,
    Ncommon_units       fixed bin,
    PDlinfo_            ptr;        /* ptr to descriptors for this log info seg.    */

     dcl    1 Dlinfo_           aligned based(PDlinfo_),
      2 Nunits      fixed bin,  /* number of units (pghs) in this log info seg. */
      2 Nsections       fixed bin,  /* number of units having section title.    */
      2 unit (0 refer (Dlinfo_.Nunits))
                like Dlinfo.unit;

dcl 1 common_units (Ncommon_units)aligned based(Pcommon_units) like Dlinfo.unit;

     dcl    Iunit           fixed bin,
         (Lline1, Lline2, Lline3)   fixed bin,
         (Llseg, Lpgh)      fixed bin(21),
         (Pline1, Pline2, Pline3)   ptr,
         (Plseg, Ppgh)      ptr,
         (i, j, k)          fixed bin;

     dcl    line1           char(Lline1) based(Pline1),
    line2           char(Lline2) based(Pline2),
    line3           char(Lline3) based(Pline3),
    lseg            char(Llseg) based(Plseg),
    lseg_char   (Llseg)     char(1)     based(Plseg),
    pgh         char(Lpgh)  based(Ppgh),
    pgh_char (Lpgh)     char(1)     based(Ppgh);
\014
    Dlinfo_.Nunits = 0;
    Dlinfo_.Icommon_unit = 0;
    Dlinfo_.Nsections = 0;
    linfo.PDlinfo = PDlinfo_;
    Plseg = linfo.Pstart;
    Llseg = linfo.L;
    if linfo.S.old_format then
         go to OLD_FORMAT;          /* parse an old-format info segment.        */
    do while (Llseg > 0);            /* parse into units until log info seg exhausted.   */
         i = verify (lseg, "     
");                     /* check for pgh containing HT SP NL.       */
         if i = 0 then Llseg = 0;           /* stop if remaining part of log info seg   */
                        /*   consists of these chars.           */
         else do;
        i = verify (lseg, "  ");        /* strip blank lines from start of pgh.     */
        do while (i > 0);
             if lseg_char(i) = NL then do;
            Plseg = addr(lseg_char(i+1));
            Llseg = Llseg - i;
            i = verify (lseg, "  ");
            end;
             else i = 0;
             end;
        i = index(lseg, "


");                     /* find beginning of next pgh (<NL><NL><NL>). */
        Pline1, Ppgh = Plseg;       /* address this pgh.            */
        if i = 0 then do;           /* this is last pgh of log info seg.        */
             Lpgh = Llseg;
             Llseg = 0;
             end;
        else do;                /* next pgh found.              */
             Lpgh = i;          /* i is index relative to start of this     */
                        /*   pgh.  Save length of this pgh.     */
             Plseg = addr(lseg_char(i+1));  /* First NL of <NL><NL><NL> is in this pgh.   */
             Llseg = Llseg - i;
             end;
        j, Dlinfo_.Nunits = Dlinfo_.Nunits + 1; /* Fill in unit descriptor for this pgh.    */
        Dlinfo_.unit(j).title  = "";
        Dlinfo_.unit(j).Pstart = Ppgh;
        Dlinfo_.unit(j).L      = Lpgh;
        Dlinfo_.unit(j).Nlines = 0;
        Dlinfo_.unit(j).S      = FALSE;
        Dlinfo_.unit(j).Icommon_unit = 0;
\014

        Lline1 = index(pgh, NL);        /* See if pgh begins new section (has title).   */
        k = index (reverse(line1), ":");    /* Title ends with LAST : on 1st line of pgh.   */
        if k > 0 then do;
             k = Lline1 - (k-1);        /*   Get char index of last colon in  line. */
             Dlinfo_.unit(j).title = ltrim(rtrim(substr(line1,1,k-1), "  "), "   ");
             Dlinfo_.unit(j).Pstart = addr(pgh_char(k+1));
             Dlinfo_.unit(j).L      = Dlinfo_.unit(j).L - k;
             Dlinfo_.unit(j).S.scn = TRUE;
             Dlinfo_.Nsections = Dlinfo_.Nsections + 1;

                        /* Is section an arg_list section?      */
             if length(Dlinfo_.unit(j).title) >= 16 then
            if substr(Dlinfo_.unit(j).title,1,16) = "Control argument"  |
               substr(Dlinfo_.unit(j).title,1,16) = "Control Argument"  |
               substr(Dlinfo_.unit(j).title,1,8)  = "Argument"  |
               substr(Dlinfo_.unit(j).title,1,8)  = "List of "  then
                 Dlinfo_.unit(j).S.arg_list = TRUE;
            else;
             else if length(Dlinfo_.unit(j).title) >= 8 then
            if substr(Dlinfo_.unit(j).title,1,8) = "Argument"  |
               substr(Dlinfo_.unit(j).title,1,8) = "List of "  then
                 Dlinfo_.unit(j).S.arg_list = TRUE;
             end;
        else if j > 1 then           /* propagate arg_list finding to all pghs of sect.*/
             if Dlinfo_.unit(j-1).S.arg_list then
            Dlinfo_.unit(j).S.arg_list = TRUE;
        do while (Lpgh > 0);     /* Count lines in pgh.          */
             Dlinfo_.unit(j).Nlines = Dlinfo_.unit(j).Nlines + 1;
             i = index(pgh, NL);
             if i = 0 then Lpgh = 0;
             else do;
            if i < Lpgh then
                 Ppgh = addr(pgh_char(i+1));
            Lpgh = Lpgh - i;
            end;
             end;
        end;
         end;

    if Ncommon_units > 0 then do;            /* Add common units onto end of entry point part.   */
         i = Dlinfo_.Nunits + 1;
         Dlinfo_.Nunits = Dlinfo_.Nunits + Ncommon_units;
         addr(Dlinfo_.unit(i))->common_units = common_units;
         end;

                        /* Compute line count of entry point part.  */
    linfo.Nlines = sum(Dlinfo_.unit.Nlines) + (Dlinfo_.Nunits-1)*2;
    if length(linfo.header) > 0 then linfo.Nlines = linfo.Nlines + 2;
    return;
\014

OLD_FORMAT:
    i = verify(lseg, "   
");                     /* strip off HT NL SP chars.            */
    if i = 0 then
         Llseg = 0;
    else do;                    /* process the first unit.          */
         Plseg = addr(lseg_char(i));
         Llseg = Llseg - (i-1);
         Llseg = length(rtrim(lseg, "    
"));                        /* Remove trailing SP HT NL \006 chars.     */
         Dlinfo_.Nunits = 1;
         Dlinfo_.unit(1).Nlines = 0;
         Dlinfo_.unit(1).S      = FALSE;
         Dlinfo_.unit(1).Icommon_unit = 0;
         i = index(lseg, NL);           /* See if first line contains section title.    */
         if i = 0 then i = Llseg + 1;
         j = index(substr(lseg,1,i-1), ":");
         if j > 0 then do;           /* It does.             */
        Dlinfo_.unit(1).title  = substr(lseg,1,j-1);
        Dlinfo_.unit(1).Pstart = addr(lseg_char(j+1));
        Dlinfo_.unit(1).S.scn  = TRUE;
        Plseg = addr(lseg_char(j+1));
        Llseg = Llseg - j;
        end;
         else do;
        Dlinfo_.unit(1).title  = "";
        Dlinfo_.unit(1).Pstart = Plseg;
        end;
         Dlinfo_.unit(1).L = Llseg;     /* store interim length for now.        */
         Iunit = 0;
         end;
    do while( Iunit = 0  |  Llseg > 0);      /* parse old-format info seg into units (pghs). */
         Iunit = Iunit + 1;         /* process the next unit.           */
         Ppgh = Plseg;
         i = index(lseg, OLD_HELP_PGH_CHAR);
         if i = 0 then i = Llseg + 1;
         if  (i >= Llseg)  then do;      /* this is last pgh of log info seg.        */
        Lpgh = Llseg - 1;
        Lpgh = length(rtrim(lseg, "  
"));                        /* strip HT NL SP off end of unit.      */
        Llseg = 0;
        Dlinfo_.unit(Iunit).L = Lpgh;
        end;
         else do;               /* next pgh found.              */
        Dlinfo_.Nunits = Dlinfo_.Nunits + 1;
        Dlinfo_.unit(Iunit+1).S = FALSE;
        Dlinfo_.unit(Iunit+1).Icommon_unit = 0;
        Lpgh = i - 1;
        i = index(reverse(pgh), NL);        /* address last 3 lines of pgh.     */
        j = index(reverse(substr(pgh,1,Lpgh-i)),NL);
        if j > 0 then do;
             j = j + i;
             k = index(reverse(substr(pgh,1,Lpgh-j)),NL);
             if k = 0 then k = Lpgh+1-j;
             end;
        else k = 0;
        if k > 0 then do;
             k = k + j;
             Pline1 = addr(pgh_char(Lpgh-k+2));
             Lline1 = k-j-1;
             end;
        else do;
             Pline1 = Ppgh;
             Lline1 = 0;
             end;
        if j > 0 then do;
             Pline2 = addr(pgh_char(Lpgh-j+2));
             Lline2 = j-i-1;
             end;
        else do;
             Pline2 = Ppgh;
             Lline2 = 0;
             end;
        Pline3 = addr(pgh_char(Lpgh-i+2));
        Lline3 = i - 1;
        if Lpgh+1 < Llseg then       /* address units following the current unit.    */
             Plseg = addr(lseg_char(Lpgh+2));
        Llseg = Llseg - (Lpgh+1);
        if Llseg <= 0 then           /* Check for empty next pgh.            */
             Llseg, Lline1, Lline2, Lline3 = 0;
        if length(ltrim(line3,"  ")) > 0 & /* Section title on line containing PGH char. */
           length(ltrim(line2,"  ")) = 0 then do;
            Dlinfo_.unit(Iunit+1).title = ltrim(rtrim(line3,"    :"), "  ");
            Dlinfo_.unit(Iunit+1).S.scn = TRUE;
            Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
            Lpgh = Lpgh - (j-1);
            end;
        else if length(ltrim(line3,"     ")) = 0 & 
                length(ltrim(line2,"     ")) > 0 & 
                length(ltrim(line1,"     ")) = 0 then do;
                        /* Section title on line preceding PGH char.    */
            Dlinfo_.unit(Iunit+1).title = ltrim(rtrim(line2,"    :"), "  ");
            Dlinfo_.unit(Iunit+1).S.scn = TRUE;
            Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
            Lpgh = Lpgh - (k-1);
            end;
        else do;                /* No section title preceding PGH char.     */
             i = verify(lseg, "  
");          if i = 0 then do;      /* Next pgh is empty.  Forget about it. */
            Llseg = 0;
            Dlinfo_.Nunits = Dlinfo_.Nunits - 1;
            end;
             else do;           /* Ignoring any SP HT NL chars at pgh head, */
            Pline1 = addr(lseg_char(i));    /* see if a title is in 1st line of next pgh.   */
            Lline1 = Llseg - (i-1);
            j = index(line1, NL);
            if j > 0 then
                 Lline1 = j - 1;
            Lline1 = index(line1, ":");
            if Lline1 > 0 then do;
                 Dlinfo_.unit(Iunit+1).title = ltrim(rtrim(line1,"   :"), "  ");
                 Dlinfo_.unit(Iunit+1).S.scn = TRUE;
                 Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
                 if Lline1+1+(i-1) < Llseg then
                Plseg = addr(lseg_char(Lline1+2+(i-1)));
                 Llseg = Llseg - (Lline1+1) - (i-1);
                 end;
            else Dlinfo_.unit(Iunit+1).title = "";
            end;
             end;
        end;
         if Dlinfo_.unit(Iunit).S.scn then
        i = 0;              /* Strip HT SP off pghs not starting a section. */
         else i = verify(pgh,NL);           /* Strip NL off other sections.     */
         if i > 1 then do;
        Ppgh = addr(pgh_char(i));
        Lpgh = Lpgh - (i-1);
        end;
         i = verify(reverse(pgh), "  
");                     /* Strip HT SP NL from end of pgh.      */
         Pline1 = addr(pgh_char(Lpgh-(i-2)));
         Lline1 = (i-1);
         k = index(line1, NL);
         if k = 0 then
        Lpgh = Lpgh - (i-1);
         else Lpgh = Lpgh - (i-1) + k;
         Dlinfo_.unit(Iunit).Pstart = Ppgh;
         Dlinfo_.unit(Iunit).L      = Lpgh;
         Dlinfo_.unit(Iunit).Nlines = 0;
         if Dlinfo_.unit(Iunit).S.scn then do;
        i = index(Dlinfo_.unit(Iunit).title, BS_underscore);
        do while (i > 0);            /* Remove underscoring from title of old info seg.*/
             if i+2 <= length(Dlinfo_.unit(Iunit).title) then
            Dlinfo_.unit(Iunit).title =
                 substr(Dlinfo_.unit(Iunit).title,1,i-1) ||
                 substr(Dlinfo_.unit(Iunit).title,i+2);
             else Dlinfo_.unit(Iunit).title =
                 substr(Dlinfo_.unit(Iunit).title,1,i-1);
             i = index(Dlinfo_.unit(Iunit).title, BS_underscore);
             end;
        i = index(Dlinfo_.unit(Iunit).title, underscore_BS);
        do while (i > 0);
             if i+2 <= length(Dlinfo_.unit(Iunit).title) then
            Dlinfo_.unit(Iunit).title =
                 substr(Dlinfo_.unit(Iunit).title,1,i-1) ||
                 substr(Dlinfo_.unit(Iunit).title,i+2);
             else Dlinfo_.unit(Iunit).title =
                 substr(Dlinfo_.unit(Iunit).title,1,i-1);
             i = index(Dlinfo_.unit(Iunit).title, underscore_BS);
             end;

                        /* Check for an arg_list section.       */
        if length(Dlinfo_.unit(j).title) >= 8 then
             if substr(Dlinfo_.unit(Iunit).title,1,8) = "Argument" then
            Dlinfo_.unit(Iunit).S.arg_list = TRUE;
             else if length(Dlinfo_.unit(Iunit).title) >= 16 then
            if substr(Dlinfo_.unit(Iunit).title,1,16) = "Control argument"  | 
               substr(Dlinfo_.unit(Iunit).title,1,16) = "Control Argument" then
                 Dlinfo_.unit(Iunit).S.arg_list = TRUE;
        end;
         else if Iunit > 1 then          /* propagate arg_list finding to all pghs of sect.*/
        if Dlinfo_.unit(Iunit-1).S.arg_list then
             Dlinfo_.unit(Iunit).S.arg_list = TRUE;

                        /* Count lines in  the pgh.         */
         do while (Lpgh > 0);
              Dlinfo_.unit(Iunit).Nlines = Dlinfo_.unit(Iunit).Nlines + 1;
              i = index(pgh, NL);
              if i = 0 then Lpgh = 0;
              else do;
             if i < Lpgh then
            Ppgh = addr(pgh_char(i+1));
             Lpgh = Lpgh - i;
             end;
              end;
         end;

                        /* Compute line count of log. info.     */
    linfo.Nlines = sum(Dlinfo_.unit.Nlines) + (Dlinfo_.Nunits-1)*2;
    if length(linfo.header) > 0 then linfo.Nlines = linfo.Nlines + 2;

    end parse_entry_point_into_units;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


parse_info_into_entry_points: procedure (APseg, ALseg, PDeps_);
                        /* Parse logical info into 1 or more entry points   */

     dcl    APseg           ptr,        /* ptr to logical info. (Input)     */
    ALseg           fixed bin(21),  /* length of logical info (in chars). (In)  */
    PDeps_          ptr;        /* ptr to entry points structure to be filled in.   */

     dcl (Llseg, Lseg)      fixed bin(21),
    Lline           fixed bin,
         (Plseg, Pseg)      ptr,
    code            fixed bin(35),
    i           fixed bin(21),
         (j, k)         fixed bin;

     dcl    line            char(Lline) based (Plseg),
    seg         char(Lseg) based(Pseg),
    seg_char (Lseg)     char(1)    based(Pseg),
    lseg            char(Llseg) based(Plseg),
    lseg_char   (Llseg)     char(1)     based(Plseg);

     dcl    1 Deps_         aligned based(PDeps_),
      2 Nlines      fixed bin,
      2 N           fixed bin,
      2 linfo (0: 0 refer (Deps_.N)) like Deps.linfo;

    Pseg = APseg;               /* Address the logical info segment.        */
    Lseg = ALseg;
    Deps_.N = -1;               /* At least 1 entry point will be found.    */
    Deps_.Nlines = 0;               /* No lines counted yet in logical info.    */
    i = index(seg, "


:Entry:");                  /* Search for 1st log info seg divider.     */
    do while(Lseg > 0);              /* record info about log. info seg.     */
         Plseg = Pseg;
         Deps_.N, j = Deps_.N + 1;
         Deps_.linfo(j).Nep_names = 0;
         if  (i = 0)  &  (j = 0)  then do;      /* This info has no :Entry: lines.      */
        Llseg = Lseg;
        Lseg = 0;
        i = verify (lseg, "  
");                     /* Strip off leading SP HT NL chars.        */
        if i = 0 then do;
             Deps_.N = Deps_.N - 1;     /* Empty entry.             */
             go to END_ENTRIES;
             end;
        else if i > 1 then do;
             Plseg = addr(lseg_char(i));
             Llseg = Llseg - (i-1);
             end;
        end;
\014
         else do;
        if i = 0 then do;           /* This is last entry point in the info.    */
             Llseg = Lseg;
             Lseg = 0;
             end;
        else do;                /* One of other entry points in the info.   */
             Llseg = i;
             Pseg = addr(seg_char(i+10));   /* 10 = length("<NL><NL><NL>:Entry:")     */
             Lseg = Lseg - (i+9);
             end;
        Lline = index(lseg, NL);        /* Search for entry names in :Entry: line.  */
        if Lline = 0 then do;
             Deps_.N = Deps_.N - 1;     /*   Nothing left of :Entry: line.      */
             go to END_ENTRIES;
             end;
        i = index(line, ":");       /* Look for : ending first entry point name.    */
        do while (i > 0);            /* Sample line looks like:          */
                        /* :Entry: rs: rsnnl: 05/25/78 ioa_$rs, ioa_$rsnnl*/
             k, Deps_.linfo(j).Nep_names = Deps_.linfo(j).Nep_names+1;
             if k <= dim(Deps_.linfo.ep_name, 2) then
            Deps_.linfo(j).ep_name(k) = ltrim(rtrim(substr(line,1,i), "  :"), "  ");
             Plseg = addr(lseg_char(i+1));  /* Skip over name and :         */
             Llseg = Llseg - i;
             Lline = Lline - i;
             i = index(line, ":");
             end;
        if  (j > 0)  &  (Deps_.linfo(j).Nep_names = 0)  then do;
             Deps_.N = Deps_.N - 1;     /* All but common info must have entry point    */
             go to NEXT_ENTRY;      /* names.  But look!            */
             end;               /* No names!  Can never read this info via help */
        i = verify(lseg, "   
");                     /* Strip off HT SP NL from start of info    */
        if i = 0 then do;           /* Nothing in info!  Forget about it.       */
             Deps_.N = Deps_.N - 1;
             go to NEXT_ENTRY;
             end;
        else if i > 1 then do;
             Plseg = addr(lseg_char(i));
             Llseg = Llseg - (i-1);
             end;
        end;
\014
         Deps_.linfo(j).Pstart  = Plseg;
         Deps_.linfo(j).L       = Llseg;
         Deps_.linfo(j).Nlines  = 0;
         Deps_.linfo(j).S       = "0"b;
         Lline = index(lseg, NL);           /* header is first line of log. info seg.   */
         if Lline >= Llseg then do;      /* header is only line of file.     */
        Deps_.linfo(j).header = "";
        Deps_.linfo(j).date    = 0;
        end;
         else if lseg_char(Lline+1) = NL then do;   /* header line must be followed by 1 blank line,    */
                        /* at least.                */
        Deps_.linfo(j).header = substr(lseg,1,Lline-1);
                        /* Remainder should be an entry point name. */
        Deps_.linfo(j).Pstart = addr(lseg_char(Lline+1));
        Deps_.linfo(j).L      = Llseg - Lline;  /* Remove header from logical info.     */
        i = search(substr(lseg,1,Lline), "   ");
        if i = 0 then
             Deps_.linfo(j).date    = 0;
        else do;
             call convert_date_to_binary_ (substr(line,1,i-1), Deps_.linfo(j).date, code);
             if code ^= 0 then      /* No date!             */
            Deps_.linfo(j).date = 0;
             end;
        end;
         else do;
        Deps_.linfo(j).header = "";
        Deps_.linfo(j).date    = 0;
        end;
         if index(lseg, OLD_HELP_PGH_CHAR) > 0 then  /* check old format info segs with \006 chars   */
        Deps_.linfo(j).S.old_format = TRUE;
NEXT_ENTRY:    i = index(seg, "


:Entry:");
         end;
END_ENTRIES:

    end parse_info_into_entry_points;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


print_header: proc ();              /* This procedure prints a regular heading line.    */

     dcl    Lcount          fixed bin,
    Linfo_name      fixed bin,
    Lpath           fixed bin;
     dcl    case            fixed bin;
     dcl    line            char(256) varying;

    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Output heading line before other info.  The heading spans at least 2 lines, and has  */
    /* the form:                                */
    /*  pathname   (line counts)                        */
    /*  info_name:  info_title                      */
    /*                                  */
    /* where all parts but the info_title are optional.             */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if help_args.Sctl.he_counts then do;        /* Do following only if line/entry counts wanted.   */
         if Deps.N = 0 then         /*   No subroutine entry points.        */
        if Nlines >=  Deps.linfo(0).Nlines then  /*     Only 1 paragraph.            */
             case = 1;
        else case = 2;          /*     Multiple paragraphs.         */
         else do;               /*   Subroutine entry points.           */
        if Iep = 0 then         /*     Subroutine introduction.     */
             if Nlines >= Deps.linfo(0).Nlines then
            case = 3;           /*       Only 1 paragraph.          */
             else case = 4;         /*       Multiple paragraphs.           */
        else                /*     A subroutine entry point.        */
             if Deps.N = 1 then     /*       Only 1 entry point.            */
            if Nlines >= Deps.linfo(Iep).Nlines then
                 case = 5;      /*   Only 1 paragraph.          */
            else case = 6;      /*   Multiple paragraphs.       */
             else               /*       Multiple entry points.     */
            if Nlines >= Deps.linfo(Iep).Nlines then
                 case = 7;      /*   Only 1 paragraph.          */
            else case = 8;      /*   Multiple paragraphs.       */
        end;
         go to FORM(case);

FORM(1):         call ioa_$rsnnl ("^d line^[s^] in info", line, 0,
        Nlines, (Nlines > 1));
         go to END_FORM;

FORM(2):         call ioa_$rsnnl ("^d ^[lines follow^;line follows^];  ^d in info", line, 0,
        Nlines, (Nlines > 1), Deps.linfo(Iep).Nlines);
         go to END_FORM;

FORM(3):         call ioa_$rsnnl ("^d line^[s^] in introduction;  ^d lines, ^d entry point^[s^] in info", line, 0,
        Nlines, (Nlines > 1), Deps.Nlines, Deps.N, (Deps.N > 1));
         go to END_FORM;
\014
FORM(4):         call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in introduction;  ^d lines, ^d entry point^[s^] in info",
        line, 0, Nlines, (Nlines > 1),  Deps.linfo(Iep).Nlines, Deps.Nlines, Deps.N, (Deps.N > 1));
         go to END_FORM;

FORM(5):         call ioa_$rsnnl ("^d line^[s^] in entry point", line, 0, Nlines, (Nlines > 1));
         go to END_FORM;

FORM(6):         call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in entry point", line, 0,
        Nlines, (Nlines > 1), Deps.linfo(Iep).Nlines);
         go to END_FORM;

FORM(7):         call ioa_$rsnnl ("^d line^[s^] in entry point;  ^d lines, ^d other entry point^[s^] in info",
        line, 0, Nlines, (Nlines > 1), Deps.Nlines, (Deps.N-1), (Deps.N-1 > 1));
         go to END_FORM;

FORM(8):         call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in entry point;  ^d lines, ^d other entry point^[s^] in info",
        line, 0, Nlines, (Nlines > 1), Deps.linfo(Iep).Nlines,
        Deps.Nlines, (Deps.N-1), (Deps.N-1 > 1));

END_FORM:        Lcount =length(line);
         end;
    else Lcount = 0;

    if help_args.Sctl.he_pn then do;        /* Compute length of pathname for heading.  */
         Lpath = length(rtrim(Dinfo_seg_.dir)) + length(rtrim(Dinfo_seg_.ent)) + length("   ");
         if Dinfo_seg_.dir ^= ">" then Lpath = Lpath + 1;
         end;
    else Lpath = 0;

    if help_args.Sctl.he_info_name then do;     /* If info_name to be output, compute its length    */
         Linfo_name = length(rtrim(Dinfo_seg_.info_name));
         if Linfo_name > 0 then          /* + colon + 2 spaces.          */
        Linfo_name = Linfo_name + length(":  ");
         end;
    else Linfo_name = 0;
    
    if  Lpath>0  &  Lcount>0  then
         if  Lpath+Lcount <= Loutput_line  then
        ISnl3 = 2;
         else ISnl3 = 1;
    else ISnl3 = 3;
    
    if Lpath + Lcount > 0 then
         Snl1 = TRUE;
    else Snl1 = FALSE;

    if Linfo_name + length(Deps.linfo(Iep).header) >= 0 then
         Snl2 = TRUE;
    else Snl2 = FALSE;
    
    call ioa_$nnl ("^[^v/^;^s^]^[^a^[>^]^a^;^3s^]^[^/^;   ^;^]^[(^a)^;^s^]^[^/^]^[^a:  ^;^s^]^a^[^/^]",
        (Ninfos_printed > 1),            /* For all but the first info printed,      */
        help_args.Lspace_between_infos, /*   output spaces between infos.       */
         help_args.Sctl.he_pn,          /* Put pathname into heading.           */
        Dinfo_seg_.dir, (Dinfo_seg_.dir ^= ">"), Dinfo_seg_.ent, 
         ISnl3,
         help_args.Sctl.he_counts,      /* Put line/entry point count into heading. */
        line,               /*   Description formulated above.      */
         Snl1,
         (Linfo_name > 0),           /*Put info_name into heading.           */
        Dinfo_seg_.info_name,
         Deps.linfo(Iep).header,            /* Heading line of info or entry point.     */
         Snl2);

    return;
    
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


print_header_only: entry;               /* Print header for an info.            */

    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
    /*                                  */
    /* Output a special-format info heading line when only heading lines are being output.  */
    /* The idea is for the headings to occupy as few lines as possible.         */
    /*                                  */
    /* The heading line has the form:                       */
    /*  pathname   info_name:  info_title   (line counts)               */
    /*                                  */
    /* where all fields but info_title are optional.                    */
    /*                                  */
    /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

         if help_args.Sctl.he_pn then do;
        Lpath = length(rtrim(Dinfo_seg_.dir)) + length(rtrim(Dinfo_seg_.ent)) + length("   ");
        if Dinfo_seg_.dir ^= ">" then Lpath = Lpath + 1;
        end;                /* If pathname to be output, compute length of  */
         else Lpath = 0;            /* path + 3 spaces.             */

         if help_args.Sctl.he_info_name then do;    /* If info_name to be output, compute length of */
        Linfo_name = length(rtrim(Dinfo_seg_.info_name));
        if Linfo_name > 0 then       /* info_name + colon + 2 spaces.        */
             Linfo_name = Linfo_name + length(":  ");
        end;
         else Linfo_name = 0;
         
         if help_args.Sctl.he_counts then do;   /* If line/entry point counts to be output, */
        if Dinfo_seg_.Scross_ref then       /* compute length of appropriate format + 3 spaces*/
             Lcount = length("   (another version)");
        else if Deps.N = 0 then
             Lcount = length("   (9999 lines in info)");
        else if Iep = 0 then
             Lcount = length("   (9999 lines, 999 entries in info)");
        else Lcount = length("   (9999 lines, 999 other entries in info)");
        end;
         else Lcount = 0;

         if Lpath + Linfo_name + length(Deps.linfo(Iep).header) + Lcount <= Loutput_line then do;
        Snl1 = FALSE;           /* Compute if heading must be broken into several   */
        Snl2 = FALSE;           /* lines.  Break points are after pathname and  */
        end;                /* before line/entry counts.            */
         else if Lpath + Linfo_name + length(Deps.linfo(Iep).header) <= Loutput_line then do;
        Snl1 = FALSE;
        Snl2 = TRUE;
        end;
         else if Linfo_name + length(Deps.linfo(Iep).header) + Lcount <= Loutput_line then do;
        Snl1 = TRUE;
        Snl2 = FALSE;
        end;
         else do;
        Snl1 = (Lpath > 0);
        Snl2 = (Lcount > 0);
        end;
\014         
         call ioa_ ("^[^a^[>^]^a^;^3s^]^[^/^]   ^[^a:  ^;^s^]^a^[
^]^[   ^[(another version)^;(^d line^[s^]^[, ^[^d^s^;^s^d other^] ^[entries^;entry^]^;^4s^] in info)^]^]",
                        /* Output long heading line.            */
        help_args.Sctl.he_pn,
             Dinfo_seg_.dir, Dinfo_seg_.dir^=">", Dinfo_seg_.ent,
        Snl1,
        Linfo_name > 0,
             Dinfo_seg_.info_name,
        Deps.linfo(Iep).header,     /* Output the  entry point heading.     */
        Snl2,
        help_args.Sctl.he_counts,
             Dinfo_seg_.Scross_ref,     /* Second occurence of info in another dir. */
             Deps.Nlines, (Deps.Nlines > 1), /* Output line count for all entry points.  */
             ((Deps.N > 0) & (Iep = 0)) | (Deps.N > 1),
                        /* Output count of entry points.        */
            (Iep = 0),      /*   Looking at common part.  Output info about */
                        /*   all entry points.          */
                 Deps.N,
                 Deps.N-1,      /*   Looking at entry point.  Output info about */
                        /*   other entry points.            */
                 ((Iep = 0) & (Deps.N > 1)) | (Deps.N-1 > 1));

    end print_header;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


print_pgh_2nl: procedure (unit, Sprint_inhibit);        /* This procedure prints a paragraph.       */

     dcl    1 unit          aligned like Dlinfo.unit,
    Sprint_inhibit      bit(1) aligned;

     dcl    code            fixed bin(35);

     dcl    1 event_info        aligned,
      2 ev_chan     fixed bin(71),
      2 message     fixed bin(71),
      2 sender      bit(36),
      2 origin,
        3 dev_signal        bit(18) unal,
        3 ring      bit(18) unal,
      2 chan_index      fixed bin;

     dcl    1 wait_list     aligned int static,
      2 N           fixed bin,
      2 ev_chan (1)     fixed bin(71);

     dcl    1 write_status      aligned int static,
      2 ev_chan     fixed bin(71) init(0),
      2 output_pending      bit(1);

    if Sprint_inhibit then return;
    call ioa_ ("^/");
    go to PRINT_PGH;


print_pgh: entry (unit, Sprint_inhibit);

    if Sprint_inhibit then return;
    call ioa_ ("");


print_pgh_nnl: entry (unit, Sprint_inhibit);

    if Sprint_inhibit then return;
PRINT_PGH:
    if unit.S.scn then              /* Print section title, if any.     */
         call ioa_$nnl ("^a:", unit.title);
    call iox_$put_chars (iox_$user_output, unit.Pstart, unit.L, code);
    call iox_$control (iox_$user_output, "write_status", addr(write_status), code);
    if  (code = 0)  &  (write_status.output_pending)  then do;
                        /* Wait until output on user's terminal before  */
         wait_list.N = 1;           /* marking pgh seen.            */
         wait_list.ev_chan(1) = write_status.ev_chan;
         call ipc_$block (addr(wait_list), addr(event_info), code);
         end;
    unit.S.seen_by_user = TRUE;         /* Keep track of what we've seen.       */
    if unit.Icommon_unit > 0 then
         common_units(unit.Icommon_unit).S.seen_by_user = TRUE;

    end print_pgh_2nl;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


seen_pgh: proc (unit) returns (bit(1) aligned);     /* Returns TRUE if pgh has been seen by user.   */

     dcl    1 unit          aligned like Dlinfo.unit,
    Sseen           bit(1) aligned;

    if unit.Icommon_unit > 0 then
         Sseen = common_units(unit.Icommon_unit).S.seen_by_user;
    else Sseen = unit.S.seen_by_user;
    return (Sseen);

    end seen_pgh;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */





    end process_info_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


init: entry (procedure_name, search_list_name, search_list_ref_dir, Vrequired, Phelp_args, Acode);
      
     dcl    search_list_name        char(*),        /* Name of search list used in finding infos.   */
                        /*   (input)                */
    search_list_ref_dir     char(*),        /* Referencing dir used in  search rules.   */
                        /*   (input)                */
    Vrequired           fixed bin;  /* Required version of help_args structure. */
                        /*   (input)                */

     dcl    Parea           ptr,
    area            area (25000) based(Parea);

    if Vrequired ^= Vhelp_args_1 then do;
         Acode = error_table_$unimplemented_version;
         return;
         end;
    call get_temp_segment_ (procedure_name, Phelp_args, Acode);
    if Acode ^= 0 then              /* Obtain a temporary segment.      */
         Phelp_args = null;
    else do;
         help_args.version = Vhelp_args_1;      /* Initialize the help argument structure.  */
         string(help_args.Sctl) = "0"b;
         help_args.min_Lpgh = 4;
         help_args.max_Lpgh = 15;
         help_args.Lspace_between_infos = 2;
         help_args.min_date_time = -1;
         help_args.Npaths = 0;
         help_args.Ncas = 0;
         help_args.Nsrhs = 0;
         if search_list_name ^= "" then do;
        help_args.Nsearch_dirs = 1000;  /* Allow room for up to 1000 search dirs.   */
        Parea = set_space_used (Phelp_args, currentsize(help_args));
        area = empty();
        call search_paths_$get (search_list_name, sl_control_default, search_list_ref_dir, null, Parea,
             sl_info_version_1, sl_info_p, Acode);
        if Acode = 0 then do;
             help_args.Nsearch_dirs = sl_info.num_paths;
             if help_args.Nsearch_dirs > 0 then
            help_args.search_dirs(*) = sl_info.paths(*).pathname;
             end;
        else help_args.Nsearch_dirs = 0;
        end;
         else help_args.Nsearch_dirs = 0;
         call hcs_$truncate_seg (Phelp_args, currentsize(help_args), 0);
         end;
    return;
\014

%include sl_info;

%include sl_control_s;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
\014
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


term:  entry (procedure_name, Phelp_args, Acode);

    call release_temp_segment_ (procedure_name, Phelp_args, Acode);
    return;

    end help_;
\014



            list_help.pl1                   08/12/83  1303.1r   08/12/83  1136.7      113202



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


list_help:
lh:  procedure;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*                                  */
/*             Command to list names of "help" files:               */
/*                  if no args are given, a usage message is printed,           */
/*                  arguments are taken as "topics" to be searched for,     */
/*                  only names which contain one of the topics will be listed       */
/*                                  */
/* 0)          June 1974 by John W. Dean III MITIPC             */
/*                                  */
/* 1)          Modified October 1978 by Bernie S. Greenburg for new search facility etc.    */
/*                                  */
/* 2)          Implement [list_help] and add -absolute_pathname 06/11/80 S.Herbst   */
/*                                  */
/* 3)          Modified September, 1978 by Gary E. Johnson:             */
/*                 - increase printed output limit to 4092 characters           */
/*                 - no error message when empty dir encountered            */
/*                 - ignore ".info" suffix                  */
/*                 - allow multiple -pn arguments               */
/*                 - allow -brief on active function invocation         */
/*                 - implement case insensitivity                   */
/*                 - add -long control argument                                           */
/*                                  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*   LIST OF AUTOMATIC VARIABLES    */


declare  absp_sw bit (1),               /* -absolute_pathname specified */
         af_sw bit (1),             /* invoked as an active function */
        (alp, eptr, nptr) pointer,
         arglen fixed binary (21),
        (argptr, return_ptr) ptr,
         arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr) variable,
         brief bit (1),             /* controls output format */
         complain entry variable options (variable),
         code fixed bin (35),               /* general code variable */
         ecount fixed bin,
         entryname char (32) varying,
         xentryname char (32) varying,
\014
        (numpath, return_len) fixed binary,
         found bit (1),             /* topic found in file name */
        (i, iname, narg, nargs, nentry, nname) fixed bin,
         list_all bit (1),              /* -all option */
         link_target_type fixed binary (2),
         long_sw bit (1),               /* -long option */
         ndir fixed bin,                /* directory counter */
         ntopics fixed bin,             /* number of topics given as arguments */
         number_printed fixed bin,          /* number of files listed */
         outstring char (4092) varying,
         pn_flag bit (1);               /* user has specified the dir */

/* LIST OF BASED VARIABLES  */

declare  area area based (areap),
         arg char (arglen) based (argptr),
         return_arg char (return_len) varying based (return_ptr);

declare 1 entry (ecount) aligned based (eptr),
        2 type bit (2) unaligned,
        2 nnames fixed bin (15) unaligned,
        2 nindex fixed bin (17) unaligned,
         names (iname) char (32) based (nptr);

/*  LIST OF CONDITIONS */

declare  cleanup condition;

declare  absolute_pathname_ entry (char (*), char (*), fixed bin (35)),
         active_fnc_err_ entry options (variable),
         com_err_ entry options (variable),
         check_star_name_$path entry (char (*), fixed bin (35)),
         cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)),
         cu_$arg_list_ptr entry (pointer),
         cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
         cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
         get_system_free_area_ entry returns (pointer),
         hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
         hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
         fixed bin (35)),
         ioa_ entry options (variable),
         search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));


/*      LIST OF STATIC VARIABLES          */

declare  areap ptr int static init (null),
         error_table_$badopt fixed bin (35) external,   /* illegal control argument */
         error_table_$inconsistent fixed bin (35) external,
         error_table_$incorrect_access fixed bin (35) external,
         error_table_$noentry fixed bin(35) ext static,
         error_table_$nomatch fixed bin (35) external,
         error_table_$nostars fixed bin (35) external,
         error_table_$wrong_no_of_args fixed bin (35) external,
         myname char (32) options (constant) static init ("list_help"),
        (upper_case char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
         lower_case char (26) init ("abcdefghijklmnopqrstuvwxyz")) static options (constant);


declare (divide, index, length, null, rtrim, substr, translate) builtin;

/* initialization and argument handling */


    call cu_$af_return_arg (nargs, return_ptr, return_len, code);
    if code ^= 0 then do;
         af_sw = "0"b;
         complain = com_err_;
         arg_ptr = cu_$arg_ptr_rel;
    end;
    else do;
         af_sw = "1"b;
         complain = active_fnc_err_;
         return_arg = "";
         arg_ptr = cu_$af_arg_ptr_rel;
    end;

    call cu_$arg_list_ptr (alp);

BLOCK:  begin;
declare  user_dir (divide (nargs, 2, 17, 0)) char (168);    /* for user specified directory */
declare  topic (nargs) char (32) varying;       /* can't be more topics than arguments */

         numpath = 0;               /* for pathname count */
         list_all = "0"b;
         number_printed = 0;
         ntopics = 0;
         absp_sw = "0"b;
         pn_flag = "0"b;
         brief = af_sw;
         do narg = 1 to nargs;
        call arg_ptr (narg, argptr, arglen, code, alp);
        if index (arg, "-") = 1 then do;
             if arg = "-long" | arg = "-lg" then brief = "0"b;
             else if arg = "-brief" | arg = "-bf" then brief = "1"b;
             else if arg = "-a" | arg = "-all" then list_all = "1"b;
             else if arg = "-absolute_pathname" | arg = "-absp" then absp_sw = "1"b;
             else if arg = "-pathname" | arg = "-pn" then do;
            pn_flag = "1"b;
            narg = narg + 1;
            call arg_ptr (narg, argptr, arglen, code, alp);
                        /* get user specified dir path */

            if code ^= 0 then do;
                 call complain (code, myname, "
The -pn control argument must be followed by a pathname.");
                 return;
            end;
\014

            numpath = numpath + 1;
            call absolute_pathname_ (arg, user_dir (numpath), code);
                        /* get absolute path of dir */
            if code ^= 0 then do;
                 call complain (code, myname, "^a", arg);
                 return;
end_path:           end;
            call check_star_name_$path (user_dir (numpath), code);
            if code ^= 0 then do;
                 if code = 1 | code = 2 then code = error_table_$nostars;
                 else call complain (code, myname, "^a", arg);
                 return;
            end;
             end;
             else do;
BAD_OPT:            call complain (error_table_$badopt, myname, """^a""", arg);
            return;
             end;
        end;

        else do;
             ntopics = ntopics+1;
             topic (ntopics) = translate (arg, lower_case, upper_case);
        end;


         end;                   /* of arg getting loop */

         if ntopics > 0 then do;         /* both topics and -all in same command */
        if list_all then do;
             call complain (error_table_$inconsistent, myname, "
Topics cannot be specified with -all.");
             return;
        end;
         end;
         if af_sw then if ^brief then do;
        call complain (error_table_$badopt, myname, "
The -long control arg is not accepted for active function.");
        return;
         end;

         if ntopics = 0 then do;            /* ntopics=0 and -all not specified is wrong */
        if ^list_all then do;
             call complain (error_table_$wrong_no_of_args, myname, "
You must specify topics or use the -all control_arg.  For details, type,

     help lh");
             return;
        end;
         end;
\014

         areap = get_system_free_area_ ();      /* for allocating star info */
         sl_info_p = null;
         eptr, nptr = null;
         on cleanup begin;
        if sl_info_p ^= null then free sl_info in (area);
        call clean_up;
         end;

         if ^pn_flag then do;
        call search_paths_$get ("info_segments", sl_control_default,
             "", null, areap, sl_info_version_1, sl_info_p, code);
        if code ^= 0 then do;
             call complain (code, myname, "Getting search list for info segments.");
             return;
        end;
         end;


/* searching and printing of file names */

         if pn_flag then do ndir = 1 to numpath;    /* specified by -pn option */
        call scan_dir (user_dir (ndir));
         end;
                        /* default directories */
         else do ndir = 1 to sl_info.num_paths;
        call scan_dir (sl_info.pathname (ndir));
         end;

         if number_printed = 0 & ^af_sw then call ioa_ ("No files found.");
         if sl_info_p ^= null then free sl_info in (area);

         return;

         \014                   /* internal proc to do searching and listing */

scan_dir:        procedure (dirname);

declare  dirname char (168) parameter;

        call hcs_$star_ (dirname, "**.info", 3, areap, ecount, eptr, nptr, code);
                        /* use "**" to avoid duplication of effort */
                        /* get all segs and links in specified dir */
        if code ^= 0 then do;       /* problem getting info */
             if code ^= error_table_$nomatch then do;
            call complain (code, myname, "Listing files in ^a.", dirname);

            return;
             end;
        end;
\014

        do nentry = 1 to ecount;        /* scan all entries */
             if entry.type (nentry) = "10"b then go to NEXT_ENTRY; /* ignore directories */
             iname = entry.nindex (nentry);
             if entry.type (nentry) = "00"b then do;
            call hcs_$status_minf (dirname, names(iname), 1, link_target_type,
                 0, code);
            if code = error_table_$noentry then go to NEXT_ENTRY;
            else if code = error_table_$incorrect_access then go to NEXT_ENTRY;
            else if code ^= 0 then do;
                 call complain (code, myname, "^a^[>^]^a",
                dirname, dirname ^= ">", names (iname));
                 go to NEXT_ENTRY;
            end;
            if link_target_type = 00b | link_target_type = 10b then go to NEXT_ENTRY;
             end;
             nname = 1;         /* nname is the number+1 of names with ".info" */
             found = list_all;      /* no topics matched for this seg yet */
             do nname = 1 to entry.nnames (nentry);
                        /* go through all names */
            entryname = rtrim (names (iname));

            if substr (entryname, length (entryname) - length (".info") + 1) = ".info" then do;
                 entryname = substr (entryname, 1, length (entryname) - length (".info"));
                 xentryname = translate (entryname, lower_case, upper_case);
            end;
            else go to NEXT_ENTRY;

            if ^found then do;      /* topics specified and not matched yet */
                 do i = 1 to ntopics
                     while (index (xentryname, topic (i)) = 0);
                 end;
                 found = (i <= ntopics);
            end;

            if nname = 1 then do;   /* first name */
                 if absp_sw then do;
                outstring = rtrim (dirname);
                if dirname ^= ">" then
                     outstring = outstring || ">";
                 end;
                 else outstring = "";
                 outstring = outstring || entryname;
            end;


            if ^brief & nname > 1 then do; /* additional names */
                 if nname = 2 then outstring = outstring || " (";
                 else outstring = outstring || ", ";
                 outstring = outstring || entryname;
            end;

            iname = iname+1;
             end;               /* end of loop for names of one entry */

             if found then do;      /* there is something to print */
            if ^brief & nname > 2 then   /* add closing paren */
                 outstring = outstring||")";

            if af_sw then do;
                 if number_printed > 0 then return_arg = return_arg || " ";
                 return_arg = return_arg || outstring;
            end;
            else call ioa_ ("^a", outstring);

            number_printed = number_printed+1;
             end;

NEXT_ENTRY:
        end;                /* end of processing for one entry */

        call clean_up;

         end scan_dir;              /* end of processing for one directory */

    end BLOCK;              /*  end of begin block for topic allocation */



/* procedure to free things allocated by hcs_$star_ */

clean_up:   proc;
         if nptr ^= null () then do; free names in (area); nptr = null (); end;
         if eptr ^= null () then do; free entry in (area); eptr = null (); end;
    end clean_up;


%include sl_info;
%include sl_control_s;
     end;
\014



            list_ref_names.pl1              04/09/80  1314.1rew 04/09/80  1313.5       89685



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

list_ref_names: lrn: proc;

/* This command lists the reference names of segments */
/* initially coded Jan 1971 by Dan Bricklin */
/* last modified by Dan B. March 1971 */
/* fixed to abort for invalid -from and -to, Steve Herbst 11/8/77 */
/* fixed to not make copy in [pd] if copy switch is on 03/20/80 S. Herbst */

dcl
    (i, alen, from_seg, to_seg, argno, seg_no, num_null) fixed bin,
     code fixed bin (35),
     error_table_$badopt fixed bin (35) ext,
     error_table_$segknown fixed bin (35) ext,
    (aptr, segptr) ptr,
    (brief, prt, allsw, no_zero) bit (1) aligned,
     which char (16) init ("list_ref_names") int static aligned,
     dirname char (168) aligned,
     ename char (32) aligned,
     arg char (alen) based (aptr),
     ret label init (end_loop),
     plural char (1) aligned,

     1 p aligned,
     2 ignore char (31) unaligned,
     2 rname char (32) unaligned,
     2 nl char (1) unaligned,

     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cv_oct_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     expand_pathname_ ext entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
     hcs_$initiate ext entry (char (*)aligned, char (*)aligned, char (*)aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     com_err_ ext entry options (variable),
     ioa_ ext entry options (variable),
     hcs_$terminate_noname ext entry (ptr, fixed bin (35)),
     hcs_$fs_get_path_name ext entry (ptr, char (*)aligned, fixed bin, char (*)aligned, fixed bin (35)),
     hcs_$high_low_seg_count ext entry (fixed bin, fixed bin),
     hcs_$fs_get_ref_name ext entry (ptr, fixed bin, char (*), fixed bin (35)),
     ring0_get_$name ext entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35)),
     iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)),
     iox_$user_output ptr ext;

dcl (addr, baseno, baseptr, fixed, substr) builtin;

    allsw, brief, no_zero = "0"b;           /* assume print ring-0, and not all and brief options */
    nl = "
";                      /* set nl equal to a newline char */
    argno = 1;              /* start with first argument */

    do i = 1 by 1;              /* look at all arguments */
         call cu_$arg_ptr (i, aptr, alen, code);    /* for the -all and -brief options */
         if code ^= 0 then go to next;      /* end of argument list */
         if arg = "-brief" | arg = "-bf" then brief = "1"b; /* found a brief option */
         if arg = "-all" | arg = "-a" then allsw = "1"b; /* found an all option, so set switch to remember */
    end;

next:   from_seg = 0;               /* default from segment number is zero */

    call cu_$arg_ptr (argno, aptr, alen, code); /* get next argument */

    if code ^= 0 then do;           /* end of argument list */
         if argno = 1 | argno = 2 & brief then do;  /* if nothing was given, print all non-ring zero */
        no_zero = "1"b;         /* don't print ring zero ones */
        go to all;
         end;
         return;                /* else return to caller */
    end;

    if arg = "-to" then do;         /* if the -to option is encountered, do */
         argno = argno + 1;         /* look at next argument */
to_sec:      call cu_$arg_ptr (argno, aptr, alen, code);
         if code ^= 0 then do;          /* if not there then it is an error */
error:      call com_err_ (code, which);        /* print message */
        return;             /* end of arg list, so return */
         end;

         to_seg = cv_oct_check_ (arg, code);    /* convert to number */

         if code ^= 0 | to_seg < 0 then do;
        call com_err_ (0, which, "Invalid -to argument ^a", arg);
        return;
         end;

got_to:      if from_seg>to_seg then do;     /* if lower bound > upper bound then error */
        call com_err_ (0, which, "Lower segment number bound ^o greater than upper bound ^o",
             from_seg, to_seg);
        return;
         end;

num_print:                  /* given segment number, print info */
         prt = "0"b;                /* nothing printed yet */

         do seg_no = from_seg to to_seg;        /* do for each segment number in range */

        call hcs_$fs_get_path_name (baseptr (seg_no), dirname, i, ename, code); /* get path name */
        if code ^= 0 then do;       /* if unable then try the following */
             if no_zero then go to end_loop;    /* if no ring-0 ones to be printed, don't even check */
             call ring0_get_$name (dirname, ename, baseptr (seg_no), code); /* is it in ring 0 ? */
             if code ^= 0 then go to end_loop;  /* if not, then ignore it for now */

             if dirname = "" then call ioa_ ("   ^o ^a (ring 0)", seg_no, ename); /* no dir */

             else do;

            if dirname = ">" then dirname = ""; /* don't have two >'s on root */

            call ioa_ ("   ^o ^a>^a (ring 0)", seg_no, dirname, ename); /* print info */

             end;

             prt = "1"b;

             go to printed;         /* skip around regular print routine */
        end;

        if i = 1 then dirname = "";     /* if name is only >, then remove it, since we have one */

        prt = "1"b;         /* we printed something */

        call ioa_ ("^/   ^o ^a>^a", seg_no, dirname, ename); /* print number and path */

printed:        if ^brief then do;          /* print reference names, if not brief */

             ret = end_loop;        /* pseudo call */

             go to ref_print;

        end;

end_loop:        end;                   /* end of loop for each segment number */

         if ^prt then
        if to_seg = from_seg then call com_err_ (0, which, "Invalid segment number ^o", from_seg);
        else call com_err_ (0, which, "Invalid segment numbers ^o and ^o", from_seg, to_seg);

         argno = argno + 1;
         go to next;
    end;

    if arg = "-from" | arg = "-fm" then do;     /* if -from option encountered */
         argno = argno + 1;         /* look for number after it */
         call cu_$arg_ptr (argno, aptr, alen, code);
         if code ^= 0 then go to error;     /* not found is an error */

         from_seg = cv_oct_check_ (arg, code);  /* make it a number */

         if code ^= 0 | from_seg < 0 then do;
        call com_err_ (0, which, "Invalid -from argument ^a", arg);
        return;
         end;

         call cu_$arg_ptr (argno + 1, aptr, alen, code); /* look for a "-to" after the from number */


all:         call hcs_$high_low_seg_count (to_seg, i);  /* get last allocated segment number */
         to_seg = to_seg + i;           /* by adding high hc to number after hardcore */
         if from_seg>to_seg then do;     /* starting after last seg */
        call com_err_ (0, which, "Lower bound ^o greater than highest segment number ^o.",
             from_seg, to_seg);

        return;

         end;

         if code = 0 then if arg = "-to" then do;
             argno = argno + 2;
             go to to_sec;
        end;


         go to got_to;


    end;

    if arg = "-name" | arg = "-nm" then do;     /* if name option */
         argno = argno + 1;         /* get next argument */
         call cu_$arg_ptr (argno, aptr, alen, code);    /* and treat it as a character string */
         if code = 0 then go to no_num;     /* regardless of how it looks */
         else go to error;          /* if none there, then error */
    end;

    if arg = "-brief" | arg = "-bf" then do;    /* ignore brief options since we already processed it */
         argno = argno + 1;
         go to next;
    end;

    if allsw then do;               /* if all option was present */
         from_seg = 0;              /* simulate -from 0 */
         go to all;
    end;

    if substr (arg, 1, 1) = "-" then do;        /* look for option type args which we can't identify */
         call com_err_ (error_table_$badopt, which, "^a", arg);
         return;
    end;

    seg_no = cv_oct_check_ (arg, code);     /* see if argument can be seen as a number */

    if code = 0 then do;            /* if so, then do */
         to_seg, from_seg = seg_no;     /* pretend that it is: -from num -to num */
         go to num_print;           /* go to numbered segment printing routine */
    end;

no_num: call expand_pathname_ (arg, dirname, ename, code);
    if code ^= 0 then go to error;

    call hcs_$initiate (dirname, ename, "", 0, 1, segptr, code); /* see if it is there already and where */

    if code = 0 then do;            /* wasn't known in advance, no good */
         call com_err_ (0, which, "Segment not known. ^a^[>^]^a", dirname, dirname ^= ">", ename);
         call hcs_$terminate_noname (segptr, code); /* terminate the reference */
         argno = argno + 1;         /* try next argument */
         go to next;
    end;

    if code ^= error_table_$segknown then do;   /* if it wasn't known, another error */
         call com_err_ (code, which, "^a^[>^]^a", dirname, dirname ^= ">", ename);
         argno = argno + 1;         /* try again */
         go to next;
    end;

    seg_no = fixed (baseno (segptr));       /* get segment number part of pointer */

    call hcs_$terminate_noname (segptr, code);  /* this reference dosn't count, so end it */

    call ioa_ ("^/   ^o", seg_no);      /* print segment number */

    argno = argno + 1;              /* get ready for next argument */

    if brief then go to next;           /* skip ref name printing */

    ret = next;             /* pseudo call */

ref_print:
    num_null = 0;               /* no null reference names found so far for this segment */

    do i = 1 by 1;              /* look at all reference names */
         call hcs_$fs_get_ref_name (baseptr (seg_no), i, p.rname, code); /* get reference names from this entry */
         if code ^= 0 then go to fin;       /* when ended, then go to fin */

/* if not null, write structure with it and newline */
         if p.rname ^= "" then call iox_$put_chars (iox_$user_output, addr (p.rname), 33, code);

         else num_null = num_null + 1;      /* else count number of null refs */

    end;

fin:    if num_null>0 then do;           /* print number of null refs if > zero */
         if num_null = 1 then plural = " ";     /* de-pluralize word */
         else plural = "s";         /* pluralize word */
         call ioa_ ("^d null reference name^a", num_null, plural);
    end;

    go to ret;              /* pseudo return */


     end;
\014



            print_motd.pl1                  04/13/82  1454.5rew 04/13/82  1453.8      115119



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* Prints all lines in the message-of-the-day (MOTD) segment which have been changed or added since the user last used
   this command */

/* Created:  28 July 1971 by Peter R. Bos */
/* Modified: 14 December 1972 by R. Mullen to convert to version 2 PL/I */
/* Modified: 29 March 1977 by S. Herbst to convert to iox_ */
/* Modified: 14 July 1978 by S. Herbst to use Person_id.motd rather than anonymous.motd for anonymous users */
/* Modified: 12 December 1979 by S. Herbst to fix no_s_permission bug when obtaining date-time-contents-modified */
/* Modified: 23 March 1982 by G. Palter to convert to use the user's value segment */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


print_motd:
pmotd:
     procedure () options (variable);


/* DECLARATIONS */

dcl  1 user_motd aligned based (user_motd_ptr),
       2 dtcm fixed binary (71),
       2 lth fixed binary (21),
       2 motd character (user_motd_lth refer (user_motd.lth));
dcl  user_motd_ptr pointer;
dcl  user_motd_lth fixed binary (21);

dcl  system_motd character (system_motd_lth) based (system_motd_ptr);
dcl  system_motd_lth fixed binary (21);
dcl  system_motd_ptr pointer;
dcl  system_motd_dtcm fixed binary (71);

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  code fixed binary (35);

dcl  (used, next_nl) fixed binary (21);

dcl  n_arguments fixed binary;

dcl  PRINT_MOTD character (32) static options (constant) initial ("print_motd");

dcl  NL character (1) static options (constant) initial ("
");

dcl  CHASE fixed binary (1) static options (constant) initial (1);
dcl  DELETE_OR_UNLINK bit (6) static options (constant) initial ("010110"b);

dcl  SYSTEM_CONTROL_DIR character (168) static /* options (constant) */ initial (">system_control_dir");
dcl  MOTD_ENAME character (32) static options (constant) initial ("message_of_the_day");

dcl  DEFAULT_VALUE_SEGMENT pointer static options (constant) initial (null ());
dcl  PERMANENT_VALUE bit (36) aligned static options (constant) initial ("01"b);
dcl  PMOTD_VALUE_NAME character (12) static options (constant) initial ("print_motd._");

dcl  error_table_$action_not_performed fixed binary (35) external;
dcl  error_table_$no_s_permission fixed binary (35) external;
dcl  error_table_$noentry fixed binary (35) external;
dcl  error_table_$oldnamerr fixed binary (35) external;
dcl  error_table_$wrong_no_of_args fixed binary (35) external;

dcl  iox_$user_output pointer external;

dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
dcl  com_err_ entry () options (variable);
dcl  delete_$path entry (character (*), character (*), bit (6), character (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$status_ entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35));
dcl  initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl  user_info_ entry (character (*));
dcl  user_info_$homedir entry (character (*));
dcl  value_$get_data
    entry (pointer, bit (36) aligned, character (*), pointer, pointer, fixed binary (18), fixed binary (35));
dcl  value_$get_path entry (character (*), fixed binary (35));
dcl  value_$set_data
    entry (pointer, bit (36) aligned, character (*), pointer, fixed binary (18), pointer, pointer,
    fixed binary (18), fixed binary (35));
dcl  value_$set_path entry (character (*), bit (1), fixed binary (35));

dcl  cleanup condition;

dcl  (addr, currentsize, divide, index, null, rtrim, unspec) builtin;

/*\014*/

    call cu_$arg_count (n_arguments, code);     /* insure we are invoked properly */
    if code ^= 0 then do;
         call com_err_ (code, PRINT_MOTD);
         return;
    end;

    if n_arguments ^= 0 then do;
         call com_err_ (error_table_$wrong_no_of_args, PRINT_MOTD, "No arguments are allowed.");
         return;
    end;

    system_area_ptr = get_system_free_area_ ();

    user_motd_ptr, system_motd_ptr = null ();   /* for cleanup handler */

    on condition (cleanup)
         begin;
        if user_motd_ptr ^= null () then free user_motd in (system_area);
        if system_motd_ptr ^= null () then call terminate_file_ (system_motd_ptr, 0, TERM_FILE_TERM, (0));
         end;

    call get_user_motd ();          /* fetch user's MOTD data from the value segment */

    call get_system_motd ();            /* "fetch" system's MOTD data */

    if user_motd.dtcm >= system_motd_dtcm then go to RETURN_FROM_PRINT_MOTD;
                        /* nothing new added to system MOTD yet */


/* System MOTD has changed since this user last checked it: print any lines which do not appear in the old MOTD */

    if system_motd_lth > 0 then          /* don't bother if there's nothing in it */
         if user_motd.lth = 0 then      /* ... user hasn't seen any of it yet */
        call iox_$put_chars (iox_$user_output, system_motd_ptr, system_motd_lth, (0));

         else do;
        used = 0;
        do while (used < system_motd_lth);
             begin;
dcl  rest_of_system_motd character (system_motd_lth - used) unaligned defined (system_motd) position (used + 1);
            next_nl = index (rest_of_system_motd, NL);
            if next_nl = 0 then     /* use reset of segment */
                 next_nl = length (rest_of_system_motd);
            begin;
dcl  system_motd_line character (next_nl) unaligned defined (system_motd) position (used + 1);
                 if index (user_motd.motd, system_motd_line) = 0 then
                call iox_$put_chars (iox_$user_output, addr (system_motd_line),
                     length (system_motd_line), (0));
            end;
            used = used + next_nl;
             end;
        end;
         end;


/* Update user's MOTD to be a copy of the current system MOTD */

    free user_motd in (system_area);        /* get rid of current one */

    user_motd_lth = system_motd_lth;
    allocate user_motd in (system_area) set (user_motd_ptr);

    user_motd.dtcm = system_motd_dtcm;
    user_motd.motd = system_motd;

    call put_user_motd ();          /* put it back into the value segment */

RETURN_FROM_PRINT_MOTD:
    if user_motd_ptr ^= null () then free user_motd in (system_area);

    if system_motd_ptr ^= null () then call terminate_file_ (system_motd_ptr, 0, TERM_FILE_TERM, (0));

    return;

/*\014*/

/* Get the system's MOTD */

get_system_motd:
     procedure ();

dcl  1 short_status aligned like status_branch.short;
dcl  system_motd_bc fixed binary (24);

    call initiate_file_ (SYSTEM_CONTROL_DIR, MOTD_ENAME, R_ACCESS, system_motd_ptr, system_motd_bc, code);
    if code ^= 0 then do;
         call com_err_ (code, PRINT_MOTD, "^a", pathname_ (SYSTEM_CONTROL_DIR, MOTD_ENAME));
         go to RETURN_FROM_PRINT_MOTD;
    end;

    call hcs_$status_ (SYSTEM_CONTROL_DIR, MOTD_ENAME, CHASE, addr (short_status), null (), code);
    if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
         call com_err_ (code, PRINT_MOTD, "Determining date-time modified of ^a.",
        pathname_ (SYSTEM_CONTROL_DIR, MOTD_ENAME));
         go to RETURN_FROM_PRINT_MOTD;
    end;

    system_motd_lth = divide ((system_motd_bc + 8), 9, 21, 0);
    system_motd_dtcm = cv_fs_time (short_status.dtcm);

    return;

     end get_system_motd;



/* Convert a file-system date/time to a normal clock reading */

cv_fs_time:
     procedure (p_time_bits) returns (fixed binary (71));

dcl  p_time_bits bit (36) parameter;
dcl  time fixed binary (71);

    unspec (time) = (20)"0"b || p_time_bits || (16)"0"b;

    return (time);

     end cv_fs_time;

/*\014*/

/* Get the user's MOTD data from the value segment */

get_user_motd:
     procedure ();

    call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, system_area_ptr, user_motd_ptr,
         (0), code);

    if (code = error_table_$oldnamerr) | (code = error_table_$noentry) then do;
         call convert_motd_segment ();
         call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, system_area_ptr,
        user_motd_ptr, (0), code);
    end;

    if code ^= 0 then do;           /* couldn't find it anywhere: first use of print_motd */
         user_motd_lth = 0;
         allocate user_motd in (system_area) set (user_motd_ptr);
         user_motd.dtcm = 0;
    end;

    return;

/*\014*/

/* Internal to get_user_motd: converts from the old mechanism used to store per-user MOTD data to the value segment.  The
   old mechanism was a segment named Person_id.motd in the user's home directory which contained the text of the last MOTD
   seen; the DTCM of the segment was used to compare against that of the system MOTD */

convert_motd_segment:
    procedure ();

dcl  1 short_status aligned like status_branch.short;

dcl  home_dir character (168);
dcl  person_id character (24);

dcl  old_user_motd character (user_motd_lth) based (old_user_motd_ptr);
dcl  old_user_motd_bc fixed binary (24);
dcl  old_user_motd_ptr pointer;
dcl  old_user_motd_ename character (32);


         call user_info_$homedir (home_dir);
         call user_info_ (person_id);
         old_user_motd_ename = rtrim (person_id) || ".motd";

         old_user_motd_ptr = null ();       /* for cleanup handler */

         on condition (cleanup)
        begin;
             if old_user_motd_ptr ^= null () then
            call terminate_file_ (old_user_motd_ptr, 0, TERM_FILE_TERM, (0));
        end;

         call initiate_file_ (home_dir, old_user_motd_ename, R_ACCESS, old_user_motd_ptr, old_user_motd_bc, code);
         if code ^= 0 then return;      /* no old-style MOTD segment */

         call hcs_$status_ (home_dir, old_user_motd_ename, CHASE, addr (short_status), null (), code);
         if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
        call com_err_ (code, PRINT_MOTD, "Determining date-time modified of ^a.",
             pathname_ (home_dir, old_user_motd_ename));
        short_status.dtcm = ""b;        /* assume it's very old */
         end;

         user_motd_lth = divide ((old_user_motd_bc + 8), 9, 21, 0);

         allocate user_motd in (system_area) set (user_motd_ptr);
         user_motd.dtcm = cv_fs_time (short_status.dtcm);
         user_motd.motd = old_user_motd;

         call put_user_motd ();         /* returns only if OK */

         call delete_$path (home_dir, old_user_motd_ename, DELETE_OR_UNLINK, PRINT_MOTD, code);
         if code = 0 then old_user_motd_ptr = null ();/* no longer exists */
         else if code = error_table_$action_not_performed then
        call com_err_ (0, PRINT_MOTD, "^a is no longer used by this command and should be deleted.",
             pathname_ (home_dir, old_user_motd_ename));
         else call com_err_ (code, PRINT_MOTD, "Deleting ^a.", pathname_ (home_dir, old_user_motd_ename));

         return;

    end convert_motd_segment;

     end get_user_motd;

/*\014*/

/* Put the updated MOTD data into the user's value segment */

put_user_motd:
     procedure ();

    call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, user_motd_ptr,
         currentsize (user_motd), null (), (null ()), (0), code);

    if code = error_table_$noentry then do;     /* value segment not present: try to create it */
         call create_default_value_segment ();
         call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, user_motd_ptr,
        currentsize (user_motd), null (), (null ()), (0), code);
    end;

    if code ^= 0 then do;           /* abort the whole thing if this fails */
         call com_err_ (code, PRINT_MOTD,
        "Attempting to update message-of-the-day information in default value segment.");
         go to RETURN_FROM_PRINT_MOTD;
    end;

    return;



/* Internal to put_user_motd: create the default value segment (if possible) */

create_default_value_segment:
    procedure ();

dcl  value_segment_path character (168);

         call value_$set_path ("", "1"b, code);

         if code = 0 then do;           /* created it */
        call value_$get_path (value_segment_path, (0));
        call com_err_ (0, PRINT_MOTD, "Created ^a.", value_segment_path);
         end;

         return;

    end create_default_value_segment;

     end put_user_motd;

/*\014*/

%include access_mode_values;

%include terminate_file;
%page;
%include status_structures;

     end print_motd;
\014



            resource_usage.pl1              03/24/82  1351.3rew 03/24/82  1338.7      147411



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */


/* RESOURCE_USAGE - Procedure to print user's monthly (to date) resource usage and resource limits.
   This procedure gets this info from the user's PIT, where cpg_ put it.

   This procedure is called in any of four modes:

   1) long mode (specify the control_arg -long or -lg);
   this prints the month-to-date charges, resource limits, interactive usage for all shifts,
   absentee usage in all queues, and io daemon usage in all queues.

   2) default mode (called with no control_arg)
   this lists the month-to-date charge, the resource limit, the interactive usage for all shifts, and the
   absentee and io daemon usage for all queues.

   3) brief mode (called specifying the control_arg -brief or -bf)
   this lists the month-to-date charge, the resource limit, and totals for interactive,
   absentee and io daemon usage.

   4) totals mode (called specifying the control_arg -totals or -tt )
   this lists just the month-to-date charge and the resource limit.


   J. Phillipps and THVV  - June 1972
   J. Phillipps - revised and upgraded for version 2 PL/1 September 1972
   .          - revised for memory and virtual cpu charging on 6180 March 1973
   .            - updated headers and added absolute limit reporting a la sipb April 1976.

   T. Casey - August 1977  - to only print nonzero device charges and to print some new ones.
   C. Hornig    - June 1979  - to print usage even if charge was zero.
   E. N. Kittlitz   - June 1981  - UNCA rate structure changes
   */

resource_usage: ru: procedure;

dcl  crashes char (8) aligned,
     answer char (46) varying,
     answer1 char (47) varying,
     answer2 char (29) varying,
     answer3 char (18) varying,
     j fixed bin,
     logins char (7) aligned,
     datestr char (16) aligned,
     pit_name char (32) int static init ("pit"),
     reset char (16) aligned;               /* formatted string for time last reset PDT */


dcl  an fixed bin init (1),
     al fixed bin (21),
     nargs fixed bin,
     absolute bit (1) init ("0"b),
     cutoff bit (1) init ("0"b),
     month bit (1) init ("0"b),
     ec fixed bin (35),
    (i, ii) fixed bin,
     mode fixed bin init (3),
     temp float bin init (0e0);

dcl (pp, ap) ptr;

dcl  bchr char (al) unaligned based (ap);

dcl  dev_usage_buffer char (160);           /* stuff for printing device usage */
dcl  dub_array (160) char (1) unal based (addr (dev_usage_buffer));
dcl  dubp ptr;
dcl  dubl fixed bin;
dcl  based_dub char (dubl) based (dubp);
dcl (dubi, retlen) fixed bin;
dcl  devh char (8) varying;
dcl  dusw (16) bit (1) aligned;
dcl  rs_name char (32) aligned;
dcl  max_rs_number fixed bin;

dcl  ndevices fixed bin;
dcl 1 dvt (16) aligned,
    2 device_id char (8),
    2 device_price (0:7) float bin;

dcl  MILLION fixed bin (35) internal static init (1000000),
     prettybigfloat float bin int static init (1e36);

dcl  increment (0:5) char (12) aligned initial
    ("never", "daily", "monthly", "yearly", "calendar_yr", "fiscal_yr");

dcl (addr, divide, float, length, mod, null, rtrim, substr) builtin;

/* procedures called by this program */

dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cu_$arg_count entry (fixed bin, fixed bin (35)),
     date_time_ entry (fixed bin (71), char (*) aligned),
     get_pdir_ entry () returns (char (168)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable);       /* ctl,retstr,retlen,args */
dcl  system_info_$device_prices entry (fixed bin, ptr);
dcl  system_info_$rs_name entry (fixed bin, char (*) aligned, fixed bin (35));
dcl  system_info_$max_rs_number entry (fixed bin);

dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$too_many_args fixed bin (35) ext;


%include user_attributes;
%include pit;
\014


/* ====================================================== */

    call system_info_$max_rs_number (max_rs_number);

    call hcs_$initiate ((get_pdir_ ()), pit_name, "", 0, 1, pp, ec); /* get ptr to PIT in process dir */
    if pp = null then do;
         call com_err_ (ec, "resource_usage", "pit");
         return;
    end;
    call cu_$arg_count (nargs, ec);
    if ec ^= 0 then go to argerr;
    if nargs > 1 then do;
         call com_err_ (error_table_$too_many_args, "resource_usage", "This command only takes one argument.");
         return;
    end;

    do an = 1 to nargs;
         call cu_$arg_ptr (an, ap, al, ec);     /* see which option was specified */
         if ec ^= 0 then go to argerr;
                        /* default mode = 3 */
         else if bchr = "-long" then mode = 2;  /* if arg specifies long option, set mode */
         else if bchr = "-lg" then mode = 2;
         else if bchr = "-brief" then mode = 1; /* if arg specifies brief option, set mode accordingly */
         else if bchr = "-bf" then mode = 1;
         else if bchr = "-tt" | bchr = "-totals" | bchr = "-total" then mode = 0;
                        /* if no arg, default mode is an expanded form of brief */
         else do;
        call com_err_ (error_table_$badopt, "resource_usage", """^a""", bchr);
        return;
         end;
    end;

    if mode = 0 then do;            /* total mode is specified */
         call ioa_$rsnnl ("Month-to-Date: $^9.2f; Limit: $^9a; ",
        answer, j, pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
                        /* if cutoff set by proj administrator, print it also */
         if substr ((cv_limit (pp -> pit.absolute_limit)), 6) = "open" then do;
        call ioa_$rsnnl ("Total: $^9.2f;", answer3, j, pp -> pit.absolute_spent);
        call ioa_ ("^/^a", answer || answer3);
         end;
         else do;
        call ioa_$rsnnl ("Total: $^9.2f; Absolute Limit: $^9a; ",
             answer1, j, pp -> pit.absolute_spent, (cv_limit (pp -> pit.absolute_limit)));
        call date_time_ (pp -> pit.absolute_cutoff, datestr);
        call ioa_$rsnnl ("Reset: ^a, ^a;",
             answer2, j, substr (datestr, 1, 8), increment (pp -> pit.absolute_increm));
        call ioa_ ("^/^a", answer);
        call ioa_ (answer1 || answer2);
         end;
         goto endit1;

    end;
    call date_time_ (pp -> pit.proc_creation_time, datestr); /* usage from beginning of mo. to time process created */
    call date_time_ (pp -> pit.time_last_reset, reset); /* format time last reset PDT */
    call ioa_ ("^/^a.^a  Report from ^a to ^a", pp -> pit.login_name, pp -> pit.project, reset, datestr);
    if max_rs_number > 0 then do;
         call system_info_$rs_name ((pp -> pit.rs_number), rs_name, ec);
         if ec ^= 0 then call com_err_ (ec, "resource_usage",
        "For rate structure ^d.  Contact your system administrator.", pp -> pit.rs_number);
         call ioa_ ("^5xRate Structure -- ^a", rs_name);
    end;

quick:
    if mode = 2 then do;            /* long mode */
         if substr ((cv_limit (pp -> pit.absolute_limit)), 6) = "open" then do;
        call ioa_$rsnnl ("Month-to-Date: $^9.2f; Limit: $^9a; ",
             answer, j, pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
        call ioa_$rsnnl ("Total: $^9.2f;", answer3, j, pp -> pit.absolute_spent);
        call ioa_ (answer || answer3);
         end;
         else do;
        call ioa_$rsnnl ("Total: $^9.2f, Absolute Limit: $^9a; ",
             answer1, j, pp -> pit.absolute_spent, (cv_limit (pp -> pit.absolute_limit)));
        call date_time_ (pp -> pit.absolute_cutoff, datestr);
        call ioa_$rsnnl ("Reset: ^a, ^a;",
             answer2, j, substr (datestr, 1, 8), increment (pp -> pit.absolute_increm));
        call ioa_ (answer1 || answer2);
         end;
    end;

    else do;
         call ioa_ ("Month-To-Date: $^9.2f;  Limit: $^9a;",
        pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
    end;
    do i = 1 to 7, 0;               /* sum interactive charge */
         temp = temp + pp -> pit.interactive (i).charge;
    end;
    if temp = 0e0 then do;          /* if no usage, don't print header */
         call ioa_ ("^/Interactive Usage: none;");
         go to abstee;
    end;

/*    P R I N T  H E A D E R S  */

    if pp -> pit.crashes = 1 then
         crashes = "crash.  ";          /* do singular and plural parse */
    else crashes = "crashes.";
    if pp -> pit.logins = 1 then
         logins = "login, ";
    else logins = "logins,";
    if mode = 2 then do;            /* long mode header for interactive usage */
         call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
        temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
         call ioa_ ("^4xshift^2x$charge^4x$limit^8xvcpu^4xconnect^4xterminal i/o^2xmemory/kmu");
    end;
    else if mode = 1 then do;           /* brief mode header for interactive usage */
         call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
        temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
         go to abstee;
    end;
    else if mode = 3 then do;           /* default mode */
         call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
        temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
         call ioa_ ("^4xshift^2x$charge^4x$limit");
    end;
    temp = 0e0;             /* clear temp */


/*   P R I N T   R E S O U R C E  U S A G E   */


/* print out resource usage */

    do i = 1 to 7, 0;
         if pp -> pit.shift_limit (i) > prettybigfloat
         then if pp -> pit.interactive (i).charge = 0e0
        & pp -> pit.interactive (i).cpu = 0
        & pp -> pit.interactive (i).connect = 0
        & pp -> pit.interactive (i).core = 0
        & pp -> pit.interactive (i).io_ops = 0
        then goto skip;         /* don't print useless lines */
         if mode = 2 then do;           /* long mode */
        call ioa_ ("^5x^1d^4x^8.2f^1x^9a^3x^9a^2x^9a^5x^11.1f^1x^11.1f", i,
             pp -> pit.interactive (i).charge, (cv_limit (pp -> pit.shift_limit (i))),
             (cv_time (pp -> pit.interactive (i).cpu)), (cv_time (pp -> pit.interactive (i).connect)),
             float (pp -> pit.interactive (i).io_ops/1e3), float (pp -> pit.interactive (i).core/1e6));
         end;
         else if mode = 3 then do;      /* default mode */
        call ioa_ ("^5x^1d^4x^8.2f^1x^9a", i, pp -> pit.interactive (i).charge,
             (cv_limit (pp -> pit.shift_limit (i))));
skip2:       end;
skip:   end;

abstee: temp = 0e0;             /* clear temp */
    do ii = 1 to 4;             /* scan for absentee usage */
         temp = temp + pp -> pit.absentee (ii).charge;
    end;
    if temp = 0e0 then do;
         call ioa_ ("^/Absentee Usage:    none;");
         go to iod;
    end;
    else call ioa_ ("^/Absentee Usage:    $^8.2f;", temp);
    if mode = 1 then go to iod;         /* brief mode exit here */
    else if mode = 3 then do;           /* default mode */
         call ioa_ ("^4xqueue^2x$charge^6xjobs");
         do ii = 1 to 4;
        if pp -> pit.absentee (ii).charge = 0e0 then go to next;
        call ioa_ ("^5x^1d^4x^8.2f^6x^4d", ii, pp -> pit.absentee (ii).charge, pp -> pit.absentee (ii).jobs);
next:        end;
    end;
    if mode = 2 then do;            /* long mode */
         call ioa_ ("^4xqueue^2x$charge^6xjobs^8xvcpu^2xmemory/kmu");

         do ii = 1 to 4;
        if pp -> pit.absentee (ii).charge = 0e0 then go to skip3;
        call ioa_ ("^5x^1d^4x^8.2f^6x^4d^3x^9a^2x^10.1f", ii, pp -> pit.absentee (ii).charge,
             pp -> pit.absentee (ii).jobs, cv_time (pp -> absentee (ii).cpu),
             float (pp -> pit.absentee (ii).memory/1e6));
skip3:       end;
    end;
iod:    temp = 0e0;
    do ii = 1 to 4;
         temp = temp + pp -> pit.iod (ii).charge;
    end;
    if temp = 0e0 then do;
         call ioa_ ("^/IO Daemon Usage:   none;");
         go to device;
    end;
    else call ioa_ ("^/IO Daemon Usage:   $^8.2f;", temp);
    if mode = 1 then go to device;      /* brief mode exit here */
    else if mode = 3 then do;           /* default mode */
         call ioa_ ("^4xqueue^2x$charge^6xlines");
         do ii = 1 to 4;
        if pp -> pit.iod (ii).charge = 0e0 then go to next2;
        call ioa_ ("^4x^1x^1d^4x^8.2f^x^10d",
             ii, pp -> pit.iod (ii).charge, pp -> pit.iod (ii).lines);
next2:       end;
    end;
    if mode = 2 then do;            /* long mode */
         call ioa_ ("^4xqueue^2x$charge^4xpieces^7xpages^8xlines");
         do ii = 1 to 4;
        if pp -> pit.iod (ii).charge = 0e0 then go to skip4;
        call ioa_ ("^4x^1x^1d^4x^8.2f^6x^4d^3x^9d^x^12d",
             ii, pp -> pit.iod (ii).charge, pp -> pit.iod (ii).pieces,
             pp -> pit.iod (ii).pages, pp -> pit.iod (ii).lines);
skip4:       end;
    end;
device: temp = 0e0;             /* clear temp */
    do ii = 1 to 16;                /* scan for device usage */
         if pp -> pit.devices (ii) = 0e0
         then dusw (ii) = ""b;
         else dusw (ii) = "1"b;
         temp = temp + pp -> pit.devices (ii);
    end;
    if temp = 0e0 then do;
         if mode = 2 then
        call ioa_ ("^/Device Usage:   none;");  /* only print in long mode */
    end;
    else do;
         call ioa_ ("^/Device Usage:      $^8.2f;", temp);

/* The purpose of the following code is to print a column only for devices with nonzero usage. */

         call system_info_$device_prices (ndevices, addr (dvt)); /* get device names and prices (but only use names) */
         dev_usage_buffer = "";         /* clear buffer before making heading */
         dubi = 1;              /* set index to first character position in buffer */
         do i = 1 to 16;            /* put each device name in heading */
        if dusw (i) then do;        /* but only if it has nonzero usage */
             devh = rtrim (device_id (i));  /* copy name and see how long it really is */
             dubi = dubi + 9 - length (devh);   /* compute how far to skip to right-adjust name */
             substr (dev_usage_buffer, dubi, 1) = "$"; /* put in leading dollar sign */
             substr (dev_usage_buffer, dubi+1, length (devh)) = devh; /* put in the name */
             dubi = dubi + 1 + length (devh);   /* advance char index past name */
        end;
         end;
         call ioa_ ("^a", dev_usage_buffer);    /* print the heading */

         dev_usage_buffer = "";         /* clear buffer before formatting usage figures */
         dubl = length (dev_usage_buffer);      /* initialize char counters */
         dubi = 1;
         do i = 1 to 16;            /* print usage for each device */
        if dusw (i) then do;        /* only if it is nonzero */
             dubp = addr (dub_array (dubi));    /* get addr of where to put next usage field */
             call ioa_$rsnnl ("^3x^7.2f", based_dub, retlen, pp -> pit.devices (i)); /* format the usage figure */
             dubl = dubl - retlen;      /* decrement remaining length of buffer */
             dubi = dubi + retlen;      /* advance index to next available character position */
        end;
         end;
         call ioa_ ("^a", dev_usage_buffer);    /* print the usage figures */
    end;
endit:  call ioa_ ("");
endit1: call hcs_$terminate_noname (pp, ec);
    return;

argerr: call com_err_ (ec, "resource_usage");
    return;
\014

/* =========================================================== */



cv_time:    procedure (time) returns (char (9) aligned);

/* procedure to convert from fixed bin (71) to a nice formatted string of hrs: mins: secs */



dcl  time fixed bin (71),
     j fixed bin,
     hours fixed bin,
     minutes fixed bin,
     seconds fixed bin,
     answer char (9) aligned;


         seconds = divide (time, MILLION, 35, 0);
         minutes = divide (seconds, 60, 35, 0);
         seconds = mod (seconds, 60);       /* get rid of the remainder */
         hours = divide (minutes, 60, 35, 0);
         minutes = mod (minutes, 60);       /* get rid of the remainder */

         call ioa_$rsnnl ("^3d:^2d:^2d", answer, j, hours, minutes, seconds);
         if substr (answer, 5, 1) = " " then substr (answer, 5, 1) = "0";
         if substr (answer, 8, 1) = " " then substr (answer, 8, 1) = "0";

         return (answer);
    end;


\014

/* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = */

cv_limit:   procedure (limit) returns (char (9) aligned);

/* procedure to convert a float bin $limit into either the string, "open", if $limit is >= 1e37,
   or to convert a float bin $limit into an integer $limit  */

dcl  limit float bin,
     lim char (9) aligned,
     jj fixed bin,
     itemp fixed bin;


         if limit >= prettybigfloat then do;
        lim = "     open";
        go to char;
         end;
         else do;
        itemp = limit;
        call ioa_$rsnnl ("^6d.00", lim, jj, itemp);
         end;
char:        return (lim);
    end;



test_ru:    entry (xpit);               /* enter here if using an experimental PIT */

dcl  xpit char (*);

    pit_name = xpit;



     end resource_usage;
\014



            ring0_get_.pl1                  11/28/77  1537.3rew 11/28/77  1516.6       52101



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

ring0_get_: proc;

/* "Adjusted" by Bernard Greenberg, for hc def seg 07/22/76 */

dcl (sltp1, names_ptr1, defs_ptr1) ptr static init (null),
    (names_ptr2, defs_ptr2) ptr,
    (a_defsp, a_sltp, a_namep, defp, defsp) ptr,
    (i, j) fixed bin,
     hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin),
     get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin);

dcl  based_bit18 bit (18) aligned based dim (0:511);
dcl  a_defname char (*),
     a_offset fixed bin (18),
     a_type fixed bin;



dcl (error_table_$no_defs, error_table_$noentry) fixed bin (35) ext;
dcl  error_table_$invalidsegno fixed bin (35) ext;

dcl  segptr ptr,
     code fixed bin,
     entryptr ptr,
     dir char (*),
     entry char (*);

dcl  SLDIR char (55) init (">system_library_1") static options (constant);


dcl (addr, addrel, baseno, baseptr, fixed, length, null, reverse, verify) builtin;


/* \014 */

segptr: entry (dir, entry, segptr, code);       /* entry to return segment pointer */

    call get_static_ptrs ("0"b);
    segptr = get_segptr ();
    return;


name:   entry (dir, entry, segptr, code);       /* entry to return segment name */

    call get_static_ptrs ("0"b);
    call get_name (segptr, "0"b);           /* 0 => one */
    return;

names:  entry (dir, entryptr, segptr, code);        /* entry to return pointer to names */

    call get_static_ptrs ("0"b);
    call get_name (segptr, "1"b);           /* 1 => many */
    return;

definition: entry (segptr, entry, a_defname, a_offset, a_type, code);

    call get_static_ptrs ("1"b);            /* 1 => get defs ptr */
    if segptr = null then segptr = get_segptr ();
    call get_definition (segptr);
    return;



/* The following entries are the same as the above except that the caller
   supplies a pointer to the SLT and NAME TABLE to use */

segptr_given_slt: entry (dir, entry, segptr, code, a_sltp, a_namep);

    call get_param_ptrs ("0"b);
    segptr = get_segptr ();
    return;

name_given_slt: entry (dir, entry, segptr, code, a_sltp, a_namep);

    call get_param_ptrs ("0"b);
    call get_name (segptr, "0"b);
    return;


definition_given_slt: entry (segptr, entry, a_defname, a_offset, a_type, code, a_sltp, a_namep, a_defsp);

    call get_param_ptrs ("1"b);
    if segptr = null then segptr = get_segptr ();   /* Look up entry if needed */
    call get_definition (segptr);
    return;

/* \014 */
get_static_ptrs: proc (we_want_defs);

dcl  we_want_defs bit (1) aligned;          /* T => call for defs */

         code = 0;
         if we_want_defs & defs_ptr1 = null then call init_static_ptrs;
         else if names_ptr1 = null then call init_static_ptrs;
         if code ^= 0 then go to error;
         sltp = sltp1;
         names_ptr2 = names_ptr1;
         defs_ptr2 = defs_ptr1;
         return;

init_static_ptrs: proc;
        call hcs_$initiate (SLDIR, "slt", "", 0, 1, sltp1, code);
        if sltp1 = null then return;
        call hcs_$initiate (SLDIR, "name_table", "", 0, 1, names_ptr1, code);
        if names_ptr1 = null then return;
        if we_want_defs then do;
             call hcs_$initiate (SLDIR, "definitions_", "", 0, 1, defs_ptr1, code);
             if defs_ptr1 = null then return;
        end;
        code = 0;               /* Let's hear it for hcs_$initiate! */
         end init_static_ptrs;
    end get_static_ptrs;

get_param_ptrs: proc (we_want_defs);

dcl  we_want_defs bit (1) aligned;          /* We want definitions */
         sltp = a_sltp;
         names_ptr2 = a_namep;
         if we_want_defs then defs_ptr2 = a_defsp;
    end get_param_ptrs;

get_segptr: procedure returns (ptr);


         do i = slt.first_sup_seg to slt.last_sup_seg; /* loop through sup segs searching */
        sltep = addr (slt.seg (i));     /* get pointer to SLT entry */
        namep = addrel (names_ptr2, slte.names_ptr); /* get pointer to names for this segment */
        do j = 1 to namep -> segnam.count;   /* search all names */
             if entry = namep -> segnam.names (j).name then do; /* found it */
            code = 0;
            return (baseptr (i));
             end;
        end;
         end;

         code = error_table_$noentry;
         go to error_segptr;
    end get_segptr;

get_name:   procedure (sp, many);

dcl  many bit (1) aligned, sp ptr;

         i = bin (baseno (sp));         /* get input segment number */
         if i > slt.last_sup_seg | i < slt.first_sup_seg then do; /* bad input segment number */
        code = error_table_$invalidsegno;
        return;
         end;

         sltep = addr (slt.seg (i));        /* get pointer to SLT entry */
         pathp = addrel (names_ptr2, slte.path_ptr);
         namep = addrel (names_ptr2, slte.names_ptr);
         if pathp ^= names_ptr2 then dir = pathp -> path.name; else dir = ""; /* return path name */
         if many then entryptr = namep;
         else entry = namep -> segnam.names (1).name; /* return only one name */
         code = 0;
    end get_name;

get_definition: procedure (textp);
dcl  textp ptr;

         code = 0;
         i = bin (baseno (textp));
         if i < 4 | i > 511 then code = error_table_$no_defs;
         else do;
        defsp = addrel (defs_ptr2, defs_ptr2 -> based_bit18 (i));
        if defsp = defs_ptr2 then code = error_table_$no_defs;
        else do;
             call get_definition_ (defsp, entry, a_defname, defp, code);
             if code = 0 then do;
            a_type = fixed (defp -> definition.class, 3);
            a_offset = fixed (defp -> definition.value, 18);
             end;
        end;
         end;

    end get_definition;

error_segptr: segptr = null;
error:  return;
                        /* \014 */
% include slt;
% include slte;
% include definition;
     end;
\014



            system_info_.pl1                08/12/83  1303.1r   08/12/83  1136.7      175644



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


system_info_: proc;

/* SYSTEM_INFO_ - return various information to user about Multics.

   The information is obtained from the header of "whotab"
   or from "installation_parms" or from the correct "rate_structure_x" seg.

   See AG93 (Multics Subroutines and Input/Output Modules) for documentation
   of the following entries:

   $id (installation_id)
   $sysid (sysid)
   $version_id
   $titles (company, dept, companyds, deptds)
   $users (maxusers, nusers, maxunits, nunits)
   $timeup (time)
   $prices (cpu, log, process, core, disk, registration)
   $prices_rs (rs_number, cpu, log, process, core, disk, registration)
   $device_prices (ndevices, addr (dvt))
   $device_prices_rs (rs_number, ndevices, addr (dvt))
   $abs_limits (default_cpu_limits, default_foreground_cpu_limit, max_cpu_limits)
   $abs_prices (farray)
   $default_absentee_queue (default_queue)
   $abs_prices_rs (rs_number, farray)
   $io_prices (farray)
   $io_prices_rs (rs_number, farray)
   $next_shutdown (time, reason, until)
   $last_shutdown (time, erfno)
   $shift_table (stt)
   $access_ceiling (access_ceiling)
   $level_names (long_names, short_names)
   $category_names (long_names, short_names)
   $log_threshold (state, npages)
   $next_shift_change (cur_shift, change_time, new_shift, start_time)
   $ARPANET_host_number (host_num)
   $resource_price (price_name, price, code)
   $resource_price_rs (rs_number, price_name, price, code)
   $rs_name (rs_number, rs_name, code)
   $rs_number (rs_name, rs_number, code)
   $max_rs_number (rs_count)

   See AN-66 (AS PLM) for documentation of the following internal interfaces:

   $abs_chn (evchn, pid)
   $request_chn (pid, event_channel, mseg_dname, mseg_ename)

   Written by THVV
   Modified 741231 by PG to add entries for new AIM fields.
   Modified 750324 by PG to rename $dial_chn to $request_chn.
   Modified 750912 by PG to give request facility its own process id.
   Modified 751103 by PG to complain if can't initiate whotab/installation_parms.
   Modified April 1976 by T. Casey to return shift start time as fourth argument to next_shift_change entry point.
   Modified 761229 by D. M. Wells to add $ARPANET_host_number entry point.
   Modified May 1978 by T. Casey to add resource_price entry point.
   Modified November 1978 by T. Casey for MR7.0 to add arguments to abs_limits entry point.
   Modified July 1979 by J. N. R. Barnecut for MR8.0 to add rate_structure entry points. (UNCA)
   Modified Feb 1980 by M. B. Armstrong for further changes re rate_structure. (UNCA)
   Modified 17 September 1980 by G. Palter to add default_absentee_queue entrypoint.
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures.
   Modified May 1983 by Art Beattie to add version_id entry.
*/

    return;

/* parameters */

dcl  rs_number fixed bin,
     rs_name char (*),
     ndev fixed bin,
     devp ptr;

/* external variables */

dcl  error_table_$no_entry ext fixed bin (35);

/* entries */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  active_all_rings_data$version_id ext char (8);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  datebin_$next_shift_change entry (fixed bin (71), fixed bin (71), fixed bin, fixed bin);
dcl  get_pdir_ entry () returns (char (168));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));


/* automatic */

dcl  ap ptr,                    /* ptr to arg */
     al fixed bin,                  /* lth of arg */
     arg_offset fixed bin,
     cur_rs_ptr ptr init (null),
     ec fixed bin (35),
     nargs fixed bin,
    (i, j) fixed bin,
     t71 fixed bin (71),
    (t1, t2) fixed bin;

/* based */

dcl  bchr char (al) based (ap),         /* character arg */
     bfix fixed bin (35) based (ap),            /* fixed bin arg */
     bflo float bin (27) based (ap),            /* float bin arg */
     b71 fixed bin (71) based (ap),         /* dbl prec arg */
     b36 bit (36) aligned based (ap),           /* bit (36) arg */
     bfa (0: 7) float bin (27) based (ap),      /* float array arg */
     based_fixed_array (4) fixed bin (35) based (ap),   /* fixed array arg */
     based_shift_queue_array (0:7, 4) fixed bin (35) based (ap); /* array arg for per-shift-and-queue absentee parms */

/* internal static */

dcl (whoptr, pp) ptr int static init (null);
dcl  rs_ptrs (0:9) ptr int static init ((10) null);
dcl  ip ptr defined (rs_ptrs (0));
dcl  sysdir char (168) int static init (">system_control_1");

/* builtins */

dcl (char, clock, fixed, hbound, ltrim, max, null) builtin;

/* include files */

%include installation_parms;

%include rate_structure;

%include whotab;

%include pitmsg;

%include user_attributes;

/* ======================================================== */

installation_id: entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);       /* Get ptr to string argument. */
    if ec ^= 0 then return;
    bchr = installation_parms.installation_id;

    return;

/* -------------------------------------------------------- */

sysid:  entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    bchr = whotab.sysid;

    return;


/* -------------------------------------------------------- */

version_id:
    entry;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    bchr = active_all_rings_data$version_id;

    return;

/* -------------------------------------------------------- */

titles: entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    bchr = installation_parms.company;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0 then return;
    bchr = installation_parms.department;
    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0 then return;
    bchr = installation_parms.companyds;
    call cu_$arg_ptr (4, ap, al, ec);
    if ec ^= 0 then return;
    bchr = installation_parms.departmentds;

    return;

/* -------------------------------------------------------- */

users:  entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    bfix = whotab.mxusers;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0 then return;
    bfix = whotab.n_users;
    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0 then return;
    bfix = whotab.mxunits;
    call cu_$arg_ptr (4, ap, al, ec);
    if ec ^= 0 then return;
    bfix = whotab.n_units;

    return;

/* -------------------------------------------------------- */

timeup: entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    b71 = whotab.timeup;

    return;

/* -------------------------------------------------------- */

next_shutdown: entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    b71 = whotab.nextsd;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0 then return;
    if whotab.why < "" then bchr = "";
    else bchr = whotab.why;
    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0 then return;
    b71 = whotab.until;

    return;

/* -------------------------------------------------------- */

last_shutdown: entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    b71 = whotab.lastsd;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0 then return;
    bchr = whotab.erfno;

    return;

/* -------------------------------------------------------- */

rates:
prices: entry;

    call setup_user_rs;
    arg_offset = 0;

rates_join:
    call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
    if ec ^= 0 then return;
    do i = 0 to 7;
         bfa (i) = rate_structure.cpu_price (i);
    end;
    call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
    if ec ^= 0 then return;
    do i = 0 to 7;
         bfa (i) = rate_structure.log_base_price (i);
    end;
    call cu_$arg_ptr (arg_offset + 3, ap, al, ec);
    if ec ^= 0 then return;
    do i = 0 to 7;
         bfa (i) = rate_structure.io_ops_price (i);
    end;
    call cu_$arg_ptr (arg_offset + 4, ap, al, ec);
    if ec ^= 0 then return;
    do i = 0 to 7;
         bfa (i) = rate_structure.core_price (i);
    end;
    call cu_$arg_ptr (arg_offset + 5, ap, al, ec);
    if ec ^= 0 then return;
    bflo = rate_structure.disk_price;
    call cu_$arg_ptr (arg_offset + 6, ap, al, ec);
    if ec ^= 0 then return;
    bflo = rate_structure.registration_price;

    return;

/* -------------------------------------------------------- */

rates_rs:
prices_rs: entry (rs_number);

    call setup_rs (rs_number);
    arg_offset = 1;
    go to rates_join;

/* -------------------------------------------------------- */

device_rates:
device_prices: entry (ndev, devp);

dcl 1 dvt (16) aligned based,
    2 device_id char (8),
    2 device_price (0: 7) float bin;

    call setup_user_rs;
    arg_offset = 0;

device_rates_join:
    ndev = rate_structure.ndevices;
    call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
    if ec ^= 0 then return;
    if devp ^= null then do i = 1 to rate_structure.ndevices;
         devp -> dvt.device_id (i) = rate_structure.devtab.device_id (i);
         do j = 0 to 7;
        devp -> dvt.device_price (i, j) = rate_structure.devtab.device_price (i, j);
         end;
    end;

    return;

/* -------------------------------------------------------- */

device_rates_rs:
device_prices_rs: entry (rs_number, ndev, devp);

    call setup_rs (rs_number);
    arg_offset = 1;
    go to device_rates_join;

/* -------------------------------------------------------- */

/* dcl system_info_$abs_limits ((4) fixed bin (35), fixed bin (35), (0:7,4) fixed bin (35));
   call system_info_$abs_limits (default_cpu_limits, default_foreground_cpu_limit, max_cpu_limits); */


abs_limits:
    entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;

    based_fixed_array (*) = installation_parms.abs_cpu_default_limit (*);

    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0 then return;

    bfix = installation_parms.foreground_cpu_default_limit;

    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0 then return;

    based_shift_queue_array (*, *) = installation_parms.abs_cpu_max_limit (*, *);

    return;

/* -------------------------------------------------------- */

default_absentee_queue: entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;

    bfix = installation_parms.default_absentee_queue;

    return;

/* -------------------------------------------------------- */

abs_prices: entry;

    call setup_user_rs;
    arg_offset = 0;

abs_prices_join:
    call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
    if ec ^= 0 then return;
    do i = 1 to 4;
         bfa (i-1) = rate_structure.abs_cpu_price (i);
    end;
    call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
    if ec ^= 0 then return;
    do i = 1 to 4;
         bfa (i-1) = rate_structure.abs_mem_price (i);
    end;

    return;

/* -------------------------------------------------------- */

abs_prices_rs: entry (rs_number);

    call setup_rs (rs_number);
    arg_offset = 1;
    go to abs_prices_join;

/* -------------------------------------------------------- */

io_prices: entry;

    call setup_user_rs;
    arg_offset = 0;

io_prices_join:
    call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
    if ec ^= 0 then return;
    do i = 1 to 4;
         bfa (i-1) = rate_structure.iod_rec_price (i);
    end;

    return;

/* --------------------------------------------------------- */

io_prices_rs: entry (rs_number);

    call setup_rs (rs_number);
    arg_offset = 1;
    go to io_prices_join;

/* ------------------------------------------------------- */

abs_chn:    entry (ev, pid);

dcl  ev fixed bin (71), pid bit (36);

    if whoptr = null then call setup;

    call cu_$arg_count (nargs);

    ev = whotab.abs_event;
    if nargs > 1 then pid = whotab.abs_procid;

    return;

/* ------------------------------------------------------ */

next_shift_change: entry (curshft, shftime, newshft, starttime);

dcl (curshft, newshft) fixed bin, (shftime, starttime) fixed bin (71);

    call cu_$arg_count (nargs);

    call datebin_$next_shift_change ((clock ()), t71, t1, t2);
    curshft = t1;
    if nargs > 1 then shftime = t71;
    if nargs > 2 then newshft = t2;
    if nargs > 3 then do;
         if whoptr = null then call setup;
         starttime = whotab.last_shift_change_time;
    end;

    return;

/* -------------------------------------------------------- */

shift_table: entry (stt);

dcl  stt (336) fixed bin;

    if whoptr = null then call setup;

    do i = 1 to 336;
         stt (i) = fixed (installation_parms.shifttab (i), 3);
    end;

    return;

/* -------------------------------------------------------- */

request_chn:
    entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    b36 = whotab.request_process_id;

    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0 then return;
    b71 = whotab.request_channel;

    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0 then return;
    bchr = sysdir;

    call cu_$arg_ptr (4, ap, al, ec);
    if ec ^= 0 then return;
    bchr = "as_request.ms";

    return;

/* -------------------------------------------------------- */

access_ceiling:
    entry (access_ceiling);

dcl  access_ceiling bit (72) aligned;

    if whoptr = null then call setup;

    access_ceiling = installation_parms.access_authorization_ceiling;
    return;

/* -------------------------------------------------------- */

log_threshold:
    entry;

dcl (state char (al), npages fixed bin) based (ap);

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;

    i = installation_parms.syserr_log_copy_threshold;

    if i < 0 then state = "off";
    else if i = 0 then state = "default";
    else state = "on";

    call cu_$arg_ptr (2, ap, al, ec);
    if ec = 0 then npages = max (i, 0);

    return;

/* -------------------------------------------------------- */

level_names:
    entry;

dcl (long_level_names char (32), short_level_names char (8)) dim (0:7) based (ap);

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    long_level_names (*) = installation_parms.level_names (*);

    call cu_$arg_ptr (2, ap, al, ec);
    if ec = 0 then short_level_names (*) = installation_parms.short_level_names (*);

    return;

/* -------------------------------------------------------- */

category_names:
    entry;

dcl (long_category_names char (32), short_category_names char (8)) dim (18) based (ap);

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    long_category_names (*) = installation_parms.category_names (*);

    call cu_$arg_ptr (2, ap, al, ec);
    if ec = 0 then short_category_names (*) = installation_parms.short_category_names (*);

    return;

/* -------------------------------------------------------- */

ARPANET_host_number:
    entry;

    if whoptr = null then call setup;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0 then return;
    bfix = installation_parms.ARPANET_host_number;

    return;

/* -------------------------------------------------------- */

resource_price: entry (a_price_name, a_price, a_code);

dcl  a_price_name char (*);
dcl  a_price float bin;
dcl  a_code fixed bin (35);

dcl  error_table_$noentry ext fixed bin (35);

    call setup_user_rs;

resource_price_join:
    do i = 1 to rate_structure.nrscp;
         if a_price_name = rate_structure.resource (i).name then do;
        a_price = rate_structure.resource (i).price;
        a_code = 0;
        return;
         end;
    end;
    a_code = error_table_$noentry;
    a_price = 0;
    return;

/* -------------------------------------------------------- */

resource_price_rs: entry (rs_number, a_price_name, a_price, a_code);

    call setup_rs (rs_number);
    go to resource_price_join;

/* -------------------------------------------------------- */

rs_name:    entry (rs_number, rs_name, a_code);

    if whoptr = null then call setup;

    if rs_number < 0 | rs_number > whotab.n_rate_structures then do;
         a_code = error_table_$noentry;
         rs_name = " INVALID_RS_" || ltrim (char (rs_number)); /* leading space so it won't match any name */
    end;
    else do;
         a_code = 0;
         rs_name = installation_parms.rate_structures (rs_number);
    end;
    return;

/* --------------------------------------------------------- */

rs_number: entry (rs_name, rs_number, a_code);

    if whoptr = null then call setup;

    do i = 0 to whotab.n_rate_structures;
         if installation_parms.rate_structures (i) = rs_name then do;
        rs_number = i;
        a_code = 0;
        return;
         end;
    end;

    a_code = error_table_$noentry;
    rs_number = 0;
    return;

/* --------------------------------------------------------- */

max_rs_number: entry (rs_count);

dcl  rs_count fixed bin;

    if whoptr = null then call setup;
    rs_count = whotab.n_rate_structures;
    return;

/* --------------------------------------------------------- */

setup:  proc;

dcl  ec fixed bin (35);

         call hcs_$initiate (sysdir, "whotab", "", 0, 1, whoptr, ec);
         if whoptr = null
         then call com_err_ (ec, "system_info_", "^a>whotab", sysdir);

         call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, ec);
         if ip = null
         then call com_err_ (ec, "system_info_", "^a>installation_parms", sysdir);

    end setup;

/* --------------------------------------------- */

setup_rs:   proc (rsnum);

dcl  ec fixed bin (35);
dcl  rsnum fixed bin;
dcl  rsn fixed bin;
dcl  en char (32);

         if whoptr = null then call setup;

         if rsnum < 0 | rsnum > whotab.n_rate_structures then do;
        call com_err_ (0, "system_info_", "Invalid rate_structure number ^d. Default rates will be used.", rsnum);
        rsn = 0;
         end;
         else rsn = rsnum;

         if rs_ptrs (rsn) = null then do;
        en = "rate_structure_" || ltrim (char (rsn));
        call hcs_$initiate (sysdir, en, "", 0, 0, rs_ptrs (rsn), ec);
        if rs_ptrs (rsn) = null then do;
             call com_err_ (ec, "system_info_", "^a>^a.  Default rates will be used.", sysdir, en);
             rsn = 0;           /* user loses if rsn already 0 */
        end;
         end;
         cur_rs_ptr = rs_ptrs (rsn);

    end setup_rs;

/* --------------------------------------------- */

setup_user_rs: proc;

dcl  ec fixed bin (35);
dcl  rsn fixed bin;

         if pp = null then call hcs_$initiate (get_pdir_ (), "pit", "", 0, 1, pp, ec);
         if pp = null then do;
        call com_err_ (ec, "system_info_", "pit");
        rsn = 0;
         end;
         else rsn = pp -> pit.rs_number;
         call setup_rs (rsn);

    end setup_user_rs;

/* --------------------------------------------- */

test_system_info: entry (xdirn);

dcl  xdirn char (*) parameter;
dcl  nsd char (168);

    call absolute_pathname_ (xdirn, nsd, ec);
    if ec ^= 0 then do;
         call com_err_ (ec, "system_info_$test_system_info", xdirn);
         return;
    end;
    sysdir = nsd;
    if whoptr ^= null then          /* need to cleanup? */
         call hcs_$terminate_noname (whoptr, ec);
    whoptr = null;              /* re-initiate whotab and installation_parms */
    do i = 0 to hbound (rs_ptrs, 1);        /* more tidying? */
         if rs_ptrs (i) ^= null then do;
        call hcs_$terminate_noname (rs_ptrs (i), ec);
        rs_ptrs (i) = null;
         end;
    end;

    return;

     end system_info_;
\014



            user_info_.pl1                  11/03/82  1450.9rew 11/03/82  1430.8      142425



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style2 */

user_info_:
     proc;

/* USER_INFO_ - procedure to return selected information from the PIT

   The information returned was put there by the procedure "cpg_"
   when the process was created.

   The following entries exist:

   .    user_info_$user_info_ (name, proj, acct)
   .    user_info_$whoami (name, proj, acct)
   .    user_info_$login_data (name, proj, acct, anon, stby, weight, time_login, login_word)
   .    user_info_$usage_data (n_processes, cputime_old_procs, time_login, time_proc_create,core_old_procs,io_old_procs)
   .    user_info_$homedir (home_directory)
   .    user_info_$responder (login_responder)
   .    user_info_$tty_data (terminal_id, terminal_type, channel_id, line_type)
   .    user_info_$terminal_data (terminal_id, terminal_type_name, channel_id, line_type, charge_type)
   .      user_info_$service_type (service_type)
   .      user_info_$process_type (process_type)
   .    user_info_$logout_data (logout_channel, logout_processid)
   .    user_info_$login_line (login_string)
   .    user_info_$absentee_queue (q)
   .    user_info_$absin (path)
   .    user_info_$absout (path)
   .    user_info_$outer_module (om)
   .    user_info_$load_ctl_info (group, sb, bumpclock, weight)
   .    user_info_$attributes (att)
   .    user_info_$limits (mlim, clim, cdate, crf, shlim, msp, csp, shsp)
   .    user_info_$rs_name (rs_name)
   .    user_info_$rs_number (rs_number)
   .    user_info_$absentee_request_id (request_id)

   If an entry which takes multiple arguments is called with too few arguments,
   only those supplied will be set.

   THVV 9/70
   Modified 761229 by D. M. Wells to add $service_type and $process_type entry
   points, to add line_type parameter to $tty_data, and to get info for
   $tty_data from PIT rather than the user_i/o IOSIM.
   Modified 6/20/77 by J. Stern to add $terminal_data (obsoletes $tty_data)
   Modified April 1979 by T. Casey to return correct information in foreground absentee jobs.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures.
   Modified December 1981 by E. N. Kittlitz for login_arg_ptr, login_arg_count.
   Modified 11/81 by B. Margulies for sub_err_ vs. com_err_.
   Modified 10/82 by E. N. Kittlitz for absentee_request_id.
 */

    dcl     arg_infop        pointer;
    dcl     arg_offset       fixed bin;
    dcl     (pp, whoptr)     pointer,
            i            fixed bin,
            ii       fixed bin,
            hcs_$initiate    entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
                 fixed bin (35)),
                  current_validation     fixed bin (3),
            hcs_$level_set         entry (fixed bin (3)),
                hcs_$level_get         entry (fixed bin (3)),
                get_ring_        entry() returns(fixed bin(3)),
            get_pdir_        entry returns (char (168)),
            format_attributes_   entry (ptr, char (*) var),
            ec       fixed bin (35),
            sub_err_         entry options (variable),
            sysdir       char (64) int static init (">system_control_dir") options (constant),
            system_info_$device_prices
                 entry (fixed bin, ptr),
            system_info_$rs_name     entry (fixed bin, char (*), fixed bin (35)),
            cu_$arg_count    entry (fixed bin, fixed bin (35)),
            cu_$arg_ptr      entry (fixed bin, ptr, fixed bin, fixed bin (35));

    dcl     error_table_$noarg   fixed bin (35) ext static;

    declare n_args       fixed bin;
    dcl     1 dvt        (16),
        2 device_id  char (8),
        2 device_price   (0:7) float bin;

    dcl     ndev         fixed bin;

    dcl     ap       ptr,
            al       fixed bin,
            bchr         char (al) based (ap) unaligned,
            bfix         fixed bin (35) based (ap),
            bf17         fixed bin based (ap),
            bf21         fixed bin (21) based (ap),
            bf71         fixed bin (71) based (ap),
            bflt         float bin based (ap),
            bb36         bit (36) based (ap),
            bptr         ptr based (ap),
            tvcs         char (512) var,
            bftary       (0:7) float bin based (ap);
    dcl     (addr, null, index, substr)
                 builtin;


%include pit;
%include user_attributes;

%include whotab;

%page;

fillpp:
     proc;                  /* internal proc to fill in PIT ptr on first call */

    declare whotab_$         bit (36) aligned external static;
    declare linkage_error    condition;

    on linkage_error                /* AS12.0 INSTALLATION KLUGE */
         begin;             /* to be removed after hardcore is installed */

              call hcs_$level_get (current_validation);
                  call hcs_$level_set (get_ring_ ());
        call hcs_$initiate ((get_pdir_ ()), "pit", "pit_", 0, 1, pp, ec);
        call hcs_$level_set (current_validation);
        if pp = null
        then call sub_err_ (ec, "user_info_", "s", null (), "pit");
         end;                   /* END OF KLUGE */

    pp = addr (pit_$);              /* we depend on this refname being in the environment */
    on linkage_error
         begin;

              call hcs_$level_get (current_validation);
                  call hcs_$level_set (get_ring_ ());
        call hcs_$initiate (sysdir, "whotab", "whotab_", 0, 1, whoptr, ec);
        call hcs_$level_set (current_validation);
        if whoptr = null
        then call sub_err_ (ec, "user_info_", "s", null (), "whotab");
         end;

    whoptr = addr (whotab_$);

     end fillpp;

%page;

whoami:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.login_name;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.project;
    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.account;

    return;

login_data:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.login_name;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.project;
    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.account;
    call cu_$arg_ptr (4, ap, al, ec);
    if ec ^= 0
    then return;
    bfix = pp -> pit.anonymous;
    call cu_$arg_ptr (5, ap, al, ec);
    if ec ^= 0
    then return;
    i = pp -> pit.whox;              /* use current data from whotab */
    if i = 0
    then bfix = pp -> pit.standby;       /* oof. unlisted users */
    else bfix = whotab.e (i).stby;      /* user may have been promoted since login */
    call cu_$arg_ptr (6, ap, al, ec);
    if ec ^= 0
    then return;
    bfix = pp -> pit.user_weight;
    call cu_$arg_ptr (7, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.login_time;
    call cu_$arg_ptr (8, ap, al, ec);
    if ec ^= 0
    then return;
    if pp -> pit.anonymous = 1
    then bchr = "enter";
    else bchr = "login";

    return;

usage_data:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bfix = pp -> pit.n_processes;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.old_proc_cpu;
    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.login_time;
    call cu_$arg_ptr (4, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.proc_creation_time;
    call cu_$arg_ptr (5, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.old_proc_core;
    call cu_$arg_ptr (6, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.old_proc_io_ops;

    return;

homedir:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.homedir;

    return;

responder:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.login_responder;

    return;

tty_data:
     entry;

    call fillpp;

    if pp -> pit.process_type = 2
    then do;
        call cu_$arg_ptr (1, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = "abs";
        call cu_$arg_ptr (2, ap, al, ec);
        if ec ^= 0
        then return;
        bfix = pp -> pit.tty_type;
        call cu_$arg_ptr (3, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.tty;
        call cu_$arg_ptr (4, ap, al, ec);
        if ec ^= 0
        then return;
        bfix = pp -> pit.line_type;
         end;

    else do;
        call cu_$arg_ptr (1, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.tty_answerback;
        call cu_$arg_ptr (2, ap, al, ec);
        if ec ^= 0
        then return;
        bfix = pp -> pit.tty_type;
        call cu_$arg_ptr (3, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.tty;
        call cu_$arg_ptr (4, ap, al, ec);
        if ec ^= 0
        then return;
        bfix = pp -> pit.line_type;
         end;

    return;

terminal_data:
     entry;

    call fillpp;

    if pp -> pit.process_type = 2
    then do;
        call cu_$arg_ptr (1, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = "abs";
        call cu_$arg_ptr (2, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.term_type_name;
        call cu_$arg_ptr (3, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.tty;
        call cu_$arg_ptr (4, ap, al, ec);
        if ec ^= 0
        then return;
        bfix = pp -> pit.line_type;
        call cu_$arg_ptr (5, ap, al, ec);
        if ec ^= 0
        then return;
        if pp -> pit.charge_type = 0
        then bchr = "none";
        else do;
            call system_info_$device_prices (ndev, addr (dvt));
            bchr = dvt (pp -> pit.charge_type).device_id;
             end;
         end;

    else do;
        call cu_$arg_ptr (1, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.tty_answerback;
        call cu_$arg_ptr (2, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.term_type_name;
        call cu_$arg_ptr (3, ap, al, ec);
        if ec ^= 0
        then return;
        bchr = pp -> pit.tty;
        call cu_$arg_ptr (4, ap, al, ec);
        if ec ^= 0
        then return;
        bfix = pp -> pit.line_type;
        call cu_$arg_ptr (5, ap, al, ec);
        if ec ^= 0
        then return;
        if pp -> pit.charge_type = 0
        then bchr = "none";
        else do;
            call system_info_$device_prices (ndev, addr (dvt));
            bchr = dvt (pp -> pit.charge_type).device_id;
             end;
         end;

    return;

service_type:
     entry ();

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bfix = pp -> pit.service_type;

    return;

process_type:
     entry ();

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bfix = pp -> pit.process_type;

    return;

logout_data:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.logout_channel;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0
    then return;
    bb36 = pp -> pit.logout_pid;

    return;


login_line:
     entry;
    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.login_line;

    return;

absentee_queue:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    if pp -> pit.process_type = 2
    then bfix = pp -> pit.abs_queue;
    else bfix = -1;

    return;

load_ctl_info:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.group;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0
    then return;

    i = pp -> pit.whox;              /* use current data from whotab */
    if i = 0
    then do;                    /* unlisted user? */
        bfix = pp -> pit.standby;
        call cu_$arg_ptr (3, ap, al, ec);
        if ec ^= 0
        then return;
        bf71 = pp -> pit.cant_bump_until;
         end;
    else do;
        bfix = whotab.e (i).stby;
        call cu_$arg_ptr (3, ap, al, ec);
        if ec ^= 0
        then return;
        bf71 = whotab.e (i).cant_bump_until;
         end;
    call cu_$arg_ptr (4, ap, al, ec);
    if ec ^= 0
    then return;
    bfix = pp -> pit.user_weight;
    return;

attributes:
     entry (atts);

    dcl     atts         char (*) var;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    call format_attributes_ (addr (pp -> pit.at), tvcs);
    atts = tvcs;

    return;

absin:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;

    if pp -> pit.process_type ^= 2
    then bchr = "";
    else bchr = pp -> pit.input_seg;

    return;

absout:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;

    if pp -> pit.process_type ^= 2
    then bchr = "";
    else do;
        if pp -> pit.output_seg = ""
        then do;
            bchr = before (pp -> pit.input_seg, ".absin") || ".absout";
             end;
        else bchr = pp -> pit.output_seg;
         end;

    return;

outer_module:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bchr = pp -> pit.outer_module;

    return;

limits:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bflt = pp -> pit.dollar_limit;
    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0
    then return;
    bflt = pp -> pit.absolute_limit;
    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0
    then return;
    bf71 = pp -> pit.absolute_cutoff;
    call cu_$arg_ptr (4, ap, al, ec);
    if ec ^= 0
    then return;
    bfix = pp -> pit.absolute_increm;
    call cu_$arg_ptr (5, ap, al, ec);
    if ec ^= 0
    then return;
    do i = 0 to 7;
         bftary (i) = pp -> pit.shift_limit (i);
    end;
    call cu_$arg_ptr (6, ap, al, ec);
    if ec ^= 0
    then return;
    bflt = pp -> pit.dollar_charge;
    call cu_$arg_ptr (7, ap, al, ec);
    if ec ^= 0
    then return;
    bflt = pp -> pit.absolute_spent;
    call cu_$arg_ptr (8, ap, al, ec);
    if ec ^= 0
    then return;
    do i = 0 to 7;
         bftary (i) = pp -> pit.interactive (i).charge;
    end;
    return;

rs_name:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    call system_info_$rs_name ((pp -> pit.rs_number), bchr, ec);
    if ec ^= 0
    then call sub_err_ (ec, "user_info_", "s", null (), (0), "Rate structure ^d invalid.
Contact your system administrator.", pp -> pit.rs_number);
    return;

rs_number:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    bf17 = pp -> pit.rs_number;
    return;

login_arg_count:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    if pp -> pit.arg_info_ptr = 0
    then /* no login arguments */
         bf17 = 0;
    else bf17 = ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_count;

    call cu_$arg_ptr (2, ap, al, ec);
    if ec ^= 0
    then return;

    bf21 = 0;
    if pp -> pit.arg_info_ptr = 0
    then return;
    else do ii = 1 to ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_count;
        bf21 = max (ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_lengths (ii), bf21);
         end;

    call cu_$arg_ptr (3, ap, al, ec);
    if ec ^= 0
    then return;

    if pp -> pit.arg_info_ptr = 0
    then bf21 = 0;
    else bf21 = ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.ln_args;
    return;


login_arg_ptr:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec ^= 0
    then return;
    i = bf17;                   /* get argument number */
    call cu_$arg_ptr (2, ap, al, ec);       /* argument pointer */
    if ec ^= 0
    then return;

    if pp -> pit.arg_info_ptr = 0
    then do;
        arg_infop = null;
        i = -1;
         end;
    else arg_infop = ptr (pp, pp -> pit.arg_info_ptr);
    if i < 1
    then bptr = null;
    else if i > arg_infop -> arg_info.arg_count
    then do;
        bptr = null;
        i = -1;
         end;
    else do;
        arg_offset = 1;
        do ii = 1 to i - 1;
             arg_offset = arg_offset + arg_infop -> arg_info.arg_lengths (ii);
        end;
        bptr = addr (substr (arg_infop -> arg_info.args, arg_offset, 1));
                        /* illegal pl1 */
         end;
    call cu_$arg_ptr (3, ap, al, ec);       /* argument length */
    if ec ^= 0
    then return;
    if i < 0
    then bf21 = 0;
    else bf21 = arg_infop -> arg_info.arg_lengths (i);
    call cu_$arg_ptr (4, ap, al, ec);       /* return code */
    if ec ^= 0
    then return;
    if i < 0
    then bfix = error_table_$noarg;
    else bfix = 0;
    return;


absentee_request_id:
     entry;

    call fillpp;

    call cu_$arg_ptr (1, ap, al, ec);
    if ec = 0
    then bf71 = pp -> pit.request_id;
    return;

     end user_info_;
\014



            where.pl1                       10/12/82  1155.2rew 10/12/82  1155.0      148779



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


where: wh: procedure options (variable);

/* This command prints the primary pathname of the first segment or
   entry point with a given name found using the object segment search rules.

   Usage:
   where names -control_args-

   where control_args are:

   -all, -a     list all segments or entry points in the search path.
   -inhibit_error, -ihe supress error message when segment not found and returns null string as AF.
   -entry_point, -ep    look for name$name when name does not contain a $.
   -segment, -sm        look for the segment named name even if name contains a $.

   The default is to look for an entry point if name contains a $, segment otherwise.

   Usage as an active function:

   [where name -control_arg-]

   where control_arg is either -entry_point (-ep) or -segment (-sm).
*/
/* Written 3/5/76 by Steve Herbst */
/* Entry point feature added 12/3/76 by S. Herbst */
/* fixed to show orig not copy if uninitiated seg has copysw on 03/20/80 S. Herbst */
/* Modified: 06/06/80, W. Olin Sibert, to add where -brief */
/* Fixed to work on gates 07/15/81 S. Herbst */
/* Fixed bugs and made -brief -all work 10/06/82 S. Herbst */


%include access_mode_values;

%include branch_status;

%include object_info;
dcl 1 obj_info like object_info;

dcl  refnames (32) char (168);

dcl 1 search_rules aligned,             /* from hcs_$get_search_rules */
    2 rule_count fixed bin,
    2 rule (21) char (168);

dcl 1 search_dirs (21),             /* directories to search through */
    2 dir char (168),
    2 uid bit (36),
    2 rule_number fixed bin;

dcl  area area based (area_ptr);

dcl  arg char (arg_len) based (arg_ptr);
dcl  return_arg char (return_len) varying based (return_ptr); /* if called as active function */
dcl  primary_name char (32) aligned based;
dcl (dn, entry_point_name, name) char (168);
dcl (en, unique_name) char (32);
dcl  out_str char (256);

dcl (af_sw, all_sw, brief_sw, long_sw, all_entry_points, all_segments, entry_point, inhibit_error, printed_sw,
     search_manually, some_output, some_segs, terminate, try_initiated_segs) bit (1) aligned;

dcl (area_ptr, arg_ptr, entry_point_ptr, names_ptr, return_ptr, seg_ptr) ptr;

dcl  fmode fixed bin (5);
dcl (arg_count, arg_len, dir_count, refname_count, return_len) fixed bin;
dcl (argno, dir_idx, idx, refname_idx, uid_idx) fixed bin;
dcl  bit_count fixed bin (24);
dcl  code fixed bin (35);

dcl (error_table_$badopt,
     error_table_$inconsistent,
     error_table_$dirseg,
     error_table_$no_dir,
     error_table_$no_s_permission,
     error_table_$noentry,
     error_table_$entlong,
     error_table_$not_act_fnc) fixed bin (35) external static;

dcl  complain entry variable options (variable);        /* com_err_ or active_fnc_err_ */
dcl  get_arg variable entry (fixed bin, ptr, fixed bin, fixed bin (35));

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  get_wdir_ entry returns (char (168));
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$get_search_rules entry (ptr);
dcl  hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_name entry (char (*), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

dcl  WHOAMI char (32) internal static options (constant) init ("where");

dcl  cleanup condition;

dcl (addr, bit, char, hbound, index, length, null, ptr, rtrim, substr) builtin;

/* \014 */

    all_sw, all_entry_points, all_segments, brief_sw = "0"b;
    inhibit_error, long_sw, search_manually, some_output = "0"b;
    names_ptr = null ();
    area_ptr = get_system_free_area_ ();

    call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
    if code = error_table_$not_act_fnc then do;
         af_sw = "0"b;
         complain = com_err_;
         get_arg = cu_$arg_ptr;
    end;
    else do;
         af_sw = "1"b;
         complain = active_fnc_err_;
         get_arg = cu_$af_arg_ptr;
         return_arg = "";
    end;

    if arg_count = 0 then do;
USAGE:       if af_sw then call active_fnc_err_ (0, WHOAMI, "Usage:  [^a refname {-control_args}]", WHOAMI);
         else call com_err_ (0, WHOAMI, "Usage:  ^a refnames {-control_args}", WHOAMI);
         goto MAIN_RETURN;
    end;

    on condition (cleanup) call clean_up;

    refname_count = 0;

    do argno = 1 to arg_count;
         call get_arg (argno, arg_ptr, arg_len, code);

         if char (arg, 1) ^= "-" then do;       /* a refname we should locate */
        refname_count = refname_count+1;
        if refname_count > hbound (refnames, 1) then do;
             call complain (0, WHOAMI, "Too many reference names specified. Max is ^d.",
            hbound (refnames, 1));
             goto MAIN_RETURN;
        end;

        refnames (refname_count) = arg;
         end;

         else if (arg = "-all" | arg = "-a") then
        if af_sw then do;
AF_BAD_OPT:
             call complain (0, WHOAMI, "Control arg not allowed for the active function.  ^a", arg);
             return;
        end;
        else all_sw = "1"b;

         else if (arg = "-long" | arg = "-lg") then
        if af_sw then go to AF_BAD_OPT;
        else do;
             long_sw = "1"b;
             brief_sw = "0"b;
        end;

         else if (arg = "-brief" | arg = "-bf") then
        if af_sw then go to AF_BAD_OPT;
        else do;
             brief_sw = "1"b;
             long_sw = "0"b;
        end;

         else if (arg = "-entry_point") | (arg = "-ep") then all_entry_points = "1"b;
         else if (arg = "-segment") | (arg = "-sm") then all_segments = "1"b;

         else if (arg = "-inhibit_error") | (arg = "-ihe") then inhibit_error = "1"b;
         else if (arg = "-no_inhibit_error") | (arg = "-nihe") then inhibit_error = "0"b;
         else do;
        call complain (error_table_$badopt, WHOAMI, "^a", arg);
        goto MAIN_RETURN;
         end;
    end;

    if refname_count = 0 | (af_sw & refname_count > 1) then
         goto USAGE;

    if all_entry_points & all_segments then do;
         call complain (error_table_$inconsistent, WHOAMI, "-segment and -entry_point");
         goto MAIN_RETURN;
    end;

    if all_sw & ^brief_sw then long_sw = "1"b;

    if long_sw | all_sw then do;            /* must get search rules, to locate manually */

         search_manually = "1"b;

         call hcs_$get_search_rules (addr (search_rules));
         dir_count = 0;
         try_initiated_segs = "0"b;

         do idx = 1 to rule_count;          /* find all the genuine directories */
        if rule (idx) = "initiated_segments" then try_initiated_segs = "1"b;
        else if rule (idx) ^= "referencing_dir" then do;
             dir_count = dir_count + 1;
             if rule (idx) = "working_dir" then dir (dir_count) = get_wdir_ ();
             else dir (dir_count) = rule (idx);
             rule_number (dir_count) = idx;
             end;
         end;
    end;

/* \014 */

    do refname_idx = 1 to refname_count;        /* Now, decide what to do with each of out reference name */

         name = refnames (refname_idx);

         idx = index (name, "$");
         if (idx ^= 0) & ^all_segments then do; /* name$entry */
        entry_point_name = substr (name, idx + 1);
        name = substr (name, 1, idx - 1);
        if entry_point_name = "" then entry_point = "0"b;
        else entry_point = "1"b;
         end;

         else if all_entry_points then do;      /* -entry_point specified */
        entry_point = "1"b;
        entry_point_name = name;
         end;

         else do;
        entry_point = "0"b;         /* reference name */
        entry_point_name = "";
         end;

         if length (rtrim (name)) > 32 then do;
        call complain (error_table_$entlong, WHOAMI, "^a", name);
        goto NEXT;
         end;

         else if length (rtrim (entry_point_name)) > 32 then do;
        call complain (error_table_$entlong, WHOAMI, "^a", entry_point_name);
        goto NEXT;
         end;

/* \014 */

         if ^search_manually then do;       /* locate by the usual (linker) mechanism */

        terminate = "0"b;
        call hcs_$fs_get_seg_ptr (name, seg_ptr, code); /* already initiated? */
        if seg_ptr = null then do;
             terminate = "1"b;
             call hcs_$make_ptr (null (), name, "", seg_ptr, code);
             if code ^= 0 then do;
            if ^inhibit_error then call complain (code, WHOAMI, "^a", name);
            goto NEXT;
             end;
        end;

        call hcs_$fs_get_path_name (seg_ptr, dn, (0), en, code);
        if code ^= 0 then do;
             call complain (code, WHOAMI, "^a", name);
             goto NEXT;
        end;

        if entry_point then do;

             call find_entry_point;

             if terminate then call hcs_$terminate_name (name, (0));
             if code ^= 0 then do;
            call complain (code, WHOAMI, "^a$^a", pathname_ (dn, en), entry_point_name);
            goto NEXT;
             end;
        end;

        else if terminate then call hcs_$terminate_name (name, code);

        call ioa_$rsnnl ("^a^[$^a^;^s^]", out_str, (0),
             pathname_ (dn, en), entry_point, entry_point_name);

        if af_sw then do;           /* just assign it to the return arg, and punt */
             return_arg = out_str;
             goto MAIN_RETURN;
        end;

        else call ioa_ ("^a", out_str);
         end;                   /* of searching non-manually (via hcs_$make_ptr) */

/* \014 */

         else do;               /* we must search for the segment manually */
                        /* Note that this is never done for an AF. */
        if (idx > 1) & some_output & all_sw then /* separate -all outputs by a blank line */
             call ioa_ ("");

        some_output, some_segs = "0"b;

        if try_initiated_segs then do;  /* search rules contained "initiated_segments" */
             dir_idx = 0;
             call hcs_$fs_get_seg_ptr (name, seg_ptr, code);
             if seg_ptr ^= null () then do;
            some_segs = "1"b;
            call hcs_$fs_get_path_name (seg_ptr, dn, (168), en, code);
            if code ^= 0 then call complain (code, WHOAMI, "^a", name);

            else do;
                 if entry_point then call find_entry_point ();

                 if code ^= 0 then call complain (code, WHOAMI,
                "^a$^a  Search rule ""initiated_segments""",
                pathname_ (dn, en), entry_point_name);

                 else call print_pathname ();

                 if ^all_sw then go to NEXT;
            end;
             end;               /* of successfully finding segment by refname */
        end;                /* of trying "initiated_segments" */

        do dir_idx = 1 to dir_count;        /* try to initiate in each of the dirs in the search rules */

             call hcs_$initiate (dir (dir_idx), name, "", 0, 1, seg_ptr, code);
             if seg_ptr ^= null then do;
            some_segs = "1"b;
            call hcs_$fs_get_path_name (seg_ptr, dn, (0), en, code);
            if code ^= 0 then do;
                 code = 0;
                 dn = dir (dir_idx);
                 en = name;
            end;

            if entry_point then call find_entry_point ();
            if code ^= 0 then call complain (code, WHOAMI, "^a$^a (Search rule ""^a"")",
                 pathname_ (dn, en), entry_point_name, rule (rule_number (dir_idx)));

            else call print_pathname ();

            call hcs_$terminate_noname (seg_ptr, (0));
            if ^all_sw then go to NEXT;
             end;               /* end of case for being able to initiate segment */

             else if code ^= error_table_$noentry & code ^= error_table_$no_dir & 
               code ^= error_table_$dirseg then do;

            some_output, some_segs = "1"b;

            if entry_point then call complain (code, WHOAMI, "^a (Search rule ""^a"")",
                 pathname_ (dir (dir_idx), name), rule (rule_number (dir_idx)));

            else do;
                 if brief_sw & all_sw then do;
                call hcs_$status_long (dir (dir_idx), name, 1, addr (branch_status), null, code);
                uid (dir_idx) = branch_status.unique_id;
                printed_sw = "0"b;
                do uid_idx = 1 to dir_idx - 1;    /* print each path only once */
                     if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
                end;
                if ^printed_sw then call ioa_ ("^a", pathname_ (dir (dir_idx), name));
                 end;
                 else do;
                call hcs_$status_ (dir (dir_idx), name, 1, addr (branch_status), area_ptr, code);
                if code = 0 then do;    /* print formatted line */
                     names_ptr = ptr (area_ptr, branch_status.names_rel_pointer);
                     if long_sw then call ioa_ ("^a (^a) Search rule ""^a""",
                    pathname_ (dir (dir_idx), (names_ptr -> primary_name)),
                    get_mode_letters (branch_status.mode), rule (rule_number (dir_idx)));
                     else call ioa_ ("^a", pathname_ (dir (dir_idx), name));

                     if ^all_sw then go to NEXT;
                end;

                else if code = error_table_$no_s_permission then
                     call complain (0, WHOAMI,
                    "No status permission on ^a (Search rule ""^a"")",
                    dir (dir_idx), rule (rule_number (dir_idx)));

                else if code ^= error_table_$noentry then
                     call complain (code, WHOAMI, "^a (Search rule ""^a"")",
                    dir (dir_idx), rule (rule_number (dir_idx)));

                else some_output = "0"b;
                 end;
            end;
             end;               /* of case for unable to initiate segment */
        end;                /* of loop through dirs in search rules */

        if ^some_output & ^inhibit_error then
             if entry_point & some_segs then call complain (0, WHOAMI, "Entry point not found.  ^a$^a",
            name, entry_point_name);
             else call complain (0, WHOAMI, "Segment not found. ^a", name);

         end;                   /* of case for searching manually */
NEXT:   end;                    /* end of refname loop */

MAIN_RETURN:
    call clean_up;
    return;

/* \014 */


clean_up:   proc;

    if names_ptr ^= null then free names_ptr -> primary_name in (area);

end clean_up;


find_entry_point: proc;

/* This internal procedure looks for an external definition. */

    call hcs_$fs_get_mode (seg_ptr, fmode, code);
    if fmode < R_ACCESS_BIN then do;     /* inner ring seg: gate? */
                        /* make sure make_ptr finds this one */
         unique_name = unique_chars_ ("0"b);
         call hcs_$initiate (dn, en, unique_name, 0, 1, seg_ptr, code);
         call hcs_$make_ptr (null, unique_name, entry_point_name, entry_point_ptr, code);
         call hcs_$terminate_name (unique_name, 0);
    end;
    else do;
         call hcs_$status_minf (dn, en, 1, (0), bit_count, code);
         call object_info_$brief (seg_ptr, bit_count, addr (obj_info), code);
         if code ^= 0 then return;
         call get_definition_ (obj_info.defp, name, entry_point_name, null, code);
    end;

end find_entry_point;


print_pathname: proc;

    some_output = "1"b;
    call hcs_$fs_get_mode (seg_ptr, fmode, code);
    if code ^= 0 then fmode = 0;

    if long_sw then do;
         call ioa_$nnl ("^a^[$^a^;^s^] (^a) Search rule ",
        pathname_ (dn, en), entry_point, entry_point_name, get_mode_letters (bit (fmode)));
         if dir_idx = 0 then call ioa_ ("""initiated_segments""");
         else call ioa_ ("""^a""", rule (rule_number (dir_idx)));
    end;
    else do;
         call hcs_$status_long (dn, en, 1, addr (branch_status), null, code);
         uid (dir_idx) = branch_status.unique_id;
         printed_sw = "0"b;
         do uid_idx = 1 to dir_idx-1;       /* only print each path once */
        if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
         end;
         if ^printed_sw then call ioa_ ("^a", pathname_ (dn, en));
    end;

end print_pathname;


get_mode_letters: proc (mode_bits) returns (char (4)varying);

dcl  mode_bits bit (5);
dcl  amode char (4) varying;

    amode = "";
    if substr (mode_bits, 2, 1) ^= "0"b then amode = "r";
    if substr (mode_bits, 3, 1) ^= "0"b then amode = amode||"e";
    if substr (mode_bits, 4, 1) ^= "0"b then amode = amode||"w";
    if amode = "" then amode = "null";
    return (amode);

end get_mode_letters;

end where;
\014



            who.pl1                         11/09/82  1212.0rew 11/09/82  1211.8      144135



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style4 */
who: procedure;

/* WHO - print information about who's on Multics.

   HMU, HOW_MANY_USERS - give header lines with nusers and load.

   This command types out the userid's of listed logged-in users
   from the segment "whotab", which is maintained by the answering service
   program "lg_ctl_". The possible arguments are as follows:

   .      -bf       suppress header  (not allowed for af)
   .    -lg print "long who"  (not allowed for af)
   .    -nm sort lines on user name
   .    -pj sort lines on project id
   .        (the default sort is by time logged in)
   .    -as print information on absentee users
   .    -ia print information on interactive users
   .    -dmn    print information on daemon users
   .        (default is -as -ia if none of -as -ia -dmn given)
   .      -all      -as, -ia -dmn
   .    Name    list only users with person name "Name"
   .    .Proj   list only users with project name "Proj"
   .    Name.Proj   list only users with person name "Name" and project "Proj"

   Initial coding by THVV, 9/6/70 */
/* changed for absentee by EDS 7/71 */
/* various changes by RBR 7/72      */
/* error messages changed 09/15/78 S. Herbst */
/* Modified May 1979 by T. Casey and S. Herbst for MR7.0a to add -interactive and -daemon,
   and to list foreground absentee users correctly */
/* who active function added 01/12/81 S. Herbst */
/* 12/24/81 E. N. Kittlitz.  whotab changes */
/* 9/82 BIM -all, no daemons by default */
/* 11/82 E. N. Kittlitz. list daemons if name explicitly given, do selection for af call */

dcl  return_arg char (return_len) varying based (return_ptr);
dcl  return_ptr ptr;
dcl  return_len fixed bin;
dcl  af_sw bit (1);


dcl  argno fixed bin init (1),          /* number of argument */
     arg_count fixed bin,
     ap ptr,                    /* ptr to argument */
     al fixed bin,                  /* lth of argument */
     ec fixed bin (35),             /* file-system error code */
     (f1, f2) float bin,                /* conversion temps */
     sort fixed bin init (0),               /* type of sort. 0=date, 1=name, 2=proj */
     hmucnt fixed bin init (0),         /* number of names|projects in */
     abscnt fixed bin init (0),         /* hmucnt as absentee users */
     long bit (1) aligned init ("0"b),          /* 1 if long who wanted */
     abs bit (1) aligned init ("0"b),           /* 1 if listing absentee users */
     only_abs bit (1) aligned init ("0"b),      /* if only listing absentees */
     daemon bit (1) aligned init ("0"b),        /* if listing daemon users */
     interactive bit (1) aligned init ("0"b),       /* if listing interactive users */
     brief bit (1) aligned init ("0"b),         /* 1 for no heading at all */
     hmuflg bit (1) aligned init ("0"b),        /* selective hmu flag */
     selx fixed bin init (0),               /* if particular users wanted */
     dotl fixed bin,                /* location of dot in arg */
     nm (50) char (24) aligned,         /* user names wanted */
     pj (50) char (12) aligned,         /* user projs wanted */
     caller char (14) varying,          /* name of caller to com_err */
     why char (128) aligned,                /* reason for shutdown */
     arg char (al) unaligned based (ap),        /* pickup for args */
     sort_arg char (32) init (""),
     whoptr ptr int static init (null),         /* ptr to whotab */
     ip ptr int static init (null),         /* ptr to installation_parms */
     sysdir char (64) aligned int static init (">system_control_1"), /* name of dir in which who table resides */
     j fixed bin,                   /* index */
     d fixed bin,                   /* distance between sorted elems */
     last fixed bin,                /* highest index in whotab */
     swap fixed bin,                /* 1 if a swap was done */
     ajd fixed bin,                 /* temp for sort, ary(j+d) */
     sss char (1) aligned init ("s"),           /* pretty for user-not-on */
     (time, time1) char (16) aligned init (""),     /* ASCII time */
     aj fixed bin,                  /* temp, ary(j) */
     did fixed bin init (0),                /* count of lines printed */
     mark char (3) aligned,             /* denotation of absentee user if = "*" */
     k fixed bin;                   /* index */

%include whotab;

%include installation_parms;

dcl  complain entry variable options (variable);

dcl  ioa_ ext entry options (variable),         /* library procedures */
     active_fnc_err_ entry options (variable),
     com_err_ ext entry options (variable),
     date_time_ ext entry (fixed bin (71), char (*) aligned),
     cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     hcs_$initiate ext entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     requote_string_ entry (char (*)) returns (char (*));

dcl  (divide, fixed, hbound, index, null, substr) builtin;
dcl  (error_table_$badopt,
     error_table_$not_act_fnc,
     error_table_$too_many_args) ext fixed bin;

/* - - - - - - - - - - */

    caller = "who";             /* set name of caller to com_err_ */
    go to join;

how_many_users: hmu: entry;

    caller = "how_many_users";
    hmuflg = "1"b;

join:
    call cu_$af_return_arg (arg_count, return_ptr, return_len, ec);
    if ec = error_table_$not_act_fnc then do;
         af_sw = "0"b;
         complain = com_err_;
    end;
    else if caller = "how_many_users" then do;
         call active_fnc_err_ (0, caller, "Cannot be called as an active function.");
         return;
    end;
    else do;
         af_sw = "1"b;
         complain = active_fnc_err_;
    end;

    do argno = 1 to arg_count;
         call cu_$arg_ptr (argno, ap, al, ec);  /* get nth argument */

         if arg = "-absentee" | arg = "-as" then abs = "1"b;
         else if arg = "-daemon" | arg = "-dmn" then daemon = "1"b;
         else if arg = "-interactive" | arg = "-ia" then interactive = "1"b;
         else if arg = "-all" | arg= "-a" then interactive, daemon, abs = "1"b;
         else if arg = "-name" | arg = "-nm" then sort = 1;
         else if arg = "-project" | arg = "-pj" then sort = 2;

         else if arg = "-brief" | arg = "-bf" then
        if af_sw then do;
BAD_AF_OPT:      call active_fnc_err_ (0, caller, "Invalid active function control arg ^a", arg);
             return;
        end;
        else brief = "1"b;
         else if arg = "-long" | arg = "-lg" then
        if af_sw then go to BAD_AF_OPT;
        else long = "1"b;

         else if substr (arg, 1, 1) = "-" then do;  /* then it must be a name or project */
bad_opt:        call complain (error_table_$badopt, caller, "^a", arg);
        return;
         end;
         else do;               /* save Name | .Project */
        selx = selx + 1;            /* up index in select array */
        if selx > hbound (nm, 1) then do;
             call complain (error_table_$too_many_args, caller);
             return;
        end;
        nm (selx), pj (selx) = "";      /* blank selectors */
        dotl = index (arg, ".");        /* where's the dot? */
        if dotl = 0 then nm (selx) = arg;   /* no dot. is user name. */
        else if dotl = 1 then pj (selx) = substr (arg, 2, al - 1);
        else do;                /* dot in middle, is name.proj */
             nm (selx) = substr (arg, 1, dotl - 1); /* get name */
             pj (selx) = substr (arg, dotl + 1, al - dotl);
        end;
         end;
         if sort ^= 0 & hmuflg then go to bad_opt;
    end;

    if ^interactive & ^abs & ^daemon then do;   /* if process type not specified */
         interactive, abs = "1"b;           /* default is to list abs and ia */
         if selx > 0 then daemon = "1"b;     /* but if name/proj given, list everything */
    end;
    only_abs = abs & ^interactive & ^daemon;    /* see if abs only */

go: if whoptr = null then do;           /* is this the first call? */
         call hcs_$initiate (sysdir, "whotab", "", 0, 1, whoptr, ec);
         if whoptr = null then do;
        call complain (ec, caller, "^a>whotab", sysdir);
        return;
         end;
    end;

    if ^brief & ^af_sw then do;         /* suppress header */
         if hmuflg then go to head;     /* always a header for hmu, except after brief */
         if selx = 0 then do;           /* no header with who select */
        if only_abs         /* what type absentee header if any */
        then if long
             then go to print_long_abs_totals;
             else go to print_abs_totals;
head:       f1 = whotab.n_units / 10.0e0;       /* format up units */
        f2 = whotab.mxunits / 10.0e0;       /* ... */
        j = whotab.n_users - whotab.abs_users - whotab.fg_abs_users - whotab.n_daemons; /* compute interactive users */

        if long then do;            /* long who? */
             if ip = null then do;
            call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, ec);
            if ip = null then do;
                 call complain (ec, caller, "Insufficient access for -long option");
                 return;
            end;
             end;
             call date_time_ (whotab.timeup, time); /* yup. make heading */
             call ioa_ ("^/Multics ^a; ^a", whotab.sysid, installation_parms.installation_id);
             call ioa_ ("Load = ^.1f out of ^.1f units; users = ^d, ^d interactive, ^d daemons.",
            f1, f2, whotab.n_users, j, whotab.n_daemons);
             if (whotab.abs_users + whotab.max_abs_users) ^= 0
             then               /* ! */
print_long_abs_totals:  call ioa_ ("^[^/^]Absentee users = ^d background^[, ^d foreground^;^s^]; Max background absentee users = ^d^[^/^]",
                 only_abs, whotab.abs_users, (whotab.fg_abs_users > 0), whotab.fg_abs_users, whotab.max_abs_users, only_abs);
             if only_abs then go to check_hmu;
             call ioa_ ("System up since ^a", time);
             if whotab.nextsd ^= 0 then do;
            why = whotab.why;
            if why < "" then why = "";
            call date_time_ (whotab.nextsd, time);
            if whotab.until = 0 then call ioa_ ("Scheduled shutdown at ^a ^a", time, why);
            else do;
                 call date_time_ (whotab.until, time1);
                 call ioa_ ("Scheduled shutdown from ^a to ^a ^a", time, time1, why);
            end;
             end;
             call date_time_ (whotab.lastsd, time);
             if whotab.erfno = "crash" then call ioa_ ("Last crash was at ^a^/", time);
             else if whotab.lastsd = 0 then call ioa_ ("");
             else if whotab.erfno = "" then call ioa_ ("Last shutdown was at ^a^/", time);
             else call ioa_ ("Last crash (ERF ^a) was at ^a^/", whotab.erfno, time);
             if hmuflg then if selx = 0 then return;
            else go to shell_sort;
             call ioa_ ("^4xLogin at^6xTTY  Load^3xUser ID^/");
        end;
        else do;                /* short who. */
             call ioa_ ("^/Multics ^a, load ^.1f/^.1f; ^d users, ^d interactive, ^d daemons.",
            whotab.sysid, f1, f2, whotab.n_users, j, whotab.n_daemons);
             if (whotab.max_abs_users + whotab.abs_users) ^= 0
             then               /* print absentee totals under certain conditions */
print_abs_totals:       call ioa_
                 ("^[^/^]Absentee users ^d/^d^[^x(+^d FG)^;^s^]^[^/^]",
                 only_abs, whotab.abs_users, whotab.max_abs_users, (whotab.fg_abs_users > 0), whotab.fg_abs_users, only_abs);
             if ^abs then call ioa_ ("");
        end;
         end;
    end;
check_hmu:
    if hmuflg & selx = 0            /* if a simple hmu entry then finished */
    then return;

shell_sort: last = whotab.laste;            /* save high limit on whotab */
    if hmuflg then go to count;         /* go to selective hmu counting */

    begin;

dcl  sort_array (last) fixed bin;

         do j = 1 to last;          /* set up sort array */
        sort_array (j) = j;         /* ... */
         end;

         d = last;              /* set up for Shell sort */
pass:        d = divide (d + 1, 2, 17, 0);      /* ... */
         swap = 0;              /* ... */
         do j = 1 to last - d;          /* comparison loop */
        aj = sort_array (j);        /* make temps */
        ajd = sort_array (j + d);       /* ... */
        if sort = 0 then if whotab.timeon (aj) > whotab.timeon (ajd) then go to ic;
        if sort = 1 then if whotab.person (aj) > whotab.person (ajd) then go to ic;
        if sort = 2 then if whotab.project (aj) > whotab.project (ajd) then go to ic;
             else if whotab.project (aj) = whotab.project (ajd) then if whotab.person (aj)
                 > whotab.person (ajd) then do; /* Are items in order? */
ic:              sort_array (j) = ajd;  /* No. Swap entries */
                 sort_array (j + d) = aj; /* ... */
                 swap = swap + 1;   /* remember a swap */
            end;
         end;
         if swap > 0 then go to pass;        /* if out of order do it again */
         if d > 1 then go to pass;       /* ... */



         if af_sw then return_arg = "";

         do j = 1 to last;          /* now the print loop */
        aj = sort_array (j);        /* set up speed temp */
        if whotab.active (aj) = 0 then go to skip; /* skip deads */
        if selx = 0 then go to print;       /* any users selected? */
        do k = 1 to selx;           /* check for selected users */
             if nm (k) = whotab.person (aj) then if pj (k) = "" then go to print;
            else if pj (k) = whotab.project (aj) then go to print;
             if nm (k) = "" then if pj (k) = whotab.project (aj) then go to print;
        end;
        go to skip;         /* user not in selected group */

print:
        if whotab.proc_type (aj) = 1 & ^interactive
             | whotab.proc_type (aj) = 2 & ^abs
             | whotab.proc_type (aj) = 3 & ^daemon
        then goto skip;

        if af_sw then do;
             if return_arg ^= "" then return_arg = return_arg || " ";
             return_arg = return_arg ||
            requote_string_ (rtrim (whotab.person (aj)) || "." || rtrim (whotab.project (aj)));
             go to skip;
        end;

        if whotab.proc_type (aj) ^= 2 then  /* if not absentee */
             mark = "";         /* clear absentee flag */
        else if whotab.fg_abs (aj) then /* if foreground absentee */
             mark = "*FG";          /* flag it as such */
        else mark = "*";            /* else flag it as background absentee */

        did = did + 1;          /* remember we did one */
        if long then do;            /* long who? */
             call date_time_ (whotab.timeon (aj), time); /* yup. */
             if substr (time, 1, 8) = substr (time1, 1, 8) then substr (time, 1, 8) = (8)" ";
                        /* Suppress date if it is the same as last printed date */
             else time1 = time;
             f1 = whotab.units (aj) / 10.0e0;   /* get nice units */
             call ioa_ ("^16a  ^4a ^4.1f^3x^a.^a^a^x^[D^]^[S^]",
            time, whotab.idcode (aj), f1, whotab.person (aj), whotab.project (aj),
            mark, whotab.disconnected (aj), whotab.suspended (aj));
        end;
        else do;                /* short who. */
             call ioa_ ("^a.^a^a^x^[D^]^[S^]", whotab.person (aj), whotab.project (aj), mark,
            whotab.disconnected (aj), whotab.suspended (aj));
        end;

skip:        end;

    end;

    if ^af_sw then do;
         if ^brief then

        if did = 0 then do;         /* if printed nobody */
             if selx = 1 then if nm (1) ^= "" then sss = "";
             call ioa_ ("User^a not logged in.", sss);
        end;

         call ioa_ ("");            /* extra CR */
    end;

    return;                 /* done. */

/* - - - - - - - - */


count:  do j = 1 to selx;               /* selective hmu counting */
         hmucnt = 0;                /* reset counters */
         abscnt = 0;

         if nm (j) = "" then do;            /* selected project counting */
        do aj = 1 to last;
             if pj (j) = whotab.project (aj) then
            if whotab.proc_type (aj) ^= 2
            then hmucnt = hmucnt + 1;
            else abscnt = abscnt + 1;
        end;
        call ioa_ (".^a = ^d + ^d*", pj (j), hmucnt, abscnt);
         end;

         if nm (j) ^= "" then
        if pj (j) ^= ""         /* selected name.project counting */
        then do;
             do aj = 1 to last;
            if nm (j) = whotab.person (aj)
            then if pj (j) = whotab.project (aj)
                 then if whotab.proc_type (aj) ^= 2
                then hmucnt = hmucnt + 1;
                else abscnt = abscnt + 1;
             end;
             call ioa_ ("^a.^a = ^d + ^d*", nm (j), pj (j), hmucnt, abscnt);
        end;
        else do;                /* selected name counting */
             do aj = 1 to last;

            if nm (j) = whotab.person (aj) then
                 if whotab.proc_type (aj) ^= 2
                 then hmucnt = hmucnt + 1;
                 else abscnt = abscnt + 1;
             end;
             call ioa_ ("^a = ^d + ^d*", nm (j), hmucnt, abscnt);
        end;
    end;
    return;

who_init: entry (system_directory);         /* entry used for testing who command */

dcl  system_directory char (*);

    sysdir = system_directory;          /* copy name of directory containing who table */

    whoptr = null;              /* set pointer to null */

    return;

     end who;

"This material is presented to ensure dissemination of scholarly and technical work. Copyright and all rights therein are retained by authors or by other copyright holders. All persons copying this information are expected to adhere to the terms and constraints invoked by each author's copyright. In most cases, these works may not be reposted without the explicit permission of the copyright holder."