!! Routine MODIFY for modifying object files.
!! Compile with PARM(FREE)
!! SOAP parameters = [¬BC,LL=90,XN=4,LC=125,CT=46]
!!
external routine spec disconnect alias "S#DISCONNECT"(string (31) file, integer name flag)
external routine spec destroy alias "S#DESTROY"(string (31) file, integer name flag)
external routine spec setwork alias "S#SETWORK"(integer name ad, len)
external routine spec lput alias "S#LPUT"(integer type, p1, p2, p3)
external routine spec uctranslate alias "S#UCTRANSLATE"(integer ad, len)
external integer map spec comreg alias "S#COMREG"(integer n)
external routine spec changefilesize alias "S#CHANGEFILESIZE"(string (31) file, integer size,
integer name flag)
external routine spec clear(string (255) s)
external routine spec newgen alias "S#NEWGEN"(string (31) f1, f2, integer name flag)
external routine spec prompt(string (255) s)
external integer fn spec outpos
external string fn spec uinfs(integer entry)
external string fn spec time
external string fn spec date
external routine spec define(string (255) s)
external string fn spec itos alias "S#ITOS"(integer i)
external integer fn spec pstoi alias "S#PSTOI"(string (63) s)
external routine spec psysmes alias "S#PSYSMES"(integer root, flag)
external routine spec setpar alias "S#SETPAR"(string (255) s)
external string fn spec spar alias "S#SPAR"(integer n)
record format rrf(integer conad, filetype, datastart, dataend)
external routine spec connect alias "S#CONNECT"(string (31) file, integer mode, hole, prot,
record (rrf) name rr, integer name flag)
external routine spec outfile alias "S#OUTFILE"(string (31) file, integer size, hole, prot,
integer name conad, flag)
external routine spec modpdfile alias "S#MODPDFILE"(integer ep, string (31) pdfile, string (11) memb,
string (31) infile, integer name flag)
external routine spec move alias "S#MOVE"(integer len, from, to)
external string fn spec ucstring(string (255) s)
record format relf(integer link, n, relad)
record format ofmf(integer start, l, prop)
record format centf(integer link, loc, string (31) iden)
record format dentf(integer link, disp, l, a, string (31) iden)
record format creff(integer link, refloc, string (31) iden)
record format dreff(integer link, refarray, l, string (31) iden)
record format commef(integer link, string (31) iden)
external routine modify(string (255) s)
const integer common bit= x'80000000'
const integer yes=1
const integer no=0
const string (1) snl= "
"
integer areacode, areadisp, basecode, basedisp, n
integer flag, outbase, loc, link, ad, conad, refarray
integer i, j, p1, p2, p3, topicmn, codeattributes, relarea
integer worktop, workbase, workpt, common, stlist
integer histbeg, histsize, dt, refloc, relad, newsize, maxsize
integer all, newrec, reqblock, codelength, glalength, bind
integer common entry head, omfdiags, add history, create common
integer codestart, glastart, stackstart, codesegs, glasegs, stacksegs
integer currlist, xtype, found
const byte integer array codesite(1:6)= 120,110,100,90,80,70
const integer last segment= 191
byte integer array vm map(35:last segment)
integer name linkname, llinkname, currlinkname
integer array base(1:7); !AREA START ADDRESSES IN FILE 'OUTF'
integer array lbase(1:7); !AREA START ADDRESSES WHEN LOADED
integer array arealength(1:8); !FOR TERMINATION CALL TO LPUT
string (63) s1, s2, list, op, infile, outf, pd, u1, u2
string (255) newhist, line
integer array format ldataaf(0:15)
integer array name ldata
record (centf) name cent
record (dentf) name dent
record (ofmf) array format ofmaf(1:7)
record (ofmf) array name ofm
record (creff) name cref
record (dreff) name dref
record (relf) name rel
record (commef) name comme
record (rrf) r
const integer max operations= 19
switch oper(1:max operations)
const string (12) array keyword(1:max operations)= c
"RENAME","REDIRECT","RENAMEDATA","REDIRECTDATA","ALIAS","MAKEDYNAMIC",
"MAKESTATIC","SUPPRESS","RETAIN","SUPPRESSDATA","RETAINDATA",
"SATISFYREFS","SATISFYDATA","FUSECODE","FUSEGLA","BIND","COMMONENTRY",
"NOHISTORY","CREATECOMMON"
const string (28) array heading(1:max operations)= c
"Renamed procedure entries","Redirected procedure refs",
"Renamed data entries","Redirected data refs",
"Aliased procedure entries","Procedure refs made dynamic",
"Procedure refs made static","Suppressed procedure entries",
"Retained procedure entries","Suppressed data entries",
"Retained data entries","Satisfied procedure refs",
"Satisfied data refs","","","","Created COMMON entries","",""
const string (15) array prom(1:max operations)= c
"Proc ent pair","Proc ref pair","Data ent pair","Data ref pair",
"Proc ent pair","Proc ref list","Proc ref list","Proc ent list",
"Proc ent list","Data ent list","Data ent list","Proc ref list",
"Data ref list","","","","COMMONref list","",""
const byte integer array hex(0:15)= c
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
string (8) fn htos(integer value, places)
string (8) s
integer i
i = 64-4*places
*ld_s; *lss_places; *st_(dr )
*inca_1; *std_ tos ; *std_ tos
*lss_value; *luh_0; *ush_i
*mpsr_x'24'; ! SET CC=1
*supk_ l =8
*ld_ tos ; *ands_ l =8, 0, 15; ! THROW AWAY ZONE CODES
*lss_hex+4; *luh_x'18000010'
*ld_ tos ; *ttr_ l =8
result = s
end ; !OF HTOS
integer fn free stream
external routine spec definfo(integer chan, string name file, integer name stat)
integer i, stat
string (31) file
for i = 1, 1, 80 cycle
definfo(i, file, stat)
if stat=0 then result = i
repeat
result = 0
end
routine error(integer root, flag)
selectoutput(0)
close stream(stlist)
clear(itos(stlist))
psysmes(root, flag)
stop
end ; !OF ERROR
routine report(string (255) mess)
selectoutput(0)
printstring(mess)
newline
selectoutput(stlist)
end ; !OF REPORT
routine mprint(string (31) s)
if outpos+length(s)>72 then newline
printstring(s)
space until (outpos//12)*12=outpos
end ; !OF MPRINT
integer fn check area(integer seg, len)
integer i
if len<=0 then result = 1
cycle i = seg, 1, seg+len-1
if 35<=i<=last segment and vm map(i)=0 then vm map(i) = 1 else result = 1
repeat
result = 0
end ; !OF CHECK AREA
routine getline(string name s)
while s="" cycle
skipsymbol while nextsymbol=nl or nextsymbol=' '
s = s.tostring(nextsymbol) and skipsymbol until nextsymbol=nl
s = s1.s2 while s->s1.(" ").s2; !REMOVE SPACES
uctranslate(addr(s)+1, length(s))
repeat
end ; !OF GETLINE
routine getstring(string name s1, s2, integer count)
cycle
getline(line)
if line->s1.(",").line then start
if count=1 then ->err
if count=0 then return
if line="" or line->s2.(",").line then ->err
s2 = line
line = ""
return
finish else start
s1 = line
line = ""
if s1=".END" then return
if count=0 then line = ".END" and return
if count=1 then return
finish
err:
report("Fault - wrong no of params")
line = ""
repeat
end ; !OF GETSTRING
integer fn workpos
if workpt+48>=worktop then start ; !NEED MORE SPACE
worktop = worktop+4096
changefilesize("T#MODWORK", worktop-workbase, flag)
if flag#0 then error(10, flag); !REQUEST STOP
finish
workpt = workpt+48
result = workpt-48
end ; !OF WORKPOS
integer fn matchs(string (255) s1, s2)
if ucstring(s1)=ucstring(s2) then result = yes
result = no
end ; !OF MATCHS
routine find iden(string (31) iden, integer list1, list2, offset)
!! finds a name within two lists of records, offset gives
!! no of bytes from the start of the record to the name
integer list
offset = offset+outbase
cycle list = list1, 1, list2; !LISTHEADS 1, 4, 7&8, 9
linkname == ldata(list)
while linkname#0 cycle
if matchs(iden, string(offset+linkname))=yes then return
!FOUND
linkname == integer(outbase+linkname)
repeat
repeat
end ; !OF FIND IDEN
integer fn pattstring(string (31) name, string name x1, x2)
! Gives result:
! 1 *x1*
! 2 *x2
! 3 x1*x2 or x1*
! 4 *
! 5 name
if name->x1.("*").x2 start
if x1#"" then result = 3
if x2="" then result = 4
if x2->x1.("*") then result = 1 else result = 2
finish else result = 5
end ; !of pattstring
routine amend iden(integer list1, list2, offset, string (15) entry or ref, op)
!! reads name,newname pairs until .end
!! searches given lists for newname to check for a duplicate.
!! offset gives no of bytes before iden string for the current record type
!! creates a new record in the work area to contain the new name
!! unless alias is specified, discards the old record
!! Also does renames on all entries using pattern matching (like files command)
integer newrec, i, typep, typeq, list, found, offbase
string (63) p1, p2, q1, q2, r1
const byte integer array check(1:5)= 2,4!8!16,4!8!16,4!8,32
string fn match iden(string (63) name)
switch sw(1:5)
->sw(typep)
sw(1):
sw(3):
unless name->r1.(p1).name then result = ""
if typep=1 then result = r1.q1.name
if r1#"" then result = ""
sw(2):
if length(name)<length(p2) then result = ""
r1 = name
length(r1) = length(r1)-length(p2)
if name=r1.p2 then result = q1.r1.q2 else result = ""
sw(4):
result = q1.name.q2
sw(5):
if s1=name then result = s2 else result = ""
end ; !of match iden
offbase = offset+outbase
cycle
found = 0
getstring(s1, s2, 2); !OLDNAME,NEWNAME
if length(s1)>31 or length(s2)>31 then report("Fault - names too long") and continue
if s1=".END" then exit
typep = pattstring(s1, p1, p2)
typeq = pattstring(s2, q1, q2)
if (check(typep)>>typeq)&1=1 start
cycle list = list1, 1, list2
linkname == ldata(list)
while linkname#0 cycle
r1 = match iden(ucstring(string(offbase+linkname)))
if r1#"" start
printstring(string(offbase+linkname)." -> ".r1.snl)
newrec = workpos; !ADDR OF RECORD IN WORK AREA
move(offset, outbase+linkname, newrec); !COPY RECORD
if length(r1)>31 then length(r1) = 31
string(newrec+offset) = r1; !NOW ADJUST LINKED LIST
if op#"ALIAS" then linkname = newrec-outbase else integer(outbase+linkname) = newrec-outbase
found = 1
if typep=5 and op#"REDIRECT" then ->out
finish
linkname == integer(outbase+linkname)
repeat
repeat
if found=0 then report("Fault - ".entry or ref." ".s1." not found")
finish else report("Fault - inconsistent names")
out:
repeat
newline
end ; !OF AMEND LIST
routine getnext(integer first, last, offset, string (15) entry or ref)
string (63) r1, r2
string name s
switch sw(1:4)
if s1=".START" start
xtype = 0
found = 0
currlist = first
llinkname == ldata(first)
finish
if xtype=0 or xtype=5 start
getstring(s1, s2, 0)
xtype = pattstring(s1, u1, u2)
finish
if xtype=5 start ; !not a mask
if s1=".END" then return
unless s1=".ALL" start
findiden(s1, first, last, offset)
if linkname=0 then start
report("Fault - ".entry or ref." ".s1." not found")
s1 = "#"
finish else currlinkname == linkname
return
finish else xtype = 4
finish
cycle
cycle
if llinkname#0 then exit
if currlist=last start
if found=0 start
report("Fault - no ".entry or ref." found for ".s1)
s1 = "#"
xtype = 0
finish else s1 = ".END"
return
finish
currlist = last
llinkname == ldata(last)
repeat
currlinkname == llinkname
llinkname == integer(outbase+llinkname)
s == string(outbase+currlinkname+offset)
->sw(xtype)
sw(1):
sw(3):
unless s->r1.(u1).r2 then continue
if xtype=1 then ->sw(4)
if r1#"" then continue
sw(2):
if length(s)<length(u2) then continue
r1 = s
length(r1) = length(r1)-length(u2)
unless s=r1.u2 then continue
sw(4):
found = 1
return
repeat
end ; !OF GETNEXT
routine swop refs(integer from, to)
!! moves a procedure reference between the dynamic list and
!! the static list
integer savelink
s1 = ".START"
cycle
getnext(from, from, 8, "proc ref"); !READ OR FIND NEXT PROC REF
if s1=".END" then exit ; !END OF LIST
if s1#"#" then start ; !NAME FOUND
again: mprint(string(outbase+currlinkname+8))
savelink = integer(outbase+currlinkname); !@ OF NEXT RECORD
integer(outbase+currlinkname) = ldata(to); !RECORD POINTS TO NEW LIST
ldata(to) = currlinkname; !NEW LIST HEAD POINTS TO RECORD
currlinkname = savelink; !OLD LIST BYPASSES RECORD
if xtype#5 then llinkname == currlinkname else start
findiden(s1, from, from, 8); !CHECK FOR DUPLICATE REF
if linkname#0 then currlinkname == linkname and ->again
finish
finish
repeat
end ; !OF SWOP REFS
routine change visibility(integer list, nameoffset, wordoffset, string (15) proc or data, action)
!! sets or unsets a retain bit in procedure or data entries
integer word
s1 = ".START"
cycle
getnext(list, list, nameoffset, proc or data); !TAKE NAMES ONE AT A TIME
if s1=".END" then exit
if s1#"#" then start ; !FOUND
word = outbase+currlinkname+wordoffset; !WHERE BIT IS TO BE CHANGED
if action="suppress" then integer(word) = integer(word)!x'40000000' else c
integer(word) = integer(word)&x'BFFFFFFF'
mprint(string(outbase+currlinkname+nameoffset))
finish
repeat
newline
end ; !OF CHANGE VISIBILITY
routine fuse relocate(integer oldarea, newarea, disp)
integer p, n, i
integer name baseloc
link = ldata(14); !RELOC REQUESTS
while link#0 cycle
p = outbase+link+8
n = integer(outbase+link+4)
cycle i = 1, 1, n*2; !TWO WORDS MODIFIED PER ENTRY
baseloc == integer(p)
basecode = baseloc>>24
basedisp = baseloc&x'FFFFFF'
if basecode=oldarea then start
basecode = newarea
basedisp = basedisp+disp
baseloc = (basecode<<24)!basedisp
finish
p = p+4
repeat
link = integer(outbase+link)
repeat
end ; !OF FUSE RELOCATE
!!
!!
setpar(s)
infile = spar(1)
outf = spar(2)
list = spar(3)
if outf="" then outf = infile
if outf->s1.("_").s2 then pd = outf and outf = "" else pd = ""
if outf="" or outf=infile then outf = "T#MODLPUT"
!FILE CREATED BY LPUT
if list="" then list = "T#MODLIST"
stlist = free stream
define(itos(stlist).",".list)
selectoutput(stlist)
printstring(snl."Modify file ".infile)
if outf#"T#MODLPUT" then printstring(" -> ".outf)
printstring(" at ".time." on ".date)
newlines(2)
connect(infile, 0, 0, 0, r, flag)
if flag#0 then error(8, flag); !REQUEST STOP
conad = r_conad
if integer(conad+12)#1 then report("Invalid filetype") and stop
dt = conad+20; !@ OF PACKED DATE&TIME FOR FILE HISTORY
outfile("T#MODCOPY", r_dataend, 0, 0, outbase, flag)
if flag#0 then error(10, flag); !REQUEST STOP
move(integer(conad), conad, outbase); !COPY OBJECT FILE
ldata == array(outbase+integer(outbase+24), ldataaf); !LOAD DATA
ofm == array(outbase+integer(outbase+28)+4, ofmaf); !OBJECT FILE MAP
if ldata(5)#0 then start
selectoutput(0)
printstring("Modify fails - ".infile." is a bound object file".snl)
return
finish
if ldata(0)>14 and ldata(15)#0 then start
omfdiags = ldata(15)
finish else omfdiags = 0
arealength(8) = 0
cycle i = 1, 1, 7
base(i) = outbase+ofm(i)_start; !MAP OBJECT FILE AREAS
arealength(i) = ofm(i)_l; !NOTE SIZE FOR LPUT CALL
arealength(8) = arealength(8)+arealength(i); !GRAND TOTAL
repeat
code attributes = ofm(1)_prop; !MUST COPY TO OUTPUT FILE
!!
!!now prepare to accept params
!!
outfile("T#MODWORK", 4096, 257<<10, 0, workbase, flag)
if flag#0 then error(10, flag); !REQUEST STOP
workpt = workbase+32; !POINTER TO FREE WORKSPACE
worktop = workbase+4096; !TOP OF WORKSPACE
bind = 0; common entry head = 0
add history = 1; create common = 0
cycle
prompt("Operation:")
line = ""
op = ""
getline(op)
exit if op="CLOSE"
if op->s1.("BIND").s2 and s1="" then op = s2 and ->oper(16)
cycle i = 1, 1, max operations
if op=keyword(i) then start
newlines(2)
if heading(i)#"" then printstring(heading(i).":".snl.snl)
prompt(prom(i).":")
->oper(i)
finish
repeat
report("Fault - unknown command ".op)
->next op
oper(1): !RENAME PROCEDURE ENTRY
amend iden(1, 1, 8, "proc entry", ""); !1,1=PROC ENTRY LIST,8=OFFSET
->next op
oper(2): !REDIRECT PROCEDURE REFERENCE
amend iden(7, 8, 8, "proc ref", "REDIRECT"); !7,8=PROC REF LISTS,8=OFFSET
->next op
oper(3): !RENAME DATA ENTRIES
amend iden(4, 4, 16, "data entry", ""); !4,4=DATA ENTRY LIST,16=OFFSET
->next op
oper(4): !REDIRECT DATA REFERENCES
amend iden(9, 9, 12, "data ref", ""); !9,9=DATA REF LIST,12=OFFSET
->next op
oper(5): !ALIAS PROCEDURE ENTRIES
amend iden(1, 1, 8, "proc entry", "ALIAS"); !1,1=PROC ENTRY LIST,8=OFFSET
->next op
oper(6): !MAKE PROC REF DYNAMIC
swop refs(7, 8); !FROM 7 TO 8
->next op
oper(7): !MAKE PROC REFS STATIC
swop refs(8, 7); !FROM 8 TO 7
->next op
oper(8): !SUPPRESS PROCEDURE ENTRIES
change visibility(1, 8, 4, "proc entry", "suppress"); !LIST1,NAMEOFFSET=8,WORDOFFSET=4
->next op
oper(9): !RETAIN PROCEDURE ENTRIES
change visibility(1, 8, 4, "proc entry", "retain")
->next op
oper(10): !SUPPRESS DATA ENTRIES
change visibility(4, 16, 12, "data entry", "suppress")
!LIST4,NAMEOFFSET=16,WORDOFFSET=12
->next op
oper(11): !RETAIN DATA ENTRIES
change visibility(4, 16, 12, "data entry", "retain")
->next op
oper(12): !SATISFY PROCEDURE REFS
s1 = ".START"
cycle
getnext(7, 8, 8, "ref"); !READ OR FIND NEXT PROC REF
if s1=".END" then exit ; !END OF LIST
if s1="#" then ->next12; !REF NOT FOUND
again12: cref == record(outbase+currlinkname)
find iden(cref_iden, 1, 1, 8); !SEARCH EP LIST FOR NAME
if linkname#0 then start ; !NAME FOUND
cent == record(outbase+linkname)
loc = base((cref_refloc>>24)&x'3F')+cref_refloc&x'FFFFFF'
integer(loc) = x'B1000000'; !FILL DR0
integer(loc+4) = cent_loc&x'FFFFFF'
newrec = workpos; !GET RECORD FROM WORK AREA FOR RELOCATION
integer(newrec) = ldata(14); !MERGE WITH RELOC REQUEST LIST
ldata(14) = newrec-outbase
integer(newrec+4) = 1; !SINGLE RELOCATION REQUEST
integer(newrec+8) = cref_refloc+4; !WORD TO BE RELOCATED
integer(newrec+12) = cent_loc&x'3F000000'; !RELOCATION VALUE CODE
currlinkname = integer(outbase+currlinkname)
!REMOVE REF FROM LIST
mprint(cref_iden)
if xtype#5 then llinkname == currlinkname else start
findiden(s1, 7, 8, 8); !CHECK FOR DUPLICATE REF
if linkname#0 then currlinkname == linkname and ->again12
finish
finish else start
if xtype#4 then report("Fault - no entry found for ref ".cref_iden)
finish
next12:
repeat
newline
->next op
oper(13): !SATISFY DATA REFS
s1 = ".START"
cycle
getnext(9, 9, 12, "ref"); !R OR FIND NEXT DATA REF
if s1=".END" then exit ; !END OF LIST
if s1="#" then ->next13; !REF NOT FOUND
dref == record(outbase+currlinkname)
find iden(dref_iden, 4, 4, 16); !SEARCH DATA ENTRY LIST FOR NAME
if linkname#0 then start ; !NAME FOUND
refarray = (dref_refarray&x'7FFFFFFF')+outbase
common = dref_refarray&x'80000000'; !NOTE COMMON BIT
n = integer(refarray); !NO OF LOCATIONS REQUIRING ENTRY
dent == record(outbase+linkname); !MAP DATA ENTRY RECORD
reqblock = workpos; !GET SOME SPACE
integer(reqblock) = ldata(14); !CREATE NEW RELOC REQUEST BLOCK
ldata(14) = reqblock-outbase; !ADD TO LIST
integer(reqblock+4) = n; !NO OF REQUESTS FOLLOWING
j = reqblock+8
i = 1
cycle refloc = refarray+4, 4, refarray+(n*4)
loc = base(integer(refloc)>>24)+integer(refloc)&x'FFFFFF'
integer(loc) = integer(loc)+dent_disp; !ADD OFFSET OF ENTRY
i = i+1
if i=7 then i = workpos and i = 1
integer(j) = integer(refloc); !MAKE RELOCATION REQUEST
integer(j+4) = (dent_a<<24)&x'3F000000'
j = j+8
repeat
currlinkname = integer(outbase+currlinkname)
!REMOVE REF FROM LIST
if xtype#5 then llinkname == currlinkname; !AVOID MOVING CURR IN GETNEXT
mprint(dref_iden)
finish else start
if xtype#4 then report("Fault - no data entry found for ref ".dref_iden)
finish
next13:
repeat
newline
->next op
oper(14): !FUSE CODE
codelength = arealength(1)
arealength(1) = codelength+arealength(4); !ADD SST LENGTH TO CODE LENGTH
arealength(4) = 0; !COLLAPSE SST
ofm(4)_l = 0
fuse relocate(4, 1, codelength)
printstring("Code fused".snl)
->next op
oper(15): !FUSE GLA
glalength = arealength(2)
arealength(2) = glalength+arealength(5); !ADD UST LENGTH TO GLA LENGTH
arealength(5) = 0; !COLLAPSE UST
fuse relocate(5, 2, glalength)
link = ldata(4); !DATA ENTRIES LISTHEAD
while link#0 cycle
dent == record(outbase+link)
if (dent_a&x'FF')=5 then start ; !ENTRY IN UST
dent_a = dent_a-3; !CHANGE TO GLA
dent_disp = dent_disp+glalength
finish
link = dent_link
repeat
printstring("GLA fused".snl)
->next op
oper(16): !BIND FILE
if bind#0 then report("Fault - BIND already called") and ->next op
if op="" then i = 1 else i = pstoi(op)
link = ldata(9); !SCAN DATA REFS
topicmn = 0; !HOW MUCH INITCMN
while link#0 cycle
dref == record(link+outbase)
if dref_refarray&common bit#0 start
findiden(dref_iden, 4, 4, 16); !SEARCH DATA EP LIST
if linkname=0 then topicmn = topicmn+dref_l
finish
link = dref_link
repeat
j = integer(conad)+topicmn+256+workpt-workbase; !CURRENT SIZE+INITCMN+HIST+WORK
codesegs = (j+1<<18-1)>>18
glasegs = (ofm(2)_l+ofm(3)_l+ofm(5)_l+ofm(6)_l+1<<18-1)>>18
stacksegs = 1
stackstart = 190; !ALWAYS AT THIS SEGMENT
if 0<i<7 start
codestart = codesite(i)
glastart = codestart+codesegs
finish else start
if op->s1.(",").s2 start
codestart = pstoi(s1)
glastart = pstoi(s2)
j = glastart-codestart
if codesegs<j then codesegs = j
finish else report("Fault - invalid parameters") and ->next op
finish
cycle j = 35, 1, last segment
vm map(j) = 0
repeat
flag = check area(codestart, codesegs)
if flag=0 then flag = check area(glastart, glasegs)
if flag=0 then flag = check area(stackstart, stacksegs+1)
if flag#0 then report("Fault - cannot fit code/gla/stack as requested") and ->next op
printstring(snl.snl."File bound:".snl."
Codestart=".itos(codestart)."
Glastart=".itos(glastart)."
Stackstart=".itos(stackstart).snl)
codestart = codestart<<18
glastart = glastart<<18
stackstart = stackstart<<18+32
lbase(1) = ofm(1)_start+codestart; !START OF LOADED CODE
lbase(2) = glastart+ofm(3)_l; !START OF LOADED GLA
lbase(3) = glastart; !START OF LOADED PLT
lbase(4) = ofm(4)_start+codestart; !START OF LOADED SST
lbase(5) = lbase(2)+ofm(2)_l; !START OF LOADED UST
lbase(6) = lbase(5)+ofm(5)_l; !START OF INIT COMMON
lbase(7) = stackstart; !START OF LOADED INIT STACK
bind = i
->next op
oper(17): !CREATE DATA ENTRIES FOR COMMON REFS IN BOUND FILE
s1 = ".START"
cycle
getnext(9, 9, 12, "COMMON ref"); !SEARCH DATA REF LIST
if s1=".END" then exit
if s1#"#" start ; !FOUND
dref == record(outbase+currlinkname)
if dref_refarray&common bit#0 start
comme == record(workpos)
comme_link = common entry head; !ADD TO LINKED LIST
common entry head = addr(comme_link)
comme_iden = dref_iden; !JUST REQUIRE THE NAME
mprint(dref_iden)
finish else start
if xtype#4 then report("Fault - ".dref_iden." is not a COMMON ref")
finish
finish
repeat
newline
->next op
oper(18): !REMOVE FILE HISTORY
add history = 0
printstring("History removed".snl)
->next op
oper(19): !CREATE COMMON AREAS
create common = 1
next op:
repeat
!!
!!all input processed, now resolve refs and relocate for bind
!!first initialise lput, then can pass unresolved refs to it
!!
i = 0
setwork(i, j); !CREATE WORK FILE
outfile(outf, 4000, 0, 0, conad, flag); !TO SEE IF WE CAN CREATE IT
if flag#0 then error(10, flag); !REQUEST STOP
comreg(52) = addr(outf)
comreg(24) = 0; !ZERO RETURN CODE
lput(0, 0, 0, 0); !INITIALISATION CALL
!!
!!tell users of misuse of create common and comon entry
!!
if bind=0 start
if common entry head#0 then report("COMMON ENTRY applies only to bound files") and return
finish else start
if create common#0 then report("CREATE COMMON applies only to unbound files") and return
finish
!!
!!deal with procedure entries to be retained (or main entry)
!!
flag = 1
link = ldata(1)
while link#0 cycle
cent == record(outbase+link)
unless cent_loc>>30=1 then start ; !RETAIN, OR MAIN BIT SET
p1 = (cent_loc>>24&x'3F')!(cent_loc&x'80000000')
!AND IN MAIN BIT
p2 = cent_loc&x'FFFFFF'; !DISP
p3 = addr(cent_iden); !NAME
lput(11, p1, p2, p3)
flag = 0; !AT LEAST ONE ENTRY FOUND
finish
link = cent_link
repeat
!!
!!for bind, try to satisfy ext refs internally - else make lput calls for them
!!
cycle i = 7, 1, 8; !STATIC THEN DYNAMIC REFS
link = ldata(i)
while link#0 cycle
cref == record(link+outbase); !EXT REF RECORD
if bind#0 then start
findiden(cref_iden, 1, 1, 8); !SEARCH EP LIST
if linkname#0 then start ; !CAN SATISFY
cent == record(outbase+linkname)
loc = base(cref_refloc>>24)+cref_refloc&x'FFFFFF'
integer(loc) = x'B1000000'; !FILL DR0, DR1
integer(loc+4) = lbase((cent_loc>>24)&x'3F')+cent_loc&x'FFFFFF'
!PROPAGATE RELOCATION REQUEST:
lput(19, cref_refloc>>24, (cref_refloc&x'FFFFFF')+4, (cent_loc>>24)&x'3F')
->next ref
finish
finish
p1 = cref_refloc>>24; !AREA
p2 = cref_refloc&x'FFFFFF'; !DISP
p3 = addr(cref_iden); !NAME
lput(i+5, p1, p2, p3)
next ref:
link = cref_link
repeat
repeat
!!
!!now pass data entries to lput
!!
link = ldata(4)
while link#0 cycle
dent == record(outbase+link)
if dent_a&x'40000000'=0 then start ; !NOT SUPPRESSED
flag = 0; !AT LEAST ONE ENTRY LEFT
p1 = (dent_a&x'3F')<<24!dent_l
p2 = dent_disp
p3 = addr(dent_iden)
lput(14, p1, p2, p3); !NOTE DATA ENTRY
finish
link = dent_link
repeat
if flag#0 then start
report("Fatal error - no entry in file")
return
finish
! PASS LIST11 REFS THROUGH UNALTERED MEANTIME.
! N.B. LIFTING THIS RESTRICTION WOULD REQUIRE A MAJOR REWRITE
link = ldata(11)
while link#0 cycle
cref == record(outbase+link)
p1 = cref_refloc>>24
p2 = cref_refloc&x'FFFFFF'
p3 = addr(cref_iden)
lput(22, p1, p2, p3)
link = cref_link
repeat
!!
!!now deal with data refs - for bind, try to satisfy internally
!!and add init common to gla if required
!!otherwise make lput calls
!!
link = ldata(9)
topicmn = ofm(6)_l; !TOP OF INITIALISED COMMON
newline
while link#0 cycle
dref == record(link+outbase)
refarray = (dref_refarray&x'7FFFFFFF')+outbase
common = dref_refarray&x'80000000'; !NOTE COMMON BIT
n = integer(refarray)
refloc = refarray+4
p3 = addr(dref_iden)
if bind#0 then start
findiden(dref_iden, 4, 4, 16); !SEARCH DATA EP LIST
if linkname=0 then start ; !NOT FOUND
if matchs(dref_iden, "ICL9CEAUXST")=yes then start ; !SPECIAL CASE - REF TO AUX STACK
cycle n = 1, 1, n
p1 = integer(refloc)&x'FF000000'!dref_l
p2 = integer(refloc)&x'FFFFFF'
lput(15, p1, p2, p3); !REMAKE CALL FOR AUX STACK
refloc = refloc+4
repeat
->next dref
finish
if common#0 then start ; !CREATE COMMON AREA
lput(36, dref_l, topicmn, 0); !FILL WITH ZEROS
ad = topicmn+lbase(6)
relarea = 2; !RELOCATE ICMN WRT GLA SEGMENT
printstring("ICMN area created for ".dref_iden." Length =")
write(dref_l, 1); newline
i = common entry head; !CHECK IF WE WANT TO GENERATE AN ENTRY
while i#0 cycle
comme == record(i)
if matchs(comme_iden, dref_iden)=yes start ; !FOUND, GENERATE ENTRY
lput(14, (6<<24)!dref_l, topicmn, p3)
exit
finish
i = comme_link
repeat
topicmn = (topicmn+dref_l+7)&x'fffffff8'; !RESET TOP
finish else ->lput dref
finish else start
dent == record(outbase+linkname)
relarea = dent_a&x'FF'
ad = lbase(relarea)+dent_disp
finish
cycle n = 1, 1, n; !NOW RELOCATE REFS
p1 = integer(refloc)>>24; !AREA CONTAINING WORD
p2 = integer(refloc)&x'FFFFFF'; !OFFSET OF WORD
loc = base(p1)+p2; !ADDRESS OF WORD
integer(loc) = integer(loc)+ad; !RELOCATE WORD
lput(19, p1, p2, relarea); !PROPAGATE RELOCATION REQUEST
refloc = refloc+4
repeat
finish else start ; !BIND NOT SET
if create common=1 and common#0 start
findiden(dref_iden, 4, 4, 16); !CHECK DATA ENTRIES
if linkname=0 start ; !NO ENTRY FOUND
lput(36, dref_l, topicmn, 0); !CREATE COMMON AREA
lput(14, (6<<24)!dref_l, topicmn, p3); !CREATE DATA ENTRY
printstring("ICMN area created for ".dref_iden." Length =")
write(dref_l, 1); newline
topicmn = topicmn+dref_l
finish
finish
lput dref:
cycle n = 1, 1, n
p1 = (integer(refloc)&x'FF000000')!dref_l
p2 = integer(refloc)&x'FFFFFF'
if common=0 then lput(15, p1, p2, p3) else lput(10, p1, p2, p3)
refloc = refloc+4
repeat
finish
next dref:
link = dref_link
repeat
!!
!! now deal with relocation requests
!!
link = ldata(14)
while link#0 cycle
rel == record(link+outbase)
relad = addr(rel_relad)
cycle n = 1, 1, rel_n; !NO OF RELOCATION ENTRIES IN THIS BLOCK
areacode = integer(relad)>>24
areadisp = integer(relad)&x'FFFFFF'
basecode = integer(relad+4)>>24
basedisp = integer(relad+4)&x'FFFFFF'
loc = base(areacode)+areadisp
integer(loc) = integer(loc)+basedisp
if bind#0 then integer(loc) = integer(loc)+lbase(basecode)
lput(19, areacode, areadisp, basecode); !PROPAGATE EVEN FOR BOUND FILE
relad = relad+8
repeat
link = rel_link
repeat
!!
!!pass rest of object file to lput
!!
arealength(8) = arealength(8)+topicmn-ofm(6)_l; !ADJUST GRAND TOTAL
cycle i = 1, 1, 7
lput(30+i, arealength(i), 0, base(i)); !PASS EACH AREA
repeat
arealength(6) = topicmn; !NOW UPDATE FOR ANY EXTRA COMMON CREATED
lput(7, 32, 0, addr(arealength(1))); !CURRENT FILE IS COMPLETE
!!
!!now add history to completed file
!!
if comreg(24)#0 start
report("LPUT fails to create output file")
return
finish
histbeg = ldata(12)+outbase; !NOTE THIS BEFORE MAPPING LDATA TO NEW FILE
connect(outf, 3, 0, 0, r, flag); !SOME LPUTS DISCONNECT!!
if flag#0 start
report("Cannot reconnect file")
error(1000, flag)
return
finish
conad = r_conad
ldata == array(conad+integer(conad+24), ldataaf); !MAPPED TO NEW FILE
newsize = integer(conad)
if add history=1 start
histsize = histbeg; !FIND END OF OLD HISTORY DATA
if histsize>0 start
histsize = histsize+2+byteinteger(histsize+1) while byteinteger(histsize)#0
finish
histsize = histsize-histbeg; !LENGTH OF DATA
unless infile->s1.(".").s2 then infile = uinfs(1).".".infile
if bind#0 start
newhist = "Bound object file
From object : ".infile."
Fixed site : ".htos(codestart, 8)." ".htos(glastart, 8)." ".htos(stackstart, 8)
finish else start
newhist = "Modified object file
From object : ".infile
finish
n = integer(r_conad); !NOW CHECK FILE IS BIG ENOUGH
maxsize = (n+4095)//4096*4096
newsize = (histsize+length(newhist)+3+n+4095)//4096*4096
if newsize>maxsize then start
changefilesize(outf, newsize, flag); !EXTEND FILE
if flag=261 then start ; !VM HOLE TOO SMALL
disconnect(outf, flag)
changefilesize(outf, newsize, flag)
finish
if flag=0 then connect(outf, 3, 0, 0, r, flag)
if flag#0 then report("Cannot add history") and error(1000, flag)
integer(r_conad+8) = newsize
finish
conad = r_conad
ldata == array(conad+integer(conad+24), ldataaf)
ldata(12) = integer(conad); !HISTORY STARTS AT END OF FILE
j = conad+integer(conad); !END OF THE FILE
byteinteger(j) = 8; !GENERAL TEXT RECORD
string(j+1) = newhist; !ADD NEW HISTORY TEXT
j = j+2+length(newhist)
byteinteger(j) = 6; !DATE FROM ORIGINAL FILE
byteinteger(j+1) = 4; !LENGTH OF PACKED D&T
move(4, dt, j+2); !MOVE FROM FILE HEADER
j = j+6
move(histsize, histbeg, j); !ADD OLD HISTORY
j = j+histsize
integer(j) = 0; !END OF HISTORY
integer(conad) = j+1-conad; !SET NEW LENGTH OF FILE
finish
!!
!!
if bind#0 then start
ldata(5) = codestart; !VALUES FOR THE LOADER
ldata(6) = glastart
ldata(10) = stackstart
finish else start ; !COPY CODE ATTRIB EXCEPT FOR BOUND FILE
i = conad+integer(conad+28)+12; !@ OF CODE ATTR IN OFM
integer(i) = code attributes
finish
!!
!! copy across any omf diagnostic records
!!
if omfdiags#0 then start
j = omfdiags+outbase
while halfinteger(j)#0 cycle ; !FIND END OF OMF DIAGS
j = j+halfinteger(j)
repeat
j = j+2; !INCLUDE TERMINATOR
j = j-omfdiags-outbase; !SIZE OF DIAGNOSTICS
n = integer(r_conad)
maxsize = (n+4095)//4096*4096
newsize = (n+j+4095)//4096*4096
if newsize>maxsize then start
changefilesize(outf, newsize, flag)
!EXTEND FILE
if flag=261 then start ; !VM HOLE TOO SMALL
disconnect(outf, flag)
changefilesize(outf, newsize, flag)
finish
if flag=0 then connect(outf, 3, 0, 0, r, flag)
if flag#0 then start
report("Cannot add OMF diagnostics")
error(1000, flag)
return
finish
integer(r_conad+8) = newsize
finish
conad = r_conad
ldata == array(conad+integer(conad+24), ldataaf)
ldata(0) = 15 if ldata(0)<15
ldata(15) = integer(conad); !DIAGS START AT END OF FILE
move(j, outbase+omfdiags, conad+ldata(15))
integer(conad) = integer(conad)+j
finish
disconnect(outf, flag)
if bind#0 and (newsize+(1<<18)-1)>>18>codesegs then c
report("Failure - new object file will not fit in specified site") and return
if outf="T#MODLPUT" start
if pd->s1.("_").s2 start
modpdfile(2, s1, s2, "", flag); !DESTROY MEMBER
modpdfile(1, s1, s2, "T#MODLPUT", flag)
finish else newgen("T#MODLPUT", infile, flag)
if flag#0 then error(10, flag)
finish
if flag=0 then report("OK") and printstring(snl."Modify successful".snl)
select output(0)
close stream(stlist)
clear(itos(stlist))
destroy("T#MODLPUT", flag)
destroy("T#MODWORK", flag)
end ; !OF MODIFY
end of file