From 67562173a4441e5c8ce174b7e98d997364ead3b8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 14:10:56 -0600 Subject: [PATCH 1/5] Replace more old 'stat' based code --- core/io/files/files.factor | 12 ++++++------ extra/http/server/static/static.factor | 5 +++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 8a81bb1972..3ab489739b 100755 --- 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 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 r> with-stream ; inline diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 18870a993f..9c05b87a71 100755 --- 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 ; [ swap - [ file-length "content-length" set-header ] + [ file-info file-info-size "content-length" set-header ] [ file-http-date "last-modified" set-header ] [ '[ , binary stdio get stream-copy ] >>body ] tri From a5551f8f56341427ce92a06434d385150dd818e5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 15:39:25 -0600 Subject: [PATCH 2/5] combinators.cleave: add 2cleave and improve stack effect comments --- extra/combinators/cleave/cleave.factor | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) mode change 100755 => 100644 extra/combinators/cleave/cleave.factor diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor old mode 100755 new mode 100644 index 383d5ca9ac..fd66536c12 --- 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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 70e160d08c769608b4607b0716a36b75bc46dc8f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 15:39:54 -0600 Subject: [PATCH 3/5] combinators.cleave-docs: Add a couple of items --- extra/combinators/cleave/cleave-docs.factor | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/extra/combinators/cleave/cleave-docs.factor b/extra/combinators/cleave/cleave-docs.factor index 0c491b88b1..18968628d5 100644 --- 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) )" } ; \ No newline at end of file From f6a2a9fa49f5243c1b7cd5f56b42d97cd0edd922 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 15:40:55 -0600 Subject: [PATCH 4/5] builder: change mode --- extra/builder/builder.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100755 new mode 100644 From 93ad9cb096fa78e1e82244dedc729730b0945ea2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 17:20:28 -0500 Subject: [PATCH 5/5] Working on classes --- core/classes/classes-docs.factor | 21 ++-------- core/classes/classes-tests.factor | 66 +++++++++++++++---------------- core/classes/classes.factor | 14 ++----- 3 files changed, 40 insertions(+), 61 deletions(-) diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index df97a3eff5..1e71173153 100755 --- 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 diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 640439312d..dbc1bcace2 100755 --- 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 "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 "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 "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 "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 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 48ddb2adf5..e60d3ba223 100755 --- 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 -- )