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 
 12 /****^  HISTORY COMMENTS:
 13   1) change(2017-01-19,Swenson), approve(2017-01-19,MCR10028),
 14      audit(2017-01-20,GDixon), install(2017-01-20,MR12.6f-0015):
 15      Remove spurious \015 character from source introduced when copied from
 16      ACTC/MIT tape.
 17                                                    END HISTORY COMMENTS */
 18 
 19 basic_system: bsys: bs: procedure;
 20 
 21 
 22           /* A line numbered editor for use with the BASIC language, with facilities for
 23              listing, deleting, and running programs.       J.M. Broughton  --  April 1973          */
 24 
 25 
 26      declare
 27 
 28           hcs_$make_seg entry (aligned char(*), aligned char(*), aligned char(*),
 29                fixed bin(5), ptr, fixed bin(35)),
 30           hcs_$initiate_count entry (aligned char(*), aligned char(*), aligned char(*),
 31                fixed bin(24), fixed bin(12), ptr, fixed bin(35)),
 32           hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)),  /* sets bit count given pointer to segment */
 33           hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35)),    /* truncates segment given pointer */
 34           hcs_$terminate_noname entry (pointer, fixed bin(35)),       /* terminates a segment */
 35           hcs_$delentry_seg entry ( pointer, fixed bin(35)),          /* deletes a segment */
 36           ioa_ entry options (variable),                              /* output formating routine */
 37           ioa_$rsnnl entry options (variable),                        /* writes into a string */
 38           cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)),     /* fetches arguments */
 39           cu_$cp entry (ptr, fixed bin, fixed bin(35)),               /* calls the command processor */
 40           cu_$cl entry,                                               /* forces return to command level */
 41           cu_$ptr_call entry(ptr),                                    /* calls routine specified by ptr */
 42           expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),     /* expands pathname */
 43           com_err_ entry options (variable),                          /* error printing routine */
 44           timer_manager_$cpu_call entry(fixed bin(71),bit(2),entry),  /* sets up cpu timer */
 45           timer_manager_$reset_cpu_call entry(entry);                 /* resets cpu timer */
 46 
 47      declare
 48 
 49           sys_info$max_seg_size ext fixed (35),
 50           iox_$user_input ext ptr,
 51           iox_$user_output ext ptr;
 52 
 53      declare
 54 
 55           basic_ entry(ptr, fixed bin, ptr, ptr, ptr, fixed bin),
 56           basic_resequence_ entry (fixed bin, fixed bin, ptr, ptr,    /* routine to sequence a program from n by m */
 57                fixed bin, fixed bin, fixed bin(35));
 58 
 59      declare
 60 
 61           id char(12) aligned static init("basic_system"),            /* name of entry to this routine */
 62           language char(6) aligned static init(".basic");             /* suffix for program names */
 63 
 64      declare
 65 
 66           old_linum char(10) aligned;                       /* keeps previous line num for get */
 67 
 68      declare
 69 
 70           1 segment based aligned,                                    /* temporary segment, allocated as follows: */
 71             2 program (0:21503) fixed bin(35),                        /* program as edited, for save or compilation */
 72             2 text (0:44031) fixed bin(35),                           /* area to place source while editing */
 73 
 74           1 table (0:99999) based aligned,                            /* table of line information */
 75             2 indx fixed bin(17) unal,                                /* offset of line from start of "txt" */
 76             2 chcount fixed bin(17) unal,                             /* number of characters in line */
 77 
 78           long_string char(262144) aligned based,                     /* string overlayed on lines */
 79 
 80           ch(0:262143) char(1) unaligned based,                       /* string overlay */
 81 
 82           copy_overlay (count) fixed bin(35) based,                   /* overlay for saving segment */
 83           count fixed bin(17);                                        /* word count of segment to be saved */
 84 
 85      declare
 86 
 87           name char(lname) based (np),                                /* the name of the program to be edited (arg) */
 88                lname fixed bin,                                       /* length of argument */
 89                np pointer,                                            /* pointer to argument, returned by cu_ */
 90           dirname char(168) aligned,                                  /* directory part of segment pathname */
 91           ename char(32) aligned,                                     /* entry portion of pathname */
 92           source char(168) aligned,                                   /* relative pathname of program with ".basic" suffix */
 93           prog char(32) aligned,                                      /* entry name stripped of suffix */
 94           cs char(168) based aligned;                                 /* based input string, overlayed on "txt" */
 95 
 96      declare
 97 
 98           sptr pointer,                                               /* pointer to source */
 99           tptr pointer,                                               /* pointer to base of temporary segment */
100           txt pointer,                                                /* points to part containing lines */
101           tbl pointer,                                                /* points to table of line information */
102           inp pointer,                                                /* pointer to input string */
103           obj pointer,                                                /* pointer to object segment created by basic */
104           main pointer;                                               /* pointer to entry point of basic program */
105 
106      declare
107 
108           (perm_tptr,                                                 /* permanent pointers */
109            perm_tbl,
110            perm_obj) ptr static init(null);
111 
112      declare
113 
114           error_table_$noentry fixed bin(35) external,                /* system error code for none existant file */
115           status bit(72) aligned,                                     /* i/o status code */
116           code fixed bin(35),                                         /* error code */
117 
118           program_interrupt condition,                                /* we must have a handler for this condition */
119           cleanup condition,                                          /* must have a procedure called on non-local return */
120 
121           level fixed bin static init(0),                             /* recursion level */
122 
123           (i, j) fixed bin,                                           /* omnipresent temporaries */
124           k fixed bin(21),
125           nl char(1) static aligned initial ("
126 "),       tab char(1) static aligned initial("    "),                 /* newline and tab characters */
127           chr char(1) aligned,                                        /* temporary used various places */
128           s char(1),                                                  /* used for plural(s) */
129           time_limit fixed bin(71) initial (0),                       /* limit on execution time, 0 -> none */
130           (js, jt) fixed bin initial(0),                              /* offsets from sptr, and txt */
131           numl fixed bin,                                             /* length of line number */
132           csize fixed bin(24),                                        /* size of source in characters */
133           (first, last) fixed bin,                                    /* first and last line no. for list, delete */
134           increment fixed bin defined (last),                         /* increment for resequence command */
135           linum fixed bin,                                            /* line number */
136           err_count fixed bin,                                        /* number of errors in basic program */
137           lmax fixed bin initial(1),                                  /* highest line number */
138           (newline, compiling initial ("0"b), save_sw, known,         /* various flags -- guess */
139                resequencing initial ("0"b), reading initial ("0"b)) bit(1) aligned,
140           (null, addr, fixed, divide, index, substr, mod, max,        /* helpful functions */
141                min, unspec, verify, search, string, convert) builtin;
142 
143      declare
144 
145           input_iocb ptr int static,                        /* iox_ ptr for user_input */
146           output_iocb ptr int static,                       /* iox_ ptr for user_output */
147           buffer char(159);
148 
149 %include iocb;
150 ^L
151 /***************************************** Internal Subroutines ***********************************************/
152 
153 
154 
155      get_line_number: procedure (place) returns (fixed bin);
156 
157           declare
158 
159                place, d fixed bin(17),
160                error bit(1) initial ("1"b),                           /* indicates if there are leading chars */
161                line fixed bin;                                        /* line number */
162 
163           line = 0;                                                   /* initialize line number */
164 
165           do numl = 0 by 1;                                           /* scan line */
166                chr = txt->ch(place+numl);                             /* get current line */
167                d = index("0123456789", chr) - 1;                      /* compute the digit */
168                if d < 0                                               /* test if really a digit */
169                     then do;
170                          if error                                     /* has a digit been found yet */
171                               then do;                                /* number hasn't been started */
172                                    if (chr^=" ") & (chr^=tab)         /* flush leading white space */
173                                         then return (-1);             /* indicate that something is wrong */
174                                    end;
175                               else do;                                /* end of the line number */
176                                    newline = (chr = nl);              /* set newline indicator */
177                                    return (line);                     /* finished */
178                               end;
179                          end;
180                     else do;
181                          line = (line*10)+d;                          /* compute line number */
182                          error = "0"b;                                /* a digit has been found */
183                     end;
184           end;                                                        /* of do group */
185 
186      end get_line_number;
187 
188 
189 
190      get_lines: procedure (place);                                    /* sets "first" and "last" for list, delete */
191 
192           declare place fixed bin;                                    /* points to location in text */
193 
194           first = get_line_number (place);                            /* get first line number */
195           if first < 0 then go to mistake;
196           if newline
197                then do;                                               /* set defaults */
198                     if resequencing                                   /* for rseq or list, delete */
199                          then last = 10;                              /* increment defined(last) */
200                          else last = first;
201                     end;
202                else do;                                               /* get the other one */
203                     last = get_line_number (place+numl);              /* set "last" from next position */
204                     if last < 0 | ^newline then go to mistake;        /* format error */
205                     if resequencing then return;                      /* don't set increment to ... */
206                     last = min(lmax, last);                           /* so we don't have to do so much work */
207                end;
208           return;
209 
210           mistake:
211                call error ("Bad line number specification.", "", "0"b);
212 
213      end get_lines;                                                   /* finished */
214 
215 
216 
217      error: procedure (message, info, fatal);                         /* generalized error routine */
218 
219           declare
220 
221                message char(*) aligned,                               /* error message -- "" -> code */
222                info char(*) aligned,                                  /* additional info on error */
223                fatal bit(1) aligned;                                  /* does this error terminate execution */
224 
225           resequencing, compiling = "0"b;                             /* just to make sure */
226 
227           if message = ""
228                then call com_err_ (code, id, info);                   /* use standard error code */
229                else call ioa_ ("^a ^a", message, info);               /* use ioa_ to tell user about error */
230 
231           if fatal
232                then call cu_$cl;                                      /* get back to command level */
233           else if reading                                             /* are we gettting the source */
234                then go to move;                                       /* yes, continue */
235                else do;                                               /* no, reset and go on to next command */
236                     call input_iocb -> iocb.control (input_iocb, "resetread", null(), code);
237                     call ioa_ ("RESET");
238                     go to next;
239                end;
240 
241      end error;
242 
243 
244 
245      get_seg: proc(name,type,pt);
246 
247           declare
248 
249                name char(*) aligned,                                  /* name of temporary */
250                type fixed bin(5),                                     /* access type */
251                pt ptr;                                                /* set to point at segment */
252 
253           call hcs_$make_seg("", name, "", type, pt, code);           /* make the segment */
254           if pt = null then call error("", name, "1"b);               /* complain if error */
255 
256      end get_seg;
257 
258 
259 
260      clean_up: proc;
261 
262           if compiling & (time_limit ^= 0) then call timer_manager_$reset_cpu_call(cpu_limit);
263 
264           if level = 1
265           then do;
266 
267                /* truncate segs to zero length and leave initiated */
268 
269                call hcs_$truncate_seg(tptr, 0, code);
270                call hcs_$truncate_seg(tbl, 0, code);
271                call hcs_$truncate_seg(obj, 0, code);
272                end;
273           else do;
274 
275                /* delete segs */
276 
277 
278                call hcs_$delentry_seg(tptr, code);
279                call hcs_$delentry_seg(tbl, code);
280                call hcs_$delentry_seg(obj, code);
281                end;
282 
283           level = level - 1;
284 
285      end clean_up;
286 
287 
288 
289      cpu_limit: proc;
290 
291           compiling = "1"b;
292           call ioa_("Time limit exceeded.");
293           goto edit;
294           end;
295 ^L
296 /**************************************** Execution Begins Here ***********************************************/
297 
298 
299 
300 start:                                       /*  Begin Setup  */
301 
302      on program_interrupt begin;                                      /* return here after quits */
303           if resequencing then do;                                    /* we were resequencing */
304                call ioa_ ("Resequencing aborted.");                   /* tell the user */
305                resequencing = "0"b;                                   /* reset indicator */
306           end;
307           else if compiling then do;                                  /* were we compiling the program */
308                call ioa_ ("Execution aborted.");                      /* ditto */
309                compiling = "0"b;
310                if time_limit ^= 0 then call timer_manager_$reset_cpu_call(cpu_limit);
311           end;
312           go to edit;
313      end;
314 
315 
316      level = level + 1;                                               /* bump recursion level */
317 
318      if level = 1
319      then do;
320 
321           input_iocb = iox_$user_input;
322           output_iocb = iox_$user_output;
323           if perm_tptr = null
324           then do;
325 
326                /* first time at level 1, create permanent scratch segments */
327 
328                call get_seg("basic_system_text_",01011b,perm_tptr);
329                call get_seg("basic_system_table_",01011b,perm_tbl);
330                call get_seg("basic_system_object_",01111b,perm_obj);
331                end;
332 
333           tptr = perm_tptr;
334           tbl = perm_tbl;
335           obj = perm_obj;
336           end;
337      else do;
338 
339           /* create temporary segments for recursion levels > 1 */
340 
341           call get_seg("",01011b,tptr);
342           call get_seg("",01011b,tbl);
343           call get_seg("",01111b,obj);
344           end;
345 
346      on cleanup call clean_up;                                        /* cleanup temporaries in case of errors/quits */
347      txt = addr(tptr->segment.text);                                  /* set pointer to program storage area */
348 
349                                         /* Get program to be edited */
350 
351      call cu_$arg_ptr (1, np, lname, code);                           /* fetch the argument */
352      if lname = 0 | code ^= 0 then do;                                /* no name was specified */
353           known = "0"b;                                               /* we must get a name before a save */
354           call ioa_ ("Input.^/");                                     /* enter edit mode directly */
355           go to next;
356           end;
357      known = "1"b;                                                    /* we will not need a name */
358      source = name;                                                   /* align argument string */
359 
360 get_source:                                                           /* get source segment */
361      k = index(source," ");
362      if k ^= 0
363      then if substr(source,k+1) ^= ""
364           then do;
365                known = "0"b;
366                call error ("Improper segment name.", source, "0"b);
367           end;
368      if index (source, language) = 0                                  /* if no suffix then ... */
369           then do;
370                substr(source, lname+1, 6) = language;                 /* insert one */
371                lname = lname + 6;                                     /* adjust name length */
372           end;
373      call expand_path_ (addr(source), lname, addr(dirname), addr(ename), code);
374           if code ^= 0 then call error ("", source, "0"b);            /* expand relative pathnames */
375      prog = substr(ename, 1, index(ename, language)-1);               /* keep stripped name around for compiler */
376      call ioa_$rsnnl ("^a>^a", source, i, dirname, ename);            /* remember full path name in "source" */
377      call hcs_$initiate_count (dirname, ename, "", csize, 0, sptr, code);
378           if sptr = null then do;                                     /* get pointer to and bit count of segment */
379                if code ^= error_table_$noentry
380                     then call error ("", source, "1"b);
381                     else do;
382                          call ioa_ ("Program not found.^/Input.^/");
383                          go to next;                                  /* go directly to next */
384                     end;
385           end;
386      csize = divide(csize,9,17,0);                                    /* compute character count */
387 
388 
389                                    /* Move source into temporary segment */
390 
391 
392 move:
393      reading = "1"b;                                                  /* indicate that we are reading source */
394      old_linum = "-1";                                                /* initialize to before firt line */
395      do while (js < csize);                                           /* scan the entire segment */
396           k = index (substr(sptr->long_string, js+1), nl);  /* find the end of the line */
397           if k = 0 then k = csize - js;                               /* file does not have a newline at the end */
398           substr (txt->long_string, jt+1, k) =                        /* move line into text area */
399                substr (sptr->long_string, js+1, k);
400           js = js + k;                                                /* increment pointer in source */
401           linum = get_line_number (jt);                               /* get this line's number */
402           if linum < 0                                                /* invalid line number encountered? */
403                then call error ("Bad line number in source. Line deleted after line", old_linum, "0"b);
404           else if linum > 99999                                       /* is line number too large? */
405                then call error ("Line number in source too large. Line deleted after line", old_linum, "0"b);
406           lmax = max(lmax, linum);                                    /* highest ? */
407           old_linum = substr(convert(old_linum, linum), 6);           /* save for possible diagnostic */
408           tbl->table(linum).indx = jt;                                /* "jt" is the index of the first char. */
409           tbl->table(linum).chcount = k;                              /* compute length in characters */
410           jt = jt + k + 3;
411           jt = jt - mod(jt,4);                                        /* align next line on word boundary */
412      end;
413      reading = "0"b;                                                  /* reset */
414 
415 
416                                              /* Process input lines */
417 
418 edit:
419      call ioa_ ("Edit.^/");                                           /* enter edit mode */
420 
421 next:
422      inp = addr(txt->ch(jt));                                         /* get place to put next line */
423      call input_iocb -> iocb.get_line (input_iocb, inp, 158, k, code);
424      if code ^= 0 then do;
425           call com_err_ (code, "basic_system");
426           go to next;
427      end;
428      if k <= 1 then go to next;                                       /* blank line */
429      j = verify(inp->cs,"     ");                                     /* get index of first non-white character */
430      if j > 1 then do;                                                /* if not first char, then get significant part */
431           k = k - j + 1;                                              /* get new length */
432           substr(inp->cs, 1, k) = substr(inp->cs, j, k);              /* move line back into alignment */
433      end;
434 
435      if search(substr(inp->cs, 1, 1), "0123456789") > 0
436           then do;
437                linum = get_line_number (jt);                          /* find the line number */
438                if linum < 0 then call error ("Bad line number.", "", "0"b);
439                else if linum > 99999 then call error ("Line number too large.", "", "0"b);
440                if newline
441                     then tbl->table(linum).chcount = 0;               /* if just a line number, delete the line */
442                     else do;                                          /* else insert the line */
443                          lmax = max(lmax, linum);                     /* which is the highest */
444                          tbl->table(linum).indx = jt;                 /* set the index */
445                          tbl->table(linum).chcount = k;               /* set the count */
446                          jt = jt + k + 3;
447                          jt = jt-mod(jt,4);                           /* set the next jt */
448                     end;
449                go to next;                                            /* next line */
450           end;
451 
452      if substr(inp->cs, 1, 3) = "run" then                            /* is this the run command */
453           if substr(inp->cs, 4, 1) = nl then go to run;               /* we not allow anything else */
454 
455      if substr(inp->cs, 1, 4) = "save" then go to save;               /* is this the save command? */
456 
457      if substr(inp->cs, 1, 4) = "list" then go to list;               /* is this the list command? */
458 
459      if substr(inp->cs, 1, 4) = "quit" then                           /* is this the quit command? */
460           if substr(inp->cs, 5, 1) = nl then go to quit;
461 
462      if substr(inp->cs, 1, 6) = "delete" then go to delete;           /* is this the delete command? */
463 
464      if substr(inp->cs, 1, 4) = "rseq" then go to resequence;         /* is this the command to resequence */
465 
466      if substr(inp->cs, 1, 4) = "exec"                                /* execute a Multics command */
467           then do;
468                call cu_$cp (addr(inp->ch(4)), k-4, code);             /* call the command processor */
469                go to next;
470           end;
471 
472      if substr(inp->cs, 1, 4) = "time"                                /* specify a run-time limit on the program */
473           then do;
474                time_limit = get_line_number (jt+4);                   /* use the line number routine to get the no. */
475                if time_limit < 0 then call error("Negative time limit given.","","0"b);
476                go to next;
477           end;
478 
479      if substr(inp->cs, 1, 3) = "get"                                 /* clear buffers and get new source */
480           then do;
481                known = "0"b;                                          /* we don't have a name for the file ... yet */
482                if substr (inp->cs, 4, 1) = nl                         /* was a name given in the command */
483                     then call ioa_ ("Input.^/");                      /* no -- get one later */
484                     else do;
485                          j = verify (substr(inp->cs, 4), "  ") + 3;   /* find start of name */
486                               if j = 0 then call error ("Improper syntax in get command.", "", "0"b);
487                          lname = index (substr(inp->cs, j), nl) - 1;  /* find out length of name */
488                          source = substr (inp->cs, j , lname);        /* get name */
489                          known = "1"b;                      /* got it */
490                     end;
491 
492                call hcs_$truncate_seg (tptr, 0, code);                /* zero out temporaries */
493                     if code ^= 0 then call error ("", "Temporary.", "1"b);
494                call hcs_$truncate_seg (tbl, 0, code);
495                     if code ^= 0 then call error ("", "Temporary.", "1"b);
496                lmax, js, jt = 0;                                      /* nothing left */
497 
498                if known
499                     then go to get_source;                            /* fetch the segment */
500                     else go to next;                                  /* otherwise enter edit mode directly */
501 
502           end;                                                        /* of get command */
503 
504      call ioa_ ("Command not understood.");                           /* all else has failed */
505      call input_iocb -> iocb.control (input_iocb, "resetread", null(), code);
506      call ioa_("RESET");
507      go to next;
508 
509 
510                               /* Routines to list, delete, run, etc. */
511 
512 
513 run:
514      save_sw = "0"b;                                                  /* run, not save */
515 
516 finish:                                                               /* pack lines into base of segment */
517      j = 1;                                                           /* set character pointer */
518      do k = 0 to lmax;                                                /* look at all possible lines */
519           if tbl->table(k).chcount ^= 0 then
520           substr (tptr->long_string, j, tbl->table(k).chcount) =                /* pack lines into base of segment */
521                substr (txt->long_string, tbl->table(k).indx+1, tbl->table(k).chcount);
522           j = j + tbl->table(k).chcount;
523      end;
524      j = j - 1;
525 
526      if save_sw                                                       /* how did we get here */
527           then do;                                                    /* save the program */
528                call hcs_$make_seg (dirname, ename, "", 01011b, sptr, code);     /* create the segment */
529                     if sptr = null then call error ("", source, "0"b);
530                count = divide(j+3,4,17,0);                            /* get word count */
531                sptr->copy_overlay = tptr->copy_overlay;               /* copy the program */
532                call hcs_$set_bc_seg (sptr, fixed(j*9,24,0), code);    /* set a bit count consistant with its length */
533                     if code ^= 0 then call error ("", source, "0"b);
534                call hcs_$truncate_seg (sptr, count, code);            /* truncate it to its new size in words */
535                     if code ^= 0 then call error ("", source, "0"b);
536                go to edit;                                            /* continue */
537           end;
538           else do;                                                    /* compile and run the program */
539                compiling = "1"b;                                      /* set the compile flag */
540                call hcs_$truncate_seg(obj,0,code);                    /* truncate object segment */
541                if code ^= 0 then call error("","","0"b);
542 
543                call basic_(tptr,j,obj,null,main,err_count);           /* run the compiler */
544 
545                if err_count = 0
546                then if main = null
547                     then call ioa_("No main program.");               /* must have main program */
548                     else if time_limit = 0 then call cu_$ptr_call(main);
549                          else do;
550                               call timer_manager_$cpu_call(time_limit,"11"b,cpu_limit);
551                               call cu_$ptr_call(main);
552                               call timer_manager_$reset_cpu_call(cpu_limit);
553                               end;
554                else do;
555                     if err_count = 1 then s = ""; else s = "s";
556                     call ioa_("^d error^a found, no execution.",err_count,s);
557                     end;
558 
559                compiling = "0"b;                                      /* turn off flag */
560                go to edit;                                            /* resume editing */
561           end;
562 
563 save:                                                                 /* we want to save the program */
564      save_sw = "1"b;                                                  /* this is a save, not a run */
565      if substr(inp->cs, 5, 1) = nl                                    /* test if a name was given */
566           then if known                                               /* no, check if a name has been given */
567                then go to finish;                                     /* assume orignal as the default */
568                else call error ("No name given.", "", "0"b);          /* we haven't been given a name */
569 
570      j = verify (substr(inp->cs, 5), "  ") + 4;                       /* ignore leading white space */
571           if j = 0 then call error ("Improper syntax in save command.", "", "0"b);
572      lname = index (substr(inp->cs, j), nl) - 1;                      /* get length of name */
573      source = substr(inp->cs, j, lname);                              /* remove it from the line */
574      k = index(source, " ");
575      if k ^= 0
576      then if substr(source,k+1) ^= ""
577           then do;
578                known = "0"b;                                          /* name is no longer valid */
579                call error ("Improper segment name.", source, "0"b);
580           end;
581      if index(source, language) = 0                                   /* is there a suffix */
582           then do;
583                substr(source, lname+1, 6) = language;                 /* insert one if not */
584                lname = lname + 6;                                     /* update length */
585           end;
586      call expand_path_ (addr(source), lname, addr(dirname), addr(ename), code);
587           if code ^= 0 then call error ("", source, "0"b);            /* expand the pathname */
588      prog = substr(ename, 1, index(ename, language)-1);               /* remember stripped entry name */
589      call ioa_$rsnnl ("^a>^a", source, i, dirname, ename);            /* and full path name */
590      known = "1"b;                                                    /* we now have a name */
591      go to finish;
592 
593 list:                                                                 /* list some lines */
594      if substr(inp->cs, 5, 1) = nl                                    /* no lines given, list all */
595           then do;
596                first = 0;                                             /* set defaults, first to zero */
597                last = lmax;                                           /* and last to the maximum line number */
598                end;
599           else call get_lines (jt + 4);                               /* find out which lines were given */
600 
601      if first > last then do;                                         /* we can't allow this */
602           i = last;                                                   /* exchange */
603           last = first;
604           first = i;
605      end;
606 
607      if first ^= last
608           then call output_iocb -> put_chars (output_iocb, addr(nl), 1, code); /* a new line for looks */
609      else if tbl->table.chcount(first) = 0                            /* if only one line check if it exists */
610           then call error ("No line.", "", "0"b);
611 
612      do i = first to last;                                            /* search all possible lines */
613           k = tbl->table(i).chcount;                                  /* get character count */
614           substr(buffer, 1, k+1) = substr(txt->long_string, tbl->table(i).indx + 1, k) || nl;
615           if k ^= 0 then call output_iocb -> iocb.put_chars (output_iocb, addr(buffer), k, code);/* list only those lines with */
616      end;                                                             /*  none zero count */
617 
618    call output_iocb -> iocb.put_chars (output_iocb, addr(nl), 1, code);         /* another one */
619      go to next;
620 
621 quit: call clean_up;                                                            /* clean up and return */
622      return;                                                          /* goodbye */
623 
624 delete:                                                               /* delete some lines */
625      if substr(inp->cs, 7, 1) = nl                                    /* no lines specified */
626           then call error ("No line numbers given.", "", "0"b);
627           else do;
628                if substr(inp->cs, 7, 4) = " all"                      /* delete all lines */
629                     then do;
630                          first = 0;                                   /* like list, first set to zero */
631                          last = lmax;                                 /* last to maximum */
632                          end;
633                     else call get_lines (jt + 6);                     /* get line numbers */
634           end;
635 
636      do i = first to last;                                            /* delete these lines */
637           tbl->table(i).chcount = 0;                                  /* count = 0 indicates null line */
638      end;
639 
640      go to next;
641 
642 resequence:                                                           /* resequence the line numbers of a program */
643      resequencing = "1"b;                                             /* turn indicator on in case of a quit */
644 
645      if substr(inp->cs, 5, 1) = nl                                    /* get values for resequencing */
646           then do;
647                first = 100;                                           /* if none set defaults */
648                increment = 10;                                        /* start at 100 and go by 10 */
649                end;
650           else call get_lines (jt + 4);
651 
652      call basic_resequence_ (first, increment, tbl, txt, jt, lmax, code);
653           if code ^= 0 then call error ("", "Error occurred while resequencing.", "0"b);
654      resequencing = "0"b;                                             /* finished */
655 
656      go to edit;
657 
658 end basic_system;