unit uRecord;

interface

uses
{$IFDEF LINUX}
  Types,
{$ENDIF}
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
  Rubies;

var
  cRecord: Tvalue;

function ap_cRecord: Tvalue;
procedure Init_Record;

implementation

uses SysUtils, uDefUtils, uIntern, uAlloc, uPhi, uConv{, st};

procedure ap_dispose(p: Pointer); cdecl;
begin
  try
    FreeMem(p);
  except
    on E: Exception do;
  end;
end;

function RecordClass_new(argc: Integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  args: array of Tvalue;
  size: Cardinal;
  p: Pointer;
  init: Tvalue;
  assoc_len: Integer;
  assoc_ptr: Pvalue;
  i: Integer;
  offset: Cardinal;
  val: Tvalue;
  pbeg: Cardinal;
//  pend: Cardinal;
  tmp_exist: Boolean;
  tmp_offset: Cardinal;
  tmp_val: Tvalue;

  function end_of_assoc: Boolean;
  begin
    if tmp_exist then
      result := False
    else
      result := assoc_len <= 0;
  end;

  procedure inc_assoc_ptr;
  var
    len: Integer;
    ptr: Pvalue;
    assoc: Tvalue;
  begin
    if tmp_exist then
    begin
      offset := tmp_offset;
      val := tmp_val;
      tmp_exist := False;
      Exit;
    end;
    
    assoc := assoc_ptr^;
    Check_Type(assoc, T_ARRAY);
    len := ap_ary_len(assoc);
    if len < 2 then ap_raise(ap_eIndexError, 'need assoc');
    
    ptr := ap_ary_ptr(assoc);
    offset := dl_Integer(ptr^);
    Inc(ptr);
    val := ptr^;
    
    Inc(assoc_ptr);
    Dec(assoc_len);
  end;

  procedure dec_assoc_ptr;
  begin
    tmp_offset := offset;
    tmp_val := val;
    tmp_exist := True;
  end;

  procedure assign(v: Tvalue);
  var
    vtype: Tvalue;
    datasize: Cardinal;
    data_end: Cardinal;
  begin
    vtype := RTYPE(v);
    case vtype of
    T_DATA:
      begin
        datasize := dl_Integer(rb_const_get(CLASS_OF(v), rb_intern('SIZE')));
        data_end := offset + datasize;
        while not end_of_assoc do
        begin
          if offset = data_end then begin dec_assoc_ptr; Break end;
          inc_assoc_ptr;
        end;
        Move(ap_data_get_struct(v)^, p^, datasize);
      end;
    T_FIXNUM:
      begin
        Integer(p^) := dl_Integer(v);
      end;
    T_TRUE, T_FALSE:
      begin
        Boolean(p^) := dl_Boolean(v);
      end;
    else
      ap_raise(ap_eArgError, sWrong_arg_type);
    end;
  end;
  
begin
  tmp_exist := False;
  
  SetLength(args, argc);
  args := argv;
  size := dl_Integer(rb_const_get(This, rb_intern('SIZE')));
  GetMem(p, size);
  pbeg := Cardinal(p);
//  pend := pbeg + size;
  
  result := rb_data_object_alloc(This, p, nil, @ap_dispose);
  init := rb_const_get(This, rb_intern('INIT'));
  assoc_len := ap_ary_len(init);
  assoc_ptr := ap_ary_ptr(init);
  
  i := 0;
  while not end_of_assoc do
  begin
    inc_assoc_ptr;
    p := Pointer(pbeg + offset);
    if argc > i then assign(args[i]) else assign(val);
    Inc(i);
  end;
  
  ap_obj_call_init(result, argc, argv);
end;

function Record_inspect(This: Tvalue): Tvalue; cdecl;
var
  S: string;

begin
  S := '#<'+ dl_class_name_of(This);
  S := S +'>';
  result := ap_String(S);
end;

function ap_cRecord: Tvalue;
begin
  result := cRecord;
end;

function Record_offset(This, symbol: Tvalue): Cardinal;
var
  member: Tvalue;
begin
  member := rb_const_get(This, rb_intern('MEMBER'));
  Check_Type(member, T_HASH);
  result := dl_Integer(rb_hash_aref(member, symbol));
end;

function Record_data(This: Tvalue): Pointer;
var
  id: Tid;
begin
  id := rb_frame_last_func;
  result := Pointer(Cardinal(ap_data_get_struct(This)) + Record_offset(CLASS_OF(This), ID2SYM(id)));
end;

function Record_set_boolean(This, v: Tvalue): Tvalue; cdecl;
begin
  Boolean(Record_data(This)^) := dl_Boolean(v);
  result := v;
end;

function Record_get_boolean(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_bool(Boolean(Record_data(This)^));
end;

function Record_set_integer(This, v: Tvalue): Tvalue; cdecl;
begin
  Integer(Record_data(This)^) := dl_Integer(v);
  result := v;
end;

function Record_get_integer(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Integer(Integer(Record_data(This)^));
end;

function Record_new(argc: Integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  args: array of Tvalue;
  len: Integer;
  ptr: Pvalue;
  member, init: Tvalue;
  offset: Cardinal;
  symbol, offset_v, v, vtype, assoc: Tvalue;
  i: Integer;
  name: PChar;

begin
  SetLength(args, argc);
  args := argv;
  
  result := rb_class_new(cRecord);
  member := rb_hash_new;
  init := rb_ary_new;
  offset := 0;
  
  for i := 0 to argc-1 do
  begin
    assoc := args[i];
    Check_Type(assoc, T_ARRAY);
    len := ap_ary_len(assoc);
    if len < 2 then ap_raise(ap_eArgError, sOut_of_range);
    
    ptr := ap_ary_ptr(assoc);
    symbol := ptr^;
    offset_v := ap_Integer(offset);
    rb_hash_aset(member, symbol, offset_v);
    name := rb_id2name(SYM2ID(symbol));
    Inc(ptr);
    v := ptr^;
    rb_ary_push(init, rb_assoc_new(offset_v, v));
    vtype := RTYPE(v);
    case vtype of
    T_FIXNUM:
      begin
        Inc(offset, SizeOf(Integer));
        DefineAttrSet(result, name, Record_set_integer);
        DefineAttrGet(result, name, Record_get_integer);
      end;
    T_TRUE, T_FALSE:
      begin
        Inc(offset, SizeOf(Boolean));
        DefineAttrSet(result, name, Record_set_integer);
        DefineAttrGet(result, name, Record_get_integer);
      end;
    else
      ap_raise(ap_eArgError, sWrong_arg_type);
    end;
  end;
  rb_const_set(result, rb_intern('SIZE'), ap_Integer(offset));
  rb_const_set(result, rb_intern('MEMBER'), member);
  rb_const_set(result, rb_intern('INIT'), init);
  DefineSingletonMethod(result, 'new', RecordClass_new);
  
  ap_obj_call_init(result, argc, argv);
end;

procedure Init_Record;
begin
  cRecord := rb_define_class_under(mPhi, 'Record', ap_cObject);
  DefineSingletonMethod(cRecord, 'new', Record_new);
//  rb_define_method(cRecord, 'inspect', @Record_inspect, 0);
end;

end.
