working on the FFI

diff --git a/Makefile b/Makefile
index 4355f8a245191ad57128ca1915074438840be20e..6d9ffb2200409a3dc0ea8afbd7bdbd0766dd3a1b 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,11 +1,11 @@
 CC = gcc
 
 # On FreeBSD, to use SDL and other libc_r libs:
-CFLAGS = -Os -g -Wall -pthread
+CFLAGS = -Os -g -Wall -pthread -export-dynamic
 # On PowerPC G5:
 # CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3
 # On Pentium 4:
-# CFLAGS = -march=pentium4 -ffast-math -O3 -fomit-frame-pointer
+# CFLAGS = -march=pentium4 -ffast-math -O3 -fomit-frame-pointer -export-dynamic
 # Add -fomit-frame-pointer if you don't care about debugging
 # CFLAGS = -Os -g -Wall
 

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 6edc64e24d21b54d823617ed8aa77369eac91bd2..2e274e549e6213a50118204b0dd2d935e6d77857 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,3 +1,6 @@
+FFI:\r
+- is signed -vs- unsigned pointers an issue?\r
+\r
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)\r
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)\r
 \r

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index a25eefbd14c7b1dc7e90d03cdc2598b57f654d93..76a4689d80d626b3b6f5adccf2f5bdde6aefd48d 100644 (file)
--- a/library/cross-compiler.factor
+++ b/library/cross-compiler.factor
@@ -45,6 +45,13 @@ DEFER: dlopen
 DEFER: dlsym
 DEFER: dlsym-self
 DEFER: dlclose
+DEFER: <alien>
+DEFER: alien-cell
+DEFER: set-alien-cell
+DEFER: alien-4
+DEFER: set-alien-4
+DEFER: alien-1
+DEFER: set-alien-1
 
 IN: compiler
 DEFER: set-compiled-byte
@@ -347,10 +354,10 @@ IN: image
         dump
         cwd
         cd
-        set-compiled-byte
-        set-compiled-cell
         compiled-offset
         set-compiled-offset
+        set-compiled-cell
+        set-compiled-byte
         literal-top
         set-literal-top
         address-of
@@ -358,6 +365,13 @@ IN: image
         dlsym
         dlsym-self
         dlclose
+        <alien>
+        alien-cell
+        set-alien-cell
+        alien-4
+        set-alien-4
+        alien-1
+        set-alien-1
     ] [
         swap succ tuck primitive,
     ] each drop ;

diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor
index 800ef220124173296648a7caa60a6490793d1617..29d0b6a99fbbdc0f939f8e995bcb75efbe974288 100644 (file)
--- a/library/platform/native/kernel.factor
+++ b/library/platform/native/kernel.factor
@@ -74,8 +74,12 @@ USE: vectors
         [ >fixnum ]
         [ >fixnum ]
         [ drop 0 ]
+        [ drop 0 ]
     } generic ;
 
+
+IN: math DEFER: number= ( defined later... )
+IN: kernel
 : equal? ( obj obj -- ? )
     #! Use = instead.
     {
@@ -95,6 +99,7 @@ USE: vectors
         [ number= ]
         [ number= ]
         [ eq? ]
+        [ eq? ]
     } generic ;
 
 : = ( obj obj -- ? )
@@ -113,31 +118,6 @@ USE: vectors
         [ drop t ] [ ( return the object ) ]
     ] cond ;
 
-: type-name ( n -- str )
-    [
-        [ 0 | "fixnum" ]
-        [ 1 | "word" ]
-        [ 2 | "cons" ]
-        [ 4 | "ratio" ]
-        [ 5 | "complex" ]
-        [ 6 | "f" ]
-        [ 7 | "t" ]
-        [ 9 | "vector" ]
-        [ 10 | "string" ]
-        [ 11 | "sbuf" ]
-        [ 12 | "port" ]
-        [ 13 | "bignum" ]
-        [ 14 | "float" ]
-        [ 15 | "dll" ]
-        ! These values are only used by the kernel for error
-        ! reporting.
-        [ 100 | "fixnum/bignum" ]
-        [ 101 | "fixnum/bignum/ratio" ]
-        [ 102 | "fixnum/bignum/ratio/float" ]
-        [ 103 | "fixnum/bignum/ratio/float/complex" ]
-        [ 104 | "fixnum/string" ]
-    ] assoc ;
-
 : java? f ;
 : native? t ;
 

diff --git a/library/platform/native/math.factor b/library/platform/native/math.factor
index c4976afc0794429db2765018dc7221a3e7490469..8053ce3aaf80922d8f6ce7e548174f644f3b1cf7 100644 (file)
--- a/library/platform/native/math.factor
+++ b/library/platform/native/math.factor
@@ -106,6 +106,7 @@ USE: words
         bignum=
         float=
         (not-=)
+        (not-=)
     } 2generic ;
 
 : + ( x y -- x+y )
@@ -126,6 +127,7 @@ USE: words
         bignum+
         float+
         no-method
+        no-method
     } 2generic ;
 
 : - ( x y -- x-y )
@@ -146,6 +148,7 @@ USE: words
         bignum-
         float-
         no-method
+        no-method
     } 2generic ;
 
 : * ( x y -- x*y )
@@ -166,6 +169,7 @@ USE: words
         bignum*
         float*
         no-method
+        no-method
     } 2generic ;
 
 : / ( x y -- x/y )
@@ -186,6 +190,7 @@ USE: words
         ratio
         float/f
         no-method
+        no-method
     } 2generic ;
 
 : /i ( x y -- x/y )
@@ -206,6 +211,7 @@ USE: words
         bignum/i
         no-method
         no-method
+        no-method
     } 2generic ;
 
 : /f ( x y -- x/y )
@@ -226,6 +232,7 @@ USE: words
         bignum/f
         float/f
         no-method
+        no-method
     } 2generic ;
 
 : mod ( x y -- x%y )
@@ -246,6 +253,7 @@ USE: words
         bignum-mod
         no-method
         no-method
+        no-method
     } 2generic ;
 
 : /mod ( x y -- x/y x%y )
@@ -266,6 +274,7 @@ USE: words
         bignum/mod
         no-method
         no-method
+        no-method
     } 2generic ;
 
 : bitand ( x y -- x&y )
@@ -286,6 +295,7 @@ USE: words
         bignum-bitand
         no-method
         no-method
+        no-method
     } 2generic ;
 
 : bitor ( x y -- x|y )
@@ -306,6 +316,7 @@ USE: words
         bignum-bitor
         no-method
         no-method
+        no-method
     } 2generic ;
 
 : bitxor ( x y -- x^y )
@@ -326,6 +337,7 @@ USE: words
         bignum-bitxor
         no-method
         no-method
+        no-method
     } 2generic ;
 
 : bitnot ( x -- ~x )
@@ -346,6 +358,7 @@ USE: words
         [ bignum-bitnot ]
         [ no-method     ]
         [ no-method     ]
+        [ no-method     ]
     } generic ;
 
 : shift ( x n -- x<<n )
@@ -366,6 +379,7 @@ USE: words
         bignum-shift
         no-method
         no-method
+        no-method
     } 2generic ;
 
 : < ( x y -- ? )
@@ -386,6 +400,7 @@ USE: words
         bignum<
         float<
         no-method
+        no-method
     } 2generic ;
 
 : <= ( x y -- ? )
@@ -406,6 +421,7 @@ USE: words
         bignum<=
         float<=
         no-method
+        no-method
     } 2generic ;
 
 : > ( x y -- ? )
@@ -426,6 +442,7 @@ USE: words
         bignum>
         float>
         no-method
+        no-method
     } 2generic ;
 
 : >= ( x y -- ? )
@@ -446,4 +463,5 @@ USE: words
         bignum>=
         float>=
         no-method
+        no-method
     } 2generic ;

diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor
index 1031ad8e8e06c8c9d10fa34506862fa0b95c3473..aa8bb6b7c4f66a7a1627f1fabc8c8155c19f65f3 100644 (file)
--- a/library/platform/native/primitives.factor
+++ b/library/platform/native/primitives.factor
@@ -212,10 +212,10 @@ USE: words
     [ dump                   | " obj -- " ]
     [ cwd                    | " -- dir " ]
     [ cd                     | " dir -- " ]
-    [ set-compiled-byte      | " n ptr -- " ]
-    [ set-compiled-cell      | " n ptr -- " ]
     [ compiled-offset        | " -- ptr " ]
     [ set-compiled-offset    | " ptr -- " ]
+    [ set-compiled-cell      | " n ptr -- " ]
+    [ set-compiled-byte      | " n ptr -- " ]
     [ literal-top            | " -- ptr " ]
     [ set-literal-top        | " ptr -- " ]
     [ address-of             | " obj -- ptr " ]
@@ -223,6 +223,13 @@ USE: words
     [ dlsym                  | " name dll -- ptr " ]
     [ dlsym-self             | " name -- ptr " ]
     [ dlclose                | " dll -- " ]
+    [ <alien>                | " ptr len -- alien " ]
+    [ alien-cell             | " alien off -- n " ]
+    [ set-alien-cell         | " n alien off -- " ]
+    [ alien-4                | " alien off -- n " ]
+    [ set-alien-4            | " n alien off -- " ]
+    [ alien-1                | " alien off -- n " ]
+    [ set-alien-1            | " n alien off -- " ]
 ] [
     unswons "stack-effect" swap set-word-property
 ] each

diff --git a/library/platform/native/types.factor b/library/platform/native/types.factor
index 1ccf6147c26739d13ed4e2902e9b8aea7bb1d1dd..0c61d82de06580c7c3127c3eea39328288f8b2c4 100644 (file)
--- a/library/platform/native/types.factor
+++ b/library/platform/native/types.factor
@@ -39,3 +39,32 @@ IN: io-internals : port?    ( obj -- ? ) type-of 12 eq? ;
 IN: math         : bignum?  ( obj -- ? ) type-of 13 eq? ;
 IN: math         : float?   ( obj -- ? ) type-of 14 eq? ;
 IN: alien        : dll?     ( obj -- ? ) type-of 15 eq? ;
+IN: alien        : alien?   ( obj -- ? ) type-of 16 eq? ;
+
+IN: kernel
+
+: type-name ( n -- str )
+    [
+        [ 0 | "fixnum" ]
+        [ 1 | "word" ]
+        [ 2 | "cons" ]
+        [ 4 | "ratio" ]
+        [ 5 | "complex" ]
+        [ 6 | "f" ]
+        [ 7 | "t" ]
+        [ 9 | "vector" ]
+        [ 10 | "string" ]
+        [ 11 | "sbuf" ]
+        [ 12 | "port" ]
+        [ 13 | "bignum" ]
+        [ 14 | "float" ]
+        [ 15 | "dll" ]
+        [ 16 | "alien" ]
+        ! These values are only used by the kernel for error
+        ! reporting.
+        [ 100 | "fixnum/bignum" ]
+        [ 101 | "fixnum/bignum/ratio" ]
+        [ 102 | "fixnum/bignum/ratio/float" ]
+        [ 103 | "fixnum/bignum/ratio/float/complex" ]
+        [ 104 | "fixnum/string" ]
+    ] assoc ;

diff --git a/native/arithmetic.c b/native/arithmetic.c
index 8d013c2c0e6e7088cc2b9e9a6a3cf72875d516af..330a7f13068b3c574e6415f4a2837cc89cf714b4 100644 (file)
--- a/native/arithmetic.c
+++ b/native/arithmetic.c
@@ -1,36 +1,5 @@
 #include "factor.h"
 
-CELL tag_integer(FIXNUM x)
-{
-       if(x < FIXNUM_MIN || x > FIXNUM_MAX)
-               return tag_object(s48_long_to_bignum(x));
-       else
-               return tag_fixnum(x);
-}
-
-CELL tag_cell(CELL x)
-{
-       if(x > FIXNUM_MAX)
-               return tag_object(s48_ulong_to_bignum(x));
-       else
-               return tag_fixnum(x);
-}
-
-CELL to_cell(CELL x)
-{
-       switch(type_of(x))
-       {
-       case FIXNUM_TYPE:
-               return untag_fixnum_fast(x);
-       case BIGNUM_TYPE:
-               /* really need bignum_to_ulong! */
-               return s48_bignum_to_long(untag_bignum(x));
-       default:
-               type_error(INTEGER_TYPE,x);
-               return 0;
-       }
-}
-
 void primitive_arithmetic_type(void)
 {
        CELL type2 = type_of(dpop());
@@ -52,6 +21,7 @@ void primitive_arithmetic_type(void)
                        type = type2;
                        break;
                }
+               break;
        case RATIO_TYPE:
                switch(type2)
                {
@@ -63,6 +33,7 @@ void primitive_arithmetic_type(void)
                        type = type2;
                        break;
                }
+               break;
        case FLOAT_TYPE:
                switch(type2)
                {
@@ -75,6 +46,7 @@ void primitive_arithmetic_type(void)
                        type = type2;
                        break;
                }
+               break;
        case COMPLEX_TYPE:
                switch(type2)
                {
@@ -88,6 +60,7 @@ void primitive_arithmetic_type(void)
                        type = type2;
                        break;
                }
+               break;
        default:
                type = type1;
                break;

diff --git a/native/arithmetic.h b/native/arithmetic.h
index fd2b6f94fd6eff2d0fb67d291db15d9775767798..8aa16028fb008ef633510f7ec7cd96ecf7f17898 100644 (file)
--- a/native/arithmetic.h
+++ b/native/arithmetic.h
@@ -2,10 +2,6 @@
 
 void primitive_arithmetic_type(void);
 
-CELL tag_integer(FIXNUM x);
-CELL tag_cell(CELL x);
-CELL to_cell(CELL x);
-
 bool realp(CELL tagged);
 void primitive_numberp(void);
 

diff --git a/native/bignum.c b/native/bignum.c
index 74270ef30223316b43405679ac438524f5c98d47..b07aba451630c082af007d28deda61a8991b9669 100644 (file)
--- a/native/bignum.c
+++ b/native/bignum.c
@@ -1,5 +1,31 @@
 #include "factor.h"
 
+FIXNUM to_integer(CELL x)
+{
+       switch(type_of(x))
+       {
+       case FIXNUM_TYPE:
+               return untag_fixnum_fast(x);
+       case BIGNUM_TYPE:
+               return s48_bignum_to_long(untag_bignum(x));
+       default:
+               type_error(INTEGER_TYPE,x);
+               return 0;
+       }
+}
+
+/* FFI calls this */
+void box_integer(FIXNUM integer)
+{
+       dpush(tag_integer(integer));
+}
+
+/* FFI calls this */
+FIXNUM unbox_integer(void)
+{
+       return to_integer(dpop());
+}
+
 ARRAY* to_bignum(CELL tagged)
 {
        RATIO* r;

diff --git a/native/bignum.h b/native/bignum.h
index 519d5c37dd753b516970c66f90df0f234ee02b42..143d6fc6d7c1afe605f5260c44a40d40b2aeadf8 100644 (file)
--- a/native/bignum.h
+++ b/native/bignum.h
@@ -8,6 +8,9 @@ INLINE ARRAY* untag_bignum(CELL tagged)
        return (ARRAY*)UNTAG(tagged);
 }
 
+FIXNUM to_integer(CELL x);
+void box_integer(FIXNUM integer);
+FIXNUM unbox_integer(void);
 ARRAY* to_bignum(CELL tagged);
 void primitive_to_bignum(void);
 void primitive_bignum_eq(void);
@@ -28,3 +31,19 @@ void primitive_bignum_greater(void);
 void primitive_bignum_greatereq(void);
 void primitive_bignum_not(void);
 void copy_bignum_constants(void);
+
+INLINE CELL tag_integer(FIXNUM x)
+{
+       if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+               return tag_object(s48_long_to_bignum(x));
+       else
+               return tag_fixnum(x);
+}
+
+INLINE CELL tag_cell(CELL x)
+{
+       if(x > FIXNUM_MAX)
+               return tag_object(s48_ulong_to_bignum(x));
+       else
+               return tag_fixnum(x);
+}

diff --git a/native/compiler.c b/native/compiler.c
index 13b088802cbfb014a48b229b5a9b503565d15137..d6da2b1f394d415d3f34775feb7fb609e414a021 100644 (file)
--- a/native/compiler.c
+++ b/native/compiler.c
@@ -14,7 +14,7 @@ void check_compiled_offset(CELL offset)
 
 void primitive_set_compiled_byte(void)
 {
-       CELL offset = to_cell(dpop());
+       CELL offset = unbox_integer();
        BYTE b = to_fixnum(dpop());
        check_compiled_offset(offset);
        bput(offset,b);
@@ -22,7 +22,7 @@ void primitive_set_compiled_byte(void)
 
 void primitive_set_compiled_cell(void)
 {
-       CELL offset = to_cell(dpop());
+       CELL offset = unbox_integer();
        CELL c = to_fixnum(dpop());
        check_compiled_offset(offset);
        put(offset,c);
@@ -30,24 +30,24 @@ void primitive_set_compiled_cell(void)
 
 void primitive_compiled_offset(void)
 {
-       dpush(tag_integer(compiling.here));
+       box_integer(compiling.here);
 }
 
 void primitive_set_compiled_offset(void)
 {
-       CELL offset = to_cell(dpop());
+       CELL offset = unbox_integer();
        check_compiled_offset(offset);
        compiling.here = offset;
 }
 
 void primitive_literal_top(void)
 {
-       dpush(tag_integer(literal_top));
+       box_integer(literal_top);
 }
 
 void primitive_set_literal_top(void)
 {
-       CELL offset = to_cell(dpop());
+       CELL offset = unbox_integer();
        check_compiled_offset(offset);
        literal_top = offset;
 }

diff --git a/native/ffi.c b/native/ffi.c
index 222c0100e7ff38a1701eeb846aa0c2146f1c971d..8b600b42514f7b8d21c81b0526f8f054b76841f9 100644 (file)
--- a/native/ffi.c
+++ b/native/ffi.c
@@ -3,8 +3,8 @@
 void primitive_dlopen(void)
 {
 #ifdef FFI
-       char* path = to_c_string(untag_string(dpop()));
-       void* dllptr = dlopen(path,RTLD_NOW);
+       char* path = unbox_c_string();
+       void* dllptr = dlopen(path,RTLD_LAZY);
        DLL* dll;
 
        if(dllptr == NULL)
@@ -25,7 +25,7 @@ void primitive_dlsym(void)
 {
 #ifdef FFI
        DLL* dll = untag_dll(dpop());
-       void* sym = dlsym(dll->dll,to_c_string(untag_string(dpop())));
+       void* sym = dlsym(dll->dll,unbox_c_string());
        if(sym == NULL)
        {
                general_error(ERROR_FFI,tag_object(
@@ -40,7 +40,7 @@ void primitive_dlsym(void)
 void primitive_dlsym_self(void)
 {
 #ifdef FFI
-       void* sym = dlsym(NULL,to_c_string(untag_string(dpop())));
+       void* sym = dlsym(NULL,unbox_c_string());
        if(sym == NULL)
        {
                general_error(ERROR_FFI,tag_object(
@@ -66,3 +66,91 @@ void primitive_dlclose(void)
        general_error(ERROR_FFI_DISABLED,F);
 #endif
 }
+
+void primitive_alien(void)
+{
+#ifdef FFI
+       CELL length = unbox_integer();
+       CELL ptr = unbox_integer();
+       ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+       alien->ptr = ptr;
+       alien->length = length;
+       dpush(tag_object(alien));
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+INLINE CELL alien_pointer(void)
+{
+       FIXNUM offset = unbox_integer();
+       ALIEN* alien = untag_alien(dpop());
+       if(offset < 0 || offset >= alien->length)
+       {
+               range_error(tag_object(alien),offset,alien->length);
+               return 0; /* can't happen */
+       }
+       else
+               return alien->ptr + offset;
+}
+
+void primitive_alien_cell(void)
+{
+#ifdef FFI
+       box_integer(get(alien_pointer()));
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+void primitive_set_alien_cell(void)
+{
+#ifdef FFI
+       CELL ptr = alien_pointer();
+       CELL value = unbox_integer();
+       put(ptr,value);
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+void primitive_alien_4(void)
+{
+#ifdef FFI
+       CELL ptr = alien_pointer();
+       box_integer(*(int*)ptr);
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+void primitive_set_alien_4(void)
+{
+#ifdef FFI
+       CELL ptr = alien_pointer();
+       CELL value = unbox_integer();
+       *(int*)ptr = value;
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+void primitive_alien_1(void)
+{
+#ifdef FFI
+       box_integer(bget(alien_pointer()));
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+void primitive_set_alien_1(void)
+{
+#ifdef FFI
+       CELL ptr = alien_pointer();
+       BYTE value = value = unbox_integer();
+       bput(ptr,value);
+#else
+       general_error(ERROR_FFI_DISABLED,F);
+#endif
+}

diff --git a/native/ffi.h b/native/ffi.h
index 50f6c1e2bec9953d05f3d2dde26e165a7e96e3fa..90309ec00a08db5a91abe7ce11bd4be9a9d258b8 100644 (file)
--- a/native/ffi.h
+++ b/native/ffi.h
@@ -9,7 +9,26 @@ INLINE DLL* untag_dll(CELL tagged)
        return (DLL*)UNTAG(tagged);
 }
 
+typedef struct {
+       CELL header;
+       CELL ptr;
+       CELL length;
+} ALIEN;
+
+INLINE ALIEN* untag_alien(CELL tagged)
+{
+       type_check(ALIEN_TYPE,tagged);
+       return (ALIEN*)UNTAG(tagged);
+}
+
 void primitive_dlopen(void);
 void primitive_dlsym(void);
 void primitive_dlsym_self(void);
 void primitive_dlclose(void);
+void primitive_alien(void);
+void primitive_alien_cell(void);
+void primitive_set_alien_cell(void);
+void primitive_alien_4(void);
+void primitive_set_alien_4(void);
+void primitive_alien_1(void);
+void primitive_set_alien_1(void);

diff --git a/native/file.c b/native/file.c
index cb88d026f1f20a8dd199fe2b42fe8396cba738e6..6305393bb30f116c2e842613c6b9e9128afb4122 100644 (file)
--- a/native/file.c
+++ b/native/file.c
@@ -4,7 +4,7 @@ void primitive_open_file(void)
 {
        bool write = untag_boolean(dpop());
        bool read = untag_boolean(dpop());
-       char* path = to_c_string(untag_string(dpop()));
+       char* path = unbox_c_string();
        int mode;
        int fd;
 
@@ -75,10 +75,10 @@ void primitive_cwd(void)
        char wd[MAXPATHLEN];
        if(getcwd(wd,MAXPATHLEN) < 0)
                io_error(__FUNCTION__);
-       dpush(tag_object(from_c_string(wd)));
+       box_c_string(wd);
 }
 
 void primitive_cd(void)
 {
-       chdir(to_c_string(untag_string(dpop())));
+       chdir(unbox_c_string());
 }

diff --git a/native/fixnum.c b/native/fixnum.c
index 3ce39ed587383bfebf3d08a4ddec1fabcb4fcf11..f8c4a14e4705384458ab5af6003bbb46b00321a7 100644 (file)
--- a/native/fixnum.c
+++ b/native/fixnum.c
@@ -43,14 +43,14 @@ void primitive_fixnum_add(void)
 {
        FIXNUM y = to_fixnum(dpop());
        FIXNUM x = to_fixnum(dpop());
-       dpush(tag_integer(x + y));
+       box_integer(x + y);
 }
 
 void primitive_fixnum_subtract(void)
 {
        FIXNUM y = to_fixnum(dpop());
        FIXNUM x = to_fixnum(dpop());
-       dpush(tag_integer(x - y));
+       box_integer(x - y);
 }
 
 /**
@@ -69,7 +69,7 @@ void primitive_fixnum_multiply(void)
                FIXNUM prod = x * y;
                /* if this is not equal, we have overflow */
                if(prod / x == y)
-                       dpush(tag_integer(prod));
+                       box_integer(prod);
                else
                {
                        dpush(tag_object(
@@ -84,7 +84,7 @@ void primitive_fixnum_divint(void)
 {
        FIXNUM y = to_fixnum(dpop());
        FIXNUM x = to_fixnum(dpop());
-       dpush(tag_integer(x / y));
+       box_integer(x / y);
 }
 
 void primitive_fixnum_divfloat(void)
@@ -98,8 +98,8 @@ void primitive_fixnum_divmod(void)
 {
        FIXNUM y = to_fixnum(dpop());
        FIXNUM x = to_fixnum(dpop());
-       dpush(tag_integer(x / y));
-       dpush(tag_integer(x % y));
+       box_integer(x / y);
+       box_integer(x % y);
 }
 
 void primitive_fixnum_mod(void)

diff --git a/native/float.c b/native/float.c
index 4e05e15aad79f0f82ae7845b79aeb769e6681587..940533dceb1128c9d06c5095d9344e55cdee848e 100644 (file)
--- a/native/float.c
+++ b/native/float.c
@@ -44,9 +44,9 @@ void primitive_str_to_float(void)
 void primitive_float_to_str(void)
 {
        char tmp[33];
-       snprintf(tmp,32,"%.16g",to_float(dpeek()));
+       snprintf(tmp,32,"%.16g",to_float(dpop()));
        tmp[32] = '\0';
-       drepl(tag_object(from_c_string(tmp)));
+       box_c_string(tmp);
 }
 
 void primitive_float_to_bits(void)

diff --git a/native/memory.c b/native/memory.c
index 97125da68bc2d3f624ba26c24df6cfc418295619..ac47fb20f11b8d68e564c27c8e33bf070d20e756 100644 (file)
--- a/native/memory.c
+++ b/native/memory.c
@@ -93,8 +93,8 @@ bool in_zone(ZONE* z, CELL pointer)
 void primitive_room(void)
 {
        /* push: free total */
-       dpush(tag_integer(active.limit - active.here));
-       dpush(tag_integer(active.limit - active.base));
+       box_integer(active.limit - active.here);
+       box_integer(active.limit - active.base);
 }
 
 void primitive_allot_profiling(void)

diff --git a/native/memory.h b/native/memory.h
index 1c3b0d9917a22746d85259ce8011be33b3ef9585..816139c926d9ad7360971f498b75bc9d56256f46 100644 (file)
--- a/native/memory.h
+++ b/native/memory.h
@@ -70,3 +70,9 @@ bool in_zone(ZONE* z, CELL pointer);
 void primitive_room(void);
 void primitive_allot_profiling(void);
 void primitive_address(void);
+void primitive_memory_cell(void);
+void primitive_memory_4(void);
+void primitive_memory_1(void);
+void primitive_set_memory_cell(void);
+void primitive_set_memory_4(void);
+void primitive_set_memory_1(void);

diff --git a/native/misc.c b/native/misc.c
index ddc6bf1bc79609baf90f328cc78f2fc66729d9aa..8e6822f8a643e36d3a830a6b7feadc89a0a5268a 100644 (file)
--- a/native/misc.c
+++ b/native/misc.c
@@ -7,12 +7,12 @@ void primitive_exit(void)
 
 void primitive_os_env(void)
 {
-       char* name = to_c_string(untag_string(dpeek()));
+       char* name = unbox_c_string();
        char* value = getenv(name);
        if(value == NULL)
-               drepl(F);
+               dpush(F);
        else
-               drepl(tag_object(from_c_string(getenv(name))));
+               box_c_string(getenv(name));
 }
 
 void primitive_eq(void)

diff --git a/native/primitives.c b/native/primitives.c
index 78b09d1b8c0cf2549286aaeb82446d0931ee7064..52012aceb7822dc42519f2c99cb46e6e40d40770 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -171,17 +171,24 @@ XT primitives[] = {
        primitive_dump,
        primitive_cwd,
        primitive_cd,
-       primitive_set_compiled_byte,
-       primitive_set_compiled_cell,
        primitive_compiled_offset,
        primitive_set_compiled_offset,
+       primitive_set_compiled_cell,
+       primitive_set_compiled_byte,
        primitive_literal_top,
        primitive_set_literal_top,
        primitive_address,
        primitive_dlopen,
        primitive_dlsym,
        primitive_dlsym_self,
-       primitive_dlclose
+       primitive_dlclose,
+       primitive_alien,
+       primitive_alien_cell,
+       primitive_set_alien_cell,
+       primitive_alien_4,
+       primitive_set_alien_4,
+       primitive_alien_1,
+       primitive_set_alien_1
 };
 
 CELL primitive_to_xt(CELL primitive)

diff --git a/native/primitives.h b/native/primitives.h
index 2efce88b0d1de848d3e60a31599a2427200e05d8..7698bf623a20e3c4586a4875943444375e7f4e91 100644 (file)
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 181
+#define PRIMITIVE_COUNT 188
 
 CELL primitive_to_xt(CELL primitive);

diff --git a/native/socket.c b/native/socket.c
index f1ca82e91498396d09c9fdfeeb9a930ff4016933..3919fc8d1a5d66ed3c430c1261792db45b1054b8 100644 (file)
--- a/native/socket.c
+++ b/native/socket.c
@@ -45,7 +45,7 @@ int make_client_socket(const char* hostname, uint16_t port)
 void primitive_client_socket(void)
 {
        uint16_t p = (uint16_t)to_fixnum(dpop());
-       char* host = to_c_string(untag_string(dpop()));
+       char* host = unbox_c_string();
        int sock = make_client_socket(host,p);
        dpush(tag_object(port(PORT_RECV,sock)));
        dpush(tag_object(port(PORT_WRITE,sock)));

diff --git a/native/string.c b/native/string.c
index d77baa0f76d7d2e933d8e854081bcb10b5fca5c8..a3102a99703f00db75f05d7c66ab68af26041059 100644 (file)
--- a/native/string.c
+++ b/native/string.c
@@ -71,6 +71,12 @@ STRING* from_c_string(const BYTE* c_string)
        return s;
 }
 
+/* FFI calls this */
+void box_c_string(const BYTE* c_string)
+{
+       dpush(tag_object(from_c_string(c_string)));
+}
+
 /* untagged */
 BYTE* to_c_string(STRING* s)
 {
@@ -92,6 +98,12 @@ BYTE* to_c_string(STRING* s)
        return c_str;
 }
 
+/* FFI calls this */
+BYTE* unbox_c_string(void)
+{
+       return to_c_string(untag_string(dpop()));
+}
+
 void primitive_string_length(void)
 {
        drepl(tag_fixnum(untag_string(dpeek())->capacity));

diff --git a/native/string.h b/native/string.h
index 154fcb9c572ffb6cc98620086bc2ad053feab38d..7191468b6a87d31942d99594b9357a99328ac555 100644 (file)
--- a/native/string.h
+++ b/native/string.h
@@ -17,7 +17,9 @@ STRING* string(FIXNUM capacity, CELL fill);
 void hash_string(STRING* str);
 STRING* grow_string(STRING* string, FIXNUM capacity, CHAR fill);
 BYTE* to_c_string(STRING* s);
+void box_c_string(const BYTE* c_string);
 STRING* from_c_string(const BYTE* c_string);
+BYTE* unbox_c_string(void);
 
 #define SREF(string,index) ((CELL)string + sizeof(STRING) + index * CHARS)
 

diff --git a/native/types.c b/native/types.c
index 57a7393c8dd73d3ecfb45e1e763dba229289b159..0504cdb2951dfe93ad9c39e3c7deaaba3eb21c38 100644 (file)
--- a/native/types.c
+++ b/native/types.c
@@ -100,6 +100,9 @@ CELL untagged_object_size(CELL pointer)
        case DLL_TYPE:
                size = sizeof(DLL);
                break;
+       case ALIEN_TYPE:
+               size = sizeof(ALIEN);
+               break;
        default:
                critical_error("Cannot determine size",relocating);
                size = -1;/* can't happen */

diff --git a/native/types.h b/native/types.h
index 2291f6ed7a77dead908a9dec38d0592f727c7888..b75fcaadc7e87773c5f90a76cb005d751ca3503d 100644 (file)
--- a/native/types.h
+++ b/native/types.h
@@ -32,6 +32,7 @@ CELL T;
 #define BIGNUM_TYPE 13
 #define FLOAT_TYPE 14
 #define DLL_TYPE 15
+#define ALIEN_TYPE 16
 
 /* Pseudo-types. For error reporting only. */
 #define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */

diff --git a/native/word.c b/native/word.c
index cebb1109a619be72ff725b5a8b20a1729f1322f0..f5ce3a2e8a638eb3e4479a228aa14541bc0592ed 100644 (file)
--- a/native/word.c
+++ b/native/word.c
@@ -45,7 +45,7 @@ void primitive_word_xt(void)
 void primitive_set_word_xt(void)
 {
        WORD* word = untag_word(dpop());
-       word->xt = to_cell(dpop());
+       word->xt = unbox_integer();
 }
 
 void primitive_word_primitive(void)