1
2
3
4
5
6
7
8
9
10
11 make_commands: procedure ();
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48 ^L
49 dcl NL char (1) aligned internal static options (constant) init ("
50 ");
51 dcl aclinfo_ptr ptr;
52 dcl arg_ptr ptr;
53 dcl arglen fixed bin;
54 dcl before builtin;
55 dcl bit_count fixed bin (24);
56 dcl ch char (arglen) based (arg_ptr) unaligned;
57 dcl chr char (1) aligned;
58 dcl chs char (100) aligned based (input_pointer);
59 dcl cleanup condition;
60 dcl code fixed bin (35);
61 dcl com_err_ ext entry options (variable);
62 dcl command_pointer ptr;
63 dcl cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
64 dcl cv_dec_ ext entry (char (*) aligned) returns (fixed bin (35));
65 dcl dirname char (168);
66 dcl divide builtin;
67 dcl ename char (32);
68 dcl error_occurred bit (1) aligned;
69 dcl error_table_$segknown external fixed bin (35);
70 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
71 dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
72 dcl first fixed bin;
73 dcl fixed builtin;
74 dcl hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
75 dcl i fixed bin;
76 dcl in_comment bit (1) aligned;
77 dcl index builtin;
78 dcl input_pointer pointer;
79 dcl ioa_ ext entry options (variable);
80 dcl j fixed bin;
81 dcl length builtin;
82 dcl line char (256) aligned varying;
83 dcl lineno fixed bin;
84 dcl min builtin;
85 dcl n fixed bin;
86 dcl name_len fixed bin;
87 dcl next_free fixed bin;
88 dcl null builtin;
89 dcl output_name char (32);
90 dcl paren bit (1) aligned;
91 dcl path_len fixed bin;
92 dcl rtrim builtin;
93 dcl s fixed bin;
94 dcl skip bit (1) aligned;
95 dcl start_line fixed bin;
96 dcl start_name fixed bin;
97 dcl substr builtin;
98 dcl temp1 fixed bin;
99 dcl tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35));
100 dcl tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
101 dcl tssi_$clean_up_segment entry (ptr);
102 ^L
103
104
105
106
107
108
109
110
111
112 dcl 1 commands aligned,
113 2 com_info (200),
114 3 name char (32),
115 3 path char (168),
116 3 len fixed bin (71);
117
118
119
120
121
122
123
124
125
126
127
128
129 dcl 1 table based (command_pointer) aligned,
130 2 ratio fixed bin (17),
131 2 interval_len fixed bin (17),
132 2 number_of_names fixed bin (71),
133 2 names (code refer (number_of_names)) char (32) aligned,
134 2 pointers (code refer (number_of_names)) aligned,
135 3 where fixed bin (17),
136 3 length fixed bin (17),
137 2 paths char (100) aligned;
138 ^L
139 goto common;
140
141
142 mc: entry ();
143
144
145 common:
146
147
148 call cu_$arg_ptr (1, arg_ptr, arglen, code);
149 if code ^= 0 then do;
150 call com_err_ (code, "make_commands", "Usage is: ""make_commands <input_path>""");
151 return;
152 end;
153
154 call expand_pathname_$add_suffix (ch, "ct", dirname, ename, code);
155 if code ^= 0 then do;
156 in_err: call com_err_ (code, "make_commands", "^a", ch);
157 return;
158 end;
159 call hcs_$initiate_count (dirname, ename, "", bit_count, 01b, input_pointer, code);
160 if code ^= 0 then if code ^= error_table_$segknown then do;
161 if dirname = ">" then call com_err_ (code, "make_commands", ">^a", ename);
162 else call com_err_ (code, "make_commands", "^a>^a", dirname, ename);
163 return;
164 end;
165
166 output_name = substr (ename, 1, length (rtrim (ename))-3);
167 call expand_pathname_ (output_name, dirname, ename, code);
168 if code ^= 0 then do;
169 out_err: call com_err_ (code, "make_commands", "^a", output_name);
170 return;
171 end;
172 aclinfo_ptr = null ();
173 on cleanup
174 begin;
175 if aclinfo_ptr ^= null () then call tssi_$clean_up_segment (aclinfo_ptr);
176 end;
177 call tssi_$get_segment (dirname, ename, command_pointer, aclinfo_ptr, code);
178 if command_pointer = null then go to out_err;
179 ^L
180
181
182
183
184
185
186
187
188 temp1 = divide (bit_count, 9, 17, 0);
189 n = 0;
190 s, lineno, start_line = 1;
191 paren, in_comment, skip, error_occurred = "0"b;
192 do i = 1 to temp1;
193 if in_comment then
194 if substr (chs, i-1, 2) = "*/" then do;
195 in_comment = "0"b;
196 chr = " ";
197 go to blank;
198 end;
199 else go to next;
200 chr = substr (chs, i, 1);
201 if chr = NL then do;
202 lineno = lineno + 1;
203 go to next;
204 end;
205 if skip then do;
206 if chr = ";" then skip = "0"b;
207 s = 1;
208 start_line = i+1;
209 go to next;
210 end;
211 if chr = "/" then
212 if i < temp1 then
213 if substr (chs, i+1, 1) = "*" then do;
214 in_comment = "1"b;
215 go to next;
216 end;
217 if chr = " " then do;
218 blank: if s = 2 then if paren then do;
219 s = 1;
220 name_len = 0;
221 end;
222 else s = 3;
223 if s = 5 then s = 6;
224 go to next;
225 end;
226
227 if chr = " " then do;
228 if s = 1|s = 4 then go to next;
229 go to error;
230 end;
231
232 if chr = "(" then do;
233 if ^paren & s = 1 then do;
234 paren = "1"b;
235 first = n+1;
236 go to next;
237 end;
238 go to error;
239 end;
240
241 if chr = ")" then do;
242 if paren then do;
243 if s = 2 then s = 3;
244 if s ^= 3 then go to error;
245 paren = "0"b;
246 go to next;
247 end;
248 go to error;
249 end;
250
251 if chr = ":" then do;
252 if paren then go to error;
253 if s = 2|s = 3 then do;
254 s = 4;
255 go to next;
256 end;
257 go to error;
258 end;
259
260 if chr = ";" then do;
261 if s = 4 then do;
262 do j = first to n;
263 commands.path (j) = commands.name (n);
264 commands.len (j) = name_len;
265 end;
266 s = 1;
267 start_line = i+1;
268 go to next;
269 end;
270 if s = 5|s = 6 then do;
271 do j = first to n-1;
272 commands.len (j) = path_len;
273 commands.path (j) = commands.path (n);
274 end;
275 commands.len (n) = path_len;
276 s = 1;
277 start_line = i+1;
278 go to next;
279 end;
280 go to error;
281 end;
282
283
284
285 if s = 1 then do;
286 s = 2;
287 n = n+1;
288 if ^paren then first = n;
289 if n>200 then do;
290 call com_err_ (0, "make_commands", "Max number of names (200) exceeded, terminating run.");
291 return;
292 end;
293 commands.name (n) = " ";
294 name_len = 0;
295 start_name = i;
296 end;
297 if s = 2 then do;
298 name_len = name_len + 1;
299 substr (commands.name (n), name_len, 1) = chr;
300 go to next;
301 end;
302 if s = 4 then do;
303 s = 5;
304 path_len = 0;
305 commands.path (n) = " ";
306 end;
307 if s = 5 then do;
308 path_len = path_len+1;
309 substr (commands.path (n), path_len, 1) = chr;
310 go to next;
311 end;
312 error: line = substr (chs, start_line, min (index (substr (chs, i, temp1-i+1), ";")+i-1, temp1)-start_line+1);
313 call com_err_ (0, "make_commands", "Syntax error on line ^d, around char #^d of statement: ^a",
314 lineno, i-start_line, line);
315 error_occurred, skip = "1"b;
316
317 next: end;
318
319 if s ^= 1 then do;
320 call com_err_ (0, "make_commands", "Last statement doesn't end with a semi-colon.");
321 give_up: call com_err_ (0, "make_commands", "At least one syntax error, compilation is aborted.");
322 return;
323 end;
324
325 if error_occurred then go to give_up;
326 ^L
327
328
329
330
331
332
333
334 next_free = 1;
335 j = 1;
336 ratio, interval_len = 0;
337 if commands.name (1) = "ratio" then if commands.name (2) = "interval" then do;
338 ratio = cv_dec_ (commands.path (1));
339 interval_len = cv_dec_ (commands.path (2));
340 call ioa_ ("ratio = ^d, interval = ^d", ratio, interval_len);
341 j = 3;
342 end;
343 number_of_names = n - j + 1;
344 do i = j to n;
345 table.names (i-j+1) = commands.name (i);
346 pointers.where (i-j+1) = next_free;
347 next_free = next_free + commands.len (i);
348 if i>j then if commands.path (i) = commands.path (i-1) then do;
349 next_free = pointers.where (i-j+1);
350 pointers.where (i-j+1) = pointers.where (i-j);
351 end;
352 pointers.length (i-j+1) = commands.len (i);
353 substr (paths, pointers.where (i-j+1), pointers.length (i-j+1)) = substr (commands.path (i), 1, pointers.length (i-j+1));
354 end;
355 i = 4 + 10*number_of_names + divide (next_free+2, 4, 17, 0);
356 call tssi_$finish_segment (command_pointer, fixed (i*36, 24), "110"b, aclinfo_ptr, code);
357 revert cleanup;
358 if code ^= 0 then go to out_err;
359 return;
360
361 end make_commands;