Array of const broken?

[Alekcvp]

array of const parameters not working or not supported?

The code below outputs

seems to be broken ()!

as a result.

program PSTestCase;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils, uPSCompiler, uPSRuntime, uPSUtils;

procedure Print(const Text: string);
begin
  WriteLn(Text);
end;

function PSOnUses(Sender: TPSPascalCompiler; const Name: tbtString): Boolean;
begin
  Sender.AddDelphiFunction('function Format(const Format: string; const Args: array of const): string;');
  Sender.AddDelphiFunction('procedure Print(const Text: string);');
  Result := True;
end;

var
  C: TPSPascalCompiler;
  E: TPSExec;
  Data: AnsiString;
begin
  C := TPSPascalCompiler.Create;
  E := TPSExec.Create;
  try
    C.OnUses := PSOnUses;
    C.Compile('begin Print(Format(''%s seems to be broken (%d)!'', [''Const arrays'', 323])); end.');
    C.GetOutput(Data);
    E.RegisterDelphiFunction(@Format, 'Format', cdRegister);
    E.RegisterDelphiFunction(@Print, 'Print', cdRegister);
    E.LoadData(Data);
    E.RunScript;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  E.Free;
  C.Free;
  ReadLn;
end.

[shanthipriyapakkela]

Facing the same issue with array of const. Tried in many ways but nothing worked out. Awaiting for reply.

[evgeny-k]

looks like delphi RTTI can't work with array of const parameters

check:

program Project13;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils, System.Rtti, system.TypInfo;

begin
  var res := Invoke(@Format,
                ['this is string - %s, %d',
                 TValue.FromArray(TypeInfo(TArray<TVarRec>),
                                  ArrayOfConstToTValueArray(['string',123]))],
                ccReg,
                TypeInfo(string),
                true);
  writeln(res.AsString);
end.

[Alekcvp]

It looks like you're right. The Format() function expects an "open array" type parameter as input, but receives a "dynamic array", which leads to a failure.

After tweaking your code a little with hacks, I got it to work, but I have no idea how to apply it to solve my original problem ...

PS: Note the third parameter in the Format() function parameter array. PPS: I copied the functions for working with constant arrays from here: http://rvelthuis.de/articles/articles-openarr.html

program constarrtest;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  System.Rtti,
  system.TypInfo,
  VarRecUtils in 'VarRecUtils.pas';

var
  constarr: TConstArray;
  arr: TValue;

begin
  constarr := CreateConstArray(['string', 123]);
  try
    TValue.Make(@constarr, TypeInfo(TArray<TVarRec>), arr);
    var res := Invoke(@Format,
                  [TValue('this is string - %s, %d'), arr, high(constarr)],
                  ccReg,
                  TypeInfo(string),
                  true);
    writeln(res.AsString);
  finally
    FinalizeVarRecArray(constarr);
  end;
  readln;
end.

[Alekcvp]

Although, upon further research, it seems that the error is somewhere in the compiler when compiling the function call. Because when calling the Format() function, it gets an array where the first element contains the correct data, but the wrong VType. And the second element contains invalid data.

[Alekcvp]

I made a draft fix, it works in my example, but needs some polishing and more testing.

InvokeCall.inc

function _CreateOpenArray(Val: PPSVariantIFC): TArray<TVarRec>;
var
  psrc: Pointer;
  pvr: PVarRec;
  ctype: TPSTypeRec;
  cp: Pointer;
  ic, i: Integer;
begin
  if (Val.aType.BaseType <> btArray) and (val.aType.BaseType <> btStaticArray) then
    Exit;
  if val.aType.BaseType = btStaticArray then
  begin
    SetLength(Result, TPSTypeRec_StaticArray(val.aType).Size);
    psrc := Val.Dta;
  end else
  begin
    SetLength(Result, PSDynArrayGetLength(Pointer(Val.Dta^), val.aType));
    psrc := Pointer(Val.Dta^);
  end;
  pvr := PVarRec(Result);
  for i := 0 to High(Result) do
  begin
    ctype := Pointer(Pointer(IPointer(psrc) + PointerSize)^);
    cp := Pointer(psrc^);
    if cp = nil then
    begin
      pvr.VType := vtPointer;
      pvr.VPointer := nil;
    end else begin
       case ctype.BaseType of
        btVariant: begin
          pvr.VType := vtVariant;
          pvr.VVariant := cp;
        end;
        btchar: begin
            pvr.VType := vtChar;
            pvr.VChar := tbtChar(tbtchar(cp^));
          end;
        btSingle:
          begin
            pvr.VType := vtExtended;
            New(pvr.VExtended);
            pvr.VExtended^ := tbtsingle(cp^);
          end;
        btExtended:
          begin
            pvr.VType := vtExtended;
            New(pvr.VExtended);
            pvr.VExtended^ := tbtextended(cp^);;
          end;
        btDouble:
          begin
            pvr.VType := vtExtended;
            New(pvr.VExtended);
            pvr.VExtended^ := tbtdouble(cp^);
          end;
        {$IFNDEF PS_NOWIDESTRING}
        btwidechar: begin
            pvr.VType := vtWideChar;
            pvr.VWideChar := tbtwidechar(cp^);
          end;
        {$IFDEF DELPHI2009UP}
        btUnicodeString: begin
          pvr.VType := vtUnicodeString;
          tbtunicodestring(pvr.VUnicodeString) := tbtunicodestring(cp^);
        end;
        {$ELSE}
        btUnicodeString,
        {$ENDIF}
        btwideString: begin
          pvr.VType := vtWideString;
          tbtwidestring(pvr.VWideString) := tbtwidestring(cp^);
        end;
        {$ENDIF}
        btU8: begin
            pvr.VType := vtInteger;
            pvr.VInteger := tbtu8(cp^);
          end;
        btS8: begin
            pvr.VType := vtInteger;
            pvr.VInteger := tbts8(cp^);
          end;
        btU16: begin
            pvr.VType := vtInteger;
            pvr.VInteger := tbtu16(cp^);
          end;
        btS16: begin
            pvr.VType := vtInteger;
            pvr.VInteger := tbts16(cp^);
          end;
        btU32: begin
            pvr.VType := vtInteger;
            pvr.VInteger := tbtu32(cp^);
          end;
        btS32: begin
            pvr.VType := vtInteger;
            pvr.VInteger := tbts32(cp^);
          end;
        {$IFNDEF PS_NOINT64}
        btS64: begin
            pvr.VType := vtInt64;
            New(pvr.VInt64);
            pvr.VInt64^ := tbts64(cp^);
          end;
        {$ENDIF}
        btString: begin
          pvr.VType := vtAnsiString;
          tbtString(pvr.VAnsiString) := tbtstring(cp^);
        end;
        btPChar:
        begin
          pvr.VType := vtPchar;
          pvr.VPChar := pointer(cp^);
        end;
        btClass:
        begin
          pvr.VType := vtObject;
          pvr.VObject := Pointer(cp^);
        end;
{$IFNDEF PS_NOINTERFACES}
{$IFDEF Delphi3UP}
        btInterface:
        begin
          pvr.VType := vtInterface;
          IUnknown(pvr.VInterface) := IUnknown(cp^);
        end;
{$ENDIF}
{$ENDIF}
      end;
    end;
    psrc := Pointer(IPointer(psrc) + (3 * SizeOf(Pointer)));
    Inc(pvr);
  end;
end;

procedure _FinalizeOpenArray(pvr: PVarRec; Count: Integer);
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
  begin
    case pvr^.VType of
      System.vtExtended:
        Dispose(pvr.vextended);
      {$IFNDEF PS_NOINT64}
      vtInt64:
        Dispose(pvr.VInt64);
      {$ENDIF}
      {$IFNDEF PS_NOWIDESTRING}
        {$IFDEF DELPHI2009UP}
      vtUnicodeString:
        Finalize(tbtunicodestring(pvr.VUnicodeString));
        {$ENDIF}
      vtWideString:
        Finalize(widestring(pvr.VWideString));
      vtAnsiString:
        Finalize(AnsiString(pvr.VAnsiString));
      {$ENDIF}
      {$IFNDEF PS_NOINTERFACES}
      {$IFDEF Delphi3UP}
      vtInterface:
        Finalize(tbtString(pvr.VAnsiString));
      {$ENDIF}
      {$ENDIF}
    end;
    Inc(pvr);
  end;
end;

function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var SysCalConv : TCallConv;
    Args: TArray<TValue>;
    Arrs: TArray<TArray<TVarRec>>;
    Arg : TValue;
    i : Integer;
    fvar: PPSVariantIFC;
    IsConstr : Boolean;
    ctx: TRTTIContext;
    RttiType : TRttiType;
    ResValue : TValue;
begin
  Result := False;
  case CallingConv of
    cdRegister : SysCalConv := ccReg;
    cdPascal : SysCalConv := ccPascal;
    cdCdecl : SysCalConv := ccCdecl;
    cdStdCall : SysCalConv := ccStdCall;
    cdSafeCall : SysCalConv := ccSafeCall;
  else
    SysCalConv := ccReg;//to prevent warning "W1036 Variable might not have been initialized"
  end;
  if Assigned(_Self) then
    Args := Args + [TValue.From<Pointer>( _Self )];
  for I := 0 to Params.Count - 1 do
  begin
    if Params[i] = nil
      then Exit;
    fvar := Params[i];
    if fvar.varparam then
    begin { var param }
      case fvar.aType.BaseType of
        btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
        btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency,
        btUnicodeString
        {$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
          Arg := TValue.From<Pointer>( Pointer(fvar.dta) );
        else
          begin
            Exit;
          end;
      end;
    end
    else
    begin  { not a var param }
      case fvar.aType.BaseType of
        { add normal params here }
        {$IFNDEF PS_NOWIDESTRING}
        btWidestring,
        btUnicodestring,
        {$ENDIF}
        btString:                          Arg := TValue.From<String>(pstring(fvar.dta)^);
        btU8, btS8:                        Arg := TValue.From<Byte>(pbyte(fvar.dta)^);
        btU16, BtS16:                      Arg := TValue.From<Word>(pword(fvar.dta)^);
        btU32, btS32:                      Arg := TValue.From<Cardinal>(pCardinal(fvar.dta)^);
        {$IFNDEF PS_NOINT64}bts64:{$ENDIF} Arg := TValue.From<Int64>(pint64(fvar.dta)^);
        btSingle:                          Arg := TValue.From<Single>(PSingle(fvar.dta)^);
        btDouble:                          Arg := TValue.From<Double>(PDouble(fvar.dta)^);
        btExtended:                        Arg := TValue.From<Extended>(PExtended(fvar.dta)^);
        btPChar:                           Arg := TValue.From<PChar>(ppchar(fvar.dta)^);
        btChar:                            Arg := TValue.From<Char>(pchar(fvar.dta)^);
        btClass:                           Arg := TValue.From<TObject>(TObject(fvar.dta^));
        btRecord:                          Arg := TValue.From<Pointer>(fvar.dta);
        btStaticArray:                     Arg := TValue.From<Pointer>(fvar.dta);
        btVariant:
          Arg := TValue.From(Variant(fvar.dta^));
        btArray:
          begin
             if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
             begin  //openarray
               //in case of openarray we should provide TWO params: first is pointer to array,
//               Args := Args + [TValue.From<Pointer>(Pointer(fvar.Dta^))];
               Arrs := Arrs + [_CreateOpenArray(fvar)];
               Args := Args + [TValue.From<PVarRec>(Pointer(Arrs[High(Arrs)]))];
               //2nd - integer with arraylength - 1 (high)
               Arg := TValue.From<Integer>(PSDynArrayGetLength(Pointer(fvar.Dta^), fvar.aType)-1);// = High of OpenArray
             end
             else //dynarray = just push pointer
               Arg := TValue.From<Pointer>(fvar.dta);
          end;
        btSet:
          begin
            case TPSTypeRec_Set(fvar.aType).aByteSize  of
              1: Arg := TValue.From<Byte>(pbyte(fvar.dta)^);
              2: Arg := TValue.From<Word>(pWord(fvar.dta)^);
              3,
              4: Arg := TValue.From<Cardinal>(pCardinal(fvar.dta)^);
              else
                Arg := TValue.From<Pointer>(fvar.dta);
            end;
          end;
        else
//            writeln(stderr, 'Parameter type not implemented!');
          Exit;
      end;  { case }
    end;
    Args := Args + [Arg];
  end;
  IsConstr := (Integer(CallingConv) and 64) <> 0;
  try
    if not assigned(res) then
    begin
      Invoke(Address,Args,SysCalConv,nil,False,IsConstr);  { ignore return }
    end
    else begin
      case res.atype.basetype of
        { add result types here }
        btString:                tbtstring(res.dta^) := tbtstring(Invoke(Address, Args, SysCalConv, TypeInfo(String),
                                   {$IFDEF WIN64} _Self = nil {$ELSE} False {$ENDIF},IsConstr).AsString);
        {$IFNDEF PS_NOWIDESTRING}
        btUnicodeString:         tbtunicodestring(res.dta^) := Invoke(Address, Args, SysCalConv, TypeInfo(String),
                                   {$IFDEF WIN64} _Self = nil {$ELSE} False {$ENDIF}, IsConstr).AsString;
        btWideString:            tbtWideString(res.dta^) := Invoke(Address, Args, SysCalConv, TypeInfo(String),
                                   {$IFDEF WIN64} _Self = nil {$ELSE} False {$ENDIF}, IsConstr).AsString;
        {$ENDIF}
        btU8, btS8:              pbyte(res.dta)^ := Byte(Invoke(Address,Args,SysCalConv,TypeInfo(Byte),False,IsConstr).AsInteger);
        btU16, btS16:            pword(res.dta)^ := word(Invoke(Address,Args,SysCalConv,TypeInfo(Word),False,IsConstr).AsInteger);
        btU32, btS32:            pCardinal(res.dta)^ := Cardinal(Invoke(Address,Args,SysCalConv,TypeInfo(Cardinal),False,IsConstr).AsInteger);
        {$IFNDEF PS_NOINT64}bts64:{$ENDIF}   pInt64(res.dta)^ := Int64(Invoke(Address,Args,SysCalConv,TypeInfo(Int64),False,IsConstr).AsInt64);
        btSingle:                psingle(res.dta)^ := Double(Invoke(Address,Args,SysCalConv,TypeInfo(Single),False,IsConstr).AsExtended);
        btDouble:                pdouble(res.dta)^ := Double(Invoke(Address,Args,SysCalConv,TypeInfo(Double),False,IsConstr).AsExtended);
        btExtended:              pextended(res.dta)^ := Extended(Invoke(Address,Args,SysCalConv,TypeInfo(Extended),False,IsConstr).AsExtended);
        {$IFDEF FPC}
        btPChar:                 ppchar(res.dta)^ := pchar(Invoke(Address,Args,SysCalConv,TypeInfo(PChar),False,IsConstr).AsOrdinal);
        btChar:                  pchar(res.dta)^ := Char(Invoke(Address,Args,SysCalConv,TypeInfo(Char),False,IsConstr).AsChar);
        {$ELSE}
        btPChar:                 ppchar(res.dta)^ := pchar(Invoke(Address,Args,SysCalConv,TypeInfo(PChar),False,IsConstr).AsType<PChar>());
        btChar:                  pchar(res.dta)^ := Char(Invoke(Address,Args,SysCalConv,TypeInfo(Char),False,IsConstr).AsType<Char>());
        {$ENDIF}
        btSet:
          begin
            case TPSTypeRec_Set(res.aType).aByteSize  of
              1: byte(res.Dta^) := Byte(Invoke(Address,Args,SysCalConv,TypeInfo(Byte),False,IsConstr).AsInteger);
              2: word(res.Dta^) := word(Invoke(Address,Args,SysCalConv,TypeInfo(Word),False,IsConstr).AsInteger);
              3,
              4: Longint(res.Dta^) := Cardinal(Invoke(Address,Args,SysCalConv,TypeInfo(Cardinal),False,IsConstr).AsInteger);
              {$IFNDEF FPC}
              else
              begin
                for RttiType in ctx.GetTypes do
                  if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkSet)
                    and (RttiType.TypeSize = TPSTypeRec_Set(res.aType).aByteSize) then
                  begin
                    Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr).ExtractRawData(res.dta);
                    Break;
                  end;
              end;
              {$ENDIF}
            end;
          end;
        btClass:
        begin
          {$IFNDEF FPC}for RttiType in ctx.GetTypes do
            if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkClass) then{$ENDIF}
            begin
              TObject(res.dta^) := Invoke(Address,Args,SysCalConv,{$IFDEF FPC}TypeInfo(TObject){$ELSE}RttiType.Handle{$ENDIF},False,IsConstr).AsObject;
              {$IFNDEF FPC}Break;{$ENDIF}
            end;
        end;
        {$IFNDEF FPC}
        btStaticArray:
        begin
          for RttiType in ctx.GetTypes do
            if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkArray) then
            begin
              CopyArrayContents(res.dta, Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr).GetReferenceToRawData, TPSTypeRec_StaticArray(res.aType).Size, TPSTypeRec_StaticArray(res.aType).ArrayType);
              Break;
            end;
        end;
        btRecord:
        begin
          for RttiType in ctx.GetTypes do
            if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkRecord) then
            begin
              CopyArrayContents(res.dta, (Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr).GetReferenceToRawData), 1, res.aType);
              Break;
            end;
        end;
        btArray: //need to check with open arrays
        begin
          for RttiType in ctx.GetTypes do
            if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkDynArray) then
            begin
              ResValue := Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr);
              if ResValue.GetArrayLength > 0 then
                CopyArrayContents(res.dta, ResValue.GetReferenceToRawData, 1, res.aType)
              else
                res.dta := nil;
              Break;
            end;
        end;
        btVariant:
          begin
            PVariant(res.dta)^ := Invoke(Address, Args, SysCalConv, TypeInfo(Variant), False, IsConstr).AsVariant;
          end;
        {$ENDIF}
        else
  //          writeln(stderr, 'Result type not implemented!');
          Exit;
      end;  { case }
    end; //assigned(res)
  finally
    for I := 0 to High(Arrs) do
      _FinalizeOpenArray(Pointer(Arrs[I]), Length(Arrs[I]));
  end;

  Result := True;
end;

[Alekcvp]

What I haven't done is split open arrays into arrays of constants and others.

[evgeny-k]

I'm doing something similar. btw, you can use PSGetArrayField method for getting an array item instead of psrc := Pointer(IPointer(psrc) + (3 * SizeOf(Pointer))); , like

           SetLength(openarray2, PSDynArrayGetLength(Pointer(aVar.Dta)^, aVar.aType));
           for j := 0 to Length(openarray2) - 1 do begin
             l_item := PSGetArrayField(PPSVariantIFC(aVar.Dta)^, j);

[Alekcvp]

I copied this part from the CreateOpenArray() procedure in the uPSRuntime.pas