! Dated 01 May 84
!
const integer yes=1, no=0
const integer np=x'0C' {nepwage code}
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)
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 define(string (63) s)
external routine spec clear(string (63) s)
! %externalroutinespec COPY(%string(63) S)
external routine spec cherish(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)
!
!
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
!
external routine spec dump(integer a, b, c, d)
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 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 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 obey(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)
!
include "ERCC10.SERPRGS_UINF"
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):ibmimp(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, "Y", ibmimp, 4)
end ; ! IBM80
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 im, flag, vsn, updated
string (9) sdate
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
im=bin(fromstr(date, 4, 5))
sdate=fromstr(date, 1, 2).month(im)
if ss_date#sdate start
ss_sessno=0
ss_date=sdate
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".ss_date.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, j, len, 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, value, len)
integer j, k, av
av=addr(value)+3; k=0
for j=len-1, -1, 0 cycle
byteinteger(adr+j)=byteinteger(av-k)
k=k+1
repeat
end ; ! SET VALUE
!
!-----------------------------------------------------------------------------
!
routine sbytes(string (255) file, integer len)
integer start, j, value
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
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)
set value(start, value, 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
!-------------------------------------------------------------------------------
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=halfinteger(curp+4)<<16!halfinteger(curp+6)
if j=it1 then result =curp
!
! Otherwise, go backwards for up to a page (say), or until an instruction
! setting RH is met, to see if 2(BASEREG) is set to LH.
!
back=curp
cycle
back=back-2
j=halfinteger(back)<<16!halfinteger(back+2)
!
! Exit if this instruction changes RH.
if j&x'FF000FFF'=imask1 and j&x'00FF0000'#rh1 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
record (objf) name h
string (31) file, sl1, sl2, devs
integer line1, line2, fad, relst, ad1, ad2, err, j, 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
!--------------------------------------------------------------
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
printstring("Line")
write(line1, 1)
spaces(2)
printstring(htos(line1, 5))
if ad1=0 then printstring(" not")
printstring(" found")
newline
!------------------------------------------------------------------------
offx=0
sign=1
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
printstring("Line")
write(line2, 1)
spaces(2)
printstring(htos(line2, 5))
if ad2=0 then printstring(" not")
printstring(" found")
newlines(3)
if ad1=0=ad2 then return else start
if ad1=0 then ad1=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)
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
external routine ibm lines(string (255) s)
find lines(ibmlinead, ibmrecode, s)
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="SS#KLP"
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="SS#KLP" 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)
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 CHAR 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
!
!-----------------------------------------------------------------------------
!
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:255)
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:255)
record (pdsdirf) array name d
!
! FOR THE ALPHA SORT
integer array x(1:255)
!
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 ->next master
type=filetype(master)
printstring(master); newline
if type=char start
goon=0
j=ftextf(pad, goon, text)
if j#0 start
printstring("Found
")
result =0
finish
printstring("Not found
")
->nextmaster
finish
h==record(pad)
unless h_type6=6 start
! TYPE IS 13 FOR PDFILE, ALTHOUGH TYPE RETURNED BY RT
! CONMEMBER IS 6.
printstring(master." IS NOT PARTIONED OR CHAR
")
->nextmaster
finish
if h_filecount>255 start
printstring("TOO MANY FILES FOR TSEARCH
")
->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
nextmaster:
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
!
!-----------------------------------------------------------------------------
!
external routine pdcheck(string (79) master)
string (31) array dess(0:39)
string (31) array reps(0:39)
string (31) array for disconn(0:25)
integer dpt, rpt, nf, rubbish, curroutstream
switch mp(0:6)
routine spec make file
routine spec enter(integer type, string (17) s)
routine spec printnot
routine spec mulsym(integer sym, mul)
routine spec head(string (71) s)
const integer destr=53, repla=54
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
!
! FOR THE ALPHA SORT
integer array x(1:255)
!
integer pad, fc, mtype, f1, f2, diff
curroutstream=comreg(23)
output=""
if master->master.("/").output start
define("ST54,".output)
select output(54)
finish
define("ST52,SS#DESRP")
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
")
->next master
finish
length(memfile owner)=length(memfile owner)-1
finish
pad=rdfilead(master)
if pad=0 then ->nextmaster
h==record(pad)
unless h_type6=6 start
printstring(master." IS NOT A PARTIONED FILE
")
->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
")
->nextmaster
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
! 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
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
nextmaster:
! CLEARVM
repeat
!-----------------------------------------------------------------
if output#"" start
select output(curroutstream); close stream(54)
clear("54")
finish
make file
newlines(4)
printstring("ANALYSIS COMPLETE
")
return
routine make file
integer j, perl
select output(52)
j=0; perl=0
while j<dpt cycle
printstring(dess(j))
if perl>=4 start
perl=0
newline
finish else start
perl=perl+1
printsymbol(',')
finish
j=j+1
repeat
printstring("
.END
")
j=0; perl=0
while j<rpt cycle
printstring(reps(j))
if perl>=2 start
perl=0
newline
finish else start
perl=perl+1
printsymbol(',')
finish
j=j+1
repeat
printstring("
.END
")
select output(curroutstream)
close stream(52)
clear("52")
end ; ! MAKE FILE
routine enter(integer type, string (17) file)
if type=destr start
return if dpt>39
dess(dpt)=file
dpt=dpt+1
finish else start
return if rpt>39
reps(rpt)=file
rpt=rpt+1
finish
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)
routine spec do ip(integer strm)
const integer destr=51, repla=52
own integer one=1
integer j
string (31) s
next=-1
define("ST51,SS#DESRP")
define("ST53,SS#DETAC")
prompt("YN: ")
printstring("
:::DESTROY:::
")
do ip(51)
printstring("
:::REPLACE:::
")
do ip(51)
close stream(51)
close stream(53)
clear("51,53")
printstring("
:::DETACH FILE:::
")
list("SS#DETAC")
newlines(2)
prompt("DETACH/OBEY: ")
until s="Q" or 0<j<=40 or s="OBEY" cycle
ucstrg(s)
j=bin(s)
repeat
if s="Q" then return
if s="OBEY" start
prompt(".LP/.OUT: ")
ucstrg(s) until s=".OUT" or fromstr(s, 1, 3)=".LP"
s=",".s
s="" if s=",.OUT"
obey("SS#DETAC".s)
return
finish
detach("SS#DETAC,".s)
return
routine do ip(integer strm)
string (17) array files(0:7)
integer array yns(0:7)
string (63) s, cur
string (19) prist, mas
integer ok, pt, j, ch, perline
if one=1 then prist="DESTROY " else prist="REPLACE "
one=one+1
select input(strm); ucstrg(s); select input(0)
while s#".END" cycle ; ! LINES OF FILES
redo:
cur=s; perline=0; printstring(cur."
")
while separate(cur)#"" cycle
! FULL NAME FOR REPLACE ELSE MEM NAME
if strm=repla then cur->mas.("_").cur
files(perline)=cur
perline=perline+1
repeat
ok=1; pt=0
until ch=nl cycle ; ! TT INPUT
readsymbol(ch)
unless ch='Y' or ch='N' or ch=' ' or ch=nl then ok=0
if ch='Y' then yns(pt)=1 and pt=pt+1
if ch='N' then yns(pt)=0 and pt=pt+1
repeat ; ! TT INPUT
if ok=0 or pt#perline then ->redo
select output(53); j=0
while j<pt cycle ; ! FILE OUTPUT
if yns(j)#0 then printstring(prist.files(j)."
")
j=j+1
repeat
select output(0)
select input(strm); rstrg(s); select input(0)
repeat ; ! LINES OF FILES
end ; ! DO IP
one=1
close stream(51)
close stream(53)
clear("51,53")
printstring("
:::DETACH FILE:::
")
list("SS#DETAC")
prompt("DETACH: ")
until s="NOW" or s="Q" or 0<j<=40 cycle
ucstrg(s)
j=bin(s)
repeat
if s="Q" then return
detach("SS#DETAC,".s)
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
!
!-----------------------------------------------------------------------------
!
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
string (71) confs, ddd, dtdt
string (255) s, t
record (srcf) name h
record (ssf) ss
record format df(integer y, m, d, dayno, dayname)
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)
string fn spec formrec(record (df) name w)
routine spec writerec(record (df) name w)
integer fn spec eq3(record (df) name w, y)
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
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
define("1,".file)
select input(1)
cycle
rstrg(t) until charno(t, 1)='$'
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:")
printstring(t)
bel("")
continue
finish
s->("$").s
confirm=-1
if (s->ddd.("ALTERNATE ").confs.(" FROM ").dtdt or s->dtdt.(" ").confs) and c
length(confs)=3 start
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
setrec3(w, s)
if confirm>=0 and confirm#w_dayname then ->inv
! PRINTSTRING("INPUT LINE: ")
! WRITEREC(W)
cycle j=0, 1, topinter
hit=eq3(interest(j), w)
if hit#0 then exit
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
while nextsymbol#'$' cycle
rstrg(s)
printstring(s); newline
repeat
finish
repeat
select input(0)
close stream(1)
clear("1")
! For re-usability
for j=topinter, -1, 0 cycle
printed(j)=initp(j)
repeat
! Update any "$ALTERNATE" lines in the REMINDERS file if necessary
fad=wrfilead(file)
return if fad=0
h==record(fad)
curp=fad+h_txtrelst
lastb=fad+h_nextfreebyte
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) {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) {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 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_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)
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)
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
string (79) a, b, code, res, promptstring
const integer topa=511
string (29) array aa, dd(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
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="Yes/No/Restore/.End:" else promptstring="Y/N/.End:"
j=0
while j<n cycle
s=aa(j)
s=s." " while length(s)<11
if arch#0 then printstring(s) and terminate and s=""
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
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
j=j+1
repeat
if arch#0 start
define("ST35,T#DQ2")
select output(35)
j=0
while j<nd cycle
printstring(dd(j)); newline
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 ; ! DEQ
!
!-----------------------------------------------------------------------------
!
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 ; ! DEQ
!
!-----------------------------------------------------------------------------
!
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
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