!Misc Imp Library
option "-low-nocheck-nodiag-noline"
systemintegerfn freestore
@724(a5) integername heapfront
result = a7-heapfront
! *move.l sp,d0
! *sub.l d6,d0
end
systemroutine newline
printsymbol(nl)
end
systemroutine newlines(integer n)
while n>0 cycle
n = n-1; printsymbol(nl)
repeat
end
systemroutine space
printsymbol(' ')
end
systemroutine spaces(integer n)
while n>0 cycle
n = n-1; printsymbol(' ')
repeat
end
systemstring (255)fn readstring
! a STRING is deemed a sequence of non-control characters,
! hence, as for numbers, leading control characters are skipped,
! and the terminating one is not.
string (255)s
integer k
s = ""
readsymbol(k) until k>' '
cycle
s = s.tostring(k)
exitif nextsymbol<=' '
readsymbol(k)
repeat
result = s
end
systemroutine readline(string (255)name s)
! a LINE is a sequence of non-NL characters and may be empty,
! hence blank lines are not skipped, and leading and trailing
! spaces are significant. The terminating NL is skipped, to
! make it "pipe-compatible" with printline.
integer k
s = ""
cycle
readsymbol(k); exitif k=nl
s = s.tostring(k)
repeat
end
systemroutine printline(string (255)s)
printstring(s)
printsymbol(nl)
end
systemroutine to lower(string (*)name s)
integer i
bytename b
i = length(s); returnif i=0
b == charno(s,1)
cycle
b = b!32 if 'A'<=b<='Z'
b == b[1]
i = i-1
repeatuntil i<=0
end
systemroutine to upper(string (*)name s)
integer i
bytename b
i = length(s); returnif i=0
b == charno(s,1)
cycle
b = b&95 if 'a'<=b<='z'
b == b[1]
i = i-1
repeatuntil i<=0
end
systemroutine to mixed(string (*)name s)
! "Beautify" S by turning every leading letter into upper case.
! de disgustibus non est putandum
integer case=0,i
bytename b
i = length(s); returnif i=0
b == charno(s,1)
cycle
if 'a'<=b!32<='z' then b = b&95+case and case = 32 else case = 0
b == b[1]
i = i-1
repeatuntil i<=0
end
systemstring (9)fn itoh(integer n)
string (9)s=""
integer i,k
for i = 28,-4,0 cycle
k = n>>i&15; k = k+7 if k>9; s = s.tostring(k+'0')
repeat
result = s
end
systemintegerfn htoi(string (255)s)
integer n=0,p=0,k
cycle
p = p+1
result = n if p>length(s)
k = charno(s,p); continueif k<=' '
k = k-'0'
if k>9 start
k = k-7 if k-7>9
k = k-32 if k>15
finish
result = n unless 0<=k<=15
n = n<<4+k
repeat
end
systemintegerfn 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 4, 1, k, "Non-numeric character"
finish
repeat
result = val if sign = 0
result = -val
end
systemstring (127)fn itos(integer v,p)
string (127)store
bytename l
routine printsymbol(integer x)
l = l+1; charno(store,l) = x
end
routine spaces(integer x)
x = x-1 and printsymbol(' ') while x>0
end
routine write(integer n,p)
integer q,r
if p>0 start
p = ¬p; printsymbol(' ') and p = p+1 if n>=0
finish
p = -120 if p<-120
q = n//10; *move.l d1,r
if q=0 start
p = p+1 if n<0; spaces(-1-p); printsymbol('-') if n<0
else
p = p+1 if p<0; write(q,p)
finish
printsymbol(|r|+'0')
end
store = ""; l == length(store)
write(v,p)
result = store
end
systemstring (127)fn rtos(real r,integer n,m)
constreal pmax = 2147483647.0
real y,z
integer i=0,l,count=0,sign
string (127) result = ""
!
sign = ' '
sign = '-' if r < 0
y = |r|+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
result = result." " for l = 1,1,n-i; !l not used before here
result = result.tostring(sign) unless sign = ' ' and n <= 0
cycle
z = z/10.0
l = int pt(y/z)
y = y-l*z
result = result.tostring(l+'0')
i = i-1
exit if i+m <= 0
result = result."." if i = 0
repeat
result = result."@".itos(count,0) if count # 0
result = result
end ; !rtos
systemstring (127)fn rtof(real x, integer n)
real y,round
integer count=-99,sign=0
string (127) result=""
!
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
result = rtos(x,1,n)
result = result."@".itos(count,0)
result = result
end ; !flrtos
!Original grotty faulty version
!%systemrealfn stor(%string(255)input)
! !reads a real from the string, assuming string starts with the real
! !(or blank spaces followed by a real)
! %integer sign=0,sym,pos=0
! %real value,exp
! !
! input=input."!"; !check that there is a finish character
! %cycle
! sym = charno(input,pos+1)
! %exit %if sym > ' '
! pos=pos+1
! %repeat
! %if sym = '-' %start
! sign = 1
! pos=pos+1; sym = charno(input,pos+1)
! %finish
! value = 0
! %if sym # '.' %start
! %signal 6,5,pos %unless '0' <= sym <= '9'; !charno out of range
! %cycle
! value = value*10.0+(sym-'0')
! pos=pos+1; sym = charno(input,pos+1)
! %repeat %until %not '0' <= sym <= '9'
! %finish
! %if sym = '.' %start
! exp = 10.0
! %cycle
! pos=pos+1; sym = charno(input,pos+1)
! %exit %unless '0' <= sym <= '9'
! value = value+(sym-'0')/exp
! exp = exp*10.0
! %repeat
! %finish
! %if sym = '@' %start
! pos = pos+1
! sym = charno(input,pos+1); pos = pos+1
! value = value*10.0¬(sym-'0')
! %finish
! value = -value %if sign # 0
! %result = value
!%end; !stor
!Working version, courtesy of RMM (as if it wasn't obvious
!from the grotesque 'aesthetic' source layout)
system real function S To R (string (255) Input)
integer Sign = 0,
Sym,
Pos = 1
long real Value,
Exp
routine Next
Pos = Pos + 1
if Pos > Length (Input) start
Sym = 0
else
Sym = Char No (Input, Pos)
finish
end
Sym = Char No (Input, Pos)
if Sym = '-' start
Sign = 1
Next
finish
Value = 0
if Sym # '.' start
signal 6, 5, Pos unless '0' <= Sym <= '9' {Char No out of range}
cycle
Value = Value*10.0 + (Sym - '0')
Next
repeat until not '0' <= Sym <= '9'
finish
if Sym = '.' start
Exp = 10.0
cycle
Next
exit unless '0' <= Sym <= '9'
Value = Value + (Sym - '0')/Exp
Exp = Exp * 10.0
repeat
finish
if Sym = '@' start
Sym = S To I (Sub String (Input, Pos + 1, Length (Input)))
Value = Value * 10.0¬Sym
finish
Value = -Value if Sign # 0
result = Value
end {S To R}
systemrealfn ftor(string (255)s)
result = stor(s)
end
systemstring (255)fn infilename
result = "[INFILENAME]"
end
systemstring (255)fn outfilename
result = "[OUTFILENAME]"
end
systemintegerfn xread alias "read"
integer i,k,sign,ten=10,max='9'
cycle
k = next symbol
exit if k > ' '
skip symbol
repeat
sign = 0
if k = '-' start
sign = 1
skip symbol; k = next symbol
finish
cycle
signal 4,1,nextsymbol,"Non-numeric character to READ" unless '0'<=k<=max
i = k-'0'
cycle
skip symbol
k = next symbol
k = k-32 if k>='a'
if k>'9' start
exitif k<'A'
k = k-7
finish
exit unless '0' <= k <= max
i = i*ten-'0'+k
repeat
exitunless k='_'-7
ten = i; max = '0'+ten-1
skipsymbol; k = nextsymbol
k = k-32 if k>='a'
if k>'9' start
k = -1 if k<'A'
k = k-7
finish
repeat
i = -i if sign # 0
result = i
end
systemrealfn readreal
integer sign=0,sym
real value,exp
routine read(integername n)
n = xread
end
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,"Non-numeric character to READ" 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
result = value
end ; !read real
systemroutine write(integer n,p)
integer q,r
if p>0 start
p = ¬p; printsymbol(' ') and p = p+1 if n>=0
finish
p = -120 if p<-120
q = n//10; *move.l d1,r
if q=0 start
p = p+1 if n<0; spaces(-1-p); printsymbol('-') if n<0
else
p = p+1 if p<0; write(q,p)
finish
printsymbol(|r|+'0')
end
systemroutine 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
systemroutine 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
systemroutine phex1(integer x)
x = x&15; x = x+7 if x>9; printsymbol(x+'0')
end
systemroutine phex2(integer x)
phex1(x>>4); phex1(x)
end
systemroutine phex4(integer x)
phex2(x>>8); phex2(x)
end
systemroutine phex(integer x)
phex4(x>>16); phex4(x)
end
systemintegerfn rhex
integer n=0,s
onevent 4 start
signal 4,1,s,"Non-numeric character to RHEX"
finish
cycle
s = nextsymbol; exitif s>' '
skipsymbol
repeat
s = s&95 if s>='a'
signal 4 unless '0'<=s<='9' or 'A'<=s<='F'
while '0'<=s<='9' or 'A'<=s<='F' cycle
s = s-'0'; s = s-7 if s>9
n = n<<4+s; skipsymbol; s = nextsymbol
s = s&95 if s>='a'
repeat
result = n
end
systempredicate resolves(string (*)name var,match,fore,aft)
!!Resolve the string specified by VAR into FORE and AFT split by MATCH
!![FORE and/or AFT absent is conventionally represented by an address
!! of zero]
@0string (*) null
integer i
integerfn resol(string (*)name var,match)
!Return index position of first occurrence of MATCH within VAR
label yes,no
*clr.l d0
*clr.w d1
*move.b (a1)+,d1 {length(match)
*beq yes {match="" ->
*clr.w d2
*move.b (a0)+,d2 {length(var)
*sub.b d1,d2
*bcs no {length(match)>length(var) -> {*bug: was bmi
*subq.w #1,d1
loop1:
*lea 0(a0,d0),a2
*move.l a1,a3
*move d1,d3
loop2:
*cmpm (a2)+,(a3)+
*dbne d3,loop2 {*bug?was dbeq
*beq yes
*addq.w #1,d0
*dbra d2,loop1
no: *moveq #-1,d0
yes:*addq.l #1,d0
!** (to be) re-coded for efficiency **
! %integer i=0,j,l
! 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
routine assign(string (*)name dest, integer from,to)
!! **NB use of TOSTRING is compiled in-line **
!! **OK when DEST is also source **
dest = ""
while from <= to cycle
dest = dest.tostring(charno(var,from)); from = from+1
repeat
end
routine do aft
assign(aft,i+length(match),length(var)) unless aft==null
end
i = resol(var,match)
false if i = 0
if fore ## null start
if fore ## var start
assign(fore,1,i-1)
do aft
finish else start
do aft
length(var) = i-1
finish
finish else do aft
true
end
! Bulk move
systemroutine smoveblock(integer bytes,from,to)
!"signed" move block
!if bytes>0 then move (from)+ to (to)+ but
!if bytes<0 then from:=from-bytes, to:=to-bytes, move -(from) to -(to)
label f1,f2,f3,f4,f5,f6,f7,b0,b1,b2,b3,b4,b5,b6,b7,end
*move.l d1,a0
*move.l d2,a1
*eor d1,d2
*tst.l d0
*bmi b0; !copy backwards ->
*beq end; !copy nothing ->
*btst #0,d2; !if (from!!to)&1#0 then
*bne f5; !copy bytewise ->
*btst #0,d1; !if from&1=0 then
*beq f1; !go for longword loop ->
*move.b (a0)+,(a1)+; !copy first byte to even up
*subq.l #1,d0
f1: *moveq #3,d2
*and d0,d2; !remainder for byte loop
*subq.l #4,d0
*bmi f4; !bytes<4 ->
*lsr.l #2,d0; !longwords-1
*bra f3
f2: *swap d0; !longword loop
f3: *move.l (a0)+,(a1)+
*dbra d0,f3
*swap d0
*dbra d0,f2
f4: *move.l d2,d0
f5: *subq.l #1,d0; !bytes-1
*bmi end
*bra f7
f6: *swap d0; !byte loop
f7: *move.b (a0)+,(a1)+
*dbra d0,f7
*swap d0
*dbra d0,f6
*bra end
b0: *neg.l d0; !backwards copy
*add.l d0,a0; !adjust addresses for -()
*add.l d0,a1
*btst #0,d2
*bne b5
*move a0,d1; !!
*btst #0,d1
*beq b1
*move.b -(a0),-(a1)
*subq.l #1,d0
b1: *moveq #3,d2
*and d0,d2
*subq.l #4,d0
*bmi b4
*lsr.l #2,d0
*bra b3
b2: *swap d0
b3: *move.l -(a0),-(a1)
*dbra d0,b3
*swap d0
*dbra d0,b2
b4: *move.l d2,d0
b5: *subq.l #1,d0
*bmi end
*bra b7
b6: *swap d0
b7: *move.b -(a0),-(a1)
*dbra d0,b7
*swap d0
*dbra d0,b6
end:
end
systemroutine moveblock(integer bytes,from,to)
!in case of overlap copy without propagating
! %returnif bytes<=0
! bytes = -bytes %if from<to<from+bytes
! smoveblock(bytes,from,to)
label x,y
*tst.l d0
*ble y
*cmp.l d2,d1
*bge x
*move.l d1,d3
*add.l d0,d3
*cmp.l d3,d2
*bge x
*neg.l d0
x:*jsr smoveblock
y:
end
systemstring (31)fn DATETIME
@16_1110 integerfn FCOMMR(integer c,string (255)p,
bytename b,integer max)
string (31)s
length(s) = fcommr('G'<<8,"",charno(s,1),31)
result = s
end
systemstring (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
systemstring (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
systemintegerfn cputime
*jsr 16_1130
end
! PAM stuff
!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)
externalrecord (paminfo)map PAM
!%record(paminfo)%name p
! %if pamaddr=0 %start
! p == new(p); pamaddr = addr(p)
! p = 0
! p_groupsep = '/'; p_keyflag = '-'
! %else
! p == record(pamaddr)
! %finish
! %result == p
ownrecord (paminfo)p=paminfo('/','-',0,nil)
result == p
end
systemroutine openinput(integer s,string (255)f)
*jsr 16_10f0
end
systemroutine openoutput(integer s,string (255)f)
*jsr 16_10f4
end
! Setinput and Setoutput
@16_1108 integerfn FCOMM(integer cn,string (255)s)
@16_110C integerfn FCOMMW(integer cn,string (255) s,
bytename buffer,integer size)
@16_1110 integerfn FCOMMR(integer c,string (255)p,
bytename b,integer max)
@16_35c4 short USERNO
@16_3fa8 byte LDTE,LSAP,RDTE,RSAP
@16_1100 routine ETHERWRITE(integer port,bytename buf,integer size)
@16_1104 integerfn ETHERREAD(integer port,bytename buf,integer max)
recordformat sf(integer ptr,lim,server,extra)
@16_35c6 record (sf)name curin
@16_35ca record (sf)name curout
integerfn fromhdh(integername pos,integer lim)
integer n=0,k
cycle
result = n if pos>=lim; pos = pos+1
k = byteinteger(pos-1)-'0'; result = n if k<0
n = n<<4+k
repeat
end
string (5)fn tohdh(integer n)
string (5)h
integer i
h = ""
h = h.tostring(n>>i&15+'0') for i=12,-4,0
result = h
end
systemroutine setinput(integer pos)
integer x,lo,hi
returnif curin_extra=0; !Not file =>
hi = (curin_lim+511)&¬511
lo = hi-512
curin_lim = hi
curin_ptr = hi
x = fcomm('U0'+curin_extra,tohdh(pos>>9))
returnif pos&511=0; !No part-block =>
x = fcommr('X0'+curin_extra,"",byteinteger(lo),512)
returnif x<pos&511; !File too short =>
curin_lim = lo+x
curin_ptr = lo+pos&511
end
systemroutine resetinput
setinput(0)
end
systemroutine setoutput(integer pos)
string (5)block
integer x
returnif curout_extra=0; !Not file =>
curout_ptr = curout_lim-512
block = tohdh(pos>>9)
if pos&511#0 start ; !Part-block
x = fcommr('R0'+curout_extra,block,byteinteger(curout_ptr),512)
curout_ptr = curout_ptr+pos&511
finish
x = fcomm('U0'+curout_extra,block)
end
systemroutine resetoutput
setoutput(0)
end
integerfn open and shut(string (255)name file)
string (255)s
bytename b
integer xno,blocks,pad
integerfn get
integer n=0,k
cycle
k = b-'0'; b == b[1]
result = n if k<0
n = n<<4+k
repeat
end
result = 0 if file=""
s = "S".tostring(userno+'0').file.tostring(nl)
etherwrite(lsap,charno(s,1),length(s))
length(s) = etherread(lsap,charno(s,1),255)-1
if charno(s,1)='-' start
signal 3,4,charno(s,2)-'0',substring(s,3,length(s))
finish
b == charno(s,1)
xno = get; blocks = get; pad = get
s = "K".tostring(xno+'0').tostring(nl)
etherwrite(lsap,charno(s,1),length(s))
length(s) = etherread(lsap,charno(s,1),255)
result = blocks<<9-pad
end
systempredicate exists(string (255)file)
integer x
onevent 3 start
false
finish
toupper(file)
trueif file="" or file=":N" or file=":" or file=":T"
x = openandshut(file)
true
end
systemintegerfn filesize(string (255)file)
result = openandshut(file)
end
systemroutine open append(integer stream,string (255)file)
! Open the specified file for output on the specified stream,
! such that information is added at the end.
! (Hidden) result is the size of the information in the file already.
string (255)s
record (sf)name cb
integer pos,lim,xno,blocks,pad,size
! Open anything for output first - to get file driver addr into CB
openoutput(stream,"pub:"); selectoutput(stream)
cb == curout
xno = cb_extra
! Close it again - but don't use CLOSEOUTPUT as this will zap the driver
cb_extra = 0
s = "K".tostring(xno+'0').tostring(nl)
etherwrite(lsap,charno(s,1),length(s))
length(s) = etherread(lsap,charno(s,1),255)
! Now open-mod the file we want
s = "A".tostring(userno+'0').file.tostring(nl)
etherwrite(lsap,charno(s,1),length(s))
length(s) = etherread(lsap,charno(s,1),255)
if charno(s,1)='-' start ; !failed to open
if charno(s,2)=';' start ; !does not exist: use ordinary seq output
openoutput(stream,file); selectoutput(0)
*clr.l d0; return
finish
signal 3,3,charno(s,2)-'0',substring(s,3,length(s)-1)
finish
pos = addr(s)+1; lim = pos+length(s)
xno = fromhdh(pos,lim); blocks = fromhdh(pos,lim); pad = fromhdh(pos,lim)
cb_extra = xno
size = blocks<<9-pad
setoutput(size)
*move.l size,d0
end
systemroutine close append; !no longer required
closeoutput
end
endoffile