Delphi “array of const” to “varargs”

Question

Please help! I need this conversion to write wrapper for some C headers for Delphi.

As an example:

function pushfstring(fmt: PAnsiChar): PAnsiChar; cdecl; varargs; external;

...

function PushString(fmt: AnsiString; const args: array of const): AnsiString;
begin
  Result := AnsiString(pushfstring(PAnsiString(fmt), args)); // it's incorrect :/
end;

How can I convert "array of const" to "varargs"?

edit: function PushString is actually inside the record (I gave a simplified example), and I do not have direct access to pushfstring. Direct call is excluded.

edit 2:I write the units for LUA library for Delphi and the case is quite important for me.

Specifying and providing all the details of the matter - I have this function in C:

LUA_API const char *(lua_pushfstring) (lua_State *L, const char *fmt, ...);

In Delphi I have something like this:

LuaLibrary.pas

{...}
interface
{...}
function lua_pushfstring(L: lua_State; fmt: PAnsiChar): PAnsiChar; cdecl; varargs;
implementation
{...}
function lua_pushfstring; external 'lua.dll'; // or from OMF *.obj file by $L

dtxLua.pas

uses LuaLibrary;
{...}
type
  TLuaState = packed record
  private
    FLuaState: lua_State;
  public
    class operator Implicit(A: TLuaState): lua_State; inline;
    class operator Implicit(A: lua_State): TLuaState; inline;
    {...}
    // btw. PushFString can't be inline function
    function PushFString(fmt: PAnsiChar; const args: array of const ): PAnsiChar; 
    //... and a lot of 'wrapper functions' for functions like a lua_pushfstring, 
    // where L: lua_State; is the first parameter
  end;
implementation
{...}
function TLuaState.PushFString(fmt: PAnsiChar; const args: array of const )
  : PAnsiChar;
begin
  Result := lua_pushfstring(FLuaState, fmt, args); // it's incorrect :/
end;

and in other units like Lua.pas i use only TLuaState from dtxLua.pas (because LuaLibrary is bulky, dtxLua is my wrapper), for many useful and cool things...

Answer 1

I'm guessing that the prototype for pushfstring is somewhat like this:

void pushfstring(const char *fmt, va_list args);

If it isn't, and is instead:

void pushfstring(const char *fmt, ...);

... then I should have you covered also.

In C, if you have to pass on a call from one variadic function to another, you should use va_list, va_start and va_end, and call the v version of the function. So, if you were implementing printf yourself, you might use vsprintf to format the string - you can't call sprintf directly and pass along the variadic argument list. You need to use va_list and friends.

It's pretty awkward to handle C's va_list from Delphi, and technically it shouldn't be done - the implementation of va_list is specific to the C compiler vendor's runtime.

However, we can try. Suppose we have a little class - though I made it a record for ease of use:

type
  TVarArgCaller = record
  private
    FStack: array of Byte;
    FTop: PByte;
    procedure LazyInit;
    procedure PushData(Loc: Pointer; Size: Integer);
  public
    procedure PushArg(Value: Pointer); overload;
    procedure PushArg(Value: Integer); overload;
    procedure PushArg(Value: Double); overload;
    procedure PushArgList;
    function Invoke(CodeAddress: Pointer): Pointer;
  end;

procedure TVarArgCaller.LazyInit;
begin
  if FStack = nil then
  begin
    // Warning: assuming that the target of our call doesn't 
    // use more than 8K stack
    SetLength(FStack, 8192);
    FTop := @FStack[Length(FStack)];
  end;
end;

procedure TVarArgCaller.PushData(Loc: Pointer; Size: Integer);
  function AlignUp(Value: Integer): Integer;
  begin
    Result := (Value + 3) and not 3;
  end;
begin
  LazyInit;
  // actually you want more headroom than this
  Assert(FTop - Size >= PByte(@FStack[0]));
  Dec(FTop, AlignUp(Size));
  FillChar(FTop^, AlignUp(Size), 0);
  Move(Loc^, FTop^, Size);
end;

procedure TVarArgCaller.PushArg(Value: Pointer); 
begin
  PushData(@Value, SizeOf(Value));
end;

procedure TVarArgCaller.PushArg(Value: Integer); 
begin
  PushData(@Value, SizeOf(Value));
end;

procedure TVarArgCaller.PushArg(Value: Double); 
begin
  PushData(@Value, SizeOf(Value));
end;

procedure TVarArgCaller.PushArgList;
var
  currTop: PByte;
begin
  currTop := FTop;
  PushArg(currTop);
end;

function TVarArgCaller.Invoke(CodeAddress: Pointer): Pointer;
asm
  PUSH EBP
  MOV EBP,ESP

  // Going to do something unpleasant now - swap stack out
  MOV ESP, EAX.TVarArgCaller.FTop
  CALL CodeAddress
  // return value is in EAX
  MOV ESP,EBP

  POP EBP
end;

Using this record, we can manually construct the call frame expected for various C calls. C's calling convention on x86 is to pass arguments from right to left on the stack, with the caller cleaning up. Here's the skeleton of a generic C calling routine:

function CallManually(Code: Pointer; const Args: array of const): Pointer;
var
  i: Integer;
  caller: TVarArgCaller;
begin
  for i := High(Args) downto Low(Args) do
  begin
    case Args[i].VType of
      vtInteger: caller.PushArg(Args[i].VInteger);
      vtPChar: caller.PushArg(Args[i].VPChar);
      vtExtended: caller.PushArg(Args[i].VExtended^);
      vtAnsiString: caller.PushArg(PAnsiChar(Args[i].VAnsiString));
      vtWideString: caller.PushArg(PWideChar(Args[i].VWideString));
      vtUnicodeString: caller.PushArg(PWideChar(Args[i].VUnicodeString));
      // fill as needed
    else
      raise Exception.Create('Unknown type');
    end;
  end;
  Result := caller.Invoke(Code);
end;

Taking printf as an example:

function printf(fmt: PAnsiChar): Integer; cdecl; varargs; 
    external 'msvcrt.dll' name 'printf';

const
  // necessary as 4.123 is Extended, and %g expects Double
  C: Double = 4.123;
begin
  // the old-fashioned way
  printf('test of printf %s %d %.4g'#10, PAnsiChar('hello'), 42, C);
  // the hard way
  CallManually(@printf, [AnsiString('test of printf %s %d %.4g'#10), 
                         PAnsiChar('hello'), 42, C]);
end.

Calling the va_list version is slightly more involved, as the va_list argument's location needs to be placed carefully where it is expected:

function CallManually2(Code: Pointer; Fmt: AnsiString;
    const Args: array of const): Pointer;
var
  i: Integer;
  caller: TVarArgCaller;
begin
  for i := High(Args) downto Low(Args) do
  begin
    case Args[i].VType of
      vtInteger: caller.PushArg(Args[i].VInteger);
      vtPChar: caller.PushArg(Args[i].VPChar);
      vtExtended: caller.PushArg(Args[i].VExtended^);
      vtAnsiString: caller.PushArg(PAnsiChar(Args[i].VAnsiString));
      vtWideString: caller.PushArg(PWideChar(Args[i].VWideString));
      vtUnicodeString: caller.PushArg(PWideChar(Args[i].VUnicodeString));
    else
      raise Exception.Create('Unknown type'); // etc.
    end;
  end;
  caller.PushArgList;
  caller.PushArg(PAnsiChar(Fmt));
  Result := caller.Invoke(Code);
end;

function vprintf(fmt: PAnsiChar; va_list: Pointer): Integer; cdecl;
    external 'msvcrt.dll' name 'vprintf';

begin
  // the hard way, va_list
  CallManually2(@vprintf, 'test of printf %s %d %.4g'#10, 
      [PAnsiChar('hello'), 42, C]);
end.

Notes:

• The above expects x86 on Windows. Microsoft C, bcc32 (Embarcadero C++) and gcc all pass va_list in the same way (a pointer to the first variadic argument on the stack), according to my experiments, so it should work for you; but as soon as the x86 on Windows assumption is broken, expect this to possibly break too.

• The stack is swapped to ease with its construction. This can be avoided with more work, but passing va_list also becomes trickier, as it needs to point at the arguments as if they were passed on the stack. As a consequence, the code needs to make an assumption about how much stack the called routine uses; this example assumes 8K, but this may be too small. Increase if necessary.

Answer 2

The wrapper you are trying to write is possible in Free Pascal, since Free Pascal supports 2 equvalent declarations for varargs external functions:

http://www.freepascal.org/docs-html/ref/refsu68.html

so instead of

function pushfstring(fmt: PAnsiChar): PAnsiChar; cdecl; varargs; external;

you should write

function pushfstring(fmt: PAnsiChar; Args: Array of const): PAnsiChar; cdecl; external;

Update: I have tried the same trick in Delphi, but it does not work:

//function sprintf(S, fmt: PAnsiChar; const args: array of const): Integer;
//           cdecl; external 'MSVCRT.DLL';

function sprintf(S, fmt: PAnsiChar): Integer;
           cdecl; varargs; external 'MSVCRT.DLL';

procedure TForm1.Button1Click(Sender: TObject);
var
  S, fmt: Ansistring;

begin
  SetLength(S, 99);
  fmt:= '%d - %d';
//  sprintf(PAnsiChar(S), PAnsiChar(fmt), [1, 2]);
  sprintf(PAnsiChar(S), PAnsiChar(fmt), 1, 2);
  ShowMessage(S);
end;

Answer 3

An "array of const" is actually an array of TVarRec, which is a special variant type. It's not compatible with varargs, and you really should be able to call the varargs function directly without a wrapper around it.

Answer 4

Barry Kelly inspired me to seeking a solution without replacing the stack... Here is the solution (probably could also use the Invoke from the rtti unit, instead RealCall_CDecl).

// This function is copied from PascalScript
function RealCall_CDecl(p: Pointer;
  StackData: Pointer;
  StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
  ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; 
  // make sure all things are on stack
var
  r: Longint;
begin
  asm
    mov ecx, stackdatalen
    jecxz @@2
    mov eax, stackdata
    @@1:
    mov edx, [eax]
    push edx
    sub eax, 4
    dec ecx
    or ecx, ecx
    jnz @@1
    @@2:
    call p
    mov ecx, resultlength
    cmp ecx, 0
    je @@5
    cmp ecx, 1
    je @@3
    cmp ecx, 2
    je @@4
    mov r, eax
    jmp @@5
    @@3:
    xor ecx, ecx
    mov cl, al
    mov r, ecx
    jmp @@5
    @@4:
    xor ecx, ecx
    mov cx, ax
    mov r, ecx
    @@5:
    mov ecx, stackdatalen
    jecxz @@7
    @@6:
    pop eax
    dec ecx
    or ecx, ecx
    jnz @@6
    mov ecx, resedx
    jecxz @@7
    mov [ecx], edx
    @@7:
  end;
  Result := r;
end;

// personally created function :)
function CallManually3(Code: Pointer; const Args: array of const): Pointer;
var
  i: Integer;
  tmp: AnsiString;
  data: AnsiString;
begin
  for i := Low(Args) to High(Args) do
  begin
    case Args[i].VType of
      vtInteger, vtPChar, vtAnsiString, vtWideString, vtUnicodeString: begin
          tmp := #0#0#0#0;
          Pointer((@tmp[1])^) := TVarRec(Args[i]).VPointer;
      end;
      vtExtended: begin
          tmp := #0#0#0#0#0#0#0#0;
          Double((@tmp[1])^) := TVarRec(Args[i]).VExtended^;
      end;
      // fill as needed
    else
      raise Exception.Create('Unknown type');
    end;

    data := data + tmp;
  end;

  Result := pointer(RealCall_CDecl(Code, @data[Length(data) - 3], 
    Length(data) div 4, 4, nil));
end;

function printf(fmt: PAnsiChar): Integer; cdecl; varargs;
    external 'msvcrt.dll' name 'printf';

begin
  CallManually3(@printf, 
    [AnsiString('test of printf %s %d %.4g'#10), 
      PAnsiChar('hello'), 42, 4.123]);
end.