# vcg_field --- procedures for bit-field manipulation



# ld_field --- fetch contents of field, place in proper accumulator

   ipointer function ld_field (fld, regs)
   tpointer fld
   regset regs

   include VCG_COMMON

   integer length, offset, bad (ADDR_DESC_SIZE), res, amask

   long_int lmask

   ipointer c
   ipointer reach, seq, gen_mr, rshift_l_by, lshift_l_by, rshift_a_by,
      and_a_with, and_l_with

   length = Tmem (fld + 3)
   offset = Tmem (fld + 2)    # offset is no. of bits from MSB of word

   c = reach (Tmem (fld + 4), regs, res, bad)
   if (res ~= IN_MEMORY) {
      call warning ("ld_field: bit field base must be in memory*n"p)
      return (0)
      }

   if (offset + length > 16) {      # field crosses a word boundary
      c = seq (c, gen_mr (LDL_INS, bad))

      if (length > 16) {            # field value must go in L register
         call l_field_mask (length, 32 - length, lmask)
         c = seq (c,
            rshift_l_by (32 - (offset + length)))
         if (offset ~= 0)
            c = seq (c,
               and_l_with (lmask))
         }

      else {                        # field value must go in A register
         call a_field_mask (length, 16 - length, amask)
         c = seq (c,
            lshift_l_by (offset - (16 - length)))
         if (offset ~= 0)
            c = seq (c,
               and_a_with (amask))
         }

      regs |= L_REG
      }

   else {                           # field is entirely in one word
      call a_field_mask (length, 16 - length, amask)
      c = seq (c,
         gen_mr (LDA_INS, bad),
         rshift_a_by (16 - (offset + length)))
      if (offset ~= 0)
         c = seq (c,
            and_a_with (amask))
      regs |= A_REG
      }

   return (c)
   end



# st_field --- store contents of proper accumulator in bit field

   ipointer function st_field (fld, regs)
   tpointer fld
   regset regs

   include VCG_COMMON

   ipointer c
   ipointer gen_mr, seq, reach, rshift_l_by, lshift_l_by,
      lshift_a_by, and_a_with, and_l_with

   integer length, offset
   integer tad (ADDR_DESC_SIZE), bad (ADDR_DESC_SIZE), res, amask

   long_int lmask

   string mesg "st_field: field base addr not lvalue"

   length = Tmem (fld + 3)
   offset = Tmem (fld + 2)

   if (offset + length > 16) {      # field overlaps a word boundary

      if (length <= 16)             # move contents from A into L
         c = rshift_l_by (offset + length - 16)
      else                          # adjust contents in L
         c = lshift_l_by (32 - (offset + length))

      call l_field_mask (length, offset, lmask)
      if (offset ~= 0)
         c = seq (c,
            and_l_with (lmask))
      call alloc_temp (2, tad)
      c = seq (c,
         gen_mr (STL_INS, tad),
         reach (Tmem (fld + 4), regs, res, bad))

      if (res ~= IN_MEMORY) {
         call warning ("*s*n"p, mesg)
         return (0)
         }

      c = seq (c,
         gen_mr (LDL_INS, bad),
         and_l_with (not (lmask)),
         gen_mr (ERL_INS, tad),
         gen_mr (STL_INS, bad))
      call free_temp (tad)

      regs |= L_REG
      }

   else {            # field does not overlap boundary; length must be <= 16
      c = lshift_a_by (16 - (offset + length))
      call a_field_mask (length, offset, amask)
      call alloc_temp (1, tad)

      if (offset ~= 0)
         c = seq (c,
            and_a_with (amask))
      c = seq (c,
         gen_mr (STA_INS, tad),
         reach (Tmem (fld + 4), regs, res, bad))

      if (res ~= IN_MEMORY) {
         call warning ("*s*n"p, mesg)
         return (0)
         }

      c = seq (c,
         gen_mr (LDA_INS, bad),
         and_a_with (not (amask)),
         gen_mr (ERA_INS, tad),
         gen_mr (STA_INS, bad))
      call free_temp (tad)

      regs |= A_REG
      }

   return (c)
   end



# a_field_mask --- get mask for field with given offset and length <= 16

   subroutine a_field_mask (length, offset, amask)
   integer length, offset, amask

   integer masks (16)
   data masks / _
      :100000, :140000, :160000, :170000,
      :174000, :176000, :177000, :177400,
      :177600, :177700, :177740, :177760,
      :177770, :177774, :177776, :177777 /

   string mesg "a_field_mask: bad bit field "

   if (length < 1 || length > 16)
      call panic ("*slength *i*n"p, mesg, length)
   if (offset < 0 || offset > 15)
      call panic ("*soffset *i*n"p, mesg, offset)

   amask = rs (masks (length), offset)

   return
   end



# l_field_mask --- get mask for bit field with given offset and length > 16

   subroutine l_field_mask (length, offset, lmask)
   integer length, offset
   long_int lmask

   long_int masks (32)
   data masks / _
      :20000000000, :30000000000, :34000000000, :36000000000,
      :37000000000, :37400000000, :37600000000, :37700000000,
      :37740000000, :37760000000, :37770000000, :37774000000,
      :37776000000, :37777000000, :37777400000, :37777600000,
      :37777700000, :37777740000, :37777760000, :37777770000,
      :37777774000, :37777776000, :37777777000, :37777777400,
      :37777777600, :37777777700, :37777777740, :37777777760,
      :37777777770, :37777777774, :37777777776, :37777777777 /

   string mesg "l_field_mask: bad bit field "

   if (length < 1 || length > 32)
      call panic ("*slength *i*n"p, mesg, length)
   if (offset < 0 || offset > 31)
      call panic ("*soffset *i*n"p, mesg, offset)

   lmask = rs (masks (length), offset)

   return
   end



# and_a_with --- generate code to AND A_REG with mask, quickly

   ipointer function and_a_with (mask)
   integer mask

   ipointer gen_mr, gen_generic

   integer ad (ADDR_DESC_SIZE)

   select (mask)
      when (0)
         return (gen_generic (CRA_INS))
      when (:000377)
         return (gen_generic (CAL_INS))
      when (:177400)
         return (gen_generic (CAR_INS))
      when (:177777)
         return (0)
   else {
      AD_MODE (ad) = ILIT_AM
      AD_LIT1 (ad) = mask
      return (gen_mr (ANA_INS, ad))
      }

   end



# and_l_with --- generate code to and L_REG with a mask, quickly

   ipointer function and_l_with (mask)
   long_int mask

   ipointer gen_mr, gen_generic, seq

   integer ad (ADDR_DESC_SIZE)

   select
      when (mask == :00000177777)
         return (gen_generic (CRA_INS))
      when (mask == :37777600000)
         return (gen_generic (CRB_INS))
      when (mask == 0)
         return (gen_generic (CRL_INS))
      when (mask == :37777777777)
         return (0)
      when (mask == :00077777777)
         return (gen_generic (CAL_INS))
      when (mask == :37700177777)
         return (gen_generic (CAR_INS))
      when (rt (mask, 16) == :00000177777) {
         AD_MODE (ad) = ILIT_AM
         AD_LIT1 (ad) = rs (mask, 16)
         return (gen_mr (ANA_INS, ad))
         }
      when (rt (mask, 16) == 0) {
         AD_MODE (ad) = ILIT_AM
         AD_LIT1 (ad) = rs (mask, 16)
         return (seq (gen_generic (CRB_INS), gen_mr (ANA_INS, ad)))
         }

   AD_MODE (ad) = LLIT_AM
   AD_LIT1 (ad) = rs (mask, 16)
   AD_LIT2 (ad) = rt (mask, 16)
   return (gen_mr (ANL_INS, ad))

   end



# load_field_asg_op --- load assignment operator with field LHS

   ipointer function load_field_asg_op (expr, regs)
   tpointer expr
   regset regs

   include VCG_COMMON

   ipointer c
   ipointer reach, load, gen_mr, seq

   tpointer field, base, asg_node, op_node, rev_node, obj_node
   tpointer talloc

   regset fregs

   integer fres, bad (ADDR_DESC_SIZE), tad (ADDR_DESC_SIZE), obj_id,
      op
   integer mklabel

   string mesg "load_field_asg_op: "

   field = Tmem (expr + 2)
   c = reach (Tmem (field + 4), fregs, fres, bad)
   if (fres ~= IN_MEMORY) {
      call warning ("*sfield base addr must be lvalue*n"p, mesg)
      return (0)
      }

   obj_id = 0
   if (c ~= 0) {
      call alloc_temp (2, tad)
      obj_id = mklabel (1)
      call enter_obj (obj_id, tad)
      c = seq (c, gen_mr (EAL_INS, bad), gen_mr (STL_INS, tad))
      base = talloc (3)
      Tmem (base) = DEREF_OP
      Tmem (base + 1) = STOWED_MODE
      obj_node = talloc (3)
      Tmem (obj_node) = OBJECT_OP
      Tmem (obj_node + 1) = LONG_UNS_MODE
      Tmem (obj_node + 2) = obj_id
      Tmem (base + 2) = obj_node
      Tmem (field + 4) = base
      }

   asg_node = talloc (5)
   Tmem (asg_node) = ASSIGN_OP
   Tmem (asg_node + 1) = Tmem (expr + 1)  # same assignment mode
   Tmem (asg_node + 2) = field

   op_node = talloc (4)
   select (Tmem (expr))
      when (ADDAA_OP, POSTINC_OP, PREINC_OP)
         op = ADD_OP
      when (ANDAA_OP)
         op = AND_OP
      when (DIVAA_OP)
         op = DIV_OP
      when (LSHIFTAA_OP)
         op = LSHIFT_OP
      when (MULAA_OP)
         op = MUL_OP
      when (ORAA_OP)
         op = OR_OP
      when (REMAA_OP)
         op = REM_OP
      when (RSHIFTAA_OP)
         op = RSHIFT_OP
      when (SUBAA_OP, POSTDEC_OP, PREDEC_OP)
         op = SUB_OP
      when (XORAA_OP)
         op = XOR_OP
   else {
      call warning ("*sbad field assg op *i*n"p, mesg, Tmem (expr))
      return (0)
      }
   Tmem (op_node) = op
   Tmem (op_node + 1) = Tmem (expr + 1)
   Tmem (op_node + 2) = field
   Tmem (op_node + 3) = Tmem (expr + 3)
   Tmem (asg_node + 3) = op_node
   Tmem (asg_node + 4) = 0    # length ignored --- left operand is a field

   if (Tmem (expr) == POSTINC_OP || Tmem (expr) == POSTDEC_OP) {
      rev_node = talloc (4)
      if (Tmem (expr) == POSTINC_OP)
         Tmem (rev_node) = SUB_OP
      else
         Tmem (rev_node) = ADD_OP
      Tmem (rev_node + 1) = Tmem (expr + 1)
      Tmem (rev_node + 2) = asg_node
      Tmem (rev_node + 3) = Tmem (expr + 3)
      c = seq (c, load (rev_node, regs))
      }
   else
      c = seq (c, load (asg_node, regs))

   regs |= fregs

   if (obj_id ~= 0) {
      call free_temp (tad)
      call delete_obj (obj_id)
      }

   return (c)
   end



# void_field_asg_op --- void assignment operator with field LHS

   ipointer function void_field_asg_op (expr, regs)
   tpointer expr
   regset regs

   include VCG_COMMON

   ipointer c
   ipointer reach, load, gen_mr, seq, void

   tpointer field, base, asg_node, op_node, rev_node, obj_node
   tpointer talloc

   regset fregs

   integer fres, bad (ADDR_DESC_SIZE), tad (ADDR_DESC_SIZE), obj_id,
      op

   string mesg "void_field_asg_op: "

   field = Tmem (expr + 2)
   c = reach (Tmem (field + 4), fregs, fres, bad)
   if (fres ~= IN_MEMORY) {
      call warning ("*sfield base addr must be lvalue*n"p, mesg)
      return (0)
      }

   obj_id = 0
   if (c ~= 0) {
      call alloc_temp (2, tad)
      obj_id = mklabel (1)
      call enter_obj (obj_id, tad)
      c = seq (c, gen_mr (EAL_INS, bad), gen_mr (STL_INS, tad))
      base = talloc (3)
      Tmem (base) = DEREF_OP
      Tmem (base + 1) = STOWED_MODE
      obj_node = talloc (3)
      Tmem (obj_node) = OBJECT_OP
      Tmem (obj_node + 1) = LONG_UNS_MODE
      Tmem (obj_node + 2) = obj_id
      Tmem (base + 2) = obj_node
      Tmem (field + 4) = base
      }

   asg_node = talloc (5)
   Tmem (asg_node) = ASSIGN_OP
   Tmem (asg_node + 1) = Tmem (expr + 1)  # same assignment mode
   Tmem (asg_node + 2) = field

   op_node = talloc (4)
   select (Tmem (expr))
      when (ADDAA_OP, POSTINC_OP, PREINC_OP)
         op = ADD_OP
      when (ANDAA_OP)
         op = AND_OP
      when (DIVAA_OP)
         op = DIV_OP
      when (LSHIFTAA_OP)
         op = LSHIFT_OP
      when (MULAA_OP)
         op = MUL_OP
      when (ORAA_OP)
         op = OR_OP
      when (REMAA_OP)
         op = REM_OP
      when (RSHIFTAA_OP)
         op = RSHIFT_OP
      when (SUBAA_OP, POSTDEC_OP, PREDEC_OP)
         op = SUB_OP
      when (XORAA_OP)
         op = XOR_OP
   else {
      call warning ("*sbad field assg op *i*n"p, mesg, Tmem (expr))
      return (0)
      }
   Tmem (op_node) = op
   Tmem (op_node + 1) = Tmem (expr + 1)
   Tmem (op_node + 2) = field
   Tmem (op_node + 3) = Tmem (expr + 3)
   Tmem (asg_node + 3) = op_node
   Tmem (asg_node + 4) = 0    # value ignored --- left operand is a field

   c = seq (c, void (asg_node, regs))
   regs |= fregs

   if (obj_id ~= 0) {
      call free_temp (tad)
      call delete_obj (obj_id)
      }

   return (c)
   end



# fl_field --- evaluate bit field in flow context, elide shifts

   ipointer function fl_field (expr, regs, cond, label)
   tpointer expr
   regset regs
   logical cond
   unsigned label

   include VCG_COMMON

   integer length, offset, bad (ADDR_DESC_SIZE), res, amask

   long_int lmask

   ipointer c
   ipointer reach, seq, gen_mr, and_a_with, and_l_with, gen_branch

   length = Tmem (expr + 3)
   offset = Tmem (expr + 2)

   c = reach (Tmem (expr + 4), regs, res, bad)
   if (res ~= IN_MEMORY) {
      call warning ("fl_field: bit field base not addressable*n"p)
      return (0)
      }

   if (offset + length > 16) {      # crosses a word boundary...
      c = seq (c, gen_mr (LDL_INS, bad))
      call l_field_mask (length, offset, lmask)
      c = seq (c, and_l_with (lmask))
      if (cond)
         c = seq (c, gen_branch (BLNE_INS, label))
      else
         c = seq (c, gen_branch (BLEQ_INS, label))
      regs |= L_REG
      }

   else {                           # field is all in one word
      c = seq (c, gen_mr (LDA_INS, bad))
      call a_field_mask (length, offset, amask)
      c = seq (c, and_a_with (amask))
      if (cond)
         c = seq (c, gen_branch (BNE_INS, label))
      else
         c = seq (c, gen_branch (BEQ_INS, label))
      regs |= A_REG
      }

   return (c)
   end
