steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

fix for expired fonts, inference unit test failure

cvs
Slava Pestov 2005-02-07 16:51:22 +00:00
parent 8f17b86e3d
commit a061f53214
4 changed files with 35 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
library/generic/tuple.factor
View File

@ -125,9 +125,22 @@ kernel-internals math hashtables errors ;
: add-tuple-dispatch ( word vtable -- ) : add-tuple-dispatch ( word vtable -- )
>r unit [ car tuple-dispatch ] cons tuple r> set-vtable ; >r unit [ car tuple-dispatch ] cons tuple r> set-vtable ;
M: tuple clone ( tuple -- tuple ) : clone-tuple ( tuple -- tuple )
#! Make a shallow copy of a tuple, without cloning its
#! delegate.
dup array-capacity dup <tuple> [ -rot copy-array ] keep ; dup array-capacity dup <tuple> [ -rot copy-array ] keep ;
: clone-delegate ( tuple -- )
dup class "delegate-field" word-property dup [
[ >fixnum slot clone ] 2keep set-slot
] [
2drop
] ifte ;
M: tuple clone ( tuple -- tuple )
#! Clone a tuple and its delegate.
clone-tuple dup clone-delegate ;
: tuple>list ( tuple -- list ) : tuple>list ( tuple -- list )
dup array-capacity swap array>list ; dup array-capacity swap array>list ;

7
library/sdl/sdl-utils.factor
View File

@ -132,9 +132,14 @@ global [
}} logical-fonts set }} logical-fonts set
] bind ] bind
: (lookup-font) ( [[ name ptsize ]] -- font )
unswons logical-font swons dup get dup alien-address 0 = [
drop f
] when ;
: lookup-font ( [[ name ptsize ]] -- font ) : lookup-font ( [[ name ptsize ]] -- font )
fonts get [ fonts get [
unswons logical-font swons dup get [ (lookup-font) [
nip nip
] [ ] [
[ uncons <font> dup ] keep set [ uncons <font> dup ] keep set

7
library/words.factor
View File

@ -66,5 +66,10 @@ PREDICATE: compound promise ( obj -- ? )
"name" word-property >string ; "name" word-property >string ;
: word-vocabulary ( word -- str ) "vocabulary" word-property ; : word-vocabulary ( word -- str ) "vocabulary" word-property ;
: stack-effect ( word -- str ) "stack-effect" word-property ;
: stack-effect ( word -- str )
dup "stack-effect" word-property [
] ?unless ;
: documentation ( word -- str ) "documentation" word-property ; : documentation ( word -- str ) "documentation" word-property ;

20
native/string.c
View File

@ -183,22 +183,20 @@ void primitive_string_compare(void)
dpush(tag_fixnum(string_compare(s1,s2))); dpush(tag_fixnum(string_compare(s1,s2)));
} }
bool string_eq(F_STRING* s1, F_STRING* s2)
{
if(s1 == s2)
return true;
else if(s1->hashcode != s2->hashcode)
return false;
else
return (string_compare(s1,s2) == 0);
}
void primitive_string_eq(void) void primitive_string_eq(void)
{ {
F_STRING* s1 = untag_string(dpop()); F_STRING* s1 = untag_string(dpop());
CELL with = dpop(); CELL with = dpop();
if(type_of(with) == STRING_TYPE) if(type_of(with) == STRING_TYPE)
dpush(tag_boolean(string_eq(s1,(F_STRING*)UNTAG(with)))); {
F_STRING* s2 = (F_STRING*)UNTAG(with);
if(s1->hashcode != s2->hashcode)
dpush(F);
else if(s1 == s2)
dpush(T);
else
dpush(tag_boolean((string_compare(s1,s2) == 0)));
}
else else
dpush(F); dpush(F);
} }