hashcodes are now fixnums, added debug.c

diff --git a/Makefile b/Makefile
index fa084ae0e59547896a38440b67966767a438080c..417c47a299f2f2ac842a694b9ce6539237c38df2 100644 (file)
--- a/Makefile
+++ b/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:"

diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index e8beb47ba6450555d3ee121dd853fa020badcdac..19a8e878754580cf7e5724149d3d1c001b068f13 100644 (file)
--- a/library/bootstrap/image.factor
+++ b/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 ;
 

diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index 35250acea080b7b465ee0eb079f369c6aa2ceadb..91c889f7e421c54fb8d97724a9a68b10b4d96be8 100644 (file)
--- a/library/bootstrap/primitives.factor
+++ b/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" ]

diff --git a/library/hashtables.factor b/library/hashtables.factor
index c642a0a89cb83fc175309b3b5e9d7c1a0a2689ca..f7fedec75d06cec5819dc3b2c4ff356b7add81da 100644 (file)
--- a/library/hashtables.factor
+++ b/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 ;

diff --git a/library/primitives.factor b/library/primitives.factor
index b60944835c857f3632e8cf5a92f230a22a941ccb..14d593a39e6959f09268d8e865b8f19b1a28f4ee 100644 (file)
--- a/library/primitives.factor
+++ b/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 ] ] ]

diff --git a/library/strings.factor b/library/strings.factor
index d8d9efbc8df1cc084811b1a3784ceab2c3675845..6b4fda404ac019f929b1eb6058e67bb052c95138 100644 (file)
--- a/library/strings.factor
+++ b/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= ;
 

diff --git a/native/debug.c b/native/debug.c
new file mode 100644 (file)
index 0000000..bea8212
--- /dev/null
+++ b/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

diff --git a/native/debug.h b/native/debug.h
new file mode 100644 (file)
index 0000000..8fc6192
--- /dev/null
+++ b/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);

diff --git a/native/error.c b/native/error.c
index 34dae3ffd3e4da0bb039020462b6b23285c573ce..a62a9fff6313323ec8e676345fd3fdfa0d89c557 100644 (file)
--- a/native/error.c
+++ b/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);

diff --git a/native/factor.h b/native/factor.h
index 3c54f1600b2a26bdbf360f08f2bb8f3654612d84..0da71d0af17c2a6ff923b6c73d2207cf3713a391 100644 (file)
--- a/native/factor.h
+++ b/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__ */

diff --git a/native/ffi.h b/native/ffi.h
index 7f3f8187f57c9f00d609ddd6dba5f5f81fe6d2db..4867007fbaa650091a25935b3a5ebde9c04c997f 100644 (file)
--- a/native/ffi.h
+++ b/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);

diff --git a/native/gc.c b/native/gc.c
index c926ba78929dab5ade5ffabf1ea78aac9208592b..78229c55d744ed0951b91a0f361531ede800c669 100644 (file)
--- a/native/gc.c
+++ b/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;
        }
 }

diff --git a/native/primitives.c b/native/primitives.c
index a131c7c2c2483f96d16c4ec788f89ba1cdf9764f..663522b87ac492fd3683a2fd2517a57de2d0be0c 100644 (file)
--- a/native/primitives.c
+++ b/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,

diff --git a/native/string.c b/native/string.c
index c6d6c638597f0c64417b64109f11eb4b238b2c89..3c947e35d6f4d4d4fecd15047365f731b5c90344 100644 (file)
--- a/native/string.c
+++ b/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)

diff --git a/native/string.h b/native/string.h
index f9db01df0d0c6c0c6bf34c3e07ba4939c9d0d80e..db05d73bb685d335c3dc98f7f06dda35bb660cd2 100644 (file)
--- a/native/string.h
+++ b/native/string.h
@@ -2,8 +2,8 @@ typedef struct {
        CELL header;
        /* untagged */
        CELL capacity;
-       /* untagged */
-       F_FIXNUM hashcode;
+       /* tagged */
+       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);

diff --git a/native/word.h b/native/word.h
index afbbf0d651d64845d94ef86132fc8096bd684164..f06233be9867c95e359bd918b104a3edecae4a82 100644 (file)
--- a/native/word.h
+++ b/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;