1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 make_commands: procedure ();
 12 
 13 /*
 14 
 15    Coded for the Limited Service System May 1970 by R. Frankston
 16    Modified by Dan Bricklin Nov 1970
 17    Updated 7/22/76 to current version PL/I by S. Herbst
 18    Modified March 1977 by M. R. Jordan to correct errors and update to use expand_pathname_  (MCR #2576)
 19 
 20 */
 21 
 22 
 23 
 24 /*
 25 
 26    make_commands, mc
 27 
 28    Usage:
 29 
 30    make_commands <input_path>
 31 
 32    Where:
 33 
 34    <input_path> is the pathname of the input segment. The .ct suffix may
 35    be included but is not necessary (it will be assumed). The
 36    make_commands command will build a command table from the ASCII input
 37    segment to be used by transform_command_ whenever the
 38    command_processor_ recieves a command from the listen_ procedure. The
 39    table built is named <input_seg> where <input_seg> is the entry name
 40    of <input_path> with the .ct suffix removed and is located in the
 41    working direcory. The output segment must be named lss_command_list_
 42    to be used by the limited_service_subsystem_ or
 43    limited_command_system_ process overseers. If the
 44    limited_command_system_ process overseer is used, the output segment
 45    must be located in the project directory.
 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    The following structure is used as temporary storage for the command
106    transformation information until we can determine just exactly how many
107    commands there are.
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    The following table is the template for the final output segment created
122    by this command.  The table contains information for mapping commands
123    typed to actual command segment names.  Also information for the governor
124    is save in this structure.
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    Now parse the input segment and build a temporary table of the results of
183    that parse.
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;                              /* tab */
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 /* other characters */
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    Now we must build the commands table from the data gathered thus far.
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;