VM changes for record1 strings

vm/code_heap.c

@@ -176,7 +176,7 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format)
 	{
 		F_FIXNUM value = to_fixnum(array_nth(array,i));
 		if(format == 1)
-			cput(here + i,value);
+			bput(here + i,value);
 		else if(format == sizeof(unsigned int))
 			*(unsigned int *)(here + format * i) = value;
 		else if(format == CELLS)

vm/layouts.h

@@ -19,9 +19,6 @@ typedef signed long long s64;
 
 #define CELLS ((signed)sizeof(CELL))
 
-/* must always be 16 bits */
-#define CHARS ((signed)sizeof(u16))
-
 #define WORD_SIZE (CELLS*8)
 #define HALF_WORD_SIZE (CELLS*4)
 #define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)

vm/primitives.c

@@ -152,8 +152,8 @@ void *primitives[] = {
 	primitive_alien_address,
 	primitive_slot,
 	primitive_set_slot,
-	primitive_char_slot,
+	primitive_string_nth,
-	primitive_set_char_slot,
+	primitive_set_string_nth,
 	primitive_resize_array,
 	primitive_resize_string,
 	primitive_array,

vm/run.h

@@ -74,16 +74,26 @@ INLINE void put(CELL where, CELL what)
 	*((CELL*)where) = what;
 }
 
-INLINE u16 cget(CELL where)
+INLINE CELL cget(CELL where)
 {
 	return *((u16 *)where);
 }
 
-INLINE void cput(CELL where, u16 what)
+INLINE void cput(CELL where, CELL what)
 {
 	*((u16 *)where) = what;
 }
 
+INLINE CELL bget(CELL where)
+{
+	return *((u8 *)where);
+}
+
+INLINE void bput(CELL where, CELL what)
+{
+	*((u8 *)where) = what;
+}
+
 INLINE CELL align(CELL a, CELL b)
 {
 	return (a + b) & ~b;

vm/types.c

@@ -419,29 +419,58 @@ DEFINE_PRIMITIVE(to_tuple)
 }
 
 /* Strings */
+CELL string_nth(F_STRING* string, CELL index)
+{
+	CELL ch = bget(SREF(string,index));
+	if(string->aux == F)
+		return ch;
+	else
+	{
+		F_BYTE_ARRAY *aux = untag_object(string->aux);
+		return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch;
+	}
+}
+
+void set_string_nth(F_STRING* string, CELL index, CELL value)
+{
+	bput(SREF(string,index),value & 0xff);
+
+	if(string->aux == F)
+	{
+		if(value <= 0xff)
+			return;
+		else
+		{
+			string->aux = tag_object(allot_byte_array(
+				untag_fixnum_fast(string->length)
+				* sizeof(u16)));
+		}
+	}
+
+	F_BYTE_ARRAY *aux = untag_object(string->aux);
+	cput(BREF(aux,index * sizeof(u16)),value >> 8);
+}
 
 /* untagged */
 F_STRING* allot_string_internal(CELL capacity)
 {
-	F_STRING* string = allot_object(STRING_TYPE,
+	F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
-		sizeof(F_STRING) + (capacity + 1) * CHARS);
 
 	/* strings are null-terminated in memory, even though they also
 	have a length field. The null termination allows us to add
 	the sizeof(F_STRING) to a Factor string to get a C-style
 	char* string for C library calls. */
-	set_string_nth(string,capacity,0);
 	string->length = tag_fixnum(capacity);
 	string->hashcode = F;
 	string->aux = F;
+	set_string_nth(string,capacity,0);
 	return string;
 }
 
 void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
 {
 	if(fill == 0)
-		memset((void*)SREF(string,start),'\0',
+		memset((void*)SREF(string,start),'\0',capacity - start);
-			(capacity - start) * CHARS);
 	else
 	{
 		CELL i;
@@ -466,7 +495,7 @@ DEFINE_PRIMITIVE(string)
 	dpush(tag_object(allot_string(length,initial)));
 }
 
-F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill)
+F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
 {
 	CELL to_copy = string_capacity(string);
 	if(capacity < to_copy)
@@ -476,7 +505,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill)
 	F_STRING *new_string = allot_string_internal(capacity);
 	UNREGISTER_UNTAGGED(string);
 
-	memcpy(new_string + 1,string + 1,to_copy * CHARS);
+	memcpy(new_string + 1,string + 1,to_copy);
 	fill_string(new_string,to_copy,capacity,fill);
 
 	return new_string;
@@ -530,7 +559,7 @@ bool check_string(F_STRING *s, CELL max)
 	CELL i;
 	for(i = 0; i < capacity; i++)
 	{
-		u16 ch = string_nth(s,i);
+		CELL ch = string_nth(s,i);
 		if(ch == '\0' || ch >= (1 << (max * 8)))
 			return false;
 	}
@@ -572,7 +601,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
 	} \
 	type *to_##type##_string(F_STRING *s, bool check) \
 	{ \
-		if(sizeof(type) == sizeof(u16)) \
+		if(sizeof(type) == sizeof(char)) \
 		{ \
 			if(check && !check_string(s,sizeof(type))) \
 				general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
@@ -597,14 +626,14 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
 STRING_TO_MEMORY(char);
 STRING_TO_MEMORY(u16);
 
-DEFINE_PRIMITIVE(char_slot)
+DEFINE_PRIMITIVE(string_nth)
 {
 	F_STRING *string = untag_object(dpop());
 	CELL index = untag_fixnum_fast(dpop());
 	dpush(tag_fixnum(string_nth(string,index)));
 }
 
-DEFINE_PRIMITIVE(set_char_slot)
+DEFINE_PRIMITIVE(set_string_nth)
 {
 	F_STRING *string = untag_object(dpop());
 	CELL index = untag_fixnum_fast(dpop());

vm/types.h

@@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str)
 
 INLINE CELL string_size(CELL size)
 {
-	return sizeof(F_STRING) + (size + 1) * CHARS;
+	return sizeof(F_STRING) + size + 1;
 }
 
 DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
@@ -83,7 +83,8 @@ INLINE CELL array_capacity(F_ARRAY* array)
 	return array->capacity >> TAG_BITS;
 }
 
-#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS)
+#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + index)
+#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index)
 
 INLINE F_STRING* untag_string(CELL tagged)
 {
@@ -91,16 +92,6 @@ INLINE F_STRING* untag_string(CELL tagged)
 	return untag_object(tagged);
 }
 
-INLINE CELL string_nth(F_STRING* string, CELL index)
-{
-	return cget(SREF(string,index));
-}
-
-INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
-{
-	cput(SREF(string,index),value);
-}
-
 DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
 
 DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
@@ -141,7 +132,7 @@ DECLARE_PRIMITIVE(resize_float_array);
 F_STRING* allot_string_internal(CELL capacity);
 F_STRING* allot_string(CELL capacity, CELL fill);
 DECLARE_PRIMITIVE(string);
-F_STRING *reallot_string(F_STRING *string, CELL capacity, u16 fill);
+F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill);
 DECLARE_PRIMITIVE(resize_string);
 
 F_STRING *memory_to_char_string(const char *string, CELL length);
@@ -166,8 +157,12 @@ u16* to_u16_string(F_STRING *s, bool check);
 DLLEXPORT u16 *unbox_u16_string(void);
 DECLARE_PRIMITIVE(string_to_u16_alien);
 
-DECLARE_PRIMITIVE(char_slot);
+/* String getters and setters */
-DECLARE_PRIMITIVE(set_char_slot);
+CELL string_nth(F_STRING* string, CELL index);
+void set_string_nth(F_STRING* string, CELL index, CELL value);
+
+DECLARE_PRIMITIVE(string_nth);
+DECLARE_PRIMITIVE(set_string_nth);
 
 F_WORD *allot_word(CELL vocab, CELL name);
 DECLARE_PRIMITIVE(word);