{$mode objfpc}

{ $r+,q+,s+}
{$r-,q-,s-}

{$define some_inlines} { disable this to disallow INLNE }

{$macro on}

{$ifdef some_inlines}
  {$define make_inline := inline ;}
{$else}
  {$define make_inline := (**)}
{$endif}

program pckrecar ;

{ Source provided for Free Pascal Bug Report 4145 }
{ Submitted by "Adriaan van Os" on  2005-06-30 }
{ e-mail: fpc@microbizz.nl }

  type
    t_Enum = ( e0, e1, e2, e3 ) ;
    t_Subrange = 0..7 ;
    t_Pack = {strict} packed record
               r1 : t_Enum ;     {2-bits}
               r2 : t_Subrange ; {3-bits}
               r3 : Boolean ;    {1-bit}
               r4 : t_Enum ;     {2-bits}
               r5 : Byte ; { not full packable }
              end ;

{ With bit-level packing, SizeOf( T_Pack) = 1 (in MW/MPW/Think/GPC). }
{ { r5 was not included, now the size should be 2 } }

{ the t_Pack structure should be converted internally to: }
    o_Pack = object
              private
               o_pack_byte_1 : Byte ;
(*
               r1: T_Enum;     {2-bits}
               r2: T_Subrange; {3-bits}
               r3: Boolean;    {1-bit}
               r4: T_Enum;     {2-bits}
*)
              private
               function get_r1 : t_Enum ; make_inline
               procedure put_r1 ( v : t_Enum ) ; make_inline
              public
               property r1 : t_Enum Read get_r1 Write put_r1 ;

              private
               function get_r2 : t_Subrange ; make_inline
               procedure put_r2 ( v : t_Subrange ) ; make_inline
              public
               property r2 : t_Subrange Read get_r2 Write put_r2 ;

              private
               function get_r3 : Boolean ; make_inline
               procedure put_r3 ( v : Boolean ) ; make_inline
              public
               property r3 : Boolean Read get_r3 Write put_r3 ;

              private
               function get_r4 : t_Enum ; make_inline
               procedure put_r4 ( v : t_Enum ) ; make_inline
              public
               property r4 : t_Enum Read get_r4 Write put_r4 ;

               r5 : Byte ;
              end;

  function o_Pack.get_r1 : t_Enum ; make_inline

    begin
      result := t_Enum ( ( o_pack_byte_1 and {11000000} $c0 ) shr 6 ) ;
     end ;

  procedure o_Pack.put_r1 ( v : t_Enum ) ; make_inline

    begin
      o_pack_byte_1 := ( o_pack_byte_1 and not $c0 ) or ( Ord ( v ) shl 6 ) ;
     end ;

  function o_Pack.get_r2 : t_Subrange ; make_inline

    begin
      result := t_Subrange ( ( o_pack_byte_1 and {00111000} $38 ) shr 3 ) ;
     end ;

  procedure o_Pack.put_r2 ( v : t_Subrange ) ; make_inline

    begin
      o_pack_byte_1 := ( o_pack_byte_1 and not $38 ) or ( Ord ( v ) shl 3 ) ;
     end ;

  function o_Pack.get_r3 : Boolean ; make_inline

    begin
      result := Boolean ( ( o_pack_byte_1 and {00000100} $04 ) shr 2 ) ;
     end ;

  procedure o_Pack.put_r3 ( v : Boolean ) ; make_inline

    begin
      o_pack_byte_1 := ( o_pack_byte_1 and not $04 ) or ( Ord ( v ) shl 2 ) ;
     end ;

  function o_Pack.get_r4 : t_Enum ; make_inline

    begin
      result := t_Enum ( ( o_pack_byte_1 and {00000011} $03 ) shr 0 ) ;
     end ;

  procedure o_Pack.put_r4 ( v : t_Enum ) ; make_inline

    begin
      o_pack_byte_1 := ( o_pack_byte_1 and not $03 ) or ( Ord ( v ) shl 0 ) ;
     end ;

(****** example 2: packed array *)

  type
    t_Arr_Base = 0..7 ;
    t_Arr_Index = 0..4 ;
    t_Arr = {strict} packed array [ t_Arr_Index ] of t_Arr_Base ;

{ the t_Arr structure should be converted internally to:
    ( there is a little bit additional effort nessessary so that
      when using this "object" the field .el needs not to be written )
}
  type
    o_Arr = object
             private
              o_pack_byte_1 : array [ 0..3 ] of Byte ;

             private
              function get_el ( i : t_Arr_Index ) : t_Arr_Base ; make_inline
              procedure put_el ( i : t_Arr_Index ;
                                 v : t_Arr_Base ) ; make_inline
             public
              property el[i : t_Arr_Index] : t_Arr_Base Read get_el Write put_el ;
             end ;

  const  { in this example; must be deferred from element size }
    __elems_per_byte = 2 ;  { 8 DIV element_size }
    __bits_per_elems = 3 ;
    __mask = {11100000} ( 8 + 4 + 2 ) shl 4 ;

  function o_Arr.get_el ( i : t_Arr_Index ) : t_Arr_Base ; make_inline

    var
      by : 0..maxint ; { will be >= 0 }
      bi : 0..7 ;

    begin
      by := ( i - low ( t_Arr_Index ) ) div __elems_per_byte ;
      bi := ( i - low ( t_Arr_Index ) ) mod __elems_per_byte ;
      get_el := ( o_pack_byte_1[by] and ( __mask shr ( bi * __bits_per_elems ) ) )
                shr ( 8 - __bits_per_elems - ( bi * __bits_per_elems ) ) ;
     end ;

  procedure o_Arr.put_el ( i : t_Arr_Index ;
                           v : t_Arr_Base ) ; make_inline

    var
      by : 0..maxint ; { will be >= 0 }
      bi : 0..7 ;

    begin
      by := ( i - low ( t_Arr_Index ) ) div __elems_per_byte ;
      bi := ( i - low ( t_Arr_Index ) ) mod __elems_per_byte ;
{ ****
writeln ( i, ' ', v, ' ', by, ' ', bi, ' ',
          binstr ( not ( __mask shr ( bi * __bits_per_elems ) ), 8 ), ' ',
          binstr ( v shl ( 8 - __bits_per_elems - ( bi * __bits_per_elems ) ), 8 ) );
*** }
      o_pack_byte_1[by] := ( o_pack_byte_1[by] and ( not ( __mask shr ( bi * __bits_per_elems ) ) ) )
                           or ( v shl ( 8 - __bits_per_elems - ( bi * __bits_per_elems ) ) ) ;
     end ;

(****** example 3: array with inversed index *)

  type
    t_rArr_Base = Byte ;
    t_rArr_Index = 3..10 ;
(*    t_rArr = array [ 10..3 ] of t_arr_base ; *)

{ the t_rArr structure should be converted internally to:
    ( again: there is a little bit additional effort nessessary so that
      when using this "object" the field .el needs not to be written )
}
  type
    o_rArr = object
              private
               o_bytes_1 : array [ t_rArr_Index ] of t_rArr_Base ;

              private
               function get_el ( i : t_rArr_Index ) : t_rArr_Base ; make_inline
               procedure put_el ( i : t_rArr_Index ;
                                 v : t_rArr_Base ) ; make_inline
              public
               property el[i : t_rArr_Index] : t_rArr_Base Read get_el Write put_el ;
              end ;

  function o_rArr.get_el ( i : t_rArr_Index ) : t_rArr_Base ; make_inline

    begin
      get_el := o_bytes_1[high ( t_rArr_Index ) + low ( t_rArr_Index ) -i] ;
     end ;

  procedure o_rArr.put_el ( i : t_rArr_Index ;
                           v : t_rArr_Base ) ; make_inline

    begin
      o_bytes_1[high ( t_rArr_Index ) + low ( t_rArr_Index ) -i] := v ;
     end ;

  procedure test ( {to get a surprise declare this as var param} x : Byte ) ;

    begin
     end ;

  procedure dumpbin ( var b ;
                      const s : LongInt ;
                      EoLn : Boolean ) ;
    var
      SP : 0..1 ;
      i : Integer ;
      buff : array [ 1..100 ] of Byte absolute b ;

  begin
    SP := 0 ;
    for i := 1 to s do
      begin
        Write ( '' : SP, binstr ( buff[i], 8 ) ) ;
        SP := 1 ;
       end ;
    if EoLn
      then WriteLn ;
   end ;

  var
    o_r : o_Pack ;
    o_a : o_Arr ;
    o_i : o_rArr ;
    i : Integer ;

  begin
    WriteLn ( SizeOf ( t_Pack ) ) ;
    WriteLn ( SizeOf ( o_Pack ) ) ;
    WriteLn ( SizeOf ( t_Arr ) ) ;
    WriteLn ( SizeOf ( o_Arr ) ) ;

{ example 1: strict packed record }
    with o_r do
      begin
        r1 := e0 ;
        r2 := 0 ;
        r3 := False ;
        r4 := e0 ;
        r5 := 0 ;
        WriteLn ( Ord(r1), ' ', r2, ' ', r3, ' ', Ord(r4) ) ;
        dumpbin ( o_r, SizeOf ( o_r ), True ) ;
        r1 := e1 ;
        dumpbin ( o_r, SizeOf ( o_r ), True ) ;
        r2 := 3 ;
        dumpbin ( o_r, SizeOf ( o_r ), True ) ;
        r3 := True ;
        dumpbin ( o_r, SizeOf ( o_r ), True ) ;
        r4 := e2 ;
        dumpbin ( o_r, SizeOf ( o_r ), True ) ;
        r5 := 129 ;
        dumpbin ( o_r, SizeOf ( o_r ), True ) ;
        WriteLn ( Ord(r1), ' ', r2, ' ', r3, ' ', Ord(r4), ' ', r5 ) ;
       end ;
    test ( o_r.r2 ) ;
    test ( o_r.r5 ) ;

{ example 2: strict packed array }
    with o_a do
      begin
        for i := low ( t_Arr_Index ) to high ( t_Arr_Index ) do
          el[i] := 0 ;
        dumpbin ( o_a, SizeOf ( o_a ), True ) ;
        for i := low ( t_Arr_Index ) to high ( t_Arr_Index ) do
          begin
            el[i] := i ;
            dumpbin ( o_a, SizeOf ( o_a ), True ) ;
           end ;
       end ;
    for i := low ( t_Arr_Index ) to high ( t_Arr_Index ) do
      Write ( o_a.el[i] : 3 ) ;
    WriteLn ;
    test ( o_a.el[1] ) ;

{ example 3: array with reversed index }
    with o_i do
      begin
        for i := low ( t_rArr_Index ) to high ( t_rArr_Index ) do
          el[i] := 0 ;
        dumpbin ( o_i, SizeOf ( o_i ), True ) ;
        for i := low ( t_rArr_Index ) to high ( t_rArr_Index ) do
          begin
            el[i] := i ;
            dumpbin ( o_i, SizeOf ( o_i ), True ) ;
           end ;
       end ;
    for i := low ( t_rArr_Index ) to high ( t_rArr_Index ) do
      Write ( o_i.el[i] : 3 ) ;
    WriteLn ;
    test ( o_i.el[4] ) ;
   end.