1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 
  7 /* SEVERITY - Command/Active Function to return the value (as a char string)
  8    of an external static severity value.
  9 
 10    Designed by Webber, Written 770729 by Green
 11    Modified 770914 by PG to restrict to just FORTRAN and PL/I for MR6.0 version
 12    Modified 4/80 by Michael R. Jordan to use get_external_variable_
 13    Modified 5/13/82 by L. Baldwin to fix the short name for -default to -dft.
 14 */
 15 
 16 severity:
 17      procedure options (variable);
 18 
 19 /* automatic */
 20 
 21 declare  active_function bit (1) aligned,
 22          arg_length fixed bin (21),
 23          arg_num fixed bin,
 24          arg_ptr ptr,
 25          argument_routine entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable,
 26          code fixed bin (35),
 27          default_arg_length fixed bin (21),
 28          default_arg_ptr ptr,
 29          error_routine entry options (variable) variable,
 30          n_args fixed bin,
 31          return_length fixed bin (21),
 32          return_ptr ptr,
 33          severity_string picture "-----------9",            /* room for sign + 11 digits */
 34          severity_value fixed bin (35),
 35          vdesc_ptr ptr,
 36          var_ptr ptr,
 37          var_size fixed bin (19);
 38 
 39 /* based */
 40 
 41 declare  arg_string char (arg_length) based (arg_ptr),
 42          default_arg_string char (default_arg_length) based (default_arg_ptr),
 43          return_value char (return_length) varying based (return_ptr),
 44          severity_variable fixed bin (35) based (var_ptr);
 45 
 46 /* builtins */
 47 
 48 declare  ltrim builtin;
 49 
 50 /* entries */
 51 
 52 declare  active_fnc_err_ entry options (variable),
 53          com_err_ entry options (variable),
 54          cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
 55          cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
 56          cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
 57          get_external_variable_ entry (char (*), ptr, fixed bin (19), ptr, fixed bin (35)),
 58          ioa_ entry options (variable);
 59 
 60 /* external static */
 61 
 62 declare (error_table_$badopt,
 63          error_table_$noarg,
 64          error_table_$not_act_fnc) fixed bin (35) external static;
 65 
 66 /* internal static */
 67 
 68 declare  my_name char (8) internal static init ("severity") options (constant);
 69 
 70 /* program */
 71 
 72           call cu_$af_return_arg (n_args, return_ptr, return_length, code);
 73           if code = 0
 74           then do;                                          /* called as active function */
 75                error_routine = active_fnc_err_;
 76                argument_routine = cu_$af_arg_ptr;
 77                active_function = "1"b;
 78                return_value = "";                           /* in case we get started after an error */
 79           end;
 80           else if code = error_table_$not_act_fnc           /* called as command */
 81           then do;
 82                error_routine = com_err_;
 83                argument_routine = cu_$arg_ptr;
 84                active_function = "0"b;
 85           end;
 86           else do;
 87                call com_err_ (code, my_name, "");
 88                return;
 89           end;
 90           if n_args = 0
 91           then do;
 92                call error_routine (error_table_$noarg, my_name, "^/Usage: severity indicator_name {-default STR}");
 93                return;
 94           end;
 95 
 96           default_arg_ptr = null ();
 97           do arg_num = 2 repeat arg_num+1 while (arg_num <= n_args);
 98                call argument_routine (arg_num, arg_ptr, arg_length, code);
 99                if code ^= 0
100                then do;
101                     call error_routine (code, my_name, "Unable to access argument #^d.", arg_num);
102                     return;
103                end;
104                if arg_string = "-default" | arg_string = "-dft"
105                then do;
106                     if arg_num = n_args
107                     then do;
108                          call error_routine (error_table_$noarg, my_name, "Default string missing following ^a.", arg_string);
109                          return;
110                     end;
111                     arg_num = arg_num+1;
112                     call argument_routine (arg_num, default_arg_ptr, default_arg_length, code);
113                     if code ^= 0
114                     then do;
115                          call error_routine (code, my_name, "Unable to access default string argument.");
116                          return;
117                     end;
118                end;
119                else do;
120                     call error_routine (error_table_$badopt, my_name, "^a", arg_string);
121                     return;
122                end;
123           end;
124 
125           call argument_routine (1, arg_ptr, arg_length, code);
126           if code ^= 0
127           then do;
128                call error_routine (code, my_name, "Unable to access argument #1.");
129                return;
130           end;
131 
132           call get_external_variable_ (arg_string || "_severity_", var_ptr, var_size, vdesc_ptr, code);
133           if code ^= 0
134           then do;
135                if default_arg_ptr = null ()
136                then do;
137                     call error_routine (code, my_name,
138                          "^/Error accessing severity indicator ^a.", arg_string);
139                     return;
140                end;
141                if active_function
142                then return_value = default_arg_string;
143                else call ioa_ ("^a", default_arg_string);
144                return;
145           end;
146 
147           if var_size ^= 1
148           then do;
149                call error_routine (0b, my_name, "The severity indicator ^a is not a single word variable.", arg_string);
150                return;
151           end;
152 
153           severity_value = severity_variable;
154           severity_string = severity_value;                 /* convert to pictured form */
155 
156           if active_function
157           then return_value = ltrim (severity_string);
158           else call ioa_ ("^a", ltrim (severity_string));
159 
160           return;
161 
162      end severity;