/* 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&#X3F))

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
$)