Views
Document Actions
UPD: Source maintenance program. By David Shields.
by
Paul McJones
—
last modified
2021-03-17 19:56
- History
-
Action Performed by Date and Time Comment Publish Paul McJones 2021-03-17 19:56 No comments.
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.