1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 dfast_: proc (person_id, arg_home_dir, project_id, tty_line_id, logout_arg);
  7 
  8 /*  This procedure is the listener for DFAST as well as the  parser for edit commands.  */
  9 
 10 dcl  arg_home_dir char (*);                                 /* home directory from pit */
 11 dcl  project_id char (*);                                   /* project_id for tty command */
 12 dcl  tty_line_id char (*);                                  /* tty line */
 13 dcl  logout_arg char (*);                                   /* = "hold" for HELLO */
 14 dcl  person_id char (*);                                    /* name at login */
 15 
 16 
 17 /* constants */
 18 
 19 dcl  command_names char (148) int static options (constant) init
 20     ("com,edi,lis,tty,bri,nbr,sor,ren,new,uns,sav,rep,old,bui,app,ign,scr,use,bye,goo,hel,PUN,bil,len,sys,exp,ful,hal,one,two,TAP,KEY,DIR,typ,run");
 21 
 22 /* *   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 */
 23 
 24 dcl  READ fixed bin init (1) int static options (constant); /* directory_:  read into the current segment. */
 25 dcl  SAVE fixed bin init (2) int static options (constant); /* directory_:  store only if the segment does not exist. */
 26 dcl  REPLACE fixed bin init (3) int static options (constant); /* directory_:  store only if the segment does exist. */
 27 dcl  DELETE fixed bin init (4) int static options (constant); /* directory_:  delete the segment */
 28 dcl  TRUNCATE fixed bin init (6) int static options (constant); /* directory_:  truncate the segment. */
 29 dcl  APPEND fixed bin init (1) int static options (constant); /* edit_:  append alter to current segment */
 30 dcl  SORT fixed bin init (2) int static options (constant); /* edit_:  merge alter and current and sort */
 31 dcl  BUILD fixed bin int static options (constant) init (5); /* edit_:  append to current segment */
 32 dcl  ALTER fixed bin int static options (constant) init (6); /* edit_:  append to alter segment */
 33 dcl  LENGTH fixed bin int static options (constant) init (7); /* edit_:  merge temporary segments and give length */
 34 dcl  arg_delimit char (4) int static options (constant) init ("        ,;"); /* tab blank comma semi-colon */
 35 dcl  dfast_name char (5) int static options (constant) init ("dfast");
 36 dcl  white_space char (2) int static options (constant) init ("        "); /* tab blank */
 37 dcl  character_set char (68) int static options (constant) init (">._-0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ        ");
 38 dcl  digit char (10) defined (character_set) pos (5);       /* digits */
 39 dcl  letter char (52) defined (character_set) pos (15);     /* letters */
 40 dcl  name_char char (68) defined (character_set) pos (1);   /* legal segment name characters */
 41 dcl  lowercase_letters char (26) defined (character_set) pos (15);
 42 dcl  uppercase_letters char (26) defined (character_set) pos (41);
 43 
 44 /* automatic */
 45 
 46 dcl  input char (256);
 47 dcl  input_length fixed bin;                                /* line length without the new-line */
 48 dcl  arg char (256) var;
 49 dcl  ready bit (1);                                         /* ON if ready message should be printed */
 50 dcl (length, index, verify, substr, addr, divide, search, null, translate) builtin;
 51 dcl (i, num_1, request) fixed bin;
 52 dcl  header bit (1) unal;                                   /* ON = list with header  */
 53 dcl  sort bit (1) unal;                                     /* dfast_line_edit_: ON sort; OFF no sort */
 54 dcl  string char (256) var;
 55 dcl  code fixed bin (35);
 56 
 57 dcl  quit condition;
 58 
 59 
 60 /* external */
 61 
 62 dcl  clock_ entry () returns (fixed bin (71));
 63 dcl  condition_ entry (char (*), entry);
 64 dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
 65 dcl  date_time_ entry (fixed bin (71), char (*));
 66 dcl  error_table_$long_record fixed bin (35) ext;
 67 dcl  dfast_command_processor_ entry (ptr, char (*), char (*), fixed bin (35));
 68 dcl  dfast_compile_ entry (ptr, fixed bin (35));
 69 dcl  dfast_directory_ entry (fixed bin, char (*), ptr, ptr, fixed bin (35));
 70 dcl  dfast_edit_ entry (fixed bin, char (*),  ptr, fixed bin (35));
 71 dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
 72 dcl  dfast_explain_ entry (char (*) var, char (*), fixed bin (35));
 73 dcl  dfast_line_edit_ entry (char (256) var, ptr, bit (1) unal, fixed bin (35));
 74 dcl  dfast_list_ entry (ptr, char (*), fixed bin, bit (1) unal, bit (1) unal, fixed bin (35));
 75 dcl  dfast_merge_ entry (bit (1), ptr, fixed bin (35));
 76 dcl  fast_related_data_$in_fast_or_dfast bit (1) aligned ext;
 77 dcl  fast_related_data_$in_dfast bit (1) aligned ext;
 78 dcl  dfast_run_ entry (ptr, fixed bin (35));
 79 dcl  dfast_set_system_ entry (char (256) var, bit (1) unal, char (*), fixed bin (35));
 80 dcl  dfast_terminal_control_ entry (fixed bin, char (*), ptr, fixed bin (35));
 81 dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
 82 dcl  hmu entry options (variable);
 83 dcl  ioa_$ioa_switch entry options (variable);
 84 dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin, fixed bin (35));
 85 dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
 86 dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
 87 dcl  iox_$user_input ptr ext static;
 88 dcl  iox_$user_output ptr ext static;
 89 dcl  resource_usage entry ();
 90 
 91 dcl  sys_info$max_seg_size fixed bin (35) ext;
 92 
 93 dcl  edit_info_ptr ptr;
 94 dcl 1 f aligned like dfast_edit_info;
 95 %include dfast_edit_info;
 96 %include dfast_error_codes;
 97 /* ^L */
 98 
 99           call initial;
100           if code ^= 0 then return;
101           on quit begin;
102                ready = "1"b;
103                call iox_$control (iox_$user_input, "resetread", addr (input), code);
104                call ioa_$ioa_switch (iox_$user_output, "QUIT^/");
105                goto READY;
106           end;
107           call condition_ ("any_other", any_other_handler);
108 
109 /* * This  loop prints the ready message and reads a line from the terminal.  These conventions are used:
110    *
111    *      1.  Special case the BUILD mode.
112    *                a.  If the line contains only a new_line character, BUILD  mode is terminated.
113    *                b.  Otherwise the line is appended to the end of the current_file.
114    *      2.  Blank lines are ignored.
115    *      3.  Text lines begin with a digit  and are stored in temporary segment alt to  be merged later.
116    *      4.  Command lines:
117    *                a.  Single command lines begin with an alphabetic character.  Only the first three characters
118    *                    are used.
119    *                b.  Multi-command lines begin with any character except a digit or an alphabetic charcter.
120    *                    (ie.  /tty/run/lis  )
121 */
122 
123 READY:
124           do while ("1"b);
125                if ready then do;
126                     call date_time_ (clock_ (), input);
127                     call ioa_$ioa_switch (iox_$user_output, "ready  ^a^/", substr (input, 11, 4));
128                end;
129                ready = "0"b;
130 
131                call iox_$get_line (iox_$user_input, addr (input), 256, input_length, code);
132 
133                if code ^= 0 then do;
134                     if code = error_table_$long_record then call dfast_error_ (error_long_rec, "", "");
135                end;
136 
137                else if f.build_mode then do;
138                     if input_length = 1 then do;
139                          f.build_mode = "0"b;
140                          ready = "1"b;
141                     end;
142 
143                     else call dfast_edit_ (BUILD, substr (input, 1, input_length), edit_info_ptr, code);
144                end;
145 
146                else do;
147                     i = verify (substr (input, 1, input_length -1), white_space);
148 
149                     if i > 0 then do;
150                          if index (digit, substr (input, i, 1)) > 0
151                          then call dfast_edit_ (ALTER, substr (input, i, input_length - i + 1), edit_info_ptr, code);
152 
153                          else do;                           /* command */
154                               if ^f.brief_mode then ready = "1"b;
155 
156                               if index (letter, substr (input, i, 1)) > 0
157                               then call command (substr (input, i, input_length - i), code);
158                               else call multi_command ((i));
159                          end;
160                     end;
161                end;
162 
163           end;
164 
165 RETURN:   return;
166 
167 /* ^L */
168 
169 /*   This procedure is used to find the next argument on the line.  It expects the form:
170 
171    [blank | tab] [argument] [blank | tab | comma | semi-colon]
172 
173    Any of the fields may be null.  If no argument and no delimitor is found, then the procedure returns "0"b.
174    Otherwise "1"b is returned.
175 */
176 get_arg:  proc (line, argument) returns (bit (1));
177 
178 dcl  argument char (256) var;                               /* next argument (output) */
179 
180 dcl  line char (256) var;                                   /* input buffer */
181 dcl  line_length fixed bin;                                 /* length of line on input */
182 dcl  argument_length fixed bin;                             /* length of argument */
183 dcl  start fixed bin;                                       /* index in line of start of argument */
184 
185                line_length = length (line);
186 
187                if line_length > 0 then do;
188 
189                     start = verify (line, white_space);
190                     if start > 0 then do;
191                          argument_length = search (substr (line, start), arg_delimit);
192 
193                          if argument_length = 0 then argument_length = line_length - start + 1;
194                          else argument_length = argument_length - 1;
195                          argument = substr (line, start, argument_length);
196                          start = start + argument_length + 1; /* move beyond the argument delimitor */
197                          if start > line_length then line = "";
198                          else line = substr (line, start, line_length - start + 1);
199 
200                          return ("1"b);
201                     end;
202                end;
203                return ("0"b);
204           end get_arg;
205 
206 /* ^L */
207 line_number: proc (string, num) returns (bit (1));
208 dcl  string char (*) var;
209 dcl  num fixed bin;
210 
211                num = cv_dec_check_ ((string), code);
212                if code = 0 then do;
213                     if num > 0 then return ("1"b);
214                     else call dfast_error_ (error_bad_line, "", (arg));
215                end;
216                else return ("0"b);
217           end line_number;
218 
219 
220 /* ^L */
221 /*  This procedure parses the line for a pathname and verifies that it contains legal characters.
222    If the name is not found and request is set, the user is queried for a name.
223    *
224    *      Code           Pathname       Explaination
225    *
226    *      0              ^= ""          A legal pathname was found and is returned.
227    *      0              = ""           No pathname was given and the query was not requested.
228    *      bad_name       (not set)      The pathname given contained one or more illegal characters.
229    *      name_miss      (not set)      The name was not given on the line or with the query and request was set.
230 */
231 get_name: proc (line, name, request, code);
232 
233 dcl  line char (256) var;
234 dcl  name char (*) var;                                     /* pathname (output) */
235 dcl  request bit (1);                                       /* ON if should request name (input) */
236 dcl  code fixed bin (35);
237 
238                if ^get_arg (line, arg) then do;
239                     if ^request then do;
240                          name = "";
241                          return;
242                     end;
243 
244                     call get_user_response ("0"b, "enter name: ", arg);
245                     if arg = "" then code = error_name_miss;
246                end;
247 
248                if code = 0 then do;
249                     if verify (arg, name_char) > 0 then code = error_bad_name;
250                     else name = arg;
251                end;
252 
253                if code ^= 0 then if code ^= error_name_miss then call dfast_error_ (code, dfast_name, (arg));
254 
255                return;
256 
257           end get_name;
258 
259 /* ^L */
260 /*  This command parses the command line for a command and executes it.  It returns code:
261 
262    *         code = 0         The command was successfully completed or was a null command.
263    *         code ^= 0        An error prevented the command from being completed.
264 */
265 command:  proc (line, code);
266 
267 dcl  line char (256) var;
268 dcl  code fixed bin (35);
269 
270                if get_arg (line, arg) then do;
271                     arg = translate (arg, lowercase_letters, uppercase_letters);
272                     if length ((arg)) > 2 then do;
273                          request = index (command_names, substr (arg, 1, 3));
274                          if request ^= 0 then do;
275                               request = divide (request +3, 4, 17);
276                               goto command_label (request);
277                          end;
278                     end;
279                     call dfast_command_processor_ (edit_info_ptr, (arg), (line), code);
280                end;
281 
282                return;
283 
284 
285 /* ^L */
286 /* *      compile   [fortran | basic]
287 */
288 command_label (1):
289 
290                if get_arg (line, arg) then call set_system (code);
291                if code = 0 then call dfast_compile_ (edit_info_ptr, code);
292                return;
293 
294 /* *      edit      <request>           [<request argument>]
295 */
296 
297 command_label (2):
298                if arg = "editns" | arg = "edins" then sort = "0"b;
299                else sort = "1"b;
300 
301                call dfast_line_edit_ (line, edit_info_ptr, sort, code);
302                return;
303 
304 
305 /* list:  omit header if user is in brief_mode or request was lisn, lisnh, listnh
306    [alt | cur] [<line no.>] [<line no.>]
307 */
308 command_label (3):
309 
310                if f.brief_mode then header = "0"b;
311                else if substr (arg, length (arg), 1) = "n" then header = "0"b;
312                else if substr (arg, length (arg) -1, 2) = "nh" then header = "0"b;
313                else header = "1"b;
314 
315                call parse_list_punch (line, header, "0"b);
316 
317                return;
318 
319 /* tty */
320 command_label (4):
321 
322                if f.basic_system then if f.dbasic then string = "dbasic";
323                     else string = "basic";
324                else string = "fortran";
325                call ioa_$ioa_switch (iox_$user_output, "name = ^a,  system = ^a,  user = ^a.^a,  line = ^a",
326                     f.current_name, string, person_id, project_id, tty_line_id);
327 
328                return;
329 
330 /* brief */
331 command_label (5):
332                f.brief_mode = "1"b;
333                ready = "0"b;
334 
335                return;
336 
337 /* nbrief */
338 command_label (6):
339 
340                f.brief_mode = "0"b;
341                return;
342 
343 /* sort */
344 command_label (7):
345 
346                call dfast_edit_ (SORT, "", edit_info_ptr, code);
347                return;
348 
349 /* *      rename    [<name>]
350    *      new       [<name>]
351 */
352 command_label (8):
353 command_label (9):
354 
355                call get_name (line, string, "1"b, code);
356                if code = 0 then do;
357                     if index (string, ">") = 0 then do;
358                          f.current_name = string;
359                          call dfast_set_system_ (f.current_name, f.basic_system, "", 0); /* ignore code:  OK if no suffix */
360                     end;
361                     else do;
362                          code = error_bad_name;
363                          call dfast_error_ (code, "name", (string));
364                     end;
365                end;
366                else if code = error_name_miss then code = 0; /* ignore a chage of mind by user */
367                if request = 9 then call reset_edit_info;
368 
369                return;
370 
371 
372 
373 /* *      unsave    [<pathname>]
374 */
375 command_label (10):
376 
377                call segment_control (line, DELETE);
378                return;
379 
380 /*        save      [<pathname>]
381 */
382 command_label (11):
383 
384                call segment_control (line, SAVE);
385                return;
386 
387 /* *      replace   [<pathname>]
388 */
389 command_label (12):
390 
391                call segment_control (line, REPLACE);
392                return;
393 
394 /* *      old       [<pathname>]          [<system name>]
395 */
396 command_label (13):
397 
398                call segment_control (line, READ);
399                if code = 0 then do;
400                     if f.source_segment then do;
401                          call dfast_set_system_ (f.current_name, f.basic_system, "", code);
402                          if code ^= 0 then do;
403                               code = 0;
404                               if get_arg (line, arg) then call set_system (code);
405                               else do;
406                                    call get_user_response ("0"b, "enter system name: ", arg);
407                                    call set_system (code);
408                                    do while (code ^= 0);
409                                         call get_user_response ("1"b, "answer 'basic', 'dbasic', or 'fortran': ", arg);
410                                         call set_system (code);
411                                    end;
412                               end;
413                          end;
414                     end;
415                end;
416                return;
417 
418 /* build */
419 command_label (14):
420 
421                if ^f.source_segment then call dfast_error_ (error_obj_nop, "build", "");
422                else do;
423                     if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
424                     if code = 0 then f.build_mode = "1"b;
425                end;
426 
427                return;
428 
429 /*  append */
430 command_label (15):
431 
432                call dfast_edit_ (APPEND, "", edit_info_ptr, code);
433                return;
434 
435 /* ignore */
436 command_label (16):
437 
438                f.alter_length = 0;
439                return;
440 
441 /* scratch */
442 command_label (17):
443 
444                if verify (line, white_space) = 0 then call reset_edit_info;
445                else call segment_control (line, TRUNCATE);
446 
447                return;
448 
449 
450 /*  user */
451 command_label (18):
452 
453                call hmu ();
454                return;
455 
456 /* bye and goodbye */
457 command_label (19):
458 command_label (20):
459 
460                logout_arg = "";
461                call bye_request;
462                return;
463 
464 
465 /* *      hello
466    *
467    *      help
468 */
469 command_label (21):
470 
471                if arg = "hello" then do;
472                     logout_arg = "-hold";
473                     call bye_request;
474                     return;
475                end;
476 
477                else call dfast_explain_ ("", "help", code);
478                return;
479 
480 /* punch */
481 command_label (22):
482 
483                call parse_list_punch (line, "0"b, "1"b);
484                return;
485 
486 
487 /* bill */
488 command_label (23):
489 
490                call resource_usage;
491                return;
492 
493 /* length */
494 command_label (24):
495 
496                call dfast_edit_ (LENGTH, "", edit_info_ptr, code);
497                return;
498 
499 /* *      system    [fortran | basic]
500 */
501 command_label (25):
502 
503                if ^get_arg (line, arg) then call get_user_response ("1"b, "enter system: ", arg);
504 
505                call set_system (code);
506 
507                return;
508 
509 /* *      explain   <topic>
510 */
511 command_label (26):
512 
513                call dfast_explain_ (line, "explain", code);
514                return;
515 
516 /*  These commands change the input/output mode of the terminal.  The order is important.
517    *
518    *      (27)      fullduplex
519    *      (28)      halfduplex
520    *      (29)      one_case
521    *      (30)      two_case
522    *      (31)      tape
523    *      (32)      keyboard
524    *      (33)      direct
525 */
526 command_label (27):
527 command_label (28):
528 command_label (29):
529 command_label (30):
530 command_label (31):
531 command_label (32):
532 command_label (33):
533 
534                call dfast_terminal_control_ (request - 26, "", edit_info_ptr, code);
535                if request = 33 then ready = "1"b;
536                return;
537 
538 /* *      type      <terminal_type>
539    *
540    *                <terminal_type>  ::=  tn300 | tty37 | tty33
541 */
542 command_label (34):
543 
544                if ^get_arg (line, arg) then arg = "";
545                call dfast_terminal_control_ (request - 26, (arg), edit_info_ptr, code);
546                return;
547 
548 /* *      run       [fortran | basic]
549 */
550 command_label (35):
551 
552                if get_arg (line, arg) then call set_system (code);
553                if code = 0 then call dfast_run_ (edit_info_ptr, code);
554                return;
555 
556           end command;
557 
558 /* ^L */
559 /*  This procedure is used to read into or store from the current segment and to delete segments
560    If a pathname is given on the line, it is used.  Otherwise the current name is used.
561    If no pathname is given and the current name is "no name", then and error message is printed and an error
562    code is returned.
563 */
564 
565 segment_control: proc (line, action);
566 
567 dcl  line char (256) var;
568 dcl  action fixed bin;                                      /* directory_: read, save, replace, delete */
569 dcl  request bit (1);                                       /* get_name: ON if should request name */
570 
571                if f.current_name = "no name" then request = "1"b;
572                else request = "0"b;
573 
574                call get_name (line, string, request, code);
575 
576                if code = error_name_miss then call dfast_error_ (code, dfast_name, "");
577                else if code = 0 then do;
578                     if string = "" then string = f.current_name;
579                     call dfast_directory_ (action, (string), edit_info_ptr, null, code);
580                     if action ^= DELETE then f.edit_done = "0"b;
581                end;
582 
583                return;
584 
585           end segment_control;
586 
587 /* ^L */
588 /* *  This procedure prints a message and then reads one line from user_input.  If the line contains
589    *  at least one non_blank character, response is set and the procedure returns.  If a blank
590    *  line is input, there are two actions depending on repeat:
591    *
592    *      "1"b      the message is printed again.
593    *      "0"b      response is set to "" and the procedure returns
594 */
595 get_user_response: proc (repeat, message, response);
596 
597 dcl  repeat bit (1);                                        /* ON if should repeat for blank lines */
598 dcl  message char (*);
599 dcl  response char (*) var;                                 /* the response enterred by the user */
600 
601 dcl  temp_buffer char (256);
602 dcl  amt_read fixed bin;                                    /* num_characters read */
603 dcl  start fixed bin;                                       /* index of start of response */
604 dcl  num_chars fixed bin;                                   /* number of characters in response */
605 
606                response = "";
607 
608                do while ("1"b);
609                     call iox_$put_chars (iox_$user_output, addr (message), length (message), code);
610                     call iox_$get_line (iox_$user_input, addr (temp_buffer), 256, amt_read, code);
611                     amt_read = amt_read - 1;
612                     if amt_read > 0 then do;
613                          start = verify (substr (temp_buffer, 1, amt_read), white_space);
614                          if start > 0 then do;
615                               num_chars = index (substr (temp_buffer, start, amt_read), white_space) -1;
616                               if num_chars = -1 then num_chars = amt_read - start + 1;
617                               response = substr (temp_buffer, start, num_chars);
618                               return;
619                          end;
620                     end;
621 
622                     if ^repeat then return;
623                end;
624 
625           end get_user_response;
626 
627 /* ^L */
628 /* *      This procedure parses arg for a system name.  Only the first three letters are used.
629    *      The system may be fortran or basic or dbasic.  The system can not be changed:
630    *           1.  If the current segment is object code.
631    *           2.  If the system would conflict with the current name.
632 */
633 set_system: proc (code);
634 
635 dcl  code fixed bin (35);
636 dcl  tag char (7);
637 
638                string = substr (arg, 1, 3);
639                if f.source_segment then do;
640                     call dfast_set_system_ (f.current_name, f.basic_system, tag, (0));
641                     if string = "bas" | string = "dba" then do;
642                          if tag = "fortran" then code = error_name_sys;
643                          if code = 0 then do;
644                               f.basic_system = "1"b;
645                               if string = "dba" then f.dbasic = "1"b;
646                               else f.dbasic = "0"b;
647                          end;
648                     end;
649 
650                     else if string = "for" then do;
651                          if tag = "basic" then code = error_name_sys;
652                          if code = 0 then f.basic_system, f.dbasic = "0"b;
653                     end;
654                     else code = error_unkn_sys;
655                end;
656 
657                else do;                                     /* Can't override system in object segment */
658                     if string = "bas" & f.basic_system & ^f.dbasic then;
659                     if string = "dba" & f.basic_system & f.dbasic then;
660                     else if string = "for" then if ^f.basic_system then;
661                          else code = error_obj_nop;
662                end;
663 
664                if code ^= 0 then do;
665                     if code = error_name_sys then arg = f.current_name;
666                     call dfast_error_ (code, "system", (arg));
667                end;
668 
669                return;
670 
671           end set_system;
672 
673 /* ^L */
674 /*  This procedure parses an input line with more than one command.  The first character
675    on the line is the delimitor.  Null commands are legal.
676 */
677 
678 multi_command: proc (start);
679 
680 dcl  start fixed bin;                                       /* index of input of command delimitor character */
681 dcl  command_delimitor char (1);                            /* command delimitor character */
682 dcl  len fixed bin;                                         /* length of command */
683 
684                command_delimitor = substr (input, start, 1);
685                start = start + 1;
686                input_length = input_length - 1;             /* drop the new-line character */
687 
688                code = 0;
689                do while (start <= input_length & code = 0);
690 
691                     len = index (substr (input, start, input_length - start + 1), command_delimitor);
692                     if len = 0 then len = input_length - start +2;
693                     call command (substr (input, start, len -1), code);
694 
695                     start = start + len;
696                end;
697 
698                return;
699 
700           end multi_command;
701 
702 /* ^L */
703 /*  This code clears the edit info for the initialization and the scratch and new commands.
704 */
705 reset_edit_info: proc;
706 
707                f.current_length = 0;
708                f.alter_length = 0;
709                f.edit_done = "0"b;
710                f.source_segment = "1"b;
711 
712                return;
713 
714           end reset_edit_info;
715 
716 /* ^L */
717 /*  This procedure parses the arguments for the list and the punch commands.
718    *
719    *      list      <temporary segment id>        <line number>
720    *      punch     <temporary segment id>        <line number>
721    *
722    *           temporary segment id     = alt     list the alter file.
723    *                                    = cur     list the current file.
724    *                                    = ""      Merge the alter and current files and then list.
725    *
726    *           line number n                      List the file beginning with the line number n.
727 */
728 parse_list_punch: proc (line, header, punch);
729 
730 dcl  line char (256) var;
731 dcl  header bit (1) unal;                                   /* ON if should print header */
732 dcl  punch bit (1) unal;                                    /* ON if should punch;  OFF if should list */
733 
734                num_1 = -1;                                  /* default is entire segment */
735                string = "";                                 /* default is merge with alter and then list */
736                if get_arg (line, arg) then do;
737                     string = substr (arg, 1, 3);
738                     if string = "cur" | string = "alt" then do;
739                          if get_arg (line, arg) then do;
740                               if ^line_number (arg, num_1) then code = error_unknown_arg;
741                          end;
742                     end;
743                     else do;
744                          string = "";
745                          if ^line_number (arg, num_1) then code = error_unknown_arg;
746                     end;
747 
748                end;
749 
750                if code = 0 then call dfast_list_ (edit_info_ptr, (string), num_1, header, punch, code);
751 
752                else do;
753                     if punch then string = "punch";
754                     else string = "list";
755                     call dfast_error_ (code, (string), (arg));
756                end;
757 
758                return;
759 
760           end parse_list_punch;
761 
762 /* ^L */
763 bye_request: proc;
764 
765 
766                if f.edit_done | f.alter_length > 0 then do;
767                     call get_user_response ("0"b, "editing will be lost if you quit.  Do you want to quit ? ", arg);
768                     do while ("1"b);
769                          if arg = "yes" | arg = "YES" then goto RETURN;
770                          if arg = "no" | arg = "NO" then return;
771                          call get_user_response ("1"b, "answer 'yes' or 'no': ", arg);
772                     end;
773                end;
774                goto RETURN;
775 
776 
777           end bye_request;
778 
779 /* ^L */
780 /*  This procedure sets up the PI handler and gets two scratch buffers in the process directory. */
781 
782 initial:  proc;
783 
784 dcl  ptr_array (2) ptr based;
785 
786                code = 0;
787                edit_info_ptr = addr (f);
788                f.home_dir = arg_home_dir;
789                f.current_ptr = null;
790                call get_temp_segments_ (dfast_name, addr (f.current_ptr) -> ptr_array, code);
791                if code ^= 0 then call dfast_error_ (code, dfast_name, "current_segment");
792                f.max_seg_size = sys_info$max_seg_size;
793 
794                f.current_name = "no name";
795                f.basic_system = "1"b;
796                f.brief_mode, f.build_mode = "0"b;
797                call reset_edit_info;
798 
799                fast_related_data_$in_fast_or_dfast = "1"b;  /* switches for BASIC */
800                fast_related_data_$in_dfast = "1"b;
801 
802 
803                ready = "1"b;
804 
805                return;
806 
807           end initial;
808 
809 /* ^L */
810 any_other_handler: proc (mcptr, cond_name, wcptr, info_ptr, cont);
811 
812 dcl  mcptr ptr,
813      cond_name char (*),
814      wcptr ptr,
815      info_ptr ptr,
816      cont bit (1) aligned;
817 dcl  area area (300);
818 dcl (i, l) fixed bin;
819 dcl  NEW_LINE char (1) init ("
820 ");
821 dcl  message_len fixed bin (21);
822 dcl  message char (message_len) based (message_ptr);
823 dcl  message_ptr ptr;
824 
825 dcl  condition_interpreter_ entry (ptr, ptr, fixed bin (21), fixed bin, ptr, char (*), ptr, ptr);
826 
827                if cond_name = "command_error" |
828                cond_name = "command_question" | cond_name = "string_size" then return;
829 
830                call condition_interpreter_ (addr (area), message_ptr, message_len, 1, mcptr, cond_name, wcptr, info_ptr);
831                if cond_name = "command_abort_" then goto READY;
832                if message_len > 0 then do;
833 
834 /* * This code modifies the error message to remove the shriek name and the phrase "(in process dir)"
835    *
836    *      Error: ... condition by !BBBJFbDjnMccfW.temp.0310$main_|50 (line 20) (in process dir)
837    *
838    *      Error: ... condition by main_|50 (line 20)
839 */
840                     if substr (message, 2, 6) = "Error:" then do;
841                          l = index (substr (message, 2), NEW_LINE);
842                          if l > 0 then do;
843                               i = index (substr (message, 2, l), "by !");
844                               if i > 0 then do;
845                                    i = i + 4;
846                                    if substr (message, i+15, 5) = ".temp" & substr (message, i + 25, 1) = "$" then do;
847                                         substr (message, i) = substr (message, i+26, message_len - i -26+1);
848                                         message_len = message_len - 26;
849                                         i = index (substr (message, 1, l+1), "(in process dir)");
850                                         if i > 0 then do;
851                                              substr (message, i) = substr (message, i+16);
852                                              message_len = message_len - 16;
853                                         end;
854                                    end;
855                               end;
856                          end;
857                     end;
858 
859                     call iox_$put_chars (iox_$user_output, message_ptr, message_len, code);
860                end;
861 
862                if cond_name = "finish" then return;
863 
864                goto READY;
865 
866           end any_other_handler;
867 
868      end dfast_;