Merge branch 'master' of git://factorcode.org/git/factor into unicode

2008-03-13 18:07:07 -05:00 · 2008-03-13 18:07:07 -05:00 · f378122dc5
parent fef7e8315d 9a36f36ff7
commit f378122dc5
8 changed files with 78 additions and 72 deletions
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@ -1,7 +1,7 @@
 USING: help.markup help.syntax kernel kernel.private
 namespaces sequences words arrays layouts help effects math
 layouts classes.private classes.union classes.mixin
-classes.predicate ;
+classes.predicate quotations ;
 IN: classes

 ARTICLE: "builtin-classes" "Built-in classes"
@ -114,24 +114,9 @@ HELP: predicate-word
 { $values { "word" "a word" } { "predicate" "a predicate word" } }
 { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;

-HELP: define-predicate*
-{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
-{ $description
-    "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
-    { $list
-        { "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
-        { "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }
-        { "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } }
-    }
-    "These properties are used by method dispatch and the help system."
-}
-$low-level-note ;
-
 HELP: define-predicate
-{ $values { "class" class } { "quot" "a quotation" } }
-{ $description
-    "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
-}
+{ $values { "class" class } { "quot" quotation } }
+{ $description "Defines a predicate word for a class." }
 $low-level-note ;

 HELP: superclass
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@ -178,39 +178,39 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;

 [ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test

-DEFER: mixin-forget-test-g
-
-[ "mixin-forget-test" forget-source ] with-compilation-unit
-
-[ ] [
-    {
-        "USING: sequences ;"
-        "IN: classes.tests"
-        "MIXIN: mixin-forget-test"
-        "INSTANCE: sequence mixin-forget-test"
-        "GENERIC: mixin-forget-test-g ( x -- y )"
-        "M: mixin-forget-test mixin-forget-test-g ;"
-    } "\n" join <string-reader> "mixin-forget-test"
-    parse-stream drop
-] unit-test
-
-[ { } ] [ { } mixin-forget-test-g ] unit-test
-[ H{ } mixin-forget-test-g ] must-fail
-
-[ ] [
-    {
-        "USING: hashtables ;"
-        "IN: classes.tests"
-        "MIXIN: mixin-forget-test"
-        "INSTANCE: hashtable mixin-forget-test"
-        "GENERIC: mixin-forget-test-g ( x -- y )"
-        "M: mixin-forget-test mixin-forget-test-g ;"
-    } "\n" join <string-reader> "mixin-forget-test"
-    parse-stream drop
-] unit-test
-
-[ { } mixin-forget-test-g ] must-fail
-[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
+2 [
+    [ "mixin-forget-test" forget-source ] with-compilation-unit
+    
+    [ ] [
+        {
+            "USING: sequences ;"
+            "IN: classes.tests"
+            "MIXIN: mixin-forget-test"
+            "INSTANCE: sequence mixin-forget-test"
+            "GENERIC: mixin-forget-test-g ( x -- y )"
+            "M: mixin-forget-test mixin-forget-test-g ;"
+        } "\n" join <string-reader> "mixin-forget-test"
+        parse-stream drop
+    ] unit-test
+    
+    [ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
+    [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
+    
+    [ ] [
+        {
+            "USING: hashtables ;"
+            "IN: classes.tests"
+            "MIXIN: mixin-forget-test"
+            "INSTANCE: hashtable mixin-forget-test"
+            "GENERIC: mixin-forget-test-g ( x -- y )"
+            "M: mixin-forget-test mixin-forget-test-g ;"
+        } "\n" join <string-reader> "mixin-forget-test"
+        parse-stream drop
+    ] unit-test
+    
+    [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
+    [ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
+] times

 ! Method flattening interfered with mixin update
 MIXIN: flat-mx-1
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@ -31,17 +31,9 @@ PREDICATE: class tuple-class

 PREDICATE: word predicate "predicating" word-prop >boolean ;

-: define-predicate* ( class predicate quot -- )
-    over [
-        dupd predicate-effect define-declared
-        2dup 1quotation "predicate" set-word-prop
-        swap "predicating" set-word-prop
-    ] [ 3drop ] if ;
-
 : define-predicate ( class quot -- )
-    over "forgotten" word-prop [ 2drop ] [
-        >r dup predicate-word r> define-predicate*
-    ] if ;
+    >r "predicate" word-prop first
+    r> predicate-effect define-declared ;

 : superclass ( class -- super )
    "superclass" word-prop ;
@ -257,6 +249,8 @@ PRIVATE>
    over reset-class
    over deferred? [ over define-symbol ] when
    >r dup word-props r> union over set-word-props
+    dup predicate-word 2dup 1quotation "predicate" set-word-prop
+    over "predicating" set-word-prop
    t "class" set-word-prop ;

 GENERIC: update-predicate ( class -- )
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@ -86,11 +86,11 @@ SYMBOL: +unknown+
 : stat ( path -- directory? permissions length modified )
    normalize-pathname (stat) ;

-: file-length ( path -- n ) stat drop 2nip ;
+! : file-length ( path -- n ) stat drop 2nip ;

 : file-modified ( path -- n ) stat >r 3drop r> ;

-: file-permissions ( path -- perm ) stat 2drop nip ;
+! : file-permissions ( path -- perm ) stat 2drop nip ;

 : exists? ( path -- ? ) file-modified >boolean ;

@ -219,11 +219,11 @@ M: pathname <=> [ pathname-string ] compare ;
 : with-file-reader ( path encoding quot -- )
    >r <file-reader> r> with-stream ; inline

-! : file-contents ( path encoding -- str )
-!     dupd [ file-info file-info-size read ] with-file-reader ;
-
 : file-contents ( path encoding -- str )
-    dupd [ file-length read ] with-file-reader ;
+    dupd [ file-info file-info-size read ] with-file-reader ;
+
+! : file-contents ( path encoding -- str )
+!     dupd [ file-length read ] with-file-reader ;

 : with-file-writer ( path encoding quot -- )
    >r <file-writer> r> with-stream ; inline
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
--- a/extra/combinators/cleave/cleave-docs.factor
+++ b/extra/combinators/cleave/cleave-docs.factor
@ -9,6 +9,7 @@ ARTICLE: "cleave-combinators" "Cleave Combinators"

 { $subsection bi  }
 { $subsection tri }
+{ $subsection cleave }

 { $notes
  "From the Merriam-Webster Dictionary: "
@ -49,10 +50,17 @@ HELP: tri

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

+HELP: cleave
+
+{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 ARTICLE: "spread-combinators" "Spread Combinators"

 { $subsection bi* }
-{ $subsection tri* } ;
+{ $subsection tri* }
+{ $subsection spread } ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@ -80,3 +88,9 @@ HELP: tri*
            { "p(x)" "p applied to x" }
            { "q(y)" "q applied to y" }
            { "r(z)" "r applied to z" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: spread
+
+{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@ -15,9 +15,9 @@ IN: combinators.cleave

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

-: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
+: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline

-: 2tri ( obj obj quot quot quot -- val val val )
+: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) )
  >r >r 2keep r> 2keep r> call ; inline

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -36,6 +36,18 @@ MACRO: cleave ( seq -- )
    [ drop ]
  append ;

+MACRO: 2cleave ( seq -- )
+  dup
+    [ drop [ 2dup ] ] map concat
+  swap
+  dup
+    [ drop [ >r >r ] ] map concat
+  swap
+    [ [ r> r> ] append ] map concat
+  3append
+    [ 2drop ]
+  append ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! The spread family
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@ -14,7 +14,8 @@ TUPLE: file-responder root hook special ;
    >r unix-1970 r> seconds time+ ;

 : file-http-date ( filename -- string )
-    file-modified unix-time>timestamp timestamp>http-string ;
+    file-info file-info-modified
+    unix-time>timestamp timestamp>http-string ;

 : last-modified-matches? ( filename -- ? )
    file-http-date dup [
@ -31,7 +32,7 @@ TUPLE: file-responder root hook special ;
    [
        <content>
        swap
-        [ file-length "content-length" set-header ]
+        [ file-info file-info-size "content-length" set-header ]
        [ file-http-date "last-modified" set-header ]
        [ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
        tri