1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16 severity:
17 procedure options (variable);
18
19
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 "
34 severity_value fixed bin (35),
35 vdesc_ptr ptr,
36 var_ptr ptr,
37 var_size fixed bin (19);
38
39
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
47
48 declare ltrim builtin;
49
50
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
61
62 declare (error_table_$badopt,
63 error_table_$noarg,
64 error_table_$not_act_fnc) fixed bin (35) external static;
65
66
67
68 declare my_name char (8) internal static init ("severity") options (constant);
69
70
71
72 call cu_$af_return_arg (n_args, return_ptr, return_length, code);
73 if code = 0
74 then do;
75 error_routine = active_fnc_err_;
76 argument_routine = cu_$af_arg_ptr;
77 active_function = "1"b;
78 return_value = "";
79 end;
80 else if code = error_table_$not_act_fnc
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;
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;