fix for expired fonts, inference unit test failure

diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index 224b0aed0563e2414c691ffe1787c80b41243aa9..265e345ef5d59120ed93f19177a70b1929e71a4c 100644 (file)
--- 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 <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 )
     dup array-capacity swap array>list ;
 

diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor
index 6f462ffc9188d6eb4f4f654fdf11f6fd60080e49..da0ebd71659a48790bccf78ace70ce9a7877f583 100644 (file)
--- 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 <font> dup ] keep set

diff --git a/library/words.factor b/library/words.factor
index 371b37e8f50d66a5d9888a2e2092ab5e4099fb49..bee206f3472c0999a10573b4eb44296be5bdeb42 100644 (file)
--- 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 54a1accfbfcc24faee837781dca1a35da863ff91..c790fdb3375eca9f8796d9c2f30bcdbcdc1c533f 100644 (file)
--- 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);
 }