diff --git a/Makefile b/Makefile index 4355f8a245..6d9ffb2200 100644 --- 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 6edc64e24d..2e274e549e 100644 --- a/TODO.FACTOR.txt +++ b/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/) diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index a25eefbd14..76a4689d80 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -45,6 +45,13 @@ DEFER: dlopen DEFER: dlsym DEFER: dlsym-self DEFER: dlclose +DEFER: +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-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 800ef22012..29d0b6a99f 100644 --- 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 c4976afc07..8053ce3aaf 100644 --- 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< ( 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 1031ad8e8e..aa8bb6b7c4 100644 --- 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 -- " ] + [ | " 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 1ccf6147c2..0c61d82de0 100644 --- 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 8d013c2c0e..330a7f1306 100644 --- 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 fd2b6f94fd..8aa16028fb 100644 --- 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 74270ef302..b07aba4516 100644 --- 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 519d5c37dd..143d6fc6d7 100644 --- 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 13b088802c..d6da2b1f39 100644 --- 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 222c0100e7..8b600b4251 100644 --- 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 50f6c1e2be..90309ec00a 100644 --- 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 cb88d026f1..6305393bb3 100644 --- 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 3ce39ed587..f8c4a14e47 100644 --- 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 4e05e15aad..940533dceb 100644 --- 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 97125da68b..ac47fb20f1 100644 --- 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 1c3b0d9917..816139c926 100644 --- 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 ddc6bf1bc7..8e6822f8a6 100644 --- 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 78b09d1b8c..52012aceb7 100644 --- 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 2efce88b0d..7698bf623a 100644 --- 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 f1ca82e914..3919fc8d1a 100644 --- 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 d77baa0f76..a3102a9970 100644 --- 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 154fcb9c57..7191468b6a 100644 --- 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 57a7393c8d..0504cdb295 100644 --- 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 2291f6ed7a..b75fcaadc7 100644 --- 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 cebb1109a6..f5ce3a2e8a 100644 --- 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)