hash tables cons less

diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index 36cf969e36290bace2a161386ce8625d85c9b939..e8beb47ba6450555d3ee121dd853fa020badcdac 100644 (file)
--- a/library/bootstrap/image.factor
+++ b/library/bootstrap/image.factor
@@ -193,7 +193,7 @@ M: f ' ( obj -- ptr )
 : word, ( word -- )
     [
         word-tag >header ,
-        dup hashcode ,
+        dup hashcode fixnum-tag immediate ,
         0 ,
         dup word-primitive ,
         dup word-parameter ' ,
@@ -288,7 +288,7 @@ M: string ' ( string -- pointer )
     ( elements -- ) [ emit ] each
     align-here r> ;
 
-M: vector ' ( vector -- pointer )
+: emit-vector ( vector -- pointer )
     dup vector>list emit-array swap vector-length
     object-tag here-as >r
     vector-type >header emit
@@ -296,6 +296,28 @@ M: vector ' ( vector -- pointer )
     emit ( array ptr )
     align-here r> ;
 
+M: vector ' ( vector -- pointer )
+    emit-vector ;
+
+: rehash ( hashtable -- )
+    ! Now make a rehashing boot quotation
+    dup hash>alist [
+        >r dup vector-length [
+            f swap pick set-vector-nth
+        ] times* r>
+        [ unswons pick set-hash ] each
+    ] cons cons
+    boot-quot [ append ] change ;
+
+M: hashtable ' ( hashtable -- pointer )
+    #! Only hashtables are pooled, not vectors!
+    dup pooled-object dup [
+        nip
+    ] [
+        drop [ dup emit-vector [ pool-object ] keep ] keep
+        rehash
+    ] ifte ;
+
 ( End of the image )
 
 : vocabularies, ( vocabularies -- )
@@ -316,11 +338,11 @@ M: vector ' ( vector -- pointer )
     global-offset fixup ;
 
 : boot, ( quot -- )
-    boot-quot get ' boot-quot-offset fixup ;
+    boot-quot get swap append ' boot-quot-offset fixup ;
 
-: end ( -- )
-    boot,
+: end ( quot -- )
     global,
+    boot,
     fixup-words
     here base - heap-size-offset fixup ;
 
@@ -357,6 +379,7 @@ M: vector ' ( vector -- pointer )
     ] with-scope ;
 
 : with-image ( quot -- image )
+    #! The quotation leaves a boot quotation on the stack.
     [ begin call end ] with-minimal-image ;
 
 : test-image ( quot -- ) with-image vector>list . ;
@@ -364,8 +387,8 @@ M: vector ' ( vector -- pointer )
 : make-image ( name -- )
     #! Make an image for the C interpreter.
     [
+        boot-quot off
         "/library/bootstrap/boot.factor" run-resource
-        boot-quot set
     ] with-image
 
     swap write-image ;

diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index affa2bb049e701dc6bb0fe02c8d29f2854f295bd..5dc7dee8fc33438c58af3ffcd37f10192ec5782c 100644 (file)
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -161,11 +161,14 @@ SYMBOL: object
 : type-intersection ( list list -- list )
     intersection [ > ] sort ;
 
+: lookup-union ( typelist -- class )
+    classes get hash [ object ] unless* ;
+
 : class-or ( class class -- class )
     #! Return a class that both classes are subclasses of.
     swap builtin-supertypes
     swap builtin-supertypes
-    type-union classes get hash [ object ] unless* ;
+    type-union lookup-union ;
 
 : class-and ( class class -- class )
     #! Return a class that is a subclass of both, or raise an
@@ -173,7 +176,7 @@ SYMBOL: object
     over builtin-supertypes
     over builtin-supertypes
     type-intersection dup [
-        nip nip classes get hash [ object ] unless*
+        nip nip lookup-union
     ] [
         drop [
             word-name , " and " , word-name ,

diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index 250a4fd5bf8e4961174fb77f6e4c4d3384d365be..ce648c5ecf2784db9143ae6c4317e4ab13a57661 100644 (file)
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -146,40 +146,29 @@ SYMBOL: cloned
 : terminator-quot? ( [ quot | type-prop ] -- ? )
     car literal-value [ terminator? ] some? ;
 
-: dual-branch ( branchlist branch -- rstate )
+: dual-branch ( branch branchlist -- rstate )
     #! Return a recursive state for a branch other than the
     #! given one in the list.
-    swap [ over eq? not ] subset nip car car value-recursion ;
+    [ over eq? not ] subset nip car car value-recursion ;
 
-SYMBOL: dual-recursive-state
-
-: recursive-branch ( branchlist value -- namespace )
-    #! Return effect namespace if inference didn't fail.
+: recursive-branch ( branch branchlist -- )
     [
-        [ dual-branch dual-recursive-state set ] keep
-        infer-branch
+        dupd dual-branch >r infer-branch r> set-base
     ] [
-        [ 2drop f ] when
+        [ 2drop ] when
     ] catch ;
 
-: infer-base-cases ( branchlist -- list )
-    dup [ dupd recursive-branch ] map [ ] subset nip ;
-
 : infer-base-case ( branchlist -- )
-    #! Can't do much if there is only one non-terminator branch.
-    #! Either the word is not recursive, or it is recursive
-    #! and the base case throws an error.
     [
         inferring-base-case on
 
-        [ terminator-quot? not ] subset dup length 1 > [
-            infer-base-cases unify-effects
-            effect dual-recursive-state get set-base
-        ] [
-            drop
-        ] ifte
-        
-        inferring-base-case off
+        dup [
+            2dup terminator-quot? [
+                2drop
+            ] [
+                recursive-branch
+            ] ifte
+        ] each drop
     ] with-scope ;
 
 : (infer-branches) ( branchlist -- list )

diff --git a/library/inference/inference.factor b/library/inference/inference.factor
index b7fa68452be7462721520625cb3660a1d6fda951..ed0e91268bda224439b46d8eb1c12a7d80aa0a95 100644 (file)
--- a/library/inference/inference.factor
+++ b/library/inference/inference.factor
@@ -160,11 +160,7 @@ DEFER: apply-word
 : infer-quot ( quot -- )
     #! Recursive calls to this word are made for nested
     #! quotations.
-    [
-        [ apply-object ] each
-    ] [
-        [ swap <chained-error> rethrow ] when*
-    ] catch ;
+    [ apply-object ] each ;
 
 : raise ( [ in | out ] -- [ in | out ] )
     uncons 2dup min tuck - >r - r> cons ;
@@ -190,7 +186,7 @@ DEFER: apply-word
     #! Set the base case of the current word.
     dup [
         car cdr [
-            entry-effect get swap decompose
+            [ effect ] bind entry-effect get swap decompose
             base-case set
         ] bind
     ] [
@@ -200,8 +196,7 @@ DEFER: apply-word
 : check-return ( -- )
     #! Raise an error if word leaves values on return stack.
     meta-r get vector-length 0 = [
-        "Word leaves elements on return stack"
-        <chained-error> throw
+        "Word leaves elements on return stack" throw
     ] unless ;
 
 : values-node ( op -- )

diff --git a/library/inference/words.factor b/library/inference/words.factor
index aa954b2c41251e6306f1c65fb09cd674cee52b72..168aae8fad957132a6759e127200e14de2b16a34 100644 (file)
--- a/library/inference/words.factor
+++ b/library/inference/words.factor
@@ -103,11 +103,7 @@ USE: prettyprint
 : inline-compound ( word -- effect )
     #! Infer the stack effect of a compound word in the current
     #! inferencer instance.
-    [
-        gensym [ word-parameter infer-quot effect ] with-block
-    ] [
-        [ swap <chained-error> rethrow ] when*
-    ] catch ;
+    gensym [ word-parameter infer-quot effect ] with-block ;
 
 : infer-compound ( word -- effect )
     #! Infer a word's stack effect in a separate inferencer
@@ -198,3 +194,4 @@ M: symbol (apply-word) ( word -- )
 
 \ undefined-method t "terminator" set-word-property
 \ not-a-number t "terminator" set-word-property
+\ throw t "terminator" set-word-property

diff --git a/library/primitives.factor b/library/primitives.factor
index d522d9e7edbfb53b5a7e02334d6f18ef72dcc078..b60944835c857f3632e8cf5a92f230a22a941ccb 100644 (file)
--- a/library/primitives.factor
+++ b/library/primitives.factor
@@ -88,8 +88,8 @@ USE: words
     [ fixnum*                " x y -- x*y "                       [ [ fixnum fixnum ] [ integer ] ] ]
     [ fixnum/i               " x y -- x/y "                       [ [ fixnum fixnum ] [ integer ] ] ]
     [ fixnum/f               " x y -- x/y "                       [ [ fixnum fixnum ] [ integer ] ] ]
-    [ fixnum-mod             " x y -- x%y "                       [ [ fixnum fixnum ] [ integer ] ] ]
-    [ fixnum/mod             " x y -- x/y x%y "                   [ [ fixnum fixnum ] [ integer integer ] ] ]
+    [ fixnum-mod             " x y -- x%y "                       [ [ fixnum fixnum ] [ fixnum ] ] ]
+    [ fixnum/mod             " x y -- x/y x%y "                   [ [ fixnum fixnum ] [ integer fixnum ] ] ]
     [ fixnum-bitand          " x y -- x&y "                       [ [ fixnum fixnum ] [ fixnum ] ] ]
     [ fixnum-bitor           " x y -- x|y "                       [ [ fixnum fixnum ] [ fixnum ] ] ]
     [ fixnum-bitxor          " x y -- x^y "                       [ [ fixnum fixnum ] [ fixnum ] ] ]

diff --git a/library/test/errors.factor b/library/test/errors.factor
index 2188a34c7d946bda36dcf92eb7cce0c8e8af3aea..5e7a3fb4acd90b14df25c0122aeb97836a771725 100644 (file)
--- a/library/test/errors.factor
+++ b/library/test/errors.factor
@@ -26,5 +26,3 @@ USE: stdio
 [ [ "2 car" ] parse ] [ print-error ] catch
 
 [ [ "\"\" { } vector-nth" ] parse ] [ type-check-error ] catch
-
-[ "cons" ] [ [ 1 2 ] type type-error-name ] unit-test

diff --git a/library/test/generic.factor b/library/test/generic.factor
index e2d3f1883bef5a74c6003072574f3fd0bf65f9d8..cdb3eae3881506acd9364252044d61fb276dd0a5 100644 (file)
--- a/library/test/generic.factor
+++ b/library/test/generic.factor
@@ -140,3 +140,5 @@ M: very-funny gooey sq ;
 [ number ] [ object number class-and ] unit-test
 
 [ t ] [ del1 builtin-supertypes [ integer? ] all? ] unit-test
+
+[ cons ] [ [ 1 2 ] class ] unit-test

diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor
index 3ac58740a59eeb29c87d1e2bf0ec7d57f8ce9043..1e14440fc6c552b64313f9133c3fe2d7afb47bd1 100644 (file)
--- a/library/tools/debugger.factor
+++ b/library/tools/debugger.factor
@@ -59,23 +59,11 @@ USE: generic
     "I/O error in kernel function " write
     unswons write ": " write car print ;
 
-: type-error-name ( n -- string )
-    #! These values are only used by the kernel for error
-    #! reporting.
-    dup [
-        [ 100 | "fixnum/bignum" ]
-        [ 104 | "fixnum/bignum/string" ]
-    ] assoc dup [
-        nip
-    ] [
-        drop type-name
-    ] ifte ;
-
 : type-check-error ( list -- )
     "Type check error" print
     uncons car dup "Object: " write .
-    "Object type: " write type type-error-name print
-    "Expected type: " write type-error-name print ;
+    "Object type: " write class .
+    "Expected type: " write type-name print ;
 
 : range-error ( list -- )
     "Range check error" print
@@ -132,18 +120,6 @@ M: kernel-error error. ( error -- )
 M: string error. ( error -- )
     print ;
 
-TRAITS: chained-error
-SYMBOL: original-error
-
-C: chained-error ( original chain -- )
-    [ chained-error set original-error set ] extend ;
-
-M: chained-error error. ( error -- )
-    [
-        chained-error get error.
-        " " [ original-error get error. ] with-prefix
-    ] bind ;
-
 M: object error. ( error -- )
     . ;
 

diff --git a/library/tools/heap-stats.factor b/library/tools/heap-stats.factor
index 41bd44711a85ad66dbb72753f89382e8a2d2a576..f5c9cab4710c30428a47d6d654119a7aaaeb1c81 100644 (file)
--- a/library/tools/heap-stats.factor
+++ b/library/tools/heap-stats.factor
@@ -41,7 +41,7 @@ USE: generic
     dup 0 = [
         3drop
     ] [
-        rot type-name write ": " write
+        rot builtin-type word-name write ": " write
         unparse write " bytes, " write
         unparse write " instances" print
     ] ifte ;

diff --git a/library/words.factor b/library/words.factor
index 3ff1628f16b9f3e32142115a6cfbdb5109975fa2..35c2d61dcbad1988971fdcf1df92044d9b28df81 100644 (file)
--- a/library/words.factor
+++ b/library/words.factor
@@ -37,7 +37,7 @@ USE: strings
 
 BUILTIN: word 1
 
-M: word hashcode 1 integer-slot ;
+M: word hashcode 1 slot ;
 
 : word-xt     ( w -- xt ) >word 2 integer-slot ; inline
 : set-word-xt ( xt w -- ) >word 2 set-integer-slot ; inline

diff --git a/native/bignum.c b/native/bignum.c
index baa106ddadbe2e1eadf38f41a73c2868392219db..c80ab81ec99bbf38b21bb8ec3780ad317a91b5b5 100644 (file)
--- a/native/bignum.c
+++ b/native/bignum.c
@@ -9,7 +9,7 @@ F_FIXNUM to_integer(CELL x)
        case BIGNUM_TYPE:
                return s48_bignum_to_long(untag_bignum(x));
        default:
-               type_error(INTEGER_TYPE,x);
+               type_error(BIGNUM_TYPE,x);
                return 0;
        }
 }
@@ -59,7 +59,7 @@ CELL to_cell(CELL x)
                else
                        return s48_bignum_to_long(untag_bignum(x));
        default:
-               type_error(INTEGER_TYPE,x);
+               type_error(BIGNUM_TYPE,x);
                return 0;
        }
 }

diff --git a/native/gc.c b/native/gc.c
index d8971004cef01a56d7d76aa2558ce44702991a66..c926ba78929dab5ade5ffabf1ea78aac9208592b 100644 (file)
--- a/native/gc.c
+++ b/native/gc.c
@@ -115,6 +115,9 @@ void primitive_gc(void)
 
        gc_in_progress = true;
 
+       fprintf(stderr,"GC\n");
+       fflush(stderr);
+
        flip_zones();
        scan = active.here = active.base;
        collect_roots();

diff --git a/native/sbuf.c b/native/sbuf.c
index 4efff076d5429f394bbb50771e977f627f9dd67d..b0998c2a393f778afec4b8cb69c19413d2e27982 100644 (file)
--- a/native/sbuf.c
+++ b/native/sbuf.c
@@ -116,7 +116,7 @@ void primitive_sbuf_append(void)
                sbuf_append_string(sbuf,untag_string(object));
                break;
        default:
-               type_error(TEXT_TYPE,object);
+               type_error(STRING_TYPE,object);
                break;
        }
 }

diff --git a/native/types.h b/native/types.h
index 8ff015d2f7cffe213a4c0b0953e6a426f987c4f6..518809ebf00d84130900d8b13b693c8b490e88dd 100644 (file)
--- a/native/types.h
+++ b/native/types.h
@@ -36,10 +36,6 @@ CELL T;
 
 #define TYPE_COUNT 17
 
-/* Pseudo-types. For error reporting only. */
-#define INTEGER_TYPE 100 /* F_FIXNUM or BIGNUM */
-#define TEXT_TYPE 104 /* F_FIXNUM or F_STRING */
-
 INLINE CELL tag_header(CELL cell)
 {
        return RETAG(cell << TAG_BITS,HEADER_TYPE);

diff --git a/native/unix/write.c b/native/unix/write.c
index 81008c4d3684f27bf6b35eadf240d6181d826450..9933ad483755f4f281a72c31f8e68e1cdb001d04 100644 (file)
--- a/native/unix/write.c
+++ b/native/unix/write.c
@@ -140,7 +140,7 @@ void primitive_write_8(void)
                write_string_8(port,str);
                break;
        default:
-               type_error(TEXT_TYPE,text);
+               type_error(STRING_TYPE,text);
                break;
        }
 }

diff --git a/native/win32/write.c b/native/win32/write.c
index 9f546ee69fed6ea6d1303dcb31f7a504c5a53873..9ef6127491b78bce43ce7282f645b2a0593c2b75 100644 (file)
--- a/native/win32/write.c
+++ b/native/win32/write.c
@@ -48,7 +48,7 @@ void primitive_write_8 (void)
                write_string_8(port, untag_string(text));
                break;
        default:
-               type_error(TEXT_TYPE, text);
+               type_error(STRING_TYPE, text);
                break;
        }
 }

diff --git a/native/word.c b/native/word.c
index 5f25306a855f9bd8dc9c8de86fff67e237146417..aea9ba09e00f69e2d4e3db01a09f3d80bf13f948 100644 (file)
--- a/native/word.c
+++ b/native/word.c
@@ -16,7 +16,7 @@ void primitive_word(void)
        maybe_garbage_collection();
 
        word = allot_object(WORD_TYPE,sizeof(F_WORD));
-       word->hashcode = (CELL)word; /* initial address */
+       word->hashcode = tag_fixnum((CELL)word); /* initial address */
        word->xt = (CELL)undefined;
        word->primitive = 0;
        word->parameter = F;