From 3b4bc615f10b8fb6f64f4907ade905bf0928c81a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 18 Sep 2008 12:50:16 -0500 Subject: [PATCH 001/289] 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/289] 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/289] 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/289] 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/289] 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/289] \\?\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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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/289] 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 ccac749a70c336305fb98bf99967055986dcfe44 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 14 Sep 2008 10:04:04 -0700 Subject: [PATCH 026/289] 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 55003480bc3b22645572d5006d6f5826f6c50e89 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 16 Sep 2008 17:26:28 -0700 Subject: [PATCH 027/289] 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 3e1303f784115b466e3b224290ab0b37a77e80b0 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 17 Sep 2008 09:22:48 -0700 Subject: [PATCH 028/289] Adding documentation for printf, and improvements based on IRC feedback. --- extra/printf/printf-docs.factor | 47 ++++++++++++++++++ extra/printf/printf-tests.factor | 84 +++++++++++++++++--------------- extra/printf/printf.factor | 57 +++++++++------------- 3 files changed, 117 insertions(+), 71 deletions(-) create mode 100755 extra/printf/printf-docs.factor diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor new file mode 100755 index 0000000000..c1638f0d23 --- /dev/null +++ b/extra/printf/printf-docs.factor @@ -0,0 +1,47 @@ + +USING: help.syntax help.markup kernel prettyprint sequences strings ; + +IN: printf + +HELP: printf +{ $values { "format-string" string } } +{ $description + "Writes the arguments formatted according to the format string." + { $table + { "%%" "Single %" "" } + { "%Wd" "Integer W digits wide (e.g., \"1234\")" "fixnum" } + { "%W.De" "Scientific notation" "fixnum, float" } + { "%W.DE" "Scientific notation" "fixnum, float" } + { "%W.Df" "Fixed format" "fixnum, float" } + { "%Wx" "Hexadecimal" "hex" } + { "%WX" "Hexadecimal uppercase" "hex" } + { "%W.Ds" "String format" "string" } + { "%W.DS" "String format uppercase" "string" } + { "%c" "Character format" "char" } + { "%C" "Character format uppercase" "char" } + } +} +{ $examples + { $example + "USING: printf ;" + "{ 123 } \"%05d\" printf" + "00123" } + { $example + "USING: printf ;" + "{ HEX: ff } \"04X\" printf" + "00FF" } + { $example + "USING: printf ;" + "{ 1.23456789 } \"%.3f\" printf" + "1.234" } + { $example + "USING: printf ;" + "{ 1234567890 } \"%.5e\" printf" + "1.23456e+09" } +} ; + +HELP: sprintf +{ $values { "params" sequence } { "format-string" string } { "result" string } } +{ $description "Returns the arguments formatted according to the format string as a result string." } +{ $see-also printf } ; + diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 05c33956d9..7d89b35ae9 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -3,90 +3,98 @@ USING: kernel printf tools.test ; -[ t ] [ "10" [ { 10 } "%d" sprintf ] call = ] unit-test +[ "%s" printf ] must-infer -[ t ] [ "123.456" [ { 123.456 } "%f" sprintf ] call = ] unit-test +[ t ] [ "10" { 10 } "%d" sprintf = ] unit-test -[ t ] [ "123.10" [ { 123.1 } "%01.2f" sprintf ] call = ] unit-test +[ t ] [ "123.456" { 123.456 } "%f" sprintf = ] unit-test -[ t ] [ "1.2345" [ { 1.23456789 } "%.4f" sprintf ] call = ] unit-test +[ t ] [ "123.10" { 123.1 } "%01.2f" sprintf = ] unit-test -[ t ] [ " 1.23" [ { 1.23456789 } "%6.2f" sprintf ] call = ] unit-test +[ t ] [ "1.2345" { 1.23456789 } "%.4f" sprintf = ] unit-test -[ t ] [ "1.234e+08" [ { 123400000 } "%e" sprintf ] call = ] unit-test +[ t ] [ " 1.23" { 1.23456789 } "%6.2f" sprintf = ] unit-test -[ t ] [ "1.234567e+08" [ { 123456700 } "%e" sprintf ] call = ] unit-test +[ t ] [ "1.234e+08" { 123400000 } "%e" sprintf = ] unit-test -[ t ] [ "3.625e+08" [ { 362525200 } "%.3e" sprintf ] call = ] unit-test +[ t ] [ "1.234567e+08" { 123456700 } "%e" sprintf = ] unit-test -[ t ] [ "2.5e-03" [ { 0.0025 } "%e" sprintf ] call = ] unit-test +[ t ] [ "3.625e+08" { 362525200 } "%.3e" sprintf = ] unit-test -[ t ] [ "2.5E-03" [ { 0.0025 } "%E" sprintf ] call = ] unit-test +[ t ] [ "2.5e-03" { 0.0025 } "%e" sprintf = ] unit-test -[ t ] [ "ff" [ { HEX: ff } "%x" sprintf ] call = ] unit-test +[ t ] [ "2.5E-03" { 0.0025 } "%E" sprintf = ] unit-test -[ t ] [ "FF" [ { HEX: ff } "%X" sprintf ] call = ] unit-test +[ t ] [ "ff" { HEX: ff } "%x" sprintf = ] unit-test -[ t ] [ "0f" [ { HEX: f } "%02x" sprintf ] call = ] unit-test +[ t ] [ "FF" { HEX: ff } "%X" sprintf = ] unit-test -[ t ] [ "0F" [ { HEX: f } "%02X" sprintf ] call = ] unit-test +[ t ] [ "0f" { HEX: f } "%02x" sprintf = ] unit-test + +[ t ] [ "0F" { HEX: f } "%02X" sprintf = ] unit-test [ t ] [ "2008-09-10" - [ { 2008 9 10 } "%04d-%02d-%02d" sprintf ] call = ] unit-test + { 2008 9 10 } "%04d-%02d-%02d" sprintf = ] unit-test [ t ] [ "Hello, World!" - [ { "Hello, World!" } "%s" sprintf ] call = ] unit-test + { "Hello, World!" } "%s" sprintf = ] unit-test [ t ] [ "printf test" - [ { } "printf test" sprintf ] call = ] unit-test + { } "printf test" sprintf = ] unit-test [ t ] [ "char a = 'a'" - [ { CHAR: a } "char %c = 'a'" sprintf ] call = ] unit-test + { CHAR: a } "char %c = 'a'" sprintf = ] unit-test -[ t ] [ "00" [ { HEX: 0 } "%02x" sprintf ] call = ] unit-test +[ t ] [ "00" { HEX: 0 } "%02x" sprintf = ] unit-test -[ t ] [ "ff" [ { HEX: ff } "%02x" sprintf ] call = ] unit-test +[ t ] [ "ff" { HEX: ff } "%02x" sprintf = ] unit-test [ t ] [ "0 message(s)" - [ { 0 "message" } "%d %s(s)%" sprintf ] call = ] unit-test + { 0 "message" } "%d %s(s)%" sprintf = ] unit-test [ t ] [ "0 message(s) with %" - [ { 0 "message" } "%d %s(s) with %%" sprintf ] call = ] unit-test + { 0 "message" } "%d %s(s) with %%" sprintf = ] unit-test [ t ] [ "justif: \"left \"" - [ { "left" } "justif: \"%-10s\"" sprintf ] call = ] unit-test + { "left" } "justif: \"%-10s\"" sprintf = ] unit-test [ t ] [ "justif: \" right\"" - [ { "right" } "justif: \"%10s\"" sprintf ] call = ] unit-test + { "right" } "justif: \"%10s\"" sprintf = ] unit-test [ t ] [ " 3: 0003 zero padded" - [ { 3 } " 3: %04d zero padded" sprintf ] call = ] unit-test + { 3 } " 3: %04d zero padded" sprintf = ] unit-test [ t ] [ " 3: 3 left justif" - [ { 3 } " 3: %-4d left justif" sprintf ] call = ] unit-test + { 3 } " 3: %-4d left justif" sprintf = ] unit-test [ t ] [ " 3: 3 right justif" - [ { 3 } " 3: %4d right justif" sprintf ] call = ] unit-test + { 3 } " 3: %4d right justif" sprintf = ] unit-test [ t ] [ " -3: -003 zero padded" - [ { -3 } " -3: %04d zero padded" sprintf ] call = ] unit-test + { -3 } " -3: %04d zero padded" sprintf = ] unit-test [ t ] [ " -3: -3 left justif" - [ { -3 } " -3: %-4d left justif" sprintf ] call = ] unit-test + { -3 } " -3: %-4d left justif" sprintf = ] unit-test [ t ] [ " -3: -3 right justif" - [ { -3 } " -3: %4d right justif" sprintf ] call = ] unit-test + { -3 } " -3: %4d right justif" sprintf = ] unit-test [ t ] [ "There are 10 monkeys in the kitchen" - [ { 10 "kitchen" } "There are %d monkeys in the %s" sprintf ] call = ] unit-test + { 10 "kitchen" } "There are %d monkeys in the %s" sprintf = ] unit-test -[ f ] [ "%d" [ { 10 } "%d" sprintf ] call = ] unit-test +[ f ] [ "%d" { 10 } "%d" sprintf = ] unit-test + +[ t ] [ "[monkey]" { "monkey" } "[%s]" sprintf = ] unit-test + +[ t ] [ "[ monkey]" { "monkey" } "[%10s]" sprintf = ] unit-test + +[ t ] [ "[monkey ]" { "monkey" } "[%-10s]" sprintf = ] unit-test + +[ t ] [ "[0000monkey]" { "monkey" } "[%010s]" sprintf = ] unit-test + +[ t ] [ "[####monkey]" { "monkey" } "[%'#10s]" sprintf = ] unit-test + +[ t ] [ "[many monke]" { "many monkeys" } "[%10.10s]" sprintf = ] 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 f46d08adfa..b24e58d6cc 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: io io.encodings.ascii io.files -kernel sequences strings vectors math math.parser macros +USING: io io.encodings.ascii io.files io.streams.string +kernel sequences splitting strings vectors math math.parser macros fry peg.ebnf unicode.case arrays prettyprint quotations ; IN: printf @@ -15,11 +15,8 @@ IN: printf : write-all ( seq -- quot ) [ [ write ] append ] map ; -: append-all ( seq -- string ) - SBUF" " [ dip swap append ] reduce ; - : apply-format ( params quot -- params string ) - [ dup pop ] dip call ; + [ dup pop ] dip call ; inline : fix-neg ( string -- string ) dup CHAR: 0 swap index 0 = @@ -28,14 +25,13 @@ IN: printf [ drop ] if ] when ; : >digits ( string -- digits ) - dup length 0 > [ >string string>number ] [ drop 0 ] if ; + [ 0 ] [ string>number ] if-empty ; -: zero-pad ( string digits -- string ) - swap dup - CHAR: . swap index rot + 1+ - dup rot swap - CHAR: 0 pad-right - swap head-slice ; +: max-digits ( string digits -- string ) + [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ; + +: max-width ( string length -- string ) + [ dup length ] dip [ > ] keep swap [ head-slice >string ] [ drop ] if ; : >exponential ( n -- base exp ) 0 @@ -49,8 +45,6 @@ IN: printf [ 0 < [ "-" ] [ "+" ] if ] dip append "e" prepend ; -PRIVATE> - EBNF: parse-format-string plain-text = (!("%").)+ => [[ >string 1quotation ]] @@ -62,31 +56,31 @@ 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 ]] +pad = pad-align pad-char_ pad-width => [[ reverse compose-all ]] -width = "." ([0-9])* => [[ second >digits '[ _ head-slice ] ]] +width = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] width_ = (width)? => [[ [ ] or ]] -digits = "." ([0-9])* => [[ second >digits '[ _ zero-pad ] ]] +digits = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]] digits_ = (digits)? => [[ [ ] or ]] fmt-c = "c" => [[ [ 1string ] ]] fmt-C = "C" => [[ [ 1string >upper ] ]] -chars = (fmt-c|fmt-C) => [[ '[ _ apply-format ] ]] +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 ] ]] +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 ]] +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 ]] +floats = digits_ fmt-f => [[ reverse compose-all ]] fmt-x = "x" => [[ [ >hex ] ]] fmt-X = "X" => [[ [ >hex >upper ] ]] @@ -96,21 +90,18 @@ numbers = (pad) (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg formats = "%" (chars|strings|numbers|percents) => [[ second ]] -text = (formats|plain-text)* +text = (formats|plain-text)* => [[ write-all compose-all ]] ;EBNF +PRIVATE> + 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 ] ; + parse-format-string '[ reverse >vector @ drop ] ; +: sprintf ( params format-string -- result ) + [ printf ] with-string-writer ; +: fprintf ( filename params format-string -- ) + rot ascii [ printf ] with-file-appender ; From 53197ddb1b03ddc1564e6922bde4aac42ca47971 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 17 Sep 2008 10:59:44 -0700 Subject: [PATCH 029/289] Adding more docs for printf. --- extra/printf/printf-docs.factor | 37 +++++++++++++++++++++++++-------- 1 file changed, 28 insertions(+), 9 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index c1638f0d23..21981b8b4a 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -6,20 +6,35 @@ IN: printf HELP: printf { $values { "format-string" string } } { $description - "Writes the arguments formatted according to the format string." + "Writes the arguments formatted according to the format string.\n" { $table { "%%" "Single %" "" } - { "%Wd" "Integer W digits wide (e.g., \"1234\")" "fixnum" } - { "%W.De" "Scientific notation" "fixnum, float" } - { "%W.DE" "Scientific notation" "fixnum, float" } - { "%W.Df" "Fixed format" "fixnum, float" } - { "%Wx" "Hexadecimal" "hex" } - { "%WX" "Hexadecimal uppercase" "hex" } - { "%W.Ds" "String format" "string" } - { "%W.DS" "String format uppercase" "string" } + { "%Pd" "Integer format" "fixnum" } + { "%P.De" "Scientific notation" "fixnum, float" } + { "%P.DE" "Scientific notation" "fixnum, float" } + { "%P.Df" "Fixed format" "fixnum, float" } + { "%Px" "Hexadecimal" "hex" } + { "%PX" "Hexadecimal uppercase" "hex" } + { "%P.Ds" "String format" "string" } + { "%P.DS" "String format uppercase" "string" } { "%c" "Character format" "char" } { "%C" "Character format uppercase" "char" } } + "\n" + "Padding ('P') is used to specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" + { $list + "\"%5s\" formats a string padding with spaces up to 5 characters wide." + "\"%08d\" formats an integer padding with zeros up to 3 characters wide." + "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." + "\"%-10d\" formats an integer to 10 characters wide and left-aligns." + } + "\n" + "Digits ('D') is used to specify the maximum digits in the result string. For example:\n" + { $list + "\"%.3s\" formats a string to truncate at 3 characters (from the left)." + "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." + "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." + } } { $examples { $example @@ -38,6 +53,10 @@ HELP: printf "USING: printf ;" "{ 1234567890 } \"%.5e\" printf" "1.23456e+09" } + { $example + "USING: printf ;" + "{ 12 } \"%'#4d\" printf" + "##12" } } ; HELP: sprintf From 0f2118cf38c39e85494d92e9fc013e6f9315d0b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 17 Sep 2008 19:31:35 -0500 Subject: [PATCH 030/289] Count integer and float spills separately, build stack frame after register allocation since spilling requires a stack frame --- unfinished/compiler/cfg/cfg.factor | 8 ++- .../cfg/instructions/instructions.factor | 11 ++-- .../linear-scan/allocation/allocation.factor | 17 +++--- .../linear-scan/assignment/assignment.factor | 18 +++++- .../cfg/linear-scan/linear-scan.factor | 13 ++-- .../live-intervals/live-intervals.factor | 5 +- .../cfg/linearization/linearization.factor | 24 +------- .../cfg/stack-frame/stack-frame.factor | 59 +++++++++++++++++++ unfinished/compiler/codegen/codegen.factor | 4 +- unfinished/compiler/new/new.factor | 10 +++- 10 files changed, 118 insertions(+), 51 deletions(-) create mode 100644 unfinished/compiler/cfg/stack-frame/stack-frame.factor diff --git a/unfinished/compiler/cfg/cfg.factor b/unfinished/compiler/cfg/cfg.factor index 54b991bff1..140d406c4c 100644 --- a/unfinished/compiler/cfg/cfg.factor +++ b/unfinished/compiler/cfg/cfg.factor @@ -19,6 +19,10 @@ successors ; V{ } clone >>instructions V{ } clone >>successors ; -TUPLE: mr instructions word label ; +TUPLE: mr instructions word label frame-size spill-counts ; -C: mr +: ( instructions word label -- mr ) + mr new + swap >>label + swap >>word + swap >>instructions ; diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor index 415f964acf..9bb576dcb3 100644 --- a/unfinished/compiler/cfg/instructions/instructions.factor +++ b/unfinished/compiler/cfg/instructions/instructions.factor @@ -100,8 +100,8 @@ M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ; M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ; ! Instructions used by machine IR only. -INSN: _prologue n ; -INSN: _epilogue n ; +INSN: _prologue ; +INSN: _epilogue ; INSN: _label id ; @@ -117,5 +117,8 @@ M: _cond-branch uses-vregs src>> >vreg 1array ; M: _if-intrinsic defs-vregs intrinsic-defs-vregs ; M: _if-intrinsic uses-vregs intrinsic-uses-vregs ; -INSN: _spill src n ; -INSN: _reload dst n ; +INSN: _spill-integer src n ; +INSN: _reload-integer dst n ; + +INSN: _spill-float src n ; +INSN: _reload-float dst n ; diff --git a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor index 0bfcc8bcd0..4a9646c88a 100644 --- a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences math math.order kernel assocs accessors vectors fry heaps +compiler.cfg.registers compiler.cfg.linear-scan.live-intervals compiler.backend ; IN: compiler.cfg.linear-scan.allocation @@ -68,10 +69,10 @@ SYMBOL: progress [ peek >>reg drop ] [ pop >>reg add-active ] if ; ! Spilling -SYMBOL: spill-counter +SYMBOL: spill-counts -: next-spill-location ( -- n ) - spill-counter [ dup 1+ ] change ; +: next-spill-location ( reg-class -- n ) + spill-counts get [ dup 1+ ] change-at ; : interval-to-spill ( -- live-interval ) #! We spill the interval with the most distant use location. @@ -141,7 +142,7 @@ SYMBOL: spill-counter V{ } clone active-intervals set unhandled-intervals set [ reverse >vector ] assoc-map free-registers set - 0 spill-counter set + H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set -1 progress set ; : handle-interval ( live-interval -- ) @@ -152,8 +153,6 @@ SYMBOL: spill-counter : allocate-registers ( live-intervals machine-registers -- live-intervals ) #! This modifies the input live-intervals. - [ - init-allocator - dup init-unhandled - (allocate-registers) - ] with-scope ; + init-allocator + dup init-unhandled + (allocate-registers) ; diff --git a/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor b/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor index 8b53ee9531..ffe8e6b687 100644 --- a/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math assocs namespaces sequences heaps -fry make +fry make combinators compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ; @@ -34,7 +34,13 @@ SYMBOL: unhandled-intervals [ add-unhandled ] each ; : insert-spill ( live-interval -- ) - [ reg>> ] [ spill-to>> ] bi dup [ _spill ] [ 2drop ] if ; + [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri + over [ + { + { int-regs [ _spill-integer ] } + { double-float-regs [ _spill-float ] } + } case + ] [ 3drop ] if ; : expire-old-intervals ( n -- ) active-intervals get @@ -43,7 +49,13 @@ SYMBOL: unhandled-intervals [ insert-spill ] each ; : insert-reload ( live-interval -- ) - [ reg>> ] [ reload-from>> ] bi dup [ _reload ] [ 2drop ] if ; + [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri + over [ + { + { int-regs [ _reload-integer ] } + { double-float-regs [ _reload-float ] } + } case + ] [ 3drop ] if ; : activate-new-intervals ( n -- ) #! Any live intervals which start on the current instruction diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan.factor b/unfinished/compiler/cfg/linear-scan/linear-scan.factor index 80737badc3..f62e3a39d1 100644 --- a/unfinished/compiler/cfg/linear-scan/linear-scan.factor +++ b/unfinished/compiler/cfg/linear-scan/linear-scan.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors +USING: kernel accessors namespaces compiler.backend compiler.cfg compiler.cfg.linear-scan.live-intervals @@ -24,7 +24,10 @@ IN: compiler.cfg.linear-scan : linear-scan ( mr -- mr' ) [ - dup compute-live-intervals - machine-registers allocate-registers - assign-registers - ] change-instructions ; + [ + dup compute-live-intervals + machine-registers allocate-registers + assign-registers + ] change-instructions + spill-counts get >>spill-counts + ] with-scope ; 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 d6ee979fe5..a0699b80bd 100644 --- a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -43,7 +43,6 @@ SYMBOL: live-intervals : compute-live-intervals ( instructions -- live-intervals ) H{ } clone [ - live-intervals [ - [ compute-live-intervals* ] each-index - ] with-variable + live-intervals set + [ compute-live-intervals* ] each-index ] keep finalize-live-intervals ; diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/unfinished/compiler/cfg/linearization/linearization.factor index fd21b5d3b6..24730cd17f 100644 --- a/unfinished/compiler/cfg/linearization/linearization.factor +++ b/unfinished/compiler/cfg/linearization/linearization.factor @@ -9,13 +9,6 @@ compiler.cfg.instructions.syntax ; IN: compiler.cfg.linearization ! Convert CFG IR to machine IR. -SYMBOL: frame-size - -: compute-frame-size ( rpo -- ) - [ instructions>> [ ##frame-required? ] filter ] map concat - [ f ] [ [ n>> ] map supremum ] if-empty - frame-size set ; - GENERIC: linearize-insn ( basic-block insn -- ) : linearize-insns ( basic-block -- ) @@ -23,14 +16,6 @@ GENERIC: linearize-insn ( basic-block insn -- ) M: insn linearize-insn , drop ; -M: ##frame-required linearize-insn 2drop ; - -M: ##prologue linearize-insn - 2drop frame-size get [ _prologue ] when* ; - -M: ##epilogue linearize-insn - 2drop frame-size get [ _epilogue ] when* ; - : useless-branch? ( basic-block successor -- ? ) #! If our successor immediately follows us in RPO, then we #! don't need to branch. @@ -78,9 +63,6 @@ M: ##if-intrinsic linearize-insn [ [ linearize-basic-block ] each ] { } make ; : build-mr ( cfg -- mr ) - [ - entry>> reverse-post-order [ - [ compute-frame-size ] - [ linearize-basic-blocks ] bi - ] with-scope - ] [ word>> ] [ label>> ] tri ; + [ entry>> reverse-post-order linearize-basic-blocks ] + [ word>> ] [ label>> ] + tri ; diff --git a/unfinished/compiler/cfg/stack-frame/stack-frame.factor b/unfinished/compiler/cfg/stack-frame/stack-frame.factor new file mode 100644 index 0000000000..56282cfb09 --- /dev/null +++ b/unfinished/compiler/cfg/stack-frame/stack-frame.factor @@ -0,0 +1,59 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces accessors math.order assocs kernel sequences +make compiler.cfg.instructions compiler.cfg.instructions.syntax +compiler.cfg.registers ; +IN: compiler.cfg.stack-frame + +SYMBOL: frame-required? + +SYMBOL: frame-size + +SYMBOL: spill-counts + +: init-stack-frame-builder ( -- ) + frame-required? off + 0 frame-size set ; + +GENERIC: compute-frame-size* ( insn -- ) + +M: ##frame-required compute-frame-size* + frame-required? on + n>> frame-size [ max ] change ; + +M: _spill-integer compute-frame-size* + drop frame-required? on ; + +M: _spill-float compute-frame-size* + drop frame-required? on ; + +M: insn compute-frame-size* drop ; + +: compute-frame-size ( insns -- ) + [ compute-frame-size* ] each ; + +GENERIC: insert-pro/epilogues* ( insn -- ) + +M: ##frame-required insert-pro/epilogues* drop ; + +M: ##prologue insert-pro/epilogues* + drop frame-required? get [ _prologue ] when ; + +M: ##epilogue insert-pro/epilogues* + drop frame-required? get [ _epilogue ] when ; + +M: insn insert-pro/epilogues* , ; + +: insert-pro/epilogues ( insns -- insns ) + [ [ insert-pro/epilogues* ] each ] { } make ; + +: build-stack-frame ( mr -- mr ) + [ + init-stack-frame-builder + [ + [ compute-frame-size ] + [ insert-pro/epilogues ] + bi + ] change-instructions + frame-size get >>frame-size + ] with-scope ; diff --git a/unfinished/compiler/codegen/codegen.factor b/unfinished/compiler/codegen/codegen.factor index 9ed7b3132f..15ebd691bf 100644 --- a/unfinished/compiler/codegen/codegen.factor +++ b/unfinished/compiler/codegen/codegen.factor @@ -71,10 +71,10 @@ M: _label generate-insn id>> lookup-label , ; M: _prologue generate-insn - n>> %prologue ; + drop %prologue ; M: _epilogue generate-insn - n>> %epilogue ; + drop %epilogue ; M: ##load-literal generate-insn [ obj>> ] [ dst>> v>operand ] bi load-literal ; diff --git a/unfinished/compiler/new/new.factor b/unfinished/compiler/new/new.factor index 9b640b8d84..fd402916a0 100644 --- a/unfinished/compiler/new/new.factor +++ b/unfinished/compiler/new/new.factor @@ -7,7 +7,7 @@ stack-checker stack-checker.state stack-checker.inlining compiler.errors compiler.units compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.linearization compiler.cfg.linear-scan -compiler.codegen ; +compiler.cfg.stack-frame compiler.codegen ; IN: compiler.new SYMBOL: compile-queue @@ -79,7 +79,13 @@ SYMBOL: +failed+ bi ; : backend ( nodes word -- ) - build-cfg [ build-mr linear-scan generate save-asm ] each ; + build-cfg [ + build-mr + linear-scan + build-stack-frame + generate + save-asm + ] each ; : (compile) ( word -- ) '[ From 5885a924fc2cce6bfb8bd9f9b0c031cc37bdfe94 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 17 Sep 2008 19:59:22 -0700 Subject: [PATCH 031/289] Changing printf to use arguments from the stack. --- extra/printf/printf-docs.factor | 10 ++--- extra/printf/printf-tests.factor | 76 ++++++++++++++++---------------- extra/printf/printf.factor | 60 ++++++++++--------------- 3 files changed, 67 insertions(+), 79 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index 21981b8b4a..ca26337026 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -39,23 +39,23 @@ HELP: printf { $examples { $example "USING: printf ;" - "{ 123 } \"%05d\" printf" + "123 \"%05d\" printf" "00123" } { $example "USING: printf ;" - "{ HEX: ff } \"04X\" printf" + "HEX: ff \"04X\" printf" "00FF" } { $example "USING: printf ;" - "{ 1.23456789 } \"%.3f\" printf" + "1.23456789 \"%.3f\" printf" "1.234" } { $example "USING: printf ;" - "{ 1234567890 } \"%.5e\" printf" + "1234567890 \"%.5e\" printf" "1.23456e+09" } { $example "USING: printf ;" - "{ 12 } \"%'#4d\" printf" + "12 \"%'#4d\" printf" "##12" } } ; diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 7d89b35ae9..9a608cbffc 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -5,96 +5,96 @@ USING: kernel printf tools.test ; [ "%s" printf ] must-infer -[ t ] [ "10" { 10 } "%d" sprintf = ] unit-test +[ t ] [ "10" 10 "%d" sprintf = ] unit-test -[ t ] [ "123.456" { 123.456 } "%f" sprintf = ] unit-test +[ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test -[ t ] [ "123.10" { 123.1 } "%01.2f" sprintf = ] unit-test +[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test -[ t ] [ "1.2345" { 1.23456789 } "%.4f" sprintf = ] unit-test +[ t ] [ "1.2345" 1.23456789 "%.4f" sprintf = ] unit-test -[ t ] [ " 1.23" { 1.23456789 } "%6.2f" sprintf = ] unit-test +[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test -[ t ] [ "1.234e+08" { 123400000 } "%e" sprintf = ] unit-test +[ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test -[ t ] [ "1.234567e+08" { 123456700 } "%e" sprintf = ] unit-test +[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test -[ t ] [ "3.625e+08" { 362525200 } "%.3e" sprintf = ] unit-test +[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test -[ t ] [ "2.5e-03" { 0.0025 } "%e" sprintf = ] unit-test +[ t ] [ "2.5e-03" 0.0025 "%e" sprintf = ] unit-test -[ t ] [ "2.5E-03" { 0.0025 } "%E" sprintf = ] unit-test +[ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test -[ t ] [ "ff" { HEX: ff } "%x" sprintf = ] unit-test +[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test -[ t ] [ "FF" { HEX: ff } "%X" sprintf = ] unit-test +[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test -[ t ] [ "0f" { HEX: f } "%02x" sprintf = ] unit-test +[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test -[ t ] [ "0F" { HEX: f } "%02X" sprintf = ] unit-test +[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test [ t ] [ "2008-09-10" - { 2008 9 10 } "%04d-%02d-%02d" sprintf = ] unit-test + 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test [ t ] [ "Hello, World!" - { "Hello, World!" } "%s" sprintf = ] unit-test + "Hello, World!" "%s" sprintf = ] unit-test [ t ] [ "printf test" - { } "printf test" sprintf = ] unit-test + "printf test" sprintf = ] unit-test [ t ] [ "char a = 'a'" - { CHAR: a } "char %c = 'a'" sprintf = ] unit-test + CHAR: a "char %c = 'a'" sprintf = ] unit-test -[ t ] [ "00" { HEX: 0 } "%02x" sprintf = ] unit-test +[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test -[ t ] [ "ff" { HEX: ff } "%02x" sprintf = ] unit-test +[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test [ t ] [ "0 message(s)" - { 0 "message" } "%d %s(s)%" sprintf = ] unit-test + 0 "message" "%d %s(s)" sprintf = ] unit-test [ t ] [ "0 message(s) with %" - { 0 "message" } "%d %s(s) with %%" sprintf = ] unit-test + 0 "message" "%d %s(s) with %%" sprintf = ] unit-test [ t ] [ "justif: \"left \"" - { "left" } "justif: \"%-10s\"" sprintf = ] unit-test + "left" "justif: \"%-10s\"" sprintf = ] unit-test [ t ] [ "justif: \" right\"" - { "right" } "justif: \"%10s\"" sprintf = ] unit-test + "right" "justif: \"%10s\"" sprintf = ] unit-test [ t ] [ " 3: 0003 zero padded" - { 3 } " 3: %04d zero padded" sprintf = ] unit-test + 3 " 3: %04d zero padded" sprintf = ] unit-test [ t ] [ " 3: 3 left justif" - { 3 } " 3: %-4d left justif" sprintf = ] unit-test + 3 " 3: %-4d left justif" sprintf = ] unit-test [ t ] [ " 3: 3 right justif" - { 3 } " 3: %4d right justif" sprintf = ] unit-test + 3 " 3: %4d right justif" sprintf = ] unit-test [ t ] [ " -3: -003 zero padded" - { -3 } " -3: %04d zero padded" sprintf = ] unit-test + -3 " -3: %04d zero padded" sprintf = ] unit-test [ t ] [ " -3: -3 left justif" - { -3 } " -3: %-4d left justif" sprintf = ] unit-test + -3 " -3: %-4d left justif" sprintf = ] unit-test [ t ] [ " -3: -3 right justif" - { -3 } " -3: %4d right justif" sprintf = ] unit-test + -3 " -3: %4d right justif" sprintf = ] unit-test [ t ] [ "There are 10 monkeys in the kitchen" - { 10 "kitchen" } "There are %d monkeys in the %s" sprintf = ] unit-test + 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test -[ f ] [ "%d" { 10 } "%d" sprintf = ] unit-test +[ f ] [ "%d" 10 "%d" sprintf = ] unit-test -[ t ] [ "[monkey]" { "monkey" } "[%s]" sprintf = ] unit-test +[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test -[ t ] [ "[ monkey]" { "monkey" } "[%10s]" sprintf = ] unit-test +[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test -[ t ] [ "[monkey ]" { "monkey" } "[%-10s]" sprintf = ] unit-test +[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test -[ t ] [ "[0000monkey]" { "monkey" } "[%010s]" sprintf = ] unit-test +[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test -[ t ] [ "[####monkey]" { "monkey" } "[%'#10s]" sprintf = ] unit-test +[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test -[ t ] [ "[many monke]" { "many monkeys" } "[%10.10s]" sprintf = ] unit-test +[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index b24e58d6cc..4c66db3661 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license USING: io io.encodings.ascii io.files io.streams.string -kernel sequences splitting strings vectors math math.parser macros -fry peg.ebnf unicode.case arrays prettyprint quotations ; +kernel sequences splitting strings math math.parser macros +fry peg.ebnf unicode.case arrays quotations vectors ; IN: printf @@ -12,12 +12,6 @@ IN: printf : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; -: write-all ( seq -- quot ) - [ [ write ] append ] map ; - -: apply-format ( params quot -- params string ) - [ dup pop ] dip call ; inline - : fix-neg ( string -- string ) dup CHAR: 0 swap index 0 = [ dup CHAR: - swap index dup @@ -47,61 +41,55 @@ IN: printf EBNF: parse-format-string -plain-text = (!("%").)+ => [[ >string 1quotation ]] +zero = "0" => [[ CHAR: 0 ]] +char = "'" (.) => [[ second ]] -percents = "%" => [[ '[ "%" ] ]] - -pad-zero = "0" => [[ CHAR: 0 ]] -pad-char = "'" (.) => [[ second ]] -pad-char_ = (pad-zero|pad-char)? => [[ CHAR: \s or 1quotation ]] +pad-char = (zero|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 ]] +pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]] -width = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] -width_ = (width)? => [[ [ ] or ]] +width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] +width = (width_)? => [[ [ ] or ]] -digits = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]] -digits_ = (digits)? => [[ [ ] or ]] +digits_ = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]] +digits = (digits_)? => [[ [ ] or ]] +fmt-% = "%" => [[ [ "%" ] ]] 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 ] ]] +unknown = (.)* => [[ "Unknown directive" throw ]] + +chars = fmt-c | fmt-C +strings = pad width (fmt-s|fmt-S) => [[ reverse compose-all ]] +decimals = fmt-d +exps = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] +floats = digits fmt-f => [[ reverse compose-all ]] hex = fmt-x | fmt-X +numbers = pad (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append ]] -numbers = (pad) (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append '[ _ apply-format ] ]] +formats = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]] -formats = "%" (chars|strings|numbers|percents) => [[ second ]] +plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] -text = (formats|plain-text)* => [[ write-all compose-all ]] +text = (formats|plain-text)* => [[ reverse [ [ dup [ push ] dip ] append ] map ]] ;EBNF PRIVATE> MACRO: printf ( format-string -- ) - parse-format-string '[ reverse >vector @ drop ] ; + parse-format-string [ length ] keep compose-all '[ _ @ reverse [ write ] each ] ; -: sprintf ( params format-string -- result ) +: sprintf ( format-string -- ) [ printf ] with-string-writer ; -: fprintf ( filename params format-string -- ) - rot ascii [ printf ] with-file-appender ; From 1a865f89ac487ebce50d4236ecd67c6b3bd5677c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 17 Sep 2008 22:18:08 -0500 Subject: [PATCH 032/289] Some optimizer change sfores for new codegen --- basis/compiler/intrinsics/intrinsics.factor | 34 +++++++++++++++---- .../tree/propagation/info/info.factor | 6 ++++ core/layouts/layouts.factor | 4 ++- 3 files changed, 37 insertions(+), 7 deletions(-) diff --git a/basis/compiler/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor index b995e6d737..471c05ee59 100644 --- a/basis/compiler/intrinsics/intrinsics.factor +++ b/basis/compiler/intrinsics/intrinsics.factor @@ -4,20 +4,42 @@ USING: kernel classes.tuple classes.tuple.private math arrays byte-arrays words stack-checker.known-words ; IN: compiler.intrinsics -: (tuple) ( layout -- tuple ) - "BUG: missing (tuple) intrinsic" throw ; +ERROR: missing-intrinsic ; + +: (tuple) ( n -- tuple ) missing-intrinsic ; \ (tuple) { tuple-layout } { tuple } define-primitive \ (tuple) make-flushable -: (array) ( n -- array ) - "BUG: missing (array) intrinsic" throw ; +: (array) ( n -- array ) missing-intrinsic ; \ (array) { integer } { array } define-primitive \ (array) make-flushable -: (byte-array) ( n -- byte-array ) - "BUG: missing (byte-array) intrinsic" throw ; +: (byte-array) ( n -- byte-array ) missing-intrinsic ; \ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable + +: (ratio) ( -- ratio ) missing-intrinsic ; + +\ (ratio) { } { ratio } define-primitive +\ (ratio) make-flushable + +: (complex) ( -- complex ) missing-intrinsic ; + +\ (complex) { } { complex } define-primitive +\ (complex) make-flushable + +: (wrapper) ( -- wrapper ) missing-intrinsic ; + +\ (wrapper) { } { wrapper } define-primitive +\ (wrapper) make-flushable + +: (set-slot) ( val obj n -- ) missing-intrinsic ; + +\ (set-slot) { object object fixnum } { } define-primitive + +: (write-barrier) ( obj -- ) missing-intrinsic ; + +\ (write-barrier) { object } { } define-primitive diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 0891a6629c..5f8de4eb49 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -298,6 +298,12 @@ SYMBOL: value-infos : node-output-infos ( node -- seq ) dup out-d>> [ node-value-info ] with map ; +: first-literal ( #call -- obj ) + dup in-d>> first node-value-info literal>> ; + +: last-literal ( #call -- obj ) + dup out-d>> peek node-value-info literal>> ; + : immutable-tuple-boa? ( #call -- ? ) dup word>> \ eq? [ dup in-d>> peek node-value-info diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 4788af1a91..6bd5367528 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel assocs classes math.order kernel.private ; @@ -74,3 +74,5 @@ M: bignum >integer M: real >integer dup most-negative-fixnum most-positive-fixnum between? [ >fixnum ] [ >bignum ] if ; + +UNION: immediate fixnum POSTPONE: f ; From 3a83c1e895c76e72f66bfe760bd404fe7002d95f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 17 Sep 2008 22:40:51 -0500 Subject: [PATCH 033/289] Improve resource-path behavior on NetBSD and OpenBSD --- core/io/files/files.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index e52799d10a..6a04410559 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -192,11 +192,15 @@ PRIVATE> SYMBOL: current-directory -[ cwd current-directory set-global ] "io.files" add-init-hook +[ + cwd current-directory set-global + image parent-directory "./" ?head + [ cwd prepend-path ] when + "resource-path" set +] "io.files" add-init-hook : resource-path ( path -- newpath ) - "resource-path" get [ image parent-directory ] unless* - prepend-path ; + "resource-path" get prepend-path ; : (normalize-path) ( path -- path' ) "resource:" ?head [ From 34faf1f78609c0831276bb755629a21727d0b0c8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 17 Sep 2008 23:28:54 -0500 Subject: [PATCH 034/289] Fix cache polution issue --- basis/bootstrap/image/image.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 9284728a7a..f18232b7c4 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -412,14 +412,14 @@ M: quotation ' all-words [ emit-word ] each ; : emit-global ( -- ) - [ - { - dictionary source-files builtins - update-map implementors-map class<=-cache - class-not-cache classes-intersect-cache class-and-cache - class-or-cache - } [ dup get swap bootstrap-word set ] each - ] H{ } make-assoc + { + dictionary source-files builtins + update-map implementors-map + } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc + { + class<=-cache class-not-cache classes-intersect-cache + class-and-cache class-or-cache + } [ H{ } clone ] H{ } map>assoc assoc-union bootstrap-global set bootstrap-global emit-userenv ; From 562118e158bb33f2c848a8777c2d48d60ba8c12d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 18 Sep 2008 00:20:51 -0500 Subject: [PATCH 035/289] Better fix for *BSD resource path --- basis/bootstrap/image/image.factor | 1 - core/io/files/files.factor | 4 +--- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index f18232b7c4..f3f570b462 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -26,7 +26,6 @@ IN: bootstrap.image "x86.32" "x86.64" "linux-ppc" "macosx-ppc" - ! "arm" } ; Date: Wed, 17 Sep 2008 23:11:02 -0700 Subject: [PATCH 036/289] printf: Allow positive sign to prefix numbers, add more tests, fix negative numbers in exponentials. --- extra/printf/printf-tests.factor | 24 ++++++++++++++++++++++++ extra/printf/printf.factor | 30 ++++++++++++++++++++---------- 2 files changed, 44 insertions(+), 10 deletions(-) diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 9a608cbffc..084553c54d 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -7,6 +7,16 @@ USING: kernel printf tools.test ; [ t ] [ "10" 10 "%d" sprintf = ] unit-test +[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test + +[ t ] [ "-10" -10 "%d" sprintf = ] unit-test + +[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test + +[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test + +[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test + [ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test [ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test @@ -17,6 +27,8 @@ USING: kernel printf tools.test ; [ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test +[ t ] [ "-1.234e+08" -123400000 "%e" sprintf = ] unit-test + [ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test [ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test @@ -25,6 +37,18 @@ USING: kernel printf tools.test ; [ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test +[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test + +[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test + +[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test + +[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test + +[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test + +[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test + [ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test [ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 4c66db3661..346a344093 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: io io.encodings.ascii io.files io.streams.string +USING: io io.encodings.ascii io.files io.streams.string combinators kernel sequences splitting strings math math.parser macros -fry peg.ebnf unicode.case arrays quotations vectors ; +fry peg.ebnf ascii unicode.case arrays quotations vectors ; IN: printf @@ -12,11 +12,17 @@ IN: printf : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; -: fix-neg ( string -- string ) +: fix-sign ( string -- string ) dup CHAR: 0 swap index 0 = - [ dup CHAR: - swap index dup - [ swap remove-nth "-" prepend ] - [ drop ] if ] when ; + [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from + [ dup 1- rot dup [ nth ] dip swap + { + { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] } + { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] } + [ drop swap drop ] + } case + ] [ drop ] if + ] when ; : >digits ( string -- digits ) [ 0 ] [ string>number ] if-empty ; @@ -28,16 +34,18 @@ IN: printf [ dup length ] dip [ > ] keep swap [ head-slice >string ] [ drop ] if ; : >exponential ( n -- base exp ) + [ 0 < ] keep abs 0 - [ swap dup [ 10.0 > ] keep 1.0 < or ] - [ dup 10.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 ; + "e" prepend + rot [ [ "-" prepend ] dip ] when ; EBNF: parse-format-string @@ -49,6 +57,8 @@ pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] pad-width = ([0-9])* => [[ >digits 1quotation ]] pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]] +sign = ("+")? => [[ [ [ dup CHAR: - swap index not [ "+" prepend ] when ] ] [ [ ] ] if ]] + width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] width = (width_)? => [[ [ ] or ]] @@ -74,7 +84,7 @@ decimals = fmt-d exps = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]] floats = digits fmt-f => [[ reverse compose-all ]] hex = fmt-x | fmt-X -numbers = pad (decimals|floats|hex|exps) => [[ reverse compose-all [ fix-neg ] append ]] +numbers = sign pad (decimals|floats|hex|exps) => [[ reverse first3 swap 3append [ fix-sign ] append ]] formats = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]] From 37aaaf141683be563578cd64d03b69b4e9b87ee8 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 18 Sep 2008 12:26:26 -0700 Subject: [PATCH 037/289] Updated printf docs. --- extra/printf/printf-docs.factor | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index ca26337026..5025fa421f 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -9,19 +9,21 @@ HELP: printf "Writes the arguments formatted according to the format string.\n" { $table { "%%" "Single %" "" } - { "%Pd" "Integer format" "fixnum" } - { "%P.De" "Scientific notation" "fixnum, float" } - { "%P.DE" "Scientific notation" "fixnum, float" } - { "%P.Df" "Fixed format" "fixnum, float" } - { "%Px" "Hexadecimal" "hex" } - { "%PX" "Hexadecimal uppercase" "hex" } { "%P.Ds" "String format" "string" } { "%P.DS" "String format uppercase" "string" } { "%c" "Character format" "char" } { "%C" "Character format uppercase" "char" } + { "%+Pd" "Integer format" "fixnum" } + { "%+P.De" "Scientific notation" "fixnum, float" } + { "%+P.DE" "Scientific notation" "fixnum, float" } + { "%+P.Df" "Fixed format" "fixnum, float" } + { "%+Px" "Hexadecimal" "hex" } + { "%+PX" "Hexadecimal uppercase" "hex" } } "\n" - "Padding ('P') is used to specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" + "A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." + "\n" + "Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" { $list "\"%5s\" formats a string padding with spaces up to 5 characters wide." "\"%08d\" formats an integer padding with zeros up to 3 characters wide." @@ -29,7 +31,7 @@ HELP: printf "\"%-10d\" formats an integer to 10 characters wide and left-aligns." } "\n" - "Digits ('D') is used to specify the maximum digits in the result string. For example:\n" + "Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n" { $list "\"%.3s\" formats a string to truncate at 3 characters (from the left)." "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." @@ -57,6 +59,10 @@ HELP: printf "USING: printf ;" "12 \"%'#4d\" printf" "##12" } + { $example + "USING: printf ;" + "1234 \"%+d\" printf" + "+1234" } } ; HELP: sprintf From edc1a27fcd77525aef0591820b3052c2d03343ed Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 18 Sep 2008 15:18:32 -0700 Subject: [PATCH 038/289] Adding a summary for printf. --- extra/printf/summary.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/printf/summary.txt diff --git a/extra/printf/summary.txt b/extra/printf/summary.txt new file mode 100644 index 0000000000..da1aa31abb --- /dev/null +++ b/extra/printf/summary.txt @@ -0,0 +1 @@ +Format data according to a specified format string, and writes (or returns) the result string. From 7155e422517885a7a271256fd989c158ca467de3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 03:10:44 -0500 Subject: [PATCH 039/289] Better error messages --- basis/io/launcher/launcher.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index cc48ace60b..72535053eb 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -99,7 +99,7 @@ M: process hashcode* handle>> hashcode* ; GENERIC: >process ( obj -- process ) -ERROR: process-already-started ; +ERROR: process-already-started process ; M: process-already-started summary drop "Process has already been started once" ; @@ -116,7 +116,7 @@ HOOK: current-process-handle io-backend ( -- handle ) HOOK: run-process* io-backend ( process -- handle ) -ERROR: process-was-killed ; +ERROR: process-was-killed process ; : wait-for-process ( process -- status ) [ From 0a8980d37e649f990ea88daf098d05bdd4ffda08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 03:14:11 -0500 Subject: [PATCH 040/289] Better error messages in io.launcher --- basis/io/launcher/launcher.factor | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 72535053eb..7f1a3f4507 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -101,8 +101,10 @@ GENERIC: >process ( obj -- process ) ERROR: process-already-started process ; -M: process-already-started summary - drop "Process has already been started once" ; +M: process-already-started error. + "Process has already been started" print nl + "Launch descriptor:" print nl + process>> . ; M: process >process dup process-started? [ @@ -118,6 +120,13 @@ HOOK: run-process* io-backend ( process -- handle ) ERROR: process-was-killed process ; +M: process-was-killed error. + "Process was killed as a result of a call to" print + "kill-process, or a timeout" print + nl + "Launch descriptor:" print nl + process>> . ; + : wait-for-process ( process -- status ) [ dup handle>> From 005cdd4d3a6db484417fbeb3ff6f00e37c7949dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 11:22:40 -0500 Subject: [PATCH 041/289] tweaking hello-world deploy --- extra/hello-world/deploy.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 403cb4737e..c683ef6e06 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-props? f } - { deploy-random? f } - { deploy-compiler? f } { deploy-c-types? f } - { deploy-ui? f } - { deploy-reflection 1 } - { deploy-threads? f } - { deploy-io 2 } - { deploy-word-defs? f } - { "stop-after-last-window?" t } { deploy-name "Hello world (console)" } + { deploy-threads? f } + { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-random? f } + { deploy-io 2 } { deploy-math? f } + { deploy-ui? f } + { deploy-compiler? f } + { "stop-after-last-window?" t } + { deploy-word-defs? f } } From be4915ee9c6b91d8e7878a8f5af4821a36d7e0f4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 14:44:58 -0500 Subject: [PATCH 042/289] Fix save-image-and-exit bug --- core/memory/memory-tests.factor | 3 ++- vm/image.c | 9 ++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 9fded3eb3a..1c23e700ca 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,4 +1,4 @@ -USING: generic kernel kernel.private math memory prettyprint +USING: generic kernel kernel.private math memory prettyprint io sequences tools.test words namespaces layouts classes classes.builtin arrays quotations ; IN: memory.tests @@ -19,6 +19,7 @@ TUPLE: testing x y z ; [ ] [ num-types get [ type>class [ + dup . flush "predicate" word-prop instances [ class drop ] each diff --git a/vm/image.c b/vm/image.c index a668cb7913..62f9e1c906 100755 --- a/vm/image.c +++ b/vm/image.c @@ -186,13 +186,16 @@ void strip_compiled_quotations(void) DEFINE_PRIMITIVE(save_image_and_exit) { - /* This reduces deployed image size */ - strip_compiled_quotations(); - + /* We unbox this before doing anything else. This is the only point + where we might throw an error, so we have to throw an error here since + later steps destroy the current image. */ F_CHAR *path = unbox_native_string(); REGISTER_C_STRING(path); + /* This reduces deployed image size */ + strip_compiled_quotations(); + /* strip out userenv data which is set on startup anyway */ CELL i; for(i = 0; i < FIRST_SAVE_ENV; i++) From 40009dac8793f6f1972c120446512b0078f08f61 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 15:14:05 -0500 Subject: [PATCH 043/289] add match-range to regexp --- unfinished/regexp/regexp.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/unfinished/regexp/regexp.factor b/unfinished/regexp/regexp.factor index 47c6e52c39..85bdccc2f4 100644 --- a/unfinished/regexp/regexp.factor +++ b/unfinished/regexp/regexp.factor @@ -33,7 +33,19 @@ IN: regexp dupd match [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ; -: match-head ( string regexp -- end ) match length>> 1- ; +: match-head ( string regexp -- end/f ) match [ length>> 1- ] [ f ] if* ; + +: match-at ( string m regexp -- n/f finished? ) + [ + 2dup swap length > [ 2drop f f ] [ tail-slice t ] if + ] dip swap [ match-head f ] [ 2drop f t ] if ; + +: match-range ( string m regexp -- a/f b/f ) + 3dup match-at over [ + drop nip rot drop dupd + + ] [ + [ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if + ] if ; : initial-option ( regexp option -- regexp' ) over options>> conjoin ; From 65e88f70b99f9973153f59154bac1861305b065c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:45:27 -0500 Subject: [PATCH 044/289] Make counter runnable to demonstrate web app deployment --- extra/webapps/counter/counter.factor | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index f3efb3868f..a0ee3a1b29 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: math kernel accessors http.server http.server.dispatchers furnace furnace.actions furnace.sessions furnace.redirection html.components html.forms html.templates.chloe @@ -28,3 +30,20 @@ M: counter-app init-session* drop 0 count sset ; [ 1- ] "dec" add-responder "" add-responder ; + +! Deployment example +USING: db.sqlite db.tuples db furnace.db namespaces ; + +: counter-db ( -- params db ) "counter.db" sqlite-db ; + +: init-counter-db ( -- ) + counter-db [ session ensure-table ] with-db ; + +: run-counter ( -- ) + init-counter-db + + counter-db + main-responder set-global + 8080 httpd ; + +MAIN: run-counter From 90e440bf60ccfdc5164a4a81971166b28249b600 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:45:45 -0500 Subject: [PATCH 045/289] Fix html.elements load problem --- basis/html/elements/elements.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index ab9d987b67..ad75b58df3 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -48,8 +48,6 @@ IN: html.elements ! ! -: elements-vocab ( -- vocab-name ) "html.elements" ; - SYMBOL: html : write-html ( str -- ) @@ -60,6 +58,8 @@ SYMBOL: html << +: elements-vocab ( -- vocab-name ) "html.elements" ; + : html-word ( name def effect -- ) #! Define 'word creating' word to allow #! dynamically creating words. From 5647d08f5905b8b35d539ffbef7ffed64e044c6b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:46:02 -0500 Subject: [PATCH 046/289] Fix some farkup bugs --- basis/farkup/farkup-docs.factor | 6 +- basis/farkup/farkup-tests.factor | 4 ++ basis/farkup/farkup.factor | 103 ++++++++++++++++--------------- 3 files changed, 61 insertions(+), 52 deletions(-) diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index f2d53d2362..6e7a5ddcb0 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -9,7 +9,7 @@ HELP: write-farkup { $values { "string" string } } { $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ; -HELP: farkup ( string -- farkup ) +HELP: parse-farkup ( string -- farkup ) { $values { "string" string } { "farkup" "a Farkup syntax tree node" } } { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ; @@ -18,7 +18,7 @@ HELP: (write-farkup) { $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ; ARTICLE: "farkup-ast" "Farkup syntax tree nodes" -"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." +"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." { $subsection heading1 } { $subsection heading2 } { $subsection heading3 } @@ -44,7 +44,7 @@ $nl { $subsection convert-farkup } { $subsection write-farkup } "The syntax tree of a piece of Farkup can also be inspected and modified:" -{ $subsection farkup } +{ $subsection parse-farkup } { $subsection (write-farkup) } { $subsection "farkup-ast" } ; diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index e25fa34960..cc032913b7 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -118,3 +118,7 @@ link-no-follow? off ] unit-test [ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test + +[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test + +[ "

<foo>

" ] [ "" convert-farkup ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 4d6ac127ad..cc56f48949 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -1,29 +1,29 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators html.elements io io.streams.string -kernel math memoize namespaces peg peg.ebnf prettyprint -sequences sequences.deep strings xml.entities vectors splitting -xmode.code2html ; +USING: accessors arrays combinators html.elements io +io.streams.string kernel math memoize namespaces peg peg.ebnf +prettyprint sequences sequences.deep strings xml.entities +vectors splitting xmode.code2html urls ; IN: farkup SYMBOL: relative-link-prefix SYMBOL: disable-images? SYMBOL: link-no-follow? -TUPLE: heading1 obj ; -TUPLE: heading2 obj ; -TUPLE: heading3 obj ; -TUPLE: heading4 obj ; -TUPLE: strong obj ; -TUPLE: emphasis obj ; -TUPLE: superscript obj ; -TUPLE: subscript obj ; -TUPLE: inline-code obj ; -TUPLE: paragraph obj ; -TUPLE: list-item obj ; -TUPLE: list obj ; -TUPLE: table obj ; -TUPLE: table-row obj ; +TUPLE: heading1 child ; +TUPLE: heading2 child ; +TUPLE: heading3 child ; +TUPLE: heading4 child ; +TUPLE: strong child ; +TUPLE: emphasis child ; +TUPLE: superscript child ; +TUPLE: subscript child ; +TUPLE: inline-code child ; +TUPLE: paragraph child ; +TUPLE: list-item child ; +TUPLE: list child ; +TUPLE: table child ; +TUPLE: table-row child ; TUPLE: link href text ; TUPLE: image href text ; TUPLE: code mode string ; @@ -34,7 +34,7 @@ TUPLE: code mode string ; : simple-link-title ( string -- string' ) dup absolute-url? [ "/" last-split1 swap or ] unless ; -EBNF: farkup +EBNF: parse-farkup nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] 2nl = nl nl @@ -65,7 +65,7 @@ subscript = "~" (!("~" | nl).)+ "~" inline-code = "%" (!("%" | nl).)+ "%" => [[ second >string inline-code boa ]] -escaped-char = "\" . => [[ second ]] +escaped-char = "\" . => [[ second 1string ]] link-content = (!("|"|"]").)+ @@ -89,20 +89,26 @@ inline-tag = strong | emphasis | superscript | subscript | inline-code inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '[' -table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|' +cell = (!(inline-delimiter | '|' | nl).)+ + => [[ >string ]] + +table-column = (list | cell | inline-tag | inline-delimiter ) '|' => [[ first ]] table-row = "|" (table-column)+ => [[ second table-row boa ]] table = ((table-row nl => [[ first ]] )+ table-row? | table-row) => [[ table boa ]] -paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+ +text = (!(nl | code | heading | inline-delimiter | table ).)+ + => [[ >string ]] + +paragraph-item = (table | text | inline-tag | inline-delimiter)+ paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] | (paragraph-item nl)+ paragraph-item? | paragraph-item) => [[ paragraph boa ]] - -list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)* + +list-item = '-' (cell | inline-tag)* => [[ second list-item boa ]] list = ((list-item nl)+ list-item? | list-item) => [[ list boa ]] @@ -136,7 +142,7 @@ stand-alone : write-link ( href text -- ) escape-link - [ ] + [ ] [ write ] bi* ; @@ -146,7 +152,7 @@ stand-alone "Images are not allowed" write ] [ escape-link - [ ] bi* + [ ] bi* ] if ; : render-code ( string mode -- string' ) @@ -161,31 +167,30 @@ GENERIC: (write-farkup) ( farkup -- ) : ( string -- ) write ; : ( string -- ) write ; : in-tag. ( obj quot string -- ) [ call ] keep ; inline -M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ; -M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ; -M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ; -M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ; -M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ; -M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ; -M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ; -M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ; -M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ; -M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ; -M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ; -M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ; -M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ; -M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; -M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; +M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ; +M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ; +M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ; +M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ; +M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ; +M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ; +M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ; +M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ; +M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ; +M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ; +M: list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ; +M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ; +M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ; +M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ; +M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ; M: table-row (write-farkup) ( obj -- ) - obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; -M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ; -M: fixnum (write-farkup) ( obj -- ) write1 ; -M: string (write-farkup) ( obj -- ) write ; -M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ; -M: f (write-farkup) ( obj -- ) drop ; + child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; +M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ; +M: string (write-farkup) escape-string write ; +M: vector (write-farkup) [ (write-farkup) ] each ; +M: f (write-farkup) drop ; : write-farkup ( string -- ) - farkup (write-farkup) ; + parse-farkup (write-farkup) ; : convert-farkup ( string -- string' ) - farkup [ (write-farkup) ] with-string-writer ; + parse-farkup [ (write-farkup) ] with-string-writer ; From ad1c520d13ad01d40617b80783e7866e0ecf4acf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:46:12 -0500 Subject: [PATCH 047/289] Fix stack effects --- basis/urls/urls.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index e16f62d1f1..4f2639975b 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -14,7 +14,7 @@ IN: urls [ letter? ] [ LETTER? ] [ digit? ] - [ "/_-." member? ] + [ "/_-.:" member? ] } 1|| ; foldable -: url-encode ( str -- str ) +: url-encode ( str -- encoded ) [ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; @@ -58,7 +58,7 @@ PRIVATE> PRIVATE> -: url-decode ( str -- str ) +: url-decode ( str -- decoded ) [ 0 swap url-decode-iter ] "" make utf8 decode ; Date: Fri, 19 Sep 2008 16:36:31 -0500 Subject: [PATCH 048/289] Fix validation-messages tag --- basis/furnace/actions/actions.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index cce098f208..6e55ca44a0 100755 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -14,7 +14,8 @@ html.elements html.components html.components html.templates.chloe -html.templates.chloe.syntax ; +html.templates.chloe.syntax +html.templates.chloe.compiler ; IN: furnace.actions SYMBOL: params @@ -29,7 +30,8 @@ SYMBOL: rest ] unless-empty ; -CHLOE: validation-messages drop render-validation-messages ; +CHLOE: validation-messages + drop [ render-validation-messages ] [code] ; TUPLE: action rest authorize init display validate submit ; From 0f284816c1fd90cbd7d09bbeb8b090022bdf7771 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 16:37:27 -0500 Subject: [PATCH 049/289] Fix docs --- core/sequences/sequences-docs.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 789837ea47..b8be31c55c 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1356,16 +1356,18 @@ ARTICLE: "sequences-slices" "Subsequences and slices" "A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:" { $subsection slice } { $subsection slice? } -"Creating slices:" +"Extracting a slice:" { $subsection } { $subsection head-slice } { $subsection tail-slice } -{ $subsection but-last-slice } -{ $subsection rest-slice } { $subsection head-slice* } { $subsection tail-slice* } +"Removing the first or last element:" +{ $subsection rest-slice } +{ $subsection but-last-slice } "Taking a sequence apart into a head and a tail:" { $subsection unclip-slice } +{ $subsection unclip-last-slice } { $subsection cut-slice } "A utility for words which use slices as iterators:" { $subsection } ; From 7b8be1222f87475b8aae1dd648aa369542d6fe70 Mon Sep 17 00:00:00 2001 From: "U-WSCHLIEP-PC\\wschliep" Date: Fri, 19 Sep 2008 18:32:49 -0400 Subject: [PATCH 050/289] irc.client: Got rid of the annoying 100% CPU --- extra/irc/client/client.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) mode change 100644 => 100755 extra/irc/client/client.factor diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor old mode 100644 new mode 100755 index 2474fd643a..76382edf1b --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -91,8 +91,6 @@ SYMBOL: current-irc-client : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : listener> ( name -- listener/f ) irc> listeners>> at ; -: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) - [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -294,14 +292,14 @@ DEFER: (connect-irc) [ (reader-loop) ] [ handle-disconnect ] recover t ; : writer-loop ( -- ? ) - irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ; + irc> out-messages>> mailbox-get handle-outgoing-irc t ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ? ) - irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ; + irc> in-messages>> mailbox-get handle-incoming-irc t ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -314,9 +312,10 @@ DEFER: (connect-irc) : listener-loop ( name -- ? ) dup listener> [ - out-messages>> [ maybe-annotate-with-name - irc> out-messages>> mailbox-put ] with - maybe-mailbox-get t + out-messages>> mailbox-get + maybe-annotate-with-name + irc> out-messages>> mailbox-put + t ] [ drop f ] if* ; : spawn-irc-loop ( quot: ( -- ? ) name -- ) From 19b2f6a6f31c70c77a51959d008f2d536267c4f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 17:48:32 -0500 Subject: [PATCH 051/289] Fix farkup tests --- basis/farkup/farkup-tests.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index cc032913b7..571d333359 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -11,13 +11,11 @@ link-no-follow? off [ "Baz" ] [ "Baz" simple-link-title ] unit-test [ ] [ - "abcd-*strong*\nasdifj\nweouh23ouh23" - "paragraph" \ farkup rule parse drop + "abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop ] unit-test [ ] [ - "abcd-*strong*\nasdifj\nweouh23ouh23\n" - "paragraph" \ farkup rule parse drop + "abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop ] unit-test [ "

a-b

" ] [ "a-b" convert-farkup ] unit-test From 9643ad1b9ea1bf829c71029daa24c34eca6b2a05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 17:54:34 -0500 Subject: [PATCH 052/289] work for lookahead --- unfinished/regexp/dfa/dfa.factor | 1 - unfinished/regexp/transition-tables/transition-tables.factor | 5 +++++ unfinished/regexp/traversal/traversal.factor | 4 ++++ 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/unfinished/regexp/dfa/dfa.factor b/unfinished/regexp/dfa/dfa.factor index 6f244dc8af..6200a1b3c0 100644 --- a/unfinished/regexp/dfa/dfa.factor +++ b/unfinished/regexp/dfa/dfa.factor @@ -27,7 +27,6 @@ IN: regexp.dfa nfa-table>> transitions>> [ 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/regexp/transition-tables/transition-tables.factor b/unfinished/regexp/transition-tables/transition-tables.factor index 82e2db8496..1c9a3e3001 100644 --- a/unfinished/regexp/transition-tables/transition-tables.factor +++ b/unfinished/regexp/transition-tables/transition-tables.factor @@ -32,7 +32,12 @@ TUPLE: transition-table transitions start-state final-states ; H{ } clone >>transitions H{ } clone >>final-states ; +: maybe-initialize-key ( key hashtable -- ) + 2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ; + : set-transition ( transition hash -- ) + #! set the state as a key + 2dup [ to>> ] dip maybe-initialize-key [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip 2dup at* [ 2nip insert-at ] [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ; diff --git a/unfinished/regexp/traversal/traversal.factor b/unfinished/regexp/traversal/traversal.factor index 752323de91..cfc97aff29 100644 --- a/unfinished/regexp/traversal/traversal.factor +++ b/unfinished/regexp/traversal/traversal.factor @@ -43,6 +43,10 @@ TUPLE: dfa-traverser dup save-final-state ] when text-finished? ; +: print-flags ( dfa-traverser -- dfa-traverser ) + dup [ current-state>> ] [ traversal-flags>> ] bi + ; + : increment-state ( dfa-traverser state -- dfa-traverser ) [ [ 1+ ] change-current-index dup current-state>> >>last-state From 57df3b9ee54f3515fcf3b95268d5931db34897dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 18:46:54 -0500 Subject: [PATCH 053/289] Check template modification time, recompile if changed --- basis/html/templates/chloe/chloe.factor | 47 +++++++++++++------ .../templates/chloe/compiler/compiler.factor | 30 ++++++++---- 2 files changed, 53 insertions(+), 24 deletions(-) diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 5fe53fc7a5..cc51bd05d3 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences combinators kernel fry -namespaces make classes.tuple assocs splitting words arrays -memoize io io.files io.encodings.utf8 io.streams.string -unicode.case mirrors math urls present multiline quotations xml +namespaces make classes.tuple assocs splitting words arrays io +io.files io.encodings.utf8 io.streams.string unicode.case +mirrors math urls present multiline quotations xml logging xml.data html.forms html.elements @@ -89,21 +89,40 @@ CHLOE-TUPLE: choice CHLOE-TUPLE: checkbox CHLOE-TUPLE: code -: read-template ( chloe -- xml ) - path>> ".xml" append utf8 read-xml ; +SYMBOL: template-cache -MEMO: template-quot ( chloe -- quot ) - read-template compile-template ; +H{ } template-cache set-global -MEMO: nested-template-quot ( chloe -- quot ) - read-template compile-nested-template ; +TUPLE: cached-template path last-modified quot ; -: reset-templates ( -- ) - { template-quot nested-template-quot } [ reset-memoized ] each ; +: load-template ( chloe -- cached-template ) + path>> ".xml" append + [ ] + [ file-info modified>> ] + [ utf8 read-xml compile-template ] tri + \ cached-template boa ; + +\ load-template DEBUG add-input-logging + +: cached-template ( chloe -- cached-template/f ) + template-cache get at* [ + [ + [ path>> file-info modified>> ] + [ last-modified>> ] + bi = + ] keep and + ] when ; + +: template-quot ( chloe -- quot ) + dup cached-template [ ] [ + [ load-template dup ] keep + template-cache get set-at + ] ?if quot>> ; + +: reset-cache ( -- ) + template-cache get clear-assoc ; M: chloe call-template* - nested-template? get - [ nested-template-quot ] [ template-quot ] if - assert-depth ; + template-quot assert-depth ; INSTANCE: chloe template diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index f32923f620..aa741ebf9f 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -3,7 +3,7 @@ USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present xml.writer xml.data xml.entities html.forms -html.templates.chloe.syntax ; +html.templates html.templates.chloe.syntax ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) @@ -98,9 +98,6 @@ DEFER: compile-element reset-buffer ] [ ] make ; inline -: compile-nested-template ( xml -- quot ) - [ compile-element ] with-compiler ; - : compile-chunk ( seq -- ) [ compile-element ] each ; @@ -121,12 +118,25 @@ DEFER: compile-element : compile-with-scope ( quot -- ) compile-quot [ with-scope ] [code] ; inline +: if-not-nested ( quot -- ) + nested-template? get swap unless ; inline + +: compile-prologue ( xml -- ) + [ + [ before>> compile-chunk ] + [ prolog>> [ write-prolog ] [code-with] ] + bi + ] compile-quot + [ if-not-nested ] [code] ; + +: compile-epilogue ( xml -- ) + [ after>> compile-chunk ] compile-quot + [ if-not-nested ] [code] ; + : compile-template ( xml -- quot ) [ - { - [ prolog>> [ write-prolog ] [code-with] ] - [ before>> compile-chunk ] - [ compile-element ] - [ after>> compile-chunk ] - } cleave + [ compile-prologue ] + [ compile-element ] + [ compile-epilogue ] + tri ] with-compiler ; From d9e0060eb820d0b21997ade7d5dd917fb0f20aed Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 19 Sep 2008 22:14:00 -0300 Subject: [PATCH 054/289] irc.messages: Fix `_' word conflict between fry and inverse --- extra/irc/messages/messages.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 94f80dcf0c..9201f822da 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,9 +1,10 @@ ! 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 inverse ; + arrays classes.tuple math.order ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; +EXCLUDE: inverse => _ ; IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; @@ -69,8 +70,8 @@ M: kick (>>command-parameters) ( params kick -- ) M: names-reply (>>command-parameters) ( params names-reply -- ) [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ; M: mode (>>command-parameters) ( params mode -- ) - { { [ [ 2array ] dip ] [ [ (>>mode) ] [ (>>name) ] bi ] } - { [ [ 3array ] dip ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } + { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } + { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } } switch ; PRIVATE> @@ -94,10 +95,7 @@ M: irc-message irc-message>server-line ( irc-message -- string ) ! ====================================== : split-at-first ( seq separators -- before after ) - dupd '[ _ member? ] find - [ cut 1 tail ] - [ swap ] - if ; + dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ; : remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; From 6b5af35cb608312801ec4a3c8e05b3272e974afe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 20 Sep 2008 03:33:46 -0500 Subject: [PATCH 055/289] reset-templates no longer needed --- basis/html/templates/chloe/chloe-tests.factor | 2 -- extra/websites/concatenative/concatenative.factor | 1 - 2 files changed, 3 deletions(-) diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 9eb4a5709c..3fd0d00712 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -4,8 +4,6 @@ namespaces xml html.components html.forms splitting unicode.categories furnace accessors ; IN: html.templates.chloe.tests -reset-templates - : run-template with-string-writer [ "\r\n\t" member? not ] filter "?>" split1 nip ; inline diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index a35358ae6b..dfb7ff400f 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -69,7 +69,6 @@ SYMBOL: key-file SYMBOL: dh-file : common-configuration ( -- ) - reset-templates "concatenative.org" 25 smtp-server set-global "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global From 2bc3594a0fa73cfa2a53b6e0cb365653716f392d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 20 Sep 2008 15:53:18 -0500 Subject: [PATCH 056/289] Default to 64-bit on 64-bit Intel Macs --- build-support/factor.sh | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 2d4547a121..5cbc1e96e3 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -216,9 +216,8 @@ intel_macosx_word_size() { $ECHO -n "Testing if your Intel Mac supports 64bit binaries..." sysctl machdep.cpu.extfeatures | grep EM64T >/dev/null if [[ $? -eq 0 ]] ; then - WORD=32 + WORD=64 $ECHO "yes!" - $ECHO "Defaulting to 32bit for now though..." else WORD=32 $ECHO "no." From e211260e4721378e622cedf5497e79b9b5135f0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 20 Sep 2008 18:52:39 -0500 Subject: [PATCH 057/289] Tweak unit test --- core/math/parser/parser-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index cee2314d07..aad87ca995 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -41,8 +41,8 @@ unit-test [ "-1.0e-2" string>number number>string ] unit-test -[ "-1.0e-12" ] -[ "-1.0e-12" string>number number>string ] +[ t ] +[ "-1.0e-12" string>number number>string { "-1.0e-12" "-1.0e-012" } member? ] unit-test [ f ] From f66d3d0957d9838a905782e4ae00c80067542542 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 20 Sep 2008 19:08:59 -0500 Subject: [PATCH 058/289] oops, not everyone is in my timezone --- basis/calendar/calendar-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 62ff4ad517..c3d84fc783 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -21,8 +21,8 @@ HELP: { $description "Returns a timestamp object representing the start of the specified day in your current timezone." } { $examples { $example "USING: calendar prettyprint ;" - "2010 12 25 ." - "T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}" + "2010 12 25 >gmt midnight ." + "T{ timestamp { year 2010 } { month 12 } { day 25 } }" } } ; From 6d2a25efc3648b5b6840fbeccb779bf16c98e16e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 21:46:35 -0700 Subject: [PATCH 059/289] Some simplification to printf, more to come. --- extra/printf/printf.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 346a344093..2f23085644 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -31,11 +31,10 @@ IN: printf [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ; : max-width ( string length -- string ) - [ dup length ] dip [ > ] keep swap [ head-slice >string ] [ drop ] if ; + short head ; : >exponential ( n -- base exp ) - [ 0 < ] keep abs - 0 + [ 0 < ] keep abs 0 [ swap dup [ 10.0 >= ] keep 1.0 < or ] [ dup 10.0 >= [ 10.0 / [ 1+ ] dip swap ] @@ -43,7 +42,7 @@ IN: printf ] [ swap ] while [ number>string ] dip dup abs number>string 2 CHAR: 0 pad-left - [ 0 < [ "-" ] [ "+" ] if ] dip append + [ 0 < "-" "+" ? ] dip append "e" prepend rot [ [ "-" prepend ] dip ] when ; @@ -53,11 +52,11 @@ zero = "0" => [[ CHAR: 0 ]] char = "'" (.) => [[ second ]] pad-char = (zero|char)? => [[ CHAR: \s or 1quotation ]] -pad-align = ("-")? => [[ [ [ pad-right ] ] [ [ pad-left ] ] if ]] +pad-align = ("-")? => [[ [ pad-right ] [ pad-left ] ? ]] pad-width = ([0-9])* => [[ >digits 1quotation ]] pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]] -sign = ("+")? => [[ [ [ dup CHAR: - swap index not [ "+" prepend ] when ] ] [ [ ] ] if ]] +sign = ("+")? => [[ [ dup CHAR: - swap index not [ "+" prepend ] when ] [ ] ? ]] width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] width = (width_)? => [[ [ ] or ]] From 7cbbd3e0e68aa9a259239957c2227839f66b36a3 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 22:22:12 -0700 Subject: [PATCH 060/289] Some fixes to printf for help-lint warnings. --- extra/printf/printf-docs.factor | 8 ++++---- extra/printf/printf-tests.factor | 2 ++ extra/printf/printf.factor | 4 ++-- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index 5025fa421f..fabf6d1ddd 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -6,7 +6,7 @@ IN: printf HELP: printf { $values { "format-string" string } } { $description - "Writes the arguments formatted according to the format string.\n" + "Writes the arguments (specified on the stack) formatted according to the format string.\n" { $table { "%%" "Single %" "" } { "%P.Ds" "String format" "string" } @@ -45,7 +45,7 @@ HELP: printf "00123" } { $example "USING: printf ;" - "HEX: ff \"04X\" printf" + "HEX: ff \"%04X\" printf" "00FF" } { $example "USING: printf ;" @@ -66,7 +66,7 @@ HELP: printf } ; HELP: sprintf -{ $values { "params" sequence } { "format-string" string } { "result" string } } -{ $description "Returns the arguments formatted according to the format string as a result string." } +{ $values { "format-string" string } { "result" string } } +{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." } { $see-also printf } ; diff --git a/extra/printf/printf-tests.factor b/extra/printf/printf-tests.factor index 084553c54d..b365343bf0 100644 --- a/extra/printf/printf-tests.factor +++ b/extra/printf/printf-tests.factor @@ -5,6 +5,8 @@ USING: kernel printf tools.test ; [ "%s" printf ] must-infer +[ "%s" sprintf ] must-infer + [ t ] [ "10" 10 "%d" sprintf = ] unit-test [ t ] [ "+10" 10 "%+d" sprintf = ] unit-test diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 2f23085644..c7a7153d6a 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -98,7 +98,7 @@ PRIVATE> MACRO: printf ( format-string -- ) parse-format-string [ length ] keep compose-all '[ _ @ reverse [ write ] each ] ; -: sprintf ( format-string -- ) - [ printf ] with-string-writer ; +: sprintf ( format-string -- result ) + [ printf ] with-string-writer ; inline From 2d5778c5af7c0f36a0f2973775fab32beb6dc955 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 22:39:12 -0700 Subject: [PATCH 061/289] Moving format specifications to a help article. --- extra/printf/printf-docs.factor | 68 +++++++++++++++++---------------- 1 file changed, 35 insertions(+), 33 deletions(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index fabf6d1ddd..a6f18cef8e 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -5,39 +5,7 @@ IN: printf HELP: printf { $values { "format-string" string } } -{ $description - "Writes the arguments (specified on the stack) formatted according to the format string.\n" - { $table - { "%%" "Single %" "" } - { "%P.Ds" "String format" "string" } - { "%P.DS" "String format uppercase" "string" } - { "%c" "Character format" "char" } - { "%C" "Character format uppercase" "char" } - { "%+Pd" "Integer format" "fixnum" } - { "%+P.De" "Scientific notation" "fixnum, float" } - { "%+P.DE" "Scientific notation" "fixnum, float" } - { "%+P.Df" "Fixed format" "fixnum, float" } - { "%+Px" "Hexadecimal" "hex" } - { "%+PX" "Hexadecimal uppercase" "hex" } - } - "\n" - "A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." - "\n" - "Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" - { $list - "\"%5s\" formats a string padding with spaces up to 5 characters wide." - "\"%08d\" formats an integer padding with zeros up to 3 characters wide." - "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." - "\"%-10d\" formats an integer to 10 characters wide and left-aligns." - } - "\n" - "Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n" - { $list - "\"%.3s\" formats a string to truncate at 3 characters (from the left)." - "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." - "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." - } -} +{ $description "Writes the arguments (specified on the stack) formatted according to the format string." } { $examples { $example "USING: printf ;" @@ -70,3 +38,37 @@ HELP: sprintf { $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." } { $see-also printf } ; +ARTICLE: "printf" "Formatted printing" +"The " { $vocab-link "printf" } " and " { $vocab-link "sprintf" } " words are used for formatted printing.\n" +"\n" +"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n" +{ $table + { "%%" "Single %" "" } + { "%P.Ds" "String format" "string" } + { "%P.DS" "String format uppercase" "string" } + { "%c" "Character format" "char" } + { "%C" "Character format uppercase" "char" } + { "%+Pd" "Integer format" "fixnum" } + { "%+P.De" "Scientific notation" "fixnum, float" } + { "%+P.DE" "Scientific notation" "fixnum, float" } + { "%+P.Df" "Fixed format" "fixnum, float" } + { "%+Px" "Hexadecimal" "hex" } + { "%+PX" "Hexadecimal uppercase" "hex" } +} +"\n" +"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." +"\n" +"Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" +{ $list + "\"%5s\" formats a string padding with spaces up to 5 characters wide." + "\"%08d\" formats an integer padding with zeros up to 3 characters wide." + "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." + "\"%-10d\" formats an integer to 10 characters wide and left-aligns." +} +"\n" +"Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n" +{ $list + "\"%.3s\" formats a string to truncate at 3 characters (from the left)." + "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." + "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." +} ; From a9f2fbd4a2a7e62af25e9ed55b8a315ac5503024 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 20 Sep 2008 22:41:16 -0700 Subject: [PATCH 062/289] Fix newline. --- extra/printf/printf-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor index a6f18cef8e..fdecc2ad68 100755 --- a/extra/printf/printf-docs.factor +++ b/extra/printf/printf-docs.factor @@ -56,7 +56,7 @@ ARTICLE: "printf" "Formatted printing" { "%+PX" "Hexadecimal uppercase" "hex" } } "\n" -"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive." +"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive.\n" "\n" "Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n" { $list From 6032bdf8e664093e8e0d2b5c6f6c970a34b84af0 Mon Sep 17 00:00:00 2001 From: Alexander Solovyov Date: Sat, 12 Apr 2008 19:10:34 +0300 Subject: [PATCH 063/289] first efforts to get indentation in emacs --- misc/factor.el | 45 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 5c9d050468..af6ec6c95c 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -111,6 +111,7 @@ (use-local-map factor-mode-map) (setq major-mode 'factor-mode) (setq mode-name "Factor") + (set (make-local-variable 'indent-line-function) #'factor-indent-line) (make-local-variable 'comment-start) (setq comment-start "! ") (make-local-variable 'font-lock-defaults) @@ -224,6 +225,48 @@ (define-key factor-mode-map "\C-c\C-h" 'factor-help) (define-key factor-mode-map "\C-cc" 'comment-region) (define-key factor-mode-map [return] 'newline-and-indent) +(define-key factor-mode-map [tab] 'indent-for-tab-command) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; factor-indent-line +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun factor-calculate-indentation () + "Calculate Factor indentation for line at point." + (let ((not-indented t) + (cur-indent 0)) + (save-excursion + (beginning-of-line) + (if (bobp) + (setq cur-indent 0) + (save-excursion + (while not-indented + (forward-line -1) + ;; Check that we are after the end of previous word + (if (looking-at ".*;[ \t]*$") + (progn + (setq cur-indent (- (current-indentation) default-tab-width)) + (setq not-indented nil)) + (if (looking-at "^\\(\\|:\\): ") + (progn + (setq cur-indent (+ (current-indentation) default-tab-width)) + (setq not-indented nil)) + (if (bobp) + (setq not-indented nil)))))))) + cur-indent)) + +(defun factor-indent-line () + "Indent current line as Factor code" + (let ((target (factor-calculate-indentation)) + (pos (- (point-max) (point)))) + (if (= target (current-indentation)) + (if (< (current-column) (current-indentation)) + (back-to-indentation)) + (beginning-of-line) + (delete-horizontal-space) + (indent-to target) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; factor-listener-mode @@ -244,5 +287,3 @@ (defun factor-refresh-all () (interactive) (comint-send-string "*factor*" "refresh-all\n")) - - From 22c10e8f4f133f043e6106e9de65d466db7da133 Mon Sep 17 00:00:00 2001 From: Alexander Solovyov Date: Mon, 28 Apr 2008 23:36:54 +0300 Subject: [PATCH 064/289] Got Emacs' factor-mode indentation working with non-closed brackets --- misc/factor.el | 40 ++++++++++++++++++++++++++++------------ 1 file changed, 28 insertions(+), 12 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index af6ec6c95c..402dfdf484 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -76,7 +76,7 @@ (modify-syntax-entry ?\" "\" " factor-mode-syntax-table))) (defvar factor-mode-map (make-sparse-keymap)) - + (defcustom factor-mode-hook nil "Hook run when entering Factor mode." :type 'hook @@ -211,7 +211,7 @@ (defun factor-clear () (interactive) (factor-send-string "clear")) - + (defun factor-comment-line () (interactive) (beginning-of-line) @@ -241,19 +241,35 @@ (setq cur-indent 0) (save-excursion (while not-indented - (forward-line -1) - ;; Check that we are after the end of previous word - (if (looking-at ".*;[ \t]*$") + ;; Check that we are inside open brackets + (if (> (factor-brackets-depth) 0) (progn - (setq cur-indent (- (current-indentation) default-tab-width)) - (setq not-indented nil)) - (if (looking-at "^\\(\\|:\\): ") + (let ((cur-depth (factor-brackets-depth))) + (forward-line -1) + (setq cur-indent (+ (current-indentation) + (* default-tab-width + (- cur-depth (factor-brackets-depth))))) + (setq not-indented nil))) + (forward-line -1) + ;; Check that we are after the end of previous word + (if (looking-at ".*;[ \t]*$") (progn - (setq cur-indent (+ (current-indentation) default-tab-width)) + (setq cur-indent (- (current-indentation) default-tab-width)) (setq not-indented nil)) - (if (bobp) - (setq not-indented nil)))))))) - cur-indent)) + ;; Check that we are after the start of word + (if (looking-at "^\\(\\|:\\): ") + (progn + (setq cur-indent (+ (current-indentation) default-tab-width)) + (setq not-indented nil)) + (if (bobp) + (setq not-indented nil))))))))) + cur-indent)) + +(defun factor-brackets-depth () + "Returns number of brackets, not closed on previous lines." + (syntax-ppss-depth + (save-excursion + (syntax-ppss (line-beginning-position))))) (defun factor-indent-line () "Indent current line as Factor code" From 83ef3149fe6739b7e623cfcf24098929110ae4ec Mon Sep 17 00:00:00 2001 From: Alexander Solovyov Date: Sun, 21 Sep 2008 18:42:48 +0300 Subject: [PATCH 065/289] Upgraded version of emacs indentation --- misc/factor.el | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 402dfdf484..1ae8919559 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -228,9 +228,17 @@ (define-key factor-mode-map [tab] 'indent-for-tab-command) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; factor-indent-line +;; indentation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defconst factor-word-starting-keywords + '("" ":" "TUPLE" "MACRO" "MACRO:" "M")) + +(defmacro factor-word-start-re (keywords) + `(format + "^\\(%s\\): " + (mapconcat 'identity ,keywords "\\|"))) + (defun factor-calculate-indentation () "Calculate Factor indentation for line at point." (let ((not-indented t) @@ -242,27 +250,28 @@ (save-excursion (while not-indented ;; Check that we are inside open brackets - (if (> (factor-brackets-depth) 0) - (progn - (let ((cur-depth (factor-brackets-depth))) - (forward-line -1) - (setq cur-indent (+ (current-indentation) - (* default-tab-width - (- cur-depth (factor-brackets-depth))))) - (setq not-indented nil))) - (forward-line -1) + (save-excursion + (let ((cur-depth (factor-brackets-depth))) + (forward-line -1) + (setq cur-indent (+ (current-indentation) + (* default-tab-width + (- cur-depth (factor-brackets-depth))))) + (setq not-indented nil))) + (forward-line -1) ;; Check that we are after the end of previous word (if (looking-at ".*;[ \t]*$") (progn (setq cur-indent (- (current-indentation) default-tab-width)) (setq not-indented nil)) ;; Check that we are after the start of word - (if (looking-at "^\\(\\|:\\): ") + (if (looking-at (factor-word-start-re factor-word-starting-keywords)) +; (if (looking-at "^[A-Z:]*: ") (progn + (message "inword") (setq cur-indent (+ (current-indentation) default-tab-width)) (setq not-indented nil)) (if (bobp) - (setq not-indented nil))))))))) + (setq not-indented nil)))))))) cur-indent)) (defun factor-brackets-depth () From c5a3f89b0409487b8bc1e178d635f668efa4405f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 21 Sep 2008 11:58:09 -0500 Subject: [PATCH 066/289] add feed:// since firefox and safari support it, throw a better error than "fall-through in case" --- basis/urls/urls.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index 4f2639975b..f4a6a7d792 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -212,11 +212,15 @@ PRIVATE> [ [ host>> ] [ port>> ] bi ] [ protocol>> ] bi secure-protocol? [ ] when ; +ERROR: no-protocol-found protocol ; + : protocol-port ( protocol -- port ) { { "http" [ 80 ] } { "https" [ 443 ] } + { "feed" [ 80 ] } { "ftp" [ 21 ] } + [ no-protocol-found ] } case ; : ensure-port ( url -- url' ) From d256db22d19f99c4e433e69423a83b116eb879dd Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 21 Sep 2008 20:38:01 -0300 Subject: [PATCH 067/289] irc.client: Fixes, refactoring --- extra/irc/client/client-tests.factor | 2 +- extra/irc/client/client.factor | 84 ++++++++++++++++------------ 2 files changed, 50 insertions(+), 36 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 932bdda472..c768c1a82e 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -20,7 +20,7 @@ M: mb-writer stream-nl ( mb-writer -- ) [ [ last-line>> concat ] [ lines>> ] bi push ] keep V{ } clone >>last-line drop ; -: spawn-client ( lines listeners -- irc-client ) +: spawn-client ( -- irc-client ) "someserver" irc-port "factorbot" f t >>is-running diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index db4fdd2a58..569f6c4bf7 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -68,12 +68,17 @@ SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established +> values [ out-messages>> ] map ] + [ in-messages>> ] + [ out-messages>> ] tri 2array prepend + [ irc-end swap mailbox-put ] each ; +PRIVATE> + : terminate-irc ( irc-client -- ) [ is-running>> ] keep and [ - [ [ irc-end ] dip in-messages>> mailbox-put ] - [ [ f ] dip (>>is-running) ] - [ stream>> dispose ] - tri + [ end-loops ] [ [ f ] dip (>>is-running) ] bi ] when* ; [ stream-print ] keep stream-flush ; : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : listener> ( name -- listener/f ) irc> listeners>> at ; - +: channel-mode? ( mode -- ? ) name>> first "#&" member? ; +: me? ( string -- ? ) irc> profile>> nickname>> = ; GENERIC: to-listener ( message obj -- ) @@ -137,10 +143,14 @@ M: irc-listener to-listener ( message irc-listener -- ) swap dup listeners-with-participant [ rename-participant ] with with each ; : add-participant ( mode nick channel -- ) - listener> [ - [ participants>> set-at ] - [ [ +join+ f ] dip to-listener ] 2bi - ] [ 2drop ] if* ; + listener> + [ participants>> set-at ] + [ [ +join+ f ] dip to-listener ] 2bi ; + +: change-participant-mode ( channel mode nick -- ) + rot listener> + [ participants>> set-at ] + [ [ [ +mode+ ] dip ] dip to-listener ] 3bi ; ! FIXME DEFER: me? @@ -174,9 +184,6 @@ DEFER: me? ! Server message handling ! ====================================== -: me? ( string -- ? ) - irc> profile>> nickname>> = ; - GENERIC: forward-name ( irc-message -- name ) M: join forward-name ( join -- name ) trailing>> ; M: part forward-name ( part -- name ) channel>> ; @@ -220,7 +227,8 @@ M: nick-in-use process-message ( nick-in-use -- ) name>> "_" append /NICK ; M: join process-message ( join -- ) - [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ; + [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri + dup listener> [ add-participant ] [ 3drop ] if ; M: part process-message ( part -- ) [ irc-message-sender ] [ channel>> ] bi remove-participant ; @@ -236,6 +244,12 @@ M: quit process-message ( quit -- ) M: nick process-message ( nick -- ) [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; +! M: mode process-message ( mode -- ) +! [ channel-mode? ] keep and [ +! [ name>> ] [ mode>> ] [ parameter>> ] tri +! [ change-participant-mode ] [ 2drop ] if* +! ] when* ; + : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -249,15 +263,14 @@ M: names-reply process-message ( names-reply -- ) [ [ f f f ] dip name>> to-listener ] bi ] [ drop ] if* ; -: handle-incoming-irc ( irc-message -- ) - [ forward-message ] [ process-message ] bi ; - ! ====================================== ! Client message handling ! ====================================== -: handle-outgoing-irc ( irc-message -- ) - irc-message>client-line irc-print ; +GENERIC: handle-outgoing-irc ( irc-message -- ? ) +M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ; +M: irc-message handle-outgoing-irc ( irc-message -- ? ) + irc-message>client-line irc-print t ; ! ====================================== ! Reader/Writer @@ -279,27 +292,28 @@ DEFER: (connect-irc) : handle-disconnect ( error -- ) drop irc> is-running>> [ (handle-disconnect) ] when ; -: (reader-loop) ( -- ) +: (reader-loop) ( -- ? ) irc> stream>> [ |dispose stream-readln [ - parse-irc-line handle-reader-message + parse-irc-line handle-reader-message t ] [ - irc> terminate-irc + irc> terminate-irc f ] if* ] with-destructors ; : reader-loop ( -- ? ) - [ (reader-loop) ] [ handle-disconnect ] recover t ; + [ (reader-loop) ] [ handle-disconnect t ] recover ; : writer-loop ( -- ? ) - irc> out-messages>> mailbox-get handle-outgoing-irc t ; + irc> out-messages>> mailbox-get handle-outgoing-irc ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ? ) - irc> in-messages>> mailbox-get handle-incoming-irc t ; + irc> in-messages>> mailbox-get + [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -310,22 +324,22 @@ DEFER: (connect-irc) [ nip ] } cond ; +GENERIC: handle-listener-out ( irc-message -- ? ) +M: irc-end handle-listener-out ( irc-end -- ? ) drop f ; +M: irc-message handle-listener-out ( irc-message -- ? ) + irc> out-messages>> mailbox-put t ; + : listener-loop ( name -- ? ) dup listener> [ out-messages>> mailbox-get - maybe-annotate-with-name - irc> out-messages>> mailbox-put - t + maybe-annotate-with-name handle-listener-out ] [ drop f ] if* ; -: spawn-irc-loop ( quot: ( -- ? ) name -- ) - [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip - spawn-server drop ; - : spawn-irc ( -- ) - [ reader-loop ] "irc-reader-loop" spawn-irc-loop - [ writer-loop ] "irc-writer-loop" spawn-irc-loop - [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ; + [ reader-loop ] "irc-reader-loop" spawn-server + [ writer-loop ] "irc-writer-loop" spawn-server + [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server + 3drop ; ! ====================================== ! Listener join request handling @@ -333,7 +347,7 @@ DEFER: (connect-irc) : set+run-listener ( name irc-listener -- ) over irc> listeners>> set-at - '[ _ listener-loop ] "listener" spawn-irc-loop ; + '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ; GENERIC: (add-listener) ( irc-listener -- ) From e9b30d2bbce0ee1dfcefadb63fe0b26385c6b639 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 21 Sep 2008 19:42:05 -0500 Subject: [PATCH 068/289] Debugging asides and conversation scope --- basis/furnace/actions/actions.factor | 2 +- basis/furnace/alloy/alloy.factor | 7 +- basis/furnace/asides/asides.factor | 111 ++++++++++++++++++ .../deactivate-user/deactivate-user.factor | 2 +- .../features/edit-profile/edit-profile.factor | 4 +- .../recover-password/recover-password.factor | 2 +- basis/furnace/auth/login/login.factor | 13 +- basis/furnace/chloe-tags/chloe-tags.factor | 2 +- .../conversations/conversations.factor | 85 ++------------ basis/furnace/furnace.factor | 12 ++ basis/furnace/redirection/redirection.factor | 2 +- basis/furnace/sessions/sessions.factor | 4 + basis/furnace/syndication/syndication.factor | 4 +- 13 files changed, 160 insertions(+), 90 deletions(-) create mode 100644 basis/furnace/asides/asides.factor diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 6e55ca44a0..2a63489299 100755 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -86,7 +86,7 @@ TUPLE: action rest authorize init display validate submit ; begin-conversation nested-forms-key param " " split harvest nested-forms cset form get form cset - + ] [ <400> ] if* exit-with ; diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index 6f5f6fdbf6..f27c7d67c0 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/basis/furnace/alloy/alloy.factor @@ -3,6 +3,7 @@ USING: kernel sequences db.tuples alarms calendar db fry furnace.db furnace.cache +furnace.asides furnace.referrer furnace.sessions furnace.conversations @@ -12,17 +13,17 @@ IN: furnace.alloy : ( responder db params -- responder' ) '[ + _ _ ] call ; -: state-classes { session conversation permit } ; inline +: state-classes { session aside conversation permit user } ; inline : init-furnace-tables ( -- ) - state-classes ensure-tables - user ensure-table ; + state-classes ensure-tables ; : start-expiring ( db params -- ) '[ diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor new file mode 100644 index 0000000000..6d4196cf0b --- /dev/null +++ b/basis/furnace/asides/asides.factor @@ -0,0 +1,111 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs kernel sequences accessors hashtables +urls db.types db.tuples math.parser fry logging combinators +html.templates.chloe.syntax +http http.server http.server.filters http.server.redirection +furnace +furnace.cache +furnace.sessions +furnace.redirection ; +IN: furnace.asides + +TUPLE: aside < server-state +session method url post-data ; + +: