!!!!!!!!!!!!!! Standard Video Terminal Interface !!!!!!!!!!!!!
!!!!!!!!!!!!!!!! for Vax/VMS, Emas and APM !!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Hamish Dewar EU Computer Science Department January 1983 !
! !
! Modified by Keith Refson , Physics Dept. 1985 !
! Prototype (and rather crummy) driver for Lynwood !
! Improved driver for VT52 so that sussex emulation works !
! at 9600 baud. !
! Corrected mistake in Newbury driver - now OK in HILIGHT mode!
! !
! Now works through a PAD in native mode by doing echoing in !
! software. Also code in VMS version for grabbing terminal !
! definitions from the system database using the SMG routines.!
! Now has code to $ set term/passall/noescape on VMS !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This version is implemented wholly as an external library,
! with re-definition of the various input/output procedures.
!
! The present version handles the standardisation of vdu operations
! and implements the concept of a single bounding box or frame
! applied to the screen.
! The input side is inadequate but really needs to be combined with
! the next lower level.
! Only the following I/O procedures are covered:-
! SELECT INPUT, SELECT OUTPUT, PROMPT,
! PRINT SYMBOL, SPACE(S), NEWLINE(S), PRINT STRING, WRITE,
! READ SYMBOL,SKIP SYMBOL, NEXT SYMBOL, READ (integer only)
! plus (for Emas):-
! OPEN INPUT, OPEN OUTPUT, CLOSE INPUT, CLOSE OUTPUT,
! OUTSTREAM, EVENT
! The following video functions are provided:-
! CLEAR LINE (ie rest of line), CLEAR FRAME, SCROLL, AT/GOTOXY,
! SET FRAME, SET MODE, SET SHADE, SET VIDEO MODE,
! PUSH WINDOW, POP WINDOW, SWOP WINDOW
! The routine DEFINE VIDEO is included for convenience at present.
!!!!!!!!!!!!!!!!!!!!!!! INTERFACE !!!!!!!!!!!!!!!!!!!!!!!!!!
constinteger BS=8, LF=10, FF=12, RT=13, EM=25, ESC=27; !ASCII control chars
constinteger DEL=127
! Terminal mode options
constinteger single=1<<0, maplower=1<<1, noecho=1<<2, passdel=1<<3,
notypeahead=1<<4, notermecho=1<<5,
controlterm=1<<6, noevent9=1<<7,
leavecontrols=1<<8, leavelf=1<<9,
leavert=1<<10, noflush=1<<11, nobuffer=1<<12,
specialpad=1<<13, nodelecho=1<<14,
inserting=1<<15,wide=1<<16,padecho=1<<17,debug=1<<18,
hostecho=1<<29
! 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 caninsert=32
owninteger ansiscroll = 0
constinteger noscroll=64, freeze=128; !MODE only
recordformat WININFO(byteinteger top,rows,left,cols,
row,col,fun,mode)
externalrecord (wininfo) VDU = 0; ! full-screen frame
externalrecord (wininfo) WIN = 0; ! current frame
externalinteger LEADIN=esc
constinteger STACKMAX=7
ownrecord (wininfo)array STACK(1:stackmax)
owninteger SP=0
!$IF VAX
!
! The following are added to cope with the changes made to the imp language
! by Lattice Logic Ltd
! The next release of their compiler will allow the line
! %from imp %include archaisms
! which will %include a file (not present in this version) to allow
! 'instream' and 'outstream' to be used - so the following functions can go
externalintegerfunctionspec instream
externalintegerfunctionspec outstream
!
! The next changes are because the ECS IMP Compiler has the intrinsic functions
! 'intype' and 'outtype' to describe what the current I/O channels are attached to
! (This "user contributed set of routines supplied by Ian Young of Lattice to
! bridge this gap - they are likely to be part of the run-time environment at
! the next release of the compiler)
! IOTYPE
!
! What type of thing is a stream connected to?
!
! 11-Feb-86 JF Created
!
! Answers returned are as follows:
!
! -2 = can't tell
! -1 = terminal
! 0 = null stream
! 1 = none of these - probably (always?) a file
!
external integer fn spec In Type
external integer fn spec Out Type
! End of "user contributed routines" from Lattice
!$IF AMDAHL
{%recordformat EVENTINFO(%integer event,sub,extra, %string(255) message)
{%externalrecord(eventinfo) EVENT %alias "VTEVENT"
{!%externalroutinespec OPEN INPUT %alias "VTOPIN"(%integer s,
{! %string(255) file)
{!%externalroutinespec OPEN OUTPUT %alias "VTOPOUT"(%integer s,
{! %string(255) file)
{!%externalroutinespec CLOSE INPUT %alias "VTCLIN"
{!%externalroutinespec CLOSE OUTPUT %alias "VTCLOUT"
{!%externalintegerfnspec OUTSTREAM %alias "VTOUTS"
!$FINISH
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Terminal type (ERCC enumeration)
constinteger vt52=8, esprit=13, vt100=12, bbc=29, pericom=16, x5a=27,
ansi=28, wyse=32, wysew=31; !special cases of VTTYPE
externalinteger vttype=-1
! Video operations
constinteger internal=0,smg=1,tcap=2
!$IF VAX
owninteger initialise=internal
!$IF AMDAHL OR APM
{%owninteger initialise=internal
!$FINISH
!
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]
externalinteger 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',
doscrolld=escflag+'D', doscrollu=escflag+'M',
dobegininsert=0,doendinsert=0,dodeletechar=0
externalintegerarray doselect(0:15) = escflag+'3', escflag+'4', 0 (*)
externalinteger key u=0, key d=0, key l=0, key r=0
own integer padchar=0
owninteger lfpad=0; !Pads after LF
external string (15) full screen scroll=""
own string (255) initialise tt=""
owninteger vbot=23,vright=79; !=VDU_ROWS-1,VDU_COLS-1
constinteger untouched=1<<30
owninteger options=untouched; !record of VIDEO MODE
owninteger inc=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
!
!Output buffer
!$IF AMDAHL
{%constinteger outbound=255
{!
!$IF VAX
constinteger outbound=126
!$FINISH
ownbyteintegerarray outbuff(0:outbound)
owninteger outcount=0
constinteger maxprompt=63
ownstring (maxprompt) prom = ""
constinteger inbound=255
ownbyteintegerarray inbuff(0:inbound)
owninteger incount=0,inpos=0
owninteger leaddels=0,traildels=0,repairch=0
owninteger insertflag=0; ! Signals READ SYM and PRINT SYM to turn off insert mode
!$IF VAX
constinteger outstreambase=0
constinteger lfmap=rt
!%externalintegerfnspec UINFI(%integer i)
external integer fn spec batch mode
!VMS function codes:
constinteger vmsreadvblk=16_0031, vmswritevblk=16_0020,
vmsreadall =16_003A
constinteger vmsnoecho =16_0040, vmsnofiltr =16_0200,
vmspurge =16_0800, vmstrmnoecho=16_1000,
vmsescape =16_4000, vmsnoformat =16_0100
constinteger vmsread=vmsreadvblk{+vmsescape}
constinteger vms ttm noecho = x'2', vms ttm hostsync = x'10',
vms ttm nobrdcst = x'20000', vms ttm pasthru = x'40000',
vms ttm escape = x'8', vms ttm passall = x'1'
constinteger vms io sensemode = x'27' , vms io setmode = x'23'
!VMS descriptor format
recordformat desc fm(integer length, addr)
!VMS I/O status block format
recordformat IOSB fm(short status, length, term, termlength)
system integerfn spec qiow(integer efn, chan, func, c
record (IOSB fm)name iosb, c
integer x1, x2, p1, p2, p3, p4, p5, p6)
system integerfn spec assign(record (desc fm)name device, c
integername channel, c
integer x1, x2)
! %alias added for Lattice imp
! %externalstring(127)%fn %spec sysmess %alias "IMP_GET_MESSAGE"(%integer i)
externalstring (127)fn spec sysmess (integer i)
routine IO fail(integer why)
event_message = sysmess(why)
signal 9, 3, why
end
owninteger tt channel = 0; !filled in to show initialised
owninteger readfunction=vmsread
ownrecord (descfm) termmask
ownintegerarray mask(0:3) = \0, 0,0,16_80000000; !controls+DEL
ownintegerarray saved terminal mode(0:2)
routine tt setup
ownstring (7) tt name = "TT"
integer status
record (descfm) tt
tt_length = length(tt name)
tt_addr = addr(tt name)+1
status = assign(tt, tt channel, 0, 0)
IO fail(status) if status&1 = 0
end
routine set passall noescape
integerarray new terminal mode(0:2)
integer status
record (iosb fm)iosb
status= qiow(0,tt channel,vms io sensemode,iosb,0,0,addr(saved terminal mode(0)),
12,0,0,0,0)
IO fail(status) if status&1 = 0
new terminal mode(0)=saved terminal mode(0)
new terminal mode(1)=saved terminal mode(1)
new terminal mode(2)=saved terminal mode(2)
new terminal mode(1)=new terminal mode(1) ! vms ttm passall
new terminal mode(1)=new terminal mode(1) & (-1!!vms ttm escape)
! new terminal mode(2)=new terminal mode(2) ! vms ttm pasthru
status= qiow(0,tt channel,vms io setmode,iosb,0,0,addr(new terminal mode(0)),12,0,0,0,0)
IO Fail(status) if status&1 = 0
end
routine set nopassall escape
integer status
record (iosb fm)iosb
status=qiow(0,tt channel,vms io setmode,iosb,0,0,addr(saved terminal mode(0)),
12,0,0,0,0)
IO Fail(status) if status&1 = 0
end
routine set handler mode(integer mode)
! Only do the SET if mode and options differ ie changing mode. Mask handles untouched
if mode # 0 and options&16_3FFFFFFF = 0 then start ; ! entering vecce
set passall noescape
finish else if mode = 0 and options&16_3FFFFFFF # 0 start
set nopassall escape
finish
end
routine PUT BUFFER
!Send characters in OUTBUFF to device
integer status
record (IOSB fm) IOSB
status = qiow(10, tt channel, vmswritevblk+vmsnoformat, IOSB, c
0, 0, addr(outbuff(0)), outcount, 0, 0, 0, 0)
outcount = 0
IO fail(status) if status&1 = 0
IO fail(IOSB_status) if IOSB_status&1 = 0
end
integerfn SINGLE SYMBOL
integer status,buffer=0
record (IOSB fm) IOSB
put buffer if outcount > 0
status = qiow(11, tt channel, vmsread+vmsnoecho+vmsnofiltr, IOSB, 0, 0,
addr(buffer), 1, 0, 0, 0, 0)
IO fail(status) if status&1 = 0
IO fail(IOSB_status) if IOSB_status&1 = 0
result = buffer&127; ! strip parity (just in case)
end
routinespec put sequence(integer seq)
routinespec put symbol(integer k)
routine GET BUFFER
!Read characters to INBUFF
integer status
record (IOSB fm) IOSB
incount = 0; inpos = 0; traildels = 0
cycle
put buffer if outcount # 0
status = qiow(11, tt channel, readfunction, IOSB, 0, 0,
addr(inbuff(incount)), inbound-incount, 0, addr(termmask), 0, 0)
IO fail(status) if status&1 = 0
IO fail(IOSB_status) if IOSB_status&1 = 0
incount = incount+IOSB_length
traildels = traildels-IOSB_length; traildels = 0 if traildels < 0
exit unless IOSB_term = del and options&nodelecho = 0
if incount # 0 start
incount = incount-1; traildels = traildels+1
if options&inserting=0 start
put symbol(bs); put symbol(' '); put symbol(bs)
else
put symbol(bs); put sequence(dodeletechar)
finish
finish
repeat
incount = incount+IOSB_termlength
end
!$IF AMDAHL
{%constinteger lfmap=rt; ![no mapping unless RT seen]
{!!!!!!!!!!!!!!!!! Emulation of part of Emas IOCP !!!!!!!!!!!!!!!!
{! COMREG values used -
{%constinteger INSTR = 22, OUTSTR = 23, ERRMESS = 24
{! IOCP ep flags
{%constinteger READCH=4, PRINTCH=5, SELIN=8, SELOUT=9,
{ RESET=16, NEXTCH=18
{!
{%externalroutinespec SETMODE %alias "S#SETMODE" (%string(255) par)
{%externalstring(*)%fnspec MODESTR %alias "S#MODESTR"
{%externalintegerfnspec UINFI %alias "S#UINFI"(%integer I)
{%const %integer tmode=2, terminaltype=23
{%const %integer forground=1, batch=2 ; ! result of unifi(tmode)
{%externalintegerfnspec EXIST %alias "S#EXIST"(%string(255) S)
{%externalroutinespec PROMPT %alias "S#PROMPT"(%string(255) S)
{%externalroutinespec setfname %alias "S#SETFNAME" (%string(255) file)
{%external %routine %spec OUT FILE %alias "s#outfile"(%string (255) FILE,
{ %integer SIZE, HOLE, PROT, %integer %name CONAD, FLAG)
{%externalroutinespec DEF INFO %alias "S#DEFINFO"(%integer CHAN,
{ %string(255) %name FILENAME, %integer %name STATUS)
{%externalintegermapspec COMREG %alias "S#COMREGMAP"(%integer N)
{%externalintegerfnspec IOCP %alias "S#IOCP"(%integer entry,param)
{%externalroutinespec CONSOLE %alias "S#CONSOLE"(%integer ep, %integername start, len)
{%externalroutinespec FLUSH BUFFER %alias "S#TERMINATE"
{%externalroutinespec DEFINE %alias "S#DEFINE"(%integer chan, %string(255) parm,
{ %integername a,b)
{%externalstringfnspec FAILURE MESSAGE %alias "S#FAILUREMESSAGE"(%integer errno)
{%external %routine %spec journal off %alias "S#JOURNALOFF"
{%external %routine %spec journal on %alias "S#JOURNALON"
{%externalroutinespec setiodefault %alias "S#SETIODEFAULT"(%integer d,c,b)
{! Above added (+call in VT SET VIDEO) 23/03/86 at request of Tony Gibbons
{! to allow vecce to work from his command macro scheme
{%externalroutinespec move %alias "S#MOVE"(%integer length,from,to)
{!
{%owninteger outstreambase=0; !or 16
{!
{!IMP77 compatible I/O
{%externalroutinespec emas3checkname %c
{ (%string %name name, %integer %name type, qualifier, flag) {sriririw}
{! flags for EMAS3checkname
{%const %integer emas3fileormem=1,emas3file=2
{%constinteger emas3read=1, emas3write=2, emas3exist=4, emas3notexist=8,
{ emas3nosuffix=16, emas3char=128, emas3pd=1024, emas3myfile=x'4000'
{!%routine check write(%string(255) file); ! Test file for writing
{! %integer flag, conad
{! %const %integer filespec=2, charf=128
{! emas3checkname(file,filespec,charf,flag); !Returns flag if error in name
{! -> signal %if flag # 0; !or file exists and is not char
{! out file(file,1024,0,2,conad,flag); !Attempt to create file
{! %return %if flag = 0; !success
{!signal:
{! %if flag # 0 %start
{! setfname(file)
{! event_message = failuremessage(flag)
{! %signal 9,4
{! %finish
{!%end
{
{%externalroutine OPEN INPUT %alias "VTOPIN"(%integer STREAM, %string(255) FILE)
{%integer flag,dump
{ event_extra=223 %and %signal 9,2 %unless 0 < stream <= 15
{ emas3checkname(file,emas3fileormem,emas3read!emas3exist!emas3char,flag)
{ -> err %if flag # 0
{ dump = iocp(reset,stream)
{ define(stream,file,dump,flag)
{ define(stream,".null",dump,dump) %and -> err %if flag # 0
{ %return
{err:
{ setfname(file)
{ event_extra = flag
{ event_message = failure message(flag)
{ %signal 9,3
{%end
{
{%externalroutine OPEN OUTPUT %alias "VTOPOUT"(%integer STREAM, %string(255) FILE)
{!ANY CALL ON THIS PROCEDURE IMPLIES IMP77 OUTPUT STREAM NUMBERING
{%integer flag,dump,conad
{ event_extra=223 %and %signal 9,2 %unless 0 < stream <= 15
{ emas3checkname(file,emas3file,emas3char!emas3write!emas3myfile,flag);
{ ! Check file name
{ -> err %if flag # 0
{ out file(file,4096,0,2,conad,flag); !Attempt to create file
{ -> err %if flag # 0
{ stream = stream+outstreambase
{ dump = iocp(reset,stream)
{ define(stream,file,dump,flag)
{ define(stream,".null",dump,dump) %and -> err %if flag # 0
{ %return
{err:
{ setfname(file)
{ event_extra = flag
{ event_message = failure message(flag)
{ %signal 9,3
{%end
{
{%externalroutine CLOSE INPUT %alias "VTCLIN"
{%integer s,dump
{ s = comreg(instr)
{ %if 0 < s <= 15 %start
{ dump = iocp(reset,s); define(s,".null",s,s)
{ %finish
{%end
{
{%externalroutine CLOSE OUTPUT %alias "VTCLOUT"
{%integer s,dump
{ s = comreg(outstr)
{ %if 0 < s-outstreambase <= 15 %start
{ dump = iocp(reset,s); define(s,".null",s,s)
{ %finish
{%end
{
{%externalintegerfn OUTSTREAM %alias "VTOUTS"
{ %result = comreg(outstr)-outstreambase
{%end
{
{%externalintegerfn INSTREAM %alias "VTINS"
{ %result = comreg(instr)
{%end
{
{!!!!!!!!!!!! Set PAD options
{%routine SET HANDLER MODE(%integer mode)
{
{%own %string(255) defparms="P2=1,P3=126,P4=0,P10=80,P13=4,P15=1"
{%string(127) pad mode
{%constinteger RESETMODE=controlterm+leavecontrols+notermecho+passdel+noecho+padecho
{
{%return %if (mode!!options)&resetmode = 0 ; ! Don't reset PAD unless entering/leaving screen mode
{%if mode # 0 %start
{ defparms = modestr; !Save PAD setting for later restore
{ %if mode¬ermecho#0 %start
{ pad mode="P2=0"; pad mode="P2=1" %if mode&padecho#0
{ pad mode=pad mode.",P3=127,P4=1,P10=0,P13=0,P15=0"
{ %else
{ pad mode="P2=1"; pad mode="P2=0" %if mode&noecho#0
{ pad mode=pad mode.",P3=126,P4=0,P10=0,P13=0,P15=1"
{ %finish
{ setmode(pad mode.",NOCONTROLCHARINTS,NOCRTRANSLATE")
{%finish %else %start
{ ! This cludge is to cope with the forwarding of the first character
{ ! typed after pads change from native mode - urgh! (G.Rule 24/09/86)
{ setmode("P4=255")
{ ! Setting a long (but non-zero) timeout before setting zero timeout
{ ! seems to work!
{ setmode(defparms); ! Restore default
{%finish
{%end; !SET HANDLER
{
{!!!!!!!!!!!!! Output to terminal
{%routine PUT BUFFER
{%integer from
{ outcount = 0 %and %return %if outcount <= 0 %or outmode < 0
{ from = addr(outbuff(0))
{ console(10,from,outcount)
{ outcount = 0
{%end; !of PUT BUFFER
{!
{%routinespec put symbol(%integer k)
{%routinespec put sequence(%integer seq)
{%own %integer from, amount
{!
{%routine GET BUFFER
{!Request next input packet
{%integer i,pos,flag,kk, exitflag
{%constinteger maxecho=63
{%string(maxecho) echo
{%own %integer escaping=0
{ inpos = 0; incount = 0
{ leaddels = 0; traildels = 0
{ exitflag = options&single; ! Always exit if single char.
{ journal off
{ %cycle; ! until control char or esc seq.
{ put buffer %if outcount > 0
{ console(1,from,amount) %if amount = 0; ! Get terminal Input
{ echo = ""
{ %cycle; ! transfer data to INBUFF
{ exitflag = 1 %and %exit %unless incount < inbound; !Buffer full - rest of input is lost
{ kk = byteinteger(from)&127
{ from = from + 1; amount = amount - 1
{ %if kk = del %and options&nodelecho=0 %start
{ %if incount > 0 %start
{ %continue %if escaping > 0; ! Ignore delete during Esc seq.
{ traildels = traildels+1
{ incount = incount-1;
{ %if options&hostecho # 0 %start ; ! Connection is by PAD
{ %if length(echo) > 0 %and char no(echo,1) # bs %start; ! Check for previous DEL
{ length(echo) = length(echo)-1
{ %else
{ put symbol(charno(echo,i)) %for i=1,1,length(echo)
{ echo=""
{ %if options&inserting=0 %start
{ put symbol(bs); put symbol(' '); put symbol(bs)
{ %else
{ put symbol(bs); put sequence(dodeletechar)
{ %finish
{ %finish
{ %finish
{ %finish %else leaddels = leaddels+1
{ %finish %else %start
{ inbuff(incount) = kk; incount = incount+1
{ %if (kk>=' ' %and escaping=0) %or options¬ermecho=0 %start
{ %if options&hostecho#0 %and options&noecho=0 %start
{ echo = echo.tostring(kk)
{ %if length(echo) >= maxecho %start
{ put symbol(charno(echo,i)) %for i=1,1,length(echo)
{ echo=""
{ %finish
{ %finish
{ traildels = traildels-1 %if traildels > 0
{ %finish
{ %if kk=esc %and escaping = 0 %and options&controlterm#0 %start; ! Escape
{ escaping=esc
{ %finishelseunless ' ' <= kk < del %start; ! Other Control
{ escaping=0
{ exitflag = 1 %if kk=rt %or kk=lf %or options&controlterm#0
{ %finishelseif escaping # 0 %start
{ repairch = repairch + 1 %if options&padecho#0
{ %if escaping=esc %and (kk='[' %or kk ='O' %or kk='?') %start
{ escaping=kk
{ %finishelseif escaping='[' %and kk='?' %start
{ %finishelseif escaping='[' %and '0'<=kk<='9' %start
{ %else
{ escaping=0
{ exitflag = 1
{ %finish
{ %finish
{ %finish
{ %repeat %until amount = 0
{ put symbol(charno(echo,i)) %for i=1,1,length(echo)
{ %repeat %until exitflag # 0
{ journal on
{%end; !of GET BUFFER
{
!$FINISH
!
!!!!!!!!!!!!!!!!! Internal procedures !!!!!!!!!!!!!!!!!!!!
!
routine PUT SYMBOL(integer k)
![also in-line within VT PSYM]
outbuff(outcount) = k; outcount = outcount+1
put buffer if outcount > outbound
end
!
routine PUT SEQUENCE(integer seq)
while seq # 0 cycle
if seq&escflag # 0 start
if seq&127 = 0 start ; !marker for padding
seq = seq>>8
cycle
put symbol(padchar)
exit if seq&255 = 0
seq = seq-1
repeat
finish else if vttype=bbc start ;! Allow 8 bit codes- no escapes
put symbol(seq&255)
else
put symbol(esc); put symbol(seq&127)
finish
else
put symbol(seq&127)
finish
seq = seq>>8
repeat
end
routine put string(string (255) s)
integer i
put symbol(char no(s,i)) for i = 1,1, length(s)
end
routine PUTNUM(integer val)
!Numeric output (for VT100)
putnum(val//10) and val = val-val//10*10 if val >= 10
put symbol(val+'0')
end
!$IF VAX
string (15)fnspec smg cursor seq(integer r,c)
!$FINISH
owninteger ct=0, cb=0; ! Current settings of scroll region (ANSI only()
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
return if vdu_fun = 0; !hardcopy mode
if row = vdu_row start
return if col = vdu_col; !already there =>
! Optimise for RT and BS
! [RT disabled because of Vax interference]
if col = 0 start
put symbol(rt); vdu_col = 0
return
finish
if 0 > col-vdu_col >= -3 start
cycle
put symbol(bs)
vdu_col = vdu_col-1
repeat until vdu_col = col
return
finish
finish
! Don't cause a scroll
if col = 0 and row = vdu_row+1 and vdu_row # cb start
put symbol(rt) ; ! For EMAS as well since now using graph mode
put symbol(nl)
put symbol(padchar) for k=lfpad,-1,1
!$IF VAX
!! put buffer %if outcount > outbound-80
!$FINISH
vdu_row = vdu_row+1; vdu_col = 0
return
finish
vdu_row = row; vdu_col = col; !new values
!Interpret cursor address sequence
!**************************************************************************
! First test for SETUP from SMG database USE SMG=) for emas
!$IF VAX
if initialise=smg then put string(smg cursor seq(row,col)) and return
!$FINISH
!**************************************************************************
seq = docursor
while seq # 0 cycle
k = seq&255
if k=rowcode start
k=row
k=row+' ' unless vttype=7 or vttype=29 or vttype=31
k=row+96 if vttype=esprit
finish
if k = colcode start
k=col
k=col+' ' unless vttype=7 or vttype=29 or vttype=31 or vttype=esprit
k=col+96 if vttype=esprit and col<31
finish
put symbol(esc) if k&escflag # 0
put symbol(k&127)
seq = seq>>8
repeat
if vttype = vt100 start ; !(ESC [ generated from SEQ)
putnum(row+1) if row # 0; !Internal setup only
put symbol(';') and putnum(col+1) if col # 0
put symbol('H')
finish
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 !!!!!!!!!!!!!!!!!!!!
!
externalroutine DELETE CHAR alias "VTDELCH"
! Call is Only valid if VDU_FUN&CANINSERT#0 ie terminal can delete
put sequence(dodeletechar) if dodeletechar # 0
end
externalroutine CLEAR LINE alias "VTCROL"
integer pos
return if win_col >= win_cols
position cursor(win_row,win_col)
if win_cols = vdu_cols and doclearline # 0 start
put sequence(doclearline)
finish else if outmode > 0 start
change shade
pos = win_col
cycle
put symbol(' '); pos = pos+1
if vdu_col < vright then vdu_col = vdu_col+1 c
else vdu_row = 255
repeat until pos = win_cols
finish
end
!
externalroutine CLEAR FRAME alias "VTCFRAME"
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
!
!$IF VAX
string (15)fnspec smg set scroll seq(integer vt,vb)
!$FINISH
externalroutine SCROLL alias "VTSCROLL"(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
put string(full screen scroll) and vdu_row=255 c
if vdu_fun&ansiscroll # 0 and (ct # vt or cb # vb)
ct = vt; cb = vb
position cursor(b,0) if vb # vdu_row; !any col OK
while n>0 cycle
put symbol(nl); !hardware scroll
n=n-1
repeat
return
finish
finish else win_row = t
if ansiscroll = 0 start ; !scroll by insert/delete line
if dodelete = 0 start
clear line
return
finish
if n < 0 start
n = -n
i = t; t = b; b = i
vt = t; vb = b
finish
for i = 1,1,n cycle
if vt < vbot start
position cursor(t,0) if vdu_row # vt; !any col OK
put sequence(dodelete)
vdu_col = 0
finish
if vb < vbot start
position cursor(b,0)
put sequence(doinsert)
finish
repeat
finish else start ; !vt100
if vt # ct or vb # cb start ; ! Is current scroll region OK?
!$IF VAX
if initialise=smg then put string(smg set scroll seq(vt,vb)) else start
!$FINISH
put sequence(escflag+'[')
putnum(vt+1); put symbol(';'); putnum(vb+1)
put symbol('r'); !Set Scrolling region
!$IF VAX
finish
!$FINISH
cb = vb; ct = vt
vdu_row = 255; !?
finish
cycle
if n > 0 start
position cursor(b,0)
put sequence(doscrolld); !Index
n = n-1
finish else if n < 0 start
position cursor(t,0)
put sequence(doscrollu); !Reverse Index
n = n+1
finish
repeat until n = 0
! put string(full screen scroll); !restore scroll region
! vdu_row = 255
finish
end ; !SCROLL
!
!$IF VAX
externalroutine VT SELECT INPUT alias "VTSELIN"(integer i)
select input(i)
inmode = -1
inmode = vdu_fun if intype = -1 or options&noevent9 # 0
inmode = 0 if i = 0 and options&16_7FFFFFFF = 0; ! Not in video mode
end
externalroutine VT SELECT OUTPUT alias "VTSELOUT"(integer i)
select output(outstreambase+i)
outmode = -1
outmode = vdu_fun if outtype = -1
outmode = 0 if i = 0 and options&16_7FFFFFFF = 0; ! Not in video mode
end
!$IF AMDAHL
{%externalroutine SELECT INPUT %alias "VTSELIN"(%integer i)
{%integer k
{ i = i&15; k = iocp(selin,i)
{ inmode = -1
{ inmode = vdu_fun %if i = 0 {%and aitbuffer # 0; !terminal}
{ inmode = 0 %if i = 0 %and options&16_7FFFFFFF = 0; ! Not in video mode
{%end
{%externalroutine SELECT OUTPUT %alias "VTSELOUT"(%integer i)
{%integer k
{ i = i&15; i = i+outstreambase %if i # 0
{ k = iocp(selout,i)
{ outmode = -1
{ outmode = vdu_fun %if i = 0 {%and aitbuffer # 0; !terminal}
{ outmode = 0 %if i = 0 %and options&16_7FFFFFFF = 0; ! Not in video mode
{%end
{!
!$FINISH
externalroutine VT PRINT SYM alias "VTPSYM"(integer sym)
integer i
if outmode <= 0 start ; !non-video
!$IF AMDAHL
{ i = iocp(printch,sym)
!$IF VAX
! %if outmode = 0 %start; !hard-copy
! put symbol(rt) %if sym = nl
! put symbol(sym)
! %finish %else %start
print symbol(sym); !standard route
! %finish
!$FINISH
return
finish
put sequence(doendinsert) and insertflag = 0 if insertflag # 0
if escaping # 0 start
escaping = 0
put symbol(sym)
vdu_row = 255; !assume the worst
finish else if sym = del start
if 0 < win_col < win_cols start
win_col = win_col - 1
position cursor(win_row,win_col) if win_row+win_top # vdu_row c
or win_col+win_left # vdu_col
if options&inserting#0 start
put sequence(dodeletechar)
else
put symbol(' '); ! put symbol(bs)
vdu_col = vdu_col + 1 if vdu_col < vright
finish
finish
finish else if sym&96 # 0 start ; !not control
if win_col < win_cols start
position cursor(win_row,win_col) if win_row+win_top # vdu_row c
or win_col+win_left # vdu_col
change shade if win_mode&shade # vdu_mode
put symbol(sym)
put buffer if outcount > outbound
if vdu_col < vright then vdu_col = vdu_col+1 c
else vdu_row = 255
finish
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)
put symbol(sym)
escaping = 1 if sym = esc
finish
finish else start
clear line
if win_row < win_rows-1 start
![following lines shouldn't be necessary, but lower-level]
![software happier with regular NLs]
! put symbol(rt); ! EMAS now drives video T in graph mode so CR needed.
! put symbol(nl)
! vdu_row = vdu_row+1 %if vdu_row # 255; vdu_col = 0
win_row = win_row+1
finish else start
if win_mode&freeze # 0 start
!$IF VAX
if inmode < 0 start
i = instream; select input(0); prompt("")
finish
sym = single symbol
if sym = leadin start
sym = single symbol
sym = single symbol if sym = '?' or sym = 'O' or sym = '['
finish
vdu_row = 255
select input(i) if inmode < 0
!$IF AMDAHL
{ i = comreg(instr) %and select input(0) %if inmode < 0
{! set handler mode(options&(\specialpad)!notermecho) %c
{! %if options¬ermecho = 0
{ get buffer; incount = 0
{! set handler mode(options&(\specialpad)) %if options¬ermecho = 0
{ select input(i) %if inmode < 0
!$FINISH
finish
if win_mode&(noscroll+freeze) # 0 then win_row = 0 c
else scroll(0,win_row,1)
finish
win_col = 0
finish
end
!
externalroutine VT SPACE alias "VTSP"
vt print sym(' ')
end
externalroutine VT SPACES alias "VTSPS"(integer n)
vt print sym(' ') and n = n-1 while n > 0
end
externalroutine VT NEWLINE alias "VTNL"
vt print sym(nl)
end
externalroutine VT NEWLINES alias "VTNLS"(integer n)
vt print sym(nl) and n = n-1 while n > 0
end
externalroutine VT PRINT STRING alias "VTPSTRING"(string (255) s)
integer i
vt print sym(charno(s,i)) for i = 1,1,length(s)
end
!
externalroutine VT WRITE alias "VTWRITE"(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
vt spaces(pos-16-p) if p < 0
finish else start
vt spaces(pos-16+p)
vt print sym(' ') if v >= 0
finish
vt print sym('-') if v < 0
vt print sym(store(pos)) and pos = pos+1 until pos = 16
end
externalroutine VT PROMPT alias "VTPROMPT"(string (255) s)
if inmode > 0 then prom <- s else prompt(s)
end
!
owninteger pend=\nl
externalroutine VT READ SYMBOL alias "VTRSYM"(integername k)
integer kk,s,i,n
constinteger xoff = 'S'&31, xon = 'Q'&31
routine get another
!$IF VAX
if inpos >= incount then kk = single symbol c
else kk = inbuff(inpos)&127 and inpos = inpos+1
!$IF AMDAHL
{ get buffer %while inpos >= incount
{ kk = inbuff(inpos)&127; inpos = inpos+1
!$FINISH
get another if kk = xoff or kk = xon
end
!$IF AMDAHL
{ %if inmode <= 0 %start; ! Hardcopy
{ flush buffer
{ k = iocp(readch,0)
{ kk = iocp(nextch,0) %if k = em; ! signal END OF INPUT at right place
{ %return
{ %finish
!$IF VAX
read symbol(k) and return if inmode <= 0
!$FINISH
k = pend and pend = \pend and return if pend >= 0
if inpos >= incount start
put sequence(doendinsert) and insertflag = 0 if insertflag # 0
if prom # "" start
s = outstream and select output(0) if outmode < 0
vt print sym(charno(prom,i)) for i = 1,1,length(prom)
select output(s) if outmode < 0
finish
if outmode > 0 start
position cursor(win_row,win_col)
change shade if win_mode&shade # vdu_mode
finish else win_col = 0
if options&single # 0 start ; ! Single character interaction
!$IF VAX or APM
kk = single symbol
put symbol(kk) if ' ' <= kk < del and options&noecho = 0; ! Echo character
!$IF AMDAHL
{ get buffer %if inpos >= incount
{ kk = inbuff(inpos)&127 %and incount = incount - 1 %if incount > inpos
{ kk = del %and leaddels = leaddels-1 %if leaddels > 0; ! To ensure del passed through
!$FINISH
finish else start
get buffer until incount > inpos
kk = inbuff(inpos)&127; inpos = inpos+1
finish
else
kk = inbuff(inpos)&127; inpos = inpos+1
finish
while kk = xoff or kk = xon cycle
get another
!$IF VAX
put symbol(kk) if ' ' <= kk < del and options&noecho = 0; ! Echo character
!$FINISH
repeat
if kk < ' ' start
!$IF AMDAHL
{ %if repairch > 0 %start
{ inpos = inpos - 1; !Put off seq till screen OK
{ repairch = repairch-1
{ pend = \(del+1); k = del+1
{ %return
{ %finish
!$FINISH
if traildels > 0 start
traildels = traildels-1; inpos = inpos-1
pend = \del; k = del
return
finish
if kk = rt and options&leavert = 0 start
!$IF AMDAHL
{! lfmap = rt
!$FINISH
kk = lf
finish else if kk = lf start
kk = lfmap
finish else if kk = leadin start
get another
if kk = '[' start ; ! Esc [
get another
get another if kk='?'; ! Esc [ ?
if '0' <= kk <= '9' start ; !numeric seq, terminated by '~' %or '~'
n = kk - '0'; get another
while '0' <= kk <= '9' cycle ; !Should terminate with '~' but better safe!
exit if n>100000000; !avoid overflow
n = 10*n+(kk-'0'); get another
repeat
kk = n&127
if kk >= 14 then kk = kk + 60; ! To avoid conflicting codes
finish
finish else if kk = '?' or kk = 'O' start
get another; kk = kk!!96
finish
kk = kk!128
finish
vdu_row = 255 if options¬ermecho=0 or options&padecho#0
kk = nl if options&leavecontrols = 0
finish else if kk < del start
win_col = win_col+inc if win_col # 255
if vdu_col < vright then vdu_col = vdu_col+inc else vdu_row = 255
finish
! vdu_row = 255; ![safety for now]
pend = \kk; k = kk; !NB order
end
externalintegerfn VT NEXT SYMBOL alias "VTNSYM"
!$IF VAX
result = next symbol if inmode < 0
!$IF AMDAHL
{ %result = iocp(nextch,0) %if inmode < 0
!$FINISH
result = pend if pend >= 0
vt read symbol(pend)
result = pend
end
externalroutine VT SKIP SYMBOL alias "VTSSYM"
integer i
vt read symbol(i)
end
externalroutine READ alias "VTREAD"(integername v)
integer i,k,sign
cycle
k = vt next symbol
exit unless k = ' '
vt read symbol(k)
repeat
sign = 0
if k = '-' start
sign = 1
vt read symbol(k); k = vt next symbol
finish
signal 4 unless '0' <= k <= '9'
i = k-'0'
cycle
vt read symbol(k)
k = vt next symbol
exit unless '0' <= k <= '9'
i = i*10-'0'+k
repeat
i = -i if sign # 0
v = i
end
externalroutine AT alias "VTSETCURSOR"(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
externalroutine GOTOXY alias "VTGOTOXY"(integer x,y)
at(y,x)
end
externalroutine VT SET MODE alias "VTSETMODE"(integer m)
win_mode = win_mode&shade+m
end
externalroutine SET SHADE alias "VTSETSHADE"(integer s)
win_mode = win_mode&(\shade)+s
end
!
externalroutine SET FRAME alias "VTSETFRAME"(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
!
externalroutine PUSH WINDOW alias "VTPUSH"
if sp = stackmax start
event_message = "Too many windows"; signal 9,4
finish
sp = sp+1; stack(sp) = win
end
externalroutine POP WINDOW alias "VTPOP"
if sp > 0 then win = stack(sp) and sp = sp-1 c
else win = vdu
end
externalroutine SWOP WINDOW alias "VTSWOP"
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
externalroutine SET VIDEO MODE alias "VTSETVIDEO"(integer mode)
integer p,i
put buffer if outcount > 0; !this routine guaranteed to flush
return if mode = options
p = mode&specialpad
!$IF VAX
if options = untouched start
tt setup
inmode = vdu_fun if intype = -1; !terminal
outmode = vdu_fun if outtype = -1
win = vdu; prompt("")
finish
!interpret NOEVENT9 to mean use terminal anyway
inmode = vdu_fun and outmode = vdu_fun if mode&noevent9 # 0
readfunction = vmsread; !basic function selection
readfunction = readfunction+vmsnoecho if mode&noecho # 0
readfunction = readfunction+vmstrmnoecho if mode¬ermecho # 0
readfunction = readfunction+vmspurge if mode¬ypeahead # 0
termmask_length = 0; termmask_addr = \16_1700; !normal terminators
if mode&controlterm # 0 start
termmask_addr = \0; !all controls as terminators
if mode&passdel # 0 start ; !DEL too?
termmask_length = 16; termmask_addr = addr(mask(0))
finish
finish
readfunction = readfunction+vmsnofiltr if mode&(passdel+nodelecho) # 0
!$IF AMDAHL
{ %if options = untouched %start
{ select input(0); select output(0)
{ journal off %if mode&debug # 0; ! For now, since CONSOLE calls fill it
{ inmode = vdu_fun; outmode = vdu_fun
{ win = vdu; prompt("")
{ %finish
{ ! Coerce mode options to be consistent
{ mode=mode&(\padecho) %if mode&noecho # 0
{ mode=mode!nodelecho %if mode&noecho#0
{ mode=mode!hostecho %if mode¬ermecho#0 %c
{ %and mode&padecho=0; !Flag for GET BUFF to echo.
!$FINISH
if (mode!!options)&specialpad # 0 start ; !change in pad mode
if p # 0 then put sequence(dospecialpad) c
else put sequence(donormalpad)
put string(initialise tt) if p#0
finish
if (mode!!options)&inserting # 0 start ; !set terminal to insert mode
if mode&inserting # 0 start
if insert flag = 0 then put sequence(do begin insert)
insert flag = 0
finish else insert flag = 1; !Still in video mode
finish
if mode = 0 start ; ! Reset everything
put sequence(do end insert) if insert flag # 0; !This is fairly final
scroll(0,vdu_rows-1,0); ! To reset scroll area on DEC - like terminals
position cursor(vdu_row,vdu_col); ! The call on Scroll moved the cursor
put buffer; !BEFORE resetting PAD mode so that ESC gets through.
!$IF AMDAHL
{ %finishelseif options&16_3FFFFFFF = 0 %start
{ amount = 0; ! Tell GET BUFFER that no input is outstanding
{ flush buffer; ! empty SYSTEM IO buffer before VECCE takes over
{ %finish
{ set handler mode(mode-p)
!$IF VAX
finish
set handler mode(mode) if vdu_fun#0
!$FINISH
put buffer; ! After setting PAD or TCP on entry
options = mode
inc = 1; inc = 0 if options&noecho # 0
if in stream = 0 start
if mode = 0 then inmode = 0 else inmode = vdu_fun
finish
if out stream = 0 start
if mode = 0 then outmode = 0 else outmode = vdu_fun
finish
end
string (255)fn setup bbc
! Set up sequences for *KEY definitions for BBC in XTALK mode
integer i
string (255) bbcset,bbcoff
string (1) se
ownstring (2) snl
snl=tostring(lf)
!$IF VAX
snl=tostring(rt).snl
!$FINISH
se=tostring(esc)
bbcset=""
bbcset = se."*FX 4,2".snl
for i=0,1,9 cycle
bbcset=bbcset.se."*KEY ".tostring(i+'0')." |[?".tostring(i+'p').snl
repeat
bbcset=bbcset.se."*KEY 10 |[?z".snl
for i=0,1,4 cycle
bbcset=bbcset.se."*KEY 1".tostring(i+'1')." |[?".tostring(i+'@').snl
repeat
bbcoff=se."*FX 4,0".snl
result =bbcset
end ; !of SETUP BBC
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!At present it is convenient to have a self-contained facility
! in the package for setting up the video attributes and
! control sequences appropriate to a given terminal, but
! it is assumed that this will be superseded by a more
! general facility (or set of facilities).
! There are a number of gaps and untried cases in the following.
!
!$IF VAX
own integer term addr
include "SMGTRMPTR.INC"
external integer fn spec init term table by type alias c
"SMG$INIT_TERM_TABLE_BY_TYPE" (integername devtype,adr)
external integer fn spec get term data alias c
"SMG$GET_TERM_DATA" (integername adr,code,buflen,retlen,integer bufad,parad)
integer fn VMS TERMINAL TYPE
integer devtype,flag,len
record (desc fm) d
recordformat item fm(short buff len, code, integer buff addr, ret len)
record (item fm) null=0,item
string (2) term
constinteger dvi devtype=6
system integerfn spec getdviw(integername efn,chan,
record (desc fm)name devnam,
record (item fm)name itmlst,
record (*)name iosb,
integer ast addr,
integer ast parm,null)
term="TT"; d_length=length(term); d_addr=addr(term)+1
item_code = dvi devtype; item_buff len=4;
item_buffaddr=addr(devtype);item_retlen=addr(len)
flag=get dviw(integer(0),integer(0),d,item,record(0),0,0,0)
result =devtype if flag=1
result =-1
end
integerfn emas terminal type
string (31) term
integer flag,data,len,size=size of(term)-1,code=smg name
flag=get term data(term addr,code,size,len,addr(term)+1,0)
signal 13,4,flag unless flag=1
length(term)<-len
result = 8 if term = "VT52"
result = 11 if term = "FT1";! Visual 200
result = 12 if term = "VT100"
result = 6 if term = "FT2" or term="BANTAM" or term="PE550"
result = 13 if term = "FT3" or term="ESPRIT"
result = 15 if term = "FT4" or term="NEWBURY"
result = 25 if term = "VISUAL50" or term = "VISUAL55"
result = 29 if term = "BBCX"; ! BBC micro with XTALK
result = 0
end
!
integer fn smg get integer(integer code)
integer flag,data,len,size=4
flag=get term data(term addr,code,size,len,addr(data),0)
signal 13,4,flag unless flag=1
data=0 if len=0
result =data
end
string (31) fn smg get string 2(integer code)
! RETURN STRING DATA FROM SMG
constinteger slen=31
integer flag,len,size=slen,i,seq,sh,k,pads
string (slen) data
flag=get term data(term addr,code,size,len,addr(data)+1,0)
signal 13,4,flag unless flag=1
length(data)<-len
result =data
end
integer fn smg get string 3(integer code)
! RETURN STRING DATA FROM SMG IN SAME FORM AS READ SYMBOL (For cursor keys)
constinteger slen=31
integer flag,len,size=slen,i,k
string (slen) data
flag=get term data(term addr,code,size,len,addr(data)+1,0)
signal 13,4,flag unless flag=1
length(data)<-len
result = 0 if len = 0
i=1
k=char no(data,i)
if k=esc start
i=i+1
signal 13,1 if i>length(data)
k=char no(data,i)
if k='[' then i=i+1 and k=char no(data,i)
signal 13,1 if i>length(data)
if k='O' or k='?' start
i=i+1
signal 13,1 if i>length(data)
k=char no(data,i)!!96
finish
k=k!escflag
finishelseif k=lf start
k=rt
finishelseif k=rt start
k=lf
finish
result =k&255
end
integer fn smg get string(integer code)
! RETURN STRING DATA FROM SMG PACKED AS VECCE INTEGER SEQ
constinteger slen=31
integer flag,len,size=slen,i,seq,sh,k,pads
string (slen) data
flag=get term data(term addr,code,size,len,addr(data)+1,0)
signal 13,4,flag unless flag=1
length(data)<-len
i=0; sh=0; seq=0;pads=0
while i<length(data) and sh<=24 cycle ; ! Code string as packed integer
i=i+1; k=0
i=i+1 and k=escflag if char no(data,i)=esc
signal 13,1 if i>length(data)
k=k+char no(data,i)
while i<=length(data) and char no(data,i)=0 cycle ; ! Count Padding chars
pads=pads+1; i=i+1
repeat
if pads>0 start ; ! Code padding as ESCFLAG,NPADS
signal 13,2 if sh>16
seq=seq ! escflag<<sh; sh=sh+8
seq=seq ! pads<<sh; sh=sh+8
pads=0
finish
seq=seq ! k << sh; sh=sh+8
repeat
result =seq
end
string (15)fn smg cursor seq(integer r,c)
integerarray parms(0:2)
integer flag,len,size=15,code=smg set cursor abs
string (15) data
parms(0)=2; parms(1)=r+1; parms(2)=c+1
flag=get term data(term addr,code,size,len,addr(data)+1,addr(parms(0)))
signal 13,4,flag unless flag=1
length(data)<-len
result =data
end
string (15)fn smg set scroll seq(integer t,b)
integerarray parms(0:2)
integer flag,len,size=15,code=smg set scroll region
string (15) data
parms(0)=2; parms(1)=t+1; parms(2)=b+1
flag=get term data(term addr,code,size,len,addr(data)+1,addr(parms(0)))
signal 13,4,flag unless flag=1
length(data)<-len
result =data
end
routine SETUP FROM SMG
integer vaxtype,flag,cols2
! %on %event 13 %start
! vdu_fun=0
! %monitor
! %return
! %finish
vaxtype = VMS TERMINAL TYPE
flag = init term table by type(vaxtype,term addr)
if flag&1 # 0 start ; ! Success
vttype=emas terminal type
initialise=smg; vdu = 0
vdu_rows= smg get integer(smg rows); vbot=vdu_rows-1
vdu_cols= smg get integer(smg columns)
cols2= smg get integer(smg wide screen columns)
vdu_cols=cols2 if options&wide#0 and cols2#0
vright=vdu_cols-1
vdu_fun=0
doclearscreen=smg get string(smg erase to end display)
doclearline =smg get string(smg erase to end line)
vdu_fun=vdu_fun + fullscroll if smg get string(smg set cursor abs)#0
dodelete=smg get string(smg delete line)
doinsert=smg get string(smg insert line);
dobegininsert=smg get string(smg begin insert mode)
doendinsert =smg get string(smg end insert mode)
dodeletechar =smg get string(smg delete char)
! docursorl =smg get string(smg cursor left)
vdu_fun=vdu_fun+caninsert c
if dodeletechar#0 and dobegininsert#0 and doendinsert#0
if smg get string(smg set scroll region) # 0 start ; ! VT100 type scroll
doscrolld = smg get string(smg scroll forward); ! These entries should be there
doscrollu = smg get string(smg scroll reverse); ! But people make mistakes
vdu_fun=vdu_fun!anyscroll and ansiscroll = 1 unless doscrolld=0 or doscrollu=0
full screen scroll=smg set scroll seq(0,vdu_rows-1)
finish
vdu_fun=vdu_fun!anyscroll unless dodelete=0 or doinsert=0; ! Scroll via insert/delete
dostandard=0; dograph=0
donormalpad= smg get string(smg set numeric keypad)
dospecialpad=smg get string(smg set application keypad)
doselect(0) = smg get string(smg begin normal rendition)
doselect(1) = smg get string(smg begin reverse); ! First try reverse video
doselect(1) = smg get string(smg begin bold) if doselect(1)=0; ! Then bold
doselect(1) = smg get string(smg begin underscore) if doselect(1)=0; ! Then underline
doselect(1) = smg get string(smg begin blink) if doselect(1)=0
vdu_fun=vdu_fun ! 1 if doselect(1) #0
key u=smg get string3(smg key up arrow)
key d=smg get string3(smg key down arrow)
key l=smg get string3(smg key left arrow)
key r=smg get string3(smg key right arrow)
padchar=smg get string(smg pad char)
lfpad=smg get integer(smg lf fill)
! lfpad=20 %if vttype=vt52; !Pad chars after LF
initialise tt=""
initialise tt=setup bbc if vttype=bbc
else
initialise=internal
vdu = 0; vdu_rows = 24; vdu_cols = 80
printstring(sysmess(flag).snl)
finish
end
!$FINISH
routine SETUP INTERNAL(integer emastype)
!Use EMAS video type number to set up video parameters
! ie VDU details and control sequences
! The following byte array contains one IMP string for each
! terminal, specifying the following information:
! ROWS,COLS,CLEARSSEQ,CLEARLSEQ,CURSORSEQ,
! DELETESEQ,INSERTSEQ,
! STANDARDSEQ,GRAPHSEQ,
! NORMALPADSEQ,SPECIALPADSEQ,
! SELECTSEQ(0:15)
! Sequences may be up to 4 bytes and if less than 4 are
! terminated by a zero byte; trailing null sequences may
! be omitted.
![Accommodation of individual device idiosyncrasies is]
![minimal and ad hoc: it would be easy to spend a lifetime]
![generalising to cater for all sorts of antiquated terminals]
constinteger E=128,R=254,C=255
constinteger MAXTYPE=33
constbyteintegerarray VINFO(0:532) =
{0: unspecified} 2,24,72,
{1: hardcopy width 72} 2,24,72,
{2: hardcopy width 80} 2,24,80,
{3: hardcopy width 132} 2,24,132,
{4: unknown video} 2,24,80,
{5: ITT} 2,24,80,
{6: P-Elmer Bantam} 13,24,80, e+'K',e,20,0, e+'I',e,0,
e+'X',r,e+'Y',c,
{7: Lynwood} 23,30,80,'A'&31,0,0,'X'&31,r,c,0,0,0,0,0,
'R'&31,'D'&31,'V'&31,0,
'S'&31,'T'&31,0,'Q'&31,0,'R'&31,
{8: DEC VT52} 17,24,80, e+'J',0, e+'K',0, e+'Y',r,c,0,
0,0, 0,0,
e+'>',0,e+'=',
{9: micro} 2,24,80,
{10: ADM-3A} 8,24,80, 'Z'&31,0, 0, e+'=',c,r,
{11: Visual 200} 25,24,80, e+'v',0, e+'x',0, e+'Y',r,c,0,
e+'M',0,e+'L',0,
e+'G',0,e+'F',0,
e+'>',0,e+'=',0,
e+'3',0,e+'4',
{12: VT100} 34,24,80, e+'[','J',0, e+'[','K',0, e+'[',0,
e+'[','M',0,e+'[','L',0,
e+'[','(','B',0,e+'[','(','0',0,
e+'>',0,e+'=',0,
e+'[','m',0,e+'[','7','m',
{13: Hazeltine Esprit} 27,24,80, e+24, 0, e+15,0, e+17,c,r,0,
e+19,e,20,0,e+26,e,20,0, {20 pads}
0,0,
e+'>',0,e+'=',0,
e+25,0,e+31,
{14: Hazeltine 1500} 2,24,80,
{15: Newbury} 21,24,80, 16_1F,0, 16_19,0, 16_16,c,r,0,
2,0,1,0,
0,0,
0,0,
16_13,0,16_12,
{16: Pericom} 34,24,80, e+'[','J',0, e+'[','K',0, e+'[',0,
e+'[','M',0,e+'[','L',0,
e+'[','(','B',0,e+'[','(','0',0,
e+'>',0,e+'=',0,
e+'[','m',0,e+'[','7','m',
{17: Tektronix 4010} 2,24,80,
{18: IBM 3101} 2,24,80,
{19: Dacoll 242E} 2,24,80,
{20: Volker Craig 404} 8,24,80, 0, 'V'&31,0, 'P'&31,r,c,
{21: ICL KDS7362} 20,24,80, 0, e+'T',0, e+'=',r,c,0,
{&Televideo 912/20/25} e+'R',0,e+'E',0,
0,0, 0,0,
e+'(',0,e+')',
{22: Esprit II} 2,24,80,
{23: Esprit III} 2,24,80,
{24: ADM-5} 19,24,80, 'Z'&31,0, e+'T',0, e+'=',r,c,0,
0,0, 0,0, 0,0, e+'(',0,e+')',
{25: Visual 50/5} 26,24,80, 0, e+'K',0, e+'Y',r,c,0,
e+'M',0,e+'L',0, e+'G',0,e+'F',0,
e+'>',0,e+'9','P',e+'=',0,
e+'T',0,e+'U',
{26: TEKTRONIX 4014} 2,64,132,
{27: Datatype X5A} 34,24,80, e+'[','J',0, e+'[','K',0, e+'[',0,
e+'[','M',0,e+'[','L',0,
e+'[','(','B',0,e+'[','(','0',0,
e+'>',0,e+'=',0,
e+'[','m',0,e+'[','7','m',
{28: ANSI} 34,24,80, e+'[','J',0, e+'[','K',0, e+'[',0,
e+'[','M',0,e+'[','L',0,
e+'[','(','B',0,e+'[','(','0',0,
e+'>',0,e+'=',0,
e+'[','m',0,e+'[','7','m',
{29: BBC with XTALK} 23,24,80,16_0C,0,0,16_1F,c,r,0,
0,0, 0,0, 0,0,
17,130,17,1, 17,129,17,2,
{30: cromenco } 2, 24, 80,
{31: Wyse - 132 col } 34,24,132, e+'[','J',0, e+'[','K',0, e+'[',0,
e+'[','M',0,e+'[','L',0,
e+'[','(','B',0,e+'[','(','0',0,
e+'>',0,e+'=',0,
e+'[','m',0,e+'[','7','m',
{32: Wyse - 80 col } 34,24,80, e+'[','J',0, e+'[','K',0, e+'[',0,
e+'[','M',0,e+'[','L',0,
e+'[','(','B',0,e+'[','(','0',0,
e+'>',0,e+'=',0,
e+'[','m',0,e+'[','7','m',
{33: Vt100 } 34,24,80, e+'[','J',0, e+'[','K',0, e+'[',0,
e+'[','M',0,e+'[','L',0,
e+'[','(','B',0,e+'[','(','0',0,
e+'>',0,e+'=',0,
e+'[','m',0,e+'[','7','m',
0 (*)
integer t,l,i,suppress
integerfn NEXTSEQ
integer seq,k,sh
seq = 0; sh = 0
while l > 0 and sh <= 24 cycle
l = l-1; t = t+1
k = vinfo(t)
exit if k = 0
seq = seq+k<<sh; sh = sh+8
repeat
result = 0 if suppress&1 # 0
result = seq
end
emastype = 0 if emastype > maxtype
suppress=0
vttype = emastype
t = 0
cycle
l = vinfo(t); !length of data for this terminal
emastype = emastype-1
exit if emastype < 0
t = t+l+1
repeat
vdu = 0
vdu_rows = vinfo(t+1); vbot = vdu_rows {-1}
vdu_cols = vinfo(t+2); vright = vdu_cols-1
t = t+2; l = l-2
vdu_fun = 0
doclearscreen = nextseq; doclearline = nextseq
suppress = suppress&(\1)
docursor = nextseq; vdu_fun = vdu_fun+fullscroll if docursor # 0
suppress = suppress>>1
dodelete = nextseq; vdu_fun = vdu_fun+anyscroll if dodelete # 0
doinsert = nextseq
suppress = suppress&(\1)
dostandard = nextseq; dograph=nextseq
donormalpad = nextseq; dospecialpad = nextseq
if vttype = pericom or vttype = wyse or vttype = wysew start
do begin insert = escflag+'[' + '4'<<8 + 'h'<<16
do end insert = escflag+'[' + '4'<<8 + 'l'<<16
do delete char = escflag+'[' + 'P'<<8
vdu_fun = vdu_fun ! caninsert
finish
! %if vttype = esprit %start; ! Don't know if this works
! do begin insert = escflag+'#'+(escflag+'P'<<8)
! do end insert = escflag+'P'+(escflag+'$'<<8)
! do delete char = escflag+'T'
! vdu_fun = vdu_fun ! caninsert
! %finish
if vttype=vt100{105} or vttype = wyse or vttype = pericom or vttype = ansi or c
vttype = x5a or vttype = wysew or vttype = 33 {VT100} start
vdu_fun=vdu_fun ! anyscroll
ansiscroll = 1
doscrolld = escflag+'D'
doscrollu = escflag+'M'
full screen scroll=tostring(esc)."[;r"
vttype = vt100
finish
suppress = suppress>>1
for i = 0,1,15 cycle
doselect(i) = nextseq
vdu_fun = vdu_fun!i if doselect(i) # 0
repeat
if vttype=vt52 then lfpad=20; !padding after lf
initialise tt=""
initialise tt=setup bbc if vttype=bbc
end
externalroutine DEFINE VIDEO alias "VTDEFVIDEO"(integer emastype)
!$IF AMDAHL
{ emastype = uinfi(terminaltype) %if emastype < 0; !terminal type
{ emastype = 0 %if uinfi(tmode) = batch; ! Disallow screen mode from batch
!$IF VAX
emastype = 0 if batch mode # 0
SETUP FROM SMG if emastype < 0
emastype = vttype and initialise = internal if vttype=esprit;
! Cursor addressing for esprit I
! can not be done by SMG. II& III OK.
!$FINISH
emastype = esprit if emastype = 22 or emastype = 23
setup internal(emastype) if initialise=internal
vdu_row = 255; ![safety]
end
endoffile