! VTI PERM file for Motorola 68000 IMP Compiler
!**NB order up to READSTRING
recordformat EVENTFM(integer event,(integer sub or integer subevent),
integer extra,line,string (255) message)
@16_3400record (eventfm) EVENT
@16_1114routine SIG
@16_1128routine SCOMP
routine ASET
*sub.l d2,d1
*ble #6
*moveq #-16_35,d0
sig
*neg.l d1
*addq.l #1,d1
! *mulu d1,d0
! *rts
*jmp 16_1120
end
routine AGET
*addq.l #3,d0
*and.l #-4,d0
*move.l d6,a0
*add.l d0,d6
*cmp.l d6,sp
*ble #6
*lea -256(a0),a0
*rts
*sub.l d0,d6
*moveq #-16_12,d0
sig
end
routine IX
label bad,ok,bigel,bigx,big
*cmp.l (a0)+,d0
*bgt bad
*sub.l (a0)+,d0
*bge ok
*add.l -(a0),d0
bad:*move.l d0,16_3408
*clr.w 16_3410
*move #16_26,d0
sig
ok:
*tst.w (a0)+
*bne bigel
*swap d0
*tst.w d0
*bne bigx
*swap d0
*mulu (a0)+,d0
*rts
bigel:
*move d1,-(sp)
*move d0,d1
*mulu -2(a0),d1
*bra big
bigx:
*move d1,-(sp)
*move d0,d1
*swap d0
*mulu (a0),d1
big:
*swap d1
*mulu (a0)+,d0
*add d1,d0
*move (sp)+,d1
end
@16_11B4routine RES
@16_11BCroutine LOA
@16_1120routine MUL
@16_1124routine DIV
@16_1144routine POW
@16_1148routine FPLUS
@16_114Croutine FMIN
@16_1150routine FMUL
@16_1154routine FDIV
@16_1158routine FPOW
@16_115Croutine FNEG
@16_1160routine FLOAT
@16_1114record (*)map ZNEW(name (d0) v)
@16_1114routine DISPOSE(record (*)name v)
routinespec (16_10C8) READCH(name (d0) n)
routinespec (16_10C4) PRINTSTR(string (255) s)
routinespec READ(name (d0) v)
externalroutinespec READREAL(realname v)
externalroutinespec READSTRING(string (*)name v)
@0record (*) NIL
constinteger NL=10
@0integerfn ADDR{(%name n)
@0integermap INTEGER(integer a)
@0realmap REAL(integer a)
@0string (*)map STRING(integer a)
@0record (*)map RECORD(integer a)
@0bytemap BYTEINTEGER(integer a)
@0shortmap SHORTINTEGER(integer a)
@0bytemap LENGTH(string (*)name z)
@0bytemap CHARNO(string (*)name z, integer n)
string (1)fn TOSTRING(integer k)
short z=k
byteinteger(addr(z)) = 1
result = string(addr(z))
end
@16_1124integerfn REM(integer a,b)
!
integerfnspec (16_10CC) NEXTCH
routinespec (16_10C0) PRINTCH(integer k)
routinespec (16_10C8) SKIPCH
routinespec (16_10D0) PROMPT(string (31) S)
integerfnspec (16_10D4) TESTSYMBOL
routinespec (16_10D8) SELECTIN(integer n)
routinespec (16_10DC) SELECTOUT(integer n)
routinespec (16_10E0) RESET INPUT
routinespec (16_10E4) RESET OUTPUT
routinespec (16_10E8) CLOSE INPUT
routinespec (16_10EC) CLOSE OUTPUT
routinespec (16_10F0) OPEN INPUT(integer n, string (31) S)
routinespec (16_10F4) OPEN OUTPUT(integer n, string (31) S)
routinespec (16_10E0) READDD
routinespec (16_111C) WRIT(integer m,n)
routinespec (16_1140) SET TERMINAL MODE(integer m)
integerfnspec (4400) CPUTIME; !1130
integerfnspec (16_1168) INTPT(real x)
realfnspec (16_1164) FRACPT(real x)
realfnspec (16_116C) SQRT(real x)
externalintegerfnspec INSTREAM
externalintegerfnspec OUTSTREAM
! ............................
!
!!!!!!!!!!!!!! Standard Video Terminal Interface !!!!!!!!!!!!!
! Terminal mode options
constinteger single=1<<2, noecho=1<<0, notermecho=1<<1,
nopage=1<<3,
specialpad=1<<13
constinteger ttmodebits=single+noecho+notermecho+nopage
constinteger screenmode=single+notermecho+nopage
! Video FUNction/MODE flag values:-
constinteger intense=1, reverse=2, underline=4, blink=8,
graphical=16, shade=31
constinteger fullscroll=64, anyscroll=128; !FUN only
constinteger noscroll=64, freeze=128; !MODE only
recordformat WININFO(byteinteger top,rows,left,cols,
row,col,fun,mode)
ownrecord (wininfo) VDU=0; !full-screen frame
ownrecord (wininfo) WIN=0; !current frame
owninteger insertpos=0
constinteger STACKMAX=7
ownrecord (wininfo)array STACK(1:stackmax)
owninteger SP=0
!
! Video operations
constinteger escflag=128 {flag for ESC},
rowcode=254 {place-saver for row},
colcode=255 {place-saver for col}
! Control sequences (coded - 4 bytes max)
! [Initial values shown are for V200]
owninteger docursor=escflag+'Y'+rowcode<<8+colcode<<16,
doclearline=escflag+'x',doclearscreen=escflag+'v',
dodelete=escflag+'M',doinsert=escflag+'L',
donormalpad=escflag+'>',dospecialpad=escflag+'=',
dostandard=escflag+'G',dograph=escflag+'F',
dostartins=escflag+'i',dostopins=escflag+'j',
dodelchar=escflag+'O'
ownintegerarray doselect(0:15) = escflag+'3', escflag+'4', 0 (*)
!
!ASCII control characters:
constinteger bs=8, tab=9, lf=10, ff=12, rt=13, esc=27
constinteger del=127
!
owninteger vbot=23,vright=79; !=VDU_ROWS-1,VDU_COLS-1
constinteger untouched=1<<30
owninteger options=untouched; !record of VIDEO MODE
owninteger echoinc=1; !0 if NOECHO
owninteger escaping=0; !temp for current window
owninteger inmode=-1, outmode=-1; !input/output modes
! IN/OUTMODE < 0 ==> file,etc
! = 0 ==> hardcopy terminal
! > 0 ==> video terminal
!
!!!!!!!!!!!!!!!!! Internal procedures !!!!!!!!!!!!!!!!!!!!
!
routine PUT SEQUENCE(integer seq)
while seq # 0 cycle
print ch(esc) if seq&escflag # 0 and seq&127 # 0
print ch(seq&127)
seq = seq>>8
repeat
end
routine INSERT CHAR(integer k)
put sequence(dostartins)
print ch(k)
put sequence(dostopins)
end
routine POSITION CURSOR(integer row,col)
! Set cursor to row ROW and column COL (relative)
integer k,seq
row = win_rows-1 if row >= win_rows; row = row+win_top
col = win_cols-1 if col >= win_cols; col = col+win_left
if row = vdu_row start
return if col = vdu_col; !already there =>
! Check for optimisable cases
if col = 0 start
print ch(rt); vdu_col = 0
return
finish
if 0 > col-vdu_col >= -3 start
cycle
print ch(bs)
vdu_col = vdu_col-1
repeat until vdu_col = col
return
finish
finish
if col = 0 and row-vdu_row = 1 start
print ch(nl)
vdu_row = vdu_row+1; vdu_col = 0
return
finish
vdu_row = row; vdu_col = col; !new values
!Interpret cursor address sequence
seq = docursor
while seq # 0 cycle
k = seq&255
k = row+' ' if k = rowcode
if k = colcode start
k = col+' '
finish
print ch(esc) if k&escflag # 0
print ch(k&127)
seq = seq>>8
repeat
end
!
routine CHANGE SHADE
if (win_mode!!vdu_mode)&graphical # 0 start
if win_mode&graphical = 0 then put sequence(dostandard) c
else put sequence(dograph)
finish
if (win_mode!!vdu_mode)&15 # 0 start
put sequence(doselect(win_mode&15))
finish
vdu_mode = win_mode&shade
end
!!!!!!!!!!!!!!!!!! External procedures !!!!!!!!!!!!!!!!!!!!
!
routine CLEAR LINE
if win_col < win_cols start
position cursor(win_row,win_col)
if win_cols = vdu_cols and doclearline # 0 start
put sequence(doclearline)
finish else start
cycle
print ch(' '); win_col = win_col+1
vdu_col = vdu_col+1 if vdu_col # vright
repeat until win_col = win_cols
finish
finish
end
!
routine CLEAR FRAME
!(no point in updating?)
win_row = 0; win_col = 0
position cursor(0,0)
![optimisable by record variation]
if win_top=0=win_left and win_rows=vdu_rows c
and win_cols=vdu_cols and doclearscreen # 0 start
put sequence(doclearscreen)
finish else start
cycle
clear line
win_row = win_row+1
repeat until win_row >= win_rows
win_row = 0
finish
end
!
routine SCROLL(integer t,b,n)
!Scroll area delimited by T and B by N lines
! -- reverse scroll if N < 0
integer i,vt,vb
return unless outmode > 0 and t >= 0 and b < win_rows
win_row = b; win_col = 0
if t >= b or win_cols # vdu_cols start
clear line; !clear single line
return
finish
vt = t+win_top; vb = b+win_top
if n >= 0 start
if vt = 0 and vb = vbot start ; !full screen
position cursor(b,0) if vb # vdu_row; !any col OK
print ch(nl); !hardware scroll
return
finish
finish else win_row = t
if n < 0 start
n = -n
i = t; t = b; b = i
vt = t; vb = b
finish
if vt < vbot start
position cursor(t,0) if vdu_row # vt; !any col OK
for i = 1,1,n cycle
put sequence(dodelete)
vdu_col = 0
repeat
finish
if vb < vbot start
position cursor(b,0)
for i = 1,1,n cycle
put sequence(doinsert)
repeat
finish
end ; !SCROLL
!
routine SELECT INPUT(integer n)
*JSR 16_10D8
inmode = -1; inmode = vdu_fun if n = 0
end
routine SELECT OUTPUT(integer n)
*JSR 16_10DC
outmode = -1; outmode = vdu_fun if n = 0
end
!
routine PRINT SYMBOL(integer sym)
integer i
if outmode <= 0 start ; !non-video
print ch(sym)
finish else if escaping # 0 start
escaping = 0
print ch(sym)
vdu_row = 255
finish else if sym = del start
return if win_col = 0
win_col = win_col-1
return if win_col >= win_cols
position cursor(win_row,win_col)
if insertpos # 0 then put sequence(dodelchar) c
else print ch(' ') and vdu_col = vdu_col+1
finish else if sym&96 # 0 start ; !not control
return if win_col >= win_cols
position cursor(win_row,win_col)
change shade if win_mode&shade # vdu_mode
if insertpos # 0 then insert char(sym) c
else print ch(sym)
vdu_col = vdu_col+1 if vdu_col # vright
win_col = win_col+1 if win_col # 255
finish else if sym # nl start
if sym = rt start
win_col = 0
finish else if sym = bs start
win_col = win_col-1 if win_col # 0
finish else if sym = ff start
clear frame
finish else start
position cursor(win_row,win_col)
print ch(sym)
escaping = 1 if sym = esc
finish
finish else start
clear line
if win_row # win_rows-1 start
![following line shouldn't be necessary, but lower-level]
![software happier with regular NLs]
! print ch(nl); vdu_row = vdu_row+1; vdu_col = 0
win_row = win_row+1
finish else start
if win_mode&freeze # 0 start
i = instream; select input(0) if i # 0
read ch(sym); vdu_row = 255
if sym = esc start
read ch(sym)
read ch(sym) if sym = '?'; !%or sym = 'O' %or sym = '['
finish
select input(i) if i # 0
finish
if win_mode&(noscroll+freeze) # 0 then win_row = 0 c
else scroll(0,win_row,1)
finish
win_col = 0
finish
end ; !print symbol
!
routine AT(integer row,col)
if row >= 0 and col >= 0 start
row = win_rows-1 if row >= win_rows
win_row = row
col = 255 if col > 255
win_col = col
finish
end
routine GOTOXY(integer x,y)
at(y,x)
end
routine SET MODE(integer m)
win_mode = win_mode&shade+m
end
routine SET SHADE(integer s)
win_mode = win_mode&(¬shade)+s
end
!
routine SET FRAME(integer t,r,l,c)
r = 1 if r <= 0; r = vdu_rows if r > vdu_rows
t = vdu_rows-r if t > vdu_rows-r; t = 0 if t < 0
c = 1 if c <= 0; c = vdu_cols if c > vdu_cols
l = vdu_cols-c if l > vdu_cols-c; l = 0 if l < 0
win = 0
win_top = t; win_rows = r; win_row = r-1
win_left = l; win_cols = c
win_fun = vdu_fun
win_fun = win_fun&(¬(anyscroll+fullscroll)) if c # vdu_cols c
or (win_fun&anyscroll = 0 and r # vdu_rows)
end
!
routine HILIGHT(integer k)
set shade(intense)
if k > ' ' then print symbol(k) c
else print symbol('|')
set shade(0)
end
routine LOLIGHT(integer k)
print symbol(k)
end
routine PUSH WINDOW
if sp = stackmax start
event_message = "Too many windows"; signal 9,4
finish
sp = sp+1; stack(sp) = win
end
routine POP WINDOW
if sp > 0 then win = stack(sp) and sp = sp-1 c
else win = vdu
end
routine SWOP WINDOW
record (wininfo) temp
if sp > 0 start
temp = stack(sp); stack(sp) = win; win = temp
finish else start
sp = 1; stack(sp) = win; win = vdu
finish
end
routine SET VIDEO MODE(integer mode)
integer p
return if mode = options
if options = untouched start
vdu_fun = anyscroll+fullscroll+intense
vdu_rows = 24; vdu_cols = 80
inmode = vdu_fun; outmode = vdu_fun
win = vdu
finish
set terminal mode(mode&ttmodebits)
echoinc = 1; echoinc = 0 if mode&noecho # 0
if (mode!!options)&specialpad # 0 start ; !change in pad mode
if mode&specialpad # 0 then put sequence(dospecialpad) c
else put sequence(donormalpad)
finish
options = mode
end
!
owninteger pend=¬nl
routine READ SYMBOL(integername k)
integer kk,r,c
read ch(k) and return if inmode < 0
k = pend and pend = ¬pend and return if pend >= 0
unless ¬' ' >= pend > ¬del start ; !last was control
if outmode > 0 start
position cursor(win_row,win_col)
change shade if win_mode&shade # vdu_mode
finish else win_col = 0
finish
read ch(kk)
if ' ' <= kk < del start
if options&(single+noecho) = single start
!IE echoing wanted at this level
if insertpos # 0 then insert char(kk) c
else print ch(kk)
finish
win_col = win_col+echoinc
else if kk = esc
read ch(kk)
if kk = '?' start
read ch(kk); kk = kk!!96
finish
kk = kk!128
finish
vdu_row = 255; ![safety for now]
pend = ¬kk
k = kk
end
integerfn NEXT SYMBOL
result = next ch if inmode < 0
result = pend if pend >= 0
read symbol(pend)
result = pend
end
routine SKIP SYMBOL
integer i
read symbol(i)
end
!!!!!!!!!!!!!!! End of Video Package !!!!!!!!!!!!!!!!!!!!!
routine PRINT STRING(string (255) s)
integer i
print symbol(charno(s,i)) for i = 1,1,length(s)
end
!
routine NEWLINE
print symbol(nl)
end
routine NEWLINES(integer i)
newline and i = i-1 while i > 0
end
routine SPACE
print symbol(' ')
end
routine SPACES(integer i)
space and i = i-1 while i > 0
end
routine WRITE(integer v,p)
integer vv,q,pos
byteintegerarray store(0:15)
vv = v; vv = -vv if vv > 0
pos = 15
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
spaces(pos-16-p) if p < 0
finish else start
spaces(pos-16+p)
print symbol(' ') if v >= 0
finish
print symbol('-') if v < 0
print symbol(store(pos)) and pos = pos+1 until pos = 16
end
routine READ(integername v)
integer i,k,sign
cycle
k = next symbol
exit if k > ' '
read symbol(k)
repeat
sign = 0
if k = '-' start
sign = 1
read symbol(k); k = next symbol
finish
signal 4 unless '0' <= k <= '9'
i = k-'0'
cycle
read symbol(k)
k = next symbol
exit unless '0' <= k <= '9'
i = i*10-'0'+k
repeat
i = -i if sign # 0
v = i
end
externalstring (15)fnspec DATE
externalstring (15)fnspec TIME
externalstring (31)fnspec DATETIME
externalstring (255)fnspec SUBSTRING(string (255) z, integer from,to)