! PERM file for Motorola 68000 IMP Compiler -- VTI Graphics 3
constinteger NL=10
integermapspec INTEGER(integer a)
realmapspec REAL(integer a)
string (*)mapspec STRING(integer a)
record (*)mapspec RECORD(integer a)
bytemapspec BYTEINTEGER(integer a)
shortmapspec SHORTINTEGER(integer a)
bytemapspec LENGTH(string (*)name s)
bytemapspec CHARNO(string (*)name s, integer n)
integerfnspec ADDR(name n)
string (1)fn TOSTRING(integer k)
string (1) s; shortinteger(addr(s)) = k+256
result = s
end
integerfnspec (16_1124) REM(integer a,b)
integerfnspec (16_10CC) NEXTCH
routinespec (16_10C8) READCH(name n)
routinespec (16_10C0) PRINTCH(integer k)
routinespec (16_10C8) SKIPCH
routinespec (16_10C4) PRINTSTR(string (255) s)
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 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; !full-screen frame
ownrecord (wininfo) WIN; !current frame
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 donormalpad=escflag+'>',dospecialpad=escflag+'='
!
!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
constinteger black=0,red=1,green=2,blue=4
constinteger yellow=red+green,magenta=red+blue,cyan=blue+green
constinteger white=red+green+blue
ownbyteintegerarray colours(0:3) =
blue+green,red,blue+green+8,red+8
ownbyteinteger paper=black, colour=blue+green
owninteger vpos=0, hpos=0
routine SHOW CH(integer k)
!Display (flagged) symbol K @ position VPOS,HPOS (top,left)
! ex RWT
integerarrayspec (16_C00000) frame(0:32767)
bytespec (16_C20000) enable reg
bytespec (16_C20001) colour reg
owninteger flip=0
integer p,q,shiftcount
constbyteintegerarray FSTORE(0:128*11-1) <-
0, 0, 0, 0, 0, 255, 0, 0, 0, 0, 0,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 255, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 255, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 255, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 15, 0, 0, 0, 0, 0,
120, 132, 132, 132, 120, 0, 0, 0, 0, 0, 0,
0, 8, 8, 8, 254, 8, 8, 254, 0, 0, 0,
0, 0, 0, 8, 4, 254, 4, 8, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 198, 198, 0, 0,
0, 48, 48, 0, 252, 0, 48, 48, 0, 0, 0,
8, 8, 8, 8, 8, 8, 84, 56, 8, 0, 0,
0, 0, 0, 0, 0, 248, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 248, 0, 0, 0, 0, 0,
8, 8, 8, 8, 8, 15, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 248, 8, 8, 8, 8, 8,
130, 130, 68, 40, 254, 16, 254, 16, 16, 0, 0,
0, 16, 120, 132, 128, 132, 120, 16, 0, 0, 0,
2, 66, 64, 64, 224, 64, 64, 64, 254, 0, 0,
0, 0, 0, 0, 0, 15, 8, 8, 8, 8, 8,
0, 0, 0, 0, 112, 136, 152, 168, 200, 136, 112,
0, 0, 0, 0, 32, 96, 160, 32, 32, 32, 248,
0, 0, 0, 0, 112, 136, 8, 16, 32, 64, 248,
0, 0, 0, 0, 240, 8, 8, 48, 8, 8, 240,
0, 0, 0, 0, 16, 48, 80, 144, 248, 16, 16,
0, 0, 0, 0, 248, 128, 240, 8, 8, 136, 112,
0, 0, 0, 0, 56, 64, 128, 240, 136, 136, 112,
0, 0, 0, 0, 248, 8, 16, 32, 64, 64, 64,
0, 0, 0, 0, 112, 136, 136, 112, 136, 136, 112,
0, 0, 0, 0, 112, 136, 136, 120, 8, 16, 224,
126, 242, 242, 242, 114, 18, 18, 18, 18, 0, 0,
224, 144, 224, 128, 158, 16, 28, 16, 30, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
8, 8, 8, 8, 8, 0, 0, 8, 8, 0, 0,
72, 72, 72, 0, 0, 0, 0, 0, 0, 0, 0,
40, 40, 40, 254, 40, 254, 40, 40, 40, 0, 0,
16, 126, 144, 144, 124, 18, 18, 252, 16, 0, 0,
64, 162, 68, 8, 16, 32, 68, 138, 4, 0, 0,
112, 136, 136, 80, 32, 82, 140, 140, 114, 0, 0,
24, 24, 16, 32, 0, 0, 0, 0, 0, 0, 0,
8, 16, 32, 32, 32, 32, 32, 16, 8, 0, 0,
32, 16, 8, 8, 8, 8, 8, 16, 32, 0, 0,
0, 16, 146, 84, 56, 84, 146, 16, 0, 0, 0,
0, 16, 16, 16, 254, 16, 16, 16, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 48, 48, 32, 64,
0, 0, 0, 0, 254, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 48, 48, 0, 0,
0, 2, 4, 8, 16, 32, 64, 128, 0, 0, 0,
124, 130, 134, 138, 146, 162, 194, 130, 124, 0, 0,
16, 48, 80, 16, 16, 16, 16, 16, 124, 0, 0,
124, 130, 2, 4, 8, 16, 32, 64, 254, 0, 0,
124, 130, 2, 2, 60, 2, 2, 130, 124, 0, 0,
4, 12, 20, 36, 68, 132, 252, 4, 4, 0, 0,
252, 128, 128, 248, 4, 2, 2, 132, 120, 0, 0,
60, 64, 128, 128, 252, 130, 130, 130, 124, 0, 0,
254, 130, 4, 8, 16, 32, 32, 32, 32, 0, 0,
124, 130, 130, 130, 124, 130, 130, 130, 124, 0, 0,
124, 130, 130, 130, 126, 2, 2, 4, 120, 0, 0,
0, 0, 0, 48, 48, 0, 0, 48, 48, 0, 0,
0, 0, 0, 48, 48, 0, 0, 48, 48, 32, 64,
8, 16, 32, 64, 128, 64, 32, 16, 8, 0, 0,
0, 0, 0, 124, 0, 124, 0, 0, 0, 0, 0,
32, 16, 8, 4, 2, 4, 8, 16, 32, 0, 0,
60, 66, 66, 4, 8, 16, 16, 0, 16, 0, 0,
60, 66, 154, 170, 170, 188, 128, 64, 60, 0, 0,
56, 68, 130, 130, 254, 130, 130, 130, 130, 0, 0,
252, 66, 66, 66, 124, 66, 66, 66, 252, 0, 0,
60, 66, 128, 128, 128, 128, 128, 66, 60, 0, 0,
248, 68, 66, 66, 66, 66, 66, 68, 248, 0, 0,
254, 128, 128, 128, 240, 128, 128, 128, 254, 0, 0,
254, 128, 128, 128, 240, 128, 128, 128, 128, 0, 0,
60, 66, 128, 128, 128, 158, 130, 66, 60, 0, 0,
130, 130, 130, 130, 254, 130, 130, 130, 130, 0, 0,
124, 16, 16, 16, 16, 16, 16, 16, 124, 0, 0,
2, 2, 2, 2, 2, 2, 130, 130, 124, 0, 0,
130, 132, 136, 144, 160, 208, 136, 132, 130, 0, 0,
128, 128, 128, 128, 128, 128, 128, 128, 254, 0, 0,
130, 198, 170, 146, 146, 130, 130, 130, 130, 0, 0,
130, 194, 162, 146, 138, 134, 130, 130, 130, 0, 0,
56, 68, 130, 130, 130, 130, 130, 68, 56, 0, 0,
252, 130, 130, 130, 252, 128, 128, 128, 128, 0, 0,
56, 68, 130, 130, 130, 146, 138, 68, 58, 0, 0,
252, 130, 130, 130, 252, 144, 136, 132, 130, 0, 0,
124, 130, 128, 128, 124, 2, 2, 130, 124, 0, 0,
254, 16, 16, 16, 16, 16, 16, 16, 16, 0, 0,
130, 130, 130, 130, 130, 130, 130, 130, 124, 0, 0,
130, 130, 130, 68, 68, 40, 40, 16, 16, 0, 0,
130, 130, 130, 130, 146, 146, 170, 198, 130, 0, 0,
130, 130, 68, 40, 16, 40, 68, 130, 130, 0, 0,
130, 130, 68, 40, 16, 16, 16, 16, 16, 0, 0,
254, 2, 4, 8, 16, 32, 64, 128, 254, 0, 0,
120, 64, 64, 64, 64, 64, 64, 64, 120, 0, 0,
0, 128, 64, 32, 16, 8, 4, 2, 0, 0, 0,
120, 8, 8, 8, 8, 8, 8, 8, 120, 0, 0,
16, 40, 68, 130, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 254, 0,
48, 48, 16, 8, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 120, 4, 124, 132, 132, 122, 0, 0,
128, 128, 128, 184, 196, 132, 132, 196, 184, 0, 0,
0, 0, 0, 120, 132, 128, 128, 132, 120, 0, 0,
4, 4, 4, 116, 140, 132, 132, 140, 116, 0, 0,
0, 0, 0, 120, 132, 252, 128, 128, 120, 0, 0,
24, 36, 32, 32, 248, 32, 32, 32, 32, 0, 0,
0, 0, 0, 116, 140, 132, 140, 116, 4, 132, 120,
128, 128, 128, 184, 196, 132, 132, 132, 132, 0, 0,
0, 16, 0, 48, 16, 16, 16, 16, 56, 0, 0,
0, 4, 0, 12, 4, 4, 4, 4, 4, 68, 56,
128, 128, 128, 136, 144, 160, 208, 136, 132, 0, 0,
48, 16, 16, 16, 16, 16, 16, 16, 56, 0, 0,
0, 0, 0, 236, 146, 146, 146, 146, 146, 0, 0,
0, 0, 0, 184, 196, 132, 132, 132, 132, 0, 0,
0, 0, 0, 120, 132, 132, 132, 132, 120, 0, 0,
0, 0, 0, 184, 196, 132, 196, 184, 128, 128, 128,
0, 0, 0, 116, 140, 132, 140, 116, 4, 4, 4,
0, 0, 0, 184, 196, 128, 128, 128, 128, 0, 0,
0, 0, 0, 120, 132, 96, 24, 132, 120, 0, 0,
0, 32, 32, 248, 32, 32, 32, 36, 24, 0, 0,
0, 0, 0, 132, 132, 132, 132, 140, 116, 0, 0,
0, 0, 0, 130, 130, 130, 68, 40, 16, 0, 0,
0, 0, 0, 130, 146, 146, 146, 146, 108, 0, 0,
0, 0, 0, 132, 72, 48, 48, 72, 132, 0, 0,
0, 0, 0, 132, 132, 132, 140, 116, 4, 132, 120,
0, 0, 0, 252, 8, 16, 32, 64, 252, 0, 0,
24, 32, 32, 32, 64, 32, 32, 32, 24, 0, 0,
16, 16, 16, 16, 0, 16, 16, 16, 16, 0, 0,
48, 8, 8, 8, 4, 8, 8, 8, 48, 0, 0,
96, 146, 12, 0, 0, 0, 0, 0, 0, 0, 0,
72, 146, 36, 72, 146, 36, 72, 146, 36, 0, 0
q = addr(frame(0))+(vpos!!16_3FF)<<7+(hpos&16_3F0)>>3
shiftcount = (¬hpos)&15
if k < 0 start ; !cursor
flip = flip!!8
enable reg = 8; colour reg = flip
*move.l q,a1
*move #11,d0; !height 11
*moveq #-128,d2
*move.l shiftcount,d3
*move.l #2_1111111110000000,d1
*lsl.l d3,d1
loop0:
*move.l d1,(a1)
*add.l d2,a1
*subq #1,d0
*bgt loop0
enable reg = 15
finish else start
k = k-96 if k >= 96 and win_mode&graphical # 0
colour = colours(win_mode&3)
p = addr(fstore(k*10+k))
*move.l p,a0
*move.l q,a1
*move #11,d0; !height 11
*moveq #-128,d2
*move.l shiftcount,d3
*move.l #2_1111111110000000,d1
*lsl.l d3,d1
*addq #8,d3
loop:
*move.b paper,colourreg; !restore background
*move.l d1,(a1)
*move.b colour,colourreg
*clr.l d4
*move.b (a0)+,d4
*lsl.l d3,d4
*move.l d4,(a1)
*add.l d2,a1
*subq #1,d0
*bgt loop
finish
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; vpos = row*10+row+8
col = win_cols-1 if col >= win_cols
col = col+win_left; hpos = col*9+8
vdu_row = row; vdu_col = col
end
!
!!!!!!!!!!!!!!!!!! External procedures !!!!!!!!!!!!!!!!!!!!
!
routine CLEAR LINE
bytespec (16_C20001) colour reg
routinespec (16_11a8) fill(integer x1,y1,x2,y2)
integer i
if win_col < win_cols start
position cursor(win_row,win_col)
colour reg = paper
fill(hpos,¬vpos,hpos+(win_cols-win_col)*9-1,¬(vpos+10))
! i = win_col
! %cycle
! position cursor(win_row,i)
! show ch(' '); i = i+1
! vdu_col = vdu_col+1 %if vdu_col # vright
! %repeat %until i = win_cols
finish
end
!
routine CLEAR FRAME
!(no point in updating?)
win_row = 0; win_col = 0
position cursor(0,0)
cycle
clear line
win_row = win_row+1
repeat until win_row >= win_rows
win_row = 0
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
print ch('%')
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 sym&96 # 0 start ; !not control
return if win_col >= win_cols
position cursor(win_row,win_col)
show 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
finish
finish else start
clear line
if win_row # win_rows-1 start
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
!
recordformat eventfm(integer event,subevent,extra,pc,
string (255) message,integerarray r(0:15))
record (eventfm)spec (16_3400) event
!
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 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)
shortspec (16_480000) mapreg4
bytespec (16_C20000) enable reg
shortspec (16_C20002) origin reg
bytespec (16_C20001) colour reg
routinespec (16_11a8) fill(integer x1,y1,x2,y2)
owninteger zero=0
integer p
return if mode = options
p = mode&specialpad
if options = untouched start
vdu_fun = intense
vdu_rows = 24; vdu_cols = 80
inmode = vdu_fun; outmode = vdu_fun
win = vdu
mapreg4 = 16_40; !Map reg 4 -> 004xxxxx
enable reg = 15
colour reg = paper; fill(0,0,1023,1023)
origin reg = zero
finish
set terminal mode(mode!(single+noecho)-p)
echoinc = 1; echoinc = 0 if options&noecho # 0
if (mode!!options)&specialpad # 0 start ; !change in pad mode
if p # 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
position cursor(win_row,win_col)
show ch(-1)
read ch(kk)
show ch(-1)
if ' ' <= kk < del start
if echoinc # 0 start
win_col = win_col+echoinc
show ch(kk)
finish
finish
if kk = esc start
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)
win_col = win_col-echoinc if ' ' <= pend < del
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)
record (*)spec (0) NIL