UTL: Various utility programs, some machine dependent and some principally of interest to the CDC 6600, IBM System/370, or DEC VAX implementations.
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;