1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35 basic:
36 proc;
37
38 dcl (i, k, input_length, code, err_count, arglen, bitcnt, arg_count)
39 fixed bin,
40 level fixed bin static init (0),
41 time_limit fixed bin (71) init (0),
42 time1 fixed bin (71),
43 (executing, got_path, had_bad_option)
44 bit (1),
45 work_seg ptr static init (null),
46 (source_info_pt, input_pt, output_pt)
47 ptr init (null),
48 (argpt, object_hold, main_pt)
49 ptr,
50 program_interrupt condition,
51 cleanup condition,
52 s char (1) varying,
53 arg char (arglen) based (argpt) unaligned,
54 my_name char (5) static init ("basic"),
55 (ent, sourcename) char (32),
56 (dir, wdir) char (168);
57
58 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
59 cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin),
60 cu_$ptr_call entry (ptr),
61 cv_dec_check_ entry (char (*) aligned, fixed bin) returns (fixed bin),
62 ioa_ entry options (variable),
63 (
64 active_fnc_err_,
65 com_err_,
66 com_err_$suppress_name
67 ) entry options (variable),
68 command_query_ entry options (variable),
69 expand_pathname_$add_suffix
70 entry (char (*), char (*), char (*), char (*), fixed bin),
71 hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin),
72 hcs_$terminate_noname entry (ptr, fixed bin),
73 get_wdir_ entry (char (168)),
74 hcs_$delentry_seg entry (ptr, fixed bin),
75 hcs_$make_seg entry (char (*), char (*), char (*), fixed bin, ptr, fixed bin),
76 hcs_$status_long entry options (variable),
77 tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin),
78 tssi_$finish_segment entry (ptr, fixed bin, bit (5), ptr, fixed bin),
79 hcs_$truncate_seg entry (ptr, fixed bin, fixed bin),
80 virtual_cpu_time_ entry (fixed bin (71)),
81 timer_manager_$cpu_call
82 entry (fixed bin (71), bit (2), entry),
83 timer_manager_$reset_cpu_call
84 entry (entry),
85 basic_ entry (ptr, fixed bin, ptr, ptr, ptr, fixed bin);
86
87 dcl (addr, divide, fixed, float, index, length, null, rtrim, search, substr)
88 builtin;
89
90 dcl (
91 error_table_$bad_conversion,
92 error_table_$badopt,
93 error_table_$entlong,
94 error_table_$zero_length_seg
95 ) fixed binary external;
96 dcl basic_data$precision_length
97 fixed bin (35) ext static;
98
99 dcl 1 basic_error_messages_$
100 aligned ext,
101 2 index_block (0:500),
102 3 loc fixed bin,
103 3 sev fixed bin,
104 3 len fixed bin,
105 2 message_block char (248000);
106
107 dcl basic_severity_ fixed bin ext static;
108
109 dcl 1 branch aligned automatic,
110 2 type bit (2) unaligned,
111 2 nnames bit (16) unaligned,
112 2 nrp bit (18) unaligned,
113 2 dtm bit (36) unaligned,
114 2 dtu bit (36) unaligned,
115 2 mode bit (5) unaligned,
116 2 padding bit (13) unaligned,
117 2 records bit (18) unaligned,
118 2 dtd bit (36) unaligned,
119 2 dtem bit (36) unaligned,
120 2 acct bit (36) unaligned,
121 2 curlen bit (12) unaligned,
122 2 bitcnt bit (24) unaligned,
123 2 did bit (4) unaligned,
124 2 mdid bit (4) unaligned,
125 2 copysw bit (1) unaligned,
126 2 pad2 bit (9) unaligned,
127 2 rbs (0:2) bit (6) unaligned,
128 2 uid bit (36) unaligned;
129
130 dcl 1 source_info aligned,
131 %include basic_source_info;
132
133
134
135
136 start:
137 word_count = 0;
138 basic_severity_ = 5;
139
140 on program_interrupt goto done;
141
142 got_path, had_bad_option = "0"b;
143
144 call cu_$af_return_arg (arg_count, null, 0, code);
145 if code = 0
146 then do;
147 call active_fnc_err_ (0, my_name, "Cannot be called as an active function.");
148 return;
149 end;
150
151 do i = 1 to arg_count;
152
153 call cu_$arg_ptr (i, argpt, arglen, code);
154
155 if substr (arg, 1, 1) ^= "-"
156 then do;
157 if got_path
158 then do;
159 USAGE:
160 call com_err_$suppress_name (0, my_name, "Usage: ^a path {-control_args}", my_name);
161 return;
162 end;
163 got_path = "1"b;
164 call expand_pathname_$add_suffix (arg, "basic", dir, sourcename, code);
165 if code ^= 0
166 then do;
167 if code = error_table_$entlong & substr (arg, arglen - 5, 6) ^= ".basic"
168 then call com_err_ (code, my_name, "^a.basic", arg);
169 else call com_err_ (code, my_name, "^a", arg);
170 return;
171 end;
172 ent = substr (sourcename, 1, length (rtrim (sourcename)) - length (".basic"));
173 end;
174
175 else if arg = "-time" | arg = "-tm"
176 then do;
177 i = i + 1;
178 if i > arg_count
179 then time_limit = 1;
180 else do;
181 call cu_$arg_ptr (i, argpt, arglen, code);
182 time_limit = cv_dec_check_ ((arg), code);
183 if code ^= 0
184 then do;
185 call com_err_ (error_table_$bad_conversion, my_name, "^a", arg);
186 return;
187 end;
188 end;
189 end;
190 else if arg = "-compile" | arg = "-cp"
191 then source_info_pt = addr (source_info);
192 else do;
193 call com_err_ (error_table_$badopt, my_name, "^a", arg);
194 had_bad_option = "1"b;
195 end;
196 end;
197
198 if ^got_path
199 then go to USAGE;
200 if had_bad_option
201 then return;
202
203 have_source:
204 call hcs_$initiate_count (dir, sourcename, "", bitcnt, 1, input_pt, code);
205
206 if input_pt = null
207 then do;
208 ent_err:
209 call com_err_ (code, my_name, "^a>^a", dir, sourcename);
210 return;
211 end;
212 if bitcnt = 0
213 then do;
214 code = error_table_$zero_length_seg;
215 go to ent_err;
216 end;
217
218 input_length = divide (bitcnt, 9, 17, 0);
219
220 on cleanup call clean_up;
221
222 level = level + 1;
223
224 if source_info_pt ^= null
225 then do;
226
227
228
229 source_info.segname = rtrim (ent);
230
231 source_info.dirname = rtrim (dir);
232
233 call hcs_$status_long (dir, sourcename, 0, addr (branch), null, code);
234
235 if code ^= 0
236 then goto ent_err;
237
238 source_info.unique_id = branch.uid;
239 source_info.date_time_modified = fixed (branch.dtm || (16)"0"b, 71);
240
241 call get_wdir_ (wdir);
242 call tssi_$get_segment (wdir, ent, output_pt, object_hold, code);
243 end;
244 else if level = 1
245 then do;
246 if work_seg = null
247 then call hcs_$make_seg ("", "basic_temporary_", "", 01111b, work_seg, code);
248
249 output_pt = work_seg;
250 end;
251 else call hcs_$make_seg ("", "", "", 01111b, output_pt, code);
252
253 if output_pt = null
254 then do;
255 call com_err_ (code, my_name, "^a>^a", dir, sourcename);
256 goto done;
257 end;
258
259 basic_severity_ = 0;
260 call basic_ (input_pt, input_length, output_pt, source_info_pt, main_pt, err_count);
261
262 if source_info_pt = null
263 then if err_count = 0
264 then if main_pt = null
265 then call fatal_err (180);
266 else if time_limit = 0
267 then call cu_$ptr_call (main_pt);
268 else do;
269 call virtual_cpu_time_ (time1);
270
271 call timer_manager_$cpu_call (time_limit, "11"b, cpu_limit);
272
273 executing = "1"b;
274 call cu_$ptr_call (main_pt);
275 executing = "0"b;
276 end;
277 else do;
278 if err_count = 1
279 then s = "";
280 else s = "s";
281 call ioa_ ("^d error^a found, no execution.", err_count, s);
282 call ioa_ ("");
283 end;
284
285 done:
286 call clean_up;
287 return;
288
289
290
291
292 ep_basic:
293 entry;
294
295 basic_data$precision_length = 2;
296 go to start;
297 ^L
298 clean_up:
299 proc;
300
301 if input_pt ^= null
302 then call hcs_$terminate_noname (input_pt, code);
303
304 if source_info_pt ^= null
305 then if output_pt ^= null
306 then do;
307 call hcs_$truncate_seg (output_pt, word_count, code);
308
309 if code ^= 0
310 then call com_err_ (code, my_name, "^a>^a", dir, sourcename);
311
312 call tssi_$finish_segment (output_pt, word_count * 36, "1100"b, object_hold, code);
313
314 if code ^= 0
315 then call com_err_ (code, my_name, "^a>^a", dir, sourcename);
316 end;
317 else ;
318 else if level > 1
319 then call hcs_$delentry_seg (output_pt, code);
320 else call hcs_$truncate_seg (output_pt, 0, code);
321
322 level = level - 1;
323
324 if time_limit ^= 0
325 then call timer_manager_$reset_cpu_call (cpu_limit);
326 end;
327 ^L
328 cpu_limit:
329 proc;
330
331 dcl answer char (3) varying,
332 time2 fixed bin (71);
333
334 dcl 1 query_info aligned,
335 2 version fixed bin init (2),
336 2 yes_or_no unaligned bit (1) init ("1"b),
337 2 surpress_name unaligned bit (1) init ("0"b),
338 2 status_code fixed bin init (0),
339 2 query_code fixed bin;
340
341 if executing
342 then do;
343 call virtual_cpu_time_ (time2);
344
345 call command_query_ (addr (query_info), answer, my_name,
346 "^a has used ^.3f seconds of cpu time. Do you want to continue?", ent,
347 float (time2 - time1, 27) / 1.0e6);
348
349 if answer = "no"
350 then goto done;
351
352 call timer_manager_$cpu_call (time_limit, "11"b, cpu_limit);
353 end;
354
355 end;
356
357 fatal_err:
358 proc (err_num);
359 dcl err_num fixed bin;
360 dcl (i, k) fixed bin;
361
362 dcl 1 message_overlay aligned based (addr (basic_error_messages_$)),
363 2 index_block_skip (0:500),
364 3 (a, b, c) fixed bin,
365 2 skip unal char (k),
366 2 message unal char (index_block (i).len - 1);
367
368 i = abs (err_num);
369 call ioa_ ("");
370 call ioa_ ("FATAL ERROR - ^d", i);
371 k = index_block (i).loc;
372 if k ^= -1 then call ioa_ (message);;
373 call ioa_ ("");
374 basic_severity_ = 5;
375 return;
376 end;
377 end;