! Dated 24 Jan 85
!
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 integer fn spec uinfi(integer i)
external string fn spec itos alias "S#ITOS"(integer i)
external string fn spec htos alias "S#HTOS"(integer i, pl)
external routine spec uctranslate alias "S#UCTRANSLATE"(integer adr, len)
external string fn spec ucstring(string (255) s)
external string fn spec failure message alias "S#FAILUREMESSAGE"(integer i)
external integer map spec comreg alias "S#COMREG"(integer i)
routine spec rstrg(string name s)
external string fn spec uinfs(integer i)
record format parmf(integer dest, srce, p1, p2, p3, p4, p5, p6)
external routine spec dpoff(record (parmf) name p)
external integer fn spec dpermission(string (6) owner, user, string (8) date,
string (15) file, integer fsys, type, adrprm)
external integer fn spec dsfi(string (6) user, integer fsys, type, set, adr)
external string fn spec derrs(integer i)
external integer fn spec dfinfo(string (6) user, string (15) file, integer fsys, adr)
external routine spec ddelay(integer seconds)
external routine spec phex alias "S#PHEX"(integer i)
external routine spec move alias "S#MOVE"(integer len, from, to)
external routine spec etoi alias "S#ETOI"(integer ad, len)
record format dfinfrecf(integer nkb, rup, eep, apf, use, arch, fsys, conseg, cct, codes,
byte integer sp1, sp2, pool, codes2, integer ssbyte, string (6) offer)
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)
external routine spec finfo alias "S#FINFO"(string (31) s, integer mode,
record (finfrecf) name r, integer name flag)
external integer fn spec exist(string (63) file)
external routine spec ncode alias "S#NCODE"(integer s, f, ff)
external routine spec disconnect alias "S#DISCONNECT"(string (31) s, integer name f)
external routine spec prompt(string (15) s)
external routine spec clear(string (63) s)
external routine spec define(string (63) s)
external routine spec detach(string (255) s)
external routine spec hazard(string (255) s)
external routine spec outfile alias "S#OUTFILE"(string (31) s, integer length, maxbytes,
prot, integer name conad, flag)
record format conrecf(integer conad, filetype, relst, relend)
external routine spec connect alias "S#CONNECT"(string (31) s, integer acc, maxb, prot,
record (conrecf) name r, integer name flag)
record format srcf(integer nextfreebyte, txtrelst, maxlen, zero)
const string name date=x'80C0003F', time=x'80C0004B'
external string fn fromstr(string (255) s, integer i, j)
unless 0<i<=j and j<=length(s)>0 then result =""
if i>1 then charno(s, i-1)=j-i+1 else length(s)=j-i+1
result =string(addr(s)+i-1)
end ; ! FROMSTR
!--------------------------------------------------------------------------------
external integer fn val(integer adr, len, rw{set 0 for read, 1 for write}, psr)
! Result = 1 area OK (accessible)
! 0 area not OK (inaccessible)
! RW should be set 0 (to test for read access)
! or 1 (to test for write access)
!
! Parameter PSR is used in the VALIDATE, but if zero, the PSR HERE (or rather
! of the calling routine) is used.
integer inseg0, beyond seg0, seg0, seg0 ad
integer dr0
const integer write=1
seg0=adr>>18
result =0 if len<=0
if psr=0 start ; *lss_(lnb +1); *st_psr; finish
if seg0#(adr+len-1)>>18 start
seg0 ad=seg0<<18
inseg0=x'40000'-(adr-seg0 ad)
beyond seg0=len-inseg0
result =val(adr, inseg0, rw, psr)&val(adr+inseg0, beyond seg0, rw, psr)
finish
! WE SHOULD ALSO CHECK THAT THE AREA LIES WITHIN USER SEGMENTS, AND
! NOT IN ANY HIGHER ACR SEGMENTS AS WELL.
dr0=x'18000000'!len
*ldtb_dr0
*lda_adr
*val_psr
*jcc_8, <cczer>
*jcc_4, <ccone>
*jcc_2, <cctwo>
! THEN CC=3, INVALID
result =0
cczer: ! READ AND WRITE PERMITTED
result =1; ! OK
ccone: ! READ, BUT NOT WRITE, PERMITTED
if rw=write then result =0; ! BAD
result =1; ! OK
cctwo: ! WRITE, BUT NOT READ, PERMITTED
result =0; ! BAD
end ; ! VAL
external routine uderrs(integer n)
printstring("FLAG =")
printstring(derrs(n))
newline
end ; ! UDERRS
!--------------------------------------------------------------------------------
external routine connflag(string (63) s, integer flag)
! Prints an error message for a failure of the CONNECT routine.
integer currst
if flag=0 then return
currst=comreg(23) {save current output stream number}
select output(0)
printstring(s.": CONNECT FLAG =")
write(flag, 1)
printstring(" ".failure message(flag))
select output(currst)
end ; ! CONNFLAG
integer fn fpages(string (255) file)
record (dfinfrecf) x
integer j, owner given
string (63) user, wk
j=0
file=ucstring(file)
user=""
if file->user.(".").file start
j=8 unless (length(user)=6 or length(user)=0) and 0<length(file)<=11
finish
owner given=1
if user="" then user=uinfs(1) and owner given=0
if file->("T#").wk then file=file.tostring(uinfi(13)+'0')
x=0
j=dfinfo(user, file, -1, addr(x)) if j=0
if j#0 start
printstring("FPAGES fails"); write(j, 1)
printstring(" for file ".user.".") if owner given#0
printstring(file)
newline
result =0
finish
result =x_nkb>>2
end {fpages}
external integer fn nwfilead(string (15) s, integer pgs)
integer i, flag, curr
flag=1
if 0<length(s)<=15 then outfile(s, pgs<<12, x'40000', 0, i, flag)
if flag#0 start
curr=comreg(23)
select output(0)
printstring("OUTFILE FLAG =")
write(flag, 1)
printstring(" ".failure message(flag))
i=0
select output(curr)
finish
result =i
end ; ! NWFILEAD
external integer fn tpfilead(string (15) s, integer pgs)
! SAME AS NWFILEAD, BUT SETS NEXT TO TOP BIT IN "PROTECT", THUS
! FORMING A FILE MARKED "TEMPFI"
integer i, flag, curr
flag=1
if 0<length(s)<=15 then outfile(s, pgs<<12, x'40000', x'40000000', i, flag)
if flag#0 start
curr=comreg(23)
select output(0)
printstring("OUTFILE FLAG =")
write(flag, 1)
if flag>9 then flag=flag-6; ! 16-24 -> 10-18
if flag+6=49 then flag=19
printstring(" ".failure message(flag))
i=0
select output(curr)
finish
result =i
end ; ! TPFILEAD
integer fn shortcfn(string name s)
!
! CHECK FILE NAME - 1-11 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
external integer fn rdfilead(string (63) s)
record (conrecf) r
integer i, flag
! CONNECT IN A SUITABLE MODE
flag=1
r=0
if 0<length(s)<=31 then connect(s, 0, x'40000', 0, r, flag)
connflag(s, flag)
i=r_conad
i=0 if flag#0
result =i
end ; ! RDFILEAD
external integer fn wrfilead(string (31) s)
record (conrecf) r
integer i, flag
! CONNECT IN WRITE MODE
flag=1
r=0
if 0<length(s)<=31 then connect(s, 3, x'40000', 0, r, flag)
connflag(s, flag)
i=r_conad
i=0 if flag#0
result =i
end ; ! WRFILEAD
!--------------------------------------------------------------------------------
external routine copf(string (71) s)
integer j, sizebytes
record (finfrecf) r
string (63) file1, file2
integer fromad, toad, flag
unless length(s)>0 and s->file1.(",").file2 and 0<length(file1)<=31 and c
0<length(file2)<=31 then ->bad
fromad=rdfilead(file1)
return if fromad<=0
finfo(file1, 0, r, flag)
monitor if flag#0
sizebytes=r_size
toad=nwfilead(file2, (sizebytes+x'FFF')>>12)
return if toad<=0
move(sizebytes, fromad, toad)
disconnect(file2, j)
return
bad:
printstring("Params should be INFILE,OUTFILE
")
end ; ! COPF
integer fn spec hxstobin(string (29) s)
!
external integer fn bin(string (255) s)
! RESULT IS VALUE REPRESENTED BY THE STRING PARAM
! ERROR RESULT IS X80308030 (BAD CHAR IN STRING OR BAD
! LENGTH)
integer i, q, l, as, ch, sign
string (255) a, b
sign=1
while s->a.(" ").b and a="" cycle ; s=b; repeat
if s->a.("-").b and a="" then sign=-1 and s=b
while s->a.(" ").b and a="" cycle ; s=b; repeat
if (s->a.("X").b or s->a.("x").b) and a="" start
s=b
i=hxstobin(s)
if i#x'80308030' then i=i*sign
result =i
finish
as=addr(s)
l=length(s)
result =x'80308030' if l=0
i=0
cycle q=1, 1, l
ch=byteinteger(as+q)
result =x'80308030' unless '0'<=ch<='9'
i=10*i+ch-48
repeat
result =i*sign
end ; ! BIN
external routine nrstrg(string name s)
! READS NEXT LINE FROM CURRENT INPUT STREAM, SETTING S TO BE CONTENTS
! OF THE LINE WITHOUT THE NEWLINE.
integer i
s=""
cycle
readsymbol(i)
exit if i=nl
s=s.tostring(i)
repeat
end ; ! nrstrg
!--------------------------------------------------------------------------------
external routine rstrg(string name s)
nrstrg(s) until s#""
end ; ! RSTRG
external routine ucstrg(string name s)
rstrg(s)
uctranslate(addr(s)+1, length(s))
end ; ! ucstrg
routine ucnstrg(string name s)
nrstrg(s)
s=ucstring(s)
end {ucnstrg}
external integer fn hxstobin(string (29) s)
! RESULT IS VALUE REPRESENTED BY UP TO 8 HEX DIGITS IN THE PARAM.
! ERROR RESULT IS X80308030
integer i, q, l, as, ch
as=addr(s)
l=length(s)
result =x'80308030' if l>8 or l=0
i=0
cycle q=1, 1, l
ch=byteinteger(as+q)
result =x'80308030' unless '0'<=ch<='9' or 'A'<=ch<='F'
if ch>'9' then ch=ch-55 else ch=ch-48
i=i<<4!ch
repeat
result =i
end ; ! HXSTOBIN
external integer fn rdints(string (255) s)
! READS NEXT UNSIGNED DEC NO. OR HEX NO. (NOT X80308030).
own string (15) array ns(1:10)=""(10)
string (1) t
string (255) rest, rest2
integer i
own integer np=0,nl=0
if s#"" then ->nonnull start
if np>=nl then start
reset:
ucstrg(s)
nonnull start:
np=0; nl=0
while s->rest.(" ").rest2 and rest="" cycle ; s=rest2; repeat
while s->ns(nl+1).(" ").s cycle
while s->rest.(" ").rest2 and rest="" cycle ; s=rest2; repeat
if ns(nl+1)="X" or ns(nl+1)="x" or ns(nl+1)="-" start
t=ns(nl+1)
while s->rest.(" ").rest2 and rest="" cycle ; s=rest2; repeat
unless s->rest.(" ").s then rest=s and s=""
ns(nl+1)=t.rest
finish
nl=nl+1
repeat
if s#"" start
nl=nl+1
ns(nl)=s
finish
finish
!----------------------------------------
!
!
np=np+1
s=ns(np)
i=bin(s)
if i=x'80308030' then start
printstring("Invalid hex or dec no.
")
if np>1 start
np=np-1
printstring("Last taken was ")
printstring(ns(np))
newline
finish
->reset
finish
result =i
end ; ! RDINTS
!--------------------------------------------------------------------------------
external routine rdint(integer name i)
i=rdints("")
end ; ! RDINT
external integer next=-1
external string fn separate(string name s)
! SEPARATES STRING S INTO SUB-STRINGS COMPRISING THINGS BETWEEN
! (ENDS OR) COMMAS IN S. AT SUCCESSIVE CALS OF THIS FN, S AND THE
! RESULT ARE SET TO THE "NEXT" SUB-STRING. RESULT IS "" WHEN THERE
! ARE NO SUB-STRINGS LEFT. A NULL SUB-STRING (IE. ",," IN THE
! ORIGINAL) ALSO TERMINATES THE SET OF SUB-STRINGS.
own string (127) array fs(0:19)=""(20)
own integer n=0
string (127) lh, rh
integer j
!
!
if next<0 start
if length(s)=0 then result =""
next=0
s=lh.rh while s->lh.(" ").rh
cycle j=0, 1, 19; fs(j)=""; repeat ; ! TO ALLOW SERIAL RE-USE
n=0
fs(0)=s
n=n+1 while fs(n)->fs(n).(",").fs(n+1)
finish
if fs(next)="" then next=-1 and s="" and result =""
next=next+1
s=fs(next-1)
result =s
end ; ! SEPARATE
!
!
!
!--------------------------------------------------------------------------------
external routine qinfo(string (255) file)
record format dfinfrecf(integer nkb, rup, eep, apf, use, arch, fsys, conseg, cct, codes,
byte integer sp1, sp2, pool, codes2, integer ssbyte, string (6) offer)
record (dfinfrecf) x
const integer unava=1, wrconn=1
const integer offer=2, newge=2
const integer tempfi=4, oldge=4
const integer vtempf=8, wsallow=8
const integer tempfs=12
const integer chersh=16, comms=16
const integer privat=32, discfi=32
const integer violat=64
const integer noarch=128, dead=128
integer j, owner given
string (31) user
!
string (31) w1, w2
while separate(file)#"" cycle
j=0
user=""
if file->user.(".").file start
j=8 unless (length(user)=6 or length(user)=0) and 0<length(file)<=11
finish
owner given=1
if user="" then user=uinfs(1) and owner given=0
x=0
j=dfinfo(user, file, -1, addr(x)) if j=0
if x_codes&chersh#0 then printsymbol('*') and space
printstring(user.".") if owner given#0
printstring(file.":")
if j#0 start
uderrs(j)
continue
finish
printstring(" CONN ")
if x_conseg>15 then printsymbol('X')
printstring(htos(x_conseg, 2))
printstring("; PGS ")
if x_nkb>>2>15 then printsymbol('X')
printstring(htos(x_nkb>>2, 3))
printstring("; OWP"); write(x_rup, 1)
printstring("; EEP"); write(x_eep&15, 1)
printstring("; APF "); printstring(htos(x_apf, 3))
printstring("; USERS"); write(x_use, 1)
printstring("; CCT"); write(x_cct, 1)
if length(x_offer)=6 then printstring("; OFF: ".x_offer)
if x_codes&violat#0 then printstring("; VIOL")
if x_codes&tempfs#0 then printstring("; ")
if x_codes&vtempf#0 then printstring("V")
if x_codes&tempfs#0 then printstring("TEMPFI")
if x_codes&noarch#0 then printstring("; NOARCH")
if x_codes2&(newge!oldge)#0 then printstring("; GENRS")
newline
! %if S->W1.(".").W2 %then %continue
! J=0
! %while J<U_CT %cycle
! PRINTSTRING(U_PS(J)_USER )
! WRITE(U_PS(J)_PRM,1)
! NEWLINE
! J=J+1
! %repeat
repeat
newline
end ; ! QINFO
!------------------------------------------------------------------------------
external routine dump(integer start, finish, printst, lim)
!
! DUMP ROUTINE FOR .LP OR EQUIVALENT FILE
!
! LIM GIVE BYTES PER LINE REQUIRED
! BUT IN ADDITION, LIM=-1 WILL GIVE LIM=32, AND
! LIM=-16 WILL GIVE LIM=16 AND EBCDIC PRINT, AND
! LIM=-32 WILL GIVE LIM=32 AND EBCDIC PRINT
routine spec print text
integer fn spec exlines(integer print abs)
integer j, k, sameas, msgind, acurl, ac0, ac1, dr0, dr1, v, psr
integer align, mainstop, lm1, acl4
integer ebcdic
byte integer ch2
ebcdic=0
printst=start if printst=-1
if start&3#printst&3 then printstring("DUMP: WRONG PARAMS
")
start=start&(¬3)
finish=finish&(¬3)
printst=printst&(¬3)
msgind=0
if lim=-16 then ebcdic=1 and lim=16
if lim=-32 then ebcdic=1 and lim=32
lim=32 unless lim=16; ! ONLY THESE TWO VALUES VALID
lm1=lim-1
align=printst&lm1
acurl=start-align
printst=printst-align
mainstop=finish&(¬lm1)
j=exlines(1)
return if j=0
j=exlines(0)
return if j=0
*lss_(lnb +1)
*st_psr
while acurl<mainstop cycle
! Validate next LIM bytes
dr0=x'18000000'!lim
*ldtb_dr0
*lda_acurl
*val_psr
*jcc_8, <cczer>
*jcc_4, <ccone>
*jcc_2, <cctwo>
! THEN CC=3, INVALID
cctwo:
v=0
->vout
cczer: ! READ AND WRITE PERMITTED
ccone: ! READ, BUT NOT WRITE, PERMITTED
v=1
vout:
if v=0 start
if msgind#0 then print text
printstring("(")
phex(acurl)
printstring(") ")
printstring("Address Validation Fails")
newline
return
finish
! Are next LIM bytes identical to preceding?
acl4=acurl+lim-4
sameas=1
! %cycle J=ACURL,4,ACL4
! %if INTEGER(J-LIM)#INTEGER(J) %then SAMEAS=0 %and %exit
! %repeat
dr0=x'58000000'!lim
dr1=acurl
ac0=dr0
ac1=dr1-lim
*ld_dr0
*lsd_ac0
*put_x'A500'; ! CPS
*jcc_8, <equal>
sameas=0; ! DIFFERENT
equal:
if sameas=0 start
if msgind#0 then print text
msgind=0
finish else msgind=msgind+1 {counts no of lines identical to last printed}
if msgind=0 start ; ! NOT SAME, GO ON
! PRINT ADDRESS OF LINESTART
printsymbol('(')
phex(printst)
printstring(") ")
! PRINT HEX PART
cycle k=acurl, 4, acl4
printstring(" ")
phex(integer(k))
repeat
printstring(" ")
! PRINT CHAR PART
cycle k=acurl, 1, acurl+lm1
ch2=byteinteger(k)
if ebcdic#0 then etoi(addr(ch2), 1)
if 32<=ch2<=126 then printsymbol(ch2) else space
repeat
newline
finish else start ; ! NOT SAME, GO ON/ELSE START SAME
if msgind=1 start
printsymbol('(')
phex(printst)
printstring(") ")
finish
finish ; ! SAME
acurl=acurl+lim
printst=printst+lim
repeat
if msgind#0 then print text
j=exlines(0)
return
routine print text
integer zer, k
zer=1
cycle k=acurl-lim, 4, acurl-4
if integer(k)#0 then zer=0 and exit
repeat
if msgind=1 then printstring("1 LINE ") else printstring(itos(msgind)." LINES ")
if zer=0 then printstring("SAME AS ABOVE") else printstring("OF ZEROES")
newline
end {print text}
integer fn exlines(integer print abs)
integer k
!--- STARTING AND FINAL LINES ---
result =0 unless acurl+lim>start and acurl<finish
if val(acurl, lim, 0, 0)=0 start
printstring("(")
phex(acurl)
printstring(") ")
printstring("Address Validation Fails")
newline
result =0
finish
! PRINT ADDRESS OF LINESTART
printsymbol('(')
if print abs=0 then phex(printst) else phex(acurl)
printstring(") ")
! PRINT HEX PART
cycle k=acurl, 4, acurl+lim-4
printstring(" ")
if start<=k<finish then phex(integer(k)) else spaces(8)
repeat
printstring(" ")
! PRINT CHAR PART
cycle k=acurl, 1, acurl+lim-1
ch2=byteinteger(k)
if ebcdic#0 then etoi(addr(ch2), 1)
if start<=k<=finish and 32<=ch2<=126 then printsymbol(ch2) else space
repeat
acurl=acurl+lim
printst=printst+lim
newline
result =1
end ; ! EXLINES
end ; ! DUMP
routine reduce params(integer a, b, c, d)
ncode(a, b, c)
d=0
end ; ! REDUCE PARAMS
routine reduce params2(integer a, b, c, d)
dynamic routine spec ibmrecode(integer a, b, c)
ibmrecode(a, b, c)
d=0
end {reduce params2}
routine ocdump(string (255) s, routine dumprt(integer a, b, c, d), integer type)
integer par, st, fi, filead, filename prompted for
integer printst, lim
string (71) fis, sts, devs, file
record (srcf) name hdr
filename prompted for=0
par=1
prompt("File: ")
next=-1
file=separate(s)
uctranslate(addr(s)+1, length(s))
ucstrg(file) and filename prompted for=1 while long cfn(file)#0
filead=rdfilead(file)
if filead=0 then return
hdr==record(filead)
sts=separate(s)
prompt("Relstart: ")
st=rdints(sts)
prompt("Relfinish or Bytes: ")
fis=separate(s)
fi=rdints(fis)
if fi=0 then fi=hdr_nextfreebyte
if fi<=st then fi=st+fi
if type=2 start ; ! DUMPCODE
unless 0<=st<fi and fi<=hdr_nextfreebyte then ->fail
finish
devs=separate(s)
if devs="" and filename prompted for=0 then devs=".OUT"
prompt("To file/dev: ")
cycle
exit if ".OUT"=devs or fromstr(devs, 1, 3)=".LP" or cfn(devs)=0
ucnstrg(devs)
devs=".OUT" if devs=""
repeat
lim=16
s=separate(s)
if s=".LONG" then lim=32
define("ST63,".devs.",512")
select output(63)
if devs#".OUT" start
lim=32
printstring("Dumped from file: ".file)
spaces(5)
printstring(date." ".time)
newlines(3)
finish
if type=1 {dumpfile} then printst=st else printst=st-hdr_txtrelst
if type=3 {ebcdicdump} then lim=-lim
dumprt(filead+st, filead+fi, printst, lim)
newlines(2)
select output(0)
close stream(63)
clear("")
return
fail:
printstring("Addresses must be rel to file start and within file length
")
end ; ! OCDUMP
!--------------------------------------------------------------------------------
external routine dumpfile(string (71) s)
ocdump(s, dump, 1)
end ; ! DUMPFILE
!--------------------------------------------------------------------------------
external routine ibmcode(string (255) s)
ocdump(s, reduce params2, 2)
end {ibmcode}
external routine dumpcode(string (71) s)
ocdump(s, reduce params, 2)
end ; ! DUMPCODE
!--------------------------------------------------------------------------------
external routine recode(string (71) s)
ocdump(s, reduce params, 2)
end ; ! RECODE
!--------------------------------------------------------------------------------
external routine ebcdicdump(string (71) s)
ocdump(s, dump, 3)
end ; ! EBCDICDUMP
!--------------------------------------------------------------------------------
routine processvm(routine process(integer a, b, c, d))
integer lim
integer start, finish, as at, j, segad
string (255) s
lim=32
prompt("Addr or segno: ")
rdint(start)
if 0<start<1<<18 start
prompt("Relstart: ")
rdint(j)
start=start<<18+j
finish
segad=start&x'FFFC0000'
prompt("Addr or relend:")
rdint(finish)
if 0<finish<2<<18 then finish=segad+finish
as at=0
prompt("To file/dev: ")
ucstrg(s)
define("STREAM01,".s)
select output(1)
if s=".OUT" then lim=16 else start
printstring("VIRTUAL MEMORY from X'".htos(start, 8)."' to X'".htos(finish,
8)."' on ".date." at ".time)
newlines(4)
finish
process(start, finish, start, lim)
newline
select output(99)
close stream(1)
clear("")
end ; ! processvm
external routine dumpvm(string (255) s)
processvm(dump)
end ; ! dumpvm
external routine recode vm(string (255) s)
processvm(reduce params)
end ; ! recode vm
routine vlist(integer start, finish, pstart, lim)
integer j, ad, mask, ch
mask=-1
ad=start&(¬63)
finish=(finish+63)&(¬63)
while ad<finish cycle
printstring("(")
phex(ad&mask)
mask=x'0003FFFF'
printstring(") ")
if val(ad, 64, 0, 0)#0 start
cycle j=0, 1, 63
ch=byteinteger(ad+j)
printch(ch)
if ch=nl then spaces(12)
repeat
finish else start
printstring("Address validation fails")
exit
finish
newline
ad=ad+64
repeat
end ; ! VLIST
external routine listvm(string (255) s)
processvm(vlist)
end ; ! LISTVM
routine isearch(integer from, to, segad)
string (63) type, seek
string (63) file, s
integer lseekm1, aseekplus1
integer j, k, fin, n, kind, ch
integer seek1, seek2
switch search, search again(0:2)
j=from
fin=to
prompt("STR/SHORT/INT: ")
ucstrg(type) until type="STR" or type="SHORT" or type="INT"
kind=0; ! STRING
if type="SHORT" then kind=1
if type="INT" then kind=2
->search(kind)
search(0): ! STRING
prompt("STRING: ")
rstrg(seek)
lseekm1=length(seek)-1
aseekplus1=addr(seek)+1
search again(0):
until j>=fin-lseekm1 cycle
cycle k=0, 1, lseekm1
if byteinteger(j+k)#byteinteger(aseekplus1+k) then exit
->found if k=lseekm1; ! GOT THROUGH ALL BYTES WITHOUT DISAGREEMENT
repeat
j=j+1
repeat
->not found
search(1): ! SHORT
prompt("Search for: ")
rdint(seek2) until seek2&x'FFFF0000'=0
search again(1): ! SHORT
until j>fin-2 cycle
if j&3=0 then k=integer(j)>>16 else k=integer(j)&x'FFFF'
if k=seek2 then ->found
j=j+2
repeat
->not found
search(2): ! INTEGER
prompt("Search for: ")
rdint(k)
seek1=k>>16
seek2=k&x'FFFF'
search again(2):
until j>fin-4 cycle
if j&3=0 start
if integer(j)=k then ->found
finish else start
if byteinteger(j)<<8!byteinteger(j+1)=seek1 and c
byteinteger(j+2)<<8!byteinteger(j+3)=seek2 then ->found
finish
j=j+2
repeat
not found:
printstring("
NOT FOUND
")
return
found:
printstring("
FOUND:
")
k=j+16
k=fin if k>fin
n=j-16
n=segad if n<segad
dump(n, k, n-segad, 16)
newline
return if j>fin-16
j=j+16
prompt("Continue? ")
until ch='Y' or ch='y' or ch='N' or ch='n' cycle
ucstrg(s)
ch=charno(s, 1)
repeat
if ch='Y' or ch='y' then ->search again(kind)
end ; ! ISEARCH
!-------------------------------------------------------------------------------
external routine searchvm(string (255) s)
integer lim
integer start, finish, as at, j, segad
lim=32
prompt("Addr or segno: ")
rdint(start)
if 0<start<1<<18 start
prompt("Relstart: ")
rdint(j)
start=start<<18+j
finish
segad=start&x'FFFC0000'
prompt("Addr or relend:")
rdint(finish)
if 0<finish<2<<18 then finish=segad+finish
isearch(start, finish, segad)
end ; ! SEARCHVM
!--------------------------------------------------------------------------------
external routine ysearch(string (255) file)
record (srcf) name h
string (255) aa, bb
integer start, j, fin, bytes
prompt("File: ")
if file="" then rstrg(file)
start=rdfilead(file)
return if start<=0
if file->aa.("_").bb start
h==record(start)
bytes=h_maxlen
finish else bytes=fpages(file)<<12
prompt("Relstart: ")
rdint(j) until 0<=j<bytes
fin=start+bytes
isearch(start+j, fin, start)
end ; ! YSEARCH
!--------------------------------------------------------------------------------
external routine ycomp(string (255) s)
record (finfrecf) finf
integer origs1, flag
string (63) file1, file2
integer u, v, s1, s2, sa, lim
prompt("File1: ")
rstrg(file1)
prompt("File2: ")
rstrg(file2)
prompt("Rel start: ")
rdint(sa)
sa=sa&(¬b'11'); ! ALIGN TO WORD
s1=rdfilead(file1)
s2=rdfilead(file2)
return if s1<=0 or s2<=0
origs1=s1
finfo(file1, 0, finf, flag)
if flag#0 start
printstring("Error"); write(flag, 1); newline; return
finish
lim=finf_size
finfo(file2, 0, finf, flag)
if flag#0 start
printstring("ERROR"); write(flag, 1); newline; return
finish
! SET LIM TO SHORTER OF THE TWO FILESIZES
if lim>finf_size then lim=finf_size
s1=s1+sa
s2=s2+sa
lim=origs1+lim
cycle
u=integer(s1)
v=integer(s2)
if u#v then ->diff
s1=s1+4
s2=s2+4
->done if s1>=lim
repeat
diff:
printstring("DIFF AT REL ADDRESS: ")
phex(s1-origs1)
spaces(5)
phex(u); spaces(2)
phex(v); newline
return
done:
printstring("FINISHED AT REL ADDRESS: ")
phex(s1-origs1)
newline
end ; ! YCOMP
!------------------------------------------------------------------------------
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
!
!-------------------------------------------------------------------------------
!
external routine compare(string (255) s)
! If a null parameter is supplied, the progrma prompts for filenames for comparison.
! It then prompts : for the "COMPARE"
! commands.
! If the PARAMETER parameter comprises two filenames separated by comma, then comparison commences right away.
! Unless a third parameter, .F is appended, the program returns
! after a difference has been found. It returns anyway if the files
! are found identical. (This feature is only for program use).
! If a PDfile member is being compared with a file having the same name
! and belonging to the process owner, then the file is HAZARDed if no
! difference is found. But only for the command form:
! COMPARE(PDFILE_MEMBER)
! i.e. second filename implied.
!
routine spec cfhelp
routine spec context
routine spec lrstrg(string name s)
record (srcf) name h, h2
integer i, j, c, f, as, l, agoflag, fncall, hazfile, qd, k
integer outstrm, outfile, cur in to out, ad1, ad2
string (63) u, v, pd, mem
string (255) array cur(1:2)
integer curip
integer array fa, fb, fp, fl(1:2)
switch a('A':'Z')
on event 14 start
h==record(ad1)
h2==record(ad2)
if h_nextfreebyte#h2_nextfreebyte or different(h_nextfreebyte, ad1, ad2)#0 then c
printstring("DIFF ")
printstring("Invalid input file")
newline
return
finish
qd=0 {"Type ?" flag}
fncall=0
outstrm=0
cur in to out=1
curip=1
as=addr(s)
agoflag=0
outfile=0
hazfile=0
u=""; v=""
if s="?" then cfhelp
if length(s)>0 start
unless s->u.(",").v start
if s->pd.("_").mem start
if exist(mem)#0 start
u=pd."_".mem
v=mem
hazfile=1
finish else start
printstring("File ".mem." does not exist")
newline
return
finish
finish
finish
agoflag=1
outfile=0
s=".N"
! IF PARAMETER ,.F APPENDED, WE SET "FNCALL" TO INDICATE RETURN
! REQUIRED AFTER DIFFERENCE FOUND, AS WELL AS WHEN IDENTITY FOUND.
if v->v.(",.F") then fncall=1
finish
if u="" start
prompt("File1:")
rstrg(u)
finish
i=rdfilead(u)
h==record(i)
return if i<=0
fa(1)=i; ad1=i
fp(1)=i+h_txtrelst; fl(1)=i+h_nextfreebyte; fb(1)=fp(1)
if v="" start
prompt("File2:")
rstrg(v)
finish
j=rdfilead(v)
return if j<=0
h==record(j)
fa(2)=j; ad2=j
fp(2)=j+h_txtrelst; fl(2)=j+h_nextfreebyte; fb(2)=fp(2)
advance:
curip=1
lrstrg(cur(1))
curip=2
lrstrg(cur(2))
if length(cur(1))=255 start ; f=1; ->eof; finish
if length(cur(2))=255 start ; f=2; ->eof; finish
if agoflag#0 start
agoflag=0
s="GO"
->l11
finish
nextcmd:
if qd=0 start
printstring("Type ? for commands")
newline
qd=1
finish
prompt(":")
rstrg(s)
uctranslate(addr(s)+1, 2) {command letters to upper case}
if s=":" or s="%C" then s="Q"
l11:
l=length(s)
c=byteinteger(as+1)
f=byteinteger(as+2)-'0'
->no unless c='M' or c='P' or c='G' or c='F' or c='Q' or c='A' or c='E' or c='C'
->a(c)
a('A'):
->no unless l=1 or s="AGO"
agoflag=1
->advance
a('M'):
->no unless l>=3 and (1<=f<=2 or f+'0'='B')
s=substring(s, 3, l)
i=bin(s)
->no if i<=0
if f+'0'='B' then k=2 and f=1 else k=1 {no of files we are doing}
cycle
curip=f
cycle j=1, 1, i
lrstrg(cur(f))
if length(cur(f))=255 then ->eof
repeat
f=f+1
k=k-1; exit if k=0
repeat
->print both
a('E'):
a('Q'):
->no unless l=1
return
a('C'): ! Context
context
->nextcmd
a('P'):
->no unless l=2 and (1<=f<=2 or f+'0'='B')
if f+'0'='B' start
print both:
if length(cur(1))=255 then printstring("**EOF1**
") else printstring(cur(1)."
")
if length(cur(2))=255 then printstring("**EOF2**
") else printstring(cur(2)."
")
->nextcmd
finish
if length(cur(f))=255 then printstring("**EOF**
") else printstring(cur(f)."
")
->nextcmd
a('G'):
cycle
->no unless l=2 and f+'0'='O'
if length(cur(1))=255 or length(cur(2))=255 then ->print both
if cur(1)#cur(2) then ->diff
curip=1
lrstrg(cur(1))
curip=2
lrstrg(cur(2))
repeat
a('F'):
->no unless l>2 and (1<=f<=2 or f+'0'='B')
s=substring(s, 3, l)
if f+'0'='B' then j=0 and f=1 else j=1
! J=0 MEANS DO BOTH FILES, 1 MEANS DO JUST ONE.
cycle
curip=f
cycle
if length(cur(f))=255 then ->eof
if cur(f)->u.(s).v then exit
lrstrg(cur(f))
repeat
->print both if j=1
! THEN BOTH FILES ARE BEING DONE. NO. 2 NEXT.
f=2
j=1; ! TO STOP IT AFTER THIS TIME.
repeat
no:
if c='?' then cf help and ->nextcmd
printstring("NO
")
->nextcmd
diff:
hazfile=0
printstring("DIFF
")
cycle j=1, 1, 2
spaces(20) if fncall#0
printstring(cur(j))
newline
repeat
if fncall#0 then return
->nextcmd
eof:
if curip=1 then printstring("**EOF1**") else printstring("**EOF2**")
newline
return
eofs:
if hazfile#0 then hazard(mem)
printstring("Comparison complete
")
routine lrstrg(string name s)
! SETS S TO THE NEXT LINE (WITHOUT THE NL CHARACTER) FROM THE
! RELEVANT FILE AND SETS FP(CURIP) TO POINT TO THE CHARACTER
! AFTER THE NL.
integer as, curp, i, l
as=addr(s)
curp=fp(curip)
i=fl(curip)
if curp>=i then ->leof
l=0
while 10#byteinteger(curp)#12 cycle
l=l+1
if l>=256 then signal event 14
byteinteger(as+l)=byteinteger(curp)
curp=curp+1
repeat
byteinteger(as)=l
->out
leof:
byteinteger(as)=255; ! EOF INDICATION
out:
fp(curip)=curp+1; ! POINTS TO CHAR AFTER NEWLINE
return
end ; ! LRSTRG
routine context
integer i, ad, ip, j, nls
for ip=1, 1, 2 cycle
printstring("File"); write(ip, 1)
printstring(" -------------------------"); newline
ad=fp(ip)
i=ad; nls=0
while i>fb(ip) and nls<5 cycle
i=i-1
if byteinteger(i)=nl then nls=nls+1
repeat
ad=ad+1 while ad<fl(ip) and byteinteger(ad)#nl
for j=i, 1, ad cycle
printsymbol(byteinteger(j))
repeat
repeat
end ; ! CONTEXT
routine cfhelp
printstring("A Advance one line in each file and proceed with comparison.
")
printstring("C Context: five lines printed from each file; current lines last.
")
printstring("E End (same as Quit)
"); printstring("Fftext Find <text> in file f (Case-dependent search). f=1, or 2, or B
")
printstring(" meaning both.
"); printstring("GO Proceed with comparison, from current line (will not go if current
")
printstring(" lines different).
"); printstring("Mfn Move n lines in file f (f=1, or 2, or B meaning both)
")
printstring("Pf Print current line in file f (f=1, or 2, or B meaning both).
")
printstring("Q, :, %c Quit
");
end {cfhelp}
end {compare}
!--------------------------------------------------------------------------------
external routine tim(string (255) s)
printstring(time)
newline
end ; ! TIM
!--------------------------------------------------------------------------------
record format ssf(integer switch, sessno, junkno, string (9) date)
external routine deta(string (255) par)
integer do det, fad, n, j, tvalid, mins, secs, reset sess, flag, vsn
const integer topstr=39
string (79) array strs(0:topstr)
string (79) a, b, dstrg, paramfile, opfile
string (255) s, origs
record (srcf) name h
record (ssf) ss
if par="INIT" then reset sess=1 else if par="CANCEL" then reset sess=2 else reset sess=0
do det=1
n=0
if reset sess=0 start
cycle
rstrg(origs); s=ucstring(origs)
if s="Q" then return
if s=":" or s="%C" then exit
tvalid=0; mins=0; secs=0
mins=bin(s)
if mins>0 then tvalid=1 else if s->a.(",").b start
mins=0
mins=bin(a) if a#""
secs=bin(b) if b#""
if 10000>=mins>=0 and 600000>=secs>=0 and not (mins=secs=0 or (mins#0 and c
secs>=60)) start
tvalid=1
j=secs//60
mins=mins+j
secs=secs-j*60
finish
finish
if tvalid=0 start
if n>=topstr start
printstring("Too many lines (".itos(topstr).".
file SS#DET will be written to date, but not detached
")
do det=0
exit
finish
strs(n)=origs
n=n+1
finish else exit
repeat
finish
paramfile=""; opfile=""
if not (par->a.("LP").b) start
if exist("PF")=0 or reset sess#0 start
vsn=1
read profile("Session", ss, vsn, flag)
if flag=0 or reset sess#0 start
if reset sess=2 then vsn=-1 {delete}
if ss_date#date or reset sess=1 start
ss=0
ss_date=date
finish
ss_junkno=ss_junkno+1
opfile="J".itos(ss_junkno)
paramfile="T#PAR"
write profile("Session", ss, vsn, flag)
if flag#0 then printstring("Write profile flag") and write(flag, 1) and newline
return if reset sess#0
finish
finish else paramfile="PF"
finish
if opfile#"" start
fad=nwfilead(paramfile, 1)
if fad#0 start
h==record(fad)
s="OUT=FILE
OUTNAME=".opfile."
.END
"
move(length(s), addr(s)+1, fad+h_txtrelst)
h_nextfreebyte=h_txtrelst+length(s)
finish
finish
disconnect(paramfile, flag)
fad=nwfilead("SS#DET", 1)
if fad#0 start
h==record(fad)
if tvalid#0 start
if uinfi(16)#0 then s="CPULIMIT(".itos(mins).",".itos(secs).")" else c
s="CPULIMIT ".itos(mins).",".itos(secs)
s=s."
"
move(length(s), addr(s)+1, fad+h_nextfreebyte)
h_nextfreebyte=h_nextfreebyte+length(s)
finish
j=0
while j<n cycle
s=strs(j)."
"
move(length(s), addr(s)+1, fad+h_nextfreebyte)
h_nextfreebyte=h_nextfreebyte+length(s)
j=j+1
repeat
finish
dstrg=""
if tvalid#0 then dstrg=",".itos(mins*60+secs)
if paramfile#"" start
if dstrg="" then dstrg=","
paramfile=",".paramfile
finish
detach("SS#DET".dstrg.paramfile)
! printstring("SS#DET".dstrg.paramfile)
! newline
if opfile#"" start
printstring("Output file ".opfile)
newline
finish
end ; ! DETA
end of file