begin ; !APM IMP Library
!** NB must not contain owns
!** Value of string FNAME must be name of MOB file
!** Some string value parameters masquerading as names
!
!IMP PRIM+PERM procedures are dealt with in one of four ways:
! . never called -- in-line code generated (eg store-mapping)
! . included in APM system and called via extracode call vector,
! (eg floating point routines)
! . compiled into program as procedures (eg array access)
! . included in this library which is pre-loaded and referenced
! by external call mechanism (except for CONNECT and EXTLOAD
! which are inserted into the extracode call vector when loaded)
!
@16_1114 routine signal(integer code)
@16_1198 routine phex(integer x)
recordformat DICT(integer a,b,c,d)
@16_3FAC integer cliparamad
@16_3FC0 record (dict) FILDICT
@16_3FD0 record (dict) EXTDICT
@16_3FE0 record (dict) SYSDICT
@16_117C integerfn DEFNAME(string (255)s,record (dict)name d,
integer size)
@16_1180 integerfn REFNAME(string (255)s,record (dict)name d)
@16_1184 routine TRANSNAME(integer ref,string (255)name s)
@16_1110 integerfn FCOMMR(integer c,string (255)p,
bytename b,integer max)
@16_1100 routine ETHERWRITE(integer port,bytename buf,
integer size)
@16_1104 integerfn ETHERREAD(integer port,bytename buf,
integer max)
!
!!!!!!!!!!!!!!!!! Floating-point input/output !!!!!!!!!!!!!!!!!!!!!!!
externalroutine FREAD alias "read"(name v)
!Called only for reals
integer sign=0,sym
real value,exp
cycle
sym = nextsymbol
exit if sym > ' '
skipsymbol
repeat
if sym = '-' start
sign = 1
skip symbol; sym = nextsymbol
finish
value = 0
if sym # '.' start
signal 4,1,sym unless '0' <= sym <= '9'
cycle
value = value*10.0+(sym-'0')
skip symbol; sym = nextsymbol
repeat until not '0' <= sym <= '9'
finish
if sym = '.' start
exp = 10.0
cycle
skip symbol; sym = nextsymbol
exit unless '0' <= sym <= '9'
value = value+(sym-'0')/exp
exp = exp*10.0
repeat
finish
if sym = '@' start
skipsymbol
read(sym)
value = value*10.0^sym
finish
value = -value if sign # 0
! v = value
*move v,a0
*move value,(a0)
end ; !fread
externalroutine READREAL(realname v)
fread(v)
end
externalroutine PRINT(real x, integer n,m)
constreal pmax = 2147483647.0
real y,z
integer i=0,l,count=0,sign
sign = ' '
sign = '-' if x < 0
y = |x|+0.5/10.0^m; !modulus, rounded
if y > pmax start
count = count+1 and y = y/10.0 until y < 10.0
finish
z = 1.0
cycle
i = i+1; z = z*10.0
repeat until z > y
spaces(n-i)
printsymbol(sign) unless sign = ' ' and n <= 0
cycle
z = z/10.0
l = int pt(y/z)
y = y-l*z
printsymbol(l+'0')
i = i-1
exit if i+m <= 0
print symbol('.') if i = 0
repeat
printsymbol('@') and write(count,0) if count # 0
end ; !print
externalroutine PRINTFL(real x, integer n)
real y,round
integer count=-99,sign=0
if x # 0 start
x = -x and sign = 1 if x < 0
!Adjust X so that 1.0 <= rounded(X) < 10.0
count = 0; round = 0.5^n
y = 1.0-round
if x < y start ; !ie rounded(X) < 1.0
count = count-1 and x = x*10.0 until x >= y
finish else start
y = 10.0-round
while x >= y cycle ; !ie rounded(X) > 10.0
count = count+1; x = x/10.0
repeat
finish
x = -x if sign # 0
finish
print(x,1,n)
printsymbol('@')
write(count,0)
end ; !printfl
externalintegerfn int(real r)
result = intpt(r+0.5)
end
externalrealfn fraction(real r)
result = fracpt(r) if r>=0
result = -fracpt(-r)
end
externalintegerfn round(real r)
result = int(r)
end
externalintegerfn trunc(real r)
result = intpt(r) if r>=0
result = -intpt(-r)
end
!!!!!!!!!!!!!!!!!!!! Stream control !!!!!!!!!!!!!!!!!!!!!!!!
constinteger iocbsize=16, iocbshift=4
constinteger icb0=16_35ce, ocb0=16_360e
@16_35c6 integer icb
@16_35ca integer ocb
externalintegerfn INSTREAM
result = (icb-icb0)>>iocbshift
end
externalintegerfn OUTSTREAM
result = (ocb-ocb0)>>iocbshift
end
!!!!!!!!!!!!!!!!!!!! String procedures !!!!!!!!!!!!!!!!!!!!!!!!
externalstring (255)fn SUBSTRING(string (255) s, integer from,to)
string (255) t
t = ""
while from <= to cycle
t = t.tostring(charno(s,from)); from = from+1
repeat
result = t
end
externalintegerfn INDEX(string (*)name var,match)
!Return index position of first occurrence of match within string
!** to be re-coded for efficiency **
integer i=0,j,l=length(match)
cycle
result = 0 if i > length(var)-l
i = i+1
j = 0
cycle
result = i if j = l
j = j+1
repeat until charno(var,i+j-1) # charno(match,j)
repeat
end
predicate RESOLVE(string (*)name var,match,fore,aft)
integer i
routine do aft
aft = substring(var,i+length(match),length(var)) if addr(aft) # 0
end
i = index(var,match)
false if i = 0
if addr(fore) # 0 start
if addr(fore) # addr(var) start
fore = substring(var,1,i-1)
do aft
finish else start
do aft
length(var) = i-1
finish
finish else do aft
true
end
external string (127)fn ITOS(integer v,p)
integer vv,q,pos
byteintegerarray store(0:127)
vv = v; vv = -vv if vv > 0
pos = 127
while vv <= -10 cycle
q = vv//10
store(pos) = q*10-vv+'0'; pos = pos-1
vv = q
repeat
store(pos) = '0'-vv
if p <= 0 start
p = 128+p
else
p = 128-p
p = pos if p > pos
p = p-1
finish
pos = pos-1 and store(pos) = '-' if v < 0
while pos > p and pos > 1 cycle
pos = pos-1; store(pos) = ' '
repeat
pos = pos-1; store(pos) = 127-pos
result = string(addr(store(pos)))
end
external integer fn STOI(string (255) S)
integer i,k
integer sign=0, val=0
i = 0
while i < length(s) cycle
i = i+1; k = charno(s,i)
continue if k <= ' '
if k = '-' start
sign = 1
else if '0' <= k <= '9'
val = val<<3+val+val+k-'0'
else
signal 3, 1, k
finish
repeat
result = val if sign = 0
result = -val
end
externalroutinespec PRINT LINE(string (255) s)
externalroutine PRINT LINE
*JSR printstring
newline
end
externalroutine READ LINE(string (255)name s)
integer k
s = ""
cycle
read symbol(k)
return if k < ' '
s = s.tostring(k)
repeat
end
externalroutine READ STRING(string (*)name s)
integer k
readsymbol(k) until k>' '
s = ""
cycle
s = s.tostring(k)
k = nextsymbol; returnif k<=' '
skipsymbol
repeat
end
externalstring (31)fn DATETIME
string (31)s
length(s) = fcommr('G'<<8,"",charno(s,1),31)
result = s
end
externalstring (8)fn DATE; !** No owns
!%string(31)s
! s = datetime; length(s) = 8; %result = s
*BSR DATETIME; !ad -> A0
*MOVE.B #8,(A0); !alter length
end
externalstring (5)fn TIME; !** No owns
!%string(31)s
!%integer p
! s = datetime; p = addr(s)+length(s)-5
! byteinteger(p) = 5; %result = string(p)
*BSR DATETIME
*LEA 10(A0),A0; *MOVE.B #5,(A0); !adjust start & length
end
!!!!!!!!!!!!!!!!!!!!!!! Parameter processing !!!!!!!!!!!!!!!!!!!!!!!!!!
externalstring (255)fn CLIPARAM
!Gives effect of VAX/VMS function for obtaining command parameters
string (255) s
! %if cliparamad>0 %start
s = string(cliparamad)
result = "" if shortinteger(cliparamad)=511
result = s unless s=""
! %finish
skip symbol while nextsymbol = ' '
read line(s)
result = s
end
!!!!!!!!!!!!!!!!!!!!!! File connection !!!!!!!!!!!!!!!!!!!!!!!!!
recordformat CONNINFO(integer memstart,fstart,flim,memlim)
externalroutine CONNECT(string (255)name f,record (conninfo)name d)
!Read in the file F to space allocated on the heap
! Allocate a total of D_FSTART + fsize + D_MEMLIM bytes
! and align file to D_FSTART within this space;
! D_MEMSTART := start of space; D_FSTART := D_FSTART+D_MEMSTART
! D_FLIM := D_FSTART+fsize; D_MEMLIM := D_MEMLIM+D_FLIM
@16_35C4 short uno
@16_372C byte cylock
@16_372D byte fsport
integer i,j,xno,len,blocks,pos,fsize,fpos,original
string (255) fscomm
routine lock
cylock = cylock+1
end
routine unlock
returnif cylock=0
cylock = cylock-1
cylock = 0 and signal 0,1 if cylock=128
end
routine GET(integername v)
!Extract numeric info from FSCOMM
integer k
v = 0
cycle
i = i+1; k = charno(fscomm,i)
i = i-1 if k < ' '
k = k-'0'
return if k < 0
v = v<<4+k
repeat
end
routine READ FILE(integer ok)
integer j
unless fsize=0 start
if fpos#0 start
j = fsize-4
while j>=0 cycle
j = j-4; integer(pos) = integer(fpos)
pos = pos+4; fpos = fpos+4
repeat
j = j+4-1
while j>=0 cycle
j = j-1; byteinteger(pos) = byteinteger(fpos)
pos = pos+1; fpos = fpos+1
repeat
else
cycle
j = 512; j = fsize if fsize<j
j = etherread(fsport,byteinteger(pos),j)
pos = pos+j if ok # 0; fsize = j unless fsize=0
repeatuntil j#512
finish
finish
unlock
end
if f # "" start
j = refname(f,fildict); fpos = 0
if j>0 and integer(j)>0 start ; !File already in store
fpos = integer(j); fsize = integer(j+4)-fpos
fpos = 0 if fsize<=0
finish
if fpos=0 start ; !Read file from filestore
lock
fscomm = "Z".tostring(uno+'0').f.tostring(nl)
etherwrite(fsport,charno(fscomm,1),length(fscomm))
len = etherread(fsport,charno(fscomm,1),255);!Read response
if charno(fscomm,1) = '-' start
unlock
event_extra = charno(fscomm,2)-'0'
charno(fscomm,2) = len-2
event_message = string(addr(charno(fscomm,2)))
signal(16_39)
finish
i = 0
get(blocks); get(fsize)
fsize = blocks<<9-fsize; !size of file in bytes
finish
finish else fsize = 0
!Allocate space
*MOVE D6,pos; *MOVE A7,j; !**Heap -><- Stack **
if pos+fsize+d_fstart+d_memlim >= j start ; !no space
read file(0)
event_message = "*No space to connect ".f
signal(16_49)
finish
pos = pos-256; !HP displaced by 256
d_memstart = pos
pos = pos+d_fstart; d_fstart = pos
read file(1)
d_flim = pos
pos = pos+d_memlim; d_memlim = pos
pos = (pos+259)&(¬3); !aligned
*MOVE pos,D6
end
externalroutine CONNECT FILE(string (255) f, integer mode,
integername start,len)
record (conninfo) r
r = 0; connect(f,r); start = r_fstart; len = r_flim-start
end
!!!!!!!!!!!!!!!!!!!!!!! External loading !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine EXTLOAD
*MOVE 4(A7),A3; !**allow for LINK**
integer lmax=-1, errors=0
{%integer level=0
record (conninfo)array LOADED(0:63)
string (255) fid
routine LOAD(integer p,a)
integer i,q,r,e,b,fref,idref
record (conninfo)name L
{%integer count=0
{spaces(level)
while shortinteger(p) # 0 cycle ; !For each ref
{printstring(string(p))
idref = refname(string(p),extdict); !lookup in ext dict
if idref <= 0 start
printstring("*Unknown external: ".string(p)); newline
errors = errors+1
finish else start
fref = integer(idref)
i = -1
cycle
i = i+1; l == loaded(i)
if i > lmax start ; !first use of this file
lmax = i; l = 0; !new cell
{printstring("=>")
{ %if integer(fref) <= 0 %start; !not permanently loaded
transname(fref,fid); !recover name of file
{printstring(fid); newline
connect(fid,l); !read it in
l_memstart = fref
{%for i = 0,1,lmax %cycle
{ space; phex(loaded(i)_memstart)
{ newline %if i&7 = 7
{%repeat
{newline
i = l_flim-2
i = i+shortinteger(i); !entry point
b = l_flim-6-shortinteger(i+6)<<1; !start of owns
l_flim = b
if i+60 < b start ; !ext specs present
{level = level+2; newline
load(i+40,b)
{level = level-2; spaces(level)
finish
finish else start
{ l_fstart = integer(fref); l_memstart = fref
{ %finish
finish
repeat until l_memstart = fref
q = l_fstart+2; !start of externals
e = 0
while byteinteger(q) < 12 cycle ; !find & set Q to end
e = q if string(q) = string(p)
q = q+20
repeat
if e = 0 start
printstring("*".string(p)." no longer valid"); newline
stop
finish
if integer(p+12) # integer(e+12) start
if (integer(p+12)!!integer(e+12))&4#0 start
printstring("*Class mismatch for ".string(p)); newline
stop
finish
! printstring("*Type mismatch for ".string(p)); newline
! %stop
finish
r = integer(p+16)+a; !disp of ref + A6
if integer(p+12)&4 # 0 start ; !procedure
shortinteger(r) = 16_2C7C; !MOVE.L #xxxxxxxx,A6
integer(r+2) = l_flim; !start of owns
shortinteger(r+6) = 16_4EF9; !JMP xxxxxxxx
integer(r+8) = q+integer(e+16); !entry-point
finish else start
integer(r) = l_flim+integer(e+16)
{phex(integer(r))
finish
finish
p = p+20
{%if shortinteger(p) # 0 %start
{ printsymbol(','); count = count+1
{ newline %and spaces(level) %and count = 0 %if count = 6
{%finish
repeat
{newline
end
*MOVE A3,D0; *ADDQ #4,D0
*MOVE A6,D1
*BSR load
stop if errors # 0
end
!Parameter records:
recordformat INFO(string (255) name,
integer addr,short size,flags,
record (info)name link)
!Base record
recordformat PAMINFO(byte groupsep,keyflag, short allflags,
record (info)name chain)
external record (paminfo)map PAM
record (paminfo)name p
predicate ok(record (info)name p)
integer q
*move d6,q
while p ## nil cycle
false unless 16_800000 < addr(p) < q and addr(p)&1 = 0
p == p_link
repeat
true
end
p == record(refname("PAM_INFO",sysdict))
if addr(p) <= 0 start
p == record(defname("PAM_INFO",sysdict,sizeof(p)))
p_chain == nil; p_allflags = 0
p_groupsep = '/'; p_keyflag = '-'
finish
p_chain == nil and p_allflags = 0 if not ok(p_chain)
result == p
end
!Branch table entry displacement addresses:
constinteger connted=16_11BA, loadted=16_11BE, resolted=16_11B6
conststring (19)FNAME="I:LIB.MOB"
@16_3ff0 integer freebot
integer i,j
!Insert CONNECT, EXTLOAD & RESOLVE
j = shortinteger(connted)+connted+2
*lea connect,a0
*move.l a0,i
integer(j) = i
j = shortinteger(loadted)+loadted+2
*lea extload,a0
*move.l a0,i
integer(j) = i
j = shortinteger(resolted)+resolted+2
*lea resolve,a0
*move.l a0,i
integer(j) = i
!Install entry-points
j = refname(fname,fildict)
printstring(fname." not in dict!") and stop if j <= 0
i = integer(j)+2
while 1<=byteinteger(i)<=11 cycle
integer(defname(string(i),extdict,8)) = j
i = i+20
repeat
!Lock file in store
freebot = integer(j+4)+4
printstring("IMPLIB loaded"); printsymbol(nl)
endofprogram