diff --git a/CHANGES.html b/CHANGES.html
index caf459f15e..e15a7c36a1 100644
--- a/CHANGES.html
+++ b/CHANGES.html
@@ -25,6 +25,13 @@
rather than an association list for specifying style information.
+
C library interface:
+
+
+Added a pair of words for between Factor strings and C strings, alien>string
and string>alien
.
+
+
+
Compiler changes:
diff --git a/library/alien/primitive-types.factor b/library/alien/primitive-types.factor
index 8b4b93c7c1..c9cf7424a8 100644
--- a/library/alien/primitive-types.factor
+++ b/library/alien/primitive-types.factor
@@ -103,8 +103,11 @@ math namespaces ;
] "uchar" define-primitive-type
[
- [ alien-c-string ] "getter" set
- [ set-alien-c-string ] "setter" set
+ [ alien-unsigned-cell alien>string ] "getter" set
+ [
+ >r >r string>alien alien-address r> r>
+ set-alien-unsigned-cell
+ ] "setter" set
cell "width" set
cell "align" set
"box_c_string" "boxer" set
diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index 22708dfdc9..bdebbb7f07 100644
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -176,8 +176,8 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
{ "set-alien-float" "alien" }
{ "alien-double" "alien" }
{ "set-alien-double" "alien" }
- { "alien-c-string" "alien" }
- { "set-alien-c-string" "alien" }
+ { "alien>string" "alien" }
+ { "string>alien" "alien" }
{ "throw" "errors" }
{ "string>memory" "kernel-internals" }
{ "memory>string" "kernel-internals" }
diff --git a/library/compiler/ppc/fixnum.factor b/library/compiler/ppc/fixnum.factor
index 8d26dc9118..3f1b5cd41f 100644
--- a/library/compiler/ppc/fixnum.factor
+++ b/library/compiler/ppc/fixnum.factor
@@ -11,7 +11,7 @@ math-internals memory namespaces words ;
>r >r
"end" set
"end" get BNO
- r> execute
+ >3-vop< r> execute
0 input-operand dup untag-fixnum
1 input-operand dup untag-fixnum
>3-vop< r> execute
@@ -34,8 +34,9 @@ M: %fixnum* generate-node ( vop -- )
0 MTXER
0 scratch 0 input-operand 1 input-operand MULLWO.
"end" get BNO
- >3-vop< MULHW
- 4 0 scratch MR
+ 1 scratch 0 input-operand 1 input-operand MULHW
+ 4 1 scratch MR
+ 3 0 scratch MR
"s48_long_pair_to_bignum" f compile-c-call
! now we have to shift it by three bits to remove the second
! tag
@@ -47,8 +48,11 @@ M: %fixnum* generate-node ( vop -- )
0 output-operand 0 scratch MR ;
: generate-fixnum/i
- ! divide in2 by in1, store result in out1
- 0 scratch 0 input-operand 1 input-operand DIVW
+ #! This VOP is funny. If there is an overflow, it falls
+ #! through to the end, and the result is in 0 output-operand.
+ #! Otherwise it jumps to the "no-overflow" label and the
+ #! result is in 0 scratch.
+ 0 scratch 1 input-operand 0 input-operand DIVW
! if the result is greater than the most positive fixnum,
! which can only ever happen if we do
! most-negative-fixnum -1 /i, then the result is a bignum.
@@ -57,9 +61,9 @@ M: %fixnum* generate-node ( vop -- )
most-positive-fixnum 1 scratch LOAD
0 scratch 0 1 scratch CMP
"no-overflow" get BLE
- most-negative-fixnum neg 0 output-operand LOAD
+ most-negative-fixnum neg 3 LOAD
"s48_long_to_bignum" f compile-c-call
- 0 output-operand dup bignum-tag ORI ;
+ 3 dup bignum-tag ORI ;
M: %fixnum/i generate-node ( vop -- )
#! This has specific vreg requirements.
@@ -72,26 +76,29 @@ M: %fixnum/i generate-node ( vop -- )
: generate-fixnum-mod
#! PowerPC doesn't have a MOD instruction; so we compute
- #! x-(x/y)*y.
- 0 scratch 0 output-operand 0 input-operand MULLW
- 1 scratch 0 scratch 1 input-operand SUBF ;
+ #! x-(x/y)*y. Puts the result in 1 scratch.
+ 1 scratch 0 scratch 0 input-operand MULLW
+ 1 scratch 1 scratch 1 input-operand SUBF ;
M: %fixnum-mod generate-node ( vop -- )
- #! This has specific vreg requirements.
drop
! divide in2 by in1, store result in out1
- >3-vop< DIVW
- generate-fixnum-mod ;
+ 0 scratch 1 input-operand 0 input-operand DIVW
+ generate-fixnum-mod
+ 0 output-operand 1 scratch MR ;
M: %fixnum/mod generate-node ( vop -- )
- #! This has specific vreg requirements.
+ #! This has specific vreg requirements. Note: if there's an
+ #! overflow, (most-negative-fixnum 1 /mod) the modulus is
+ #! always zero.
drop
generate-fixnum/i
- 0 1 scratch LI
+ 0 0 output-operand LI
"end" get B
"no-overflow" get save-xt
generate-fixnum-mod
- 0 output-operand 1 output-operand tag-fixnum
+ 0 scratch 1 output-operand tag-fixnum
+ 0 output-operand 1 scratch MR
"end" get save-xt ;
M: %fixnum-bitand generate-node ( vop -- ) drop >3-vop< AND ;
@@ -130,7 +137,8 @@ M: %fixnum<< generate-node ( vop -- )
"end" get save-xt ;
M: %fixnum>> generate-node ( vop -- )
- 0 output-operand 1 input-operand 0 output-operand SRAWI
+ drop
+ 1 input-operand 0 output-operand 0 input SRAWI
0 output-operand dup untag ;
M: %fixnum-sgn generate-node ( vop -- )
diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor
index 789f199dc9..2b4946a410 100644
--- a/library/compiler/ppc/generator.factor
+++ b/library/compiler/ppc/generator.factor
@@ -5,7 +5,7 @@ USING: alien assembler compiler inference kernel
kernel-internals lists math memory namespaces words ;
: compile-dlsym ( symbol dll register -- )
- >r 2dup dlsym r> LOAD32 rel-2-2 rel-dlsym ;
+ >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
: compile-c-call ( symbol dll -- )
11 [ compile-dlsym ] keep MTLR BLRL ;
@@ -60,10 +60,11 @@ M: %jump-label generate-node ( vop -- )
drop label B ;
M: %jump-t generate-node ( vop -- )
- drop 0 input-operand 0 swap f address CMPI vop-label BNE ;
+ drop 0 input-operand 0 swap f address CMPI label BNE ;
M: %return-to generate-node ( vop -- )
- drop label 0 3 LOAD32 absolute-2/2
+ drop
+ label 0 3 LOAD32 absolute-2/2
1 1 stack-increment neg STWU
3 1 stack-increment lr@ STW ;
diff --git a/library/compiler/ppc/slots.factor b/library/compiler/ppc/slots.factor
index 65af9d6539..1fb08f27ed 100644
--- a/library/compiler/ppc/slots.factor
+++ b/library/compiler/ppc/slots.factor
@@ -56,7 +56,7 @@ M: %set-char-slot generate-node ( vop -- )
: userenv ( reg -- )
#! Load the userenv pointer in a virtual register.
- "userenv" f dlsym swap LOAD32 rel-2/2 rel-userenv ;
+ "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
M: %getenv generate-node ( vop -- )
drop 0 output-operand dup dup userenv 0 input cell * LWZ ;
diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor
index b60c9529d1..26d82b3c59 100644
--- a/library/inference/known-words.factor
+++ b/library/inference/known-words.factor
@@ -440,13 +440,15 @@ sequences strings vectors words prettyprint ;
\ alien-double [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
\ alien-double t "flushable" set-word-prop
-\ set-alien-double [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ alien-c-string [ [ c-ptr integer ] [ string ] ] "infer-effect" set-word-prop
-\ alien-c-string t "flushable" set-word-prop
+\ alien>string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
+\ alien>string t "flushable" set-word-prop
+
+\ string>alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
+\ string>alien t "flushable" set-word-prop
-\ set-alien-c-string [ [ string c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop
\ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
+
\ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop
\ slot [ [ object fixnum ] [ object ] ] "infer-effect" set-word-prop
diff --git a/native/alien.c b/native/alien.c
index 95c747e68d..ce78b6ecd7 100644
--- a/native/alien.c
+++ b/native/alien.c
@@ -90,6 +90,18 @@ void primitive_alien_address(void)
box_unsigned_cell((CELL)alien_offset(dpop()));
}
+void primitive_alien_to_string(void)
+{
+ maybe_gc(0);
+ drepl(tag_object(from_c_string(alien_offset(dpeek()))));
+}
+
+void primitive_string_to_alien(void)
+{
+ maybe_gc(0);
+ drepl(tag_object(string_to_alien(untag_string(dpeek()),true)));
+}
+
void fixup_alien(ALIEN* alien)
{
alien->expired = true;
@@ -129,4 +141,3 @@ DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
DEF_ALIEN_SLOT(float,float,float)
DEF_ALIEN_SLOT(double,double,double)
-DEF_ALIEN_SLOT(c_string,char*,c_string)
diff --git a/native/alien.h b/native/alien.h
index 3d608b95e1..931436a4ab 100644
--- a/native/alien.h
+++ b/native/alien.h
@@ -27,6 +27,9 @@ void primitive_alien_address(void);
void* alien_offset(CELL object);
+void primitive_alien_to_string(void);
+void primitive_string_to_alien(void);
+
void fixup_alien(ALIEN* alien);
void fixup_displaced_alien(DISPLACED_ALIEN* d);
void collect_displaced_alien(DISPLACED_ALIEN* d);
@@ -59,5 +62,3 @@ void primitive_alien_float(void);
void primitive_set_alien_float(void);
void primitive_alien_double(void);
void primitive_set_alien_double(void);
-void primitive_alien_c_string(void);
-void primitive_set_alien_c_string(void);
diff --git a/native/debug.c b/native/debug.c
index c1806d4bca..0318fbc0a9 100644
--- a/native/debug.c
+++ b/native/debug.c
@@ -24,7 +24,7 @@ void print_cons(CELL cons)
void print_word(F_WORD* word)
{
if(type_of(word->name) == STRING_TYPE)
- fprintf(stderr,"%s",to_c_string(untag_string(word->name)));
+ fprintf(stderr,"%s",to_c_string(untag_string(word->name),true));
else
{
fprintf(stderr,"#length),
file) == 0)
io_error();
diff --git a/native/misc.h b/native/misc.h
index 71e58fb83e..2a8c7c40d4 100644
--- a/native/misc.h
+++ b/native/misc.h
@@ -5,6 +5,6 @@ s64 current_millis(void);
void primitive_millis(void);
#ifdef WIN32
char *buffer_to_c_string(char *buffer);
-F_STRING *get_error_message();
+F_STRING *get_error_message(void);
DLLEXPORT char *error_message(DWORD id);
#endif
diff --git a/native/primitives.c b/native/primitives.c
index d24833af8f..faa169870b 100644
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -154,8 +154,8 @@ void* primitives[] = {
primitive_set_alien_float,
primitive_alien_double,
primitive_set_alien_double,
- primitive_alien_c_string,
- primitive_set_alien_c_string,
+ primitive_alien_to_string,
+ primitive_string_to_alien,
primitive_throw,
primitive_string_to_memory,
primitive_memory_to_string,
diff --git a/native/string.c b/native/string.c
index 280e157637..b6dbacee7c 100644
--- a/native/string.c
+++ b/native/string.c
@@ -108,19 +108,33 @@ void box_c_string(const char *c_string)
dpush(c_string ? tag_object(from_c_string(c_string)) : F);
}
-/* untagged */
-char *to_c_string(F_STRING *s)
+F_ARRAY *string_to_alien(F_STRING *s, bool check)
{
- CELL i;
CELL capacity = string_capacity(s);
- for(i = 0; i < capacity; i++)
+ F_ARRAY *_c_str;
+
+ if(check)
{
- u16 ch = string_nth(s,i);
- if(ch == '\0' || ch > 255)
- general_error(ERROR_C_STRING,tag_object(s));
+ CELL i;
+ for(i = 0; i < capacity; i++)
+ {
+ u16 ch = string_nth(s,i);
+ if(ch == '\0' || ch > 255)
+ general_error(ERROR_C_STRING,tag_object(s));
+ }
}
- return to_c_string_unchecked(s);
+ _c_str = allot_array(BYTE_ARRAY_TYPE,capacity / CELLS + 1);
+ BYTE *c_str = (BYTE*)(_c_str + 1);
+ string_to_memory(s,c_str);
+ c_str[capacity] = '\0';
+ return _c_str;
+}
+
+/* untagged */
+char *to_c_string(F_STRING *s, bool check)
+{
+ return (char*)(string_to_alien(s,check) + 1);
}
void string_to_memory(F_STRING *s, BYTE *string)
@@ -138,23 +152,12 @@ void primitive_string_to_memory(void)
string_to_memory(str,address);
}
-/* untagged */
-char *to_c_string_unchecked(F_STRING *s)
-{
- CELL capacity = string_capacity(s);
- F_STRING *_c_str = allot_string(capacity / CHARS + 1);
- BYTE *c_str = (BYTE*)(_c_str + 1);
- string_to_memory(s,c_str);
- c_str[capacity] = '\0';
- return (char*)c_str;
-}
-
/* FFI calls this */
char* unbox_c_string(void)
{
CELL str = dpop();
if(type_of(str) == STRING_TYPE)
- return to_c_string(untag_string(str));
+ return to_c_string(untag_string(str),true);
else
return (char*)alien_offset(str);
}
diff --git a/native/string.h b/native/string.h
index b664a75743..4738756859 100644
--- a/native/string.h
+++ b/native/string.h
@@ -35,8 +35,8 @@ void rehash_string(F_STRING* str);
void primitive_rehash_string(void);
F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill);
void primitive_resize_string(void);
-char* to_c_string(F_STRING* s);
-char* to_c_string_unchecked(F_STRING* s);
+F_ARRAY *string_to_alien(F_STRING *s, bool check);
+char* to_c_string(F_STRING* s, bool check);
void string_to_memory(F_STRING* s, BYTE* string);
void primitive_string_to_memory(void);
DLLEXPORT void box_c_string(const char* c_string);
diff --git a/native/unix/ffi.c b/native/unix/ffi.c
index 8009b85937..05302cf3fe 100644
--- a/native/unix/ffi.c
+++ b/native/unix/ffi.c
@@ -9,7 +9,7 @@ void init_ffi(void)
void ffi_dlopen(DLL *dll, bool error)
{
- void *dllptr = dlopen(to_c_string(untag_string(dll->path)), RTLD_LAZY);
+ void *dllptr = dlopen(to_c_string(untag_string(dll->path),true), RTLD_LAZY);
if(dllptr == NULL)
{
@@ -30,7 +30,7 @@ void ffi_dlopen(DLL *dll, bool error)
void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
- void *sym = dlsym(handle,to_c_string(symbol));
+ void *sym = dlsym(handle,to_c_string(symbol,true));
if(sym == NULL)
{
if(error)
diff --git a/native/unix/file.c b/native/unix/file.c
index 3793b6d5bc..628ff069ca 100644
--- a/native/unix/file.c
+++ b/native/unix/file.c
@@ -8,7 +8,7 @@ void primitive_stat(void)
maybe_gc(0);
path = untag_string(dpop());
- if(stat(to_c_string(path),&sb) < 0)
+ if(stat(to_c_string(path,true),&sb) < 0)
dpush(F);
else
{
@@ -36,7 +36,7 @@ void primitive_read_dir(void)
maybe_gc(0);
path = untag_string(dpop());
- dir = opendir(to_c_string(path));
+ dir = opendir(to_c_string(path,true));
if(dir != NULL)
{
struct dirent* file;
diff --git a/native/win32/ffi.c b/native/win32/ffi.c
index aa35f7d6c9..1fc1e58171 100644
--- a/native/win32/ffi.c
+++ b/native/win32/ffi.c
@@ -7,7 +7,7 @@ void init_ffi (void)
void ffi_dlopen (DLL *dll, bool error)
{
HMODULE module;
- char *path = to_c_string(untag_string(dll->path));
+ char *path = to_c_string(untag_string(dll->path,true));
module = LoadLibrary(path);
@@ -26,7 +26,7 @@ void ffi_dlopen (DLL *dll, bool error)
void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error)
{
void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
- to_c_string(symbol));
+ to_c_string(symbol,true));
if (!sym)
{
diff --git a/native/win32/file.c b/native/win32/file.c
index 13e7fc8db8..134841f6d5 100644
--- a/native/win32/file.c
+++ b/native/win32/file.c
@@ -8,7 +8,7 @@ void primitive_stat(void)
maybe_gc(0);
path = untag_string(dpop());
- if(!GetFileAttributesEx(to_c_string(path), GetFileExInfoStandard, &st))
+ if(!GetFileAttributesEx(to_c_string(path,true), GetFileExInfoStandard, &st))
{
dpush(F);
}