1
2
3
4
5
6
7
8
9
10
11
12
13
14 select:
15 procedure options (variable);
16
17
18
19 dcl afargl fixed bin (21);
20 dcl afargp ptr;
21 dcl afsw bit (1) aligned;
22 dcl argl fixed bin (21);
23 dcl argp ptr;
24 dcl code fixed bin (35);
25 dcl err entry options (variable) variable;
26 dcl err_suppress_name entry options (variable) variable;
27 dcl first bit (1) aligned;
28 dcl i fixed bin;
29 dcl nargs fixed bin;
30 dcl torf char (1500) varying;
31 dcl vargl fixed bin (21);
32 dcl vargp ptr;
33
34
35
36 dcl afarg char (afargl) based (afargp);
37 dcl arg char (argl) based (argp);
38 dcl varg char (vargl) varying based (vargp);
39
40
41
42 dcl null builtin;
43
44
45
46 dcl command char (6) internal static options (constant) initial ("select");
47
48
49
50 dcl error_table_$not_act_fnc
51 fixed bin (35) external static;
52
53
54
55 dcl active_fnc_err_ entry options (variable);
56 dcl active_fnc_err_$af_suppress_name
57 entry options (variable);
58 dcl com_err_ entry options (variable);
59 dcl com_err_$suppress_name entry options (variable);
60 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
61 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
62 dcl cu_$evaluate_active_string
63 entry (ptr, char (*), fixed bin, char (*) varying, fixed bin (35));
64 dcl ioa_$nnl entry options (variable);
65 dcl requote_string_ entry (char (*)) returns (char (*));
66
67 %include cp_active_string_types;
68 ^L
69
70
71 call cu_$af_return_arg (nargs, vargp, vargl, code);
72 if code = 0
73 then do;
74 afsw = "1"b;
75 err = active_fnc_err_;
76 err_suppress_name = active_fnc_err_$af_suppress_name;
77 varg = "";
78 end;
79 else if code = error_table_$not_act_fnc
80 then do;
81 afsw = "0"b;
82 err = com_err_;
83 err_suppress_name = com_err_$suppress_name;
84 end;
85 else do;
86 call com_err_ (code, command);
87 return;
88 end;
89
90 if nargs = 0
91 then do;
92 call err_suppress_name (0, command, "Usage: ^[[^]^a test_string {args}^[]^]", afsw, command, afsw);
93 return;
94 end;
95
96 call cu_$arg_ptr (1, afargp, afargl, code);
97 if code ^= 0
98 then do;
99 call err (code, command, "Argument 1.");
100 return;
101 end;
102
103 first = "1"b;
104 do i = 2 to nargs;
105 call cu_$arg_ptr (i, argp, argl, code);
106 if code ^= 0
107 then do;
108 call print_before_error;
109 call err (code, command, "Argument ^d.", i);
110 return;
111 end;
112
113 call cu_$evaluate_active_string (null, afarg || " " || requote_string_ (arg), NORMAL_ACTIVE_STRING, torf, code)
114 ;
115 if code ^= 0
116 then do;
117 call print_before_error;
118 call err (code, command, "[^a ^a]", afarg, requote_string_ (arg));
119 return;
120 end;
121
122 if torf = "true"
123 then do;
124 if afsw
125 then do;
126 if ^first
127 then varg = varg || " ";
128
129 varg = varg || requote_string_ (arg);
130 end;
131 else call ioa_$nnl ("^[^x^]^a", ^first, arg);
132
133 first = "0"b;
134 end;
135 else if torf ^= "false"
136 then do;
137 call print_before_error;
138 call err (0, command, "Test result for argument ^d (^a) is neither ""true"" nor ""false"". ^a", i,
139 requote_string_ (arg), requote_string_ ((torf)));
140 return;
141 end;
142 end;
143
144 if ^afsw
145 then call ioa_$nnl ("^/");
146
147 return;
148
149 print_before_error:
150 procedure;
151
152 if ^afsw & ^first
153 then call ioa_$nnl ("^/");
154 end print_before_error;
155
156 end select;