Calling 4 - Native to Native

Content:

  1. Introduction
  2. Common
  3. Direct
  4. Load DLL/so
    1. Decoration / name mangling
  5. Windows COM
    1. Concept
    2. Server
    3. Client
  6. VMS Calling standard

Introduction:

Network communication is important today for integration.

But sometimes a simple call is what is needed.

That can create some challenges when the calling language is different than the called language.

This article will cover native (C, Pascal, Fortran etc.) to native (C etc.).

Other articles:

Common:

All the following examples will call this simple C Code.

demolib.h: 

#ifndef DEMOLIB_H
#define DEMOLIB_H

/* workaround conflict with *nix dup function */
#if defined(NIX) || defined(VMS)
#define dup mydup
#endif

struct Data1
{
    int iv;
    char sv[50];
};

struct Data2
{
    int iv1;
    char sv1[50];
    int iv2;
    char sv2[50];
};

/* int in arg + int retval */
int add(int a, int b);
/* int array in arg + int retval */
int sum(int n, int *a);
/* string in arg + string retval */
/* caller must call free on retval */
char *dup(char *s);
/* int out arg + string out arg */
/* caller must call free on second arg */
void get_out(int *iv, char **sv);
/* caller must call free on retval */
/* struct retval */
struct Data1 *get_ret();
/* inout struct arg */
void chg(struct Data2 *d);

#endif

demolib.c: 

#include <string.h>
#include <stdlib.h>

#include "demolib.h"

/* some very simple functions */

int add(int a, int b)
{
    return a + b;
}

int sum(int n, int *a)
{
    int i, sum;
    sum = 0;
    for(i = 0; i < n; i++)
    {
        sum += a[i];
    }
    return sum;
}

char *dup(char *s)
{
    char *s2;
    s2 = malloc(2 * strlen(s) + 1);
    strcpy(s2, s);
    strcat(s2, s);
    return s2;
}

/* functions simulating real work */

static int IV = 123;
static char *SV = "ABC";

void get_out(int *iv, char **sv)
{
    *iv = IV;
    *sv = malloc(strlen(SV) + 1);
    strcpy(*sv, SV);
}

struct Data1 *get_ret()
{
    struct Data1 *d;
    d = malloc(sizeof(struct Data1));
    d->iv = IV;
    strcpy(d->sv, SV);
    return d;
}

void chg(struct Data2 *d)
{
    d->iv2 = d->iv1 + 1;
    strcpy(d->sv2, d->sv1);
    strcat(d->sv2, "X");
}

The example does not cover all aspects of calling from managed to native, but it does cover some of the more common.

Direct:

C is a foundational language on most platform so often it is possible to call from one language to another simply by using C converntions.

Example with GCC compiler suite.

Obviously no problem calling C from C. 

#include <stdio.h>
#include <string.h>
#include <stdlib.h>

#include "demolib.h"

int main()
{
    int a, b, c, allsix, iv;
    char *s, *s2, *sv;
    int six[] = { 1, 2, 3, 4, 5, 6 };
    struct Data1 *d1;
    struct Data2 d2;
    /* */
    a = 123;
    b = 456;
    c = add(a, b);
    printf("%d\n", c);
    /* */
    allsix = sum(6, six);
    printf("%d\n", allsix);
    /* */
    s = "ABC";
    s2 = dup(s);
    printf("%s\n", s2);
    free(s2);
    /* */
    get_out(&iv, &sv);
    printf("%d %s\n", iv, sv);
    free(sv);
    /* */
    d1 = get_ret();
    printf("%d %s\n", d1->iv, d1->sv);
    /* */
    d2.iv1 = 123;
    strcpy(d2.sv1, "ABC");
    chg(&d2);
    printf("%d %s\n", d2.iv2, d2.sv2);
    /* */
    return 0;
}

Build: 

gcc -Wall testc.c demolib.c -o testc.exe

Output: 

579
21
ABCABC
123 ABC
123 ABC
124 ABCX

To get from Fortran convention to C convention a small wrapper is practical: 

#include <string.h>
#include <stdlib.h>

#include "demolib.h"

// scope: gfortran and gcc only
// strategy: using fortran 77 and VAX extensions only - no modern fortran C interop features used
// add trailing underscore to function names
// always pass by reference never by value
// convert array return types to extra array argument
// assume character string contain trailing nul
int add_(int *a, int *b)
{
    return add(*a, *b);
}

int sum_(int *n, int *a)
{
    return sum(*n, a);
}

void dup_(char *s, char *s2)
{
    char *p;
    p = dup(s);
    strcpy(s2, p);
    free(p);
}

void get_out_(int *iv, char *sv)
{
    char *p;
    get_out(iv, &p);
    strcpy(sv, p);
    free(p);
}

struct Data1 get_ret_()
{
    struct Data1 d;
    memcpy(&d, get_ret(), sizeof(struct Data1));
    return d;
}

void chg_(struct Data2 *d)
{
    chg(d);
}

And now it is simple: 

      program testfor
      structure /data1/
        integer*4 iv
        character*50 sv
      end structure
      structure /data2/
        integer*4 iv1
        character*50 sv1
        integer*4 iv2
        character*50 sv2
      end structure
      integer*4 a,b,c,six(6),allsix,iv
      character*50 s,s2,sv
      record /data1/d1
      record /data2/d2
      integer*4 add,sum
      record /data1/get_ret
      external add,sum,dup,get_out,get_ret,chg
      data six/1,2,3,4,5,6/
c     
      a = 123
      b = 456
      c = add(a, b)
      write(*,*) c
c     
      allsix = sum(6, six)
      write(*,*) allsix
c     
      s(1:4) = 'ABC' // char(0)
      call dup(s(1:3), s2)
      write(*,*) s2(1:6)
c   
      call get_out(iv, sv)
      write(*,*) iv,sv(1:3)
c
      d1 = get_ret()
      write(*,*) d1.iv,d1.sv(1:3)
c
      d2.iv1 = 123
      d2.sv1(1:4) = 'ABC' // char(0)
      call chg(d2)
      write(*,*) d2.iv2,d2.sv2(1:4)
c     
      end

Build: 

gcc -c -Wall demolib.c -o demolib.obj
gcc -c -Wall fordemolib.c -o fordemolib.obj
gfortran -Wall -fdec-structure testfor.for fordemolib.obj demolib.obj -o testfor.exe

Output: 

         579
          21
 ABCABC
         123 ABC
         123 ABC
         124 ABCX

Delphi/Lazarus support many C constructs making it relative easy to call C. 

program testpas2;

{$MODE objfpc}
{$H+}
{$LINK demolib.obj} 
{$LINKLIB C:\DivNative\64bit\gcc\x86_64-w64-mingw32\lib\libmsvcrt.a}

type
  Data1 = record
    iv : integer;
    sv : packed array[0..49] of char;
  end;
  Data2 = record
    iv1 : integer;
    sv1 : packed array[0..49] of char;
    iv2 : integer;
    sv2 : packed array[0..49] of char;
  end;
  PData1 = ^Data1;

function add(a, b : integer) : integer; cdecl; external name 'add';
function sum(n : integer; a : array of integer) : integer; cdecl; external name 'sum';
function dup(s : PChar) : PChar; cdecl; external name 'dup';
procedure  get_out(var iv : integer; var sv : PChar); cdecl; external name 'get_out';
function get_ret : PData1; cdecl; external name 'get_ret';
procedure chg(var d : Data2); cdecl; external name 'chg';

var
  a, b, c, allsix, iv : integer;
  six : array [0..5] of integer = (1, 2, 3, 4, 5, 6);
  s, s2, sv : string;
  tempsv : pchar;
  d1 : PData1;
  d2 : Data2;

begin
  (* *)
  a := 123;
  b := 456;
  c := add(a, b);
  writeln(c:1);
  (* *)
  allsix := sum(Length(six), six);
  writeln(allsix:1);
  (* *)
  s := 'ABC';
  s2 := dup(PChar(s));
  writeln(s2);
  (* *)
  iv := 0;
  tempsv := '';
  get_out(iv, tempsv);
  sv := tempsv;
  writeln(iv:1,' ', sv);
  (* *)
  d1 := get_ret();
  writeln(d1^.iv:1, ' ', d1^.sv);
  (* *)
  d2.iv1 := 123;
  d2.sv1 := 'ABC';
  chg(d2);
  writeln(d2.iv2:1, ' ', d2.sv2);
end.

Build: 

gcc -c demolib.c -o demolib.obj
fpc testpas2.pas

Output: 

579
21
ABCABC
123 ABC
123 ABC
124 ABCX

Load DLL/so:

Sometimes one have a DLL/so instead of a libray.

To demo how to handle that we will create the following wrapper.

stddemolib.c: 

#include <stdlib.h>

#include "demolib.h"

#ifdef WIN
#define EXTERNAL(t) __declspec(dllexport) t __stdcall
#else
#ifdef NIX
#define EXTERNAL(t) t
#else
#ifdef VMS
#define EXTERNAL(t) t
#else
#error "Platform not supported or not specified"
#endif
#endif
#endif

EXTERNAL(int) std_add(int a, int b)
{
    return add(a, b);
}

EXTERNAL(int) std_sum(int n, int *a)
{
    return sum(n, a);
}

EXTERNAL(char *) std_dup(char *s)
{
    return dup(s);
}

EXTERNAL(void) std_get_out(int *iv, char **sv)
{
    get_out(iv, sv);
}

EXTERNAL(struct Data1 *) std_get_ret()
{
    return get_ret();
}

EXTERNAL(void) std_chg(struct Data2 *d)
{
    chg(d);
}

EXTERNAL(void) std_free(char *s)
{
    free(s);
}

Build on Windows with GCC: 

gcc -Wall -DWIN -shared -Wl,--kill-at stddemolib.c demolib.c -o stddemolib.dll

Build on Linux with GCC: 

gcc -Wall -DNIX -shared -fPIC stddemolib.c demolib.c -o stddemolib.so

Build on VMS: 

$ cc demolib
$ cc/def="VMS" stddemolib
$ link/share stddemolib+demolib+sys$input/option
SYMBOL_VECTOR=(std_add=PROCEDURE,-
               std_sum=PROCEDURE,-
               std_dup=PROCEDURE,-
               std_get_out=PROCEDURE,-
               std_get_ret=PROCEDURE,-
               std_chg=PROCEDURE)
$
$ define/nolog/super stddemolib sys$disk:[]stddemolib

The API can be recreated in C and the necessary library and function pointers be loaded manually in C. 

#include <stdio.h>
#include <string.h>
#include <stdlib.h>

#include <windows.h>

struct Data1
{
    int iv;
    char sv[50];
};

struct Data2
{
    int iv1;
    char sv1[50];
    int iv2;
    char sv2[50];
};

typedef int (*F_add)(int a, int b);
typedef int (*F_sum)(int n, int *a);
typedef char *(*F_dup)(char *s);
typedef void (*F_get_out)(int *iv, char **sv);
typedef struct Data1 *(*F_get_ret)();
typedef void (*F_chg)(struct Data2 *d);

int main()
{
    HINSTANCE dll;
    F_add add;
    F_sum sum;
    F_dup dup;
    F_get_out get_out;
    F_get_ret get_ret;
    F_chg chg;
    int a, b, c, allsix, iv;
    char *s, *s2, *sv;
    int six[] = { 1, 2, 3, 4, 5, 6 };
    struct Data1 *d1;
    struct Data2 d2;
    /* */
    dll = LoadLibrary("stddemolib.dll");
    add = (F_add)GetProcAddress(dll, "std_add");
    sum = (F_sum)GetProcAddress(dll, "std_sum");
    dup = (F_dup)GetProcAddress(dll, "std_dup");
    get_out = (F_get_out)GetProcAddress(dll, "std_get_out");
    get_ret = (F_get_ret)GetProcAddress(dll, "std_get_ret");
    chg = (F_chg)GetProcAddress(dll, "std_chg");
    /* */
    a = 123;
    b = 456;
    c = add(a, b);
    printf("%d\n", c);
    /* */
    allsix = sum(6, six);
    printf("%d\n", allsix);
    /* */
    s = "ABC";
    s2 = dup(s);
    printf("%s\n", s2);
    free(s2);
    /* */
    get_out(&iv, &sv);
    printf("%d %s\n", iv, sv);
    free(sv);
    /* */
    d1 = get_ret();
    printf("%d %s\n", d1->iv, d1->sv);
    /* */
    d2.iv1 = 123;
    strcpy(d2.sv1, "ABC");
    chg(&d2);
    printf("%d %s\n", d2.iv2, d2.sv2);
    /* */
    return 0;
}

Build with GCC: 

gcc -Wall -DWIN testcstd.c -o testcstd.exe

Output: 

579
21
ABCABC
123 ABC
123 ABC
124 ABCX

The API can be recreated in C and the necessary library and function pointers be loaded manually in C. 

#include <stdio.h>
#include <string.h>
#include <stdlib.h>

#include <dlfcn.h>

struct Data1
{
    int iv;
    char sv[50];
};

struct Data2
{
    int iv1;
    char sv1[50];
    int iv2;
    char sv2[50];
};

typedef int (*F_add)(int a, int b);
typedef int (*F_sum)(int n, int *a);
typedef char *(*F_dup)(char *s);
typedef void (*F_get_out)(int *iv, char **sv);
typedef struct Data1 *(*F_get_ret)();
typedef void (*F_chg)(struct Data2 *d);

int main()
{
    void *so;
    F_add add;
    F_sum sum;
    F_dup dup;
    F_get_out get_out;
    F_get_ret get_ret;
    F_chg chg;
    int a, b, c, allsix, iv;
    char *s, *s2, *sv;
    int six[] = { 1, 2, 3, 4, 5, 6 };
    struct Data1 *d1;
    struct Data2 d2;
    /* */
    so = dlopen("./stddemolib.so", RTLD_NOW);
    add = (F_add)dlsym(so, "std_add");
    sum = (F_sum)dlsym(so, "std_sum");
    dup = (F_dup)dlsym(so, "std_dup");
    get_out = (F_get_out)dlsym(so, "std_get_out");
    get_ret = (F_get_ret)dlsym(so, "std_get_ret");
    chg = (F_chg)dlsym(so, "std_chg");
    /* */
    a = 123;
    b = 456;
    c = add(a, b);
    printf("%d\n", c);
    /* */
    allsix = sum(6, six);
    printf("%d\n", allsix);
    /* */
    s = "ABC";
    s2 = dup(s);
    printf("%s\n", s2);
    free(s2);
    /* */
    get_out(&iv, &sv);
    printf("%d %s\n", iv, sv);
    free(sv);
    /* */
    d1 = get_ret();
    printf("%d %s\n", d1->iv, d1->sv);
    /* */
    d2.iv1 = 123;
    strcpy(d2.sv1, "ABC");
    chg(&d2);
    printf("%d %s\n", d2.iv2, d2.sv2);
    /* */
    return 0;
}

Build with GCC: 

gcc -Wall -DNIX -ldl testcstd.c -o testcstd

Output: 

579
21
ABCABC
123 ABC
123 ABC
124 ABCX

The API can be recreated in C and the necessary library and function pointers be loaded manually in C. 

#include <stdio.h>
#include <string.h>
#include <stdlib.h>

#include <descrip.h>
#include <lib$routines.h>

struct Data1
{
    int iv;
    char sv[50];
};

struct Data2
{
    int iv1;
    char sv1[50];
    int iv2;
    char sv2[50];
};

typedef int (*F_add)(int a, int b);
typedef int (*F_sum)(int n, int *a);
typedef char *(*F_dup)(char *s);
typedef void (*F_get_out)(int *iv, char **sv);
typedef struct Data1 *(*F_get_ret)();
typedef void (*F_chg)(struct Data2 *d);

int main()
{
    F_add add;
    F_sum sum;
    F_dup dup;
    F_get_out get_out;
    F_get_ret get_ret;
    F_chg chg;
    int a, b, c, allsix, iv;
    char *s, *s2, *sv;
    int six[] = { 1, 2, 3, 4, 5, 6 };
    struct Data1 *d1;
    struct Data2 d2;
    /* */
    $DESCRIPTOR(shrexe, "stddemolib");
    $DESCRIPTOR(S_add, "std_add");
    $DESCRIPTOR(S_sum, "std_sum");
    $DESCRIPTOR(S_dup, "std_dup");
    $DESCRIPTOR(S_get_out, "std_get_out");
    $DESCRIPTOR(S_get_ret, "std_get_ret");
    $DESCRIPTOR(S_chg, "std_chg");
    int res = lib$find_image_symbol(&shrexe, &S_add, &add);
    lib$find_image_symbol(&shrexe, &S_sum, &sum);
    lib$find_image_symbol(&shrexe, &S_dup, &dup);
    lib$find_image_symbol(&shrexe, &S_get_out, &get_out);
    lib$find_image_symbol(&shrexe, &S_get_ret, &get_ret);
    lib$find_image_symbol(&shrexe, &S_chg, &chg);
    /* */
    a = 123;
    b = 456;
    c = add(a, b);
    printf("%d\n", c);
    /* */
    allsix = sum(6, six);
    printf("%d\n", allsix);
    /* */
    s = "ABC";
    s2 = dup(s);
    printf("%s\n", s2);
    free(s2);
    /* */
    get_out(&iv, &sv);
    printf("%d %s\n", iv, sv);
    free(sv);
    /* */
    d1 = get_ret();
    printf("%d %s\n", d1->iv, d1->sv);
    /* */
    d2.iv1 = 123;
    strcpy(d2.sv1, "ABC");
    chg(&d2);
    printf("%d %s\n", d2.iv2, d2.sv2);
    /* */
    return 0;
}

Build: 

$ cc/def="VMS" testcstd
$ link testcstd+sys$input/option
stddemolib/share
$

Output: 

579
21
ABCABC
123 ABC
123 ABC
124 ABCX

Delphi/Lazarus has builtin support for referencing C functions in DLL's. 

program TestPas;

type
  Data1 = record
    iv : integer;
    sv : array[0..49] of char;
  end;
  Data2 = record
    iv1 : integer;
    sv1 : array[0..49] of char;
    iv2 : integer;
    sv2 : array[0..49] of char;
  end;
  PData1 = ^Data1;

function std_add(a, b : integer) : integer; stdcall; external 'stddemolib.dll';
function std_sum(n : integer; a : array of integer) : integer; stdcall; external 'stddemolib.dll';
function std_dup(s : PChar) : PChar; stdcall; external 'stddemolib.dll';
procedure  std_get_out(var iv : integer; var sv : PChar); stdcall; external 'stddemolib.dll';
function std_get_ret : PData1; stdcall; external 'stddemolib.dll';
procedure std_chg(var d : Data2); stdcall; external 'stddemolib.dll';

var
  a, b, c, allsix, iv : integer;
  six : array [0..5] of integer = (1, 2, 3, 4, 5, 6);
  s, s2, sv : string;
  tempsv : pchar;
  d1 : PData1;
  d2 : Data2;

begin
  (* *)
  a := 123;
  b := 456;
  c := std_add(a, b);
  writeln(c:1);
  (* *)
  allsix := std_sum(Length(six), six);
  writeln(allsix:1);
  (* *)
  s := 'ABC';
  s2 := std_dup(PChar(s));
  writeln(s2);
  (* *)
  iv := 0;
  tempsv := '';
  std_get_out(iv, tempsv);
  sv := tempsv;
  writeln(iv:1,' ', sv);
  (* *)
  d1 := std_get_ret();
  writeln(d1^.iv:1,' ', d1^.sv);
  (* *)
  d2.iv1 := 123;
  d2.sv1 := 'ABC';
  std_chg(d2);
  writeln(d2.iv2:1,' ', d2.sv2);
end.

It works pretty smooth.

Output: 

579
21
ABCABC
123 ABC
123 ABC
124 ABCX

Decoration / name mangling:

Note that C++ provides an extra problem in this context..

C++ use decoration or name mangling to handle overload and limitations on length of names.

This can make it somewhat difficult to fine names in a DLL/so unless extern "C" is used.

A simple demo.

C++ source for Windows DLL: 

extern "C" 
{
__declspec(dllexport) int __stdcall add_c(int a, int b);
}
__declspec(dllexport) int __stdcall add_cpp(int a, int b);

int add_c(int a, int b)
{
    return a + b;
}

int add_cpp(int a, int b)
{
    return a + b;
}

Usage from Delphi/Lazarus: 

program DemoPas;

function add_c_msvc(a, b : integer) : integer; stdcall; external 'demomsvc.dll' name 'add_c';
function add_cpp_msvc(a, b : integer) : integer; stdcall; external 'demomsvc.dll' name '?add_cpp@@YAHHH@Z';
function add_c_gcc(a, b : integer) : integer; stdcall; external 'demogcc.dll' name 'add_c';
function add_cpp_gcc(a, b : integer) : integer; stdcall; external 'demogcc.dll' name '_Z7add_cppii';

begin
  writeln(add_c_msvc(123, 456));
  writeln(add_cpp_msvc(123, 456));
  writeln(add_c_gcc(123, 456));
  writeln(add_cpp_gcc(123, 456));
end.

Build on Windows with MSVC++ and GCC: 

cl /LD demo.cpp /Fedemomsvc.dll
gcc -Wall -shared -Wl,--kill-at demo.cpp -o demogcc.dll

And even though the names of the *_cpp_* entries can both be found in DLL using dumpbin and calculated using the compiler specific algorithm, then it is obviously not optimal.

Always use extern "C" for exported names (unless caller is known to be C++).

Windows COM:

Concept:

COM/DCOM/COM+/ActiveX is a core Windows technology.

It covers a lot of different functionality:

Here we will focus on the two first aspects.

At the very lowest level a COM class is just a class implementing the interface IUnknown and following some conventions.

COM classes that need to support dynamic API explorartion must also implement the interface IDispatch. This is needed to support script languages without strong type system.

But this article will not focus on the lower levels - instead it will focus on how it practically can be used for cross language calls.

For more details on COM see the COM article.

Server:

Writing a COM component in C++ is not that simple.

Basically there are two approaches:

Since this article is about using COM not understanding the internals, then it will take the second approach as it is significant less code to write - and live with the fact that it is far from standard C++.

Here comes an example.

First we define th einterface in IDL (Interface Definition Language).

SNat.idl: 

import "oaidl.idl";

// IS
[object, uuid(CBF5E889-BFBA-41FC-83DF-98156E999C21), oleautomation, dual, pointer_default(unique)]
interface IS : IDispatch
{
    [id(1)] HRESULT Add([in] long a, [in] long b, [out,retval] long *c);
    [id(2)] HRESULT Dup([in] BSTR s, [out,retval]BSTR *s2);
    [id(3),propget] HRESULT Iv([out, retval] long *iv);
    [id(3),propput] HRESULT Iv([in] long iv);
    [id(4),propget] HRESULT Sv([out, retval] BSTR *sv);
    [id(4),propput] HRESULT Sv([in] BSTR sv);
    [id(5)] HRESULT M();
}

// S library
[uuid(170E2745-A02D-416D-A3FA-4160ACE70F41), version(1.0)]
library SLibrary
{
    importlib("stdole32.tlb");
    [uuid(DB83A5B9-D6CC-4807-9755-BBD02755DD67)]
    coclass CoS
    {
        [default] interface IS;
    };
};

We compile that with the MIDL compiler: 

midl SNat.idl

and we get a bunch of files including SNat.h with a C++ interface IS and a SNat.tlb type library, that will be used by languages with strong type system.

We define a class that use stuff from the generated files and the builtin support for COM.

SNatEx.h: 

#ifndef SNAT_H
#define SNAT_H

#include <windows.h>
#include <tchar.h>

#include <atlbase.h>
#include <atlcom.h>

#include "SNat_i.c"
#include "SNat.h"

class ATL_NO_VTABLE CCoS : public CComObjectRootEx<CComSingleThreadModel>, public CComCoClass<CCoS, &CLSID_CoS>, public IDispatchImpl<IS, &IID_IS, &LIBID_SLibrary>
{
private:
    long m_iv;
    BSTR m_sv;
public:
    CCoS();
    virtual ~CCoS();
    BEGIN_COM_MAP(CCoS)
       COM_INTERFACE_ENTRY(IS)
       COM_INTERFACE_ENTRY2(IDispatch, IS)
    END_COM_MAP()
    // IS
    STDMETHODIMP Add(long a, long b, long *c);
    STDMETHODIMP Dup(BSTR s, BSTR *s2);
    STDMETHODIMP get_Iv(long *iv);
    STDMETHODIMP put_Iv(long iv);
    STDMETHODIMP get_Sv(BSTR *sv);
    STDMETHODIMP put_Sv(BSTR sv);
    STDMETHODIMP M();
    static HRESULT WINAPI UpdateRegistry(BOOL b)
    {
        return _Module.UpdateRegistryClass(CLSID_CoS, _T("COM.SNat.1"), _T("COM.SNat"), 0U, THREADFLAGS_APARTMENT, b);
    }
};

#endif

We provide the implementation for that class and some registration functions.

SNat.cpp: 

#include <windows.h>
#include <oleauto.h>
#include <initguid.h>

#include <atlbase.h>
extern CComModule _Module;
#include <atlcom.h>

#include "SNatEx.h"

CComModule _Module;

BEGIN_OBJECT_MAP(ObjectMap)
    OBJECT_ENTRY(CLSID_CoS, CCoS)
END_OBJECT_MAP()

CCoS::CCoS()
{
    m_iv = 0;
    m_sv = SysAllocString(L"");
}

CCoS::~CCoS()
{
    SysFreeString(m_sv);
}

STDMETHODIMP CCoS::Add(long a, long b, long *c)
{
    *c = a + b;
    return S_OK;
}

STDMETHODIMP CCoS::Dup(BSTR s, BSTR *s2)
{
    OLECHAR *buf = new OLECHAR[2 * SysStringLen(s) + 1];
    wcscpy(buf, s);
    wcscat(buf, s);
    *s2 = SysAllocString(buf);
    delete[] buf;
    return S_OK;
}

STDMETHODIMP CCoS::get_Iv(long *iv)
{
    *iv = m_iv;
    return S_OK;
}

STDMETHODIMP CCoS::put_Iv(long iv)
{
    m_iv = iv;
    return S_OK;
}

STDMETHODIMP CCoS::get_Sv(BSTR *sv)
{
    *sv = SysAllocString(m_sv);
    return S_OK;
}

STDMETHODIMP CCoS::put_Sv(BSTR sv)
{
    SysReAllocString(&m_sv, sv);
    return S_OK;
}

STDMETHODIMP CCoS::M()
{
    m_iv = m_iv + 1;
    OLECHAR *buf = new OLECHAR[SysStringLen(m_sv) + 1 + 1];
    wcscpy(buf, m_sv);
    wcscat(buf, L"X");
    SysFreeString(m_sv);
    m_sv = SysAllocString(buf);
    delete[] buf;
    return S_OK;
}

BOOL WINAPI DllMain(HINSTANCE hInstance, DWORD dwReason, LPVOID lpReserved)
{
    if(dwReason == DLL_PROCESS_ATTACH)
    {
        _Module.Init(ObjectMap, hInstance, &LIBID_SLibrary);
    }
    else if(dwReason == DLL_PROCESS_DETACH)
    {
        _Module.Term();
    }
    return TRUE;
}

STDMETHODIMP DllGetClassObject(REFCLSID rclsid, REFIID riid, void **ppv)
{
    return _Module.GetClassObject(rclsid, riid, ppv);
}

STDMETHODIMP DllCanUnloadNow()
{
    return (_Module.GetLockCount() == 0) ? S_OK : S_FALSE;
}

STDMETHODIMP DllRegisterServer()
{
    return _Module.RegisterServer(TRUE);
}

STDMETHODIMP DllUnregisterServer()
{
    return _Module.UnregisterServer(TRUE);
}

Build: 

cl /LD SNat.cpp SNat.def oleaut32.lib

Registration: 

regsvr32 SNat.dll

Be sure to register it correctly as either a 64 bit or 32 bit COM component.

Client:

We will see how to call the above COM component from C++ and Delphi/Lazarus. 

// C++
#include <iostream>
using namespace std;

// Windows
#include <windows.h>
#include <initguid.h>
#include <tchar.h>

// our stuff
#import "SNat.tlb" no_namespace named_guids

void ReturnCheck(LPTSTR func, HRESULT res)
{
    if(res != S_OK)
    {
        TCHAR buffer[1000];
        FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, res, 0, buffer, sizeof(buffer), 0);
        _tprintf("%s: %s\n", func, buffer);
        exit(1);
    }
}

int main()
{
    HRESULT res;
    CoInitialize(NULL);
    try
    {
        ISPtr spS;
        res = spS.CreateInstance(CLSID_CoS);
        ReturnCheck(_T("CreateInstance"), res);
        long a = 123;
        long b = 456;
        long c = spS->Add(a, b);
        wcout << c << endl;
        BSTR s = SysAllocString(L"ABC");
        BSTR s2 = spS->Dup(s);
        wcout << s2 << endl;
        SysFreeString(s);
        SysFreeString(s2);
        BSTR temp = SysAllocString(L"ABC");
        spS->PutIv(123);
        spS->PutSv(temp);
        SysFreeString(temp);
        spS->M();
        long iv = spS->GetIv();
        BSTR sv = spS->GetSv();
        wcout << iv << " " << sv << endl;
        SysFreeString(sv);
        spS = NULL;
    }
    catch (_com_error er)
    {
        _tprintf("%s\n", er.ErrorMessage());
    }
    //
    CoUninitialize();
    return 0;
}

Build: 

cl /EHsc C1.cpp ole32.lib oleaut32.lib

Output: 

579
ABCABC
124 ABCX

// C++
#include <iostream>
using namespace std;

// Windows
#include <windows.h>
#include <initguid.h>
#include <tchar.h>

// our stuff
#import "SNat.tlb" no_namespace named_guids

int main()
{
    CoInitialize(NULL);
    try
    {
        ISPtr spS(__uuidof(CoS));
        long a = 123;
        long b = 456;
        long c = spS->Add(a, b);
        wcout << c << endl;
        BSTR s = SysAllocString(L"ABC");
        BSTR s2 = spS->Dup(s);
        wcout << s2 << endl;
        SysFreeString(s);
        SysFreeString(s2);
        BSTR temp = SysAllocString(L"ABC");
        spS->PutIv(123);
        spS->PutSv(temp);
        SysFreeString(temp);
        spS->M();
        long iv = spS->GetIv();
        BSTR sv = spS->GetSv();
        wcout << iv << " " << sv << endl;
        SysFreeString(sv);
        spS = NULL;
    }
    catch (_com_error er)
    {
        _tprintf("%s\n", er.ErrorMessage());
    }
    //
    CoUninitialize();
    return 0;
}

Build: 

cl /EHsc C2.cpp ole32.lib oleaut32.lib

Output: 

579
ABCABC
124 ABCX

program CProgram2;

uses
  ActiveX,ComObj;

var
  a, b, c : integer;
  s, s2 : widestring;
  sdn : Variant;

begin
  CoInitialize(nil);
  sdn := CreateOLEObject('COM.SNat');
  a := 123;
  b := 456;
  c := sdn.Add(a, b);
  writeln(c);
  s := 'ABC';
  s2 := sdn.Dup(s);
  writeln(s2);
  sdn.Iv := 123;
  sdn.Sv := 'ABC';
  sdn.M;
  writeln(sdn.Iv:1,' ',sdn.Sv);
  CoUninitialize;
end.

Note that Delphi/Lazarus in this example use IDispatch and the dynamic API.

Output: 

579
ABCABC
124 ABCX

VMS Calling standard:

Calling standard:

VMS is a special case as the operating system define a language neutral calling standard or calling convention.

Note that the VMS calling standard is procedural only - there is no object oriented version.

Arguments have the following attributes:

type
the type of the data passed, possible values include:
access
how the argument wil be used, possible values are: semantics should be obvious.
mechanism
how the argument is passed, possible values are: the semantics of by value and by reference are the classic meanings. The by decsriptor mechanism is equivalent of calling with reference to a tuple of data type, data length and data address.

Example:

Let us see an example.

We will use this API: 

S(iv1, iv2, sv1, sv2)

Returns

  type:      longword
  access:    write only
  mechanism: by value

Arguments

  iv1

  type:      longword
  access:    read only
  mechanism: by value


  iv2

  type:      longword
  access:    write only
  mechanism: by reference


  sv1

  type:      character string
  access:    read only
  mechanism: by descriptor


  sv2

  type:      character string
  access:    write only
  mechanism: by descriptor

Calling program: 

      PROGRAM P
      INTEGER*4 IV1,IV2,RES
      CHARACTER*10 SV1,SV2
      INTEGER*4 S
      IV1=123
      SV1='ABC       '
      RES=S(%VAL(IV1),IV2,SV1,SV2)
      WRITE(*,*) RES,IV2,SV2
      END

program p(input, output);

type
    fixstr10 = packed array [1..10] of char;

function s(%IMMED iv1 : integer;
           var iv2 : integer;
           sv1 : [class_s] packed array[low1..high1:integer] of char;
           var sv2 : [class_s] packed array[low2..high2:integer] of char) : integer; external;

var
    iv1, iv2, res : integer;
    sv1, sv2 : fixstr10;

begin
   iv1 := 123;
   sv1 := 'ABC       ';
   sv2 := '          '; (* necessary or compiler complains *)
   res := s(iv1, iv2, sv1, sv2);
   writeln(res:1, ' ', iv2:1, ' ', sv2);
end.

#include <stdio.h>
#include <string.h>

#include <descrip.h>

int s(int iv1, int *iv2, struct dsc$descriptor_s *dsv1, struct dsc$descriptor_s *dsv2);

int main()
{
    int iv1, iv2, res;
    char sv1[11] = "ABC       ";
    char sv2[11];
    struct dsc$descriptor_s dsv1, dsv2;
    dsv1.dsc$w_length = strlen(sv1);
    dsv1.dsc$b_dtype = DSC$K_DTYPE_T;
    dsv1.dsc$b_class = DSC$K_CLASS_S;
    dsv1.dsc$a_pointer = sv1;
    dsv2.dsc$w_length = sizeof(sv2) - 1;
    dsv2.dsc$b_dtype = DSC$K_DTYPE_T;
    dsv2.dsc$b_class = DSC$K_CLASS_S;
    dsv2.dsc$a_pointer = sv2;
    iv1 = 123;
    res = s(iv1, &iv2, &dsv1, &dsv2); 
    dsv2.dsc$a_pointer[sizeof(sv2) - 1] = 0;
    printf("%d %d %s\n", res, iv2, dsv2.dsc$a_pointer);
    return 0;
}

or if using $DESCRIPTOR macro to define descriptors: 

#include <stdio.h>
#include <string.h>

#include <descrip.h>

int s(int iv1, int *iv2, struct dsc$descriptor_s *dsv1, struct dsc$descriptor_s *dsv2);

int main()
{
    int iv1, iv2, res;
    char sv1[11] = "ABC       ";
    char sv2[11];
    $DESCRIPTOR(dsv1, sv1);
    $DESCRIPTOR(dsv2, sv2);
    iv1 = 123;
    res = s(iv1, &iv2, &dsv1, &dsv2); 
    dsv2.dsc$a_pointer[sizeof(sv2) - 1] = 0;
    printf("%d %d %s\n", res, iv2, dsv2.dsc$a_pointer);
    return 0;
}

program p

declare integer iv1
declare integer iv2
declare integer res
map (sv1) string sv1 = 10
map (sv2) string sv2 = 10
external integer function s(integer by value, integer, string, string) 

iv1 = 123
sv1 = "ABC"
res = s(iv1, iv2, sv1, sv2)
print res, iv2, sv2

end program

        .title  p
        .psect  $PDATA quad,pic,con,lcl,shr,noexe,nowrt
        .psect  $LOCAL quad,pic,con,lcl,noshr,noexe,wrt
iv1:    .long   123
iv2:    .long   0
sv1:    .ascid  "ABC       "
sv2:    .ascid  "          "
dir:    .ascid  "!SL !SL !AS"
res:    .ascid  "                    "
reslen: .long   0
        .psect  $CODE quad,pic,con,lcl,shr,exe,nowrt
        .entry  p,^m<>
        pushal  sv2
        pushal  sv1
        pushal  iv2
        pushl   iv1
        calls   #4,S
;
        pushal  sv2
        pushl   iv2
        pushl   r0
        pushal  res
        pushal  reslen
        pushal  dir
        calls   #6,G^LIB$SYS_FAO
;
        pushal  res
        calls   #1,G^LIB$PUT_OUTPUT
;
        movl    #1,r0
        ret
        .end    p

Called function: 

      INTEGER*4 FUNCTION S(TEMPIV1,IV2,SV1,SV2)
      INTEGER*4 IV1,IV2,TEMPIV1
      CHARACTER*10 SV1,SV2
      IV1=%LOC(TEMPIV1) ! hack because Fortran do not support pass by value
      IV2=IV1+1
      SV2=SV1
      SV2(4:4)='X'
      S=1
      RETURN
      END

module ms(input, output);

[global] function s(%IMMED iv1 : integer;
                    var iv2 : integer;
                    sv1 : [class_s] packed array[low1..high1:integer] of char;
                    var sv2 : [class_s] packed array[low2..high2:integer] of char) : integer;

begin
    iv2 := iv1 + 1;
    sv2 := sv1;
    sv2[4] := 'X';
    s := 1;
end;

end.

#include <string.h>

#include <descrip.h>

int s(int iv1, int *iv2, struct dsc$descriptor_s *dsv1, struct dsc$descriptor_s *dsv2)
{
   *iv2 = iv1 + 1;
   memcpy(dsv2->dsc$a_pointer, dsv1->dsc$a_pointer, dsv1->dsc$w_length);
   dsv2->dsc$a_pointer[3] = 'X';
   return 1;
}

function integer s(integer iv1 by value, integer iv2, string sv1, string sv2)

iv2 = iv1 + 1
sv2 = sv1
mid$(sv2, 4, 1) = "X"
s = 1

end function

        .title  s
iv1=4
iv2=8
sv1=12
sv2=16
X=88
        .psect  $CODE quad,pic,con,lcl,shr,exe,nowrt
        .entry  s,^m<r2,r3,r4,r5,r6,r7,r8>
        movl    iv1(ap),@iv2(ap)
        incl    @iv2(ap)
        movl    sv1(ap),r6
        movl    sv2(ap),r7
        movc3   (r6),@4(r6),@4(r7)
        addl3   #3,4(r7),r8
        movb    #X,(r8)
        movl    #1,r0
        ret
        .end

Article history:

Version Date Description
1.0 February 2nd 2020 Initial version
1.1 February 9th 2020 Add direct Lazarus/Delphi to C and Windows COM

Other articles:

See list of all articles here

Comments:

Please send comments to Arne Vajhøj