Archive for 3月 9th, 2013

  1. Hello, Win32 API(OCaml) World!

    Posted on 3月 9th, 2013 by cx20

    Win32 API(OCaml)

    Win32 API は、Windows の機能にアクセスする為の API（Application Programming Interface）である。
    以下は OCaml による Win32 API 呼出しの例となっている。

    ソースコード（C言語）

    hello_stubs.c
    raw download
    #include <stdio.h>
#include <windows.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
 
#define Is_nil(v) ((v) == Val_int(0))
#define Head(v) (Field((v), 0))
#define Tail(v) (Field((v), 1))
 
#define Declare_constants(name) 
    extern DWORD name[]; 
    extern int num_##name
 
#define Define_constants(name) 
    int num_##name = sizeof(name) / sizeof(DWORD)
 
#define Constant_val(val, constants) (constants[Int_val(val)])
 
#define Handle_val(v) (*((HANDLE*)(v)))
value alloc_handle(HANDLE h);
 
value val_constant_with_count(DWORD constant, int num_constants, DWORD* constants);
 
#define Val_constant(constant, constants) 
    (val_constant_with_count((constant), num_##constants, constants))
 
Declare_constants(standard_control_ids);
 
DWORD standard_control_ids[] = {
    IDABORT,
    IDCANCEL,
    IDCLOSE,
    IDHELP,
    IDIGNORE,
    IDNO,
    IDOK,
    IDRETRY,
    IDYES
};
Define_constants(standard_control_ids);
 
DWORD message_box_options[] = {
    MB_ABORTRETRYIGNORE,
    MB_APPLMODAL,
    MB_DEFAULT_DESKTOP_ONLY,
    MB_DEFBUTTON1,
    MB_DEFBUTTON2,
    MB_DEFBUTTON3,
    MB_DEFBUTTON4,
    MB_HELP,
    MB_ICONASTERISK,
    MB_ICONERROR,
    MB_ICONEXCLAMATION,
    MB_ICONHAND,
    MB_ICONINFORMATION,
    MB_ICONQUESTION,
    MB_ICONSTOP,
    MB_ICONWARNING,
    MB_OK,
    MB_OKCANCEL,
    MB_RETRYCANCEL,
    MB_RIGHT,
    MB_RTLREADING,
    MB_SETFOREGROUND,
    MB_SYSTEMMODAL,
    MB_TASKMODAL,
    MB_TOPMOST,
    MB_YESNO,
    MB_YESNOCANCEL
};
 
value val_constant_with_count(DWORD constant, int num_constants, DWORD* constants)
{
    int i;
 
    for (i = 0; i < num_constants; ++i)
        if (constants[i] == constant)
            return Val_int(i);
    failwith("Invalid constant");
    return Val_int(0);
}
 
CAMLprim value get_null_hwnd(value unit)
{
    return alloc_handle(NULL);
}
 
value alloc_handle(HANDLE h)
{
    value val;
 
    val = alloc_small(sizeof(HANDLE) / sizeof(value), Abstract_tag);
    Handle_val(val) = h;
    return val;
}
 
DWORD flags_val(value list, DWORD* constants)
{
    int result;
 
    result = 0;
    for (; !Is_nil(list); list = Tail(list))
        result |= Constant_val(Head(list), constants);
    return result;
}
 
char* new_string(value v)
{
    return strdup(String_val(v));
}
 
void free_string(char* s)
{
    free(s);
}
 
static value* win32_error_exception = NULL;
 
void raise_win32_error(DWORD error)
{
    if (win32_error_exception == NULL)
        win32_error_exception = caml_named_value("win32 error");
    raise_with_arg(*win32_error_exception, Val_int((int)error));
}
 
void raise_last_error(void)
{
    raise_win32_error(GetLastError());
}
 
CAMLprim value message_box(value wnd, value text, value caption, value type)
{
    CAMLparam4(wnd, text, caption, type);
    HWND hwnd;
    char* txt;
    char* capt;
    UINT typ;
    int result;
 
    hwnd = Handle_val(wnd);
    txt = new_string(text);
    capt = new_string(caption);
    typ = flags_val(type, message_box_options);
    enter_blocking_section();
    result = MessageBox(hwnd, txt, capt, typ);
    leave_blocking_section();
    free_string(txt);
    free_string(capt);
    if (result == 0)
        raise_last_error();
    CAMLreturn(Val_constant(result, standard_control_ids));
}

    ソースコード（OCaml）

    hello.ml
    raw download
    type hwnd
 
type message_box_option =
    MB_ABORTRETRYIGNORE
  | MB_APPLMODAL
  | MB_DEFAULT_DESKTOP_ONLY
  | MB_DEFBUTTON1
  | MB_DEFBUTTON2
  | MB_DEFBUTTON3
  | MB_DEFBUTTON4
  | MB_HELP
  | MB_ICONASTERISK
  | MB_ICONERROR
  | MB_ICONEXCLAMATION
  | MB_ICONHAND
  | MB_ICONINFORMATION
  | MB_ICONQUESTION
  | MB_ICONSTOP
  | MB_ICONWARNING
  | MB_OK
  | MB_OKCANCEL
  | MB_RETRYCANCEL
  | MB_RIGHT
  | MB_RTLREADING
  | MB_SETFOREGROUND
  | MB_SYSTEMMODAL
  | MB_TASKMODAL
  | MB_TOPMOST
  | MB_YESNO
  | MB_YESNOCANCEL
 
type standard_control_id =
    IDABORT
  | IDCANCEL
  | IDCLOSE
  | IDHELP
  | IDIGNORE
  | IDNO
  | IDOK
  | IDRETRY
  | IDYES
 
external get_null_hwnd : unit -> hwnd = "get_null_hwnd"
let null_hwnd = get_null_hwnd ()
 
external message_box :
    wnd:hwnd ->
    text:string ->
    caption:string ->
    options:message_box_option list ->
    standard_control_id = "message_box"
 
let () =
  ignore ( message_box ~wnd:null_hwnd ~text:"Hello, Win32 API World!" ~caption:"Hello, World!" ~options:[MB_OK] );

    実行方法

    C:¥> ocamlopt -o hello.exe hello.ml hello_stubs.c

    実行結果

    ---------------------------
Hello, World!
---------------------------
Hello, Win32 API World!
---------------------------
OK   
---------------------------