diff --git a/RC-Ron-Brody/RC.alg_m b/RC-Ron-Brody/RC.alg_m index 9870a88..c542300 100644 --- a/RC-Ron-Brody/RC.alg_m +++ b/RC-Ron-Brody/RC.alg_m @@ -1,4098 +1,4098 @@ -?execute object/reader -?common=3 -?file newtape = symbol/rcsy94 serial -?data card - r / c -- a multi user remote/card. 00000500 - written by ron brody; burroughs corp.; paoli, pa. 215-ni4-4700 x219 00001000 -begin 00001500 - define version = 94#; % november 18, 1971. 00002000 - define maxusers = 8#, maxuser = 7#; 00002500 - define chrsperbuffer = 56 #, % or 28 00002600 - wordsperbuffer = 8#, % or 5 00002700 - wdsperbuffer = 7# ; % or 4 00002800 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00003000 -alpha file in twxinput 14 (maxuser + maxuser, 8); 00003500 -alpha file out twxoutput 14 (maxusers, wordsperbuffer) ; 00004000 -define twxout = twxoutput (stationi, 0)# ; 00008500 -array pretank [0 : 3], 00009500 - buffers [0 : maxusers, 0 :44] ; 00010000 -define buffer [buffer1] = buffers [user, buffer1]#, 00010200 - bloc = buffer [29]#, 00010300 - buff [buff1] = buffers [maxusers, buff1]# ; 00010400 -integer array readyq [0 : maxusers] ; 00011000 -define rattleindex = readyq [maxusers]# ; 00011500 -integer user, 00012000 - user32, 00012200 - clock, 00013000 - readyqtop, 00013500 - nextclock, 00014500 - tink, 00015000 - bigbird ; 00016000 -boolean globalbool ; 00016500 -define 00017000 - tankedoutput = globalbool . [47 : 1]#, 00017010 - outputready = (globalbool)#, 00017020 - q = globalbool . [46 : 1]#, 00017100 - locked = globalbool . [45 : 1]#, 00017200 - xlocked = globalbool . [44 : 1]#, 00017210 - ylocked = globalbool . [43 : 1]#, 00017220 - qinput = globalbool . [42 : 1]#, 00017300 - errtog = globalbool . [1 : 1]#; 00017500 -array input [0 : 14] ; 00018000 -define t0 = input [10]#, 00018100 - t1 = input [11]#, 00018200 - tn = input [12]#, 00018300 - freehead = input[13]#, 00018400 - maxfreehead = input[14]# ; 00018500 -define chrs = buffer [30]#, 00019000 - nchrs = buffer [31]#, 00019100 - usercodei = buffer [32]#, 00019500 - stationi = buffer [33]#, 00020000 - breaki = buffer [34]#, 00020500 - abnormalend = buffer [35]#, 00020600 - inreadyq = buffer [36]#, 00020700 - firstchance = buffer [37]#, 00020710 - ilfcri = buffer [38]#, 00020800 - translatei = buffer [39]#, 00020900 - headi = buffer [40]#, 00021000 - timei = buffer [41]#, 00021100 - taili = buffer [42]#, 00021500 - sloti = buffer [43]#, 00022000 - block = buffer [44]#, 00022100 - counti = buffer [0]# ; 00022500 -alpha array record [0 : 9] ; 00023000 -real array linklists [0 : 32 | maxusers - 1, 0 : 255] ; 00023500 -define timex = time (1)#, 00023600 - first = linklists [user32, 0]#, 00023800 - last = linklists [user32, 1]#, 00023900 - leftside = [35 : 5]#, 00024000 - rightside = [40 : 8]#, 00024500 - ll [ll1] = 00025000 - linklists [(tink := ll1).leftside + user32, tink.rightside]#, 00025500 - s = [1 : 21]#, 00026000 - sf = 1 : 27 : 21#, 00026500 - f = [22 : 13]#, 00027000 - ff = 22 : 35 : 13#, 00027500 - t = [35 : 13]#, 00028000 - tf = 35 : 35 : 13#, 00028500 - infinity = 2097151#, %maximum sequence number = 2*21-1. 00029000 - finity = 2097160#, 00029010 - maxfilelength = 8191# ;% = 2*13-1. 00029500 -define modify (modify1) = 00029700 - modified := modified or two ((modify1).leftside)# ; 00029800 -define waitflag = bool . [47 : 1]#, waiting = (bool)#, 00030500 - inlinetog = bool . [46 : 1]#, 00031000 - extralfcr = bool . [45 : 1]#, 00031500 - executeecho = bool . [44 : 1]#, 00032000 - translating = bool . [43 : 1]#, % initially on 00032500 - xecho = bool . [42 : 1]#, 00033000 - num1 = bool . [36 : 2]#, 00035000 - num2 = bool . [34 : 2]#, 00035500 - num3 = bool . [32 : 2]#, 00036000 - num4 = bool . [30 : 2]#, 00036500 - empty1 = bool . [36 : 1]#, 00037500 - empty2 = bool . [34 : 1]#, 00038000 - empty3 = bool . [32 : 1]#, 00038500 - empty4 = bool . [30 : 1]#, 00039000 - nostar = bool . [29 : 1]#, 00039500 - moreinput = bool . [23 : 1]#, 00042500 - notfirstinput = bool . [22 : 1]#, 00043000 - inlineecho = bool . [21 : 1]#, % initially on 00043010 - changeecho = bool . [20 : 1]#, 00043020 - editecho = bool . [19 : 1]#, 00043030 - copyclobber = bool . [18 : 1]#, 00043040 - dittoclobber = bool . [17 : 1]#, 00043050 - temptog = bool . [16 : 1]#, 00043060 - tabon = bool . [15 : 1]#, % initially on 00043070 - columns = bool . [12 : 1]#, 00043100 - inorder = bool . [1 : 1]#, 00043500 - initialbool = boolean ("44000+")# ; 00043600 -array controls [0 : 90] ; 00043700 -define vn = controls [89]#, 00043800 - stringi = controls [88]#, 00043900 - stringid = controls [87]#, 00044000 - stringileft = controls [86]#, 00044100 - stringirepeat = controls [85]#, 00044200 - stringj = controls [84]#, 00044300 - stringjd = controls [83]#, 00044400 - stringjleft = controls [82]#, 00044500 - stringjrepeat = controls [81]#, 00044600 - character = controls [80]#, 00044700 - maxcolstop = controls [79]#, 00044800 - colstops = controls [78]#, 00044900 - colstop4 = controls [77]#, 00045000 - colstop3 = controls [76]#, 00045100 - colstop2 = controls [75]#, 00045200 - colstop1 = controls [74]#, 00045300 - colstop [colstop1] = controls [73 + colstop1]#, 00045400 - relativenumber = controls [73]#, 00045500 - string = controls [30]# ; % - controls [37] 00046000 -real parameter0, % controls [38] 00046610 - parameter1, % controls [39] 00046620 - parameter2, % controls [40] 00046630 - parameter3, % controls [41] 00046640 - parameter4, % controls [42] 00046650 - usercode, % controls [43] 00046700 - station, % controls [44] 00046800 - prefix, % controls [45] 00046900 - suffix, % controls [46] 00047000 - macrolibrary ; % controls [47] 00047100 -boolean modified ; % controls [48] 00047200 -integer fileinfo, % controls [49] 00047300 - tabamount, % controls [50] 00047400 - fileaccess, % controls [51] 00047500 - savefactor, % controls [52] 00047600 - prewhere, % controls [53] 00047700 - xdex, % controls [54] 00047800 - n, % controls [55] 00047900 - at, % controls [56] 00048000 - d, % controls [57] 00048100 - m, % controls [58] 00048200 - inc, % controls [59] 00048300 - i, % controls [60] 00048400 - resetn ; % controls [61] 00048500 -boolean bool ; % controls [62] 00048800 -define cobolfile = boolean (fileinfo)#, 00048820 - datafile = fileinfo = data#, 00048830 - algolfile = fileinfo geq algol#, 00048840 - compiler = fileinfo#, 00048850 - length = (if algolfile then 72 else if cobolfile then 66 else 80)#, 00048860 - halflength=(if algolfile then 36 else if cobolfile then 33 else 40)#, 00048870 - fulllength = (if datafile then 80 else 72)#, 00048880 - halffulllength = (if datafile then 40 else 36)#, 00048890 - cobol = 1#, 00049600 - data = 2#, 00049610 - algol = 4#, 00049620 - xalgol = 6#, 00049630 - fortran = 8#, 00049640 - basic = 10#, 00049650 - fileopen = fileaccess gtr 0#, 00050710 - fileclosed = fileaccess leq 0#, 00050720 - readonlyfile = fileaccess = 2#, 00050730 - readwritefile = fileaccess geq 3# ; 00050740 -save array image [0 : 29] ; 00058000 -define rswdm = 27#, 00058500 - rswd [rswd1] = controls [rswd1]#, 00061500 - rwteach = rswd [24]# ; 00062000 -file disc disk serial (2, 10, 30) ; 00064000 -file library disk serial (2, 10, 30) ; 00065500 -file r1 disk serial "r/c" "#1" (1, 90) ; 00069500 -file r2 disk serial "r/c" "#2" (1, 256) ; 00070000 -file io disk random [20:150] (1, 30) ; 00070500 -array zippy [0 : max (29, maxusers + maxusers + 1)] ; 00071500 -format zipper ("cc compile ", a1, a6, "/", a1, a6, " with ", 00072000 - a1, a6, " library; algol file card=", a1, a6, "/", a1, a6, 00072500 - "serial; algol file line=line/", a1, a6, "serial; end."), 00073000 - eoj ("{!good bye{!!!~"), 00073600 - noroom (x8, "sorry, full up.{!bye{!~"), 00073700 - userun (x8, "use:{!?? run ...~"), 00078600 - star ("*", x79), 00079000 - date (x6, a1, a6, "/", a1, a6, " listed at", i3, ":", i2, " on ", 00079300 - a6, "day ", o, " by ", a1, a6, x62), 00079400 - waitf ("wait...~"), 00085000 - rattle (x8, "<<<~"), 00087000 - teach1 ("{!the valid verbs are:~"), 00087500 - teach2 (7 (a1, a6, x2)), 00088000 - teach3 ("for syntax of a verb (e.g. tab), input: * teach", 00088500 - " verb. (e.g. * teach tab) *"), 00089000 - broken (x8, "{!breaks{!~") ; 00092000 -define onoff (onoff1) = (if onoff1 then " on " else " off ")# ; 00097100 -define xmax = 5# ; 00099600 -array xarray [0:maxuser, 0:xmax | 13 - 1] ; 00099700 -define 00099800 - xsub = xdex | 13#, 00099810 - xparameters [xparameters1] = xarray [user, xsub + xparameters1]#, 00099900 - xstart = xarray [user, xsub + 5]#, 00100000 - xlast = xarray [user, xsub + 6]#, 00100100 - xn = xarray [user, xsub + 7]#, 00100200 - xrepeat = xarray [user, xsub + 8]#, 00100300 - xprefix = xarray [user, xsub + 9]#, 00100400 - xsuffix = xarray [user, xsub + 10]#, 00100500 - xfiletype = xarray [user, xsub + 11]#, 00100600 - xnchrs = xarray [user, xsub + 12]# ; 00100700 -procedure program ; forward ; 00101000 -alpha procedure octdecimal (n, m, f) ; 00101100 -value n, f ; 00101200 -integer n, m, f ; 00101300 -begin 00101400 -alpha stream procedure octdecx (n, f, q, t) ; 00101500 -value f, q, t ; 00101600 - begin 00102500 -label exit ; 00102600 - di := loc octdecx ; 00103000 - si := n ; 00103100 - t (q (ds := f oct ; jump out 2 to exit) ; 00103200 - skip f db ; ds := set ; jump out to exit) ; 00103500 - q (f (si := si + 2 ; ds := 2 chr ; ds := lit "/" ; ds := 2 chr ; 00103600 - ds := lit "/" ; ds := 2 chr ; jump out 2 to exit) ; 00103700 - di := di + 7 ; ds := chr ; jump out to exit) ; 00103800 - ds := 8 dec ; 00104000 - f (di := di - 7 ; ds := 6 fill) ; 00104100 -exit: 00104200 - end octdecx; 00104300 - if f leq 1 then 00104400 - begin 00104500 - n := n ; 00104600 - octdecimal := octdecx (n, f, 0, 0) ; 00104700 - end else if f = 2 then 00104800 - octdecimal := octdecx (m, 0, 1, 0) 00104900 - else if f = 3 then 00104910 - octdecimal := octdecx (n, 1, 1, 0) 00104920 - else if f = 4 then 00104930 - octdecimal := octdecx (m, n, 1, 1) 00104940 - else 00105000 - octdecimal := octdecx (m, n:= 47 - n, 0, 1) ; 00105100 -end octdecimal ; 00105200 -define octdec (octdec1) = octdecimal (octdec1, m, 0)#, 00105300 - octdex (octdex1) = octdecimal (octdex1, m, 1)#, 00105400 - firstchar (firstchar1) = octdecimal (0, firstchar1, 2)#, 00105500 - mmddyy = octdecimal (time (5), m, 3)#, 00105600 - dec (dec1, dec2) = octdecimal (dec2, dec1, 4)#, 00105700 - two (two1) = boolean (octdecimal (two1, m, 5))# ; 00105800 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00120500 -define sequence = 00121000 - if algolfile then 00121500 - image [9] := octdec (if n = finity then 99999999 else n) 00122000 - else if cobolfile then 00122500 - begin 00123000 - image [0].[1:35] := octdec (n) ; 00124000 - image [9] := suffix & "."[1:43:5] ; 00124500 - end# ; 00125000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00126000 -procedure stationfix (station, i) ; 00126500 -value station, i ; 00126600 -real station ; 00126700 -integer i ; 00126800 -begin 00126900 -real x ; 00127000 - if i leq 4 then 00127100 - x := status (station, i) 00127200 - else if i leq 6 then 00127300 - release (station) 00127400 - else if i leq 8 then 00127500 - begin 00127600 - seek (twxinput (station)) ; 00127625 - x := status (station, 0) ; 00127650 - end 00127675 - else if i = 9 then 00127700 - begin 00127800 - write (twxoutput (station), noroom) ; 00127900 - release (station) ; 00128000 - end 00128100 - else if i = 10 then 00128200 - begin 00128300 - if boolean (status (station, 0)).[30:1] or 00128400 - usercodei neq status (station) then 00128500 - abnormalend := 1 ; 00128600 - end ; 00128700 -end stationfix ; 00128800 -define charge (charge1) = stationfix (charge1, 0)#, 00128900 - freefile (freefile1) = stationfix (freefile1, 3)#, 00129000 - unfreefile (unfreefile1) = stationfix (unfreefile1, 4)#, 00129100 - forget (forget1) = stationfix (forget1, 5)#, 00129200 - detach = stationfix (station, 6)#, 00129300 - attach = stationfix (station, 7)#, 00129400 - reattach = stationfix (station, 8)#, 00129500 - nomoreroom = stationfix (station, 9)#, 00129600 - check (check1) = stationfix (check1, 10)# ; 00129700 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00129800 -procedure output ; 00130000 - begin 00130200 -stream procedure move (s, d, w, c) ; value w, c ; 00130400 -begin 00130600 - si := s ; 00130800 - di := d ; 00131000 - ds := w wds ; 00131200 - ds := c chr ; 00131400 -end move ; 00131600 -integer user, 00131800 - t, 00132200 - spot ; 00132400 -boolean x ; 00132600 -label fakeout, 00132800 - next ; 00133000 -define a = input# ; 00133200 - charge (0) ; 00133400 - tankedoutput := false ; 00133600 - a [wdsperbuffer] := "~ " ; 00133800 - for user := 0 step 1 until bigbird do 00134000 - begin 00134200 - if counti geq 0 then 00134600 - begin 00134800 - if timei - timex gtr 180 then 00135000 - go to fakeout ; 00135200 - spot := headi ; 00135400 - if real ((x := boolean (status (stationi, 0)).[22:9]) 00135600 - and boolean ("6a")) neq 0 then 00135800 - begin 00136000 - if x.[39:1] then % busy 00136200 - begin 00136400 - t := 15 ; 00136600 - go to fakeout ; 00136800 - end ; 00137000 - if real (x and boolean (10)) neq 0 and not x then 00137200 - write (twxout, broken) ; % clear write ready 00137400 - if spot geq 0 then 00137600 - begin 00137800 - a [0] := freehead ; 00138000 - write (io [taili], 1, a [*]) ; 00138200 - freehead := spot ; 00138400 - end ; 00138600 - counti := xdex := -1 ; 00138800 - timei := 0 ; 00139000 - breaki := 1 ; 00139200 - moreinput := false ; 00139400 - go to next ; 00139600 - end ; 00139800 - if spot geq 0 then 00140000 - begin 00140200 - read (io [spot], 30, buff [*]) ; 00140400 - move (buff [block], a [1], 0, chrsperbuffer) ; 00140600 - write (twxout, wordsperbuffer, a [*]) [fakeout] ; 00140800 - t := chrsperbuffer ; 00141000 - if block := block + wdsperbuffer geq 29 then 00141200 - begin 00141400 - block := 1 ; 00141600 - a [0] := freehead ; 00141800 - write (io [spot], 1, a [*]) ; 00142000 - headi := buff[0] ; 00142200 - end ; 00142400 - end else 00142600 - begin 00143000 - move (buffer [1], a [1], 0, chrsperbuffer) ; 00143200 - write (twxout, wordsperbuffer, a [*]) [fakeout] ; 00143400 - if bloc := bloc - wdsperbuffer lss 1 then 00143600 - begin 00143800 - counti := -1 ; 00144000 - if abnormalend geq 2 then 00144200 - abnormalend := abnormalend + 1 ; 00144400 - go to next ; 00144600 - end ; 00144800 - t := chrsperbuffer ; 00145000 - move (buffer[wordsperbuffer],buffer[1],29-wordsperbuffer,0); 00145200 - end; 00145400 -fakeout: 00145600 - if timei:=max(timei,timex)+t|6 lss tn or not outputready then 00145800 - begin 00146000 - tn := timei ; 00146200 - tankedoutput := true ; 00146400 - end ; 00146600 -next: 00146800 - end ; 00147000 - end ; 00147200 - if outputready then 00147400 - nextclock := clock - t0 | (tn - timex - 90) / 150 00147600 - else 00147800 - nextclock := -99 ; 00148000 - charge (station) ; 00148200 - end output ; 00148400 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00148600 -procedure writetwx ; 00148800 - begin 00149200 -integer stream procedure count (s) ; 00149400 -begin 00149600 - si := s ; 00149800 - 28 (if sc = "~" then 00150000 - jump out ; 00150200 - tally := tally + 1 ; 00150400 - si := si + 1) ; 00150600 - s := si ; 00150800 - di := s ; 00151000 - ds := lit "~" ; 00151200 - count := tally ; 00151400 -end count ; 00151600 -stream procedure move (s, d, skps, skpd, n) ; 00151800 -value skps, skpd, n ; 00152000 -begin 00152200 - si := s ; 00152400 - di := d ; 00152600 - si := si + skps ; 00152800 - di := di + skpd ; 00153000 - ds := n chr ; 00153200 -end move ; 00153400 -integer c, j, k ; 00153600 -define a = pretank# ; 00153700 -label noskip, 00153800 - skip ; 00154000 - if boolean (ilfcri) then 00154200 - begin 00154400 - ilfcri := 0 ; 00154600 - if firstchar (a [0]) = "{" then 00154800 - j := 2 ; 00155000 - end ; 00155200 - if c := count (a) - j neq 0 and not boolean (breaki) then 00155400 - begin 00155600 - if k := counti lss 0 then 00155800 - begin 00156000 - buffer [4] := "~ " ; 00156200 - move ( a [0], buffer [1], j, 0, 28); 00156400 - if timei - timex geq 180 then 00156600 - go to noskip ; 00156800 - write (twxout, 5, buffer [*]) [noskip : noskip] ; 00157000 - timei := max (timei, timex) + c | 6 ; 00157200 - go to skip ; 00157400 -noskip: 00157600 - counti := c ; 00157800 - block := bloc := 1; 00158000 - headi := -1 ; 00158200 - if timei lss tn or not outputready then 00158400 - begin 00158600 - nextclock := clock - t0 | ((tn:=timei)-timex-120) / 150 ; 00158800 - tankedoutput := true ; 00159000 - end ; 00159200 - go to skip ; 00159400 - end ; 00159600 - if k lss chrsperbuffer then 00159800 - begin 00160000 - move (a, buffer [bloc], j, k, chrsperbuffer - k) ; 00160200 - j := j + chrsperbuffer - k ; 00160400 - if counti := k := k + c lss chrsperbuffer then 00160600 - go to skip ; 00160800 - c := k - chrsperbuffer ; 00161000 - end ; 00161200 - if bloc := bloc + wdsperbuffer geq 29 then 00161400 - begin 00161600 - bloc := 1 ; 00161800 - if freehead neq maxfreehead then 00162000 - begin 00162200 - read (io [freehead], 1, buffer [*]) ; 00162400 - k := buffer [0] ; 00162600 - end else 00162800 - k := maxfreehead := maxfreehead + 1 ; 00163000 - buffer [0] := -1 ; 00163200 - write (io [freehead], 1, buffer [*]) ; 00163400 - if headi geq 0 then 00163600 - begin 00163800 - read (io [taili], 30, buffer [*]) ; 00164000 - buffer [0] := freehead ; 00164200 - write (io [taili], 30, buffer [*]) ; 00164400 - end else 00164600 - headi := freehead ; 00164800 - taili := freehead ; 00165000 - freehead := k ; 00165200 - end ; 00165400 - move (a, buffer [bloc], j, 0, 29) ; 00165600 - counti := c ; 00165800 - end ; 00166000 -skip: 00166200 - end writetwx ; 00166400 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00170000 -define itsold (itsold1) = boolean (kount (itsold1, 0, 0))#, 00170010 - loc (loc1) = kount (loc1, 1, 0)# ; 00170020 -integer procedure kount (n, m, kk) ; 00170030 -value n, m, kk ; 00170040 -integer n, m, kk ; 00170050 - begin 00170060 -integer k ; 00170070 -real l ; 00170080 - while n lss (l := ll [at]).s do 00170090 - at := l.f ; 00170100 - while n gtr (l := ll [at]).s do 00170110 - at := l.t ; 00170120 - if kk neq 0 then 00170130 - begin 00170140 - if m = infinity then m := m - 1 ; 00170150 - while m geq (l := ll [at]).s and k := k + 1 neq kk do 00170160 - at := l.t ; 00170170 - kount := k - real (m lss l.s) ; 00170180 - end else 00170190 - if boolean (m) then 00170200 - kount := at 00170210 - else 00170220 - kount := real (n = l.s) ; 00170230 - end kount ; 00170240 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00170500 -define 00175000 - writesequence = writealine (0)#, 00175100 - writelfcr = writealine (1)#, 00175200 - writeseq = writealine (2)#, 00175300 - writequeued = writealine (5)#, 00175600 - writesegment = writealine (6)#, 00175700 - writereladdr = writealine (7)# ; 00175800 -procedure writealine (k) ; 00175900 -value k ; 00176000 -integer k ; 00176100 - begin 00176200 -stream procedure form (pretank, n, k, lfcr, colon, f) ; 00176300 -value n, k, lfcr, colon, f ; 00176400 -begin 00176500 -label exit ; 00176600 - di := pretank ; 00176700 - lfcr (ds := 2 lit "{!" ; 00176800 - k (si := loc n ; 00176900 - ds := k dec ; 00177000 - f (pretank := di ; 00177100 - di := di - k ; 00177200 - ds := k fill ; 00177300 - di := pretank) ; 00177400 - jump out) ; 00177500 - colon (ds := lit ":") ; 00177600 - jump out to exit) ; 00177700 - colon (si := loc n ; 00177800 - f (ds := 7 lit "queued(" ; 00177900 - ds := 2 dec ; 00178000 - ds := lit ")" ; 00178100 - jump out 2 to exit) ; 00178200 - k (ds := 9 lit "rel addr=" ; 00178300 - ds := 4 dec ; 00178400 - jump out 2 to exit) ; 00178500 - ds := 8 lit "segment=" ; 00178600 - ds := 4 dec ; 00178700 - jump out to exit) ; 00178900 - f (n (ds := lit " ") ; jump out to exit) ; 00179000 - ds := lit ">" ; 00179100 -exit: 00179200 - ds := lit "~" ; 00179300 -end form ; 00179400 -define xon = form (pretank, 0, 0, 0, 0, 0)#, 00179500 - tabit = form (pretank, i, 0, 0, 0, 1)#, 00179600 - lfcr = form (pretank, 0, 0, 1, 0, 0)#, 00179700 - colon = form (pretank, 0, 0, 1, 1, 0)#, 00179800 - seq = form (pretank, if n = infinity then 99999999 else n, 00179900 - if cobolfile then 6 else 8, 1, 00180000 - if cobolfile then 0 else 1, 1)#, 00180100 - oldseq = form (pretank, if n = infinity then 99999999 else n, 00180200 - if cobolfile then 6 else 8, 1, 00180300 - if cobolfile then 0 else 1, 1-real(itsold (n)))#, 00180400 - queform = form (pretank, readyqtop, 0, 0, 1, 1)#, 00180500 - segment = form (pretank, parameter2, 0, 0, 1, 0)#, 00180600 - reladdr = form (pretank, parameter3, 1, 0, 1, 0)#, 00180700 - twx (twx1) = begin twx1 ; writetwx ; end# ; 00180800 - if k = 0 then 00181000 - begin 00181100 - if fileopen then 00181200 - begin 00181300 - twx (oldseq) ; 00181400 - if inlinetog and extralfcr then 00181500 - twx (lfcr) ; 00181600 - if tabon and tabamount neq 0 then 00181700 - begin 00181800 - if i := tabamount gtr 27 then 00181900 - begin 00182000 - i := i - 27 ; 00182100 - twx (tabit) ; 00182200 - i := 27 ; 00182300 - end ; 00182400 - twx (tabit) ; 00182500 - end ; 00182600 - end 00182700 - else 00182800 - twx (colon) ; 00182900 - if xdex lss 0 and not errtog then 00183000 - twx (xon) 00183100 - else 00183200 - errtog := false ; 00183300 - end 00183400 - else if k = 1 then 00183500 - begin 00183600 - twx (lfcr) ; 00183700 - ilfcri := 1 ; 00183800 - end 00183900 - else 00184000 - twx (if k=2 then seq else if k=5 then queform else 00184100 - if k=6 then segment else if k=7 then reladdr) ; 00184200 - end writealine ; 00184300 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00190500 -procedure writerow (row, q, f) ; 00191000 -value q, 00191500 - f ; 00192000 -boolean q ; 00192500 -integer f ; 00193000 -array row [0] ; 00193500 - begin 00193600 -stream procedure move (s, d, skps, n) ; 00193700 -value skps, n ; 00193800 -begin 00193900 - si := s ; 00194000 - di := d ; 00194100 - si := si + skps ; 00194200 - ds := n chr ; 00194300 -end move ; 00194400 -stream procedure blankoutspecialcharacters (s, d, n, k) ; 00195000 -value n, 00195500 - k ; 00195600 - begin 00196000 - di := loc n ; ds := 6 lit "!><}{~" ; 00197500 - di := d ; 00198000 - ds := 8 lit " " ; 00198500 - si := d ; 00199000 - ds := 9 wds ; 00199500 - si := s ; 00200000 - di := d ; 00200500 - 2 (k (if sc = " " then 00201000 - begin 00201500 - n (si := si - 1 ; 00202000 - if sc = " " then 00202500 - di := di - 1 ; 00203000 - si := si + 1) ; 00203500 - ds := chr ; 00204000 - end else 00204500 - if sc = alpha then 00205000 - ds := chr 00205500 - else 00206000 - begin 00206500 - d := di ; 00207000 - di := loc n ; 00207500 - 6 (if sc = dc then jump out ; si := si - 1) ; 00208000 - di := d ; 00208500 - if toggle then 00209000 - ds := 1 lit "$" 00209500 - else 00210000 - ds := chr ; 00210500 - end)) ; 00211000 - end blankoutspecialcharacters ; 00219000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00219500 -boolean stream procedure allblank (s, skp, n) ; 00220000 -value skp, 00220500 - n ; 00221000 - begin 00221500 -label grpmkit ; 00222000 - si := s ; 00222500 - si := si + skp ; 00223000 - si := si + n ; 00223500 - n (si := si - 1 ; 00224000 - if sc neq " " then 00224500 - jump out to grpmkit) ; 00225000 - tally := 1 ; 00225500 - si := si - 1 ; 00226000 -grpmkit: 00226600 - si := si + 1 ; 00227000 - n := si ; 00227500 - di := n ; 00228000 - ds := 1 lit "~" ; 00228500 - allblank := tally ; 00229000 - end all blank ; 00229500 -boolean datum ; 00229600 -define fileinfo = f# ; 00229700 -integer z ; 00229800 - blankoutspecialcharacters (row, input, q, halffulllength) ; 00230000 - if datafile then 00230100 - begin 00230200 - move (input [9], zippy [15], 0, 8) ; 00230300 - datum := not allblank (zippy [15], 0, 8) ; 00230400 - end ; 00230500 - extralfcr := not (cobolfile or q:=allblank (input [z:=7], 7, 9)) ; 00231000 - if extralfcr or cobolfile then 00231500 - writelfcr ; 00232000 - if q then 00232500 - if q := allblank (input [7], 0, 7) then 00233000 - if q := allblank (input [z:=3], 4, 28) then 00233500 - q := allblank (input [z:=0], 0, 28) ; 00234000 - if not q then 00234500 - for f := 0 step 3 until z do 00235000 - begin 00235500 - move (input [f], pretank [0], 4 | f div 3, 28) ; 00236000 - writetwx ; 00236500 - end ; 00237000 - if datum then 00237050 - begin 00237100 - writelfcr ; 00237200 - move (zippy [15], pretank, 0, 9) ; 00237300 - writetwx ; 00237400 - end ; 00237450 - writelfcr ; 00237460 - end writerow ; 00237500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00237510 -procedure errorx (k, a, b) ; 00237512 -value k, 00237514 - a, 00237516 - b ; 00237518 -integer k ; 00237520 -real a, 00237522 - b ; 00237524 - begin 00237526 -stream procedure crunch (s, k, a, b) ; value k, a, b ; 00237528 -begin 00237530 -label e0, e1, e2, e3, e4, e5, e6, filename, crunch, deblank ; 00237532 - si := loc a ; 00237534 - si := si + 1 ; 00237536 - di := s ; 00237538 - ds := 2 lit "{!" ; 00237540 - ci := ci + k ; 00237542 - go to e0 ; 00237544 - go to e1 ; 00237546 - go to e2 ; 00237548 - go to e3 ; 00237550 - go to e4 ; 00237552 - go to e5 ; 00237554 - go to e6 ; 00237556 - go to e0 ; 00237558 - go to e0 ; 00237560 -e1: 00237562 - ds := 10 lit "inv user: " ; 00237564 - go to e6 ; 00237566 -e2: 00237568 - ds := 2 lit "no" ; 00237570 - go to filename ; 00237572 -e3: 00237574 - ds := 3 lit "bad" ; 00237576 - go to filename ; 00237578 -e5: 00237580 - ds := 8 lit "no file " ; 00237582 -e0: 00237584 - ds := 7 chr ; 00237586 - si := si + 1 ; 00237588 - ds := 7 chr ; 00237590 - go to crunch ; 00237592 -e4: 00237594 - ds := 3 lit "dup" ; 00237596 -filename: 00237598 - ds := 7 lit " file: " ; 00237600 -e6: 00237602 - ds := 7 chr ; 00237604 - ds := lit "/" ; 00237606 - si := si + 1 ; 00237608 - ds := 7 chr ; 00237610 -crunch: 00237612 - ds := lit "~" ; 00237614 - si := s ; 00237616 - di := s ; 00237618 - 28 (if sc = " " then 00237620 - begin 00237622 -deblank: 00237624 - si := si + 1 ; 00237626 - if sc = " " then 00237628 - go to deblank ; 00237630 - if sc = alpha then 00237632 - ds := 1 lit " " ; 00237634 - end else 00237636 - ds := chr) ; 00237638 -end crunch ; 00237640 - if a = "#000000" then a := " " ; 00237642 - if b = "#000000" then b := " " ; 00237644 - crunch (pretank, k, a, b) ; 00237646 - writetwx ; 00237648 - if k leq 6 then 00237650 - begin 00237652 - errtog := true ; 00237654 - moreinput := false ; 00237656 - nostar := false ; 00237658 - xdex := -1 ; 00237660 - end else if k = 8 then 00237662 - ilfcri := 1 ; 00237664 - end errorx ; 00237666 -define error (error1, error2, error3, error4) = 00237668 - begin 00237670 - errorx (error2, error3, error4) ; 00237672 - go to error1 ; 00237674 - end error#, 00237676 - show (show1, show2) = errorx (8, show1, show2)# ; 00237678 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00237700 -boolean procedure filecheck (b) ; 00237740 -value b ; 00237750 -boolean b ; 00237760 -begin 00237770 -label next ; 00237780 - if b then 00237790 - begin 00237800 - if fileclosed then 00237810 - error (next, 5, " open: ", parameter0) ; 00237820 - if b.[46:1] and readonlyfile then 00237830 - error (next, 0, "read on", "ly file") ; 00237840 - end else 00237850 - if fileopen then 00237860 - begin 00237870 - search (disc, input [*]) ; 00237880 - if input [0] lss fileaccess then 00237890 - begin 00237900 - charge (station) ; 00237905 - close (disc) ; 00237910 - fill disc with prefix, suffix ; 00237920 - search (disc, input [*]) ; 00237930 - if input [0] lss fileaccess then 00237940 - begin 00237950 - fileaccess := 0 ; 00237960 - inorder := true ; 00237970 - error (next, 1 + real (input [0] lss 0), prefix, suffix) ; 00237980 - end ; 00238000 - end ; 00238010 - end ; 00238020 - if false then 00238030 -next: 00238040 - filecheck := true ; 00238050 -end filecheck ; 00238060 -define opencheck = if filecheck (true) then go to next#, 00238070 - readonlycheck = if filecheck (boolean (3)) then go to next#, 00238080 - securitycheck = if filecheck (false) then go to next# ; 00238090 -procedure state (s) ; 00238100 -value s ; 00238200 -boolean s ; 00238300 - begin 00238400 -stream procedure stuffstate (n, record, p0, c) ; 00238500 -value n ; 00238600 - begin 00239000 -label exit ; 00239100 - n (di := c ; 00239200 - si := p0 ; 00239300 - ds := 25 wds ; 00239400 - si := record ; 00239600 - ds := 10 wds ; 00239700 - jump out to exit) ; 00240400 - si := c ; 00240500 - di := p0 ; 00240600 - ds := 25 wds ; 00240700 - di := record ; 00240900 - ds := 10 wds ; 00241000 -exit: 00241700 - end stuffstate ; 00246000 -integer i, k ; 00247500 - close (disc) ; 00248000 - k := if s.[46:1] then sloti else 46 ; 00248500 - if s then 00248600 - begin 00248700 - stuffstate (1, record, parameter0, controls [38]) ; 00250000 - write (r1 [k], 90, controls [*]) ; 00250600 - if s.[46:1] and fileopen and real (modified) neq 0 then 00251000 - begin 00251500 - k := d.leftside ; 00252000 - for i := 0 step 1 until k do 00252500 - begin 00253000 - if modified then 00253100 - write (r2 [32|sloti + i], 256, linklists [user32+i, *]) ; 00253200 - modified := modified.[16:31] ; 00253500 - end ; 00254000 - modified := false ; 00254100 - end ; 00254200 - end savestate else 00254500 - begin 00255500 - read (r1 [k], 90, controls [*]) ; 00256500 - stuffstate (0, record, parameter0, controls [38]) ; 00257500 - fill disc with prefix, suffix ; 00258500 - if s.[46:1] then 00259000 - modified := false ; 00259500 - user32 := user | 32 ; 00260000 - end restorestate ; 00260500 - prewhere := -1 ; 00261000 - end state ; 00262000 -define savestate = state (boolean(3))#, 00262500 - restorestate = state (boolean (2))#, 00263000 - unswapstate = state (false)#, 00263500 - swapstate = state (true)# ; 00264000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00264500 -define wait (wait1, wait2) = 00265000 - begin 00265100 - if not waiting then 00265150 - if waitx (wait1, wait2) then 00265200 - go to next ; 00265250 - end# ; 00265300 -boolean procedure waitx (tocks, forced) ; 00265500 -value tocks, 00265600 - forced ; 00265700 -integer tocks ; 00265800 -boolean forced ; 00265900 - begin 00266000 -define segment = #; 00266100 - if tocks geq clock or forced then 00266200 - if q then 00266300 - begin 00266400 - readyq [readyqtop := readyqtop + 1] := user ; 00266500 - inreadyq := 1 ; 00266600 - writequeued ; 00266700 - n := resetn ; 00266900 - if notfirstinput then 00267000 - savestate ; 00267100 - station := 0 ; 00267200 - waitx := true ; 00267300 - end else 00267400 - begin 00267500 - if forced.[46:1] then 00267600 - begin 00267700 - waitx := boolean (user := readyq [1]) ; 00267800 - charge (stationi) ; 00267900 - inreadyq := 0 ; 00268000 - for i := 2 step 1 until readyqtop do 00268100 - readyq [i - 1] := readyq [i] ; 00268200 - readyqtop := readyqtop - 1 ; 00268300 - restorestate ; 00268400 - read (io [user], 30, image [*]) ; 00268410 - end ; 00268500 - write (pretank [*], waitf ) ; 00268600 - writetwx ; 00268700 - waitflag := true ; 00268800 - readyq [0] := user ; 00268900 - end ; 00269300 - end waitx ; 00269400 -define interrupt (interrupt1) = interupt (interrupt1, 0, 0)#, 00282000 - interupt (interupt1, interupt2, interupt3) = 00282100 - begin 00282500 - if clock := clock - interupt1 leq nextclock then 00283000 - output ; 00283100 - if clock leq 0 then 00283200 - if interrupts (interupt2, interupt3) then 00283500 - go to next ; 00284000 - end# ; 00284500 -boolean procedure interrupts (lib, loc) ; 00285000 -value lib, loc ; 00285100 -integer lib, loc ; 00285200 -begin 00285500 -label newbird, none, next ; 00286000 - t0 := clock := max (50, t0 | 150 / (-t1 + t1 := timex)) ; 00286500 - if waiting then 00287000 - begin 00287500 - input [5] := 0 & "~"[1:43:5] ; 00288000 - read (twxinput (0, 0), 8, input [*]) [none] ; 00288500 - qinput := true ; 00289000 -newbird: 00289500 - swapstate ; 00290000 - close (library) ; 00290100 - charge (station := 0) ; 00290500 - inreadyq := 3 ; 00291000 - q := true ; 00291500 - program ; 00292000 - q := false ; 00292500 - user := readyq [0] ; 00293000 - charge (stationi) ; 00295500 - inreadyq := 0 ; 00296000 - unswapstate ; 00296500 - securitycheck ; 00297000 - if lib neq 0 then 00297100 - begin 00297200 - fill library with if boolean (lib) then parameter1 else prefix, 00297300 - if boolean (lib) then parameter2 else suffix ; 00297400 - read seek (library [loc]) ; 00297500 - end ; 00297600 -none: 00297700 - if rattleindex := rattleindex + 1 = 5 then 00298000 - begin 00298500 - for tink := 0 step 1 until readyqtop do 00299000 - begin 00299500 - user := readyq [tink] ; 00300000 - if counti lss 0 then 00300500 - if real (boolean (status (stationi, 0)).[22:9] and 00301000 - boolean ("6c")) = 0 then 00301100 - write (twxout, rattle) ; 00301500 - end ; 00302000 - user := readyq [rattleindex := 0] ; 00302500 - charge (station) ; 00302700 - if 2 | bigbird + 2 lss status (zippy [*]) then 00303000 - go to newbird ; 00303500 - if false then 00304000 -next: 00304500 - interrupts := true ; 00305000 - end ; 00305500 - end ; 00306000 - clock := t0 ; 00306100 - t1 := timex ; 00306200 - if outputready then 00306300 - nextclock := clock - t0 | (tn - t1 - 90) / 150 ; 00306400 -end interrupts ; 00307000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00318000 -integer procedure xfile (p, s, fs) ; 00318100 -value p, s, fs ; 00318110 -real p, s, fs ; 00318120 -begin 00318130 -define segment = # ; 00318140 - if p = 12 then 00318150 - begin 00318160 - if num1 then 00318170 - begin 00318180 - num1 := false ; 00318190 - p := parameter1 := octdec (parameter1) ; 00318200 - end else 00318210 - p := parameter1 ; 00318220 - if num2 then 00318230 - begin 00318240 - num2 := false ; 00318250 - s := parameter2 := octdec (parameter2) ; 00318260 - end else 00318270 - s := parameter2 ; 00318280 - end ; 00318290 - fill library with p, s ; 00318300 - search (library, input [*]) ; 00318310 - if xfile := input [0] lss fs then 00318320 - errorx (1 + real (input [0] lss 0), p, s) ; 00318330 -end xfile ; 00318350 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00318360 -procedure readin ; 00319000 - begin 00319100 -boolean procedure more ; 00319210 -begin 00319220 -label next, 00319230 - exit ; 00319240 -integer stream procedure trailingblanks (s, n) ; 00319250 -value n ; 00319260 -begin 00319270 -label done ; 00319280 - si := s ; 00319290 - si := si + 7 ; 00319300 - s := tally ; 00319310 - di := s ; 00319320 - 2 (n (if sc neq " " then jump out 2 to done ; 00319330 - si := si - 1 ; 00319340 - di := di + 8)) ; 00319350 -done: 00319360 - trailingblanks := di ; 00319370 -end trailingblanks ; 00319380 -integer xsub ; 00319390 -define fileinfo = xfiletype# ; 00319400 - if fileopen then 00319410 - begin 00319420 - if n gtr finity then 00319430 - if n := ll [last.f].s + inc gtr finity then 00319440 - begin 00319450 - n := finity ; 00319460 - error (next, 0, "seq. ov", "er-flow") ; 00319470 - end ; 00319480 - if n leq 0 then 00319490 - n := 1 ; 00319500 - end ; 00319510 - if moreinput then 00319520 - begin 00319530 - read (io [user + maxusers], 30, image [*]) ; 00319540 - chrs := nchrs ; 00319550 - go to exit ; 00319560 - end ; 00319570 - if xdex lss 0 then 00319580 - begin 00319590 -next: 00319600 - if not nostar then 00319610 - writesequence ; 00319620 - chrs := 0 ; 00319630 - savestate ; 00319640 - end else 00319650 - begin 00319660 - xsub := xdex | 13 ; 00319670 - while xn := xn + 1 gtr xlast do 00319680 - if xrepeat := xrepeat - 1 gtr 0 then 00319690 - xn := xstart 00319700 - else 00319710 - begin 00319720 - if xsuffix = "#macro#" then 00319730 - begin 00319740 - if xfile (xprefix, xsuffix, 7) lss 7 then 00319750 - go to next ; 00319760 - read (library) ; 00319770 - detach ; 00319780 - close (library, purge) ; 00319790 - end ; 00319800 - if boolean (xnchrs.[1:1]) then 00319810 - begin 00319820 - read (io [2|maxusers+xmax|user+xdex], 30, image [*]) ; 00319830 - chrs := abs (xnchrs) ; 00319840 - xdex := xdex - 1 ; 00319850 - go to exit ; 00319860 - end ; 00319870 - if xdex := xdex - 1 lss 0 then 00319880 - go to next ; 00319890 - xsub := xdex | 13 ; 00319900 - end ; 00319910 - if xfile (xprefix, xsuffix, 2) lss 2 then 00319920 - go to next ; 00319930 - if xecho then 00319940 - writesequence ; 00319950 - savestate ; 00319960 - interrupt (3) ; 00319970 - read (library [xn - 1], 10, image [*]) ; 00319980 - close (library) ; 00319990 - chrs := (i := fulllength) - 00320000 - trailingblanks (image [i.[41:4]-1], i.[41:6]) ; 00320010 - if xecho then 00320020 - writerow (image [*], false, xfiletype) ; 00320030 -exit: 00320040 - more := true ; 00320050 - end ; 00320060 -end more ; 00320070 -boolean stream procedure lineedit (s, d, c, chrs, p, over80, eighty1) ; 00321000 -value c, 00321100 - p, 00321200 - over80, 00321300 - eighty1 ; 00321400 - begin 00321500 -local t, 00321600 - percent1, percent ; 00321700 -label around, next ; 00321800 - p (di := loc percent ; ds := 14 lit "%?-~=!(<)>[{]}") ; 00321900 - si := loc c ; 00322000 - di := loc t ; 00322100 - si := si + 6 ; 00322200 - di := di + 7 ; 00322300 - ds := chr ; 00322400 - si := s ; 00322500 - di := d ; 00322600 - t (di := di + 32 ; di := di + 32) ; 00322700 - di := di + c ; 00322800 - 56(if sc = "~" then 00322900 - go to around ; 00323000 - if sc = "}" then% disconnect or exclamation 00323010 - begin 00323020 - tally := 1 ; 00323030 - go to around ; 00323040 - end ; 00323050 - if sc = "!" then% line erase 00323100 - begin 00323200 - c := tally ; 00323300 - over80 := tally ; 00323400 - di := d ; 00323500 - go to around ; 00323600 - end ; 00323700 - if sc = "{" then% backspace 00323800 - begin 00323900 - s := si ; 00324000 - t := di ; 00324100 - si := loc c ; 00324200 - di := loc lineedit ; 00324300 - if 8 sc neq dc then 00324400 - begin 00324500 - over80 (si := si - 8 ; 00324600 - di := loc eighty1 ; 00324700 - if 8 sc = dc then 00324800 - over80 := tally) ; 00324900 - si := c ; 00325000 - si := si - 8 ; 00325100 - c := si ; 00325200 - di := t ; 00325300 - di := di - 1 ; 00325400 - end else 00325500 - di := t ; 00325600 - si := s ; 00325700 -around: 00325800 - end else 00325900 - begin 00326500 - s := si ; 00326600 - over80 (di := di + 1 ; 00326700 - si := c ; 00326900 - si := si + 8 ; 00327000 - c := si ; 00327100 - si := s ; 00327200 - jump out to around) ; 00327300 - t := di ; 00327500 - p (di := s ; 00327600 - si := t ; 00327700 - si := si - 1 ; 00327800 - if sc = "%" then 00327900 - begin 00328000 - si := loc percent ; 00328100 - 7 (if sc = dc then 00328200 - begin 00328300 - di := t ; 00328400 - di := di - 1 ; 00328500 - ds := chr ; 00328600 - si := s ; 00328700 - jump out 2 to around ; 00328900 - end ; 00329000 - si := si + 1 ; 00329100 - di := di - 1) ; 00329200 - end) ; 00329300 - si := c ; 00330600 - si := si + 8 ; 00330700 - c := si ; 00330800 - si := loc c ; 00330900 - di := loc eighty1 ; 00331000 - if 8 sc = dc then 00331100 - begin 00331200 - tally := 1 ; 00331300 - over80 := tally ; 00331400 - tally := 0 ; 00331500 - end ; 00331600 - si := s ; 00331700 - di := t ; 00331800 - if toggle then 00331900 - di := di + 1 00332000 - else begin 00332100 - ds := chr ; 00332200 - si := si - 1 ; 00332300 - end ; 00332400 - go to next ; 00332500 - end ; 00332550 - if sc = "~" then jump out ; 00332560 - if sc = "}" then jump out ; 00332570 -next: 00332580 - si := si + 1) ; 00332600 - si := loc c ; 00332700 - di := chrs ; 00332800 - ds := wds ; 00332900 - lineedit := tally ; 00333100 -end lineedit ; 00333200 -boolean procedure finalanalysis ; 00333210 -begin 00333220 -stream procedure move (s, d, skps, skpd, n) ; 00333230 -value skps, skpd, n ; 00333240 - begin 00333250 -local t ; 00333260 - si := loc n ; 00333270 - di := loc t ; 00333280 - si := si + 6 ; 00333290 - di := di + 7 ; 00333300 - ds := chr ; 00333310 - si := s ; 00333320 - di := d ; 00333330 - si := si + skps ; 00333340 - di := di + skpd ; 00333350 - t (ds := 32 chr ; ds := 32 chr) ; 00333360 - ds := n chr ; 00333370 - end move ; 00333380 -integer stream procedure hunt (s, d, c, n) ; 00333390 -value c, 00333400 - n ; 00333500 - begin 00333600 -label again, 00333700 - xit ; 00333800 - si := d ; 00333900 - di := d ; 00334000 - ds := 8 lit " " ; 00334100 - ds := 9 wds ; 00334200 - d := tally ; 00334300 - di := loc d ; 00334400 - si := loc c ; 00334500 - si := si + 7 ; 00334600 - ds := chr ; 00334700 -again: 00334800 - si := loc n ; 00334900 - si := si + 1 ; 00335000 - if 7 sc = dc then 00335100 - go to xit ; 00335200 - si := n ; 00335300 - si := si - 8 ; 00335400 - n := si ; 00335500 - si := s ; 00335600 - di := loc d ; 00335700 - if sc = dc then 00335800 - go to xit ; 00335900 - s := si ; 00336000 - si := hunt ; 00336100 - si := si + 8 ; 00336200 - hunt := si ; 00336300 - go to again ; 00336400 -xit: 00336500 - end hunt ; 00336600 -boolean stream procedure more (image, input, c, chrs) ; 00344000 -value c ; 00344010 - begin 00344500 -local quotes, 00345000 - endquote, 00345500 - zero, 00345510 - temp ; 00346000 -label nothingyet, 00346500 - bump, 00347000 - foundquote, 00347500 - foundsemicolan, 00348000 - loop, 00348500 - xit, 00349000 - exit ; 00349100 - si := image ; 00349500 - di := loc quotes ; 00350000 - ds := 2 lit """ ; 00350500 - ds := 6 lit "..()[]" ; 00351000 - di := loc endquote ; 00351100 - ds := 2 lit ";;" ; 00351200 -loop: 00351300 - image := si ; 00351310 - si := loc c ; 00351330 - di := loc zero ; 00351340 - if 8 sc = dc then 00351350 - go to xit ; 00351360 - si := c ; 00351370 - si := si - 8 ; 00351380 - c := si ; 00351390 - si := image ; 00351400 - ci := ci + more ; 00351500 - go to nothingyet ; 00352000 - go to loop ; 00352500 - go to foundquote ; 00353000 -nothingyet: 00353500 - if sc = alpha then 00354000 - go to bump ; 00354500 - if sc = " " then 00355000 - go to bump ; 00355500 - di := loc quotes ; 00356000 - 4 (if sc = dc then 00356500 - begin 00359000 - temp := si ; 00359500 - endquote := di ; 00360000 - di := loc endquote ; 00360500 - si := endquote ; 00361000 - ds := 1 chr ; 00361500 - tally := 2 ; 00362000 - more := tally ; 00362500 - si := temp ; 00363000 - jump out to loop ; 00363500 - end ; 00364000 - si := si - 1 ; 00364100 - di := di + 1) ; 00364200 - if sc = ";" then 00365500 - go to foundsemicolan ; 00369000 -bump: 00371500 - si := si + 1 ; 00372000 - go to loop ; 00372500 -foundquote: 00374500 - di := loc endquote ; 00375000 - if sc = dc then 00375500 - begin 00376000 - di := di - 1 ; 00376100 - ds := lit ";" ; 00376200 - tally := 0 ; 00376500 - more := tally ; 00377000 - end ; 00377500 - go to loop ; 00378000 -xit: 00378500 - si := loc endquote ; 00378600 - di := image ; 00378700 - ds := 2 chr ; 00378800 - go to exit ; 00378900 -foundsemicolan: 00378910 - tally := 1 ; 00378920 - more := tally ; 00378930 - si := loc c ; 00378940 - di := chrs ; 00378950 - ds := wds ; 00378960 - si := loc c ; 00378970 - di := loc temp ; 00378980 - si := si + 6 ; 00378990 - di := di + 7 ; 00379000 - ds := chr ; 00379010 - si := image ; 00379020 - si := si + 1 ; 00379030 - di := input ; 00379040 - temp (ds := 32 chr ; ds := 32 chr) ; 00379050 - ds := chr ; 00379060 -exit: 00379070 - end more ; 00379500 -integer stream procedure fix (im, tab, c, z, p, q) ; 00380000 -value tab, 00380500 - c, 00381000 - p, 00381100 - q ; 00381200 - begin 00381500 -local t ; 00382000 - p (si := im ; 00382100 - if sc = "%" then 00382110 - begin 00382120 - si := si + 1 ; 00382130 - if sc = "*" then 00382140 - begin 00382150 - si := c ; 00382180 - si := si - 8 ; 00382190 - c := si ; 00382200 - tally := 1 ; 00382210 - fix := tally ; 00382220 - end ; 00382230 - end) ; 00382240 - si := z ; 00382500 - di := z ; 00383000 - ds := 8 lit " " ; 00383500 - ds := 9 wds ; 00384000 - si := loc c ; 00384100 - di := loc t ; 00384200 - si := si + 6 ; 00384300 - di := di + 7 ; 00384400 - ds := chr ; 00384500 - si := im ; 00384600 - si := si + fix ; 00384650 - di := z ; 00384700 - di := di + tab ; 00384800 - t (ds := 32 chr ; ds := 32 chr) ; 00384900 - ds := c chr ; 00385000 - si := z ; 00389000 - di := im ; 00389500 - ds := 10 wds ; 00390000 - q (di := im ; ds := 1 lit "0") ; 00390100 - end fix ; 00390500 -integer c, 00390505 - h, 00390508 - k ; 00390510 -label err, next ; 00390520 - nostar := (firstchar (image [0]) neq "*" or h := chrs = 0) 00390540 - and readwritefile ; 00390550 - notfirstinput := moreinput ; 00390560 - if nostar then 00390570 - begin 00390580 - i := if cobolfile then 6 else 0 ; 00390590 - if xdex geq 0 then if boolean (xfiletype) then i := 0 ; 00390595 - moreinput := false ; 00390600 - if h + tabamount gtr length then 00390610 - go to err ; 00390630 - h := h + tabamount + i - fix (image, tabamount + i, h, 00390640 - zippy, translating and h geq 2, i = 6) ; 00390650 - if columns then 00390660 - begin 00390670 - for k := 1 step 1 until colstops do 00390680 - if i := min (h, maxcolstop) neq 00390690 - c := hunt (image, zippy, character, i) then 00390700 - begin 00390710 - while c geq i := colstop [k] do 00390720 - k := k + 1 ; 00390730 - i := i - 1 ; 00390760 - move (image, zippy, 0, 0, c) ; 00390770 - if h := h + i - (c := c + 1) gtr fulllength then 00390780 - begin 00390785 -err: 00390790 - finalanalysis := true ; 00390795 - error (next, 0, "input ", "overflw") ; 00390800 - end ; 00390805 - move (image [c.[41:4]], zippy [i.[41:4]], c.[45:3], 00390810 - i.[45:3], h - i) ; 00390820 - move (zippy, image, 0, 0, 80) ; 00390840 - end else 00390850 - k := 5 ; 00390860 - end ; 00390870 - chrs := h ; 00390875 - if xdex lss 0 and not inlinetog and n := n+inc lss infinity then 00390880 - writesequence ; 00390910 - n := n - inc ; 00390920 - end 00391110 - else 00391120 - begin 00391130 - if h gtr 240 then 00391140 - go to err ; 00391150 - inlinetog := false ; 00391160 - moreinput := more (image, zippy, h, nchrs) ; 00391170 - if moreinput then 00391175 - write (io [user + maxusers], 30, zippy [*]) ; 00391180 - end ; 00391190 -next: 00391210 -end finalanalysis ; 00391230 -integer c, 00391240 - lastuser ; 00391250 -real x ; 00391260 -label again, 00392000 - inputfull, 00392500 - exit, 00394500 - next, 00394600 - escape ; 00394700 -integer procedure readtwx ; 00394800 -begin 00394900 -label none, trouble, exit ; 00395000 -real timeout, x ; 00395100 - input [5] := 0 & "~"[1:43:5] ; 00395200 - if not q then 00395300 - timeout := if outputready then max(0,min(15,(tn-timex-60)/60)) 00395400 - else 15 ; 00395500 - read (twxinput (0, timeout), 8, input [*]) [none:trouble] ; 00395600 - go to exit ; 00395700 -none: 00395800 - if q then 00395900 - begin 00396000 - user := maxusers ; 00396100 - readtwx := 1 ; % escape 00396200 - go to exit ; 00396300 - end ; 00396400 - if outputready then 00396500 - output ; 00396600 - t1 := timex ; 00396700 - for user := 0 step 1 until bigbird do 00396800 - begin 00396900 - check (stationi) ; 00397100 - if boolean (abnormalend) then 00397200 - begin 00397300 - readtwx := 1 ; 00397400 - go to exit ; 00397500 - end ; 00397600 - if x := (t1 - timei)/1000 lss 0 then 00397700 - x := x + 5184 ; 00397800 - if x gtr 15 and x lss 100 then 00397900 - begin 00398000 - if x lss 18 then 00398100 - firstchance := 0 00398200 - else if x geq 36 then 00398300 - begin 00398400 - write (pretank [*], eoj) ; 00398500 - writetwx ; 00398600 - abnormalend := readtwx := 1 ; 00398700 - go to exit ; 00398800 - end else if firstchance = 0 then 00398900 - begin 00399000 - firstchance := 1 ; 00399100 - x := timei ; 00399200 - errorx (7, "look ", "alive.") ; 00399300 - timei := x ; 00399400 - end ; 00399500 - end ; 00399600 - end ; 00399700 - readtwx := 2 ; 00399800 - go to exit ; 00399900 -trouble: 00400000 - read (twxinput (0, 0), 1, input [*]) ; 00400100 - input [1] := "}" ; 00400200 -exit: 00400300 -end readtwx ; 00400400 -procedure initialize ; 00406000 - begin 00407000 -monitor intovr, flag ; 00407500 -integer i, 00408000 - c ; 00408100 -real u ; 00408200 -boolean olduser ; 00408500 -define dirctry = controls# ; 00408600 -label old, 00409000 - fault, 00409500 - new, 00410000 - mailcall, 00410500 - next ; 00410600 - user := bigbird := bigbird + 1 ; 00420000 - attach ; 00421000 - stationi := station ; 00421500 - if usercodei := usercode = -1 then 00422500 - usercode := octdex (100|station.[9:4]+station.[14:4]) ; 00423000 - counti := -1 ; 00426000 - ilfcri := 1 ; 00426100 - errorx (7, "version", octdex (version)) ; 00427900 -fault: 00427910 - read (r1 [45], 90, dirctry [*]) ; 00427920 - if olduser then 00427930 - begin 00427940 - olduser := false ; 00427950 - i := c + c ; 00427960 - error (old, 0, "backup ", "error. ") ; 00427970 - end ; 00427980 - c := 200 ; 00428000 - for i := 0 step 2 while u := dirctry [i] neq 12 do 00428100 - if usercode = u then 00428200 - begin 00428300 - olduser := true ; 00428400 - if station = dirctry [i + 1] then 00428500 - go to old ; 00428600 - c := i ; 00428700 - end else 00428800 - if u = 0 and not olduser then 00428900 - c := i ; 00429000 - if c neq 200 then 00429100 - i := c 00429300 - else if i leq 88 then 00432500 - dirctry [i + 2] := 12 00433500 - else 00434500 - while dirctry [i := i - 2] lss 0 do ; 00435000 -old: 00436500 - c := sloti := i / 2 ; 00437000 - dirctry [i] := - usercode ; 00437500 - dirctry [i + 1] := station ; 00438000 - write (r1 [45], 90, dirctry [*]) ; 00438500 - if not olduser then 00438600 - go to new ; 00438700 - intovr := fault ; 00439500 - flag := fault ; 00440500 - restorestate ; 00441000 - station := stationi ; 00441500 - if vn lss 94 or vn gtr version then 00441800 - go to fault ; 00441900 - if fileclosed then 00443000 - go to mailcall ; 00444500 - if d gtr maxfilelength then 00445100 - go to fault ; 00445200 - read seek (r2 [32 | c]) ; 00445300 - securitycheck ; 00447000 - if input [5] + 2 lss d or input [3] neq 10 then 00450000 - error (mailcall, 3, prefix, suffix) ; 00452500 - at := d.leftside ; 00453000 - for i := 0 step 1 until at do 00453100 - read (r2, 256, linklists [user32 + i, *]) [fault] ; 00453200 - at := 0 ; 00453500 - for i := 1 step 1 until d do 00454000 - begin 00454100 - if at neq ll [at := ll [at] . t] . f then 00454400 - i := d 00454500 - else if at = 1 then 00454600 - error (next, 6, prefix, suffix) ; 00455000 - end ; 00455100 - error (mailcall, 7, "linklis", "t error") ; 00456500 -new: 00458500 - write (r2 [32 | c + 31], 1, image [*]) ; 00459000 - lock (r2) ; 00459500 - user32 := user | 32 ; 00460000 - bool := initialbool ; 00461000 - inc := 100 ; 00462500 - macrolibrary := "macro " ; 00462900 - character := "#" ; 00463000 - savefactor := 7 ; 00463500 - colstops := stringi := 0 ; 00465000 - fill rswd [*] with "execute", "ditto ", "copy ", "inline ", 00466000 - "zip ", "change ", "edit ", "save ", "reseq ", 00466500 - "punch ", "print ", "delete ", "close ", "compile", 00467000 - "column ", "scan ", "listing", "inc ", "tab ", 00467500 - "percent", "quick ", "list ", "open ", "mail ", 00468000 - "teach ", "remove ", "replace", "end " ; 00468500 -mailcall: 00469000 - fileaccess := 0 ; 00469100 - inorder := true ; 00469200 -next: 00469300 - translatei := real (translating) ; 00472100 - vn := version ; 00472200 - errorx (0, (if xfile ("mail % ", usercode, -1) = 7 then "mail % " 00489500 - else "hello ") & real (not olduser)[42:47:1], usercode) ; 00490000 - end initialize ; 00490500 - lastuser := maxusers ; 00490600 - if qinput then 00491000 - begin 00491100 - qinput := false ; 00491200 - go to inputfull ; 00491300 - end ; 00491400 - if station neq 0 then 00493200 - begin 00493400 - lastuser := user ; 00493410 -next: 00493500 - if more then 00494000 - go to exit ; 00494400 - end ; 00494600 - if not q and readyqtop gtr 0 then 00494700 - begin 00494800 - lastuser := real (waitx (0, boolean (3))) ; 00494900 - securitycheck ; 00495000 - go to exit ; 00495100 - end ; 00495200 -again: 00495300 - charge (0) ; 00495400 - if 2 | bigbird lss c := status (zippy [*]) - 2 then 00495500 - begin 00495600 - lastuser := bigbird + 1 ; 00495650 - for x := 0 step 2 until c do 00495700 - begin 00495800 - station := 0 & zippy [x] [9:9:9] ; 00495900 - for user := 0 step 1 until bigbird do 00496000 - if station = stationi then 00496100 - user := maxusers ; 00496200 - if user leq maxusers then 00496300 - begin 00496400 - if bigbird lss maxuser then 00496500 - begin 00496600 - usercode := zippy [x + 1] ; 00496700 - initialize ; 00496800 - go to next ; 00496900 - end ; 00497000 - nomoreroom ; 00497100 - end ; 00497300 - end ; 00497400 - end ; 00497500 - if x := readtwx neq 0 then 00497600 - begin 00497700 - if x = 2 then 00497800 - go to again ; 00497900 - go to escape ; 00498100 - end ; 00498300 -inputfull: 00506000 - x := input [0] ; 00506100 - user := 0 ; 00506500 - while stationi neq 0 & x[9:9:9] do 00507000 - if user := user + 1 gtr bigbird then 00507500 - go to again ; 00507600 - charge (x) ; 00508000 - if c := chrs neq 0 then 00508500 - read (io [user], 30, image [*]) ; 00509000 - breaki := 0 ; 00511000 - if lineedit (input [1], image, c, c, 00512000 - translatei, c gtr 240, 241) then 00512100 - error (again, 7, "del{!~ ", chrs := 0) ; 00512300 - if boolean (x.[25:1]) then 00512500 - begin 00512600 - if firstchar (input [5]) = "~" then 00513000 - c := c - 4 ; 00513500 - chrs := c ; 00513700 - write (io [user], 30, image [*]) ; 00514000 - go to again ; 00520000 - end ; 00520500 - if boolean (inreadyq) then 00520600 - error (again, 7, "please ", "wait...") ; 00520700 - writelfcr ; 00520800 - chrs := c ; 00520810 - clock := t0 ; 00520850 - t1 := timex ; 00520900 - if outputready then 00520950 - nextclock := clock - t0 | (tn - t1 - 90) / 150 ; 00520960 - if lastuser neq lastuser := user then 00522000 - restorestate ; 00522500 - securitycheck ; 00522600 - waitflag := false ; 00522700 -exit: 00532000 - if finalanalysis then 00532500 - go to next ; 00533500 - if outputready then 00533600 - if tn - 60 leq timex then 00533700 - output ; 00533800 -escape: 00534500 - end readin ; 00546500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00547000 -define rdisc (rdisc1, rdisc2) = 00547100 - if rdiscx (rdisc1, rdisc2) then go to next# ; 00547200 -boolean procedure rdiscx (where, image) ; 00547500 -value where ; 00548000 -integer where ; 00548500 -array image [0] ; 00549000 - begin 00549500 -label eof ; 00549600 -stream procedure zot (d) ; 00549710 -begin 00549720 - di := d ; 00549730 - ds := reset ; 00549740 -end zot ; 00549750 - if prewhere + 1 neq prewhere := abs (where) - 2 then 00550000 - read seek (disc [prewhere]) ; 00550500 - read (disc, 10, image [*]) [eof] ; 00551000 - if cobolfile then 00551010 - zot (image) ; 00551020 - if where lss 0 then 00551030 - sequence ; 00551040 - if false then 00551100 - begin 00551150 -eof: 00551200 - errorx (5, "at seq#", octdex (n)) ; 00551250 - rdiscx := true ; 00551350 - prewhere := -2 ; 00551400 - end ; 00551450 - end rdisc ; 00551500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00552000 -define writeat = 00552500 - if writeatx (quick, -n, record) then 00552800 - go to next# ; 00552900 -boolean procedure writeatx (quick, nn, record) ; 00553000 -value quick, nn ; 00553100 -boolean quick ; 00553200 -integer nn ; 00553300 -array record [0] ; 00553400 - begin 00554000 -label next ; 00554100 - n := abs (nn) ; 00555500 - if not cobolfile then 00556000 - writeseq ; 00556500 - if nn lss 0 then 00556600 - rdisc (at, record) ; 00557000 - if cobolfile then 00557500 - record [0].[1:35] := octdec (n) ; 00558000 - writerow (record, quick, fileinfo) ; 00558500 - if boolean (breaki) then 00559600 -next: 00559700 - writeatx := true ; 00559800 - end writeax ; 00560000 -define writeme (writeme1, writeme2) = 00560100 - if writeatx (quick, writeme1, writeme2) then 00560200 - go to next# ; 00560300 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00560500 -boolean procedure toggle (oldvalue, i) ; 00561000 -value oldvalue, 00561500 - i ; 00562000 -boolean oldvalue ; 00562500 -real i ; 00563000 -begin 00563500 -label next ; 00564000 - if i = 3 then 00564100 - begin 00564110 - if real (oldvalue) = "algol " then 00564120 - toggle := boolean (algol) 00564130 - else if real (oldvalue) = "xalgol " then 00564140 - toggle := boolean (xalgol) 00564150 - else if real (oldvalue) = "data " then 00564160 - toggle := boolean (data) 00564170 - else if real (oldvalue) = "fortran" then 00564180 - toggle := boolean (fortran) 00564190 - else if real (oldvalue) = "cobol " then 00564200 - toggle := boolean (cobol) 00564210 - else if real (oldvalue) = "basic " then 00564220 - toggle := boolean (basic) ; 00564230 - go to next ; 00564240 - end ; 00564250 - if (if i = 1 then empty1 else empty2) then 00564500 - error (next, 7, parameter0, onoff (toggle := oldvalue)) ; 00565000 - i := if i = 1 then parameter1 else parameter2 ; 00565100 - if not (toggle := i = "on ") then 00565500 - if i neq "off " then 00566000 - errorx (0, "missing", " on/off") ; 00566500 -next: 00567000 -end toggle ; 00567500 -define filetype (filetype1) = real (toggle (boolean (filetype1), 3))# ; 00567600 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00568200 -boolean procedure verifax (xerox, dd) ; 00680000 -value xerox, dd ; 00680500 -integer xerox, 00681000 - dd ; 00681100 - begin 00681500 -define 00681600 - printing = xerox = 2#, 00681700 - punching = xerox = 4#, 00681800 - zipping = xerox = 8# ; 00681900 -file copy disk serial [20:dd] (2, 10, 150, save savefactor) ; 00682000 -boolean b ; 00683500 -real l ; 00684000 -label next ; 00684500 - xlocked := true ; 00687000 - if boolean (xerox) then 00687500 - begin 00688000 - fill copy with prefix, suffix, *, *, *, 12 ; 00689000 - l := first ; 00691000 - while at := l.t neq 1 do 00692100 - begin 00692500 - n := (l := ll [at]).s ; 00693300 - rdisc (-at, zippy) ; 00693500 - write (copy, 10, zippy [*]) ; 00695500 - interrupt (1) ; 00696000 - end ; 00696500 - read (disc [0]) ; 00697500 - detach ; 00698000 - close (disc, purge) ; 00698500 - lock (copy) ; 00699500 - reattach ; 00700000 - inorder := true ; 00702500 - fileaccess := 0 ; 00705500 - savestate ; 00706000 - end xerox 00706500 - else 00707000 - begin 00708000 - fill copy with parameter1, parameter2, *, *, *, 00709000 - if printing then 15 else if punching then 22 else 12 ; 00709500 - if printing then 00713000 - begin 00713500 - write (zippy [*], date, prefix.[6:6], prefix, 00714000 - suffix.[6:6], suffix, (l := time (1)) div 216000, 00714500 - l div 3600 mod 60, time (6), mmddyy, 00715000 - usercode.[6:6], usercode) ; 00715500 - detach ; 00716000 - write (copy [dbl], 17, zippy [*]) ; 00716500 - reattach ; 00719000 - end ; 00720000 - l := n ; 00720500 - dd := m := 0 ; 00721000 - b := printing and parameter2 = "double " ; 00721100 - while n := ll [dd := ll [dd].t].s leq parameter4 do 00721500 - if parameter3 leq n then 00722000 - begin 00723000 - rdisc (dd & (real (not zipping))[1:47:1], zippy) ; 00723500 - if printing then 00724000 - zippy [14] := octdex (m := m + 1) & "#"[1:43:5] ; 00724500 - if b then 00726000 - write (copy [dbl], 17, zippy [*]) 00726500 - else write (copy, 17, zippy [*]) ; 00727000 - interrupt (1) ; 00727500 - end 00728000 - else m := m + 1 ; 00728500 - if zipping then 00729000 - zip with copy ; 00729500 - lock (copy) ; 00730000 - n := l ; 00730500 - end thermofax ; 00731000 - if false then 00731100 -next: 00731200 - verifax := true ; 00731300 - xlocked := false ; 00731400 - end verifax ; 00731500 -define thermofax (thermofax1, thermofax2) = 00731600 - begin 00731650 - wait (kount (parameter3, parameter4, clock), xlocked) ; 00731700 - if verifax (thermofax1, thermofax2) then 00731750 - go to next ; 00731800 - end#, 00731850 - createfile (createfile1) = 00731900 - begin 00731950 - library.areas := 20 ; 00732000 - library.areasize := createfile1 ; 00732010 - library.save := savefactor ; 00732020 - write (library, 10, record [*]) ; 00732030 - lock (library) ; 00732040 - library.areasize := 0 ; 00732050 - library.areas := 0 ; 00732060 - end#, 00732100 - closemyfile = 00732150 - begin 00732200 - if not inorder then 00732250 - begin 00732300 - wait (kount (1, finity, clock), xlocked) ; 00732350 - if verifax (17, (d + 14) div 15 | 15) then 00732400 - go to next ; 00732450 - end else 00732500 - begin 00732550 - fileaccess := 0 ; 00732600 - close (disc) ; 00732650 - end ; 00732700 - end# ; 00732750 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00733000 -define wdisc = if wdiscx (image) then go to next# ; 00733500 -boolean procedure wdiscx (image) ; 00734000 -array image [0] ; 00734500 - begin 00735000 -real l ; 00735100 -label eot, 00735500 - next ; 00735600 - while n gtr (l := ll [at]).s do 00743500 - at := l.t ; 00744000 - while n lss (l := ll [at]).s do 00744500 - at := l.f ; 00745000 - if n neq l.s then 00745500 - begin 00746000 - if d geq maxfilelength then 00746500 - error (next, 0, "file to", " long. ") ; 00747000 - if prewhere neq prewhere := d - 2 then 00747100 - read seek (disc [prewhere + 1]) ; 00747200 - l := ll [d := d + 1] := (l.t) & n [sf] & at [ff] ; 00747500 - modify (d) ; 00748000 - ll [at] . t := d ; 00748500 - modify (at) ; 00748600 - at := l.t ; 00749000 - if at neq 1 then 00749500 - inorder := false ; 00750000 - ll [at] .f := d ; 00750500 - modify (at) ; 00750600 - at := d ; 00751000 - end ; 00751500 - sequence ; 00752000 - if prewhere + 1 neq prewhere := at - 2 then 00752500 - write (disc [prewhere], 10, image [*]) 00753000 - else write (disc, 10, image[*]) [eot] ; 00753500 - n := n + inc ; 00753510 - if false then 00753600 - begin 00753610 -eot: 00753620 - ll [l.f] . t := at := l.t ; 00753630 - ll [at] . f := l.f ; 00753640 - d := d - 1 ; 00753650 - inorder := false ; 00753660 - show ("file ", "full. ") ; 00753670 - errorx (0, "please ", "reopen.") ; 00753690 -next: 00753700 - wdiscx := true ; 00753800 - end ; 00753900 - end wdisc ; 00754000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00754500 -integer procedure getparameters (n) ; value n ; integer n ; 00754600 - begin 00754650 -integer stream procedure star (s, d, e) ; value e ; 00754700 - begin 00754750 -local n, 00754800 - plus, 00754850 - minus, 00754900 - crosshatch, 00754950 - k ; 00755000 -label deblank, 00755050 - nalpha, 00755100 - blank, 00755150 - numalpha, 00755200 - getrepeat ; 00755250 - si := s ; 00755300 - si := si - 1 ; 00755350 - di := d ; 00755400 - 5 (ds := 8 lit "+#000000") ; 00755450 - di := d ; 00755500 - e (if sc = "(" then jump out ; 00755550 - if sc = "@" then jump out to getrepeat ; 00755600 - if sc = ";" then jump out to getrepeat ; 00755650 - si := si + 1) ; 00755700 - 5 (tally := 0 ; 00755750 - k := tally ; 00755800 - plus := tally ; 00755850 - minus := tally ; 00755900 - crosshatch := tally ; 00755950 - tally := 1 ; 00756000 -deblank: 00756050 - si := si + 1 ; 00756100 - if sc = " " then 00756150 - go to deblank ; 00756200 - if sc = alpha then 00756250 - tally := 0 00756300 - else 00756350 - begin 00756400 - if sc = ";" then 00756450 - jump out to getrepeat ; 00756500 - if sc = """ then 00756550 - jump out to getrepeat ; 00756600 - if sc = "(" then 00756650 - jump out to getrepeat ; 00756700 - if sc = "[" then 00756750 - jump out to getrepeat ; 00756800 - if sc = "." then 00756850 - jump out to getrepeat ; 00756900 - if sc = "@" then 00756950 - jump out to getrepeat ; 00757000 - if sc = "/" then 00757050 - k := tally 00757100 - else if sc = "+" then 00757150 - plus := tally 00757200 - else if sc = "#" then 00757250 - crosshatch := tally 00757300 - else if sc = "-" then 00757350 - minus := tally ; 00757400 - go to deblank ; 00757450 - end ; 00757500 - if sc geq "0" then 00757550 - begin 00757600 - k (jump out to nalpha) ; 00757650 - k := si ; 00757700 - 8 (if sc lss "0" then 00757750 - jump out ; 00757800 - tally := tally + 1 ; 00757850 - si := si + 1) ; 00757900 - n := tally ; 00757950 - if toggle then 00758000 - begin 00758050 - if sc = alpha then 00758100 - go to numalpha ; 00758150 -blank: 00758200 - if sc = " " then 00758250 - begin 00758300 - si := si + 1 ; 00758350 - go to blank ; 00758400 - end ; 00758450 - if sc = "/" then 00758500 - begin 00758550 -numalpha: 00758600 - si := k ; 00758650 - go to nalpha ; 00758700 - end ; 00758750 - end ; 00758800 - si := k ; 00758850 - ds := n oct ; 00758900 - end 00758950 - else 00759000 - begin 00759050 -nalpha: 00759100 - ds := 1 lit "+" ; 00759150 - 7 (if sc = alpha then 00759200 - ds := 1 chr 00759250 - else ds := 1 lit " ") ; 00759300 - end ; 00759350 - di := di - 8 ; 00759400 - skip 2 db ; 00759450 - ds := plus set ; 00759500 - di := di - 1 ; 00759550 - skip 3 db ; 00759600 - ds := minus set ; 00759650 - di := di - 1 ; 00759700 - skip 3 db ; 00759750 - ds := crosshatch set ; 00759800 - di := di + 7 ; 00759850 - si := si - 1) ; 00759900 -getrepeat: 00759910 - e (if sc = ")" then jump out ; 00759950 - if sc = ";" then jump out ; 00760000 - if sc = "@" then jump out ; 00760050 - si := si + 1) ; 00760100 - e (di := loc star ; 00760200 - ds := 8 lit "00000001" ; 00760250 - di := di - 8 ; 00760300 - 10 (if sc = ";" then jump out ; 00760350 - if sc geq "0" then 00760400 - begin 00760450 - tally := 1 ; 00760500 - 3 (si := si + 1 ; 00760550 - if sc lss "0" then jump out ; 00760600 - tally := tally + 1) ; 00760650 - k := tally ; 00760700 - si := si - k ; 00760750 - ds := k oct ; 00760800 - jump out ; 00760850 - end ; 00760900 - si := si + 1) ; 00760950 - jump out) ; 00761000 -end star ; 00761050 -define xsub = (xdex + 1) | 13# ; 00761100 - if n = 0 then 00761150 - getparameters := star (image, parameter0, 0) 00761200 - else 00761250 - getparameters := star (image, xparameters [0], 63) ; 00761300 -end get parameters ; 00761350 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00761400 -integer procedure verb ; 00763900 -begin 00764000 -boolean procedure number (n, c) ; 00764100 -integer n ; 00764300 -real c ; 00764400 - begin 00764500 -integer xdexx ; 00764510 -label zero ; 00764520 - if xdex geq 0 then 00764530 - begin 00764540 - xdexx := xdex + 1 ; 00764550 - while boolean (c.[4:1]) and xdexx := xdexx - 1 geq 0 do 00764560 - c := xarray [user, xdexx|13 + abs (c&0[1:44:4]-1) mod 5] ; 00764570 - end ; 00764580 - c.[4:1] := 0 ; 00764600 - if number := (not boolean (c.[1:1])) & (c = -"#000000")[46:47:1] then 00764610 - begin 00764620 - if c . [2:2] neq 0 and fileopen then 00764700 - begin 00764800 - c . [1:3] := c . [3:3] ; 00764900 - if c = 0 then 00765100 - begin 00765200 - c := n ; 00765300 - go to zero ; 00765400 - end ; 00765500 - if not (itsold (n) or boolean (c . [1:1])) then 00765600 - c := c - 1 ; 00765700 - for n := 1 - c step 1 until 0 do 00765800 - if at := ll [at] . t = 1 then 00765900 - begin 00766000 - n := 0 ; 00766100 - at := last . f ; 00766200 - end ; 00766300 - for n := c + 1 step 1 until 0 do 00766400 - if at := ll [at] .f = 0 then 00766500 - begin 00766600 - n := 0 ; 00766700 - at := first . t ; 00766800 - end ; 00766900 - c := ll [at] . s ; 00767000 - end else c.[2:2] := 0 ; 00767100 -zero: 00767200 - c := min (finity, max (1, n := c)) ; 00767300 - end else 00767310 - c.[1:3] := 0 ; 00767320 - end number ; 00767400 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00767500 -integer stream procedure inlineedit (s, d, t, c, n, bidr, initial) ; 00767600 -value initial, 00767700 - c, 00767800 - n, 00767900 - bidr ; 00768000 - begin 00768100 -label search, 00768200 - insert, 00768300 - delete, 00768400 - replace, 00768500 - wrapup, 00768600 - loop, 00768700 - error1, 00768710 - here, 00768720 - there, 00768730 - idr, 00768800 - xit ; 00768900 - bidr (si := s ; si := si + 6 ; s := si ; 00769000 - si := d ; si := si + 6 ; d := si ; 00769100 - di := t ; ds := 6 lit "0" ; t := di ; 00769200 - si := c ; si := si - 48 ; c := si) ; 00769300 - di := loc bidr ; 00769400 - ds := 4 lit " idr" ; 00769500 - di := t ; 00769600 - si := t ; 00769700 - ds := 8 lit " " ; 00769800 - ds := 9 wds ; 00769900 - 2 (n (ci := ci + initial ; 00770400 - go to search ; 00770500 - go to idr ; 00770600 - go to idr ; 00770700 - go to idr ; 00770800 - go to wrapup ; 00770900 -search: 00771000 - si := loc c ; 00771100 - si := si + 6 ; 00771200 - di := loc n ; 00771300 - if 2 sc = dc then 00771400 - go to error1 ; 00771500 - si := c ; 00771900 - si := si - 8 ; 00772000 - c := si ; 00772100 - si := d ; 00772200 - di := t ; 00772300 - ds := 1 chr ; 00772400 - d := si ; 00772500 - t := di ; 00772600 - si := s ; 00772700 - di := loc bidr ; 00772800 - 4 (if sc = dc then 00772900 - jump out ; 00773000 - si := si - 1 ; 00773100 - tally := tally + 1) ; 00773200 - if toggle then 00773300 - else 00773400 - begin 00773500 -error1: 00773510 - tally := 1 ; 00773600 - jump out 2 to here ; 00773700 - end ; 00773800 - initial := tally ; 00773900 - tally := 0 ; 00774000 - s := si ; 00774100 - go to loop ; 00774200 -idr: 00774300 - si := loc c ; 00774400 - si := si + 6 ; 00774500 - di := loc n ; 00774600 - if 2 sc = dc then 00774700 - begin 00774800 - si := d ; 00774900 - di := t ; 00775000 - tally := 4 ; 00775100 - initial := tally ; 00775200 -wrapup: 00775300 - ds := 1 chr ; 00775400 - go to loop ; 00775500 - end ; 00775600 - si := c ; 00775700 - si := si - 8 ; 00775800 - c := si ; 00775900 - si := s ; 00776000 - ci := ci + initial ; 00776100 - go to wrapup ; 00776200 - go to insert ; 00776300 - go to delete ; 00776400 - go to replace ; 00776500 -insert: 00776600 - di := t ; 00776700 - ds := 1 chr ; 00776800 - s := si ; 00776900 - t := di ; 00777000 - di := inlineedit ; 00777100 - di := di + 8 ; 00777200 - inlineedit := di ; 00777300 - go to loop ; 00777400 -delete: 00777500 - di := d ; 00777600 - di := di + 1 ; 00777700 - d := di ; 00777800 - si := si + 1 ; 00777900 - s := si ; 00778000 - go to loop ; 00778100 -replace: 00778200 - di := t ; 00778300 - ds := 1 chr ; 00778400 - s := si ; 00778500 - t := di ; 00778600 - si := d ; 00778700 - si := si + 1 ; 00778800 - d := si ; 00778900 -loop: 00779000 - )) ; 00779100 - go to there ; 00779110 -here: 00779120 - go to xit ; 00779130 -there: 00779140 - tally := 0 ; 00779200 - s := si ; 00779300 - si := loc inlineedit ; 00779400 - di := loc bidr ; 00779500 - si := si + 6 ; 00779600 - di := di + 7 ; 00779700 - ds := 1 chr ; 00779800 - si := s ; 00779900 - bidr (2 (32 (if sc neq " " then 00780000 - begin 00780100 - tally := 2 ; 00780200 - jump out 3 to xit ; 00780300 - end ; 00780400 - si := si + 1))) ; 00780500 - inlineedit (if sc neq " " then 00780600 - begin 00780700 - tally := 2 ; 00780800 - jump out 1 to xit ; 00780900 - end ; 00781000 - si := si + 1) ; 00781100 -xit: 00781200 - inlineedit := tally ; 00781300 - end inline ; 00781400 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00781500 -label next, 00786000 - verbexit ; 00786100 -define quick = false# ; 00786110 -next: 00806500 - readin ; 00807000 - if boolean (abnormalend) or user = maxusers then 00807500 - begin 00808000 - verb := rswdm + real (user = maxusers) ; 00809000 - go to verbexit ; 00809500 - end ; 00810000 - if inlinetog then 00811000 - begin 00811500 - inlinetog := false ; 00811600 - if m := inlineedit (image, record, zippy, chrs, 00813000 - halflength, fileinfo = cobol, m) = 0 then 00813500 - begin 00814000 - if inlineecho eqv temptog then 00814100 - writeme (n, zippy) ; 00814200 - if wdiscx (zippy) then ; 00814500 - nostar := false ; 00815000 - go to next ; 00815200 - end ; 00815500 - if m = 2 then 00816000 - error (next, 0, parameter0, " ovrflw") ; 00816100 - error (next, 0, "needs i", ",r or d") ; 00816500 - end ; 00817500 - if nostar then 00818000 - begin 00818500 - if wdiscx (image) then ; 00822500 - go to next ; 00826000 - end ; 00826500 - write (io [user], 30, image [*]) ; 00827000 - i := getparameters (0) ; 00828000 - temptog := parameter0.[2:2] = 0 ; 00828100 - if number (n, parameter0) then 00837000 - begin 00837100 - if fileclosed then 00837500 - error (next, 5, " open:", octdex (parameter0)) ; 00838000 - if not moreinput and itsold (n := parameter0) then 00838500 - writeat ; 00838600 - go to next ; 00839000 - end ; 00839500 - m := resetn := n ; 00839700 - for i := 0 step 1 until rswdm do 00840000 - if parameter0 = rswd [i] then 00840500 - begin 00840600 - relativenumber := parameter1; 00840605 - num1 := number (m, parameter1) ; 00840610 - num2 := number (m, parameter2) ; 00840620 - num3 := number (m, parameter3) ; 00840630 - num4 := number (m, parameter4) ; 00840640 - verb := i ; 00840700 - go to verbexit ; 00841000 - end ; 00841010 - if i := xfile (parameter0, macrolibrary, -1) lss 2 00841100 - and macrolibrary neq "macro " then 00841200 - i := xfile (parameter0, "macro ", -1) ; 00841220 - if i lss 2 or input [3] neq 10 then 00841300 - begin 00841320 - show (parameter0, " invali") ; 00841360 - error (next, 0, "d:* ", rwteach) ; 00841400 - end ; 00841500 -verbexit: 00844500 - end ; 00845000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00846000 -define quicklist = listit (1)#, 00850000 - scan = listit(2)#, 00850100 - change = listit(4)#, 00850200 - edit = listit(8)# ; 00850300 -procedure listit (listtype) ; value listtype ; integer listtype ; 00850400 - begin 00850500 -label next ; 00850600 -define quick = boolean (listtype) and true#, 00850700 - scantog = listtype = 2#, 00850800 - changetog = listtype = 4#, 00850900 - edittog = listtype = 8#, 00851000 - posting = listtype geq 16# ; 00851100 -boolean procedure stringfound ; 00851110 -begin 00851120 -boolean stream procedure present (s, r, i, sr, t, id, k) ; 00851200 -value i, 00851300 - sr, 00851400 - id, 00851500 - k, 00851600 - t ; 00851700 - begin 00851800 -label xit ; 00851900 - si := s ; 00852000 - si := si + k ; 00852100 - s := si ; 00852200 - si := loc sr ; 00852300 - di := loc k ; 00852400 - si := si + 6 ; 00852500 - di := di + 7 ; 00852600 - ds := chr ; 00852700 - di := r ; 00852800 - k (di := di + 32 ; di := di + 32) ; 00852900 - di := di + sr ; 00853000 - r := di ; 00853100 - tally := 1 ; 00853200 - si := loc t ; 00853300 - di := loc k ; 00853400 - si := si + 6 ; 00853500 - di := di + 7 ; 00853600 - ds := 1 chr ; 00853700 - di := r ; 00853800 - k (2 (32 ( 00853900 - si := s ; 00854000 - if i sc = dc then 00854100 - begin 00854200 - id (jump out 4 to xit) ; 00854300 - r := di ; 00854400 - si := r ; 00854500 - if sc = alpha then else 00854600 - begin 00854700 - si := si - i ; 00854800 - si := si - 1 ; 00854900 - if sc = alpha then else 00855000 - jump out 3 to xit ; 00855100 - end ; 00855200 - end ; 00855300 - di := di - i ; 00855400 - di := di + 1))) ; 00855500 - t ( 00855600 - si := s ; 00855700 - if i sc = dc then 00855800 - begin 00855900 - id (jump out 2 to xit) ; 00856000 - r := di ; 00856100 - si := r ; 00856200 - if sc = alpha then else 00856300 - begin 00856400 - si := si - i ; 00856500 - si := si - 1 ; 00856600 - if sc = alpha then else 00856700 - jump out to xit ; 00856800 - end ; 00856900 - end ; 00857000 - di := di - i ; 00857100 - di := di + 1) ; 00857200 - tally := 0 ; 00857300 -xit: 00857400 - present := tally ; 00857500 - end present ; 00857600 - if present (string, zippy, stringi, stringileft, stringirepeat, 00857610 - 1-stringid, 0) eqv temptog then 00857620 - stringfound := true 00857630 - else if stringj neq 0 then 00857640 - stringfound := 00857650 - present (string, zippy, stringj, stringjleft, stringjrepeat, 00857660 - 1-stringjd, stringi) eqv temptog ; 00857670 -end stringfound ; 00857680 -define getstrings = if isolatestrings (listtype) then go to next# ; 00857700 -boolean procedure isolatestrings (listtype) ; 00857800 -value listtype ; 00857900 -integer listtype ; 00858000 -begin 00858100 -stream procedure isolate (s, d, l1, l2) ; 00858200 - begin 00858300 -local stopchr, 00858400 - dx, 00858500 - quotes ; 00858600 -label ok, 00858700 - nostring, 00858800 - string, 00858900 - jumpout, 00858910 - no, 00859000 - nextno ; 00859100 - tally := 63 ; 00859200 - stopchr := tally ; 00859300 - di := loc quotes ; 00859400 - ds := 2 lit """ ; 00859500 - ds := 6 lit "..()[]" ; 00859600 - 2 (si := s ; 00859700 - 63 (si := si + 1 ; 00859800 - if sc = alpha then 00859900 - else if sc neq " " then 00860000 - begin 00860100 - di := loc quotes ; 00860200 - 4 (if sc = dc then jump out 2 to ok ; 00860300 - si := si - 1 ; 00860400 - di := di + 1) ; 00860500 - if sc = ";" then jump out ; 00860600 - end) ; 00860700 - go to nostring ; 00860800 -ok: 00861200 - dx := di ; 00861300 - si := si - 1 ; 00861400 - if sc = "." then 00861500 - begin 00861600 - di := l1 ; 00861700 - ds := lit "+" ; 00861800 - end ; 00861900 - si := si + 1 ; 00862000 - tally := 0 ; 00862100 - stopchr (di := dx ; 00862200 - if sc = dc then 00862300 - jump out 1 to string ; 00862400 - si := si - 1 ; 00862500 - di := d ; 00862600 - ds := 1 chr ; 00862700 - d := di ; 00862800 - tally := tally + 1) ; 00862900 -nostring: 00863000 - di := l1 ; 00863010 - ds := 8 lit "00000010" ; 00863020 - go to jumpout ; 00863030 -string: 00863100 - di := l1 ; 00863200 - di := di + 2 ; 00863300 - 2 (dx := di ; 00863400 - 10 (if sc geq "0" then 00863500 - begin 00863600 - di := dx ; 00863700 - ds := lit "0" ; 00863800 - ds := chr ; 00863900 - if sc geq "0" then 00864000 - begin 00864100 - si := si - 1 ; 00864200 - di := di - 2 ; 00864300 - ds := 2 chr ; 00864400 - end ; 00864500 - jump out 1 to nextno ; 00864600 - end ; 00864700 - if sc = alpha then 00864800 - else if sc neq " " then 00864900 - begin 00865000 - if sc = ";" then jump out 2 to no ; 00865100 - di := loc quotes ; 00865200 - 4 (if sc = dc then 00865300 - begin 00865400 - si := si - 1 ; 00865500 - jump out 3 to no ; 00865600 - end ; 00865700 - si := si - 1 ; 00865800 - di := di + 1) ; 00865900 - end ; 00866000 - si := si + 1) ; 00866100 - jump out to no ; 00866200 -nextno: 00866300 - ) ; 00866400 - go to no ; 00866410 -jumpout: 00866420 - jump out ; 00866430 -no: 00866500 - si := si - 1 ; 00866600 - s := si ; 00866700 - di := l1 ; 00866800 - l1 := tally ; 00866900 - tally := stopchr ; 00867000 - l1 (tally := tally + 63) ; 00867100 - stopchr := tally ; 00867200 - si := loc l1 ; 00867300 - di := di + 7 ; 00867400 - si := si + 7 ; 00867500 - ds := 1 chr ; 00867600 - di := l2 ; 00867700 - l1 := di) ; 00867800 - end isolate ; 00867900 -label next ; 00868000 -integer procedure definestring (i, left, right) ; 00868010 -value left, right ; integer i, left, right ; 00868020 -begin 00868030 - if left := 10|i.[12:6] + i.[18:6] = 99 then 00868060 - begin 00868070 - left := 1 ; 00868080 - right := 80 ; 00868090 - end else 00868100 - if right := 10|i.[24:6] + i.[30:6] = 99 then 00868110 - right := left ; 00868120 - i := fulllength + 1 - stringi ; 00868130 - left := min (max (left, if cobolfile then 6 else 1), i) ; 00868140 - right := min (max (left,right), i) ; 00868150 - definestring := left - 1 ; 00868160 - i := right - left + 1 ; 00868170 -end definestring ; 00868190 - if not scantog then 00868200 - begin 00868300 - if parameter1 = "echo " then 00868400 - begin 00868500 - if changetog then 00868600 - changeecho := toggle (changeecho, 2) 00868700 - else 00868800 - editecho := toggle (editecho, 2) ; 00868900 - go to next ; 00869000 - end ; 00869100 - readonlycheck ; 00869200 - end ; 00869300 - if edittog then 00869400 - begin 00869500 - if not (num1 and num2 and num3) then 00869600 - error (next, 0, parameter0, " error.") ; 00869700 - if not itsold (n := parameter3) then 00869800 - error (next, 0, "missing", " format") ; 00869900 - rdisc (at, record) ; 00870000 - if cobolfile then 00870100 - record [0].[1:35] := "@@@@@@" ; 00870200 - end else 00870300 - begin 00870400 - i := m := 0 & "9999" [12:24:24] ; 00870500 - isolate (image, string, i, m) ; 00870600 - if i neq 64 then 00870700 - begin 00870800 - relativenumber := fileinfo ; 00870900 - if scantog then 00871000 - if not (empty1 or (num1 and (num2 or empty2))) then 00871100 - fileinfo := data ; 00871200 - stringi := i.[41:7] ; 00871300 - stringid := real (i lss 0) ; 00871400 - stringileft := definestring (i, 0, 0) ; 00871500 - stringirepeat := i ; 00871600 - if m neq 64 then 00871700 - begin 00871800 - stringj := m.[41:7] ; 00871900 - stringjd := real (m lss 0) ; 00872000 - stringjleft := definestring (m, 0, 0) ; 00872100 - stringjrepeat := m ; 00872200 - end else 00872300 - stringj := 64 ; 00872400 - fileinfo := relativenumber ; 00872500 - end ; 00874100 - if stringi = 0 or (changetog and stringj = 64) then 00874200 - error (next, 0, "missing", " string") ; 00874300 - if stringj = 64 then 00874400 - stringj := 0 ; 00874500 - end ; 00874600 - if false then 00874700 -next: 00874800 - isolatestrings := true ; 00874900 -end isolatestrings ; 00875000 -procedure externalfile (listtype) ; 00875100 -value listtype ; integer listtype ; 00875200 - begin 00875300 -file ro disk serial (2, input [3], input [4]) ; 00875400 -label more, 00875600 - eof, 00875700 - next ; 00875800 -boolean posted, 00875900 - b ; 00876000 - locked := true ; 00876100 - resetn := n ; 00876300 - fill ro with input [1], input [2], *, *, *, 00876400 - 12 + real (posted := parameter1 = "mail % ") ; 00876500 - n := 0 ; 00876600 - m := input [5] + 1 ; 00876700 - b := posting ; 00876800 - if num3 then 00876900 - begin 00877000 - if n := parameter3 - 1 geq m then 00877100 - error (next, 0, "use rec", "ord #s.") ; 00877110 - read seek (ro [n]) ; 00877120 - if num4 then 00877200 - m := parameter4 ; 00877300 - end 00877400 - else if not empty3 then 00877500 - b := true ; 00877600 - i := if posting then algol else data ; 00877700 - write (zippy [*], star) ; 00877750 -more: 00877800 - interrupt (1) ; 00877900 - if n := n + 1 gtr m then 00878000 - go to eof ; 00878100 - read (ro, 10, zippy [*]) [eof] ; 00878200 - if scantog then 00878300 - if not stringfound then 00878400 - go to more ; 00878500 - if b then 00879100 - begin 00879200 - if posting and firstchar (zippy [0]) = "*" then 00879300 - go to more ; 00879400 - writelfcr ; 00879500 - end else writeseq ; 00879600 - writerow (zippy, quick, i) ; 00879700 - if posted then 00879800 - write (ro, star) ; 00879900 - if breaki = 0 then 00880000 - begin 00880100 - go to more ; 00880200 -eof: 00880300 - if posted then 00880400 - begin 00880500 - detach ; 00880600 - close (ro, purge) ; 00880700 - reattach ; 00880800 - end ; 00880900 - end ; 00880910 -next: 00881000 - n := resetn ; 00881100 - locked := false ; 00881200 - end externalfile ; 00881300 -procedure special (listtype, echo) ; 00881400 -value listtype, echo ; integer listtype ; boolean echo ; 00881500 - begin 00881600 -label 00881700 - rewrite, 00881800 - overflow, 00881900 - next ; 00881950 -define quick = false# ; 00882100 -integer stream procedure changed (s,d,i,j,string,ss,t,t1,sr,m,n,id) ; 00882200 -value i, 00882300 - j, 00882400 - ss, 00882500 - t, 00882600 - t1, 00882700 - sr, 00882800 - id, 00882900 - m, 00883000 - n ; 00883100 - begin 00883200 -local k, 00883300 - total ; 00883400 -label around, 00883500 - xit, 00883600 - no, 00883700 - underflow, 00883800 - here, 00883900 - there, 00883910 - exit ; 00883920 - di := d ; 00884000 - ds := 8 lit " " ; 00884100 - si := d ; 00884200 - ds := 9 wds ; 00884300 - si := loc ss ; 00884400 - di := loc k ; 00884500 - si := si + 6 ; 00884600 - di := di + 7 ; 00884700 - ds := chr ; 00884800 - si := s ; 00884900 - di := d ; 00885000 - k (ds := 32 chr ; ds := 32 chr) ; 00885100 - ds := ss chr ; 00885200 - s := si ; 00885300 - d := di ; 00885400 - k := tally ; 00885500 - 2 (t (k (ds := n chr ; 00885600 - tally := k ; 00885700 - jump out to here) ; 00886000 - di := s ; 00886100 - si := string ; 00886200 - if i sc neq dc then 00886300 - begin 00886400 -no: 00886500 - si := s ; 00886600 - di := d ; 00886700 - ds := chr ; 00886800 - s := si ; 00886900 - d := di ; 00887000 - si := sr ; 00887100 - si := si - 8 ; 00887200 - sr := si ; 00887300 - tally := 1 ; 00887310 - go to here ; 00887400 - end ; 00887500 - id (ss := di ; 00887600 - si := ss ; 00887700 - if sc = alpha then 00887800 - jump out to no ; 00887900 - si := si - i ; 00888000 - si := si - 1 ; 00888100 - if sc = alpha then 00888200 - jump out to no ; 00888300 - si := string ; 00888400 - si := si + i) ; 00888500 - tally := 1 ; 00888600 - changed := tally ; 00888700 - s := di ; 00888800 - di := d ; 00888900 - go to there ; 00888910 -here: 00888920 - go to around ; 00888930 -there: 00888940 - n (di := di + j ; 00889000 - d := di ; 00889100 - di := total ; 00889200 - 8 (di := di + j ; 00889300 - di := di - i) ; 00889400 - total := di ; 00889500 - di := sr ; 00889600 - 8 (di := di - j) ; 00889700 - sr := di ; 00889800 - di := d ; 00889900 - di := di - j ; 00890000 - ds := chr ; 00890100 - tally := j ; 00890200 - jump out to around) ; 00890300 - ds := j chr ; 00890400 - d := di ; 00890500 - si := sr ; 00890600 - 8 (si := si - i) ; 00890700 - sr := si ; 00890800 - tally := i ; 00890900 -around: 00891000 - tally := tally + 63 ; 00891100 - k := tally) ; 00891200 - tally := t1 ; 00891600 - t := tally) ; 00891700 - ci := ci + changed ; 00891800 - go to exit ; 00891900 - m (k (ds := n chr ; 00892000 - tally := k ; 00892100 - tally := tally + 63 ; 00892200 - k := tally ; 00892300 - jump out)) ; 00892400 - tally := 2 ; 00892500 - k (changed := tally ; 00892600 - jump out to exit) ; 00892700 - si := loc sr ; 00892800 - di := loc ss ; 00892900 - 6 (if sc neq "0" then jump out to underflow ; si := si + 1) ; 00893000 - di := di + 7 ; 00893100 - ds := chr ; 00893200 - si := s ; 00893300 - di := d ; 00893400 - ss (ds := 32 chr ; ds := 32 chr) ; 00893500 - ds := sr chr ; 00893600 - s := si ; 00893700 - go to underflow ; 00893710 -exit: 00893720 - go to xit ; 00893730 -underflow: 00893800 - n (si := loc total ; 00893900 - di := loc k ; 00894000 - si := si + 6 ; 00894100 - di := di + 7 ; 00894200 - ds := 1 chr ; 00894300 - si := s ; 00894400 - k (2 (32 (if sc neq " " then 00894500 - begin 00894600 - changed := tally ; 00894700 - jump out 4 to xit ; 00894800 - end ; 00894900 - si := si + 1))) ; 00895000 - total (if sc neq " " then 00895100 - begin 00895200 - changed := tally ; 00895300 - jump out 2 to xit ; 00895400 - end ; 00895500 - si := si + 1)) ; 00895600 -xit: 00895700 - end changed ; 00895800 -boolean stream procedure edits (f, s, d, n) ; 00895900 -value n ; 00896000 - begin 00896100 -label xit ; 00896200 - di := d ; 00896300 - ds := 8 lit " " ; 00896400 - si := d ; 00896500 - ds := 9 wds ; 00896600 - di := d ; 00896700 - d := tally ; 00896800 - 2 (n (si := f ; 00896900 - if sc = "@" then 00897000 - begin 00897100 - si := si + 1 ; 00897200 - f := si ; 00897300 - si := s ; 00897400 - ds := chr ; 00897500 - s := si ; 00897600 - end 00897700 - else if sc = "#" then 00897800 - begin 00897900 - si := si + 1 ; 00898000 - f := si ; 00898100 - si := s ; 00898200 - si := si + 1 ; 00898300 - s := si ; 00898400 - end 00898500 - else 00898600 - begin 00898700 - ds := chr ; 00898800 - f := si ; 00898900 - si := d ; 00899000 - si := si + 8 ; 00899100 - d := si ; 00899200 - end)) ; 00899300 - si := loc d ; 00899400 - di := loc n ; 00899500 - si := si + 6 ; 00899600 - di := di + 7 ; 00899700 - ds := 1 chr ; 00899800 - si := s ; 00899900 - n ( 2 ( 32 (if sc neq " " then 00900000 - begin 00900100 - tally : = 1 ; 00900200 - edits := tally ; 00900300 - jump out 3 to xit ; 00900400 - end ; 00900500 - si := si + 1))) ; 00900600 - d (if sc neq " " then 00900700 - begin 00900800 - tally := 1 ; 00900900 - edits := tally ; 00901000 - jump out ; 00901100 - end ; 00901200 - si := si + 1) ; 00901300 -xit: 00901400 - end edits ; 00901500 -real l ; 00901600 - if changetog then 00901700 - begin 00901710 - parameter1 := stringirepeat div 2 ; 00901720 - parameter2 := stringirepeat - parameter1 ; 00901730 - parameter3 := fulllength - stringileft ; 00901740 - parameter4 := min (parameter3, 63) ; 00901750 - end ; 00901760 - while n := (l := ll [at]).s leq m do 00901900 - begin 00902000 - rdisc (at, zippy) ; 00902100 - if scantog then 00902200 - begin 00902300 - if stringfound then 00902400 - begin 00902700 - writeme (n, zippy) ; 00902900 - n := n + 1 ; 00903000 - go to next ; 00903100 - end ; 00903700 - end 00903800 - else if changetog then 00903900 - begin 00904000 - if i := changed (zippy, image, stringi, stringj, 00904100 - string, stringileft, parameter1, parameter2, 00904200 - parameter3, parameter4, stringi lss stringj, 00904300 - stringid) = 1 then 00904400 - begin 00904500 - resetn := n ; 00904600 -rewrite: 00904700 - if echo then 00904800 - writeme (n, image) ; 00904900 - wdisc ; 00905000 - end else 00905100 - if i = 2 then 00905200 -overflow: 00905250 - error (next, 0, parameter0, "ovrflw") ; 00905300 - end 00905400 - else 00905500 - begin 00905600 - if edits (record, zippy, image, halffulllength) then 00905700 - go to overflow ; 00905800 - go to rewrite ; 00905900 - end ; 00906000 - interrupt (1) ; 00906100 - at := l.t ; 00906110 - end ; 00906200 - if scantog then 00906300 - errorx (0, "eof no ", "string.") ; 00906400 -next: 00906500 - if changetog then 00906600 - n := resetn ; 00906700 - end special ; 00906800 -boolean complex ; 00906900 -real l ; 00906910 - if complex := scantog or changetog or edittog then 00907000 - getstrings ; 00907100 - if num1 and (num2 or empty2 or changetog) then 00907200 - begin 00907300 - n := parameter1 ; 00907400 - if num2 then 00907500 - m := parameter2 00907600 - else if scantog then 00907700 - m := finity 00907800 - else m := n ; 00907900 - end 00908000 - else if not (empty1 or changetog) then 00908100 - begin 00908200 - if xfile (12, 0, 2) lss 2 then 00908300 - go to next ; 00908400 - if locked or not posting then 00908500 - wait ((if num3 and num4 then 00908600 - min (parameter4, input [5]) else input [5]) - 00908700 - (if num3 then parameter3 else 0), locked) ; 00908800 - externalfile (listtype) ; 00908900 - go to next ; 00909000 - end 00909100 - else 00909200 - begin 00909300 - if not complex then 00909400 - begin 00909500 - at := 0 ; 00909600 - n := 1 ; 00909700 - end ; 00909800 - if changetog then 00909900 - m := n 00910000 - else 00910100 - m := finity ; 00910200 - end ; 00910300 - opencheck ; 00910400 - if complex then 00910500 - wait (kount (n, m, clock), false) ; 00910600 - if itsold (n) then ; 00910700 - if complex then 00910900 - special (listtype, temptog eqv (if changetog then changeecho 00911000 - else editecho)) 00911050 - else 00911100 - begin 00911200 - while n := (l := ll [at]).s leq m do 00911300 - begin 00911310 - writeat ; 00911400 - interrupt (1) ; 00911410 - at := l.t ; 00911420 - end ; 00911500 - n := ll [l.f].s + inc ; 00911600 - end ; 00911700 -next: 00911800 - end listit ; 00911900 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00912000 -procedure execute ; 00950000 -begin 00950100 -label next ; 00950200 -integer xsub ; 00950300 -real ystart, 00950400 - ylast, 00950500 - yfiletype, 00950600 - yrepeat, 00950700 - ynchrs ; 00950800 -boolean verbisexecute ; 00950900 - if verbisexecute := parameter0 = rswd [0] then 00951000 - if parameter1 = "library" then 00951100 - begin 00951200 - if empty2 then 00951300 - error (next, 7, "macro=/", macrolibrary) ; 00951400 - if num2 then 00951500 - macrolibrary := octdec (parameter2) 00951600 - else 00951700 - macrolibrary := parameter2 ; 00951800 - go to next ; 00951900 - end else 00952000 - if parameter1 = "echo " then 00952100 - begin 00952200 - executeecho := toggle (executeecho, 2) ; 00952300 - go to next ; 00952400 - end ; 00952500 - if xdex + 1 geq xmax then 00952600 - error (next, 0, parameter0, " ovrflw") ; 00952700 - xsub := (xdex + 1) | 13 ; 00952800 - yfiletype := data ; 00952900 - if not verbisexecute then 00953000 - begin 00953100 - xparameters [0] := parameter1 ; 00953200 - xparameters [1] := parameter2 ; 00953300 - xparameters [2] := parameter3 ; 00953400 - xparameters [3] := parameter4 ; 00953500 - xparameters [4] := -"#000000" ; 00953600 - yrepeat := 1 ; 00953700 - parameter2 := input [2] ; 00953800 - parameter1 := parameter0 ; 00953900 - ylast := input [5] + 1 ; 00954000 - end else 00954100 - if fileopen and (num1 or empty1) and (num2 or empty2) then 00954200 - begin 00954300 - if num1 then 00954400 - begin 00954500 - parameter3 := parameter1 ; 00954600 - if num2 then 00954700 - parameter4 := parameter2 00954800 - else 00954900 - parameter4 := parameter3 ; 00955000 - end else 00955100 - begin 00955200 - parameter3 := 1 ; 00955300 - parameter4 := infinity ; 00955400 - end ; 00955500 - parameter1 := octdec(xdex+1+10|station.[14:4]+1000|station.[9:4]);00955600 - parameter2 := "#macro" ; 00955700 - if yfiletype := xfile (parameter1, parameter2, -1) = 7 then 00955800 - begin 00955900 - read (library) ; 00956000 - detach ; 00956100 - close (library, purge) ; 00956200 - reattach ; 00956300 - end else 00956400 - if yfiletype geq 0 then 00956500 - error (next, 4, parameter1, parameter2) ; 00956600 - ylast := kount (parameter3, parameter4, -1) ; 00956700 - i := savefactor ; 00956710 - freefile (station) ; 00956800 - thermofax (savefactor := 0, (ylast + 14) div 15 | 15) ; 00956900 - unfreefile (station) ; 00957000 - savefactor := i ; 00957010 - yfiletype := fileinfo ; 00957100 - end else 00957200 - begin 00957300 - if xfile (12, 0, 2) lss 2 then 00957400 - go to next ; 00957500 - ylast := input [5] + 1 ; 00957600 - if num3 then 00957700 - begin 00957800 - if ystart := parameter3 - 1 gtr ylast then 00957900 - error (next, 0, "use rec", "ord #s.") ; 00958000 - if num4 then 00958100 - if parameter4 lss ylast then 00958200 - ylast := parameter4 ; 00958300 - end ; 00958400 - end ; 00958500 - if xdex lss 0 then 00958600 - xecho := temptog eqv executeecho ; 00958700 - if verbisexecute then 00958800 - if yrepeat := getparameters (63) = 0 then 00958900 - go to next ; 00959000 - wait ((ylast - ystart) | yrepeat | 3, false) ; 00959100 - if moreinput then 00959200 - begin 00959300 - read (io [user + maxusers], 30, image [*]) ; 00959400 - write (io [2|maxusers+xmax|user+xdex+1], 30, image [*]) ; 00959410 - ynchrs := nchrs & 1[1:47:1] ; 00959500 - moreinput := false ; 00959600 - end ; 00959700 - xdex := xdex + 1 ; 00959800 - xn := xstart := ystart ; 00959900 - xlast := ylast ; 00960000 - xfiletype := yfiletype ; 00960100 - xrepeat := yrepeat ; 00960200 - xnchrs := ynchrs ; 00960300 - xprefix := parameter1 ; 00960400 - xsuffix := parameter2 ; 00960500 -next: 00960600 -end execute ; 00960700 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00970000 -procedure xverbs (k) ; value k ; integer k ; 00970100 -begin 00970200 -define 00970300 - replace = 00970400 - begin 00970500 - if num2 or empty2 then 00970600 - error (next, 0, parameter2, " is bad") ; 00970700 - m := -1 ; 00970800 - for i := 0 step 1 until rswdm do 00970900 - if parameter0 := rswd [i] = parameter1 then 00971000 - m := i 00971100 - else if parameter0 = parameter2 then 00971200 - error (next, 0, "dup ", parameter2) ; 00971300 - if m lss 0 then 00971400 - error (next, 0, "no verb", parameter1) ; 00971500 - rswd [m] := parameter2 ; 00971600 - end#, 00971700 - delete = 00971800 - begin 00971900 - opencheck ; 00972000 - if not num1 then 00972100 - parameter1 := n ; 00972200 - inorder := readonlyfile ; 00972300 - if not num2 or parameter2 lss parameter1 then 00972400 - parameter2 := parameter1 ; 00972500 - i := ll [loc (parameter1)] . f ; 00972600 - if itsold (parameter2) then 00972700 - at := ll [at] . t ; 00972800 - ll [i] . t := at ; 00972900 - modify (i) ; 00973000 - ll [at] . f := i ; 00973100 - modify (at) ; 00973200 - n := ll [i] .s + inc ; 00973300 - end#, 00973400 - printorpunch = 00973500 - begin 00973600 - opencheck ; 00973700 - if not num3 then 00973800 - parameter3 := 1 ; 00973900 - if not num4 then 00974000 - parameter4 := finity ; 00974100 - thermofax (k, 0) ; 00974200 - end# ; 00974300 -label next ; 00974400 - if boolean (k) then 00974500 - if k = 1 then 00974600 - replace 00974700 - else 00974800 - delete 00974900 - else if k = 0 then 00975000 - closemyfile 00975100 - else 00975200 - printorpunch ; 00975300 -next: 00975400 -end xverbs ; 00975500 -define closefile = xverbs (0)#, 00975600 - replace = xverbs (1)#, 00975700 - print = xverbs (2)#, 00975800 - delete = xverbs (3)#, 00975900 - punch = xverbs (4)# ; 00976000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01023000 -procedure mail ; 01023500 - begin 01024000 -label next ; 01024100 -boolean stream procedure postfrom (sender, message, z) ; 01024500 - begin 01025000 -label ok, 01025500 - exit ; 01026000 - si := z ; 01026500 - di := z ; 01027000 - ds := 8 lit " " ; 01027500 - ds := 8 wds ; 01028000 - si := message ; 01028500 - 20 (if sc = ":" then 01029000 - jump out to ok ; 01029500 - si := si + 1) ; 01030000 - tally := 1 ; 01030500 - postfrom := tally ; 01031000 - go to exit ; 01031500 -ok: 01032000 - si := si + 1 ; 01032500 - di := z ; 01033000 - 63 (if sc = ";" then 01033500 - jump out ; 01034000 - ds := 1 chr) ; 01034500 - ds := 1 lit "-" ; 01035000 - si := sender ; 01035500 - si := si + 1 ; 01036000 - ds := 7 chr ; 01036500 -exit: 01037000 - end postfrom ; 01037500 - if num2 then 01038000 - parameter2 := octdec (parameter2) ; 01038500 - i := xfile ("mail % ", if empty1 then usercode else parameter2, 01039000 - -1) ; 01039500 - if empty1 then 01040500 - begin 01041000 - if i lss 7 then 01041500 - error (next, 0, "sorry, ", "no mail") ; 01042000 - parameter1 := "mail % " ; 01042500 - num1 := false ; 01043500 - parameter2 := usercode ; 01044000 - num2 := false ; 01045000 - num3 := false ; 01045500 - listit (17) ;%posting and quick 01046000 - end 01047000 - else 01047500 - begin 01048000 - if parameter1 neq "to " then 01048500 - error (next, 0, "missing", " to. ") ; 01049000 - if postfrom (usercode, image, record) then 01049500 - error (next, 0, "missing", " colon.") ; 01050000 - if i lss 0 then 01050500 - begin 01051000 - freefile (station) ; 01051500 - parameter1 := "mail % " ; 01052000 - createfile (15) ; 01053000 - unfreefile (station) ; 01053500 - end 01054000 - else if i gtr 2 then 01054500 - begin 01055000 - write (library [input [5] + 1], 10, record [*]) ; 01055500 - close (library) ; 01056000 - end else 01056500 - errorx (1, "mail % ", parameter2) ; 01056600 - end ; 01057500 -next: 01058000 - end postman ; 01058500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01059000 -procedure copy ; 01059500 - begin 01060000 -boolean b, 01060100 - merge ; 01060200 -label next ; 01060500 - if parameter1 = "overite" then 01060550 - begin 01060600 - copyclobber := toggle (copyclobber, 2) ; 01060700 - go to next ; 01060850 - end ; 01060900 - readonlycheck ; 01060950 - if xfile (12, 0, 2) lss 2 then 01061500 - go to next ; 01062000 - if input [3] neq 10 or input [4] mod 30 neq 0 then 01063500 - error (next, 3, parameter1, parameter2) ; 01064000 - if num3 then 01064500 - begin 01065000 - i := parameter3 - 1 ; 01065500 - if i gtr input [5] then 01066000 - error (next, 0, "use rec", "ord #s.") ; 01066500 - if num4 then 01067000 - m := min (parameter4 - 1, input [5]) 01067500 - else m := i ; 01070000 - end 01070400 - else 01071000 - begin 01071500 - i := 0 ; 01072000 - m := input [5] ; 01072500 - if datafile and merge := parameter3 = "merge " then 01072600 - error (next, 5, " type: ", parameter3) ; 01072700 - end ; 01073000 - wait (m - i, false) ; 01073500 - read seek (library [i]) ; 01075000 - b := not (copyclobber eqv temptog) ; 01075100 - for i := i step 1 until m do 01075500 - begin 01076000 - read (library, 10, image [*]) ; 01076100 - if merge then 01076200 - n := if cobolfile then dec (image [0], 6) 01076300 - else dec (image [9], 8) ; 01076400 - if itsold (n) and b then 01076500 - error (next, 0, "overite", " is off") ; 01076600 - wdisc ; 01077000 - interupt (1, 1, i + 1) ; 01078000 - end ; 01078500 -next: 01079500 - close (library) ; 01079600 - end ; 01080000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01086500 -procedure zipit ; 01087000 - begin 01087500 -alpha stream procedure endcheck (s) ; 01087550 -begin 01087600 - si := s ; 01087650 - if sc = "?" then 01087700 - begin 01087710 - di := loc endcheck ; 01087750 - di := di + 3 ; 01087800 - ds := chr ; 01087810 - 63 (if sc neq " " then jump out ; 01087850 - si := si + 1) ; 01087900 - 4 (if sc = alpha then ds := 1 chr else jump out) ; 01087950 - end ; 01087960 -end endcheck ; 01088000 -label next ; 01088050 - readonlycheck ; 01088100 - rdisc (first . t, record) ; 01089500 - if endcheck (record) = 0 then 01090000 - error (next, 0, "inv fir", "st card") ; 01090500 - rdisc (last . f, image) ; 01092000 - if endcheck (image) neq "?end0" then 01093100 - error (next, 0, "no end ", "card. ") ; 01093200 - wait (kount (1, finity, clock) | 2, xlocked) ; 01095500 - fill library with prefix, suffix ; 01096000 - read seek (library [m := (at := first.t) - 2]) ; 01096500 - i := 0 ; 01096600 - while at := ll [at] . t neq 1 do 01097000 - begin 01097500 - rdisc (at, image) ; 01098000 - i := i + 1 ; 01098100 - if endcheck (image) neq 0 then 01098500 - begin 01099000 - record [9] := i ; 01100000 - write (library, 10, record [*]) ; 01100500 - if m + 1 neq m := at - 2 then 01100510 - read seek (library [m]) ; 01100600 - read (image [*], 10, record [*]) ; 01101600 - end ; 01102000 - interupt (1, 2, m) ; 01102500 - end ; 01103000 - image [9] := i ; 01104000 - write (library, 10, image [*]) ; 01104500 - close (library) ; 01104600 - if not empty1 then 01105000 - begin 01105500 - parameter3 := 1 ; 01106100 - parameter4 := finity ; 01106200 - thermofax (8, (d + 14) div 15 | 15) ; 01107500 - end 01108500 - else 01109000 - begin 01109500 - fileinfo := data ; 01109600 - closefile ; 01110000 - zip with disc ; 01111000 - end ; 01111500 -next: 01111600 - close (library) ; 01111700 - end ; 01112000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01113000 -define closeit = 01113500 - begin 01113600 - opencheck ; 01113700 - closefile ; 01113800 - end# ; 01116500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01117000 -procedure open ; 01117500 - begin 01118000 -label next ; 01118500 - if fileopen then closefile ; 01119000 - tabamount := 0 ; 01119500 - prewhere := -1 ; 01121000 - if fileinfo := filetype (parameter3) = 0 then 01122000 - error (next, 5, " type: ", parameter3) ; 01126000 - i := xfile (12, 0, -1) ; 01126100 - fill disc with prefix := parameter1, suffix := parameter2 ; 01126200 - if parameter4 = "new " then 01126500 - begin 01127000 - if i geq 0 then 01128500 - error (next, 4, parameter1, parameter2) ; 01129000 - createfile (450) ; 01130000 - fileaccess := 7 ; 01130500 - first := d := 1 ; 01130650 - last := 1 & infinity [sf] ; 01130700 - modified := true ; 01130750 - n := 0 ; 01130800 - inorder := false ; 01130850 - go to next ; 01130900 - end ; 01131000 - if i leq 0 then 01133500 - error (next, 1 - i, parameter1, parameter2) ; 01134000 - if input [3] neq 10 or input [4] mod 30 neq 0 then 01134500 - error (next, 3, parameter1, parameter2) ; 01135000 - if input [6] neq 0 then 01135500 - error (next, 0, "file in", " use. ") ; 01136000 - if d := input [5] + 2 gtr maxfilelength then 01146000 - error (next, 0, "file to", " long. ") ; 01147500 - if parameter4 = "old " or datafile then 01155000 - begin 01155500 - inorder := datafile or readonlyfile ; 01156000 - n := 0 ; 01157500 - for at := 2 step 1 until d do 01157600 - ll [at] := (at+1) & (n:=n+inc)[sf] & (at-1)[ff] ; 01157700 - end else 01158000 - begin 01158500 - wait (d, false) ; 01158600 - m := 0 ; 01159000 - for at := 2 step 1 until d do 01160000 - begin 01160500 - read (library, 10, image [*]) ; 01161000 - n := if cobolfile then dec (image [0], 6) 01161500 - else dec (image [9], 8) ; 01162000 - if m gtr n then 01164500 - error (next, 0, "seqerr ", octdex (m)) ; 01166000 - ll [at] := (at+1) & (m:=n)[sf] & (at-1)[ff] ; 01167500 - interupt (1, 2, at - 1) ; 01167600 - end ; 01168000 - end ; 01168100 - fileaccess := i ; 01168200 - modified := not false ; 01168210 - ll [d] . t := 1 ; 01168220 - first := 2 ; 01168230 - last := 1 & infinity [sf] & d [ff] ; 01168240 - ll [2] . f := 0 ; 01168250 -next: 01168500 - close (library) ; 01168600 - n := n + inc ; 01169000 - at := 0 ; 01169100 - if readonlyfile then 01169500 - errorx (7, "read on", "ly file") ; 01170000 - end ; 01171000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01171500 -define increment = 01172000 - begin 01172100 - if not num1 then 01172500 - errorx (7, parameter0, octdex (inc)) 01173000 - else inc := parameter1 ; 01173500 - end# ; 01174000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01174500 -procedure reseq ; 01175000 - begin 01175500 -real l ; 01175600 -label next ; 01176000 - opencheck ; 01176100 - if num2 then 01176500 - begin 01177000 - if not num1 then 01177500 - error (next, 0, parameter1, "invalid") ; 01178000 - if num4 then 01178500 - inc := parameter4 ; 01179000 - if num3 then 01179500 - m := parameter3 - inc 01180000 - else m := parameter1 - inc ; 01180500 - if m + inc | kount (parameter1,parameter2,-1) geq ll [at].s then 01180600 - error (next, 0, parameter0, " error.") ; 01180700 - at := loc (parameter1) ; 01181000 - if m + inc leq ll [ll [at].f].s then 01181010 - error (next, 0, parameter0, " error.") ; 01181020 - n := m ; 01181500 - while (l := ll [at]).s leq parameter2 do 01182000 - begin 01182500 - ll [at] . s := n := n + inc ; 01183000 - modify (at) ; 01183500 - at := l.t ; 01183600 - end ; 01184000 - end 01185500 - else 01186000 - begin 01186500 - if num1 then 01187000 - inc := parameter1 ; ; 01187500 - if inc | kount (1, finity, -1) geq infinity then 01187600 - error (next, 0, parameter0, " error.") ; 01187700 - n := 0 ; 01188000 - at := 0 ; 01188500 - while at := ll [at] . t neq 1 do 01189000 - ll [at] . s := n := n + inc ; 01189500 - modified := not false ; 01189600 - end ; 01190000 - n := n + inc ; 01190500 - if not datafile then 01191000 - inorder := readonlyfile ; 01191500 -next: 01192000 - end reseq ; 01192500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01193000 -define tab = 01193500 - begin 01193600 - if not num1 then 01194000 - begin 01194010 - if not empty1 then 01194100 - tabon := toggle (tabon, 1) 01194300 - else 01194450 - errorx (7, parameter0, onoff (tabon) & 01194500 - octdex (if cobolfile then tabamount + 7 else tabamount + 1) 01194600 - [36:36:12]) ; 01194700 - end else 01194800 - begin 01194900 - if relativenumber.[2:2] neq 0 then 01194910 - parameter1 := tabamount + 1 + 01194920 - (relativenumber & relativenumber[1:3:3]) 01194930 - else if cobolfile then 01194940 - parameter1 := parameter1 - 6 ; 01194950 - if tabamount := parameter1 gtr 55 then 01195000 - tabamount := 55 ; 01195500 - if tabamount := tabamount - 1 lss 0 then 01197000 - tabamount := 0 ; 01197500 - end ; 01197600 - end#, 01198000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01198500 - saveit = 01199000 - begin 01199100 - if not num1 then 01199500 - errorx (7, parameter0, octdex (savefactor)) 01200000 - else savefactor := parameter1 ; 01200500 - end # ; 01201000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01211500 -procedure compile ; 01212000 - begin 01212500 -label next ; 01213000 - opencheck ; 01213100 - if empty2 then 01213500 - error (next, 3, parameter1, parameter2 ) ; 01214000 - if datafile and empty3 then 01216000 - error (next, 3, prefix, suffix) ; 01216500 - if not empty3 then 01217000 - if xfile (parameter3, "disk ", 2) lss 2 then 01218000 - go to next ; 01218500 - if parameter0 := xfile ("line ", usercode, -1) = 7 then 01221500 - begin 01223000 - read (library) ; 01223500 - detach ; 01224000 - close (library, purge) ; 01224500 - reattach ; 01225000 - end else 01225500 - if parameter0 geq 0 then 01226000 - error (next, 4, "line ", usercode) ; 01226500 - if xfile (12, 0, -1) geq 0 then 01227000 - error (next, 4, parameter1, parameter2) ; 01228500 - closefile ; 01229000 - if empty3 then 01230000 - if compiler = algol then 01230500 - parameter3 := "algol " 01231000 - else if compiler = fortran then 01231500 - parameter3 := "fortran" 01232000 - else if compiler = xalgol then 01232500 - parameter3 := "xalgol " 01233000 - else if compiler = basic then 01233500 - parameter3 := "basic " 01234000 - else 01234500 - parameter3 := "cobol " ; 01235000 - write (zippy [*], zipper, parameter1.[6:6], 01238000 - parameter1, parameter2.[6:6], parameter2, parameter3.[6:6], 01238500 - parameter3, prefix.[6:6], prefix, suffix.[6:6], suffix, 01239000 - usercode . [6 : 6], usercode) ; 01239500 - zip with zippy [*] ; 01240000 -next: 01242000 - end compile ; 01242500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01243000 -procedure ditto ; 01243400 - begin 01244000 -boolean b ; 01244100 -real l ; 01244200 -procedure link (x, y) ; value x, y ; integer x, y ; 01244300 -begin 01244310 - ll [x].t := y ; 01244320 - modify (x) ; 01244330 - ll [y].f := x ; 01244340 - modify (y) ; 01244350 -end link ; 01244360 -label next ; 01244500 - if parameter1 = "overite" then 01244550 - begin 01244600 - dittoclobber := toggle (dittoclobber, 2) ; 01244700 - go to next ; 01244850 - end ; 01244900 - readonlycheck ; 01245000 - if not num1 then 01246000 - error (next, 0, parameter0, " error.") ; 01246500 - if parameter2 = "move " or parameter3 = "move " then 01246510 - begin 01246520 - if not num2 then 01246530 - parameter2 := parameter1 ; 01246540 - b := itsold (n) ; 01246550 - parameter4 := ll [parameter3 := at] ; 01246560 - m := ll [i := loc (parameter1)].f ; 01246570 - if parameter0 := kount (parameter1,parameter2,-1) - 1 lss 0 then 01246580 - go to next ; 01246590 - if itsold (parameter2) then 01246600 - l := ll [at].t 01246610 - else 01246620 - at := ll [l := at].f ; 01246630 - if (b and b := ll [m].s geq n or n geq ll [l].s) or 01246640 - n+inc|parameter0 geq (if b then parameter4 else ll [l]).s then 01246650 - error (next, 0, "no room", ": move ") ; 01246660 - if b then 01246670 - begin 01246680 - link (m, l) ; 01246690 - link (at, parameter3) ; 01246700 - link (parameter4.f, i) ; 01246710 - end else 01246720 - parameter3 := l ; 01246730 - do begin 01246740 - ll [i].s := n ; 01246750 - n := n + inc ; 01246760 - modify (i) ; 01246770 - end until i := ll [i].t = parameter3 ; 01246780 - inorder := false ; 01246790 - go to next ; 01246800 - end ; 01246810 - close (disc) ; 01247000 - prewhere := parameter3 := -1 ; 01247100 - if num2 then 01247500 - wait (kount (parameter1, parameter2, clock), false) 01248500 - else parameter2 := parameter1 ; 01250000 - fill library with prefix, suffix ; 01250500 - i := loc (parameter1) ; 01251600 - m := d ; 01252000 - b := not (dittoclobber eqv temptog) ; 01252100 - while (l := ll [i]).s leq parameter2 and i leq m do 01252500 - begin 01253500 - if parameter3 + 1 neq parameter3 := i then 01254000 - read seek (library [i - 2]) ; 01254500 - if itsold (n) and b then 01255000 - error (next, 0, "overite", " is off") ; 01255500 - i := l.t ; 01256000 - read (library, 10, image [*]) ; 01256500 - wdisc ; 01257000 - interupt (1, 2, i - 2) ; 01257500 - end ; 01258000 -next: 01259500 - close (library) ; 01260000 - end ditto ; 01261000 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01261500 -procedure remove ; 01262000 - begin 01262500 -label next ; 01263000 - if empty2 and parameter1 = "listing" then 01263100 - begin 01263200 - parameter1 := "line " ; 01263300 - parameter2 := usercode ; 01263400 - end ; 01263500 - if xfile (12, 0, 4) lss 4 then 01263600 - go to next ; 01263700 - if parameter1 = prefix then 01264000 - if parameter2 = suffix and readwritefile then 01264500 - begin 01265000 - read (disc [0]) ; 01265500 - detach ; 01266000 - close (disc, purge) ; 01266500 - reattach ; 01267500 - fileaccess := 0 ; 01268000 - inorder := true ; 01268500 - go to next ; 01269000 - end ; 01269500 - if input [6] neq 0 then 01273000 - error (next, 0, "file in", " use. ") ; 01273500 - read (library) ; 01274000 - detach ; 01274500 - close (library, purge) ; 01275000 - reattach ; 01275500 -next: 01276000 - end remove ; 01276500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01277000 -procedure listing ; 01277200 - begin 01277400 -boolean locked ; 01277500 -integer p5 ; 01277510 -label next ; 01277600 -file line 15 (2, 15) ; 01277800 -file feedback disk serial (2, 15, 30) ; 01278000 -real stream procedure readz (z, skp, a, n) ; 01278200 -value skp, a, n ; 01278210 -begin 01278220 -label exit ; 01278230 - si := z ; 01278240 - si := si + skp ; 01278250 - di := loc readz ; 01278260 - a (di := di + 8 ; di := di - n ; ds := n chr ; jump out to exit) ; 01278270 - ds := n oct ; 01278280 -exit: 01278290 -end readz ; 01278300 - if xfile ("line ", usercode, 1) lss 1 then 01278400 - go to next ; 01278600 - if not empty1 then 01279200 - if i := filetype (parameter1) = 0 or i = data then 01279400 - error (next, 5, "type: ", parameter1) ; 01281600 - wait (input [5], ylocked) ; 01281800 - ylocked := locked := true ; 01282000 - fill feedback with "line ", usercode ; 01282200 - if num2 and num3 and num4 then 01282400 - begin 01282600 - parameter1 := 1 ; 01282800 - writesegment ; 01283200 - parameter0 := if i=fortran then 10 else real(i geq algol)+12 ; 01283300 - p5 := if i geq algol then parameter0 - 1 else 0 ; 01283310 - end 01283600 - else if parameter2.[6:30] = "error" or parameter2 01283800 - = "syntax " then 01284000 - begin 01284100 - parameter1 := 2 ; 01284200 - p5 := if i=fortran then 9 else 12 ; 01284300 - end 01284310 - else if empty2 then 01284400 - begin 01284600 - fill line with "line ", usercode ; 01284800 - detach ; 01285000 - write (line) ; 01285200 - reattach ; 01285400 - parameter1 := 3 ; 01285600 - end 01285800 - else 01286000 - error (next, 0, parameter0, " error.") ; 01286200 - do begin 01286400 - read (feedback, 15, zippy [*]) [next] ; 01287000 - if parameter1 = 1 then 01287200 - begin 01287400 - if i = fortran then 01287600 - begin 01287800 - if n := readz (zippy [11], 4, 1, 4) neq "long" then 01288000 - if n := readz (zippy [11], 3, 0, 4) neq 0 then 01288200 - m := n ; 01288400 - end 01288800 - else if i geq algol then 01289000 - begin 01289200 - if n := readz (zippy [14], 4, 0, 4) neq 0 then 01289400 - m := n ; 01289600 - end 01289800 - else m := readz (zippy [12], n := 0, 0, 4) ; 01293000 - if m = parameter2 and n = 0 then 01293200 - begin 01293400 - n := readz (zippy [parameter0], real (i=cobol) + 4, 0, 4) ; 01293600 - if n gtr parameter4 then 01294600 - go to next ; 01294800 - if parameter3 leq n then 01295000 - begin 01295200 - parameter3 := n ; 01295400 - n := readz (zippy [p5], if i=cobol then 3 else 0, 0, 8) ; 01295600 - writeseq ; 01296600 - writereladdr ; 01297000 - end ; 01297200 - end ; 01297400 - end 01297600 - else if parameter1 = 2 then 01297800 - begin 01298000 - if i = cobol then 01298200 - begin 01298400 - m := readz (zippy [0], 0, 1, 1) ; 01298600 - if m = " " or m = "[" then 01298800 - m := readz (zippy [0], 5, 0, 6) 01299000 - else m := 0 ; 01299200 - end 01299400 - else m := readz (zippy [p5], 0, 0, 8) ; 01300000 - if m = 0 and n gtr 0 then 01300200 - begin 01301200 - writeseq ; 01301600 - writerow (zippy, true, data) ; 01301800 - end else n := m ; 01302000 - end 01302200 - else 01302400 - write (line [dbl], 15, zippy [*]) ; 01302600 - interrupt (1) ; 01302800 - end until boolean (breaki) ; 01303000 -next: 01303200 - n := resetn ; 01303400 - if locked then 01303500 - ylocked := false ; 01303600 - end listing ; 01303800 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01345000 -procedure inline ; 01345500 - begin 01345550 -label next ; 01345560 -define quick = false# ; 01345570 - if parameter1 = "echo " then 01345600 - begin 01345610 - inlineecho := toggle (inlineecho, 2) ; 01345620 - go to next ; 01345660 - end ; 01345670 - readonlycheck ; 01345700 - if num1 then 01346000 - begin 01346500 - n := parameter1 ; 01347000 - if not itsold (n) then 01347500 - error (next, 0, "missing", octdex (n)) ; 01348000 - if not moreinput then 01348500 - writeat ; 01349000 - i := parameter2.[6:6] ; 01349500 - end 01350000 - else 01350500 - begin 01351000 - at := ll [loc (n)].f ; 01351500 - n := ll [at].s ; 01352500 - i := parameter1.[6:6] ; 01353000 - end ; 01353500 - if not num1 or moreinput then 01353600 - rdisc (at, record) ; 01354000 - inlinetog := true ; 01354500 - if i = "i" then 01356000 - m := 1 01356500 - else if i = "d" then 01357000 - m := 2 01357500 - else if i = "r" then 01358000 - m := 3 01358500 - else m := 0 ; 01359000 -next: 01359500 - end inline; 01359600 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01360000 -procedure column ; 01360100 - begin 01360150 - integer stream procedure getchar (s) ; 01360200 - begin 01360250 - label nope, yes, xit ; 01360300 - di := loc getchar ; 01360350 - si := s ; 01360400 - 2(40(if sc = alpha then else if sc = " " then else 01360450 - if sc = """ then 01360500 - jump out 2 to yes 01360550 - else if sc = "." then 01360600 - jump out 2 to yes 01360650 - else if sc = "(" then 01360700 - jump out 2 to yes 01360750 - else if sc = "[" then 01360800 - jump out 2 to yes 01360850 - else if sc = ";" then 01360900 - jump out 2 to nope ; 01360950 - si := si + 1)) ; 01361000 -nope: 01361050 - ds := 8 lit "+0000001" ; 01361100 - go to xit ; 01361150 -yes: 01361200 - si := si + 1 ; 01361250 - di := di + 7 ; 01361300 - ds := chr ; 01361350 -xit: 01361400 - end getchar ; 01361450 - if i := getchar (image) geq 0 then 01361500 - character := i ; 01361550 - if num1 then 01361600 - begin 01361650 - colstop1 := min (parameter1, 80) ; 01361700 - if num2 then 01361900 - begin 01361950 - colstop2 := min (max (parameter2, colstop1), 80) ; 01362000 - if num3 then 01362050 - begin 01362100 - colstop3 := min (max (parameter3, colstop2), 80) ; 01362150 - if num4 then 01362200 - begin 01362250 - colstop4 := min (max (parameter4, colstop3), 80) ; 01362300 - colstops := 4 ; 01362350 - end else 01362400 - colstops := 3 ; 01362450 - end else 01362500 - colstops := 2 ; 01362550 - end else 01362600 - colstops := 1 ; 01362650 - maxcolstop := colstop [colstops] ; 01362675 - end else 01362700 - if empty1 then 01362750 - begin 01363100 - show (parameter0, onoff (columns) & (character)[42:42:6]) ; 01363200 - if colstops lss 1 then 01363210 - parameter1 := 0 & "#"[6:42:6] 01363220 - else parameter1 := octdex (colstop1) ; 01363230 - if colstops lss 2 then 01363240 - parameter2 := 0 & "#"[6:42:6] 01363250 - else parameter2 := octdex (colstop2) ; 01363260 - show (parameter1, parameter2) ; 01363270 - if colstops lss 3 then 01363280 - parameter3 := 0 & "#"[6:42:6] 01363290 - else parameter3 := octdex (colstop3) ; 01363300 - if colstops lss 4 then 01363310 - parameter4 := 0 & "#"[6:42:6] 01363320 - else parameter4 := octdex (colstop4) ; 01363330 - errorx (7, parameter3, parameter4) ; 01363410 - end else 01363420 - columns := toggle (columns, 1) ; 01363430 - end column ; 01363500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01365000 -procedure teach ; 01365500 - begin 01366000 -label next ; 01366500 - if not empty1 then 01367000 - begin 01367500 - m := -1 ; 01368000 - for i := 0 step 1 until rswdm do 01368500 - if parameter1 = rswd [i] then 01369000 - begin 01369500 - m := i ; 01370000 - i := rswdm ; 01370500 - end ; 01371000 - if m lss 0 then 01371500 - begin 01371600 - if i := xfile (parameter1, parameter2:=macrolibrary, -1) lss 2 01371700 - and macrolibrary neq "macro " then 01371800 - i := xfile (parameter1, parameter2:="macro ", -1) ; 01371830 - if i lss 2 then 01371900 - begin 01372000 - show (parameter1, " invali") ; 01372020 - error (next, 0, "d: * ", rwteach) ; 01372040 - end ; 01372050 - num2 := false ; 01372100 - num3 := boolean (2) ; 01372200 - listit (0) ; 01372300 - go to next ; 01372400 - end ; 01372450 - parameter1 := "teacher" ; 01372500 - parameter2 := octdec (version) ; 01373000 - if xfile (parameter1, parameter2, 2) lss 2 then 01373500 - go to next ; 01374000 - read (library [m], 1, image [*]) ; 01375000 - n := dec (image [0], 8) ; 01376000 - close (library) ; 01376500 - parameter3 := n div 10000 ; 01377000 - num3 := true ; 01377500 - parameter4 := n mod 10000 ; 01378000 - num4 := true ; 01378500 - n := resetn ; 01379000 - listit (17) ;%posting and quick 01379500 - end else 01380500 - begin 01380600 - write (pretank [*], teach1) ; 01381500 - writetwx ; 01382000 - for i := 0 step 7 until rswdm do 01382500 - begin 01383000 - write (image [*], teach2, for m := 0 step 1 until 6 do 01383500 - [(parameter0 := rswd [i + m]).[6:6], parameter0]) ; 01384000 - writerow (image, false, cobol) ; 01384500 - end ; 01386500 - write (image [*], teach3) ; 01387000 - writerow (image, false, cobol) ; 01387500 - end ; 01390500 -next: 01390600 - end teach ; 01390700 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01391500 -define percent = 01392000 - begin 01392500 - translating := boolean (i := real (toggle (translating, 1))) ; 01393000 - translatei := i ; 01393500 - end# ; 01394500 -% * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01402000 -procedure stop ; 01402500 - begin 01403000 -define dirctry = controls# ; 01403100 -label next ; 01403500 - if boolean (abnormalend) then 01403600 - begin 01403610 - empty1 := abnormalend = 3 ; 01403620 - abnormalend := breaki := 0 ; 01403630 - if boolean (inreadyq) then 01403650 - begin 01403690 - for i := 1 step 1 while readyq [i] neq user do ; 01403700 - for i := i + 1 step 1 until readyqtop do 01403750 - readyq [i - 1] := readyq [i] ; 01403755 - readyqtop := readyqtop - 1 ; 01403800 - inreadyq := 0 ; 01403810 - end ; 01403825 - end else 01403850 - begin 01403875 - if fileopen and parameter1 neq "ds " then 01403900 - closefile ; 01404500 - write (pretank [*], eoj) ; 01407000 - writetwx ; 01407500 - if not empty1 then 01407600 - savestate ; 01407700 - if counti geq 0 then 01407710 - begin 01407720 - abnormalend := if empty1 then 2 else 4 ; 01407730 - station := 0 ; 01407740 - go to next ; 01407750 - end ; 01407760 - end ; 01407800 - forget (stationi) ; 01407900 - i := 2 | sloti ; 01408000 - read (r1 [45], 90, dirctry [*]) ; 01408100 - if empty1 then 01408500 - dirctry [i] := 0 01408600 - else 01408700 - dirctry [i].[1:1] := 0 ; 01408800 - dirctry [i + 1] := 0 ; 01409000 - write (r1 [45], 90, dirctry [*]) ; 01409500 - station := 0 ; 01410500 - if user neq bigbird then 01415100 - begin 01415110 - write (buffers [user, *], 45, buffers [bigbird, *]) ; 01415130 - if boolean (inreadyq) then 01415140 - for i := 0 step 1 until readyqtop do 01415150 - if readyq [i] = bigbird then 01415160 - readyq [i] := user ; 01415170 - read (r1 [if inreadyq=3 then 46 else sloti], 90, controls [*]) ; 01415180 - fileaccess := controls [51] ; 01415190 - if fileopen then 01415200 - begin 01415210 - n := bigbird | 32 ; 01415215 - m := controls [57].leftside ; 01415220 - for i := 0 step 1 until m do 01415230 - write (linklists [user32 + i, *], 256, 01415240 - linklists [n + i, *]) ; 01415250 - end ; 01415260 - if xdex := controls [62] geq 0 then 01415265 - begin 01415270 - write (xarray [user, *], xmax | 13, xarray [bigbird, *]) ; 01415275 - for xdex := xdex step -1 until 0 do 01415280 - if boolean (xnchrs).[1:1] then 01415285 - begin 01415290 - read (io [2|maxusers+xmax|bigbird+xdex], 30, image [*]) ; 01415295 - write (io [2|maxusers+xmax|user+xdex], 30, image [*]) ; 01415300 - end ; 01415305 - end ; 01415310 - end ; 01415315 - bigbird := bigbird - 1 ; 01415500 -next: 01416500 - end ; 01417000 -procedure program ; 01417100 -begin 01417110 -label next, exit ; 01417120 -next: 01417150 - case verb of 01417160 - begin 01417170 - execute ; 01417175 - ditto ; 01417180 - copy ; 01417190 - inline ; 01417200 - zipit ; 01417210 - change ; 01417220 - edit ; 01417230 - saveit ; 01417240 - reseq ; 01417250 - punch ; 01417260 - print ; 01417270 - delete ; 01417280 - closeit ; 01417300 - compile ; 01417310 - column ; 01417320 - scan ; 01417330 - listing ; 01417340 - increment ; 01417350 - tab ; 01417360 - percent ; 01417370 - quicklist ; 01417380 - listit (0) ; 01417390 - open ; 01417400 - mail ; 01417410 - teach ; 01417420 - remove ; 01417430 - replace ; 01417440 - stop ; 01417450 - go to exit ; 01417460 - end ; 01417470 - if bigbird geq 0 then 01417480 - go to next ; 01417490 -exit: 01417500 -end program ; 01418000 -boolean procedure rc (start) ; 01418100 -value start ; 01418200 -boolean start ; 01418300 -begin 01418500 -save file out rone disk serial [1:47] "r/c" "#1" (1, 90, save 99) ; 01418600 -save file out rtwo disk serial [15:96] "r/c" "#2" (1, 256, save 99) ; 01418700 -array dirctry, newdirctry [0:90], 01418800 - linklist [0:255] ; 01418900 -label endofprogram ; 01419000 - charge (0) ; 01419100 - freefile (0) ; 01419150 - if start then 01419200 - begin 01419300 - search (rone, image [*]) ; 01419500 - if image [6] gtr 0 then 01420000 - begin 01420100 - i := status (image [*]) ; 01420200 - write (twxoutput (image [0]), userun) ; 01420300 - go to endofprogram ; 01420500 - end ; 01420600 - if image [0] geq 0 then 01421000 - begin 01421500 - read (r1 [45], 90, dirctry [*]) ; 01422000 - dirctry [90] := 12 ; 01422500 - for i := 0 step 2 while usercode := dirctry [i] neq 12 do 01423000 - dirctry [i] := abs (usercode) ; 01423500 - write (r1 [45], 90, dirctry [*]) ; 01424000 - end else 01424500 - begin 01425000 - dirctry [0] := 12 ; 01425500 - write (rone [45], 90, dirctry [*]) ; 01426000 - end ; 01426500 - search (rtwo, image [*]) ; 01432500 - if image [0] lss 0 then 01433000 - write (rtwo[0], 1, image [*]) ; 01433500 - end else 01436500 - begin 01436600 - read (r1 [45], 90, dirctry [*]) ; 01437300 - user := -2 ; 01437500 - for n := 0 step 1 until 1 do 01437600 - for i := 0 step 2 while usercode := dirctry [i] neq 12 do 01438000 - if usercode neq 0 then 01439000 - begin 01439500 - read (r1 [i/2], 90, controls [*]) ; 01440000 - fileaccess := controls [51] ; 01440100 - if fileopen or boolean (n) then 01440500 - begin 01441000 - newdirctry [user := user + 2] := usercode ; 01441500 - write (rone, 90, controls [*]) ; 01442500 - if fileopen then 01442600 - begin 01442700 - read seek (r2 [16 | i]) ; 01443000 - newdirctry [user + 1] := dirctry [i + 1] ; 01443100 - m := controls [57].leftside ; 01444100 - for d := 0 step 1 until m do 01444500 - begin 01445000 - read (r2, 256, linklist [*]) ; 01445500 - write (rtwo, 256, linklist [*]) ; 01446000 - end ; 01446500 - if m neq 31 then 01446600 - write (rtwo [16 | user + 31], 1, controls [*]) ; 01446700 - dirctry [i] := 0 ; 01447000 - end ; 01447100 - end ; 01447500 - end ; 01448000 - newdirctry [user + 2] := 12 ; 01455000 - if user geq 0 then 01455500 - write (rone [45], 90, newdirctry [*]) ; 01456000 - close (r1, purge) ; 01456500 - read (r2 [0]) ; 01456600 - close (r2, purge) ; 01457000 -endofprogram: 01458100 - rc := true ; 01458200 - end ; 01458300 -end rc ; 01458500 - controls [90] := 12 ; 01458900 - if not rc (true) then 01459000 - begin 01459100 - bigbird := -1 ; 01459110 - t0 := 150 ; 01459120 - freehead := maxfreehead := (xmax + 2) | maxusers ; 01459130 - program ; 01459200 - bool := rc (false) ; 01459300 - if xfile ("teacher", octdec (version), -1) gtr 0 then 01459310 - read (library) ; 01459320 - end ; 01459400 -end. 01459500 -?end +?EXECUTE OBJECT/READER 00000010 +?COMMON=3 00000020 +?FILE NEWTAPE = SYMBOL/RCSY94 SERIAL 00000030 +?DATA CARD 00000040 + R / C -- A MULTI USER REMOTE/CARD. 00000500 + WRITTEN BY RON BRODY; BURROUGHS CORP.; PAOLI, PA. 215-NI4-4700 X219 00001000 +BEGIN 00001500 + DEFINE VERSION = 94#; % NOVEMBER 18, 1971. 00002000 + DEFINE MAXUSERS = 8#, MAXUSER = 7#; 00002500 + DEFINE CHRSPERBUFFER = 56 #, % OR 28 00002600 + WORDSPERBUFFER = 8#, % OR 5 00002700 + WDSPERBUFFER = 7# ; % OR 4 00002800 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00003000 + ALPHA FILE IN TWXINPUT 14 (MAXUSER + MAXUSER, 8); 00003500 + ALPHA FILE OUT TWXOUTPUT 14 (MAXUSERS, WORDSPERBUFFER) ; 00004000 + DEFINE TWXOUT = TWXOUTPUT (STATIONI, 0)# ; 00008500 + ARRAY PRETANK [0 : 3], 00009500 + BUFFERS [0 : MAXUSERS, 0 :44] ; 00010000 + DEFINE BUFFER [BUFFER1] = BUFFERS [USER, BUFFER1]#, 00010200 + BLOC = BUFFER [29]#, 00010300 + BUFF [BUFF1] = BUFFERS [MAXUSERS, BUFF1]# ; 00010400 + INTEGER ARRAY READYQ [0 : MAXUSERS] ; 00011000 + DEFINE RATTLEINDEX = READYQ [MAXUSERS]# ; 00011500 + INTEGER USER, 00012000 + USER32, 00012200 + CLOCK, 00013000 + READYQTOP, 00013500 + NEXTCLOCK, 00014500 + TINK, 00015000 + BIGBIRD ; 00016000 + BOOLEAN GLOBALBOOL ; 00016500 + DEFINE 00017000 + TANKEDOUTPUT = GLOBALBOOL . [47 : 1]#, 00017010 + OUTPUTREADY = (GLOBALBOOL)#, 00017020 + Q = GLOBALBOOL . [46 : 1]#, 00017100 + LOCKED = GLOBALBOOL . [45 : 1]#, 00017200 + XLOCKED = GLOBALBOOL . [44 : 1]#, 00017210 + YLOCKED = GLOBALBOOL . [43 : 1]#, 00017220 + QINPUT = GLOBALBOOL . [42 : 1]#, 00017300 + ERRTOG = GLOBALBOOL . [1 : 1]#; 00017500 + ARRAY INPUT [0 : 14] ; 00018000 + DEFINE T0 = INPUT [10]#, 00018100 + T1 = INPUT [11]#, 00018200 + TN = INPUT [12]#, 00018300 + FREEHEAD = INPUT[13]#, 00018400 + MAXFREEHEAD = INPUT[14]# ; 00018500 + DEFINE CHRS = BUFFER [30]#, 00019000 + NCHRS = BUFFER [31]#, 00019100 + USERCODEI = BUFFER [32]#, 00019500 + STATIONI = BUFFER [33]#, 00020000 + BREAKI = BUFFER [34]#, 00020500 + ABNORMALEND = BUFFER [35]#, 00020600 + INREADYQ = BUFFER [36]#, 00020700 + FIRSTCHANCE = BUFFER [37]#, 00020710 + ILFCRI = BUFFER [38]#, 00020800 + TRANSLATEI = BUFFER [39]#, 00020900 + HEADI = BUFFER [40]#, 00021000 + TIMEI = BUFFER [41]#, 00021100 + TAILI = BUFFER [42]#, 00021500 + SLOTI = BUFFER [43]#, 00022000 + BLOCK = BUFFER [44]#, 00022100 + COUNTI = BUFFER [0]# ; 00022500 + ALPHA ARRAY RECORD [0 : 9] ; 00023000 + REAL ARRAY LINKLISTS [0 : 32 | MAXUSERS - 1, 0 : 255] ; 00023500 + DEFINE TIMEX = TIME (1)#, 00023600 + FIRST = LINKLISTS [USER32, 0]#, 00023800 + LAST = LINKLISTS [USER32, 1]#, 00023900 + LEFTSIDE = [35 : 5]#, 00024000 + RIGHTSIDE = [40 : 8]#, 00024500 + LL [LL1] = 00025000 + LINKLISTS [(TINK := LL1).LEFTSIDE + USER32, TINK.RIGHTSIDE]#, 00025500 + S = [1 : 21]#, 00026000 + SF = 1 : 27 : 21#, 00026500 + F = [22 : 13]#, 00027000 + FF = 22 : 35 : 13#, 00027500 + T = [35 : 13]#, 00028000 + TF = 35 : 35 : 13#, 00028500 + INFINITY = 2097151#, %MAXIMUM SEQUENCE NUMBER = 2*21-1. 00029000 + FINITY = 2097160#, 00029010 + MAXFILELENGTH = 8191# ;% = 2*13-1. 00029500 + DEFINE MODIFY (MODIFY1) = 00029700 + MODIFIED := MODIFIED OR TWO ((MODIFY1).LEFTSIDE)# ; 00029800 + DEFINE WAITFLAG = BOOL . [47 : 1]#, WAITING = (BOOL)#, 00030500 + INLINETOG = BOOL . [46 : 1]#, 00031000 + EXTRALFCR = BOOL . [45 : 1]#, 00031500 + EXECUTEECHO = BOOL . [44 : 1]#, 00032000 + TRANSLATING = BOOL . [43 : 1]#, % INITIALLY ON 00032500 + XECHO = BOOL . [42 : 1]#, 00033000 + NUM1 = BOOL . [36 : 2]#, 00035000 + NUM2 = BOOL . [34 : 2]#, 00035500 + NUM3 = BOOL . [32 : 2]#, 00036000 + NUM4 = BOOL . [30 : 2]#, 00036500 + EMPTY1 = BOOL . [36 : 1]#, 00037500 + EMPTY2 = BOOL . [34 : 1]#, 00038000 + EMPTY3 = BOOL . [32 : 1]#, 00038500 + EMPTY4 = BOOL . [30 : 1]#, 00039000 + NOSTAR = BOOL . [29 : 1]#, 00039500 + MOREINPUT = BOOL . [23 : 1]#, 00042500 + NOTFIRSTINPUT = BOOL . [22 : 1]#, 00043000 + INLINEECHO = BOOL . [21 : 1]#, % INITIALLY ON 00043010 + CHANGEECHO = BOOL . [20 : 1]#, 00043020 + EDITECHO = BOOL . [19 : 1]#, 00043030 + COPYCLOBBER = BOOL . [18 : 1]#, 00043040 + DITTOCLOBBER = BOOL . [17 : 1]#, 00043050 + TEMPTOG = BOOL . [16 : 1]#, 00043060 + TABON = BOOL . [15 : 1]#, % INITIALLY ON 00043070 + COLUMNS = BOOL . [12 : 1]#, 00043100 + INORDER = BOOL . [1 : 1]#, 00043500 + INITIALBOOL = BOOLEAN ("44000+")# ; 00043600 + ARRAY CONTROLS [0 : 90] ; 00043700 + DEFINE VN = CONTROLS [89]#, 00043800 + STRINGI = CONTROLS [88]#, 00043900 + STRINGID = CONTROLS [87]#, 00044000 + STRINGILEFT = CONTROLS [86]#, 00044100 + STRINGIREPEAT = CONTROLS [85]#, 00044200 + STRINGJ = CONTROLS [84]#, 00044300 + STRINGJD = CONTROLS [83]#, 00044400 + STRINGJLEFT = CONTROLS [82]#, 00044500 + STRINGJREPEAT = CONTROLS [81]#, 00044600 + CHARACTER = CONTROLS [80]#, 00044700 + MAXCOLSTOP = CONTROLS [79]#, 00044800 + COLSTOPS = CONTROLS [78]#, 00044900 + COLSTOP4 = CONTROLS [77]#, 00045000 + COLSTOP3 = CONTROLS [76]#, 00045100 + COLSTOP2 = CONTROLS [75]#, 00045200 + COLSTOP1 = CONTROLS [74]#, 00045300 + COLSTOP [COLSTOP1] = CONTROLS [73 + COLSTOP1]#, 00045400 + RELATIVENUMBER = CONTROLS [73]#, 00045500 + STRING = CONTROLS [30]# ; % - CONTROLS [37] 00046000 + REAL PARAMETER0, % CONTROLS [38] 00046610 + PARAMETER1, % CONTROLS [39] 00046620 + PARAMETER2, % CONTROLS [40] 00046630 + PARAMETER3, % CONTROLS [41] 00046640 + PARAMETER4, % CONTROLS [42] 00046650 + USERCODE, % CONTROLS [43] 00046700 + STATION, % CONTROLS [44] 00046800 + PREFIX, % CONTROLS [45] 00046900 + SUFFIX, % CONTROLS [46] 00047000 + MACROLIBRARY ; % CONTROLS [47] 00047100 + BOOLEAN MODIFIED ; % CONTROLS [48] 00047200 + INTEGER FILEINFO, % CONTROLS [49] 00047300 + TABAMOUNT, % CONTROLS [50] 00047400 + FILEACCESS, % CONTROLS [51] 00047500 + SAVEFACTOR, % CONTROLS [52] 00047600 + PREWHERE, % CONTROLS [53] 00047700 + XDEX, % CONTROLS [54] 00047800 + N, % CONTROLS [55] 00047900 + AT, % CONTROLS [56] 00048000 + D, % CONTROLS [57] 00048100 + M, % CONTROLS [58] 00048200 + INC, % CONTROLS [59] 00048300 + I, % CONTROLS [60] 00048400 + RESETN ; % CONTROLS [61] 00048500 + BOOLEAN BOOL ; % CONTROLS [62] 00048800 + DEFINE COBOLFILE = BOOLEAN (FILEINFO)#, 00048820 + DATAFILE = FILEINFO = DATA#, 00048830 + ALGOLFILE = FILEINFO GEQ ALGOL#, 00048840 + COMPILER = FILEINFO#, 00048850 + LENGTH = (IF ALGOLFILE THEN 72 ELSE IF COBOLFILE THEN 66 ELSE 80)#, 00048860 + HALFLENGTH=(IF ALGOLFILE THEN 36 ELSE IF COBOLFILE THEN 33 ELSE 40)#,00048870 + FULLLENGTH = (IF DATAFILE THEN 80 ELSE 72)#, 00048880 + HALFFULLLENGTH = (IF DATAFILE THEN 40 ELSE 36)#, 00048890 + COBOL = 1#, 00049600 + DATA = 2#, 00049610 + ALGOL = 4#, 00049620 + XALGOL = 6#, 00049630 + FORTRAN = 8#, 00049640 + BASIC = 10#, 00049650 + FILEOPEN = FILEACCESS GTR 0#, 00050710 + FILECLOSED = FILEACCESS LEQ 0#, 00050720 + READONLYFILE = FILEACCESS = 2#, 00050730 + READWRITEFILE = FILEACCESS GEQ 3# ; 00050740 + SAVE ARRAY IMAGE [0 : 29] ; 00058000 + DEFINE RSWDM = 27#, 00058500 + RSWD [RSWD1] = CONTROLS [RSWD1]#, 00061500 + RWTEACH = RSWD [24]# ; 00062000 + FILE DISC DISK SERIAL (2, 10, 30) ; 00064000 + FILE LIBRARY DISK SERIAL (2, 10, 30) ; 00065500 + FILE R1 DISK SERIAL "R/C" "#1" (1, 90) ; 00069500 + FILE R2 DISK SERIAL "R/C" "#2" (1, 256) ; 00070000 + FILE IO DISK RANDOM [20:150] (1, 30) ; 00070500 + ARRAY ZIPPY [0 : MAX (29, MAXUSERS + MAXUSERS + 1)] ; 00071500 + FORMAT ZIPPER ("CC COMPILE ", A1, A6, "/", A1, A6, " WITH ", 00072000 + A1, A6, " LIBRARY; ALGOL FILE CARD=", A1, A6, "/", A1, A6, 00072500 + "SERIAL; ALGOL FILE LINE=LINE/", A1, A6, "SERIAL; END."), 00073000 + EOJ ("{!GOOD BYE{!!!~"), 00073600 + NOROOM (X8, "SORRY, FULL UP.{!BYE{!~"), 00073700 + USERUN (X8, "USE:{!?? RUN ...~"), 00078600 + STAR ("*", X79), 00079000 + DATE (X6, A1, A6, "/", A1, A6, " LISTED AT", I3, ":", I2, " ON ", 00079300 + A6, "DAY ", O, " BY ", A1, A6, X62), 00079400 + WAITF ("WAIT...~"), 00085000 + RATTLE (X8, "<<<~"), 00087000 + TEACH1 ("{!THE VALID VERBS ARE:~"), 00087500 + TEACH2 (7 (A1, A6, X2)), 00088000 + TEACH3 ("FOR SYNTAX OF A VERB (E.G. TAB), INPUT: * TEACH", 00088500 + " VERB. (E.G. * TEACH TAB) *"), 00089000 + BROKEN (X8, "{!BREAKS{!~") ; 00092000 + DEFINE ONOFF (ONOFF1) = (IF ONOFF1 THEN " ON " ELSE " OFF ")# ; 00097100 + DEFINE XMAX = 5# ; 00099600 + ARRAY XARRAY [0:MAXUSER, 0:XMAX | 13 - 1] ; 00099700 + DEFINE 00099800 + XSUB = XDEX | 13#, 00099810 + XPARAMETERS [XPARAMETERS1] = XARRAY [USER, XSUB + XPARAMETERS1]#, 00099900 + XSTART = XARRAY [USER, XSUB + 5]#, 00100000 + XLAST = XARRAY [USER, XSUB + 6]#, 00100100 + XN = XARRAY [USER, XSUB + 7]#, 00100200 + XREPEAT = XARRAY [USER, XSUB + 8]#, 00100300 + XPREFIX = XARRAY [USER, XSUB + 9]#, 00100400 + XSUFFIX = XARRAY [USER, XSUB + 10]#, 00100500 + XFILETYPE = XARRAY [USER, XSUB + 11]#, 00100600 + XNCHRS = XARRAY [USER, XSUB + 12]# ; 00100700 + PROCEDURE PROGRAM ; FORWARD ; 00101000 + ALPHA PROCEDURE OCTDECIMAL (N, M, F) ; 00101100 + VALUE N, F ; 00101200 + INTEGER N, M, F ; 00101300 + BEGIN 00101400 + ALPHA STREAM PROCEDURE OCTDECX (N, F, Q, T) ; 00101500 + VALUE F, Q, T ; 00101600 + BEGIN 00102500 + LABEL EXIT ; 00102600 + DI := LOC OCTDECX ; 00103000 + SI := N ; 00103100 + T (Q (DS := F OCT ; JUMP OUT 2 TO EXIT) ; 00103200 + SKIP F DB ; DS := SET ; JUMP OUT TO EXIT) ; 00103500 + Q (F (SI := SI + 2 ; DS := 2 CHR ; DS := LIT "/" ; DS := 2 CHR ; 00103600 + DS := LIT "/" ; DS := 2 CHR ; JUMP OUT 2 TO EXIT) ; 00103700 + DI := DI + 7 ; DS := CHR ; JUMP OUT TO EXIT) ; 00103800 + DS := 8 DEC ; 00104000 + F (DI := DI - 7 ; DS := 6 FILL) ; 00104100 + EXIT: 00104200 + END OCTDECX; 00104300 + IF F LEQ 1 THEN 00104400 + BEGIN 00104500 + N := N ; 00104600 + OCTDECIMAL := OCTDECX (N, F, 0, 0) ; 00104700 + END ELSE IF F = 2 THEN 00104800 + OCTDECIMAL := OCTDECX (M, 0, 1, 0) 00104900 + ELSE IF F = 3 THEN 00104910 + OCTDECIMAL := OCTDECX (N, 1, 1, 0) 00104920 + ELSE IF F = 4 THEN 00104930 + OCTDECIMAL := OCTDECX (M, N, 1, 1) 00104940 + ELSE 00105000 + OCTDECIMAL := OCTDECX (M, N:= 47 - N, 0, 1) ; 00105100 + END OCTDECIMAL ; 00105200 + DEFINE OCTDEC (OCTDEC1) = OCTDECIMAL (OCTDEC1, M, 0)#, 00105300 + OCTDEX (OCTDEX1) = OCTDECIMAL (OCTDEX1, M, 1)#, 00105400 + FIRSTCHAR (FIRSTCHAR1) = OCTDECIMAL (0, FIRSTCHAR1, 2)#, 00105500 + MMDDYY = OCTDECIMAL (TIME (5), M, 3)#, 00105600 + DEC (DEC1, DEC2) = OCTDECIMAL (DEC2, DEC1, 4)#, 00105700 + TWO (TWO1) = BOOLEAN (OCTDECIMAL (TWO1, M, 5))# ; 00105800 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00120500 + DEFINE SEQUENCE = 00121000 + IF ALGOLFILE THEN 00121500 + IMAGE [9] := OCTDEC (IF N = FINITY THEN 99999999 ELSE N) 00122000 + ELSE IF COBOLFILE THEN 00122500 + BEGIN 00123000 + IMAGE [0].[1:35] := OCTDEC (N) ; 00124000 + IMAGE [9] := SUFFIX & "."[1:43:5] ; 00124500 + END# ; 00125000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00126000 + PROCEDURE STATIONFIX (STATION, I) ; 00126500 + VALUE STATION, I ; 00126600 + REAL STATION ; 00126700 + INTEGER I ; 00126800 + BEGIN 00126900 + REAL X ; 00127000 + IF I LEQ 4 THEN 00127100 + X := STATUS (STATION, I) 00127200 + ELSE IF I LEQ 6 THEN 00127300 + RELEASE (STATION) 00127400 + ELSE IF I LEQ 8 THEN 00127500 + BEGIN 00127600 + SEEK (TWXINPUT (STATION)) ; 00127625 + X := STATUS (STATION, 0) ; 00127650 + END 00127675 + ELSE IF I = 9 THEN 00127700 + BEGIN 00127800 + WRITE (TWXOUTPUT (STATION), NOROOM) ; 00127900 + RELEASE (STATION) ; 00128000 + END 00128100 + ELSE IF I = 10 THEN 00128200 + BEGIN 00128300 + IF BOOLEAN (STATUS (STATION, 0)).[30:1] OR 00128400 + USERCODEI NEQ STATUS (STATION) THEN 00128500 + ABNORMALEND := 1 ; 00128600 + END ; 00128700 + END STATIONFIX ; 00128800 + DEFINE CHARGE (CHARGE1) = STATIONFIX (CHARGE1, 0)#, 00128900 + FREEFILE (FREEFILE1) = STATIONFIX (FREEFILE1, 3)#, 00129000 + UNFREEFILE (UNFREEFILE1) = STATIONFIX (UNFREEFILE1, 4)#, 00129100 + FORGET (FORGET1) = STATIONFIX (FORGET1, 5)#, 00129200 + DETACH = STATIONFIX (STATION, 6)#, 00129300 + ATTACH = STATIONFIX (STATION, 7)#, 00129400 + REATTACH = STATIONFIX (STATION, 8)#, 00129500 + NOMOREROOM = STATIONFIX (STATION, 9)#, 00129600 + CHECK (CHECK1) = STATIONFIX (CHECK1, 10)# ; 00129700 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00129800 + PROCEDURE OUTPUT ; 00130000 + BEGIN 00130200 + STREAM PROCEDURE MOVE (S, D, W, C) ; VALUE W, C ; 00130400 + BEGIN 00130600 + SI := S ; 00130800 + DI := D ; 00131000 + DS := W WDS ; 00131200 + DS := C CHR ; 00131400 + END MOVE ; 00131600 + INTEGER USER, 00131800 + T, 00132200 + SPOT ; 00132400 + BOOLEAN X ; 00132600 + LABEL FAKEOUT, 00132800 + NEXT ; 00133000 + DEFINE A = INPUT# ; 00133200 + CHARGE (0) ; 00133400 + TANKEDOUTPUT := FALSE ; 00133600 + A [WDSPERBUFFER] := "~ " ; 00133800 + FOR USER := 0 STEP 1 UNTIL BIGBIRD DO 00134000 + BEGIN 00134200 + IF COUNTI GEQ 0 THEN 00134600 + BEGIN 00134800 + IF TIMEI - TIMEX GTR 180 THEN 00135000 + GO TO FAKEOUT ; 00135200 + SPOT := HEADI ; 00135400 + IF REAL ((X := BOOLEAN (STATUS (STATIONI, 0)).[22:9]) 00135600 + AND BOOLEAN ("6A")) NEQ 0 THEN 00135800 + BEGIN 00136000 + IF X.[39:1] THEN % BUSY 00136200 + BEGIN 00136400 + T := 15 ; 00136600 + GO TO FAKEOUT ; 00136800 + END ; 00137000 + IF REAL (X AND BOOLEAN (10)) NEQ 0 AND NOT X THEN 00137200 + WRITE (TWXOUT, BROKEN) ; % CLEAR WRITE READY 00137400 + IF SPOT GEQ 0 THEN 00137600 + BEGIN 00137800 + A [0] := FREEHEAD ; 00138000 + WRITE (IO [TAILI], 1, A [*]) ; 00138200 + FREEHEAD := SPOT ; 00138400 + END ; 00138600 + COUNTI := XDEX := -1 ; 00138800 + TIMEI := 0 ; 00139000 + BREAKI := 1 ; 00139200 + MOREINPUT := FALSE ; 00139400 + GO TO NEXT ; 00139600 + END ; 00139800 + IF SPOT GEQ 0 THEN 00140000 + BEGIN 00140200 + READ (IO [SPOT], 30, BUFF [*]) ; 00140400 + MOVE (BUFF [BLOCK], A [1], 0, CHRSPERBUFFER) ; 00140600 + WRITE (TWXOUT, WORDSPERBUFFER, A [*]) [FAKEOUT] ; 00140800 + T := CHRSPERBUFFER ; 00141000 + IF BLOCK := BLOCK + WDSPERBUFFER GEQ 29 THEN 00141200 + BEGIN 00141400 + BLOCK := 1 ; 00141600 + A [0] := FREEHEAD ; 00141800 + WRITE (IO [SPOT], 1, A [*]) ; 00142000 + HEADI := BUFF[0] ; 00142400 + END ; 00142600 + END ELSE 00142800 + BEGIN 00143000 + MOVE (BUFFER [1], A [1], 0, CHRSPERBUFFER) ; 00143200 + WRITE (TWXOUT, WORDSPERBUFFER, A [*]) [FAKEOUT] ; 00143400 + IF BLOC := BLOC - WDSPERBUFFER LSS 1 THEN 00143600 + BEGIN 00143800 + COUNTI := -1 ; 00144000 + IF ABNORMALEND GEQ 2 THEN 00144200 + ABNORMALEND := ABNORMALEND + 1 ; 00144400 + GO TO NEXT ; 00144600 + END ; 00144800 + T := CHRSPERBUFFER ; 00145000 + MOVE (BUFFER[WORDSPERBUFFER],BUFFER[1],29-WORDSPERBUFFER,0);00145200 + END; 00145400 + FAKEOUT: 00145600 + IF TIMEI:=MAX(TIMEI,TIMEX)+T|6 LSS TN OR NOT OUTPUTREADY THEN 00145800 + BEGIN 00146000 + TN := TIMEI ; 00146200 + TANKEDOUTPUT := TRUE ; 00146400 + END ; 00146600 + NEXT: 00146800 + END ; 00147000 + END ; 00147200 + IF OUTPUTREADY THEN 00147400 + NEXTCLOCK := CLOCK - T0 | (TN - TIMEX - 90) / 150 00147600 + ELSE 00147800 + NEXTCLOCK := -99 ; 00148000 + CHARGE (STATION) ; 00148200 + END OUTPUT ; 00148400 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00148600 + PROCEDURE WRITETWX ; 00148800 + BEGIN 00149200 + INTEGER STREAM PROCEDURE COUNT (S) ; 00149400 + BEGIN 00149600 + SI := S ; 00149800 + 28 (IF SC = "~" THEN 00150000 + JUMP OUT ; 00150200 + TALLY := TALLY + 1 ; 00150400 + SI := SI + 1) ; 00150600 + S := SI ; 00150800 + DI := S ; 00151000 + DS := LIT "~" ; 00151200 + COUNT := TALLY ; 00151400 + END COUNT ; 00151600 + STREAM PROCEDURE MOVE (S, D, SKPS, SKPD, N) ; 00151800 + VALUE SKPS, SKPD, N ; 00152000 + BEGIN 00152200 + SI := S ; 00152400 + DI := D ; 00152600 + SI := SI + SKPS ; 00152800 + DI := DI + SKPD ; 00153000 + DS := N CHR ; 00153200 + END MOVE ; 00153400 + INTEGER C, J, K ; 00153600 + DEFINE A = PRETANK# ; 00153700 + LABEL NOSKIP, 00153800 + SKIP ; 00154000 + IF BOOLEAN (ILFCRI) THEN 00154200 + BEGIN 00154400 + ILFCRI := 0 ; 00154600 + IF FIRSTCHAR (A [0]) = "{" THEN 00154800 + J := 2 ; 00155000 + END ; 00155200 + IF C := COUNT (A) - J NEQ 0 AND NOT BOOLEAN (BREAKI) THEN 00155400 + BEGIN 00155600 + IF K := COUNTI LSS 0 THEN 00155800 + BEGIN 00156000 + BUFFER [4] := "~ " ; 00156200 + MOVE ( A [0], BUFFER [1], J, 0, 28); 00156400 + IF TIMEI - TIMEX GEQ 180 THEN 00156600 + GO TO NOSKIP ; 00156800 + WRITE (TWXOUT, 5, BUFFER [*]) [NOSKIP : NOSKIP] ; 00157000 + TIMEI := MAX (TIMEI, TIMEX) + C | 6 ; 00157200 + GO TO SKIP ; 00157400 + NOSKIP: 00157600 + COUNTI := C ; 00157800 + BLOCK := BLOC := 1; 00158000 + HEADI := -1 ; 00158200 + IF TIMEI LSS TN OR NOT OUTPUTREADY THEN 00158400 + BEGIN 00158600 + NEXTCLOCK := CLOCK - T0 | ((TN:=TIMEI)-TIMEX-120) / 150 ; 00158800 + TANKEDOUTPUT := TRUE ; 00159000 + END ; 00159200 + GO TO SKIP ; 00159400 + END ; 00159600 + IF K LSS CHRSPERBUFFER THEN 00159800 + BEGIN 00160000 + MOVE (A, BUFFER [BLOC], J, K, CHRSPERBUFFER - K) ; 00160200 + J := J + CHRSPERBUFFER - K ; 00160400 + IF COUNTI := K := K + C LSS CHRSPERBUFFER THEN 00160600 + GO TO SKIP ; 00160800 + C := K - CHRSPERBUFFER ; 00161000 + END ; 00161200 + IF BLOC := BLOC + WDSPERBUFFER GEQ 29 THEN 00161400 + BEGIN 00161600 + BLOC := 1 ; 00161800 + IF FREEHEAD NEQ MAXFREEHEAD THEN 00162000 + BEGIN 00162200 + READ (IO [FREEHEAD], 1, BUFFER [*]) ; 00162400 + K := BUFFER [0] ; 00162600 + END ELSE 00162800 + K := MAXFREEHEAD := MAXFREEHEAD + 1 ; 00163000 + BUFFER [0] := -1 ; 00163200 + WRITE (IO [FREEHEAD], 1, BUFFER [*]) ; 00163400 + IF HEADI GEQ 0 THEN 00163600 + BEGIN 00163800 + READ (IO [TAILI], 30, BUFFER [*]) ; 00164000 + BUFFER [0] := FREEHEAD ; 00164200 + WRITE (IO [TAILI], 30, BUFFER [*]) ; 00164400 + END ELSE 00164600 + HEADI := FREEHEAD ; 00164800 + TAILI := FREEHEAD ; 00165000 + FREEHEAD := K ; 00165200 + END ; 00165400 + MOVE (A, BUFFER [BLOC], J, 0, 29) ; 00165600 + COUNTI := C ; 00165800 + END ; 00166000 + SKIP: 00166200 + END WRITETWX ; 00166400 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00170000 + DEFINE ITSOLD (ITSOLD1) = BOOLEAN (KOUNT (ITSOLD1, 0, 0))#, 00170010 + LOC (LOC1) = KOUNT (LOC1, 1, 0)# ; 00170020 + INTEGER PROCEDURE KOUNT (N, M, KK) ; 00170030 + VALUE N, M, KK ; 00170040 + INTEGER N, M, KK ; 00170050 + BEGIN 00170060 + INTEGER K ; 00170070 + REAL L ; 00170080 + WHILE N LSS (L := LL [AT]).S DO 00170090 + AT := L.F ; 00170100 + WHILE N GTR (L := LL [AT]).S DO 00170110 + AT := L.T ; 00170120 + IF KK NEQ 0 THEN 00170130 + BEGIN 00170140 + IF M = INFINITY THEN M := M - 1 ; 00170150 + WHILE M GEQ (L := LL [AT]).S AND K := K + 1 NEQ KK DO 00170160 + AT := L.T ; 00170170 + KOUNT := K - REAL (M LSS L.S) ; 00170180 + END ELSE 00170190 + IF BOOLEAN (M) THEN 00170200 + KOUNT := AT 00170210 + ELSE 00170220 + KOUNT := REAL (N = L.S) ; 00170230 + END KOUNT ; 00170240 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00170500 + DEFINE 00175000 + WRITESEQUENCE = WRITEALINE (0)#, 00175100 + WRITELFCR = WRITEALINE (1)#, 00175200 + WRITESEQ = WRITEALINE (2)#, 00175300 + WRITEQUEUED = WRITEALINE (5)#, 00175600 + WRITESEGMENT = WRITEALINE (6)#, 00175700 + WRITERELADDR = WRITEALINE (7)# ; 00175800 + PROCEDURE WRITEALINE (K) ; 00175900 + VALUE K ; 00176000 + INTEGER K ; 00176100 + BEGIN 00176200 + STREAM PROCEDURE FORM (PRETANK, N, K, LFCR, COLON, F) ; 00176300 + VALUE N, K, LFCR, COLON, F ; 00176400 + BEGIN 00176500 + LABEL EXIT ; 00176600 + DI := PRETANK ; 00176700 + LFCR (DS := 2 LIT "{!" ; 00176800 + K (SI := LOC N ; 00176900 + DS := K DEC ; 00177000 + F (PRETANK := DI ; 00177100 + DI := DI - K ; 00177200 + DS := K FILL ; 00177300 + DI := PRETANK) ; 00177400 + JUMP OUT) ; 00177500 + COLON (DS := LIT ":") ; 00177600 + JUMP OUT TO EXIT) ; 00177700 + COLON (SI := LOC N ; 00177800 + F (DS := 7 LIT "QUEUED(" ; 00177900 + DS := 2 DEC ; 00178000 + DS := LIT ")" ; 00178100 + JUMP OUT 2 TO EXIT) ; 00178200 + K (DS := 9 LIT "REL ADDR=" ; 00178300 + DS := 4 DEC ; 00178400 + JUMP OUT 2 TO EXIT) ; 00178500 + DS := 8 LIT "SEGMENT=" ; 00178600 + DS := 4 DEC ; 00178700 + JUMP OUT TO EXIT) ; 00178900 + F (N (DS := LIT " ") ; JUMP OUT TO EXIT) ; 00179000 + DS := LIT ">" ; 00179100 + EXIT: 00179200 + DS := LIT "~" ; 00179300 + END FORM ; 00179400 + DEFINE XON = FORM (PRETANK, 0, 0, 0, 0, 0)#, 00179500 + TABIT = FORM (PRETANK, I, 0, 0, 0, 1)#, 00179600 + LFCR = FORM (PRETANK, 0, 0, 1, 0, 0)#, 00179700 + COLON = FORM (PRETANK, 0, 0, 1, 1, 0)#, 00179800 + SEQ = FORM (PRETANK, IF N = INFINITY THEN 99999999 ELSE N, 00179900 + IF COBOLFILE THEN 6 ELSE 8, 1, 00180000 + IF COBOLFILE THEN 0 ELSE 1, 1)#, 00180100 + OLDSEQ = FORM (PRETANK, IF N = INFINITY THEN 99999999 ELSE N, 00180200 + IF COBOLFILE THEN 6 ELSE 8, 1, 00180300 + IF COBOLFILE THEN 0 ELSE 1, 1-REAL(ITSOLD (N)))#, 00180400 + QUEFORM = FORM (PRETANK, READYQTOP, 0, 0, 1, 1)#, 00180500 + SEGMENT = FORM (PRETANK, PARAMETER2, 0, 0, 1, 0)#, 00180600 + RELADDR = FORM (PRETANK, PARAMETER3, 1, 0, 1, 0)#, 00180700 + TWX (TWX1) = BEGIN TWX1 ; WRITETWX ; END# ; 00180800 + IF K = 0 THEN 00181000 + BEGIN 00181100 + IF FILEOPEN THEN 00181200 + BEGIN 00181300 + TWX (OLDSEQ) ; 00181400 + IF INLINETOG AND EXTRALFCR THEN 00181500 + TWX (LFCR) ; 00181600 + IF TABON AND TABAMOUNT NEQ 0 THEN 00181700 + BEGIN 00181800 + IF I := TABAMOUNT GTR 27 THEN 00181900 + BEGIN 00182000 + I := I - 27 ; 00182100 + TWX (TABIT) ; 00182200 + I := 27 ; 00182300 + END ; 00182400 + TWX (TABIT) ; 00182500 + END ; 00182600 + END 00182700 + ELSE 00182800 + TWX (COLON) ; 00182900 + IF XDEX LSS 0 AND NOT ERRTOG THEN 00183000 + TWX (XON) 00183100 + ELSE 00183200 + ERRTOG := FALSE ; 00183300 + END 00183400 + ELSE IF K = 1 THEN 00183500 + BEGIN 00183600 + TWX (LFCR) ; 00183700 + ILFCRI := 1 ; 00183800 + END 00183900 + ELSE 00184000 + TWX (IF K=2 THEN SEQ ELSE IF K=5 THEN QUEFORM ELSE 00184100 + IF K=6 THEN SEGMENT ELSE IF K=7 THEN RELADDR) ; 00184200 + END WRITEALINE ; 00184300 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00190500 + PROCEDURE WRITEROW (ROW, Q, F) ; 00191000 + VALUE Q, 00191500 + F ; 00192000 + BOOLEAN Q ; 00192500 + INTEGER F ; 00193000 + ARRAY ROW [0] ; 00193500 + BEGIN 00193600 + STREAM PROCEDURE MOVE (S, D, SKPS, N) ; 00193700 + VALUE SKPS, N ; 00193800 + BEGIN 00193900 + SI := S ; 00194000 + DI := D ; 00194100 + SI := SI + SKPS ; 00194200 + DS := N CHR ; 00194300 + END MOVE ; 00194400 + STREAM PROCEDURE BLANKOUTSPECIALCHARACTERS (S, D, N, K) ; 00195000 + VALUE N, 00195500 + K ; 00195600 + BEGIN 00196000 + DI := LOC N ; DS := 6 LIT "!><}{~" ; 00197500 + DI := D ; 00198000 + DS := 8 LIT " " ; 00198500 + SI := D ; 00199000 + DS := 9 WDS ; 00199500 + SI := S ; 00200000 + DI := D ; 00200500 + 2 (K (IF SC = " " THEN 00201000 + BEGIN 00201500 + N (SI := SI - 1 ; 00202000 + IF SC = " " THEN 00202500 + DI := DI - 1 ; 00203000 + SI := SI + 1) ; 00203500 + DS := CHR ; 00204000 + END ELSE 00204500 + IF SC = ALPHA THEN 00205000 + DS := CHR 00205500 + ELSE 00206000 + BEGIN 00206500 + D := DI ; 00207000 + DI := LOC N ; 00207500 + 6 (IF SC = DC THEN JUMP OUT ; SI := SI - 1) ; 00208000 + DI := D ; 00208500 + IF TOGGLE THEN 00209000 + DS := 1 LIT "$" 00209500 + ELSE 00210000 + DS := CHR ; 00210500 + END)) ; 00211000 + END BLANKOUTSPECIALCHARACTERS ; 00219000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00219500 + BOOLEAN STREAM PROCEDURE ALLBLANK (S, SKP, N) ; 00220000 + VALUE SKP, 00220500 + N ; 00221000 + BEGIN 00221500 + LABEL GRPMKIT ; 00222000 + SI := S ; 00222500 + SI := SI + SKP ; 00223000 + SI := SI + N ; 00223500 + N (SI := SI - 1 ; 00224000 + IF SC NEQ " " THEN 00224500 + JUMP OUT TO GRPMKIT) ; 00225000 + TALLY := 1 ; 00225500 + SI := SI - 1 ; 00226000 + GRPMKIT: 00226600 + SI := SI + 1 ; 00227000 + N := SI ; 00227500 + DI := N ; 00228000 + DS := 1 LIT "~" ; 00228500 + ALLBLANK := TALLY ; 00229000 + END ALL BLANK ; 00229500 + BOOLEAN DATUM ; 00229600 + DEFINE FILEINFO = F# ; 00229700 + INTEGER Z ; 00229800 + BLANKOUTSPECIALCHARACTERS (ROW, INPUT, Q, HALFFULLLENGTH) ; 00230000 + IF DATAFILE THEN 00230100 + BEGIN 00230200 + MOVE (INPUT [9], ZIPPY [15], 0, 8) ; 00230300 + DATUM := NOT ALLBLANK (ZIPPY [15], 0, 8) ; 00230400 + END ; 00230500 + EXTRALFCR := NOT (COBOLFILE OR Q:=ALLBLANK (INPUT [Z:=7], 7, 9)) ;00231000 + IF EXTRALFCR OR COBOLFILE THEN 00231500 + WRITELFCR ; 00232000 + IF Q THEN 00232500 + IF Q := ALLBLANK (INPUT [7], 0, 7) THEN 00233000 + IF Q := ALLBLANK (INPUT [Z:=3], 4, 28) THEN 00233500 + Q := ALLBLANK (INPUT [Z:=0], 0, 28) ; 00234000 + IF NOT Q THEN 00234500 + FOR F := 0 STEP 3 UNTIL Z DO 00235000 + BEGIN 00235500 + MOVE (INPUT [F], PRETANK [0], 4 | F DIV 3, 28) ; 00236000 + WRITETWX ; 00236500 + END ; 00237000 + IF DATUM THEN 00237050 + BEGIN 00237100 + WRITELFCR ; 00237200 + MOVE (ZIPPY [15], PRETANK, 0, 9) ; 00237300 + WRITETWX ; 00237400 + END ; 00237450 + WRITELFCR ; 00237460 + END WRITEROW ; 00237500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00237510 + PROCEDURE ERRORX (K, A, B) ; 00237512 + VALUE K, 00237514 + A, 00237516 + B ; 00237518 + INTEGER K ; 00237520 + REAL A, 00237522 + B ; 00237524 + BEGIN 00237526 + STREAM PROCEDURE CRUNCH (S, K, A, B) ; VALUE K, A, B ; 00237528 + BEGIN 00237530 + LABEL E0, E1, E2, E3, E4, E5, E6, FILENAME, CRUNCH, DEBLANK ; 00237532 + SI := LOC A ; 00237534 + SI := SI + 1 ; 00237536 + DI := S ; 00237538 + DS := 2 LIT "{!" ; 00237540 + CI := CI + K ; 00237542 + GO TO E0 ; 00237544 + GO TO E1 ; 00237546 + GO TO E2 ; 00237548 + GO TO E3 ; 00237550 + GO TO E4 ; 00237552 + GO TO E5 ; 00237554 + GO TO E6 ; 00237556 + GO TO E0 ; 00237558 + GO TO E0 ; 00237560 + E1: 00237562 + DS := 10 LIT "INV USER: " ; 00237564 + GO TO E6 ; 00237566 + E2: 00237568 + DS := 2 LIT "NO" ; 00237570 + GO TO FILENAME ; 00237572 + E3: 00237574 + DS := 3 LIT "BAD" ; 00237576 + GO TO FILENAME ; 00237578 + E5: 00237580 + DS := 8 LIT "NO FILE " ; 00237582 + E0: 00237584 + DS := 7 CHR ; 00237586 + SI := SI + 1 ; 00237588 + DS := 7 CHR ; 00237590 + GO TO CRUNCH ; 00237592 + E4: 00237594 + DS := 3 LIT "DUP" ; 00237596 + FILENAME: 00237598 + DS := 7 LIT " FILE: " ; 00237600 + E6: 00237602 + DS := 7 CHR ; 00237604 + DS := LIT "/" ; 00237606 + SI := SI + 1 ; 00237608 + DS := 7 CHR ; 00237610 + CRUNCH: 00237612 + DS := LIT "~" ; 00237614 + SI := S ; 00237616 + DI := S ; 00237618 + 28 (IF SC = " " THEN 00237620 + BEGIN 00237622 + DEBLANK: 00237624 + SI := SI + 1 ; 00237626 + IF SC = " " THEN 00237628 + GO TO DEBLANK ; 00237630 + IF SC = ALPHA THEN 00237632 + DS := 1 LIT " " ; 00237634 + END ELSE 00237636 + DS := CHR) ; 00237638 + END CRUNCH ; 00237640 + IF A = "#000000" THEN A := " " ; 00237642 + IF B = "#000000" THEN B := " " ; 00237644 + CRUNCH (PRETANK, K, A, B) ; 00237646 + WRITETWX ; 00237648 + IF K LEQ 6 THEN 00237650 + BEGIN 00237652 + ERRTOG := TRUE ; 00237654 + MOREINPUT := FALSE ; 00237656 + NOSTAR := FALSE ; 00237658 + XDEX := -1 ; 00237660 + END ELSE IF K = 8 THEN 00237662 + ILFCRI := 1 ; 00237664 + END ERRORX ; 00237666 + DEFINE ERROR (ERROR1, ERROR2, ERROR3, ERROR4) = 00237668 + BEGIN 00237670 + ERRORX (ERROR2, ERROR3, ERROR4) ; 00237672 + GO TO ERROR1 ; 00237674 + END ERROR#, 00237676 + SHOW (SHOW1, SHOW2) = ERRORX (8, SHOW1, SHOW2)# ; 00237678 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00237700 + BOOLEAN PROCEDURE FILECHECK (B) ; 00237740 + VALUE B ; 00237750 + BOOLEAN B ; 00237760 + BEGIN 00237770 + LABEL NEXT ; 00237780 + IF B THEN 00237790 + BEGIN 00237800 + IF FILECLOSED THEN 00237810 + ERROR (NEXT, 5, " OPEN: ", PARAMETER0) ; 00237820 + IF B.[46:1] AND READONLYFILE THEN 00237830 + ERROR (NEXT, 0, "READ ON", "LY FILE") ; 00237840 + END ELSE 00237850 + IF FILEOPEN THEN 00237860 + BEGIN 00237870 + SEARCH (DISC, INPUT [*]) ; 00237880 + IF INPUT [0] LSS FILEACCESS THEN 00237890 + BEGIN 00237900 + CHARGE (STATION) ; 00237905 + CLOSE (DISC) ; 00237910 + FILL DISC WITH PREFIX, SUFFIX ; 00237920 + SEARCH (DISC, INPUT [*]) ; 00237930 + IF INPUT [0] LSS FILEACCESS THEN 00237940 + BEGIN 00237950 + FILEACCESS := 0 ; 00237960 + INORDER := TRUE ; 00237970 + ERROR (NEXT, 1 + REAL (INPUT [0] LSS 0), PREFIX, SUFFIX) ; 00237980 + END ; 00238000 + END ; 00238010 + END ; 00238020 + IF FALSE THEN 00238030 + NEXT: 00238040 + FILECHECK := TRUE ; 00238050 + END FILECHECK ; 00238060 + DEFINE OPENCHECK = IF FILECHECK (TRUE) THEN GO TO NEXT#, 00238070 + READONLYCHECK = IF FILECHECK (BOOLEAN (3)) THEN GO TO NEXT#, 00238080 + SECURITYCHECK = IF FILECHECK (FALSE) THEN GO TO NEXT# ; 00238090 + PROCEDURE STATE (S) ; 00238100 + VALUE S ; 00238200 + BOOLEAN S ; 00238300 + BEGIN 00238400 + STREAM PROCEDURE STUFFSTATE (N, RECORD, P0, C) ; 00238500 + VALUE N ; 00238600 + BEGIN 00239000 + LABEL EXIT ; 00239100 + N (DI := C ; 00239200 + SI := P0 ; 00239300 + DS := 25 WDS ; 00239400 + SI := RECORD ; 00239600 + DS := 10 WDS ; 00239700 + JUMP OUT TO EXIT) ; 00240400 + SI := C ; 00240500 + DI := P0 ; 00240600 + DS := 25 WDS ; 00240700 + DI := RECORD ; 00240900 + DS := 10 WDS ; 00241000 + EXIT: 00241700 + END STUFFSTATE ; 00246000 + INTEGER I, K ; 00247500 + CLOSE (DISC) ; 00248000 + K := IF S.[46:1] THEN SLOTI ELSE 46 ; 00248500 + IF S THEN 00248600 + BEGIN 00248700 + STUFFSTATE (1, RECORD, PARAMETER0, CONTROLS [38]) ; 00250000 + WRITE (R1 [K], 90, CONTROLS [*]) ; 00250600 + IF S.[46:1] AND FILEOPEN AND REAL (MODIFIED) NEQ 0 THEN 00251000 + BEGIN 00251500 + K := D.LEFTSIDE ; 00252000 + FOR I := 0 STEP 1 UNTIL K DO 00252500 + BEGIN 00253000 + IF MODIFIED THEN 00253100 + WRITE (R2 [32|SLOTI + I], 256, LINKLISTS [USER32+I, *]) ; 00253200 + MODIFIED := MODIFIED.[16:31] ; 00253500 + END ; 00254000 + MODIFIED := FALSE ; 00254100 + END ; 00254200 + END SAVESTATE ELSE 00254500 + BEGIN 00255500 + READ (R1 [K], 90, CONTROLS [*]) ; 00256500 + STUFFSTATE (0, RECORD, PARAMETER0, CONTROLS [38]) ; 00257500 + FILL DISC WITH PREFIX, SUFFIX ; 00258500 + IF S.[46:1] THEN 00259000 + MODIFIED := FALSE ; 00259500 + USER32 := USER | 32 ; 00260000 + END RESTORESTATE ; 00260500 + PREWHERE := -1 ; 00261000 + END STATE ; 00262000 + DEFINE SAVESTATE = STATE (BOOLEAN(3))#, 00262500 + RESTORESTATE = STATE (BOOLEAN (2))#, 00263000 + UNSWAPSTATE = STATE (FALSE)#, 00263500 + SWAPSTATE = STATE (TRUE)# ; 00264000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00264500 + DEFINE WAIT (WAIT1, WAIT2) = 00265000 + BEGIN 00265100 + IF NOT WAITING THEN 00265150 + IF WAITX (WAIT1, WAIT2) THEN 00265200 + GO TO NEXT ; 00265250 + END# ; 00265300 + BOOLEAN PROCEDURE WAITX (TOCKS, FORCED) ; 00265500 + VALUE TOCKS, 00265600 + FORCED ; 00265700 + INTEGER TOCKS ; 00265800 + BOOLEAN FORCED ; 00265900 + BEGIN 00266000 + DEFINE SEGMENT = #; 00266100 + IF TOCKS GEQ CLOCK OR FORCED THEN 00266200 + IF Q THEN 00266300 + BEGIN 00266400 + READYQ [READYQTOP := READYQTOP + 1] := USER ; 00266500 + INREADYQ := 1 ; 00266600 + WRITEQUEUED ; 00266700 + N := RESETN ; 00266900 + IF NOTFIRSTINPUT THEN 00267000 + SAVESTATE ; 00267100 + STATION := 0 ; 00267200 + WAITX := TRUE ; 00267300 + END ELSE 00267400 + BEGIN 00267500 + IF FORCED.[46:1] THEN 00267600 + BEGIN 00267700 + WAITX := BOOLEAN (USER := READYQ [1]) ; 00267800 + CHARGE (STATIONI) ; 00267900 + INREADYQ := 0 ; 00268000 + FOR I := 2 STEP 1 UNTIL READYQTOP DO 00268100 + READYQ [I - 1] := READYQ [I] ; 00268200 + READYQTOP := READYQTOP - 1 ; 00268300 + RESTORESTATE ; 00268400 + READ (IO [USER], 30, IMAGE [*]) ; 00268410 + END ; 00268500 + WRITE (PRETANK [*], WAITF ) ; 00268600 + WRITETWX ; 00268700 + WAITFLAG := TRUE ; 00268800 + READYQ [0] := USER ; 00268900 + END ; 00269300 + END WAITX ; 00269400 + DEFINE INTERRUPT (INTERRUPT1) = INTERUPT (INTERRUPT1, 0, 0)#, 00282000 + INTERUPT (INTERUPT1, INTERUPT2, INTERUPT3) = 00282100 + BEGIN 00282500 + IF CLOCK := CLOCK - INTERUPT1 LEQ NEXTCLOCK THEN 00283000 + OUTPUT ; 00283100 + IF CLOCK LEQ 0 THEN 00283200 + IF INTERRUPTS (INTERUPT2, INTERUPT3) THEN 00283500 + GO TO NEXT ; 00284000 + END# ; 00284500 + BOOLEAN PROCEDURE INTERRUPTS (LIB, LOC) ; 00285000 + VALUE LIB, LOC ; 00285100 + INTEGER LIB, LOC ; 00285200 + BEGIN 00285500 + LABEL NEWBIRD, NONE, NEXT ; 00286000 + T0 := CLOCK := MAX (50, T0 | 150 / (-T1 + T1 := TIMEX)) ; 00286500 + IF WAITING THEN 00287000 + BEGIN 00287500 + INPUT [5] := 0 & "~"[1:43:5] ; 00288000 + READ (TWXINPUT (0, 0), 8, INPUT [*]) [NONE] ; 00288500 + QINPUT := TRUE ; 00289000 + NEWBIRD: 00289500 + SWAPSTATE ; 00290000 + CLOSE (LIBRARY) ; 00290100 + CHARGE (STATION := 0) ; 00290500 + INREADYQ := 3 ; 00291000 + Q := TRUE ; 00291500 + PROGRAM ; 00292000 + Q := FALSE ; 00292500 + USER := READYQ [0] ; 00293000 + CHARGE (STATIONI) ; 00295500 + INREADYQ := 0 ; 00296000 + UNSWAPSTATE ; 00296500 + SECURITYCHECK ; 00297000 + IF LIB NEQ 0 THEN 00297100 + BEGIN 00297200 + FILL LIBRARY WITH IF BOOLEAN (LIB) THEN PARAMETER1 ELSE PREFIX, 00297300 + IF BOOLEAN (LIB) THEN PARAMETER2 ELSE SUFFIX ; 00297400 + READ SEEK (LIBRARY [LOC]) ; 00297500 + END ; 00297600 + NONE: 00297700 + IF RATTLEINDEX := RATTLEINDEX + 1 = 5 THEN 00298000 + BEGIN 00298500 + FOR TINK := 0 STEP 1 UNTIL READYQTOP DO 00299000 + BEGIN 00299500 + USER := READYQ [TINK] ; 00300000 + IF COUNTI LSS 0 THEN 00300500 + IF REAL (BOOLEAN (STATUS (STATIONI, 0)).[22:9] AND 00301000 + BOOLEAN ("6C")) = 0 THEN 00301100 + WRITE (TWXOUT, RATTLE) ; 00301500 + END ; 00302000 + USER := READYQ [RATTLEINDEX := 0] ; 00302500 + CHARGE (STATION) ; 00302700 + IF 2 | BIGBIRD + 2 LSS STATUS (ZIPPY [*]) THEN 00303000 + GO TO NEWBIRD ; 00303500 + IF FALSE THEN 00304000 + NEXT: 00304500 + INTERRUPTS := TRUE ; 00305000 + END ; 00305500 + END ; 00306000 + CLOCK := T0 ; 00306100 + T1 := TIMEX ; 00306200 + IF OUTPUTREADY THEN 00306300 + NEXTCLOCK := CLOCK - T0 | (TN - T1 - 90) / 150 ; 00306400 + END INTERRUPTS ; 00307000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00318000 + INTEGER PROCEDURE XFILE (P, S, FS) ; 00318100 + VALUE P, S, FS ; 00318110 + REAL P, S, FS ; 00318120 + BEGIN 00318130 + DEFINE SEGMENT = # ; 00318140 + IF P = 12 THEN 00318150 + BEGIN 00318160 + IF NUM1 THEN 00318170 + BEGIN 00318180 + NUM1 := FALSE ; 00318190 + P := PARAMETER1 := OCTDEC (PARAMETER1) ; 00318200 + END ELSE 00318210 + P := PARAMETER1 ; 00318220 + IF NUM2 THEN 00318230 + BEGIN 00318240 + NUM2 := FALSE ; 00318250 + S := PARAMETER2 := OCTDEC (PARAMETER2) ; 00318260 + END ELSE 00318270 + S := PARAMETER2 ; 00318280 + END ; 00318290 + FILL LIBRARY WITH P, S ; 00318300 + SEARCH (LIBRARY, INPUT [*]) ; 00318310 + IF XFILE := INPUT [0] LSS FS THEN 00318320 + ERRORX (1 + REAL (INPUT [0] LSS 0), P, S) ; 00318330 + END XFILE ; 00318350 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00318360 + PROCEDURE READIN ; 00319000 + BEGIN 00319100 + BOOLEAN PROCEDURE MORE ; 00319210 + BEGIN 00319220 + LABEL NEXT, 00319230 + EXIT ; 00319240 + INTEGER STREAM PROCEDURE TRAILINGBLANKS (S, N) ; 00319250 + VALUE N ; 00319260 + BEGIN 00319270 + LABEL DONE ; 00319280 + SI := S ; 00319290 + SI := SI + 7 ; 00319300 + S := TALLY ; 00319310 + DI := S ; 00319320 + 2 (N (IF SC NEQ " " THEN JUMP OUT 2 TO DONE ; 00319330 + SI := SI - 1 ; 00319340 + DI := DI + 8)) ; 00319350 + DONE: 00319360 + TRAILINGBLANKS := DI ; 00319370 + END TRAILINGBLANKS ; 00319380 + INTEGER XSUB ; 00319390 + DEFINE FILEINFO = XFILETYPE# ; 00319400 + IF FILEOPEN THEN 00319410 + BEGIN 00319420 + IF N GTR FINITY THEN 00319430 + IF N := LL [LAST.F].S + INC GTR FINITY THEN 00319440 + BEGIN 00319450 + N := FINITY ; 00319460 + ERROR (NEXT, 0, "SEQ. OV", "ER-FLOW") ; 00319470 + END ; 00319480 + IF N LEQ 0 THEN 00319490 + N := 1 ; 00319500 + END ; 00319510 + IF MOREINPUT THEN 00319520 + BEGIN 00319530 + READ (IO [USER + MAXUSERS], 30, IMAGE [*]) ; 00319540 + CHRS := NCHRS ; 00319545 + GO TO EXIT ; 00319550 + END ; 00319560 + IF XDEX LSS 0 THEN 00319570 + BEGIN 00319580 + NEXT: 00319590 + IF NOT NOSTAR THEN 00319600 + WRITESEQUENCE ; 00319610 + CHRS := 0 ; 00319620 + SAVESTATE ; 00319630 + END ELSE 00319640 + BEGIN 00319650 + XSUB := XDEX | 13 ; 00319660 + WHILE XN := XN + 1 GTR XLAST DO 00319670 + IF XREPEAT := XREPEAT - 1 GTR 0 THEN 00319680 + XN := XSTART 00319690 + ELSE 00319700 + BEGIN 00319710 + IF XSUFFIX = "#MACRO#" THEN 00319720 + BEGIN 00319730 + IF XFILE (XPREFIX, XSUFFIX, 7) LSS 7 THEN 00319740 + GO TO NEXT ; 00319750 + READ (LIBRARY) ; 00319760 + DETACH ; 00319770 + CLOSE (LIBRARY, PURGE) ; 00319780 + END ; 00319800 + IF BOOLEAN (XNCHRS.[1:1]) THEN 00319810 + BEGIN 00319820 + READ (IO [2|MAXUSERS+XMAX|USER+XDEX], 30, IMAGE [*]) ; 00319830 + CHRS := ABS (XNCHRS) ; 00319840 + XDEX := XDEX - 1 ; 00319850 + GO TO EXIT ; 00319860 + END ; 00319870 + IF XDEX := XDEX - 1 LSS 0 THEN 00319880 + GO TO NEXT ; 00319890 + XSUB := XDEX | 13 ; 00319900 + END ; 00319910 + IF XFILE (XPREFIX, XSUFFIX, 2) LSS 2 THEN 00319920 + GO TO NEXT ; 00319930 + IF XECHO THEN 00319940 + WRITESEQUENCE ; 00319950 + SAVESTATE ; 00319960 + INTERRUPT (3) ; 00319970 + READ (LIBRARY [XN - 1], 10, IMAGE [*]) ; 00319980 + CLOSE (LIBRARY) ; 00319990 + CHRS := (I := FULLLENGTH) - 00320000 + TRAILINGBLANKS (IMAGE [I.[41:4]-1], I.[41:6]) ; 00320010 + IF XECHO THEN 00320020 + WRITEROW (IMAGE [*], FALSE, XFILETYPE) ; 00320030 + EXIT: 00320040 + MORE := TRUE ; 00320050 + END ; 00320060 + END MORE ; 00320070 + BOOLEAN STREAM PROCEDURE LINEEDIT (S, D, C, CHRS, P, OVER80, EIGHTY1) ;00321000 + VALUE C, 00321100 + P, 00321200 + OVER80, 00321300 + EIGHTY1 ; 00321400 + BEGIN 00321500 + LOCAL T, 00321600 + PERCENT1, PERCENT ; 00321700 + LABEL AROUND, NEXT ; 00321800 + P (DI := LOC PERCENT ; DS := 14 LIT "%?-~=!(<)>[{]}") ; 00321900 + SI := LOC C ; 00322000 + DI := LOC T ; 00322100 + SI := SI + 6 ; 00322200 + DI := DI + 7 ; 00322300 + DS := CHR ; 00322400 + SI := S ; 00322500 + DI := D ; 00322600 + T (DI := DI + 32 ; DI := DI + 32) ; 00322700 + DI := DI + C ; 00322800 + 56(IF SC = "~" THEN 00322900 + GO TO AROUND ; 00323000 + IF SC = "}" THEN% DISCONNECT OR EXCLAMATION 00323010 + BEGIN 00323020 + TALLY := 1 ; 00323030 + GO TO AROUND ; 00323040 + END ; 00323050 + IF SC = "!" THEN% LINE ERASE 00323100 + BEGIN 00323200 + C := TALLY ; 00323300 + OVER80 := TALLY ; 00323400 + DI := D ; 00323500 + GO TO AROUND ; 00323600 + END ; 00323700 + IF SC = "{" THEN% BACKSPACE 00323800 + BEGIN 00323900 + S := SI ; 00324000 + T := DI ; 00324100 + SI := LOC C ; 00324200 + DI := LOC LINEEDIT ; 00324300 + IF 8 SC NEQ DC THEN 00324400 + BEGIN 00324500 + OVER80 (SI := SI - 8 ; 00324600 + DI := LOC EIGHTY1 ; 00324700 + IF 8 SC = DC THEN 00324800 + OVER80 := TALLY) ; 00324900 + SI := C ; 00325000 + SI := SI - 8 ; 00325100 + C := SI ; 00325200 + DI := T ; 00325300 + DI := DI - 1 ; 00325400 + END ELSE 00325500 + DI := T ; 00325600 + SI := S ; 00325700 + AROUND: 00325800 + END ELSE 00325900 + BEGIN 00326500 + S := SI ; 00326600 + OVER80 (DI := DI + 1 ; 00326700 + SI := C ; 00326900 + SI := SI + 8 ; 00327000 + C := SI ; 00327100 + SI := S ; 00327200 + JUMP OUT TO AROUND) ; 00327300 + T := DI ; 00327500 + P (DI := S ; 00327600 + SI := T ; 00327700 + SI := SI - 1 ; 00327800 + IF SC = "%" THEN 00327900 + BEGIN 00328000 + SI := LOC PERCENT ; 00328100 + 7 (IF SC = DC THEN 00328200 + BEGIN 00328300 + DI := T ; 00328400 + DI := DI - 1 ; 00328500 + DS := CHR ; 00328600 + SI := S ; 00328700 + JUMP OUT 2 TO AROUND ; 00328900 + END ; 00329000 + SI := SI + 1 ; 00329100 + DI := DI - 1) ; 00329200 + END) ; 00329300 + SI := C ; 00330600 + SI := SI + 8 ; 00330700 + C := SI ; 00330800 + SI := LOC C ; 00330900 + DI := LOC EIGHTY1 ; 00331000 + IF 8 SC = DC THEN 00331100 + BEGIN 00331200 + TALLY := 1 ; 00331300 + OVER80 := TALLY ; 00331400 + TALLY := 0 ; 00331500 + END ; 00331600 + SI := S ; 00331700 + DI := T ; 00331800 + IF TOGGLE THEN 00331900 + DI := DI + 1 00332000 + ELSE BEGIN 00332100 + DS := CHR ; 00332200 + SI := SI - 1 ; 00332300 + END ; 00332400 + GO TO NEXT ; 00332500 + END ; 00332550 + IF SC = "~" THEN JUMP OUT ; 00332560 + IF SC = "}" THEN JUMP OUT ; 00332570 + NEXT: 00332580 + SI := SI + 1) ; 00332600 + SI := LOC C ; 00332700 + DI := CHRS ; 00332800 + DS := WDS ; 00332900 + LINEEDIT := TALLY ; 00333100 + END LINEEDIT ; 00333200 + BOOLEAN PROCEDURE FINALANALYSIS ; 00333210 + BEGIN 00333220 + STREAM PROCEDURE MOVE (S, D, SKPS, SKPD, N) ; 00333230 + VALUE SKPS, SKPD, N ; 00333240 + BEGIN 00333250 + LOCAL T ; 00333260 + SI := LOC N ; 00333270 + DI := LOC T ; 00333280 + SI := SI + 6 ; 00333290 + DI := DI + 7 ; 00333300 + DS := CHR ; 00333310 + SI := S ; 00333320 + DI := D ; 00333330 + SI := SI + SKPS ; 00333340 + DI := DI + SKPD ; 00333350 + T (DS := 32 CHR ; DS := 32 CHR) ; 00333360 + DS := N CHR ; 00333370 + END MOVE ; 00333380 + INTEGER STREAM PROCEDURE HUNT (S, D, C, N) ; 00333390 + VALUE C, 00333400 + N ; 00333500 + BEGIN 00333600 + LABEL AGAIN, 00333700 + XIT ; 00333800 + SI := D ; 00333900 + DI := D ; 00334000 + DS := 8 LIT " " ; 00334100 + DS := 9 WDS ; 00334200 + D := TALLY ; 00334300 + DI := LOC D ; 00334400 + SI := LOC C ; 00334500 + SI := SI + 7 ; 00334600 + DS := CHR ; 00334700 + AGAIN: 00334800 + SI := LOC N ; 00334900 + SI := SI + 1 ; 00335000 + IF 7 SC = DC THEN 00335100 + GO TO XIT ; 00335200 + SI := N ; 00335300 + SI := SI - 8 ; 00335400 + N := SI ; 00335500 + SI := S ; 00335600 + DI := LOC D ; 00335700 + IF SC = DC THEN 00335800 + GO TO XIT ; 00335900 + S := SI ; 00336000 + SI := HUNT ; 00336100 + SI := SI + 8 ; 00336200 + HUNT := SI ; 00336300 + GO TO AGAIN ; 00336400 + XIT: 00336500 + END HUNT ; 00336600 + BOOLEAN STREAM PROCEDURE MORE (IMAGE, INPUT, C, CHRS) ; 00344000 + VALUE C ; 00344010 + BEGIN 00344500 + LOCAL QUOTES, 00345000 + ENDQUOTE, 00345500 + ZERO, 00345510 + TEMP ; 00346000 + LABEL NOTHINGYET, 00346500 + BUMP, 00347000 + FOUNDQUOTE, 00347500 + FOUNDSEMICOLAN, 00348000 + LOOP, 00348500 + XIT, 00349000 + EXIT ; 00349100 + SI := IMAGE ; 00349500 + DI := LOC QUOTES ; 00350000 + DS := 2 LIT """ ; 00350500 + DS := 6 LIT "..()[]" ; 00351000 + DI := LOC ENDQUOTE ; 00351100 + DS := 2 LIT ";;" ; 00351200 + LOOP: 00351300 + IMAGE := SI ; 00351310 + SI := LOC C ; 00351330 + DI := LOC ZERO ; 00351340 + IF 8 SC = DC THEN 00351350 + GO TO XIT ; 00351360 + SI := C ; 00351370 + SI := SI - 8 ; 00351380 + C := SI ; 00351390 + SI := IMAGE ; 00351400 + CI := CI + MORE ; 00351500 + GO TO NOTHINGYET ; 00352000 + GO TO LOOP ; 00352500 + GO TO FOUNDQUOTE ; 00353000 + NOTHINGYET: 00353500 + IF SC = ALPHA THEN 00354000 + GO TO BUMP ; 00354500 + IF SC = " " THEN 00355000 + GO TO BUMP ; 00355500 + DI := LOC QUOTES ; 00356000 + 4 (IF SC = DC THEN 00356500 + BEGIN 00359000 + TEMP := SI ; 00359500 + ENDQUOTE := DI ; 00360000 + DI := LOC ENDQUOTE ; 00360500 + SI := ENDQUOTE ; 00361000 + DS := 1 CHR ; 00361500 + TALLY := 2 ; 00362000 + MORE := TALLY ; 00362500 + SI := TEMP ; 00363000 + JUMP OUT TO LOOP ; 00363500 + END ; 00364000 + SI := SI - 1 ; 00364100 + DI := DI + 1) ; 00364200 + IF SC = ";" THEN 00365500 + GO TO FOUNDSEMICOLAN ; 00369000 + BUMP: 00371500 + SI := SI + 1 ; 00372000 + GO TO LOOP ; 00372500 + FOUNDQUOTE: 00374500 + DI := LOC ENDQUOTE ; 00375000 + IF SC = DC THEN 00375500 + BEGIN 00376000 + DI := DI - 1 ; 00376100 + DS := LIT ";" ; 00376200 + TALLY := 0 ; 00376500 + MORE := TALLY ; 00377000 + END ; 00377500 + GO TO LOOP ; 00378000 + XIT: 00378500 + SI := LOC ENDQUOTE ; 00378600 + DI := IMAGE ; 00378700 + DS := 2 CHR ; 00378800 + GO TO EXIT ; 00378900 + FOUNDSEMICOLAN: 00378910 + TALLY := 1 ; 00378920 + MORE := TALLY ; 00378930 + SI := LOC C ; 00378940 + DI := CHRS ; 00378950 + DS := WDS ; 00378960 + SI := LOC C ; 00378970 + DI := LOC TEMP ; 00378980 + SI := SI + 6 ; 00378990 + DI := DI + 7 ; 00379000 + DS := CHR ; 00379010 + SI := IMAGE ; 00379020 + SI := SI + 1 ; 00379030 + DI := INPUT ; 00379040 + TEMP (DS := 32 CHR ; DS := 32 CHR) ; 00379050 + DS := CHR ; 00379060 + EXIT: 00379070 + END MORE ; 00379500 + INTEGER STREAM PROCEDURE FIX (IM, TAB, C, Z, P, Q) ; 00380000 + VALUE TAB, 00380500 + C, 00381000 + P, 00381100 + Q ; 00381200 + BEGIN 00381500 + LOCAL T ; 00382000 + P (SI := IM ; 00382100 + IF SC = "%" THEN 00382110 + BEGIN 00382120 + SI := SI + 1 ; 00382130 + IF SC = "*" THEN 00382140 + BEGIN 00382150 + SI := C ; 00382180 + SI := SI - 8 ; 00382190 + C := SI ; 00382200 + TALLY := 1 ; 00382210 + FIX := TALLY ; 00382220 + END ; 00382230 + END) ; 00382240 + SI := Z ; 00382500 + DI := Z ; 00383000 + DS := 8 LIT " " ; 00383500 + DS := 9 WDS ; 00384000 + SI := LOC C ; 00384100 + DI := LOC T ; 00384200 + SI := SI + 6 ; 00384300 + DI := DI + 7 ; 00384400 + DS := CHR ; 00384500 + SI := IM ; 00384600 + SI := SI + FIX ; 00384650 + DI := Z ; 00384700 + DI := DI + TAB ; 00384800 + T (DS := 32 CHR ; DS := 32 CHR) ; 00384900 + DS := C CHR ; 00385000 + SI := Z ; 00389000 + DI := IM ; 00389500 + DS := 10 WDS ; 00390000 + Q (DI := IM ; DS := 1 LIT "0") ; 00390100 + END FIX ; 00390500 + INTEGER C, 00390505 + H, 00390508 + K ; 00390510 + LABEL ERR, NEXT ; 00390520 + NOSTAR := (FIRSTCHAR (IMAGE [0]) NEQ "*" OR H := CHRS = 0) 00390540 + AND READWRITEFILE ; 00390550 + NOTFIRSTINPUT := MOREINPUT ; 00390560 + IF NOSTAR THEN 00390570 + BEGIN 00390580 + I := IF COBOLFILE THEN 6 ELSE 0 ; 00390590 + IF XDEX GEQ 0 THEN IF BOOLEAN (XFILETYPE) THEN I := 0 ; 00390595 + MOREINPUT := FALSE ; 00390600 + IF H + TABAMOUNT GTR LENGTH THEN 00390610 + GO TO ERR ; 00390630 + H := H + TABAMOUNT + I - FIX (IMAGE, TABAMOUNT + I, H, 00390640 + ZIPPY, TRANSLATING AND H GEQ 2, I = 6) ; 00390650 + IF COLUMNS THEN 00390660 + BEGIN 00390670 + FOR K := 1 STEP 1 UNTIL COLSTOPS DO 00390680 + IF I := MIN (H, MAXCOLSTOP) NEQ 00390690 + C := HUNT (IMAGE, ZIPPY, CHARACTER, I) THEN 00390700 + BEGIN 00390710 + WHILE C GEQ I := COLSTOP [K] DO 00390720 + K := K + 1 ; 00390730 + I := I - 1 ; 00390760 + MOVE (IMAGE, ZIPPY, 0, 0, C) ; 00390770 + IF H := H + I - (C := C + 1) GTR FULLLENGTH THEN 00390780 + BEGIN 00390785 + ERR: 00390790 + FINALANALYSIS := TRUE ; 00390795 + ERROR (NEXT, 0, "INPUT ", "OVERFLW") ; 00390800 + END ; 00390805 + MOVE (IMAGE [C.[41:4]], ZIPPY [I.[41:4]], C.[45:3], 00390810 + I.[45:3], H - I) ; 00390820 + MOVE (ZIPPY, IMAGE, 0, 0, 80) ; 00390840 + END ELSE 00390850 + K := 5 ; 00390860 + END ; 00390870 + CHRS := H ; 00390875 + IF XDEX LSS 0 AND NOT INLINETOG AND N := N+INC LSS INFINITY THEN00390880 + WRITESEQUENCE ; 00390910 + N := N - INC ; 00390920 + END 00391110 + ELSE 00391120 + BEGIN 00391130 + IF H GTR 240 THEN 00391140 + GO TO ERR ; 00391150 + INLINETOG := FALSE ; 00391160 + MOREINPUT := MORE (IMAGE, ZIPPY, H, NCHRS) ; 00391170 + IF MOREINPUT THEN 00391175 + WRITE (IO [USER + MAXUSERS], 30, ZIPPY [*]) ; 00391180 + END ; 00391190 + NEXT: 00391210 + END FINALANALYSIS ; 00391230 + INTEGER C, 00391240 + LASTUSER ; 00391250 + REAL X ; 00391260 + LABEL AGAIN, 00392000 + INPUTFULL, 00392500 + EXIT, 00394500 + NEXT, 00394600 + ESCAPE ; 00394700 + INTEGER PROCEDURE READTWX ; 00394800 + BEGIN 00394900 + LABEL NONE, TROUBLE, EXIT ; 00395000 + REAL TIMEOUT, X ; 00395100 + INPUT [5] := 0 & "~"[1:43:5] ; 00395200 + IF NOT Q THEN 00395300 + TIMEOUT := IF OUTPUTREADY THEN MAX(0,MIN(15,(TN-TIMEX-60)/60)) 00395400 + ELSE 15 ; 00395500 + READ (TWXINPUT (0, TIMEOUT), 8, INPUT [*]) [NONE:TROUBLE] ; 00395600 + GO TO EXIT ; 00395700 + NONE: 00395800 + IF Q THEN 00395900 + BEGIN 00396000 + USER := MAXUSERS ; 00396100 + READTWX := 1 ; % ESCAPE 00396200 + GO TO EXIT ; 00396300 + END ; 00396400 + IF OUTPUTREADY THEN 00396500 + OUTPUT ; 00396600 + T1 := TIMEX ; 00396700 + FOR USER := 0 STEP 1 UNTIL BIGBIRD DO 00396800 + BEGIN 00396900 + CHECK (STATIONI) ; 00397100 + IF BOOLEAN (ABNORMALEND) THEN 00397200 + BEGIN 00397300 + READTWX := 1 ; 00397400 + GO TO EXIT ; 00397500 + END ; 00397600 + IF X := (T1 - TIMEI)/1000 LSS 0 THEN 00397700 + X := X + 5184 ; 00397800 + IF X GTR 15 AND X LSS 100 THEN 00397900 + BEGIN 00398000 + IF X LSS 18 THEN 00398100 + FIRSTCHANCE := 0 00398200 + ELSE IF X GEQ 36 THEN 00398300 + BEGIN 00398400 + WRITE (PRETANK [*], EOJ) ; 00398500 + WRITETWX ; 00398600 + ABNORMALEND := READTWX := 1 ; 00398700 + GO TO EXIT ; 00398800 + END ELSE IF FIRSTCHANCE = 0 THEN 00398900 + BEGIN 00399000 + FIRSTCHANCE := 1 ; 00399100 + X := TIMEI ; 00399200 + ERRORX (7, "LOOK ", "ALIVE.") ; 00399300 + TIMEI := X ; 00399400 + END ; 00399500 + END ; 00399600 + END ; 00399700 + READTWX := 2 ; 00399800 + GO TO EXIT ; 00399900 + TROUBLE: 00400000 + READ (TWXINPUT (0, 0), 1, INPUT [*]) ; 00400100 + INPUT [1] := "}" ; 00400200 + EXIT: 00400300 + END READTWX ; 00400400 + PROCEDURE INITIALIZE ; 00406000 + BEGIN 00407000 + MONITOR INTOVR, FLAG ; 00407500 + INTEGER I, 00408000 + C ; 00408100 + REAL U ; 00408200 + BOOLEAN OLDUSER ; 00408500 + DEFINE DIRCTRY = CONTROLS# ; 00408600 + LABEL OLD, 00409000 + FAULT, 00409500 + NEW, 00410000 + MAILCALL, 00410500 + NEXT ; 00410600 + USER := BIGBIRD := BIGBIRD + 1 ; 00420000 + ATTACH ; 00421000 + STATIONI := STATION ; 00421500 + IF USERCODEI := USERCODE = -1 THEN 00422500 + USERCODE := OCTDEX (100|STATION.[9:4]+STATION.[14:4]) ; 00423000 + COUNTI := -1 ; 00426000 + ILFCRI := 1 ; 00426100 + ERRORX (7, "VERSION", OCTDEX (VERSION)) ; 00427900 + FAULT: 00427910 + READ (R1 [45], 90, DIRCTRY [*]) ; 00427920 + IF OLDUSER THEN 00427930 + BEGIN 00427940 + OLDUSER := FALSE ; 00427950 + I := C + C ; 00427960 + ERROR (OLD, 0, "BACKUP ", "ERROR. ") ; 00427970 + END ; 00427980 + C := 200 ; 00428000 + FOR I := 0 STEP 2 WHILE U := DIRCTRY [I] NEQ 12 DO 00428100 + IF USERCODE = U THEN 00428200 + BEGIN 00428300 + OLDUSER := TRUE ; 00428400 + IF STATION = DIRCTRY [I + 1] THEN 00428500 + GO TO OLD ; 00428600 + C := I ; 00428700 + END ELSE 00428800 + IF U = 0 AND NOT OLDUSER THEN 00428900 + C := I ; 00429000 + IF C NEQ 200 THEN 00429100 + I := C 00429300 + ELSE IF I LEQ 88 THEN 00432500 + DIRCTRY [I + 2] := 12 00433500 + ELSE 00434500 + WHILE DIRCTRY [I := I - 2] LSS 0 DO ; 00435000 + OLD: 00436500 + C := SLOTI := I / 2 ; 00437000 + DIRCTRY [I] := - USERCODE ; 00437500 + DIRCTRY [I + 1] := STATION ; 00438000 + WRITE (R1 [45], 90, DIRCTRY [*]) ; 00438500 + IF NOT OLDUSER THEN 00438600 + GO TO NEW ; 00438700 + INTOVR := FAULT ; 00439500 + FLAG := FAULT ; 00440500 + RESTORESTATE ; 00441000 + STATION := STATIONI ; 00441500 + IF VN LSS 94 OR VN GTR VERSION THEN 00441800 + GO TO FAULT ; 00441900 + IF FILECLOSED THEN 00443000 + GO TO MAILCALL ; 00444500 + IF D GTR MAXFILELENGTH THEN 00445100 + GO TO FAULT ; 00445200 + READ SEEK (R2 [32 | C]) ; 00445300 + SECURITYCHECK ; 00447000 + IF INPUT [5] + 2 LSS D OR INPUT [3] NEQ 10 THEN 00450000 + ERROR (MAILCALL, 3, PREFIX, SUFFIX) ; 00452500 + AT := D.LEFTSIDE ; 00453000 + FOR I := 0 STEP 1 UNTIL AT DO 00453100 + READ (R2, 256, LINKLISTS [USER32 + I, *]) [FAULT] ; 00453200 + AT := 0 ; 00453500 + FOR I := 1 STEP 1 UNTIL D DO 00454000 + BEGIN 00454100 + IF AT NEQ LL [AT := LL [AT] . T] . F THEN 00454400 + I := D 00454500 + ELSE IF AT = 1 THEN 00454600 + ERROR (NEXT, 6, PREFIX, SUFFIX) ; 00455000 + END ; 00455100 + ERROR (MAILCALL, 7, "LINKLIS", "T ERROR") ; 00456500 + NEW: 00458500 + WRITE (R2 [32 | C + 31], 1, IMAGE [*]) ; 00459000 + LOCK (R2) ; 00459500 + USER32 := USER | 32 ; 00460000 + BOOL := INITIALBOOL ; 00461000 + INC := 100 ; 00462500 + MACROLIBRARY := "MACRO " ; 00462900 + CHARACTER := "#" ; 00463000 + SAVEFACTOR := 7 ; 00463500 + COLSTOPS := STRINGI := 0 ; 00465000 + FILL RSWD [*] WITH "EXECUTE", "DITTO ", "COPY ", "INLINE ", 00466000 + "ZIP ", "CHANGE ", "EDIT ", "SAVE ", "RESEQ ", 00466500 + "PUNCH ", "PRINT ", "DELETE ", "CLOSE ", "COMPILE", 00467000 + "COLUMN ", "SCAN ", "LISTING", "INC ", "TAB ", 00467500 + "PERCENT", "QUICK ", "LIST ", "OPEN ", "MAIL ", 00468000 + "TEACH ", "REMOVE ", "REPLACE", "END " ; 00468500 + MAILCALL: 00469000 + FILEACCESS := 0 ; 00469100 + INORDER := TRUE ; 00469200 + NEXT: 00469300 + TRANSLATEI := REAL (TRANSLATING) ; 00472100 + VN := VERSION ; 00472200 + ERRORX (0, (IF XFILE ("MAIL % ", USERCODE, -1) = 7 THEN "MAIL % " 00489500 + ELSE "HELLO ") & REAL (NOT OLDUSER)[42:47:1], USERCODE) ; 00490000 + END INITIALIZE ; 00490500 + LASTUSER := MAXUSERS ; 00490600 + IF QINPUT THEN 00491000 + BEGIN 00491100 + QINPUT := FALSE ; 00491200 + GO TO INPUTFULL ; 00491300 + END ; 00491400 + IF STATION NEQ 0 THEN 00493200 + BEGIN 00493400 + LASTUSER := USER ; 00493410 + NEXT: 00493500 + IF MORE THEN 00494000 + GO TO EXIT ; 00494400 + END ; 00494600 + IF NOT Q AND READYQTOP GTR 0 THEN 00494700 + BEGIN 00494800 + LASTUSER := REAL (WAITX (0, BOOLEAN (3))) ; 00494900 + SECURITYCHECK ; 00495000 + GO TO EXIT ; 00495100 + END ; 00495200 + AGAIN: 00495300 + CHARGE (0) ; 00495400 + IF 2 | BIGBIRD LSS C := STATUS (ZIPPY [*]) - 2 THEN 00495500 + BEGIN 00495600 + LASTUSER := BIGBIRD + 1 ; 00495650 + FOR X := 0 STEP 2 UNTIL C DO 00495700 + BEGIN 00495800 + STATION := 0 & ZIPPY [X] [9:9:9] ; 00495900 + FOR USER := 0 STEP 1 UNTIL BIGBIRD DO 00496000 + IF STATION = STATIONI THEN 00496100 + USER := MAXUSERS ; 00496200 + IF USER LEQ MAXUSERS THEN 00496300 + BEGIN 00496400 + IF BIGBIRD LSS MAXUSER THEN 00496500 + BEGIN 00496600 + USERCODE := ZIPPY [X + 1] ; 00496700 + INITIALIZE ; 00496800 + GO TO NEXT ; 00496900 + END ; 00497000 + NOMOREROOM ; 00497100 + END ; 00497300 + END ; 00497400 + END ; 00497500 + IF X := READTWX NEQ 0 THEN 00497600 + BEGIN 00497700 + IF X = 2 THEN 00497800 + GO TO AGAIN ; 00497900 + GO TO ESCAPE ; 00498100 + END ; 00498300 + INPUTFULL: 00506000 + X := INPUT [0] ; 00506100 + USER := 0 ; 00506500 + WHILE STATIONI NEQ 0 & X[9:9:9] DO 00507000 + IF USER := USER + 1 GTR BIGBIRD THEN 00507500 + GO TO AGAIN ; 00507600 + CHARGE (X) ; 00508000 + IF C := CHRS NEQ 0 THEN 00508500 + READ (IO [USER], 30, IMAGE [*]) ; 00509000 + BREAKI := 0 ; 00511000 + IF LINEEDIT (INPUT [1], IMAGE, C, C, 00512000 + TRANSLATEI, C GTR 240, 241) THEN 00512100 + ERROR (AGAIN, 7, "DEL{!~ ", CHRS := 0) ; 00512300 + IF BOOLEAN (X.[25:1]) THEN 00512500 + BEGIN 00512600 + IF FIRSTCHAR (INPUT [5]) = "~" THEN 00513000 + C := C - 4 ; 00513500 + CHRS := C ; 00513700 + WRITE (IO [USER], 30, IMAGE [*]) ; 00514000 + GO TO AGAIN ; 00520000 + END ; 00520500 + IF BOOLEAN (INREADYQ) THEN 00520600 + ERROR (AGAIN, 7, "PLEASE ", "WAIT...") ; 00520700 + WRITELFCR ; 00520800 + CHRS := C ; 00520810 + CLOCK := T0 ; 00520850 + T1 := TIMEX ; 00520900 + IF OUTPUTREADY THEN 00520950 + NEXTCLOCK := CLOCK - T0 | (TN - T1 - 90) / 150 ; 00520960 + IF LASTUSER NEQ LASTUSER := USER THEN 00522000 + RESTORESTATE ; 00522500 + SECURITYCHECK ; 00522600 + WAITFLAG := FALSE ; 00522700 + EXIT: 00532000 + IF FINALANALYSIS THEN 00532500 + GO TO NEXT ; 00533500 + IF OUTPUTREADY THEN 00533600 + IF TN - 60 LEQ TIMEX THEN 00533700 + OUTPUT ; 00533800 + ESCAPE: 00534500 + END READIN ; 00546500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00547000 + DEFINE RDISC (RDISC1, RDISC2) = 00547100 + IF RDISCX (RDISC1, RDISC2) THEN GO TO NEXT# ; 00547200 + BOOLEAN PROCEDURE RDISCX (WHERE, IMAGE) ; 00547500 + VALUE WHERE ; 00548000 + INTEGER WHERE ; 00548500 + ARRAY IMAGE [0] ; 00549000 + BEGIN 00549500 + LABEL EOF ; 00549600 + STREAM PROCEDURE ZOT (D) ; 00549710 + BEGIN 00549720 + DI := D ; 00549730 + DS := RESET ; 00549740 + END ZOT ; 00549750 + IF PREWHERE + 1 NEQ PREWHERE := ABS (WHERE) - 2 THEN 00550000 + READ SEEK (DISC [PREWHERE]) ; 00550500 + READ (DISC, 10, IMAGE [*]) [EOF] ; 00551000 + IF COBOLFILE THEN 00551010 + ZOT (IMAGE) ; 00551020 + IF WHERE LSS 0 THEN 00551030 + SEQUENCE ; 00551040 + IF FALSE THEN 00551100 + BEGIN 00551150 + EOF: 00551200 + ERRORX (5, "AT SEQ#", OCTDEX (N)) ; 00551250 + RDISCX := TRUE ; 00551350 + PREWHERE := -2 ; 00551400 + END ; 00551450 + END RDISC ; 00551500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00552000 + DEFINE WRITEAT = 00552500 + IF WRITEATX (QUICK, -N, RECORD) THEN 00552800 + GO TO NEXT# ; 00552900 + BOOLEAN PROCEDURE WRITEATX (QUICK, NN, RECORD) ; 00553000 + VALUE QUICK, NN ; 00553100 + BOOLEAN QUICK ; 00553200 + INTEGER NN ; 00553300 + ARRAY RECORD [0] ; 00553400 + BEGIN 00554000 + LABEL NEXT ; 00554100 + N := ABS (NN) ; 00555500 + IF NOT COBOLFILE THEN 00556000 + WRITESEQ ; 00556500 + IF NN LSS 0 THEN 00556600 + RDISC (AT, RECORD) ; 00557000 + IF COBOLFILE THEN 00557500 + RECORD [0].[1:35] := OCTDEC (N) ; 00558000 + WRITEROW (RECORD, QUICK, FILEINFO) ; 00558500 + IF BOOLEAN (BREAKI) THEN 00559600 + NEXT: 00559700 + WRITEATX := TRUE ; 00559800 + END WRITEAX ; 00560000 + DEFINE WRITEME (WRITEME1, WRITEME2) = 00560100 + IF WRITEATX (QUICK, WRITEME1, WRITEME2) THEN 00560200 + GO TO NEXT# ; 00560300 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00560500 + BOOLEAN PROCEDURE TOGGLE (OLDVALUE, I) ; 00561000 + VALUE OLDVALUE, 00561500 + I ; 00562000 + BOOLEAN OLDVALUE ; 00562500 + REAL I ; 00563000 + BEGIN 00563500 + LABEL NEXT ; 00564000 + IF I = 3 THEN 00564100 + BEGIN 00564110 + IF REAL (OLDVALUE) = "ALGOL " THEN 00564120 + TOGGLE := BOOLEAN (ALGOL) 00564130 + ELSE IF REAL (OLDVALUE) = "XALGOL " THEN 00564140 + TOGGLE := BOOLEAN (XALGOL) 00564150 + ELSE IF REAL (OLDVALUE) = "DATA " THEN 00564160 + TOGGLE := BOOLEAN (DATA) 00564170 + ELSE IF REAL (OLDVALUE) = "FORTRAN" THEN 00564180 + TOGGLE := BOOLEAN (FORTRAN) 00564190 + ELSE IF REAL (OLDVALUE) = "COBOL " THEN 00564200 + TOGGLE := BOOLEAN (COBOL) 00564210 + ELSE IF REAL (OLDVALUE) = "BASIC " THEN 00564220 + TOGGLE := BOOLEAN (BASIC) ; 00564230 + GO TO NEXT ; 00564240 + END ; 00564250 + IF (IF I = 1 THEN EMPTY1 ELSE EMPTY2) THEN 00564500 + ERROR (NEXT, 7, PARAMETER0, ONOFF (TOGGLE := OLDVALUE)) ; 00565000 + I := IF I = 1 THEN PARAMETER1 ELSE PARAMETER2 ; 00565100 + IF NOT (TOGGLE := I = "ON ") THEN 00565500 + IF I NEQ "OFF " THEN 00566000 + ERRORX (0, "MISSING", " ON/OFF") ; 00566500 + NEXT: 00567000 + END TOGGLE ; 00567500 + DEFINE FILETYPE (FILETYPE1) = REAL (TOGGLE (BOOLEAN (FILETYPE1), 3))# ;00567600 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00568200 + BOOLEAN PROCEDURE VERIFAX (XEROX, DD) ; 00680000 + VALUE XEROX, DD ; 00680500 + INTEGER XEROX, 00681000 + DD ; 00681100 + BEGIN 00681500 + DEFINE 00681600 + PRINTING = XEROX = 2#, 00681700 + PUNCHING = XEROX = 4#, 00681800 + ZIPPING = XEROX = 8# ; 00681900 + FILE COPY DISK SERIAL [20:DD] (2, 10, 150, SAVE SAVEFACTOR) ; 00682000 + BOOLEAN B ; 00683500 + REAL L ; 00684000 + LABEL NEXT ; 00684500 + XLOCKED := TRUE ; 00687000 + IF BOOLEAN (XEROX) THEN 00687500 + BEGIN 00688000 + FILL COPY WITH PREFIX, SUFFIX, *, *, *, 12 ; 00689000 + L := FIRST ; 00691000 + WHILE AT := L.T NEQ 1 DO 00692100 + BEGIN 00692500 + N := (L := LL [AT]).S ; 00693300 + RDISC (-AT, ZIPPY) ; 00693500 + WRITE (COPY, 10, ZIPPY [*]) ; 00695500 + INTERRUPT (1) ; 00696000 + END ; 00696500 + READ (DISC [0]) ; 00697500 + DETACH ; 00698000 + CLOSE (DISC, PURGE) ; 00698500 + LOCK (COPY) ; 00699500 + REATTACH ; 00700000 + INORDER := TRUE ; 00702500 + FILEACCESS := 0 ; 00705500 + SAVESTATE ; 00706000 + END XEROX 00706500 + ELSE 00707000 + BEGIN 00708000 + FILL COPY WITH PARAMETER1, PARAMETER2, *, *, *, 00709000 + IF PRINTING THEN 15 ELSE IF PUNCHING THEN 22 ELSE 12 ; 00709500 + IF PRINTING THEN 00713000 + BEGIN 00713500 + WRITE (ZIPPY [*], DATE, PREFIX.[6:6], PREFIX, 00714000 + SUFFIX.[6:6], SUFFIX, (L := TIME (1)) DIV 216000, 00714500 + L DIV 3600 MOD 60, TIME (6), MMDDYY, 00715000 + USERCODE.[6:6], USERCODE) ; 00715500 + DETACH ; 00716000 + WRITE (COPY [DBL], 17, ZIPPY [*]) ; 00716500 + REATTACH ; 00719000 + END ; 00720000 + L := N ; 00720500 + DD := M := 0 ; 00721000 + B := PRINTING AND PARAMETER2 = "DOUBLE " ; 00721100 + WHILE N := LL [DD := LL [DD].T].S LEQ PARAMETER4 DO 00721500 + IF PARAMETER3 LEQ N THEN 00722000 + BEGIN 00723000 + RDISC (DD & (REAL (NOT ZIPPING))[1:47:1], ZIPPY) ; 00723500 + IF PRINTING THEN 00724000 + ZIPPY [14] := OCTDEX (M := M + 1) & "#"[1:43:5] ; 00724500 + IF B THEN 00726000 + WRITE (COPY [DBL], 17, ZIPPY [*]) 00726500 + ELSE WRITE (COPY, 17, ZIPPY [*]) ; 00727000 + INTERRUPT (1) ; 00727500 + END 00728000 + ELSE M := M + 1 ; 00728500 + IF ZIPPING THEN 00729000 + ZIP WITH COPY ; 00729500 + LOCK (COPY) ; 00730000 + N := L ; 00730500 + END THERMOFAX ; 00731000 + IF FALSE THEN 00731100 + NEXT: 00731200 + VERIFAX := TRUE ; 00731300 + XLOCKED := FALSE ; 00731400 + END VERIFAX ; 00731500 + DEFINE THERMOFAX (THERMOFAX1, THERMOFAX2) = 00731600 + BEGIN 00731650 + WAIT (KOUNT (PARAMETER3, PARAMETER4, CLOCK), XLOCKED) ; 00731700 + IF VERIFAX (THERMOFAX1, THERMOFAX2) THEN 00731750 + GO TO NEXT ; 00731800 + END#, 00731850 + CREATEFILE (CREATEFILE1) = 00731900 + BEGIN 00731950 + LIBRARY.AREAS := 20 ; 00732000 + LIBRARY.AREASIZE := CREATEFILE1 ; 00732010 + LIBRARY.SAVE := SAVEFACTOR ; 00732020 + WRITE (LIBRARY, 10, RECORD [*]) ; 00732030 + LOCK (LIBRARY) ; 00732040 + LIBRARY.AREASIZE := 0 ; 00732050 + LIBRARY.AREAS := 0 ; 00732060 + END#, 00732100 + CLOSEMYFILE = 00732150 + BEGIN 00732200 + IF NOT INORDER THEN 00732250 + BEGIN 00732300 + WAIT (KOUNT (1, FINITY, CLOCK), XLOCKED) ; 00732350 + IF VERIFAX (17, (D + 14) DIV 15 | 15) THEN 00732400 + GO TO NEXT ; 00732450 + END ELSE 00732500 + BEGIN 00732550 + FILEACCESS := 0 ; 00732600 + CLOSE (DISC) ; 00732650 + END ; 00732700 + END# ; 00732750 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00733000 + DEFINE WDISC = IF WDISCX (IMAGE) THEN GO TO NEXT# ; 00733500 + BOOLEAN PROCEDURE WDISCX (IMAGE) ; 00734000 + ARRAY IMAGE [0] ; 00734500 + BEGIN 00735000 + REAL L ; 00735100 + LABEL EOT, 00735500 + NEXT ; 00735600 + WHILE N GTR (L := LL [AT]).S DO 00743500 + AT := L.T ; 00744000 + WHILE N LSS (L := LL [AT]).S DO 00744500 + AT := L.F ; 00745000 + IF N NEQ L.S THEN 00745500 + BEGIN 00746000 + IF D GEQ MAXFILELENGTH THEN 00746500 + ERROR (NEXT, 0, "FILE TO", " LONG. ") ; 00747000 + IF PREWHERE NEQ PREWHERE := D - 2 THEN 00747100 + READ SEEK (DISC [PREWHERE + 1]) ; 00747200 + L := LL [D := D + 1] := (L.T) & N [SF] & AT [FF] ; 00747500 + MODIFY (D) ; 00748000 + LL [AT] . T := D ; 00748500 + MODIFY (AT) ; 00748600 + AT := L.T ; 00749000 + IF AT NEQ 1 THEN 00749500 + INORDER := FALSE ; 00750000 + LL [AT] .F := D ; 00750500 + MODIFY (AT) ; 00750600 + AT := D ; 00751000 + END ; 00751500 + SEQUENCE ; 00752000 + IF PREWHERE + 1 NEQ PREWHERE := AT - 2 THEN 00752500 + WRITE (DISC [PREWHERE], 10, IMAGE [*]) 00753000 + ELSE WRITE (DISC, 10, IMAGE[*]) [EOT] ; 00753500 + N := N + INC ; 00753510 + IF FALSE THEN 00753600 + BEGIN 00753610 + EOT: 00753620 + LL [L.F] . T := AT := L.T ; 00753630 + LL [AT] . F := L.F ; 00753640 + D := D - 1 ; 00753650 + INORDER := FALSE ; 00753660 + SHOW ("FILE ", "FULL. ") ; 00753670 + ERRORX (0, "PLEASE ", "REOPEN.") ; 00753690 + NEXT: 00753700 + WDISCX := TRUE ; 00753800 + END ; 00753900 + END WDISC ; 00754000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00754500 + INTEGER PROCEDURE GETPARAMETERS (N) ; VALUE N ; INTEGER N ; 00754600 + BEGIN 00754650 + INTEGER STREAM PROCEDURE STAR (S, D, E) ; VALUE E ; 00754700 + BEGIN 00754750 + LOCAL N, 00754800 + PLUS, 00754850 + MINUS, 00754900 + CROSSHATCH, 00754950 + K ; 00755000 + LABEL DEBLANK, 00755050 + NALPHA, 00755100 + BLANK, 00755150 + NUMALPHA, 00755200 + GETREPEAT ; 00755250 + SI := S ; 00755300 + SI := SI - 1 ; 00755350 + DI := D ; 00755400 + 5 (DS := 8 LIT "+#000000") ; 00755450 + DI := D ; 00755500 + E (IF SC = "(" THEN JUMP OUT ; 00755550 + IF SC = "@" THEN JUMP OUT TO GETREPEAT ; 00755600 + IF SC = ";" THEN JUMP OUT TO GETREPEAT ; 00755650 + SI := SI + 1) ; 00755700 + 5 (TALLY := 0 ; 00755750 + K := TALLY ; 00755800 + PLUS := TALLY ; 00755850 + MINUS := TALLY ; 00755900 + CROSSHATCH := TALLY ; 00755950 + TALLY := 1 ; 00756000 + DEBLANK: 00756050 + SI := SI + 1 ; 00756100 + IF SC = " " THEN 00756150 + GO TO DEBLANK ; 00756200 + IF SC = ALPHA THEN 00756250 + TALLY := 0 00756300 + ELSE 00756350 + BEGIN 00756400 + IF SC = ";" THEN 00756450 + JUMP OUT TO GETREPEAT ; 00756500 + IF SC = """ THEN 00756550 + JUMP OUT TO GETREPEAT ; 00756600 + IF SC = "(" THEN 00756650 + JUMP OUT TO GETREPEAT ; 00756700 + IF SC = "[" THEN 00756750 + JUMP OUT TO GETREPEAT ; 00756800 + IF SC = "." THEN 00756850 + JUMP OUT TO GETREPEAT ; 00756900 + IF SC = "@" THEN 00756950 + JUMP OUT TO GETREPEAT ; 00757000 + IF SC = "/" THEN 00757050 + K := TALLY 00757100 + ELSE IF SC = "+" THEN 00757150 + PLUS := TALLY 00757200 + ELSE IF SC = "#" THEN 00757250 + CROSSHATCH := TALLY 00757300 + ELSE IF SC = "-" THEN 00757350 + MINUS := TALLY ; 00757400 + GO TO DEBLANK ; 00757450 + END ; 00757500 + IF SC GEQ "0" THEN 00757550 + BEGIN 00757600 + K (JUMP OUT TO NALPHA) ; 00757650 + K := SI ; 00757700 + 8 (IF SC LSS "0" THEN 00757750 + JUMP OUT ; 00757800 + TALLY := TALLY + 1 ; 00757850 + SI := SI + 1) ; 00757900 + N := TALLY ; 00757950 + IF TOGGLE THEN 00758000 + BEGIN 00758050 + IF SC = ALPHA THEN 00758100 + GO TO NUMALPHA ; 00758150 + BLANK: 00758200 + IF SC = " " THEN 00758250 + BEGIN 00758300 + SI := SI + 1 ; 00758350 + GO TO BLANK ; 00758400 + END ; 00758450 + IF SC = "/" THEN 00758500 + BEGIN 00758550 + NUMALPHA: 00758600 + SI := K ; 00758650 + GO TO NALPHA ; 00758700 + END ; 00758750 + END ; 00758800 + SI := K ; 00758850 + DS := N OCT ; 00758900 + END 00758950 + ELSE 00759000 + BEGIN 00759050 + NALPHA: 00759100 + DS := 1 LIT "+" ; 00759150 + 7 (IF SC = ALPHA THEN 00759200 + DS := 1 CHR 00759250 + ELSE DS := 1 LIT " ") ; 00759300 + END ; 00759350 + DI := DI - 8 ; 00759400 + SKIP 2 DB ; 00759450 + DS := PLUS SET ; 00759500 + DI := DI - 1 ; 00759550 + SKIP 3 DB ; 00759600 + DS := MINUS SET ; 00759650 + DI := DI - 1 ; 00759700 + SKIP 3 DB ; 00759750 + DS := CROSSHATCH SET ; 00759800 + DI := DI + 7 ; 00759850 + SI := SI - 1) ; 00759900 + GETREPEAT: 00759910 + E (IF SC = ")" THEN JUMP OUT ; 00759950 + IF SC = ";" THEN JUMP OUT ; 00760000 + IF SC = "@" THEN JUMP OUT ; 00760050 + SI := SI + 1) ; 00760100 + E (DI := LOC STAR ; 00760200 + DS := 8 LIT "00000001" ; 00760250 + DI := DI - 8 ; 00760300 + 10 (IF SC = ";" THEN JUMP OUT ; 00760350 + IF SC GEQ "0" THEN 00760400 + BEGIN 00760450 + TALLY := 1 ; 00760500 + 3 (SI := SI + 1 ; 00760550 + IF SC LSS "0" THEN JUMP OUT ; 00760600 + TALLY := TALLY + 1) ; 00760650 + K := TALLY ; 00760700 + SI := SI - K ; 00760750 + DS := K OCT ; 00760800 + JUMP OUT ; 00760850 + END ; 00760900 + SI := SI + 1) ; 00760950 + JUMP OUT) ; 00761000 + END STAR ; 00761050 + DEFINE XSUB = (XDEX + 1) | 13# ; 00761100 + IF N = 0 THEN 00761150 + GETPARAMETERS := STAR (IMAGE, PARAMETER0, 0) 00761200 + ELSE 00761250 + GETPARAMETERS := STAR (IMAGE, XPARAMETERS [0], 63) ; 00761300 + END GET PARAMETERS ; 00761350 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00761400 + INTEGER PROCEDURE VERB ; 00763900 + BEGIN 00764000 + BOOLEAN PROCEDURE NUMBER (N, C) ; 00764100 + INTEGER N ; 00764300 + REAL C ; 00764400 + BEGIN 00764500 + INTEGER XDEXX ; 00764510 + LABEL ZERO ; 00764520 + IF XDEX GEQ 0 THEN 00764530 + BEGIN 00764540 + XDEXX := XDEX + 1 ; 00764550 + WHILE BOOLEAN (C.[4:1]) AND XDEXX := XDEXX - 1 GEQ 0 DO 00764560 + C := XARRAY [USER, XDEXX|13 + ABS (C&0[1:44:4]-1) MOD 5] ; 00764570 + END ; 00764580 + C.[4:1] := 0 ; 00764600 + IF NUMBER := (NOT BOOLEAN (C.[1:1])) & (C = -"#000000")[46:47:1] THEN00764610 + BEGIN 00764620 + IF C . [2:2] NEQ 0 AND FILEOPEN THEN 00764700 + BEGIN 00764800 + C . [1:3] := C . [3:3] ; 00764900 + IF C = 0 THEN 00765100 + BEGIN 00765200 + C := N ; 00765300 + GO TO ZERO ; 00765400 + END ; 00765500 + IF NOT (ITSOLD (N) OR BOOLEAN (C . [1:1])) THEN 00765600 + C := C - 1 ; 00765700 + FOR N := 1 - C STEP 1 UNTIL 0 DO 00765800 + IF AT := LL [AT] . T = 1 THEN 00765900 + BEGIN 00766000 + N := 0 ; 00766100 + AT := LAST . F ; 00766200 + END ; 00766300 + FOR N := C + 1 STEP 1 UNTIL 0 DO 00766400 + IF AT := LL [AT] .F = 0 THEN 00766500 + BEGIN 00766600 + N := 0 ; 00766700 + AT := FIRST . T ; 00766800 + END ; 00766900 + C := LL [AT] . S ; 00767000 + END ELSE C.[2:2] := 0 ; 00767100 + ZERO: 00767200 + C := MIN (FINITY, MAX (1, N := C)) ; 00767300 + END ELSE 00767310 + C.[1:3] := 0 ; 00767320 + END NUMBER ; 00767400 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00767500 + INTEGER STREAM PROCEDURE INLINEEDIT (S, D, T, C, N, BIDR, INITIAL) ; 00767600 + VALUE INITIAL, 00767700 + C, 00767800 + N, 00767900 + BIDR ; 00768000 + BEGIN 00768100 + LABEL SEARCH, 00768200 + INSERT, 00768300 + DELETE, 00768400 + REPLACE, 00768500 + WRAPUP, 00768600 + LOOP, 00768700 + ERROR1, 00768710 + HERE, 00768720 + THERE, 00768730 + IDR, 00768800 + XIT ; 00768900 + BIDR (SI := S ; SI := SI + 6 ; S := SI ; 00769000 + SI := D ; SI := SI + 6 ; D := SI ; 00769100 + DI := T ; DS := 6 LIT "0" ; T := DI ; 00769200 + SI := C ; SI := SI - 48 ; C := SI) ; 00769300 + DI := LOC BIDR ; 00769400 + DS := 4 LIT " IDR" ; 00769500 + DI := T ; 00769600 + SI := T ; 00769700 + DS := 8 LIT " " ; 00769800 + DS := 9 WDS ; 00769900 + 2 (N (CI := CI + INITIAL ; 00770400 + GO TO SEARCH ; 00770500 + GO TO IDR ; 00770600 + GO TO IDR ; 00770700 + GO TO IDR ; 00770800 + GO TO WRAPUP ; 00770900 + SEARCH: 00771000 + SI := LOC C ; 00771100 + SI := SI + 6 ; 00771200 + DI := LOC N ; 00771300 + IF 2 SC = DC THEN 00771400 + GO TO ERROR1 ; 00771500 + SI := C ; 00771900 + SI := SI - 8 ; 00772000 + C := SI ; 00772100 + SI := D ; 00772200 + DI := T ; 00772300 + DS := 1 CHR ; 00772400 + D := SI ; 00772500 + T := DI ; 00772600 + SI := S ; 00772700 + DI := LOC BIDR ; 00772800 + 4 (IF SC = DC THEN 00772900 + JUMP OUT ; 00773000 + SI := SI - 1 ; 00773100 + TALLY := TALLY + 1) ; 00773200 + IF TOGGLE THEN 00773300 + ELSE 00773400 + BEGIN 00773500 + ERROR1: 00773510 + TALLY := 1 ; 00773600 + JUMP OUT 2 TO HERE ; 00773700 + END ; 00773800 + INITIAL := TALLY ; 00773900 + TALLY := 0 ; 00774000 + S := SI ; 00774100 + GO TO LOOP ; 00774200 + IDR: 00774300 + SI := LOC C ; 00774400 + SI := SI + 6 ; 00774500 + DI := LOC N ; 00774600 + IF 2 SC = DC THEN 00774700 + BEGIN 00774800 + SI := D ; 00774900 + DI := T ; 00775000 + TALLY := 4 ; 00775100 + INITIAL := TALLY ; 00775200 + WRAPUP: 00775300 + DS := 1 CHR ; 00775400 + GO TO LOOP ; 00775500 + END ; 00775600 + SI := C ; 00775700 + SI := SI - 8 ; 00775800 + C := SI ; 00775900 + SI := S ; 00776000 + CI := CI + INITIAL ; 00776100 + GO TO WRAPUP ; 00776200 + GO TO INSERT ; 00776300 + GO TO DELETE ; 00776400 + GO TO REPLACE ; 00776500 + INSERT: 00776600 + DI := T ; 00776700 + DS := 1 CHR ; 00776800 + S := SI ; 00776900 + T := DI ; 00777000 + DI := INLINEEDIT ; 00777100 + DI := DI + 8 ; 00777200 + INLINEEDIT := DI ; 00777300 + GO TO LOOP ; 00777400 + DELETE: 00777500 + DI := D ; 00777600 + DI := DI + 1 ; 00777700 + D := DI ; 00777800 + SI := SI + 1 ; 00777900 + S := SI ; 00778000 + GO TO LOOP ; 00778100 + REPLACE: 00778200 + DI := T ; 00778300 + DS := 1 CHR ; 00778400 + S := SI ; 00778500 + T := DI ; 00778600 + SI := D ; 00778700 + SI := SI + 1 ; 00778800 + D := SI ; 00778900 + LOOP: 00779000 + )) ; 00779100 + GO TO THERE ; 00779110 + HERE: 00779120 + GO TO XIT ; 00779130 + THERE: 00779140 + TALLY := 0 ; 00779200 + S := SI ; 00779300 + SI := LOC INLINEEDIT ; 00779400 + DI := LOC BIDR ; 00779500 + SI := SI + 6 ; 00779600 + DI := DI + 7 ; 00779700 + DS := 1 CHR ; 00779800 + SI := S ; 00779900 + BIDR (2 (32 (IF SC NEQ " " THEN 00780000 + BEGIN 00780100 + TALLY := 2 ; 00780200 + JUMP OUT 3 TO XIT ; 00780300 + END ; 00780400 + SI := SI + 1))) ; 00780500 + INLINEEDIT (IF SC NEQ " " THEN 00780600 + BEGIN 00780700 + TALLY := 2 ; 00780800 + JUMP OUT 1 TO XIT ; 00780900 + END ; 00781000 + SI := SI + 1) ; 00781100 + XIT: 00781200 + INLINEEDIT := TALLY ; 00781300 + END INLINE ; 00781400 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00781500 + LABEL NEXT, 00786000 + VERBEXIT ; 00786100 + DEFINE QUICK = FALSE# ; 00786110 + NEXT: 00806500 + READIN ; 00807000 + IF BOOLEAN (ABNORMALEND) OR USER = MAXUSERS THEN 00807500 + BEGIN 00808000 + VERB := RSWDM + REAL (USER = MAXUSERS) ; 00809000 + GO TO VERBEXIT ; 00809500 + END ; 00810000 + IF INLINETOG THEN 00811000 + BEGIN 00811500 + INLINETOG := FALSE ; 00811600 + IF M := INLINEEDIT (IMAGE, RECORD, ZIPPY, CHRS, 00813000 + HALFLENGTH, FILEINFO = COBOL, M) = 0 THEN 00813500 + BEGIN 00814000 + IF INLINEECHO EQV TEMPTOG THEN 00814100 + WRITEME (N, ZIPPY) ; 00814200 + IF WDISCX (ZIPPY) THEN ; 00814500 + NOSTAR := FALSE ; 00815000 + GO TO NEXT ; 00815200 + END ; 00815500 + IF M = 2 THEN 00816000 + ERROR (NEXT, 0, PARAMETER0, " OVRFLW") ; 00816100 + ERROR (NEXT, 0, "NEEDS I", ",R OR D") ; 00816500 + END ; 00817500 + IF NOSTAR THEN 00818000 + BEGIN 00818500 + IF WDISCX (IMAGE) THEN ; 00822500 + GO TO NEXT ; 00826000 + END ; 00826500 + WRITE (IO [USER], 30, IMAGE [*]) ; 00827000 + I := GETPARAMETERS (0) ; 00828000 + TEMPTOG := PARAMETER0.[2:2] = 0 ; 00828100 + IF NUMBER (N, PARAMETER0) THEN 00837000 + BEGIN 00837100 + IF FILECLOSED THEN 00837500 + ERROR (NEXT, 5, " OPEN:", OCTDEX (PARAMETER0)) ; 00838000 + IF NOT MOREINPUT AND ITSOLD (N := PARAMETER0) THEN 00838500 + WRITEAT ; 00838600 + GO TO NEXT ; 00839000 + END ; 00839500 + M := RESETN := N ; 00839700 + FOR I := 0 STEP 1 UNTIL RSWDM DO 00840000 + IF PARAMETER0 = RSWD [I] THEN 00840500 + BEGIN 00840600 + RELATIVENUMBER := PARAMETER1; 00840605 + NUM1 := NUMBER (M, PARAMETER1) ; 00840610 + NUM2 := NUMBER (M, PARAMETER2) ; 00840620 + NUM3 := NUMBER (M, PARAMETER3) ; 00840630 + NUM4 := NUMBER (M, PARAMETER4) ; 00840640 + VERB := I ; 00840700 + GO TO VERBEXIT ; 00841000 + END ; 00841010 + IF I := XFILE (PARAMETER0, MACROLIBRARY, -1) LSS 2 00841100 + AND MACROLIBRARY NEQ "MACRO " THEN 00841200 + I := XFILE (PARAMETER0, "MACRO ", -1) ; 00841220 + IF I LSS 2 OR INPUT [3] NEQ 10 THEN 00841300 + BEGIN 00841320 + SHOW (PARAMETER0, " INVALI") ; 00841360 + ERROR (NEXT, 0, "D:* ", RWTEACH) ; 00841400 + END ; 00841500 + VERBEXIT: 00844500 + END ; 00845000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00846000 + DEFINE QUICKLIST = LISTIT (1)#, 00850000 + SCAN = LISTIT(2)#, 00850100 + CHANGE = LISTIT(4)#, 00850200 + EDIT = LISTIT(8)# ; 00850300 + PROCEDURE LISTIT (LISTTYPE) ; VALUE LISTTYPE ; INTEGER LISTTYPE ; 00850400 + BEGIN 00850500 + LABEL NEXT ; 00850600 + DEFINE QUICK = BOOLEAN (LISTTYPE) AND TRUE#, 00850700 + SCANTOG = LISTTYPE = 2#, 00850800 + CHANGETOG = LISTTYPE = 4#, 00850900 + EDITTOG = LISTTYPE = 8#, 00851000 + POSTING = LISTTYPE GEQ 16# ; 00851100 + BOOLEAN PROCEDURE STRINGFOUND ; 00851110 + BEGIN 00851120 + BOOLEAN STREAM PROCEDURE PRESENT (S, R, I, SR, T, ID, K) ; 00851200 + VALUE I, 00851300 + SR, 00851400 + ID, 00851500 + K, 00851600 + T ; 00851700 + BEGIN 00851800 + LABEL XIT ; 00851900 + SI := S ; 00852000 + SI := SI + K ; 00852100 + S := SI ; 00852200 + SI := LOC SR ; 00852300 + DI := LOC K ; 00852400 + SI := SI + 6 ; 00852500 + DI := DI + 7 ; 00852600 + DS := CHR ; 00852700 + DI := R ; 00852800 + K (DI := DI + 32 ; DI := DI + 32) ; 00852900 + DI := DI + SR ; 00853000 + R := DI ; 00853100 + TALLY := 1 ; 00853200 + SI := LOC T ; 00853300 + DI := LOC K ; 00853400 + SI := SI + 6 ; 00853500 + DI := DI + 7 ; 00853600 + DS := 1 CHR ; 00853700 + DI := R ; 00853800 + K (2 (32 ( 00853900 + SI := S ; 00854000 + IF I SC = DC THEN 00854100 + BEGIN 00854200 + ID (JUMP OUT 4 TO XIT) ; 00854300 + R := DI ; 00854400 + SI := R ; 00854500 + IF SC = ALPHA THEN ELSE 00854600 + BEGIN 00854700 + SI := SI - I ; 00854800 + SI := SI - 1 ; 00854900 + IF SC = ALPHA THEN ELSE 00855000 + JUMP OUT 3 TO XIT ; 00855100 + END ; 00855200 + END ; 00855300 + DI := DI - I ; 00855400 + DI := DI + 1))) ; 00855500 + T ( 00855600 + SI := S ; 00855700 + IF I SC = DC THEN 00855800 + BEGIN 00855900 + ID (JUMP OUT 2 TO XIT) ; 00856000 + R := DI ; 00856100 + SI := R ; 00856200 + IF SC = ALPHA THEN ELSE 00856300 + BEGIN 00856400 + SI := SI - I ; 00856500 + SI := SI - 1 ; 00856600 + IF SC = ALPHA THEN ELSE 00856700 + JUMP OUT TO XIT ; 00856800 + END ; 00856900 + END ; 00857000 + DI := DI - I ; 00857100 + DI := DI + 1) ; 00857200 + TALLY := 0 ; 00857300 + XIT: 00857400 + PRESENT := TALLY ; 00857500 + END PRESENT ; 00857600 + IF PRESENT (STRING, ZIPPY, STRINGI, STRINGILEFT, STRINGIREPEAT, 00857610 + 1-STRINGID, 0) EQV TEMPTOG THEN 00857620 + STRINGFOUND := TRUE 00857630 + ELSE IF STRINGJ NEQ 0 THEN 00857640 + STRINGFOUND := 00857650 + PRESENT (STRING, ZIPPY, STRINGJ, STRINGJLEFT, STRINGJREPEAT, 00857660 + 1-STRINGJD, STRINGI) EQV TEMPTOG ; 00857670 + END STRINGFOUND ; 00857680 + DEFINE GETSTRINGS = IF ISOLATESTRINGS (LISTTYPE) THEN GO TO NEXT# ; 00857700 + BOOLEAN PROCEDURE ISOLATESTRINGS (LISTTYPE) ; 00857800 + VALUE LISTTYPE ; 00857900 + INTEGER LISTTYPE ; 00858000 + BEGIN 00858100 + STREAM PROCEDURE ISOLATE (S, D, L1, L2) ; 00858200 + BEGIN 00858300 + LOCAL STOPCHR, 00858400 + DX, 00858500 + QUOTES ; 00858600 + LABEL OK, 00858700 + NOSTRING, 00858800 + STRING, 00858900 + JUMPOUT, 00858910 + NO, 00859000 + NEXTNO ; 00859100 + TALLY := 63 ; 00859200 + STOPCHR := TALLY ; 00859300 + DI := LOC QUOTES ; 00859400 + DS := 2 LIT """ ; 00859500 + DS := 6 LIT "..()[]" ; 00859600 + 2 (SI := S ; 00859700 + 63 (SI := SI + 1 ; 00859800 + IF SC = ALPHA THEN 00859900 + ELSE IF SC NEQ " " THEN 00860000 + BEGIN 00860100 + DI := LOC QUOTES ; 00860200 + 4 (IF SC = DC THEN JUMP OUT 2 TO OK ; 00860300 + SI := SI - 1 ; 00860400 + DI := DI + 1) ; 00860500 + IF SC = ";" THEN JUMP OUT ; 00860600 + END) ; 00860700 + GO TO NOSTRING ; 00860800 + OK: 00861200 + DX := DI ; 00861300 + SI := SI - 1 ; 00861400 + IF SC = "." THEN 00861500 + BEGIN 00861600 + DI := L1 ; 00861700 + DS := LIT "+" ; 00861800 + END ; 00861900 + SI := SI + 1 ; 00862000 + TALLY := 0 ; 00862100 + STOPCHR (DI := DX ; 00862200 + IF SC = DC THEN 00862300 + JUMP OUT 1 TO STRING ; 00862400 + SI := SI - 1 ; 00862500 + DI := D ; 00862600 + DS := 1 CHR ; 00862700 + D := DI ; 00862800 + TALLY := TALLY + 1) ; 00862900 + NOSTRING: 00863000 + DI := L1 ; 00863010 + DS := 8 LIT "00000010" ; 00863020 + GO TO JUMPOUT ; 00863030 + STRING: 00863100 + DI := L1 ; 00863200 + DI := DI + 2 ; 00863300 + 2 (DX := DI ; 00863400 + 10 (IF SC GEQ "0" THEN 00863500 + BEGIN 00863600 + DI := DX ; 00863700 + DS := LIT "0" ; 00863800 + DS := CHR ; 00863900 + IF SC GEQ "0" THEN 00864000 + BEGIN 00864100 + SI := SI - 1 ; 00864200 + DI := DI - 2 ; 00864300 + DS := 2 CHR ; 00864400 + END ; 00864500 + JUMP OUT 1 TO NEXTNO ; 00864600 + END ; 00864700 + IF SC = ALPHA THEN 00864800 + ELSE IF SC NEQ " " THEN 00864900 + BEGIN 00865000 + IF SC = ";" THEN JUMP OUT 2 TO NO ; 00865100 + DI := LOC QUOTES ; 00865200 + 4 (IF SC = DC THEN 00865300 + BEGIN 00865400 + SI := SI - 1 ; 00865500 + JUMP OUT 3 TO NO ; 00865600 + END ; 00865700 + SI := SI - 1 ; 00865800 + DI := DI + 1) ; 00865900 + END ; 00866000 + SI := SI + 1) ; 00866100 + JUMP OUT TO NO ; 00866200 + NEXTNO: 00866300 + ) ; 00866400 + GO TO NO ; 00866410 + JUMPOUT: 00866420 + JUMP OUT ; 00866430 + NO: 00866500 + SI := SI - 1 ; 00866600 + S := SI ; 00866700 + DI := L1 ; 00866800 + L1 := TALLY ; 00866900 + TALLY := STOPCHR ; 00867000 + L1 (TALLY := TALLY + 63) ; 00867100 + STOPCHR := TALLY ; 00867200 + SI := LOC L1 ; 00867300 + DI := DI + 7 ; 00867400 + SI := SI + 7 ; 00867500 + DS := 1 CHR ; 00867600 + DI := L2 ; 00867700 + L1 := DI) ; 00867800 + END ISOLATE ; 00867900 + LABEL NEXT ; 00868000 + INTEGER PROCEDURE DEFINESTRING (I, LEFT, RIGHT) ; 00868010 + VALUE LEFT, RIGHT ; INTEGER I, LEFT, RIGHT ; 00868020 + BEGIN 00868030 + IF LEFT := 10|I.[12:6] + I.[18:6] = 99 THEN 00868060 + BEGIN 00868070 + LEFT := 1 ; 00868080 + RIGHT := 80 ; 00868090 + END ELSE 00868100 + IF RIGHT := 10|I.[24:6] + I.[30:6] = 99 THEN 00868110 + RIGHT := LEFT ; 00868120 + I := FULLLENGTH + 1 - STRINGI ; 00868130 + LEFT := MIN (MAX (LEFT, IF COBOLFILE THEN 6 ELSE 1), I) ; 00868140 + RIGHT := MIN (MAX (LEFT,RIGHT), I) ; 00868150 + DEFINESTRING := LEFT - 1 ; 00868160 + I := RIGHT - LEFT + 1 ; 00868170 + END DEFINESTRING ; 00868190 + IF NOT SCANTOG THEN 00868200 + BEGIN 00868300 + IF PARAMETER1 = "ECHO " THEN 00868400 + BEGIN 00868500 + IF CHANGETOG THEN 00868600 + CHANGEECHO := TOGGLE (CHANGEECHO, 2) 00868700 + ELSE 00868800 + EDITECHO := TOGGLE (EDITECHO, 2) ; 00868900 + GO TO NEXT ; 00869000 + END ; 00869100 + READONLYCHECK ; 00869200 + END ; 00869300 + IF EDITTOG THEN 00869400 + BEGIN 00869500 + IF NOT (NUM1 AND NUM2 AND NUM3) THEN 00869600 + ERROR (NEXT, 0, PARAMETER0, " ERROR.") ; 00869700 + IF NOT ITSOLD (N := PARAMETER3) THEN 00869800 + ERROR (NEXT, 0, "MISSING", " FORMAT") ; 00869900 + RDISC (AT, RECORD) ; 00870000 + IF COBOLFILE THEN 00870100 + RECORD [0].[1:35] := "@@@@@@" ; 00870200 + END ELSE 00870300 + BEGIN 00870400 + I := M := 0 & "9999" [12:24:24] ; 00870500 + ISOLATE (IMAGE, STRING, I, M) ; 00870600 + IF I NEQ 64 THEN 00870700 + BEGIN 00870800 + RELATIVENUMBER := FILEINFO ; 00870900 + IF SCANTOG THEN 00871000 + IF NOT (EMPTY1 OR (NUM1 AND (NUM2 OR EMPTY2))) THEN 00871100 + FILEINFO := DATA ; 00871200 + STRINGI := I.[41:7] ; 00871300 + STRINGID := REAL (I LSS 0) ; 00871400 + STRINGILEFT := DEFINESTRING (I, 0, 0) ; 00871500 + STRINGIREPEAT := I ; 00871600 + IF M NEQ 64 THEN 00871700 + BEGIN 00871800 + STRINGJ := M.[41:7] ; 00871900 + STRINGJD := REAL (M LSS 0) ; 00872000 + STRINGJLEFT := DEFINESTRING (M, 0, 0) ; 00872100 + STRINGJREPEAT := M ; 00872200 + END ELSE 00872300 + STRINGJ := 64 ; 00872400 + FILEINFO := RELATIVENUMBER ; 00872500 + END ; 00874100 + IF STRINGI = 0 OR (CHANGETOG AND STRINGJ = 64) THEN 00874200 + ERROR (NEXT, 0, "MISSING", " STRING") ; 00874300 + IF STRINGJ = 64 THEN 00874400 + STRINGJ := 0 ; 00874500 + END ; 00874600 + IF FALSE THEN 00874700 + NEXT: 00874800 + ISOLATESTRINGS := TRUE ; 00874900 + END ISOLATESTRINGS ; 00875000 + PROCEDURE EXTERNALFILE (LISTTYPE) ; 00875100 + VALUE LISTTYPE ; INTEGER LISTTYPE ; 00875200 + BEGIN 00875300 + FILE RO DISK SERIAL (2, INPUT [3], INPUT [4]) ; 00875400 + LABEL MORE, 00875600 + EOF, 00875700 + NEXT ; 00875800 + BOOLEAN POSTED, 00875900 + B ; 00876000 + LOCKED := TRUE ; 00876100 + RESETN := N ; 00876300 + FILL RO WITH INPUT [1], INPUT [2], *, *, *, 00876400 + 12 + REAL (POSTED := PARAMETER1 = "MAIL % ") ; 00876500 + N := 0 ; 00876600 + M := INPUT [5] + 1 ; 00876700 + B := POSTING ; 00876800 + IF NUM3 THEN 00876900 + BEGIN 00877000 + IF N := PARAMETER3 - 1 GEQ M THEN 00877100 + ERROR (NEXT, 0, "USE REC", "ORD #S.") ; 00877110 + READ SEEK (RO [N]) ; 00877120 + IF NUM4 THEN 00877200 + M := PARAMETER4 ; 00877300 + END 00877400 + ELSE IF NOT EMPTY3 THEN 00877500 + B := TRUE ; 00877600 + I := IF POSTING THEN ALGOL ELSE DATA ; 00877700 + WRITE (ZIPPY [*], STAR) ; 00877750 + MORE: 00877800 + INTERRUPT (1) ; 00877900 + IF N := N + 1 GTR M THEN 00878000 + GO TO EOF ; 00878100 + READ (RO, 10, ZIPPY [*]) [EOF] ; 00878200 + IF SCANTOG THEN 00878300 + IF NOT STRINGFOUND THEN 00878400 + GO TO MORE ; 00878500 + IF B THEN 00879100 + BEGIN 00879200 + IF POSTING AND FIRSTCHAR (ZIPPY [0]) = "*" THEN 00879300 + GO TO MORE ; 00879400 + WRITELFCR ; 00879500 + END ELSE WRITESEQ ; 00879600 + WRITEROW (ZIPPY, QUICK, I) ; 00879700 + IF POSTED THEN 00879800 + WRITE (RO, STAR) ; 00879900 + IF BREAKI = 0 THEN 00880000 + BEGIN 00880100 + GO TO MORE ; 00880200 + EOF: 00880300 + IF POSTED THEN 00880400 + BEGIN 00880500 + DETACH ; 00880600 + CLOSE (RO, PURGE) ; 00880700 + REATTACH ; 00880800 + END ; 00880900 + END ; 00880910 + NEXT: 00881000 + N := RESETN ; 00881100 + LOCKED := FALSE ; 00881200 + END EXTERNALFILE ; 00881300 + PROCEDURE SPECIAL (LISTTYPE, ECHO) ; 00881400 + VALUE LISTTYPE, ECHO ; INTEGER LISTTYPE ; BOOLEAN ECHO ; 00881500 + BEGIN 00881600 + LABEL 00881700 + REWRITE, 00881800 + OVERFLOW, 00881900 + NEXT ; 00881950 + DEFINE QUICK = FALSE# ; 00882100 + INTEGER STREAM PROCEDURE CHANGED (S,D,I,J,STRING,SS,T,T1,SR,M,N,ID) ; 00882200 + VALUE I, 00882300 + J, 00882400 + SS, 00882500 + T, 00882600 + T1, 00882700 + SR, 00882800 + ID, 00882900 + M, 00883000 + N ; 00883100 + BEGIN 00883200 + LOCAL K, 00883300 + TOTAL ; 00883400 + LABEL AROUND, 00883500 + XIT, 00883600 + NO, 00883700 + UNDERFLOW, 00883800 + HERE, 00883900 + THERE, 00883910 + EXIT ; 00883920 + DI := D ; 00884000 + DS := 8 LIT " " ; 00884100 + SI := D ; 00884200 + DS := 9 WDS ; 00884300 + SI := LOC SS ; 00884400 + DI := LOC K ; 00884500 + SI := SI + 6 ; 00884600 + DI := DI + 7 ; 00884700 + DS := CHR ; 00884800 + SI := S ; 00884900 + DI := D ; 00885000 + K (DS := 32 CHR ; DS := 32 CHR) ; 00885100 + DS := SS CHR ; 00885200 + S := SI ; 00885300 + D := DI ; 00885400 + K := TALLY ; 00885500 + 2 (T (K (DS := N CHR ; 00885600 + TALLY := K ; 00885700 + JUMP OUT TO HERE) ; 00886000 + DI := S ; 00886100 + SI := STRING ; 00886200 + IF I SC NEQ DC THEN 00886300 + BEGIN 00886400 + NO: 00886500 + SI := S ; 00886600 + DI := D ; 00886700 + DS := CHR ; 00886800 + S := SI ; 00886900 + D := DI ; 00887000 + SI := SR ; 00887100 + SI := SI - 8 ; 00887200 + SR := SI ; 00887300 + TALLY := 1 ; 00887310 + GO TO HERE ; 00887400 + END ; 00887500 + ID (SS := DI ; 00887600 + SI := SS ; 00887700 + IF SC = ALPHA THEN 00887800 + JUMP OUT TO NO ; 00887900 + SI := SI - I ; 00888000 + SI := SI - 1 ; 00888100 + IF SC = ALPHA THEN 00888200 + JUMP OUT TO NO ; 00888300 + SI := STRING ; 00888400 + SI := SI + I) ; 00888500 + TALLY := 1 ; 00888600 + CHANGED := TALLY ; 00888700 + S := DI ; 00888800 + DI := D ; 00888900 + GO TO THERE ; 00888910 + HERE: 00888920 + GO TO AROUND ; 00888930 + THERE: 00888940 + N (DI := DI + J ; 00889000 + D := DI ; 00889100 + DI := TOTAL ; 00889200 + 8 (DI := DI + J ; 00889300 + DI := DI - I) ; 00889400 + TOTAL := DI ; 00889500 + DI := SR ; 00889600 + 8 (DI := DI - J) ; 00889700 + SR := DI ; 00889800 + DI := D ; 00889900 + DI := DI - J ; 00890000 + DS := CHR ; 00890100 + TALLY := J ; 00890200 + JUMP OUT TO AROUND) ; 00890300 + DS := J CHR ; 00890400 + D := DI ; 00890500 + SI := SR ; 00890600 + 8 (SI := SI - I) ; 00890700 + SR := SI ; 00890800 + TALLY := I ; 00890900 + AROUND: 00891000 + TALLY := TALLY + 63 ; 00891100 + K := TALLY) ; 00891200 + TALLY := T1 ; 00891600 + T := TALLY) ; 00891700 + CI := CI + CHANGED ; 00891800 + GO TO EXIT ; 00891900 + M (K (DS := N CHR ; 00892000 + TALLY := K ; 00892100 + TALLY := TALLY + 63 ; 00892200 + K := TALLY ; 00892300 + JUMP OUT)) ; 00892400 + TALLY := 2 ; 00892500 + K (CHANGED := TALLY ; 00892600 + JUMP OUT TO EXIT) ; 00892700 + SI := LOC SR ; 00892800 + DI := LOC SS ; 00892900 + 6 (IF SC NEQ "0" THEN JUMP OUT TO UNDERFLOW ; SI := SI + 1) ; 00893000 + DI := DI + 7 ; 00893100 + DS := CHR ; 00893200 + SI := S ; 00893300 + DI := D ; 00893400 + SS (DS := 32 CHR ; DS := 32 CHR) ; 00893500 + DS := SR CHR ; 00893600 + S := SI ; 00893700 + GO TO UNDERFLOW ; 00893710 + EXIT: 00893720 + GO TO XIT ; 00893730 + UNDERFLOW: 00893800 + N (SI := LOC TOTAL ; 00893900 + DI := LOC K ; 00894000 + SI := SI + 6 ; 00894100 + DI := DI + 7 ; 00894200 + DS := 1 CHR ; 00894300 + SI := S ; 00894400 + K (2 (32 (IF SC NEQ " " THEN 00894500 + BEGIN 00894600 + CHANGED := TALLY ; 00894700 + JUMP OUT 4 TO XIT ; 00894800 + END ; 00894900 + SI := SI + 1))) ; 00895000 + TOTAL (IF SC NEQ " " THEN 00895100 + BEGIN 00895200 + CHANGED := TALLY ; 00895300 + JUMP OUT 2 TO XIT ; 00895400 + END ; 00895500 + SI := SI + 1)) ; 00895600 + XIT: 00895700 + END CHANGED ; 00895800 + BOOLEAN STREAM PROCEDURE EDITS (F, S, D, N) ; 00895900 + VALUE N ; 00896000 + BEGIN 00896100 + LABEL XIT ; 00896200 + DI := D ; 00896300 + DS := 8 LIT " " ; 00896400 + SI := D ; 00896500 + DS := 9 WDS ; 00896600 + DI := D ; 00896700 + D := TALLY ; 00896800 + 2 (N (SI := F ; 00896900 + IF SC = "@" THEN 00897000 + BEGIN 00897100 + SI := SI + 1 ; 00897200 + F := SI ; 00897300 + SI := S ; 00897400 + DS := CHR ; 00897500 + S := SI ; 00897600 + END 00897700 + ELSE IF SC = "#" THEN 00897800 + BEGIN 00897900 + SI := SI + 1 ; 00898000 + F := SI ; 00898100 + SI := S ; 00898200 + SI := SI + 1 ; 00898300 + S := SI ; 00898400 + END 00898500 + ELSE 00898600 + BEGIN 00898700 + DS := CHR ; 00898800 + F := SI ; 00898900 + SI := D ; 00899000 + SI := SI + 8 ; 00899100 + D := SI ; 00899200 + END)) ; 00899300 + SI := LOC D ; 00899400 + DI := LOC N ; 00899500 + SI := SI + 6 ; 00899600 + DI := DI + 7 ; 00899700 + DS := 1 CHR ; 00899800 + SI := S ; 00899900 + N ( 2 ( 32 (IF SC NEQ " " THEN 00900000 + BEGIN 00900100 + TALLY : = 1 ; 00900200 + EDITS := TALLY ; 00900300 + JUMP OUT 3 TO XIT ; 00900400 + END ; 00900500 + SI := SI + 1))) ; 00900600 + D (IF SC NEQ " " THEN 00900700 + BEGIN 00900800 + TALLY := 1 ; 00900900 + EDITS := TALLY ; 00901000 + JUMP OUT ; 00901100 + END ; 00901200 + SI := SI + 1) ; 00901300 + XIT: 00901400 + END EDITS ; 00901500 + REAL L ; 00901600 + IF CHANGETOG THEN 00901700 + BEGIN 00901710 + PARAMETER1 := STRINGIREPEAT DIV 2 ; 00901720 + PARAMETER2 := STRINGIREPEAT - PARAMETER1 ; 00901730 + PARAMETER3 := FULLLENGTH - STRINGILEFT ; 00901740 + PARAMETER4 := MIN (PARAMETER3, 63) ; 00901750 + END ; 00901760 + WHILE N := (L := LL [AT]).S LEQ M DO 00901900 + BEGIN 00902000 + RDISC (AT, ZIPPY) ; 00902100 + IF SCANTOG THEN 00902200 + BEGIN 00902300 + IF STRINGFOUND THEN 00902400 + BEGIN 00902700 + WRITEME (N, ZIPPY) ; 00902900 + N := N + 1 ; 00903000 + GO TO NEXT ; 00903100 + END ; 00903700 + END 00903800 + ELSE IF CHANGETOG THEN 00903900 + BEGIN 00904000 + IF I := CHANGED (ZIPPY, IMAGE, STRINGI, STRINGJ, 00904100 + STRING, STRINGILEFT, PARAMETER1, PARAMETER2, 00904200 + PARAMETER3, PARAMETER4, STRINGI LSS STRINGJ, 00904300 + STRINGID) = 1 THEN 00904400 + BEGIN 00904500 + RESETN := N ; 00904600 + REWRITE: 00904700 + IF ECHO THEN 00904800 + WRITEME (N, IMAGE) ; 00904900 + WDISC ; 00905000 + END ELSE 00905100 + IF I = 2 THEN 00905200 + OVERFLOW: 00905250 + ERROR (NEXT, 0, PARAMETER0, "OVRFLW") ; 00905300 + END 00905400 + ELSE 00905500 + BEGIN 00905600 + IF EDITS (RECORD, ZIPPY, IMAGE, HALFFULLLENGTH) THEN 00905700 + GO TO OVERFLOW ; 00905800 + GO TO REWRITE ; 00905900 + END ; 00906000 + INTERRUPT (1) ; 00906100 + AT := L.T ; 00906110 + END ; 00906200 + IF SCANTOG THEN 00906300 + ERRORX (0, "EOF NO ", "STRING.") ; 00906400 + NEXT: 00906500 + IF CHANGETOG THEN 00906600 + N := RESETN ; 00906700 + END SPECIAL ; 00906800 + BOOLEAN COMPLEX ; 00906900 + REAL L ; 00906910 + IF COMPLEX := SCANTOG OR CHANGETOG OR EDITTOG THEN 00907000 + GETSTRINGS ; 00907100 + IF NUM1 AND (NUM2 OR EMPTY2 OR CHANGETOG) THEN 00907200 + BEGIN 00907300 + N := PARAMETER1 ; 00907400 + IF NUM2 THEN 00907500 + M := PARAMETER2 00907600 + ELSE IF SCANTOG THEN 00907700 + M := FINITY 00907800 + ELSE M := N ; 00907900 + END 00908000 + ELSE IF NOT (EMPTY1 OR CHANGETOG) THEN 00908100 + BEGIN 00908200 + IF XFILE (12, 0, 2) LSS 2 THEN 00908300 + GO TO NEXT ; 00908400 + IF LOCKED OR NOT POSTING THEN 00908500 + WAIT ((IF NUM3 AND NUM4 THEN 00908600 + MIN (PARAMETER4, INPUT [5]) ELSE INPUT [5]) - 00908700 + (IF NUM3 THEN PARAMETER3 ELSE 0), LOCKED) ; 00908800 + EXTERNALFILE (LISTTYPE) ; 00908900 + GO TO NEXT ; 00909000 + END 00909100 + ELSE 00909200 + BEGIN 00909300 + IF NOT COMPLEX THEN 00909400 + BEGIN 00909500 + AT := 0 ; 00909600 + N := 1 ; 00909700 + END ; 00909800 + IF CHANGETOG THEN 00909900 + M := N 00910000 + ELSE 00910100 + M := FINITY ; 00910200 + END ; 00910300 + OPENCHECK ; 00910400 + IF COMPLEX THEN 00910500 + WAIT (KOUNT (N, M, CLOCK), FALSE) ; 00910600 + IF ITSOLD (N) THEN ; 00910700 + IF COMPLEX THEN 00910900 + SPECIAL (LISTTYPE, TEMPTOG EQV (IF CHANGETOG THEN CHANGEECHO 00911000 + ELSE EDITECHO)) 00911050 + ELSE 00911100 + BEGIN 00911200 + WHILE N := (L := LL [AT]).S LEQ M DO 00911300 + BEGIN 00911310 + WRITEAT ; 00911400 + INTERRUPT (1) ; 00911410 + AT := L.T ; 00911420 + END ; 00911500 + N := LL [L.F].S + INC ; 00911600 + END ; 00911700 + NEXT: 00911800 + END LISTIT ; 00911900 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00912000 + PROCEDURE EXECUTE ; 00950000 + BEGIN 00950100 + LABEL NEXT ; 00950200 + INTEGER XSUB ; 00950300 + REAL YSTART, 00950400 + YLAST, 00950500 + YFILETYPE, 00950600 + YREPEAT, 00950700 + YNCHRS ; 00950800 + BOOLEAN VERBISEXECUTE ; 00950900 + IF VERBISEXECUTE := PARAMETER0 = RSWD [0] THEN 00951000 + IF PARAMETER1 = "LIBRARY" THEN 00951100 + BEGIN 00951200 + IF EMPTY2 THEN 00951300 + ERROR (NEXT, 7, "MACRO=/", MACROLIBRARY) ; 00951400 + IF NUM2 THEN 00951500 + MACROLIBRARY := OCTDEC (PARAMETER2) 00951600 + ELSE 00951700 + MACROLIBRARY := PARAMETER2 ; 00951800 + GO TO NEXT ; 00951900 + END ELSE 00952000 + IF PARAMETER1 = "ECHO " THEN 00952100 + BEGIN 00952200 + EXECUTEECHO := TOGGLE (EXECUTEECHO, 2) ; 00952300 + GO TO NEXT ; 00952400 + END ; 00952500 + IF XDEX + 1 GEQ XMAX THEN 00952600 + ERROR (NEXT, 0, PARAMETER0, " OVRFLW") ; 00952700 + XSUB := (XDEX + 1) | 13 ; 00952800 + YFILETYPE := DATA ; 00952900 + IF NOT VERBISEXECUTE THEN 00953000 + BEGIN 00953100 + XPARAMETERS [0] := PARAMETER1 ; 00953200 + XPARAMETERS [1] := PARAMETER2 ; 00953300 + XPARAMETERS [2] := PARAMETER3 ; 00953400 + XPARAMETERS [3] := PARAMETER4 ; 00953500 + XPARAMETERS [4] := -"#000000" ; 00953600 + YREPEAT := 1 ; 00953700 + PARAMETER2 := INPUT [2] ; 00953800 + PARAMETER1 := PARAMETER0 ; 00953900 + YLAST := INPUT [5] + 1 ; 00954000 + END ELSE 00954100 + IF FILEOPEN AND (NUM1 OR EMPTY1) AND (NUM2 OR EMPTY2) THEN 00954200 + BEGIN 00954300 + IF NUM1 THEN 00954400 + BEGIN 00954500 + PARAMETER3 := PARAMETER1 ; 00954600 + IF NUM2 THEN 00954700 + PARAMETER4 := PARAMETER2 00954800 + ELSE 00954900 + PARAMETER4 := PARAMETER3 ; 00955000 + END ELSE 00955100 + BEGIN 00955200 + PARAMETER3 := 1 ; 00955300 + PARAMETER4 := INFINITY ; 00955400 + END ; 00955500 + PARAMETER1 := OCTDEC(XDEX+1+10|STATION.[14:4]+1000|STATION.[9:4]);00955600 + PARAMETER2 := "#MACRO" ; 00955700 + IF YFILETYPE := XFILE (PARAMETER1, PARAMETER2, -1) = 7 THEN 00955800 + BEGIN 00955900 + READ (LIBRARY) ; 00956000 + DETACH ; 00956100 + CLOSE (LIBRARY, PURGE) ; 00956200 + REATTACH ; 00956300 + END ELSE 00956400 + IF YFILETYPE GEQ 0 THEN 00956500 + ERROR (NEXT, 4, PARAMETER1, PARAMETER2) ; 00956600 + YLAST := KOUNT (PARAMETER3, PARAMETER4, -1) ; 00956700 + I := SAVEFACTOR ; 00956710 + FREEFILE (STATION) ; 00956800 + THERMOFAX (SAVEFACTOR := 0, (YLAST + 14) DIV 15 | 15) ; 00956900 + UNFREEFILE (STATION) ; 00957000 + SAVEFACTOR := I ; 00957010 + YFILETYPE := FILEINFO ; 00957100 + END ELSE 00957200 + BEGIN 00957300 + IF XFILE (12, 0, 2) LSS 2 THEN 00957400 + GO TO NEXT ; 00957500 + YLAST := INPUT [5] + 1 ; 00957600 + IF NUM3 THEN 00957700 + BEGIN 00957800 + IF YSTART := PARAMETER3 - 1 GTR YLAST THEN 00957900 + ERROR (NEXT, 0, "USE REC", "ORD #S.") ; 00958000 + IF NUM4 THEN 00958100 + IF PARAMETER4 LSS YLAST THEN 00958200 + YLAST := PARAMETER4 ; 00958300 + END ; 00958400 + END ; 00958500 + IF XDEX LSS 0 THEN 00958600 + XECHO := TEMPTOG EQV EXECUTEECHO ; 00958700 + IF VERBISEXECUTE THEN 00958800 + IF YREPEAT := GETPARAMETERS (63) = 0 THEN 00958900 + GO TO NEXT ; 00959000 + WAIT ((YLAST - YSTART) | YREPEAT | 3, FALSE) ; 00959100 + IF MOREINPUT THEN 00959200 + BEGIN 00959300 + READ (IO [USER + MAXUSERS], 30, IMAGE [*]) ; 00959400 + WRITE (IO [2|MAXUSERS+XMAX|USER+XDEX+1], 30, IMAGE [*]) ; 00959410 + YNCHRS := NCHRS & 1[1:47:1] ; 00959500 + MOREINPUT := FALSE ; 00959600 + END ; 00959700 + XDEX := XDEX + 1 ; 00959800 + XN := XSTART := YSTART ; 00959900 + XLAST := YLAST ; 00960000 + XFILETYPE := YFILETYPE ; 00960100 + XREPEAT := YREPEAT ; 00960200 + XNCHRS := YNCHRS ; 00960300 + XPREFIX := PARAMETER1 ; 00960400 + XSUFFIX := PARAMETER2 ; 00960500 + NEXT: 00960600 + END EXECUTE ; 00960700 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 00970000 + PROCEDURE XVERBS (K) ; VALUE K ; INTEGER K ; 00970100 + BEGIN 00970200 + DEFINE 00970300 + REPLACE = 00970400 + BEGIN 00970500 + IF NUM2 OR EMPTY2 THEN 00970600 + ERROR (NEXT, 0, PARAMETER2, " IS BAD") ; 00970700 + M := -1 ; 00970800 + FOR I := 0 STEP 1 UNTIL RSWDM DO 00970900 + IF PARAMETER0 := RSWD [I] = PARAMETER1 THEN 00971000 + M := I 00971100 + ELSE IF PARAMETER0 = PARAMETER2 THEN 00971200 + ERROR (NEXT, 0, "DUP ", PARAMETER2) ; 00971300 + IF M LSS 0 THEN 00971400 + ERROR (NEXT, 0, "NO VERB", PARAMETER1) ; 00971500 + RSWD [M] := PARAMETER2 ; 00971600 + END#, 00971700 + DELETE = 00971800 + BEGIN 00971900 + OPENCHECK ; 00972000 + IF NOT NUM1 THEN 00972100 + PARAMETER1 := N ; 00972200 + INORDER := READONLYFILE ; 00972300 + IF NOT NUM2 OR PARAMETER2 LSS PARAMETER1 THEN 00972400 + PARAMETER2 := PARAMETER1 ; 00972500 + I := LL [LOC (PARAMETER1)] . F ; 00972600 + IF ITSOLD (PARAMETER2) THEN 00972700 + AT := LL [AT] . T ; 00972800 + LL [I] . T := AT ; 00972900 + MODIFY (I) ; 00973000 + LL [AT] . F := I ; 00973100 + MODIFY (AT) ; 00973200 + N := LL [I] .S + INC ; 00973300 + END#, 00973400 + PRINTORPUNCH = 00973500 + BEGIN 00973600 + OPENCHECK ; 00973700 + IF NOT NUM3 THEN 00973800 + PARAMETER3 := 1 ; 00973900 + IF NOT NUM4 THEN 00974000 + PARAMETER4 := FINITY ; 00974100 + THERMOFAX (K, 0) ; 00974200 + END# ; 00974300 + LABEL NEXT ; 00974400 + IF BOOLEAN (K) THEN 00974500 + IF K = 1 THEN 00974600 + REPLACE 00974700 + ELSE 00974800 + DELETE 00974900 + ELSE IF K = 0 THEN 00975000 + CLOSEMYFILE 00975100 + ELSE 00975200 + PRINTORPUNCH ; 00975300 + NEXT: 00975400 + END XVERBS ; 00975500 + DEFINE CLOSEFILE = XVERBS (0)#, 00975600 + REPLACE = XVERBS (1)#, 00975700 + PRINT = XVERBS (2)#, 00975800 + DELETE = XVERBS (3)#, 00975900 + PUNCH = XVERBS (4)# ; 00976000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01023000 + PROCEDURE MAIL ; 01023500 + BEGIN 01024000 + LABEL NEXT ; 01024100 + BOOLEAN STREAM PROCEDURE POSTFROM (SENDER, MESSAGE, Z) ; 01024500 + BEGIN 01025000 + LABEL OK, 01025500 + EXIT ; 01026000 + SI := Z ; 01026500 + DI := Z ; 01027000 + DS := 8 LIT " " ; 01027500 + DS := 8 WDS ; 01028000 + SI := MESSAGE ; 01028500 + 20 (IF SC = ":" THEN 01029000 + JUMP OUT TO OK ; 01029500 + SI := SI + 1) ; 01030000 + TALLY := 1 ; 01030500 + POSTFROM := TALLY ; 01031000 + GO TO EXIT ; 01031500 + OK: 01032000 + SI := SI + 1 ; 01032500 + DI := Z ; 01033000 + 63 (IF SC = ";" THEN 01033500 + JUMP OUT ; 01034000 + DS := 1 CHR) ; 01034500 + DS := 1 LIT "-" ; 01035000 + SI := SENDER ; 01035500 + SI := SI + 1 ; 01036000 + DS := 7 CHR ; 01036500 + EXIT: 01037000 + END POSTFROM ; 01037500 + IF NUM2 THEN 01038000 + PARAMETER2 := OCTDEC (PARAMETER2) ; 01038500 + I := XFILE ("MAIL % ", IF EMPTY1 THEN USERCODE ELSE PARAMETER2, 01039000 + -1) ; 01039500 + IF EMPTY1 THEN 01040500 + BEGIN 01041000 + IF I LSS 7 THEN 01041500 + ERROR (NEXT, 0, "SORRY, ", "NO MAIL") ; 01042000 + PARAMETER1 := "MAIL % " ; 01042500 + NUM1 := FALSE ; 01043500 + PARAMETER2 := USERCODE ; 01044000 + NUM2 := FALSE ; 01045000 + NUM3 := FALSE ; 01045500 + LISTIT (17) ;%POSTING AND QUICK 01046000 + END 01047000 + ELSE 01047500 + BEGIN 01048000 + IF PARAMETER1 NEQ "TO " THEN 01048500 + ERROR (NEXT, 0, "MISSING", " TO. ") ; 01049000 + IF POSTFROM (USERCODE, IMAGE, RECORD) THEN 01049500 + ERROR (NEXT, 0, "MISSING", " COLON.") ; 01050000 + IF I LSS 0 THEN 01050500 + BEGIN 01051000 + FREEFILE (STATION) ; 01051500 + PARAMETER1 := "MAIL % " ; 01052000 + CREATEFILE (15) ; 01053000 + UNFREEFILE (STATION) ; 01053500 + END 01054000 + ELSE IF I GTR 2 THEN 01054500 + BEGIN 01055000 + WRITE (LIBRARY [INPUT [5] + 1], 10, RECORD [*]) ; 01055500 + CLOSE (LIBRARY) ; 01056000 + END ELSE 01056500 + ERRORX (1, "MAIL % ", PARAMETER2) ; 01056600 + END ; 01057500 + NEXT: 01058000 + END POSTMAN ; 01058500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01059000 + PROCEDURE COPY ; 01059500 + BEGIN 01060000 + BOOLEAN B, 01060100 + MERGE ; 01060200 + LABEL NEXT ; 01060500 + IF PARAMETER1 = "OVERITE" THEN 01060550 + BEGIN 01060600 + COPYCLOBBER := TOGGLE (COPYCLOBBER, 2) ; 01060700 + GO TO NEXT ; 01060850 + END ; 01060900 + READONLYCHECK ; 01060950 + IF XFILE (12, 0, 2) LSS 2 THEN 01061500 + GO TO NEXT ; 01062000 + IF INPUT [3] NEQ 10 OR INPUT [4] MOD 30 NEQ 0 THEN 01063500 + ERROR (NEXT, 3, PARAMETER1, PARAMETER2) ; 01064000 + IF NUM3 THEN 01064500 + BEGIN 01065000 + I := PARAMETER3 - 1 ; 01065500 + IF I GTR INPUT [5] THEN 01066000 + ERROR (NEXT, 0, "USE REC", "ORD #S.") ; 01066500 + IF NUM4 THEN 01067000 + M := MIN (PARAMETER4 - 1, INPUT [5]) 01067500 + ELSE M := I ; 01070000 + END 01070400 + ELSE 01071000 + BEGIN 01071500 + I := 0 ; 01072000 + M := INPUT [5] ; 01072500 + IF DATAFILE AND MERGE := PARAMETER3 = "MERGE " THEN 01072600 + ERROR (NEXT, 5, " TYPE: ", PARAMETER3) ; 01072700 + END ; 01073000 + WAIT (M - I, FALSE) ; 01073500 + READ SEEK (LIBRARY [I]) ; 01075000 + B := NOT (COPYCLOBBER EQV TEMPTOG) ; 01075100 + FOR I := I STEP 1 UNTIL M DO 01075500 + BEGIN 01076000 + READ (LIBRARY, 10, IMAGE [*]) ; 01076100 + IF MERGE THEN 01076200 + N := IF COBOLFILE THEN DEC (IMAGE [0], 6) 01076300 + ELSE DEC (IMAGE [9], 8) ; 01076400 + IF ITSOLD (N) AND B THEN 01076500 + ERROR (NEXT, 0, "OVERITE", " IS OFF") ; 01076600 + WDISC ; 01077000 + INTERUPT (1, 1, I + 1) ; 01078000 + END ; 01078500 + NEXT: 01079500 + CLOSE (LIBRARY) ; 01079600 + END ; 01080000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01086500 + PROCEDURE ZIPIT ; 01087000 + BEGIN 01087500 + ALPHA STREAM PROCEDURE ENDCHECK (S) ; 01087550 + BEGIN 01087600 + SI := S ; 01087650 + IF SC = "?" THEN 01087700 + BEGIN 01087710 + DI := LOC ENDCHECK ; 01087750 + DI := DI + 3 ; 01087800 + DS := CHR ; 01087810 + 63 (IF SC NEQ " " THEN JUMP OUT ; 01087850 + SI := SI + 1) ; 01087900 + 4 (IF SC = ALPHA THEN DS := 1 CHR ELSE JUMP OUT) ; 01087950 + END ; 01087960 + END ENDCHECK ; 01088000 + LABEL NEXT ; 01088050 + READONLYCHECK ; 01088100 + RDISC (FIRST . T, RECORD) ; 01089500 + IF ENDCHECK (RECORD) = 0 THEN 01090000 + ERROR (NEXT, 0, "INV FIR", "ST CARD") ; 01090500 + RDISC (LAST . F, IMAGE) ; 01092000 + IF ENDCHECK (IMAGE) NEQ "?END0" THEN 01093100 + ERROR (NEXT, 0, "NO END ", "CARD. ") ; 01093200 + WAIT (KOUNT (1, FINITY, CLOCK) | 2, XLOCKED) ; 01095500 + FILL LIBRARY WITH PREFIX, SUFFIX ; 01096000 + READ SEEK (LIBRARY [M := (AT := FIRST.T) - 2]) ; 01096500 + I := 0 ; 01096600 + WHILE AT := LL [AT] . T NEQ 1 DO 01097000 + BEGIN 01097500 + RDISC (AT, IMAGE) ; 01098000 + I := I + 1 ; 01098100 + IF ENDCHECK (IMAGE) NEQ 0 THEN 01098500 + BEGIN 01099000 + RECORD [9] := I ; 01100000 + WRITE (LIBRARY, 10, RECORD [*]) ; 01100500 + IF M + 1 NEQ M := AT - 2 THEN 01100510 + READ SEEK (LIBRARY [M]) ; 01100600 + READ (IMAGE [*], 10, RECORD [*]) ; 01101600 + END ; 01102000 + INTERUPT (1, 2, M) ; 01102500 + END ; 01103000 + IMAGE [9] := I ; 01104000 + WRITE (LIBRARY, 10, IMAGE [*]) ; 01104500 + CLOSE (LIBRARY) ; 01104600 + IF NOT EMPTY1 THEN 01105000 + BEGIN 01105500 + PARAMETER3 := 1 ; 01106100 + PARAMETER4 := FINITY ; 01106200 + THERMOFAX (8, (D + 14) DIV 15 | 15) ; 01107500 + END 01108500 + ELSE 01109000 + BEGIN 01109500 + FILEINFO := DATA ; 01109600 + CLOSEFILE ; 01110000 + ZIP WITH DISC ; 01111000 + END ; 01111500 + NEXT: 01111600 + CLOSE (LIBRARY) ; 01111700 + END ; 01112000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01113000 + DEFINE CLOSEIT = 01113500 + BEGIN 01113600 + OPENCHECK ; 01113700 + CLOSEFILE ; 01113800 + END# ; 01116500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01117000 + PROCEDURE OPEN ; 01117500 + BEGIN 01118000 + LABEL NEXT ; 01118500 + IF FILEOPEN THEN CLOSEFILE ; 01119000 + TABAMOUNT := 0 ; 01119500 + PREWHERE := -1 ; 01121000 + IF FILEINFO := FILETYPE (PARAMETER3) = 0 THEN 01122000 + ERROR (NEXT, 5, " TYPE: ", PARAMETER3) ; 01126000 + I := XFILE (12, 0, -1) ; 01126100 + FILL DISC WITH PREFIX := PARAMETER1, SUFFIX := PARAMETER2 ; 01126200 + IF PARAMETER4 = "NEW " THEN 01126500 + BEGIN 01127000 + IF I GEQ 0 THEN 01128500 + ERROR (NEXT, 4, PARAMETER1, PARAMETER2) ; 01129000 + CREATEFILE (450) ; 01130000 + FILEACCESS := 7 ; 01130500 + FIRST := D := 1 ; 01130650 + LAST := 1 & INFINITY [SF] ; 01130700 + MODIFIED := TRUE ; 01130750 + N := 0 ; 01130800 + INORDER := FALSE ; 01130850 + GO TO NEXT ; 01130900 + END ; 01131000 + IF I LEQ 0 THEN 01133500 + ERROR (NEXT, 1 - I, PARAMETER1, PARAMETER2) ; 01134000 + IF INPUT [3] NEQ 10 OR INPUT [4] MOD 30 NEQ 0 THEN 01134500 + ERROR (NEXT, 3, PARAMETER1, PARAMETER2) ; 01135000 + IF INPUT [6] NEQ 0 THEN 01135500 + ERROR (NEXT, 0, "FILE IN", " USE. ") ; 01136000 + IF D := INPUT [5] + 2 GTR MAXFILELENGTH THEN 01146000 + ERROR (NEXT, 0, "FILE TO", " LONG. ") ; 01147500 + IF PARAMETER4 = "OLD " OR DATAFILE THEN 01155000 + BEGIN 01155500 + INORDER := DATAFILE OR READONLYFILE ; 01156000 + N := 0 ; 01157500 + FOR AT := 2 STEP 1 UNTIL D DO 01157600 + LL [AT] := (AT+1) & (N:=N+INC)[SF] & (AT-1)[FF] ; 01157700 + END ELSE 01158000 + BEGIN 01158500 + WAIT (D, FALSE) ; 01158600 + M := 0 ; 01159000 + FOR AT := 2 STEP 1 UNTIL D DO 01160000 + BEGIN 01160500 + READ (LIBRARY, 10, IMAGE [*]) ; 01161000 + N := IF COBOLFILE THEN DEC (IMAGE [0], 6) 01161500 + ELSE DEC (IMAGE [9], 8) ; 01162000 + IF M GTR N THEN 01164500 + ERROR (NEXT, 0, "SEQERR ", OCTDEX (M)) ; 01166000 + LL [AT] := (AT+1) & (M:=N)[SF] & (AT-1)[FF] ; 01167500 + INTERUPT (1, 2, AT - 1) ; 01167600 + END ; 01168000 + END ; 01168100 + FILEACCESS := I ; 01168200 + MODIFIED := NOT FALSE ; 01168210 + LL [D] . T := 1 ; 01168220 + FIRST := 2 ; 01168230 + LAST := 1 & INFINITY [SF] & D [FF] ; 01168240 + LL [2] . F := 0 ; 01168250 + NEXT: 01168500 + CLOSE (LIBRARY) ; 01168600 + N := N + INC ; 01169000 + AT := 0 ; 01169100 + IF READONLYFILE THEN 01169500 + ERRORX (7, "READ ON", "LY FILE") ; 01170000 + END ; 01171000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01171500 + DEFINE INCREMENT = 01172000 + BEGIN 01172100 + IF NOT NUM1 THEN 01172500 + ERRORX (7, PARAMETER0, OCTDEX (INC)) 01173000 + ELSE INC := PARAMETER1 ; 01173500 + END# ; 01174000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01174500 + PROCEDURE RESEQ ; 01175000 + BEGIN 01175500 + REAL L ; 01175600 + LABEL NEXT ; 01176000 + OPENCHECK ; 01176100 + IF NUM2 THEN 01176500 + BEGIN 01177000 + IF NOT NUM1 THEN 01177500 + ERROR (NEXT, 0, PARAMETER1, "INVALID") ; 01178000 + IF NUM4 THEN 01178500 + INC := PARAMETER4 ; 01179000 + IF NUM3 THEN 01179500 + M := PARAMETER3 - INC 01180000 + ELSE M := PARAMETER1 - INC ; 01180500 + IF M + INC | KOUNT (PARAMETER1,PARAMETER2,-1) GEQ LL [AT].S THEN01180600 + ERROR (NEXT, 0, PARAMETER0, " ERROR.") ; 01180700 + AT := LOC (PARAMETER1) ; 01181000 + IF M + INC LEQ LL [LL [AT].F].S THEN 01181010 + ERROR (NEXT, 0, PARAMETER0, " ERROR.") ; 01181020 + N := M ; 01181500 + WHILE (L := LL [AT]).S LEQ PARAMETER2 DO 01182000 + BEGIN 01182500 + LL [AT] . S := N := N + INC ; 01183000 + MODIFY (AT) ; 01183500 + AT := L.T ; 01183600 + END ; 01184000 + END 01185500 + ELSE 01186000 + BEGIN 01186500 + IF NUM1 THEN 01187000 + INC := PARAMETER1 ; ; 01187500 + IF INC | KOUNT (1, FINITY, -1) GEQ INFINITY THEN 01187600 + ERROR (NEXT, 0, PARAMETER0, " ERROR.") ; 01187700 + N := 0 ; 01188000 + AT := 0 ; 01188500 + WHILE AT := LL [AT] . T NEQ 1 DO 01189000 + LL [AT] . S := N := N + INC ; 01189500 + MODIFIED := NOT FALSE ; 01189600 + END ; 01190000 + N := N + INC ; 01190500 + IF NOT DATAFILE THEN 01191000 + INORDER := READONLYFILE ; 01191500 + NEXT: 01192000 + END RESEQ ; 01192500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01193000 + DEFINE TAB = 01193500 + BEGIN 01193600 + IF NOT NUM1 THEN 01194000 + BEGIN 01194010 + IF NOT EMPTY1 THEN 01194100 + TABON := TOGGLE (TABON, 1) 01194300 + ELSE 01194450 + ERRORX (7, PARAMETER0, ONOFF (TABON) & 01194500 + OCTDEX (IF COBOLFILE THEN TABAMOUNT + 7 ELSE TABAMOUNT + 1) 01194600 + [36:36:12]) ; 01194700 + END ELSE 01194800 + BEGIN 01194900 + IF RELATIVENUMBER.[2:2] NEQ 0 THEN 01194910 + PARAMETER1 := TABAMOUNT + 1 + 01194920 + (RELATIVENUMBER & RELATIVENUMBER[1:3:3]) 01194930 + ELSE IF COBOLFILE THEN 01194940 + PARAMETER1 := PARAMETER1 - 6 ; 01194950 + IF TABAMOUNT := PARAMETER1 GTR 55 THEN 01195000 + TABAMOUNT := 55 ; 01195500 + IF TABAMOUNT := TABAMOUNT - 1 LSS 0 THEN 01197000 + TABAMOUNT := 0 ; 01197500 + END ; 01197600 + END#, 01198000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01198500 + SAVEIT = 01199000 + BEGIN 01199100 + IF NOT NUM1 THEN 01199500 + ERRORX (7, PARAMETER0, OCTDEX (SAVEFACTOR)) 01200000 + ELSE SAVEFACTOR := PARAMETER1 ; 01200500 + END # ; 01201000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01211500 + PROCEDURE COMPILE ; 01212000 + BEGIN 01212500 + LABEL NEXT ; 01213000 + OPENCHECK ; 01213100 + IF EMPTY2 THEN 01213500 + ERROR (NEXT, 3, PARAMETER1, PARAMETER2 ) ; 01214000 + IF DATAFILE AND EMPTY3 THEN 01216000 + ERROR (NEXT, 3, PREFIX, SUFFIX) ; 01216500 + IF NOT EMPTY3 THEN 01217000 + IF XFILE (PARAMETER3, "DISK ", 2) LSS 2 THEN 01218000 + GO TO NEXT ; 01218500 + IF PARAMETER0 := XFILE ("LINE ", USERCODE, -1) = 7 THEN 01221500 + BEGIN 01223000 + READ (LIBRARY) ; 01223500 + DETACH ; 01224000 + CLOSE (LIBRARY, PURGE) ; 01224500 + REATTACH ; 01225000 + END ELSE 01225500 + IF PARAMETER0 GEQ 0 THEN 01226000 + ERROR (NEXT, 4, "LINE ", USERCODE) ; 01226500 + IF XFILE (12, 0, -1) GEQ 0 THEN 01227000 + ERROR (NEXT, 4, PARAMETER1, PARAMETER2) ; 01228500 + CLOSEFILE ; 01229000 + IF EMPTY3 THEN 01230000 + IF COMPILER = ALGOL THEN 01230500 + PARAMETER3 := "ALGOL " 01231000 + ELSE IF COMPILER = FORTRAN THEN 01231500 + PARAMETER3 := "FORTRAN" 01232000 + ELSE IF COMPILER = XALGOL THEN 01232500 + PARAMETER3 := "XALGOL " 01233000 + ELSE IF COMPILER = BASIC THEN 01233500 + PARAMETER3 := "BASIC " 01234000 + ELSE 01234500 + PARAMETER3 := "COBOL " ; 01235000 + WRITE (ZIPPY [*], ZIPPER, PARAMETER1.[6:6], 01238000 + PARAMETER1, PARAMETER2.[6:6], PARAMETER2, PARAMETER3.[6:6], 01238500 + PARAMETER3, PREFIX.[6:6], PREFIX, SUFFIX.[6:6], SUFFIX, 01239000 + USERCODE . [6 : 6], USERCODE) ; 01239500 + ZIP WITH ZIPPY [*] ; 01240000 + NEXT: 01242000 + END COMPILE ; 01242500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01243000 + PROCEDURE DITTO ; 01243400 + BEGIN 01244000 + BOOLEAN B ; 01244100 + REAL L ; 01244200 + PROCEDURE LINK (X, Y) ; VALUE X, Y ; INTEGER X, Y ; 01244300 + BEGIN 01244310 + LL [X].T := Y ; 01244320 + MODIFY (X) ; 01244330 + LL [Y].F := X ; 01244340 + MODIFY (Y) ; 01244350 + END LINK ; 01244360 + LABEL NEXT ; 01244500 + IF PARAMETER1 = "OVERITE" THEN 01244550 + BEGIN 01244600 + DITTOCLOBBER := TOGGLE (DITTOCLOBBER, 2) ; 01244700 + GO TO NEXT ; 01244850 + END ; 01244900 + READONLYCHECK ; 01245000 + IF NOT NUM1 THEN 01246000 + ERROR (NEXT, 0, PARAMETER0, " ERROR.") ; 01246500 + IF PARAMETER2 = "MOVE " OR PARAMETER3 = "MOVE " THEN 01246510 + BEGIN 01246520 + IF NOT NUM2 THEN 01246530 + PARAMETER2 := PARAMETER1 ; 01246540 + B := ITSOLD (N) ; 01246550 + PARAMETER4 := LL [PARAMETER3 := AT] ; 01246560 + M := LL [I := LOC (PARAMETER1)].F ; 01246570 + IF PARAMETER0 := KOUNT (PARAMETER1,PARAMETER2,-1) - 1 LSS 0 THEN01246580 + GO TO NEXT ; 01246590 + IF ITSOLD (PARAMETER2) THEN 01246600 + L := LL [AT].T 01246610 + ELSE 01246620 + AT := LL [L := AT].F ; 01246630 + IF (B AND B := LL [M].S GEQ N OR N GEQ LL [L].S) OR 01246640 + N+INC|PARAMETER0 GEQ (IF B THEN PARAMETER4 ELSE LL [L]).S THEN01246650 + ERROR (NEXT, 0, "NO ROOM", ": MOVE ") ; 01246660 + IF B THEN 01246670 + BEGIN 01246680 + LINK (M, L) ; 01246690 + LINK (AT, PARAMETER3) ; 01246700 + LINK (PARAMETER4.F, I) ; 01246710 + END ELSE 01246720 + PARAMETER3 := L ; 01246730 + DO BEGIN 01246740 + LL [I].S := N ; 01246750 + N := N + INC ; 01246760 + MODIFY (I) ; 01246770 + END UNTIL I := LL [I].T = PARAMETER3 ; 01246780 + INORDER := FALSE ; 01246790 + GO TO NEXT ; 01246800 + END ; 01246810 + CLOSE (DISC) ; 01247000 + PREWHERE := PARAMETER3 := -1 ; 01247100 + IF NUM2 THEN 01247500 + WAIT (KOUNT (PARAMETER1, PARAMETER2, CLOCK), FALSE) 01248500 + ELSE PARAMETER2 := PARAMETER1 ; 01250000 + FILL LIBRARY WITH PREFIX, SUFFIX ; 01250500 + I := LOC (PARAMETER1) ; 01251600 + M := D ; 01252000 + B := NOT (DITTOCLOBBER EQV TEMPTOG) ; 01252100 + WHILE (L := LL [I]).S LEQ PARAMETER2 AND I LEQ M DO 01252500 + BEGIN 01253500 + IF PARAMETER3 + 1 NEQ PARAMETER3 := I THEN 01254000 + READ SEEK (LIBRARY [I - 2]) ; 01254500 + IF ITSOLD (N) AND B THEN 01255000 + ERROR (NEXT, 0, "OVERITE", " IS OFF") ; 01255500 + I := L.T ; 01256000 + READ (LIBRARY, 10, IMAGE [*]) ; 01256500 + WDISC ; 01257000 + INTERUPT (1, 2, I - 2) ; 01257500 + END ; 01258000 + NEXT: 01259500 + CLOSE (LIBRARY) ; 01260000 + END DITTO ; 01261000 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01261500 + PROCEDURE REMOVE ; 01262000 + BEGIN 01262500 + LABEL NEXT ; 01263000 + IF EMPTY2 AND PARAMETER1 = "LISTING" THEN 01263100 + BEGIN 01263200 + PARAMETER1 := "LINE " ; 01263300 + PARAMETER2 := USERCODE ; 01263400 + END ; 01263500 + IF XFILE (12, 0, 4) LSS 4 THEN 01263600 + GO TO NEXT ; 01263700 + IF PARAMETER1 = PREFIX THEN 01264000 + IF PARAMETER2 = SUFFIX AND READWRITEFILE THEN 01264500 + BEGIN 01265000 + READ (DISC [0]) ; 01265500 + DETACH ; 01266000 + CLOSE (DISC, PURGE) ; 01266500 + REATTACH ; 01267500 + FILEACCESS := 0 ; 01268000 + INORDER := TRUE ; 01268500 + GO TO NEXT ; 01269000 + END ; 01269500 + IF INPUT [6] NEQ 0 THEN 01273000 + ERROR (NEXT, 0, "FILE IN", " USE. ") ; 01273500 + READ (LIBRARY) ; 01274000 + DETACH ; 01274500 + CLOSE (LIBRARY, PURGE) ; 01275000 + REATTACH ; 01275500 + NEXT: 01276000 + END REMOVE ; 01276500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01277000 + PROCEDURE LISTING ; 01277200 + BEGIN 01277400 + BOOLEAN LOCKED ; 01277500 + INTEGER P5 ; 01277510 + LABEL NEXT ; 01277600 + FILE LINE 15 (2, 15) ; 01277800 + FILE FEEDBACK DISK SERIAL (2, 15, 30) ; 01278000 + REAL STREAM PROCEDURE READZ (Z, SKP, A, N) ; 01278200 + VALUE SKP, A, N ; 01278210 + BEGIN 01278220 + LABEL EXIT ; 01278230 + SI := Z ; 01278240 + SI := SI + SKP ; 01278250 + DI := LOC READZ ; 01278260 + A (DI := DI + 8 ; DI := DI - N ; DS := N CHR ; JUMP OUT TO EXIT) ; 01278270 + DS := N OCT ; 01278280 + EXIT: 01278290 + END READZ ; 01278300 + IF XFILE ("LINE ", USERCODE, 1) LSS 1 THEN 01278400 + GO TO NEXT ; 01278600 + IF NOT EMPTY1 THEN 01279200 + IF I := FILETYPE (PARAMETER1) = 0 OR I = DATA THEN 01279400 + ERROR (NEXT, 5, "TYPE: ", PARAMETER1) ; 01281600 + WAIT (INPUT [5], YLOCKED) ; 01281800 + YLOCKED := LOCKED := TRUE ; 01282000 + FILL FEEDBACK WITH "LINE ", USERCODE ; 01282200 + IF NUM2 AND NUM3 AND NUM4 THEN 01282400 + BEGIN 01282600 + PARAMETER1 := 1 ; 01282800 + WRITESEGMENT ; 01283200 + PARAMETER0 := IF I=FORTRAN THEN 10 ELSE REAL(I GEQ ALGOL)+12 ; 01283300 + P5 := IF I GEQ ALGOL THEN PARAMETER0 - 1 ELSE 0 ; 01283310 + END 01283600 + ELSE IF PARAMETER2.[6:30] = "ERROR" OR PARAMETER2 01283800 + = "SYNTAX " THEN 01284000 + BEGIN 01284100 + PARAMETER1 := 2 ; 01284200 + P5 := IF I=FORTRAN THEN 9 ELSE 12 ; 01284300 + END 01284310 + ELSE IF EMPTY2 THEN 01284400 + BEGIN 01284600 + FILL LINE WITH "LINE ", USERCODE ; 01284800 + DETACH ; 01285000 + WRITE (LINE) ; 01285200 + REATTACH ; 01285400 + PARAMETER1 := 3 ; 01285600 + END 01285800 + ELSE 01286000 + ERROR (NEXT, 0, PARAMETER0, " ERROR.") ; 01286200 + DO BEGIN 01286400 + READ (FEEDBACK, 15, ZIPPY [*]) [NEXT] ; 01287000 + IF PARAMETER1 = 1 THEN 01287200 + BEGIN 01287400 + IF I = FORTRAN THEN 01287600 + BEGIN 01287800 + IF N := READZ (ZIPPY [11], 4, 1, 4) NEQ "LONG" THEN 01288000 + IF N := READZ (ZIPPY [11], 3, 0, 4) NEQ 0 THEN 01288200 + M := N ; 01288400 + END 01288800 + ELSE IF I GEQ ALGOL THEN 01289000 + BEGIN 01289200 + IF N := READZ (ZIPPY [14], 4, 0, 4) NEQ 0 THEN 01289400 + M := N ; 01289600 + END 01289800 + ELSE M := READZ (ZIPPY [12], N := 0, 0, 4) ; 01293000 + IF M = PARAMETER2 AND N = 0 THEN 01293200 + BEGIN 01293400 + N := READZ (ZIPPY [PARAMETER0], REAL (I=COBOL) + 4, 0, 4) ; 01293600 + IF N GTR PARAMETER4 THEN 01294600 + GO TO NEXT ; 01294800 + IF PARAMETER3 LEQ N THEN 01295000 + BEGIN 01295200 + PARAMETER3 := N ; 01295400 + N := READZ (ZIPPY [P5], IF I=COBOL THEN 3 ELSE 0, 0, 8) ; 01295600 + WRITESEQ ; 01296600 + WRITERELADDR ; 01297000 + END ; 01297200 + END ; 01297400 + END 01297600 + ELSE IF PARAMETER1 = 2 THEN 01297800 + BEGIN 01298000 + IF I = COBOL THEN 01298200 + BEGIN 01298400 + M := READZ (ZIPPY [0], 0, 1, 1) ; 01298600 + IF M = " " OR M = "[" THEN 01298800 + M := READZ (ZIPPY [0], 5, 0, 6) 01299000 + ELSE M := 0 ; 01299200 + END 01299400 + ELSE M := READZ (ZIPPY [P5], 0, 0, 8) ; 01300000 + IF M = 0 AND N GTR 0 THEN 01300200 + BEGIN 01301200 + WRITESEQ ; 01301600 + WRITEROW (ZIPPY, TRUE, DATA) ; 01301800 + END ELSE N := M ; 01302000 + END 01302200 + ELSE 01302400 + WRITE (LINE [DBL], 15, ZIPPY [*]) ; 01302600 + INTERRUPT (1) ; 01302800 + END UNTIL BOOLEAN (BREAKI) ; 01303000 + NEXT: 01303200 + N := RESETN ; 01303400 + IF LOCKED THEN 01303500 + YLOCKED := FALSE ; 01303600 + END LISTING ; 01303800 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01345000 + PROCEDURE INLINE ; 01345500 + BEGIN 01345550 + LABEL NEXT ; 01345560 + DEFINE QUICK = FALSE# ; 01345570 + IF PARAMETER1 = "ECHO " THEN 01345600 + BEGIN 01345610 + INLINEECHO := TOGGLE (INLINEECHO, 2) ; 01345620 + GO TO NEXT ; 01345660 + END ; 01345670 + READONLYCHECK ; 01345700 + IF NUM1 THEN 01346000 + BEGIN 01346500 + N := PARAMETER1 ; 01347000 + IF NOT ITSOLD (N) THEN 01347500 + ERROR (NEXT, 0, "MISSING", OCTDEX (N)) ; 01348000 + IF NOT MOREINPUT THEN 01348500 + WRITEAT ; 01349000 + I := PARAMETER2.[6:6] ; 01349500 + END 01350000 + ELSE 01350500 + BEGIN 01351000 + AT := LL [LOC (N)].F ; 01351500 + N := LL [AT].S ; 01352500 + I := PARAMETER1.[6:6] ; 01353000 + END ; 01353500 + IF NOT NUM1 OR MOREINPUT THEN 01353600 + RDISC (AT, RECORD) ; 01354000 + INLINETOG := TRUE ; 01354500 + IF I = "I" THEN 01356000 + M := 1 01356500 + ELSE IF I = "D" THEN 01357000 + M := 2 01357500 + ELSE IF I = "R" THEN 01358000 + M := 3 01358500 + ELSE M := 0 ; 01359000 + NEXT: 01359500 + END INLINE; 01359600 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01360000 + PROCEDURE COLUMN ; 01360100 + BEGIN 01360150 + INTEGER STREAM PROCEDURE GETCHAR (S) ; 01360200 + BEGIN 01360250 + LABEL NOPE, YES, XIT ; 01360300 + DI := LOC GETCHAR ; 01360350 + SI := S ; 01360400 + 2(40(IF SC = ALPHA THEN ELSE IF SC = " " THEN ELSE 01360450 + IF SC = """ THEN 01360500 + JUMP OUT 2 TO YES 01360550 + ELSE IF SC = "." THEN 01360600 + JUMP OUT 2 TO YES 01360650 + ELSE IF SC = "(" THEN 01360700 + JUMP OUT 2 TO YES 01360750 + ELSE IF SC = "[" THEN 01360800 + JUMP OUT 2 TO YES 01360850 + ELSE IF SC = ";" THEN 01360900 + JUMP OUT 2 TO NOPE ; 01360950 + SI := SI + 1)) ; 01361000 + NOPE: 01361050 + DS := 8 LIT "+0000001" ; 01361100 + GO TO XIT ; 01361150 + YES: 01361200 + SI := SI + 1 ; 01361250 + DI := DI + 7 ; 01361300 + DS := CHR ; 01361350 + XIT: 01361400 + END GETCHAR ; 01361450 + IF I := GETCHAR (IMAGE) GEQ 0 THEN 01361500 + CHARACTER := I ; 01361550 + IF NUM1 THEN 01361600 + BEGIN 01361650 + COLSTOP1 := MIN (PARAMETER1, 80) ; 01361700 + IF NUM2 THEN 01361900 + BEGIN 01361950 + COLSTOP2 := MIN (MAX (PARAMETER2, COLSTOP1), 80) ; 01362000 + IF NUM3 THEN 01362050 + BEGIN 01362100 + COLSTOP3 := MIN (MAX (PARAMETER3, COLSTOP2), 80) ; 01362150 + IF NUM4 THEN 01362200 + BEGIN 01362250 + COLSTOP4 := MIN (MAX (PARAMETER4, COLSTOP3), 80) ; 01362300 + COLSTOPS := 4 ; 01362350 + END ELSE 01362400 + COLSTOPS := 3 ; 01362450 + END ELSE 01362500 + COLSTOPS := 2 ; 01362550 + END ELSE 01362600 + COLSTOPS := 1 ; 01362650 + MAXCOLSTOP := COLSTOP [COLSTOPS] ; 01362675 + END ELSE 01362700 + IF EMPTY1 THEN 01362750 + BEGIN 01363100 + SHOW (PARAMETER0, ONOFF (COLUMNS) & (CHARACTER)[42:42:6]) ; 01363200 + IF COLSTOPS LSS 1 THEN 01363210 + PARAMETER1 := 0 & "#"[6:42:6] 01363220 + ELSE PARAMETER1 := OCTDEX (COLSTOP1) ; 01363230 + IF COLSTOPS LSS 2 THEN 01363240 + PARAMETER2 := 0 & "#"[6:42:6] 01363250 + ELSE PARAMETER2 := OCTDEX (COLSTOP2) ; 01363260 + SHOW (PARAMETER1, PARAMETER2) ; 01363270 + IF COLSTOPS LSS 3 THEN 01363280 + PARAMETER3 := 0 & "#"[6:42:6] 01363290 + ELSE PARAMETER3 := OCTDEX (COLSTOP3) ; 01363300 + IF COLSTOPS LSS 4 THEN 01363310 + PARAMETER4 := 0 & "#"[6:42:6] 01363320 + ELSE PARAMETER4 := OCTDEX (COLSTOP4) ; 01363330 + ERRORX (7, PARAMETER3, PARAMETER4) ; 01363410 + END ELSE 01363420 + COLUMNS := TOGGLE (COLUMNS, 1) ; 01363430 + END COLUMN ; 01363500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01365000 + PROCEDURE TEACH ; 01365500 + BEGIN 01366000 + LABEL NEXT ; 01366500 + IF NOT EMPTY1 THEN 01367000 + BEGIN 01367500 + M := -1 ; 01368000 + FOR I := 0 STEP 1 UNTIL RSWDM DO 01368500 + IF PARAMETER1 = RSWD [I] THEN 01369000 + BEGIN 01369500 + M := I ; 01370000 + I := RSWDM ; 01370500 + END ; 01371000 + IF M LSS 0 THEN 01371500 + BEGIN 01371600 + IF I := XFILE (PARAMETER1, PARAMETER2:=MACROLIBRARY, -1) LSS 201371700 + AND MACROLIBRARY NEQ "MACRO " THEN 01371800 + I := XFILE (PARAMETER1, PARAMETER2:="MACRO ", -1) ; 01371830 + IF I LSS 2 THEN 01371900 + BEGIN 01372000 + SHOW (PARAMETER1, " INVALI") ; 01372020 + ERROR (NEXT, 0, "D: * ", RWTEACH) ; 01372040 + END ; 01372050 + NUM2 := FALSE ; 01372100 + NUM3 := BOOLEAN (2) ; 01372200 + LISTIT (0) ; 01372300 + GO TO NEXT ; 01372400 + END ; 01372450 + PARAMETER1 := "TEACHER" ; 01372500 + PARAMETER2 := OCTDEC (VERSION) ; 01373000 + IF XFILE (PARAMETER1, PARAMETER2, 2) LSS 2 THEN 01373500 + GO TO NEXT ; 01374000 + READ (LIBRARY [M], 1, IMAGE [*]) ; 01375000 + N := DEC (IMAGE [0], 8) ; 01376000 + CLOSE (LIBRARY) ; 01376500 + PARAMETER3 := N DIV 10000 ; 01377000 + NUM3 := TRUE ; 01377500 + PARAMETER4 := N MOD 10000 ; 01378000 + NUM4 := TRUE ; 01378500 + N := RESETN ; 01379000 + LISTIT (17) ;%POSTING AND QUICK 01379500 + END ELSE 01380500 + BEGIN 01380600 + WRITE (PRETANK [*], TEACH1) ; 01381500 + WRITETWX ; 01382000 + FOR I := 0 STEP 7 UNTIL RSWDM DO 01382500 + BEGIN 01383000 + WRITE (IMAGE [*], TEACH2, FOR M := 0 STEP 1 UNTIL 6 DO 01383500 + [(PARAMETER0 := RSWD [I + M]).[6:6], PARAMETER0]) ; 01384000 + WRITEROW (IMAGE, FALSE, COBOL) ; 01384500 + END ; 01386500 + WRITE (IMAGE [*], TEACH3) ; 01387000 + WRITEROW (IMAGE, FALSE, COBOL) ; 01387500 + END ; 01390500 + NEXT: 01390600 + END TEACH ; 01390700 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01391500 + DEFINE PERCENT = 01392000 + BEGIN 01392500 + TRANSLATING := BOOLEAN (I := REAL (TOGGLE (TRANSLATING, 1))) ; 01393000 + TRANSLATEI := I ; 01393500 + END# ; 01394500 + % * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 01402000 + PROCEDURE STOP ; 01402500 + BEGIN 01403000 + DEFINE DIRCTRY = CONTROLS# ; 01403100 + LABEL NEXT ; 01403500 + IF BOOLEAN (ABNORMALEND) THEN 01403600 + BEGIN 01403610 + EMPTY1 := ABNORMALEND = 3 ; 01403620 + ABNORMALEND := BREAKI := 0 ; 01403630 + IF BOOLEAN (INREADYQ) THEN 01403650 + BEGIN 01403690 + FOR I := 1 STEP 1 WHILE READYQ [I] NEQ USER DO ; 01403700 + FOR I := I + 1 STEP 1 UNTIL READYQTOP DO 01403750 + READYQ [I - 1] := READYQ [I] ; 01403755 + READYQTOP := READYQTOP - 1 ; 01403800 + INREADYQ := 0 ; 01403810 + END ; 01403825 + END ELSE 01403850 + BEGIN 01403875 + IF FILEOPEN AND PARAMETER1 NEQ "DS " THEN 01403900 + CLOSEFILE ; 01404500 + WRITE (PRETANK [*], EOJ) ; 01407000 + WRITETWX ; 01407500 + IF NOT EMPTY1 THEN 01407600 + SAVESTATE ; 01407700 + IF COUNTI GEQ 0 THEN 01407710 + BEGIN 01407720 + ABNORMALEND := IF EMPTY1 THEN 2 ELSE 4 ; 01407730 + STATION := 0 ; 01407740 + GO TO NEXT ; 01407750 + END ; 01407760 + END ; 01407800 + FORGET (STATIONI) ; 01407900 + I := 2 | SLOTI ; 01408000 + READ (R1 [45], 90, DIRCTRY [*]) ; 01408100 + IF EMPTY1 THEN 01408500 + DIRCTRY [I] := 0 01408600 + ELSE 01408700 + DIRCTRY [I].[1:1] := 0 ; 01408800 + DIRCTRY [I + 1] := 0 ; 01409000 + WRITE (R1 [45], 90, DIRCTRY [*]) ; 01409500 + STATION := 0 ; 01410500 + IF USER NEQ BIGBIRD THEN 01415100 + BEGIN 01415110 + WRITE (BUFFERS [USER, *], 45, BUFFERS [BIGBIRD, *]) ; 01415130 + IF BOOLEAN (INREADYQ) THEN 01415140 + FOR I := 0 STEP 1 UNTIL READYQTOP DO 01415150 + IF READYQ [I] = BIGBIRD THEN 01415160 + READYQ [I] := USER ; 01415170 + READ (R1 [IF INREADYQ=3 THEN 46 ELSE SLOTI], 90, CONTROLS [*]) ;01415180 + FILEACCESS := CONTROLS [51] ; 01415190 + IF FILEOPEN THEN 01415200 + BEGIN 01415210 + N := BIGBIRD | 32 ; 01415215 + M := CONTROLS [57].LEFTSIDE ; 01415220 + FOR I := 0 STEP 1 UNTIL M DO 01415230 + WRITE (LINKLISTS [USER32 + I, *], 256, 01415240 + LINKLISTS [N + I, *]) ; 01415250 + END ; 01415260 + IF XDEX := CONTROLS [62] GEQ 0 THEN 01415265 + BEGIN 01415270 + WRITE (XARRAY [USER, *], XMAX | 13, XARRAY [BIGBIRD, *]) ; 01415275 + FOR XDEX := XDEX STEP -1 UNTIL 0 DO 01415280 + IF BOOLEAN (XNCHRS).[1:1] THEN 01415285 + BEGIN 01415290 + READ (IO [2|MAXUSERS+XMAX|BIGBIRD+XDEX], 30, IMAGE [*]) ;01415295 + WRITE (IO [2|MAXUSERS+XMAX|USER+XDEX], 30, IMAGE [*]) ; 01415300 + END ; 01415305 + END ; 01415310 + END ; 01415315 + BIGBIRD := BIGBIRD - 1 ; 01415500 + NEXT: 01416500 + END ; 01417000 + PROCEDURE PROGRAM ; 01417100 + BEGIN 01417110 + LABEL NEXT, EXIT ; 01417120 + NEXT: 01417150 + CASE VERB OF 01417160 + BEGIN 01417170 + EXECUTE ; 01417175 + DITTO ; 01417180 + COPY ; 01417190 + INLINE ; 01417200 + ZIPIT ; 01417210 + CHANGE ; 01417220 + EDIT ; 01417230 + SAVEIT ; 01417240 + RESEQ ; 01417250 + PUNCH ; 01417260 + PRINT ; 01417270 + DELETE ; 01417280 + CLOSEIT ; 01417300 + COMPILE ; 01417310 + COLUMN ; 01417320 + SCAN ; 01417330 + LISTING ; 01417340 + INCREMENT ; 01417350 + TAB ; 01417360 + PERCENT ; 01417370 + QUICKLIST ; 01417380 + LISTIT (0) ; 01417390 + OPEN ; 01417400 + MAIL ; 01417410 + TEACH ; 01417420 + REMOVE ; 01417430 + REPLACE ; 01417440 + STOP ; 01417450 + GO TO EXIT ; 01417460 + END ; 01417470 + IF BIGBIRD GEQ 0 THEN 01417480 + GO TO NEXT ; 01417490 + EXIT: 01417500 + END PROGRAM ; 01418000 + BOOLEAN PROCEDURE RC (START) ; 01418100 + VALUE START ; 01418200 + BOOLEAN START ; 01418300 + BEGIN 01418500 + SAVE FILE OUT RONE DISK SERIAL [1:47] "R/C" "#1" (1, 90, SAVE 99) ; 01418600 + SAVE FILE OUT RTWO DISK SERIAL [15:96] "R/C" "#2" (1, 256, SAVE 99) ; 01418700 + ARRAY DIRCTRY, NEWDIRCTRY [0:90], 01418800 + LINKLIST [0:255] ; 01418900 + LABEL ENDOFPROGRAM ; 01419000 + CHARGE (0) ; 01419100 + FREEFILE (0) ; 01419150 + IF START THEN 01419200 + BEGIN 01419300 + SEARCH (RONE, IMAGE [*]) ; 01419500 + IF IMAGE [6] GTR 0 THEN 01420000 + BEGIN 01420100 + I := STATUS (IMAGE [*]) ; 01420200 + WRITE (TWXOUTPUT (IMAGE [0]), USERUN) ; 01420300 + GO TO ENDOFPROGRAM ; 01420500 + END ; 01420600 + IF IMAGE [0] GEQ 0 THEN 01421000 + BEGIN 01421500 + READ (R1 [45], 90, DIRCTRY [*]) ; 01422000 + DIRCTRY [90] := 12 ; 01422500 + FOR I := 0 STEP 2 WHILE USERCODE := DIRCTRY [I] NEQ 12 DO 01423000 + DIRCTRY [I] := ABS (USERCODE) ; 01423500 + WRITE (R1 [45], 90, DIRCTRY [*]) ; 01424000 + END ELSE 01424500 + BEGIN 01425000 + DIRCTRY [0] := 12 ; 01425500 + WRITE (RONE [45], 90, DIRCTRY [*]) ; 01426000 + END ; 01426500 + SEARCH (RTWO, IMAGE [*]) ; 01432500 + IF IMAGE [0] LSS 0 THEN 01433000 + WRITE (RTWO[0], 1, IMAGE [*]) ; 01433500 + END ELSE 01436500 + BEGIN 01436600 + READ (R1 [45], 90, DIRCTRY [*]) ; 01437300 + USER := -2 ; 01437500 + FOR N := 0 STEP 1 UNTIL 1 DO 01437600 + FOR I := 0 STEP 2 WHILE USERCODE := DIRCTRY [I] NEQ 12 DO 01438000 + IF USERCODE NEQ 0 THEN 01439000 + BEGIN 01439500 + READ (R1 [I/2], 90, CONTROLS [*]) ; 01440000 + FILEACCESS := CONTROLS [51] ; 01440100 + IF FILEOPEN OR BOOLEAN (N) THEN 01440500 + BEGIN 01441000 + NEWDIRCTRY [USER := USER + 2] := USERCODE ; 01441500 + WRITE (RONE, 90, CONTROLS [*]) ; 01442500 + IF FILEOPEN THEN 01442600 + BEGIN 01442700 + READ SEEK (R2 [16 | I]) ; 01443000 + NEWDIRCTRY [USER + 1] := DIRCTRY [I + 1] ; 01443100 + M := CONTROLS [57].LEFTSIDE ; 01444100 + FOR D := 0 STEP 1 UNTIL M DO 01444500 + BEGIN 01445000 + READ (R2, 256, LINKLIST [*]) ; 01445500 + WRITE (RTWO, 256, LINKLIST [*]) ; 01446000 + END ; 01446500 + IF M NEQ 31 THEN 01446600 + WRITE (RTWO [16 | USER + 31], 1, CONTROLS [*]) ; 01446700 + DIRCTRY [I] := 0 ; 01447000 + END ; 01447100 + END ; 01447500 + END ; 01448000 + NEWDIRCTRY [USER + 2] := 12 ; 01455000 + IF USER GEQ 0 THEN 01455500 + WRITE (RONE [45], 90, NEWDIRCTRY [*]) ; 01456000 + CLOSE (R1, PURGE) ; 01456500 + READ (R2 [0]) ; 01456600 + CLOSE (R2, PURGE) ; 01457000 + ENDOFPROGRAM: 01458100 + RC := TRUE ; 01458200 + END ; 01458300 + END RC ; 01458500 + CONTROLS [90] := 12 ; 01458900 + IF NOT RC (TRUE) THEN 01459000 + BEGIN 01459100 + BIGBIRD := -1 ; 01459110 + T0 := 150 ; 01459120 + FREEHEAD := MAXFREEHEAD := (XMAX + 2) | MAXUSERS ; 01459130 + PROGRAM ; 01459200 + BOOL := RC (FALSE) ; 01459300 + IF XFILE ("TEACHER", OCTDEC (VERSION), -1) GTR 0 THEN 01459310 + READ (LIBRARY) ; 01459320 + END ; 01459400 +END. 01459500 +?END 99999990