1
2
3
4
5
6
7
8
9
10
11 run:
12 proc;
13
14
15
16
17
18
19
20
21
22 dcl (i, j, k, m, alng, nargs, nprogargs, ref_name_spec_count)
23 fixed bin;
24 dcl code fixed bin (35);
25 dcl type fixed bin (2);
26 dcl bit_cnt fixed bin (24);
27
28 dcl me char (3) init ("run") static options (constant);
29 dcl arg char (alng) based (aptr);
30 dcl (main_dir, arg_ec_name)
31 char (168);
32 dcl ec_name char (168) var;
33 dcl main_ename char (32);
34
35 dcl (no_ec, have_main) bit (1) aligned;
36
37 dcl (aptr, arglist_ptr, new_arglist_ptr, sys_areap)
38 ptr;
39
40 dcl (error_table_$noarg, error_table_$badopt)
41 fixed bin (35) ext;
42
43 dcl system_area area based (sys_areap);
44
45 dcl 1 control_structure aligned like run_control_structure;
46
47 dcl 1 char_desc aligned,
48 2 flag bit (1) unal init ("1"b),
49 2 type fixed bin (5) unal init (21),
50 2 packed bit (1) unal init ("1"b),
51 2 number_dims bit (4) unal init ("0"b),
52 2 size fixed bin (23) unal;
53
54 dcl 1 old_arglist aligned based (arglist_ptr),
55 2 (arg_count, code) fixed bin (17) unal,
56 2 (desc_count, mbz) fixed (17) unal,
57 2 args (nargs) ptr,
58 2 descs (nargs) ptr;
59
60 dcl 1 new_arglist aligned based (new_arglist_ptr),
61 2 (arg_count, code) fixed bin (17) unal,
62 2 (desc_count, mbz) fixed bin (17) unal,
63 2 args (nprogargs) ptr,
64 2 descs (nprogargs) ptr;
65
66 dcl (addr, hbound, length, null, rtrim, substr, unspec)
67 builtin;
68
69 dcl main_entry entry variable;
70
71 dcl cu_$arg_count entry () returns (fixed bin);
72 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
73 dcl cu_$arg_list_ptr entry () returns (ptr);
74 dcl com_err_ entry options (variable);
75 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
76 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
77 fixed bin (35));
78 dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
79 dcl hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35));
80 dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
81 dcl run_ entry (entry, ptr, ptr, fixed bin (35));
82 dcl get_wdir_ entry () returns (char (168));
83 dcl get_system_free_area_ entry () returns (ptr);
84
85
86 %include run_control_structure;
87 ^L
88 unspec (control_structure) = "0"b;
89 control_structure.version = run_control_structure_version_1;
90 no_ec = "0"b;
91 ref_name_spec_count = 0;
92
93 nargs = cu_$arg_count ();
94
95 do i = 1 to nargs;
96
97 call cu_$arg_ptr (i, aptr, alng, code);
98 if code ^= 0
99 then do;
100 if code = error_table_$noarg
101 then goto no_main;
102 call com_err_ (code, me);
103 return;
104 end;
105
106 if (arg = "-exec_com") | (arg = "-ec")
107 then do;
108 i = i + 1;
109 control_structure.flags.ec = "1"b;
110 no_ec = "0"b;
111 call cu_$arg_ptr (i, aptr, alng, code);
112 if code ^= 0
113 then do;
114 call com_err_ (code, me, "exec_com name");
115 return;
116 end;
117 ec_name = arg;
118 end;
119
120 else if (arg = "-no_exec_com") | (arg = "-nec")
121 then do;
122 control_structure.flags.ec = "0"b;
123 no_ec = "1"b;
124 end;
125
126 else if (arg = "-limit") | (arg = "-li")
127 then do;
128 i = i + 1;
129 call cu_$arg_ptr (i, aptr, alng, code);
130 if code ^= 0
131 then do;
132 call com_err_ (code, me, "time limit");
133 return;
134 end;
135 control_structure.time_limit = cv_dec_check_ (arg, code);
136 if code ^= 0
137 then do;
138 call com_err_ (0, me, "Invalid time limit specification ^a.", arg);
139 return;
140 end;
141 end;
142
143 else if (arg = "-copy_reference_names") | (arg = "-crn")
144 then do;
145 control_structure.reference_name_switch = COPY_REFERENCE_NAMES;
146 ref_name_spec_count = ref_name_spec_count + 1;
147 end;
148
149 else if (arg = "-old_reference_names") | (arg = "-orn")
150 then do;
151 control_structure.reference_name_switch = OLD_REFERENCE_NAMES;
152 ref_name_spec_count = ref_name_spec_count + 1;
153 end;
154
155 else if (arg = "-new_reference_names") | (arg = "-nrn")
156 then do;
157 control_structure.reference_name_switch = NEW_REFERENCE_NAMES;
158 ref_name_spec_count = ref_name_spec_count + 1;
159 end;
160
161 else if substr (arg, 1, 1) = "-"
162 then do;
163 call com_err_ (error_table_$badopt, me, arg);
164 return;
165 end;
166
167 else do;
168
169 if ^control_structure.flags.ec
170 then do;
171 call expand_pathname_ (arg, main_dir, main_ename, code);
172 if code ^= 0
173 then do;
174 call com_err_ (code, me, arg);
175 return;
176 end;
177 end;
178 have_main = "1"b;
179 goto setup_entry_var;
180 end;
181
182 end;
183
184 no_main:
185 have_main = "0"b;
186
187 setup_entry_var:
188 if ref_name_spec_count > 1
189 then do;
190 call com_err_ (0, me, "Only one reference name control argument may be specified.");
191 return;
192 end;
193
194 if control_structure.flags.ec
195 then if no_ec
196 then do;
197 call com_err_ (0, me, "Incompatible exec_com arguments specified.");
198 return;
199 end;
200
201 if ^control_structure.flags.ec
202 then if ^no_ec
203 then do;
204 if ^have_main
205 then do;
206 call com_err_ (0, me, "No exec_com or main program specified.");
207 return;
208 end;
209 call hcs_$status_minf (main_dir, rtrim (main_ename) || ".run.ec", 1, type, bit_cnt, code);
210 if code = 0
211 then do;
212 control_structure.flags.ec = "1"b;
213 ec_name = rtrim (main_dir) || ">" || rtrim (main_ename) || ".run.ec";
214 end;
215 end;
216
217 if control_structure.flags.ec
218 then do;
219
220 call hcs_$make_entry (null, "exec_com", "exec_com", main_entry, code);
221 if code ^= 0
222 then do;
223 call com_err_ (code, me, "exec_com");
224 return;
225 end;
226 i = i - 1;
227 end;
228
229 else do;
230 i = i + 1;
231 main_entry = cv_entry_ (arg, null, code);
232 if code ^= 0
233 then do;
234 call com_err_ (code, me, arg);
235 return;
236 end;
237 end;
238
239 if i > nargs
240 then nprogargs = 0;
241 else nprogargs = nargs - i + 1;
242
243 sys_areap = get_system_free_area_ ();
244 allocate new_arglist in (sys_areap -> system_area) set (new_arglist_ptr);
245
246 arglist_ptr = cu_$arg_list_ptr ();
247
248 new_arglist.arg_count, new_arglist.desc_count = nprogargs * 2;
249 new_arglist.code = 4;
250 if control_structure.flags.ec
251 then do;
252 m = 2;
253 arg_ec_name = ec_name;
254 new_arglist.args (1) = addr (arg_ec_name);
255 char_desc.size = length (ec_name);
256 new_arglist.descs (1) = addr (char_desc);
257 end;
258 else m = 1;
259
260 do j = m to nprogargs;
261 k = j + i - 1;
262 new_arglist.args (j) = old_arglist.args (k);
263 new_arglist.descs (j) = old_arglist.descs (k);
264 end;
265
266 call run_ (main_entry, new_arglist_ptr, addr (control_structure), code);
267
268 if code ^= 0
269 then call com_err_ (code, me);
270
271 free new_arglist_ptr -> new_arglist;
272
273 return;
274
275 end;