hashcodes are now fixnums, added debug.c
Slava Pestov
parent
423ac5a947
commit
b97f362201
3
Makefile
3
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:"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" ]
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ] ] ]
|
||||
|
|
|
|||
|
|
@ -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= ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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);
|
||||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -139,5 +139,6 @@ typedef unsigned char BYTE;
|
|||
#include "compiler.h"
|
||||
#include "relocate.h"
|
||||
#include "ffi.h"
|
||||
#include "debug.h"
|
||||
|
||||
#endif /* __FACTOR_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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue