word-name, word-vocabulary are now slots in the word object

library/bootstrap/image.factor

@@ -145,13 +145,18 @@ M: f ' ( obj -- ptr )
 : emit-word ( word -- )
     dup word-props ' >r
     dup word-def ' >r
+    dup word-primitive ' >r
+    dup word-vocabulary ' >r
+    dup word-name ' >r
     object-tag here-as over objects get set-hash
     word-type >header emit
-    dup hashcode emit-fixnum
-    0 emit
-    word-primitive emit
+    hashcode emit-fixnum
     r> emit
-    r> emit ;
+    r> emit
+    r> emit
+    r> emit
+    r> emit
+    0 emit ;
 
 : word-error ( word msg -- )
     [ % dup word-vocabulary % " " % word-name % ] "" make

library/bootstrap/primitives.factor

@@ -314,8 +314,11 @@ null null define-class
 
 "word" "words" create 17 "word?" "words" create {
     { 1 { "hashcode" "kernel" } f }
-    { 4 { "word-def" "words" } { "set-word-def" "words" } }
-    { 5 { "word-props" "words" } { "set-word-props" "words" } }
+    { 2 { "word-name" "words" } f }
+    { 3 { "word-vocabulary" "words" } f }
+    { 4 { "word-primitive" "words" } { "set-word-primitive" "words" } }
+    { 5 { "word-def" "words" } { "set-word-def" "words" } }
+    { 6 { "word-props" "words" } { "set-word-props" "words" } }
 } define-builtin
 
 "tuple" "kernel" create 18 "tuple?" "kernel" create { } define-builtin

library/syntax/prettyprint.factor

@@ -60,7 +60,7 @@ C: section ( length -- section )
     #! n is current column position.
     last-newline set
     line-count inc
-    line-limit? [ " ..." write end-printing get call ] when
+    line-limit? [ "..." write end-printing get call ] when
     "\n" write do-indent ;
 
 TUPLE: text string style ;

library/tools/gensym.factor

@@ -12,6 +12,6 @@ SYMBOL: gensym-count
 : gensym ( -- word )
     #! Return a word that is distinct from every other word, and
     #! is not contained in any vocabulary.
-    (gensym) f (create) ;
+    (gensym) f <word> ;
 
 global [ 0 gensym-count set ] bind

library/vocabularies.factor

@@ -46,13 +46,6 @@ SYMBOL: vocabularies
 : search ( name vocabs -- word )
     [ lookup ] map-with [ ] find nip ;
 
-: <props> ( name vocab -- plist )
-    [ "vocabulary" set "name" set ] make-hash ;
-
-: (create) ( name vocab -- word )
-    #! Create an undefined word without adding to a vocabulary.
-    <props> <word> [ set-word-props ] keep ;
-
 : reveal ( word -- )
     #! Add a new word to its vocabulary.
     vocabularies get [
@@ -67,8 +60,8 @@ SYMBOL: vocabularies
     #! Create a new word in a vocabulary. If the vocabulary
     #! already contains the word, the existing instance is
     #! returned.
-    2dup check-create 2dup lookup
-    [ nip ] [ (create) dup reveal ] ?ifte ;
+    2dup check-create 2dup lookup dup
+    [ 2nip ] [ drop <word> dup reveal ] ifte ;
 
 : constructor-word ( string vocab -- word )
     >r "<" swap ">" append3 r> create ;

library/words.factor

@@ -10,21 +10,11 @@ namespaces sequences strings vectors ;
 : word-prop ( word name -- value ) swap word-props hash ;
 : set-word-prop ( word value name -- ) rot word-props set-hash ;
 
-: word-name ( word -- str ) "name" word-prop ;
-: word-vocabulary ( word -- str ) "vocabulary" word-prop ;
-
 ! Pointer to executable native code
 GENERIC: word-xt
-M: word word-xt ( w -- xt ) 2 integer-slot ;
+M: word word-xt ( w -- xt ) 7 integer-slot ;
 GENERIC: set-word-xt
-M: word set-word-xt ( xt w -- ) 2 set-integer-slot ;
-
-! Primitive number; some are magic, see below.
-GENERIC: word-primitive
-M: word word-primitive ( w -- n ) 3 integer-slot ;
-GENERIC: set-word-primitive
-M: word set-word-primitive ( n w -- )
-    [ 3 set-integer-slot ] keep update-xt ;
+M: word set-word-xt ( xt w -- ) 7 set-integer-slot ;
 
 : word-sort ( list -- list )
     #! Sort a list of words by name.
@@ -85,7 +75,10 @@ M: word (uncrossref) drop ;
 ! word does when invoked.
 
 : define ( word primitive parameter -- )
-    pick uncrossref pick set-word-def swap set-word-primitive ;
+    pick uncrossref
+    pick set-word-def
+    over set-word-primitive
+    update-xt ;
 
 GENERIC: definer ( word -- word )
 #! Return the parsing word that defined this word.

native/debug.c

@@ -1,97 +1,5 @@
 #include "factor.h"
 
-F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2)
-{
-	CELL len1 = string_capacity(s1);
-	CELL len2 = string_capacity(s2);
-
-	CELL limit = (len1 < len2 ? len1 : len2);
-
-	CELL i = 0;
-	while(i < limit)
-	{
-		u16 c1 = string_nth(s1,i);
-		u16 c2 = string_nth(s2,i);
-		if(c1 != c2)
-			return c1 - c2;
-		i++;
-	}
-
-	return len1 - len2;
-}
-
-/* Implements some Factor library words in C, to dump a stack in a semi-human-readable
-form without any Factor code executing.. This is not used during normal execution, only
-when the runtime dies. */
-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(alist == F)
-		return F;
-
-	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);
-	}
-}
-
-CELL hash(CELL hash, CELL key)
-{
-	if(type_of(hash) != HASHTABLE_TYPE)
-	{
-		fprintf(stderr,"Not a hash: %ld\n",hash);
-		return F;
-	}
-
-	{
-		int i;
-
-		CELL array = ((F_HASHTABLE*)UNTAG(hash))->array;
-		F_ARRAY* a;
-
-		if(type_of(array) != ARRAY_TYPE)
-		{
-			fprintf(stderr,"Not an array: %ld\n",hash);
-			return F;
-		}
-
-		a = untag_array_fast(array);
-
-		for(i = 0; i < array_capacity(a); i++)
-		{
-			CELL value = assoc(get(AREF(a,i)),key);
-			if(value != F)
-				return value;
-		}
-		
-		return F;
-	}
-}
 void print_cons(CELL cons)
 {
 	fprintf(stderr,"[ ");
@@ -115,17 +23,16 @@ void print_cons(CELL cons)
 
 void print_word(F_WORD* word)
 {
-	CELL name = hash(word->props,tag_object(from_c_string("name")));
-	if(type_of(name) == STRING_TYPE)
-		fprintf(stderr,"%s",to_c_string(untag_string(name)));
+	if(type_of(word->name) == STRING_TYPE)
+		fprintf(stderr,"%s",to_c_string(untag_string(word->name)));
 	else
 	{
 		fprintf(stderr,"#<not a string: ");
-		print_obj(name);
+		print_obj(word->name);
 		fprintf(stderr,">");
 	}
 
-	fprintf(stderr," (#%ld)",word->primitive);
+	fprintf(stderr," (#%ld)",untag_fixnum_fast(word->primitive));
 }
 
 void print_string(F_STRING* str)

native/word.c

@@ -5,22 +5,27 @@
    number that indexes a list of xts. */
 void update_xt(F_WORD* word)
 {
-	word->xt = primitive_to_xt(word->primitive);
+	word->xt = primitive_to_xt(untag_fixnum_fast(word->primitive));
 }
 
-/* <word> ( primitive parameter plist -- word ) */
+/* <word> ( name vocabulary -- word ) */
 void primitive_word(void)
 {
-	F_WORD* word;
+	F_WORD *word;
+	CELL name, vocabulary;
 
 	maybe_gc(sizeof(F_WORD));
 
+	vocabulary = dpop();
+	name = dpop();
 	word = allot_object(WORD_TYPE,sizeof(F_WORD));
 	word->hashcode = tag_fixnum((CELL)word); /* initial address */
-	word->xt = (CELL)undefined;
-	word->primitive = 0;
+	word->name = name;
+	word->vocabulary = vocabulary;
+	word->primitive = tag_fixnum(0);
 	word->def = F;
-	word->props = F;
+	word->props = tag_object(hashtable(8));
+	word->xt = (CELL)undefined;
 	dpush(tag_object(word));
 }
 
@@ -46,12 +51,16 @@ void fixup_word(F_WORD* word)
 	else
 		update_xt(word);
 
+	data_fixup(&word->name);
+	data_fixup(&word->vocabulary);
 	data_fixup(&word->def);
 	data_fixup(&word->props);
 }
 
 void collect_word(F_WORD* word)
 {
+	copy_handle(&word->name);
+	copy_handle(&word->vocabulary);
 	copy_handle(&word->def);
 	copy_handle(&word->props);
 }

native/word.h

@@ -3,14 +3,18 @@ typedef struct {
 	CELL header;
 	/* TAGGED hashcode */
 	CELL hashcode;
-	/* untagged execution token: jump here to execute word */
-	CELL xt;
-	/* untagged on-disk primitive number */
+	/* TAGGED word name */
+	CELL name;
+	/* TAGGED word vocabulary */
+	CELL vocabulary;
+	/* TAGGED on-disk primitive number */
 	CELL primitive;
 	/* TAGGED parameter to xt; used for colon definitions */
 	CELL def;
 	/* TAGGED property hash for library code */
 	CELL props;
+	/* untagged execution token: jump here to execute word */
+	CELL xt;
 } F_WORD;
 
 typedef void (*XT)(F_WORD* word);