Forgot your password?
Document Actions
UPD: Source maintenance program. By David Shields.
UPD: Source maintenance program. By David Shields.
1 .=member intro
2 $ !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
3 $ the above line contains, in order of ascii codes, the 56
4 $ characters of the little language, starting in column 7.
5
6
7
8
9 /*
10
11 $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$
12 $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$
13 $$ $$ $$ $$ $$ $$
14 $$ $$ $$ $$ $$ $$
15 $$ $$ $$ $$ $$ $$$$$$
16 $$ $$ $$ $$ $$ $$$$$$
17 $$ $$ $$ $$ $$ $$
18 $$ $$ $$ $$ $$ $$
19 $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$
20 $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$
21
22 $$ $$ $$$$$$$$$ $$$$$$$$$
23 $$ $$ $$$$$$$$$$ $$$$$$$$$$
24 $$ $$ $$ $$ $$ $$
25 $$ $$ $$ $$ $$ $$
26 $$ $$ $$$$$$$$$$ $$ $$
27 $$ $$ $$$$$$$$$ $$ $$
28 $$ $$ $$ $$ $$
29 $$ $$ $$ $$ $$
30 $$$$$$$$$$ $$ $$$$$$$$$$
31 $$$$$$$$ $$ $$$$$$$$$
32
33
34 this software is part of the little programming system.
35 address queries and comments to
36
37 little project
38 department of computer science
39 new york university
40 courant institute of mathematical sciences
41 251 mercer street
42 new york, ny 10012
43
44 this is the source maintenance program upd, written
45 by david shields of nyu.
46
47
48
49 */
50
51
52
53
1 .=member mods
2 $ - - - all changes are to include self-description after mods.2
dsj 1
dsj 2 $ dsj d. shields 26-sep-80 level 80270
dsj 3 $
dsj 4 $ add option 'shink=0/1' such that shrink=1 causes upd to not
dsj 5 $ write out lines which are all blank or begin with blanks followed
dsj 6 $ by dollar sign (comments).
dsj 7 $ decks affected - putlin, shrink (new)
dsj 8
dsi 1
dsi 2 $ dsi d. shields 21-jul-80 level 80203
dsi 3 $
dsi 4 $ fix bug (fr2.3.140) that caused problems if opl identifier
dsi 5 $ specified in lower case.
dsi 6 $ deck affected - moveto.
dsi 7
dsh 1
dsh 2 $ dsh d. shields 10-jul-80 level 80192
dsh 3 $
dsh 4 $ 1. fix problem (fr135) in setting of termination code.
dsh 5 $ now issue code 0 if no warnings or errors, code 4 if warnings
dsh 6 $ and no errors, code 8 if any errors detected.
dsh 7 $ 2. add conditional symbol -unix- for the unix operating system.
dsh 8 $ use iset=unix to obtain unix variant.
dsh 9 $
dsh 10 $ decks affected - macros, updini, updexi.
dsh 11
dsg 1
dsg 2 $ dsg d. shields 20-may-80 level 80141
dsg 3 $
dsg 4 $ 1. fix bug (fr2.3.133) that caused problems if member name
dsg 5 $ given in lower case in opl.
dsg 6 $ 2. fix bug (fr2.3.134) that caused errors in second arg to
dsg 7 $ -del to go unreported.
dsg 8 $ decks affected - scncmd, chkmem.
dsg 9
dsf 1
dsf 2 $ dsf d. shields 25-mar-80 level 80085
dsf 3 $
dsf 4 $ on error, copy current command line to terminal (term=).
dsf 5 $ delete call to ltlxtr on abnormal termination.
dsf 6 $ decks affected - docmd, upderr
dsf 7
dse 1
dse 2 $ dse d. shields 21-dec-79 level 79355
dse 3 $
dse 4 $ 1. fix error that caused looping in some cases if member
dse 5 $ not present.
dse 6 $ 2. fix error in ucs option with -note commands.
dse 7 $ decks affected - docmd, movmem.
dse 8 $
dsd 1
dsd 2 $ dsd d. shields 23-nov-79 level 79327
dsd 3 $
dsd 4 $ add option ucs (u-pdate c-orrection s-et) with default
dsd 5 $ 'ucs=/'. if 'ucs=name' specified, upd writes out to named
dsd 6 $ file the correction set in cdc update format. this assists
dsd 7 $ converting upd correction sets developed in the field.
dsd 8 $ decks affected - updini, docmd, uscid(new), doalt, insert.
dsd 9
dsc 1 $ dsc d. shields 21-sep-79 level 79264
dsc 2
dsc 3 $ fix bug that caused .=member line to be recognized only if in
dsc 4 $ upper case (fr2.3.123).
dsc 5 $ deck affected - chkmem.
dsc 6
dsb 1
dsb 2 $ dsb d. shields 07-aug-79 level 79220
dsb 3 $
dsb 4 $ 1. revise to use string search primtives provided by lib
dsb 5 $ level 79200.
dsb 6 $ 2. provide support for lower-case if available and also
dsb 7 $ permit available 'separators' to be used where blank
dsb 8 $ previously required.
dsb 9 $ 3. for s10, issue standard prefix character in warning
dsb 10 $ and error messages.
dsb 11 $ decks affected - most. decks containing original definition
dsb 12 $ of string primitives have been deleted, as this material now
dsb 13 $ in little lib.
dsb 14
dsa 1
dsa 2 $ dsa d. shields 18 may 79 level 79138
dsa 3 $
dsa 4 $ fix error (fr2.3.106) in listing -ps- and -ns- program paramters.
dsa 5 $ deck affected - updini.
dsa 6
3
4 $ (none) d. shields 05 feb 79 level 79036
5 $
6 $ release first, preliminary version (v1.0). this version
7 $ has been tested on s32 (dec vax) and s66 (cdc 6000).
8
1 .=member macros
2
3 $ set cupd to recognize cdc update directives
4 $ during creation run.
5 .+set cupd
dsb 15
dsh 12 $ set mc if lower-case characters available.
dsh 13 $ if mixed-case available, default primary case is upper.
dsh 14 $ obtain lower primary case by defining mcl.
dsb 17
dsh 15 .+set mc $ mc set by default
dsb 19
dsb 23 .+s66.
dsh 16 .-set mc $ s66 is upper-case only.
dsb 25 ..s66
dsb 26
6 /*
7 commands
8
9 alter l1,/old/new/
10 before l1
11 copy n1,n2,n3..n4
12 edit n1
13 end
14 delete l1
15 delete l1,l2
16 insert l1
17 modname n1
18 note arbitrary text
19
20 */
21
22
23 +* programlevel = $ date of last change.
dsj 9 'upd(80270)' $ 26-sep-80
25 **
26
dsja 1 .+s32.
dsja 2 .+set s32v $ assume vms.
dsja 3 ..s32
dsja 4
dsja 5 .+s32u.
dsja 6 .+s32.
dsja 7 .-set s32v $ do not want vms.
dsja 8 .+set s32u $ want unix os.
dsja 9 ..s32
dsja 10 .+set mcl $ want primary case to be lower.
dsja 11 ..s32u
dsja 12 .+s47.
dsh 19 $ configure for unix, set primary case lower.
dsh 20 .+set mcl
dsja 13 ..s47
dsh 22
dsh 23 .+mc.
dsh 24 .+mcl. $ if mixed-case to be lower
dsh 25 +* ctpc(x) = ctlc(x) ** $ primary case is lower.
dsh 26 +* stpc(x) = stlc(x) ** $ primary case is lower.
dsh 27 .-mcl.
dsh 28 +* ctpc(x) = ctuc(x) ** $ primary case is upper.
dsh 29 +* stpc(x) = stuc(x) ** $ primary case is upper.
dsh 30 ..mcl
dsh 31 ..mc
dsh 32
27 +* terml(n) = call contlpr(27, n); ** $ terminal control.
28
29 +* error(txt) = call upderr(txt); ** $ report error.
30
31 +* filenamlen = 20 ** $ length of file name.
vaxa 1 .+s32 +* filenamlen = 64 ** $ length of file name.
dsjb 1 .+s47 +* filenamlen = 64 ** $ length of file name.
32
dsd 11 +* getapp_len = 128 ** $ length of parameter string.
dsd 12 .+s32 +* getapp_len = 240 **
dsjb 2 .+s47 +* getapp_len = 240 **
dsd 13
33 +* ws = .ws. ** +* ps = .ps. ** +* cs = .cs. **
34
35 +* countup(ptr, lim, msg) = $ increment table pointer.
36 ptr = ptr + 1;
37 if (ptr>lim) then error(msg); end if;
38 **
39
40 $ codes for new sequence option.
41 +* seq_n = 0 ** $ no sequence.
42 +* seq_l = 1 ** $ left sequence.
43 +* seq_r = 2 ** $ right sequence.
44
45 $ codes for commands.
46
47 +* c_alt = 1 ** $ alter
48 +* c_bef = 2 ** $ before
49 +* c_cop = 3 ** $ copy
50 +* c_del = 4 ** $ delete
51 +* c_edi = 5 ** $ edit
52 +* c_end = 6 ** $ end
53 +* c_ins = 7 ** $ insert
54 +* c_mod = 8 ** $ modname
55 +* c_not = 9 ** $ note
56 +* n_cmd = 9 ** $ number of commands.
57
58 +* charofdig(d) = (d+1r0) ** $ digit to character.
59 +* digofchar(c) = (c-1r0) ** $ character to digit.
60
61 +* oldfile = 3 ** +* newfile = 4 ** $ file numbers.
dsd 14 $ unit 5 is used if produced update correction set format.
62
dsb 28 $ codes for standard string sets.
dsb 29
dsb 30 +* ss_blank = 1 **
dsb 31 $ ss_separ matches blank and other characters (such as tab and
dsb 32 $ form feed for ascii environments) which are by convention
dsb 33 $ considered equivalent to blanks.
dsb 34 +* ss_separ = 2 **
dsb 35 +* ss_digit = 4 ** $ digits.
dsb 36 +* ss_ucltr = 8 ** $ upper case letters a..z
dsb 37 +* ss_lcltr = 16 ** $ lower case letters a..z
dsb 38 +* ss_break = 32 ** $ underline, break '_'
dsb 39
dsb 40 $ additional string sets.
dsb 41
dsb 42 +* ss_al = (ss_ucltr ! ss_lcltr) ** $ alphabetics.
dsb 43 +* ss_aprpbl = 64 ** $ string set for ''') '.
dsb 44 +* ss_cm = 128 ** $ search set for ','.
dsb 45 +* ss_lpap = 256 ** $ search set for '('''.
dsb 46 +* ss_period = 512 ** $ search set for '.'.
dsb 47
67 +* yes = 1 ** +* no = 0 **
68
dsh 33 +* openchk(f, t) = $ check that file open.
dsh 34 if filestat(f,access)=0 then $ if not open
dsh 35 put ,'open error, unit ' :f,i ,', file ' :t,a ,skip;
dsh 36 error('cannot open file');
dsh 37 end if;
dsh 38 **
dsh 39
1 .=member start
vaxb 1 prog start; $ upd main program.
3 size af(ps); $ index of start of command argument
4 size al(ps); $ length of command argument.
5 size altnew(.sds. 72); $ new string for alter.
6 size altold(.sds. 72); $ old string for alter.
7 size cl(.sds. 72); $ command line.
8 size cmdend(1); $ on at end of command input file.
9 data cmdend = no;
10 size cmdi(ps); $ index of current command.
11 size cmdlisted(1); $ on when command line listed.
12 $ cmdnames gives names of commands.
13 size cmdnames(.sds.8); dims cmdnames(n_cmd);
14 data
15 cmdnames(c_alt) = 'alter':
16 cmdnames(c_bef) = 'before':
17 cmdnames(c_cop) = 'copy':
18 cmdnames(c_del) = 'delete':
19 cmdnames(c_edi) = 'edit':
20 cmdnames(c_end) = 'end':
21 cmdnames(c_ins) = 'insert':
22 cmdnames(c_mod) = 'modname':
23 cmdnames(c_not) = 'note';
24
25 +* copymax = 60 ** $ maximum copy members in command.
26 size copylist(.sds.8); $ list of names of copy members.
27 size copyptr(ps); $ number of elements in copy list.
28 size copytype(ps); $ list of types of copy members.
29 dims copylist(copymax);
30 dims copytype(copymax);
31 size cpyall(1); $ on to copy all members.
32 size cpydef(ps); $ on to copy definition lines.
33 .+cupd.
34 size cueors(ps); $ number of *cweor or *weor lines.
35 data cueors = 0;
36 ..cupd
37 size curact(ps); $ activity status of current line.
dsia 1 data curact = no;
38 size curid(.sds.8); $ identifier of current line.
39 size curseq(.sds.8); $ sequence part of current line.
40 size cursn(ws); $ sequence number of current line.
dsia 2 data cursn = 0;
41 size curtxt(.sds.72); $ text part of current line.
51 size delsev(1); $ on if deleting several lines.
dsj 10 size shrink_opt(ps); $ on to discard blank lines,comments
dsia 3 data delsev = no;
52 size docopy(1); $ on to do copy.
53 size editname(.sds.8); $ name from edit command.
54 data editname = ''.pad.8;
55 size editing(1); $ on if editing member.
56 data editing=no;
57 size getrc(ws); $ getlin return code.
58 data getrc = 0;
59 size id1(.sds.8), id2(.sds.8); $ sequence fields.
60 size im_c(1); $ on if im option for copied members.
61 size im_e(1); $ on if im option for edited members.
62 size im_f(1); $ on if im option for all members.
63 size im_l(ps); $ im option length.
64 size im_name(.sds.8); $ im option name.
65 data im_name = '';
66 size keepcmd(1); $ on to reread command.
dsia 4 data keepcmd = no;
67 size list_a(1); $ on to list altered lines.
68 size list_c(1); $ on to list names of members copied.
69 size list_d(1); $ on to list lines deleted.
70 size list_u(1); $ on to list upd commands.
71 size list_i(1); $ on to list lines inserted.
72 size list_p(1); $ on to list parameters, statistics.
73 size modname(.sds.8); $ name from modname command.
74 data modname = ''.pad.8; .len. modname = 0;
75 size ndelete(ws); data ndelete = 0; $ lines deleted.
76 size nerrors(ps); data nerrors = 0; $ error count.
77 size newfilename(.sds. filenamlen); $ name of new file.
78 size newlines(ws); $ number of lines read from new file.
dsia 5 data newlines = 0;
79 size ninsert(ws); data ninsert = 0; $ lines insertd.
80 size nmem(ps); $ number of members in creation mode.
81 size nseq(ps); $ new sequence option.
82 size nwarnings(ps); data nwarnings = 0; $ warning count.
83 size oldend(1); $ on at end of old file.
dsia 6 data oldend = no;
84 size oldfilename(.sds. filenamlen); $ name of old file.
85 size oldlines(ws); $ number of lines read from old file.
dsia 7 data oldlines = 0;
86 size pseq(ps); $ old sequence option.
87 size seqno(ws); $ sequence number.
88 size sn1(ws), sn2(ws); $ sequence numbers.
89 size umode(ps); $ run mode.
dsd 15 size ucsfile(ps); $ nonzero if producing update format.
90
91 call updini; $ initialize.
92 call updcon; $ call control program.
93 call updexi(0); $ exit.
vaxb 2 end prog start;
1 .=member updini
2 subr updini; $ upd initialization.
3 $ read program parameter for mode, read other parameters
4 $ according to mode setting.
6 size spn(ps); $ span function.
7 size pseqstr(.sds.filenamlen); $ pseq option.
8 size nseqstr(.sds.filenamlen); $ nseq option string.
9 size defopt(ps); $ copy definitions (d) option.
10 size foptstr(.sds.filenamlen); $ option string for 'f' option.
11 size lstopt(.sds.filenamlen); $ option string for lo option.
12 size imopt(.sds.filenamlen); $ option string for im option.
dsia 8 data imopt = 0; $ initially null.
dsd 16 size ucsname(.sds. filenamlen); $ name for ucs file.
dsd 17 size app(.sds. getapp_len); $ actual parameter string.
13 size i(ps); $ index.
14 size l(ps); $ index.
16
17 $ build global character vectors for spn and brk.
dsb 48 call blds(',', ss_cm);
dsb 49 call blds('.', ss_period);
dsb 50 call blds('(''', ss_lpap);
dsb 51 call blds(')'' ', ss_aprpbl);
27
33
dsj 11 call getipp(shrink_opt, 'shrink=0/1');
34 call getspp(oldfilename, 'p=old/');
35 call getspp(newfilename, 'n=new/');
dsd 18 call getapp(app, getapp_len); $ get full parameter string.
dsd 19
dsd 20 $ ucs=name option requests that correction set be written out
dsd 21 $ to named file in cdc update format.
dsd 22 call getspp(ucsname, 'ucs=/');
dsd 23 ucsfile = 0; $ assume no ucs file.
dsd 24 if .len. ucsname then $ if want ucs format.
dsd 25 ucsfile = 5;
dsd 26 file 5 access=put, title=ucsname, linesize=80;
dsh 40 openchk(5, ucsname); $ see if open.
dsd 27 end if;
36
37 im_l = 0; $ assume no im option.
38 im_c = 0; $ assume no im option.
39 im_e = 0; $ assume no im option.
40 call getipp(umode, 'm=2/1'); $ get run mode.
41 if umode=0 ! umode>3 then error('invalid mode'); end if;
42
43 if umode=1 then $ if creation run.
44 call getspp(pseqstr, 'ps=n/');
45 call getspp(nseqstr, 'ns=l/r');
46 call getspp(foptstr, 'f=f/f');
47 call getipp(defopt, 'd=1/1');
48 elseif umode=2 then $ if retrieval run.
49 call getspp(pseqstr, 'ps=l/r');
50 call getspp(nseqstr, 'ns=n/r');
51 call getspp(foptstr, 'f=ec/f');
52 call getipp(defopt, 'd=0/1');
ulst 1 call getspp(imopt, 'im=/ec6'); $ im option value.
54 im_f = ('f'.in.imopt)>0; $ full option.
55 im_c = im_f ! (('c'.in.imopt)>0); $ im for copied members.
56 im_e = im_f ! (('e'.in.imopt)>0); $ im for edited members.
57 l = .len. imopt;
58 if l then $ if possible im optin.
59 im_l = 6;
60 until 1; $ parse option.
dsb 52 $ see if last is number.
dsb 53 i = spn((.s.l,1,imopt), 1, ss_digit);
62 if (i=0) quit until;
63 i = digofchar((.ch.l,imopt)); $ convert to digit.
64 if (i>6) i = 6;
65 im_l = i;
66 end until;
67 end if;
68 .len. im_name = im_l;
69 if ((im_c=0)&(im_e=0)) im_l = 0;
70 else $ umode = 3, revision run.
71 call getspp(pseqstr, 'ps=l/r');
72 call getspp(nseqstr, 'ns=l/r');
73 call getspp(foptstr, 'f=f/f');
74 call getipp(defopt, 'd=1/1');
75 end if;
76
77 call getspp(lstopt, 'lo=acdipu/adipu');
78 list_a = ('a'.in.lstopt) > 0;
79 list_c = ('c'.in.lstopt) > 0;
80 list_d = ('d'.in.lstopt) > 0;
81 list_i = ('i'.in.lstopt) > 0;
82 list_p = ('p'.in.lstopt) > 0;
83 list_u = ('u'.in.lstopt) > 0;
84 pseq = pseqstr .in. 'nlr'; if (pseq) pseq = pseq - 1;
85 nseq = nseqstr .in. 'nlr'; if (nseq) nseq = nseq - 1;
86
87 $ im only meaningful if new file sequenced.
88 if im_l>0 & nseq=seq_n then $ warn and quit.
dsb 54 error('im option requires that new file be sequenced');
93 call updexi(1);
94 end if;
95
96 cpydef = defopt>0; $ on to copy member definition lines.
97 cpyall = ('f'.in.foptstr) > 0; $ on to copy all members.
98 docopy = cpyall ! (('c'.in.foptstr)>0); $ on to do copies.
99 if (cpyall) list_c = no;
100
101 file oldfile access=get, title=oldfilename, linesize=80;
dsh 41 openchk(oldfile, oldfilename);
102 file newfile access=put, title=newfilename, linesize=80;
dsh 42 openchk(newfile, newfilename);
103
104 .+s66 rewind oldfile; rewind newfile;
105
106
107 $ list program parameters if list_p set.
108 if list_p then
109 call ltitlr(programlevel);
110 call stitlr(0, 'upd - update source');
dsd 28 if .len. app then $ if actual parameters given, list them.
dsd 29 put :app,a ,skip(2);
dsd 30 end if;
111 put
dsa 8 ,'upd parameters: mode: m = ' :umode,i ,skip
113 ,'old: p = ' :oldfilename,a
dsb 55 ,', new: n = ' :newfilename,a
dsb 56 ,', pseq: ps = ' :(.s. pseq+1, 1, 'nlr'),a
dsb 57 ,', nseq: ns = ' :(.s. nseq+1, 1, 'nlr'),a ,skip
dsd 31 ,'ucs: ucs = ' :ucsname,a ,', '
dsb 58 ,'im: im = ' :imopt,a
dsa 11 ,', def: d = ' :cpydef,i
dsb 59 ,', f: f = ' :foptstr,a
dsb 60 ,', list option: lo = ' :lstopt,a ,skip(3);
120 end if;
121 end subr updini;
1 .=member updcon
2 subr updcon; $ upd control procedure.
3 size rc(ws); $ return code.
4 size drc(ws); $ return code.
5 size l(ps); $ string length.
6 size cmdn(.sds.8); $ command name as given.
7 size i(ps); $ loop index.
8 size t(.sds.72),s(.sds.8); $ text, sequence parts of line.
9 size brk(ps); $ break function.
10 size dl(ps); $ command name length.
11
12
13 if umode=1 then $ if creation run.
14 call create; return;
15 end if;
16 $ here for retrieval or revision run.
17 while 1;
18 call getcmd(drc, cl, s); $ read command line.
19 cmdlisted = no;
20 if (drc) quit while; $ if end or error.
21 if (.ch.1,cl ^= 1r-) go to cmderr;
22 if list_u then $ if want command listed.
23 put :cl,a ,skip;
24 cmdlisted = yes;
25 end if;
dsb 61 l = brk(cl, 2, ss_separ); $ break to blank
27 if (l>8) l =8; $ only examine first eight characters.
28 cmdi = 0; $ assume not valid command.
29 cmdn = .s. 2, l, cl; $ get command name.
dsh 43 .+mc call stpc(cmdn); $ convert to primary case.
30 do i = 1 to n_cmd; $ loop to find which command.
31 dl = .len. cmdnames(i);
32 if (dl>l) dl = l; $ set length for comparison.
33 if (dl1 then $ if not starting first member.
51 put ,'member ' :mnow,a(8) ,' contains '
52 :oldlines-morg,i(8) ,' lines.' ,skip;
53 end if;
54 morg = oldlines; mnow = mnxt;
55 else $ not member line, advance sequence.
56 $ check for first line in file not member line.
57 if oldlines=1 then $ if first line not member.
58 put ,'first line not member, taken as m.0' ,skip;
59 newlines = newlines + 1;
60 if nseq=seq_l then
61 put newfile :0,i(8) ,' .=member m' ,skip;
62 else put newfile :' .=member m',a :0,i(8) ,skip;
63 end if;
64 seqno = 0; morg = 0; nmem = 1;
65 end if;
66
67 seqno = seqno + 1;
68 end if;
69
70 newlines = newlines + 1;
71 if nseq=seq_l then $ if left sequence.
72 put newfile :seqno,i(8) :t,a(72) ,skip;
73 else
74 put newfile :t,a(72) :seqno,i(8) ,skip;
75 end if;
76 end while;
77
78 put ,'member ' :mnow,a(8) ,' contains '
79 :(oldlines-morg+1),i(8) ,' lines.' ,skip;
80 return;
81
82 /err/
dsb 68 error('input/output error during creation run');
87 call updexi(1);
88 end subr create;
1 .=member cdcupd
2 .+cupd.
3 subr cdcupd(isdeck, t); $ check for cdc update directive.
4 $ check for cdc update directive in string t. if is *deck, then
5 $ set isdeck and change t to little member definition.
6 $ if other command, issue warning and proceed as follows:
7 $ *weor generate member eorn; e.g., eor1, eor2.
8 $ *cweor similar to eor.
9 $ *comdeck same as *deck
10 $ *call generate little include.
11 $
12 $ the *comdeck is used to define section of code that is later
13 $ copied out by *call. *cweor and *weor are used to denote
14 $ record positions in text and generally indicate point at
15 $ which file should be broken into separate files.
16
17 size isdeck(1); $ set if *deck line found.
18 size t(.sds. 72); $ string to check.
19 size n(ws); $ count.
20 size cui(ps); $ command index.
21 size spn(ps); $ span function.
22 size brk(ps); $ break function.
23 size i(ps); $ loop index.
24 size l(ps); $ string length.
25 size us(.sds. 8); $ name of update directive.
26 $ codes for cdc update directives.
27 +* cu_call = 1 ** $ *call
28 +* cu_comd = 2 ** $ *comdeck
29 +* cu_cweo = 3 ** $ *cweor
30 +* cu_deck = 4 ** $ *deck
31 +* cu_weor = 5 ** $ *weor
32 +* n_cu = 5 ** $ number of cdc update directives.
33
34 size cunam(.sds.8); dims cunam(n_cu); $ update names.
35 data cunam(cu_call) = 'call':
36 cunam(cu_comd) = 'comdeck':
37 cunam(cu_cweo) = 'cweor':
38 cunam(cu_deck) = 'deck':
39 cunam(cu_weor) = 'weor';
40 size cucod(ps); dims cucod(n_cu); $ action codes.
41 data cucod(cu_call) = 3:
42 cucod(cu_comd) = 1:
43 cucod(cu_cweo) = 2:
44 cucod(cu_deck) = 1:
45 cucod(cu_weor) = 2;
46
47 isdeck = no; $ assume not update directive.
48 if (.ch. 1, t ^= 1r*) return; $ if cannot be command.
dsb 69 l = brk(t, 1, ss_blank); $ break to blank.
50 if (l<4) return; $ if cannot be command.
51 if (l>8) return; $ if cannot be command.
52 us = .s. 2, 8, t;
53 .len. us = l-1;
dsh 44 .+mc call stpc(us); $ convert to primary case.
54 cui = 0; $ assume not command.
55 do i = 1 to n_cu; $ search command list.
56 if (cunam(i).sne.us) cont do; $ if no match
57 cui = i; quit do; $ if match.
58 end do;
59 if (cui=0) return; $ if not command.
60
61 put ,'process cdc update directive ''' :cunam(cui),a
62 ,''' at line ' :oldlines,i ,'.' ,skip;
63 put ,' old line' ,column(17) :t,a ,skip;
64
65 go to l(cucod(cui)) in 1 to 3;
66
67 /l(1)/ $ turn *comdeck or *deck into .=member
68 isdeck = yes; $ flag as changed deck line.
69 l = .len. cunam(cui) + 3; $ length initial part.
70 t = ' .=member ' .cc. .s. l, 40, t;
71 go to ret;
72
73 /l(2)/ $ change *cweor or *cweor to member.
74 cueors = cueors + 1;
75 isdeck = yes;
76 .s. 1, 15, t = ' .=member eor ';
77 n = cueors;
78 i = 14+(n>9)+(n>99);
79 until n=0;
80 .ch. i, t = charofdig(mod(n,10));
81 n = n / 10; i = i - 1;
82 end until;
83 go to ret;
84
85 /l(3)/ $ change *call to .=include.
86 t = ' .=include ' .cc. .s. 7, 61, t;
87 go to ret;
88 /ret/
89 put ,' new line' ,column(17) :t,a ,skip;
90 end subr cdcupd;
91 ..cupd
1 .=member scncmd
2 subr scncmd(rc); $ scan command.
3 $ scan command line for valid command arguments.
4 size rc(ws); $ return code.
5 size spn(ps); $ span function.
6 size brk(ws); $ break function.
7 size s1(.sds.1); $ string temporary.
dsb 71 size s8(.sds. 8); $ temporary string with copy name.
dsb 72 size l(ws); $ string length.
9 size del(.sds.1); $ delimiter string.
dsb 73 size ch(cs); $ character in alter strings.
dsb 74 size anyc(ps); $ function to match any character.
dsb 75 size brkc(ws); $ function to break to given character.
11 size dl(ps); $ string length.
12
13 rc = 0;
dsb 76 af = brk(cl, 1, ss_separ); $ brk to blank after command name.
dsb 77 $ span to start of arguments.
dsb 78 af = af + spn(cl, af+1, ss_separ) + 1;
16
17 go to l(cmdi) in 1 to n_cmd;
18
19 /l(c_alt)/ $ alter l1,/old/new/
20 $ scan and verify line number, collect change strings.
dsb 79 al = brk(cl, af, ss_cm); $ break to comma.
22 call verlin(rc, cl, af, al, id1, sn1); $ verify sequence spec.
23 if (rc) go to vererr;
24 af = af + al + 2; $ break out old, new strings.
dsb 80 ch = .ch. af-1, cl; if (anyc(ch, ss_separ)) go to err;
dsb 81 l = brkc(cl, af, ch); $ break to end of old.
dsb 82 if (l<0) l = 0;
27 if (l=0) go to err;
28 altold = .s. af, l, cl; af = af + l + 1;
dsb 83 l = brkc(cl, af, ch);
dsb 84 if (l<0) l = 0; $ if brkc failed, adjust length to zero.
dsb 85 al = l;
30 altnew = .s. af, al, cl;
31 go to ret;
32
33 /l(c_cop)/ $ copy n1,n2,n3.n4
34 copyptr = 0;
35 while 1; $ scan member list.
dsb 86 $ get delimiter.
dsb 87 al = brk(cl, af, ss_blank ! ss_cm ! ss_period);
37 if (al=0) go to err;
38 del = .ch. af+al, cl; $ get delimiter character.
39 countup(copyptr, copymax, 'copy1');
40 copytype(copyptr) = 0; $ assume single member copy.
41 l = al; if (l>8) l =8; $ truncate long name.
42 copylist(copyptr) = .s. af, l, cl; $ copy name.
dsh 45 .+mc. $ convert to primary case.
dsb 89 s8 = copylist(copyptr);
dsh 46 call stpc(s8);
dsb 91 copylist(copyptr) = s8;
dsh 47 ..mc
43 af = af + al + 1; $ move to start of next argument.
44 if del=1r. then $ if range copy.
45 af = af-1;
dsb 93 l = spn(cl, af, ss_period); $ allow multiple periods.
47 if (l=0) go to err;
48 af = af + l;
dsb 94 $ break to end of argument.
dsb 95 al = brk(cl, af, ss_blank ! ss_cm);
50 if (al=0) go to err;
51 l = al; if (l>8) l = 8;
52 copytype(copyptr) = 1; $ indicate multiple copy.
53 countup(copyptr, copymax, 'copy2');
54 copylist(copyptr) = .s. af, l, cl; $ copy name.
dsh 48 .+mc. $ convert to primary case.
dsb 97 s8 = copylist(copyptr);
dsh 49 call stpc(s8);
dsb 99 copylist(copyptr) = s8;
dsh 50 ..mc
55 af = af + al + 1;
56 del = .ch. af-1, cl; $ retriev delimiter.
57 end if;
58 if (del=1r ) quit while; $ if end of list.
59 end while;
60
61 go to ret;
62
63 /l(c_del)/ $ delete n1 or delete n1,n2
dsb 101 $ break out first argument.
dsb 102 al = brk(cl, af, ss_blank ! ss_cm);
65 call verlin(rc, cl, af, al, id1, sn1); $ verify specifier.
66 if (rc) go to vererr;
67 delsev = no; $ assume single delete.
68 if .ch. af+al, cl = 1r, then $ if possible multiple delete.
69 af = af + al + 1; $ position to start of second argument.
dsb 103 $ break to end of second argument.
dsb 104 al = brk(cl, af, ss_separ);
71 call verlin(rc, cl, af, al, id2, sn2); $ verify specifier.
dsg 11 if (rc) go to vererr;
72 if (sn1^=sn2 ! id1.sne.id2) delsev = yes;
73 end if;
74 go to ret;
75
76 /l(c_edi)/ $ edit n1
dsb 105 al = brk(cl, af, ss_separ); $ break out name.
78 if (al=0) go to err;
79 if (al>8) al = 8; $ truncate long name.
80 editname = .s. af, al, cl; $ copy name.
dsh 51 .+mc call stpc(editname); $ convert to primary case.
81 if list_u then $ if listing commands.
82 put ,'editing' ,column(17) :editname,a ,'.' ,skip;
83 end if;
84 go to ret;
85
86 /l(c_end)/ $end
87 go to ret;
88
89 /l(c_ins)/ $ insert l1
90 /l(c_bef)/ $ before l1
dsb 107 al = brk(cl, af, ss_separ); $ break out first argument.
92 call verlin(rc, cl, af, al, id1, sn1); $ verify specifier.
93 if (rc) go to vererr;
94 go to ret;
95
96 /l(c_mod)/ $ modname n1
dsb 108 al = spn(cl, af, ss_al); $ span name (must be all alphabetics).
98 if (al=0) go to err;
99 if (al>4) al = 4;
100 modname = .s. af, al, cl; $ get modname.
dsh 52 .+mc call stpc(modname); $ convert to primary case.
101 if list_u then $ if listing commands.
102 put ,'modname' ,column(17) :modname,a ,'.' ,skip;
103 end if;
104 go to ret;
105
106 /l(c_not)/ $ note
107 go to ret;
108
109 /ret/ $ here for normal return.
110 rc = 0; return;
111 /err/ $ here if error.
112 rc = 1; return;
113 /vererr/ $ here if cannot verify specifier.
dsb 110 error('invalid line specification ' !! cl);
119 go to err;
120 end subr scncmd;
1 .=member verlin
2 subr verlin(rc, s, sp, sl, id, sn); $ verify specification.
3 $ seek valid line specifier in the sl characters of string s
4 $ starting at position sp. if found, set id to identifier and
5 $ sn to sequence number and return with rc of zero. if invalid
6 $ return with rc nonzero. return identifier of null if supplied
7 $ identifier is same as name of member being edited.
8
9 size rc(ws); $ return code.
10 size s(.sds. 8); $ sequence field.
11 size sp(ps); $ sarting position.
12 size sl(ps); $ length of field.
13 size id(.sds.8); $ identifier part.
14 size sn(ws); $ sequence number.
15 size snf(ps); $ starting index of sequence number.
16 size snl(ps); $ length of sequence number part.
17 size idl(ps); $ length of identifier.
18 size i(ps); $ loop index.
19 size spn(ps); $ span function.
20 size brk(ps); $ break function.
21
22 if (sl=0) go to err;
23 if (sp>(.len.s)) go to err;
24 .len. id = 0; $ assume no identifier.
25 $ see if only sequence number present, as this will be
26 $ case for original line in member.
dsb 111 snl = spn(s, sp, ss_digit); $ span numerics.
28 if snl=sl then $ if only number.
29 snf = sp; go to ret;
30 end if;
dsb 112 idl = brk(s, sp, ss_period); $ break to end of identifier.
32 if ((idl=0)&(.ch.sp,s^=1r.)) go to err;
33 i = idl; if (i>8) i = 8; $ copy identifier.
34 id = .s. sp, i, s;
dsh 53 .+mc call stpc(id); $ convert to primary case.
35 if (id.seq.editname) .len. id = 0; $ if same as editname.
36 snf = sp + idl + 1; $ point to start of sequence part.
dsb 114 snl = spn(s, snf, ss_digit); $ span numerics.
38 if (snl=0) go to err;
39 if ((idl+snl+1)^=sl) go to err; $ if all not matched.
40
41 /ret/ $ here to return after converting sequence number.
42 sn = 0; snf = snf - 1;
43 do i = 1 to snl;
44 sn = sn*10 + digofchar((.ch. snf+i, s));
45 end do;
46 rc = 0; return;
47 /err/ $ here if error.
48 rc = 1;
49 end subr verlin;
1 .=member docmd
2 subr docmd(drc); $ process command.
3 size i(ps); $ loop index.
4 size n1(.sds.8), n2(.sds. 8), n(.sds.8); $ member names.
5 size rc(ws); $ return code.
6 size drc(ws); $ return code.
7 size t(.sds.72),s(.sds.8); $ text, sequence parts.
8 size mnext(.sds.8); $ getlin member name.
9 size mthis(.sds.8); $ member name.
dsd 32 size ucsid(.sds. 8); $ exands names for ucs format.
10
11 drc = 0; rc = 0;
12 go to l(cmdi) in 1 to n_cmd;
13
14 /l(c_alt)/ $ alter
15 if (editing=no) go to err;
16 call moveto(rc, id1, sn1, yes); $ move to line.
17 if (rc) go to moverr;
dsd 33 if ucsfile then $ if want ucs format.
dsd 34 put ucsfile ,'*delete ' :ucsid(id1),a ,'.' :sn1,i ,skip;
dsd 35 end if;
18 call doalt(rc);
19 if (rc) go to err;
20 call insert;
21 go to ret;
22
23 /l(c_bef)/ $ before
24 if (editing=no) go to err;
25 call moveto(rc, id1, sn1, yes); $ move to line.
26 if (rc) go to moverr;
27 i = curact; curact = no;
dsd 36 if ucsfile then $ if want ucs format.
dsd 37 put ucsfile ,'*before ' :ucsid(id1),a ,'.' :sn1,i ,skip;
dsd 38 end if;
28 call insert;
29 curact = i; $ restore state of saved line.
30 go to ret;
31
32 /l(c_cop)/ $ copy
33 call endedt; $ end possible prior edit.
34 if (cpyall) go to ret; $ no need if copying all members.
35 if (docopy=no) go to ret; $ if not doing copies.
36 do i = 1 to copyptr;
37 $ set last member to first unless range copy.
38 n1 = copylist(i);
39 n2 = n1; $ assume single copy.
40 if copytype(i) then $ if multiple copy.
41 i = i + 1;
42 n2 = copylist(i); $ get name of last member.
43 end if;
44 n = n1;
45 while 1; $ copy entries.
46 call cpymem(rc, n, mnext);
47 if (rc>1) quit do; $ if end.
48 if (n.seq.n2) quit while; $ if copy done.
49 n = mnext;
50 end while;
51 if (rc>1) then go to enderr; end if; $ if end.
52 if (rc^=1) go to moverr; $ if not at end of member.
53 end do;
54 editing = no;
55 if (rc=2) then go to enderr; end if; $ if end.
56 go to ret;
57
58 /l(c_del)/ $ delete
59 if (editing=no) go to err;
60 call moveto(rc, id1, sn1, yes); $ move to first line.
61 if (rc) go to moverr;
62 curact = no; $ delete line.
63 if (list_d) call putlst(0, curtxt, curseq);
64 if delsev then $ if multiple delete.
65 call moveto(rc, id2, sn2, no); $ move to last line.
66 if (rc) go to moverr;
67 if (list_d) call putlst(0, curtxt, curseq);
68 end if;
dsd 39
dsd 40 if ucsfile then $ if want ucs format.
dsd 41 put ucsfile ,'*delete ' :ucsid(id1),a ,'.' :sn1,i;
dsd 42 if delsev then $ if multiple delete.
dsd 43 put ucsfile ,',' :ucsid(id2),a ,'.' :sn2,i;
dsd 44 end if;
dsd 45 put ucsfile ,skip;
dsd 46 end if;
dsd 47
69 call insert;
70 go to ret;
71
72 /l(c_edi)/ $ edit
73 call endedt; $ end possible prior edit.
74 call movmem(rc, editname); $ move to member.
75 if (rc^=1) go to enderr;
76 call getlin(rc, 1, mnext, curtxt, curseq); $ get definition line.
77 if (rc>1) go to enderr;
78 editing = yes;
79 if im_l then $ if identifying members.
80 if im_e then $ if want to identify this member.
81 call seqnam(editname);
82 else call seqnam(''); $ else clear name.
83 end if;
84 end if;
85 call brkseq(rc, curseq, curid, cursn); $ break sequence field.
86 curact = 2; $ note at member definition line.
dsd 48 if ucsfile then $ if want ucs format.
dsd 49 put ucsfile ,'*compile ' :editname,a ,skip;
dsd 50 end if;
87 go to ret;
88
89 /l(c_end)/ $ end
90 cmdend = yes; go to ret;
91
92 /l(c_ins)/ $ insert
93 if (editing=no) go to err;
94 call moveto(rc, id1, sn1, yes); $ move to line.
95 if (rc) go to moverr;
dsd 51 if ucsfile then $ if want ucs format.
dsd 52 put ucsfile ,'*insert ' :ucsid(id1),a ,'.' :sn1,i ,skip;
dsd 53 end if;
96 call insert;
97 go to ret;
98
99 /l(c_mod)/ $ modname
100 seqno = 0; $ reset sequence number.
dsd 54 if ucsfile then $ if want ucs format.
dsd 55 put ucsfile ,'*ident ' :modname,a ,skip;
dsd 56 end if;
101 go to ret;
102
103 /l(c_not)/ $ note
dsd 57 if ucsfile then $ if want ucs format.
dse 10 put ucsfile ,'*' ,'/ ' :(.s. 1, 69, cl),a ,skip;
dsd 59 end if;
104 go to ret;
105
106 /ret/ $ normal termination.
107 drc = 0; return;
108 /enderr/ $ here if either end of file or error.
109 if (rc=3) go to err;
110 drc = 2; return;
111 /err/ $ here if error.
112 terml(yes);
113 put ,'error processing command' ,skip;
dsf 9 $ copy command line to terminal.
dsf 10 call contlpr(26, no); $ turn off listing, as line has been listed.
dsf 11 put ,x :cl,a ,skip;
dsf 12 call contlpr(26, yes); $ resume listing.
114 terml(no);
115 drc = 1;
116 return;
117 /moverr/ $ here if error during move.
dsf 13 error('unable to find line in member ' .cc. editname);
122 drc = 1;
123 end subr docmd;
1 .=member ucsid
2 fnct ucsid(id); $ return expanded ident name.
3 size id(.sds. 8); $ ident name (null if current member)
4 size ucsid(.sds. 8); $ expanded name
5
6 $ if id is null return current member name, else return id.
7 if .len. id = 0 then $ if need member name.
8 ucsid = editname;
9 else ucsid = id;
10 end if;
11 end fnct ucsid;
1 .=member doalt
2 subr doalt(rc); $ do alter.
3 $ change instance of oldalt (which must occur) to string
4 $ given by newalt. report error if line truncation.
5 $ doalt is separate procedure to simplify addition of
6 $ more powerful string editing/alteration facilities.
7
8 size rc(ws); $ return code.
9 size c(cs); $ character temporary.
10 size i(ps); $ loop index.
11 size nl(ps); $ length of new line.
12 size newtxt(.sds.72); $ new text.
13 size l(ps); $ string length.
14 size rp(ps); $ starting point of string remainder.
15 size rl(ps); $ length of trailing part.
16
17 if list_a then $ list line before alter
18 call putlst(0, curtxt, curseq);
19 end if;
20 i = altold .in. curtxt; $ look for instance of old.
21 if (i=0) go to err; $ if required instance not found.
22 newtxt = curtxt; $ copy current text.
23 nl = i - 1; $ set length new text.
24 rp = i + (.len. altold); $ starting position of string rest.
25 l = .len. altnew; $ set length of subsitution string.
26 if ((nl+l)>72) go to err; $ if new string too long.
27 .s. nl+1, l, newtxt = altnew; $ do substitution.
28 nl = nl + l; $ adjust new string length.
29 if nl+1>rp then $ if possible truncation.
30 rl = 73 - rp; $ trim trailing blanks.
31 do i = 72 to rp by -1;
32 if (.ch.i,curtxt ^= 1r ) quit do;
33 rl = rl - 1;
34 end do;
35 if ((nl+rl)>72) go to err; $ if truncation.
36 end if;
37 if nl<72 then $ if need to copy trailing part.
38 .s. nl+1, 72-nl, newtxt = .s. rp, 73-rp, curtxt; $ copy rest.
39 end if;
40 curtxt = newtxt;
41 call genseq(curseq); $ generate sequence field.
42 call putlin(curtxt, curseq);
dsd 60 if ucsfile then $ if want ucs format.
dsd 61 put ucsfile :curtxt,a ,skip;
dsd 62 end if;
43 curact = no;
44 if list_a then $ list line after alter.
45 call putlst(1, curtxt, curseq);
46 end if;
47 rc = 0;
48 return;
49 /err/
50 rc = 1;
51 end subr doalt;
1 .=member brkseq
2 subr brkseq(rc, s, id, sn); $ break out sequence info.
3 $ break out identifier id and sequence number sn from
4 $ sequence field s. set to rc to zero for normal return,
5 $ else set rc nonzero if s not valid sequence field (in
6 $ which case id and sn are not altered).
7
8 size rc(ws); $ return code.
9 size s(.sds. 8); $ sequence field.
10 size id(.sds.8); $ identifier part.
11 size sn(ws); $ sequence number.
12 size idl(ps); $ identifier length.
13 size sb(ps); $ number of starting blanks.
14 size ib(ps); $ number of intermediate blanks.
15 size tb(ps); $ number of trailing blanks.
16 size snf(ps); $ starting index of sequence number.
17 size snl(ps); $ length of sequence number.
18 size i(ps); $ loop index.
19 size brk(ps); $ span function.
20 size spn(ps); $ span function.
21
22 rc = 0; $ assume normal return.
23 idl = 0; $ assume no identifier.
dsb 116 sb = spn(s, 1, ss_blank); $ span initial blanks.
25 if (sb=8) go to err; $ error if all blanks.
26 $ assume no identifier, see if just sequence.
dsb 117 snl = spn(s, sb+1, ss_digit); $ span digits.
28 if snl then $ if number field.
29 snf = sb+1; $ starting index of sequence field.
30 if (sb+snl)<8 then $ if required trailing blanks.
dsb 118 tb = spn(s, snf+snl, ss_blank); $ span blanks.
32 if (snf+snl+tb ^= 9) go to err;
33 end if;
34 go to ret;
35 end if;
36 $ here if identifier.
dsb 119 idl = spn(s, sb+1, ss_al); $ span identifier.
38 if (idl=0) go to err;
dsb 120 $ span possible intervening blanks.
dsb 121 ib = spn(s, sb+idl+1, ss_blank);
40 snf = sb + idl + ib + 1; $ $ set starting index.
41 if (snf>8) go to err;
dsb 122 snl = spn(s, snf, ss_digit); $ span digits.
43 if (snl=0) go to err; $ if no sequence field.
dsb 123 tb = spn(s, snf+snl, ss_blank); $ span blanks.
45 if ((snf+snl+tb) ^= 9) go to err; $ if illformed.
46
47 /ret/ $ here to convert sequence number.
48 if idl then $ if identifier.
49 id = .s. sb+1, idl, s;
50 else .len. id = 0; $ if no identifier.
51 end if;
52 sn = 0; snf = snf - 1;
53 do i = 1 to snl;
54 sn = sn*10 + digofchar((.ch. snf+i, s));
55 end do;
56 return;
57 /err/ $ here if error.
58 rc = 3;
59 end subr brkseq;
1 .=member moveto
2 subr moveto(rc, id, sn, act); $ move to line.
3 $ move edit file to line id.sn, copying intervening lines
4 $ if act nonzero. set status of line to act.
5
6 size rc(ws); $ return code.
7 size id(.sds. 8); $ desired identifier.
dsi 9 .+mc size idf(.sds. 8); $ desired identifier (folded).
dsi 10 .+mc size curidf(.sds. 8); $ current identifier (folded).
8 size sn(ws); $ sequence number.
9 size act(1); $ on to copy lines.
10 size avail(ps); $ on if line available.
11 size brc(ws); $ return code.
12 size mname(.sds. 8); $ next member name.
13 size gotline(1); $ on if have line.
14
15 if (editing=no) return;
16 avail = curact; $ set if current line active.
dsi 11 .+mc.
dsi 12 $ convert to primary case for search.
dsi 13 idf = id;
dsi 14 call stpc(idf);
dsi 15 ..mc
dsi 16
17 gotline = (curact = 1);
18 curact = no; gotline = no;
19 while 1;
20 if avail then $ if current line may be desired one.
21 if cursn=sn then $ if found.
dsi 17 .-mc if curid.seq.id then $ if same name.
dsi 18 .+mc.
dsi 19 $ if mixed case, fold non-null identifier from opl.
dsi 20 if .len. curid = 0 then $ if null
dsi 21 .len. curidf = 0; $ just reassign length.
dsi 22 else $ else convert to primary case.
dsi 23 curidf = curid;
dsi 24 call stpc(curidf);
dsi 25 end if;
dsi 26 if curidf .seq. idf then $ if same name.
dsi 27 ..mc
23 curact = act;
24 rc = 0;
25 return;
26 end if;
27 end if;
28 $ here if line at hand that may need writing.
29 if act then
30 if (avail=1)!(avail=2&cpydef) then
31 call putlin(curtxt, curseq);
32 end if;
33 else
34 if gotline&list_d then
35 call putlst(0, curtxt, curseq);
36 end if;
37 end if;
38 end if;
39 call getlin(rc, 0, mname, curtxt, curseq); $ get next line.
40 if (rc) go to err;
41 call brkseq(brc, curseq, curid, cursn); $ get sequence.
42 if (brc) go to err;
43 gotline = yes;
44 avail = 1; $ note line available.
45 end while;
46 return;
47 /err/ $ here if error.
48 rc = 1;
49 end subr moveto;
1 .=member insert
2 subr insert; $ do text insertion.
3 $ copy non-commands in command file as new text, adding
4 $ generated sequence numbers.
5
6 size rc(ws); $ return code.
7 size t(.sds.72),s(.sds.8); $ text, sequence part.
8
9 rc = 0;
10 if (.len.modname=0) then $ if no modname yet seen.
dsb 124 terml(yes);
dsb 125 .+s10 put :37,r(1); $ issue s10 percent warning character.
11 put,'***warning*** missing modname, use -mo-',skip;
dsb 126 terml(no);
12 modname = 'mo';
13 end if;
14
15 if editing=no then $ if cannot insert.
16 error('attempt insert while not editing.');
17 $i skip to next non-command.
18 while 1;
19 call getcmd(rc, t, s);
20 if (rc=2) return;
21 if (rc) go to err;
22 if (.ch. 1, t ^= 1r-) cont while;
23 keepcmd = yes; $ keep command.
24 end while;
25 go to err;
26 end if;
27
28 $ here to possibly write out current line if active.
29 if curact=1 ! (curact=2&cpydef) then
30 call putlin(curtxt, curseq); $ put defining line.
31 end if;
32 curact = no;
33
34 while 1; $ copy out non-commands.
35 call getcmd(rc, t, s);
36 if (rc) quit while;
37 if .ch. 1, t = 1r- then keepcmd=yes; quit while; end if;
38 call genseq(s); $ generate new sequence field.
dsd 63 if ucsfile then $ if want ucs format.
dsd 64 put ucsfile :t,a ,skip;
dsd 65 end if;
39 call putlin(t, s); $ write new line.
40 if list_i then $ if listing inserts.
41 call putlst(1, t, s);
42 end if;
43 end while;
44 return;
45 /err/ rc = 1;
46 end subr insert;
1 .=member genseq
2 subr genseq(s); $ generate new sequence field.
3 $ generate new sequence field.
4 size s(.sds. 8); $ sequence field.
5 size n(ws); $ working value.
6 size d(ps); $ temporary.
7 size i(ps); $ position.
8 size l(ps); $ position.
9
10 s = ''.pad. 8; .s. 1, (.len. modname), s = modname;
11 seqno = seqno + 1; $ advance sequence number.
12 n = seqno; l = .len. modname;
13 i = 8; $ rightmost postion.
14 until n=0; $ until sequence number converted.
15 d = mod(n, 10);
16 .ch. i, s = charofdig(d); $ store converted char.
17 i = i - 1; n = n / 10;
18 if (i=0) quit until;
19 end until;
20
21 if i8) ml = 8;
30 mnam = .s. mf, ml, t; $ enter member name.
dsh 55 .+mc call stpc(mnam); $ convert name to primary case.
31 end subr chkmem;
1 .=member getcmd
2 subr getcmd(rc, t); $ get command line.
3 $ get next line from standard input file.
4 size rc(ws); $ return code.
5 size t(.sds. 72), s(.sds.8); $ text, sequence parts.
6 size cmds(.sds. 8);
7 size txt(.sds.72); $ text string.
8
9 if cmdend then rc = 2; return; end if; $ if end seen.
10 if keepcmd then $ if previous line to be returned.
11 t = txt; s = cmds; rc =0; keepcmd = no;
12 return;
13 end if;
14
15 get ,skip :txt,a(72); t = txt;
16 cmds = '' .pad. 8;
17 if (filestat(1,end)!filestat(1,err)) then
18 rc = 2; cmdend = yes;
19 else rc = 0; end if;
20 end subr getcmd;
1 .=member cpyrst
2 subr cpyrst(rc); $ copy rest of file if full mode.
3 size rc(ws); $ return code.
4 size t(.sds.72),s(.sds.8); $ sequence, text parts.
5 size mthis(.sds.8); $ name of current member.
6 size mnext(.sds.8); $ name of next member.
7
8 call endedt;
9 if (cpyall=no) return;
10 if (oldend) return; $ if end of old already seen.
11 call getlin(rc, 0, mthis, t, s); $ get member def. line.
12 if (rc^=1) then $ error if not at member line.
13 error('cpyrst not at member line');
14 rc = 3; return;
15 end if;
16
17 while 1;
18 call cpymem(rc, mthis, mnext); $ copy member.
19 if (rc>1) quit while; $ if end seend.
20 mthis = mnext; $ set name of next member.
21 end while;
22 rc = 0;
23 end subr cpyrst;
1 .=member endedt
2 subr endedt; $ end edit if editing active.
3 $ if editing, copy out rest of member.
4 size rc(ws); $ return code.
5 size mnext(.sds.8); $ name of next member.
6
7 if (editing=no) return;
8 $ copy current line if active.
9 if (curact=1)!(curact=2 & cpydef) then
10 call putlin(curtxt, curseq); $ put line.
11 end if;
12 call movend(rc, mnext, yes); $ move to end of member.
13 editing = no;
14 end subr endedt;
1 .=member cpymem
2 subr cpymem(rc, mthis, mnext); $ copy member mthis.
3 $ copy member mthis and set mnext to name of next member.
4 size rc(ws); $ return code.
5 size mthis(.sds. 8); $ name of member to copy.
6 size mnext(.sds. 8); $ name of next member.
7 size t(.sds. 72), s(.sds. 8); $ text, sequence parts.
8
9 if list_c then $ if listing copies.
10 put ,'copying' ,column(17) :mthis,a ,'.' ,skip;
11 end if;
12 call movmem(rc, mthis); $ move to member.
13 if (rc^=1) return;
14 if im_c & (im_l>0) then $ if identifying this member.
15 call seqnam(mthis);
16 end if;
17 call getlin(rc, 1, mnext, t, s); $ get member name.
18 if (rc>1) return; $ if end or error.
19 if (cpydef) call putlin(t, s); $ if want defining line.
20 call movend(rc, mnext, yes); $ copy rest of member.
21 end subr cpymem;
1 .=member movmem
2 subr movmem(rc, mwant); $ move to start of member.
3 size rc(ws); $ return code.
4 size mwant(.sds. 8); $ name of member.
5 size t(.sds. 72), s(.sds. 8); $ text, sequence parts.
6 size mnext(.sds. 8); $ name of next member.
7 size mname(.sds. 8); $ member name.
8
9 call movend(rc, mnext, cpyall); $ copy to end of current member.
10 if (rc>1) return; $ if end or error.
11
12 while 1;
13 if mnext.seq.mwant then $ if desired member found.
14 rc = 1; return;
15 end if;
16 if cpyall then $ if copying all members, copy this one.
17 call getlin(rc, 1, mname, t, s); $ get defining line.
18 if (im_l) call seqnam(''); $ reset im name.
19 if (cpydef) call putlin(t, s); $ if want defining line.
20 call movend(rc, mnext, yes); $ copy rest.
dse 11 if (rc>1) quit while; $ if end seen.
21 else $ here to skip to end of this member.
22 call getlin(rc, 2, mnext, t, s);
23 if (rc^=1) quit while;
24 end if;
25 end while;
26 rc = 2;
dsb 134 error('unable to locate member ' !! mwant);
31 end subr movmem;
1 .=member movend
2 subr movend(rc, mnext, cpy); $ move to end of member.
3 $ move to initial part of next member, copying intervening
4 $ lines if cpy nonzero. set mnext to name of next member.
5
6 size rc(ws); $ return code.
7 size mnext(.sds. 8); $ name of next member.
8 size mname(.sds. 8); $ member name.
9 size cpy(1); $ on to copy.
10
11 size t(.sds. 72), s(.sds. 8); $ sequence, text parts.
12
13 size grc(ws); $ getlin return code.
14 .len. mnext = 0;
15 call getlin(grc, 0, mname, t, s); $ get line.
16 if (grc>1) go to enderr; $ if end or error.
17 while grc=0; $ move to end of member.
18 if (cpy) call putlin(t, s); $ if copying member.
19 call getlin(grc, 0, mname, t, s);
20 if (grc>1) go to enderr;
21 end while;
22 assert grc=1;
23 if (im_l) call seqnam(''); $ clear im name.
24 mnext = mname; rc = grc;
25 return;
26 /enderr/ $ here if end or error on old file.
27 rc = grc;
28 end subr movend;
1 .=member getlin
2 subr getlin(rc, fc, mname, t, s); $ get line from old file.
3 /* read line from old file according to status of getrc and
4 function code fc, as follows:
5 getrc fc action
6 0 0 read line, check for member line.
7 0 1 set getrc=3 and return.
8 0 2 skip to next line that begins member, then
9 set getrc=1 and return member name in mname.
10
11 1 0 return member name in mname.
12 1 1 return saved t, s; set getrc=0.
13 1 2 skip to next line that begins member, then
14 set getrc=1 and return member name in mname.
15
16 2 - return getrc.
17 3 - return getrc.
18
19 for random files mode,
20 (rc=1,fc=2) is request to set rc=1 and return name
21 of next member; (rc=0,fc=2) returns name of next member.
22
23 */
24 size rc(ws); $ return code.
25 size fc(ps); $ function code.
26 size t(.sds. 72), s(.sds. 8); $ text, sequence parts.
27 size nrc(ws); $ getnxt return code.
28 size mnext(.sds. 8); $ name of next member.
29 size mname(.sds. 8); $ member name.
30 size ot(.sds. 72), os(.sds. 8); $ saved text, sequence parts.
31
32 if getrc>1 then rc = getrc; return; end if;
33
34 if fc=0 then $ if normal read request.
35 if getrc=0 then $ if not at member line.
36 call getnxt(nrc, mnext, t, s); $ get next line.
37 if (nrc>1) then getrc=nrc; go to ret; end if;
38 if nrc=1 then $ if member line.
39 ot = t; os = s; $ save line.
40 getrc = 1; $ indicate at member line.
41 go to retmem; $ return member name.
42 else getrc=0; go to ret; $ if not member line.
43 end if;
44 else go to retmem; $ else return name of next member.
45 end if;
46 elseif fc=1 then
47 if getrc=0 then getrc=3; go to ret;
48 else $ return saved line.
49 t = ot; s = os; getrc = 0; go to ret;
50 end if;
51 elseif fc=2 then $ if want to skip to next member.
52 while 1;
53 call getnxt(nrc, mnext, ot, os); $ read line.
54 if nrc>1 then getrc = nrc; go to ret; end if;
55 if (nrc=1) go to retmem;
56 end while;
57 else error('invalid getlin function code');
58 getrc = 3; go to ret;
59 end if;
60 /retmem/ $ here to return member name.
61 getrc = 1; rc = getrc; $ set return codes.
62 mname = mnext; $ copy member name.
63 return;
64 /ret/ $ normal return.
65 rc = getrc; return;
66 /err/
67 error('getlin error');
68 getrc = 3; rc = getrc;
69 end subr getlin;
1 .=member getnxt
2 subr getnxt(rc, mname, t, s); $ get next line from old file.
3 $ read next line from old file. set t,s to text and
4 $ sequence parts. if line begins member, set rc to one and
5 $ set mname to member name.
6
7 size rc(ws); $ return code.
8 size mname(.sds. 8); $ member name.
9 size t(.sds. 72), s(.sds. 8); $ sequence, text parts.
10 size ot(.sds. 72), os(.sds. 8); $ saved sequence, text parts.
11 size mn(.sds. 8); $ member name.
12
13 if oldend then rc = 2; return; end if; $ if at end of old.
14
15 if pseq=seq_l then $ if sequence at left.
16 get oldfile ,skip :s,a(8) :t,a(72);
17 elseif pseq=seq_r then $ if sequence at right.
18 get oldfile ,skip :t,a(72) :s,a(8);
19 else $ if no sequence.
20 get oldfile ,skip :t,a(72); s = ''.pad.8;
21 end if;
22 if filestat(oldfile,end)>0 ! filestat(oldfile,err)>0 then
23 oldend = yes; rc = 2; return;
24 end if;
25
26 oldlines = oldlines + 1;
27 call chkmem(mn, t); $ see if member line.
28 if .len. mn then $ if member line.
29 mname = mn; rc = 1;
30 else rc = 0; end if;
31 end subr getnxt;
1 .=member putlin
2 subr putlin(t, sa); $ put line to new file.
3 size t(.sds. 72), sa(.sds. 8); $ text, sequence parts.
4 size s(.sds. 8); $ sequence field.
5 size spn(ps); $ span function.
6 size l(ps); $ string length.
7
dsj 12 size shrink(1); $ function to check for discard.
dsj 13
dsj 14 if shrink_opt then
dsj 15 if (shrink(t)) return;
dsj 16 end if;
dsj 17
8 s = sa; $ copy sequence field.
9 until 1; $ process possible im option.
10 if (im_l=0) quit until; $ if no im option.
11 if ((.len. im_name) = 0) quit until;
dsb 135 l = spn(s, 1, ss_blank); $ count initial blanks.
13 if (l<3) quit until; $ if no room for name.
14 if (l=8) quit until; $ if no room for name.
15 $ if first nonblank not numeric, is already identified.
dsb 136 if (spn((.s. l+1, 1, s), 1, ss_digit) = 0) quit until;
17 .s. 1, l-1, s = im_name; $ substitute name part.
18 end until;
19
20 if nseq=seq_n then $ if no sequence.
21 put newfile :t,a ,skip;
22 elseif nseq=seq_l then $ if left sequence.
23 put newfile :s,a(8) :t,a ,skip;
24 else $ if right sequence.
25 put newfile :t,a(72) :s,a(8) ,skip;
26 end if;
27 newlines = newlines + 1;
28 end subr putlin;
1 .=member shrink
2 fnct shrink(iline);
3 $ determine if text can be discarded.
4 $ lines to be ignored are indicated by returning 1.
5 $
6 $ discard blank lines
7 $ discard comments (lines with dollar sign as first
8 $ non-blank character)
9 $
10 $ input linesize of 72 is assumed.
11 $
12
13
14 size iline(.sds. 72); $ input line
15 size nlb(ws); $ number of leading blanks.
16 size spns(ws); $ character span function
17 size shrink(1); $ return value, set for discard.
18
19
20
21
22
23 if .len. iline = 0 then
24 shrink = yes;
25 elseif .ch. 1, iline = 1r$ then $ if initial comment
26 shrink = yes;
27 else
28 nlb = spns(iline, 1, ss_separ); $ count initial blanks.
29 $ process all blank lines.
30 if nlb=-1 then $ if no leading separators.
31 shrink=no;
32 elseif nlb=72 then
33 shrink = yes;
34 elseif (.ch. nlb+1,iline = 1r$ ) then
35 shrink = yes;
36 else shrink = no;
37 end if;
38 end if;
39 end fnct;
1 .=member seqnam
2 subr seqnam(s); $ generate identifying member name.
3 $ if im option enabled, set im name to s.
4 size s(.sds. 8); $ desired name.
5 size l(ps); $ string length.
6
7 if (im_l=0) return; $ if im option disabled.
8 l = .len. s; if (l>im_l) l = im_l;
9 .len. im_name = 0; if (l=0) return;
10 im_name = .s. 1, l, s;
11 end subr seqnam;
1 .=member brk
dsb 137 fnct brk(s, sp, ss); $ return span string length.
3 $ return length of longest string of s, starting at sp-th
4 $ character, which is followed by character in char vector cv.
5 size s(.sds. 10); $ string to search.
6 size sp(ps); $ starting position.
dsb 138 size ss(ws); $ character vector.
8 size brk(ps); $ result.
dsb 139 size brks(ws); $ result.
12
dsb 140 brk = brks(s, sp, ss);
dsb 141 if (brk<0) brk = 0;
24 end fnct brk;
1 .=member spn
dsb 142 fnct spn(s, sp, ss);
3 $ return length of longest string of s, starting at sp-th
4 $ character, which consists of characters in char vector cv.
5 size s(.sds. 10); $ string to search
6 size sp(ps); $ starting index
dsb 143 size ss(ws); $ character vector.
8 size spn(ps); $ result.
dsb 144 size spns(ps); $ functin to span string.
12
dsb 145 spn = spns(s, sp, ss);
dsb 146 if (spn<0) spn = 0;
22 end fnct spn;
1 .=member upderr
2 subr upderr(txt); $ report error.
dsb 147 size txt(.sds. 120); $ error message.
4
5 nerrors = nerrors + 1;
6 terml(yes);
dsb 148 .+s10 put :63,r(1); $ issue s10 question mark error character.
7 put ,'***error*** ' :txt,a ,skip;
dsf 14 call contlpr(26, no); $ do not copy to listing.
dsf 15 put ,x :cl,a ,skip;
dsf 16 call contlpr(26, yes); $ resume listing.
8 terml(no);
10 call updexi(1);
11 end subr upderr;
1 .=member putlst
2 subr putlst(act, txt, seq);
3 size act(ps); $ nonzero if line inserted.
4 size txt(.sds. 72); $ text part.
5 size seq(.sds. 8); $ sequence part.
6 size acttyp(cs); dims acttyp(2); $ activity type.
7 data acttyp = 1r-, 1r+;
8
9 put ,x(2) :seq,a(8) :acttyp(act+1),r(1) :txt,a(72) ,skip;
10 ninsert = ninsert + act; $ increment if line added.
11 ndelete = ndelete + (1-act); $ increment if line deleted.
12 end subr putlst;
1 .=member updexi
2 subr updexi(c); $ upd exit procedure.
3 size c(ps); $ completion code, nonzero if abnormal.
dsh 56 size termcode(ws); $ termination code.
4 .+s66 rewind newfile;
5 if nerrors then $ if errors detected.
6 terml(yes);
7 put ,skip :nerrors,i ,' errors detected.' ,skip;
8 terml(no);
9 end if;
10 if list_p then
11 terml(yes);
12 put ,skip;
13 put ,'lines ';
14 if (oldlines) put ,' read=' :oldlines,i ;
15 if (newlines) put ,' written=' :newlines,i ;
16 if (ninsert) put ,' inserted=' :ninsert,i ;
17 if (ndelete) put ,' deleted=' :ndelete,i ;
18 put ,'.' ,skip;
19 terml(no);
20 end if;
dsh 57 .-unix.
21 put ,'end of upd run.' ,skip;
dsh 58 ..unix
dsh 59
dsh 60 $ determine termination code.
dsh 61
dsh 62 termcode = 0;
dsh 63 if (nwarnings) termcode = 4;
dsh 64 if (nerrors) termcode = 8;
dsh 65
dsh 66 call ltlfin(c, termcode);
23 end subr updexi;