! Dated 22 May 85 const integer yes=1, no=0 const integer np=x'0C' {nepwage code} const string (1) snl=" " const integer invi=x'80308030' external routine spec read profile(string (11) key, name info, integer name version, uflag) external routine spec write profile(string (11) key, name info, integer name version, uflag) external routine spec terminate external routine spec discard(string (255) s) external routine spec restore(string (255) s) external routine spec destroy(string (255) s) external routine spec files(string (255) s) external integer fn spec return code external integer fn spec outpos system string fn spec unpackdate(integer i) system string fn spec unpacktime(integer i) record format rf(string (11) mem, integer type) ! This routine returns records in the parameter array R of format ! (RF) defined above, ! for each member in pdfile PD. N should be set before the call to the ! top entry no of the recordarray (i.e. the declaration sould be (0:N) ). ! And on return N is set to the no of records returned. ! Result zero if not OK, e.g. file not exist etc. ! non-zero if OK external string fn spec fromstr(string (255) s, integer i, j) external integer fn spec uinfi(integer i) external routine spec list(string (255) s) system routine spec get journal(string name file, integer name flag) external routine spec tim(string (255) s) system string fn spec itos(integer i) routine spec pdrep(string (255) s) external integer fn spec nwfilead(string (15) s, integer pgs) external integer fn spec bin(string (255) s) external routine spec prompt(string (15) s) external routine spec ucstrg(string name s) external routine spec rstrg(string name s) external routine spec nrstrg(string name s) external string fn spec ucstring(string (255) s) external routine spec define(string (63) s) external routine spec clear(string (63) s) external routine spec hazard(string (255) s) external integer fn spec exist(string (63) s) external integer fn spec wrfilead(string (63) s) external integer fn spec rdfilead(string (255) s) external integer fn spec tpfilead(string (255) s, integer pgs) record format srcf(integer nextfreebyte, txtrelst, maxlen, filetype) const string (3) array month(1:12)= c "JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG", "SEP","OCT","NOV","DEC" external routine spec rename(string (255) s) external routine spec copy(string (255) s) external string fn spec separate(string name s) extrinsic integer next dynamic routine spec ibmrecode(integer from, to, printad) system routine spec uctranslate(integer adr, len) external integer fn spec val(integer adr, len, rw, psr) system string fn spec htos(integer i, pl) external routine spec dump(integer start, finish, printst, lim) external routine spec rdint(integer name i) external routine spec connflag(string (63) s, integer flag) routine spec remind(string (255) s) external routine spec compare(string (255) s) external routine spec newgen(string (255) s) system routine spec set use(string (31) file, integer mode, value) ! Spec for the above routine is as follows: ! FILE = filename ! MODE = 0 take VALUE ! 1 increment ! -1 decrement ! VALUE used only for MODE = 0 system routine spec phex(integer i) system routine spec move(integer len, from, to) record format finfrecf(integer conad, filetype, relst, relend, size, rup, eep, mode, users, arch, string (6) tran, string (8) date, time, integer count, spare1, spare2) system routine spec finfo(string (31) s, integer mode, record (finfrecf) name r, integer name flag) system routine spec ncode(integer s, f, ff) external routine spec send(string (63) s) system integer map spec comreg(integer i) system routine spec disconnect(string (31) s, integer name f) external routine spec parm(string (63) s) external routine spec forte(string (255) s) external routine spec ibmimp(string (255) s) external routine spec bibmimp(string (255) s) external routine spec imp80(string (255) s) external routine spec bimp80(string (255) s) external routine spec iopt(string (255) s) external routine spec biopt(string (255) s) external routine spec imp(string (63) s) external routine spec detach(string (255) s) record format conrecf(integer conad, filetype, relst, relend) system routine spec connect(string (31) s, integer acc, maxb, prot, record (conrecf) name r, integer name flag) system routine spec changefilesize(string (31) s, integer newsize, integer name flag) recordformat c TMODEF(halfinteger FLAGS1, FLAGS2, {.04} byteinteger PROMPTCHAR, ENDCHAR, {.06} bytearray BREAKBIT1(0:3) {%or %halfintegerarray BREAKBIT2(0:1))} , {.0A} byteinteger PADS, RPTBUF, LINELIMIT, PAGELENG, {.0E} byteintegerARRAY TABVEC(0:7), {.16} byteinteger CR, ESC, DEL, CAN, {.1A} byteinteger FLAGS, INTERNAL STATE, LEADIN1, LEADIN2, XLO, XHI) {.20} recordformat c UINFF (string (6)USER, string (31)JOBDOCFILE, {.28} integer MARK, FSYS, {.30} PROCNO, ISUFF, REASON, BATCHID, {.40} SESSICLIM, SCIDENSAD, SCIDENS, STARTCNSL, {.50} AIOSTAT, SCT DATE, SYNC1 DEST, SYNC2 DEST, {.60} ASYNC DEST, AACCT REC, AIC REVS, {.6C} string (15)JOBNAME, {.7C} string (31)BASEFILE, {.9C} integer PREVIC, {.A0} ITADDR0, ITADDR1, ITADDR2, ITADDR3, {.B0} ITADDR4, STREAM ID, DIDENT, SCARCITY, {.C0} PREEMPTAT, string (11)SPOOLRFILE, {.D0} integer FUNDS, SESSLEN, PRIORITY, DECKS, {.E0} DRIVES, PART CLOSE, {.E8} record (TMODEF)TMODES, {108} integer PSLOT, {10C} string (63)ITADDR, {14C} integerarray FCLOSING(0:3), integer CLO FES, {160} integer OUTPUT LIMIT, DAPSECS, longinteger DAPINSTRS, {170} integer OUT, string (15)OUTNAME, {184} integer HISEG, {188} string (31)FORK, {1A8} integer INSTREAM, OUTSTREAM, {1B0} integer DIRVSN, DAP NO, SCT BLOCK AD, integer UEND) const record (uinff) name uinf=9<<18 const string name date=x'80C0003F', time=x'80C0004B' record format objf(integer nextfreebyte, coderelst, glarelst, type1, chksm, dt, w6, w7) integer fn spec locate(string (255) s, integer name curp, integer lastb) routine spec bel(string (255) s) !----------------------------------------------------------------------------- routine instrg(string name s) ! READS NEXT LINE FROM CURRENT INPUT STREAM, SETTING S TO BE CONTENTS ! OF THE LINE WITHOUT THE NEWLINE. integer i s="" until i=nl cycle readsymbol(i) s=s.tostring(i) repeat length(s)=length(s)-1 end ; ! INSTRG integer fn shortcfn(string name s) ! CHECK FILE NAME - 1-8 CHARS, ALPHA,NUMBERS OR HASH ! RESULT = 0 GOOD 1 BAD integer ch, j, l l=length(s) result =1 unless 0<l<=11 cycle j=1, 1, l ch=byteinteger(addr(s)+j) result =1 unless 'A'<=ch<='Z' or '0'<=ch<='9' or ch='#' or 'a'<=ch<='z' repeat result =0; ! FILENAME IS GOOD end ; ! SHORTCFN integer fn cfn(string name s) string (31) mas, mem if s->mas.("_").mem then result =shortcfn(mas)!shortcfn(mem) result =shortcfn(s) end ; ! CFN integer fn long cfn(string name s) ! RESULT 0 GOOD 1 BAD string (63) user, file if s->user.(".").file start if length(user)#6 or shortcfn(user)#0 or cfn(file)#0 then result =1 result =0; ! GOOD finish result =cfn(s) end ; ! LONG CFN !----------------------------------------------------------------------------- integer fn possparms(string (255) file, string name parms, integer remove) ! S is string supplied at terminal for compilation ! If PARMS is null, see if FILE appears in file SS#PARMS. ! If so, use input line from the file. ! If PARMS is not null replace line in file SS#PARMS (if file and name exist) ! or add filename and parms to the file. ! If REMOVE#0 then delete filename from file. ! Result = 0 if return is OK for compilation to continue ! 1 if compilation is to be abandoned integer j, n, rewrite, found, abandon string (71) fn, rest const integer topf=63 string (71) array aa(0:topf) on event 9 start ; ->eof; finish if exist("SS#PARMS")=0 then result =0 if exist(file)=0 start printstring("File ".file." does not exist") newline result =1 finish newline define("54,SS#PARMS") select input(54) n=0; rewrite=0; found=0; abandon=0 cycle rstrg(aa(n)) aa(n)->fn.(",").rest if fn=file start found=1 if remove#0 start aa(n)="" rewrite=1 exit finish if parms="" then parms=rest else if parms=rest then exit else c aa(n)=fn.",".parms and rewrite=1 finish n=n+1 if n>=topf start printstring("SS#PARMS file full") newline result =1 finish repeat eof:select input(0) close stream(54) if found=0 and parms#"" start aa(n)=file.",".parms; n=n+1 rewrite=1 finish if rewrite#0 start select output(54) j=0 while j<n cycle if aa(j)#"" start printstring(aa(j)) newline finish j=j+1 repeat select output(0) close stream(54) clear("54") finish ! PRINTSTRING("Parms: ".PARMS) ! %if PARMS="" %then PRINTSTRING("Defaults") ! NEWLINE result =abandon end ; ! POSSPARMS !----------------------------------------------------------------------------- routine sanal(string name s, string (1) objchar, routine compiler(string (255) s), integer cplr id) system routine spec destroy(string (31) s, integer name flag) routine spec badpar switch cr(0:17) const integer topsan=30 switch sp(1:topsan) const string (9) array pars(1:topsan)= c {1} "NULL", "NULLY", "NOLIST", "OPT", "PX", {6} "NOCHECK", "NOTRACE", "NOARRAY", "NODIAG", {10} "MAP", "STACK", ".LP", ".N", ".NY", {15} "PARMX", "PY", "DEBUG", "MAXDICT", ".LPD", {20} "FIXED", "NEWGEN", "X", "CHECK", ".OUT", "PARMY", {26} "PROFILE", "CODE", "BEL", "REMOVE", "DEFAULTS" record (objf) name h integer tolp, newg, savparm, bell, defaults integer param, as, p, badp, check, jj, remove string (127) rest, parmfld, cstring, work string (31) sou string (11) obj, li, tte, rhgen, lptag, aa as=addr(s) badp=0 newg=0 check=0 tolp=0 remove=0 bell=0 param=0 defaults=0 parmfld="" tte=",.OUT" lptag="" next=-1 s=separate(s) sou<-s p=1 unless longcfn(s)=0 then badpar ! TURN S INTO THE ROOT FOR OBJ AND LIST FILENAMES if s->rest.(".").s start ; finish if s->rest.("_").s start ; finish if byteinteger(as+length(s))#'S' start if length(s)=11 then badpar finish else start length(s)=length(s)-1 finish return if badp#0 obj=s.objchar li=s."L" ! REMAINING PARAMETERS AFTER FIRST while separate(rest)#"" cycle p=p+1 cycle param=1, 1, topsan if rest=pars(param) then ->sp(param) if length(rest)=5 and rest->aa.(".LP").lptag and aa="" then ->sp(12) repeat badpar continue sp(1): ! NULL sp(3): ! NOLIST sp(13): ! .N li=".NULL" continue sp(2): ! NULLY sp(14): ! .NY obj=".NULL" continue sp(6): ! NOCHECK - IGNORE IF "CHECK" GIVEN BEFORE continue if check#0 ->tack on sp(30): ! DEFAULTS defaults=1 continue sp(4): ! OPT check=1 sp(18): ! MAXDICT sp(20): ! FIXED sp(17): sp(7): sp(8): sp(9): sp(10): sp(11): sp(26): ! PROFILE sp(27): ! CODE tack on: if parmfld#"" then parmfld=parmfld."," parmfld=parmfld.rest continue sp(19): ! .LPD, IE. LIST TO .LP AND DESTROY LISTING if tolp#0 then badpar tolp=2 continue sp(12): ! .LP if tolp#0 then badpar tolp=1 continue sp(5): ! PX (=PARMX) sp(15): ! PARMX rest="PARMX" ->tack on sp(16): ! PY (=PARMY) sp(25): ! PARMY rest="PARMY" ->tack on sp(24): ! .OUT ! TTE=",.OUT" (IGNORE) continue sp(21): ! NEWGEN newg=1 sp(22): ! "X" OBJ, BUT NOT NEWGEN rhgen=obj byteinteger(addr(obj)+length(obj))='X' continue sp(23): ! CHECK - GIVEN ONLY TO SUPPRESS "NOCHECK" ! check=1 continue sp(28): ! BEL bell=1 continue sp(29): ! REMOVE remove=1 repeat return if badp#0 ! Remove NOCHECK if CHECK included. if check=1 start if parmfld->work.("NOCHECK").rest start parmfld=work.rest if parmfld->work.(",,").rest then parmfld=work.",".rest finish finish savparm=comreg(27) if possparms(sou, parmfld, defaults!remove)#0 then return if remove#0 then return if defaults#0 then parmfld="" if li=".NULL" start if parmfld#"" then parmfld=parmfld."," parmfld=parmfld."NOLIST" finish parm(parmfld) parm("?") ! TOLP HAS BEEN SET 1 FOR .LP ! 2 FOR .LPD if tolp=2 or (tolp#0 and cplr id>=10) start destroy(li, jj) li=".LP" finish cstring=sou.",".obj.",".li.tte ->cr(cplr id) unless cplr id<0 compiler(cstring); ! NONSTANDARD COMPILER ->lo out cr(0):imp(cstring); ->lo out cr(1):forte(cstring); ->lo out cr(2):imp(cstring); ->lo out cr(3):imp80(cstring); ->lo out cr(4):ibmimp(cstring); ->lo out cr(5):bimp80(cstring); ->lo out cr(6):iopt(cstring); ->lo out cr(7):biopt(cstring); ->lo out cr(10):imp(cstring); ->hi out cr(11):forte(cstring); ->hi out cr(12):imp(cstring); ->hi out cr(13):imp80(cstring); ->hi out cr(14):bibmimp(cstring); ->hi out cr(15):bimp80(cstring); ->hi out cr(16):iopt(cstring); ->hi out cr(17):biopt(cstring); ->hi out lo out: if tolp=1 then list(li.",.LP".lptag) if newg=0 then ->hi out p=rdfilead(obj) if p=0 then ->hi out h==record(p) if h_nextfreebyte<=h_coderelst then ->hi out if exist(rhgen)=0 then rename(obj.",".rhgen) else start set use("ERCC10.SERV1Y", 1, 0) set use("ERCC10.SERV2Y", 1, 0) newgen(obj.",".rhgen) set use("ERCC10.SERV1Y", -1, 0) set use("ERCC10.SERV2Y", -1, 0) finish hi out: comreg(27)=savparm if bell#0 then bel("") return routine badpar printstring("Bad param") write(p, 1) newline badp=1 end ; ! BADPAR end ; ! SANAL !------------------------------------------------------------------------------- external routine i80(string (255) s) sanal(s, "Y", imp80, 3) end ; ! I80 externalroutine iop(string (255) s) sanal(s, "Y", iopt, 6) end {iop} externalroutine bop(string (255) s) sanal(s, "Y", biopt, 7) end {biopt} external routine b80(string (255) s) sanal(s, "Y", bimp80, 5) end ; ! B80 external routine ibm80(string (255) s) sanal(s, "W", ibmimp, 4) end ; ! IBM80 external routine bibm(string (255) s) sanal(s, "W", bibmimp, 14) end ; ! BIBM external routine pim(string (255) s) sanal(s, "Y", imp, 0) end ; ! PIM !------------------------------------------------------------------------------- !externalroutine ft(%string(255) s) ! sanal(s,"Y",forte,1) ! %end; ! FT !------------------------------------------------------------------------------- external routine complr(routine compiler(string (255) s), string (1) objsym, string (63) s) ! THIS ROUTINE TO PASS ANY COMPILER IN TO HAVE THE STRING ANALYSIS DONE ! AS USUAL .. sanal(s, objsym, compiler, -1) end ; ! COMPLR !------------------------------------------------------------------------------- integer fn crewrfilead(string (31) s, integer epgs) if exist(s)=0 then result =nwfilead(s, epgs) result =wrfilead(s) end ; ! CREWRFILEAD record format ssf(integer switch, sessno, junkno, string (9) date) !----------------------------------------------------------------------------- string fn sesstext(integer update) record (ssf) ss integer flag, vsn, updated updated=0 vsn=1 read profile("Session", ss, vsn, flag) if flag=3 {SS#PROFILE does not exist} or flag=4 {keywordnot found} start ss=0 flag=0 finish if flag=0 start if ss_date#date start ss_sessno=0 ss_date=date ss_switch=0 ss_junkno=0 updated=1 finish if update#0 then ss_sessno=ss_sessno+1 and updated=1 if updated#0 start write profile("Session", ss, vsn, flag) if flag#0 start printstring("Write profile flag"); write(flag, 1) newline finish finish finish result ="XX".fromstr(ss_date, 1, 2).month(bin(fromstr(ss_date, 4, 5))).itos(ss_sessno) end ; ! SESSTEXT !----------------------------------------------------------------------------- external routine newsession(string (255) s) string (31) tx tx=sesstext(1) printstring(tx) printstring(" TIME=") tim("") if charno(tx, length(tx))&3=1 and exist("REMINDERS")#0 then remind("") end ; ! NEWSESSION !----------------------------------------------------------------------------- external routine session(string (255) s) s=sesstext(0) printstring(fromstr(s, 3, 7)) space printstring(fromstr(s, 8, length(s))) newline end ; ! SESSION !----------------------------------------------------------------------------- routine hiss(string (255) file or dev, integer which) ! Extracts a session record out of the recall file string (63) file, text integer fad, offset, flag, curp, lastb, oldcurp, curp minus1, curp minus2, xx, yy record (srcf) name h get journal(file, flag) if flag#0 start printstring("GET JOURNAL flag =") write(flag, 1); newline return finish fad=wrfilead(file) if fad=0 then return h==record(fad) curp=fad+h_txtrelst lastb=fad+h_nextfreebyte-1 text=sesstext(0) if text="" start printstring("Session text not found") newline return finish ! Remove numeric part from end: we will simply look for the one previous to ! the current (or previous to that), not assuming the sessio number. length(text)=length(text)-1 while '0'<=charno(text, length(text))<='9' curp minus1=curp curp minus2=curp oldcurp=curp cycle offset=locate(text, curp, lastb) if offset=0 then exit {not found/no lnger found} if offset>0 start ! Found curp minus2=curp minus1 curp minus1=oldcurp oldcurp=curp curp=curp+1 finish repeat curp=curp+1 while curp<fad+h_nextfreebyte and byteinteger(curp)#nl if which=-2 start xx=curp minus2 yy=curp minus1 finish else {-1} start xx=curp minus1 yy=curp finish h_txtrelst=xx-fad h_nextfreebyte=yy-fad file or dev=".LP" if file or dev="" if fromstr(file or dev, 1, 3)=".LP" start list(file.",".file or dev) finish else start cycle rename(file.",".file or dev) if return code=0 then exit prompt("Output filename: ") rstrg(file or dev) repeat finish end {hiss} !----------------------------------------------------------------------------- external routine thiss(string (255) s) new session("") hiss(s, -1) end ; ! THISS !----------------------------------------------------------------------------- external routine prevv(string (255) s) hiss(s, -2) end ; ! PREVV routine show value(integer adr, len) integer j printstring("X") for j=0, 1, len-1 cycle printstring(htos(byteinteger(adr+j), 2)) repeat newline end ; ! SHOW VALUE routine set value(integer adr, fromad, len) integer k k=0 while k<len cycle byteinteger(adr+k)=byteinteger(fromad+k) k=k+1 repeat end ; ! SET VALUE integer fn getyn string (255) wk ucstrg(wk) until wk="Y" or wk="N" if wk="Y" then result =1 result =0 end {getyn} !----------------------------------------------------------------------------- routine sbytes(string (255) file, integer len) integer start, j, value, take from, show from string (255) work if file#"" start start=wrfilead(file) if start=0 start printstring(" Parameter, if any, should be a filename.") newline printstring(" Omit parameter to patch vitual address.") newline finish else start=start>>18 finish else start=0 prompt("Addr or segno: ") rdint(start) if start=0 if 0<start<1<<18 or file#"" start prompt("Offset: ") rdint(j) start=start<<18+j finish if val(start, 1, 1, 0)=0 then ->inval ! Here we deal specially with "SSTRING" if len>4 start printstring("Area currently contains:") newline show from=start&(¬3) dump(show from, show from+32, show from, 16) prompt("New string:") nrstrg(work) prompt("Store at ".htos(start, 8)." WITH length byte?y/n:") take from=addr(work); len=length(work) if getyn=0 {NO} then take from=take from+1 else len=len+1 set value(start, take from, len) printstring("Area now contains:") newline dump(show from, show from+32, show from, 16) return finish if start&(len-1)#0 start printstring("Warning: alignment not ""correct""") newline finish printstring("Current value is: ") show value(start, len) prompt("New value: ") rdint(value) for j=0, 1, 3-len cycle if byteinteger(addr(value)+j)#0 start printstring("Warning: value too large!") newline exit finish repeat if len=1 then printstring("Byte") else if len=2 then printstring("Half") else c printstring("Word") printstring(" at address X") phex(start) newline printstring(" was ") show value(start, len) j=addr(value)+4-len set value(start, j, len) printstring(" becomes ") show value(start, len) return inval: printstring("Invalid address ") phex(start); newline end ; ! SBYTES !----------------------------------------------------------------------------- external routine sbyte(string (255) s) sbytes(s, 1) end ; ! SBYTE external routine shalf(string (255) s) sbytes(s, 2) end ; ! SHALF external routine sword(string (255) s) sbytes(s, 4) end ; ! SWORD external routine sstring(string (255) s) sbytes(s, 5) end ; ! SSTRING !------------------------------------------------------------------------------- integer fn memtype(string (15) master, string (11) member) integer flag string (31) file record (conrecf) r file=master."_".member connect(file, 0, x'40000', 0, r, flag) connflag(file, flag) result =-1 if flag#0 result =r_filetype end ; ! MEMTYPE record format pdshf(integer nextfreebyte, datast, maxbytes, type6, date, time, dirrelst, filecount) record format pdsdirf(integer filerelst, string (11) name, integer p4, p5, p6, p7) !----------------------------------------------------------------------------- routine sort files(record (pdsdirf) array name p, integer array name x, integer num) ! DECLARE INTEGER ARRAY X, BOUNDS 1:NUM, IN CALLING ROUTINE integer i, j, hit, n cycle i=1, 1, num x(i)=i repeat cycle i=num-1, -1, 1 hit=0 cycle n=1, 1, i if p(x(n))_name>p(x(n+1))_name start j=x(n) x(n)=x(n+1) x(n+1)=j hit=1 finish repeat if hit=0 then exit repeat end ; ! SORT FILES !----------------------------------------------------------------------------- external integer fn filetype(string (63) file) record (conrecf) r integer flag ! CONNECT IN A SUITABLE MODE flag=1 if 0<length(file)<=31 then connect(file, 0, x'40000', 0, r, flag) connflag(file, flag) result =-1 if flag#0 result =r_filetype end ; ! FILETYPE !----------------------------------------------------------------------------- external routine bel(string (255) t) integer j cycle j=1, 1, 8 printch(7); spaces(7) repeat newline end ; ! BEL !----------------------------------------------------------------------------- external integer fn locate(string (255) s, integer name curp, integer lastb) ! CURP should be set to search start address ! LASTB should be set to search end address (typically addr of last byte of file) ! Returns result 1 string S found, CURP points to it. ! 0 string S not found at all in file, CURP=LASTB ! -1 string S not found in about 1 page from starting ! CURP. CURP points to where search can resume. !*THE FUNCTION USES THE MACHINE CODE INSTRUCTIONS SWNE AND CPS. * !*SWNE IS USED TO FIND THE FIRST CHARACTER OF THE REQUESTED TEXT. * ! THEN CPS IS USED TO TEST FOR THE REST OF THE TEXT. integer lenb, tlen, ch1, lim, as1, b integer dr0, dr1, acc0, acc1; !DR0-DR1 AND ACC0-ACC1 MUST STAY AS PAIRS lim=curp+4096 lim=lastb if lim>lastb as1=addr(s)+1 tlen=length(s); !NO OF CHAS TO BE TESTED ch1=byteinteger(as1); !CH1 CHAR TO BE FOUND again:lenb=lim-curp+1; !NUMBER LEFT IN CURRENT RECORD !LOOK FOR CH1 CHARACTER !SWNE INS REQUIRES B REGISTER TO CONTAIN MASK IN BITS 16-23 !AND REF BYTE IN BITS 24-31. DR MUST CONTAIN A DESCRIPTOR !TO THE STRING TO BE SEARCHED b=ch1; !MASK(0)<<8 ! TEST CHAR dr0=x'58000000'!lenb; !STRING DESCRIPTOR dr1=curp; !ADDRESS OF STRING *lb_b; !LOAD B REGISTER *ld_dr0; !LOAD DESCRIPTOR REGISTER *put_x'A300'; !*SWNE_X'100' SCAN WHILE NOT EQUAL !CONDITION CODE NOW SET AS FOLLOWS !0 REF BYTE NOT FOUND !1 REF BYTE FOUND - ADDRESS IN BOTTOM OF DR *jcc_8, <firstnotfound>; !JUMP IF NOT FOUND *std_dr0; !STORE DESCRIPTOR REGISTER curp=dr1; !POSSIBLE FIRST BYTE !NOW DEAL WITH SINGLE CHARACTER SEARCH if tlen=1 then ->found; !FIRST AND ONLY CHARACTER MATCHED OK !NOW NEED TO COMPARE REST OF TEXT !IF ENOUGH TEXT IN BEFORE EOF USE CPS INSTRUCTION ELSE NOT FOUND AT ALL if lastb-curp+1<tlen then curp=lastb and result =0; ! NOT FOUND AT ALL !CPS(COMPARE STRINGS) INSTRUCTION REQUIRES DESCRIPTORS TO TWO !STRINGS IN DR AND ACC dr0=x'58000000'!(tlen-1); !NO NEED TO TEST FIRST CHAR AGAIN dr1=as1+1; !START OF STRING TO BE TESTED acc0=dr0 acc1=curp+1; !POSSIBLE SECOND CHARACTER *ld_dr0; !LOAD DESCRIPTOR REGISTER *lsd_acc0; !SET ACS TO 64 AND LOAD *put_x'A500'; !*CPS_X'100' COMPARE STRINGS !CONDITION CODE NOW 0 IF STRINGS EQUAL *jcc_8, <found>; !JUMP IF EQUAL !INCREMENT CURP AND TRY ALL OVER AGAIN curp=curp+1; !CANNOT HIT END OF SEGMENT BECAUSE STRING CONTAINS AT LEAST 2 CHAS ->again; !TRY AGAIN found: !THIS IS EXIT FOR SIMPLE CASE WHERE ALL TEXT IN ONE SEGMENT result =1; ! FOUND firstnotfound: curp=lim if curp=lastb then result =0; ! NOT FOUND AT ALL result =-1; ! NOT FOUND IN ABOUT 4K end ; ! LOCATE !----------------------------------------------------------------------------- routine endline(integer name curp) ! MOVES CURP TO NEXT NL (IF NOT ALREADY POINTING TO A NL) curp=curp+1 while byteinteger(curp)#nl end ; ! ENDLINE routine startline(integer name curp, integer firstb) ! MAKES SURE BYTE BEFORE CURP IS NL, OR STEPS BACK TILL IT IS if curp>firstb and byteinteger(curp-1)#nl start curp=curp-1 until byteinteger(curp-1)=nl or curp<=firstb finish end ; ! STARTLINE routine prevline(integer name curp, integer firstb) ! MOVES CURP BACK TO START OF PREVIOUS LINE (IF ANY) startline(curp, firstb) curp=curp-1 if curp>firstb startline(curp, firstb) end ; ! PREVLINE routine nextline(integer name curp) ! MOVES CURP TO 1ST BYTE OF NEXT LINE (OR PREV NL IF LINE NULL) endline(curp) curp=curp+1 end ; ! NEXTLINE routine printline(integer name curp, integer firstb) integer j startline(curp, firstb); ! TO 1ST BYTE OF LINE (OR PREV NL IF NULL) j=curp until byteinteger(j-1)=nl cycle printsymbol(byteinteger(j)) unless byteinteger(j-1)=' ' and byteinteger(j)=' ' j=j+1 repeat end ; ! PRINTLINE routine double u out(string name s) string (255) w integer as integer i, ch1, ch2 return if s="" as=addr(s) i=1 w="" until i>length(s) cycle ch1=byteinteger(as+i) ch2=byteinteger(as+i+1) if i>length(s) then ch2=0 if ch1='_'=ch2 then i=i+1 and ch1=' ' w=w.tostring(ch1) i=i+1 repeat s=w end ; ! DOUBLE U OUT !----------------------------------------------------------------------------- !%integer %fn ibmlinead(%integer fad, line1) !! Returns address of code for line1 in file at address file, or zero if not found !%record (objf) %name h !%integer curp, lastb, savc, basereg, hit, back !%integer it0, it1, relst, j, lh1, rh1, imask1, imask2 ! h==record(fad) ! relst=fad+h_coderelst ! curp=relst ! lastb=fad+h_nextfreebyte !! MAKE SUITABLE STRINGS FOR THE SEARCHES, IN IT0,IT1 ! imask1=x'92000003' ! imask2=x'92000002' { These two masks need lineno & basereg adding } ! lh1=(line1>>8)&255 ! rh1=line1&255 ! it0=4 ! %cycle ! %cycle ! ! In each 'page', try first for IMASK1, with BASEREG from 10 to 7. ! savc=curp ! basereg=10 ! %while basereg>=7 %cycle ! curp=savc ! it1=imask1!(rh1<<16)!(basereg<<12) ! hit=locate(string(addr(it0)+3), curp, lastb) ! %if hit=1 %then %exit ! %if hit=0 %then %result=0 ! basereg=basereg-1 ! %repeat ! %if hit=1 %then %exit ! %repeat !! DUMP(CURP&(¬16),CURP+16,CURP&(¬16),16) !! PRINTSTRING(" <- ONE/TWO-> ") !! NEWLINE ! ! ! ! Then we have found the second half of the line number. Use BASEREG ! ! to find the first half. ! ! ! ! First we look at the next instruction, to see if it sets the LH half. ! ! ! it1=imask2!(lh1<<16)!(basereg<<12) ! j=byteinteger(curp+4)<<24!byteinteger(curp+5)<<16!byteinteger(curp+6)<<8!byteinteger(curp+7) ! %if j=it1 %then %result=curp ! ! ! ! Otherwise, go backwards for up to a page (say), to see if 2(BASEREG) is set to LH. ! ! ! back=curp ! %cycle ! back=back-2 ! j=byteinteger(back)<<24!byteinteger(back+1)<<16!byteinteger(back+2)<<8!byteinteger(back+3) ! ! ! Exit (not the correct instance of RH) if this instruction changes LH ! ! but not to the correct value. ! %if j&x'FF000FFF'=imask2 %and j&x'00FF0000'#lh1<<16 %then %exit ! ! %if j=it1 %then %result=curp ! %repeat %until back<=relst %or back<curp-4000 ! ! ! ! No good. Look for second half again further on. ! curp=curp+1 ! %result=0 %if curp>=lastb ! %repeat !! HIT=LOCATE(STRING(ADDR(IT0)+3),CURP,LASTB) !! %if HIT=1 %then DUMP(CURP&(¬16),CURP+16,CURP&(¬16),16) %and %c !! %result=CURP !! %if HIT=1 %then %result=CURP !! %if HIT=0 %then %result=0 !! %repeat !%end {ibmlinead} !----------------------------------------------------------------------------- integer fn linead(integer fad, line1) ! Returns address of code for line1 in file at address file, or zero if not found record (objf) name h integer times, max lnb value, curp, lastb integer it0, it1, relst, j integer fn spec st instr(integer plus) h==record(fad) relst=fad+h_coderelst curp=relst lastb=fad+h_nextfreebyte ! MAKE SUITABLE STRINGS FOR THE SEARCHES, IN IT0,IT1 AND ST0,ST1 it0=4 it1=x'63800000'!line1 if line1<=63 start it0=2 it1=x'62000000'!(line1<<16) finish ! Have two shots at each line with ! either increased max lnb value ! or long instruction form (if low line number) ! for the second try max lnb value=12 cycle times=0, 1, 1 curp=relst cycle curp=curp+1 j=locate(string(addr(it0)+3), curp, lastb) if j=0 start if times=0 then exit else result =0 finish if j=1 and st instr(it0)#0 then result =curp; ! FOUND repeat if line1<=63 start ! Algol has long LSS instruction form even for these ! small line numbers it0=4 it1=x'63800000'!line1 finish else max lnb value=127 repeat printstring("SHOULD NOT GET HERE ") result =0 integer fn st instr(integer plus) ! RESULT = 1 IF NEXT HALFWORD IS A SUITABLE "STORE" INSTRUCTION ! 0 OTHERWISE integer nexthalfword, pt pt=curp+plus result =0 if pt>=lastb if pt&1#0 then result =0 if pt&3=0 then nexthalfword=integer(pt)>>16 else nexthalfword=integer(pt-2)&x'FFFF' unless x'4885'<=nexthalfword<=x'4880'!max lnb value then result =0 result =1 end ; ! ST INSTR end ; ! LINEAD !----------------------------------------------------------------------------- routine find lines(integer fn linead(integer a, b), routine recode(integer a, b, c), string (255) s) const integer maxoff=7 integer sign, offx, curp, lastb, line2 found record (objf) name h string (31) file, sl1, sl2, devs integer line1, line2, fad, relst, ad1, ad2, reql1, reql2 file=s; sl1=""; sl2=""; devs="" if s->file.(",").sl1 start ; finish if sl1->sl1.(",").sl2 start ; finish if sl2->sl2.(",").devs start ; finish if sl1#""#sl2 and devs="" then devs=".OUT" prompt("File: ") ucstrg(file) while long cfn(file)#0 fad=rdfilead(file) return if fad=0 h==record(fad) relst=fad+h_coderelst curp=relst lastb=fad+h_nextfreebyte prompt("START LINE NO: ") line1=bin(sl1) if line1=x'80308030' then rdint(line1) line2=bin(sl2) prompt("End line no: ") if line2=x'80308030' then rdint(line2) prompt("To file/dev: ") ucstrg(devs) while ".OUT"#devs and fromstr(devs, 1, 3)#".LP" and cfn(devs)#0 reql1=line1 reql2=line2 !-------------------------------------------------------------- ! Look for start line-number offx=0 sign=1 until ad1>0 or offx>maxoff cycle line1=line1+sign*offx ad1=linead(fad, line1) sign=-sign offx=offx+1 repeat if ad1=0 then line1=reql1; ! set back to requested value {phex(ad1);write(line1, 1); write(offx, 1);space} printstring("Line") write(line1, 1) spaces(2) printstring(htos(line1, 5)) if ad1=0 then printstring(" not") printstring(" found") newline !------------------------------------------------------------------------ ! Look for end line-number plus one line2=line2+1 offx=0 sign=1 line2 found=9999999 until ad1>0 or offx>maxoff cycle line2=line2+sign*offx ad2=linead(fad, line2) sign=-sign offx=offx+1 repeat if ad2=0 then line2=reql2 {set back to requested value} else c line2 found=line2 {line number actually found} printstring("Line") write(line2, 1) spaces(2) printstring(htos(line2, 5)) if ad2=0 then printstring(" not") printstring(" found") if ad2=0 start printstring(" (nor line") write(line2+1, 1); spaces(2) printstring(htos(line2+1,5)); printstring(")") finish newlines(3) if ad1=0=ad2 then return else start if ad1=0 then ad1=ad2-64 ! If the end line-number found was less than the one requested plus one ! then recode 64 extra bytes. if line2 found<reql2+1 then ad2=ad2+64 if ad2=0 then ad2=ad1+64 finish !---------------------------------------------------------------------- define("65,".devs) select output(65) if devs#".OUT" start printstring("DUMPED FROM FILE: ") printstring(file) spaces(5) printstring(date." ".time) newlines(2) finish recode(ad1, ad2, ad1-h_coderelst) select output(0) close stream(65) clear("65") end ; ! FIND LINES !----------------------------------------------------------------------------- external routine recode lines(string (255) s) find lines(linead, ncode, s) end ; ! RECODE LINES integer fn ibmlinesearch(integer name address, lineno, integer lim, below) ! Result 1 if found a line number, zero if not ! BELOW indictae whether nearest below or above is required integer opcode, b2, b3, disp, basereg, prevline, prevad, ad, line, prev1ad prevline=999999; prevad=x'0FFFFFFF'; prev1ad=prevad ad=address line=0 while ad<lim and ad<prevad+1024 cycle opcode=byteinteger(ad) if opcode=x'92' {mvi} start b2=byteinteger(ad+1); b3=byteinteger(ad+2); disp=(b3<<8!byteinteger(ad+3))&x'FFF' basereg=b3>>4 if 5<=basereg<=10 start if disp=2 or disp=3 start if byteinteger(ad-4)#x'92' start prevline=line prevad=prev1ad prev1ad=ad finish if disp=2 then line=(line&x'FFFF00FF')!b2<<8 else line=(line&x'FFFFFF00')!b2 exit if line>=lineno finish finish finish ad=ad+((opcode>>6)&1+(opcode>>7)&1+1)<<1 repeat if line=lineno then address=ad and result =1 {found OK} if below#0 start if prevline=999999 then result =0 address=prevad; lineno=prevline result =1 {found something} finish ! Then wanted line above given lineno if line>lineno start lineno=line; address=ad+4 result =1 {found something} finish address=address+64 result =0 end {ibmlinesearch} external routine ibmlines(string (255) s) const integer maxoff=7 integer sign, offx, lastb, line2 found record (objf) name h string (31) file, sl1, sl2, devs integer line1, line2, fad, relst, ad1, ad2, j file=s; sl1=""; sl2=""; devs="" if s->file.(",").sl1 start ; finish if sl1->sl1.(",").sl2 start ; finish if sl2->sl2.(",").devs start ; finish if sl1#""#sl2 and devs="" then devs=".OUT" prompt("File: ") ucstrg(file) while long cfn(file)#0 fad=rdfilead(file) return if fad=0 h==record(fad) relst=fad+h_coderelst lastb=fad+h_nextfreebyte prompt("Start line no: ") line1=bin(sl1) if line1=x'80308030' then rdint(line1) line2=bin(sl2) prompt("End line no: ") if line2=x'80308030' or line2<line1 then rdint(line2) prompt("To file/dev: ") while ".OUT"#devs and fromstr(devs, 1, 3)#".LP" and cfn(devs)#0 cycle nrstrg(devs) devs=".OUT" if devs="" devs=ucstring(devs) repeat !-------------------------------------------------------------- ! Look for start line-number ad1=relst j=ibmlinesearch(ad1, line1, lastb, 1 {next below}) printstring("Line") write(line1, 1) spaces(2) printstring(htos(line1, 5)) if j=0 then printstring(" not") printstring(" found") newline !------------------------------------------------------------------------ ! Look for end line-number plus one line2=line2+1 ad2=ad1-1024 {go back somewhat to pick up full lineno} ad2=relst if ad2<relst j=ibmlinesearch(ad2, line2, lastb, 0) if j#0 start printstring("Line") write(line2, 1) spaces(2) printstring(htos(line2, 5)) printstring(" found") newlines(2) finish !---------------------------------------------------------------------- define("65,".devs) select output(65) if devs#".OUT" start printstring("DUMPED FROM FILE: ") printstring(file) spaces(5) printstring(date." ".time) newlines(2) finish ibmrecode(ad1, ad2, ad1-h_coderelst) select output(0) close stream(65) clear("65") end ; ! IBMLINES !----------------------------------------------------------------------------- external routine exfile(string (135) file) record (srcf) name h1 record (srcf) name h2 integer flag, copy from, copy to, in, out, j, curp, lastb string (63) outfn, outdev switch loc1(-1:1) switch loc2(-1:1) string (127) text1, text2, header integer len, outfpgs, par par=1 outfn=".LP" outdev=".LP" if file="" then ->getips if file->file.(",").text1 start if exist(file)=0 then ->bp finish else text1="" par=2 if text1->text1.(",").text2 start par=3 ! NOW SEE IF THERE IS AN OUTPUT FILE SPECIFIED if text2->text2.(",").outfn start par=4 uctranslate(addr(outfn)+1, length(outfn)) unless fromstr(outfn, 1, 3)=".LP" or cfn(outfn)=0 then ->bp finish double u out(text1) double u out(text2) ->ready finish bp: printstring("Bad/missing param") write(par, 1); newline return getips: prompt("File: ") rstrg(file) until rdfilead(file)>0 prompt("Text1:") instrg(text1) ! GET TEXT2 prompt("Text2:") instrg(text2) ! GET OUT FILE NAME prompt("To file/device: ") ucstrg(outfn) until fromstr(outfn, 1, 3)=".LP" or cfn(outfn)=0 ready: if fromstr(outfn, 1, 3)=".LP" then outdev=outfn and outfn="T#EXFILE" in=rdfilead(file) return if in<=0 h1==record(in) outfpgs=(h1_nextfreebyte+4095)>>12 out=nwfilead(outfn, outfpgs) return if out<=0 h2==record(out) !---------------------------- PHASE ONE ----------------------------- curp=in+h1_txtrelst lastb=in+h1_nextfreebyte if text1="" then copy from=curp and ->find end loc1(-1): ! TEXT1 NOT FOUND WITHIN ABOUT 1 PAGE. CONTINUE. ->loc1(locate(text1, curp, lastb)) loc1(1): ! CURP POINTS TO TEXT1. FIND PRECEDING NEWLINE j=curp if byteinteger(j-1)#nl start j=j-1 until byteinteger(j-1)=nl or j<=in+h1_txtrelst finish copy from=j ! SET POINTER ONE BYTE PAST THIS TEXT SO THAT IF TEXT2 IS IDENTICAL ! WITH TEXT1 WE FIND THE NEXT (RATHER THAN THE SAME) OCCURRENCE OF IT IN ! PHASE TWO curp=curp+1 !------------------------------ PHASE TWO --------------------------- find end: ! COPY FROM IS SET UP. FIND TEXT2, IE. END OF AMOUNT TO COPY ! PUT FILENAME D+T HERE header=" Extract from file: ".file." ".date." ".time." " copy to=out+16 string(copy to-1)=header byteinteger(copy to-1)=0 copy to=copy to+length(header) if text2="" start len=lastb-copy from ->tidyup finish locate text2: ->loc2(locate(text2, curp, lastb)) loc2(1): ! TEXT2 FOUND. CURP POINTS TO IT. ! FIND END OF LINE CONTAINGING TEXT2 j=curp j=j+1 until byteinteger(j)=nl len=j+1-copyfrom ->tidyup loc2(-1): ! TEXT2 NOT FOUND WITHIM ABOUT 1 PAGE. COPY AND CONTINUE len=curp-copy from move(len, copy from, copy to) copy from=curp copy to=copy to+len ->locate text2 tidyup: move(len, copy from, copy to) copy to=copy to+len h2_nextfreebyte=copy to-out h2_txtrelst=16 h2_maxlen=(h2_nextfreebyte+x'FFF')&x'FFFFF000' h2_filetype=3 ! REDUCE FILE SIZE (PHYSICAL) TO MINIMUM changefilesize(outfn, h2_maxlen, flag) if flag#0 start printstring("CHANGEFILESIZE FLAG =") write(flag, 1); newline finish ! PRINTSTRING("H2_NEXTFREEBYTE=") ! PHEX(H2_NEXTFREEBYTE) ! PRINTSTRING(" FILE PHYSICAL SIZE=") ! PHEX(J) ! NEWLINE if outfn="T#EXFILE" then send(outfn.",".outdev) return loc1(0): ! TEXT1 NOT FOUND IN FILE printstring("TEXT1 """.text1.""" Not found") newline return loc2(0): ! TEXT2 NOT FOUND IN FILE printstring("TEXT2 """.text2.""" Not found") newline return end ; ! EXFILE !----------------------------------------------------------------------------- integer fn ftextf(integer fad, integer name goon, string (255) text) ! Result = 1 if text found (several lines have been printed) ! ! 0 if text not found, or not a char file ! ! GOON should be set zero to commence at start of text in the file, else to ! ADDRESS of point for resumption. And is set to address following printed ! test, for Result=1. integer j, ct, firstb, curp, lastb record (srcf) name hs switch stat(-1:1) ct=3 hs==record(fad) if 3#hs_filetype#0 then ->obj firstb=fad+hs_txtrelst lastb=fad+hs_nextfreebyte if firstb=lastb start printstring("File empty! ") result =0; ! BAD finish if goon>0 start curp=goon result =0 if curp>lastb-length(text) finish else curp=firstb stat(-1): ->stat(locate(text, curp, lastb)) stat(1): newline prevline(curp, firstb) cycle j=1, 1, ct printline(curp, firstb) nextline(curp) exit if curp>=lastb repeat newline goon=curp result =1; ! OK stat(0): result =0; ! BAD obj: printstring("Not a character file ") result =0; ! BAD end ; ! FTEXTF !----------------------------------------------------------------------------- external integer fn concf(string (255) s) ! INTENDED TO BE ASUBSTITUTE FOR "CONCAT", ALLOWING THE PARAMS ! "FILE1,FILE2, /OUTFILE" ! RESULT = 0 SUCCESSFUL ! 1 SOME ERROR (MESSAGE ALREADY PRINTED) record (finfrecf) r1 string (1) sepr string (255) sav string (31) out, out1 integer bytes, ad1, ad2, flag, len, pgs, np record (srcf) name h1 record (srcf) name h2 unless s->s.("/").out start s=""; sepr="," prompt("CONC: ") cycle ucstrg(sav) if sav=".E" or sav=".END" start sepr="/" prompt("TO FILE: ") ucstrg(out) exit finish else start if rdfilead(sav)=0 then continue finish s=s.sepr if length(s)>0 s=s.sav exit if sepr="/" repeat finish out1=""; ! SET TO OUT FILE WHEN OUT=ONE OF THE IN FILES np=0 if out->out.(",NP") or out->out.(",.NP") then np=1 sav=s bytes=0 next=-1 while separate(s)#"" cycle if s=out start out1=out out="SS#CON" finish finfo(s, 1, r1, flag) if flag#0 start printstring(s." FINFO FLAG =") write(flag, 1); newline; result =1 finish bytes=bytes+r1_size repeat pgs=(bytes+x'FFF')>>12 ad2=nwfilead(out, pgs) result =1 if ad2=0 h2==record(ad2) h2_nextfreebyte=32 h2_txtrelst=32 h2_maxlen=pgs<<12 h2_filetype=3 s=sav while separate(s)#"" cycle ad1=rdfilead(s) result =1 if ad1<=0 h1==record(ad1) len=h1_nextfreebyte-h1_txtrelst move(len, ad1+h1_txtrelst, ad2+h2_nextfreebyte) h2_nextfreebyte=h2_nextfreebyte+len if np#0 start byteinteger(ad2+h2_nextfreebyte)=12 h2_nextfreebyte=h2_nextfreebyte+1 finish repeat if out1#"" then newgen("SS#CON,".out1) result =0 end ; ! CONCF !----------------------------------------------------------------------------- external routine conc(string (79) s) integer j j=concf(s) end ; ! CONC !----------------------------------------------------------------------------- string fn cdate(integer fad) record (objf) name ho ho==record(fad) result =unpackdate(ho_dt)." ".unpacktime(ho_dt)." " end ; ! CDATE !----------------------------------------------------------------------------- integer fn different(integer len, a, b) integer dr0, dr1, ac0, ac1 dr0=x'58000000'!len dr1=a ac0=dr0 ac1=b *ld_dr0 *lsd_ac0 *put_x'A500'; ! CPS *jcc_8, <equal> result =1; ! DIFFERENT equal: result =0; ! SAME end ; ! DIFFERENT !----------------------------------------------------------------------------- constinteger maxmems=1024 integer fn lexist(string (11) mem, integer dirad, ct) ! RESULT IS 1 IF A LISTING FILE EXISTS FOR THIS SRC FILENAME ! ELSE RESULT 0. byte integer name ch integer j record (pdsdirf) array format dirarrf(1:maxmems) record (pdsdirf) array name d d==array(dirad, dirarrf) ch==byteinteger(addr(mem)+length(mem)) if ch='S' then ch='L' else start result =0 if length(mem)=8 mem=mem."L" finish cycle j=1, 1, ct if d(j)_name=mem then result =1 repeat result =0 end ; ! LEXIST !----------------------------------------------------------------------------- integer fn searchf(integer all, string (79) text, master) ! SEARCHES FOR "TEXT" IN PDFILE "MASTER" (WHICH MAY BE A SEQUENCE OF ! PDFILENAMES SEPARATED BY COMMAS. ! FOR ALL = 0 ! RESULT = 1 FOUND ! 0 NOT FOUND ! FOR ALL = 1, CONTINUE TO FIND ALL OCCURRENCES integer type, j switch searmp(0:6) const byte integer nonstd=0 const integer obj=1 const integer lib=2 const integer char=3 const integer dat=4 const integer map=5 const integer part=6 string (63) member string (31) fullmem name record (objf) name h1 record (pdshf) name h record (pdsdirf) array format dirarrf(1:maxmems) record (pdsdirf) array name d ! FOR THE ALPHA SORT integer array x(1:maxmems) integer pad, fc, mtype, f1, found, goon, accum next=-1 while separate(master)#"" cycle ! NEWLINES(3) newlines(2) pad=rdfilead(master) if pad=0 then continue {to nextmaster} type=filetype(master) printstring(master); newline if type=char start goon=0 found=0; accum=0 until found=0 cycle found=ftextf(pad, goon, text) accum=accum!found if accum=0 then printstring("Not found".snl) if all=0 and found#0 then printstring("Found".snl) and result =1 repeat continue {to nextmaster} finish h==record(pad) unless h_type6=6 start ! TYPE IS 13 FOR PDFILE, ALTHOUGH TYPE RETURNED BY RT ! CONMEMBER IS 6. printstring("File ".master." is not partitioned or character ") continue {to nextmaster} finish if h_filecount>maxmems start printstring("Too many files for TSEARCH ") continue {to nextmaster} finish d==array(pad+h_dirrelst, dirarrf) sort files(d, x, h_filecount) fc=0 while fc<h_filecount cycle ; ! MEMBERS ! 32-BYTE ENTRIES fc=fc+1 member=d(x(fc))_name fullmem name=master."_".member mtype=memtype(master, member) unless 0<=mtype<=6 then mtype=0 f1=rdfilead(fullmem name) ->mcont if f1=0 h1==record(f1) ->searmp(mtype) searmp(3): ! CHARACTER spaces(3) printstring("Member ".member) ! SKIP SRC MEM IF A LISTING MEM EXISTS.. if lexist(member, pad+h_dirrelst, h_filecount)#0 then ->mcont spaces(25-outpos) found=0; accum=0 goon=0 until found=0 cycle found=ftextf(f1, goon, text) accum=accum!found if accum=0 then printstring("Not found ") if all=0 and found#0 then printstring("Found ") and result =1 repeat ->mcont searmp(1): ! OBJECT searmp(*): mcont: searmp(0): ! NON-STANDARD newline repeat ; ! MEMBER repeat !----------------------------------------------------------------- if all=0 then printstring("""".text.""" Not found ") result =0 end ; ! SEARCHF !----------------------------------------------------------------------------- external routine tsearch(string (79) s) string (79) text, file integer j if s="" start prompt("Text:") rstrg(text) prompt("File/.END: ") ucstrg(file) until file=".END" or searchf(0, text, file)#0 return finish unless s->text.(",").file start printstring("PARAMS ? ") return finish double u out(text) j=searchf(0, text, file) end ; ! TSEARCH !----------------------------------------------------------------------------- external routine tsearchall(string (79) s) string (79) text, file, aa, bb integer j if s="" start prompt("Text:") rstrg(text) prompt("File/.END: ") until file=".END" or searchf(1, text, file)=-1 cycle ucstrg(file) file=aa.bb while file->aa.(" ").bb repeat ! (IT NEVER IS -1) return finish unless s->text.(",").file start printstring("PARAMS ? ") return finish double u out(text) j=searchf(1, text, file) end ; ! TSEARCHALL !----------------------------------------------------------------------------- external integer fn pdmems(string (31) pd, integer name n, record (rf) array name r) ! This routine returns records in the parameter array R of format: ! (RF) defined above, ! for each member in pdfile PD. N should be set before the call to the ! top entry no of the recordarray (i.e. the declaration sould be (0:N) ). ! And on return N is set to the no of records returned. ! Result zero if not OK, e.g. file not exist etc. ! non-zero if OK integer pad, fc string (11) member integer array x(1:n+1) record (pdshf) name h record (pdsdirf) array format dirarrf(1:n+1) record (pdsdirf) array name d pad=rdfilead(pd) if pad=0 then result =1 h==record(pad) unless h_type6=6 start printstring(pd." is not a partioned file ") result =0 finish unless 0<n<=4096 start printstring("PDMEMS: Array bound param invalid") write(n, 1) newline result =0 finish if h_filecount>n+1 start printstring("PDfile has") write(h_filecount, 1) printstring(" members. Output array too small (0:") write(n, 1) printstring(")") newline result =0 finish d==array(pad+h_dirrelst, dirarrf) sort files(d, x, h_filecount) fc=0 n=0 while fc<h_filecount cycle fc=fc+1 member=d(x(fc))_name r(n)_mem=member r(n)_type=memtype(pd, member) n=n+1 repeat result =0 end ; ! PDMEMS ! Prototype routine calling PDMEMS: !%externalroutine PMEMS(%string(255) S) !%constinteger TOPE=255 !%recordformat RF(%string(11) MEM,%integer TYPE) !%recordarray R(0:TOPE)(RF) !%integer J,N !%string(31) PD ! PROMPT("PDfile: ") ! RSTRG(PD) ! N=5 ! J=PDMEMS(PD,N,R) ! %return %if J=0 ! J=0 ! %while J<N %cycle !! PRINTSTRING(R(J)_MEM) !! SPACES(12-OUTPOS) !! WRITE(R(J)_TYPE,2) ! LIST(PD."_".R(J)_MEM) %if R(J)_TYPE=3; ! CHARACTER ! NEWLINES(2) ! J=J+1 ! %repeat ! %end; ! PDMEMS !----------------------------------------------------------------------------- recordformat ddf(byteinteger dr, string (30) file) const integer destr=53, repla=54, act destr=56, act repla=57 external routine pdcheck(string (79) master) string (31) array for disconn(0:25) record (ddf)array name dd record (ddf)array format ddff(1:40) integer dpt, rpt, nf, rubbish, curroutstream, nn switch mp(0:6) routine spec enter(integer type, string (17) s) routine spec printnot routine spec mulsym(integer sym, mul) routine spec head(string (71) s) const byte integer nonstd=0 const integer obj=1 const integer lib=2 const integer char=3 const integer dat=4 const integer map=5 const integer part=6 const string (11) array mtypes(0:6)= c "Nonstandard","Object ","Library ","Character ","Data ", "Storemap ","Partitioned" string (63) member, memfile owner string (31) fullmem name string (31) s1, s2, output record (objf) name h1, h2 record (pdshf) name h record (pdsdirf) array format dirarrf(1:255) record (pdsdirf) array name d record (srcf) name desrh ! FOR THE ALPHA SORT integer array x(1:255) integer pad, fc, mtype, f1, f2, diff, dfad record (ddf) ddum nn=0 curroutstream=comreg(23) output="" if master->master.("/").output start define("ST54,".output) select output(54) finish dfad=tpfilead("SS#DESRP", 2) return if dfad=0 desrh==record(dfad) desrh_txtrelst=32; desrh_nextfreebyte=32; desrh_maxlen=x'2000' desrh_filetype=4 dd==array(dfad+desrh_txtrelst, ddff) dpt=0; rpt=0; nf=0 next=-1 while separate(master)#"" cycle newlines(3) head("Analysis of PDfile: ".master) newlines(2) memfile owner="" if master->master.("(").memfile owner start unless length(memfile owner)=7 and byteinteger(addr(memfile owner)+7)=')' start printstring("Invalid member-file owner ") continue {to next master} finish length(memfile owner)=length(memfile owner)-1 finish pad=rdfilead(master) if pad=0 then exit {to next master} h==record(pad) unless h_type6=6 start printstring(master." IS NOT A PARTIONED FILE ") exit {to nextmaster} finish printstring("Member Type File of same name Member last altered") printstring(" File last alered ") if h_filecount>255 start printstring("Too many files for Mastercheck ") continue {to next master} finish d==array(pad+h_dirrelst, dirarrf) sort files(d, x, h_filecount) fc=0 while fc<h_filecount cycle ! 32-BYTE ENTRIES fc=fc+1 member=d(x(fc))_name fullmem name=master."_".member printstring(member) spaces(11-length(member)) mtype=memtype(master, member) unless 0<=mtype<=6 then mtype=0 printstring(mtypes(mtype)." ") f1=rdfilead(fullmem name) ->mcont if f1=0 h1==record(f1) f2=0 if memfile owner#"" then member=memfile owner.".".member if exist(member)=0 then printnot else f2=rdfilead(member) h2==record(f2) diff=1 spaces(19) if f2#0 s1<-cdate(f1) printstring(s1) ->mcont if f2=0 s2<-cdate(f2) if s1#s2 start spaces(2) printstring(s2) ->mcont finish ->mp(mtype) mp(3): ! CHARACTER ->mcont if f2=0; ! NOT EXIST if h1_nextfreebyte=h2_nextfreebyte then diff=different(h1_nextfreebyte, f1, f2) else c diff=1 if diff#0 then compare(master."_".member.",".member.",.F") else c printstring("COMPARISON COMPLETE") and hazard(member) ->mcont mp(1): ! OBJECT if h1_nextfreebyte=h2_nextfreebyte then diff=different(h1_nextfreebyte, f1, f2) if diff=0 then printstring("COMPARISON COMPLETE") else printstring("DIFFERENT") ->mcont mp(2): mp(4): mp(5): mp(6): ->mcont if f2=0 diff=different(h1_nextfreebyte, f1, f2) if diff=0 then printstring("COMPARISON COMPLETE") else printstring("DIFFERENT") ->mcont mcont: if f2#0 start ; ! IE. FILE OF SAME NAME EXISTS ! ? REPLACE IF DIFFERENT ? DESTROY IF NOT DIFFERENT if diff=0 then enter(destr, member) else enter(repla, fullmemname) ! COUNT FILES WHICH EXIST, DISCONNECT IF "TOO MANY" for disconn(nf)=member nf=nf+1 if nf>25 start while nf>0 cycle nf=nf-1 disconnect(for disconn(nf), rubbish) repeat finish finish mp(0): ! NON-STANDARD newline repeat repeat !----------------------------------------------------------------- if output#"" start select output(curroutstream); close stream(54) clear("54") finish desrh_nextfreebyte=desrh_txtrelst+nn*sizeof(ddum) disconnect("SS#DESRP", f1) newlines(2) printstring("ANALYSIS COMPLETE ") routine enter(integer type, string (17) file) return if nn>=40 nn=nn+1 dd(nn)_file=file dd(nn)_dr=type end ; ! ENTER routine head(string (71) s) integer j s=" ".s." " j=(80-length(s))>>1 mulsym('-', j) printstring(s) mulsym('-', j) newline end ; ! HEAD routine printnot printstring("does not exist ") end ; ! PRINTNOT routine mulsym(integer sym, mul) integer j return if mul<=0 cycle j=1, 1, mul; print symbol(sym); repeat end ; ! MULSYM end ; ! PDCHECK !----------------------------------------------------------------------------- external routine update(string (255) t) own integer one=1 integer j, nn, dfad, ch record (ddf)array name dd record (ddf)array format ddff(1:40) record (ddf) ddum record (srcf) name desrh string (31) s, brack, tt if uinfi(16)=0 then brack=" " else brack="(" next=-1 dfad=wrfilead("SS#DESRP") return if dfad=0 desrh==record(dfad) dd==array(dfad+desrh_txtrelst, ddff) nn=(desrh_nextfreebyte-desrh_txtrelst)//sizeof(ddum) define("ST53,SS#DETAC") prompt("YN: ") printstring(" :::DESTROY::: ") select output(53) for j=1, 1, nn cycle if dd(j)_dr=destr start prompt(dd(j)_file." YN: ") ucstrg(s) if charno(s, 1)='Y' start dd(j)_dr=act destr printstring("DESTROY".brack.dd(j)_file) printstring(")") if brack="(" newline finish finish repeat select output(0) printstring(" :::REPLACE::: ") select output(53) for j=1, 1, nn cycle if dd(j)_dr=repla start prompt(dd(j)_file." YN: ") ucstrg(s) if charno(s, 1)='Y' start dd(j)_dr=act repla printstring("PDREP".brack.dd(j)_file) printstring(")") if brack="(" newline finish finish repeat select output(0) close stream(53) clear("53") printstring(" :::DETACH FILE::: ") list("SS#DETAC") newlines(2) prompt("Detach/Obey: ") cycle ucstrg(s) ch=charno(s, 1) j=bin(s) repeat until ch='O' or 0<j<=40 or ch='Q' or ch='D' if 0<j<=40 then tt=",s" else tt="" if s="Q" then return if charno(s, 1)='O' start prompt(".LP/.OUT: ") ucstrg(s) until s=".OUT" or fromstr(s, 1, 3)=".LP" for j=1, 1, nn cycle if dd(j)_dr=act destr then destroy(dd(j)_file) if dd(j)_dr=act repla then pdrep(dd(j)_file) repeat list("SS#DETAC,".s) finish else detach("SS#DETAC".tt) end ; ! UPDATE !----------------------------------------------------------------------------- external routine redate(string (255) file) ! CONNECTS FILE IN WRITE MODE AND LOOKS AT THE FIRST LINE OF TEXT. ! IF THE LINE CONTAINS ="VSN ! OR DATED ! FOLLOWED BY A 9-CHARACTER FIELD CONTAINING A DATE (01 JAN 76, EG.), ! THEN THE DATE IS REPLACED BY TODAY'S DATE. integer j, j1, ad, amm1, ch, upvsn string (15) seek1, seek2 string (127) v, w1 string (63) w2, vsn, newvsn string (2) dd, mm, yy string (15) date, newdate byte integer name vsnbyt const string name pdate=x'80C0003F' record (srcf) name h ad=wrfilead(file) return if ad<=0 seek1="SN="""; ! e.g. VSN= or XSN=, to allow various IMP names seek2=" DATED " h==record(ad) j=ad+h_txtrelst ! PICK UP FIRST LINE INTO STRING V v="" until ch=nl cycle ch=byteinteger(j) v=v.tostring(ch) j=j+1 repeat length(v)=length(v)-1; ! DROP NEWLINE ! DOES IT CONTAIN "VSN" OR "DATED" ? upvsn=0 vsn="" newvsn="" if v->w1.(seek1).date or v->w1.(seek2).date start ! CHOP OFF QUOTE AND NEWLINE FROM DATE IF FIELD LONGER THAN 9 ! RETURN IF DATE FIELD NOT LONG ENOUGH if length(date)>=9 start if date->date.(" ").vsn and length(date)=9 and (length(vsn)=1 or c (length(vsn)=2 and vsn->vsn.(""""))) then upvsn=yes length(date)=9 finish else ->chout ! IF VERSION-DIGIT IS TO BE UPDATED, IT OCCURS AT 13TH BYTE BEYOND ! START OF DATE FIELD ! 22 DEC 99___4 ! 1234567890123 ! FORM THE NEW DATE (TODAY'S) amm1=addr(mm)+1 newdate=pdate newdate->dd.("/").mm.("/").yy j=byteinteger(amm1+1)-'0' j1=byteinteger(amm1)-'0' if j1#0 then j=j+10 newdate=dd." ".month(j)." ".yy ! RECONSTRUCT (IN STRING W1) 1ST LINE UP TO AND EXCLUDING THE DATE FIELD if v->w1.(seek1).w2 then w1=w1.seek1 else w1=w1.seek2 ! FIND POSITION OF 9-CHAR DATE FIELD IN FIRST LINE (EG. 01 JAN 76) j=ad+h_txtrelst+length(w1); ! POINTS TO POSN OF DATE IN FILE j1=0 until j1>=length(newdate) cycle byteinteger(j+j1)=byteinteger(addr(newdate)+j1+1) j1=j1+1 repeat if upvsn=yes start vsnbyt==byteinteger(j+12) if vsnbyt='9' then vsnbyt='A'-1 if vsnbyt='Z' then vsnbyt='1'-1 vsnbyt=vsnbyt+1 if date#newdate then vsnbyt='1' newvsn=" ".tostring(vsnbyt) finish printstring("LAST UPDATE ".date." ".vsn) newline printstring("NEW VERSION ".newdate.newvsn) newline finish ; ! V RESOLVES chout: ! DISCONNECT(FILE) end ; ! REDATE !----------------------------------------------------------------------------- routine kdate(integer name d, m, y, integer k) ! K IS DAYS SINCE 1ST JAN 1900 ! RETURNS D, M, Y 2 DIGIT Y ONLY ! %integer W ! K=K+693902; ! days since Cleopatras birthday ! W=4*K-1 ! Y=W//146097 ! K=W-146097*Y ! D=K//4 ! K=(4*D+3)//1461 ! D=4*D+3-1461*K ! D=(D+4)//4 ! M=(5*D-3)//153 ! D=5*D-3-153*M ! D=(D+5)//5 ! Y=K *lss_k; *iad_693902 *imy_4; *isb_1; *imdv_146097 *lss_ tos ; *idv_4; *imy_4; *iad_3 *imdv_1461; *st_(y) *lss_ tos ; *iad_4; *idv_4 *imy_5; *isb_3; *imdv_153 *st_(m); *lss_ tos *iad_5; *idv_5; *st_(d) if m<10 then m=m+3 else start m=m-9 if y=99 then y=0 else y=y+1 finish end ; ! OF KDATE integer fn day no const long integer jms= x'141DD76000' *rrtc_0 *ush_-1 *shs_1 *ush_1 *idv_jms *stuh_ b *exit_-64 end {day no} integer fn kday(integer d, m, y) if m>2 then m=m-3 else m=m+9 and y=y-1 result =1461*y//4+(153*m+2)//5+d+58 end ; ! OF KDAY !----------------------------------------------------------------------------- record format df(integer y, m, d, dayno, dayname, spoint, epoint, flags) routine sort2(record (df) array name p, integer array name x, integer num) ! DECLARE INTEGER ARRAY X, BOUNDS 1:NUM, IN CALLING ROUTINE integer i, j, hit, n cycle i=1, 1, num x(i)=i repeat cycle i=num-1, -1, 1 hit=0 cycle n=1, 1, i if p(x(n))_dayno>p(x(n+1))_dayno start j=x(n) x(n)=x(n+1) x(n+1)=j hit=1 finish repeat if hit=0 then exit repeat end {sort2} !----------------------------------------------------------------------------- external routine remind(string (255) file) const string (3) array day(0:6)="MON","TUE","WED","THU","FRI","SAT","SUN" const integer sun=6,mon=0,tue=1,wed=2,thu=3,fri=4,sat=5 integer j, k, hit, todayno, confirm, curp, lastb, ch, fad, vsn, flag, fpoint, spoint, prevch, aad, nd, len, errors, textpoint, dayname supplied const integer maxents=100 record (df) array dayrecs(1:maxents) integer array x(1:maxents) string (71) confs, ddd, dtdt string (255) s, t record (srcf) name h record (ssf) ss const integer topinter=9 own record (df) array interest(0:topinter) const string (8) array interdays(0:topinter)="TODAY","TOMORROW", "SOON"(topinter-1) const byte integer array initp(0:topinter)=0(3),1(topinter-2) own byte integer array printed(0:topinter)=0(3),1(topinter-2) record (df) today, w routine spec add1(record (df) name w) routine spec setrec3(record (df) name w, string (8) date, integer spoint, epoint, flags) string fn spec formrec(record (df) name w) routine spec writerec(record (df) name w) integer fn spec eq3(record (df) name w, y) errors=0 uctranslate(addr(file)+1, length(file)) if file=".ALL" then file="" else start ! Has reminding been set on? ss=0 vsn=1 read profile("Session", ss, vsn, flag) if flag=0 start if file=".ON" start if ss_switch=0 start ss_switch=1 write profile("Session", ss, vsn, flag) if flag#0 then printstring("Write profile flag") and write(flag, 1) and newline finish file="" finish if ss_switch=0 then return finish else return finish ! SET TODAYS'S DATE RECORD AND WORK OUT DAYOF WEEK today=0 todayno=dayno kdate(today_d, today_m, today_y, todayno) today_dayname=todayno-7*(todayno//7) printstring("Today is ".day(today_dayname)); newline today_dayno=todayno ! Now set the day records we are integerested in into array INTER interest(0)=today w=today add1(w); ! TOMORROW interest(1)=w add1(w); ! day after tomorrow if today_dayname=fri then interest(2)=w; ! this coming Sunday add1(w); ! day after tomorrow if today_dayname=fri then interest(3)=w; ! this coming Monday ! NOW GO A WEEK AHEAD, IE. 4 MORE DAYS for j=3, -1, 0 cycle ; add1(w); repeat interest(4)=w ! Two extra days if today is Friday, for the weekend after this coming one if today_dayname=fri start add1(w); interest(5)=w add1(w); interest(6)=w finish file="REMINDERS" if file="" if exist(file)=0 start printstring("No REMINDERS file") newline return finish fad=wrfilead(file) return if fad=0 h==record(fad) fpoint=h_txtrelst nd=0; ch=nl cycle exit if fpoint>=h_nextfreebyte prevch=ch unless ch=' ' ch=byteinteger(fad+fpoint) if ch='$' and prevch=nl start spoint=fpoint t=tostring('$') cycle fpoint=fpoint+1 prevch=ch ch=byteinteger(fad+fpoint) exit if ch=nl t=t.tostring(ch) repeat finish else fpoint=fpoint+1 and continue if t="$E" or t="$e" then exit s=t ! WE'RE ALLOWING (E.G.) $01/01/78 ! $01/01 ! $TUE ! $ALTERNATE MON FROM 13/07/81 (Length=28) ! $EVERY MONTH FROM 13/07/81 (Length=26) unless length(s)=4 or charno(s, 4)='/' or length(s)=28 or length(s)=26 start inv: printstring("******************Invalid line:") newline printstring(t) bel("") errors=errors+1 continue finish s->("$").s dayname supplied=0 confirm=-1 if (s->ddd.("ALTERNATE ").confs.(" FROM ").dtdt or s->dtdt.(" ").confs) and c length(confs)=3 start ! If dayname was supplied [not in "ALTERNATE" case] then mark as such, ! as the entry can be dropped when the day is passed (by a certain amount) if length(s)#28 then dayname supplied=1 {exclude the $ALTERNATE case} s=dtdt {dayname to u.c. and check for validity} uctranslate(addr(confs)+1, 3) for j=6, -1, 0 cycle if confs=day(j) then confirm=j and exit repeat if confirm<0 then ->inv finish if s->ddd.("EVERY MONTH FROM ").s start ; finish ! Find next $-line (to record length of this entry) textpoint=fpoint+1 cycle fpoint=fpoint+1 exit if fpoint>=h_nextfreebyte prevch=ch unless ch=' ' ch=byteinteger(fad+fpoint) exit if ch='$' and prevch=nl repeat ch=nl {set back for next $-line} setrec3(w, s, spoint, fpoint, dayname supplied) if confirm>=0 and confirm#w_dayname then ->inv if nd<maxents start nd=nd+1 dayrecs(nd)=w ! Things earlier than a week ago, move to back of file (add 366 days) if w_dayno<todayno-7 start dayrecs(nd)_dayno=dayrecs(nd)_dayno+366 dayrecs(nd)_flags=dayrecs(nd)_flags!2 finish finish j=0 while j<=topinter cycle hit=eq3(interest(j), w) if hit#0 then exit j=j+1 repeat if hit#0 start k=j k=2 if k>2 if printed(k)=0 start printed(k)=1 printstring("------ ") printstring(interdays(j)) printstring(" ------") newline finish writerec(interest(j)) ! PRINT UP TO NEXT $ LINE spoint=textpoint cycle spoint=spoint+1 j=byteinteger(fad+spoint) printsymbol(j) exit if spoint=fpoint-1 repeat finish repeat ! For re-usability for j=topinter, -1, 0 cycle printed(j)=initp(j) repeat !%for j=1, 1, nd %cycle ! writerec(dayrecs(j)) !%repeat return if errors>0 ! Next order file according to dayno. begin byte integer array copyarr(1:h_nextfreebyte) curp=fad+h_txtrelst lastb=fad+h_nextfreebyte fpoint=curp sort2(dayrecs, x, nd) aad=addr(copyarr(1)) move(lastb-fad, fad, aad) for k=1, 1, nd cycle w=dayrecs(x(k)) spoint=w_spoint ! Skip spaces at line-start (of date-line, preceding '$') len=w_epoint-spoint len=len-1 while byteinteger(aad+spoint+len-1)=' ' if w_flags=3 start printstring("Item discarded: ") writerec(w) for j=aad+spoint, 1, aad+spoint+len-1 cycle printsymbol(byteinteger(j)) repeat finish else start move(len, aad+spoint, fpoint) fpoint=fpoint+len finish repeat h_nextfreebyte=fpoint-fad end {begin-block} ! Now update any "$ALTERNATE" lines in the REMINDERS file if necessary cycle j=locate("$ALTERNATE ", curp, lastb) exit if j<=0 s="" {get rest of line} until ch=nl cycle curp=curp+1 ch=byteinteger(curp) s=s.tostring(ch) repeat s->ddd.(" FROM ").dtdt {must have " FROM "} setrec3(w, dtdt, -1, 0, 0) {set _d, _m, _y in record w} if todayno>w_dayno start ! update the date field by 14 days kdate(w_d, w_m, w_y, w_dayno+14) {set _d, _m, _y from _dayno+14} s=formrec(w) length(s)=length(s)-4 cycle j=1, 1, 8 {place in file} byteinteger(curp-9+j)=charno(s, j) repeat finish repeat ! Update any "$EVERY MONTH FROM " lines in the REMINDERS file if necessary curp=fad+h_txtrelst lastb=fad+h_nextfreebyte cycle j=locate("$EVERY MONTH FROM ", curp, lastb) exit if j<=0 curp=curp+17 {length of "$EV.. from "} s="" {get rest of line after "$EV.. FROM "} until ch=nl cycle curp=curp+1 ch=byteinteger(curp) s=s.tostring(ch) repeat dtdt=s length(dtdt)=length(dtdt)-1 {remove nl} setrec3(w, dtdt, -1, 0, 0) {set _d, _m, _y in record w} if todayno>w_dayno start ! update the date field by 1 month w_m=w_m+1 if w_m>12 then w_m=1 and w_y=w_y+1 s=formrec(w) length(s)=length(s)-4 cycle j=1, 1, 8 {place in file} byteinteger(curp-9+j)=charno(s, j) repeat finish repeat disconnect(file, j) return routine add1(record (df) name w) w_dayno=w_dayno+1 kdate(w_d, w_m, w_y, w_dayno) w_dayname=w_dayname+1 if w_dayname>6 then w_dayname=0 end ; ! ADD1 routine setrec3(record (df) name w, string (8) dat, integer spoint, epoint, flags) integer dno, j ! IF DATE COMPRISES ONLY DAY+MONTH, ADD ON CURRENT YEAR if length(dat)=5 then dat=dat.fromstr(date, 6, 8) ! IF IT COMPRISES JUST ONE DAY-OF-WEEK, EXPAND TO NEXT DATE ! BEING THAT DAY. if length(dat)=3 start for j=6, -1, 0 cycle if day(j)=dat then dno=j and exit repeat w=today add1(w) while w_dayname#dno return finish w=0 w_y=bin(fromstr(dat, 7, 8)) w_m=bin(fromstr(dat, 4, 5)) w_d=bin(fromstr(dat, 1, 2)) w_dayno=kday(w_d, w_m, w_y) w_dayname=w_dayno-7*(w_dayno//7) w_spoint=spoint and w_epoint=epoint if spoint>0 w_flags=flags end ; ! SETREC3 integer fn eq3(record (df) name w, y) if w_y=y_y and w_m=y_m and w_d=y_d then result =1 result =0 end ; ! EQ3 string fn formrec(record (df) name w) string (3) dd, mm string (255) s result ="" if w_y=0 dd=itos(w_d) if length(dd)=1 then dd="0".dd mm=itos(w_m) if length(mm)=1 then mm="0".mm s=dd."/".mm."/".itos(w_y)." ".day(w_dayname) ! s=s." ".htos(w_spoint, 8)." ".htos(w_epoint,8) result =s end ; ! FORMREC routine writerec(record (df) name w) printstring(formrec(w)) newline end ; ! WRITEREC end ; ! REMIND !----------------------------------------------------------------------------- external routine dq(string (255) s) routine spec trestore(string (255) s) routine spec eh integer j, n, arch, ch, nd, itw, col, npl, nexc, jj, kk, dupl string (79) a, b, code, res, promptstring, rest1, rest2, fname const integer topa=511 string (29) array aa, dd, exclatest(0:topa) string fn spec valid(integer ch) on event 9 start ; ->eof; finish nd=0 arch=0 if s->a.(",").b start if a->a.(",").b or b->a.(",").b then ->bp code="" j=0 while j<length(b) cycle j=j+1 ch=charno(b, j) res=valid(ch) if res="Invalid" then ->bp if res="A" then arch=1 code=code.res repeat ! Disallow online & archive together if arch#0 and length(code)>1 start printstring("Not online and archive files together") newline ->bp finish finish else s=s."," if arch=0 then s=s."S" files(s.",T#DQ") define("ST13,T#DQ") selectinput(13) n=0 cycle if n>=topa start printstring("First"); write(topa, 1) printstring(" files being processed") newline exit finish rstrg(s) if arch#0 and s->a.("Archived files").b then continue aa(n)=s n=n+1 repeat eof:selectinput(0) close stream(13) clear("13") if arch#0 then list("T#DQ") else start itw=uinfi(15) {itwidth} npl=itw//13 {names per line. max name len=13} col=0 j=0 while j<n cycle printstring(aa(j)) spaces(13-length(aa(j))) col=col+1 if col>=npl or j=n-1 then newline and col=0 j=j+1 repeat newline finish if arch=0 then promptstring="Y/N/.End:" nexc=0 {count of those to be discarded "all except latest"} j=0 while j<n cycle s=aa(j) s=s." " while length(s)<11 s->fname.(" ").rest2 ! See if next name appears in "All except latest" array,and if so, skip over it ! Use dupl as indicator: nonzero if to skip over. NEXC can be non-zero only for archived files dupl=0 kk=0 while kk<nexc cycle if fname=exclatest(kk) then dupl=1 and exit kk=kk+1 repeat if s#"" and dupl=0 start {ignore nullified entries} s=s." " while length(s)<11 if arch#0 start ! Whip through to end to see if there are others of same name and choose prompt accordingly promptstring="" dupl=0 s->fname.(" ").rest2 kk=j+1 while kk<n cycle if aa(kk)->rest1.(fname." ").rest2 and rest1="" start ! occurred again promptstring="Y/N/Allexceptlatest/Restore/.E:" dupl=1 exit finish kk=kk+1 repeat promptstring="Y/N/Restore/.End:" if promptstring="" printstring(s) terminate s="" finish prompt(s." Destroy? ".promptstring) ucstrg(s) exit if fromstr(s, 1, 2)=".E" return if fromstr(s, 1, 2)=".Q" ch=charno(s, 1) s=aa(j) if arch=0 start s=a.b while s->a.("*").b s=a.b while s->a.(" ").b if ch='Y' then destroy(s) else if ch#'N' then eh finish else start ! Archive files if (dupl#0 and ch='A') start ! Remember name in array exclatest(nexc)=fname nexc=nexc+1 finish else if ch='R' then trestore(s) else if ch='Y' start dd(nd)=s nd=nd+1 finish else if ch#'N' then eh finish finish j=j+1 repeat if arch#0 start ! Remove all "All except latest" names from DD. Then go back through AA ! and put first occurrence of each name back into DD. There always must ! be an occurrence of each of these names, and the first occurrence must ! be the latest-archived. kk=0 while kk<nexc cycle fname=exclatest(kk) {printstring("Except latest entry:".fname); newline jj=0 while jj<nd cycle if dd(jj)->rest1.(fname." ").rest2 and rest1="" start {printstring("DD entry delted:".dd(jj)); newline dd(jj)="" finish jj=jj+1 repeat dupl=0 {indicator set nonzero at first occurrence of fname} jj=0 while jj<n cycle if aa(jj)->rest1.(fname." ").rest2 and rest1="" start if dupl#0 start {printstring("Added DD entry:".aa(jj)); newline dd(nd)=aa(jj) nd=nd+1 finish dupl=1 finish jj=jj+1 repeat kk=kk+1 repeat define("ST35,T#DQ2") select output(35) {printstring("Discard list:");newline j=0 while j<nd cycle if dd(j)#"" start printstring(dd(j)); newline finish j=j+1 repeat select output(0) close stream(35) clear("") discard("T#DQ2") finish return bp:printstring("Bad param ") return string fn valid(integer ch) const integer topch=4 const byte integer array v(0:topch)='I','C','H','S','A' integer j if ch='P' or ch='E' then result ="" for j=topch, -1, 0 cycle if ch=v(j) then result =tostring(ch) repeat result ="Invalid" end ; ! VALID routine trestore(string (255) s) integer j string (255) aa, bb s=aa." ".bb while s->aa.(" ").bb j=0 while j<length(s) cycle j=j+1 if charno(s, j)=' ' then charno(s, j)=',' and exit repeat j=length(s) while j>0 cycle if charno(s, j)=' ' then length(s)=j-1 and exit j=j-1 repeat printstring("Restore ".s); newline restore(s) end ; ! TRESTORE routine eh printstring("Eh ??") newline end ; ! EH end ; ! DQ !----------------------------------------------------------------------------- external routine pdli(string (255) pdname) string (79) dest, subfname integer j, n, k, jj n=255 record (rf) array r(0:n) dest=".OUT" if pdname->pdname.(",").dest start ; finish if pdname="" start prompt("Pdfile: ") and rstrg(pdname) prompt("to file/dev: ") ucstrg(dest) finish dest=",".dest j=pdmems(pdname, n, r) return if j#0 jj=0 while jj<n cycle subfname=pdname."_".r(jj)_mem if dest=",.OUT" start newline k=length(subfname); k=k+1 if k&1=0 j=0 j=j+1 and printsymbol('-') while j<k printstring(subfname) j=0 j=j+1 and printsymbol('-') while j<k newlines(2) finish list(subfname.dest) if r(jj)_type=3; ! Character jj=jj+1 repeat end ; ! PDLI !----------------------------------------------------------------------------- routine pdparams(string (255) s, integer action) string (19) pd, memprompt string (255) tt, aa, mem, pdmem integer j, memex, filex, prompted, query switch pdact(1:5) integer fn spec getfil(string name file, string (15) prom, integer getact) routine spec px(string name file, integer which, ex) integer fn spec tconfirm routine spec tdestroy(string (255) s) routine spec trename(string (255) s) routine spec tcopy(string (255) s) const integer fil=0, memb=1 const integer not ex=0, ex=1 const integer part=6 const integer must e= 0, must not e = 1, dont care = -1 const string (1) snl=" " if action=5 then memprompt="Rename mem: " else memprompt="Member: " query=0 pd=""; mem="" prompted=-1 cycle tt=separate(s) return if prompted=0 and s="" prompted=0 if prompted<0 if tt#"" and prompted#0 then query=1 if tt->aa.("_").mem start if aa#"" and filetype(aa)=part then pd=aa else pd="" finish else start if pd="" and tt#"" and filetype(tt)=part then pd=tt else mem=tt finish ! j=getfil(pd, "PDfile: ", 1) return if j=0 ! j=getfil(mem, memprompt, 0) return if j=0 ! pdmem=pd."_".mem memex=exist(pd."_".mem) filex=exist(mem) ! ->pdact(action) pdact(1): ! insert if filex=0 then px(mem, fil, not ex) else if memex#0 then px(mem, memb, ex) else c tcopy(mem.",".pdmem) disconnect(mem, j) continue pdact(2): ! replace if filex=0 then px(mem, fil, not ex) else if memex=0 then px(mem, memb, not ex) else c tcopy(mem.",".pd."_".mem) disconnect(mem, j) continue pdact(3): ! Tdestroy if memex=0 then px(mem, memb, not ex) else tdestroy(pd."_".mem) continue pdact(4): ! extract if memex=0 then px(mem, memb, not ex) else if filex#0 then px(mem, fil, ex) else c tcopy(pdmem.",".mem) continue pdact(5): ! rename tt=separate(s) s="" next=-1 if memex=0 then px(mem, memb, not ex) else start j=getfil(tt, "To mem: ", 0) return if j=0 if exist(pd."_".tt)#0 then px(tt, memb, ex) else trename(pdmem.",".pd."_".tt) finish repeat integer fn getfil(string name file, string (15) prom, integer getact) integer msg msg=0 cycle if getact=0 start result =1 if file#"" ! %if EXIST(FILE)#0 %then %result=1 %else %if MSG#0 %then %c ! PRINTSTRING(FILE." does not exist".SNL) finish else start if file#"" and filetype(file)=part then result =1 else if msg#0 then c printstring(file." does not exist or is not partitioned") and newline finish prompted=1 s="" next=-1 prompt(prom) ucstrg(file) result =0 if charno(file, 1)='.' msg=1 repeat end ; ! GETFIL integer fn tconfirm string (79) s if query=0 then result =1 prompt("Confirm(Y/N): ") rstrg(s) and charno(s, 1)=charno(s, 1)&(¬32) until charno(s, 1)='Y' or charno(s, 1)='N' if charno(s, 1)='Y' then result =1 result =0 end ; ! TCONFIRM routine tdestroy(string (255) s) printstring("DESTROY(".s.")"); newline if tconfirm#0 start destroy(s) printstring("Done") finish else printstring("Abandoned") newline end ; ! TDESTROY routine trename(string (255) s) printstring("RENAME(".s.")"); newline if tconfirm#0 start rename(s) printstring("done") finish else printstring("Abandoned") newline end ; ! TRENAME routine tcopy(string (255) s) printstring("COPY(".s.")"); newline if tconfirm#0 start copy(s) printstring("done") finish else printstring("Abandoned") newline end ; ! TCOPY routine px(string name file, integer which, ex) if which=fil then printstring("File ") else printstring("Member ") printstring(file) if ex=0 then printstring(" does not exist") else printstring(" already exists") newline file="" prompted=1 end ; ! PX end ; ! PDPARAMS !----------------------------------------------------------------------------- external routine pdins(string (255) s) pdparams(s, 1) end ; ! PDINS external routine pdrep(string (255) s) pdparams(s, 2) end ; ! PDREP external routine pddes(string (255) s) pdparams(s, 3) end ; ! PDDES external routine pddel(string (255) s) pdparams(s, 3) end ; ! PDDEL external routine pdext(string (255) s) pdparams(s, 4) end ; ! PDEXT external routine pdren(string (255) s) pdparams(s, 5) end ; ! PDREN external routine addnp(string (255) s) integer j, firstb, lastb, fad, front, back, pars given string (255) pars record (srcf) name h if s="?" start printstring("Params are: filename, codes") newline printstring("where codes is F(ront, B(ack, FB(front & back, or N(either") newline return finish pars given=no; front=no; back=no if s->s.(",").pars then pars given=yes fad=wrfilead(s) return if fad=0 if pars given=yes start prompt("F(ront, B(ack, FB or N(either: ") cycle if pars="F" then front=yes and exit if pars="B" then back=yes and exit if pars="FB" then front=yes and back=yes and exit if pars="N" then exit ucstrg(pars) repeat finish else front=yes and back=yes h==record(fad) firstb=fad+h_txtrelst lastb=fad+h_nextfreebyte if front=no and (byteinteger(firstb)=x'0C' or byteinteger(firstb+1)=x'0C') start if byteinteger(firstb)=x'0C' then j=firstb else j=firstb+1 move(lastb-firstb-1, j+1, j) h_nextfreebyte=h_nextfreebyte-1 finish if front=yes start unless (byteinteger(firstb)=np or byteinteger(firstb+1)=np) start if h_nextfreebyte&x'FFF'=0 start printstring("Bad luck") newline finish else start move(lastb-firstb, firstb, firstb+1) byteinteger(firstb)=x'0C' h_nextfreebyte=h_nextfreebyte+1 finish finish finish lastb=fad+h_nextfreebyte if back=yes and byteinteger(lastb-1)#x'0C'#byteinteger(lastb-2) and lastb&x'FFF'#0 start byteinteger(lastb)=x'0C' h_nextfreebyte=h_nextfreebyte+1 finish if back=no and (byteinteger(lastb-1)=np or byteinteger(lastb-2)=np) start if byteinteger(lastb-1)=np then j=1 else j=2 h_nextfreebyte=h_nextfreebyte-j finish end ; ! ADDNP external routine de space(string name s) ! Replaces multiple spaces in S with single spaces. Removes leading and ! trailing spaces. string (255) a, b s=a." ".b while s->a.(" ").b if length(s)>1 and charno(s, length(s))=' ' then length(s)=length(s)-1 if length(s)>1 and charno(s, 1)=' ' then s=substring(s, 2, length(s)) end ; ! de space end of file