working on the FFI

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
 

TODO.FACTOR.txt

@@ -1,3 +1,6 @@
+FFI:
+- is signed -vs- unsigned pointers an issue?
+
 [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/)
 [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/)
 

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 ;

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 ;
 

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 ;

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

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 ;

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;

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);
 

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;

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);
+}

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;
 }

native/ffi.c

@@ -3,8 +3,8 @@
 void primitive_dlopen(void)
 {
 #ifdef FFI
-	char* path = to_c_string(untag_string(dpop()));
+	char* path = unbox_c_string();
-	void* dllptr = dlopen(path,RTLD_NOW);
+	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
+}

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);

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());
 }

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));
+	box_integer(x / y);
-	dpush(tag_integer(x % y));
+	box_integer(x % y);
 }
 
 void primitive_fixnum_mod(void)

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)

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));
+	box_integer(active.limit - active.here);
-	dpush(tag_integer(active.limit - active.base));
+	box_integer(active.limit - active.base);
 }
 
 void primitive_allot_profiling(void)

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);

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)

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)

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 181
+#define PRIMITIVE_COUNT 188
 
 CELL primitive_to_xt(CELL primitive);

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)));

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));

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)
 

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 */

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 */

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)