From b1daea44a69cba3f719af3d3e910db70dff15419 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Aug 2005 06:34:04 +0000 Subject: [PATCH] word-name, word-vocabulary are now slots in the word object --- library/bootstrap/image.factor | 13 ++-- library/bootstrap/primitives.factor | 7 +- library/syntax/prettyprint.factor | 2 +- library/tools/gensym.factor | 2 +- library/vocabularies.factor | 11 +-- library/words.factor | 19 ++---- native/debug.c | 101 ++-------------------------- native/word.c | 21 ++++-- native/word.h | 10 ++- 9 files changed, 50 insertions(+), 136 deletions(-) diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index e2bff6dc89..e035c8e371 100644 --- a/library/bootstrap/image.factor +++ b/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 diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 7695166ae6..f5cd043ce5 100644 --- a/library/bootstrap/primitives.factor +++ b/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 diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index ad30287ddb..41fa8d6d87 100644 --- a/library/syntax/prettyprint.factor +++ b/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 ; diff --git a/library/tools/gensym.factor b/library/tools/gensym.factor index ab5f82397e..fb95bbe375 100644 --- a/library/tools/gensym.factor +++ b/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 ; global [ 0 gensym-count set ] bind diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 9378f567fd..a1c9da885b 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -46,13 +46,6 @@ SYMBOL: vocabularies : search ( name vocabs -- word ) [ lookup ] map-with [ ] find nip ; -: ( name vocab -- plist ) - [ "vocabulary" set "name" set ] make-hash ; - -: (create) ( name vocab -- word ) - #! Create an undefined word without adding to a vocabulary. - [ 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 dup reveal ] ifte ; : constructor-word ( string vocab -- word ) >r "<" swap ">" append3 r> create ; diff --git a/library/words.factor b/library/words.factor index f68fb18fc8..eca4bb80bc 100644 --- a/library/words.factor +++ b/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. diff --git a/native/debug.c b/native/debug.c index 303a491e92..b7bd771df3 100644 --- a/native/debug.c +++ b/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,"#name); fprintf(stderr,">"); } - fprintf(stderr," (#%ld)",word->primitive); + fprintf(stderr," (#%ld)",untag_fixnum_fast(word->primitive)); } void print_string(F_STRING* str) diff --git a/native/word.c b/native/word.c index 77016fe84c..b35b431beb 100644 --- a/native/word.c +++ b/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)); } -/* ( primitive parameter plist -- 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); } diff --git a/native/word.h b/native/word.h index 081f4c08c4..c9cb165722 100644 --- a/native/word.h +++ b/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);