hashcodes are now fixnums, added debug.c

Makefile

@@ -23,7 +23,8 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \
 	native/unix/signal.o \
 	native/unix/read.o \
 	native/unix/write.o \
-	native/unix/ffi.o
+	native/unix/ffi.o \
+	native/debug.o
 
 default:
 	@echo "Run 'make' with one of the following parameters:"

library/bootstrap/image.factor

@@ -265,7 +265,7 @@ M: cons ' ( c -- tagged )
     object-tag here-as swap
     string-type >header emit
     dup str-length emit
-    dup hashcode emit
+    dup hashcode fixnum-tag immediate emit
     pack-string
     align-here ;
 
@@ -305,7 +305,7 @@ M: vector ' ( vector -- pointer )
         >r dup vector-length [
             f swap pick set-vector-nth
         ] times* r>
-        [ unswons pick set-hash ] each
+        [ unswons pick set-hash ] each drop
     ] cons cons
     boot-quot [ append ] change ;
 

library/bootstrap/primitives.factor

@@ -61,7 +61,6 @@ vocabularies get [
     [ "strings" | "str-nth" ]
     [ "strings" | "str-compare" ]
     [ "strings" | "str=" ]
-    [ "strings" | "str-hashcode" ]
     [ "strings" | "index-of*" ]
     [ "strings" | "substring" ]
     [ "strings" | "str-reverse" ]

library/hashtables.factor

@@ -105,3 +105,22 @@ PREDICATE: vector hashtable ( obj -- ? )
 
 : alist>hash ( alist -- hash )
     37 <hashtable> swap [ unswons pick set-hash ] each ;
+
+! In case I break hashing:
+
+! : hash* ( key table -- value )
+!     hash>alist assoc* ;
+! 
+! : set-hash ( value key table -- )
+!     dup vector-length [
+!         ( value key table index )
+!         >r 3dup r>
+!         ( value key table value key table index )
+!         [
+!             swap vector-nth
+!             ( value key table value key alist )
+!             set-assoc
+!         ] keep
+!         ( value key table new-assoc index )
+!         pick set-vector-nth
+!     ] times* 3drop ;

library/primitives.factor

@@ -59,7 +59,6 @@ USE: words
     [ str-nth                " n str -- ch "                      [ [ integer string ] [ integer ] ] ]
     [ str-compare            " str str -- -1/0/1 "                [ [ string string ] [ integer ] ] ]
     [ str=                   " str str -- ? "                     [ [ string string ] [ boolean ] ] ]
-    [ str-hashcode           " str -- n "                         [ [ string ] [ integer ] ] ]
     [ index-of*              " n str/ch str -- n "                [ [ integer string text ] [ integer ] ] ]
     [ substring              " start end str -- str "             [ [ integer integer string ] [ string ] ] ]
     [ str-reverse            " str -- str "                       [ [ string ] [ string ] ] ]

library/strings.factor

@@ -34,12 +34,12 @@ USE: math
 
 ! Define methods bound to primitives
 BUILTIN: string 12
-M: string hashcode str-hashcode ;
+M: string hashcode 2 slot ;
 M: string = str= ;
 
 : str-length ( str -- len ) >string 1 integer-slot ; inline
 
-BUILTIN: sbuf   13
+BUILTIN: sbuf 13
 M: sbuf hashcode sbuf-hashcode ;
 M: sbuf = sbuf= ;
 

native/debug.c

@@ -0,0 +1,136 @@
+#include "factor.h"
+
+#ifdef F_DEBUG
+
+bool equals(CELL obj1, CELL obj2)
+{
+	if(type_of(obj1) == STRING_TYPE
+		&& type_of(obj2) == STRING_TYPE)
+	{
+		return string_compare(untag_string(obj1),untag_string(obj2)) == 0;
+	}
+	else
+		return (obj1 == obj2);
+}
+
+CELL assoc(CELL alist, CELL key)
+{
+	if(TAG(alist) != CONS_TYPE)
+	{
+		fprintf(stderr,"Not an alist: %ld\n",alist);
+		return F;
+	}
+
+	{
+		CELL pair = untag_cons(alist)->car;
+		if(TAG(pair) != CONS_TYPE)
+		{
+			fprintf(stderr,"Not a pair: %ld\n",alist);
+			return F;
+		}
+
+		if(equals(untag_cons(pair)->car,key))
+			return untag_cons(pair)->cdr;
+		else
+			return assoc(untag_cons(alist)->cdr,key);
+	}
+}
+
+void print_cons(CELL cons)
+{
+	fprintf(stderr,"[ ");
+
+	do
+	{
+		print_obj(untag_cons(cons)->car);
+		fprintf(stderr," ");
+		cons = untag_cons(cons)->cdr;
+	}
+	while(TAG(cons) == CONS_TYPE);
+
+	if(cons != F)
+	{
+		fprintf(stderr,"| ");
+		print_obj(cons);
+		fprintf(stderr," ");
+	}
+	fprintf(stderr,"]");
+}
+
+void print_word(F_WORD* word)
+{
+	CELL name = assoc(word->plist,tag_object(from_c_string("name")));
+	if(type_of(name) == STRING_TYPE)
+		fprintf(stderr,"%s",to_c_string(untag_string(name)));
+	else
+	{
+		fprintf(stderr,"#<not a string: ");
+		print_obj(name);
+		fprintf(stderr,">");
+	}
+
+	fprintf(stderr," (#%ld)",word->primitive);
+}
+
+void print_string(F_STRING* str)
+{
+	fprintf(stderr,"\"");
+	fprintf(stderr,"%s",to_c_string(str));
+	fprintf(stderr,"\"");
+}
+
+void print_obj(CELL obj)
+{
+	switch(type_of(obj))
+	{
+	case CONS_TYPE:
+		print_cons(obj);
+		break;
+	case WORD_TYPE:
+		print_word(untag_word(obj));
+		break;
+	case STRING_TYPE:
+		print_string(untag_string(obj));
+		break;
+	case F_TYPE:
+		fprintf(stderr,"f");
+		break;
+	default:
+		fprintf(stderr,"#<type %ld @ %ld>",type_of(obj),obj);
+		break;
+	}
+}
+
+void print_stack(CELL* start, CELL* end)
+{
+	while(start < end)
+	{
+		print_obj(*start);
+		fprintf(stderr,"\n");
+		start++;
+	}
+}
+
+void dump_stacks(void)
+{
+	fprintf(stderr,"*** Data stack:\n");
+	print_stack((CELL*)ds_bot,(CELL*)(ds + CELLS));
+	fprintf(stderr,"*** Call stack:\n");
+	print_stack((CELL*)cs_bot,(CELL*)(cs + CELLS));
+	fprintf(stderr,"*** Call frame:\n");
+	print_obj(callframe);
+	fprintf(stderr,"\n");
+	fprintf(stderr,"*** Executing:\n");
+	print_word(executing);
+	fprintf(stderr,"\n");
+	fflush(stderr);
+}
+
+#else
+
+void dump_stacks(void)
+{
+	fprintf(stderr,"Stack dumping disabled -- recompile with F_DEBUG\n");
+}
+
+#endif

native/debug.h

@@ -0,0 +1,9 @@
+#define F_DEBUG 1
+
+CELL assoc(CELL alist, CELL key);
+void print_cons(CELL cons);
+void print_word(F_WORD* word);
+void print_string(F_STRING* str);
+void print_obj(CELL obj);
+void print_stack(CELL* start, CELL* end);
+void dump_stacks(void);

native/error.c

@@ -42,6 +42,9 @@ void early_error(CELL error)
 			fprintf(stderr,"Error: %ld\n",to_fixnum(error));
 		else if(type_of(error) == STRING_TYPE)
 			fprintf(stderr,"Error: %s\n",to_c_string(untag_string(error)));
+
+		dump_stacks();
+
 		fflush(stderr);
 
 		exit(1);

native/factor.h

@@ -139,5 +139,6 @@ typedef unsigned char BYTE;
 #include "compiler.h"
 #include "relocate.h"
 #include "ffi.h"
+#include "debug.h"
 
 #endif /* __FACTOR_H__ */

native/ffi.h

@@ -43,5 +43,6 @@ void primitive_set_alien_2(void);
 void primitive_alien_1(void);
 void primitive_set_alien_1(void);
 void fixup_dll(DLL* dll);
+void collect_dll(DLL* dll);
 void fixup_alien(ALIEN* alien);
 void collect_alien(ALIEN* alien);

native/gc.c

@@ -83,7 +83,7 @@ INLINE void collect_object(CELL scan)
 		collect_alien((ALIEN*)scan);
 		break;
 	case DLL_TYPE:
-		collect_dll((ALIEN*)scan);
+		collect_dll((DLL*)scan);
 		break;
 	}
 }

native/primitives.c

@@ -14,7 +14,6 @@ XT primitives[] = {
 	primitive_string_nth,
 	primitive_string_compare,
 	primitive_string_eq,
-	primitive_string_hashcode,
 	primitive_index_of,
 	primitive_substring,
 	primitive_string_reverse,

native/string.c

@@ -23,7 +23,7 @@ F_FIXNUM hash_string(F_STRING* str, CELL len)
 
 void rehash_string(F_STRING* str)
 {
-	str->hashcode = hash_string(str,str->capacity);
+	str->hashcode = tag_fixnum(hash_string(str,str->capacity));
 }
 
 /* untagged */
@@ -203,11 +203,6 @@ void primitive_string_eq(void)
 		dpush(F);
 }
 
-void primitive_string_hashcode(void)
-{
-	drepl(tag_fixnum(untag_string(dpeek())->hashcode));
-}
-
 CELL index_of_ch(CELL index, F_STRING* string, CELL ch)
 {
 	while(index < string->capacity)

native/string.h

@@ -2,8 +2,8 @@ typedef struct {
 	CELL header;
 	/* untagged */
 	CELL capacity;
-	/* untagged */
+	/* tagged */
-	F_FIXNUM hashcode;
+	CELL hashcode;
 } F_STRING;
 
 INLINE F_STRING* untag_string(CELL tagged)
@@ -47,7 +47,6 @@ F_FIXNUM string_compare_head(F_STRING* s1, F_STRING* s2, CELL len);
 F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2);
 void primitive_string_compare(void);
 void primitive_string_eq(void);
-void primitive_string_hashcode(void);
 void primitive_index_of(void);
 void primitive_substring(void);
 void string_reverse(F_STRING* s, int len);

native/word.h

@@ -3,7 +3,7 @@ typedef void (*XT)(void);
 typedef struct {
 	/* TAGGED header */
 	CELL header;
-	/* untagged hashcode */
+	/* TAGGED hashcode */
 	CELL hashcode;
 	/* untagged execution token: jump here to execute word */
 	CELL xt;