Commits

Yosuke Onoue committed 5926aca

add alloc functions, add caml_callbackN

Comments (0)

Files changed (3)

template/otypes.py

     def __repr__(self):
         return 'ml_header_t({})'.format(self.value)
 
+ml_header_t_p = ctypes.POINTER(ml_header_t)
+
 class ml_mlsize_t(ml_uintnat):
     '''
     typedef uintnat mlsize_t;
     def __repr__(self):
         return 'int32({})'.format(self.value)
 
+class ml_int64(ctypes.c_int64):
+    '''
+    '''
+
+    def __repr__(self):
+        return 'int64({})'.format(self.value)
+
 class ml_opcode_t(ml_int32):
     '''
     typedef int32 opcode_t;
 caml__roots_block_p = ctypes.POINTER(caml__roots_block)
 
 def caml_named_value(name):
-    return ml_value(context.caml_named_value(ctypes.c_char_p(name)).contents.value)
+    '''
+    CAMLextern value * caml_named_value (char const * name);
+    '''
+    return context.caml_named_value(ctypes.c_char_p(name)).contents
 
 def caml_callback(*args):
-    l = len(args)
-    if l == 2:
-        return ml_value(context.caml_callback(*args))
-    elif l == 3:
-        return ml_value(context.caml_callback2(*args))
-    elif l == 4:
-        return ml_value(context.caml_callback3(*args))
+    '''
+    CAMLextern value caml_callback (value closure, value arg);
+    CAMLextern value caml_callback2 (value closure, value arg1, value arg2);
+    CAMLextern value caml_callback3 (value closure, value arg1, value arg2, value arg3);
+    CAMLextern value caml_callbackN (value closure, int narg, value args[]);
+    '''
+    narg = len(args) - 1
+    if narg == 1:
+        return context.caml_callback(*args)
+    elif narg == 2:
+        return context.caml_callback2(*args)
+    elif narg == 3:
+        return context.caml_callback3(*args)
+    elif narg > 3:
+        closure, args = args[0], args[1:]
+        values = (ml_value * narg)()
+        for i, v in enumerate(args):
+            values[i] = v
+        return context.caml_callbackN(closure, ctypes.c_int(narg), values)
     else:
-        # TODO
-        raise NotImplementedError()
+        raise ValueError
 
 def caml_alloc(size, tag):
-    return ml_value(context.caml_alloc(size, tag))
+    '''
+    CAMLextern value caml_alloc (mlsize_t, tag_t);
+    '''
+    return context.caml_alloc(size, tag)
+
+def caml_alloc_small(size, tag):
+    '''
+    CAMLextern value caml_alloc_small (mlsize_t, tag_t);
+    '''
+    return context.caml_alloc(size, tag)
 
 def caml_alloc_tuple(size):
-    return ml_value(context.caml_alloc_tuple(size))
+    '''
+    CAMLextern value caml_alloc_tuple (mlsize_t);
+    '''
+    return context.caml_alloc_tuple(size)
+
+def caml_alloc_string(size):
+    '''
+    CAMLextern value caml_alloc_string (mlsize_t);  /* size in bytes */
+    '''
+    return context.caml_alloc_string(size)
+
+def caml_copy_string(string):
+    '''
+    CAMLextern value caml_copy_string (char const *);
+    '''
+    return context.caml_copy_string(ctypes.c_char_p(string))
+
+def caml_copy_string_array(strings):
+    '''
+    CAMLextern value caml_copy_string_array (char const **);
+    '''
+    return context.caml_copy_string_array(strings) # TODO
+
+def caml_copy_double(f):
+    '''
+    CAMLextern value caml_copy_double (double);
+    '''
+    return context.caml_copy_double(ctypes.c_double(f))
+
+def caml_copy_int32(x):
+    '''
+    CAMLextern value caml_copy_int32 (int32);       /* defined in [ints.c] */
+    '''
+    return context.caml_copy_int32(ml_int32(x))
+
+def caml_copy_int64(x):
+    '''
+    CAMLextern value caml_copy_int64 (int64);       /* defined in [ints.c] */
+    '''
+    return context.caml_copy_int64(ml_int64(x))
+
+def caml_copy_nativeint(x):
+    '''
+    CAMLextern value caml_copy_nativeint (intnat);  /* defined in [ints.c] */
+    '''
+    return context.caml_copy_nativeint(ml_intnat(x))
 
 def caml_modify(dest, src):
     return context.caml_modify(dest, src)
     '''
     return ml_header_t.from_address(val.value - ctypes.alignment(ml_header_t))
 
+def val_hp(hp):
+    '''
+    #define Val_hp(hp) ((value) (((header_t *) (hp)) + 1))
+    '''
+    return ml_value(ml_header_t.from_address(hp)[1].value)
+
 def wosize_val(val):
     '''
     wosize_val(v) returns the size of the block v, in words, excluding the header.
     '''
     ctypes.POINTER(ctypes.c_double).from_buffer(v)[i] = d
 
+def atom(tag):
+    '''
+    atom(t) returns an "atom" (zero-sized block) with tag t.
+    Zero-sized blocks are preallocated outside of the heap.
+
+    #define Atom(tag) (Val_hp (&(caml_atom_table [(tag)])))
+    '''
+    return val_hp(caml_atom_table()[tag].address)
+
 def caml_xparam(*args):
     roots = caml__roots_block()
     roots.next = caml_local_roots()
 def caml_local_roots():
     return caml__roots_block_p.in_dll(context, 'caml_local_roots')
 
+def caml_atom_table():
+    return ml_header_t_p.in_dll(context, 'caml_atom_table')
+
 def caml_garbage_collection():
     context.caml_garbage_collection()
 
 
 let test_double_array = [|1.; 2.; 3.; 4.; 5.|];;
 
+let test_int32 = Int32.of_int 32;;
+
+let test_int64 = Int64.of_int 64;;
+
+let test_nativeint = Nativeint.of_int 128;;
+
+let f1 a =
+  a;;
+
+let f2 a b =
+  a + b;;
+
+let f3 a b c =
+  a + b + c;;
+
+let f4 a b c d =
+  a + b + c + d;;
+
 let _ =
   Callback.register "i" i;
   Callback.register "j" j;
   Callback.register "test_tuple" test_tuple;
   Callback.register "test_list" test_list;
   Callback.register "test_array" test_array;
-  Callback.register "test_double_array" test_double_array;;
+  Callback.register "test_double_array" test_double_array;
+  Callback.register "test_int32" test_int32;
+  Callback.register "test_int64" test_int64;
+  Callback.register "test_nativeint" test_nativeint;
+  Callback.register "f1" f1;
+  Callback.register "f2" f2;
+  Callback.register "f3" f3;
+  Callback.register "f4" f4;;
 
         pass
 
     def test_atom(self):
+        # TODO
+        #atom = lib.atom(lib.DOUBLE_TAG)
+        #assertEqual(lib.tag_val(atom), lib.DOUBLE_TAG)
+        #assertEqual(lib.wosize_val(atom), 0)
         pass
 
     def test_alloc(self):
     def test_alloc_shr(self):
         pass
 
+    def test_caml_callback(self):
+        a = lib.val_int(1)
+        f1 = lib.caml_named_value('f1')
+        res = lib.int_val(lib.caml_callback(f1, a))
+        self.assertEqual(res, 1)
+
+    def test_caml_callback2(self):
+        a = lib.val_int(1)
+        b = lib.val_int(2)
+        f2 = lib.caml_named_value('f2')
+        res = lib.int_val(lib.caml_callback(f2, a, b))
+        self.assertEqual(res, 3)
+
+    def test_caml_callback3(self):
+        a = lib.val_int(1)
+        b = lib.val_int(2)
+        c = lib.val_int(3)
+        f3 = lib.caml_named_value('f3')
+        res = lib.int_val(lib.caml_callback(f3, a, b, c))
+        self.assertEqual(res, 6)
+
+    def test_caml_callbackN(self):
+        a = lib.val_int(1)
+        b = lib.val_int(2)
+        c = lib.val_int(3)
+        d = lib.val_int(4)
+        f4 = lib.caml_named_value('f4')
+        res = lib.int_val(lib.caml_callback(f4, a, b, c, d))
+        self.assertEqual(res, 10)
+
 if __name__ == "__main__":
     unittest.main()