From 3b4bc615f10b8fb6f64f4907ade905bf0928c81a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 18 Sep 2008 12:50:16 -0500 Subject: [PATCH 001/294] chicken/egg --- build-support/factor.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 8be61f322a..2d4547a121 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -464,7 +464,7 @@ make_boot_image() { } install_build_system_apt() { - sudo apt-get --yes install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + sudo apt-get --yes install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make check_ret sudo } From 01cafb935b438a57afda18a8d0e73836c95a6035 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 18 Sep 2008 13:47:42 -0500 Subject: [PATCH 002/294] moved regexp to parser-combinators.regexp --- extra/{ => parser-combinators}/regexp/authors.txt | 0 extra/{ => parser-combinators}/regexp/regexp-tests.factor | 2 +- extra/{ => parser-combinators}/regexp/regexp.factor | 2 +- extra/{ => parser-combinators}/regexp/summary.txt | 0 extra/{ => parser-combinators}/regexp/tags.txt | 0 5 files changed, 2 insertions(+), 2 deletions(-) rename extra/{ => parser-combinators}/regexp/authors.txt (100%) rename extra/{ => parser-combinators}/regexp/regexp-tests.factor (99%) rename extra/{ => parser-combinators}/regexp/regexp.factor (99%) rename extra/{ => parser-combinators}/regexp/summary.txt (100%) rename extra/{ => parser-combinators}/regexp/tags.txt (100%) diff --git a/extra/regexp/authors.txt b/extra/parser-combinators/regexp/authors.txt similarity index 100% rename from extra/regexp/authors.txt rename to extra/parser-combinators/regexp/authors.txt diff --git a/extra/regexp/regexp-tests.factor b/extra/parser-combinators/regexp/regexp-tests.factor similarity index 99% rename from extra/regexp/regexp-tests.factor rename to extra/parser-combinators/regexp/regexp-tests.factor index e9433c6c64..64feb0903c 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/parser-combinators/regexp/regexp-tests.factor @@ -1,5 +1,5 @@ USING: regexp tools.test kernel ; -IN: regexp-tests +IN: parser-combinators.regexp.tests [ f ] [ "b" "a*" f matches? ] unit-test [ t ] [ "" "a*" f matches? ] unit-test diff --git a/extra/regexp/regexp.factor b/extra/parser-combinators/regexp/regexp.factor similarity index 99% rename from extra/regexp/regexp.factor rename to extra/parser-combinators/regexp/regexp.factor index 5ef3eacc6c..40d4603fb6 100755 --- a/extra/regexp/regexp.factor +++ b/extra/parser-combinators/regexp/regexp.factor @@ -3,7 +3,7 @@ namespaces parser lexer parser-combinators parser-combinators.simple promises quotations sequences combinators.lib strings math.order assocs prettyprint.backend memoize unicode.case unicode.categories combinators.short-circuit accessors make io ; -IN: regexp +IN: parser-combinators.regexp Date: Thu, 18 Sep 2008 13:48:18 -0500 Subject: [PATCH 003/294] use parser-combinators.regexp instead of regexp --- basis/globs/globs.factor | 2 +- basis/validators/validators.factor | 5 +++-- basis/xmode/loader/loader.factor | 2 +- basis/xmode/loader/syntax/syntax.factor | 4 ++-- basis/xmode/rules/rules.factor | 3 ++- 5 files changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor index c7d5413a47..14ddb0ed9b 100755 --- a/basis/globs/globs.factor +++ b/basis/globs/globs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser-combinators regexp lists sequences kernel +USING: parser-combinators parser-combinators.regexp lists sequences kernel promises strings unicode.case ; IN: globs diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index f24171b2b4..dab109e368 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces make sets -math.parser math.ranges assocs regexp unicode.categories arrays -hashtables words classes quotations xmode.catalog ; +math.parser math.ranges assocs parser-combinators.regexp +unicode.categories arrays hashtables words classes quotations +xmode.catalog ; IN: validators : v-default ( str def -- str ) diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index 28c0de406a..8639c93e71 100755 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -1,7 +1,7 @@ USING: xmode.loader.syntax xmode.tokens xmode.rules xmode.keyword-map xml.data xml.utilities xml assocs kernel combinators sequences math.parser namespaces parser -xmode.utilities regexp io.files accessors ; +xmode.utilities parser-combinators.regexp io.files accessors ; IN: xmode.loader ! Based on org.gjt.sp.jedit.XModeHandler diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index 69c4e4fac3..cbebe090c3 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data xml.utilities xml assocs kernel combinators sequences -math.parser namespaces make parser lexer xmode.utilities regexp -io.files ; +math.parser namespaces make parser lexer xmode.utilities +parser-combinators.regexp io.files ; IN: xmode.loader.syntax SYMBOL: ignore-case? diff --git a/basis/xmode/rules/rules.factor b/basis/xmode/rules/rules.factor index e3c0c65db0..e4f12bcc49 100755 --- a/basis/xmode/rules/rules.factor +++ b/basis/xmode/rules/rules.factor @@ -1,5 +1,6 @@ USING: accessors xmode.tokens xmode.keyword-map kernel -sequences vectors assocs strings memoize regexp unicode.case ; +sequences vectors assocs strings memoize unicode.case +parser-combinators.regexp ; IN: xmode.rules TUPLE: string-matcher string ignore-case? ; From e59b320df3140fd4c3786cd80d79d98c33d27267 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 18 Sep 2008 14:42:16 -0500 Subject: [PATCH 004/294] move regexp2 to regexp, bug fixes, more tests --- unfinished/{regexp2 => regexp}/authors.txt | 0 .../backend/backend.factor | 2 +- .../classes/classes.factor | 6 +-- unfinished/{regexp2 => regexp}/dfa/dfa.factor | 13 +++--- unfinished/{regexp2 => regexp}/nfa/nfa.factor | 17 +++++-- .../parser/parser-tests.factor | 9 ++-- .../{regexp2 => regexp}/parser/parser.factor | 34 ++++++++++++-- .../regexp-docs.factor} | 4 +- .../regexp-tests.factor} | 37 ++++++++++------ .../regexp2.factor => regexp/regexp.factor} | 44 ++++++++++++------- unfinished/{regexp2 => regexp}/summary.txt | 0 unfinished/{regexp2 => regexp}/tags.txt | 0 .../transition-tables.factor | 4 +- .../traversal/traversal.factor | 15 +++---- .../{regexp2 => regexp}/utils/utils.factor | 9 ++-- 15 files changed, 123 insertions(+), 71 deletions(-) rename unfinished/{regexp2 => regexp}/authors.txt (100%) rename unfinished/{regexp2 => regexp}/backend/backend.factor (96%) rename unfinished/{regexp2 => regexp}/classes/classes.factor (90%) rename unfinished/{regexp2 => regexp}/dfa/dfa.factor (87%) rename unfinished/{regexp2 => regexp}/nfa/nfa.factor (92%) rename unfinished/{regexp2 => regexp}/parser/parser-tests.factor (82%) rename unfinished/{regexp2 => regexp}/parser/parser.factor (92%) rename unfinished/{regexp2/regexp2-docs.factor => regexp/regexp-docs.factor} (89%) rename unfinished/{regexp2/regexp2-tests.factor => regexp/regexp-tests.factor} (90%) rename unfinished/{regexp2/regexp2.factor => regexp/regexp.factor} (67%) rename unfinished/{regexp2 => regexp}/summary.txt (100%) rename unfinished/{regexp2 => regexp}/tags.txt (100%) rename unfinished/{regexp2 => regexp}/transition-tables/transition-tables.factor (95%) rename unfinished/{regexp2 => regexp}/traversal/traversal.factor (86%) rename unfinished/{regexp2 => regexp}/utils/utils.factor (91%) diff --git a/unfinished/regexp2/authors.txt b/unfinished/regexp/authors.txt similarity index 100% rename from unfinished/regexp2/authors.txt rename to unfinished/regexp/authors.txt diff --git a/unfinished/regexp2/backend/backend.factor b/unfinished/regexp/backend/backend.factor similarity index 96% rename from unfinished/regexp2/backend/backend.factor rename to unfinished/regexp/backend/backend.factor index fa5c1f7f97..1a261fb0af 100644 --- a/unfinished/regexp2/backend/backend.factor +++ b/unfinished/regexp/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors hashtables kernel math state-tables vars vectors ; -IN: regexp2.backend +IN: regexp.backend TUPLE: regexp raw diff --git a/unfinished/regexp2/classes/classes.factor b/unfinished/regexp/classes/classes.factor similarity index 90% rename from unfinished/regexp2/classes/classes.factor rename to unfinished/regexp/classes/classes.factor index 7737e02d40..a2d91b97fb 100644 --- a/unfinished/regexp2/classes/classes.factor +++ b/unfinished/regexp/classes/classes.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math math.order symbols regexp2.parser -words regexp2.utils unicode.categories combinators.short-circuit ; -IN: regexp2.classes +USING: accessors kernel math math.order symbols regexp.parser +words regexp.utils unicode.categories combinators.short-circuit ; +IN: regexp.classes GENERIC: class-member? ( obj class -- ? ) diff --git a/unfinished/regexp2/dfa/dfa.factor b/unfinished/regexp/dfa/dfa.factor similarity index 87% rename from unfinished/regexp2/dfa/dfa.factor rename to unfinished/regexp/dfa/dfa.factor index cd2f4186f4..6f244dc8af 100644 --- a/unfinished/regexp2/dfa/dfa.factor +++ b/unfinished/regexp/dfa/dfa.factor @@ -1,15 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators fry kernel locals -math math.order regexp2.nfa regexp2.transition-tables sequences -sets sorting vectors regexp2.utils sequences.lib combinators.lib -sequences.deep ; +math math.order regexp.nfa regexp.transition-tables sequences +sets sorting vectors regexp.utils sequences.deep ; USING: io prettyprint threads ; -IN: regexp2.dfa +IN: regexp.dfa : find-delta ( states transition regexp -- new-states ) nfa-table>> transitions>> - rot [ swap at at ] with with map sift concat prune ; + rot [ swap at at ] with with gather sift ; : (find-epsilon-closure) ( states regexp -- new-states ) eps swap find-delta ; @@ -26,7 +25,9 @@ IN: regexp2.dfa : find-transitions ( seq1 regexp -- seq2 ) nfa-table>> transitions>> - [ at keys ] curry map concat eps swap remove ; + [ at keys ] curry map concat + eps swap remove ; + ! dup t member? [ t swap remove t suffix ] when ; : add-todo-state ( state regexp -- ) 2dup visited-states>> key? [ diff --git a/unfinished/regexp2/nfa/nfa.factor b/unfinished/regexp/nfa/nfa.factor similarity index 92% rename from unfinished/regexp2/nfa/nfa.factor rename to unfinished/regexp/nfa/nfa.factor index 792d9fe30f..f070c3528b 100644 --- a/unfinished/regexp2/nfa/nfa.factor +++ b/unfinished/regexp/nfa/nfa.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs grouping kernel regexp2.backend -locals math namespaces regexp2.parser sequences state-tables fry +USING: accessors arrays assocs grouping kernel regexp.backend +locals math namespaces regexp.parser sequences state-tables fry quotations math.order math.ranges vectors unicode.categories -regexp2.utils regexp2.transition-tables words sequences.lib sets ; -IN: regexp2.nfa +regexp.utils regexp.transition-tables words sets ; +IN: regexp.nfa SYMBOL: negation-mode : negated? ( -- ? ) negation-mode get 0 or odd? ; @@ -121,6 +121,15 @@ M: character-class-range nfa-node ( node -- ) M: capture-group nfa-node ( node -- ) term>> nfa-node ; +! xyzzy +M: non-capture-group nfa-node ( node -- ) + term>> nfa-node ; + +M: reluctant-kleene-star nfa-node ( node -- ) + term>> nfa-node ; + +! + M: negation nfa-node ( node -- ) negation-mode inc term>> nfa-node diff --git a/unfinished/regexp2/parser/parser-tests.factor b/unfinished/regexp/parser/parser-tests.factor similarity index 82% rename from unfinished/regexp2/parser/parser-tests.factor rename to unfinished/regexp/parser/parser-tests.factor index 6911e8e76d..0f25b2e3bf 100644 --- a/unfinished/regexp2/parser/parser-tests.factor +++ b/unfinished/regexp/parser/parser-tests.factor @@ -1,13 +1,10 @@ -USING: kernel tools.test regexp2.backend regexp2 ; -IN: regexp2.parser +USING: kernel tools.test regexp.backend regexp ; +IN: regexp.parser : test-regexp ( string -- ) default-regexp parse-regexp ; -: test-regexp2 ( string -- regexp ) - default-regexp dup parse-regexp ; - -[ "(" ] [ unmatched-parentheses? ] must-fail-with +! [ "(" ] [ unmatched-parentheses? ] must-fail-with [ ] [ "a|b" test-regexp ] unit-test [ ] [ "a.b" test-regexp ] unit-test diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp/parser/parser.factor similarity index 92% rename from unfinished/regexp2/parser/parser.factor rename to unfinished/regexp/parser/parser.factor index fb1bd08bfe..eaee70210e 100644 --- a/unfinished/regexp2/parser/parser.factor +++ b/unfinished/regexp/parser/parser.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators io io.streams.string kernel math math.parser multi-methods namespaces qualified sets -quotations sequences sequences.lib splitting symbols vectors -dlists math.order combinators.lib unicode.categories strings -sequences.lib regexp2.backend regexp2.utils unicode.case ; -IN: regexp2.parser +quotations sequences splitting symbols vectors math.order +unicode.categories strings regexp.backend regexp.utils +unicode.case ; +IN: regexp.parser FROM: math.ranges => [a,b] ; @@ -280,11 +280,26 @@ ERROR: bad-escaped-literals seq ; first|concatenation ] if-empty ; +ERROR: unrecognized-escape char ; + : parse-escaped ( -- obj ) read1 { { CHAR: \ [ CHAR: \ ] } + { CHAR: - [ CHAR: - ] } + { CHAR: { [ CHAR: { ] } + { CHAR: } [ CHAR: } ] } + { CHAR: [ [ CHAR: [ ] } + { CHAR: ] [ CHAR: ] ] } + { CHAR: ( [ CHAR: ( ] } + { CHAR: ) [ CHAR: ) ] } + { CHAR: @ [ CHAR: @ ] } + { CHAR: * [ CHAR: * ] } + { CHAR: + [ CHAR: + ] } + { CHAR: ? [ CHAR: ? ] } { CHAR: . [ CHAR: . ] } +! xyzzy + { CHAR: : [ CHAR: : ] } { CHAR: t [ CHAR: \t ] } { CHAR: n [ CHAR: \n ] } { CHAR: r [ CHAR: \r ] } @@ -314,8 +329,19 @@ ERROR: bad-escaped-literals seq ; ! { CHAR: G [ end of previous match ] } ! { CHAR: Z [ handle-end-of-input ] } ! { CHAR: z [ handle-end-of-input ] } ! except for terminator +! xyzzy + { CHAR: 1 [ CHAR: 1 ] } + { CHAR: 2 [ CHAR: 2 ] } + { CHAR: 3 [ CHAR: 3 ] } + { CHAR: 4 [ CHAR: 4 ] } + { CHAR: 5 [ CHAR: 5 ] } + { CHAR: 6 [ CHAR: 6 ] } + { CHAR: 7 [ CHAR: 7 ] } + { CHAR: 8 [ CHAR: 8 ] } + { CHAR: 9 [ CHAR: 9 ] } { CHAR: Q [ parse-escaped-literals ] } + [ unrecognized-escape ] } case ; : handle-escape ( -- ) parse-escaped push-stack ; diff --git a/unfinished/regexp2/regexp2-docs.factor b/unfinished/regexp/regexp-docs.factor similarity index 89% rename from unfinished/regexp2/regexp2-docs.factor rename to unfinished/regexp/regexp-docs.factor index f903c14bc4..f6a1fe1876 100644 --- a/unfinished/regexp2/regexp2-docs.factor +++ b/unfinished/regexp/regexp-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel strings help.markup help.syntax regexp2.backend ; -IN: regexp2 +USING: kernel strings help.markup help.syntax regexp.backend ; +IN: regexp HELP: { $values { "string" string } { "regexp" regexp } } diff --git a/unfinished/regexp2/regexp2-tests.factor b/unfinished/regexp/regexp-tests.factor similarity index 90% rename from unfinished/regexp2/regexp2-tests.factor rename to unfinished/regexp/regexp-tests.factor index e77a7a4419..78098952d3 100644 --- a/unfinished/regexp2/regexp2-tests.factor +++ b/unfinished/regexp/regexp-tests.factor @@ -1,6 +1,6 @@ -USING: regexp2 tools.test kernel sequences regexp2.parser -regexp2.traversal ; -IN: regexp2-tests +USING: regexp tools.test kernel sequences regexp.parser +regexp.traversal eval ; +IN: regexp-tests [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test @@ -224,6 +224,9 @@ IN: regexp2-tests [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test [ t ] [ ".o" "\\.[a-z]" matches? ] unit-test +[ t ] [ "abc*" "[^\\*]*\\*" matches? ] unit-test +[ t ] [ "bca" "[^a]*a" matches? ] unit-test + [ ] [ "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))" drop @@ -236,20 +239,20 @@ IN: regexp2-tests -[ "{Lower}" ] [ invalid-range? ] must-fail-with +! [ "{Lower}" ] [ invalid-range? ] must-fail-with -[ 1 ] [ "aaacb" "a+?" match-head ] unit-test -[ 1 ] [ "aaacb" "aa??" match-head ] unit-test -[ f ] [ "aaaab" "a++ab" matches? ] unit-test -[ t ] [ "aaacb" "a++cb" matches? ] unit-test -[ 3 ] [ "aacb" "aa?c" match-head ] unit-test -[ 3 ] [ "aacb" "aa??c" match-head ] unit-test +! [ 1 ] [ "aaacb" "a+?" match-head ] unit-test +! [ 1 ] [ "aaacb" "aa??" match-head ] unit-test +! [ f ] [ "aaaab" "a++ab" matches? ] unit-test +! [ t ] [ "aaacb" "a++cb" matches? ] unit-test +! [ 3 ] [ "aacb" "aa?c" match-head ] unit-test +! [ 3 ] [ "aacb" "aa??c" match-head ] unit-test -[ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test -[ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test +! [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test +! [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test -[ 3 ] [ "foobar" "foo(?=bar)" match-head ] unit-test -[ f ] [ "foobxr" "foo(?=bar)" match-head ] unit-test +! [ 3 ] [ "foobar" "foo(?=bar)" match-head ] unit-test +! [ f ] [ "foobxr" "foo(?=bar)" match-head ] unit-test ! [ f ] [ "foobxr" "foo\\z" match-head ] unit-test ! [ 3 ] [ "foo" "foo\\z" match-head ] unit-test @@ -268,6 +271,12 @@ IN: regexp2-tests ! [ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test ! [ f ] [ "foo" "foo\\Bbar" matches? ] unit-test +[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test + +[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test + +[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test + ! Bug in parsing word ! [ t ] [ "a" R' a' matches? ] unit-test diff --git a/unfinished/regexp2/regexp2.factor b/unfinished/regexp/regexp.factor similarity index 67% rename from unfinished/regexp2/regexp2.factor rename to unfinished/regexp/regexp.factor index feec8ea97e..47c6e52c39 100644 --- a/unfinished/regexp2/regexp2.factor +++ b/unfinished/regexp/regexp.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators kernel math math.ranges -sequences regexp2.backend regexp2.utils memoize sets -regexp2.parser regexp2.nfa regexp2.dfa regexp2.traversal -regexp2.transition-tables assocs prettyprint.backend -make ; -IN: regexp2 +sequences regexp.backend regexp.utils memoize sets +regexp.parser regexp.nfa regexp.dfa regexp.traversal +regexp.transition-tables assocs prettyprint.backend +make lexer namespaces parser ; +IN: regexp : default-regexp ( string -- regexp ) regexp new @@ -51,17 +51,26 @@ IN: regexp2 reversed-regexp initial-option construct-regexp ; -: R! CHAR: ! ; parsing -: R" CHAR: " ; parsing -: R# CHAR: # ; parsing -: R' CHAR: ' ; parsing -: R( CHAR: ) ; parsing -: R/ CHAR: / ; parsing -: R@ CHAR: @ ; parsing -: R[ CHAR: ] ; parsing -: R` CHAR: ` ; parsing -: R{ CHAR: } ; parsing -: R| CHAR: | ; parsing + +: parsing-regexp ( accum end -- accum ) + lexer get dup skip-blank + [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column + lexer get dup still-parsing-line? + [ (parse-token) ] [ drop f ] if + "i" = [ ] [ ] if parsed ; + +: R! CHAR: ! parsing-regexp ; parsing +: R" CHAR: " parsing-regexp ; parsing +: R# CHAR: # parsing-regexp ; parsing +: R' CHAR: ' parsing-regexp ; parsing +: R( CHAR: ) parsing-regexp ; parsing +: R/ CHAR: / parsing-regexp ; parsing +: R@ CHAR: @ parsing-regexp ; parsing +: R[ CHAR: ] parsing-regexp ; parsing +: R` CHAR: ` parsing-regexp ; parsing +: R{ CHAR: } parsing-regexp ; parsing +: R| CHAR: | parsing-regexp ; parsing + : find-regexp-syntax ( string -- prefix suffix ) { @@ -81,6 +90,8 @@ IN: regexp2 : option? ( option regexp -- ? ) options>> key? ; +USE: multiline +/* M: regexp pprint* [ [ @@ -89,3 +100,4 @@ M: regexp pprint* case-insensitive swap option? [ "i" % ] when ] "" make ] keep present-text ; +*/ diff --git a/unfinished/regexp2/summary.txt b/unfinished/regexp/summary.txt similarity index 100% rename from unfinished/regexp2/summary.txt rename to unfinished/regexp/summary.txt diff --git a/unfinished/regexp2/tags.txt b/unfinished/regexp/tags.txt similarity index 100% rename from unfinished/regexp2/tags.txt rename to unfinished/regexp/tags.txt diff --git a/unfinished/regexp2/transition-tables/transition-tables.factor b/unfinished/regexp/transition-tables/transition-tables.factor similarity index 95% rename from unfinished/regexp2/transition-tables/transition-tables.factor rename to unfinished/regexp/transition-tables/transition-tables.factor index c67985af4a..82e2db8496 100644 --- a/unfinished/regexp2/transition-tables/transition-tables.factor +++ b/unfinished/regexp/transition-tables/transition-tables.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs fry hashtables kernel sequences -vectors regexp2.utils ; -IN: regexp2.transition-tables +vectors regexp.utils ; +IN: regexp.transition-tables TUPLE: transition from to obj ; TUPLE: literal-transition < transition ; diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp/traversal/traversal.factor similarity index 86% rename from unfinished/regexp2/traversal/traversal.factor rename to unfinished/regexp/traversal/traversal.factor index ba9284c110..752323de91 100644 --- a/unfinished/regexp2/traversal/traversal.factor +++ b/unfinished/regexp/traversal/traversal.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators combinators.lib kernel -math math.ranges quotations sequences regexp2.parser -regexp2.classes combinators.short-circuit assocs.lib -sequences.lib regexp2.utils ; -IN: regexp2.traversal +USING: accessors assocs combinators kernel math math.ranges +quotations sequences regexp.parser regexp.classes +combinators.short-circuit regexp.utils ; +IN: regexp.traversal TUPLE: dfa-traverser dfa-table @@ -54,7 +53,7 @@ TUPLE: dfa-traverser V{ } clone >>matches ; : match-literal ( transition from-state table -- to-state/f ) - transitions>> [ at ] [ 2drop f ] if-at ; + transitions>> at* [ at ] [ 2drop f ] if ; : match-class ( transition from-state table -- to-state/f ) transitions>> at* [ @@ -62,8 +61,8 @@ TUPLE: dfa-traverser ] [ drop ] if ; : match-default ( transition from-state table -- to-state/f ) - [ nip ] dip transitions>> - [ t swap [ drop f ] unless-at ] [ drop f ] if-at ; + [ nip ] dip transitions>> at* + [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ; : match-transition ( obj from-state dfa -- to-state/f ) { [ match-literal ] [ match-class ] [ match-default ] } 3|| ; diff --git a/unfinished/regexp2/utils/utils.factor b/unfinished/regexp/utils/utils.factor similarity index 91% rename from unfinished/regexp2/utils/utils.factor rename to unfinished/regexp/utils/utils.factor index ab51436f8b..fb058ecf92 100644 --- a/unfinished/regexp2/utils/utils.factor +++ b/unfinished/regexp/utils/utils.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators.lib io kernel -math math.order namespaces regexp2.backend sequences -sequences.lib unicode.categories math.ranges fry -combinators.short-circuit vectors ; -IN: regexp2.utils +USING: accessors arrays assocs io kernel math math.order +namespaces regexp.backend sequences unicode.categories +math.ranges fry combinators.short-circuit vectors ; +IN: regexp.utils : (while-changes) ( obj quot pred pred-ret -- obj ) ! quot: ( obj -- obj' ) From a53a198cc2a77cdd10d3573ee7359bc67ed91ece Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 18 Sep 2008 15:16:06 -0500 Subject: [PATCH 005/294] fix load error --- basis/xmode/marker/marker.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d0d68febec..d36aa1228f 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -4,7 +4,8 @@ IN: xmode.marker USING: kernel namespaces make xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators -strings regexp splitting parser-combinators ascii unicode.case +strings parser-combinators.regexp regexp splitting +parser-combinators ascii unicode.case combinators.short-circuit accessors ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker From 772a964a04e787f6be5341a1212cbed89ad37e16 Mon Sep 17 00:00:00 2001 From: "U-ENCHILADA\\sheeple" Date: Thu, 18 Sep 2008 16:45:15 -0600 Subject: [PATCH 006/294] \\?\c: is a root-directory on windows --- basis/io/windows/nt/files/files-tests.factor | 7 +++++++ basis/io/windows/nt/files/files.factor | 13 ++++++++----- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/basis/io/windows/nt/files/files-tests.factor b/basis/io/windows/nt/files/files-tests.factor index 830861eba0..6620dd691e 100755 --- a/basis/io/windows/nt/files/files-tests.factor +++ b/basis/io/windows/nt/files/files-tests.factor @@ -4,8 +4,12 @@ IN: io.windows.nt.files.tests [ f ] [ "\\foo" absolute-path? ] unit-test [ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test [ t ] [ "c:\\foo" absolute-path? ] unit-test [ t ] [ "c:" absolute-path? ] unit-test +[ t ] [ "c:\\" absolute-path? ] unit-test +[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test [ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test @@ -26,6 +30,9 @@ IN: io.windows.nt.files.tests [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test +[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test +[ t ] [ "\\\\?\\c:" root-directory? ] unit-test +[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test [ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index b572d9ec65..157662ade8 100755 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -20,11 +20,14 @@ M: winnt cd M: winnt root-directory? ( path -- ? ) { - { [ dup empty? ] [ f ] } - { [ dup [ path-separator? ] all? ] [ t ] } - { [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] } - [ f ] - } cond nip ; + { [ dup empty? ] [ drop f ] } + { [ dup [ path-separator? ] all? ] [ drop t ] } + { [ dup trim-right-separators { [ length 2 = ] + [ second CHAR: : = ] } 1&& ] [ drop t ] } + { [ dup unicode-prefix head? ] + [ trim-right-separators length unicode-prefix length 2 + = ] } + [ drop f ] + } cond ; ERROR: not-absolute-path ; From 58914da662d1776fea50bd7b7248032d9d082399 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 18 Sep 2008 18:20:26 -0500 Subject: [PATCH 007/294] I/O fixes --- basis/io/launcher/launcher.factor | 40 ++++++++++++++++------- basis/tools/deploy/backend/backend.factor | 12 ++----- core/io/files/files.factor | 2 +- 3 files changed, 33 insertions(+), 21 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 1b22ca8501..cc48ace60b 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -145,10 +145,13 @@ M: process-failed error. "Launch descriptor:" print nl process>> . ; -: try-process ( desc -- ) - run-process dup wait-for-process dup zero? +: wait-for-success ( process -- ) + dup wait-for-process dup zero? [ 2drop ] [ process-failed ] if ; +: try-process ( desc -- ) + run-process wait-for-success ; + HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) @@ -167,7 +170,7 @@ M: object run-pipeline-element 3bi wait-for-process ; -: ( process encoding -- process stream ) +: ( desc encoding -- stream process ) [ >r (pipe) { [ |dispose drop ] @@ -178,13 +181,18 @@ M: object run-pipeline-element ] [ out>> dispose ] [ in>> ] - } cleave r> + } cleave r> swap ] with-destructors ; : ( desc encoding -- stream ) - nip ; inline + drop ; inline -: ( process encoding -- process stream ) +: with-process-reader ( desc encoding quot -- ) + [ ] dip + swap [ with-input-stream ] dip + wait-for-success ; inline + +: ( desc encoding -- stream process ) [ >r (pipe) { [ |dispose drop ] @@ -195,13 +203,18 @@ M: object run-pipeline-element ] [ in>> dispose ] [ out>> ] - } cleave r> + } cleave r> swap ] with-destructors ; : ( desc encoding -- stream ) - nip ; inline + drop ; inline -: ( process encoding -- process stream ) +: with-process-writer ( desc encoding quot -- ) + [ ] dip + swap [ with-output-stream ] dip + wait-for-success ; inline + +: ( desc encoding -- stream process ) [ >r (pipe) (pipe) { [ [ |dispose drop ] bi@ ] @@ -213,11 +226,16 @@ M: object run-pipeline-element ] [ [ out>> dispose ] [ in>> dispose ] bi* ] [ [ in>> ] [ out>> ] bi* ] - } 2cleave r> + } 2cleave r> swap ] with-destructors ; : ( desc encoding -- stream ) - nip ; inline + drop ; inline + +: with-process-stream ( desc encoding quot -- ) + [ ] dip + swap [ with-stream ] dip + wait-for-success ; inline : notify-exit ( process status -- ) >>status diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 324adcaad2..cb899f4b87 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -18,12 +18,8 @@ IN: tools.deploy.backend : image-name ( vocab bundle-name -- str ) prepend-path ".image" append ; -: (copy-lines) ( stream -- ) - dup stream-readln dup - [ print flush (copy-lines) ] [ 2drop ] if ; - -: copy-lines ( stream -- ) - [ (copy-lines) ] with-disposal ; +: copy-lines ( -- ) + readln [ print flush copy-lines ] when* ; : run-with-output ( arguments -- ) @@ -31,9 +27,7 @@ IN: tools.deploy.backend +stdout+ >>stderr +closed+ >>stdin +low-priority+ >>priority - utf8 - copy-lines - wait-for-process zero? [ "Deployment failed" throw ] unless ; + utf8 [ copy-lines ] with-process-reader ; : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 58a08ed30c..5634336243 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -194,7 +194,7 @@ SYMBOL: current-directory [ cwd current-directory set-global - image parent-directory cwd prepend-path "resource-path" set + image parent-directory cwd prepend-path "resource-path" set-global ] "io.files" add-init-hook : resource-path ( path -- newpath ) From 1b875b8bf702d0c154073eef4daf48556d93d929 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 18 Sep 2008 18:23:46 -0500 Subject: [PATCH 008/294] Better error message if git not in path --- extra/mason/common/common.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index d5996f300c..dfda85e4d7 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -51,7 +51,7 @@ SYMBOL: stamp with-directory ; : git-id ( -- id ) - { "git" "show" } utf8 [ readln ] with-input-stream + { "git" "show" } utf8 [ readln ] with-process-reader " " split second ; : ?prepare-build-machine ( -- ) From 4ce3cc4141157f37781161532f570aca4a087284 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 18 Sep 2008 22:08:12 -0500 Subject: [PATCH 009/294] Bug fixes --- basis/bootstrap/random/random.factor | 2 +- core/io/files/files.factor | 13 ++++++++----- core/system/system.factor | 8 ++++---- 3 files changed, 13 insertions(+), 10 deletions(-) diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor index 3782d517cf..f6527cdda1 100755 --- a/basis/bootstrap/random/random.factor +++ b/basis/bootstrap/random/random.factor @@ -13,4 +13,4 @@ IN: bootstrap.random [ [ 32 random-bits ] with-system-random random-generator set-global -] "generator.random" add-init-hook +] "bootstrap.random" add-init-hook diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 5634336243..1634b7a3f1 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.files.private io hashtables kernel math -memory namespaces sequences strings assocs arrays definitions -system combinators splitting sbufs continuations destructors -io.encodings io.encodings.binary init accessors math.order ; +USING: io.backend io.files.private io hashtables kernel +kernel.private math memory namespaces sequences strings assocs +arrays definitions system combinators splitting sbufs +continuations destructors io.encodings io.encodings.binary init +accessors math.order ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -194,7 +195,9 @@ SYMBOL: current-directory [ cwd current-directory set-global - image parent-directory cwd prepend-path "resource-path" set-global + 13 getenv cwd prepend-path \ image set-global + 14 getenv cwd prepend-path \ vm set-global + image parent-directory "resource-path" set-global ] "io.files" add-init-hook : resource-path ( path -- newpath ) diff --git a/core/system/system.factor b/core/system/system.factor index 98dc605acc..3c207c4ab5 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -55,15 +55,15 @@ UNION: unix bsd solaris linux ; PRIVATE> +: image ( -- path ) \ image get-global ; + +: vm ( -- path ) \ vm get-global ; + [ 8 getenv string>cpu \ cpu set-global 9 getenv string>os \ os set-global ] "system" add-init-hook -: image ( -- path ) 13 getenv ; - -: vm ( -- path ) 14 getenv ; - : embedded? ( -- ? ) 15 getenv ; : os-envs ( -- assoc ) From 09ecec270af022da06e1267bdf524d02f670baa8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 18 Sep 2008 22:24:46 -0500 Subject: [PATCH 010/294] Fix load error --- basis/xmode/marker/marker.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d36aa1228f..f777eaa18c 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -3,10 +3,9 @@ IN: xmode.marker USING: kernel namespaces make xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities -xmode.catalog sequences math assocs combinators -strings parser-combinators.regexp regexp splitting -parser-combinators ascii unicode.case -combinators.short-circuit accessors ; +xmode.catalog sequences math assocs combinators strings +parser-combinators.regexp splitting parser-combinators ascii +unicode.case combinators.short-circuit accessors ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker From 1588d2ab4cbd884b43487bbbd2b3f3f8884f459e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 18 Sep 2008 23:49:51 -0500 Subject: [PATCH 011/294] fix a using --- extra/parser-combinators/regexp/regexp-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/parser-combinators/regexp/regexp-tests.factor b/extra/parser-combinators/regexp/regexp-tests.factor index 64feb0903c..78abd8b38a 100755 --- a/extra/parser-combinators/regexp/regexp-tests.factor +++ b/extra/parser-combinators/regexp/regexp-tests.factor @@ -1,4 +1,4 @@ -USING: regexp tools.test kernel ; +USING: parser-combinators.regexp tools.test kernel ; IN: parser-combinators.regexp.tests [ f ] [ "b" "a*" f matches? ] unit-test From 3d790d8ac848639f554e88474a9c182489c9c002 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 00:26:27 -0500 Subject: [PATCH 012/294] Memory ricing to make deploy tests pass on Mac OS X/PowerPC --- .../core-foundation/fsevents/fsevents.factor | 7 +- .../core-foundation/run-loop/run-loop.factor | 2 - .../run-loop/thread/thread.factor | 8 +++ basis/random/unix/unix.factor | 2 + .../transforms/transforms.factor | 2 +- basis/tools/deploy/shaker/shaker.factor | 34 +++++++--- basis/tools/deploy/shaker/strip-cocoa.factor | 64 ++++++++++++------- core/classes/tuple/tuple.factor | 5 +- 8 files changed, 84 insertions(+), 40 deletions(-) create mode 100644 basis/core-foundation/run-loop/thread/thread.factor diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index bb21391f0a..6bec4b23c0 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -3,13 +3,10 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces make assocs init accessors continuations combinators core-foundation -core-foundation.run-loop io.encodings.utf8 destructors ; +core-foundation.run-loop core-foundation.run-loop.thread +io.encodings.utf8 destructors ; IN: core-foundation.fsevents -! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! -! FSEventStream API, Leopard only ! -! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! - : kFSEventStreamCreateFlagUseCFTypes 2 ; inline : kFSEventStreamCreateFlagWatchRoot 4 ; inline diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 5ffcafbbaf..e30cc2eb60 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -35,5 +35,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode ( : start-run-loop-thread ( -- ) [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; - -[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook diff --git a/basis/core-foundation/run-loop/thread/thread.factor b/basis/core-foundation/run-loop/thread/thread.factor new file mode 100644 index 0000000000..326226ec0e --- /dev/null +++ b/basis/core-foundation/run-loop/thread/thread.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: init core-foundation.run-loop ; +IN: core-foundation.run-loop.thread + +! Load this vocabulary if you need a run loop running. + +[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook diff --git a/basis/random/unix/unix.factor b/basis/random/unix/unix.factor index 90f3d1efbb..599cd5e0ad 100644 --- a/basis/random/unix/unix.factor +++ b/basis/random/unix/unix.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Doug Coleman +! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io io.files kernel namespaces random io.encodings.binary init accessors system ; IN: random.unix diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 41c7e2c972..abc3ae1950 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -96,7 +96,7 @@ IN: stack-checker.transforms \ boa [ dup tuple-class? [ dup inlined-dependency depends-on - [ "boa-check" word-prop ] + [ "boa-check" word-prop [ ] or ] [ tuple-layout '[ _ ] ] bi append ] [ drop f ] if diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index f2726c00fa..8713be54bb 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces make assocs kernel parser lexer strings.parser tools.deploy.config vocabs sequences words words.private memory kernel.private continuations io prettyprint vocabs.loader debugger system -strings sets vectors quotations byte-arrays ; +strings sets vectors quotations byte-arrays sorting ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes QUALIFIED: command-line @@ -29,6 +29,7 @@ IN: tools.deploy.shaker "cpu.x86" init-hooks get delete-at "command-line" init-hooks get delete-at "libc" init-hooks get delete-at + "system" init-hooks get delete-at deploy-threads? get [ "threads" init-hooks get delete-at ] unless @@ -36,7 +37,11 @@ IN: tools.deploy.shaker "io.thread" init-hooks get delete-at ] unless strip-io? [ + "io.files" init-hooks get delete-at "io.backend" init-hooks get delete-at + ] when + strip-dictionary? [ + "compiler.units" init-hooks get delete-at ] when ; : strip-debugger ( -- ) @@ -74,17 +79,22 @@ IN: tools.deploy.shaker : strip-word-props ( stripped-props words -- ) "Stripping word properties" show [ - [ - props>> swap - '[ drop _ member? not ] assoc-filter sift-assoc - dup assoc-empty? [ drop f ] [ >alist >vector ] if - ] keep (>>props) - ] with each ; + swap '[ + [ + [ drop _ member? not ] assoc-filter sift-assoc + >alist f like + ] change-props drop + ] each + ] [ + "Remaining word properties:" print + [ props>> keys ] gather . + ] bi ; : stripped-word-props ( -- seq ) [ strip-dictionary? [ { + "boa-check" "cannot-infer" "coercer" "combination" @@ -92,12 +102,15 @@ IN: tools.deploy.shaker "compiled-generic-uses" "compiled-uses" "constraints" + "custom-inlining" "declared-effect" "default" "default-method" "default-output-classes" "derived-from" "engines" + "forgotten" + "identities" "if-intrinsics" "infer" "inferred-effect" @@ -116,9 +129,11 @@ IN: tools.deploy.shaker "macro" "members" "memo-quot" + "mixin" "method-class" "method-generic" "methods" + "modular-arithmetic" "no-compile" "optimizer-hooks" "outputs" @@ -126,6 +141,7 @@ IN: tools.deploy.shaker "predicate" "predicate-definition" "predicating" + "primitive" "reader" "reading" "recursive" @@ -230,6 +246,7 @@ IN: tools.deploy.shaker compiled-generic-crossref compiler.units:recompile-hook compiler.units:update-tuples-hook + compiler.units:definition-observers definitions:crossref interactive-vocabs layouts:num-tags @@ -244,6 +261,7 @@ IN: tools.deploy.shaker vocabs:dictionary vocabs:load-vocab-hook word + parser-notes } % { } { "math.partial-dispatch" } strip-vocab-globals % @@ -273,7 +291,7 @@ IN: tools.deploy.shaker "ui-error-hook" "ui.gadgets.worlds" lookup , ] when - "" "inference.dataflow" lookup [ , ] when* + "" "stack-checker.state" lookup [ , ] when* "windows-messages" "windows.messages" lookup [ , ] when* diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index de5aee68e2..2cf803e270 100755 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -1,30 +1,50 @@ -USING: cocoa cocoa.messages cocoa.application cocoa.nibs -assocs namespaces kernel words compiler.units sequences -ui ui.cocoa ; +! Copyright (C) 2007, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs +namespaces kernel kernel.private words compiler.units sequences +ui ui.cocoa init ; +IN: tools.deploy.shaker.cocoa + +: pool ( obj -- obj' ) \ pool get [ ] cache ; + +: pool-array ( obj -- obj' ) [ pool ] map pool ; + +: pool-keys ( assoc -- assoc' ) [ [ pool-array ] dip ] assoc-map ; + +: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ; + +IN: cocoa.application + +: objc-error ( error -- ) die ; + +[ [ die ] 19 setenv ] "cocoa.application" add-init-hook "stop-after-last-window?" get -global [ - stop-after-last-window? set - [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global +H{ } clone \ pool [ + global [ + stop-after-last-window? set - ! Only keeps those methods that we actually call - sent-messages get super-sent-messages get assoc-union - objc-methods [ assoc-intersect ] change + [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global - sent-messages get - super-sent-messages get - [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@ - super-message-senders [ assoc-intersect ] change - message-senders [ assoc-intersect ] change + ! Only keeps those methods that we actually call + sent-messages get super-sent-messages get assoc-union + objc-methods [ assoc-intersect pool-values ] change - sent-messages off - super-sent-messages off + sent-messages get + super-sent-messages get + [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@ + super-message-senders [ assoc-intersect pool-keys ] change + message-senders [ assoc-intersect pool-keys ] change - alien>objc-types off - objc>alien-types off + sent-messages off + super-sent-messages off - ! We need this for strip-stack-traces to work fully - { message-senders super-message-senders } - [ get values compile ] each -] bind + alien>objc-types off + objc>alien-types off + + ! We need this for strip-stack-traces to work fully + { message-senders super-message-senders } + [ get values compile ] each + ] bind +] with-variable diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index f92c9c0fd5..577ad133e1 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -125,7 +125,8 @@ ERROR: bad-superclass class ; } cond ; : boa-check-quot ( class -- quot ) - all-slots [ class>> instance-check-quot ] map spread>quot ; + all-slots [ class>> instance-check-quot ] map spread>quot + f like ; : define-boa-check ( class -- ) dup boa-check-quot "boa-check" set-word-prop ; @@ -311,7 +312,7 @@ M: tuple-class new [ (clone) ] [ tuple-layout ] ?if ; M: tuple-class boa - [ "boa-check" word-prop call ] + [ "boa-check" word-prop [ call ] when* ] [ tuple-layout ] bi ; From d592106e93863f2cc4be967a6403002dc407475d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 01:08:27 -0500 Subject: [PATCH 013/294] Fix inference --- basis/opengl/opengl.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 2d1b644050..bae05f4244 100755 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -16,8 +16,6 @@ IN: opengl : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) [ first2 [ >fixnum ] bi@ ] bi@ ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : gl-color ( color -- ) first4 glColor4d ; inline : gl-clear-color ( color -- ) @@ -27,13 +25,11 @@ IN: opengl gl-clear-color GL_COLOR_BUFFER_BIT glClear ; : color>raw ( object -- r g b a ) - >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; + >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; -: set-color ( object -- ) color>raw glColor4d ; +: set-color ( object -- ) color>raw glColor4d ; : set-clear-color ( object -- ) color>raw glClearColor ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : gl-error ( -- ) glGetError dup zero? [ "GL error: " over gluErrorString append throw @@ -53,7 +49,9 @@ IN: opengl : (all-enabled) ( seq quot -- ) over [ glEnable ] each dip [ glDisable ] each ; inline : (all-enabled-client-state) ( seq quot -- ) - over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline + [ dup [ glEnableClientState ] each ] dip + dip + [ glDisableClientState ] each ; inline MACRO: all-enabled ( seq quot -- ) >r words>values r> [ (all-enabled) ] 2curry ; From c6db662b3b3d58e7036bd46dc4cca40e705f6ae3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Aug 2008 04:38:01 -0500 Subject: [PATCH 014/294] Rice is a part of every healthy diet --- basis/tools/deploy/shaker/shaker.factor | 24 ++++++++++++++++++++---- vm/image.c | 18 ++++++++++++++++++ 2 files changed, 38 insertions(+), 4 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 8713be54bb..7a2aa1c299 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -42,6 +42,7 @@ IN: tools.deploy.shaker ] when strip-dictionary? [ "compiler.units" init-hooks get delete-at + "tools.vocabs" init-hooks get delete-at ] when ; : strip-debugger ( -- ) @@ -88,16 +89,28 @@ IN: tools.deploy.shaker ] [ "Remaining word properties:" print [ props>> keys ] gather . - ] bi ; + ] [ + H{ } clone '[ + [ [ _ [ ] cache ] map ] change-props drop + ] each + ] tri ; : stripped-word-props ( -- seq ) [ + strip-dictionary? deploy-compiler? get and [ + { + "combination" + "members" + "methods" + } % + ] when + strip-dictionary? [ { + "alias" "boa-check" "cannot-infer" "coercer" - "combination" "compiled-effect" "compiled-generic-uses" "compiled-uses" @@ -127,12 +140,10 @@ IN: tools.deploy.shaker "local-writer?" "local?" "macro" - "members" "memo-quot" "mixin" "method-class" "method-generic" - "methods" "modular-arithmetic" "no-compile" "optimizer-hooks" @@ -145,6 +156,8 @@ IN: tools.deploy.shaker "reader" "reading" "recursive" + "register" + "register-size" "shuffle" "slot-names" "slots" @@ -226,9 +239,12 @@ IN: tools.deploy.shaker "alarms" "tools" "io.launcher" + "random" } strip-vocab-globals % strip-dictionary? [ + "libraries" "alien" lookup , + { } { "cpu" } strip-vocab-globals % { diff --git a/vm/image.c b/vm/image.c index a0fa48d504..a668cb7913 100755 --- a/vm/image.c +++ b/vm/image.c @@ -169,8 +169,26 @@ DEFINE_PRIMITIVE(save_image) save_image(unbox_native_string()); } +void strip_compiled_quotations(void) +{ + begin_scan(); + CELL obj; + while((obj = next_object()) != F) + { + if(type_of(obj) == QUOTATION_TYPE) + { + F_QUOTATION *quot = untag_object(obj); + quot->compiledp = F; + } + } + gc_off = false; +} + DEFINE_PRIMITIVE(save_image_and_exit) { + /* This reduces deployed image size */ + strip_compiled_quotations(); + F_CHAR *path = unbox_native_string(); REGISTER_C_STRING(path); From f936f5f54f90cfe042c5035fa71bfe8ef28428c7 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 3 Sep 2008 23:56:58 -0300 Subject: [PATCH 015/294] irc.messages: use >tuple --- Makefile | 2 +- extra/irc/messages/messages.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 769aeacb8c..8831ed9c7e 100755 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ CFLAGS = -Wall ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 $(SITE_CFLAGS) + CFLAGS += -O3 -fno-forward-propagate $(SITE_CFLAGS) endif ifdef CONFIG diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index d3eca92f15..e68cf12d2d 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -127,4 +127,4 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip [ all-slots over [ length ] bi@ min head >quotation ] keep - '[ @ , boa ] call ; + prefix >tuple ; From 7f588bbb8481a51eb6629032395798c4ace45702 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 4 Sep 2008 01:28:37 -0300 Subject: [PATCH 016/294] irc.messages: oops --- extra/irc/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index e68cf12d2d..3a9654dd6f 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -126,5 +126,5 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) [ drop unhandled ] } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head >quotation ] keep + [ all-slots over [ length ] bi@ min head ] keep prefix >tuple ; From b610e0776992fe5c49193ec59ee2fdc1cacd6bf7 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 5 Sep 2008 02:16:38 -0300 Subject: [PATCH 017/294] irc.messages: Change the way messages are built when parsed --- extra/irc/messages/messages.factor | 103 +++++++++++++++++------------ 1 file changed, 62 insertions(+), 41 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 3a9654dd6f..981844f187 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -19,7 +19,7 @@ TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message channel mode ; -TUPLE: names-reply < irc-message who = channel ; +TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; : ( command parameters trailing -- irc-message ) @@ -28,41 +28,55 @@ TUPLE: unhandled < irc-message ; > ( irc-message -- string ) -M: irc-message irc-command-string ( irc-message -- string ) command>> ; -M: ping irc-command-string ( ping -- string ) drop "PING" ; -M: join irc-command-string ( join -- string ) drop "JOIN" ; -M: part irc-command-string ( part -- string ) drop "PART" ; -M: quit irc-command-string ( quit -- string ) drop "QUIT" ; -M: nick irc-command-string ( nick -- string ) drop "NICK" ; -M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; -M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; -M: mode irc-command-string ( mode -- string ) drop "MODE" ; -M: kick irc-command-string ( kick -- string ) drop "KICK" ; +M: irc-message command-string>> ( irc-message -- string ) command>> ; +M: ping command-string>> ( ping -- string ) drop "PING" ; +M: join command-string>> ( join -- string ) drop "JOIN" ; +M: part command-string>> ( part -- string ) drop "PART" ; +M: quit command-string>> ( quit -- string ) drop "QUIT" ; +M: nick command-string>> ( nick -- string ) drop "NICK" ; +M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ; +M: notice command-string>> ( notice -- string ) drop "NOTICE" ; +M: mode command-string>> ( mode -- string ) drop "MODE" ; +M: kick command-string>> ( kick -- string ) drop "KICK" ; -GENERIC: irc-command-parameters ( irc-message -- seq ) +GENERIC: command-parameters>> ( irc-message -- seq ) -M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ; -M: ping irc-command-parameters ( ping -- seq ) drop { } ; -M: join irc-command-parameters ( join -- seq ) drop { } ; -M: part irc-command-parameters ( part -- seq ) channel>> 1array ; -M: quit irc-command-parameters ( quit -- seq ) drop { } ; -M: nick irc-command-parameters ( nick -- seq ) drop { } ; -M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; -M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; -M: kick irc-command-parameters ( kick -- seq ) +M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ; +M: ping command-parameters>> ( ping -- seq ) drop { } ; +M: join command-parameters>> ( join -- seq ) drop { } ; +M: part command-parameters>> ( part -- seq ) channel>> 1array ; +M: quit command-parameters>> ( quit -- seq ) drop { } ; +M: nick command-parameters>> ( nick -- seq ) drop { } ; +M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ; +M: notice command-parameters>> ( norice -- seq ) type>> 1array ; +M: kick command-parameters>> ( kick -- seq ) [ channel>> ] [ who>> ] bi 2array ; -M: mode irc-command-parameters ( mode -- seq ) +M: mode command-parameters>> ( mode -- seq ) [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; +GENERIC: (>>command-parameters) ( params irc-message -- ) + +M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; +M: logged-in (>>command-parameters) ( params part -- ) >r first r> (>>name) ; +M: part (>>command-parameters) ( params part -- ) >r first r> (>>channel) ; +M: privmsg (>>command-parameters) ( params privmsg -- ) >r first r> (>>name) ; +M: notice (>>command-parameters) ( params notice -- ) >r first r> (>>type) ; +M: kick (>>command-parameters) ( params kick -- ) + >r first2 r> [ (>>who) ] [ (>>channel) ] bi ; +M: mode (>>command-parameters) ( params mode -- ) + >r first2 r> [ (>>mode) ] [ (>>channel) ] bi ; ! FIXME +M: names-reply (>>command-parameters) ( params names-reply -- ) + [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; + PRIVATE> GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) - [ irc-command-string ] - [ irc-command-parameters " " sjoin ] + [ command-string>> ] + [ command-parameters>> " " sjoin ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; @@ -96,6 +110,15 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; +: copy-contents ( origin dest -- ) + { [ >r parameters>> r> [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] + [ >r line>> r> (>>line) ] + [ >r prefix>> r> (>>prefix) ] + [ >r command>> r> (>>command) ] + [ >r trailing>> r> (>>trailing) ] + [ >r timestamp>> r> (>>timestamp) ] + } 2cleave ; + PRIVATE> UNION: sender-in-prefix privmsg join part quit kick mode nick ; @@ -111,20 +134,18 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ ping ] } - { "NOTICE" [ notice ] } - { "001" [ logged-in ] } - { "433" [ nick-in-use ] } - { "353" [ names-reply ] } - { "JOIN" [ join ] } - { "PART" [ part ] } - { "NICK" [ nick ] } - { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } - [ drop unhandled ] + { "PING" [ ping new ] } + { "NOTICE" [ notice new ] } + { "001" [ logged-in new ] } + { "433" [ nick-in-use new ] } + { "353" [ names-reply new ] } + { "JOIN" [ join new ] } + { "PART" [ part new ] } + { "NICK" [ nick new ] } + { "PRIVMSG" [ privmsg new ] } + { "QUIT" [ quit new ] } + { "MODE" [ mode new ] } + { "KICK" [ kick new ] } + [ drop unhandled new ] } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head ] keep - prefix >tuple ; + [ copy-contents ] keep ; From db1d988988a96a08bc68daff3f5d8aaf34739811 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 5 Sep 2008 02:19:30 -0300 Subject: [PATCH 018/294] Makefile: oops, revert --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 8831ed9c7e..769aeacb8c 100755 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ CFLAGS = -Wall ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 -fno-forward-propagate $(SITE_CFLAGS) + CFLAGS += -O3 $(SITE_CFLAGS) endif ifdef CONFIG From 50e5ffa594284d9eb4402627786bea26acc0a32b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 6 Sep 2008 18:39:00 -0300 Subject: [PATCH 019/294] irc.messages: Handle mode messages better, tests --- extra/irc/messages/messages-tests.factor | 90 ++++++++++++++---------- extra/irc/messages/messages.factor | 48 ++++++++----- 2 files changed, 82 insertions(+), 56 deletions(-) diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 20f4f1b277..ca8a4b1f50 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -6,54 +6,70 @@ IN: irc.messages.tests { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test -irc-message new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing -1array +{ T{ irc-message + { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } + { prefix "someuser!n=user@some.where" } + { command "PRIVMSG" } + { parameters { "#factortest" } } + { trailing "hi" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" string>irc-message f >>timestamp ] unit-test -privmsg new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing - "#factortest" >>name -1array +{ T{ privmsg + { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } + { prefix "someuser!n=user@some.where" } + { command "PRIVMSG" } + { parameters { "#factortest" } } + { trailing "hi" } + { name "#factortest" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" parse-irc-line f >>timestamp ] unit-test -join new - ":someuser!n=user@some.where JOIN :#factortest" >>line - "someuser!n=user@some.where" >>prefix - "JOIN" >>command - { } >>parameters - "#factortest" >>trailing -1array +{ T{ join + { line ":someuser!n=user@some.where JOIN :#factortest" } + { prefix "someuser!n=user@some.where" } + { command "JOIN" } + { parameters { } } + { trailing "#factortest" } } } [ ":someuser!n=user@some.where JOIN :#factortest" parse-irc-line f >>timestamp ] unit-test -mode new - ":ircserver.net MODE #factortest +ns" >>line - "ircserver.net" >>prefix - "MODE" >>command - { "#factortest" "+ns" } >>parameters - "#factortest" >>channel - "+ns" >>mode -1array +{ T{ mode + { line ":ircserver.net MODE #factortest +ns" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "#factortest" "+ns" } } + { channel "#factortest" } + { mode "+ns" } } } [ ":ircserver.net MODE #factortest +ns" parse-irc-line f >>timestamp ] unit-test -nick new - ":someuser!n=user@some.where NICK :someuser2" >>line - "someuser!n=user@some.where" >>prefix - "NICK" >>command - { } >>parameters - "someuser2" >>trailing -1array +{ T{ mode + { line ":ircserver.net MODE #factortest +o someuser" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "#factortest" "+o" "someuser" } } + { channel "#factortest" } + { mode "+o" } + { parameter "someuser" } } } +[ ":ircserver.net MODE #factortest +o someuser" + parse-irc-line f >>timestamp ] unit-test + +{ T{ mode + { line ":ircserver.net MODE someuser +i" } + { prefix "ircserver.net" } + { command "MODE" } + { parameters { "someuser" "+i" } } + { nickname "someuser" } + { mode "+i" } } } +[ ":ircserver.net MODE someuser +i" + parse-irc-line f >>timestamp ] unit-test + +{ T{ nick + { line ":someuser!n=user@some.where NICK :someuser2" } + { prefix "someuser!n=user@some.where" } + { command "NICK" } + { parameters { } } + { trailing "someuser2" } } } [ ":someuser!n=user@some.where NICK :someuser2" parse-irc-line f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 981844f187..6159c3d97d 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -18,7 +18,7 @@ TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message channel mode ; +TUPLE: mode < irc-message channel mode nickname parameter ; TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; @@ -28,6 +28,9 @@ TUPLE: unhandled < irc-message ; > ( irc-message -- string ) M: irc-message command-string>> ( irc-message -- string ) command>> ; @@ -65,10 +68,18 @@ M: privmsg (>>command-parameters) ( params privmsg -- ) >r first r> (>>name) ; M: notice (>>command-parameters) ( params notice -- ) >r first r> (>>type) ; M: kick (>>command-parameters) ( params kick -- ) >r first2 r> [ (>>who) ] [ (>>channel) ] bi ; -M: mode (>>command-parameters) ( params mode -- ) - >r first2 r> [ (>>mode) ] [ (>>channel) ] bi ; ! FIXME M: names-reply (>>command-parameters) ( params names-reply -- ) [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; +M: mode (>>command-parameters) ( params mode -- ) + over first channel? [ + over length 3 = [ + >r first3 r> [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri + ] [ + >r first2 r> [ (>>mode) ] [ (>>channel) ] bi + ] if + ] [ + >r first2 r> [ (>>mode) ] [ (>>nickname) ] bi + ] if ; PRIVATE> @@ -110,7 +121,7 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; -: copy-contents ( origin dest -- ) +: copy-message-in ( origin dest -- ) { [ >r parameters>> r> [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] [ >r line>> r> (>>line) ] [ >r prefix>> r> (>>prefix) ] @@ -134,18 +145,17 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ ping new ] } - { "NOTICE" [ notice new ] } - { "001" [ logged-in new ] } - { "433" [ nick-in-use new ] } - { "353" [ names-reply new ] } - { "JOIN" [ join new ] } - { "PART" [ part new ] } - { "NICK" [ nick new ] } - { "PRIVMSG" [ privmsg new ] } - { "QUIT" [ quit new ] } - { "MODE" [ mode new ] } - { "KICK" [ kick new ] } - [ drop unhandled new ] - } case - [ copy-contents ] keep ; + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "NICK" [ nick ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] + } case new [ copy-message-in ] keep ; From 007c68ab6baef0c92bd77f7c65f98715c79afca7 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 6 Sep 2008 19:29:18 -0300 Subject: [PATCH 020/294] irc.messages: handle mode parameters using inverse's switch --- extra/irc/messages/messages.factor | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 6159c3d97d..9cae8f6159 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators qualified - arrays classes.tuple math.order quotations ; + arrays classes.tuple math.order inverse ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.messages @@ -59,6 +59,9 @@ M: kick command-parameters>> ( kick -- seq ) M: mode command-parameters>> ( mode -- seq ) [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; +: (>>channel|nickname) ( string mode -- ) + over channel? [ (>>channel) ] [ (>>nickname) ] if ; + GENERIC: (>>command-parameters) ( params irc-message -- ) M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; @@ -71,15 +74,9 @@ M: kick (>>command-parameters) ( params kick -- ) M: names-reply (>>command-parameters) ( params names-reply -- ) [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - over first channel? [ - over length 3 = [ - >r first3 r> [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri - ] [ - >r first2 r> [ (>>mode) ] [ (>>channel) ] bi - ] if - ] [ - >r first2 r> [ (>>mode) ] [ (>>nickname) ] bi - ] if ; + { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>channel|nickname) ] bi ] } + { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri ] } + } switch ; PRIVATE> From 198e35fac2a7b4b9e9bb3a24cae1bdba7cb45283 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 7 Sep 2008 00:14:51 -0300 Subject: [PATCH 021/294] irc.messages: Remove nickname/channel distiction --- extra/irc/client/client.factor | 2 +- extra/irc/messages/messages-tests.factor | 14 ++------------ extra/irc/messages/messages.factor | 12 +++--------- 3 files changed, 6 insertions(+), 22 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 575c26972f..7d4c4977bb 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -183,7 +183,7 @@ GENERIC: forward-name ( irc-message -- name ) M: join forward-name ( join -- name ) trailing>> ; M: part forward-name ( part -- name ) channel>> ; M: kick forward-name ( kick -- name ) channel>> ; -M: mode forward-name ( mode -- name ) channel>> ; +M: mode forward-name ( mode -- name ) name>> ; M: privmsg forward-name ( privmsg -- name ) dup name>> me? [ irc-message-sender ] [ name>> ] if ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index ca8a4b1f50..b61dd16448 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -39,7 +39,7 @@ IN: irc.messages.tests { prefix "ircserver.net" } { command "MODE" } { parameters { "#factortest" "+ns" } } - { channel "#factortest" } + { name "#factortest" } { mode "+ns" } } } [ ":ircserver.net MODE #factortest +ns" parse-irc-line f >>timestamp ] unit-test @@ -49,22 +49,12 @@ IN: irc.messages.tests { prefix "ircserver.net" } { command "MODE" } { parameters { "#factortest" "+o" "someuser" } } - { channel "#factortest" } + { name "#factortest" } { mode "+o" } { parameter "someuser" } } } [ ":ircserver.net MODE #factortest +o someuser" parse-irc-line f >>timestamp ] unit-test -{ T{ mode - { line ":ircserver.net MODE someuser +i" } - { prefix "ircserver.net" } - { command "MODE" } - { parameters { "someuser" "+i" } } - { nickname "someuser" } - { mode "+i" } } } -[ ":ircserver.net MODE someuser +i" - parse-irc-line f >>timestamp ] unit-test - { T{ nick { line ":someuser!n=user@some.where NICK :someuser2" } { prefix "someuser!n=user@some.where" } diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 9cae8f6159..bb78efd680 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -18,7 +18,7 @@ TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message channel mode nickname parameter ; +TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-message ; @@ -28,9 +28,6 @@ TUPLE: unhandled < irc-message ; > ( irc-message -- string ) M: irc-message command-string>> ( irc-message -- string ) command>> ; @@ -59,9 +56,6 @@ M: kick command-parameters>> ( kick -- seq ) M: mode command-parameters>> ( mode -- seq ) [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; -: (>>channel|nickname) ( string mode -- ) - over channel? [ (>>channel) ] [ (>>nickname) ] if ; - GENERIC: (>>command-parameters) ( params irc-message -- ) M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; @@ -74,8 +68,8 @@ M: kick (>>command-parameters) ( params kick -- ) M: names-reply (>>command-parameters) ( params names-reply -- ) [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>channel|nickname) ] bi ] } - { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri ] } + { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } + { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } } switch ; PRIVATE> From c3380865c107824ac6a7081b9de46f124ecdb71a Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 11 Sep 2008 03:35:34 -0300 Subject: [PATCH 022/294] irc.messages: dip --- extra/irc/messages/messages.factor | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index bb78efd680..db25ba86d8 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -59,17 +59,18 @@ M: mode command-parameters>> ( mode -- seq ) GENERIC: (>>command-parameters) ( params irc-message -- ) M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; -M: logged-in (>>command-parameters) ( params part -- ) >r first r> (>>name) ; -M: part (>>command-parameters) ( params part -- ) >r first r> (>>channel) ; -M: privmsg (>>command-parameters) ( params privmsg -- ) >r first r> (>>name) ; -M: notice (>>command-parameters) ( params notice -- ) >r first r> (>>type) ; +M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ; +M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ; +M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ; +M: part (>>command-parameters) ( params part -- ) + [ first ] dip (>>channel) ; M: kick (>>command-parameters) ( params kick -- ) - >r first2 r> [ (>>who) ] [ (>>channel) ] bi ; + [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ; M: names-reply (>>command-parameters) ( params names-reply -- ) - [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ; + [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } - { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } + { { [ [ 2array ] dip ] [ [ (>>mode) ] [ (>>name) ] bi ] } + { [ [ 3array ] dip ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } } switch ; PRIVATE> @@ -113,12 +114,12 @@ M: irc-message irc-message>server-line ( irc-message -- string ) ":" split1 ; : copy-message-in ( origin dest -- ) - { [ >r parameters>> r> [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] - [ >r line>> r> (>>line) ] - [ >r prefix>> r> (>>prefix) ] - [ >r command>> r> (>>command) ] - [ >r trailing>> r> (>>trailing) ] - [ >r timestamp>> r> (>>timestamp) ] + { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ] + [ [ line>> ] dip (>>line) ] + [ [ prefix>> ] dip (>>prefix) ] + [ [ command>> ] dip (>>command) ] + [ [ trailing>> ] dip (>>trailing) ] + [ [ timestamp>> ] dip (>>timestamp) ] } 2cleave ; PRIVATE> From 4f6ae2dee6bff6af2c3af5a8c1afbceb6108c1d2 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 11 Sep 2008 18:15:48 -0700 Subject: [PATCH 023/294] Adding support for MacVim. --- basis/editors/macvim/authors.txt | 1 + basis/editors/macvim/macvim.factor | 13 +++++++++++++ basis/editors/macvim/summary.txt | 1 + basis/editors/macvim/tags.txt | 1 + 4 files changed, 16 insertions(+) create mode 100644 basis/editors/macvim/authors.txt create mode 100755 basis/editors/macvim/macvim.factor create mode 100644 basis/editors/macvim/summary.txt create mode 100644 basis/editors/macvim/tags.txt diff --git a/basis/editors/macvim/authors.txt b/basis/editors/macvim/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/macvim/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor new file mode 100755 index 0000000000..b5f864dcd0 --- /dev/null +++ b/basis/editors/macvim/macvim.factor @@ -0,0 +1,13 @@ +USING: definitions io.launcher kernel math math.parser parser +namespaces prettyprint editors make ; + +IN: editors.macvim + +: macvim-location ( file line -- ) + drop + [ "open" , "-a" , "MacVim", , ] { } make + try-process ; + +[ macvim-location ] edit-hook set-global + + diff --git a/basis/editors/macvim/summary.txt b/basis/editors/macvim/summary.txt new file mode 100644 index 0000000000..894d635b47 --- /dev/null +++ b/basis/editors/macvim/summary.txt @@ -0,0 +1 @@ +MacVim editor integration diff --git a/basis/editors/macvim/tags.txt b/basis/editors/macvim/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/macvim/tags.txt @@ -0,0 +1 @@ +unportable From b1231476c50f65af2936d1bd3e4d6bfefab1316d Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 11 Sep 2008 18:15:59 -0700 Subject: [PATCH 024/294] Adding support for TextEdit. --- basis/editors/textedit/authors.txt | 1 + basis/editors/textedit/summary.txt | 1 + basis/editors/textedit/tags.txt | 1 + basis/editors/textedit/textedit.factor | 13 +++++++++++++ 4 files changed, 16 insertions(+) create mode 100644 basis/editors/textedit/authors.txt create mode 100644 basis/editors/textedit/summary.txt create mode 100644 basis/editors/textedit/tags.txt create mode 100755 basis/editors/textedit/textedit.factor diff --git a/basis/editors/textedit/authors.txt b/basis/editors/textedit/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/textedit/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/textedit/summary.txt b/basis/editors/textedit/summary.txt new file mode 100644 index 0000000000..1d72d10db0 --- /dev/null +++ b/basis/editors/textedit/summary.txt @@ -0,0 +1 @@ +TextEdit editor integration diff --git a/basis/editors/textedit/tags.txt b/basis/editors/textedit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/textedit/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor new file mode 100755 index 0000000000..6942e24534 --- /dev/null +++ b/basis/editors/textedit/textedit.factor @@ -0,0 +1,13 @@ +USING: definitions io.launcher kernel math math.parser parser +namespaces prettyprint editors make ; + +IN: editors.textedit + +: textedit-location ( file line -- ) + drop + [ "open" , "-a" , "TextEdit", , ] { } make + try-process ; + +[ textedit-location ] edit-hook set-global + + From 571794ba057b403c1cdf23d99c033fbe9614a54e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 11 Sep 2008 18:16:35 -0700 Subject: [PATCH 025/294] Initial version of printf. --- extra/printf/authors.txt | 1 + extra/printf/printf-tests.factor | 79 ++++++++++++++++++ extra/printf/printf.factor | 135 +++++++++++++++++++++++++++++++ 3 files changed, 215 insertions(+) create mode 100644 extra/printf/authors.txt create mode 100644 extra/printf/printf-tests.factor create mode 100644 extra/printf/printf.factor diff --git a/extra/printf/authors.txt b/extra/printf/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/printf/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor new file mode 100644 index 0000000000..b2a49573f7 --- /dev/null +++ b/extra/printf/printf-tests.factor @@ -0,0 +1,79 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: kernel printf tools.test ; + +[ t ] [ "10" [ "%d" { 10 } sprintf ] call = ] unit-test + +[ t ] [ "123.456" [ "%f" { 123.456 } sprintf ] call = ] unit-test + +[ t ] [ "123.10" [ "%01.2f" { 123.1 } sprintf ] call = ] unit-test + +[ t ] [ "1.2345" [ "%.4f" { 1.23456789 } sprintf ] call = ] unit-test + +[ t ] [ " 1.23" [ "%6.2f" { 1.23456789 } sprintf ] call = ] unit-test + +[ t ] [ "3.625e+8" [ "%.3e" { 362525200 } sprintf ] call = ] unit-test + +[ t ] [ "2008-09-10" + [ "%04d-%02d-%02d" { 2008 9 10 } sprintf ] call = ] unit-test + +[ t ] [ "Hello, World!" + [ "%s" { "Hello, World!" } sprintf ] call = ] unit-test + +[ t ] [ "printf test" + [ "printf test" { } sprintf ] call = ] unit-test + +[ t ] [ "char a = 'a'" + [ "char %c = 'a'" { CHAR: a } sprintf ] call = ] unit-test + +[ t ] [ "00" [ "%02x" { HEX: 0 } sprintf ] call = ] unit-test + +[ t ] [ "ff" [ "%02x" { HEX: ff } sprintf ] call = ] unit-test + +[ t ] [ "signed -3 = unsigned 4294967293 = hex fffffffd" + [ "signed %d = unsigned %u = hex %x" { -3 -3 -3 } sprintf ] call = ] unit-test + +[ t ] [ "0 message(s)" + [ "%d %s(s)%" { 0 "message" } sprintf ] call = ] unit-test + +[ t ] [ "0 message(s) with %" + [ "%d %s(s) with %%" { 0 "message" } sprintf ] call = ] unit-test + +[ t ] [ "justif: \"left \"" + [ "justif: \"%-10s\"" { "left" } sprintf ] call = ] unit-test + +[ t ] [ "justif: \" right\"" + [ "justif: \"%10s\"" { "right" } sprintf ] call = ] unit-test + +[ t ] [ " 3: 0003 zero padded" + [ " 3: %04d zero padded" { 3 } sprintf ] call = ] unit-test + +[ t ] [ " 3: 3 left justif" + [ " 3: %-4d left justif" { 3 } sprintf ] call = ] unit-test + +[ t ] [ " 3: 3 right justif" + [ " 3: %4d right justif" { 3 } sprintf ] call = ] unit-test + +[ t ] [ " -3: -003 zero padded" + [ " -3: %04d zero padded" { -3 } sprintf ] call = ] unit-test + +[ t ] [ " -3: -3 left justif" + [ " -3: %-4d left justif" { -3 } sprintf ] call = ] unit-test + +[ t ] [ " -3: -3 right justif" + [ " -3: %4d right justif" { -3 } sprintf ] call = ] unit-test + +[ t ] [ "There are 10 monkeys in the kitchen" + [ "There are %d monkeys in the %s" { 10 "kitchen" } sprintf ] call = ] unit-test + +[ f ] [ "%d" [ "%d" 10 sprintf ] call = ] unit-test + +[ t ] [ "[monkey]" [ "[%s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[ monkey]" [ "[%10s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[monkey ]" [ "[%-10s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[0000monkey]" [ "[%010s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[####monkey]" [ "[%'#10s]" { "monkey" } sprintf ] call = ] unit-test +[ t ] [ "[many monke]" [ "[%10.10s]" { "many monkeys" } sprintf ] call = ] unit-test + + diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor new file mode 100644 index 0000000000..8638afcca6 --- /dev/null +++ b/extra/printf/printf.factor @@ -0,0 +1,135 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: ascii io io.encodings.ascii io.files present kernel strings +math math.parser unicode.case sequences combinators +accessors namespaces prettyprint vectors ; + +IN: printf + +! FIXME: Handle invalid formats properly. +! FIXME: Handle incomplete formats properly. +! FIXME: Deal only with CHAR rather than converting to { CHAR } ? +! FIXME: Understand intermediate allocations that are happening... + +TUPLE: state type pad align width decimals neg loop ; + +SYMBOL: current + +SYMBOL: args + +>type + CHAR: \s >>pad + CHAR: r >>align + 0 >>width + -1 >>decimals + f >>neg + CHAR: % >>loop + current set ; + +: stop-% ( -- ) + current off ; + +: render ( s -- s ) + >vector + + current get decimals>> 0 >= current get type>> CHAR: f = and + [ CHAR: . swap dup rot swap index current get decimals>> + 1 + dup rot swap + CHAR: 0 pad-right swap 0 swap rot ] when + + current get align>> CHAR: l = + + [ current get neg>> [ { CHAR: - } prepend ] when + current get width>> CHAR: \s pad-right ] + + [ current get pad>> CHAR: \s = + [ current get neg>> [ { CHAR: - } prepend ] when + current get width>> current get pad>> pad-left ] + [ current get width>> current get neg>> [ 1 - ] when + current get pad>> pad-left + current get neg>> [ { CHAR: - } prepend ] when ] if + ] if + + current get decimals>> 0 >= current get type>> CHAR: f = not and + [ current get align>> CHAR: l = + [ current get decimals>> CHAR: \s pad-right ] + [ current get decimals>> current get pad>> pad-left ] if + current get decimals>> head-slice ] when + >string ; + +: loop-% ( c -- s ) + current get swap + { + { CHAR: % [ drop stop-% "%" ] } + { CHAR: ' [ CHAR: ' >>loop drop "" ] } + { CHAR: . [ CHAR: . >>loop 0 >>decimals drop "" ] } + { CHAR: - [ CHAR: l >>align drop "" ] } + { CHAR: 0 [ dup width>> 0 = [ CHAR: 0 >>pad ] when + [ 10 * 0 + ] change-width drop "" ] } + { CHAR: 1 [ [ 10 * 1 + ] change-width drop "" ] } + { CHAR: 2 [ [ 10 * 2 + ] change-width drop "" ] } + { CHAR: 3 [ [ 10 * 3 + ] change-width drop "" ] } + { CHAR: 4 [ [ 10 * 4 + ] change-width drop "" ] } + { CHAR: 5 [ [ 10 * 5 + ] change-width drop "" ] } + { CHAR: 6 [ [ 10 * 6 + ] change-width drop "" ] } + { CHAR: 7 [ [ 10 * 7 + ] change-width drop "" ] } + { CHAR: 8 [ [ 10 * 8 + ] change-width drop "" ] } + { CHAR: 9 [ [ 10 * 9 + ] change-width drop "" ] } + { CHAR: d [ CHAR: d >>type drop + args get pop >fixnum + dup 0 < [ current get t >>neg drop ] when + abs present render stop-% ] } + { CHAR: f [ CHAR: f >>type drop + args get pop >float + dup 0 < [ current get t >>neg drop ] when + abs present render stop-% ] } + { CHAR: s [ CHAR: s >>type drop + args get pop present render stop-% ] } + { CHAR: c [ CHAR: c >>type 1 >>width drop + 1 args get pop stop-% ] } + { CHAR: x [ CHAR: x >>type drop + args get pop >hex present render stop-% ] } + { CHAR: X [ CHAR: X >>type drop + args get pop >hex present >upper render stop-% ] } + [ drop drop stop-% "" ] + } case ; + +: loop-. ( c -- s ) + dup digit? current get swap + [ swap CHAR: 0 - swap [ 10 * + ] change-decimals drop "" ] + [ CHAR: % >>loop drop loop-% ] if ; + +: loop-' ( c -- s ) + current get swap >>pad CHAR: % >>loop drop "" ; + +: loop- ( c -- s ) + dup CHAR: % = [ drop start-% "" ] [ 1 swap ] if ; + +: loop ( c -- s ) + current get + [ current get loop>> + { + { CHAR: % [ loop-% ] } + { CHAR: ' [ loop-' ] } + { CHAR: . [ loop-. ] } + [ drop stop-% loop- ] ! FIXME: RAISE ERROR + } case ] + [ loop- ] if ; + +PRIVATE> + +: sprintf ( fmt args -- str ) + [ >vector reverse args set + V{ } swap [ loop append ] each >string ] with-scope ; + +: printf ( fmt args -- ) + sprintf print ; + +: fprintf ( path fmt args -- ) + rot ascii [ sprintf write flush ] with-file-appender ; + + From 0aa4000c462b81e5518568ae0dd4ef1b17289b9f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 14 Sep 2008 09:45:26 -0500 Subject: [PATCH 026/294] more docs --- core/sequences/sequences-docs.factor | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 5c0dbf7985..6207b5beb1 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -65,7 +65,8 @@ ARTICLE: "sequences-add-remove" "Adding and removing sequence elements" { $subsection prefix } { $subsection suffix } "Removing elements:" -{ $subsection remove } ; +{ $subsection remove } +{ $subsection remove-nth } ; ARTICLE: "sequences-reshape" "Reshaping sequences" "A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:" @@ -124,6 +125,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices" ARTICLE: "sequences-combinators" "Sequence combinators" "Iteration:" { $subsection each } +{ $subsection each-index } { $subsection reduce } { $subsection interleave } { $subsection replicate } @@ -131,6 +133,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators" "Mapping:" { $subsection map } { $subsection map-as } +{ $subsection map-index } { $subsection accumulate } { $subsection produce } "Filtering:" @@ -533,6 +536,24 @@ HELP: map-as "Note that " { $link map } " could not be used here, because it would create another string to hold results, and one-element strings cannot themselves be elements of strings." } ; +HELP: each-index +{ $values + { "seq" sequence } { "quot" quotation } } +{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack." } +{ $examples { $example "USING: sequences prettyprint math ;" +"{ 10 20 30 } [ + . ] each-index" +"10\n21\n32" +} } ; + +HELP: map-index +{ $values + { "seq" sequence } { "quot" quotation } } +{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." } +{ $examples { $example "USING: sequences prettyprint math ;" +"{ 10 20 30 } [ + ] map-index ." +"{ 10 21 32 }" +} } ; + HELP: change-nth { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } } { $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." } From ccac749a70c336305fb98bf99967055986dcfe44 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 14 Sep 2008 10:04:04 -0700 Subject: [PATCH 027/294] Adding support for fry quotations. --- misc/factor.vim | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/misc/factor.vim b/misc/factor.vim index d1c46cee0b..90a3d46d50 100644 --- a/misc/factor.vim +++ b/misc/factor.vim @@ -131,18 +131,18 @@ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained "adapted from lisp.vim if exists("g:factor_norainbow") - syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL + syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL else - syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 - syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 - syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 - syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 - syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 - syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 - syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 - syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 - syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 - syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 + syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 + syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 + syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 + syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 + syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 + syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 + syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 + syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 + syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 + syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 endif if exists("g:factor_norainbow") From e501a411fed86519d49c9f25d405046d671c6d71 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 14 Sep 2008 22:28:54 -0500 Subject: [PATCH 028/294] add about, article --- basis/channels/channels-docs.factor | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/basis/channels/channels-docs.factor b/basis/channels/channels-docs.factor index 521a4a4ae2..b6ddc299e5 100644 --- a/basis/channels/channels-docs.factor +++ b/basis/channels/channels-docs.factor @@ -33,3 +33,14 @@ HELP: from " It will block the calling thread until there is data in the channel." } { $see-also to } ; + +ARTICLE: "channels" "Channels" +"The " { $vocab-link "channels" } " vocabulary provides a simple abstraction to send and receive objects." $nl +"Opening a channel:" +{ $subsection } +"Sending a message:" +{ $subsection to } +"Receiving a message:" +{ $subsection from } ; + +ABOUT: "channels" From 7d418ec3de8c6433d62b054b72d68a08c19be8d6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 14 Sep 2008 23:27:37 -0500 Subject: [PATCH 029/294] add some docs to circular --- basis/circular/circular-docs.factor | 58 +++++++++++++++++++++++++++++ basis/circular/circular.factor | 4 ++ 2 files changed, 62 insertions(+) create mode 100644 basis/circular/circular-docs.factor diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor new file mode 100644 index 0000000000..362d41c9de --- /dev/null +++ b/basis/circular/circular-docs.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax io.streams.string sequences +math kernel ; +IN: circular + +HELP: +{ $values + { "n" integer } + { "circular" circular } } +{ $description "Creates a new circular string object. A circular string is a string object that can be accessed out of bounds and the index will wrap around to the start of the string." } ; + +HELP: +{ $values + { "seq" sequence } + { "circular" circular } } +{ $description "Creates a new " { $link circular } " object that wraps an existing sequence. By default, the index is set to zero." } ; + +HELP: +{ $values + { "capacity" integer } + { "growing-circular" growing-circular } } +{ $description "Creates a new growing-circular object." } ; + +HELP: change-circular-start +{ $values + { "n" integer } { "circular" circular } } +{ $description "Changes the start index of a circular object." } ; + +HELP: circular +{ $description "A tuple class that stores a sequence and its start index." } ; + +HELP: growing-circular +{ $description "A circular sequence that is growable." } ; + +HELP: push-circular +{ $values + { "elt" object } { "circular" circular } } +{ $description "Pushes an element to a " { $link circular } " object." } ; + +HELP: push-growing-circular +{ $values + { "elt" object } { "circular" circular } } +{ $description "Pushes an element onto a " { $link growing-circular } " object." } ; + +ARTICLE: "circular" "circular" +"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl +"Creating a new circular object:" +{ $subsection } +{ $subsection } +{ $subsection } +"Changing the start index:" +{ $subsection change-circular-start } +"Pushing new elements:" +{ $subsection push-circular } +{ $subsection push-growing-circular } ; + +ABOUT: "circular" diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 5d2378120f..9f3a71f2a8 100755 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -11,9 +11,11 @@ TUPLE: circular seq start ; : ( seq -- circular ) 0 circular boa ; +> + ] keep [ seq>> length rem ] keep ; inline +PRIVATE> M: circular length seq>> length ; @@ -37,11 +39,13 @@ TUPLE: growing-circular < circular length ; M: growing-circular length length>> ; +> length ] bi = ; : set-peek ( elt seq -- ) [ length 1- ] keep set-nth ; +PRIVATE> : push-growing-circular ( elt circular -- ) dup full? [ push-circular ] From 6455b44d582d975963eb6ed132148767c63870f9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 14 Sep 2008 23:32:25 -0500 Subject: [PATCH 030/294] move the article down --- basis/columns/columns-docs.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/columns/columns-docs.factor b/basis/columns/columns-docs.factor index 818ce2f752..27dc160812 100644 --- a/basis/columns/columns-docs.factor +++ b/basis/columns/columns-docs.factor @@ -1,13 +1,6 @@ USING: help.markup help.syntax sequences ; IN: columns -ARTICLE: "columns" "Column sequences" -"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" -{ $subsection column } -{ $subsection } -"A utility word:" -{ $subsection } ; - HELP: column { $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ; @@ -30,4 +23,11 @@ HELP: { $description "Outputs a new virtual sequence which presents the transpose of " { $snippet "seq" } "." } { $notes "This is the virtual sequence equivalent of " { $link flip } "." } ; +ARTICLE: "columns" "Column sequences" +"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" +{ $subsection column } +{ $subsection } +"A utility word:" +{ $subsection } ; + ABOUT: "columns" From d5281cbe464155df51e243156470269ffd29d211 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 00:03:53 -0500 Subject: [PATCH 031/294] add docs for short-circuit combinators --- .../short-circuit/short-circuit-docs.factor | 84 +++++++++++++++++++ 1 file changed, 84 insertions(+) create mode 100644 basis/combinators/short-circuit/short-circuit-docs.factor diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor new file mode 100644 index 0000000000..058291d022 --- /dev/null +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -0,0 +1,84 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax io.streams.string quotations +math ; +IN: combinators.short-circuit + +HELP: 0&& +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if every quotation in the sequence of quotations returns true." } ; + +HELP: 0|| +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if any quotation in the sequence returns true." } ; + +HELP: 1&& +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ; + +HELP: 1|| +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ; + +HELP: 2&& +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ; + +HELP: 2|| +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ; + +HELP: 3&& +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ; + +HELP: 3|| +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ; + +HELP: n&&-rewrite +{ $values + { "quots" "a sequence of quotations" } { "N" integer } + { "quot" quotation } } +{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ; + +HELP: n||-rewrite +{ $values + { "quots" "a sequence of quotations" } { "N" integer } + { "quot" quotation } } +{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ; + +ARTICLE: "combinators.short-circuit" "combinators.short-circuit" +"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl +"AND combinators:" +{ $subsection 0&& } +{ $subsection 1&& } +{ $subsection 2&& } +{ $subsection 3&& } +"OR combinators:" +{ $subsection 0|| } +{ $subsection 1|| } +{ $subsection 2|| } +{ $subsection 3|| } +"Generalized combinators:" +{ $subsection n&&-rewrite } +{ $subsection n||-rewrite } +; + +ABOUT: "combinators.short-circuit" From d3636216256b5799d033d8a1ddb17a23f9de9637 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Sep 2008 01:54:48 -0500 Subject: [PATCH 032/294] Live interval splitting and spilling --- unfinished/compiler/backend/x86/32/32.factor | 3 +- unfinished/compiler/backend/x86/64/64.factor | 14 ++ .../compiler/cfg/builder/builder.factor | 6 +- .../instructions/instructions.factor | 32 ++- .../instructions/syntax/syntax.factor | 2 +- .../linear-scan/allocation/allocation.factor | 210 +++++++++++++----- .../cfg/linear-scan/debugger/debugger.factor | 38 ++++ .../cfg/linear-scan/linear-scan-tests.factor | 100 +++++++++ .../live-intervals/live-intervals.factor | 49 ++-- .../cfg/linearization/linearization.factor | 7 +- .../{ => cfg}/registers/registers.factor | 2 +- unfinished/compiler/cfg/rpo/rpo.factor | 2 +- unfinished/compiler/cfg/stacks/stacks.factor | 4 +- .../compiler/cfg/templates/templates.factor | 4 +- 14 files changed, 378 insertions(+), 95 deletions(-) create mode 100644 unfinished/compiler/backend/x86/64/64.factor rename unfinished/compiler/{ => cfg}/instructions/instructions.factor (77%) rename unfinished/compiler/{ => cfg}/instructions/syntax/syntax.factor (91%) create mode 100644 unfinished/compiler/cfg/linear-scan/debugger/debugger.factor create mode 100644 unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor rename unfinished/compiler/{ => cfg}/registers/registers.factor (98%) diff --git a/unfinished/compiler/backend/x86/32/32.factor b/unfinished/compiler/backend/x86/32/32.factor index 85df673839..98726d7e35 100644 --- a/unfinished/compiler/backend/x86/32/32.factor +++ b/unfinished/compiler/backend/x86/32/32.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system cpu.x86.assembler compiler.registers compiler.backend ; +USING: system cpu.x86.assembler compiler.cfg.registers +compiler.backend ; IN: compiler.backend.x86.32 M: x86.32 machine-registers diff --git a/unfinished/compiler/backend/x86/64/64.factor b/unfinished/compiler/backend/x86/64/64.factor new file mode 100644 index 0000000000..fe21fadbd5 --- /dev/null +++ b/unfinished/compiler/backend/x86/64/64.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: system cpu.x86.assembler compiler.cfg.registers +compiler.backend ; +IN: compiler.backend.x86.64 + +M: x86.64 machine-registers + { + { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } } + { float-regs { + XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 + XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 + } } + } ; diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor index 86e69a50b7..f1199183d0 100755 --- a/unfinished/compiler/cfg/builder/builder.factor +++ b/unfinished/compiler/cfg/builder/builder.factor @@ -10,9 +10,9 @@ compiler.cfg compiler.cfg.stacks compiler.cfg.templates compiler.cfg.iterator -compiler.alien -compiler.instructions -compiler.registers ; +compiler.cfg.instructions +compiler.cfg.registers +compiler.alien ; IN: compiler.cfg.builder ! Convert tree SSA IR to CFG (not quite SSA yet) IR. diff --git a/unfinished/compiler/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor similarity index 77% rename from unfinished/compiler/instructions/instructions.factor rename to unfinished/compiler/cfg/instructions/instructions.factor index 57b3ff51fd..83532d6038 100644 --- a/unfinished/compiler/instructions/instructions.factor +++ b/unfinished/compiler/cfg/instructions/instructions.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors arrays kernel sequences namespaces -math compiler.instructions.syntax ; -IN: compiler.instructions +math compiler.cfg.instructions.syntax ; +IN: compiler.cfg.instructions ! Virtual CPU instructions, used by CFG and machine IRs @@ -46,14 +46,22 @@ INSN: %alien-invoke params ; INSN: %alien-indirect params ; INSN: %alien-callback params ; +GENERIC: defs-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) +M: insn defs-vregs drop f ; M: insn uses-vregs drop f ; -M: %peek uses-vregs vreg>> 1array ; + +M: %peek defs-vregs vreg>> 1array ; + M: %replace uses-vregs vreg>> 1array ; -M: %load-literal uses-vregs vreg>> 1array ; -M: %unary uses-vregs [ dst>> ] [ src>> ] bi 2array ; -M: %intrinsic uses-vregs vregs>> values ; + +M: %load-literal defs-vregs vreg>> 1array ; + +M: %unary defs-vregs dst>> 1array ; +M: %unary uses-vregs src>> 1array ; + +! M: %intrinsic uses-vregs vregs>> values ; ! Instructions used by CFG IR only. INSN: %prologue ; @@ -67,9 +75,13 @@ INSN: %if-intrinsic quot vregs ; INSN: %boolean-intrinsic quot vregs out ; M: %cond-branch uses-vregs vreg>> 1array ; -M: %if-intrinsic uses-vregs vregs>> values ; -M: %boolean-intrinsic uses-vregs - [ vregs>> values ] [ out>> ] bi suffix ; + +! M: %if-intrinsic uses-vregs vregs>> values ; + +M: %boolean-intrinsic defs-vregs out>> 1array ; + +! M: %boolean-intrinsic uses-vregs +! [ vregs>> values ] [ out>> ] bi suffix ; ! Instructions used by machine IR only. INSN: _prologue n ; @@ -93,4 +105,4 @@ INSN: _branch-t < _cond-branch ; INSN: _if-intrinsic label quot vregs ; M: _cond-branch uses-vregs vreg>> 1array ; -M: _if-intrinsic uses-vregs vregs>> values ; +! M: _if-intrinsic uses-vregs vregs>> values ; diff --git a/unfinished/compiler/instructions/syntax/syntax.factor b/unfinished/compiler/cfg/instructions/syntax/syntax.factor similarity index 91% rename from unfinished/compiler/instructions/syntax/syntax.factor rename to unfinished/compiler/cfg/instructions/syntax/syntax.factor index 0a4ffae876..30bec6ac37 100644 --- a/unfinished/compiler/instructions/syntax/syntax.factor +++ b/unfinished/compiler/cfg/instructions/syntax/syntax.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: classes.tuple classes.tuple.parser kernel words make parser ; -IN: compiler.instructions.syntax +IN: compiler.cfg.instructions.syntax TUPLE: insn ; diff --git a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor index 37e1d512cd..4e75957990 100644 --- a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,18 +1,30 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences math math.order kernel assocs -accessors vectors fry +accessors vectors fry heaps compiler.cfg.linear-scan.live-intervals compiler.backend ; IN: compiler.cfg.linear-scan.allocation -! Mapping from vregs to machine registers -SYMBOL: register-allocation +! Vector of live intervals we have already processed +SYMBOL: retired-intervals -! Mapping from vregs to spill locations -SYMBOL: spill-locations +: retire-interval ( live-interval -- ) + retired-intervals get push ; -! Vector of active live intervals, in order of increasing end point +: retire-intervals ( live-intervals -- ) + retired-intervals get push-all ; + +! Mapping from register classes to sequences of machine registers +SYMBOL: free-registers + +: free-registers-for ( vreg -- seq ) + reg-class>> free-registers get at ; + +: deallocate-register ( live-interval -- ) + [ reg>> ] [ vreg>> ] bi free-registers-for push ; + +! Vector of active live intervals SYMBOL: active-intervals : add-active ( live-interval -- ) @@ -21,70 +33,156 @@ SYMBOL: active-intervals : delete-active ( live-interval -- ) active-intervals get delete ; -! Mapping from register classes to sequences of machine registers -SYMBOL: free-registers +: expire-old-intervals ( n -- ) + active-intervals get + swap '[ end>> _ < ] partition + active-intervals set + [ [ retire-interval ] [ deallocate-register ] bi ] each ; -! Counter of spill locations +: expire-old-uses ( n -- ) + active-intervals get + swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ; + +: update-state ( live-interval -- ) + start>> [ expire-old-intervals ] [ expire-old-uses ] bi ; + +! Minheap of live intervals which still need a register allocation +SYMBOL: unhandled-intervals + +! Start index of current live interval. We ensure that all +! live intervals added to the unhandled set have a start index +! strictly greater than ths one. This ensures that we can catch +! infinite loop situations. +SYMBOL: progress + +: check-progress ( live-interval -- ) + start>> progress get <= [ "No progress" throw ] when ; inline + +: add-unhandled ( live-interval -- ) + [ check-progress ] + [ dup start>> unhandled-intervals get heap-push ] + bi ; + +: init-unhandled ( live-intervals -- ) + [ [ start>> ] keep ] { } map>assoc + unhandled-intervals get heap-push-all ; + +: assign-free-register ( live-interval registers -- ) + #! If the live interval does not have any uses, it means it + #! will be spilled immediately, so it still needs a register + #! to compute the new value, but we don't add the interval + #! to the active set and we don't remove the register from + #! the free list. + over uses>> empty? + [ peek >>reg drop ] [ pop >>reg add-active ] if ; + +! Spilling SYMBOL: spill-counter : next-spill-location ( -- n ) spill-counter [ dup 1+ ] change ; -: assign-spill ( live-interval -- ) - next-spill-location swap vreg>> spill-locations get set-at ; - -: free-registers-for ( vreg -- seq ) - reg-class>> free-registers get at ; - -: free-register ( vreg -- ) - #! Free machine register currently assigned to vreg. - [ register-allocation get at ] [ free-registers-for ] bi push ; - -: expire-old-intervals ( live-interval -- ) - active-intervals get - swap '[ end>> _ start>> < ] partition - active-intervals set - [ vreg>> free-register ] each ; - : interval-to-spill ( -- live-interval ) - #! We spill the interval with the longest remaining range. + #! We spill the interval with the most distant use location. active-intervals get unclip-slice [ - [ [ end>> ] bi@ > ] most + [ [ uses>> peek ] bi@ > ] most ] reduce ; -: reuse-register ( live-interval to-spill -- ) - vreg>> swap vreg>> - register-allocation get - tuck [ at ] [ set-at ] 2bi* ; +: check-split ( live-interval -- ) + [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ; -: spill-at-interval ( live-interval -- ) +: split-interval ( live-interval -- before after ) + #! Split the live interval at the location of its first use. + #! 'Before' now starts and ends on the same instruction. + [ check-split ] + [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ] + [ clone f >>reg dup uses>> peek >>start ] + tri ; + +: record-split ( live-interval before after -- ) + [ >>split-before ] [ >>split-after ] bi* drop ; + +: assign-spill ( before after -- before after ) + #! If it has been spilled already, reuse spill location. + over reload-from>> [ next-spill-location ] unless* + tuck [ >>spill-to ] [ >>reload-from ] 2bi* ; + +: split-and-spill ( live-interval -- before after ) + dup split-interval [ record-split ] [ assign-spill ] 2bi ; + +: reuse-register ( new existing -- ) + reg>> >>reg + dup uses>> empty? [ + [ retire-interval ] [ deallocate-register ] bi + ] [ add-active ] if ; + +: spill-existing ( new existing -- ) + #! Our new interval will be used before the active interval + #! with the most distant use location. Spill the existing + #! interval, then process the new interval and the tail end + #! of the existing interval again. + [ reuse-register ] + [ delete-active ] + [ + split-and-spill + [ retire-interval ] + [ add-unhandled ] + bi* + ] tri ; + +: spill-new ( new existing -- ) + #! Our new interval will be used after the active interval + #! with the most distant use location. Split the new + #! interval, then process both parts of the new interval + #! again. + [ split-and-spill add-unhandled ] dip spill-existing ; + +: spill-existing? ( new existing -- ? ) + over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ; + +: assign-blocked-register ( live-interval -- ) interval-to-spill - 2dup [ end>> ] bi@ > [ - [ reuse-register ] - [ nip assign-spill ] - [ [ add-active ] [ delete-active ] bi* ] - 2tri - ] [ drop assign-spill ] if ; + 2dup spill-existing? + [ spill-existing ] [ spill-new ] if ; -: init-allocator ( -- ) - H{ } clone register-allocation set - H{ } clone spill-locations set - V{ } clone active-intervals set - machine-registers [ >vector ] assoc-map free-registers set - 0 spill-counter set ; - -: assign-register ( live-interval register -- ) - swap vreg>> register-allocation get set-at ; - -: allocate-register ( live-interval -- ) +: assign-register ( live-interval -- ) dup vreg>> free-registers-for [ - spill-at-interval + assign-blocked-register ] [ - [ pop assign-register ] - [ drop add-active ] - 2bi + assign-free-register ] if-empty ; -: allocate-registers ( live-intervals -- ) - init-allocator - [ [ expire-old-intervals ] [ allocate-register ] bi ] each ; +! Main loop +: slurp-heap ( heap quot: ( elt -- ) -- ) + over heap-empty? [ 2drop ] [ + [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi + ] if ; inline recursive + +: init-allocator ( registers -- ) + V{ } clone retired-intervals set + V{ } clone active-intervals set + unhandled-intervals set + [ >vector ] assoc-map free-registers set + 0 spill-counter set + -1 progress set ; + +: handle-interval ( live-interval -- ) + [ start>> progress set ] [ update-state ] [ assign-register ] tri ; + +: (allocate-registers) ( -- ) + unhandled-intervals get [ handle-interval ] slurp-heap ; + +: finish-allocator ( -- live-intervals ) + #! After register allocation is done, we retire all + #! live intervals which are still active. + active-intervals get retire-intervals + retired-intervals get ; + +: allocate-registers ( live-intervals machine-registers -- live-intervals' ) + #! This destroys the input live-intervals. + [ + init-allocator + init-unhandled + (allocate-registers) + finish-allocator + ] with-scope ; diff --git a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor b/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor new file mode 100644 index 0000000000..b9bfb17cf6 --- /dev/null +++ b/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences sets arrays +compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.allocation ; +IN: compiler.cfg.linear-scan.debugger + +: check-assigned ( live-intervals -- ) + [ + reg>> + [ "Not all intervals have registers" throw ] unless + ] each ; + +: check-split ( live-intervals -- ) + [ + split-before>> + [ "Split intervals returned" throw ] when + ] each ; + +: split-children ( live-interval -- seq ) + dup split-before>> [ + [ split-before>> ] [ split-after>> ] bi + [ split-children ] bi@ + append + ] [ + 1array + ] if ; + +: check-retired ( original live-intervals -- ) + #! All original live intervals should have either been + #! split, or ended up in the output set. + [ [ split-children ] map concat ] dip + 2dup subset? [ "We lost some intervals" throw ] unless + swap subset? [ "We didn't record all splits" throw ] unless ; + +: check-linear-scan ( live-intervals machine-registers -- ) + [ [ clone ] map dup ] dip allocate-registers + [ check-assigned ] [ check-split ] [ check-retired ] tri ; diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor b/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor new file mode 100644 index 0000000000..00252e0c23 --- /dev/null +++ b/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -0,0 +1,100 @@ +IN: compiler.cfg.linear-scan.tests +USING: tools.test random sorting sequences sets hashtables assocs +kernel fry arrays splitting namespaces math accessors vectors +math.order +compiler.cfg.registers +compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.debugger ; + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } + } + H{ { f { "A" } } } + check-linear-scan +] unit-test + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } } + T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } } + } + H{ { f { "A" } } } + check-linear-scan +] unit-test + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } + T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } } + } + H{ { f { "A" } } } + check-linear-scan +] unit-test + +[ ] [ + { + T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } + T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } } + } + H{ { f { "A" } } } + check-linear-scan +] unit-test + +[ + { + T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } } + T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } } + } + H{ { f { "A" } } } + check-linear-scan +] must-fail + +SYMBOL: available + +SYMBOL: taken + +SYMBOL: max-registers + +SYMBOL: max-insns + +SYMBOL: max-uses + +: not-taken ( -- n ) + available get keys dup empty? [ "Oops" throw ] when + random + dup taken get nth 1 + max-registers get = [ + dup available get delete-at + ] [ + dup taken get [ 1 + ] change-nth + ] if ; + +: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq ) + [ + max-insns set + max-registers set + max-uses set + max-insns get [ 0 ] replicate taken set + max-insns get [ dup ] H{ } map>assoc available set + [ + live-interval new + swap f swap vreg boa >>vreg + max-uses get random 2 max [ not-taken ] replicate natural-sort + unclip [ >vector >>uses ] [ >>start ] bi* + dup uses>> first >>end + ] map + ] with-scope ; + +: random-test ( num-intervals max-uses max-registers max-insns -- ) + over >r random-live-intervals r> f associate check-linear-scan ; + +[ ] [ 30 2 1 60 random-test ] unit-test +[ ] [ 60 2 2 60 random-test ] unit-test +[ ] [ 80 2 3 200 random-test ] unit-test +[ ] [ 70 2 5 30 random-test ] unit-test +[ ] [ 60 2 6 30 random-test ] unit-test +[ ] [ 1 2 10 10 random-test ] unit-test + +[ ] [ 10 4 2 60 random-test ] unit-test +[ ] [ 10 20 2 400 random-test ] unit-test +[ ] [ 10 20 4 300 random-test ] unit-test diff --git a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 6a3514c4e2..77222518fa 100644 --- a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,32 +1,49 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel assocs accessors sequences math -math.order sorting compiler.instructions compiler.registers ; +USING: namespaces kernel assocs accessors sequences math fry +compiler.cfg.instructions compiler.cfg.registers ; IN: compiler.cfg.linear-scan.live-intervals -TUPLE: live-interval < identity-tuple vreg start end ; +TUPLE: live-interval < identity-tuple +vreg +reg spill-to reload-from split-before split-after +start end uses ; -M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ; +: ( start vreg -- live-interval ) + live-interval new + swap >>vreg + swap >>start + V{ } clone >>uses ; + +M: live-interval hashcode* + nip [ start>> ] [ end>> 1000 * ] bi + ; + +M: live-interval clone + call-next-method [ clone ] change-uses ; ! Mapping from vreg to live-interval SYMBOL: live-intervals -: update-live-interval ( n vreg -- ) - >vreg +: add-use ( n vreg live-intervals -- ) + at [ (>>end) ] [ uses>> push ] 2bi ; + +: new-live-interval ( n vreg live-intervals -- ) + 2dup key? [ "Multiple defs" throw ] when + [ [ ] keep ] dip set-at ; + +: compute-live-intervals* ( insn n -- ) live-intervals get - [ over f live-interval boa ] cache - (>>end) ; + [ [ uses-vregs ] 2dip '[ _ swap >vreg _ add-use ] each ] + [ [ defs-vregs ] 2dip '[ _ swap >vreg _ new-live-interval ] each ] + 3bi ; -: compute-live-intervals* ( n insn -- ) - uses-vregs [ update-live-interval ] with each ; - -: sort-live-intervals ( assoc -- seq' ) - #! Sort by increasing start location. - values [ [ start>> ] compare ] sort ; +: finalize-live-intervals ( assoc -- seq' ) + #! Reverse uses lists so that we can pop values off. + values dup [ uses>> reverse-here ] each ; : compute-live-intervals ( instructions -- live-intervals ) H{ } clone [ live-intervals [ - [ swap compute-live-intervals* ] each-index + [ compute-live-intervals* ] each-index ] with-variable - ] keep sort-live-intervals ; + ] keep finalize-live-intervals ; diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/unfinished/compiler/cfg/linearization/linearization.factor index 2aa7c66777..2c4a62d3be 100644 --- a/unfinished/compiler/cfg/linearization/linearization.factor +++ b/unfinished/compiler/cfg/linearization/linearization.factor @@ -1,8 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math accessors sequences namespaces make -combinators compiler.cfg compiler.cfg.rpo compiler.instructions -compiler.instructions.syntax ; +combinators +compiler.cfg +compiler.cfg.rpo +compiler.cfg.instructions +compiler.cfg.instructions.syntax ; IN: compiler.cfg.linearization ! Convert CFG IR to machine IR. diff --git a/unfinished/compiler/registers/registers.factor b/unfinished/compiler/cfg/registers/registers.factor similarity index 98% rename from unfinished/compiler/registers/registers.factor rename to unfinished/compiler/cfg/registers/registers.factor index 6087064c80..5eaed92072 100644 --- a/unfinished/compiler/registers/registers.factor +++ b/unfinished/compiler/cfg/registers/registers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces math kernel ; -IN: compiler.registers +IN: compiler.cfg.registers ! Virtual CPU registers, used by CFG and machine IRs diff --git a/unfinished/compiler/cfg/rpo/rpo.factor b/unfinished/compiler/cfg/rpo/rpo.factor index d5280a8142..658bd5a29b 100644 --- a/unfinished/compiler/cfg/rpo/rpo.factor +++ b/unfinished/compiler/cfg/rpo/rpo.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces make math sequences -compiler.instructions ; +compiler.cfg.instructions ; IN: compiler.cfg.rpo : post-order-traversal ( basic-block -- ) diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor index f2cfbb70a1..ae421f30f8 100755 --- a/unfinished/compiler/cfg/stacks/stacks.factor +++ b/unfinished/compiler/cfg/stacks/stacks.factor @@ -3,8 +3,8 @@ USING: arrays assocs classes classes.private classes.algebra combinators hashtables kernel layouts math fry namespaces quotations sequences system vectors words effects alien -byte-arrays accessors sets math.order compiler.instructions -compiler.registers ; +byte-arrays accessors sets math.order compiler.cfg.instructions +compiler.cfg.registers ; IN: compiler.cfg.stacks ! Converting stack operations into register operations, while diff --git a/unfinished/compiler/cfg/templates/templates.factor b/unfinished/compiler/cfg/templates/templates.factor index 798e1fd563..1be714afa5 100644 --- a/unfinished/compiler/cfg/templates/templates.factor +++ b/unfinished/compiler/cfg/templates/templates.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors sequences kernel fry namespaces -quotations combinators classes.algebra compiler.instructions -compiler.registers compiler.cfg.stacks ; +quotations combinators classes.algebra compiler.cfg.instructions +compiler.cfg.registers compiler.cfg.stacks ; IN: compiler.cfg.templates USE: qualified From 89ce8e1f3e43cf360a3c206529bde74e31e57358 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Sep 2008 02:59:00 -0500 Subject: [PATCH 033/294] Add slurp-heap combinator, like slurp-deque --- basis/heaps/heaps.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 21eab2b8f1..6c387632ed 100755 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -190,3 +190,8 @@ M: heap heap-pop ( heap -- value key ) [ dup heap-empty? not ] [ dup heap-pop swap 2array ] [ ] produce nip ; + +: slurp-heap ( heap quot: ( elt -- ) -- ) + over heap-empty? [ 2drop ] [ + [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi + ] if ; inline recursive From f7cb6e3051e27ea54e1a8ade6a6e0874b43cb03e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Sep 2008 02:59:24 -0500 Subject: [PATCH 034/294] Inserting spills and reloads --- .../cfg/instructions/instructions.factor | 36 +++---- .../linear-scan/allocation/allocation.factor | 39 +------ .../cfg/linear-scan/debugger/debugger.factor | 19 +--- .../live-intervals/live-intervals.factor | 14 ++- .../rewriting/rewriting-tests.factor | 4 + .../linear-scan/rewriting/rewriting.factor | 100 ++++++++++++++++++ .../cfg/linearization/linearization.factor | 6 +- unfinished/compiler/cfg/stacks/stacks.factor | 2 +- 8 files changed, 139 insertions(+), 81 deletions(-) create mode 100644 unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor create mode 100644 unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor index 83532d6038..ac3b3b75a0 100644 --- a/unfinished/compiler/cfg/instructions/instructions.factor +++ b/unfinished/compiler/cfg/instructions/instructions.factor @@ -6,15 +6,16 @@ IN: compiler.cfg.instructions ! Virtual CPU instructions, used by CFG and machine IRs -INSN: %cond-branch vreg ; +INSN: %cond-branch src ; INSN: %unary dst src ; +INSN: %nullary dst ; ! Stack operations -INSN: %peek vreg loc ; -INSN: %replace vreg loc ; +INSN: %load-literal < %nullary obj ; +INSN: %peek < %nullary loc ; +INSN: %replace src loc ; INSN: %inc-d n ; INSN: %inc-r n ; -INSN: %load-literal obj vreg ; ! Calling convention INSN: %return ; @@ -22,7 +23,7 @@ INSN: %return ; ! Subroutine calls INSN: %call word ; INSN: %jump word ; -INSN: %intrinsic quot vregs ; +INSN: %intrinsic quot regs ; ! Jump tables INSN: %dispatch-label label ; @@ -49,17 +50,13 @@ INSN: %alien-callback params ; GENERIC: defs-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) -M: insn defs-vregs drop f ; -M: insn uses-vregs drop f ; - -M: %peek defs-vregs vreg>> 1array ; - -M: %replace uses-vregs vreg>> 1array ; - -M: %load-literal defs-vregs vreg>> 1array ; - +M: %nullary defs-vregs dst>> 1array ; M: %unary defs-vregs dst>> 1array ; +M: insn defs-vregs drop f ; + +M: %replace uses-vregs src>> 1array ; M: %unary uses-vregs src>> 1array ; +M: insn uses-vregs drop f ; ! M: %intrinsic uses-vregs vregs>> values ; @@ -72,9 +69,9 @@ INSN: %branch ; INSN: %branch-f < %cond-branch ; INSN: %branch-t < %cond-branch ; INSN: %if-intrinsic quot vregs ; -INSN: %boolean-intrinsic quot vregs out ; +INSN: %boolean-intrinsic quot vregs dst ; -M: %cond-branch uses-vregs vreg>> 1array ; +M: %cond-branch uses-vregs src>> 1array ; ! M: %if-intrinsic uses-vregs vregs>> values ; @@ -97,12 +94,15 @@ INSN: _label label ; : resolve-label ( label/name -- ) dup label? [ get ] unless _label ; -TUPLE: _cond-branch vreg label ; +TUPLE: _cond-branch src label ; INSN: _branch label ; INSN: _branch-f < _cond-branch ; INSN: _branch-t < _cond-branch ; INSN: _if-intrinsic label quot vregs ; -M: _cond-branch uses-vregs vreg>> 1array ; +M: _cond-branch uses-vregs src>> 1array ; ! M: _if-intrinsic uses-vregs vregs>> values ; + +INSN: _spill src n ; +INSN: _reload dst n ; diff --git a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor index 4e75957990..d0b1176c68 100644 --- a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor @@ -6,15 +6,6 @@ compiler.cfg.linear-scan.live-intervals compiler.backend ; IN: compiler.cfg.linear-scan.allocation -! Vector of live intervals we have already processed -SYMBOL: retired-intervals - -: retire-interval ( live-interval -- ) - retired-intervals get push ; - -: retire-intervals ( live-intervals -- ) - retired-intervals get push-all ; - ! Mapping from register classes to sequences of machine registers SYMBOL: free-registers @@ -37,7 +28,7 @@ SYMBOL: active-intervals active-intervals get swap '[ end>> _ < ] partition active-intervals set - [ [ retire-interval ] [ deallocate-register ] bi ] each ; + [ deallocate-register ] each ; : expire-old-uses ( n -- ) active-intervals get @@ -112,9 +103,7 @@ SYMBOL: spill-counter : reuse-register ( new existing -- ) reg>> >>reg - dup uses>> empty? [ - [ retire-interval ] [ deallocate-register ] bi - ] [ add-active ] if ; + dup uses>> empty? [ deallocate-register ] [ add-active ] if ; : spill-existing ( new existing -- ) #! Our new interval will be used before the active interval @@ -123,12 +112,7 @@ SYMBOL: spill-counter #! of the existing interval again. [ reuse-register ] [ delete-active ] - [ - split-and-spill - [ retire-interval ] - [ add-unhandled ] - bi* - ] tri ; + [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ; : spill-new ( new existing -- ) #! Our new interval will be used after the active interval @@ -153,13 +137,7 @@ SYMBOL: spill-counter ] if-empty ; ! Main loop -: slurp-heap ( heap quot: ( elt -- ) -- ) - over heap-empty? [ 2drop ] [ - [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi - ] if ; inline recursive - : init-allocator ( registers -- ) - V{ } clone retired-intervals set V{ } clone active-intervals set unhandled-intervals set [ >vector ] assoc-map free-registers set @@ -172,17 +150,10 @@ SYMBOL: spill-counter : (allocate-registers) ( -- ) unhandled-intervals get [ handle-interval ] slurp-heap ; -: finish-allocator ( -- live-intervals ) - #! After register allocation is done, we retire all - #! live intervals which are still active. - active-intervals get retire-intervals - retired-intervals get ; - -: allocate-registers ( live-intervals machine-registers -- live-intervals' ) - #! This destroys the input live-intervals. +: allocate-registers ( live-intervals machine-registers -- ) + #! This modifies the input live-intervals. [ init-allocator init-unhandled (allocate-registers) - finish-allocator ] with-scope ; diff --git a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor b/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor index b9bfb17cf6..88cff9e95f 100644 --- a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor @@ -11,28 +11,13 @@ IN: compiler.cfg.linear-scan.debugger [ "Not all intervals have registers" throw ] unless ] each ; -: check-split ( live-intervals -- ) - [ - split-before>> - [ "Split intervals returned" throw ] when - ] each ; - : split-children ( live-interval -- seq ) dup split-before>> [ [ split-before>> ] [ split-after>> ] bi [ split-children ] bi@ append - ] [ - 1array - ] if ; - -: check-retired ( original live-intervals -- ) - #! All original live intervals should have either been - #! split, or ended up in the output set. - [ [ split-children ] map concat ] dip - 2dup subset? [ "We lost some intervals" throw ] unless - swap subset? [ "We didn't record all splits" throw ] unless ; + ] [ 1array ] if ; : check-linear-scan ( live-intervals machine-registers -- ) [ [ clone ] map dup ] dip allocate-registers - [ check-assigned ] [ check-split ] [ check-retired ] tri ; + [ split-children ] map concat check-assigned ; diff --git a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 77222518fa..f3f20680e6 100644 --- a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -37,13 +37,11 @@ SYMBOL: live-intervals [ [ defs-vregs ] 2dip '[ _ swap >vreg _ new-live-interval ] each ] 3bi ; -: finalize-live-intervals ( assoc -- seq' ) +: finalize-live-intervals ( -- ) #! Reverse uses lists so that we can pop values off. - values dup [ uses>> reverse-here ] each ; + live-intervals get [ nip uses>> reverse-here ] assoc-each ; -: compute-live-intervals ( instructions -- live-intervals ) - H{ } clone [ - live-intervals [ - [ compute-live-intervals* ] each-index - ] with-variable - ] keep finalize-live-intervals ; +: compute-live-intervals ( instructions -- ) + H{ } clone live-intervals set + [ compute-live-intervals* ] each-index + finalize-live-intervals ; diff --git a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor b/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor new file mode 100644 index 0000000000..63a411c777 --- /dev/null +++ b/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor @@ -0,0 +1,4 @@ +USING: compiler.cfg.linear-scan.rewriting tools.test ; +IN: compiler.cfg.linear-scan.rewriting.tests + +\ rewrite-instructions must-infer diff --git a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor b/unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor new file mode 100644 index 0000000000..ad9e58c2ec --- /dev/null +++ b/unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math assocs namespaces sequences heaps +fry make +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.linear-scan.live-intervals ; +IN: compiler.cfg.linear-scan.rewriting + +! A vector of live intervals. There is linear searching involved +! but since we never have too many machine registers (around 30 +! at most) and we probably won't have that many live at any one +! time anyway, it is not a problem to check each element. +SYMBOL: active-intervals + +: add-active ( live-interval -- ) + active-intervals get push ; + +: lookup-register ( vreg -- reg ) + active-intervals get [ vreg>> = ] with find nip reg>> ; + +! Minheap of live intervals which still need a register allocation +SYMBOL: unhandled-intervals + +: add-unhandled ( live-interval -- ) + dup split-before>> [ + [ split-before>> ] [ split-after>> ] bi + [ add-unhandled ] bi@ + ] [ + dup start>> unhandled-intervals get heap-push + ] if ; + +: init-unhandled ( live-intervals -- ) + [ add-unhandled ] each ; + +: insert-spill ( live-interval -- ) + [ reg>> ] [ spill-to>> ] bi dup [ _spill ] [ 2drop ] if ; + +: expire-old-intervals ( n -- ) + active-intervals get + swap '[ end>> _ = ] partition + active-intervals set + [ insert-spill ] each ; + +: insert-reload ( live-interval -- ) + [ reg>> ] [ reload-from>> ] bi dup [ _reload ] [ 2drop ] if ; + +: activate-new-intervals ( n -- ) + #! Any live intervals which start on the current instruction + #! are added to the active set. + unhandled-intervals get dup heap-empty? [ 2drop ] [ + 2dup heap-peek drop start>> = [ + heap-pop drop [ add-active ] [ insert-reload ] bi + activate-new-intervals + ] [ 2drop ] if + ] if ; + +GENERIC: rewrite-instruction ( insn -- ) + +M: %cond-branch rewrite-instruction + [ lookup-register ] change-vreg + drop ; + +M: %unary rewrite-instruction + [ lookup-register ] change-dst + [ lookup-register ] change-src + drop ; + +M: %peek rewrite-instruction + [ lookup-register ] change-vreg + drop ; + +M: %replace rewrite-instruction + [ lookup-register ] change-vreg + drop ; + +M: %load-literal rewrite-instruction + [ lookup-register ] change-vreg + drop ; + +: lookup-registers ( assoc -- assoc' ) + [ dup vreg? [ lookup-register ] when ] assoc-map ; + +M: %intrinsic rewrite-instruction + [ lookup-registers ] change-vregs + drop ; + +M: _if-intrinsic rewrite-instruction + [ lookup-registers ] change-vregs + drop ; + +: rewrite-instructions ( insns -- insns' ) + [ + [ + [ activate-new-intervals ] + [ drop [ rewrite-instruction ] [ , ] bi ] + [ expire-old-intervals ] + tri + ] each-index + ] { } make ; diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/unfinished/compiler/cfg/linearization/linearization.factor index 2c4a62d3be..7c25a1b3bf 100644 --- a/unfinished/compiler/cfg/linearization/linearization.factor +++ b/unfinished/compiler/cfg/linearization/linearization.factor @@ -56,7 +56,7 @@ M: %branch linearize-insn dup successors>> first2 swap label>> ; inline : boolean-conditional ( basic-block insn -- basic-block successor vreg label2 ) - [ conditional ] [ vreg>> ] bi* swap ; inline + [ conditional ] [ dst>> ] bi* swap ; inline M: %branch-f linearize-insn boolean-conditional _branch-f emit-branch ; @@ -73,10 +73,10 @@ M: %boolean-intrinsic linearize-insn "false" define-label "end" define-label "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic - t over out>> %load-literal + dup out>> t %load-literal "end" get _branch "false" resolve-label - f over out>> %load-literal + dup out>> f %load-literal "end" resolve-label ] with-scope 2drop ; diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor index ae421f30f8..3cff5da37e 100755 --- a/unfinished/compiler/cfg/stacks/stacks.factor +++ b/unfinished/compiler/cfg/stacks/stacks.factor @@ -127,7 +127,7 @@ M: constant move-spec class ; { { f unboxed-c-ptr } [ %move-bug ] } { { f unboxed-byte-array } [ %move-bug ] } - { { f constant } [ value>> swap %load-literal ] } + { { f constant } [ value>> %load-literal ] } { { f float } [ %box-float ] } { { f unboxed-alien } [ %box-alien ] } From 389b04ad42af603ac72717f1b18776f6ac90a934 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Sep 2008 04:22:12 -0500 Subject: [PATCH 035/294] More progress --- unfinished/compiler/backend/x86/32/32.factor | 2 +- unfinished/compiler/backend/x86/64/64.factor | 2 +- .../cfg/instructions/instructions.factor | 22 ++++----- .../cfg/instructions/syntax/syntax.factor | 6 +-- .../linear-scan/allocation/allocation.factor | 6 +-- .../assignment/assignment-tests.factor | 4 ++ .../assignment.factor} | 49 ++++++------------- .../cfg/linear-scan/debugger/debugger.factor | 2 +- .../cfg/linear-scan/linear-scan.factor | 13 +++++ .../live-intervals/live-intervals.factor | 18 ++++--- .../rewriting/rewriting-tests.factor | 4 -- .../cfg/linearization/linearization.factor | 6 +-- 12 files changed, 64 insertions(+), 70 deletions(-) create mode 100644 unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor rename unfinished/compiler/cfg/linear-scan/{rewriting/rewriting.factor => assignment/assignment.factor} (68%) delete mode 100644 unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor diff --git a/unfinished/compiler/backend/x86/32/32.factor b/unfinished/compiler/backend/x86/32/32.factor index 98726d7e35..fabdaa7ff3 100644 --- a/unfinished/compiler/backend/x86/32/32.factor +++ b/unfinished/compiler/backend/x86/32/32.factor @@ -7,5 +7,5 @@ IN: compiler.backend.x86.32 M: x86.32 machine-registers { { int-regs { EAX ECX EDX EBP EBX } } - { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } } + { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } } } ; diff --git a/unfinished/compiler/backend/x86/64/64.factor b/unfinished/compiler/backend/x86/64/64.factor index fe21fadbd5..9499995068 100644 --- a/unfinished/compiler/backend/x86/64/64.factor +++ b/unfinished/compiler/backend/x86/64/64.factor @@ -7,7 +7,7 @@ IN: compiler.backend.x86.64 M: x86.64 machine-registers { { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } } - { float-regs { + { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 } } diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor index ac3b3b75a0..5fd7608a4c 100644 --- a/unfinished/compiler/cfg/instructions/instructions.factor +++ b/unfinished/compiler/cfg/instructions/instructions.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors arrays kernel sequences namespaces -math compiler.cfg.instructions.syntax ; +math compiler.cfg.registers compiler.cfg.instructions.syntax ; IN: compiler.cfg.instructions ! Virtual CPU instructions, used by CFG and machine IRs -INSN: %cond-branch src ; -INSN: %unary dst src ; -INSN: %nullary dst ; +TUPLE: %cond-branch < insn src ; +TUPLE: %unary < insn dst src ; +TUPLE: %nullary < insn dst ; ! Stack operations INSN: %load-literal < %nullary obj ; @@ -50,12 +50,12 @@ INSN: %alien-callback params ; GENERIC: defs-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) -M: %nullary defs-vregs dst>> 1array ; -M: %unary defs-vregs dst>> 1array ; +M: %nullary defs-vregs dst>> >vreg 1array ; +M: %unary defs-vregs dst>> >vreg 1array ; M: insn defs-vregs drop f ; -M: %replace uses-vregs src>> 1array ; -M: %unary uses-vregs src>> 1array ; +M: %replace uses-vregs src>> >vreg 1array ; +M: %unary uses-vregs src>> >vreg 1array ; M: insn uses-vregs drop f ; ! M: %intrinsic uses-vregs vregs>> values ; @@ -75,7 +75,7 @@ M: %cond-branch uses-vregs src>> 1array ; ! M: %if-intrinsic uses-vregs vregs>> values ; -M: %boolean-intrinsic defs-vregs out>> 1array ; +M: %boolean-intrinsic defs-vregs dst>> 1array ; ! M: %boolean-intrinsic uses-vregs ! [ vregs>> values ] [ out>> ] bi suffix ; @@ -94,14 +94,14 @@ INSN: _label label ; : resolve-label ( label/name -- ) dup label? [ get ] unless _label ; -TUPLE: _cond-branch src label ; +TUPLE: _cond-branch < insn src label ; INSN: _branch label ; INSN: _branch-f < _cond-branch ; INSN: _branch-t < _cond-branch ; INSN: _if-intrinsic label quot vregs ; -M: _cond-branch uses-vregs src>> 1array ; +M: _cond-branch uses-vregs src>> >vreg 1array ; ! M: _if-intrinsic uses-vregs vregs>> values ; INSN: _spill src n ; diff --git a/unfinished/compiler/cfg/instructions/syntax/syntax.factor b/unfinished/compiler/cfg/instructions/syntax/syntax.factor index 30bec6ac37..6d533d2059 100644 --- a/unfinished/compiler/cfg/instructions/syntax/syntax.factor +++ b/unfinished/compiler/cfg/instructions/syntax/syntax.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes.tuple classes.tuple.parser kernel words -make parser ; +make fry sequences parser ; IN: compiler.cfg.instructions.syntax TUPLE: insn ; : INSN: - parse-tuple-definition + parse-tuple-definition "regs" suffix [ dup tuple eq? [ drop insn ] when ] dip [ define-tuple-class ] [ 2drop save-location ] - [ 2drop dup [ boa , ] curry define-inline ] + [ 2drop dup '[ f _ boa , ] define-inline ] 3tri ; parsing diff --git a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor index d0b1176c68..0bfcc8bcd0 100644 --- a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor @@ -140,7 +140,7 @@ SYMBOL: spill-counter : init-allocator ( registers -- ) V{ } clone active-intervals set unhandled-intervals set - [ >vector ] assoc-map free-registers set + [ reverse >vector ] assoc-map free-registers set 0 spill-counter set -1 progress set ; @@ -150,10 +150,10 @@ SYMBOL: spill-counter : (allocate-registers) ( -- ) unhandled-intervals get [ handle-interval ] slurp-heap ; -: allocate-registers ( live-intervals machine-registers -- ) +: allocate-registers ( live-intervals machine-registers -- live-intervals ) #! This modifies the input live-intervals. [ init-allocator - init-unhandled + dup init-unhandled (allocate-registers) ] with-scope ; diff --git a/unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor new file mode 100644 index 0000000000..9efc23651b --- /dev/null +++ b/unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor @@ -0,0 +1,4 @@ +USING: compiler.cfg.linear-scan.assignment tools.test ; +IN: compiler.cfg.linear-scan.assignment.tests + +\ assign-registers must-infer diff --git a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor b/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor similarity index 68% rename from unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor rename to unfinished/compiler/cfg/linear-scan/assignment/assignment.factor index ad9e58c2ec..8b53ee9531 100644 --- a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor +++ b/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor @@ -5,7 +5,7 @@ fry make compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ; -IN: compiler.cfg.linear-scan.rewriting +IN: compiler.cfg.linear-scan.assignment ! A vector of live intervals. There is linear searching involved ! but since we never have too many machine registers (around 30 @@ -55,45 +55,24 @@ SYMBOL: unhandled-intervals ] [ 2drop ] if ] if ; -GENERIC: rewrite-instruction ( insn -- ) +: (assign-registers) ( insn -- ) + dup + [ defs-vregs ] [ uses-vregs ] bi append + active-intervals get swap '[ vreg>> _ member? ] filter + [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc + >>regs drop ; -M: %cond-branch rewrite-instruction - [ lookup-register ] change-vreg - drop ; +: init-assignment ( live-intervals -- ) + V{ } clone active-intervals set + unhandled-intervals set + init-unhandled ; -M: %unary rewrite-instruction - [ lookup-register ] change-dst - [ lookup-register ] change-src - drop ; - -M: %peek rewrite-instruction - [ lookup-register ] change-vreg - drop ; - -M: %replace rewrite-instruction - [ lookup-register ] change-vreg - drop ; - -M: %load-literal rewrite-instruction - [ lookup-register ] change-vreg - drop ; - -: lookup-registers ( assoc -- assoc' ) - [ dup vreg? [ lookup-register ] when ] assoc-map ; - -M: %intrinsic rewrite-instruction - [ lookup-registers ] change-vregs - drop ; - -M: _if-intrinsic rewrite-instruction - [ lookup-registers ] change-vregs - drop ; - -: rewrite-instructions ( insns -- insns' ) +: assign-registers ( insns live-intervals -- insns' ) [ + init-assignment [ [ activate-new-intervals ] - [ drop [ rewrite-instruction ] [ , ] bi ] + [ drop [ (assign-registers) ] [ , ] bi ] [ expire-old-intervals ] tri ] each-index diff --git a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor b/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor index 88cff9e95f..89bf81d2ba 100644 --- a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor @@ -19,5 +19,5 @@ IN: compiler.cfg.linear-scan.debugger ] [ 1array ] if ; : check-linear-scan ( live-intervals machine-registers -- ) - [ [ clone ] map dup ] dip allocate-registers + [ [ clone ] map ] dip allocate-registers [ split-children ] map concat check-assigned ; diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan.factor b/unfinished/compiler/cfg/linear-scan/linear-scan.factor index 307eecf53a..cbbb33b6c9 100644 --- a/unfinished/compiler/cfg/linear-scan/linear-scan.factor +++ b/unfinished/compiler/cfg/linear-scan/linear-scan.factor @@ -1,6 +1,19 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors +compiler.backend +compiler.cfg +compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.allocation +compiler.cfg.linear-scan.assignment ; IN: compiler.cfg.linear-scan ! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf +! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/ +: linear-scan ( mr -- mr' ) + [ + dup compute-live-intervals + machine-registers allocate-registers + assign-registers + ] change-instructions ; diff --git a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index f3f20680e6..d6ee979fe5 100644 --- a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -33,15 +33,17 @@ SYMBOL: live-intervals : compute-live-intervals* ( insn n -- ) live-intervals get - [ [ uses-vregs ] 2dip '[ _ swap >vreg _ add-use ] each ] - [ [ defs-vregs ] 2dip '[ _ swap >vreg _ new-live-interval ] each ] + [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ] + [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] 3bi ; -: finalize-live-intervals ( -- ) +: finalize-live-intervals ( assoc -- seq' ) #! Reverse uses lists so that we can pop values off. - live-intervals get [ nip uses>> reverse-here ] assoc-each ; + values dup [ uses>> reverse-here ] each ; -: compute-live-intervals ( instructions -- ) - H{ } clone live-intervals set - [ compute-live-intervals* ] each-index - finalize-live-intervals ; +: compute-live-intervals ( instructions -- live-intervals ) + H{ } clone [ + live-intervals [ + [ compute-live-intervals* ] each-index + ] with-variable + ] keep finalize-live-intervals ; diff --git a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor b/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor deleted file mode 100644 index 63a411c777..0000000000 --- a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: compiler.cfg.linear-scan.rewriting tools.test ; -IN: compiler.cfg.linear-scan.rewriting.tests - -\ rewrite-instructions must-infer diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/unfinished/compiler/cfg/linearization/linearization.factor index 7c25a1b3bf..b1288fb301 100644 --- a/unfinished/compiler/cfg/linearization/linearization.factor +++ b/unfinished/compiler/cfg/linearization/linearization.factor @@ -56,7 +56,7 @@ M: %branch linearize-insn dup successors>> first2 swap label>> ; inline : boolean-conditional ( basic-block insn -- basic-block successor vreg label2 ) - [ conditional ] [ dst>> ] bi* swap ; inline + [ conditional ] [ src>> ] bi* swap ; inline M: %branch-f linearize-insn boolean-conditional _branch-f emit-branch ; @@ -73,10 +73,10 @@ M: %boolean-intrinsic linearize-insn "false" define-label "end" define-label "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic - dup out>> t %load-literal + dup dst>> t %load-literal "end" get _branch "false" resolve-label - dup out>> f %load-literal + dup dst>> f %load-literal "end" resolve-label ] with-scope 2drop ; From af9e85550e5768371e26eea4c7361244f639144f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 10:07:13 -0500 Subject: [PATCH 036/294] document remove-nth --- core/sequences/sequences-docs.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index dc45670aab..a0691f0d82 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -695,6 +695,16 @@ HELP: remove { $values { "obj" object } { "seq" sequence } { "newseq" "a new sequence" } } { $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } ; +HELP: remove-nth +{ $values + { "n" integer } { "seq" sequence } + { "seq'" sequence } } +{ $description "Creates a new sequence without the element at index " { $snippet "n" } "." } +{ $examples "Notice that the original sequence is left intact:" { $example "USING: sequences prettyprint kernel ;" + "{ 1 2 3 } 1 over remove-nth . ." + "{ 1 3 }\n{ 1 2 3 }" +} } ; + HELP: move { $values { "from" "an index in " { $snippet "seq" } } { "to" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } } { $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." } From 1c178869851c5792bcdbbc599c984e428e03a6d0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 10:17:08 -0500 Subject: [PATCH 037/294] document smart short circuit combinators --- .../short-circuit/smart/smart-docs.factor | 37 +++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 basis/combinators/short-circuit/smart/smart-docs.factor diff --git a/basis/combinators/short-circuit/smart/smart-docs.factor b/basis/combinators/short-circuit/smart/smart-docs.factor new file mode 100644 index 0000000000..abf3ff0eef --- /dev/null +++ b/basis/combinators/short-circuit/smart/smart-docs.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax io.streams.string quotations ; +IN: combinators.short-circuit.smart + +HELP: && +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if every quotation yields true, and stops early if one yields false." } +{ $examples "Smart combinators will infer the two inputs:" + { $example "USING: prettyprint kernel math combinators.short-circuit.smart ;" + "2 3 { [ + 5 = ] [ - -1 = ] } && ." + "t" + } +} ; + +HELP: || +{ $values + { "quots" "a sequence of quotations" } + { "quot" quotation } } +{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if any quotation yields true, and stops early when one yields true." } +{ $examples "Smart combinators will infer the two inputs:" + { $example "USING: prettyprint kernel math combinators.short-circuit.smart ;" + "2 3 { [ - 1 = ] [ + 5 = ] } || ." + "t" + } +} ; + +ARTICLE: "combinators.short-circuit.smart" "combinators.short-circuit.smart" +"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary infers the number of inputs that the sequence of quotations takes." $nl +"Generalized AND:" +{ $subsection && } +"Generalized OR:" +{ $subsection || } ; + +ABOUT: "combinators.short-circuit.smart" From 8da5f3a82a3d6c82782edae67e9d4df91ba6e12a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 10:18:43 -0500 Subject: [PATCH 038/294] move article and about to bottom --- basis/command-line/command-line-docs.factor | 74 ++++++++++----------- 1 file changed, 37 insertions(+), 37 deletions(-) diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 440896deac..d1b18ab5da 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -1,6 +1,43 @@ USING: help.markup help.syntax parser vocabs.loader strings ; IN: command-line +HELP: run-bootstrap-init +{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ; + +HELP: run-user-init +{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ; + +HELP: cli-param +{ $values { "param" string } } +{ $description "Process a command-line switch." +$nl +"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign." +$nl +"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "." +$nl +"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ; + +HELP: cli-args +{ $values { "args" "a sequence of strings" } } +{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ; + +HELP: main-vocab-hook +{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ; + +HELP: main-vocab +{ $values { "vocab" string } } +{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ; + +HELP: default-cli-args +{ $description "Sets global variables corresponding to default command line arguments." } ; + +HELP: ignore-cli-args? +{ $values { "?" "a boolean" } } +{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ; + +HELP: parse-command-line +{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ; + ARTICLE: "runtime-cli-args" "Command line switches for the VM" "A handful of command line switches are processed by the VM and not the library. They control low-level features." { $table @@ -77,40 +114,3 @@ $nl { $subsection main-vocab-hook } ; ABOUT: "cli" - -HELP: run-bootstrap-init -{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ; - -HELP: run-user-init -{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ; - -HELP: cli-param -{ $values { "param" string } } -{ $description "Process a command-line switch." -$nl -"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign." -$nl -"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "." -$nl -"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ; - -HELP: cli-args -{ $values { "args" "a sequence of strings" } } -{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ; - -HELP: main-vocab-hook -{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ; - -HELP: main-vocab -{ $values { "vocab" string } } -{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ; - -HELP: default-cli-args -{ $description "Sets global variables corresponding to default command line arguments." } ; - -HELP: ignore-cli-args? -{ $values { "?" "a boolean" } } -{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ; - -HELP: parse-command-line -{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ; From f7c322f83aaef1ea7d46c4cd620f0f13aedf47dc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 10:30:06 -0500 Subject: [PATCH 039/294] make a couple words private, use ERROR: instead of throwing strings --- basis/concurrency/combinators/combinators.factor | 4 ++++ basis/concurrency/count-downs/count-downs.factor | 8 ++++++-- basis/concurrency/messaging/messaging.factor | 9 +++++++-- basis/concurrency/promises/promises.factor | 3 ++- 4 files changed, 19 insertions(+), 5 deletions(-) diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index eab0ed4cb4..ab3ca7ed4a 100755 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -4,8 +4,10 @@ USING: concurrency.futures concurrency.count-downs sequences kernel ; IN: concurrency.combinators +r r> keep await ; inline +PRIVATE> : parallel-each ( seq quot -- ) over length [ @@ -20,7 +22,9 @@ IN: concurrency.combinators : parallel-filter ( seq quot -- newseq ) over >r pusher >r each r> r> like ; inline + : parallel-map ( seq quot -- newseq ) [ curry future ] curry map future-values ; diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index 93cef250a1..c4bc92c688 100755 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -11,14 +11,18 @@ TUPLE: count-down n promise ; : count-down-check ( count-down -- ) dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ; +ERROR: invalid-count-down-count count ; + : ( n -- count-down ) - dup 0 < [ "Invalid count for count down" throw ] when + dup 0 < [ invalid-count-down-count ] when \ count-down boa dup count-down-check ; +ERROR: count-down-already-done ; + : count-down ( count-down -- ) dup n>> dup zero? - [ "Count down already done" throw ] + [ count-down-already-done ] [ 1- >>n count-down-check ] if ; : await-timeout ( count-down timeout -- ) diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 12b5d270d4..03d1304527 100755 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -4,7 +4,7 @@ ! Concurrency library for Factor, based on Erlang/Termite style ! concurrency. USING: kernel threads concurrency.mailboxes continuations -namespaces assocs random accessors ; +namespaces assocs random accessors summary ; IN: concurrency.messaging GENERIC: send ( message thread -- ) @@ -52,9 +52,14 @@ TUPLE: reply data tag ; [ >r tag>> r> tag>> = ] [ 2drop f ] if ; +ERROR: cannot-send-synchronous-to-self message thread ; + +M: cannot-send-synchronous-to-self summary + drop "Cannot synchronous send to myself" ; + : send-synchronous ( message thread -- reply ) dup self eq? [ - "Cannot synchronous send to myself" throw + cannot-send-synchronous-to-self ] [ >r dup r> send [ synchronous-reply? ] curry receive-if diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor index 511decdf35..382697e04f 100755 --- a/basis/concurrency/promises/promises.factor +++ b/basis/concurrency/promises/promises.factor @@ -11,9 +11,10 @@ TUPLE: promise mailbox ; : promise-fulfilled? ( promise -- ? ) mailbox>> mailbox-empty? not ; +ERROR: promise-already-fulfilled promise ; : fulfill ( value promise -- ) dup promise-fulfilled? [ - "Promise already fulfilled" throw + promise-already-fulfilled ] [ mailbox>> mailbox-put ] if ; From 7bebe265aff8e1d511a1e0ef2ef284700817db41 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 10:33:03 -0500 Subject: [PATCH 040/294] remove extra IN:, use dip --- basis/delegate/delegate-docs.factor | 1 - basis/delegate/delegate.factor | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 93bf70b950..0d2f94c13d 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -45,5 +45,4 @@ $nl { $subsection define-consult } "The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ; -IN: delegate ABOUT: { "delegate" "intro" } diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 45cc214792..12860337ff 100755 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -62,7 +62,7 @@ M: tuple-class group-words protocol-consult keys ; : lost-words ( protocol wordlist -- lost-words ) - >r protocol-words r> diff ; + [ protocol-words ] dip diff ; : forget-old-definitions ( protocol new-wordlist -- ) [ drop protocol-users ] [ lost-words ] 2bi From 951b6c79187a69479cd749d090192478a5f523e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 11:53:39 -0500 Subject: [PATCH 041/294] add a vocab-link --- basis/disjoint-sets/disjoint-sets-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor index 40e14b7fca..cded25b48d 100644 --- a/basis/disjoint-sets/disjoint-sets-docs.factor +++ b/basis/disjoint-sets/disjoint-sets-docs.factor @@ -37,7 +37,7 @@ HELP: assoc>disjoint-set } ; ARTICLE: "disjoint-sets" "Disjoint sets" -"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set." +"The " { $vocab-link "disjoint-sets" } " vocabulary implements the " { $emphasis "disjoint set" } " data structure (also known as " { $emphasis "union-find" } ", after the two main operations which it supports) that represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set." $nl "The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time." $nl From e39d8ab92c394eddf865a3717f67dab0781d3506 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 11:54:42 -0500 Subject: [PATCH 042/294] deques docs --- basis/deques/deques-docs.factor | 119 ++++++++++++++++++++++---------- 1 file changed, 83 insertions(+), 36 deletions(-) diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor index 5a4b33887b..58f077ed1e 100644 --- a/basis/deques/deques-docs.factor +++ b/basis/deques/deques-docs.factor @@ -1,45 +1,29 @@ +USING: help.markup help.syntax kernel math sequences +quotations ; IN: deques -USING: help.markup help.syntax kernel ; - -ARTICLE: "deques" "Dequeues" -"A deque is a data structure with constant-time insertion and removal of elements at both ends. Dequeue operations are defined in the " { $vocab-link "deques" } " vocabulary." -$nl -"Dequeues must be instances of a mixin class:" -{ $subsection deque } -"Dequeues must implement a protocol." -$nl -"Querying the deque:" -{ $subsection peek-front } -{ $subsection peek-back } -{ $subsection deque-length } -{ $subsection deque-member? } -"Adding and removing elements:" -{ $subsection push-front* } -{ $subsection push-back* } -{ $subsection pop-front* } -{ $subsection pop-back* } -{ $subsection clear-deque } -"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":" -{ $subsection delete-node } -{ $subsection node-value } -"Utility operations built in terms of the above:" -{ $subsection deque-empty? } -{ $subsection push-front } -{ $subsection push-all-front } -{ $subsection push-back } -{ $subsection push-all-back } -{ $subsection pop-front } -{ $subsection pop-back } -{ $subsection slurp-deque } -"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ; - -ABOUT: "deques" HELP: deque-empty? -{ $values { "deque" { $link deque } } { "?" "a boolean" } } +{ $values { "deque" deque } { "?" "a boolean" } } { $description "Returns true if a deque is empty." } { $notes "This operation is O(1)." } ; +HELP: clear-deque +{ $values + { "deque" deque } } +{ $description "Removes all elements from a deque." } ; + +HELP: deque-length +{ $values + { "deque" deque } + { "n" integer } } +{ $description "Returns the number of elements in a deque." } ; + +HELP: deque-member? +{ $values + { "value" object } { "deque" deque } + { "?" "a boolean" } } +{ $description "Returns true if the " { $snippet "value" } " is found in the deque." } ; + HELP: push-front { $values { "obj" object } { "deque" deque } } { $description "Push the object onto the front of the deque." } @@ -60,6 +44,16 @@ HELP: push-back* { $description "Push the object onto the back of the deque and return the newly created node." } { $notes "This operation is O(1)." } ; +HELP: push-all-back +{ $values + { "seq" sequence } { "deque" deque } } +{ $description "Pushes a sequence of elements onto the back of a deque." } ; + +HELP: push-all-front +{ $values + { "seq" sequence } { "deque" deque } } +{ $description "Pushes a sequence of elements onto the front of a deque." } ; + HELP: peek-front { $values { "deque" deque } { "obj" object } } { $description "Returns the object at the front of the deque." } ; @@ -87,3 +81,56 @@ HELP: pop-back* { $values { "deque" deque } } { $description "Pop the object off the back of the deque." } { $notes "This operation is O(1)." } ; + +HELP: delete-node +{ $values + { "node" object } { "deque" deque } } +{ $description "Deletes the node from the deque." } ; + +HELP: deque +{ $description "A data structure that has constant-time insertion and removal of elements at both ends." } ; + +HELP: node-value +{ $values + { "node" object } + { "value" object } } +{ $description "Accesses the value stored at a node." } ; + +HELP: slurp-deque +{ $values + { "deque" deque } { "quot" quotation } } +{ $description "Pops off the back element of the deque and calls the quotation in a loop until the deque is empty." } ; + +ARTICLE: "deques" "Deques" +"The " { $vocab-link "deques" } " vocabulary implements the deque data structure which has constant-time insertion and removal of elements at both ends." +$nl +"Deques must be instances of a mixin class:" +{ $subsection deque } +"Deques must implement a protocol." +$nl +"Querying the deque:" +{ $subsection peek-front } +{ $subsection peek-back } +{ $subsection deque-length } +{ $subsection deque-member? } +"Adding and removing elements:" +{ $subsection push-front* } +{ $subsection push-back* } +{ $subsection pop-front* } +{ $subsection pop-back* } +{ $subsection clear-deque } +"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":" +{ $subsection delete-node } +{ $subsection node-value } +"Utility operations built in terms of the above:" +{ $subsection deque-empty? } +{ $subsection push-front } +{ $subsection push-all-front } +{ $subsection push-back } +{ $subsection push-all-back } +{ $subsection pop-front } +{ $subsection pop-back } +{ $subsection slurp-deque } +"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ; + +ABOUT: "deques" From e3678cf2486ae9d3d07eebe5153f402f0e67229f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 15 Sep 2008 17:13:48 -0500 Subject: [PATCH 043/294] Add timeouts --- basis/io/unix/linux/monitors/monitors-tests.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/io/unix/linux/monitors/monitors-tests.factor b/basis/io/unix/linux/monitors/monitors-tests.factor index c71b053919..42c5009ccb 100644 --- a/basis/io/unix/linux/monitors/monitors-tests.factor +++ b/basis/io/unix/linux/monitors/monitors-tests.factor @@ -10,6 +10,7 @@ threads calendar prettyprint destructors io.timeouts ; ! Non-recursive [ ] [ "monitor-test-self" temp-file f "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test [ ] [ "monitor-test-self" temp-file touch-file ] unit-test @@ -22,6 +23,7 @@ threads calendar prettyprint destructors io.timeouts ; ! Recursive [ ] [ "monitor-test-self" temp-file t "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test [ ] [ "monitor-test-self" temp-file touch-file ] unit-test From 7c5dd1344957657e67681846364b90e55f1cb894 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Sep 2008 23:20:33 -0500 Subject: [PATCH 044/294] Mason: another type of builder --- extra/mason/authors.txt | 2 + extra/mason/build/build-tests.factor | 5 ++ extra/mason/build/build.factor | 30 +++++++ extra/mason/child/child-tests.factor | 34 ++++++++ extra/mason/child/child.factor | 80 ++++++++++++++++++ extra/mason/cleanup/cleanup-tests.factor | 4 + extra/mason/cleanup/cleanup.factor | 22 +++++ extra/mason/common/common-tests.factor | 34 ++++++++ extra/mason/common/common.factor | 81 +++++++++++++++++++ extra/mason/config/config.factor | 66 +++++++++++++++ extra/mason/email/email-tests.factor | 11 +++ extra/mason/email/email.factor | 35 ++++++++ extra/mason/mason.factor | 30 +++++++ extra/mason/platform/platform.factor | 19 +++++ extra/mason/release/archive/archive.factor | 47 +++++++++++ .../mason/release/branch/branch-tests.factor | 24 ++++++ extra/mason/release/branch/branch.factor | 48 +++++++++++ extra/mason/release/release.factor | 16 ++++ extra/mason/release/tidy/tidy-tests.factor | 2 + extra/mason/release/tidy/tidy.factor | 33 ++++++++ .../mason/release/upload/upload-tests.factor | 38 +++++++++ extra/mason/release/upload/upload.factor | 47 +++++++++++ extra/mason/report/report-tests.factor | 2 + extra/mason/report/report.factor | 66 +++++++++++++++ extra/mason/summary.txt | 1 + extra/mason/test/test.factor | 38 +++++++++ extra/mason/updates/updates.factor | 28 +++++++ 27 files changed, 843 insertions(+) create mode 100644 extra/mason/authors.txt create mode 100644 extra/mason/build/build-tests.factor create mode 100644 extra/mason/build/build.factor create mode 100644 extra/mason/child/child-tests.factor create mode 100644 extra/mason/child/child.factor create mode 100644 extra/mason/cleanup/cleanup-tests.factor create mode 100644 extra/mason/cleanup/cleanup.factor create mode 100644 extra/mason/common/common-tests.factor create mode 100644 extra/mason/common/common.factor create mode 100644 extra/mason/config/config.factor create mode 100644 extra/mason/email/email-tests.factor create mode 100644 extra/mason/email/email.factor create mode 100644 extra/mason/mason.factor create mode 100644 extra/mason/platform/platform.factor create mode 100644 extra/mason/release/archive/archive.factor create mode 100644 extra/mason/release/branch/branch-tests.factor create mode 100644 extra/mason/release/branch/branch.factor create mode 100644 extra/mason/release/release.factor create mode 100644 extra/mason/release/tidy/tidy-tests.factor create mode 100644 extra/mason/release/tidy/tidy.factor create mode 100644 extra/mason/release/upload/upload-tests.factor create mode 100644 extra/mason/release/upload/upload.factor create mode 100644 extra/mason/report/report-tests.factor create mode 100644 extra/mason/report/report.factor create mode 100644 extra/mason/summary.txt create mode 100644 extra/mason/test/test.factor create mode 100644 extra/mason/updates/updates.factor diff --git a/extra/mason/authors.txt b/extra/mason/authors.txt new file mode 100644 index 0000000000..db8d84451d --- /dev/null +++ b/extra/mason/authors.txt @@ -0,0 +1,2 @@ +Eduardo Cavazos +Slava Pestov diff --git a/extra/mason/build/build-tests.factor b/extra/mason/build/build-tests.factor new file mode 100644 index 0000000000..1e3705629f --- /dev/null +++ b/extra/mason/build/build-tests.factor @@ -0,0 +1,5 @@ +USING: mason.build tools.test sequences ; +IN: mason.build.tests + +{ create-build-dir enter-build-dir clone-builds-factor record-id } +[ must-infer ] each diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor new file mode 100644 index 0000000000..8b8befce34 --- /dev/null +++ b/extra/mason/build/build.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files io.launcher io.encodings.utf8 prettyprint arrays +calendar namespaces mason.common mason.child +mason.release mason.report mason.email mason.cleanup ; +IN: mason.build + +: create-build-dir ( -- ) + now datestamp stamp set + build-dir make-directory ; + +: enter-build-dir ( -- ) build-dir set-current-directory ; + +: clone-builds-factor ( -- ) + "git" "clone" builds/factor 3array try-process ; + +: record-id ( -- ) + "factor" [ git-id ] with-directory "git-id" to-file ; + +: build ( -- ) + create-build-dir + enter-build-dir + clone-builds-factor + record-id + build-child + release + email-report + cleanup ; + +MAIN: build \ No newline at end of file diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor new file mode 100644 index 0000000000..7913d05b26 --- /dev/null +++ b/extra/mason/child/child-tests.factor @@ -0,0 +1,34 @@ +IN: mason.child.tests +USING: mason.child mason.config tools.test namespaces ; + +[ { "make" "clean" "winnt-x86-32" } ] [ + [ + "winnt" target-os set + "x86.32" target-cpu set + make-cmd + ] with-scope +] unit-test + +[ { "make" "clean" "macosx-x86-32" } ] [ + [ + "macosx" target-os set + "x86.32" target-cpu set + make-cmd + ] with-scope +] unit-test + +[ { "gmake" "clean" "netbsd-ppc" } ] [ + [ + "netbsd" target-os set + "ppc" target-cpu set + make-cmd + ] with-scope +] unit-test + +[ { "./factor" "-i=boot.macosx-ppc.image" "-no-user-init" } ] [ + [ + "macosx" target-os set + "ppc" target-cpu set + boot-cmd + ] with-scope +] unit-test diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor new file mode 100644 index 0000000000..02085a89b3 --- /dev/null +++ b/extra/mason/child/child.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces make debugger sequences io.files +io.launcher arrays accessors calendar continuations +combinators.short-circuit mason.common mason.report mason.platform ; +IN: mason.child + +: make-cmd ( -- args ) + [ gnu-make , "clean" , platform , ] { } make ; + +: make-vm ( -- ) + "factor" [ + + make-cmd >>command + "../compile-log" >>stdout + +stdout+ >>stderr + try-process + ] with-directory ; + +: builds-factor-image ( -- img ) + builds/factor boot-image-name append-path ; + +: copy-image ( -- ) + builds-factor-image "." copy-file-into + builds-factor-image "factor" copy-file-into ; + +: boot-cmd ( -- cmd ) + "./factor" + "-i=" boot-image-name append + "-no-user-init" + 3array ; + +: boot ( -- ) + "factor" [ + + boot-cmd >>command + +closed+ >>stdin + "../boot-log" >>stdout + +stdout+ >>stderr + 1 hours >>timeout + try-process + ] with-directory ; + +: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ; + +: test ( -- ) + "factor" [ + + test-cmd >>command + +closed+ >>stdin + "../test-log" >>stdout + +stdout+ >>stderr + 4 hours >>timeout + try-process + ] with-directory ; + +: return-with ( obj -- ) return-continuation get continue-with ; + +: build-clean? ( -- ? ) + { + [ load-everything-vocabs-file eval-file empty? ] + [ test-all-vocabs-file eval-file empty? ] + [ help-lint-vocabs-file eval-file empty? ] + } 0&& ; + +: build-child ( -- ) + [ + return-continuation set + + copy-image + + [ make-vm ] [ compile-failed-report status-error return-with ] recover + [ boot ] [ boot-failed-report status-error return-with ] recover + [ test ] [ test-failed-report status-error return-with ] recover + + successful-report + + build-clean? status-clean status-dirty ? return-with + ] callcc1 + status set ; \ No newline at end of file diff --git a/extra/mason/cleanup/cleanup-tests.factor b/extra/mason/cleanup/cleanup-tests.factor new file mode 100644 index 0000000000..9158536ffb --- /dev/null +++ b/extra/mason/cleanup/cleanup-tests.factor @@ -0,0 +1,4 @@ +USING: tools.test mason.cleanup ; +IN: mason.cleanup.tests + +\ cleanup must-infer diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor new file mode 100644 index 0000000000..ae24f533d6 --- /dev/null +++ b/extra/mason/cleanup/cleanup.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces arrays continuations io.files io.launcher +mason.common mason.platform mason.config ; +IN: mason.cleanup + +: compress-image ( -- ) + "bzip2" boot-image-name 2array try-process ; + +: compress-test-log ( -- ) + "test-log" exists? [ + { "bzip2" "test-log" } try-process + ] when ; + +: cleanup ( -- ) + builder-debug get [ + build-dir [ + compress-image + compress-test-log + "factor" delete-tree + ] with-directory + ] unless ; diff --git a/extra/mason/common/common-tests.factor b/extra/mason/common/common-tests.factor new file mode 100644 index 0000000000..ed6ffecdd1 --- /dev/null +++ b/extra/mason/common/common-tests.factor @@ -0,0 +1,34 @@ +IN: mason.common.tests +USING: prettyprint mason.common mason.config +namespaces calendar tools.test io.files io.encodings.utf8 ; + +[ "00:01:01" ] [ 61000 milli-seconds>time ] unit-test + +[ "/home/bobby/builds/factor" ] [ + [ + "/home/bobby/builds" builds-dir set + builds/factor + ] with-scope +] unit-test + +[ "/home/bobby/builds/2008-09-11-12-23" ] [ + [ + "/home/bobby/builds" builds-dir set + T{ timestamp + { year 2008 } + { month 9 } + { day 11 } + { hour 12 } + { minute 23 } + } datestamp stamp set + build-dir + ] with-scope +] unit-test + +[ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test + +[ "empty-test" temp-file eval-file ] must-fail + +[ ] [ "eval-file-test" temp-file utf8 [ { 1 2 3 } . ] with-file-writer ] unit-test + +[ { 1 2 3 } ] [ "eval-file-test" temp-file eval-file ] unit-test diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor new file mode 100644 index 0000000000..d5996f300c --- /dev/null +++ b/extra/mason/common/common.factor @@ -0,0 +1,81 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences splitting system accessors +math.functions make io io.files io.launcher io.encodings.utf8 +prettyprint combinators.short-circuit parser combinators +calendar calendar.format arrays mason.config ; +IN: mason.common + +: short-running-process ( command -- ) + #! Give network operations at most 15 minutes to complete. + + swap >>command + 15 minutes >>timeout + try-process ; + +: eval-file ( file -- obj ) + dup utf8 file-lines parse-fresh + [ "Empty file: " swap append throw ] [ nip first ] if-empty ; + +: cat ( file -- ) utf8 file-contents print ; + +: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ; + +: to-file ( object file -- ) utf8 [ . ] with-file-writer ; + +: datestamp ( timestamp -- string ) + [ + { + [ year>> , ] + [ month>> , ] + [ day>> , ] + [ hour>> , ] + [ minute>> , ] + } cleave + ] { } make [ pad-00 ] map "-" join ; + +: milli-seconds>time ( n -- string ) + millis>timestamp + [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array + [ pad-00 ] map ":" join ; + +SYMBOL: stamp + +: builds/factor ( -- path ) builds-dir get "factor" append-path ; +: build-dir ( -- path ) builds-dir get stamp get append-path ; + +: prepare-build-machine ( -- ) + builds-dir get make-directories + builds-dir get + [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] + with-directory ; + +: git-id ( -- id ) + { "git" "show" } utf8 [ readln ] with-input-stream + " " split second ; + +: ?prepare-build-machine ( -- ) + builds/factor exists? [ prepare-build-machine ] unless ; + +: load-everything-vocabs-file "load-everything-vocabs" ; +: load-everything-errors-file "load-everything-errors" ; + +: test-all-vocabs-file "test-all-vocabs" ; +: test-all-errors-file "test-all-errors" ; + +: help-lint-vocabs-file "help-lint-vocabs" ; +: help-lint-errors-file "help-lint-errors" ; + +: boot-time-file "boot-time" ; +: load-time-file "load-time" ; +: test-time-file "test-time" ; +: help-lint-time-file "help-lint-time" ; +: benchmark-time-file "benchmark-time" ; + +: benchmarks-file "benchmarks" ; + +SYMBOL: status + +SYMBOL: status-error ! didn't bootstrap, or crashed +SYMBOL: status-dirty ! bootstrapped but not all tests passed +SYMBOL: status-clean ! everything good diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor new file mode 100644 index 0000000000..0ce059c995 --- /dev/null +++ b/extra/mason/config/config.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: system io.files namespaces kernel accessors ; +IN: mason.config + +! (Optional) Location for build directories +SYMBOL: builds-dir + +builds-dir get-global [ + home "builds" append-path builds-dir set-global +] unless + +! Who sends build reports. +SYMBOL: builder-from + +! Who receives build reports. +SYMBOL: builder-recipients + +! (Optional) CPU architecture to build for. +SYMBOL: target-cpu + +target-cpu get-global [ + cpu name>> target-cpu set-global +] unless + +! (Optional) OS to build for. +SYMBOL: target-os + +target-os get-global [ + os name>> target-os set-global +] unless + +! Keep test-log around? +SYMBOL: builder-debug + +! Boolean. Do we release binaries and update the clean branch? +SYMBOL: upload-to-factorcode + +! The below are only needed if upload-to-factorcode is true. + +! Host with clean git repo. +SYMBOL: branch-host + +! Username to log in. +SYMBOL: branch-username + +! Directory with git repo. +SYMBOL: branch-directory + +! Host to upload clean image to. +SYMBOL: image-host + +! Username to log in. +SYMBOL: image-username + +! Directory with clean images. +SYMBOL: image-directory + +! Host to upload binary package to. +SYMBOL: upload-host + +! Username to log in. +SYMBOL: upload-username + +! Directory with binary packages. +SYMBOL: upload-directory diff --git a/extra/mason/email/email-tests.factor b/extra/mason/email/email-tests.factor new file mode 100644 index 0000000000..5bde9a9cfe --- /dev/null +++ b/extra/mason/email/email-tests.factor @@ -0,0 +1,11 @@ +IN: mason.email.tests +USING: mason.email mason.common mason.config namespaces tools.test ; + +[ "mason on linux-x86-64: error" ] [ + [ + "linux" target-os set + "x86.64" target-cpu set + status-error status set + subject prefix-subject + ] with-scope +] unit-test diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor new file mode 100644 index 0000000000..f25f7e5cfa --- /dev/null +++ b/extra/mason/email/email.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces accessors combinators make smtp +debugger prettyprint io io.streams.string io.encodings.utf8 +io.files io.sockets +mason.common mason.platform mason.config ; +IN: mason.email + +: prefix-subject ( str -- str' ) + [ "mason on " % platform % ": " % % ] "" make ; + +: email-status ( body subject -- ) + + builder-from get >>from + builder-recipients get >>to + swap prefix-subject >>subject + swap >>body + send-email ; + +: subject ( -- str ) + status get { + { status-clean [ "clean" ] } + { status-dirty [ "dirty" ] } + { status-error [ "error" ] } + } case ; + +: email-report ( -- ) + "report" utf8 file-contents subject email-status ; + +: email-error ( error callstack -- ) + [ + "Fatal error on " write host-name print nl + [ error. ] [ callstack. ] bi* + ] with-string-writer "fatal error" + email-status ; diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor new file mode 100644 index 0000000000..4f9c8f65d3 --- /dev/null +++ b/extra/mason/mason.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel debugger io io.files threads debugger continuations +namespaces accessors calendar mason.common mason.updates +mason.build mason.email ; +IN: mason + +: build-loop-error ( error -- ) + error-continuation get call>> email-error ; + +: build-loop-fatal ( error -- ) + "FATAL BUILDER ERROR:" print + error. flush ; + +: build-loop ( -- ) + ?prepare-build-machine + [ + [ + builds/factor set-current-directory + new-code-available? [ build ] when + ] [ + build-loop-error + ] recover + ] [ + build-loop-fatal + ] recover + 5 minutes sleep + build-loop ; + +MAIN: build-loop \ No newline at end of file diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor new file mode 100644 index 0000000000..e4bba51491 --- /dev/null +++ b/extra/mason/platform/platform.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel system accessors namespaces splitting sequences make +mason.config ; +IN: mason.platform + +: platform ( -- string ) + target-os get "-" target-cpu get "." split "-" join 3append ; + +: gnu-make ( -- string ) + target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ; + +: boot-image-name ( -- string ) + [ + "boot." % + target-cpu get "ppc" = [ target-os get % "-" % ] when + target-cpu get % + ".image" % + ] "" make ; diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor new file mode 100644 index 0000000000..e76979d885 --- /dev/null +++ b/extra/mason/release/archive/archive.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel combinators sequences make namespaces io.files +io.launcher prettyprint arrays +mason.common mason.platform mason.config ; +IN: mason.release.archive + +: base-name ( -- string ) + [ "factor-" % platform % "-" % stamp get % ] "" make ; + +: extension ( -- extension ) + target-os get { + { "winnt" [ ".zip" ] } + { "macosx" [ ".dmg" ] } + [ drop ".tar.gz" ] + } case ; + +: archive-name ( -- string ) base-name extension append ; + +: make-windows-archive ( -- ) + [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ; + +: make-macosx-archive ( -- ) + { "mkdir" "dmg-root" } try-process + { "cp" "-R" "factor" "dmg-root" } try-process + { "hdiutil" "create" + "-srcfolder" "dmg-root" + "-fs" "HFS+" + "-volname" "factor" } + archive-name suffix try-process + "dmg-root" delete-tree ; + +: make-unix-archive ( -- ) + [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ; + +: make-archive ( -- ) + target-os get { + { "winnt" [ make-windows-archive ] } + { "macosx" [ make-macosx-archive ] } + [ drop make-unix-archive ] + } case ; + +: releases ( -- path ) + builds-dir get "releases" append-path dup make-directories ; + +: save-archive ( -- ) + archive-name releases move-file-into ; \ No newline at end of file diff --git a/extra/mason/release/branch/branch-tests.factor b/extra/mason/release/branch/branch-tests.factor new file mode 100644 index 0000000000..68046f79cf --- /dev/null +++ b/extra/mason/release/branch/branch-tests.factor @@ -0,0 +1,24 @@ +IN: mason.release.branch.tests +USING: mason.release.branch mason.config tools.test namespaces ; + +[ { "git" "push" "joe@blah.com:/my/git" "master:clean-linux-x86-32" } ] [ + [ + "joe" branch-username set + "blah.com" branch-host set + "/my/git" branch-directory set + "linux" target-os set + "x86.32" target-cpu set + push-to-clean-branch-cmd + ] with-scope +] unit-test + +[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [ + [ + "joe" image-username set + "blah.com" image-host set + "/stuff/clean" image-directory set + "netbsd" target-os set + "x86.64" target-cpu set + upload-clean-image-cmd + ] with-scope +] unit-test diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor new file mode 100644 index 0000000000..8872cda5b5 --- /dev/null +++ b/extra/mason/release/branch/branch.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences prettyprint io.files +io.launcher make +mason.common mason.platform mason.config ; +IN: mason.release.branch + +: branch-name ( -- string ) "clean-" platform append ; + +: refspec ( -- string ) "master:" branch-name append ; + +: push-to-clean-branch-cmd ( -- args ) + [ + "git" , "push" , + [ + branch-username get % "@" % + branch-host get % ":" % + branch-directory get % + ] "" make , + refspec , + ] { } make ; + +: push-to-clean-branch ( -- ) + push-to-clean-branch-cmd short-running-process ; + +: upload-clean-image-cmd ( -- args ) + [ + "scp" , + boot-image-name , + [ + image-username get % "@" % + image-host get % ":" % + image-directory get % "/" % + platform % + ] "" make , + ] { } make ; + +: upload-clean-image ( -- ) + upload-clean-image-cmd short-running-process ; + +: (update-clean-branch) ( -- ) + "factor" [ + push-to-clean-branch + upload-clean-image + ] with-directory ; + +: update-clean-branch ( -- ) + upload-to-factorcode get [ (update-clean-branch) ] when ; diff --git a/extra/mason/release/release.factor b/extra/mason/release/release.factor new file mode 100644 index 0000000000..bbb47ba0d3 --- /dev/null +++ b/extra/mason/release/release.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel debugger namespaces sequences splitting +combinators io io.files io.launcher prettyprint bootstrap.image +mason.common mason.release.branch mason.release.tidy +mason.release.archive mason.release.upload ; +IN: mason.release + +: (release) ( -- ) + update-clean-branch + tidy + make-archive + upload + save-archive ; + +: release ( -- ) status get status-clean eq? [ (release) ] when ; \ No newline at end of file diff --git a/extra/mason/release/tidy/tidy-tests.factor b/extra/mason/release/tidy/tidy-tests.factor new file mode 100644 index 0000000000..e140926c7a --- /dev/null +++ b/extra/mason/release/tidy/tidy-tests.factor @@ -0,0 +1,2 @@ +IN: mason.release.tidy.tests +USING: mason.release.tidy tools.test ; diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor new file mode 100644 index 0000000000..cc993b8edc --- /dev/null +++ b/extra/mason/release/tidy/tidy.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces continuations debugger sequences fry +io.files io.launcher mason.common mason.platform +mason.config ; +IN: mason.release.tidy + +: common-files ( -- seq ) + { + "boot.x86.32.image" + "boot.x86.64.image" + "boot.macosx-ppc.image" + "boot.linux-ppc.image" + "vm" + "temp" + "logs" + ".git" + ".gitignore" + "Makefile" + "unmaintained" + "unfinished" + "build-support" + } ; + +: remove-common-files ( -- ) + common-files [ delete-tree ] each ; + +: remove-factor-app ( -- ) + target-os get "macosx" = + [ [ "Factor.app" delete-tree ] unless ; + +: tidy ( -- ) + "factor" [ remove-factor-app remove-common-files ] with-directory ; diff --git a/extra/mason/release/upload/upload-tests.factor b/extra/mason/release/upload/upload-tests.factor new file mode 100644 index 0000000000..9f5300b129 --- /dev/null +++ b/extra/mason/release/upload/upload-tests.factor @@ -0,0 +1,38 @@ +IN: mason.release.upload.tests +USING: mason.release.upload mason.common mason.config +mason.common namespaces calendar tools.test ; + +[ + { + "scp" + "factor-linux-ppc-2008-09-11-23-12.tar.gz" + "slava@www.apple.com:/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete" + } + { + "ssh" + "www.apple.com" + "-l" "slava" + "mv" + "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete" + "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz" + } +] [ + [ + "slava" upload-username set + "www.apple.com" upload-host set + "/uploads" upload-directory set + "linux" target-os set + "ppc" target-cpu set + T{ timestamp + { year 2008 } + { month 09 } + { day 11 } + { hour 23 } + { minute 12 } + } datestamp stamp set + upload-command + rename-command + ] with-scope +] unit-test + +\ upload must-infer diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor new file mode 100644 index 0000000000..2bf18f1126 --- /dev/null +++ b/extra/mason/release/upload/upload.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces make sequences arrays io io.files +io.launcher mason.common mason.platform +mason.release.archive mason.config ; +IN: mason.release.upload + +: remote-location ( -- dest ) + upload-directory get "/" platform 3append ; + +: remote-archive-name ( -- dest ) + remote-location "/" archive-name 3append ; + +: temp-archive-name ( -- dest ) + remote-archive-name ".incomplete" append ; + +: upload-command ( -- args ) + "scp" + archive-name + [ + upload-username get % "@" % + upload-host get % ":" % + temp-archive-name % + ] "" make + 3array ; + +: rename-command ( -- args ) + [ + "ssh" , + upload-host get , + "-l" , + upload-username get , + "mv" , + temp-archive-name , + remote-archive-name , + ] { } make ; + +: upload-temp-file ( -- ) + upload-command short-running-process ; + +: rename-temp-file ( -- ) + rename-command short-running-process ; + +: upload ( -- ) + upload-to-factorcode get + [ upload-temp-file rename-temp-file ] + when ; diff --git a/extra/mason/report/report-tests.factor b/extra/mason/report/report-tests.factor new file mode 100644 index 0000000000..7f5c4f1d30 --- /dev/null +++ b/extra/mason/report/report-tests.factor @@ -0,0 +1,2 @@ +IN: mason.report.tests +USING: mason.report tools.test ; diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor new file mode 100644 index 0000000000..145686d621 --- /dev/null +++ b/extra/mason/report/report.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces debugger fry io io.files io.sockets +io.encodings.utf8 prettyprint benchmark mason.common +mason.platform mason.config ; +IN: mason.report + +: time. ( file -- ) + [ write ": " write ] [ eval-file milli-seconds>time print ] bi ; + +: common-report ( -- ) + "Build machine: " write host-name print + "CPU: " write target-cpu get print + "OS: " write target-os get print + "Build directory: " write build-dir print + "git id: " write "git-id" eval-file print nl ; + +: with-report ( quot -- ) + [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; + +: compile-failed-report ( error -- ) + [ + "VM compile failed:" print nl + "compile-log" cat nl + error. + ] with-report ; + +: boot-failed-report ( error -- ) + [ + "Bootstrap failed:" print nl + "boot-log" 100 cat-n nl + error. + ] with-report ; + +: test-failed-report ( error -- ) + [ + "Tests failed:" print nl + "test-log" 100 cat-n nl + error. + ] with-report ; + +: successful-report ( -- ) + [ + boot-time-file time. + load-time-file time. + test-time-file time. + help-lint-time-file time. + benchmark-time-file time. + + nl + + "Did not pass load-everything:" print + load-everything-vocabs-file cat + load-everything-errors-file cat + + "Did not pass test-all:" print + test-all-vocabs-file cat + test-all-errors-file cat + + "Did not pass help-lint:" print + help-lint-vocabs-file cat + help-lint-errors-file cat + + "Benchmarks:" print + benchmarks-file eval-file benchmarks. + ] with-report ; \ No newline at end of file diff --git a/extra/mason/summary.txt b/extra/mason/summary.txt new file mode 100644 index 0000000000..798064e958 --- /dev/null +++ b/extra/mason/summary.txt @@ -0,0 +1 @@ +Continuous build system for Factor diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor new file mode 100644 index 0000000000..58884175a3 --- /dev/null +++ b/extra/mason/test/test.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces assocs io.files io.encodings.utf8 +prettyprint help.lint benchmark tools.time bootstrap.stage2 +tools.test tools.vocabs mason.common ; +IN: mason.test + +: do-load ( -- ) + try-everything + [ keys load-everything-vocabs-file to-file ] + [ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ] + bi ; + +: do-tests ( -- ) + run-all-tests + [ keys test-all-vocabs-file to-file ] + [ test-all-errors-file utf8 [ test-failures. ] with-file-writer ] + bi ; + +: do-help-lint ( -- ) + "" run-help-lint + [ keys help-lint-vocabs-file to-file ] + [ help-lint-errors-file utf8 [ typos. ] with-file-writer ] + bi ; + +: do-benchmarks ( -- ) + run-benchmarks benchmarks-file to-file ; + +: do-all ( -- ) + ".." [ + bootstrap-time get boot-time-file to-file + [ do-load ] benchmark load-time-file to-file + [ do-tests ] benchmark test-time-file to-file + [ do-help-lint ] benchmark help-lint-time-file to-file + [ do-benchmarks ] benchmark benchmark-time-file to-file + ] with-directory ; + +MAIN: do-all \ No newline at end of file diff --git a/extra/mason/updates/updates.factor b/extra/mason/updates/updates.factor new file mode 100644 index 0000000000..9c42ba2850 --- /dev/null +++ b/extra/mason/updates/updates.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel io.launcher bootstrap.image.download +mason.common mason.platform ; +IN: mason.updates + +: git-pull-cmd ( -- cmd ) + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } ; + +: updates-available? ( -- ? ) + git-id + git-pull-cmd short-running-process + git-id + = not ; + +: new-image-available? ( -- ? ) + boot-image-name need-new-image? [ download-my-image t ] [ f ] if ; + +: new-code-available? ( -- ? ) + updates-available? + new-image-available? + or ; \ No newline at end of file From 47f5706147f159419e744de1513863689989353c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 16 Sep 2008 10:34:51 -0500 Subject: [PATCH 045/294] fix typo --- extra/mason/release/tidy/tidy.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor index cc993b8edc..a456e6ff23 100644 --- a/extra/mason/release/tidy/tidy.factor +++ b/extra/mason/release/tidy/tidy.factor @@ -27,7 +27,7 @@ IN: mason.release.tidy : remove-factor-app ( -- ) target-os get "macosx" = - [ [ "Factor.app" delete-tree ] unless ; + [ "Factor.app" delete-tree ] unless ; : tidy ( -- ) "factor" [ remove-factor-app remove-common-files ] with-directory ; From ab0fe84ab4b2185c5086a971ea75a0b01ff08e87 Mon Sep 17 00:00:00 2001 From: sheeple Date: Tue, 16 Sep 2008 15:56:17 -0500 Subject: [PATCH 046/294] default to unknown target --- build-support/factor.sh | 3 +++ 1 file changed, 3 insertions(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index 16ab260df5..8988c33b57 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -261,6 +261,7 @@ check_os_arch_word() { $ECHO "ARCH: $ARCH" $ECHO "WORD: $WORD" $ECHO "OS, ARCH, or WORD is empty. Please report this." + echo $MAKE_TARGET exit 5 fi } @@ -486,6 +487,8 @@ usage() { echo " $0 update macosx-x86-32" } +MAKE_TARGET=unknown + # -n is nonzero length, -z is zero length if [[ -n "$2" ]] ; then parse_build_info $2 From ae8af068dbb822f998121bd01a7e53477bb317c5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 16 Sep 2008 15:59:07 -0500 Subject: [PATCH 047/294] id solaris for factor.sh --- build-support/factor.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index 8988c33b57..cdb2a87bba 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -175,6 +175,7 @@ find_os() { *FreeBSD*) OS=freebsd;; *OpenBSD*) OS=openbsd;; *DragonFly*) OS=dragonflybsd;; + SunOS) OS=solaris;; esac } @@ -186,6 +187,7 @@ find_architecture() { case $uname_m in i386) ARCH=x86;; i686) ARCH=x86;; + i86pc) ARCH=x86;; amd64) ARCH=x86;; ppc64) ARCH=ppc;; *86) ARCH=x86;; From 55003480bc3b22645572d5006d6f5826f6c50e89 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 16 Sep 2008 17:26:28 -0700 Subject: [PATCH 048/294] Changing printf to use peg.ebnf. --- extra/printf/printf-tests.factor | 79 +++++++----- extra/printf/printf.factor | 209 ++++++++++++++----------------- 2 files changed, 141 insertions(+), 147 deletions(-) diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index b2a49573f7..05c33956d9 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -3,77 +3,90 @@ USING: kernel printf tools.test ; -[ t ] [ "10" [ "%d" { 10 } sprintf ] call = ] unit-test +[ t ] [ "10" [ { 10 } "%d" sprintf ] call = ] unit-test -[ t ] [ "123.456" [ "%f" { 123.456 } sprintf ] call = ] unit-test +[ t ] [ "123.456" [ { 123.456 } "%f" sprintf ] call = ] unit-test -[ t ] [ "123.10" [ "%01.2f" { 123.1 } sprintf ] call = ] unit-test +[ t ] [ "123.10" [ { 123.1 } "%01.2f" sprintf ] call = ] unit-test -[ t ] [ "1.2345" [ "%.4f" { 1.23456789 } sprintf ] call = ] unit-test +[ t ] [ "1.2345" [ { 1.23456789 } "%.4f" sprintf ] call = ] unit-test -[ t ] [ " 1.23" [ "%6.2f" { 1.23456789 } sprintf ] call = ] unit-test +[ t ] [ " 1.23" [ { 1.23456789 } "%6.2f" sprintf ] call = ] unit-test -[ t ] [ "3.625e+8" [ "%.3e" { 362525200 } sprintf ] call = ] unit-test +[ t ] [ "1.234e+08" [ { 123400000 } "%e" sprintf ] call = ] unit-test + +[ t ] [ "1.234567e+08" [ { 123456700 } "%e" sprintf ] call = ] unit-test + +[ t ] [ "3.625e+08" [ { 362525200 } "%.3e" sprintf ] call = ] unit-test + +[ t ] [ "2.5e-03" [ { 0.0025 } "%e" sprintf ] call = ] unit-test + +[ t ] [ "2.5E-03" [ { 0.0025 } "%E" sprintf ] call = ] unit-test + +[ t ] [ "ff" [ { HEX: ff } "%x" sprintf ] call = ] unit-test + +[ t ] [ "FF" [ { HEX: ff } "%X" sprintf ] call = ] unit-test + +[ t ] [ "0f" [ { HEX: f } "%02x" sprintf ] call = ] unit-test + +[ t ] [ "0F" [ { HEX: f } "%02X" sprintf ] call = ] unit-test [ t ] [ "2008-09-10" - [ "%04d-%02d-%02d" { 2008 9 10 } sprintf ] call = ] unit-test + [ { 2008 9 10 } "%04d-%02d-%02d" sprintf ] call = ] unit-test [ t ] [ "Hello, World!" - [ "%s" { "Hello, World!" } sprintf ] call = ] unit-test + [ { "Hello, World!" } "%s" sprintf ] call = ] unit-test [ t ] [ "printf test" - [ "printf test" { } sprintf ] call = ] unit-test + [ { } "printf test" sprintf ] call = ] unit-test [ t ] [ "char a = 'a'" - [ "char %c = 'a'" { CHAR: a } sprintf ] call = ] unit-test + [ { CHAR: a } "char %c = 'a'" sprintf ] call = ] unit-test -[ t ] [ "00" [ "%02x" { HEX: 0 } sprintf ] call = ] unit-test +[ t ] [ "00" [ { HEX: 0 } "%02x" sprintf ] call = ] unit-test -[ t ] [ "ff" [ "%02x" { HEX: ff } sprintf ] call = ] unit-test - -[ t ] [ "signed -3 = unsigned 4294967293 = hex fffffffd" - [ "signed %d = unsigned %u = hex %x" { -3 -3 -3 } sprintf ] call = ] unit-test +[ t ] [ "ff" [ { HEX: ff } "%02x" sprintf ] call = ] unit-test [ t ] [ "0 message(s)" - [ "%d %s(s)%" { 0 "message" } sprintf ] call = ] unit-test + [ { 0 "message" } "%d %s(s)%" sprintf ] call = ] unit-test [ t ] [ "0 message(s) with %" - [ "%d %s(s) with %%" { 0 "message" } sprintf ] call = ] unit-test + [ { 0 "message" } "%d %s(s) with %%" sprintf ] call = ] unit-test [ t ] [ "justif: \"left \"" - [ "justif: \"%-10s\"" { "left" } sprintf ] call = ] unit-test + [ { "left" } "justif: \"%-10s\"" sprintf ] call = ] unit-test [ t ] [ "justif: \" right\"" - [ "justif: \"%10s\"" { "right" } sprintf ] call = ] unit-test + [ { "right" } "justif: \"%10s\"" sprintf ] call = ] unit-test [ t ] [ " 3: 0003 zero padded" - [ " 3: %04d zero padded" { 3 } sprintf ] call = ] unit-test + [ { 3 } " 3: %04d zero padded" sprintf ] call = ] unit-test [ t ] [ " 3: 3 left justif" - [ " 3: %-4d left justif" { 3 } sprintf ] call = ] unit-test + [ { 3 } " 3: %-4d left justif" sprintf ] call = ] unit-test [ t ] [ " 3: 3 right justif" - [ " 3: %4d right justif" { 3 } sprintf ] call = ] unit-test + [ { 3 } " 3: %4d right justif" sprintf ] call = ] unit-test [ t ] [ " -3: -003 zero padded" - [ " -3: %04d zero padded" { -3 } sprintf ] call = ] unit-test + [ { -3 } " -3: %04d zero padded" sprintf ] call = ] unit-test [ t ] [ " -3: -3 left justif" - [ " -3: %-4d left justif" { -3 } sprintf ] call = ] unit-test + [ { -3 } " -3: %-4d left justif" sprintf ] call = ] unit-test [ t ] [ " -3: -3 right justif" - [ " -3: %4d right justif" { -3 } sprintf ] call = ] unit-test + [ { -3 } " -3: %4d right justif" sprintf ] call = ] unit-test [ t ] [ "There are 10 monkeys in the kitchen" - [ "There are %d monkeys in the %s" { 10 "kitchen" } sprintf ] call = ] unit-test + [ { 10 "kitchen" } "There are %d monkeys in the %s" sprintf ] call = ] unit-test -[ f ] [ "%d" [ "%d" 10 sprintf ] call = ] unit-test +[ f ] [ "%d" [ { 10 } "%d" sprintf ] call = ] unit-test -[ t ] [ "[monkey]" [ "[%s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[ monkey]" [ "[%10s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[monkey ]" [ "[%-10s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[0000monkey]" [ "[%010s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[####monkey]" [ "[%'#10s]" { "monkey" } sprintf ] call = ] unit-test -[ t ] [ "[many monke]" [ "[%10.10s]" { "many monkeys" } sprintf ] call = ] unit-test +[ t ] [ "[monkey]" [ { "monkey" } "[%s]" sprintf ] call = ] unit-test +[ t ] [ "[ monkey]" [ { "monkey" } "[%10s]" sprintf ] call = ] unit-test +[ t ] [ "[monkey ]" [ { "monkey" } "[%-10s]" sprintf ] call = ] unit-test +[ t ] [ "[0000monkey]" [ { "monkey" } "[%010s]" sprintf ] call = ] unit-test +[ t ] [ "[####monkey]" [ { "monkey" } "[%'#10s]" sprintf ] call = ] unit-test +[ t ] [ "[many monke]" [ { "many monkeys" } "[%10.10s]" sprintf ] call = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 8638afcca6..f46d08adfa 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -1,135 +1,116 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: ascii io io.encodings.ascii io.files present kernel strings -math math.parser unicode.case sequences combinators -accessors namespaces prettyprint vectors ; +USING: io io.encodings.ascii io.files +kernel sequences strings vectors math math.parser macros +fry peg.ebnf unicode.case arrays prettyprint quotations ; -IN: printf - -! FIXME: Handle invalid formats properly. -! FIXME: Handle incomplete formats properly. -! FIXME: Deal only with CHAR rather than converting to { CHAR } ? -! FIXME: Understand intermediate allocations that are happening... - -TUPLE: state type pad align width decimals neg loop ; - -SYMBOL: current - -SYMBOL: args +IN: printf >type - CHAR: \s >>pad - CHAR: r >>align - 0 >>width - -1 >>decimals - f >>neg - CHAR: % >>loop - current set ; +: compose-all ( seq -- quot ) + [ ] [ compose ] reduce ; -: stop-% ( -- ) - current off ; +: write-all ( seq -- quot ) + [ [ write ] append ] map ; -: render ( s -- s ) - >vector +: append-all ( seq -- string ) + SBUF" " [ dip swap append ] reduce ; - current get decimals>> 0 >= current get type>> CHAR: f = and - [ CHAR: . swap dup rot swap index current get decimals>> + 1 + dup rot swap - CHAR: 0 pad-right swap 0 swap rot ] when +: apply-format ( params quot -- params string ) + [ dup pop ] dip call ; - current get align>> CHAR: l = +: fix-neg ( string -- string ) + dup CHAR: 0 swap index 0 = + [ dup CHAR: - swap index dup + [ swap remove-nth "-" prepend ] + [ drop ] if ] when ; - [ current get neg>> [ { CHAR: - } prepend ] when - current get width>> CHAR: \s pad-right ] +: >digits ( string -- digits ) + dup length 0 > [ >string string>number ] [ drop 0 ] if ; - [ current get pad>> CHAR: \s = - [ current get neg>> [ { CHAR: - } prepend ] when - current get width>> current get pad>> pad-left ] - [ current get width>> current get neg>> [ 1 - ] when - current get pad>> pad-left - current get neg>> [ { CHAR: - } prepend ] when ] if - ] if +: zero-pad ( string digits -- string ) + swap dup + CHAR: . swap index rot + 1+ + dup rot swap + CHAR: 0 pad-right + swap head-slice ; - current get decimals>> 0 >= current get type>> CHAR: f = not and - [ current get align>> CHAR: l = - [ current get decimals>> CHAR: \s pad-right ] - [ current get decimals>> current get pad>> pad-left ] if - current get decimals>> head-slice ] when - >string ; - -: loop-% ( c -- s ) - current get swap - { - { CHAR: % [ drop stop-% "%" ] } - { CHAR: ' [ CHAR: ' >>loop drop "" ] } - { CHAR: . [ CHAR: . >>loop 0 >>decimals drop "" ] } - { CHAR: - [ CHAR: l >>align drop "" ] } - { CHAR: 0 [ dup width>> 0 = [ CHAR: 0 >>pad ] when - [ 10 * 0 + ] change-width drop "" ] } - { CHAR: 1 [ [ 10 * 1 + ] change-width drop "" ] } - { CHAR: 2 [ [ 10 * 2 + ] change-width drop "" ] } - { CHAR: 3 [ [ 10 * 3 + ] change-width drop "" ] } - { CHAR: 4 [ [ 10 * 4 + ] change-width drop "" ] } - { CHAR: 5 [ [ 10 * 5 + ] change-width drop "" ] } - { CHAR: 6 [ [ 10 * 6 + ] change-width drop "" ] } - { CHAR: 7 [ [ 10 * 7 + ] change-width drop "" ] } - { CHAR: 8 [ [ 10 * 8 + ] change-width drop "" ] } - { CHAR: 9 [ [ 10 * 9 + ] change-width drop "" ] } - { CHAR: d [ CHAR: d >>type drop - args get pop >fixnum - dup 0 < [ current get t >>neg drop ] when - abs present render stop-% ] } - { CHAR: f [ CHAR: f >>type drop - args get pop >float - dup 0 < [ current get t >>neg drop ] when - abs present render stop-% ] } - { CHAR: s [ CHAR: s >>type drop - args get pop present render stop-% ] } - { CHAR: c [ CHAR: c >>type 1 >>width drop - 1 args get pop stop-% ] } - { CHAR: x [ CHAR: x >>type drop - args get pop >hex present render stop-% ] } - { CHAR: X [ CHAR: X >>type drop - args get pop >hex present >upper render stop-% ] } - [ drop drop stop-% "" ] - } case ; - -: loop-. ( c -- s ) - dup digit? current get swap - [ swap CHAR: 0 - swap [ 10 * + ] change-decimals drop "" ] - [ CHAR: % >>loop drop loop-% ] if ; - -: loop-' ( c -- s ) - current get swap >>pad CHAR: % >>loop drop "" ; - -: loop- ( c -- s ) - dup CHAR: % = [ drop start-% "" ] [ 1 swap ] if ; - -: loop ( c -- s ) - current get - [ current get loop>> - { - { CHAR: % [ loop-% ] } - { CHAR: ' [ loop-' ] } - { CHAR: . [ loop-. ] } - [ drop stop-% loop- ] ! FIXME: RAISE ERROR - } case ] - [ loop- ] if ; +: >exponential ( n -- base exp ) + 0 + [ swap dup [ 10.0 > ] keep 1.0 < or ] + [ dup 10.0 > + [ 10.0 / [ 1+ ] dip swap ] + [ 10.0 * [ 1- ] dip swap ] if + ] [ swap ] while + [ number>string ] dip + dup abs number>string 2 CHAR: 0 pad-left + [ 0 < [ "-" ] [ "+" ] if ] dip append + "e" prepend ; PRIVATE> -: sprintf ( fmt args -- str ) - [ >vector reverse args set - V{ } swap [ loop append ] each >string ] with-scope ; +EBNF: parse-format-string -: printf ( fmt args -- ) - sprintf print ; +plain-text = (!("%").)+ => [[ >string 1quotation ]] + +percents = "%" => [[ '[ "%" ] ]] + +pad-zero = "0" => [[ CHAR: 0 ]] +pad-char = "'" (.) => [[ second ]] +pad-char_ = (pad-zero|pad-char)? => [[ CHAR: \s or 1quotation ]] +pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] +pad-width = ([0-9])* => [[ >digits 1quotation ]] +pad = (pad-align) (pad-char_) (pad-width) => [[ reverse compose-all ]] + +width = "." ([0-9])* => [[ second >digits '[ _ head-slice ] ]] +width_ = (width)? => [[ [ ] or ]] + +digits = "." ([0-9])* => [[ second >digits '[ _ zero-pad ] ]] +digits_ = (digits)? => [[ [ ] or ]] + +fmt-c = "c" => [[ [ 1string ] ]] +fmt-C = "C" => [[ [ 1string >upper ] ]] +chars = (fmt-c|fmt-C) => [[ '[ _ apply-format ] ]] + +fmt-s = "s" => [[ [ ] ]] +fmt-S = "S" => [[ [ >upper ] ]] +strings = (pad) (width_) (fmt-s|fmt-S) => [[ reverse compose-all '[ _ apply-format ] ]] + +fmt-d = "d" => [[ [ >fixnum number>string ] ]] +decimals = fmt-d + +fmt-e = "e" => [[ [ >exponential ] ]] +fmt-E = "E" => [[ [ >exponential >upper ] ]] +exps = (digits_) (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] + +fmt-f = "f" => [[ [ >float number>string ] ]] +floats = (digits_) (fmt-f) => [[ reverse compose-all ]] + +fmt-x = "x" => [[ [ >hex ] ]] +fmt-X = "X" => [[ [ >hex >upper ] ]] +hex = fmt-x | fmt-X + +numbers = (pad) (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append '[ _ apply-format ] ]] + +formats = "%" (chars|strings|numbers|percents) => [[ second ]] + +text = (formats|plain-text)* + +;EBNF + +MACRO: printf ( format-string -- ) + parse-format-string + '[ reverse >vector _ write-all compose-all call drop ] ; + +MACRO: sprintf ( format-string -- ) + parse-format-string + '[ reverse >vector _ append-all >string swap drop ] ; + +MACRO: fprintf ( format-string -- ) + parse-format-string + '[ reverse >vector _ write-all compose-all rot ascii [ call ] with-file-appender drop ] ; -: fprintf ( path fmt args -- ) - rot ascii [ sprintf write flush ] with-file-appender ; From 4fe65ae3313d8145db2fb27d476498dd4edc28c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 16 Sep 2008 22:44:29 -0500 Subject: [PATCH 049/294] more continuations docs --- core/continuations/continuations-docs.factor | 42 ++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 3949c4b566..f5ebc2a338 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -77,6 +77,9 @@ $nl "Another two words resume continuations:" { $subsection continue } { $subsection continue-with } +"Continuations as control-flow:" +{ $subsection attempt-all } +{ $subsection with-return } "Reflecting the datastack:" { $subsection with-datastack } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." @@ -211,3 +214,42 @@ HELP: with-datastack { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; + +HELP: +{ $description "Constructs a new continuation." } +{ $notes "User code should call " { $link continuation } " instead." } ; + +HELP: attempt-all +{ $values + { "seq" sequence } { "quot" quotation } + { "obj" object } } +{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." } +{ $examples "The first two numbers throw, the last one doesn't:" + { $example + "USING: prettyprint continuations kernel math ;" + "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ." + "6" } + "All quotations throw, the last exception is rethrown:" + { $example + "USING: prettyprint continuations kernel math ;" + "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ." + "5" + } +} ; + +HELP: return +{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; + +HELP: with-return +{ $values + { "quot" quotation } } +{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." } +{ $examples + "Only \"Hi\" will print:" + { $example + "USING: prettyprint continuations io ;" + "[ \"Hi\" print return \"Bye\" print ] with-return" + "Hi" +} } ; + +{ return with-return } related-words From 819234bedd656be7f014efb869e06744c2d7ab9a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 16 Sep 2008 22:55:26 -0500 Subject: [PATCH 050/294] document dispose-each --- core/destructors/destructors-docs.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index b611b8ec19..c82f92dc10 100755 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax libc kernel continuations io ; +USING: help.markup help.syntax libc kernel continuations io +sequences ; IN: destructors HELP: dispose @@ -45,6 +46,11 @@ HELP: |dispose { $values { "disposable" "a disposable object" } } { $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ; +HELP: dispose-each +{ $values + { "seq" sequence } } +{ $description "Attempts to dispose of each element of a sequence and collects all of the errors into a sequence. If any errors are thrown during disposal, the last error is rethrown after all objects have been disposed." } ; + ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns" "Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:" { $code From 733ad4616a401c076e7e42028b214f92ffdf2b87 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 16 Sep 2008 23:03:42 -0500 Subject: [PATCH 051/294] print the word name as a clickable link instead of just text --- basis/tools/scaffold/scaffold.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 12f9a55795..60082e7e00 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -157,7 +157,7 @@ ERROR: no-vocab vocab ; "{ $description \"\" } ;" print ; : help-header. ( word -- ) - "HELP: " write name>> print ; + "HELP: " write . ; : (help.) ( word -- ) [ help-header. ] [ $values. ] [ $description. ] tri ; From dff2c2808b0ce86a03290d76801cad6dce4b9fcb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 16 Sep 2008 23:14:25 -0500 Subject: [PATCH 052/294] document ?set-at --- core/hashtables/hashtables-docs.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index 07517afdf7..7cc8333c12 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -111,6 +111,12 @@ HELP: associate { $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } } { $description "Create a new hashtable holding one key/value pair." } ; +HELP: ?set-at +{ $values + { "value" object } { "key" object } { "assoc/f" "an assoc or " { $link f } } + { "assoc" assoc } } +{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ; + HELP: >hashtable { $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } } { $description "Constructs a hashtable from any assoc." } ; From e3ae3afcb84bc86e3bc03bfe76150ddc5035bc55 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 16 Sep 2008 23:52:04 -0500 Subject: [PATCH 053/294] document stream-read-partial, read-partial, change stack effect --- core/io/io-docs.factor | 258 ++++++++++++++++++++++------------------- core/io/io.factor | 2 +- 2 files changed, 137 insertions(+), 123 deletions(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index b639696f57..43f66657a7 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -1,128 +1,7 @@ USING: help.markup help.syntax quotations hashtables kernel -classes strings continuations destructors ; +classes strings continuations destructors math ; IN: io -ARTICLE: "stream-protocol" "Stream protocol" -"The stream protocol consists of a large number of generic words, many of which are optional." -$nl -"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "." -$nl -"All streams must implement the " { $link dispose } " word in addition to the stream protocol." -$nl -"Three words are required for input streams:" -{ $subsection stream-read1 } -{ $subsection stream-read } -{ $subsection stream-read-until } -{ $subsection stream-readln } -"Seven words are required for output streams:" -{ $subsection stream-flush } -{ $subsection stream-write1 } -{ $subsection stream-write } -{ $subsection stream-format } -{ $subsection stream-nl } -{ $subsection make-span-stream } -{ $subsection make-block-stream } -{ $subsection make-cell-stream } -{ $subsection stream-write-table } -{ $see-also "io.timeouts" } ; - -ARTICLE: "stdio" "Default input and output streams" -"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:" -{ $list - { "Code becomes simpler because there is no need to keep a stream around on the stack." } - { "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." } - { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." } -} -"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:" -{ $code - "USING: continuations kernel io io.files math.parser splitting ;" - "\"data.txt\" utf8 " - "dup stream-readln number>string over stream-read 16 group" - "swap dispose" -} -"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:" -{ $code - "USING: continuations kernel io io.files math.parser splitting ;" - "\"data.txt\" utf8 [" - " dup stream-readln number>string over stream-read" - " 16 group" - "] with-disposal" -} -"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:" -{ $code - "USING: continuations kernel io io.files math.parser splitting ;" - "\"data.txt\" utf8 [" - " readln number>string read 16 group" - "] with-input-stream" -} -"An even better implementation that takes advantage of a utility word:" -{ $code - "USING: continuations kernel io io.files math.parser splitting ;" - "\"data.txt\" utf8 [" - " readln number>string read 16 group" - "] with-file-reader" -} -"The default input stream is stored in a dynamically-scoped variable:" -{ $subsection input-stream } -"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user." -$nl -"Words reading from the default input stream:" -{ $subsection read1 } -{ $subsection read } -{ $subsection read-until } -{ $subsection readln } -"A pair of combinators for rebinding the " { $link input-stream } " variable:" -{ $subsection with-input-stream } -{ $subsection with-input-stream* } -"The default output stream is stored in a dynamically-scoped variable:" -{ $subsection output-stream } -"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user." -$nl -"Words writing to the default input stream:" -{ $subsection flush } -{ $subsection write1 } -{ $subsection write } -{ $subsection print } -{ $subsection nl } -{ $subsection bl } -"Formatted output:" -{ $subsection format } -{ $subsection with-style } -{ $subsection with-nesting } -"Tabular output:" -{ $subsection tabular-output } -{ $subsection with-row } -{ $subsection with-cell } -{ $subsection write-cell } -"A pair of combinators for rebinding the " { $link output-stream } " variable:" -{ $subsection with-output-stream } -{ $subsection with-output-stream* } -"A pair of combinators for rebinding both default streams at once:" -{ $subsection with-streams } -{ $subsection with-streams* } ; - -ARTICLE: "stream-utils" "Stream utilities" -"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol." -$nl -"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" -{ $subsection stream-print } -"Sluring an entire stream into memory all at once:" -{ $subsection lines } -{ $subsection contents } -"Copying the contents of one stream to another:" -{ $subsection stream-copy } ; - -ARTICLE: "streams" "Streams" -"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." -$nl -"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "." -{ $subsection "stream-protocol" } -{ $subsection "stdio" } -{ $subsection "stream-utils" } -{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ; - -ABOUT: "streams" - HELP: stream-readln { $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } @@ -147,6 +26,12 @@ HELP: stream-read-until { $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." } $io-error ; +HELP: stream-read-partial +{ $values + { "n" integer } { "stream" "an input stream" } + { "str/f" "a string or " { $link f } } } +{ $description "Reads at most " { $snippet "n" } " characters from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; + HELP: stream-write1 { $values { "ch" "a character" } { "stream" "an output stream" } } { $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } @@ -249,6 +134,12 @@ HELP: read-until { $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } $io-error ; +HELP: read-partial +{ $values + { "n" null } + { "str/f" null } } +{ $description "Reads at most " { $snippet "n" } " characters from " { $link input-stream } " and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; + HELP: write1 { $values { "ch" "a character" } } { $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } @@ -363,3 +254,126 @@ HELP: contents { $values { "stream" "an input stream" } { "str" string } } { $description "Reads the entire contents of a stream into a string." } $io-error ; + +ARTICLE: "stream-protocol" "Stream protocol" +"The stream protocol consists of a large number of generic words, many of which are optional." +$nl +"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "." +$nl +"All streams must implement the " { $link dispose } " word in addition to the stream protocol." +$nl +"These words are required for input streams:" +{ $subsection stream-read1 } +{ $subsection stream-read } +{ $subsection stream-read-until } +{ $subsection stream-readln } +{ $subsection stream-read-partial } +"These words are required for output streams:" +{ $subsection stream-flush } +{ $subsection stream-write1 } +{ $subsection stream-write } +{ $subsection stream-format } +{ $subsection stream-nl } +{ $subsection make-span-stream } +{ $subsection make-block-stream } +{ $subsection make-cell-stream } +{ $subsection stream-write-table } +{ $see-also "io.timeouts" } ; + +ARTICLE: "stdio" "Default input and output streams" +"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:" +{ $list + { "Code becomes simpler because there is no need to keep a stream around on the stack." } + { "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." } + { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." } +} +"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" utf8 " + "dup stream-readln number>string over stream-read 16 group" + "swap dispose" +} +"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" utf8 [" + " dup stream-readln number>string over stream-read" + " 16 group" + "] with-disposal" +} +"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" utf8 [" + " readln number>string read 16 group" + "] with-input-stream" +} +"An even better implementation that takes advantage of a utility word:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" utf8 [" + " readln number>string read 16 group" + "] with-file-reader" +} +"The default input stream is stored in a dynamically-scoped variable:" +{ $subsection input-stream } +"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user." +$nl +"Words reading from the default input stream:" +{ $subsection read1 } +{ $subsection read } +{ $subsection read-until } +{ $subsection readln } +{ $subsection read-partial } +"A pair of combinators for rebinding the " { $link input-stream } " variable:" +{ $subsection with-input-stream } +{ $subsection with-input-stream* } +"The default output stream is stored in a dynamically-scoped variable:" +{ $subsection output-stream } +"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user." +$nl +"Words writing to the default input stream:" +{ $subsection flush } +{ $subsection write1 } +{ $subsection write } +{ $subsection print } +{ $subsection nl } +{ $subsection bl } +"Formatted output:" +{ $subsection format } +{ $subsection with-style } +{ $subsection with-nesting } +"Tabular output:" +{ $subsection tabular-output } +{ $subsection with-row } +{ $subsection with-cell } +{ $subsection write-cell } +"A pair of combinators for rebinding the " { $link output-stream } " variable:" +{ $subsection with-output-stream } +{ $subsection with-output-stream* } +"A pair of combinators for rebinding both default streams at once:" +{ $subsection with-streams } +{ $subsection with-streams* } ; + +ARTICLE: "stream-utils" "Stream utilities" +"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol." +$nl +"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" +{ $subsection stream-print } +"Sluring an entire stream into memory all at once:" +{ $subsection lines } +{ $subsection contents } +"Copying the contents of one stream to another:" +{ $subsection stream-copy } ; + +ARTICLE: "streams" "Streams" +"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." +$nl +"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "." +{ $subsection "stream-protocol" } +{ $subsection "stdio" } +{ $subsection "stream-utils" } +{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ; + +ABOUT: "streams" diff --git a/core/io/io.factor b/core/io/io.factor index 0d5a857490..c50fc6f46c 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -8,7 +8,7 @@ GENERIC: stream-readln ( stream -- str/f ) GENERIC: stream-read1 ( stream -- ch/f ) GENERIC: stream-read ( n stream -- str/f ) GENERIC: stream-read-until ( seps stream -- str/f sep/f ) -GENERIC: stream-read-partial ( max stream -- str/f ) +GENERIC: stream-read-partial ( n stream -- str/f ) GENERIC: stream-write1 ( ch stream -- ) GENERIC: stream-write ( str stream -- ) GENERIC: stream-flush ( stream -- ) From fa3999b909865182acf976f3fd065daca7cbd581 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 17 Sep 2008 00:18:42 -0500 Subject: [PATCH 054/294] add some docs for loop, move article to the end --- core/kernel/kernel-docs.factor | 582 +++++++++++++++++---------------- 1 file changed, 299 insertions(+), 283 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index c833325c41..786919bb68 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -4,289 +4,6 @@ kernel.private vectors combinators quotations strings words assocs arrays math.order ; IN: kernel -ARTICLE: "shuffle-words" "Shuffle words" -"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions." -$nl -"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "." -$nl -"Removing stack elements:" -{ $subsection drop } -{ $subsection 2drop } -{ $subsection 3drop } -{ $subsection nip } -{ $subsection 2nip } -"Duplicating stack elements:" -{ $subsection dup } -{ $subsection 2dup } -{ $subsection 3dup } -{ $subsection dupd } -{ $subsection over } -{ $subsection 2over } -{ $subsection pick } -{ $subsection tuck } -"Permuting stack elements:" -{ $subsection swap } -{ $subsection swapd } -{ $subsection rot } -{ $subsection -rot } -{ $subsection spin } -{ $subsection roll } -{ $subsection -roll } -"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:" -{ $subsection >r } -{ $subsection r> } -"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":" -{ $example "1 2 3 >r .s r>" "1\n2" } -"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning." -$nl -"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ; - -ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" -"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." -$nl -"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" -{ $code - ": keep [ ] bi ;" - ": 2keep [ ] 2bi ;" - ": 3keep [ ] 3bi ;" - "" - ": dup [ ] [ ] bi ;" - ": 2dup [ ] [ ] 2bi ;" - ": 3dup [ ] [ ] 3bi ;" - "" - ": tuck [ nip ] [ ] 2bi ;" - ": swap [ nip ] [ drop ] 2bi ;" - "" - ": over [ ] [ drop ] 2bi ;" - ": pick [ ] [ 2drop ] 3bi ;" - ": 2over [ ] [ drop ] 3bi ;" -} ; - -ARTICLE: "cleave-combinators" "Cleave combinators" -"The cleave combinators apply multiple quotations to a single value." -$nl -"Two quotations:" -{ $subsection bi } -{ $subsection 2bi } -{ $subsection 3bi } -"Three quotations:" -{ $subsection tri } -{ $subsection 2tri } -{ $subsection 3tri } -"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" -{ $code - "! First alternative; uses keep" - "[ 1 + ] keep" - "[ 1 - ] keep" - "2 *" - "! Second alternative: uses tri" - "[ 1 + ]" - "[ 1 - ]" - "[ 2 * ] tri" -} -"The latter is more aesthetically pleasing than the former." -$nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." -{ $subsection "cleave-shuffle-equivalence" } ; - -ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" -"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "." -$nl -"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" -{ $code - ": dip [ ] bi* ;" - ": 2dip [ ] [ ] tri* ;" - "" - ": slip [ call ] [ ] bi* ;" - ": 2slip [ call ] [ ] [ ] tri* ;" - "" - ": nip [ drop ] [ ] bi* ;" - ": 2nip [ drop ] [ drop ] [ ] tri* ;" - "" - ": rot" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" - "" - ": -rot" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " 3tri ;" - "" - ": spin" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" -} ; - -ARTICLE: "spread-combinators" "Spread combinators" -"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." -$nl -"Two quotations:" -{ $subsection bi* } -{ $subsection 2bi* } -"Three quotations:" -{ $subsection tri* } -"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" -{ $code - "! First alternative; uses retain stack explicitly" - ">r >r 1 +" - "r> 1 -" - "r> 2 *" - "! Second alternative: uses tri*" - "[ 1 + ]" - "[ 1 - ]" - "[ 2 * ] tri*" -} - -$nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." -{ $subsection "spread-shuffle-equivalence" } ; - -ARTICLE: "apply-combinators" "Apply combinators" -"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." -$nl -"Two quotations:" -{ $subsection bi@ } -{ $subsection 2bi@ } -"Three quotations:" -{ $subsection tri@ } -"A pair of utility words built from " { $link bi@ } ":" -{ $subsection both? } -{ $subsection either? } ; - -ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators" -"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" -{ $subsection dip } -{ $subsection 2dip } -"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" -{ $subsection slip } -{ $subsection 2slip } -{ $subsection 3slip } -"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" -{ $subsection keep } -{ $subsection 2keep } -{ $subsection 3keep } ; - -ARTICLE: "compositional-combinators" "Compositional combinators" -"Quotations can be composed using efficient quotation-specific operations:" -{ $subsection curry } -{ $subsection 2curry } -{ $subsection 3curry } -{ $subsection with } -{ $subsection compose } -{ $subsection 3compose } -{ $subsection prepose } -"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ; - -ARTICLE: "implementing-combinators" "Implementing combinators" -"The following pair of words invoke words and quotations reflectively:" -{ $subsection call } -{ $subsection execute } -"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" -{ $code - ": keep ( x quot -- x )" - " over >r call r> ; inline" -} -"Word inlining is documented in " { $link "declarations" } "." ; - -ARTICLE: "booleans" "Booleans" -"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." -{ $subsection f } -{ $subsection t } -"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing." -$nl -"Here is the " { $link f } " object:" -{ $example "f ." "f" } -"Here is the " { $link f } " class:" -{ $example "\\ f ." "POSTPONE: f" } -"They are not equal:" -{ $example "f \\ f = ." "f" } -"Here is an array containing the " { $link f } " object:" -{ $example "{ f } ." "{ f }" } -"Here is an array containing the " { $link f } " class:" -{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" } -"The " { $link f } " object is an instance of the " { $link f } " class:" -{ $example "f class ." "POSTPONE: f" } -"The " { $link f } " class is an instance of " { $link word } ":" -{ $example "\\ f class ." "word" } -"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." -{ $example "t \\ t eq? ." "t" } -"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; - -ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" -"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." -$nl -"The following two lines are equivalent:" -{ $code "[ drop f ] unless" "swap and" } -"The following two lines are equivalent:" -{ $code "[ ] [ ] ?if" "swap or" } -"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" -{ $code "[ L ] unless*" "L or" } ; - -ARTICLE: "conditionals" "Conditionals and logic" -"The basic conditionals:" -{ $subsection if } -{ $subsection when } -{ $subsection unless } -"Forms abstracting a common stack shuffle pattern:" -{ $subsection if* } -{ $subsection when* } -{ $subsection unless* } -"Another form abstracting a common stack shuffle pattern:" -{ $subsection ?if } -"Sometimes instead of branching, you just need to pick one of two values:" -{ $subsection ? } -"There are some logical operations on booleans:" -{ $subsection >boolean } -{ $subsection not } -{ $subsection and } -{ $subsection or } -{ $subsection xor } -{ $subsection "conditionals-boolean-equivalence" } -"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." -{ $see-also "booleans" "bitwise-arithmetic" both? either? } ; - -ARTICLE: "equality" "Equality" -"There are two distinct notions of ``sameness'' when it comes to objects." -$nl -"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:" -{ $subsection eq? } -"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):" -{ $subsection = } -"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types." -$nl -"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:" -{ $subsection equal? } -"Utility class:" -{ $subsection identity-tuple } -"An object can be cloned; the clone has distinct identity but equal value:" -{ $subsection clone } ; - -ARTICLE: "dataflow" "Data and control flow" -{ $subsection "evaluator" } -{ $subsection "words" } -{ $subsection "effects" } -{ $subsection "booleans" } -{ $subsection "shuffle-words" } -"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." -{ $subsection "cleave-combinators" } -{ $subsection "spread-combinators" } -{ $subsection "apply-combinators" } -{ $subsection "slip-keep-combinators" } -{ $subsection "conditionals" } -{ $subsection "compositional-combinators" } -{ $subsection "combinators" } -"Advanced topics:" -{ $subsection "implementing-combinators" } -{ $subsection "errors" } -{ $subsection "continuations" } ; - -ABOUT: "dataflow" - HELP: eq? ( obj1 obj2 -- ? ) { $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if two references point at the same object." } ; @@ -916,6 +633,20 @@ $nl } "However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ; +HELP: loop +{ $values + { "pred" quotation } } +{ $description "Calls the quotation repeatedly until the output is true." } +{ $examples "Loop until we hit a zero:" + { $unchecked-example "USING: kernel random math io ; " + " [ \"hi\" write bl 10 random zero? not ] loop" + "hi hi hi" } + "A fun loop:" + { $example "USING: kernel prettyprint math ; " + "3 [ dup . 7 + 11 mod dup 3 = not ] loop" + "3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" } +} ; + HELP: assert { $values { "got" "the obtained value" } { "expect" "the expected value" } } { $description "Throws an " { $link assert } " error." } @@ -924,3 +655,288 @@ HELP: assert HELP: assert= { $values { "a" object } { "b" object } } { $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ; + + +ARTICLE: "shuffle-words" "Shuffle words" +"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions." +$nl +"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "." +$nl +"Removing stack elements:" +{ $subsection drop } +{ $subsection 2drop } +{ $subsection 3drop } +{ $subsection nip } +{ $subsection 2nip } +"Duplicating stack elements:" +{ $subsection dup } +{ $subsection 2dup } +{ $subsection 3dup } +{ $subsection dupd } +{ $subsection over } +{ $subsection 2over } +{ $subsection pick } +{ $subsection tuck } +"Permuting stack elements:" +{ $subsection swap } +{ $subsection swapd } +{ $subsection rot } +{ $subsection -rot } +{ $subsection spin } +{ $subsection roll } +{ $subsection -roll } +"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:" +{ $subsection >r } +{ $subsection r> } +"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":" +{ $example "1 2 3 >r .s r>" "1\n2" } +"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning." +$nl +"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ; + +ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" +"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." +$nl +"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" +{ $code + ": keep [ ] bi ;" + ": 2keep [ ] 2bi ;" + ": 3keep [ ] 3bi ;" + "" + ": dup [ ] [ ] bi ;" + ": 2dup [ ] [ ] 2bi ;" + ": 3dup [ ] [ ] 3bi ;" + "" + ": tuck [ nip ] [ ] 2bi ;" + ": swap [ nip ] [ drop ] 2bi ;" + "" + ": over [ ] [ drop ] 2bi ;" + ": pick [ ] [ 2drop ] 3bi ;" + ": 2over [ ] [ drop ] 3bi ;" +} ; + +ARTICLE: "cleave-combinators" "Cleave combinators" +"The cleave combinators apply multiple quotations to a single value." +$nl +"Two quotations:" +{ $subsection bi } +{ $subsection 2bi } +{ $subsection 3bi } +"Three quotations:" +{ $subsection tri } +{ $subsection 2tri } +{ $subsection 3tri } +"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" +{ $code + "! First alternative; uses keep" + "[ 1 + ] keep" + "[ 1 - ] keep" + "2 *" + "! Second alternative: uses tri" + "[ 1 + ]" + "[ 1 - ]" + "[ 2 * ] tri" +} +"The latter is more aesthetically pleasing than the former." +$nl +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "cleave-shuffle-equivalence" } ; + +ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "." +$nl +"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" +{ $code + ": dip [ ] bi* ;" + ": 2dip [ ] [ ] tri* ;" + "" + ": slip [ call ] [ ] bi* ;" + ": 2slip [ call ] [ ] [ ] tri* ;" + "" + ": nip [ drop ] [ ] bi* ;" + ": 2nip [ drop ] [ drop ] [ ] tri* ;" + "" + ": rot" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" + "" + ": -rot" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " 3tri ;" + "" + ": spin" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" +} ; + +ARTICLE: "spread-combinators" "Spread combinators" +"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." +$nl +"Two quotations:" +{ $subsection bi* } +{ $subsection 2bi* } +"Three quotations:" +{ $subsection tri* } +"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" +{ $code + "! First alternative; uses retain stack explicitly" + ">r >r 1 +" + "r> 1 -" + "r> 2 *" + "! Second alternative: uses tri*" + "[ 1 + ]" + "[ 1 - ]" + "[ 2 * ] tri*" +} + +$nl +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "spread-shuffle-equivalence" } ; + +ARTICLE: "apply-combinators" "Apply combinators" +"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." +$nl +"Two quotations:" +{ $subsection bi@ } +{ $subsection 2bi@ } +"Three quotations:" +{ $subsection tri@ } +"A pair of utility words built from " { $link bi@ } ":" +{ $subsection both? } +{ $subsection either? } ; + +ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators" +"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" +{ $subsection dip } +{ $subsection 2dip } +"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" +{ $subsection slip } +{ $subsection 2slip } +{ $subsection 3slip } +"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" +{ $subsection keep } +{ $subsection 2keep } +{ $subsection 3keep } ; + +ARTICLE: "compositional-combinators" "Compositional combinators" +"Quotations can be composed using efficient quotation-specific operations:" +{ $subsection curry } +{ $subsection 2curry } +{ $subsection 3curry } +{ $subsection with } +{ $subsection compose } +{ $subsection 3compose } +{ $subsection prepose } +"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ; + +ARTICLE: "implementing-combinators" "Implementing combinators" +"The following pair of words invoke words and quotations reflectively:" +{ $subsection call } +{ $subsection execute } +"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" +{ $code + ": keep ( x quot -- x )" + " over >r call r> ; inline" +} +"Word inlining is documented in " { $link "declarations" } "." ; + +ARTICLE: "booleans" "Booleans" +"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." +{ $subsection f } +{ $subsection t } +"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing." +$nl +"Here is the " { $link f } " object:" +{ $example "f ." "f" } +"Here is the " { $link f } " class:" +{ $example "\\ f ." "POSTPONE: f" } +"They are not equal:" +{ $example "f \\ f = ." "f" } +"Here is an array containing the " { $link f } " object:" +{ $example "{ f } ." "{ f }" } +"Here is an array containing the " { $link f } " class:" +{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" } +"The " { $link f } " object is an instance of the " { $link f } " class:" +{ $example "f class ." "POSTPONE: f" } +"The " { $link f } " class is an instance of " { $link word } ":" +{ $example "\\ f class ." "word" } +"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." +{ $example "t \\ t eq? ." "t" } +"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; + +ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" +"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." +$nl +"The following two lines are equivalent:" +{ $code "[ drop f ] unless" "swap and" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } ; + +ARTICLE: "conditionals" "Conditionals and logic" +"The basic conditionals:" +{ $subsection if } +{ $subsection when } +{ $subsection unless } +"Forms abstracting a common stack shuffle pattern:" +{ $subsection if* } +{ $subsection when* } +{ $subsection unless* } +"Another form abstracting a common stack shuffle pattern:" +{ $subsection ?if } +"Sometimes instead of branching, you just need to pick one of two values:" +{ $subsection ? } +"There are some logical operations on booleans:" +{ $subsection >boolean } +{ $subsection not } +{ $subsection and } +{ $subsection or } +{ $subsection xor } +{ $subsection "conditionals-boolean-equivalence" } +"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." +{ $see-also "booleans" "bitwise-arithmetic" both? either? } ; + +ARTICLE: "equality" "Equality" +"There are two distinct notions of ``sameness'' when it comes to objects." +$nl +"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:" +{ $subsection eq? } +"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):" +{ $subsection = } +"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types." +$nl +"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:" +{ $subsection equal? } +"Utility class:" +{ $subsection identity-tuple } +"An object can be cloned; the clone has distinct identity but equal value:" +{ $subsection clone } ; + +ARTICLE: "dataflow" "Data and control flow" +{ $subsection "evaluator" } +{ $subsection "words" } +{ $subsection "effects" } +{ $subsection "booleans" } +{ $subsection "shuffle-words" } +"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } +{ $subsection "slip-keep-combinators" } +{ $subsection "conditionals" } +{ $subsection "compositional-combinators" } +{ $subsection "combinators" } +"Advanced topics:" +{ $subsection "implementing-combinators" } +{ $subsection "errors" } +{ $subsection "continuations" } ; + +ABOUT: "dataflow" + From 3d7ed0f1223f98518bad68f635da34fc9fd43322 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 17 Sep 2008 00:21:11 -0500 Subject: [PATCH 055/294] document ?1+ for the lulz --- core/math/math-docs.factor | 120 +++++++++++++++++++------------------ 1 file changed, 62 insertions(+), 58 deletions(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index b38baa5cc9..a863715d33 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -2,64 +2,6 @@ USING: help.markup help.syntax kernel sequences quotations math.private ; IN: math -ARTICLE: "division-by-zero" "Division by zero" -"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value." -$nl -"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero." -$nl -"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ; - -ARTICLE: "number-protocol" "Number protocol" -"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float." -$nl -"Two examples where you should note the types of the inputs and outputs:" -{ $example "3 >fixnum 6 >bignum * class ." "bignum" } -{ $example "1/2 2.0 + ." "4.5" } -"The following usual operations are supported by all numbers." -{ $subsection + } -{ $subsection - } -{ $subsection * } -{ $subsection / } -"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2." -{ $subsection "division-by-zero" } -"Real numbers (but not complex numbers) can be ordered:" -{ $subsection < } -{ $subsection <= } -{ $subsection > } -{ $subsection >= } -"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:" -{ $subsection number= } ; - -ARTICLE: "modular-arithmetic" "Modular arithmetic" -{ $subsection mod } -{ $subsection rem } -{ $subsection /mod } -{ $subsection /i } -{ $see-also "integer-functions" } ; - -ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" -"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "." -{ $subsection bitand } -{ $subsection bitor } -{ $subsection bitxor } -{ $subsection bitnot } -{ $subsection shift } -{ $subsection 2/ } -{ $subsection 2^ } -{ $subsection bit? } -{ $see-also "conditionals" } ; - -ARTICLE: "arithmetic" "Arithmetic" -"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers." -$nl -"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary." -{ $subsection "number-protocol" } -{ $subsection "modular-arithmetic" } -{ $subsection "bitwise-arithmetic" } -{ $see-also "integers" "rationals" "floats" "complex-numbers" } ; - -ABOUT: "arithmetic" - HELP: number= { $values { "x" number } { "y" number } { "?" "a boolean" } } { $description "Tests if two numbers have the same numeric value." } @@ -235,6 +177,9 @@ HELP: 1- { $code "1-" "1 -" } } ; +HELP: ?1+ +{ $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ; + HELP: sq { $values { "x" number } { "y" number } } { $description "Multiplies a number by itself." } ; @@ -357,3 +302,62 @@ HELP: find-last-integer { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } } { $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." } { $notes "This word is used to implement " { $link find-last } "." } ; + +ARTICLE: "division-by-zero" "Division by zero" +"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value." +$nl +"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero." +$nl +"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ; + +ARTICLE: "number-protocol" "Number protocol" +"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float." +$nl +"Two examples where you should note the types of the inputs and outputs:" +{ $example "3 >fixnum 6 >bignum * class ." "bignum" } +{ $example "1/2 2.0 + ." "4.5" } +"The following usual operations are supported by all numbers." +{ $subsection + } +{ $subsection - } +{ $subsection * } +{ $subsection / } +"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2." +{ $subsection "division-by-zero" } +"Real numbers (but not complex numbers) can be ordered:" +{ $subsection < } +{ $subsection <= } +{ $subsection > } +{ $subsection >= } +"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:" +{ $subsection number= } ; + +ARTICLE: "modular-arithmetic" "Modular arithmetic" +{ $subsection mod } +{ $subsection rem } +{ $subsection /mod } +{ $subsection /i } +{ $see-also "integer-functions" } ; + +ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" +"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "." +{ $subsection bitand } +{ $subsection bitor } +{ $subsection bitxor } +{ $subsection bitnot } +{ $subsection shift } +{ $subsection 2/ } +{ $subsection 2^ } +{ $subsection bit? } +{ $see-also "conditionals" } ; + +ARTICLE: "arithmetic" "Arithmetic" +"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers." +$nl +"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary." +{ $subsection "number-protocol" } +{ $subsection "modular-arithmetic" } +{ $subsection "bitwise-arithmetic" } +{ $see-also "integers" "rationals" "floats" "complex-numbers" } ; + +ABOUT: "arithmetic" + From 6f91454cf33147cc8a57ab87331dd9e41d8d5ac5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 17 Sep 2008 00:35:40 -0500 Subject: [PATCH 056/294] document count-instances --- core/memory/memory-docs.factor | 40 ++++++++++++++++++++++------------ 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index 506ae43671..fb1d4a336f 100755 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -1,19 +1,7 @@ -USING: help.markup help.syntax debugger sequences kernel ; +USING: help.markup help.syntax debugger sequences kernel +quotations math ; IN: memory -ARTICLE: "images" "Images" -"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:" -{ $subsection save } -{ $subsection save-image } -{ $subsection save-image-and-exit } -"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "." -$nl -"New images can be created from scratch:" -{ $subsection "bootstrap.image" } -{ $see-also "tools.memory" "tools.deploy" } ; - -ABOUT: "images" - HELP: begin-scan ( -- ) { $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." $nl @@ -67,3 +55,27 @@ HELP: save-image-and-exit ( path -- ) HELP: save { $description "Saves a snapshot of the heap to the current image file." } ; + +HELP: count-instances +{ $values + { "quot" quotation } + { "n" integer } } +{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." } +{ $examples { $unchecked-example + "USING: memory words prettyprint ;" + "[ word? ] count-instances ." + "24210" +} } ; + +ARTICLE: "images" "Images" +"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:" +{ $subsection save } +{ $subsection save-image } +{ $subsection save-image-and-exit } +"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "." +$nl +"New images can be created from scratch:" +{ $subsection "bootstrap.image" } +{ $see-also "tools.memory" "tools.deploy" } ; + +ABOUT: "images" From 6cad2e02e495b9adde0a094c2f3b743ecefe917e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 17 Sep 2008 00:46:38 -0500 Subject: [PATCH 057/294] Updating x86 backend for new codegen --- basis/compiler/constants/constants.factor | 27 + unfinished/compiler/backend/backend.factor | 221 ++++- unfinished/compiler/backend/x86/32/32.factor | 313 +++++++- unfinished/compiler/backend/x86/64/64.factor | 218 ++++- .../compiler/backend/x86/sse2/sse2.factor | 110 +++ unfinished/compiler/backend/x86/x86.factor | 755 ++++++++++++++++++ .../compiler/cfg/builder/builder.factor | 109 ++- unfinished/compiler/cfg/cfg.factor | 7 +- .../compiler/cfg/debugger/debugger.factor | 5 +- .../cfg/instructions/instructions.factor | 115 ++- .../cfg/linear-scan/linear-scan-tests.factor | 5 + .../cfg/linear-scan/linear-scan.factor | 13 +- .../live-intervals/live-intervals.factor | 1 - .../cfg/linearization/linearization.factor | 42 +- .../compiler/cfg/registers/registers.factor | 22 +- unfinished/compiler/cfg/rpo/rpo.factor | 1 - unfinished/compiler/cfg/stacks/stacks.factor | 91 +-- .../compiler/cfg/templates/templates.factor | 31 +- .../alien.factor => codegen/codegen.factor} | 222 +++-- .../compiler/codegen/fixup/fixup.factor | 77 +- unfinished/compiler/new/new.factor | 116 +++ 21 files changed, 2134 insertions(+), 367 deletions(-) create mode 100644 unfinished/compiler/backend/x86/sse2/sse2.factor create mode 100644 unfinished/compiler/backend/x86/x86.factor rename unfinished/compiler/{backend/alien/alien.factor => codegen/codegen.factor} (58%) create mode 100644 unfinished/compiler/new/new.factor diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 80f0b4f515..b5b2be5095 100755 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -23,3 +23,30 @@ IN: compiler.constants : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; : compiled-header-size ( -- n ) 4 bootstrap-cells ; + +! Relocation classes +: rc-absolute-cell 0 ; +: rc-absolute 1 ; +: rc-relative 2 ; +: rc-absolute-ppc-2/2 3 ; +: rc-relative-ppc-2 4 ; +: rc-relative-ppc-3 5 ; +: rc-relative-arm-3 6 ; +: rc-indirect-arm 7 ; +: rc-indirect-arm-pc 8 ; + +! Relocation types +: rt-primitive 0 ; +: rt-dlsym 1 ; +: rt-literal 2 ; +: rt-dispatch 3 ; +: rt-xt 4 ; +: rt-here 5 ; +: rt-label 6 ; +: rt-immediate 7 ; + +: rc-absolute? ( n -- ? ) + [ rc-absolute-ppc-2/2 = ] + [ rc-absolute-cell = ] + [ rc-absolute = ] + tri or or ; diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor index c1944eb9a7..ffe8f73ba9 100644 --- a/unfinished/compiler/backend/backend.factor +++ b/unfinished/compiler/backend/backend.factor @@ -1,10 +1,223 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system ; +USING: accessors assocs arrays generic kernel kernel.private +math memory namespaces make sequences layouts system hashtables +classes alien byte-arrays combinators words sets classes.algebra +compiler.cfg.registers compiler.cfg.instructions ; IN: compiler.backend -! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? cpu ( size -- ? ) +! Labels +TUPLE: label offset ; + +: