Personal tools
You are here: Home Projects SETL LITTLE Source code UTL: Various utility programs, some machine dependent and some principally of interest to the CDC 6600, IBM System/370, or DEC VAX implementations.
Document Actions

UTL: Various utility programs, some machine dependent and some principally of interest to the CDC 6600, IBM System/370, or DEC VAX implementations.

by Paul McJones last modified 2021-03-17 19:57

UTL: Various utility programs, some machine dependent and some principally of interest to the CDC 6600, IBM System/370, or DEC VAX implementations. By David Shields, except objname by Richard Kenner.

       1 .=member intro
       2  /*
       3
       4       !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       5      the above line contains, in order of ascii codes, the 56
       6      characters of the little language, starting in column 7.
       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      this software is part of the little programming system.
      33               address queries and comments to
      34
      35                        little project
      36                department of computer science
      37                     new york university
      38          courant institute of mathematical sciences
      39                      251 mercer street
      40                     new york,  ny  10012
      41
      42      this file contains various utility programs.
      43
      44      the following programs are of interest to all sites:
      45
      46          ascint - exchange ascii files
      47          ltldoc - list little document
      48          ltlpad - pad (justify) little document
      49          merger - combine files
      50          p8020l - process 80/20l format text
      51          shrink - eliminate blank lines and comments
      52          ulst   - structured list  of upd opl file
      53          updfnd - located string in upd opl
      54
      55      the following programs are principally of interest to
      56      sites using s66, the cdc 6000 series implementation:
      57
      58          bldltl - build little overlay input
      59          p8020c - convert 80/20l format to cdc 6/12 bit
      60          makupl - convert update oldpl to upd opl
      61          rflovl - set field length of overlay
      62          tic    - translate individual character
      63          updbrk - break out comments
      64          updedt - update/edit interface
      65          updlst - structured list of update compile file
      66
      67
      68      the following programs are principally of interest to
      69      sites using s37, the ibm system/370 implementation
      70
      71          objname - format for linkage editor
      72
      73
      74      the following programs are principally of interest to
      75      sites using s32, the dec vax implementation
      76
      77          spl    - split t32 file (vms only)
      78          mktvec - make transfer vector (vms only)
      79
      80  */
       1 .=member mods
       2 $ all mods are to insert self description after mods.2
utsa   1
utsa   2 $    utsa      d. shields          29-nov-81           level 81333
utsa   3 $
utsa   4 $    support s47: amdahl uts (universal timesharing system).
utsa   5 $    this implementation runs on s37 architecture using an operating
utsa   6 $    system very close to unix (v7), and uses the ascii character set.
utsa   7
tva    1
tva    2 $    tva       d. shields          9-sep-81
tva    3 $
tva    4 $    add parameter 'name=ltllibtv/' to mktvec to permit naming
tva    5 $    psect for mktvec.
tva    6 $    deck affected - mktvec.
tva    7
obja   1
obja   2 $    obja      d. shields          9-sep-81
obja   3 $
obja   4 $    increase name table limit for objname and check for table overflow
obja   5 $    deck affected - objname.
obja   6
dsd    1
dsd    2 $    dsd       d. shields          25-feb-81
dsd    3 $
dsd    4 $    add 'km=0/1' so km=1 needed to keep generated .mar files.
dsd    5 $    add 'ko=0/1' so that ko=1 needed to keep generated .obj files.
dsd    6 $    deck affected - spl.
dsd    7
       3
       4 $    dsc       d. shields          9-feb-81
       5 $
       6 $    1.  add merger, updfnd, mktvec and spl.
       7 $    2.  modify p8020l format so shift string put on separate line.
       8 $        this permits keeping line length at 80 when writing export
       9 $        files.  this requires changes to p8020l and p8020c
      10 $    3.  modify filename defaults for shrink, p8020l, p8020c,
      11 $        ascint and ltlpad to be p=/p and n=/n.
      12 $        this means p and n files will be
      13 $        units 3 and 4 respectively if parameters not specified.
      14 $    decks affected - ascint, p8020l, p8020c, shrink, merger, updfnd.
      15
      16 $    updb      d. shields          11 sep 78
      17 $
      18 $    modify updlst to list five, not four, digits of update
      19 $    sequence number.
      20 $    deck affected - updlst.
      21
      22
      23 $    doca        d. shields         23 jun 78
      24 $
      25 $    correct error in sizing of -ptxtara-.
      26 $    deck affected - ltldoc.
      27
      28
      29 $    upda      d. shields          22 nov 77
      30 $
      31 $    add option 'b=1/0' to updlst so that 'b=0' causes updlst to not
      32 $    list lines which are all blank.
      33 $    deck affected - updlst.
      34
      35
      36 $    rfla      d. shields          21 nov 77           s66 only
      37 $
      38 $    add option 'a=1' to rflovl to permit reformatting of 5400-type
      39 $    overlays into 5000-type.  this assists export of binaries, as
      40 $    not all nos/be and scope 3.4 sites support the 5400 tables
      41 $    produced by nos loader used by cims.
      42 $    deck affected - rflovl (resequenced).
      43
      44
      45 $    dsb       d. shields          03 nov 77
      46 $
      47 $    modify updbrk to be consistent with library mod dso.  this
      48 $    requires that updbrk use column zero to handle carriage control
      49 $    instead of redefining access mode of file 2 (which is now
      50 $    forbidden).
      51 $    deck affected - updbrk.
      52
      53
      54 $    dsa       d. shields          30 aug 77.
      55 $
      56 $    reported problem - print limits in updlst and updbrk too small
      57 $    for setl library.
      58 $    fix - drop special print limit code in updlst and updbrk.  this
      59 $    code attempted to avoid print limits in moderately large files
      60 $    by increasing standard print limits.  as it is not clear what
      61 $    limits to use, the standard print limits are restored, and
      62 $    users are to use -pfpl- and -pfll- parameters to print large
      63 $    files.
      64 $    decks affected - updbrk, updlst.
      65
      66
      67 $    agb       a. grand            29 jul 77.
      68 $
      69 $    extend print limits of -updbrk- and -updlst- to permit up to
      70 $    750 pages.
      71 $    decks affected - updbrk, updlst.
      72
      73
      74 $    aga       a. grand            17 may 77.
      75 $
      76 $    extend updlst to accept -s- (setl) option which treats -define-
      77 $    -definef-, -module- and -macro- as procedure openers.
      78 $    deck affected - updlst.
      79
       1 .=member ascint
       2 $ ascint - program to interchange full ascii files.
       3
       4 $ this program permits transmission of full ascii files
       5 $ using only the 64 character subset of ascii.
       6 $ each character is transmitted as two characters. the
       7 $ first character indicates if further translation needed,
       8 $ and second character is data character. the
       9 $ first character is one of following:
      10 $
      11 $  blank   no further translation needed
      12 $  <       (less than) subtract 32 to get true code.
      13 $  >       (greater than)  add 32 to get true code.
      14 $
      15 $          for example, word little in lower case transmitted
      16 $          as  >l>i>t>t>l>e.
      17 $
      18 $ program parameters are as follows:
      19 $
      20 $ p=/p     input data file (use unit 3 if not specified)
      21 $
      22 $ n=/n     output data file (use unit 4 if not specified)
      23 $
      24 $ w=0/1    w=0 if reading ascint format, w=1 if writing.
      25
      26 $ ff=0/1   if ff=1 and w=1 then express form feed by writing
      27 $          line with ' 1' in first two columns, otherwise
      28 $          write line with '  ' in first two columns.
      29 $          if ff=0 translate formfeed as any other special
      30 $          ascii character.
      31 $
      32 $ author:  d. shields  (nyu)  20-nov-79
      33 $
      34    +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      35    +*  filenamelen = 64 **  $ length of file name
      36    +*  ifile = 3 ** +*  ofile = 4 **
      37    prog start;
      38    size  ifilename(.sds. filenamelen), ofilename(.sds. filenamelen);
      39    size  inplen(ps);    $ length of input lines.
      40    size  writing(ps);    $ nonzero if writing in ascint form.
      41    size  ff_opt(ps);           $ form-feed option
      42 $  ff_opt is used to avoid form-feeds in file as follows:
      43 $  when writing:
      44 $  if first char of record is ff, then first
      45 $  two chars of output record are ' 1'
      46 $  otherwise, first two chars of output record are '  '
      47        $ zero to convert to full ascii.
      48    size  ilines(ws);  data  ilines = 0;  $ input lines.
      49    size  il(cs);  dims il(160);  $ input line
      50    size  ol(cs);  dims ol(160);  $ output line
      51    size  ilp(ps), olp(ps);    $ line pointers.
      52    size  esc(ps);    $ escape code.
      53    size  cod(ps);    $ char code.
      54    size  rc(ws);    $ return code.
      55    size  i(ps),l(ps);
      56
      57    call fltini;  $ initialize filter.
      58    if  writing then  call ascwtr; else call ascrdr; end if;
      59    put ,' read ' :ilines,i ,' lines.' ,skip;
      60    end prog;
      61    subr ascrdr;
      62    size  i(ps);    $ loop index.
      63    size  rc(ws);    $ return code.
      64 $  read file in ascint format and convert to full ascii
      65    while 1;
      66    call getcsio(ifile, rc, il, 1, 80); $ get first part.
      67    if  (rc)  quit while;
      68    call getcsio(ifile, rc, il, 81, 80); $ get second part.
      69    if  (rc)  quit while;
      70    ilines = ilines + 1;
      71    olp = 0;
      72 do  i = 1 to 160 by 2;
      73     esc = il(i);  $ get escape character.
      74     cod = il(i+1);  $ get code as transmitted.
      75     if  esc=1r     then  $ if no change.
      76    ; $ do nothing;
      77     elseif  esc = 1r<  then  $ if lower code.
      78    cod = cod - 32;
      79     elseif  esc = 1r>  then  $ if upper code.
      80    cod = cod + 32;
      81    end if;
      82     olp = olp + 1;  ol(olp) = cod;
      83     end do;
      84 call putcsio(ofile, rc, ol, 1, 80); $ transmit decoded line.
      85 end while;
      86    end subr ascrdr;
      87    subr ascwtr;
      88    size  i(ps);    $ loop index.
      89    size  rc(ws);    $ return code.
      90  $ read file in full ascii and write in ascint format.
      91    while 1;
      92 call getcsio(ifile, rc, il, 1, 80); $ get line.
      93 if  (rc)  quit while;
      94 ilines = ilines + 1;
      95 olp = 0;
      96 if  ff_opt  then
      97     if  il(1) = 12  then $ if form_feed
      98 put ,'formfeed seen, line ' :ilines,i ,skip;
      99    ol(1) = 1r ; ol(2) = 1r1;
     100    call putcsio(ofile, rc, ol, 1, 2);
     101    cont while;
     102     else ol(1) = 1r ;  ol(2) = 1r ;
     103    end if;
     104     olp = olp + 2;
     105     end if;
     106 do  i = 1 to 80;
     107     cod = il(i);  $ get character to transmit.
     108     if cod<32  then  $ if low code.
     109    esc = 1r<;
     110    cod = cod + 32;
     111     elseif  cod<96  then $ if in 64 char subset
     112    esc = 1r ;
     113     else  $ if high code.
     114    esc = 1r>;
     115    cod = cod-32;
     116    end if;
     117     ol(olp+1) = esc;  $ transmit escape char.
     118     ol(olp+2) = cod;  $ transmit char.
     119     olp = olp + 2;
     120    end do;
     121 call putcsio(ofile, rc, ol, 1, 80); $ write first part.
     122 call putcsio(ofile, rc, ol, 81, 80); $ write second part.
     123 end while;
     124    end subr ascwtr;
     125    subr filter;
     126    end subr;
     127    subr fltini;
     128 $ fltini - initialize filter
     129    size  rc(ws);    $ return code
     130    size  l(ws);    $ return value.
     131    call getipp(writing,'w=0/1');  $ assume reading by default.
     132    call getipp(ff_opt,'ff=0/1');  $ assume no form-feeds.
     133    call getspp(ifilename,'p=/p');
     134    call getspp(ofilename,'n=/n');
     135    call opensio(ifile, rc, 1, ifilename, 80, inplen);
     136    call opensio(ofile, rc, 3, ofilename, 80, l);
     137    end subr fltini;
       1 .=member ltldoc
       2  /*              ltldoc - list little document.
       3
       4      input consists of lines with control characters in
       5      the first two columns, and text in the remaining seventy columns.
       6      control characters are as follows:
       7
       8      d - document: initialize. should be first control line.
       9      e - eject: set eject flag, do not list text.
      10      p - page: set eject flag, list text.
      11      q - define symbolic page number.
      12      s - subtitle: use text to define subtitle, set eject flag.
      13      t - title: use text to define main title, set eject flag.
      14      u - underline: list text, then underline it.
      15      y - enable expansion of symbolic page numbers.
      16      z - disable expansion of symbolic page numbers.
      17      0 - skip line before listing text.
      18      1 - same as p.
      19      n - integer in 2..9. force new page if less that given number
      20          of lines remain on page.
      21
      22      the q, y and z directives permit the construction of a simple
      23      table of contents at the end of a document.  a symbolic page
      24      number consists of a string starting with '<' and ending with '>'.
      25      the q directive associates the current page number with the
      26      symbolic page number.  later y and z directives determine
      27      if symbolic page numbers are to be replaced by page numbers.
      28
      29      author:  david shields  (cims)  11 jan 77.
      30      revise:  david shields  (cims)  23 jun 78.
      31      revise:  9-feb-81 add 2..9 case to test for required number
      32               of lines at bottom of page
      33  */
      34
      35      $   standard macros.
      36      +* ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      37      +* yes = 1 **  +* no = 0 **  $ aid readability.
      38      +*  sympagelim = 200 ** $ limit of symbolic page numbers.
      39
      40      $   program parameters.
      41      +*  nlb = 4  **  $ number of leading blanks in line.
      42      +*  ibl = (''.pad. nlb) **  $ initial blank string.
      43
      44      prog ltldoc;            $ list little document.
      45
      46      size  linesperpage(ps);  $ lines per page.
      47      size  anyc(ws);  $ function to see if character in string set
      48      size  dotext(1);        $ on to list text of line.
      49      size  ejecting(1);      $ on to begin new page with next text
      50                              $ line.
      51      size  underlining(1);   $ on to underline text.
      52      $   firstnb and lastnb delimit text for underline option.
      53      size  firstnb(ps), lastnb(ps);
      54      $   firstpn and lastpn delimit symbolic page number.
      55      $   firstpn nonzero only if valid symbolic page number.
      56      size  firstpn(ps), lastpn(ps);
      57      size  dosympage(ps);     $ on to expand symbolic page numbers.
      58      size  spnlab(.sds.10); $ text of symbolic page number.
      59      $   pnumara and ptxtara are arrays of symbolic page numbers and
      60      $   strings, respectively.  sympagelim is maximum number of
      61      $   symbolic pages.  sympageptr gives last symbolic page index.
      62      size  pnumara(ps);  dims pnumara(sympagelim);
      63      size  ptxtara(.sds.10);  dims ptxtara(sympagelim);
      64      size  sympageptr(ps);  data  sympageptr = 0;
      65      size  pagenumstr(.sds. 4);  $ conversion string.
      66      data  pagenumstr = ''.pad. 4;
      67      size  i(ps);            $ loop index.
      68      size  c1(cs), c2(cs);   $ first two characters in line.
      69      size  text(.sds. 70);   $ text line.
      70      size  skipcount(ps);    $ skip count.
      71
      72      $   get number of lines per page.
      73      call contlpr(10, linesperpage);
      74
      75
      76      file 3 access=string, title=pagenumstr, linesize=4;
      77
      78      call docini;            $ initialize for new document.
      79
      80      while 1;
      81          get ,skip :c1 :c2,r(1) :text,a(70);
      82          if  (filestat(1,end))  quit while;
      83
      84          if  c1 = 1r  then  $ if blank, list text.
      85              dotext = yes;
      86
      87          elseif  c1 = 1rd  then  $ if new document
      88              call docini;
      89              dotext = no;
      90
      91          elseif  c1 = 1re  then  $ if eject request.
      92              dotext = no;  ejecting = yes;
      93
      94          elseif  c1=1rp ! c1=1r1  then  $ if new page
      95              dotext = yes;  ejecting = yes;
      96
      97          elseif  c1=1rq  then  $ if defining symbolic page number.
      98              dotext = no;
      99              call getspn;  $ get symbolic page number.
     100              if  firstpn > 0  then
     101                  sympageptr = sympageptr + (sympageptr(firstpn+11))  lastpn = firstpn + 11;
     105                  ptxtara(sympageptr) =
     106                      .s. firstpn+1,lastpn-firstpn-1, text;
     107                  end if;
     108
     109          elseif  c1 = 1rs  then  $ if subtitle definition
     110              dotext = no;  ejecting = yes;
     111              call stitlr(1, ibl!!text);  $ enter subtitle.
     112
     113          elseif  c1 = 1rt  then  $ if main title definition
     114              dotext = no;  ejecting = yes;
     115              call stitlr(0, ibl!!text);  $ enter main title.
     116              call stitlr(1, '');  $ clear subtitle.
     117
     118          elseif  c1 = 1ru  then  $ if underline request
     119              dotext = yes;  underlining = yes;
     120
     121          elseif  c1 = 1ry  then  $ expand symbolic page numbers.
     122              dosympage = yes;  dotext = no;
     123
     124          elseif  c1 = 1rz  then  $ do not expand symbolic page numbers.
     125              dosympage = no;  dotext = no;
     126
     127          elseif  c1 = 1r0  then  $ if skip line request.
     128              dotext = yes;
     129              $ avoid skip if already ejecting
     130              if  (ejecting=no)  skipcount = 1;
     131
     132          elseif  anyc(c1, 4) then  $ if digit 2..9
     133              dotext = no;
     134              call contlpr(5, (c1-1r0)); $ conditional eject
     135
     136          else  dotext = yes;
     137              end if;
     138
     139          if  (dotext=no)  cont while;
     140
     141          if  ejecting  then  $ if starting new page.
     142              put ,page;
     143              ejecting = no;  skipcount = 0;
     144              end if;
     145
     146          if  skipcount  then $ if skipping lines before text.
     147              put ,skip(skipcount);  skipcount = 0;  end if;
     148
     149      $   here to process symbolic page numbers.
     150      if  (dosympage = no)  go to notsympage;
     151      call getspn;  $ seek symbolic page number.
     152      if  (firstpn = 0)  go to notsympage;  $ if no number.
     153      spnlab = .s. firstpn+1, lastpn-firstpn-1, text;
     154      do  i = 1 to sympageptr;
     155          if  ptxtara(i) .seq. spnlab  then  $ if match
     156              .s. firstpn, lastpn-firstpn+1, text = ' '; $ clear field.
     157              put 3 ,column(1) :pnumara(i),i(4);
     158              .s. firstpn, 3, text = .s. 2, 3, pagenumstr;
     159              go to notsympage;
     160              end if;
     161          end do;
     162 /notsympage/
     163
     164          put ,x(nlb) :text,a,skip;
     165          dotext = yes;
     166          if  underlining  then
     167              underlining = no;
     168              if  (text .seq. (''.pad.70))  cont while;
     169              call contlpr(5, 3);  $ need at least three lines.
     170              firstnb = 1;    $ find first, last non blanks.
     171              while  .ch. firstnb, text = 1r ;
     172                  firstnb = firstnb + 1;  end while;
     173              lastnb = 70;
     174              while  .ch. lastnb, text = 1r ;
     175                  lastnb = lastnb - 1;  end while;
     176              text = '' .pad. 70;
     177              do  i = firstnb to lastnb;  .ch. i, text = 1r-;  end do;
     178              put ,x(nlb) :text,a,skip;
     179              end if;
     180
     181          end while;
     182      end prog ltldoc;
     183      subr docini;            $ initialize for new document.
     184
     185      call contlpr(6, 1);     $ enable paging.
     186      call contlpr(7,1);      $ enable titling, clear main, subtitles.
     187      call etitlr(0, 'page', 63+nlb, 0);  $ enter 'page' field.
     188      call contlpr(8, 67+nlb);    $ set page field.
     189      call contlpr(9, 0);     $ clear date field.
     190      call contlpr(13,0);     $ set initial page number.
     191      call contlpr(2,2);      $ set initial line position.
     192
     193      dosympage = no;  $ disable symbolic page expansion.
     194      sympageptr = 0;  $ reset symbolic page pointer.
     195      dotext = no;  ejecting = yes;  underlining = no;
     196      skipcount = 0;
     197      end subr docini;
     198      subr getspn;  $ get symbolic page number.
     199      size  i(ps);   $ search index.
     200      $   seek symbolic page number, delimited by '<...>'.
     201      firstpn  = '<' .in. text;
     202      if  (firstpn=0)  return;
     203      lastpn = '>' .in. text;
     204      if  (lastpn<=firstpn)  then  $ if no page number.
     205          firstpn = 0;
     206          return;
     207          end if;
     208      end subr getspn;
       1 .=member ltlpad
       2      /*  ltlpad - pad text.
       3      ltlpad uses directives in column two to mark groups of lines to be
       4      padded, i.e., aligned on left and right margins.
       5      commands in column two:
       6          n - begin numeric paragraph.
       7          x - begin text paragraph.
       8
       9      a paragraph ends with next paragraph begin, blank line, or
      10      line with directive in column one.
      11      the left margin of a text paragraph is the first nonblank in
      12      the opening line.  the first line of a numbered paragraph must
      13      contain an instance of '. ', and the left margin is the first
      14      nonblank following this instance.
      15
      16      program parameters are
      17
      18          p  p=/p  input file (use unit 3 if not specified)
      19          n  n=/n  output file (use unit 4 if not specified)
      20
      21      author: d. shields  (cims)  01 mar 77.
      22      revise  9-feb-81  convert to use p and n parameters for files
      23
      24  */
      25
      26      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      27      +*  wmax = 70 **  $ maximum words per line.
      28      +*  yes = 1 **  +* no = 0 **  $ for logical expressions.
      29      +*  ifile = 3 **
      30      +*  ofile = 4 **
      31      +*  filenamelen = 20 **  $ length of string parameter.
      32 .+s32    +* filenamelen = 64 **
utsb   1 .+s47    +* filenamelen = 64 **
      33      +*  wclear =  $ clear word array variables.
      34          wp = 0;  $ reset word pointer.
      35          wstrptr = 0;  $ rest text pointer.
      36          lineleft = linewidth;  $ indicate free line.
      37          .len. otext = 0;  $ reset output text position.
      38          **
      39      prog ltlpad;
      40      size  lineleft(ps);  $ remaining space in line.
      41      size  filldir(ps);  $ fill direction.
      42      size  wstrptr(ps);    $ index of text in wstr.
      43      size  wstr(.sds. 72);   $ text of words
      44      size  ifilename(.sds. filenamelen);
      45      size  ofilename(.sds. filenamelen);
      46      size  intext(.sds. 72);
      47      size  linewidth(ps);  $ line width during fill.
      48      size  groupline(ps);  $ line number within group.
      49      size  first_line(.sds. 72); $ first line in fill group.
      50      size  first_fill(ps);  $ on when start fill.
      51      size  isblank(1);  $ on if text part of line is blank.
      52      size  add_to_fill(1);  $ on to add line to filled text.
      53      size  end_fill(1);  $ on if line ends fill.
      54      size  start_fill(1);  $ on if line starts fill.
      55      size  inline(.sds. 72);
      56      size  otext(.sds. 72);
      57      size  c1(cs);  $ column one character.
      58      size  c2(cs);  $ column two character.
      59      size  filling(ps);  $ on when filling.
      60      size  fill_mode(ps);  $ mode of fill.
      61      size  raw(.sds. 72);
      62      size  wp(ps);   $ word pointer.
      63      size  wlen(ps);  dims wlen(wmax);  $ word lengths.
      64      size  wtrail(ps);  dims wtrail(wmax);  $ trailing blank counts.
      65      size  worg(ps);  dims worg(wmax);  $ word origin.
      66      size  ioline(.sds. 72);  $ output line.
      67      size  leftmarg(ps);  $ left margin during fill.
      68      size  rawp(ps);  $ position in raw.
      69      size  packmode(ps);  $ on to pack only, no justify.
      70      size  buglev(ps);  $ debug trace flag.
      71      call getipp(buglev, 'bug=0/1');
      72      if  buglev=0  then monitor nostores,noentry; end if;
      73
      74      otext = ''.pad.72;  $ output text line.
      75      wstr = ''.pad.72;  $ word text line.
      76      wclear;
      77      call getipp(packmode, 'pack=0/1');
      78      call getspp(ifilename, 'p=/p');
      79      call getspp(ofilename, 'n=/n');
      80      file ifile access=get, title=ifilename, linesize=72;
      81      file ofile access=put, title=ofilename, linesize=72;
      82      rewind ofile;
      83      filling = no;
      84      wclear;
      85      $   main control loop.
      86      while 1;
      87          get  ifile ,skip :inline,a(72);
      88          if  filestat(ifile,end)  then
      89              if  filling  then  call filler(3);  end if;
      90              quit while;
      91              end if;
      92
      93          c1 = .ch. 1, inline;
      94          c2 = .ch. 2, inline;
      95          intext = .s. 3, 70, inline;
      96          isblank = intext .seq. (''.pad. 70);
      97          add_to_fill = filling & (c1=1r )
      98              & (isblank=no) & (c2=1r );
      99          if  add_to_fill  then  call filler(2);  end if;
     100
     101      end_fill = filling & (isblank ! (c1^=1r ) ! (c2^=1r ));
     102          if  end_fill  then  call filler(3);  end if;
     103
     104          start_fill = (isblank=no) & (c2=1rn ! c2=1rx);
     105          if  start_fill  then  call filler(1);  end if;
     106
     107          if  add_to_fill=no & start_fill=no  then  $ if text, copy it.
     108              put ofile :inline,a ,skip;
     109              end if;
     110          end while;
     111
     112      end prog;
     113      subr filler(case);  $ fill text control procedure.
     114      $   fill text according to parameter case, as follows:
     115      $   1.  begin filled text, determine margin.
     116      $   2.  add current line to filled text.
     117      $   3.  end filling, flush remaining text.
     118
     119      size  case(ps);   $ action.
     120      go to l(case) in 1 to 3;
     121 /l(1)/  $ begin fill mode.
     122      first_fill = yes;
     123      first_line = inline;
     124      call findmarg;  $ locate left margin.
     125      if  (leftmarg = 0)  then  $ if no left margin, cannot fill.
     126          start_fill = no;  return;  end if;
     127      linewidth = 72 - leftmarg + 1;
     128      filldir = 1;  $ first fill from left.
     129      filling = yes;
     130      wclear;
     131      groupline = 1;
     132      return;
     133 /l(2)/  $ add to filled text.
     134      if  first_fill then  $ if first additional line, set up.
     135          raw = .s. leftmarg, linewidth, first_line;
     136          call digest;
     137          first_fill = no;
     138          end if;
     139      raw = .s. leftmarg, linewidth, inline;
     140      call digest;
     141      return;
     142 /l(3)/  $ end fill.
     143          filling = no;
     144      if  first_fill  then  $ if only one line in group.
     145          put ofile :first_line,a(72) ,skip;
     146          return;
     147          end if;
     148
     149      if  wp  then  call writout;  end if;  $ if any words.
     150      end subr filler;
     151
     152      $   for each word, note text, length, and number of trailing blank
     153      $   trailing blank count is zero if word ends line; otherwise code
     154      $   respects internal blanks given in text.
     155
     156      $   code to write out words with filling.
     157      $   code assumes word arrays correctly setup.
     158      subr writout;
     159      size  i(ps);  $ loop index.
     160      size  l(ps);  $ line length.
     161      size  nfill(ps);  $ number of filling blanks.
     162      size  minfill(ps);  $ minimum filling blanks.
     163
     164      lineleft = linewidth;
     165      if  (wp=0)  return;  $ if no words.
     166
     167      $   if packing along, suppress all justification.
     168
     169      wtrail(wp) = 0;  $ last is end of line.
     170      if  (packmode)  go to putem;
     171      if  (wp=1)  go to putem; $ if only word, cannot justify.
     172      nfill = 0;
     173      if  filling  then
     174      $   line has more than one word, can justify.
     175      l = wlen(wp);  $ line length.
     176      do  i = 1 to wp-1;  $ find length so far.
     177          l = l + wlen(i) + wtrail(i);
     178          end do;
     179      nfill = linewidth - l;  $ number to fill.
     180      end if;
     181      $   if fill count is zero, line is justified.
     182      if  (nfill=0)  go to putem; $ if no need justify.
     183      $   here if fill.  if fill count exceeds word count, each word
     184      $   will get at least one blank, so insert blanks so fill count
     185      $   reduce so does not exceed word count.
     186      if  nfill > (wp-1)  then  $ if fill each word at least once.
     187          minfill = nfill / (wp-1);
     188          do  i = 1 to wp-1;
     189              wtrail(i) = wtrail(i) + minfill;
     190              end do;
     191          nfill = nfill - minfill*(wp-1);
     192          end if;
     193
     194      if  (nfill=0)  go to putem;  $ if justified.
     195
     196      $   code to fill from left.
     197      if  filldir = 1  then  $ if fill from left.
     198          do  i = 1 to nfill;  wtrail(i) = wtrail(i) + 1;  end do;
     199
     200      else
     201          $   code to fill from right.
     202          do  i = 1 to nfill;  wtrail(wp-i) = wtrail(wp-i) + 1;  end do;
     203      end if;
     204
     205 /putem/
     206      do  i = 1 to wp;  call putwrd(i);  end do;
     207      filldir = 1 - filldir;
     208
     209      end subr writout;
     210
     211      subr putwrd(wi);
     212      size  wi(ps);  $ index of word to put out.
     213      size  i(ps);   $ loop index.
     214      size  l(ps);   $ length.
     215      size  lprev(ps);  $ prior length of otext.
     216      l = wlen(wi);
     217      lprev = .len. otext;
     218      .len. otext = lprev + l;
     219      .s. lprev+1, l, otext = .s. worg(wi), l, wstr;
     220      lprev = l + lprev;
     221      l = wtrail(wi);  $ number of trailing blanks.
     222      if  l  then  $ if trailing blanks.
     223          .len. otext = lprev + l;
     224          .s. lprev+1, l, otext = ' ';
     225          end if;
     226
     227      $   if last word, then write out line.
     228      if  wi = wp  then  $ if last word in line.
     229          if  groupline = 1  then  $ if first line, get pretext.
     230              put ofile :.s. 1, leftmarg-1, first_line,a;
     231          else
     232              put ofile ,x(leftmarg-1);
     233              end if;
     234          groupline = groupline + 1;
     235          put ofile :otext,a ,skip;
     236      wclear;
     237          end if;
     238      end subr putwrd;
     239      subr findmarg;
     240      $   determine fill mode by char in column towo.  determine left
     241      $   margin and copy first part of text to output line.
     242      size  i(ps);      $ loop index.
     243      size  firstnb(ps);  $ first nonblank positin.
     244      size  lastnb(ps);   $ last nonblank position.
     245      size  dotpos(ps);   $ index of '. '.
     246      leftmarg = 0;
     247      groupline = 1;
     248      firstnb = 0;
     249      do  i = 3 to 72;
     250          if  .ch. i,inline ^= 1r  then
     251              firstnb = i;
     252              quit do;
     253              end if;
     254          end do;
     255      if  (firstnb=0)  return;  $ if no left margin.
     256      if  .ch. 2, inline = 1rx  then  $ if text mode.
     257          leftmarg = firstnb;
     258          end if;
     259      if  .ch. 2, inline = 1rn  then  $ if numeric mode.
     260          dotpos = '. ' .in. inline;
     261          if  (dotpos=0 ! dotpos>60)  return;
     262          do  i = dotpos+2 to 72;
     263              if  .ch. i, inline ^= 1r   then
     264                  leftmarg = i;
     265                  quit do;
     266                  end if;
     267              end do;
     268          end if;
     269
     270      end subr findmarg;
     271      subr digest;
     272      size  i(ps);  $ loop index.
     273      size  wo(ps);  $ word origin.
     274      size  wl(ps);  $ word length.
     275      size  ntb(ps);  $ number of traling blanks.
     276  notrace stores i;  $ digest notrace
     277      $   get words until input text exhausted.
     278      rawp = 1;
     279
     280      while 1;
     281          call getwrd(wo, wl, ntb);
     282          $   wo is word origin, wl is word length, ntb is number traili
     283          $   if wl is zero, then at end of line.
     284          if  wl = 0  then  return;  end if;
     285          if  wl > lineleft  then  $ if no room in line.
     286              call writout;
     287              end if;
     288          if  wl > lineleft  then  $ if long word.
     289              wl = lineleft;
     290              end if;
     291          if  wl <= lineleft  then  $ if can add.
     292              wp = wp + 1;
     293              wlen(wp) = wl;
     294              worg(wp) = wstrptr + 1;
     295              .s. worg(wp), wl, wstr = .s. wo, wl, raw;
     296              wstrptr = wstrptr + wl;
     297      $   if word ended line, put one blank after it, and two blanks
     298      $   if word ends in period.
     299              if  ntb = 0  then
     300                  ntb = 1;
     301                  if  (.ch. wstrptr, wstr=1r.)  ntb = 2;
     302                  end if;
     303              wtrail(wp) = ntb;
     304              lineleft = idim(lineleft, wl);
     305              lineleft = idim(lineleft, ntb);  $ room for blanks.
     306              end if;
     307          end while;
     308
     309      end subr digest;
     310      subr getwrd(wo, wl, ntb);  $ get word.
     311      $   get next word from unfilled string.  set wo to starting
     312      $   index of word.  set wl to length of word or to zero if no more
     313      $   words.  if word found, set ntb to number of following blanks
     314      $   unless word ends line, in which case set ntb to zero.
     315
     316      size  wo(ps);   $ word origin.
     317      size  wl(ps);   $ word length.
     318      size  ntb(ps);  $ number of trailing blanks.
     319 notrace stores;
     320
     321      wo = rawp;
     322      wl = 0;
     323      ntb = 0;
     324      while  rawp<=linewidth;
     325          if  .ch. rawp, raw ^= 1r  then  go to found; ; end if;
     326          rawp = rawp + 1;
     327          end while;
     328      return;  $ no word found.
     329 /found/  $ here when start of word seen.
     330      wo = rawp;
     331      wl = 1;
     332      while 1;
     333          if  rawp = linewidth  then
     334              rawp = rawp + 1;  $ force up, so next call fails.
     335              return;
     336              end if;
     337          rawp = rawp + 1;
     338          if  .ch. rawp, raw ^= 1r  then  $ if non blank, add to word.
     339              wl = wl + 1;
     340              cont while;
     341          else  $ if blank, end word, find trailing blanks.
     342              quit while;
     343              end if;
     344          end while;
     345      $   here when word ended by blank, determing trailing blank
     346      $   count, returning zero if word ends line.
     347      ntb = 0;
     348      rawp = rawp - 1;  $ set up for loop.
     349      while 1;
     350          rawp = rawp + 1;
     351          if  rawp >= linewidth  then
     352              rawp = linewidth + 1;
     353              ntb = 0;
     354              return;
     355              end if;
     356          if  .ch. rawp, raw ^= 1r  then
     357              quit while;  end if;  $ if end found.
     358          ntb = ntb + 1;
     359          end while;
     360      end subr getwrd;
       1 .=member merger
       2      prog merger; $ program to merge files
       3$ the input file is copied to the output file, except
       4$ that lines starting with '0;
      75          i2 = brks(iline, 9+i1, 2);
      76          assert i2>0;
      77          fname = .s. i1+9, i2, iline;
      78        $ account for quotes
      79          i1 = spns(fname, 1, ss_quote);
      80          i2 = rsps(fname, .len. fname, ss_quote);
      81          if  i1>0  then
      82              i2 = i2 - i1;
      83              fname = .f. i1+1, i2, fname;
      84              end if;
      85          if  i2>0  then
      86              .len. fname = .len. fname - i2;
      87              end if;
      88          fname = b_parm !! fname !! a_parm;
      89          depth = depth + 1;
      90          assert depth<=maxdepth;
      91          ifile = ifiles(depth);
      92          file ifile access=get, title=fname, linesize=linelen;
      93          call opnchk(ifile, fname);
      94 .+s66    rewind ifile;
      95          if  verbose then
      96              put ,'including ' :fname,a ,skip;
      97              end if;
      98          end while;
      99      end prog;
     100      subr opnchk(i, nam);
     101      size i(ps), nam(.sds. filenamlen);
     102      if  filestat(i, access) = 0 then
     103          put ,'cannot open ' :nam,a ,skip;
     104          call ltlfin(1,0);
     105          end if;
     106      end subr;
       1 .=member p8020l
       2 /*   p8020l - process 80/20l format records
       3          for transmitting mixed case text in upper case.
       4
       5      the 80/20l format permits the distribution of mixed case
       6      text using only upper case characters.  a line of 80
       7      characters is followed by a line with a shift string of
       8      20 hexadecimal digits which associate a 'shift' bit with
       9      each text character.  the shift bit is one to indicate
      10      a character should (if possible) be translated to corresponding
      11      lower case character by the receiver.  each original
      12      line is thus transmitted as two lines.
      13
      14      each hexadecimal digit in the shift string gives the shift bits
      15      for four text characters.  the most significant bit in the
      16      digit gives the shift bit for the leftmost character.
      17      the shift string is in the same order as the text string:
      18      column 1 contains the shift bits for columns 1-4,
      19      column 20 contains the shift bits fol columns 77-80.
      20
      21      this program writes and reads records in 80/20l format.
      22      desired direction is given by program parameter
      23          m = 0/1   0 to read 80/20l, 1 to write 80/20l
      24
      25      the program reads from unit 3 and writes to unit 4.
      26
      27      author:  david shields  (cims)   01 feb 78
      28      revise  9-feb-81 to place shift string on separate line
      29 */
      30
      31      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      32
      33      +*  filenamelen = 20 **  $ length of file name
      34 .+s32  +* filenamelen = 64 **
utsb   2 .+s47  +* filenamelen = 64 **
      35
      36
      37      +*  ss_ucltr =  8 **  $ string set for upper case letters
      38      +*  ss_lcltr = 16 **  $ string set for lower case letters
      39
      40      prog p8020l;  $ translate lines in 80/20l format.
      41      size  i(ps);            $ loop index
      42      size  c(cs);            $ character temporary.
      43      size  chi(cs), clo(cs);        $ character temporarires.
      44      size  anyc(ws); $ check for character in string set.
      45      size  ctlc(cs), ctuc(cs);  $ case conversion functions
      46      size  hextab(cs);       $ binary to hex translation table.
      47      dims  hextab(16);
      48      data  hextab = 1r0,1r1,1r2,1r3,1r4,1r5,1r6,1r7,
      49                     1r8,1r9,1ra,1rb,1rc,1rd,1re,1rf;
      50      size  inline(.sds. 80); $ input line.
      51      size  cstr(.sds. 20);    $ character shift string.
      52      data  cstr = '' .pad. 20;
      53      size  bstr(80);   $ shift string as bitstring.
      54      size  pfilename(.sds. filenamelen); $ input file
      55      size  nfilename(.sds. filenamelen); $ output file.
      56
      57      size  writing(1);        $ on to write, off to read.
      58
      59      call getipp(writing,'m=0/1');  $ get mode (1 to write)
      60      call getspp(pfilename, 'p=/p');
      61      call getspp(nfilename, 'n=/n');
      62
      63      file  3 access = get, linesize = 80, title = pfilename;
      64      file  4 access = put, linesize = 80, title = nfilename;
      65
      66
      67
      68      if  writing  then
      69      while 1;  $ loop to process file.
      70          get 3 ,skip :inline,a(80);
      71          if  (filestat(3,end))  quit while;
      72          bstr = 0;
      73          do  i = 1 to 80;  $ translate, compute shift bits.
      74              c = .ch. i, inline;
      75              if  anyc(c, ss_lcltr)  then $ if lower case
      76                  .ch. i, inline = ctuc(c); $ convert to upper
      77                  .f. 81-i, 1, bstr = 1; $ flag as lower.
      78                  end if;
      79              end do;
      80          do i = 1 to 20;  $ express shift string in hex.
      81              .ch. i, cstr = hextab(1+.f.81-i*4,4,bstr);
      82              end do;
      83              put 4  :inline,a(80) ,skip :cstr,a(20) ,skip;
      84          end while;
      85      else  $ if reading.
      86      while 1;
      87          get 3 ,skip :inline,a(80) ,skip :bstr,b(20,4);
      88          if  (filestat(3,end)) quit while;
      89          do  i = 1 to 80;
      90              c = .ch. i, inline;
      91              if  .f. 81-i, 1, bstr  then $ if lower
      92                  .ch. i, inline = ctlc(c);
      93                  end if;
      94              end do;
      95              put 4 :inline,a(80) ,skip;
      96          end while;
      97          end if;
      98      end prog;
       1 .=member shrink
       2      prog shrink;
       3 $    shrink - program to shrink text
       4 $    this program shrinks text in several ways, selected according
       5 $    to program option:
       6 $
       7 $    a   align at left by replacing n>2 initial blanks by
       8 $        two initial blanks.
       9 $    b   discard blank lines
      10 $    c   discard comments (lines with dollar sign as first
      11 $        non-blank character)
      12 $    p  p=/p  input file name (use unit 3 if not specified)
      13 $    n  n=/n  output file name (use unit 3 if not specified)
      14 $
      15 $    input linesize of 72 is assumed.
      16 $    program parameter 'opt=bc/abc' selects options.
      17 $
      18 $    author: d. shields  (nyu-cims)  11-dec-79
      19
      20      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      21      +*  ifile = 3 **  +* ofile = 4 **  $ unit numbers.
      22
      23      +*  filenamelen = 20 ** $ length of filename
      24 .+s32  +* filenamelen = 64 **
utsb   3 .+s47  +* filenamelen = 64 **
      25
      26
      27      size  iline(.sds. 72);  $ input line
      28      size  oline(.sds. 72);  $ output line
      29      size  nlb(ws);          $ number of leading blanks.
      30      size  spnc(ws);         $ character span function
      31      size  opt_str(.sds. 20);$ option string
      32      size  opt_a(1);         $ a option
      33      size  opt_b(1);         $ b option
      34      size  opt_c(1);         $ c option
      35      size  ifilename(.sds. filenamelen); $ ifile name
      36      size  ofilename(.sds. filenamelen); $ ofile name
      37
      38      call getspp(opt_str,'opt=bc/abc');
      39      call getspp(ifilename, 'p=/p');
      40      call getspp(ofilename, 'n=/n');
      41      opt_a = ('a'.in.opt_str) > 0;
      42      opt_b = ('b'.in.opt_str) > 0;
      43      opt_c = ('c'.in.opt_str) > 0;
      44
      45
      46      file ifile access=get, title=ifilename, linesize=72;
      47      file ofile access=put, title=ofilename, linesize=72;
      48
      49 .+s66  rewind ifile; rewind ofile;
      50
      51      while  1;
      52          get ifile  ,skip :iline,a(72);
      53          if  (filestat(ifile,end))  quit while;
      54          nlb = spnc(iline, 1, 1r );  $ count initial blanks.
      55          $   process all blank lines.
      56          if  (nlb=72 & opt_b)  cont while;
      57          if  nlb<72  then  $ process possible comment.
      58              if  (.ch. nlb+1,iline = 1r$ & opt_c)  cont while;
      59              if  (nlb=-1 & .ch.1,iline=1r$ & opt_c)  cont while;
      60              if  nlb>2 & opt_a  then $ if initial blanks
      61                  iline = .s. nlb-1,(72-(nlb-2)), iline;
      62                  end if;
      63              end if;
      64          put ofile :iline,a ,skip;
      65          end while;
      66      end prog;
       1 .=member ulst
       2      $   ulst for new library.
       3 $ very preliminary version of ulst adapted from update updlst
       4 $ requires that input be output of upd run with ns=l,im
       5 $ program identifies procedueres, producing directory.
       6 $ by david shields  (nyu-cims)  25 jan 79.
       7      +* ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
       8      +*  spplen = 20 **
       9 .+s32 +*  spplen = 64 **
utsb   4 .+s47 +*  spplen = 64 **
      10      +*  procmax = 400  **  $ maximum number of procedures.
      11      +*  yes = 1 **  +*  no = 0 **
      12      +*  infile = 1 **  $ standard input file.
      13      +*  scfile = 3 **  $ scratch file.
      14
      15 $    set mc if lower-case characters available.
      16 $    if mixed-case available, default primary case is upper.
      17 $    obtain lower primary case by defining mcl.
      18
      19 .+set  mc  $ mc set by default
      20
      21 .+s66.
      22 .-set  mc  $ s66 is upper-case only.
      23 ..s66
      24
ulsa   1 .+s32.
ulsa   2 .+set s32v  $ assume vms.
ulsa   3 ..s32
ulsa   4
ulsa   5 .+s32u.
ulsa   6 .+s32.
ulsa   7 .-set s32v  $ do not want vms.
ulsa   8 .+set s32u  $ want unix os.
ulsa   9 ..s32
ulsa  10 .+set mcl   $ want primary case to be lower.
ulsa  11 ..s32u
ulsa  12 .+s47.
      26 $    configure for unix, set primary case lower.
      27 .+set mcl
ulsa  13 ..s47
      29
      30 .+mc.
      31 .+mcl.   $ if mixed-case to be lower
      32      +*  ctpc(x) = ctlc(x) **  $ primary case is lower.
      33      +*  stpc(x) = stlc(x) **  $ primary case is lower.
      34 .-mcl.
      35      +*  ctpc(x) = ctuc(x) **  $ primary case is upper.
      36      +*  stpc(x) = stuc(x) **  $ primary case is upper.
      37 ..mcl
      38 ..mc
      39
      40
      41      prog updlst;
      42
      43 /*
      44      updlst lists an update compile file by placing sequence informati
      45      file.  updlst places sequence information on the left and finds
      46      procedures.
      47
      48      program parameters are as follows:
      49
      50          code      default   meaning
      51          p         1/0       process procedures, giving list of header
      52          s         0/1       process setl procedures, giving list
      53          c         1/0       list comments
      54          t         1/0       list text
      55          h         '/'       header string used as page title.
      56          b         1/0       list lines with blanks in cols 1-72.
      57
      58      updlst reads the standard input file and writes to the standard
      59      output file.
      60
      61          some duplicate instances of an ident name are eliminated, but
      62          the name will appear at least every 10 lines.
      63          pages are numbered, and include time and date of program run.
      64
      65          lines which are probably the last of a procedure are followed
      66          followed by blank line and line of asterisks.
      67          the listing concludes with a list of each line which is the
      68          header of a procedure, followed by a sorted list of
      69          procedure names and paged numbers.
      70
      71          the procedure processing requires that the keywords -subr-,
      72          -fnct-, and -func- begin in column 7.  the -end- statement
      73          must also begin in column 7, and must include -subr- or -fnct-
      74          for little-written procedures.
      75
      76          the 's' option allows procedures to begin with the keyword
      77          'module', 'define', 'definef', and 'macro'. these keywords
      78          must begin in column 7.
      79
      80      author:  david shields  (cims)  05 febuary 77.
      81 */
      82
      83      size  bpos(ps);
      84      size  c(cs);            $ character termporary.
      85      size  c1(cs);           $ first character in line.
      86      size  dupcount(ps);     $ number of consecutive duplicate ids.
      87      size  endtype(ps);      $ type of end seen in file.
      88      size  header(.sds. spplen);  $ page header.
      89      size  i(ps);
      90      size  l(ps);            $ minimal name length.
      91      size  idprnt(.sds. 10); $ name, sequence fields to list.
      92      size  idseq(.sds. 10);  $ name, sequence fields as listed.
      93      size  ifblank(ps);      $ on to list blank lines.
      94      size  ifcomm(ps);       $ on to list comments.
      95      size  ifproc(ps);       $ on to list subroutines.
      96      size  ifsetl(ps);    $ on to list setl procedures.
      97      size  iorc(ps);         $ io return code.
      98      size  iftext(ps);       $ on to list non comment text.
      99      size  blknt(ps); data blknt = 0;  $ count of all blank lines.
     100      size  inknt(ps); data inknt = 0;  $ number of lines read.
     101      size  inline(.sds. 100);  $ input line.
     102      size  ioknt(ps); data ioknt = 0;  $ number of lines written.
     103      size  istext(1);        $ on if line not a comment.
     104      size  kntcomm(ps);  data kntcomm=0;  $ number of comments.
     105      size  knteor(ps);  data knteor=0;  $ number of eor's seen.
     106      size  knttext(ps);  data knttext=0;  $ number of text lines.
     107      size  nuid(.sds. 8);    $ ident name field of new line.
     108      size  inseq(.sds.8);
     109      size  lines(ps);
     110      size  name(.sds. 10);
     111      size  npages(ps);
     112      size  nuseq(.sds. 5);   $ sequence field of new line.
     113      size  lastid(.sds. 8);  $ name field to list.
     114      size  pagenow(ps);      $ current page number.
     115      $   procnames is list of procedure names, procpages is list
     116      $   of page numbers of first line of procedure text.
     117      size  procnames(.sds. 10);  dims  procnames(procmax);
     118      size  procpages(ps);        dims  procpages(procmax);
     119      size  procptr(ps);      $  number of procedures seen.
     120      data  procptr = 0;
     121      size  s10(.sds. 10);    $ first ten characters in line (proc check
     122      size  s14(.sds. 14);    $ first fourteen chars (end check)
     123      size  s4(.sds. 4);      $ first four chars (end check)
     124      size  s5(.sds. 5);      $ first five chars
     125
     126
     127      file scfile access=put,title='updscr',linesize=100;
     128      call dropsio(scfile, iorc);  $ release at end.
     129      rewind scfile;
     130
     131 $        -p- option for listing -subr- -func- -fnct- cards, default on
     132      call getipp(ifproc, 'p=1/0');
     133
     134 $        -ifcomm- not-zero if want to list comments
     135
     136      call getipp(ifcomm,'c=1/0');
     137
     138 $        -iftext- non-zero when text to be listed, default is 1
     139
     140      call getipp(iftext,'t=1/0');
     141
     142 $ -ifsetl- non-zero if listing setl procs and macros
     143
     144      call getipp(ifsetl, 's=0/1');
     145
     146 $ -ifblank- nonzero to list lines which are all blank.
     147
     148      call getipp(ifblank, 'b=1/0');
     149
     150      lastid = ''.pad.8;
     151      call getspp(header, 'h=/');
     152
     153      $   set up page header (modelled on ltitlr in library).
     154      call contlpr(6, 1);     $ enable paging.
     155      call contlpr(7, 1);     $ enable titling.
     156      call contlpr(8, 72);    $ enter page field.
     157      call contlpr(9, 37);    $ enter date field.
     158      call etitlr(0, 'page', 67, 0);
     159      if  (.len. header > 19) .len. header = 19;
     160      call etitlr(0, header, 18, 0);  $ enter user title.
     161      call contlpr(13, 0);    $ set page number.
     162      call contlpr(2, 2);     $ set line position.
     163      call contlpr(10, i);  $ get lines per page.
     164      call contlpr(15, i);  $ set line so next line starts page.
     165
     166      inknt = 0;  ioknt = 0;
     167
     168      while infile;
     169          get infile, skip :inseq,a(8) :inline,a(72);
     170          if  filestat(infile,end)  then
     171 .+s66.
     172              call endqsio(infile, endtype);  $ get end type.
     173              if  endtype = 1  then  $ if eor.
     174                  knteor = knteor + 1;
     175                  put ,skip,'eor seen after line' :inknt,i(6)
     176                      ,', continuing.',skip;
     177                  cont while;
     178              else  $ if eof or eoi do terminal processing.
     179 ..s66
     180                  put ,skip ,'end of input after line'
     181                      :inknt,i(7) ,'.' ,skip;
     182                  if  ifblank=0 & blknt>0  then  $ if not listing blank
     183                      put ,skip ,'text contains ' :blknt,i
     184                          ,' blank lines that were not listed.' ,skip;
     185                      end if;
     186                  quit while infile;
     187 .+s66            end if;
     188          end if;
     189
     190      inknt = inknt + 1;
     191
     192      if  ifblank = no  then  $ if do not want blank lines listed.
     193          if  (.s. 1, 72, inline) .seq. (''.pad.72)  then  $ if blank.
     194              blknt = blknt + 1;
     195              cont while infile;
     196              end if;
     197          end if;
     198
     199      nuid = inseq;  $ find length of identifier name.
     200      l = 0;
     201      do  i = 1 to 8;
     202          if  .ch. i, inseq = 1r  then  $ if blank found.
     203              l = i-1;  quit do;
     204              end if;
     205          end do;
     206      .len. nuid = l;
     207      if  (l)  .s. 1, l, nuid = .s. 1, l, inseq;
     208      c1 = .ch. 1, inline;
     209      istext = yes;
     210      if  c1 ^=  1r  then  $ look for comment.
     211          if  ((c1=1r$) ! (c1=1rc))  istext = no;
     212          end if;
     213      knttext = knttext + istext;
     214      kntcomm = kntcomm + (1-istext);
     215      if  istext  then
     216          if  (iftext=no)  cont while infile;
     217      elseif  ifcomm=no  then cont while infile;
     218          end if;
     219
     220      $   form ident name and sequence field to list.
     221      idprnt = inseq;
     222      ioknt = ioknt + 1;
     223      if  nuid .sne. lastid  then
     224          lastid = nuid;
     225          idprnt = inseq;
     226          call etitlr(0, nuid, 0, 10);  $ enter new id in title.
     227          dupcount = 0;
     228      else  dupcount = dupcount + 1;
     229          .s. 1, (.len. lastid), idprnt = '';
     230          end if;
     231      if  dupcount >= 10  then  $ if run of id, list it.
     232          dupcount = 0;
     233          idprnt = inseq;
     234          end if;
     235
     236
     237 $    if -p- option on, will save card if columns 7-10 contain
     238      $   a procedure header.
     239
     240      if  ifproc   then
     241          call updproc(name); $ see if procedure header.
     242          if  .len. name > 0  then
     243              call contlpr(5, 10);  $ new page if less than 10 lines.
     244              call contlpr(12, pagenow);  $ get current page number.
     245              if  procptr < procmax  then  $ save name if can.
     246                  procptr = procptr + 1;
     247                  procnames(procptr) = name;
     248                  procpages(procptr) = pagenow;
     249                  end if;
     250              put scfile :pagenow,i(4),x(1) :inseq,a(8),x(1)
     251                :inline,a(72),skip;
     252              end if;
     253          end if;
     254
     255      put :idprnt,a(8) ,x  :inline,a(72) ,skip;
     256
     257 $        look for end of routine or ident
     258 $        mark with ****** in listng
     259
     260     if ifsetl then  $ find 'end' followed by routine name
     261          s4 = .s. 7, 4, inline;
     262 .+mc     call stpc(s4);  $ convert to primary case.
     263          if s4 .seq. 'end ' then
     264              do i = procptr to 1 by -1;
     265                  name = procnames(i);
     266                  if .s. 11, .len. name, inline .seq. name then
     267                      put, '*********', skip(2);
     268                      quit;
     269                      end if;
     270                  end do;
     271              end if;
     272      else      $ find 'end prog', etc.
     273          s10 = .s. 1, 10, inline;
     274 .+mc     call stpc(s10);  $ convert to primary case.
     275          if  s10 .seq. '      end '  then
     276          s14 = .s. 1, 14, inline;
     277 .+mc     call stpc(s14);  $ convert to primary case.
     278          if  s14.seq.'      end subr'  !  s14.seq. '      end fnct' !
     279           s14.seq.'      end prog'  !  s14.seq. '      end     '  then
     280              put ,'*********' ,skip(2);
     281              end if;
     282          end if;
     283          end if;
     284      end while infile;
     285
     286 $        write out saved cards if -x- option on
     287
     288      if  (procptr=0 ! ifproc=0)  go to endofproclist;
     289
     290          put ,page,'lines with subr, fnct or func in cc 7-10',skip;
     291          put ,skip ,'page    ident' ,skip(2);
     292
     293 $        write record and file mark on scratch file; rewind for read
     294
     295          file  scfile  access=get;
     296          while  1;
     297              get scfile ,skip :inline,a(80);
     298              if  filestat(scfile,end) quit while;
     299              put :inline,a(80) ,skip(2);
     300              end while;
     301
     302 $        if any routines found, output sorted list
     303
     304          put ,page,'sorted list of procedure names and pages:',skip(2);
     305
     306 $        sort, using -shell- sort
     307 $        (code taken from kernighan and plaugher, 'programming style'
     308 $        ,page 109.)
     309
     310      size  igap(ps);         $ gap width.
     311      size  iex(ps), imax(ps);  $ indexes.
     312      size  iplusg(ps);       $ index.
     313      size  s1(.sds. 10), s2(.sds. 10);  $ copies of names.
     314      size  ii(ps);           $ index for name comparison.
     315      size  c2(cs);           $ character from second name.
     316      size  itrout(.sds. 10);  $ for name exchange.
     317      size  itpage(ps);       $ for page number exchange.
     318      size  bigger(1);    $ on if first symbol lexically bigger.
     319
     320
     321      igap = procptr;
     322
     323      while  igap>1;
     324      igap = igap/2;
     325      imax = procptr-igap;
     326      until  iex = 0;
     327          iex = 0;
     328      do  i = 1 to imax;
     329          iplusg = i+igap;
     330          s1 = procnames(i);  s2 = procnames(iplusg);
     331          l = .len. s1;
     332          if  (l> .len. s2)  l = .len. s2;
     333          if  (l=0)  cont do i;
     334          bigger = no;
     335          do  ii = 1 to l;
     336              c1 = .ch. ii, s1;  c2 = .ch. ii, s2;
     337              if  c1 ^= c2  then
     338                  bigger = (c1 > c2);
     339                  quit do;
     340                  end if;
     341              end do;
     342          if  bigger  then  $ if bigger, swap.
     343              itrout = procnames(i);
     344              procnames(i) = procnames(iplusg);
     345              procnames(iplusg) = itrout;
     346              itpage = procpages(i);
     347              procpages(i) = procpages(iplusg);
     348              procpages(iplusg) = itpage;
     349              iex = iex+1;
     350              end if;
     351          end do i;
     352
     353          end until;
     354          end while;
     355      lines = (procptr+3) / 4;
     356      do l = 1 to lines;
     357          i = l;
     358          while  i <= procptr;
     359              put :procpages(i),i(4) ,x(2) :procnames(i),a(10);
     360              i = i + lines;
     361              end while;
     362          put ,skip(2);
     363          end do;
     364      put ,skip;
     365 /endofproclist/
     366
     367      end prog updlst;
     368      subr updproc(name);     $ get procedure name.
     369      size  name(.sds. 10);   $ procedure name.
     370      size s7(.sds. 7);       $ characters 7-13 of input line
     371      size  s10(.sds. 10);    $ first ten chars of line.
     372      size  sname(.sds. 20);
     373      size  isaproc(1);       $ on if procedure header line.
     374      size  bpos(ps);         $ index of blank.
     375      size  l(ps);            $ length of name.
     376      size  i(ps);            $ loop index.
     377      size  tpos(ps);         $ terminator position.
     378      size  terminator(.sds.1);  dims terminator(3);
     379      data terminator = ' ', ';', '(';
     380
     381      size  str(.sds. 20);    $
     382      .len. name = 0;
     383
     384      if ifsetl then  $ look for setl keywords
     385          s7 = .s. 7, 7, inline;
     386 .+mc     call stpc(s7);  $ convert to primary case.
     387          isaproc = (s7 .seq. 'definef') ! (s7 .seq. 'define ') !
     388                    (s7 .seq. 'module ');
     389          s5 = .s. 1, 5, s7;
     390 .+mc     call stpc(s5);  $ convert to primary case for search.
     391          isaproc = isaproc ! (s5 .seq. 'macro');
     392      else  $ look for little keywords
     393          s10 = .s. 1, 10, inline;
     394 .+mc     call stpc(s10);  $ convert to primary case for search.
     395          isaproc = (s10.seq.'      fnct') ! (s10.seq.'      func')
     396              ! (s10.seq.'      prog') ! (s10.seq.'      subr');
     397          end if;
     398      if  (isaproc=0)  return;
     399      str = .s. 7, 20, inline;
     400      bpos = ' ' .in. str;
     401      if  (bpos=0 ! bpos=20)  return;
     402      sname = .s. bpos+1, 20-bpos, str;
     403      l = 0;
     404      $   leftmost terminator ends name.
     405      do  i = 1 to 3;         $ search for terminator.
     406          tpos = terminator(i) .in. sname;
     407          if  tpos  then      $ if terminator seen.
     408              tpos = tpos-1;
     409              if  (l=0)  l=tpos;  $ if first terminator.
     410              if  (tpos10)  l = 10; $ truncate long name.
     414          if (l=0)  return;
     415      if  .ch. 1, sname = 1r  then  $ if need to eliminate leading blank
     416          do  i = 2 to l;
     417              if  .ch. i, sname ^= 1r  then
     418                  name = .s. i, l + 1 - i, sname;
     419                  quit do;
     420                  end if;
     421              end do;
     422      else
     423          name = .s. 1, l, sname;
     424          end if;
     425      end subr;
       1 .=member updfnd
       2 $  updfnd - program to extract specified lines from upd opl
       3 $
       4 $  updfnd reads a upd opl file and extracts all lines containing
       5 $  an instance of a specified string.  the output file is in the
       6 $  form of a upd correction set.
       7 $  the program reads a match string from the standard input file.
       8 $  this string is delimited to permit precise specifications
       9 $  of blanks in the match string; for example
      10 $  /  little  /
      11 $  indicates instance of "little" with two blanks before and after.
      12 $
      13 $  parameters:
      14 $      com     1/0     nonzero to skip $ comments
      15 $      exact   0/1     nonzero to require exact match in case
      16 $                      zero to ignore upper-lower casing.
      17 $      mod     mod/    mod name
      18 $      n       n/      output file name
      19 $      p       p/      input file name
      20 $
      21 $  author:  d. shields  (nyu-cims)  21-sep-79
      22
      23 +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs.**
      24    +*  ifile = 3 **  +*  ofile = 4 **
      25    +*  filenamelen = 20 **
      26 .+s32  +*  filenamelen = 64 **
utsb   5 .+s47  +*  filenamelen = 64 **
      27    +*  linlen = 133 ** $ maximum line length.
      28    prog start;
      29    size  comments(ws);  data comments=0;  $ comments (ignored).
      30    size  com_opt(ps);          $ find in comment ($) lines
      31    size  exact_opt(ps);                $ case option
      32    size  found(ws); data found = 0;  $ lines with pattern.
      33    size  ifilename(.sds. filenamelen), ofilename(.sds. filenamelen);
      34    size  iseq(.sds. 8), itxt(.sds. (linlen-8));
      35    size  itxtlen(ps);  $ actual txt length.
      36    size  lines(ws);  data  lines = 0;  $ lines read.
      37    size  members(ws);  data members=0; $ member count.
      38    size  membername(.sds. 20); $ member name
utsc   1      size  memberuc(.sds. 10); $ ' .=member ' in upper-case.
      39    size  modname(.sds. 20);    $ upd mod name
      40    size  need_edit(ps);      $ on when need -edit line.
      41    size  pat(.sds. 80), patstr(.sds. 80);
      42    size  rc(ws);       $ return code.
      43
      44    call fndini;  $ initialize
      45    while 1;  $ main loop;
      46        get ifile ,skip :iseq,a(8) :itxt,a(itxtlen);
      47        if (filestat(ifile,end)) quit while;
      48        lines = lines + 1;
      49        call chkcom(rc);  $ process comments.
      50        if  (rc)  cont while;  $ if want to skip comment.
      51        call seekml(rc);        $ seek member lines
      52        if (rc)  cont while;
      53        call seekpa;            $ seek pattern.
      54        end while;
      55    if  found  then $ if any lines matched.
      56        put ,'match in ' :found,i ,' of ' :lines,i ,' lines.'
      57            ,skip ,x :members,i ,' members, '
      58            ,x :comments,i ,' comments skipped.' ,skip;
      59        put ofile ,'-end' ,skip;
      60    else  $ if no matches, clear out output file.
      61        put ,'no lines matched.' ,skip;
      62        file ofile access=release;
      63        file ofile access=put, title=ofilename,linesize=80;
      64        put ofile ,'-note no instances of ' :pat,a
      65            ,skip ,'-note in file ':ifilename,a ,skip;
      66        end if;
      67    end prog;
      68    subr fndini;
      69 $  initialize
      70    size  brkc(ws);             $ string search function.
      71    size  del(cs);  $ delimiter
      72    size  patstr(.sds. 80);
      73    size  patlen(ws);           $ length of pattern.
      74    call fltini;  $ initialize filter files.
      75    call getipp(com_opt, 'com=0/1'); $ ignore comments option
      76    call getipp(exact_opt, 'exact=1/0');  $ case option
      77    call getspp(modname,'mod=mod/');  $ get mod name
      78 $  read pattern specification from std input
      79    get  :patstr,a(80);
      80    patlen = 0;
      81    if  .len. patstr > 2 then
      82        del = .ch. 1, patstr;
      83        patlen = brkc(patstr, 2, del);
      84        end if;
      85    if  patlen<=0  then
      86        put ,'error - null or illformed match string.' ,skip;
      87        call ltlfin(1,0);
      88        end if;
      89    pat = .s. 2, patlen, patstr;
      90    put ofile ,'-note extract ' :(.s.1,patlen+2, patstr),a ,skip
      91        ,'-note from file ' :ifilename,a ,' to '
      92        :ofilename,a ,skip;
      93    put ofile ,'-mod ':modname,a ,skip;
utsc   2      memberuc = ' .=member ';  call stuc(memberuc); $ for search
      94    if (exact_opt)  call stuc(pat);  $ if ignoring cases
      95    end subr fndini;
      96    subr chkcom(rc);  $ seek initial comments
      97    size  rc(ws);       $ return code (set if comment found)
      98    size  spnc(ws),brkc(ws);  $ string search functions.
      99    size  nb(ws);        $ number of initial blanks
     100    size  cp(ws);        $ comment position.
     101
     102    rc = 0;  $ assume no skip
     103    if  (com_opt = 1)  return;  $ if searching comments
     104 $  here to see if comment, and set rc if comment.
     105    cp = brkc(itxt, 1, 1r$);  $ see if comment present.
     106    if  (cp<0)  return;
     107    nb = spnc(itxt, 1, 1r );  $ count initial blanks
     108    if  nb=cp ! (cp=0 & nb=-1)  then  $ if initial comment
     109        rc = 1;
     110        comments = comments + 1;
     111        end if;
     112    end subr;
     113    subr  seekml(rc);  $ seek member line.
     114    size  rc(ws);       $ return code (set if member line)
     115    size  s10(.sds. 10);  $ string for search.
     116
     117    rc = 0;  $ assume not member line.
     118    s10 = .s. 1, 10, itxt;  $ get initial part
     119    call stuc(s10);  $ convert to upper case.
utsc   3    if  (s10 .sne. memberuc)  return;
     121 $  here if member found, set need_edit flag and save name.
     122    membername = .s. 11, 20, itxt;
     123    need_edit = 1;
     124    rc = 1;
     125    end subr;
     126    subr seekpa;  $ seek pattern line.
     127    size  pos(ps);  $ position of pattern
     128    size  ptxt(.sds. 125);
     129    if  exact_opt  then  $ if case significant
     130        ptxt = itxt;  call stuc(ptxt);  $ convert to upper.
     131        pos = pat .in. ptxt;
     132    else  $ if case not significant.
     133        pos = pat .in. itxt;
     134        end if;
     135    if  (pos=0)  return;
     136    if  need_edit  then  $ if first line in this member.
     137        need_edit = 0;
     138        put ofile ,'-edit ' :membername,a ,skip;
     139        members = members + 1;
     140        end if;
     141    put ofile ,'-del ':iseq,a(8) ,skip
     142        :itxt,a(itxtlen) ,skip;
     143    found = found + 1;
     144    end subr;
     145 $ fltini - initialize filter
     146    subr fltini;
     147    call getspp(ifilename,'p=p/');
     148    call getspp(ofilename,'n=n/');
     149    file ifile access=get,title=ifilename,linesize=80;
     150 .+s66  rewind ifile;
     151    itxtlen = 80 - 8;
     152    file ofile access=put, title=ofilename,linesize=80;
     153
     154    end subr fltini;
       1 .=member bldltl
       2      +* ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
       3      $   isoctdig determines is character is octal digit.
       4      +*  isoctdig(k) = (k>=1r0 & k<=1r7) **
       5      +*  spplen = 20 **      $ length of string parameter.
       6      +*  digofchar(c) = (c-1r0) **  $ character to digit.
       7      +*  maxlen = 500 **     $ buffer length.
       8      +*  ioid(i) = ioidara(i) **  $ convert internal numbers to sio .
       9      +*  inp(i,f) =  $ read i-th word from file f buffer.
      10          inpara((f-1)*maxlen+i) **
      11      +*  namesmax = 300 **
      12      +*  abort(msg) =  $ abnormal termination with message msg.
      13          call remarkl(msg);  $ display message.
      14          call ltlfin(1,0); **  $ terminate abnormally.
      15
      16      +*  dispos(f) =  $ dispose of file f.
      17          size  zzza(ps);     $ io return code.
      18          call rewisio(ioid(f), zzza);
      19          call clossio(ioid(f), zzza);
      20          **
      21      $   io access codes.
      22
      23      +*  access_read = 4 **
      24      +*  access_write = 6 **
      25      prog bldltl;
      26
      27$     bldltl prepares loader input and allows selective substitution of
      28$     routines in the compiler.
      29$     bldltl is needed for the following reasons -
      30$     1.  the compiler runs as an in three passes. these passes ar
      31$         expressed as overlays.  since the implementation of overlays
      32$         is necessarily system-dependent, the language does not allow
      33$         for expression of this function, and so bldltl is used to comb
      34$         the lgo files by compiling each phase with the compiler into a
      35$         format acceptable to the loader.
      36$     2.  the standard cdc lgo-edit routines (copyl in scope 3.2,
      37$         libedit in kronos) do not work on overlays. bldltl
      38$         allows for convenient, selective replacement of routines
      39$         so that a new compiler can be tested without recompiling the
      40$         entire compiler.
      41
      42$     bldltl works as follows -
      43$     1.  the overlay scaffolding is expressed in binary form
      44$         on the -root- file.  this file is obtained by compiling deck
      45$     -ltlovl- on the library oldpl.
      46$     2.  each phase runs as a separate overlay.  a mod file, in
      47$         lgo format, may be supplied; if present, this file is copied
      48$         into the start of the appropriate phase.  then the main
      49$         binary for the phase is copied out, completing the definition
      50$         of the phase.
      51 $    author:  david shields  (cims)  26 january 77.
      52
      53 $    program parameters are as follows:
      54
      55$     n  new  -  file on which output written
      56$     r  ltlroot - file containing binary overlay scaffolding
      57$     s  ltllex - file containing scanner
      58$     sm sm     - file with mods for scanner
      59$     g  ltlgen - file with gen routines
      60$     gm gm     - file with mods for gen
      61$     a  ltlasm - file with asm routines
      62$     am am     - file with asm mods
      63
      64$     file names may be changed by substituting new name after code, e.g
      65$         bldltl. (s=mylex,g=newgen,a=oldasm)
      66
      67$     the default case is to construct compiler from standard files, wit
      68$     no corrections, i.e.,
      69$         bldltl.
      70$     is equivalent to
      71$         bldltl. (s=ltllex,g=ltlgen,a=ltlasm,n=new)
      72
      73
      74
      75      size  endlev(ws);  dims endlev(3);  $ end type of file.
      76      size  ioidara(ps);  dims ioidara(3); data ioidara = 5,3,4;
      77      size  iorc(ps);         $ io return code.
      78      size  inpara(ws);  dims inpara(maxlen*2);
      79      size  levp(ws), levs(ws);  $ primary, secondary overlay numbers.
      80      size  lnsret(ps);
      81      size  ltlasm(.sds. spplen);
      82      size  ltlgen(.sds. spplen);
      83      size  ltllex(.sds. spplen);
      84      size  ltlnew(.sds. spplen);
      85      size  ltlroot(.sds. spplen);
      86      size  modasm(.sds. spplen);
      87      size  modgen(.sds. spplen);
      88      size  modlex(.sds. spplen);
      89      size  nwords(ws);  dims nwords(3);
      90      size  names(ws);  dims names(namesmax);
      91      size  namesptr(ps);     $ top of names array.
      92
      93      nwords(1) = 0;  nwords(2) = 0;
      94      endlev(1) = 0;  endlev(2) = 0;
      95      namesptr = 0;
      96
      97
      98      call getspp(ltlroot, 'r=ltlroot/');
      99      call getspp(ltlnew, 'n=new/');
     100      call getspp(ltllex, 's=ltllex/');
     101      call getspp(ltlgen, 'g=ltlgen/');
     102      call getspp(ltlasm, 'a=ltlasm/');
     103      call getspp(modlex, 'sm=0/sm');
     104      call getspp(modgen, 'gm=0/gm');
     105      call getspp(modasm, 'am=0/am');
     106
     107      call opensio(ioid(1), iorc, access_read, ltlroot, 0,lnsret,0,0);
     108      call rewisio(ioid(1), iorc);
     109      call opensio(ioid(3), iorc, access_write, ltlnew, 0, lnsret,0,0);
     110      call rewisio(ioid(3), iorc);
     111
     112      call step (2,0,ltllex,modlex);
     113      call step (3,0,ltlgen,modgen);
     114      call step (4,0,ltlasm,modasm);
     115      dispos(1);  dispos(3);
     116
     117      end prog bldltl;
     118      subr step(lep, les, mainfile, modfile);
     119
     120      $   position root at (lep,les) overlay, then copy any procedures
     121      $   in modfile, then copy procedures in mainfil which are not in
     122      $   modfile.
     123
     124      size  c(cs);
     125      size  i(ps);            $ loop index.
     126      size  iorc(ps);         $ io return code.
     127      size  j(ps);            $ loop index;
     128      size  lep(ps);          $ desired primary level.
     129      size  les(ps);          $ desired secondary level.
     130      size  lnsret(ps);       $ returned line size.
     131      size  mainfile(.sds. spplen);
     132      size  modfile(.sds. spplen);
     133      size  modname(ws);      $ name of routine to modify.
     134      size  mainnam(ws);      $ name of current routine on main file.
     135      size  msg(.sds. 30);    $ string to display updated message.
     136
     137$         read mod file up to overlay(lep,les) record, copying
     138$         contents to output file (3)
     139      size  isovl(1);
     140
     141      while 1;
     142      call bldwtr(1);
     143      if  (endlev(1)>1)  quit while;
     144      call bldrdr(1);
     145      if  (endlev(1)>1)  quit while;
     146      if  (nwords(1) > 8) cont while;
     147      call ifovl(isovl);
     148      if  (isovl & (lep=levp) & (les=levs)) quit while;
     149      end while;
     150
     151      namesptr = 0;
     152      if  (modfile .seq. '')  go to nomodfile;
     153      call opensio(ioid(2), iorc, access_read,  modfile, 0, lnsret,0,0);
     154      call rewisio(ioid(2), iorc);  $ rewind.
     155      endlev(2) = 0;  nwords(2) = 0;
     156
     157
     158      while 1;
     159      if  (endlev(2)>1)  quit while;
     160      call bldrdr(2);
     161      if  (endlev(2)>1)  quit while;
     162      modname = inp(2,2);  .f. 1, 18, modname = 0;
     163      namesptr = namesptr + 1;
     164      if  namesptr > namesmax  then
     165          abort(' too many procedures in mod files.');
     166          end if;
     167      names(namesptr) = modname;
     168      call bldwtr(2);
     169      end while;
     170
     171      dispos(2);
     172
     173 /nomodfile/
     174$         now copy out routines from main, which are not already present
     175      call opensio(ioid(2), iorc, access_read, mainfile, 0, lnsret,0,0);
     176      call rewisio(ioid(2), iorc);  $ rewind.
     177      endlev(2) = 0;  nwords(2) = 0;
     178
     179      while 1;
     180      call bldrdr(2);
     181      if  (endlev(2)>1)  quit while;
     182      if  namesptr = 0  then  $ if no mod, copy to output.
     183          call bldwtr(2);  cont while;
     184          end if;
     185      mainnam = inp(2,2);  .f. 1, 18, mainnam = 0;
     186      $   do not copy if proc of same name in mod file.
     187      do  j = 1 to namesptr;
     188      if  (mainnam^=names(j))  cont do;
     189      msg = ' updated - ' .pad. 30;
     190      do  i = 1 to 7;
     191          c = .f. ws+1-i*cs, cs, mainnam;
     192          if  (c=0)  quit do;
     193          .ch. 11+i, msg = c;
     194          .len. msg = 12+i;
     195          end do;
     196      call remarkl(msg);
     197          while endlev(2) = 0;  $ skip records.
     198              call bldrdr(2);  end while;
     199              nwords(2) = 0;
     200          cont while;
     201      end do;
     202      call bldwtr(2);
     203      end while;
     204
     205      dispos(2);
     206      end;
     207      subr bldrdr (ifile);    $ read from file ifile.
     208
     209      $   read from file ifile.  set endlev and nwords to reflect end
     210      $   type and number of words read, respectively.
     211
     212      size  ifile(ps);        $ file number.
     213      size  iorc(ps);         $ io return code.
     214      size  n(ps);            $ counter.
     215
     216      call rdrwsio(ioid(ifile), iorc, inpara, (ifile-1)*maxlen+1,
     217          maxlen);
     218      if  iorc  then          $ if end seen.
     219          call endqsio(ioid(ifile), n);
     220          endlev(ifile) = n;
     221          call reclsio(ioid(ifile), n);
     222          nwords(ifile) = n;
     223      else
     224          endlev(ifile) = 0;
     225          nwords(ifile) = maxlen;
     226          end if;
     227      end subr bldrdr;
     228      subr bldwtr(ifile);     $ copy record from ifile to file 3.
     229
     230      $   copy to end of record from file ifile to file 3.
     231
     232      size  ifile(ps);        $ file number.
     233      size  iorc(ps);         $ io return code.
     234      size  n(ps);            $ transmission count.
     235      if  (nwords(ifile) = 0)  return;
     236      while  1;
     237          if  nwords(ifile)  then  $ if data, copy it out.
     238              call wtrwsio(ioid(3), iorc, inpara,
     239                  (ifile-1)*maxlen + 1,  nwords(ifile));
     240              end if;
     241          if  (endlev(ifile))  quit while;
     242          call bldrdr(ifile); $ if end not yet seen.
     243          end while;
     244      call weorsio(ioid(3), iorc); $ write end-of-record.
     245      nwords(ifile) = 0;
     246      end subr bldwtr;
     247      subr  ifovl(isovl);     $ look for overlay card.
     248
     249      $   examine first few words in record from file 1 to see if
     250      $   overlay directive.  if not, set isovl to zero and return.
     251      $   otherwise set isovl to one, then set levp and levs to the
     252      $   primary and secondary overlay levels.
     253
     254      size  ca(cs);  dims ca(80);  $ unpacked card array.
     255      size  cap(ps);          $ current character position.
     256      size  c(cs);            $ current character.
     257      size  i(ps);            $ loop index.
     258      size  isovl(ps);        $ set on if overlay card.
     259
     260      levs = 0;  levp = 0;
     261      isovl = (.f. 19, 42, inp(1,1    ) = 7roverlay);
     262      if  (isovl=0) return;
     263      call 7nunpk$li(ca, 1, inpara, 1, 80);
     264      do  cap = 1 to 80;
     265              if  (ca(cap) = 1r,)  go to found;
     266          end do;
     267      cap = 1;                $ no comma, position so will get error.
     268 /found/
     269      c = ca(cap);
     270      +*  getlev(v) =  $ get overlay level and store in v.
     271          if  c ^= 1r,  then
     272          put  :c,rl :cap,il :ca,r ,skip;
     273          abort(' illformed overlay card.');
     274          end if;
     275          v = 0;
     276          do  i = 1 to 2;
     277              cap = cap + 1;  c = ca(cap);  $ get next character.
     278              if  isoctdig(c)  then  $ if octal, convert to value.
     279                  v = v*8 + digofchar(c);
     280              else  quit do;  end if;
     281              end do;
     282          **
     283      getlev(levp)  $ get primary level.
     284      getlev(levs)  $ get secondary level.
     285      end;
       1 .=member makupl
       2 /*
       3      this program converts a cdc update new sequential format oldpl
       4      program oldpl to upd library format.  the oldpl format is assumed
       5      to be as described in the cdc update reference manual, cdc
       6      publication 60342500, revision g (12-75), chapter 3.
       7
       8      the program processes update directives  *call, *comdeck,
       9      *cweor, *deck and *weor in the same way as upd when running with
      10      u66 option enabled.
      11
      12      the program converts any instance of character codes 3b'63' or
      13      3b'00' to 3b'00', thus permitting use of percent or colon to
      14      represent the colon in a 64 set environment.
      15
      16      update identifiers not in upd form (up to four alphabetic
      17      characters) are mapped into upd form, and a list of any names
      18      changed is given.
      19
      20      makupl rewinds old and new file at start of execution and at
      21      end of execution.
      22
      23      makupl assumes old file in correct form and reports errors by
      24      use of little -asserts-, as it is not meaningful to attempt
      25      any error correction.
      26
      27      program parameters
      28
      29            p  oldpl/old    old update oldpl file
      30            n  upl/new      new upd library file
      31            ns l/r          new file sequencing option.
      32
      33      author - david shields  (cims)  25-jan-79
      34
      35
      36
      37 */
      38      $   program to convert cdc update oldpl to upd library
      39      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      40      +*  yes = 1 **  +* no = 0 **
      41      +*  oldfile = 3 **  $ old file
      42      +*  newfile = 4 **  $ new file
      43      +*  iamax = 400 **  $ length of identifier list.
      44      +*  namax = 400 **  $ length of generated identifier list.
      45      +*  charofdig(d) = (d+1r0) **
      46      +*  filenamlen = 20 **
      47
      48      prog makupl;
      49      size  oldfilename(.sds. filenamlen);
      50      size  newfilename(.sds. filenamlen);
      51      size  nseq(ps);              $ new sequence option
      52      size  nseqopt(.sds. filenamlen);              $ new sequence optio
      53      size  fw(ws);                $ first word of card image
      54      size  w(ws);                 $ word temporary
      55      size  wc(ws);                $ number of word in card text
      56      size  cc(ws);  dims cc(20);  $ array with compressed image
      57      size  ccw(ws);
      58      size  cci(ps),ccn(ps),ccp(ps);  $ temporaries for unpacking
      59      size  i(ps);        $ loop index.
      60      size  ia(ws);  dims ia(iamax); $ identifier array
      61 $    size  da(ws);  dims da(damax); $ deck array
      62      size  iaptr(ps);             $ number of identifiers
      63      data  iaptr = 0;
      64      size  daptr(ps);             $ number of names in deck list
      65      data  daptr = 0;
      66      size  isdeck(1);             $ on if line if update *deck
      67      size  listlev(ps);      $ listing level, nonzero for detail.
      68      data  listlev = 0;
      69      size  na(.sds.4); dims na(namax);  $ identifier names array
      70      size  naptr(ps);  data  naptr=0;
      71      size  ndecks(ps);             $ number of decks seen
      72      data  ndecks = 0;
      73      size  iorc(ws);              $ io return code.
      74      size  seqnum(ps);            $ sequence number.
      75      size  seqid(.sds.4);         $ identifier
      76      size  sold(.sds.9);          $ old identifier
      77      size  snew(.sds.8);          $ new identifier
      78      size  idmem(ps);         $ ia index of current member.
      79      size  idnow(ps);         $ ia index of current line.
      80      size  cueors(ps);        $ number of *weor or *cweor lines.
      81      size  oldlines(ws);      $ number of lines in old file.
      82      data  oldlines = 1;
      83      size  newlines(ws);      $ number of lines in new file.
      84      data  newlines = 0;
      85      size  idnam(.sds.4);     $ identifier name to list.
      86      size  t(.sds.80);        $ text line.
      87      size  tp(ps);            $ length of text line during unpacking.
      88      size  nl(ps);            $ length of new name.
      89      size  haveid(iamax);     $ flags generated names.
      90      data  haveid = 0;
      91
      92      +*  getw(w) =  $ read word from pl
      93          call rdrwsio(oldfile, iorc, w, 1, 1);
      94          if  (iorc)  go to oldend;
      95          **
      96      +*  geta(a,lo,hi) = $ read array slice from oldpl
      97          call rdrwsio(oldfile, iorc, a, lo, hi);
      98          if  (iorc)  go to oldend;
      99          **
     100
     101      $   get program parameters.
     102      $   parameters
     103      $      p    oldpl/old    input file with update oldpl
     104      $      n    upl/new      output file with upd library
     105      $      ns   l/r          sequence option for new file.
     106
     107      call getipp(listlev, 'lo=0/1');  $ listing level.
     108
     109      call getspp(oldfilename, 'p=oldpl/old');
     110      call getspp(newfilename, 'n=upl/new');
     111
     112      call getspp(nseqopt, 'ns=l/r');
     113      nseq = 2;  $ assume new sequence on right.
     114      nseq = nseqopt .in. 'nlr';
     115      if  (nseq)  nseq = nseq-1;  if (nseq=0)  nseq = 2;
     116
     117      put ,'convert update oldpl to upd pl',skip;
     118      put ,'old file: p = ' :oldfilename,a
     119          ,', new file: n = ' :newfilename,a
     120          ,', new sequence: ns = ' :nseqopt,a ,skip(2);
     121
     122      call opensio(oldfile, iorc, 4, oldfilename, 0, 0, 0, 0);
     123      file newfile access=put, title = newfilename, linesize=80;
     124
     125      call rewisio(oldfile, iorc);
     126      rewind newfile;
     127
     128      getw(w);  $ read and check header word
     129      assert (.f. 31,30,w) = 5rcheck;
     130      assert (.f.1,6,w) = 1r*;  $ require master character of *
     131
     132      $   read word with directory, decklist lengths
     133      getw(w);
     134      iaptr = .f. 19, 17, w;  $ length of identifier list
     135      daptr = .f. 1,  17, w;  $ length of deck list.
     136      assert (iaptr>0) & (iaptr<=iamax);
     137      assert (daptr>0);
     138
     139      $   read identifier list.
     140      geta(ia, 1, iaptr);
     141      $   read and skip deck list.
     142      do  i = 1 to daptr;
     143          getw(w);
     144          end do;
     145
     146      naptr = 0;
     147        idnow = 0;
     148
     149      $   loop to read lines in file.
     150
     151      idmem = 0;
     152      while 1;
     153          getw(fw);  $ get first word
     154          wc = .f. 37, 15, fw;
     155          if  (wc=0)  quit while;  $ end if checksum word
     156          $   skip correction history.
     157          w = fw;
     158          while (.f. 60, 1, w) = 0;
     159              getw(w);
     160              end while;
     161      $   read compressed card image
     162          assert wc<=20;
     163          geta(cc, 1, wc);
     164          if  (.f. 59, 1, fw  = 0)  cont while;  $ skip inactive line.
     165          call exptxt;  $ expand compressed text.
     166          isdeck = no;  $ assume not *deck or *comdeck
     167          if  (.ch.1,t = 1r*)  call cdcupd;
     168          if  (ndecks=0)  cont while;  $ continue if in yank$$$
     169          oldlines = oldlines + 1;
     170          seqnum = .f. 19, 17, fw;  $ get sequence number.
     171          idnow = .f. 01, 15, fw;  $ identifier of this line.
     172          if  isdeck  then  $ if *deck line
     173              idmem = idnow;
     174              end if;
     175
     176          idnam = '    ';
     177          if  (idnow^=idmem)  call gennam(idnow);  $ if need name.
     178
     179          $   here to write line.
     180          if  nseq=1  then  $ if left sequencing.
     181              put newfile :idnam,a(4) :seqnum,i(4) :t,a(72) ,skip;
     182          else  $ if right sequencing
     183              put newfile :t,a(72) :idnam,a(4) :seqnum,i(4) ,skip;
     184              end if;
     185          newlines = newlines + 1;
     186          end while;
     187
     188 /oldend/  $ here at end of old file.
     189      oldlines = oldlines - 1;
     190      call rewisio(oldfile, iorc);  $ rewind old file.
     191      rewind newfile;
     192      put ,skip ,'copied ' :oldlines,i ,' lines in '
     193          :ndecks,i ,' decks.' ,skip;
     194      if  naptr  then  $ if modnames present.
     195          put ,'new library contains ' :naptr,i ,' modnames.' ,skip;
     196          do  i = 1 to naptr by 10;
     197              nl = i+9; if (nl>naptr) nl = naptr;
     198              put ,column(7) :na(i) to na(nl),a(6) ,skip;
     199              end do;
     200          end if;
     201      $   issue warning if encountered *cweor or *weor directives.
     202      if  cueors  then  $ if need warning
     203          put ,'warning, encountered ' :cueors,i ,' *cwoer or *weor '
     204              ,' directives.' ,skip;
     205          end if;
     206      put ,'end of run.',skip;
     207      end prog makupl;
     208      subr exptxt;  $ expand compressed image.
     209      size  b(6);
     210      t = ''.pad. 80;  tp = 0;  $ initialize as blank line.
     211      ccp = ws+1;  ccw = cc(1);  cci = 1;  ccn = wc;
     212
     213      while 1;
     214          if  ccp=1  then  $ if need new word
     215              ccp = ws+1;  cci = cci + 1;  ccw = cc(cci);
     216              if  (cci>ccn)  quit while;
     217              end if;
     218              ccp = ccp - 6;
     219          b = .f. ccp, 6, ccw;  $ get current character.
     220          if  b>0  then  $ if character.
     221              tp = tp + 1;
     222              if  (b=3b'63')  b = 0;  $ convert percent to colon.
     223              if  (b^=1r )  .ch. tp, t = b;  $ enter non-blank.
     224          else  $ if special byte.
     225              if  ccp=1  then  $ if need new word
     226                  ccp = ws+1;  cci = cci+1;  ccw = cc(cci);
     227                  if  (cci>ccn)  quit while;
     228                  end if;
     229              ccp = ccp - 6;
     230              b = .f. ccp, 6, ccw;
     231              if  b=0  then  tp=72;  $ 0000 ends line.
     232              elseif  b=1  then  $ if colon.
     233                  tp = tp + 1;  .ch. tp, t = 0;
     234              else  $ (b+1) blanks.
     235                  tp = tp + (b+1);
     236                  end if;
     237              end if;
     238          if  (tp>=72)  quit while;
     239          end while;
     240      .len. t =  72;
     241      end subr exptxt;
     242      subr gennam(idn);  $ generate identifier for identifier number idn
     243      size  idn(ps);
     244      size  w(ws);         $ word temporary.
     245      size  i(ps);         $ loop index.
     246      size  c(cs);         $ character temporary.
     247
     248      if  .f. idn, 1, haveid  then  $ if have name
     249          idnam = na(ia(idn));
     250          return;
     251          end if;
     252      .f. idn, 1, haveid = 1;
     253
     254      $  here if need to generate name.
     255      w = ia(idn);  $ get current word with right adjusted name
     256      assert (.f.1,6,w) ^= 3b'20';  $ error if purged ident
     257      nl = 0;  sold = ''.pad. 9;  $ determine identifier
     258      do  i = 1 to 9;
     259          c = .f. (ws+1)-i*cs, cs, w;  $ get character.
     260          if  (c=0)  quit do;  $ zero byte ends name
     261          nl = nl+1;
     262          .ch. nl, sold = c;
     263          end do;
     264      .len. sold = nl;
     265      assert nl>0;  $ cannot have null name.
     266      if  (nl>4) nl=4;  $ truncate long name.
     267      snew = ''.pad. 4;
     268      .len. snew = nl;
     269      .s. 1, nl, snew = .s. 1, nl, sold;
     270$     eliminate non alphabetics from snew.
     271
     272      do  i = 1 to nl;
     273          c = .ch. i, snew;
     274          if  c>=1ra & c<=1rz  then  cont do;
     275          elseif  c>=1r0 & c <=1r9  then  $ number to letter
     276              .ch. i, snew = .ch. 1+(c-1r0), 'jabcdefghi';
     277          else  .ch. i, snew = 1ra; $ else make into letter a.
     278              end if;
     279          end do;
     280
     281      $  now make snew unique.
     282      $   code to generate identifier name
     283      while 1;
     284          do  i = 1 to naptr;
     285              if  na(i).seq.snew  then  $ if duplicate
     286                  call gennew;  $ generate new name.
     287                  cont while;
     288                  end if;
     289              end do;
     290          quit while;
     291          end while;
     292
     293      naptr = naptr + 1;  assert naptr<=namax;
     294      na(naptr) = snew;
     295      if  sold.sne.snew  then  $ if changed name.
     296          put ,'change ' :sold,a ,' to ' :snew,a ,skip;
     297          end if;
     298      ia(idn) = naptr;
     299      idnam = na(naptr);
     300      end subr gennam;
     301
     302      subr gennew;
     303      $   perform lexicographic addition of letter to name.
     304      size  carry(1);    $ on if carry into position
     305      size  i(ps);      $ loop index.
     306      size  c(ps);      $ character.
     307
     308      carry = 1;
     309      do  i = nl to 1 by -1;
     310          if  (carry=0)  quit do;
     311          c = .ch. i, snew + 1;  $ get next character.
     312          if  c<=1rz  then  carry = 0;
     313          else  c = 1ra;  carry = 1; end if;
     314          .ch. i, snew = c;
     315          end do;
     316      if  (carry)  then  $ if need to extend name.
     317          if  nl<4  then  $ make name longer.
     318              nl = nl+1;  .len. snew = nl;
     319              end if;
     320          .s. 1, nl, snew = 'aaaa';
     321          end if;
     322      end subr gennew;
     323      subr cdcupd;  $ check for cdc update directive.
     324 $ this is copied from cdcupd in upd program.
     325      $   check for cdc update directive in string t.  if is *deck, then
     326      $   set isdeck and change t to little member definition.
     327      $   if other command, issue warning and proceed as follows:
     328      $   *weor     generate member eorn; e.g., eor1, eor2.
     329      $   *cweor    similar to eor.
     330      $   *comdeck  same as *deck
     331      $   *call     generate little include.
     332      $
     333      $   the *comdeck is used to define section of code that is later
     334      $   copied out by *call.  *cweor and *weor are used to denote
     335      $   record positions in text and generally indicate point at
     336      $   which file should be broken into separate files.
     337
     338      size  n(ws);            $ count.
     339      size  cui(ps);          $ command index.
     340      size  i(ps);            $ loop index.
     341      size  l(ps);            $ string length.
     342      size  us(.sds. 8);      $ name of update directive.
     343      size  listit(ps);       $ on to list old and new lines.
     344      size  oldt(.sds. 80);   $ old line if need listing.
     345      $   codes for cdc update directives.
     346      +*  cu_call = 1  **  $ *call
     347      +*  cu_comd = 2  **  $ *comdeck
     348      +*  cu_cweo = 3  **  $ *cweor
     349      +*  cu_deck = 4  **  $ *deck
     350      +*  cu_weor = 5  **  $ *weor
     351      +*  n_cu    = 5  **  $ number of cdc update directives.
     352
     353      size  cunam(.sds.8); dims cunam(n_cu);  $ update names.
     354      data  cunam(cu_call) = 'call':
     355            cunam(cu_comd) = 'comdeck':
     356            cunam(cu_cweo) = 'cweor':
     357            cunam(cu_deck) = 'deck':
     358            cunam(cu_weor) = 'weor';
     359      size  cucod(ps);  dims  cucod(n_cu);  $ action codes.
     360      data  cucod(cu_call) = 3:
     361            cucod(cu_comd) = 1:
     362            cucod(cu_cweo) = 2:
     363            cucod(cu_deck) = 1:
     364            cucod(cu_weor) = 2;
     365
     366      isdeck = no;  $ assume not update directive.
     367      if  (.ch. 1, t ^= 1r*)  return;  $ if cannot be command.
     368      if  (.ch. 2, t = 1r )  return;  $ if cannot be command.
     369      $ break to blank.
     370      l = 0;
     371      do  i = 1 to 10;
     372          if  .ch. i, t = 1r  then  $ if blank
     373              l = i-1;  quit do;
     374          end if;
     375          end do;
     376      if (l<4)  return;  $ if cannot be command.
     377      if (l>8)  return;  $ if cannot be command.
     378      us = .s. 2, 8, t;
     379      .len. us = l-1;
     380      cui = 0;  $ assume not command.
     381      do  i = 1 to n_cu;  $ search command list.
     382          if  (cunam(i).sne.us)  cont do;  $ if no match
     383          cui = i;  quit do;  $ if match.
     384          end do;
     385      if  (cui=0)  return;  $ if not command.
     386      listit = listlev;  $ see if want listing of changed lines.
     387      oldt = t;  $ save old text if may list.
     388
     389      go to l(cucod(cui)) in 1 to 3;
     390
     391 /l(1)/  $ turn *comdeck or *deck into .=member
     392 $ translate semicolons to blanks (due to extra semicolons in
     393 $ some setl files.
     394      i = ';' .in. t;
     395      if (i)  .ch. i, t = 1r ;
     396      if  (cui=cu_comd)  listit = yes;  $ always list comdecks.
     397      if  (cui=cu_deck)  listit = listlev;
     398      isdeck = yes;  $  flag as changed deck line.
     399      ndecks = ndecks + 1;
     400      l = .len. cunam(cui) + 3;  $ length initial part.
     401      t = ' .=member ' .cc. .s. l, 40, t;
     402      go to ret;
     403
     404 /l(2)/  $ change *cweor or *cweor to member.
     405      listit = yes;
     406      cueors = cueors + 1;
     407      isdeck = yes;
     408      ndecks = ndecks + 1;
     409      .s. 1, 15, t = ' .=member eor    ';
     410      n = cueors;
     411      i = 14+(n>9)+(n>99);
     412      until n=0;
     413          .ch. i, t = charofdig(mod(n,10));
     414          n = n / 10;  i = i - 1;
     415          end until;
     416     go to ret;
     417
     418 /l(3)/  $ change *call  to  .=include.
     419      listit = yes;
     420      t = ' .=include ' .cc. .s. 7, 61, t;
     421      go to ret;
     422 /ret/
     423      if  listit  then  $ if want listing.
     424          put ,'process cdc update directive ''' :cunam(cui),a
     425          ,''' at line ' :oldlines,i ,'.' ,skip;
     426          put ,' old line' ,column(17) :oldt,a(72) ,skip;
     427
     428          put ,' new line' ,column(17) :t,a(72) ,skip;
     429          end if;
     430      end subr cdcupd;
       1 .=member p8020c
       2      prog p8020c;  $ translate lines in 80/20l format.
       3
       4 /*   p8020c - process 80/20l format records
       5          and convert to cdc 6/12 bit code.
       6
       7      (this program only for s66, the cdc 6000 series implementation.)
       8
       9      this program is a variant of p8020l (deck p8020l on utilpl)
      10      which reads a 80/20l format file and writes cdc 6/12 bit
      11      codes.  lower case letters are represented by writing the
      12      escape character 3b'76' before the upper case code.  the
      13      6/12 character set is not well defined, as the table given
      14      in cdc publication 60435400 (revision e), nos version 1
      15      reference manual, volume 1, pages 1-a-1 through 1-a-3, contains
      16      multiple entries for ascii characters circumflex, at sign,
      17      colon and apostrophe (shields wrote to cdc about this on
      18      20 jun 78).
      19
      20      this version supports only conversion from 80/20l format
      21      to cdc 6/12.  the characters circumflex, at sign and colon
      22      are translated to 12 bit codes; apostrophe is translated to
      23      a 6 bit code (these are conventions used at cims).
      24
      25      the program only reads 80/20l format, but the skeleton needed
      26      to extend to support reading cdc 6/12 and writing 80/20l has
      27      been left in for possible use by zealous reader.
      28
      29      desired direction is given by program parameter
      30          m = 0/1   0 to read 80/20l, 1 to write 80/20l
      31
      32      the program reads from unit 3 and writes to unit 4.
      33
      34      author:  david shields  (cims)   20 jun 78
      35      revise  9-feb-81 for format with shift string on separate line
      36 */
      37
      38      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      39
      40      +*  filenamelen = 20 **  $ length of file name
      41 .+s32  +* filenamelen = 64 **
utsb   6 .+s47  +* filenamelen = 64 **
      42
      43
      44      +*  ss_ucltr =  8 **  $ string set for upper case letters
      45      +*  ss_lcltr = 16 **  $ string set for lower case letters
      46
      47      size  i(ps);            $ loop index
      48      size  c(cs);            $ character temporary.
      49      size  chi(cs), clo(cs);        $ character temporarires.
      50      size  anyc(ws); $ check for character in string set.
      51      size  ctlc(cs), ctuc(cs);  $ case conversion functions
      52      size  hextab(cs);       $ binary to hex translation table.
      53      dims  hextab(16);
      54      data  hextab = 1r0,1r1,1r2,1r3,1r4,1r5,1r6,1r7,
      55                     1r8,1r9,1ra,1rb,1rc,1rd,1re,1rf;
      56      size  inline(.sds. 80); $ input line.
      57      size  cstr(.sds. 20);    $ character shift string.
      58      data  cstr = '' .pad. 20;
      59      size  bstr(80);   $ shift string as bitstring.
      60      size  pfilename(.sds. filenamelen); $ input file
      61      size  nfilename(.sds. filenamelen); $ output file.
      62      size  nout(ps);
      63      size  outline(.sds. 160);
      64
      65      size  writing(1);        $ on to write, off to read.
      66
      67      +*  outc(c) =  $ put character to output line.
      68          nout = nout+1;  .ch. nout, outline = c;
      69          **
      70      call getipp(writing,'m=0/1');  $ get mode (1 to write)
      71      call getspp(pfilename, 'p=/p');
      72      call getspp(nfilename, 'n=/n');
      73
      74      if  writing  then  $ writing not supported yet.
      75          put ,'writing mode not supported.' ,skip;
      76          call ltlfin(1, 1);
      77          end if;
      78
      79      file  3 access = get, linesize = 80, title = pfilename;
      80      file  4 access = put, linesize = 160, title = nfilename;
      81
      82      .len. outline = 160;  $ initialize outline.
      83      .f. 1+.sl., .so., outline = .sds. 160 + 1;
      84
      85
      86      if  writing  then
      87      while 1;  $ loop to process file.
      88          get 3 ,skip :inline,a(80);
      89          if  (filestat(3,end))  quit while;
      90          bstr = 0;
      91          do  i = 1 to 80;  $ translate, compute shift bits.
      92              c = .ch. i, inline;
      93              if  anyc(c, ss_lcltr)  then $ if lower case
      94                  .ch. i, inline = ctuc(c); $ convert to upper
      95                  .f. 81-i, 1, bstr = 1; $ flag as lower.
      96                  end if;
      97              end do;
      98          do i = 1 to 20;  $ express shift string in hex.
      99              .ch. i, cstr = hextab(1+.f.81-i*4,4,bstr);
     100              end do;
     101              put 4  :inline,a(80) ,skip :cstr,a(20) ,skip;
     102          end while;
     103      else  $ if reading.
     104      while 1;
     105          get 3 ,skip :inline,a(80) ,skip :bstr,b(20,4);
     106          if  (filestat(3,end)) quit while;
     107          nout = 0;  $ initialize output line.
     108          do i = 1 to 80;
     109              c = .ch. i, inline;
     110              if  .f. 81-i, 1, bstr  then $ if lower.
     111                  outc(3b'76');  outc(c);
     112              elseif  c = 1r@  then  $ if at sign.
     113                  outc(3b'74');  outc(3b'01');
     114              elseif  c = 1r^  then  $ if circumflex.
     115                  outc(3b'74');  outc(3b'02');
     116              elseif  c = 1r:  then  $ if colon.
     117                  outc(3b'74');  outc(3b'04');
     118              else  outc(c);  $ otherwise, just copy character.
     119                  end if;
     120              end do;
     121              .len.  outline = nout;
     122              put 4 :outline,a(nout) ,skip;
     123          end while;
     124          end if;
     125      end prog;
       1 .=member rflovl
       2 /*
       3      rflovl - reduce field length of absolute overlay (s66 only).
       4
       5      rflovl overcomes a minor problem in the cdc absolute overlay
       6      loader for kronos 2.1 and nos 1.2.  the overlay table (5400)
       7      contains a high-high field length which is the maximum of the
       8      field lengths of the various overlay phases.  the system sets
       9      the field length to this value before starting execution.
      10      however, the little compiler does its own field length management,
      11      and the result is an initial rfl up to high-high value, followed
      12      immediately by rfl to length of first phase.
      13
      14      rflovl copies an absolute overlay file and sets the high-high
      15      length to the minfl length (length of root), to avoid needless
      16      initial rfl up to high-high.
      17
      18      rflovl can also be used to convert a 5400 (eacpm) type overlay
      19      into a 5000 (ascm) overlay.  this in useful in that nos produces
      20      absolute overlays in 5400 form, while scope 3.4 and some nos/be
      21      sites can only load 5000 form overlays.  the conversion mode
      22      is selected by option 'a=1'.
      23
      24      program parameters are as follows:
      25
      26      p  old - file containg prior absolute overlay.
      27      n  new - file containing new absolute overlay.
      28      a  act - action to do, as follows
      29               0 - perform rfl high-high reduction
      30               1 - convert from 5400 form to 5000 form overlay.
      31               (any other value taken as a=0.)
      32
      33      author:  david shields  (cims)  19 may 77.
      34 */
      35      +* ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      36
      37      +*  yes = 1 **  +* no = 0 **
      38      $   isoctdig determines if character is octal digit.
      39      +*  isoctdig(k) = (k>=1r0 & k<=1r7) **
      40      +*  spplen = 20 **      $ length of string parameter.
      41      +*  digofchar(c) = (c-1r0) **  $ character to digit.
      42      +*  maxlen = 500 **     $ buffer length.
      43      +*  ioid(i) = ioidara(i) **  $ convert internal numbers to sio .
      44      +*  inp(i,f) =  $ read i-th word from file f buffer.
      45          ara((f-1)*maxlen+i) **
      46      +*  abort(msg) =  $ abnormal termination with message msg.
      47          call remarkl(msg);  $ display message.
      48          call ltlfin(1,0); **  $ terminate abnormally.
      49
      50      +*  dispos(f) =  $ dispose of file f.
      51          size  zzza(ps);     $ io return code.
      52          call rewisio(ioid(f), zzza);
      53          call clossio(ioid(f), zzza);
      54          **
      55      $   io access codes.
      56
      57      +*  access_read = 4 **
      58      +*  access_write = 6 **
      59      prog rflovl;
      60
      61
      62
      63      size  endlev(ws);  dims endlev(3);  $ end type of file.
      64      size  ioidara(ps);  dims ioidara(3); data ioidara = 3,4,5;
      65      size  iorc(ps);         $ io return code.
      66      size  ara(ws);  dims ara(maxlen);
      67      size  levp(ws), levs(ws);  $ primary, secondary overlay numbers.
      68      size  oldtitle(.sds. spplen);   $ old file title.
      69      size  newtitle(.sds. spplen);   $ new file title.
      70      size  nwords(ws);  dims nwords(3);
      71      size  c(cs);
      72      size  i(ps);            $ loop index.
      73      size  j(ps);            $ loop index;
      74      size  lep(ps);          $ desired primary level.
      75      size  les(ps);          $ desired secondary level.
      76      size  lnsret(ps);       $ returned line size.
      77      size  mainfile(.sds. spplen);
      78      size  modfile(.sds. spplen);
      79      size  modname(ws);      $ name of routine to modify.
      80      size  mainnam(ws);      $ name of current routine on main file.
      81      size  msg(.sds. 30);    $ string to display updated message.
      82
      83      nwords(1) = 0;  nwords(2) = 0;
      84      endlev(1) = 0;  endlev(2) = 0;
      85
      86
      87      call getspp(oldtitle, 'p=old/');
      88      call getspp(newtitle, 'n=new/');
      89
      90      call opensio(ioid(1), iorc, access_read, oldtitle, 0,lnsret,0,0);
      91      call rewisio(ioid(1), iorc);
      92      call opensio(ioid(2), iorc, access_write, newtitle, 0,lnsret,0,0);
      93      call rewisio(ioid(2), iorc);
      94
      95
      96      size  firstrec(1);  data firstrec=yes;
      97      size  act(ps);    $ action wanted (0=reduce hihi, 1=make 50).
      98
      99      call getipp(act,'a=0/1');
     100      if  (act>1)  act = 0;  $ force to rfl if not make 50 mode.
     101
     102      while 1;
     103          call rflrdr;
     104          if  (endlev(1)>1)  quit while;
     105          if  (act=1)  then  call rfl50;  $ if want 5000 conversion.
     106          else  $ want high-high reduction.
     107              if  firstrec  then  $ only alter first record.
     108                  firstrec = no;
     109                  call rflfix;
     110                  end if;
     111              end if;
     112          call rflwtr;
     113          end while;
     114
     115      dispos(1);  dispos(2);
     116
     117      end prog rflovl;
     118      subr rflfix;
     119      $   if first 20 words correspond to prfx (7700) and eapcm (5400)
     120      $   tables, adjust hhfl to minfl.
     121      size  minfl(ps);  $ minimum fl.
     122      size  hhafl(ps);  $ high high address.
     123      size daymsg(.sds. 38); data daymsg=''.pad.38;
     124
     125      $   verify that have 5400-type (eacpm) table.
     126      assert .f. 49, 12, ara(1) = 3b'7700';  $ require prefix table.
     127      assert .f. 49, 12, ara(16) = 3b'5400';  $ require 5400 table.
     128      minfl = .f. 01, 18, ara(17);
     129      hhafl = .f. 01, 18, ara(20);
     130      .f. 01, 18, ara(20) = minfl;
     131      file 5 access=string, title = daymsg, linesize = 38;
     132      put 5 ,' change fl from ' :hhafl,b(6,3) , ' to ' :minfl,b(6,3);
     133      call remarkl(daymsg);
     134      end subr rflfix;
     135      subr rfl50;
     136      $   if first 20 words correspond to prfx (7700) and eapcm (5400)
     137      $   tables, convert to 5000-type (ascm) overlay, for use in
     138      $   nos/be.
     139      size  minfl(ps);  $ minimum fl.
     140      size  hhafl(ps);  $ high high address.
     141      size daymsg(.sds. 38); data daymsg=''.pad.38;
     142      size  epa(ps);  $ entry point address.
     143      size  i(ps);    $ loop index.
     144      size  wcs(ps);  $ word count of cm image.
     145      size  lev(ps);    $ overlay level.
     146
     147      $   verify that have 5400-type (eacpm) table.
     148      assert .f. 49, 12, ara(1) = 3b'7700';  $ require prefix table.
     149      assert .f. 49, 12, ara(16) = 3b'5400';  $ require 5400 table.
     150      assert .f. 01,18, ara(16) = 1;  $ require one entry point.
     151      $   for (0,0) overlay, verify that fwa is 3b'100'.
     152      lev = .f. 37,12, ara(16);
     153      if  lev = 3b'0000'  then  $ if (0,0)
     154          assert .f. 19, 18, ara(16) = 3b'100';
     155          epa = .f. 01, 18, ara(24);  $ get entry point address.
     156          minfl = .f. 01, 18, ara(17);  $ get minimum fl.
     157          hhafl = .f. 01, 18, ara(20);  $ get high-high fl.
     158          file 5 access=string, title = daymsg, linesize = 38;
     159          put 5, ' convert to 5000 ovl, fl is ':hhafl,b(6,3);
     160          call remarkl(daymsg);
     161      else  $ if not (0,0).
     162          epa = .f. 01, 18, ara(20);
     163          end if;
     164      .f. 49, 12, ara(16) = 3b'5000';  $ convert to 5000 table.
     165      wcs = .f. 43, 18, ara(17);  $ get word count of cm image.
     166      assert .f. 19, 24, ara(17) = 0;  $ require no use of ecs.
     167      assert epa > 0;  $ require entry point address.
     168      .f. 01, 18, ara(16) = epa;  $ set entry point for 5000 format.
     169      end subr rfl50;
     170      subr rflrdr;    $ read from file 1.
     171
     172      $   read from file 1.  set endlev and nwords to reflect end
     173      $   type and number of words read, respectively.
     174
     175      size  iorc(ps);         $ io return code.
     176      size  n(ps);            $ counter.
     177
     178      call rdrwsio(ioid(1), iorc, ara, 1,
     179          maxlen);
     180      if  iorc  then          $ if end seen.
     181          call endqsio(ioid(1), n);
     182          endlev(1) = n;
     183          call reclsio(ioid(1), n);
     184          nwords(1) = n;
     185      else
     186          endlev(1) = 0;
     187          nwords(1) = maxlen;
     188          end if;
     189      end subr rflrdr;
     190      subr rflwtr;     $ copy record from 2 to file 3.
     191
     192      $   copy to end of record from file 2 to file 3.
     193
     194      size  iorc(ps);         $ io return code.
     195      size  n(ps);            $ transmission count.
     196      if  (nwords(1) = 0)  return;
     197      while  1;
     198          if  nwords(1)  then  $ if data, copy it out.
     199              call wtrwsio(ioid(2), iorc, ara,
     200                  1,  nwords(1));
     201              end if;
     202          if  (endlev(1))  quit while;
     203          call rflrdr; $ if end not yet seen.
     204          end while;
     205      call weorsio(ioid(2), iorc); $ write end-of-record.
     206      nwords(1) = 0;
     207      end subr rflwtr;
       1 .=member tic
       2 /*
       3      tic    t-translate i-ndividual c-haracter
       4
       5      tic filters a file by translating each instance of a selected
       6      character code.  program parameters are as follows.
       7
       8          p     'old/c'       prior (input) file.
       9          n     'new/ce'      new (output) file.
      10          m     63            mode, as follows.
      11                              m=63 (default), convert codes of 00 to 51.
      12                              m=64, convert codes of 00 to 51.
      13                              otherwise, pc and nc determine translation
      14          pc    00/51         code for prior (input) character.
      15          nc    51/00         code for new (output) code.
      16          u     0/1           on for update mode. tic blanks columns 81-
      17                              90 of each line for later use of updedt.
      18          rl    90/130        line length.
      19
      20      by default, tic translates 00 (colon) to 51 (percent).
      21      tic uses integer codes for characters to translate.
      22
      23      author -  d. shields  (cims)  04 mar 77.
      24 */
      25
      26      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
      27      +*  cpw = (ws/cs) **  $ characters per word.
      28      +*  spplen   = 20 **  $ string parameter length.
      29      prog tic;
      30      size  coldwd(ws);  $ word of old characters.
      31      size  cnewwd(ws);  $ word of new characters.
      32      size  i(ps);       $ loop index.
      33      size  pfilename(.sds. spplen);  $ prior file name.
      34      size  nfilename(.sds. spplen);  $ new file name.
      35      size  pchar(ps);  $ prior character.
      36      size  nchar(ps);  $ new character.
      37      size  chngthis(ps);  $ changes this line.
      38      size  chngtot(ps);  $ total changed characters.
      39      size  updmode(ps);  $ update mode.
      40      size  mode(ps);  $ mode of conversion.
      41      size  ara(ws);  dims ara(20);  $ line to convert.
      42      size  nlines(ps);   $ number of lines.
      43      size  iorc(ps);     $ io return code.
      44      size  reclen(ps);   $ line length.
      45      size  nw(ps);       $ words per line.
      46      size  lnsret(ps);   $ returned line size.
      47      size  chnglines(ps);      $ number of lines with changes.
      48
      49      nlines = 0;  chnglines = 0;
      50      call getspp(pfilename, 'p=old/c');
      51      call getspp(nfilename, 'n=new/ce');
      52      call getipp(mode, 'm=63/');  $ get conversion mode.
      53      if  mode = 63  then  $ if mode 63, convert 00b to 63b.
      54          pchar = 00;  nchar = 51;
      55      elseif  mode = 64  then  $ if mode 64, convert 63b to 00.
      56          pchar = 51;  nchar = 00;
      57      else  $ otherwise get prior and new chars.
      58          call getipp(pchar, 'pc=00/51');
      59          call getipp(nchar, 'nc=51/00');
      60          end if;
      61
      62      assert pchar>=0 & pchar<=63;
      63      assert nchar>=0 & nchar<=63;
      64      call getipp(updmode, 'u=0/1');
      65
      66      coldwd = 0;
      67      coldwd = 0;  cnewwd = 0;
      68      do  i = 1 to 10;  $ build words of old, new chars.
      69          .f. (i-1)*cs+1, cs, coldwd = pchar;
      70          .f. (i-1)*cs+1, cs, cnewwd = nchar;
      71          end do;
      72
      73      chngthis = 0;  chngtot = 0;  $ change this line, total count.
      74
      75      call getipp(reclen, 'rl=90/130');
      76      if  (updmode)  reclen = 90;
      77      nw = (reclen-1)/cpw + 1;  $ number of words.
      78      assert reclen>0 & reclen<=200;
      79
      80      call opensio(3, iorc, 1, pfilename, reclen, lnsret, 0, 0);
      81      call opensio(4, iorc, 3, nfilename, reclen, lnsret, 0, 0);
      82      call rewisio(3, iorc);  call rewisio(4, iorc);  $ rewind files.
      83
      84      while 1;
      85          call getwsio(3, iorc, ara, 1, reclen);
      86          if  iorc  then  $ if end seen.
      87              call endqsio(3, iorc);
      88              if  (iorc>2)  quit while;
      89              if  iorc=1
      90                  then  call weorsio(4, iorc);
      91                  else  call weofsio(4, iorc);
      92                  end if;
      93              cont while;
      94              end if;
      95      $   convert line.
      96          nlines = nlines + 1;
      97          call adjustc(chngthis, ara, 1, nw, coldwd, cnewwd);
      98      do i=1 to nw; ara(i) = ara(i); end do;
      99          chngtot = chngtot + chngthis;
     100          chnglines = chnglines + (chngthis>0);
     101          if  updmode & (chngthis>0)  then  $ if need to mark.
     102              ara(9) = 10r           ;  $ kill update sequence.
     103              end if;
     104          call putwsio(4, iorc, ara, 1, reclen);
     105          end while;
     106
     107      put ,'convert code ' :pchar,i(2), ' to code ' :nchar,i(2) ,'.'
     108          ,skip;
     109      if  chngtot  then   $ if any conversions.
     110          put ,skip ,'converted ' :chngtot,i(5) ,' characters in '
     111              :chnglines,i(5);
     112      else
     113          put ,skip ,'no conversions';
     114          end if;
     115      put ,' of ' :nlines,i(6) ,' lines.';
     116      call rewisio(3, iorc);  call rewisio(4, iorc);  $ rewind files.
     117      end prog;
     118 .=member eor1
     119          ident  adjustc
     120          xtext  ltlale
     121          ltlent tic,adjustc
     122***       adjustc - adjust characters.
     123          sb7    x1          save address to receive change count.
     124          sa1    a1+b1       load address of ara.
     125          sa2    a1+b1       load address of ndx.
     126          sa3    a2+b1       load address of nw.
     127          sa4    a3+b1       load address of coldwd.
     128          sa5    a4+b1       load address of cnewwd.
     129          sa2    x2          load value of ndx.
     130          sa3    x3          load value of nw.
     131          sa4    x4          load coldwd.
     132          sa5    x5          load cnewwd.
     133          bx0    x4          save coldwd
     134          bx7    x5          save cnewwd.
     135          sb5    x1-2        load address of ara(-1)
     136          sb5    b5+x2       load address of ara(ndx-1).
     137          sb3    x3          save nw.
     138          sb4    b1          initialize count.
     139          sb6    b0          initialize change count.
     140          sa4    =37373737373737373737b  load mask word.
     141
     142 tic1     sa5    b4+b5       load next word to convert.
     143          bx1    x5-x0       convert instances of cold to 00b.
     144*         convert nonzero chars to  40b, zero chars unchanged.
     145          bx2    x1*x4       extract right five bits of each char.
     146          ix3    x2+x4       set high order bit if any of right five non
     147          bx3    x3+x1       also set high if originally on.
     148          bx3    -x4*x3      nonzero now 40b.
     149          bx1    -x4-x3      zero now 40b, others now 00b.
     150          cx2    x1          adjust conversion count.
     151          sb6    b6+x2       ...
     152*         convert each 40b to 77b.
     153          bx2    x1          40b.
     154          lx2    -3          04b.
     155          bx2    x1+x2       44b.
     156          ax1    x2,b1       22b.
     157          bx2    x1+x2       66b.
     158          ax1    x2,b1       33b.
     159          bx1    x1+x2       77b.
     160*         now do conversion to new code.
     161          bx2    -x1*x5      extract other old characters.
     162          bx3    x1*x7       get new codes to insert.
     163          bx6    x2+x3       combine.
     164          sa6    a5          store new word.
     165          sb4    b4+b1       increment word count.
     166          le     b4,b3,tic1  if more words.
     167          sx7    b6          store change count.
     168          sa7    b7          ...
     169          eq     tic0        return.
     170          end
       1 .=member updbrk
       2      +*  inlinelen=100**
       3      +*  infile = 1 **  +* iofile = 2 **
       4      +* ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
       5      +*  yes = 1 **  +* no = 0 **
       6      +*  spplen = 20 **
       7      +*  cpw = (ws/cs) **    $ characters per word.
       8
       9      +*  append(s1, s2) =  $ append string s2 to string s1.
      10          size  zzza(ps), zzzb(ps);  $ length variables.
      11          zzza = .len. s1;
      12          zzzb = .len. s2;
      13          if  zzzb  then
      14              .len. s1 = zzza + zzzb;  $ adjust lnength.
      15              .s. zzza+1, zzzb, s1 = s2;  $ append string.
      16              end if;
      17          **
      18
      19      +*  blankword =  $  word of blanks.
      20 .+s37    4r
utsa   8 .+s47    4r
      21 .+s66    10r
      22          **
      23      +*  sorg = .f. 1+.sl., .so., **  $ origin field of char string.
      24      prog updbrk;
      25
      26 /*
      27      updbrk identifies the comments in the input file, and
      28      writes a file in which the comment text is separated and appears
      29      on the right.
      30
      31      program parameters are as follows;
      32
      33          code      default    meaning
      34          c         1/0        list comments
      35          cc        62         comment column. separated text begins her
      36          dc        1/0        process dollar style comments
      37          pl1       1/0        process pl/1 style comments / * ... * /.
      38          fc        0/1        process fortran comments
      39          f         3/         file format, as follows
      40                               1.data - text in columns 1-72
      41                               2.compile - update compile file
      42                               3.upd - output of -updlst- program
      43 */
      44
      45      size  inpl1(1);  data inpl1=0;  $ on when inside pl1 comment.
      46      size  inline(.sds. 132);  $ input line.
      47      size  ioline(.sds. 132);
      48      size  intext(.sds. 72);  $ text to search.
      49      size  iotext(.sds. 80);  $ output text.
      50      size  tmptext(.sds. 80);  $ temporary text.
      51      size  fmtname(.sds. spplen);  $ file format name.
      52      size  icknt(ps);
      53      size  kar1(cs);
      54      size  iostrorg(ps);
      55      size  komorg(ps);
      56      size  komlist(ps);
      57      size  komlong(ps);      $ length of comment text to litt.
      58      size  iostring(.sds. (132+cpw));  $ output string.
      59      size  kotext(.sds. 72);  $ comment text buffer.
      60      size  kotextl(ps);
      61      size  nbl(ps);
      62      size  trimf(ps);
      63      size  insorg(ps);       $ origin of instring.
      64      size  ifdc(ps);
      65      size  ifpl1(ps);
      66      size  iffc(ps);         $ on to list fortran comments.
      67      size  ifcc(ps);         $ on to list fortran comments.
      68      size  iofiletitle(.sds. spplen);
      69      size  infc(ps);         $ input first column.
      70      size  inlc(ps);         $ input last column.
      71      size  iofc(ps);         $ output first column.
      72      size  iolc(ps);         $ output last column.
      73      size  movelong(ps);     $ length of move.
      74      size  ipcc(ps);         $ comment text starts here.
      75      size  intextl(ps);      $ length of intext.
      76      size  iotextl(ps);      $ length of iotext.
      77      size  inll(ps);         $ length of inline.
      78      size  ioll(ps);         $ length of ioline.
      79      size  inknt(ps), ioknt(ps);  $ lines read, written.
      80      size  iofcol(ps);       $ start of comment output.
      81      size  ioecol(ps);       $ end of comment output.
      82      size  itsfmt(ps);       $ file format type.
      83      size  i(ps);            $ index.
      84 trace stores intext, kotext;
      85
      86$         process control-card parameters
      87
      88$     c   list comment text; default is on
      89
      90      call getipp(komlist, 'c=1/0');
      91
      92$         -ipcc- set to column in which comments to be output
      93      call getipp(ipcc, 'cc=52/');
      94
      95$         -dc- indicates dollar style comments are to be processed.
      96$             default is on.
      97      call getipp(ifdc, 'dc=1/0');
      98$     -pl1- indicates pl1-style comments to be processed.
      99$         default is on.
     100      call getipp(ifpl1,'pl1=1/0');
     101
     102$     -fc- indicates fortran-style comments to be processed,
     103$             fortran-style indicated by -c-, -*- in col. 1
     104
     105      call getipp(ifcc, 'fc=0/1');
     106
     107      if  iffc  then  $ if fortran on, disable $-style and pl1.
     108          ifpl1 = 0;  ifdc = 0;
     109          end if;
     110
     111$     -f- indicates file format. default is -data-
     112$         file formats and interpretation as follows
     113$ data        data in columns 1-72
     114$ compile data in columns 1-72, update sequence in 73-90
     115$         sequence info moved to columns 2-19, 20 left blank
     116$         output code started in column 21, and 20 is added to -ipcc-
     117$         thus moving comment text to right
     118$ upd     lds compile file format, file-format corresponding to
     119$         output of compile file listing program
     120$         update info in 1,12, data in 13,84
     121$         data read from 13,84, and 12 added to -ipcc-
     122
     123
     124      call getipp(itsfmt, 'f=3/1');
     125      if  itsfmt = 1  then  $ if data type format.
     126          infc = 1;  inlc = 72;  iofc = 1;  iolc = 72;
     127      elseif  itsfmt=2  then  $ if compile format.
     128          infc = 1;  inlc = 72;  iofc = 21;  iolc = 92;
     129          ipcc = ipcc+20;
     130      else  $ if format not one or two, force three.
     131          itsfmt = 3;
     132          infc = 13;  inlc = 84;  iofc = 13;  iolc = 84; ipcc = ipcc+13;
     133          end if;
     134$         determine input line length
     135
     136      intextl = inlc-infc+1;
     137      inll = intextl;
     138
     139$         determine output line length
     140
     141      ioll = iolc-iofc+1;
     142
     143      inknt = 0;
     144
     145$         -inpl1- nonzero when inside pl1 style comment
     146
     147      inpl1 = 0;
     148
     149      iotext = ''.pad.72;  kotext = '' .pad. 72;
     150
     151      while  1;
     152      get infile ,skip :inline,a(90);
     153          if  filestat(infile,end)  then
     154              call ltlfin(0,0);
     155              end if;
     156      ioline = '' .pad. 132;
     157      inknt = inknt + 1;
     158      if  itsfmt = 1  then
     159          intext = .s. 1, 72, inline;
     160      elseif  itsfmt = 2  then
     161          intext = .s. 1, 72, inline;
     162          .s. 1, 18, ioline = .s. 73, 18, inline;
     163      elseif  itsfmt = 3  then
     164          $   look for line marking end of text.
     165          if  (.s. 1, 20, inline) .seq. ' end of input after '  then
     166              ifdc = no;  iffc = no;  ifpl1 = no;
     167              put iofile ,column(0) :inline,a ,skip;
     168              itsfmt = 4;
     169              cont while;
     170              end if;
     171          kar1 = .ch. 1, inline;
     172          if  kar1 = 1r  then
     173              intext = .s. 12, 72, inline;
     174              .s. 1, 11, ioline = .s. 1, 11, inline;
     175          else
     176              put iofile ,column(0) :inline,a ,skip;
     177              cont while;
     178              end if kar1;
     179          else  $ otherwise, just copy out line.
     180              put iofile ,column(0) :inline,a ,skip;
     181              cont while;
     182          end if itsfmt;
     183      intextl = 72;
     184      .len. iotext = 0;
     185      .len. kotext = 0;
     186
     187$         first process pl1-style comments
     188
     189      if (ifpl1) call pl1spl1;
     190
     191$         if enabled, process $-style comments
     192
     193      if (ifdc) call dollspl;
     194
     195$         proces fortran-style comments, if enabled
     196
     197      if (iffc) call fortspl;
     198
     199      if  (.len. intext)  then  $ if intext remains, add to iotext.
     200          append(iotext, intext);
     201          end if;
     202      iotextl = .len. iotext;  kotextl = .len. kotext;
     203
     204$         if code text all blank, reduce lengt to one
     205
     206      iofcol = iofc;
     207      ioecol = iofc+iotextl-1;
     208      if  (iotextl=0)  ioecol = iofcol;
     209      if  iotextl  then
     210
     211$         if code text all blank reduce length to one
     212
     213      nbl = trimf(iotext,iotextl);
     214      if  nbl=0  then  iotextl = 1;  ioecol = iofc - 1;  end if;
     215      .s. iofcol, iotextl, ioline = .s. 1, iotextl, iotext;
     216      else  ioecol = iofcol;
     217      end if;
     218      if  komlist & (kotextl>0)  then
     219
     220$         here when comment text available for output
     221$         first determine column in which to start comment
     222
     223      komorg = ioecol+1;  if  (komorgkotextl) komlong=kotextl;
     230
     231$         and move in comment text
     232
     233      .s. komorg+2, komlong, ioline = kotext;
     234      end if;
     235      if (kotextl) icknt = icknt+1;
     236
     237$         update comment count.
     238
     239      put iofile ,column(0) :ioline,a ,skip;
     240      end while;
     241
     242      end prog updbrk;
     243      fnct trimf(str, strl);  $ find index of first nonblank.
     244      size  trimf(ps);       $ index of first non blank.
     245      size  str(.sds. 132);
     246      size  strl(ps);         $ length to search;
     247      size  i(ps);            $ loop index.
     248      size  pos(ps);                $ position.
     249      size  rem(ps);                $ remaining chars to check in last w
     250      size  so(ps);                 $ string origin.
     251      size  w(ws);              $ word to check.
     252      size  nw(ps);             $ number of words.
     253      trimf = 0;
     254      so = sorg str;
     255      nw = (strl + (cpw-1)) / cpw;
     256      do  i = 1 to nw;
     257          w = .f. so - i*ws, ws, str;
     258          if  (w ^= blankword)  go to found;
     259          end do;
     260      return;
     261 /found/
     262      pos = (i-1)*cpw;  $ number of initial blanks.
     263      rem = strl - pos;  $ remaining chars to check.
     264      do  i = 1 to rem;
     265          if  .f. ws+1 - i*cs, cs, w  ^= 1r  then
     266              trimf = pos + i;
     267              return;
     268              end if;
     269          end do;
     270      end fnct trimf;
     271 trace stores kotext,intext;
     272      subr dollspl;  $ process $-style comments.
     273
     274      size  kdpos(ps);
     275
     276      if  (.len.intext =0)  return;
     277      kdpos = '$ ' .in. intext;
     278      if  kdpos  then  $ if dollar comment.
     279          komlong = (.len. intext) - kdpos;  $ comment length.
     280          if  komlong > 1  then  $ if not entire line.
     281              tmptext = .s. kdpos+1, komlong, intext;
     282              append(kotext, tmptext);
     283              end if;
     284          .len. intext = kdpos - 1;  $ remaining text.
     285          end if;
     286      end subr dollspl;
     287      subr fortspl;
     288
     289      size  c(cs);            $ character.
     290$         process fortran-style comments
     291
     292      if  (.len. intext  = 0)  return;
     293      c = .ch. 1, intext;
     294      if  c = 1r* ! c=1rc  then
     295          kotext = .s. 2, 71, intext;
     296          .len. intext =  0;  $ done with intext.
     297          end if;
     298      end subr fortspl;
     299      subr pl1spl1;
     300
     301      size  kopos(ps);
     302      size  temptext(.sds. 72);   $ temporary text area.
     303      size  kcpos(ps);        $ comment position.
     304      size  trimf(ps);       $ index of next nonblank.
     305      size  locbl(ps);        $ location of nonblank.
     306      size  l(ps);        $ length during string append.
     307
     308  while  1;
     309
     310      if  inpl1  then  $ if starting inside comment.
     311          kcpos = '*/' .in. intext;
     312          if  kcpos = 0  then  $ if no closer, entire line is comment.
     313              append(kotext, intext);
     314              .len. intext = 0;
     315              inpl1 = yes;  $ now inside pl1 comment.
     316              quit while;
     317              end if;
     318          inpl1 = no;
     319          $   text after closer becomes intext.
     320          temptext = .s. 1, kcpos-1, intext;
     321          append(kotext, temptext);
     322          temptext = .s. kcpos+2, (.len. intext) - (kcpos+1), intext;
     323          .len. intext = 0;
     324          append(intext, temptext);
     325          end if;
     326
     327      $   here to look for opener starting comment.
     328      kopos = '/*' .in. intext;
     329      if  (kopos = 0)  quit while;  $ if entire line is text.
     330      kcpos = '*/' .in. intext;  $ look for closer.
     331      if  kcpos = 0  then  $ if no closer, line ends in comment.
     332          temptext = .s. kopos+2, (.len. intext) - (kopos+1), intext;
     333          append(kotext, temptext);  $ add comment text.
     334          .len. intext = kopos - 1;
     335              inpl1 = yes;  $ now inside pl1 comment.
     336          quit while;
     337          end if;
     338      $   line contains comment, move it to comment portion.
     339      temptext = .s. kopos+2, (kcpos-1) - (kopos+1), intext;  $ comment
     340      append(kotext, temptext);  append(kotext, ' ');
     341      temptext = .s. kcpos+2, (.len. intext) - (kcpos+1), intext;
     342      .len. intext = kopos - 1;
     343      append(intext, ' ');  $ so code does not run together.
     344      append(intext, temptext);  $ remaining text after closer.
     345      inpl1 = 0;
     346  end while;
     347      end subr pl1spl1;
       1 .=member updedt
       2      +*  ws = .ws. **  +* ps = .ps. **  +*  cs = .cs. **
       3      +*  yes = 1 **  +*  no = 0 **
       4      +*  stop = call ltlfin(0,0); **  $ terminate execution.
       5      +*  txtfld = .s. 01, 72, **
       6      +*  seqfld = .s. 74, 13, **
       7      +*  oldfile = 3 **
       8      +*  newfile = 4 **
       9      +*  modfile = 5 **
      10      +*  spplen = 20 **
      11
      12      +*  emit(line) =  $ emit line to correction file.
      13          put modfile :line,a(72) ,skip;
      14          **
      15      prog updedt;
      16      /*
      17      updedt compares an -update- compile file and an editted version of
      18      the file to produce an update correction set (ident) expressing
      19      the results of the edit.
      20
      21      program parameters are as follows:
      22
      23          c      'c/compile'      original compile file.
      24          ce     'ce/'            editted compile file.
      25          id     'id/'            generated correction file.
      26
      27      updedt rewinds all files before and after processing.
      28
      29      updedt assumes that editting done using reich/russell editor 'e'
      30      in 'update' mode (edit command 'upd').
      31
      32      author:  david shields  (cims)  01 february 1977.
      33
      34      credit:  david shields wrote the first version of this program
      35      and suggested addition of 'update' mode to editor.
      36      paul abrahams rewrote the program in pl/i and substantially
      37      improved the logic.  the present version is a transcription of the
      38      pl/i version into little.
      39      */
      40
      41      size  oldserial1(.sds. 13);  $  serial number.
      42      size  oldserial2(.sds. 13);  $  serial number.
      43      size  newin_text(.sds. 72);  $ text part of new card.
      44      size  newin_serial(.sds. 13);  $ serial part of new card.
      45      size  endofold(1), endofnew(1);  $ end file flags.
      46      size  insertor(1);      $ positioning procedure.
      47      size  oldfiletitle(.sds. spplen);
      48      size  newfiletitle(.sds. spplen);
      49      size  modfiletitle(.sds. spplen);
      50
      51      call getspp(oldfiletitle, 'c=c/compile');
      52      call getspp(newfiletitle, 'ce=ce/');
      53      call getspp(modfiletitle, 'id=id/');
      54
      55
      56          file oldfile access = get,
      57
      58          title = oldfiletitle,linesize=90;
      59          file newfile access = get,
      60          title = newfiletitle,linesize=90;
      61          file modfile access = put,
      62          title = modfiletitle,linesize=72;
      63
      64      rewind oldfile; rewind modfile; rewind newfile;
      65
      66      call headers; $ read and copy control cards
      67
      68      if  insertor('*before ') then  stop;  end if;
      69      call deletor; $ deletor will position us at matching cards
      70      while  1;
      71          call scanner;
      72          if  endofold then
      73              if  (endofnew=no)  endofnew = insertor('*insert ');
      74              quit while;
      75          elseif  endofnew  then  call deletend;
      76              end if;
      77               $ we get here if no eof
      78          if  insertor('*insert ') then call deletend;  end if;
      79                  $ if endfile on insert, delete rest of old cards
      80          call deletor; $ delete to get to matching card
      81          end while;
      82      end prog;
      83      subr scanner;
      84      size  buff1(.sds. 90), buff2(.sds. 90);
      85      while 1;
      86          get oldfile ,skip  :buff1,a(90);
      87          endofold = filestat(oldfile,end);
      88          if  endofold=no  then
      89              oldserial1 = oldserial2;
      90              oldserial2 = seqfld buff1;
      91              end if;
      92          get newfile ,skip  :buff2,a(90);
      93          endofnew = filestat(newfile, end);
      94          if  (endofnew)  return;
      95          if  endofold  then  quit while;
      96          elseif oldserial2 .seq. seqfld buff2 then cont while;;
      97              end if;
      98          quit while;
      99          end while;
     100           $ get here if cards differ
     101      newin_text = txtfld buff2;
     102      newin_serial = seqfld buff2;
     103      end subr scanner;
     104      fnct insertor(ctl);  $ insert current line from ce if is mod.
     105           $ insertor -nsert if current card on 'new' is a mod
     106           $ return '1'b if stop on eof
     107      size  insertor(1);      $ give one if stop at eof.
     108      size  ctl(.sds. 8);     $ control characters.
     109      size  buff(.sds. 90);   $ line.
     110      size  id(.sds. 13);     $ identifier.
     111
     112      if  .ch. 13, newin_serial^=1r  then
     113          insertor = 0;
     114          return;
     115          end if;
     116      call ident(id);
     117      emit(ctl!!id);
     118      emit(newin_text);
     119      while 1;
     120          get newfile ,skip  :buff,a(90);
     121          if  filestat(newfile,end)  then
     122              insertor = 1;  return;  end if;
     123          if .ch. 86, buff^=1r  then
     124              newin_text = txtfld buff;
     125              newin_serial = seqfld buff;
     126              insertor = 0;  return;
     127              end if;
     128          emit(buff); $ inserted card to modfile
     129          end while;
     130      end fnct insertor;
     131      subr deletor;
     132           $ deletor - delete cards from oldfile if necessary
     133      size  id1(.sds. 14);    $ start of deletion.
     134      size  buff(.sds. 90);   $ line.
     135      size  id(.sds. 13);     $ identifier.
     136
     137      if  oldserial2  .seq.  newin_serial  then return;  end if;
     138      oldserial1 = oldserial2;
     139      call ident(id1);
     140      get oldfile ,skip  :buff,a(90);
     141      if  filestat(oldfile,end)  then  endofold=1; return; end if;
     142      oldserial2 = seqfld buff;
     143      while (newin_serial.sne.oldserial2);
     144          get oldfile ,skip :buff,a(90);
     145          if  filestat(oldfile,end)  then
     146              endofold = 1;  quit while;  end if;
     147          oldserial1 = oldserial2;
     148          oldserial2 = seqfld buff;
     149          end while;
     150      call ident(id);
     151      emit('*delete '!!id1!!','!!id);
     152      end subr;
     153      subr deletend;
     154           $ deletend - delete to end of file
     155      size  id1(.sds. 14);    $ start of deletion.
     156      size  buff(.sds. 90);   $ line.
     157      size  id(.sds. 13);
     158      oldserial1 = oldserial2;
     159      call ident(id1);
     160      while  1;
     161          get oldfile ,skip  :buff,a(90);
     162          if  filestat(oldfile,end)  quit while;
     163          oldserial1 = seqfld buff;
     164          end while;
     165      call ident(id);
     166      emit('*delete '!!id1!!','!!id);
     167      stop;
     168      end subr deletend;
     169      subr headers;  $ copy out initial directives.
     170      size  buff(.sds. 90);
     171      size  c(cs);
     172
     173      get oldfile ,skip  :buff,a(90);
     174      oldserial1 = seqfld buff;
     175      oldserial2 = seqfld buff;
     176
     177      while 1;
     178          get newfile ,skip  :buff,a(90);
     179          c = .ch. 1, buff;
     180          if  (c ^= 1r*)  quit while;
     181          c = .ch. 2, buff;
     182          if  (c = 1r )  quit while;
     183          emit(buff);
     184          end while;
     185
     186      newin_text = txtfld buff;
     187      newin_serial = seqfld buff;
     188      end subr headers;
     189      subr ident(id);  $ determine identifier of oldserial1.
     190      size  id(.sds. 14);
     191      size  p1(.sds. 9), p2(.sds. 6);
     192      size  i(ps);            $ loop index for blank elimination.
     193      p1 = .s. 1, 8, oldserial1;
     194      i = 8;  while .ch. i, oldserial1 = 1r ; i = i-1; end while;
     195      .len. p1 = i;
     196      p2 = .s. 9, 5, oldserial1;
     197      i = 1;  while .ch. i,p2 = 1r ; i = i+1;  end while;
     198      p2 = .s. i, (.len. p2) - i + 1, p2;
     199      id = p1 !! '.' !! p2;
     200      end subr ident;  $ emit line to correction file.
       1 .=member updlst
       2      $   updlst for new library.
       3      +* ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
       4      +*  spplen = 20 **
       5      +*  procmax = 300  **  $ maximum number of procedures.
       6      +*  yes = 1 **  +*  no = 0 **
       7      +*  infile = 1 **  $ standard input file.
       8      +*  scfile = 3 **  $ scratch file.
       9      prog updlst;
      10
      11 /*
      12      updlst lists an update compile file by placing sequence informati
      13      file.  updlst places sequence information on the left and finds
      14      procedures.
      15
      16      program parameters are as follows:
      17
      18          code      default   meaning
      19          p         1/0       process procedures, giving list of header
      20          s         0/1       process setl procedures, giving list
      21          c         1/0       list comments
      22          t         1/0       list text
      23          h         '/'       header string used as page title.
      24          b         1/0       list lines with blanks in cols 1-72.
      25
      26      updlst reads the standard input file and writes to the standard
      27      output file.
      28
      29          some duplicate instances of an ident name are eliminated, but
      30          the name will appear at least every 10 lines.
      31          pages are numbered, and include time and date of program run.
      32
      33          lines which are probably the last of a procedure are followed
      34          followed by blank line and line of asterisks.
      35          the listing concludes with a list of each line which is the
      36          header of a procedure, followed by a sorted list of
      37          procedure names and paged numbers.
      38
      39          the procedure processing requires that the keywords -subr-,
      40          -fnct-, and -func- begin in column 7.  the -end- statement
      41          must also begin in column 7, and must include -subr- or -fnct-
      42          for little-written procedures.
      43
      44          the 's' option allows procedures to begin with the keyword
      45          'module', 'define', 'definef', and 'macro'. these keywords
      46          must begin in column 7.
      47
      48      author:  david shields  (cims)  26 january 77.
      49 */
      50
      51      size  bpos(ps);
      52      size  c(cs);            $ character termporary.
      53      size  c1(cs);           $ first character in line.
      54      size  dupcount(ps);     $ number of consecutive duplicate ids.
      55      size  endtype(ps);      $ type of end seen in file.
      56      size  header(.sds. spplen);  $ page header.
      57      size  i(ps);
      58      size  idprnt(.sds. 10); $ name, sequence fields to list.
      59      size  idseq(.sds. 10);  $ name, sequence fields as listed.
      60      size  ifblank(ps);      $ on to list blank lines.
      61      size  ifcomm(ps);       $ on to list comments.
      62      size  ifproc(ps);       $ on to list subroutines.
      63      size  ifsetl(ps);    $ on to list setl procedures.
      64      size  iorc(ps);         $ io return code.
      65      size  iftext(ps);       $ on to list non comment text.
      66      size  blknt(ps); data blknt = 0;  $ count of all blank lines.
      67      size  inknt(ps); data inknt = 0;  $ number of lines read.
      68      size  inline(.sds. 130);  $ input line.
      69      size  ioknt(ps); data ioknt = 0;  $ number of lines written.
      70      size  istext(1);        $ on if line not a comment.
      71      size  kntcomm(ps);  data kntcomm=0;  $ number of comments.
      72      size  knteor(ps);  data knteor=0;  $ number of eor's seen.
      73      size  knttext(ps);  data knttext=0;  $ number of text lines.
      74      size  nuid(.sds. 7);    $ ident name field of new line.
      75      size  lines(ps);
      76      size  name(.sds. 10);
      77      size  npages(ps);
      78      size  nuseq(.sds. 5);   $ sequence field of new line.
      79      size  listid(.sds. 7);  $ name field to list.
      80      size  pagenow(ps);      $ current page number.
      81      $   procnames is list of procedure names, procpages is list
      82      $   of page numbers of first line of procedure text.
      83      size  procnames(.sds. 10);  dims  procnames(procmax);
      84      size  procpages(ps);        dims  procpages(procmax);
      85      size  procptr(ps);      $  number of procedures seen.
      86      data  procptr = 0;
      87      size  s10(.sds. 10);    $ first ten characters in line (proc check
      88      size  s14(.sds. 14);    $ first fourteen chars (end check)
      89
      90
      91      file scfile access=put,title='updscr',linesize=130;
      92      call dropsio(scfile, iorc);  $ release at end.
      93      rewind scfile;
      94
      95 $        -p- option for listing -subr- -func- -fnct- cards, default on
      96      call getipp(ifproc, 'p=1/0');
      97
      98 $        -ifcomm- not-zero if want to list comments
      99
     100      call getipp(ifcomm,'c=1/0');
     101
     102 $        -iftext- non-zero when text to be listed, default is 1
     103
     104      call getipp(iftext,'t=1/0');
     105
     106 $ -ifsetl- non-zero if listing setl procs and macros
     107
     108      call getipp(ifsetl, 's=0/1');
     109
     110 $ -ifblank- nonzero to list lines which are all blank.
     111
     112      call getipp(ifblank, 'b=1/0');
     113
     114      listid = '...'.pad.10;
     115      call getspp(header, 'h=/');
     116
     117      $   set up page header (modelled on ltitlr in library).
     118      call contlpr(6, 1);     $ enable paging.
     119      call contlpr(7, 1);     $ enable titling.
     120      call contlpr(8, 79);    $ enter page field.
     121      call contlpr(9, 45);    $ enter date field.
     122      call etitlr(0, 'page', 75, 0);
     123      call etitlr(0, header, 18, 0);  $ enter user title.
     124      call contlpr(13, 0);    $ set page number.
     125      call contlpr(2, 2);     $ set line position.
     126      call contlpr(10, i);  $ get lines per page.
     127      call contlpr(15, i);  $ set line so next line starts page.
     128
     129      inknt = 0;  ioknt = 0;
     130
     131      while infile;
     132          get infile, skip:inline,a(90);
     133          if  filestat(infile,end)  then
     134              call endqsio(infile, endtype);  $ get end type.
     135              if  endtype = 1  then  $ if eor.
     136                  knteor = knteor + 1;
     137                  put ,skip,'eor seen after line' :inknt,i(6)
     138                      ,', continuing.',skip;
     139                  cont while;
     140              else  $ if eof or eoi do terminal processing.
     141                  put ,skip ,'end of input after line'
     142                      :inknt,i(7) ,'.' ,skip;
     143                  if  ifblank=0 & blknt>0  then  $ if not listing blank
     144                      put ,skip ,'text contains ' :blknt,i
     145                          ,' blank lines that were not listed.' ,skip;
     146                      end if;
     147                  quit while infile;
     148                  end if;
     149          end if;
     150
     151      inknt = inknt + 1;
     152
     153      if  ifblank = no  then  $ if do not want blank lines listed.
     154          if  (.s. 1, 72, inline) .seq. (''.pad.72)  then  $ if blank.
     155              blknt = blknt + 1;
     156              cont while infile;
     157              end if;
     158          end if;
     159
     160      nuid = .s. 74, 7, inline;
     161      nuseq = .s. 82, 5, inline;  $ sequence number.
     162      c1 = .ch. 1, inline;
     163      istext = yes;
     164      if  c1 ^=  1r  then  $ look for comment.
     165          if  ((c1=1r$) ! (c1=1rc))  istext = no;
     166          end if;
     167      knttext = knttext + istext;
     168      kntcomm = kntcomm + (1-istext);
     169      if  istext  then
     170          if  (iftext=no)  cont while infile;
     171      elseif  ifcomm=no  then cont while infile;
     172          end if;
     173
     174      $   form ident name and sequence field to list.
     175      idprnt = 7q           ;
     176      ioknt = ioknt + 1;
     177      if  nuid .sne. listid  then
     178          listid = nuid;
     179          idprnt = listid;
     180          call etitlr(0, nuid, 0, 10);  $ enter new id in title.
     181          dupcount = 0;
     182      dupcount = 0;
     183      else  dupcount = dupcount + 1;
     184          end if;
     185      if  dupcount >= 10  then  $ if run of id, list it.
     186          dupcount = 0;
     187          idprnt = listid;
     188          end if;
     189
     190      idseq = '' .pad. 10;
     191      .s. 1, 7, idseq = idprnt;
     192      do  i = 5 to 1 by -1;  $ insert sequence number.
     193          c = .ch. i, nuseq;
     194          if  (c=1r ) quit do;
     195          .ch. i+4, idseq = c;
     196          end do;
     197
     198
     199 $    if -p- option on, will save card if columns 7-10 contain
     200      $   a procedure header.
     201
     202      if  ifproc   then
     203          call updproc(name); $ see if procedure header.
     204          if  .len. name > 0  then
     205              call contlpr(5, 10);  $ new page if less than 10 lines.
     206              call contlpr(12, pagenow);  $ get current page number.
     207              if  procptr < procmax  then  $ save name if can.
     208                  procptr = procptr + 1;
     209                  procnames(procptr) = name;
     210                  procpages(procptr) = pagenow;
     211                  end if;
     212              put scfile :pagenow,i(4),x(1) :nuid:nuseq,a ,x(1)
     213                :inline,a(72),skip;
     214              end if;
     215          end if;
     216
     217      put :idseq,a  :inline,a(72) ,skip;
     218
     219 $        look for end of routine or ident
     220 $        mark with ****** in listng
     221
     222     if ifsetl then  $ find 'end' followed by routine name
     223          if .s. 7, 6, inline .seq. 'end pr'
     224              ! .s. 7, 6, inline .seq. 'end op'  then
     225              put, '*********', skip(2);
     226              end if;
     227      else      $ find 'end prog', etc.
     228          if  .s. 1, 10, inline .seq. '      end '  then
     229          s14 = .s. 1, 14, inline;
     230          if  s14.seq.'      end subr'  !  s14.seq. '      end fnct' !
     231           s14.seq.'      end prog'  !  s14.seq. '      end     '  then
     232              put ,'*********' ,skip(2);
     233              end if;
     234          end if;
     235          end if;
     236      end while infile;
     237
     238 $        write out saved cards if -x- option on
     239
     240      if  (procptr=0 ! ifproc=0)  go to endofproclist;
     241
     242          put ,page,'lines with subr, fnct or func in cc 7-10',skip;
     243          put ,skip ,'page    ident' ,skip(2);
     244
     245 $        write record and file mark on scratch file; rewind for read
     246
     247          file  scfile  access=get;
     248          while  1;
     249              get scfile ,skip :inline,a(90);
     250              if  filestat(scfile,end) quit while;
     251              put :inline,a(90) ,skip(2);
     252              end while;
     253
     254 $        if any routines found, output sorted list
     255
     256          put ,page,'sorted list of procedure names and pages:',skip(2);
     257
     258 $        sort, using -shell- sort
     259 $        (code taken from kernighan and plaugher, 'programming style'
     260 $        ,page 109.)
     261
     262      size  igap(ps);         $ gap width.
     263      size  iex(ps), imax(ps);  $ indexes.
     264      size  iplusg(ps);       $ index.
     265      size  s1(.sds. 10), s2(.sds. 10);  $ copies of names.
     266      size  l(ps);            $ minimal name length.
     267      size  ii(ps);           $ index for name comparison.
     268      size  c2(cs);           $ character from second name.
     269      size  itrout(.sds. 10);  $ for name exchange.
     270      size  itpage(ps);       $ for page number exchange.
     271      size  bigger(1);    $ on if first symbol lexically bigger.
     272
     273
     274      igap = procptr;
     275
     276      while  igap>1;
     277      igap = igap/2;
     278      imax = procptr-igap;
     279      until  iex = 0;
     280          iex = 0;
     281      do  i = 1 to imax;
     282          iplusg = i+igap;
     283          s1 = procnames(i);  s2 = procnames(iplusg);
     284          l = .len. s1;
     285          if  (l> .len. s2)  l = .len. s2;
     286          if  (l=0)  cont do i;
     287          bigger = no;
     288          do  ii = 1 to l;
     289              c1 = .ch. ii, s1;  c2 = .ch. ii, s2;
     290              if  c1 ^= c2  then
     291                  bigger = (c1 > c2);
     292                  quit do;
     293                  end if;
     294              end do;
     295          if  bigger  then  $ if bigger, swap.
     296              itrout = procnames(i);
     297              procnames(i) = procnames(iplusg);
     298              procnames(iplusg) = itrout;
     299              itpage = procpages(i);
     300              procpages(i) = procpages(iplusg);
     301              procpages(iplusg) = itpage;
     302              iex = iex+1;
     303              end if;
     304          end do i;
     305
     306          end until;
     307          end while;
     308      lines = (procptr+3) / 4;
     309      do l = 1 to lines;
     310          i = l;
     311          while  i <= procptr;
     312              put :procpages(i),i(4) ,x(2) :procnames(i),a(10);
     313              i = i + lines;
     314              end while;
     315          put ,skip(2);
     316          end do;
     317      put ,skip;
     318 /endofproclist/
     319
     320      end prog updlst;
     321      subr updproc(name);     $ get procedure name.
     322      size  name(.sds. 10);   $ procedure name.
     323      size s7(.sds. 7);       $ characters 7-13 of input line
     324      size  s10(.sds. 10);    $ first ten chars of line.
     325      size  sname(.sds. 20);
     326      size  isaproc(1);       $ on if procedure header line.
     327      size  bpos(ps);         $ index of blank.
     328      size  l(ps);            $ length of name.
     329      size  i(ps);            $ loop index.
     330      size  tpos(ps);         $ terminator position.
     331      size  terminator(.sds.1);  dims terminator(3);
     332      data terminator = ' ', ';', '(';
     333
     334      size  str(.sds. 20);    $
     335      .len. name = 0;
     336      isaproc = no;
     337
     338      if ifsetl then  $ look for setl keywords
     339          until 1;
     340              if  (.s. 1, 6, inline .sne. '      ') quit until;
     341              c = .ch. 7, inline;
     342              if  (c^=1rd) & (c^=1rl) & (c^=1rm)
     343                  &(c^=1ro) & (c^=1rp)  then  quit until;  end if;
     344              if  (.s. 7, 10, inline .seq. 'directory ') then
     345                  isaproc = yes;  quit until;  end if;
     346              if  (.s. 7, 8, inline .seq. 'library ') then
     347                  isaproc = yes;  quit until;  end if;
     348              if  (.s. 7, 7, inline .seq. 'module ') then
     349                  isaproc = yes;  quit until;  end if;
     350              if  (.s. 7, 5, inline .seq. 'proc ') then
     351                  isaproc = yes;  quit until;  end if;
     352              if  (.s. 7, 3, inline .seq. 'op ') then
     353                  isaproc = yes;  quit until;  end if;
     354              if  (.s. 7, 9, inline .seq. 'operator ') then
     355                  isaproc = yes;  quit until;  end if;
     356              if  (.s. 7, 5, inline .seq. 'proc ') then
     357                  isaproc = yes;  quit until;  end if;
     358              if  (.s. 7, 10, inline .seq. 'procedure ') then
     359                  isaproc = yes;  quit until;  end if;
     360              if  (.s. 7, 5, inline .seq. 'prog ')  then
     361                  isaproc = yes;  quit until; end if;
     362              if  (.s. 7, 8, inline .seq. 'program ')  then
     363                  isaproc = yes;  quit until; end if;
     364              end until;
     365      else  $ look for little keywords
     366          s10 = .s. 1, 10, inline;
     367          isaproc = (s10.seq.'      fnct') ! (s10.seq.'      func')
     368              ! (s10.seq.'      prog') ! (s10.seq.'      subr');
     369          end if;
     370      if  (isaproc=0)  return;
     371      str = .s. 7, 20, inline;
     372      bpos = ' ' .in. str;
     373      if  (bpos=0 ! bpos=20)  return;
     374      sname = .s. bpos+1, 20-bpos, str;
     375      l = 0;
     376      $   leftmost terminator ends name.
     377      do  i = 1 to 3;         $ search for terminator.
     378          tpos = terminator(i) .in. sname;
     379          if  tpos  then      $ if terminator seen.
     380              tpos = tpos-1;
     381              if  (l=0)  l=tpos;  $ if first terminator.
     382              if  (tpos10)  l = 10; $ truncate long name.
     386          if (l=0)  return;
     387      if  .ch. 1, sname = 1r  then  $ if need to eliminate leading blank
     388          do  i = 2 to l;
     389              if  .ch. i, sname ^= 1r  then
     390                  name = .s. i, l + 1 - i, sname;
     391                  quit do;
     392                  end if;
     393              end do;
     394      else
     395          name = .s. 1, l, sname;
     396          end if;
     397      end subr;
       1 .=member objname
       2      $   this program is used on s37 only.
       3
       4      $   this program takes as input on ddname='in' a file of
       5      $   concatenated object modules.  its output is on ddname='out'
       6      $   and is the same object modules with interspersed 'name' and
       7      $   'alias' cards to convert it into a linkage editor stream for
       8      $   building the library.  this is needed both for os and cms.
       9
      10
      11      $   author:  r. kenner  (nyu-cims)  1-aug-80
      12
      13      $   standard macros.
      14
      15      +*  ws = .ws. **     +*  ps = .ps. **    +*  cs = .cs. **
      16
      17      +*  yes = 1 **   +*  no = 0 **
obja   7
objb   1      +*  nameslim = 100 **  $ max. number of names.
      18
      19      prog objname;  $ add linkage editor statements.
      20      size  card(.sds. 80);           $ a card from the input file.
      21      size  name(.sds. 8);            $ the name of the module.
obja   9      $ aliases for the module
obja  10      size  names(.sds. 8); dims names(nameslim);
      23      size  nameptr(ps);  data nameptr = 0;  $ pointer into 'names'.
      24      size  i(ps);                    $ loop variable.
      25      size  between_decks(1);         $ 'we are between two decks'
      26      data  between_decks = yes;      $ initially, we are.
      27
      28      $   open the input and output files.
      29
      30      file  3  title = 'out', access = put;  $ open output file.
      31      file  4  title = 'in', access = get;   $ open input file.
      32
      33      $   get the first card and loop until end of file.
      34
      35      get  4 ,skip :card,a(80);  $ read the first card.
      36      while  filestat(4,end) = no;   $ while not end of file.
      37          $   if this is an esd card and we are 'between' modules, then
      38          $   process the names on it.
      39          if  .s. 2, 3, card .seq. 'esd' & between_decks then
      40              $   process each symbol on the card.
      41              do  i = 1 to (.ch. 12, card)/16;  $ process each symbol.
      42                  if  .ch. i*16+9, card = 0  then  $ this is an sd.
      43                      name = .s. i*16+1, 8, card;  $ get the csect name.
      44                  elseif  .ch. i*16+9, card = 1 then  $ this is an ld.
      45                      nameptr = nameptr + 1;  $ show another name.
obja  11                      if nameptr>nameslim then $ if too many names
obja  12                          put ,'too many names - rebuilb objname',skip;
obja  13                          call ltlfin(1,0);
obja  14                          end if;
      46                      names(nameptr) = .s. i*16+1, 8, card;  $ get it.
      47                      end if;
      48                  end do;
      49
      50          else    $   not an esd card or after found a non-esd card.
      51              between_decks = no;  $ show no longer between decks.
      52              end if;
      53
      54          $   now write out the card to the output file.  if this is an
      55          $   'end' card, write out all the stored-up names and reset.
      56
      57          put  3 :card,a ,skip;  $ write out the card.
      58          if  .s. 2, 3, card .seq. 'end' then   $ if end card.
      59              do  i = 1 to nameptr;  $ process all aliases.
      60                  put  3 ,' alias ' :names(i),a  ,skip;  $ write alias.
      61                  end do;
      62
      63              put  3 ,' name ' :name,a ,skip;  $ write out deck name.
      64              between_decks = yes;  nameptr = 0;  $ reset for next deck.
      65              end if;
      66
      67          $   finally, read next card.
      68
      69          get  4  ,skip  :card,a(80);  $ read the next card.
      70          end while;
      71
      72      end prog objname;
       1 .=member mktvec
       2      prog mktvec;  $ needed for s32 vms
       3$ program to build transfer vector file  tvect.mar from tvect.dat
       4$ author - d. shields  (nyu-cims)  01-feb-81
tva    8 $ revise - d. shields  9-sep-81
tva    9 $   add parameter 'name=ltllibtv/' to permit naming psect.
       5$       (transcription of prior spitbol version to little)
       6
       7      +* ws = .ws. **  +* ps = .ps. **  +* cs = .cs. ** $ std. macros
       8      +*  ifile = 3 **  $ input file
       9      +*  ofile = 4 **  $ output file
      10      size  i(ps);                  $ index
      11      size  nam(.sds. 20);          $ procedure name
tva   10      size tvname(.sds. 64); $ transfer vector psect name
      12
tva   11      call getspp(tvname,'name=ltllibtv/');
tva   12
      13      file ifile title='tvect.dat', access=get;
      14      file ofile title='tvect.mar', access=put;
      15
tvaa   1      put ofile, column(9) ,'.title  ' :tvname,a ,skip
tva   14            ,column(9) ,'.psect  '
tva   15            :tvname,a ,',pic,page,noshr,wrt,exe'
      18            ,skip
      19            ,'$$=.' ,skip;
      20      while 1;
      21        get ifile ,skip :nam,a(20);
      22        if  filestat(ifile,end) then quit while; end if;
      23        if  .ch. 1, nam =1r* then cont; end if; $ skip comment line.
      24        i = ' ' .in. nam; $ find ending blank
      25        if i=0 then i=20; end if;
      26        .len. nam = i-1;  $ adjust length
      27        put ofile ,skip
      28              ,column(9) ,'.transfer  ' :nam,a ,skip
      29              ,column(9) ,'.mask' ,column(17) :nam,a ,skip
      30              ,column(9) ,'jmp' ,column(17)  :nam,a ,'+2'  ,skip;
      31        end while;
      32      put ofile ,column(9)
      33            ,'.blkb 512-<.-$$>  ; room for future entry points'
      34            ,skip
      35            ,column(9) ,'.end' ,skip;
      36    end prog;
       1 .=member spl
       2      prog spl; $ little splitter for s32 (vms)
       3
       4 $ this program is recoding of prior "splitter" program from
       5 $ macro-11 to little. the program splits up a t32 file into
       6 $ a separate file for each procedure. the file name is derived
       7 $ from the procedure name by using at most nine characters, and
       8 $ changing instances of '$' or '_' to 'z'.
       9 $
      10 $ program parameters are as follows:
      11 $
      12 $ c=prog.com/      name of generated command file
      13 $ km=0/1           on to keep .mar files in subdirectory
      14 $ ko=0/1           on to keep .obj files in subdirectory
smfa   1 $ ml=t32/          macro library file name
smfa   2 $ o=ltl.oba/       object file name
      15 $ t=prog.t32/      name of input t32 file
      16 $
      17 $ author:  d. shields  (nyu-cims)  14-jul-80
      18 $
      19 $ revise: d. shields  17-nov-80
      20 $ fix problem if procedure has same name as logical name by
      21 $ putting _ before procedure name to avoid logical name
      22 $ translation.
      23 $
      24 $ revise: d. shields  25-feb-81
      25 $ add switch km=0/1 such that km=0 causes generated .mar files to
      26 $ be deleted after they have been assembled. km=1 'keeps' them.
      27 $ add switch ko=0/1 such that ko=0 causes generated .obj files to be
      28 $ combined into file ltl.oba and then deleted.
      29 $ ko=1 'keeps' them.
smfa   3 $
smfa   4 $ revise: s. freudenberger  23-apr-81
smfa   5 $ add file name parameter ml=t32/ to specify the file name of the
smfa   6 $ macro library used during the assembly phase.
smfa   7 $ also add file name parameter o=ltl.oba/ to specify file name into
smfa   8 $ which the object files are collected.
smfa   9 $ nb. the o= file name must reside on the same device as the current
smfa  10 $ default directory.
      30
      31
      32 $ define macros.
      33
      34      +*  ws = .ws. **  +* ps =.ps.**  +* cs = .cs. **  $ std. macros
      35      +*  ifile = 3 **  $ t32 file
      36      +*  cfile = 4 **  $ generated command file
      37      +*  ofile = 5 **  $ generated macro file name
      38      +*  filenamlen = 64 **  $ length of file name
      39      +*  ss_separ = 2  **  $ string set for blanks, tabs.
      40      +*  tab = 9 **  $ ascii code for tab character
      41
      42      $ define global variables.
      43
      44      size  line(.sds.80);
      45      size  linel(ps);                $ line length
      47      size  cfilename(.sds. filenamlen);
      48      size  ifilename(.sds. filenamlen);
smfa  11      size  mfilename(.sds. filenamlen);
smfa  12      size  ofilename(.sds. filenamlen);
      49      size  i1(ws),i2(ws);  $ search temporaries
      50      size  procs(ps);  data procs = 0;  $ number of procedures.
      51      size  kmaropt(ps);     $ keep .mar option
      52      size  kobjopt(ps);     $ keep obj option
      53      size  opc(.sds. 3);    $ three-character opcode
      54
      55      size  rsps(ws);  $ span string from right.
      56      size  brkc(ws);  $ function to break to character
      57      size  spns(ws);  $ function to span to character
      58      size  name(.sds. filenamlen);
      59      size  namel(ws);  $ length of name
      60
      61      $ acquire program parameters.
      62      call getipp(kmaropt, 'km=0/1');  $ keep .mar option.
      63      call getipp(kobjopt, 'ko=0/1');   $ keep .obj option.
      64      call getspp(ifilename, 't=prog.t32/');
      65      call getspp(cfilename, 'c=prog.com/');
smfa  13      call getspp(mfilename, 'ml=t32/'    );
smfa  14      call getspp(ofilename, 'o=ltl.oba/' );
      66
      67      call rpld('$_','zz');  $ map these to z for filenames
      68
      69      file ifile access=get,linesize=80,title=ifilename; $ open input
      70      file cfile access=put,linesize=80,title=cfilename; $ open input
      71
      72  while 1;  $ loop over input
      73      get ifile ,skip :line,a(80);  $ get next line
      74      if  filestat(ifile,end) then quit while; end if; $ if end of data
      75      $ determine length of input line.
      76      linel = .len. line; $ get current length.
      77      i1 = rsps(line, linel, ss_separ); $ trim blanks, tabs
      78
      79      if  i1>0 then $ if trailing blanks or tabs
      80          linel = linel - i1;
      81          .len. line = linel;  $ adjust length.
      82          end if;
      83
      84      if  linel>8  then
      85          if  .s. 1, 8, line = (''.pad.8)  then
      86          $ here to insert initial tab.
      87              .ch. 1, line = tab;
      88              .s. 2, linel-8, line = .s. 9, linel-8, line;
      89              linel = linel - 7;
      90              .len. line = linel;
      91              end if;
      92          end if;
      93
      94      $ if first character tab, and characters 5..9 blank
      95      $ turn the blanks into tab.
      96      if .ch. 1, line = tab & linel>9  then
      97          if  .s. 5, 5, line .seq. (''.pad.5) then
      98              .ch. 5, line = tab;
      99              .s. 6,linel-9, line = .s. 10,linel-9, line;
     100              linel = linel - 4;
     101              .len. line = linel;
     102              end if;
     103          end if;
     104
     105      $ if first character not a tab, just copy out the line.
     106      if  .ch. 1, line ^= tab  then
     107          put ofile :line,a ,skip;
     108          cont while;
     109          end if;
     110      $ here if possible line requiring special action.
     111      opc = .s. 2, 3, line;
     112      call stuc(opc);  $ fold to upper case
     113       $ if end line, close file and copy out
     114      if  opc .seq. '.en'  then
     115          put ofile :line,a ,skip;
     116          file ofile access=release;
     117          cont while;
     118      $ if start of procedure
     119      elseif  opc .seq. 'dsp' then
     120      $ here to start new procedure: build command line, open target
     121      $ file
     122          i1 = spns(line, 5, ss_separ); $ get start of name
     123          assert i1>0;
     124          namel = brkc(line, 5+i1,1r,);  $ break to end of name.
     125          assert namel>0;
     126          name = .s. i1+5, namel, line;  $ get procedure name.
     127          if (.len.name>9) .len. name = 9; $ truncate long name.
     128          namel = .len. name;
     129          call rple(name);  $ convert to valid file name.
     130          $ write command line to assemble.
smfa  15          put cfile
smfa  16              ,'$ macro/nolist _' :name,a ,'/obj+'
smfa  17              :mfilename,a ,'/lib' ,skip;
     132          if  kmaropt=0 then  $ if want .mar file deleted
     133              put cfile ,'$ delete ' :name,a ,'.mar.0' ,skip;
     134              end if;
     135          procs = procs + 1;
     136          if  kobjopt=0  then  $ if appending
     137              if  procs=1  then $ rename first proc
     138                  put cfile
smfa  18                      ,'$ rename ' :name,a ,'.obj.0 ' :ofilename,a
smfa  19                      ,skip;
     140              else  $ append and delete.
     141                  put cfile
smfa  20                      ,'$ append ' :name,a ,'.obj.0 ' :ofilename,a
smfa  21                      ,skip
smfa  22                      ,'$ delete ' :name,a ,'.obj.0 '
smfa  23                      ,skip;
     144                  end if;
     145              end if;
     146          file ofile access=put, linesize=80, title=(name!!'.mar');
     147          put ofile :line,a ,skip;  $ copy line.
     148      else  $ copy out other lines.
     149          put ofile :line,a ,skip;
     150          end if;
     151      end while;
     152      end prog;

« August 2022 »
Su Mo Tu We Th Fr Sa
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
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: