diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 224b0aed05..265e345ef5 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -125,9 +125,22 @@ kernel-internals math hashtables errors ; : add-tuple-dispatch ( word 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 [ -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 ) dup array-capacity swap array>list ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 6f462ffc91..da0ebd7165 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -132,9 +132,14 @@ global [ }} logical-fonts set ] bind +: (lookup-font) ( [[ name ptsize ]] -- font ) + unswons logical-font swons dup get dup alien-address 0 = [ + drop f + ] when ; + : lookup-font ( [[ name ptsize ]] -- font ) fonts get [ - unswons logical-font swons dup get [ + (lookup-font) [ nip ] [ [ uncons dup ] keep set diff --git a/library/words.factor b/library/words.factor index 371b37e8f5..bee206f347 100644 --- a/library/words.factor +++ b/library/words.factor @@ -66,5 +66,10 @@ PREDICATE: compound promise ( obj -- ? ) "name" word-property >string ; : 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 ; diff --git a/native/string.c b/native/string.c index 54a1accfbf..c790fdb337 100644 --- a/native/string.c +++ b/native/string.c @@ -183,22 +183,20 @@ void primitive_string_compare(void) 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) { F_STRING* s1 = untag_string(dpop()); CELL with = dpop(); 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 dpush(F); }