From 726710a949279b19bb844bbcfcfeea677dc7a562 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 3 Nov 2006 05:37:51 +0000
Subject: [PATCH] alien>char/u16-string primitives now work correctly if the
 input is a byte array

---
 TODO.FACTOR.txt            |  5 +++--
 library/test/kernel.factor |  2 +-
 vm/data_gc.h               | 24 ++++++++++++++++++++++--
 vm/math.c                  |  2 +-
 vm/run.c                   | 13 ++++++++++---
 vm/types.c                 |  2 ++
 6 files changed, 39 insertions(+), 9 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 00c998b40f..024469b603 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,8 +1,9 @@
 + allot refactoring:
 
 - inline float allocation needs a gc check
-- alien invoke, callback need a gc check
-- make sure alien>ZZZ-string is safe on byte arrays
+- fix alien invoke as required
+  - we can just convert strings to aliens beforehand
+- fix alien callback as required
 
 + ui:
 
diff --git a/library/test/kernel.factor b/library/test/kernel.factor
index 423a4d76c1..59b6fdfc9b 100644
--- a/library/test/kernel.factor
+++ b/library/test/kernel.factor
@@ -12,7 +12,7 @@ sequences test errors math-internals ;
 [ ] [ 268435455 >fixnum 10000000 [ dup dup fixnum+ drop ] times drop ] unit-test
 [ ] [ 10000000 [ drop 1/3 >fixnum drop ] each ] unit-test
 [ ] [ 10000000 [ drop 1/3 >bignum drop ] each ] unit-test
-[ ] [ 10000000 [ drop 1/3 >float drop ] each ] unit-test
+! [ ] [ 10000000 [ drop 1/3 >float drop ] each ] unit-test
 
 ! Don't leak extra roots if error is thrown
 [ ] [ 10000 [ [ -1 f <array> ] catch drop ] times ] unit-test
diff --git a/vm/data_gc.h b/vm/data_gc.h
index e97a38ccf1..4e34f49c3c 100644
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -208,8 +208,28 @@ DEFPUSHPOP(root_,extra_roots)
 #define REGISTER_STRING(obj) root_push(tag_object(obj))
 #define UNREGISTER_STRING(obj) obj = untag_string_fast(root_pop())
 
-#define REGISTER_C_STRING(obj) root_push(tag_object(((F_ARRAY *)obj) - 1))
-#define UNREGISTER_C_STRING(obj) obj = ((char*)(untag_array_fast(root_pop()) + 1))
+/* We ignore strings which point outside the data heap, but we might be given
+a char* which points inside the data heap, in which case it is a root, for
+example if we call unbox_char_string() the result is placed in a byte array */
+INLINE bool root_push_alien(const void *ptr)
+{
+	if((CELL)ptr > data_heap_start && (CELL)ptr < data_heap_end)
+	{
+		F_ARRAY *objptr = ((F_ARRAY *)ptr) - 1;
+		if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
+		{
+			root_push(tag_object(objptr));
+			return true;
+		}
+	}
+
+	return false;
+}
+
+#define REGISTER_C_STRING(obj) \
+	bool obj##_root = root_push_alien(obj)
+#define UNREGISTER_C_STRING(obj) \
+	if(obj##_root) obj = alien_offset(root_pop())
 
 #define REGISTER_BIGNUM(obj) root_push(tag_bignum(obj))
 #define UNREGISTER_BIGNUM(obj) obj = (untag_bignum_fast(root_pop()))
diff --git a/vm/math.c b/vm/math.c
index 77600437ea..b43be01d16 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -190,7 +190,7 @@ void primitive_fixnum_not(void)
 }
 
 #define INT_DEFBOX(name,type) \
-void name (type integer)                                                       \
+void name(type integer)                                                        \
 {                                                                              \
 	dpush(tag_fixnum(integer));                                            \
 }
diff --git a/vm/run.c b/vm/run.c
index 33f2b992d3..c8bcea5eee 100644
--- a/vm/run.c
+++ b/vm/run.c
@@ -7,10 +7,13 @@ INLINE void execute(F_WORD* word)
 
 INLINE void push_callframe(void)
 {
+	put(cs + CELLS,callframe);
+	put(cs + CELLS * 2,callframe_scan);
+	put(cs + CELLS * 3,callframe_end);
+
+	/* update the pointer last, so that if we have a memory protection error
+	above, we don't have garbage stored as live data */
 	cs += CELLS * 3;
-	put(cs - CELLS * 2,callframe);
-	put(cs - CELLS,callframe_scan);
-	put(cs,callframe_end);
 }
 
 INLINE void set_callframe(CELL quot)
@@ -278,6 +281,10 @@ void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks)
 
 void memory_protection_error(CELL addr, int signal)
 {
+	/* this is here to catch GC bugs; see the comment in push_callframe()
+	above */
+	garbage_collection(NURSERY,false);
+
 	if(in_page(addr, ds_bot, 0, -1))
 		general_error(ERROR_DS_UNDERFLOW,F,F,false);
 	else if(in_page(addr, ds_bot, ds_size, 0))
diff --git a/vm/types.c b/vm/types.c
index e70638aae8..51fa4c4ef0 100644
--- a/vm/types.c
+++ b/vm/types.c
@@ -229,7 +229,9 @@ void primitive_resize_string(void)
 #define MEMORY_TO_STRING(type,utype) \
 	F_STRING *memory_to_##type##_string(const type *string, CELL length) \
 	{ \
+		REGISTER_C_STRING(string); \
 		F_STRING* s = allot_string_internal(length); \
+		UNREGISTER_C_STRING(string); \
 		CELL i; \
 		for(i = 0; i < length; i++) \
 		{ \