: 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
"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
#! 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 ;
: 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
: 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 [
#! 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 ;
: 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.
! 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.
#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,"[ ");
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)
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));
}
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);
}
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);
projects / factor.git / commitdiff