SECTION "Cifer"
GET "LIBHDR"
GET "SIM3270HDR"
MANIFEST $( esc = #X1B
cr = #XD
bs = 8
lf = #XA
$)
LET clear.display() BE
$( outch(esc); outch('J')
FOR i = 0 TO 1920/bytesperword-1 DO
$( dba!i := 0
dbb!i := 0
$)
// clear field list
$( LET ll = la
la := -1
UNTIL ll=-1 DO
$( LET lll = !ll
free.ele(ll)
ll := lll
$)
$)
ca, rca := 0, 0
curruat := 0; curruatp := -1
$)
AND highlights.off() BE
$( outesc('X')
outesc('+')
highlighting := FALSE
$)
AND highlights.on() BE
$( outesc('Y')
outesc('+')
highlighting := TRUE
$)
AND setup.display() BE
$( outesc('=')
outesc('J')
outesc('N') // enable highlighting (model 2605-04)
outesc('+') // copy highlight status
outesc('X') // half intensity on
outesc('+')
outesc('M') // inverted video off
outesc('+')
$)
AND unsetup.display() BE
$( outesc('7')
outesc('O')
$)
AND outesc(c) BE
$( outch(esc)
outch(c)
$)
AND keyboard.lock() BE outesc('"')
AND set.cursor(c) BE
$( ca := c
UNLESS rca=ca DO
$(
outch(esc)
outch('P')
outch(c REM 80)
outch(c/80)
rca := ca
$)
find.user(ca)
$)
AND sound.alarm() BE
outch(7)
AND clear.line(ad) BE
$( // clear line on display from address ad
UNLESS rca=ad DO
$( outesc('P')
outch(ad REM 80)
outch(ad/80)
rca := ad
$)
outesc('K') // CLEAR TO END OF LINE
$)
AND keyboard.restore() BE
$( aid := #X60 // reset AID byte
outch(esc)
outch('$')
$)
/* dispch routine for CIFER terminals (2605).
Puts character at given address in dba, also writes
it to the screen. Determines a good way to move
the cursor. Must also restore cursor to correct
address for input if no more.to.display.
Cursor address on screen is given by rca,
cursor address for user by ca.
Cifer should be set up with:
esc 8 roll mode, fixed screen
esc J clear screen
Controls used:
esc C cursor right
bs backspace
esc ! cursor to end of line
cr carriage return
esc ← cursor bottom (left)
lf line feed
esc @ cursor down
esc A cursor up
esc : reverse line feed
esc " keyboard lock
esc $ keyboard unlock
esc P x y move cursor to col x row y
Uses cursor position command unless other commands
can effect change in 0, 1, 2 or 3 characters.
Cursor will often be in correct place if writing
a field.
*/
AND dispch(a, ch) BE
$( LET dch = dba%a
LET ach = ascii(ch)
dba%a := ch
UNLESS ((#X20<ach<=#X7E)|(#X20<ascii(dch)<=#X7E))&(ch~=dch) DO
// if blank on blank or characters same return
RETURN
UNLESS a=rca DO // dont bother to move if already OK
$( TEST a=0 DO // use cursor home
$( outch(esc); outch('H') $)
OR
$( TEST a=1840 DO // use cursor bottom
$( outch(esc); outch('←') $)
OR // try others
$(
LET row = a/80
LET col = a REM 80
LET rowc = rca/80
LET colc = rca REM 80
LET vd = ABS(row-rowc)
LET hd = ABS(col-colc)
UNLESS hd=0 DO IF col=0 DO hd := 1
UNLESS hd<=1 DO IF col=79 DO hd := 2
UNLESS vd=0 DO IF rowc>row DO vd := vd<<1 // weighted
TEST vd+hd<=3 DO
$( UNLESS hd=0 DO // move horizontally
TEST col=0 DO // use cr
outch(cr)
OR
$( TEST col=79 DO // move to end of line
$( outch(esc); outch('!') $)
OR
$( TEST col>colc DO
$( LET bas = rowc*80
FOR i = colc+bas TO col+bas-1 DO
$( LET cc = ascii(dba%i)
TEST #X20<=cc<=#X7E DO outch(cc)
OR outch('*S')
$)
$)
OR FOR i = 1 TO colc-col DO outch(bs)
$)
$)
UNLESS vd=0 DO // move vertically
TEST row>rowc DO
FOR i = 1 TO row-rowc DO outch(lf)
OR FOR i = 1 TO rowc-row DO $( outch(esc); outch(':') $)
$)
OR // use cursor position command
$( outch(esc); outch('P')
outch(col); outch(row)
$)
$)
$)
$)
UNLESS #X20<=ach<=#X7E DO ach := '*S'
outch(ach)
UNLESS a=1919 DO a := a+1
rca := a
UNLESS more.to.display DO set.cursor(a)
$)
AND handle.ch(ch) BE // handle character typed by the user
$( /* The user has the ability to
. move the cursor about
. enter characters into display
. use special function keys to cause data transmission
The cifer keyboard has to emulate the 3277 keyboard.
Some keys will behave as usual, others have altered functions
and others will be ignored.
The program has control of the screen at all times, LOCAL mode
and ECHO ON are not used.
The keys are handled as follows:
clear scrn esc B performs clear AID byte, clears buffer
and display (esc J) (cursor to 0)
cursor down esc @ move cursor down
cursor up esc A move cursor up
cursor left esc D move cursor left
cursor right esc C move cursor right
esc ! move cursor to end of line
home esc H move cursor to home position
esc ← move cursor to bottom left position
rev line feed esc : as cursor up
esc esc write esc in buffer
clear line esc K erase to end of field
esc 0 erase input
esc 8 insert mode
esc 9 cancel insert mode
All other escapes are illegal except 1, 2 and 3 (see below).
Program attention keys:
CLEAR use clear
ENTER " return
PA1 " esc 1
PA2 " esc 2
PA3 " esc 3
PF1 " ctrl-A
PF2 " ctrl-S
PF3 " ctrl-D
PF4 " ctrl-F
PF5 " ctrl-G
PF6 " ctrl-H
PF7 " ctrl-Z
PF8 " ctrl-X
PF9 " ctrl-C
PF10 " ctrl-V
PF11 " ctrl-B
PF12 " ctrl-N
The following characters behave 'as expected' (printing characters).
They are entered at the current cursor position and the cursor moves
right.
sp ! " # $ % & ' ( ) * + , - . /
0 1 2 3 4 5 6 7 8 9 : ; < = > ?
@ A B C D E F G H I J K L M N O
P Q R S T U V W X Y Z [ \ ] ↑ ←
a b c d e f g h i j k l m n o
p q r s t u v w x y z { | } ~
any other characters, controls or otherwise are ignored.
*/
SWITCHON ch INTO // seems like a good idea
$( CASE esc:
IF escing DO safeprint(esc)
escing := ~escing
ENDCASE
CASE 'A': CASE 'B': CASE 'C': CASE 'D': CASE 'H':
CASE '@': CASE '!': CASE '←': CASE ':': CASE 'K':
CASE '1': CASE '2': CASE '3':
CASE '8': CASE '9': CASE '0':
IF escing DO
$( escing := FALSE
SWITCHON ch INTO
$( CASE ':':
CASE 'A':
outesc('A') // cursor up
TEST ca/80=0 DO
ca := 23*80 + ca REM 80
OR ca := ca-80
rca := ca
find.user(ca) // sets curruat and curruatp
ENDCASE
CASE 'B':
clear.display()
aid := #X6D
cba := 0; currat := 0
read.modified()
ENDCASE
CASE 'C':
outesc('C') // cursor right
ca := ca=1919 -> 0, ca+1
rca := ca
find.user(ca)
ENDCASE
CASE 'D':
outch(bs)
ca := ca=0 -> 1919, ca-1
rca := ca
find.user(ca)
ENDCASE
CASE '←':
outesc('←') // cursor bottom left
ca := 1840
rca := ca
find.user(ca)
ENDCASE
CASE '@':
TEST ca/80=23 DO
$( ca := ca REM 80
outesc('@')
$)
OR
$( ca := ca+80
outch(lf)
$)
rca := ca
find.user(ca)
ENDCASE
CASE '!':
outesc('!') // cursor to end of line
ca := (ca/80)*80+79
rca := ca
find.user(ca)
ENDCASE
CASE '1':CASE '2': CASE '3':
aid := ch='1' -> #X6C, // PA1
ch='2' -> #X6E, // PA2
#X6B // PA3
read.modified()
ENDCASE
CASE '8':
insert.mode.on := TRUE
ENDCASE
CASE '9':
insert.mode.on := FALSE
ENDCASE
CASE '0':
$( LET fuf = FALSE // unprotected fields found
LET fpf = FALSE // protected fields found
LET fu = 0 // address of first unprotected field
LET a = next.attribute(0)
UNTIL a=-1 DO // until no more fields
$( LET b = a=1919 -> -1, next.attribute(a+1)
LET c = b=-1 -> 1920, b
currat := dbb%a
TEST bit(currat, 2) DO fpf := TRUE OR // unless protected
$( dbb%a := dbb%a & #XFE // reset MDT bit
a := a+1
fuf := TRUE
IF fu=0 DO fu := a
UNTIL a=c DO
$( dispch(a, null)
a := a+1
$)
$)
a := b
$)
UNLESS fpf | fuf DO clear.display()
set.cursor(fu)
$)
ENDCASE
CASE 'H': // cursor home
outesc('H')
ca := 0
rca := 0
find.user(ca)
ENDCASE
CASE 'K':
$( // erase to end of field
LET a = next.attribute(ca) // rh limit
LET ns = ?
LET i = ca
LET es = ebcdic('*S')
IF curruatp<0 | ca=curruatp ENDCASE
IF a=ca | bit(curruat, 2) ENDCASE
IF a<0 DO a := 1920
a := a-1
ns := highlight.check()
$( outch('*S')
dba%i := es
i := i+1
$) REPEATUNTIL i>a
UNLESS ns=0 DO outesc(ns)
dbb%curruatp := curruat | 1 // set modified bit
UNLESS ca=1919 DO
$( rca := i
set.cursor(ca)
$)
$)
$)
ENDCASE
$)
CASE '*S': CASE '*"': CASE '#': CASE '$': CASE '%': CASE '&':
CASE '*'': CASE '(': CASE ')': CASE '**': CASE '+': CASE ',':
CASE '-': CASE '.': CASE '/': CASE '4':
CASE '5': CASE '6': CASE '7': CASE ';':
CASE '<': CASE '=': CASE '>': CASE '?': CASE 'E': CASE 'F':
CASE 'G': CASE 'I': CASE 'J': CASE 'L': CASE 'M':
CASE 'N': CASE 'O': CASE 'P': CASE 'Q': CASE 'R': CASE 'S':
CASE 'T': CASE 'U': CASE 'V': CASE 'W': CASE 'X': CASE 'Y':
CASE 'Z':
CASE '[': CASE '\': CASE ']': CASE '↑':
CASE 'a': CASE 'b': CASE 'c': CASE 'd': CASE 'e': CASE 'f':
CASE 'g': CASE 'h': CASE 'i': CASE 'j': CASE 'k': CASE 'l':
CASE 'm': CASE 'n': CASE 'o': CASE 'p': CASE 'q': CASE 'r':
CASE 's': CASE 't': CASE 'u': CASE 'v': CASE 'w': CASE 'x':
CASE 'y': CASE 'z':
CASE '{': CASE '|': CASE '}': CASE '~':
TEST insert.mode.on DO
$( LET a = next.attribute(ca) // rh limit
LET i = ca
LET ns = ?
IF curruatp<0 | ca=curruatp ENDCASE
IF a=ca | bit(curruat,2) ENDCASE
IF a<0 DO a := 1920
a := a-1
ns := highlight.check()
$( LET tc = ascii(dba%i) // will go over end of dba!
TEST safe.for.terminal(ch) DO outch(ch) OR outch('*S')
dba%i := ebcdic(ch)
i := i+1
ch := tc
$) REPEATUNTIL i>a
UNLESS ns=0 DO outesc(ns)
dbb%curruatp := curruat | 1 // set modified bit
UNLESS ca=1919 DO
$( rca := a+1
set.cursor(ca+1)
$)
$)
OR safeprint(ch)
ENDCASE
CASE tab: // tab key
$( LET a1 = ca
UNTIL a1=-1 DO
$( a1 := next.attribute(a1)
UNLESS a1=-1 DO $( a1 := a1+1
IF ~bit(dbb%(a1-1),2) DO BREAK
$)
$)
IF a1=-1 DO
$( a1 := 0
UNTIL a1=-1 | a1>ca DO
$( a1 := next.attribute(a1)
UNLESS a1=-1 DO $( a1 := a1+1
IF ~bit(dbb%(a1-1),2) DO BREAK
$)
$)
IF a1=-1 DO a1 := 0
$)
IF a1>1919 DO a1 := 0
set.cursor(a1)
ENDCASE
$)
CASE lf: // newline
$( LET line = ca/80
UNLESS line>=23 DO
$( LET lina = (line+1)*80 // first address on new line
LET a = find.attribute(lina)
UNTIL a=-1 | lina=1919 | (lina/80)~=(line+1) DO
$( UNLESS bit(dbb%a, 2) DO
$( set.cursor(a=lina -> lina+1, lina)
ENDCASE
$)
a := next.attribute(a+1)
lina := a
$)
$)
ENDCASE
$)
CASE del:
$( LET a = next.attribute(ca) // rh limit
LET i, ch = ca, ?
LET ns = ?
IF curruatp<0 | ca=curruatp ENDCASE
IF a=ca | bit(curruat, 2) ENDCASE
UNLESS a/80=ca/80 DO a := -1
a := a=-1 -> (ca/80)*80 + 79, a-1
ns := highlight.check()
$( ch := i=a -> 0, dba%(i+1)
ch := ascii(ch)
TEST safe.for.terminal(ch) DO outch(ch) OR outch('*S')
dba%i := ebcdic(ch)
i := i+1
$) REPEATUNTIL i>a
UNLESS ns=0 DO outesc(ns)
dbb%curruatp := curruat | 1 // set modified bit
rca := a=1919 -> 1919, a+1
set.cursor(ca)
$)
ENDCASE
CASE ctrl.Q:
abort(#X1010, ca) // escape to DEBUG
ENDCASE // continue
CASE ctrl.W:
user.terminate()
exstring := "user terminated"
ENDCASE
CASE cr: aid := #X7D; GOTO rma
CASE ctrl.A: aid := #XF1; GOTO rma
CASE ctrl.S: aid := #XF2; GOTO rma
CASE ctrl.D: aid := #XF3; GOTO rma
CASE ctrl.F: aid := #XF4; GOTO rma
CASE ctrl.G: aid := #XF5; GOTO rma
CASE ctrl.H: aid := #XF6; GOTO rma
CASE ctrl.Z: aid := #XF7; GOTO rma
CASE ctrl.X: aid := #XF8; GOTO rma
CASE ctrl.C: aid := #XF9; GOTO rma
CASE ctrl.V: aid := #X7A; GOTO rma
CASE ctrl.B: aid := #X7B; GOTO rma
CASE ctrl.N: aid := #X7C
rma: read.modified()
$)
$)
AND highlight.check() = VALOF
$( LET newhi = bit(curruat,4) & ~bit(curruat,5)
IF newhi & ~highlighting DO
$( outesc('Y');outesc('+'); RESULTIS 'X' $)
IF highlighting & ~ newhi DO
$( outesc('X'); outesc('+');RESULTIS 'Y' $)
RESULTIS 0
$)
AND safeprint(ch) BE
$(
TEST bit(curruat, 2) | dbb%ca~=0 DO sound.alarm() // prot. or attr.
OR
$( LET ns = highlight.check()
TEST safe.for.terminal(ch) & ~[bit(curruat,4) & bit(curruat,5)] DO
outch(ch)
OR
outch('*S')
dba%ca := ebcdic(ch)
UNLESS ca=1919 DO
$( ca := ca+1
rca := ca
$)
UNLESS curruatp=-1 DO dbb%curruatp := curruat | 1 // set modified bit
UNLESS ns=0 DO outesc(ns)
$)
$)
AND safe.for.terminal(ch) = #X20 <= ch <= #X7E