/* Two buffers are used.
dba contains the ebcdic value of each display location - attribute
character positions are nulls.
dbb contains attribute characters at the start of field positions -
elsewhere it contains zeroes.
An ordered list la of fields exists -
each element in the list has the structure
[link] [address] .
*/
SECTION "SIM3270-1"
GET "LIBHDR"
GET "SIM3270"
LET host.update(buffer, buflen, command) BE
/* This routine interprets a write, erase/write or
erase all unprotected command from the host.
buffer is the byte address of the 3270 data stream
buflen is the length of buffer in bytes
command is the CCW opcode
*/
$( LET bufp = buffer
LET buflim = bufp+buflen
// for investigative purposes
UNLESS command=com.write | command=com.erase.write |
command=com.erase.unprotected DO abort(#X707, buffer)
IF command=com.write | command=com.erase.write DO
$( UNLESS buflen>0 RETURN
IF command=com.erase.write DO
$( clear.display()
cba := 0
currat := 0
IF highlighting DO highlights.off()
set.cursor(0)
$)
wcc := 0%buffer
IF bit(wcc, 7) DO reset.mdt.bits()
bufp := bufp+1
last.was.order := TRUE // wcc counts as an order
more.to.display := TRUE
UNTIL (buflim-bufp)<=0 DO
$( LET ch = 0%bufp
UNLESS ch=order.PT DO last.PT.nulling := FALSE
SWITCHON ch INTO
$( CASE order.SF: // Start Field
$( LET attch = 0%(bufp+1)
dispch(cba, null)
dbb%cba := attch
set.currat(attch)
enter.field.list(cba, attch)
cba := cba+1
bufp := bufp+2
last.was.order := TRUE
ENDCASE
$)
CASE order.SBA: // Set Buffer Address
$( LET a1=(0%(bufp+1)) & #X3F
LET a2=(0%(bufp+2)) & #X3F
a2 := (a1 << 6) | a2
IF a2>1919 RETURN // !!!
cba := a2
bufp := bufp+3
last.was.order := TRUE
currat := find.attribute(cba)
set.currat(currat=-1 -> 0, dbb%currat)
ENDCASE
$)
CASE order.PT: // Program Tab
$( LET nulling = FALSE
TEST (dbb%cba~=0)&~bit(dbb%cba,2) DO
cba := cba=1919 -> 0, cba+1
OR
$( LET a = find.attribute(cba)
IF a=-1 DO a := find.attribute(1919)
TEST a=-1 DO cba := 0 // no field found
OR
$( LET b = cba=1919 -> -1, next.attribute(cba+1)
nulling := (cba=0 & last.PT.nulling) |
(~last.was.order)
a := b; b := b=-1 -> 1919, b-1
IF nulling DO FOR i = cba TO b DO dispch(i, null)
UNTIL a=-1 | ~bit(dbb%a, 2) DO
a := a=1919 -> -1, next.attribute(a+1)
TEST a=-1 DO
$( cba := 0
a := find.attribute(0)
IF a=-1 DO a := find.attribute(1919)
set.currat(a=-1 -> 0, dbb%a)
$)
OR
$( cba := a=1919 -> 0, a+1
set.currat(dbb%a)
$)
$)
$)
last.PT.nulling := nulling
last.was.order := FALSE
bufp := bufp+1
ENDCASE
$)
CASE order.RA: // Repeat to Address
$( LET a1 = (0%(bufp+1)) & #X3F
LET a2 = (0%(bufp+2)) & #X3F
LET cch = 0%(bufp+3)
a2 := (a1 << 6) | a2
IF a2>1919 RETURN
$( IF (cba REM 80)=0 & a2-cba>=80 & (cch=null | cch=#X40) DO
$( // use CLEAR TO END OF LINE
clear.line(cba) // clears line beginning at cba
FOR i = cba TO cba+79 DO
$( TEST dbb%i=0 DO dba%i := null
OR
$( remove.field.list(i)
dbb%i := 0
currat := find.attribute(i)
set.currat(currat<0 -> 0, dbb%currat)
$)
$)
cba := cba+80
LOOP
$)
dispch(cba, cch)
UNLESS dbb%cba=0 DO
$( remove.field.list(cba)
dbb%cba := 0
currat := find.attribute(cba)
set.currat(currat=-1 -> 0, dbb%currat)
$)
cba := cba=1919 -> 0, cba+1
$) REPEATUNTIL cba=a2
bufp := bufp+4
last.was.order := TRUE
ENDCASE
$)
CASE order.EUA: // Erase Unprotected to Address
$( LET a1 = (0%(bufp+1)) & #X3F
LET a2 = (0%(bufp+2)) & #X3F
LET nulling = FALSE
a2 := (a1 << 6) | a2
IF a2>1919 RETURN
UNLESS bit(currat, 2) DO nulling := TRUE // protected?
$( LET cch = dbb%cba
TEST cch~=0 DO
$( set.currat(cch)
nulling := bit(currat, 2)
$)
OR IF nulling DO dispch(cba, null)
cba := cba=1919 -> 0, cba+1
$) REPEATUNTIL cba=a2
bufp := bufp+3
last.was.order := TRUE
ENDCASE
$)
CASE order.IC: // Insert Cursor
ca := cba
set.cursor(ca)
bufp := bufp+1
last.was.order := TRUE
ENDCASE
DEFAULT:
dispch(cba, ch)
UNLESS dbb%cba=0 DO
$( remove.field.list(cba)
dbb%cba := 0
currat := find.attribute(cba)
set.currat(currat=-1 -> 0, dbb%currat)
$)
cba := cba=1919 -> 0, cba+1
bufp := bufp+1
last.was.order := FALSE
$)
$)
more.to.display := FALSE
set.cursor(ca)
$)
IF command=com.erase.unprotected DO
$( LET fuf = FALSE // unprotected fields found
LET fu = 0 // address of first unprotected field
LET fpf = FALSE // protected fileds found
LET a = next.attribute(0)
more.to.display := TRUE
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
UNLESS bit(currat, 2) DO // unless protected
$( dbb%a := dbb%a & #XFE // reset MDT bit
fuf := TRUE
IF fu=0 DO fu := a
a := a+1
UNTIL a=c DO
$( dispch(a, null)
a := a+1
$)
$)
a := b
$)
more.to.display := FALSE
keyboard.restore()
aid := #X60
cba := fuf -> fu,0
set.currat(fuf -> dbb%fu,0)
set.cursor(fuf -> fu, 0) // set cursor address
$)
IF bit(wcc, 5) DO sound.alarm()
IF bit(wcc, 6) DO keyboard.restore()
$)
AND find.attribute(ba) = VALOF
$( /* This function returns the buffer address of the attribute character
for the field containing address ba.
If a field is not found it returns -1.
*/
LET lla = la
LET tb = ?
IF lla=-1 RESULTIS -1 // no fields
// look before
IF lla!1<=ba DO
$(
$( tb := lla!1
lla := !lla
IF lla=-1 RESULTIS tb
IF lla!1>ba RESULTIS tb
$) REPEAT
$)
// look at last field
UNTIL !lla=-1 DO lla := !lla
RESULTIS lla!1
$)
AND next.attribute(ba) = VALOF
$( /* This function returns the buffer address of the
attribute character of the field on or after ba.
It does not wrap. If no field
is found it returns -1.
*/
LET lla = la
UNTIL lla=-1 DO
$( IF lla!1>=ba RESULTIS lla!1
lla := !lla
$)
RESULTIS -1
$)
AND set.currat(att) BE // may change highlight status
$( LET newhi = bit(att, 4) & ~bit(att, 5)
currat := att
TEST newhi & ~highlighting DO
$( outesc('Y'); outesc('+'); highlighting := TRUE $)
OR IF highlighting & ~newhi DO
$( outesc('X'); outesc('+'); highlighting := FALSE $)
$)
.
SECTION "SIM3270-2"
GET "LIBHDR"
GET "SIM3270"
LET bit(a, b) = [(a & (#X80 >> b)) ~= 0]
AND reset.mdt.bits() BE
$( LET a = next.attribute(0)
UNTIL a=-1 DO
$( dbb%a := dbb%a & #XFE
a := a=1919 -> -1, next.attribute(a+1)
$)
$)
AND errstring(s, a, b, c, d) BE
$( LET p = output()
selectoutput(errstream)
writef(s, a, b, c, d)
selectoutput(p)
$)
AND enter.field.list(ba, ch) BE
$( LET lla = @la
dbb%ba := ch
UNTIL !lla=-1 DO
$( IF (!lla)!1>=ba BREAK
lla := !lla
$)
UNLESS !lla=-1 DO IF (!lla)!1=ba RETURN
$( LET e = get.ele()
!e := !lla
!lla := e
e!1 := ba
$)
$)
AND remove.field.list(ba) BE
$( LET lla = @la
dbb%ba := 0
UNTIL !lla=-1 DO
$( IF (!lla)!1>ba BREAK
IF (!lla)!1=ba DO
$( LET e = !lla
!lla := !e
free.ele(e)
RETURN
$)
lla := !lla
$)
$)
AND get.ele() = VALOF
$( UNTIL !listp=0 DO listp := listp-maxlistp>=0 -> minlistp, listp+2
!listp := -1
RESULTIS listp
$)
AND free.ele(e) BE !e := 0
AND find.user(a) = VALOF
$( LET c = find.attribute(a)
curruatp := c
curruat := c=-1 -> 0, dbb%c
$)
AND read.modified() BE
$( LET n = read.modified.data()
send(n)
$)
AND read.modified.data() = VALOF
$( /* AID contains code for program attention key.
(ENTER, CLEAR, PA1, PA2, PA3, PF1 -> PF12 or no attention.)
PA keys and CLEAR result in a short read, AID only.
Other keys cause AID, cursor address then an SBA order,
attribute address +1 and text for each modified field
(nulls are suppressed). If no fields exist then the
entire buffer is sent (still suppressing nulls).
Value returned is the length of the buffer filled in bytes.
*/
LET ta = ?
LET tc = 3 // current position in buffer
LET buffer = read.buffer
keyboard.lock()
IF aid=pa.PA1 | aid=pa.PA2 | aid=pa.PA3 | aid=pa.CLEAR DO // short read
$( buffer%0 := aid
RESULTIS 1
$)
/* Perform a read modified operation on the display buffer.
First 3 bytes are AID and cursor address.
*/
buffer%0 := aid
ta := ibmadd(ca) // gets IBM form of address
buffer%1 := ta>>8
buffer%2 := ta
// examine attribute bytes for MDT bit set
$( LET na = next.attribute(0)
LET naa = na // save initial na
UNTIL na=-1 DO // until no more fields
$( LET nb = na=1919 -> -1, next.attribute(na+1)
LET ab = dbb%na
LET nc = nb=-1 -> 1920, nb
UNLESS bit(ab, 7) DO // unless modified
$( na := nb
LOOP
$)
ta := ibmadd(na+1)
buffer%tc := order.SBA
buffer%(tc+1) := ta>>8
buffer%(tc+2) := ta
tc := tc+3
na := na+1
// put bytes in buffer suppressing nulls
UNTIL na=nc DO
$(
ta := dba%na
UNLESS ta=0 DO // suppress nulls
$( buffer%tc := ta
tc := tc+1
$)
na := na+1
$)
cba := 0 // if not wrapped set display buffer address to 0
set.currat(dbb%0)
IF nb=-1 DO // wrapped?
IF dbb%0=0 DO // yes!
$( LET tcc = 0
cba := naa
set.currat(dbb%naa)
$( ta := dba%tcc
tcc := tcc+1
UNLESS ta=0 DO
$( buffer%tc := ta
tc := tc+1
$)
$) REPEATUNTIL tcc=naa
$)
na := nb
$)
IF tc=3 TEST naa=-1 DO // aha, no fields!
$( FOR i = 0 TO 1919 DO
$( LET cc = dba%i
UNLESS cc=0 DO
$( buffer%tc := cc
tc := tc+1
$)
$)
cba := 0; set.currat(0)
$)
OR
$( cba := 0
TEST dbb%0=0 DO set.currat(dbb%find.attribute(1919))
OR set.currat(dbb%0)
$)
RESULTIS tc
$)
$)
AND ibmadd(a) =
/* put 2 bytes in ls positions of result word (res).
The 12 bit address is split between the l.s. 6 bits
of each byte. The top 2 bits of each byte are set so
that the contents of the byte are a valid EBCDIC graphic (!).
*/
(ibmch(a>>6) << 8) | (ibmch(a?))
AND ibmch(bits) = bits!TABLE
#X40,#XC1,#XC2,#XC3,#XC4,#XC5,#XC6,#XC7,
#XC8,#XC9,#X4A,#X4B,#X4C,#X4D,#X4E,#X4F,
#X50,#XD1,#XD2,#XD3,#XD4,#XD5,#XD6,#XD7,
#XD8,#XD9,#X5A,#X5B,#X5C,#X5D,#X5E,#X5F,
#X60,#X61,#XE2,#XE3,#XE4,#XE5,#XE6,#XE7,
#XE8,#XE9,#X6A,#X6B,#X6C,#X6D,#X6E,#X6F,
#XF0,#XF1,#XF2,#XF3,#XF4,#XF5,#XF6,#XF7,
#XF8,#XF9,#X7A,#X7B,#X7C,#X7D,#X7E,#X7F
AND ascii(ch) = ch!TABLE
/*<8086 /* EBCDIC 00-07 */ #000, #001, #002, #003, 0, #011, 0, #177,
/*<8086 /* EBCDIC 08-0F */ 0, 0, 0, #013, #014, #015, #016, #017,
/*<8086 /* EBCDIC 10-17 */ #020, #021, #022, #023, 0, 0, #010, 0,
/*<8086 /* EBCDIC 18-1F */ #030, #031, 0, 0, #034, #035, #036, #037,
/*<8086 /* EBCDIC 20-27 */ 0, 0, 0, 0, 0, #012, #027, #033,
/*<8086 /* EBCDIC 28-2F */ 0, 0, 0, 0, 0, #005, #006, #007,
/*<8086 /* EBCDIC 30-37 */ 0, 0, #026, 0, 0, 0, 0, #004,
/*<8086 /* EBCDIC 38-3F */ 0, 0, 0, 0, #024, #025, 0, #032,
/*<8086 /* EBCDIC 40-47 */ #040, 0, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC 48-4F */ 0, 0, 0, #056, #074, #050, #053, #174,
/*<8086 /* EBCDIC 50-57 */ #046, 0, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC 58-5F */ 0, 0, #041, #044, #052, #051, #073, #176,
/*<8086 /* EBCDIC 60-67 */ #055, #057, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC 68-6F */ 0, 0, 0, #054, #045, #137, #076, #077,
/*<8086 /* EBCDIC 70-77 */ 0, #136, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC 78-7F */ 0, #140, #072, #043, #100, #047, #075, #042,
/*<8086 /* EBCDIC 80-87 */ 0, #141, #142, #143, #144, #145, #146, #147,
/*<8086 /* EBCDIC 88-8F */ #150, #151, 0, #173, 0, 0, 0, 0,
/*<8086 /* EBCDIC 90-97 */ 0, #152, #153, #154, #155, #156, #157, #160,
/*<8086 /* EBCDIC 98-9F */ #161, #162, 0, #175, 0, 0, 0, 0,
/*<8086 /* EBCDIC A0-A7 */ 0, 0, #163, #164, #165, #166, #167, #170,
/*<8086 /* EBCDIC A8-AF */ #171, #172, 0, 0, 0, #133, 0, 0,
/*<8086 /* EBCDIC B0-B7 */ 0, 0, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC B8-BF */ 0, 0, 0, 0, 0, #135, 0, 0,
/*<8086 /* EBCDIC C0-C7 */ 0, #101, #102, #103, #104, #105, #106, #107,
/*<8086 /* EBCDIC C8-CF */ #110, #111, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC D0-D7 */ 0, #112, #113, #114, #115, #116, #117, #120,
/*<8086 /* EBCDIC D8-DF */ #121, #122, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC E0-E7 */ #134, 0, #123, #124, #125, #126, #127, #130,
/*<8086 /* EBCDIC E8-EF */ #131, #132, 0, 0, 0, 0, 0, 0,
/*<8086 /* EBCDIC F0-F7 */ #060, #061, #062, #063, #064, #065, #066, #067,
/*<8086 /* EBCDIC F8-FF */ #070, #071, 0, 0, 0, 0, 0, #134
AND ebcdic(ch) = ch!TABLE
#X00,#X01,#X02,#X03,#X37,#X2D,#X2E,#X2F,
#X16,#X05,#X25,#X0B,#X0C,#X0D,#X0E,#X0F,
#X10,#X11,#X12,#X13,#X3C,#X3D,#X32,#X26,
#X18,#X19,#X3F,#X27,#X1C,#X1D,#X1E,#X1F,
#X40,#X5A,#X7F,#X7B,#X5B,#X6C,#X50,#X7D,
#X4D,#X5D,#X5C,#X4E,#X6B,#X60,#X4B,#X61,
#XF0,#XF1,#XF2,#XF3,#XF4,#XF5,#XF6,#XF7,
#XF8,#XF9,#X7A,#X5E,#X4C,#X7E,#X6E,#X6F,
#X7C,#XC1,#XC2,#XC3,#XC4,#XC5,#XC6,#XC7,
#XC8,#XC9,#XD1,#XD2,#XD3,#XD4,#XD5,#XD6,
#XD7,#XD8,#XD9,#XE2,#XE3,#XE4,#XE5,#XE6,
#XE7,#XE8,#XE9,#XAD,#XE0,#XBD,#X71,#X6D,
#X79,#X81,#X82,#X83,#X84,#X85,#X86,#X87,
#X88,#X89,#X91,#X92,#X93,#X94,#X95,#X96,
#X97,#X98,#X99,#XA2,#XA3,#XA4,#XA5,#XA6,
#XA7,#XA8,#XA9,#X8B,#X4F,#X9B,#X5F,#X07,
#X00,#X01,#X02,#X03,#X37,#X2D,#X2E,#X2F,
#X16,#X05,#X25,#X0B,#X0C,#X0D,#X0E,#X0F,
#X10,#X11,#X12,#X13,#X3C,#X3D,#X32,#X26,
#X18,#X19,#X3F,#X27,#X1C,#X1D,#X1E,#X1F,
#X40,#X5A,#X7F,#X7B,#X5B,#X6C,#X50,#X7D,
#X4D,#X5D,#X5C,#X4E,#X6B,#X60,#X4B,#X61,
#XF0,#XF1,#XF2,#XF3,#XF4,#XF5,#XF6,#XF7,
#XF8,#XF9,#X7A,#X5E,#X4C,#X7E,#X6E,#X6F,
#X7C,#XC1,#XC2,#XC3,#XC4,#XC5,#XC6,#XC7,
#XC8,#XC9,#XD1,#XD2,#XD3,#XD4,#XD5,#XD6,
#XD7,#XD8,#XD9,#XE2,#XE3,#XE4,#XE5,#XE6,
#XE7,#XE8,#XE9,#XAD,#XE0,#XBD,#X71,#X6D,
#X79,#X81,#X82,#X83,#X84,#X85,#X86,#X87,
#X88,#X89,#X91,#X92,#X93,#X94,#X95,#X96,
#X97,#X98,#X99,#XA2,#XA3,#XA4,#XA5,#XA6,
#XA7,#XA8,#XA9,#X8B,#X4F,#X9B,#X5F,#X07
AND read.buff() BE
$( LET n = read.buffer.data()
send(n)
$)
AND read.buffer.data() = VALOF
$( // READ BUFFER reads the whole buffer, fields are introduced by
// SF and the attribute character.
LET buf = read.buffer
LET ta, tc = ?, 3
buf%0 := aid
ta := ibmadd(ca)
buf%1 := ta>>8
buf%2 := ta
FOR i=0 TO 1919 DO
TEST dbb%i~=0 DO
$( buf%tc := order.SF
buf%(tc+1) := dbb%i
tc := tc+2
$)
OR
$( buf%tc := dba%i
tc := tc+1
$)
RESULTIS tc
$)