From 719376e412804f1286482ff32cf3aaf1889f524d Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 13:17:09 +1200 Subject: [PATCH 01/46] Remove w-c-u from ebnf transform --- extra/peg/ebnf/ebnf.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e5787e6cf8..56f88fc866 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -318,11 +318,11 @@ M: object build-locals ( code ast -- ) M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals - string-lines [ parse-lines ] with-compilation-unit action ; + string-lines parse-lines action ; M: ebnf-semantic (transform) ( ast -- parser ) [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals - string-lines [ parse-lines ] with-compilation-unit semantic ; + string-lines parse-lines semantic ; M: ebnf-var (transform) ( ast -- parser ) parser>> (transform) ; From a641c6d332e36910239a6a269e299a231f422d18 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 14:39:18 +1200 Subject: [PATCH 02/46] Add \r to ebnf escape rules --- extra/peg/ebnf/ebnf.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 56f88fc866..8bf0475da5 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -361,7 +361,11 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) [ compiled-parse ] curry [ with-scope ] curry ; : replace-escapes ( string -- string ) - "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ; + [ + "\\t" token [ drop "\t" ] action , + "\\n" token [ drop "\n" ] action , + "\\r" token [ drop "\r" ] action , + ] choice* replace ; : [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing From f7f7972756d6de6b4fab6d687092eefea214e319 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:07:03 -0500 Subject: [PATCH 03/46] Sequence equality on slices and reversals --- core/combinators/combinators.factor | 4 ++++ core/sequences/sequences-tests.factor | 20 +++++++++++++++++- core/sequences/sequences.factor | 30 +++++++++++++++++---------- 3 files changed, 42 insertions(+), 12 deletions(-) diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 139c6d8fdf..96c4009ba9 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -59,6 +59,10 @@ ERROR: no-case ; M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ; +M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ; + +M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ; + M: hashtable hashcode* [ dup assoc-size 1 number= diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 3a30824084..281b27d540 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel math namespaces sequences kernel.private sequences.private strings sbufs tools.test vectors bit-arrays -generic ; +generic vocabs.loader ; IN: sequences.tests [ V{ 1 2 3 4 } ] [ 1 5 dup >vector ] unit-test @@ -100,6 +100,16 @@ unit-test [ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test +[ "blah" ] [ "blahxx" 2 head* ] unit-test + +[ "xx" ] [ "blahxx" 2 tail* ] unit-test + +[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test +[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test + +[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test +[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test + [ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test [ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test [ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test @@ -195,6 +205,12 @@ unit-test ! Pathological case [ "ihbye" ] [ "hi" "bye" append ] unit-test +[ t ] [ "hi" SBUF" hi" = ] unit-test + +[ t ] [ "hi" SBUF" hi" = ] unit-test + +[ t ] [ "hi" SBUF" hi" [ hashcode ] bi@ = ] unit-test + [ -10 "hi" "bye" copy ] must-fail [ 10 "hi" "bye" copy ] must-fail @@ -244,3 +260,5 @@ unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test +! Hardcore +[ ] [ "sequences" reload ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 01a1cb9b6a..996aba8e6e 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -172,7 +172,9 @@ TUPLE: reversed seq ; C: reversed M: reversed virtual-seq reversed-seq ; + M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ; + M: reversed length reversed-seq length ; INSTANCE: reversed virtual-sequence @@ -198,7 +200,9 @@ ERROR: slice-error reason ; slice construct-boa ; inline M: slice virtual-seq slice-seq ; + M: slice virtual@ [ slice-from + ] keep slice-seq ; + M: slice length dup slice-to swap slice-from - ; : head-slice ( seq n -- slice ) (head) ; @@ -466,6 +470,21 @@ M: sequence <=> 2dup [ length ] bi@ number= [ mismatch not ] [ 2drop f ] if ; inline +: sequence-hashcode-step ( oldhash newpart -- newhash ) + swap [ + dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast + fixnum+fast fixnum+fast + ] keep fixnum-bitxor ; inline + +: sequence-hashcode ( n seq -- x ) + 0 -rot [ + hashcode* >fixnum sequence-hashcode-step + ] with each ; inline + +M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ; + +M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; + : move ( to from seq -- ) 2over number= [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline @@ -692,14 +711,3 @@ PRIVATE> dup [ length ] map infimum [ dup like ] with map ] unless ; - -: sequence-hashcode-step ( oldhash newpart -- newhash ) - swap [ - dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast - fixnum+fast fixnum+fast - ] keep fixnum-bitxor ; inline - -: sequence-hashcode ( n seq -- x ) - 0 -rot [ - hashcode* >fixnum sequence-hashcode-step - ] with each ; inline From e4f5448ae1508d979e74db1328643dbea0b7caee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:07:12 -0500 Subject: [PATCH 04/46] Documentation --- core/parser/parser-docs.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d11f036445..e7984f7ec3 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files" { $subsection parse-file } { $subsection bootstrap-file } "The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions." +$nl +"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "." { $see-also "source-files" } ; ARTICLE: "parser-usage" "Reflective parser usage" @@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage" "The parser can also parse from a stream:" { $subsection parse-stream } ; +ARTICLE: "top-level-forms" "Top level forms" +"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file." +$nl +"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word." +$nl +"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ; + ARTICLE: "parser" "The parser" "This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies." $nl @@ -168,6 +177,7 @@ $nl { $subsection "vocabulary-search" } { $subsection "parser-files" } { $subsection "parser-usage" } +{ $subsection "top-level-forms" } "The parser can be extended." { $subsection "parsing-words" } { $subsection "parser-lexer" } From 600740d68bfc5977ab459a3555e1f9154dac5341 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:07:30 -0500 Subject: [PATCH 05/46] Tweaks --- core/compiler/compiler.factor | 8 ++++---- core/optimizer/optimizer-tests.factor | 3 +++ 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index a0599f79a1..6f75ca873d 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces arrays sequences io inference.backend -inference.state generator debugger math.parser prettyprint words -compiler.units continuations vocabs assocs alien.compiler dlists -optimizer definitions math compiler.errors threads graphs -generic inference ; +inference.state generator debugger words compiler.units +continuations vocabs assocs alien.compiler dlists optimizer +definitions math compiler.errors threads graphs generic +inference ; IN: compiler : ripple-up ( word -- ) diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 6c6adfa3e6..c8d7a0a0a0 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ; HINTS: recursive-inline-hang-3 array ; +! Regression +USE: sequences.private +[ ] [ { (3append) } compile ] unit-test From 0f4ac3a8dc1448af61b7110b9830d3b43c2925c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:44:43 -0500 Subject: [PATCH 06/46] Slot shadow warnings --- core/classes/tuple/tuple-tests.factor | 9 +++++++++ core/classes/tuple/tuple.factor | 6 +++--- core/parser/parser.factor | 29 +++++++++++++++++++-------- 3 files changed, 33 insertions(+), 11 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 729997d3b2..2575570d2f 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ; ] unit-test [ t ] [ \ another-forget-accessors-test class? ] unit-test + +! Shadowing test +[ f ] [ + t parser-notes? [ + [ + "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval + ] with-string-writer empty? + ] with-variable +] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 608fb8cf6c..aa8ef6cdb7 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -55,6 +55,9 @@ PRIVATE> "slot-names" word-prop [ dup array? [ second ] when ] map ; +: all-slot-names ( class -- slots ) + superclasses [ slot-names ] map concat \ class prefix ; + : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: all-slot-names ( class -- slots ) - superclasses [ slot-names ] map concat \ class prefix ; - : compute-slot-permutation ( class old-slot-names -- permutation ) >r all-slot-names r> [ index ] curry map ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d091fd1c0..6c09e08f84 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions generic assocs kernel math -namespaces prettyprint sequences strings vectors words -quotations inspector io.styles io combinators sorting -splitting math.parser effects continuations debugger -io.files io.streams.string vocabs io.encodings.utf8 -source-files classes hashtables compiler.errors compiler.units -accessors ; +USING: arrays definitions generic assocs kernel math namespaces +prettyprint sequences strings vectors words quotations inspector +io.styles io combinators sorting splitting math.parser effects +continuations debugger io.files io.streams.string vocabs +io.encodings.utf8 source-files classes classes.tuple hashtables +compiler.errors compiler.units accessors ; IN: parser TUPLE: lexer text line line-text line-length column ; @@ -285,13 +284,27 @@ M: no-word-error summary : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; +: shadowed-slots ( superclass slots -- shadowed ) + >r all-slot-names r> seq-intersect ; + +: check-slot-shadowing ( class superclass slots -- ) + shadowed-slots [ + [ + "Definition of slot ``" % + % + "'' in class ``" % + word-name % + "'' shadows a superclass slot" % + ] "" make note. + ] with each ; + : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS scan { { ";" [ tuple f ] } { "<" [ scan-word ";" parse-tokens ] } [ >r tuple ";" parse-tokens r> prefix ] - } case ; + } case 3dup check-slot-shadowing ; ERROR: staging-violation word ; From a48120c80b2886c56adc4b52ee092a020e78de1d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 21:04:51 -0500 Subject: [PATCH 07/46] Improve memory tooL --- extra/tools/memory/memory-tests.factor | 4 ++ extra/tools/memory/memory.factor | 58 ++++++++++++++++++-------- 2 files changed, 44 insertions(+), 18 deletions(-) diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor index 9efbf63f7f..60b54c2a0d 100644 --- a/extra/tools/memory/memory-tests.factor +++ b/extra/tools/memory/memory-tests.factor @@ -1,4 +1,8 @@ USING: tools.test tools.memory ; IN: tools.memory.tests +\ room. must-infer +[ ] [ room. ] unit-test + +\ heap-stats. must-infer [ ] [ heap-stats. ] unit-test diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor index 2077ea497e..b8fdcab280 100644 --- a/extra/tools/memory/memory.factor +++ b/extra/tools/memory/memory.factor @@ -1,22 +1,29 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences vectors arrays generic assocs io math namespaces parser prettyprint strings io.styles vectors words -system sorting splitting math.parser classes memory ; +system sorting splitting math.parser classes memory combinators ; IN: tools.memory +string + dup length 4 > [ 3 cut* "," swap 3append ] when + " KB" append write-cell ; + : write-total/used/free ( free total str -- ) [ write-cell - dup number>string write-cell - over - number>string write-cell - number>string write-cell + dup write-size + over - write-size + write-size ] with-row ; : write-total ( n str -- ) [ write-cell - number>string write-cell + write-size [ ] with-cell [ ] with-cell ] with-row ; @@ -25,26 +32,41 @@ IN: tools.memory [ [ write-cell ] each ] with-row ; : (data-room.) ( -- ) - data-room 2 0 [ - "Generation " pick number>string append - >r first2 r> write-total/used/free 1+ - ] reduce drop + data-room 2 dup length [ + [ first2 ] [ number>string "Generation " prepend ] bi* + write-total/used/free + ] 2each "Cards" write-total ; -: (code-room.) ( -- ) - code-room "Code space" write-total/used/free ; +: write-labelled-size ( n string -- ) + [ write-cell write-size ] with-row ; -: room. ( -- ) - standard-table-style [ - { "" "Total" "Used" "Free" } write-headings - (data-room.) - (code-room.) - ] tabular-output ; +: (code-room.) ( -- ) + code-room { + [ "Size:" write-labelled-size ] + [ "Used:" write-labelled-size ] + [ "Total free space:" write-labelled-size ] + [ "Largest free block:" write-labelled-size ] + } spread ; : heap-stat-step ( counts sizes obj -- ) [ dup size swap class rot at+ ] keep 1 swap class rot at+ ; +PRIVATE> + +: room. ( -- ) + "==== DATA HEAP" print + standard-table-style [ + { "" "Total" "Used" "Free" } write-headings + (data-room.) + ] tabular-output + nl + "==== CODE HEAP" print + standard-table-style [ + (code-room.) + ] tabular-output ; + : heap-stats ( -- counts sizes ) H{ } clone H{ } clone [ >r 2dup r> heap-stat-step ] each-object ; From b6befe6100a692d3a24b34645d005d5a0e61e173 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 21:05:00 -0500 Subject: [PATCH 08/46] Remove redundant word --- extra/assocs/lib/lib.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index b23ee1f830..92fb9aac81 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -37,9 +37,6 @@ IN: assocs.lib : insert ( value variable -- ) namespace insert-at ; -: 2seq>assoc ( keys values exemplar -- assoc ) - >r 2array flip r> assoc-like ; - : generate-key ( assoc -- str ) >r 256 random-bits >hex r> 2dup key? [ nip generate-key ] [ drop ] if ; From 9d8062aa46f6dac5161675d7db3f4ac3fb369452 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 22:16:51 -0500 Subject: [PATCH 09/46] Remove *.lib from using --- extra/peg/peg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ee9037ff25..3b1d408ae2 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle - vectors arrays combinators.lib math.parser - unicode.categories sequences.lib compiler.units parser + vectors arrays math.parser + unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting ; IN: peg From 8df3751049fe170114b3ced8593af74e267f1d49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 22:32:46 -0500 Subject: [PATCH 10/46] Load fix --- extra/sequences/lib/lib.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 945ba1a3b7..2e74708aa9 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -4,7 +4,7 @@ USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors arrays math.parser math.private sorting strings ascii macros -assocs.lib quotations ; +assocs.lib quotations hashtables ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline @@ -221,7 +221,7 @@ PRIVATE> [ swap nth ] with map ; : replace ( str oldseq newseq -- str' ) - H{ } 2seq>assoc substitute ; + zip >hashtable substitute ; : remove-nth ( seq n -- seq' ) cut-slice 1 tail-slice append ; From 042b5ece238cec0b67de7d441ef22c1b4ca181e7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:24:41 -0500 Subject: [PATCH 11/46] Add a few words to newfx --- extra/newfx/newfx.factor | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index df826dc295..b123fef2a3 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -1,7 +1,8 @@ -USING: kernel sequences assocs qualified ; +USING: kernel sequences assocs qualified circular ; QUALIFIED: sequences +QUALIFIED: circular IN: newfx @@ -53,8 +54,10 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: push ( seq obj -- seq ) over sequences:push ; -: push-on ( obj seq -- seq ) tuck sequences:push ; +: push ( seq obj -- seq ) over sequences:push ; +: push-on ( obj seq -- seq ) tuck sequences:push ; +: pushed ( seq obj -- ) swap sequences:push ; +: pushed-on ( obj seq -- ) sequences:push ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -91,6 +94,10 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: push-circular ( seq elt -- seq ) over circular:push-circular ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! A note about the 'mutate' qualifier. Other words also technically mutate ! their primary object. However, the 'mutate' qualifier is supposed to ! indicate that this is the main objective of the word, as a side effect. \ No newline at end of file From 9430478503d8fc302371c872501b9cf630356bb2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:25:14 -0500 Subject: [PATCH 12/46] sequences.lib: Add each-percent --- extra/sequences/lib/lib.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 945ba1a3b7..ac50d3f6c6 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -37,6 +37,16 @@ MACRO: firstn ( n -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: each-percent ( seq quot -- ) + >r + dup length + dup [ / ] curry + [ 1+ ] swap compose + r> compose + 2each ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline From e67978b759bf3403e0cb6487418137f7051c7206 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:26:02 -0500 Subject: [PATCH 13/46] processing: Move some items from the bubble-chamber demo --- extra/processing/processing.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index acad02363b..02a8325663 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -1,6 +1,6 @@ USING: kernel namespaces threads combinators sequences arrays - math math.functions + math math.functions math.ranges random opengl.gl opengl.glu vars multi-methods shuffle ui ui.gestures @@ -16,6 +16,18 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 2random ( a b -- num ) 2dup swap - 100 / random ; + +: 1random ( b -- num ) 0 swap 2random ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: chance ( fraction -- ? ) 0 1 2random > ; + +: percent-chance ( percent -- ? ) 100 / chance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: fill-color VAR: stroke-color From 469470347b6f3692544c0ecb53c483a96708a230 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:27:43 -0500 Subject: [PATCH 14/46] bubble-chamber: use inheritance for the particles --- .../bubble-chamber/bubble-chamber.factor | 92 ++++++++----------- 1 file changed, 38 insertions(+), 54 deletions(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index c6e000e74f..5d128d5102 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -25,12 +25,6 @@ IN: processing.gallery.bubble-chamber ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 2random ( a b -- num ) 2dup swap - 100 / random ; - -: 1random ( b -- num ) 0 swap 2random ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : move-by ( obj delta -- obj ) over pos>> v+ >>pos ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -103,23 +97,34 @@ VARS: particles muons quarks hadrons axions ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: initialize-particle ( particle -- particle ) + + 0 0 {2} >>pos + 0 0 {2} >>vel + + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + + 0 0 0 1 >>myc + 0 0 0 1 >>mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + GENERIC: collide ( particle -- ) GENERIC: move ( particle -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ; +TUPLE: muon < particle ; -: ( -- muon ) - muon construct-empty - 0 0 2array >>pos - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - 0 0 0 1 >>myc - 0 0 0 1 >>mya ; +: ( -- muon ) muon construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,18 +182,9 @@ METHOD: move { muon } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ; +TUPLE: quark < particle ; -: ( -- quark ) - quark construct-empty - 0 0 2array >>pos - 0 0 2array >>vel - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - 0 0 0 1 >>myc ; +: ( -- quark ) quark construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -228,7 +224,8 @@ METHOD: move { quark } [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d [ ] [ speed>> ] [ speed-d>> ] tri * >>speed - 1000 random 997 > + ! 1000 random 997 > + 3/1000 chance [ dup speed>> neg >>speed 2 over speed-d>> - >>speed-d @@ -242,18 +239,9 @@ METHOD: move { quark } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ; +TUPLE: hadron < particle ; -: ( -- hadron ) - hadron construct-empty - 0 0 2array >>pos - 0 0 2array >>vel - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - 0 0 0 1 >>myc ; +: ( -- hadron ) hadron construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -296,12 +284,14 @@ METHOD: move { hadron } [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d [ ] [ speed>> ] [ speed-d>> ] tri * >>speed - 1000 random 997 > + ! 1000 random 997 > + 3/1000 chance [ 1.0 >>speed-d 0.00001 >>theta-dd - 100 random 70 > + ! 100 random 70 > + 30/100 chance [ dim 2 / dup 2array >>pos dup collide @@ -317,17 +307,9 @@ METHOD: move { hadron } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ; +TUPLE: axion < particle ; -: ( -- axion ) - axion construct-empty - 0 0 2array >>pos - 0 0 2array >>vel - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd ; +: ( -- axion ) axion construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -381,12 +363,14 @@ METHOD: move { axion } [ ] [ speed-d>> 0.9999 * ] bi >>speed-d - 1000 random 996 > + ! 1000 random 996 > + 4/1000 chance [ dup speed>> neg >>speed dup speed-d>> neg 2 + >>speed-d - 100 random 30 > + ! 100 random 30 > + 70/100 chance [ dim 2 / dup 2array >>pos collide From 71d1848a89c46d3e23cf23bc851cb7e3e8244cb3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:28:25 -0500 Subject: [PATCH 15/46] trails: Factor out some items --- extra/processing/gallery/trails/trails.factor | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor index f0a8889fbf..dc191bc439 100644 --- a/extra/processing/gallery/trails/trails.factor +++ b/extra/processing/gallery/trails/trails.factor @@ -1,5 +1,6 @@ -USING: kernel arrays sequences math qualified circular processing ui ; +USING: kernel arrays sequences math qualified + sequences.lib circular processing ui newfx ; IN: processing.gallery.trails @@ -9,22 +10,6 @@ IN: processing.gallery.trails ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -QUALIFIED: circular - -: push-circular ( seq elt -- seq ) over circular:push-circular ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: each-percent ( seq quot -- ) - >r - dup length - dup [ / ] curry - [ 1+ ] swap compose - r> compose - 2each ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : point-list ( n -- seq ) [ drop 0 0 2array ] map ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From f71d174f38e5e1f9d4d7caac5c51917be42d6b20 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:28:46 -0500 Subject: [PATCH 16/46] Add documentation for bubble-chamber --- .../bubble-chamber/bubble-chamber-docs.factor | 97 +++++++++++++++++++ 1 file changed, 97 insertions(+) create mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor new file mode 100644 index 0000000000..21a845e089 --- /dev/null +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor @@ -0,0 +1,97 @@ + +USING: help.syntax help.markup ; + +IN: processing.gallery.bubble-chamber + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: muon + + { $class-description + "The muon is a colorful particle with an entangled friend." + "It draws both itself and its horizontally symmetric partner." + "A high range of speed and almost no speed decay allow the" + "muon to reach the extents of the window, often forming rings" + "where theta has decayed but speed remains stable. The result" + "is color almost everywhere in the general direction of collision," + "stabilized into fuzzy rings." } ; + +HELP: quark + + { $class-description + "The quark draws as a translucent black. Their large numbers" + "create fields of blackness overwritten only by the glowing shadows of " + "Hadrons. " + "quarks are allowed to accelerate away with speed decay values above 1.0. " + "Each quark has an entangled friend. Both particles are drawn identically," + "mirrored along the y-axis." } ; + +HELP: hadron + + { $class-description + "Hadrons collide from totally random directions. " + "Those hadrons that do not exit the drawing area, " + "tend to stabilize into perfect circular orbits. " + "Each hadron draws with a slight glowing emboss. " + "The hadron itself is not drawn." } ; + +HELP: axion + + { $class-description + "The axion particle draws a bold black path. Axions exist " + "in a slightly higher dimension and as such are drawn with " + "elevated embossed shadows. Axions are quick to stabilize " + "and fall into single pixel orbits axions automatically " + "recollide themselves after stabilizing." } ; + +{ muon quark hadron axion } related-words + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "bubble-chamber" "Bubble Chamber" + + { $subsection "bubble-chamber-introduction" } + { $subsection "bubble-chamber-particles" } + { $subsection "bubble-chamber-author" } + { $subsection "bubble-chamber-running" } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "bubble-chamber-introduction" "Introduction" + +"The Bubble Chamber is a generative painting system of imaginary " +"colliding particles. A single super-massive collision produces a " +"discrete universe of four particle types. Particles draw their " +"positions over time as pixel exposures. " ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "bubble-chamber-particles" "Particles" + +"Four types of particles exist. The behavior and graphic appearance of " +"each particle type is unique." + + { $subsection muon } + { $subsection quark } + { $subsection hadron } + { $subsection axion } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "bubble-chamber-author" "Author" + + "Bubble Chamber was created by Jared Tarbell. " + "It was originally implemented in Processing. " + "It was ported to Factor by Eduardo Cavazos. " + "The original work is on display here: " + { $url + "http://www.complexification.net/gallery/machines/bubblechamber/" } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "bubble-chamber-running" "How to use" + + "After you run the vocabulary, a window will appear. Click the " + "mouse in a random area to fire 11 particles of each type. " + "Another way to fire particles is to press the " + "spacebar. This fires all the particles." ; \ No newline at end of file From e7c3d888f642e379a6af7c8741f5dfe2148e1ae3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 04:04:12 -0500 Subject: [PATCH 17/46] math.points: Utility words for two and three dimensional points --- extra/math/points/points.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 extra/math/points/points.factor diff --git a/extra/math/points/points.factor b/extra/math/points/points.factor new file mode 100644 index 0000000000..5efd6e07e0 --- /dev/null +++ b/extra/math/points/points.factor @@ -0,0 +1,22 @@ + +USING: kernel arrays math.vectors ; + +IN: math.points + + + +: v+x ( seq x -- seq ) X v+ ; +: v-x ( seq x -- seq ) X v- ; + +: v+y ( seq y -- seq ) Y v+ ; +: v-y ( seq y -- seq ) Y v- ; + +: v+z ( seq z -- seq ) Z v+ ; +: v-z ( seq z -- seq ) Z v- ; + From 94863d980de8c608902186d5b9546098c9cd6f6b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 04:13:02 -0500 Subject: [PATCH 18/46] bubble-chamber: minor refactoring --- .../gallery/bubble-chamber/bubble-chamber.factor | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index 5d128d5102..2efa04efad 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -7,6 +7,7 @@ USING: kernel namespaces sequences combinators arrays threads math.ranges math.constants math.functions + math.points ui ui.gadgets @@ -76,17 +77,8 @@ VARS: particles muons quarks hadrons axions ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: x>> ( particle -- x ) pos>> first ; -: y>> ( particle -- x ) pos>> second ; - -: >>x ( particle x -- particle ) over y>> 2array >>pos ; -: >>y ( particle y -- particle ) over x>> swap 2array >>pos ; - -: x x>> ; -: y y>> ; - -: v+y ( seq y -- seq ) >r first2 r> + 2array ; -: v-y ( seq y -- seq ) >r first2 r> - 2array ; +: x ( particle -- x ) pos>> first ; +: y ( particle -- x ) pos>> second ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 4cd86a06174816adefef7f3899a82cedf66be585 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 8 Apr 2008 17:32:37 -0300 Subject: [PATCH 19/46] IRC client update --- extra/irc/irc.factor | 337 ++++++++++++++++++++++++++----------------- 1 file changed, 206 insertions(+), 131 deletions(-) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 8a39846fc4..0105fc53bb 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -1,87 +1,130 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar io io.sockets kernel match namespaces -sequences splitting strings continuations threads ascii -io.encodings.utf8 ; +USING: arrays calendar combinators channels concurrency.messaging fry io + io.encodings.8-bit io.sockets kernel math namespaces sequences + sequences.lib singleton splitting strings threads + continuations classes.tuple ascii accessors ; IN: irc -! "setup" objects -TUPLE: profile server port nickname password default-channels ; -C: profile +! utils +: split-at-first ( seq separators -- before after ) + dupd '[ , member? ] find + [ cut 1 tail ] + [ swap ] + if ; -TUPLE: channel-profile name password auto-rejoin ; -C: channel-profile +: spawn-server-linked ( quot name -- thread ) + >r '[ , [ ] [ ] while ] r> + spawn-linked ; +! --- + +! Default irc port +: irc-port 6667 ; + +! Message used when the client isn't running anymore +SINGLETON: irc-end + +! "setup" objects +TUPLE: irc-profile server port nickname password default-channels ; +C: irc-profile + +TUPLE: irc-channel-profile name password auto-rejoin ; +C: irc-channel-profile ! "live" objects -TUPLE: irc-client profile nick stream stream-process controller-process ; -C: irc-client - TUPLE: nick name channels log ; C: nick -TUPLE: channel name topic members log attributes ; -C: channel +TUPLE: irc-client profile nick stream stream-channel controller-channel + listeners is-running ; +: ( profile -- irc-client ) + f V{ } clone V{ } clone + f V{ } clone f irc-client construct-boa ; + +USE: prettyprint +TUPLE: irc-listener channel ; +! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? ) +! tener la opción de dejar de correr un client?? +: ( quot -- irc-listener ) + irc-listener construct-boa swap + [ + [ channel>> '[ , from ] ] + [ '[ , curry f spawn drop ] ] + bi* compose "irc-listener" spawn-server-linked drop + ] [ drop ] 2bi ; + +! TUPLE: irc-channel name topic members log attributes ; +! C: irc-channel ! the delegate of all irc messages -TUPLE: irc-message timestamp ; +TUPLE: irc-message line prefix command parameters trailing timestamp ; C: irc-message ! "irc message" objects -TUPLE: logged-in name text ; +TUPLE: logged-in < irc-message name ; C: logged-in -TUPLE: ping name ; +TUPLE: ping < irc-message ; C: ping -TUPLE: join name channel ; -C: join +TUPLE: join_ < irc-message ; +C: join_ -TUPLE: part name channel text ; +TUPLE: part < irc-message name channel ; C: part -TUPLE: quit text ; +TUPLE: quit ; C: quit -TUPLE: privmsg name text ; +TUPLE: privmsg < irc-message name ; C: privmsg -TUPLE: kick channel er ee text ; +TUPLE: kick < irc-message channel who ; C: kick -TUPLE: roomlist channel names ; +TUPLE: roomlist < irc-message channel names ; C: roomlist -TUPLE: nick-in-use name ; +TUPLE: nick-in-use < irc-message name ; C: nick-in-use -TUPLE: notice type text ; +TUPLE: notice < irc-message type ; C: notice -TUPLE: mode name channel mode text ; +TUPLE: mode < irc-message name channel mode ; C: mode -! TUPLE: members -TUPLE: unhandled text ; +TUPLE: unhandled < irc-message ; C: unhandled -! "control message" objects -TUPLE: command sender ; -TUPLE: service predicate quot enabled? ; -TUPLE: chat-command from to text ; -TUPLE: join-command channel password ; -TUPLE: part-command channel text ; - SYMBOL: irc-client -: irc-stream> ( -- stream ) irc-client get irc-client-stream ; -: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ; +: irc-client> ( -- irc-client ) irc-client get ; +: irc-stream> ( -- stream ) irc-client> stream>> ; + +: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; + : parse-name ( string -- string ) - trim-: "!" split first ; -: irc-split ( string -- seq ) - 1 swap [ [ CHAR: : = ] find* ] keep - swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-: - " " split r> [ 1array append ] when* ; + remove-heading-: "!" split-at-first drop ; + +: sender>> ( obj -- string ) + prefix>> parse-name ; + +: split-prefix ( string -- string/f string ) + dup ":" head? + [ remove-heading-: " " split1 ] + [ f swap ] + if ; + +: split-trailing ( string -- string string/f ) + ":" split1 ; + +: string>irc-message ( string -- object ) + dup split-prefix split-trailing + [ [ blank? ] trim " " split unclip swap ] dip + now ; + : me? ( name -- ? ) - irc-client get irc-client-nick nick-name = ; + irc-client> nick>> name>> = ; : irc-write ( s -- ) irc-stream> stream-write ; @@ -89,123 +132,155 @@ SYMBOL: irc-client : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; -: nick ( nick -- ) +! Irc commands + +: NICK ( nick -- ) "NICK " irc-write irc-print ; -: login ( nick -- ) - dup nick +: LOGIN ( nick -- ) + dup NICK "USER " irc-write irc-write " hostname servername :irc.factor" irc-print ; -: connect* ( server port -- ) - utf8 irc-client get set-irc-client-stream ; +: CONNECT ( server port -- stream ) + latin1 ; -: connect ( server -- ) 6667 connect* ; - -: join ( channel password -- ) +: JOIN ( channel password -- ) "JOIN " irc-write - [ >r " :" r> 3append ] when* irc-print ; + [ " :" swap 3append ] when* irc-print ; -: part ( channel text -- ) - >r "PART " irc-write irc-write r> +: PART ( channel text -- ) + [ "PART " irc-write irc-write ] dip " :" irc-write irc-print ; -: say ( line nick -- ) - "PRIVMSG " irc-write irc-write " :" irc-write irc-print ; +: KICK ( channel who -- ) + [ "KICK " irc-write irc-write ] dip + " " irc-write irc-print ; + +: PRIVMSG ( nick line -- ) + [ "PRIVMSG " irc-write irc-write ] dip + " :" irc-write irc-print ; -: quit ( text -- ) +: SAY ( nick line -- ) + PRIVMSG ; + +: ACTION ( nick line -- ) + [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ; + +: QUIT ( text -- ) "QUIT :" irc-write irc-print ; +: join-channel ( channel-profile -- ) + [ name>> ] keep password>> JOIN ; +: irc-connect ( irc-client -- ) + [ profile>> [ server>> ] keep port>> CONNECT ] keep + swap >>stream t >>is-running drop ; + GENERIC: handle-irc ( obj -- ) M: object handle-irc ( obj -- ) - "Unhandled irc object" print drop ; + drop ; M: logged-in handle-irc ( obj -- ) - logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep - - irc-client-profile profile-default-channels - [ - [ channel-profile-name ] keep - channel-profile-password join - ] each ; + name>> + irc-client> [ nick>> swap >>name drop ] keep + profile>> default-channels>> [ join-channel ] each ; M: ping handle-irc ( obj -- ) "PONG " irc-write - ping-name irc-print ; + trailing>> irc-print ; M: nick-in-use handle-irc ( obj -- ) - nick-in-use-name "_" append nick ; + name>> "_" append NICK ; -: delegate-timestamp ( obj -- obj ) - now over set-delegate ; +: parse-irc-line ( string -- message ) + string>irc-message + dup command>> { + { "PING" [ \ ping ] } + { "NOTICE" [ \ notice ] } + { "001" [ \ logged-in ] } + { "433" [ \ nick-in-use ] } + { "JOIN" [ \ join_ ] } + { "PART" [ \ part ] } + { "PRIVMSG" [ \ privmsg ] } + { "QUIT" [ \ quit ] } + { "MODE" [ \ mode ] } + { "KICK" [ \ kick ] } + [ drop \ unhandled ] + } case + [ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ; -MATCH-VARS: ?name ?name2 ?channel ?text ?mode ; -SYMBOL: line -: match-irc ( string -- ) - dup line set - dup print flush - irc-split - { - { { "PING" ?name } - [ ?name ] } - { { ?name "001" ?name2 ?text } - [ ?name2 ?text ] } - { { ?name "433" _ ?name2 "Nickname is already in use." } - [ ?name2 ] } +! Reader +: handle-reader-message ( irc-client irc-message -- ) + dup handle-irc swap stream-channel>> to ; - { { ?name "JOIN" ?channel } - [ ?name ?channel ] } - { { ?name "PART" ?channel ?text } - [ ?name ?channel ?text ] } - { { ?name "PRIVMSG" ?channel ?text } - [ ?name ?channel ?text ] } - { { ?name "QUIT" ?text } - [ ?name ?text ] } +: reader-loop ( irc-client -- ) + dup stream>> stream-readln [ + dup print parse-irc-line handle-reader-message + ] [ + f >>is-running + dup stream>> dispose + irc-end over controller-channel>> to + stream-channel>> irc-end swap to + ] if* ; - { { "NOTICE" ?name ?text } - [ ?name ?text ] } - { { ?name "MODE" ?channel ?mode ?text } - [ ?name ?channel ?mode ?text ] } - { { ?name "KICK" ?channel ?name2 ?text } - [ ?channel ?name ?name2 ?text ] } +! Controller commands +GENERIC: handle-command ( obj -- ) - ! { { ?name "353" ?name2 _ ?channel ?text } - ! [ ?text ?channel ?name2 make-member-list ] } - { _ [ line get ] } - } match-cond - delegate-timestamp handle-irc flush ; +M: object handle-command ( obj -- ) + . ; -: irc-loop ( -- ) - irc-stream> stream-readln - [ match-irc irc-loop ] when* ; +TUPLE: send-message to text ; +C: send-message +M: send-message handle-command ( obj -- ) + dup to>> swap text>> SAY ; +TUPLE: send-action to text ; +C: send-action +M: send-action handle-command ( obj -- ) + dup to>> swap text>> ACTION ; + +TUPLE: send-quit text ; +C: send-quit +M: send-quit handle-command ( obj -- ) + text>> QUIT ; + +: irc-listen ( irc-client quot -- ) + [ listeners>> ] [ ] bi* swap push ; + +! Controller loop +: controller-loop ( irc-client -- ) + controller-channel>> from handle-command ; + +! Multiplexer +: multiplex-message ( irc-client message -- ) + swap listeners>> [ channel>> ] map + [ '[ , , to ] "message" spawn drop ] each-with ; + +: multiplexer-loop ( irc-client -- ) + dup stream-channel>> from multiplex-message ; + +! process looping and starting +: (spawn-irc-loop) ( irc-client quot name -- ) + [ over >r curry r> '[ @ , is-running>> ] ] dip + spawn-server-linked drop ; + +: spawn-irc-loop ( irc-client quot name -- ) + '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ] + f spawn drop ; + +: spawn-irc ( irc-client -- ) + [ [ reader-loop ] "reader-loop" spawn-irc-loop ] + [ [ controller-loop ] "controller-loop" spawn-irc-loop ] + [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ] + tri ; + : do-irc ( irc-client -- ) - dup irc-client set - dup irc-client-profile profile-server - over irc-client-profile profile-port connect* - dup irc-client-profile profile-nickname login - [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ; - -: with-infinite-loop ( quot timeout -- quot timeout ) - "looping" print flush - over [ drop ] recover dup sleep with-infinite-loop ; - -: start-irc ( irc-client -- ) - ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ; - [ do-irc ] curry 3000 with-infinite-loop ; - - -! For testing -: make-factorbot - "irc.freenode.org" 6667 "factorbot" f - [ - "#concatenative-flood" f f , - ] { } make - f V{ } clone V{ } clone - f f f ; - -: test-factorbot - make-factorbot start-irc ; - + irc-client [ + irc-client> + [ irc-connect ] + [ profile>> nickname>> LOGIN ] + [ spawn-irc ] + tri + ] with-variable ; \ No newline at end of file From 2cebf7e9e59790ba5a9531e33b4c6509f35f9c4d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 18:51:56 -0500 Subject: [PATCH 20/46] Improve multi-methods: multi-var hooks --- .../multi-methods/multi-methods-tests.factor | 98 ------ extra/multi-methods/multi-methods.factor | 309 ++++++++++-------- extra/multi-methods/tests/canonicalize.factor | 66 ++++ extra/multi-methods/tests/definitions.factor | 37 +++ extra/multi-methods/tests/legacy.factor | 10 + extra/multi-methods/tests/syntax.factor | 58 ++++ .../tests/topological-sort.factor | 18 + 7 files changed, 357 insertions(+), 239 deletions(-) delete mode 100755 extra/multi-methods/multi-methods-tests.factor create mode 100644 extra/multi-methods/tests/canonicalize.factor create mode 100644 extra/multi-methods/tests/definitions.factor create mode 100644 extra/multi-methods/tests/legacy.factor create mode 100644 extra/multi-methods/tests/syntax.factor create mode 100644 extra/multi-methods/tests/topological-sort.factor diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor deleted file mode 100755 index 8910e64092..0000000000 --- a/extra/multi-methods/multi-methods-tests.factor +++ /dev/null @@ -1,98 +0,0 @@ -IN: multi-methods.tests -USING: multi-methods tools.test kernel math arrays sequences -prettyprint strings classes hashtables assocs namespaces -debugger continuations ; - -[ { 1 2 3 4 5 6 } ] [ - { 6 4 5 1 3 2 } [ <=> ] topological-sort -] unit-test - -[ -1 ] [ - { fixnum array } { number sequence } classes< -] unit-test - -[ 0 ] [ - { number sequence } { number sequence } classes< -] unit-test - -[ 1 ] [ - { object object } { number sequence } classes< -] unit-test - -[ - { - { { object integer } [ 1 ] } - { { object object } [ 2 ] } - { { POSTPONE: f POSTPONE: f } [ 3 ] } - } -] [ - { - { { integer } [ 1 ] } - { { } [ 2 ] } - { { f f } [ 3 ] } - } congruify-methods -] unit-test - -GENERIC: first-test - -[ t ] [ \ first-test generic? ] unit-test - -MIXIN: thing - -TUPLE: paper ; INSTANCE: paper thing -TUPLE: scissors ; INSTANCE: scissors thing -TUPLE: rock ; INSTANCE: rock thing - -GENERIC: beats? - -METHOD: beats? { paper scissors } t ; -METHOD: beats? { scissors rock } t ; -METHOD: beats? { rock paper } t ; -METHOD: beats? { thing thing } f ; - -: play ( obj1 obj2 -- ? ) beats? 2nip ; - -[ { } 3 play ] must-fail -[ t ] [ error get no-method? ] unit-test -[ ] [ error get error. ] unit-test -[ t ] [ T{ paper } T{ scissors } play ] unit-test -[ f ] [ T{ scissors } T{ paper } play ] unit-test - -[ t ] [ { beats? paper scissors } method-spec? ] unit-test -[ ] [ { beats? paper scissors } see ] unit-test - -GENERIC: legacy-test - -M: integer legacy-test sq ; -M: string legacy-test " hey" append ; - -[ 25 ] [ 5 legacy-test ] unit-test -[ "hello hey" ] [ "hello" legacy-test ] unit-test - -SYMBOL: some-var - -HOOK: hook-test some-var - -[ t ] [ \ hook-test hook-generic? ] unit-test - -METHOD: hook-test { array array } reverse ; -METHOD: hook-test { array } class ; -METHOD: hook-test { hashtable number } assoc-size ; - -{ 1 2 3 } some-var set -[ { f t t } ] [ { t t f } hook-test ] unit-test -[ fixnum ] [ 3 hook-test ] unit-test -5.0 some-var set -[ 0 ] [ H{ } hook-test ] unit-test - -MIXIN: busted - -TUPLE: busted-1 ; -TUPLE: busted-2 ; INSTANCE: busted-2 busted -TUPLE: busted-3 ; - -GENERIC: busted-sort - -METHOD: busted-sort { busted-1 busted-2 } ; -METHOD: busted-sort { busted-2 busted-3 } ; -METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 115432b14d..0276e1422c 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -3,13 +3,74 @@ USING: kernel math sequences vectors classes classes.algebra combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib -debugger io compiler.units kernel.private effects ; +debugger io compiler.units kernel.private effects accessors +hashtables sorting shuffle ; IN: multi-methods -GENERIC: generic-prologue ( combination -- quot ) +! PART I: Converting hook specializers +: canonicalize-specializer-0 ( specializer -- specializer' ) + [ \ f or ] map ; -GENERIC: method-prologue ( combination -- quot ) +SYMBOL: args +SYMBOL: hooks + +SYMBOL: total + +: canonicalize-specializer-1 ( specializer -- specializer' ) + [ + [ class? ] subset + [ length [ 1+ neg ] map ] keep zip + [ length args [ max ] change ] keep + ] + [ + [ pair? ] subset + [ keys [ hooks get push-new ] each ] keep + ] bi append ; + +: canonicalize-specializer-2 ( specializer -- specializer' ) + [ + >r + { + { [ dup integer? ] [ ] } + { [ dup word? ] [ hooks get index ] } + } cond args get + r> + ] assoc-map ; + +: canonicalize-specializer-3 ( specializer -- specializer' ) + >r total get object dup r> update ; + +: canonicalize-specializers ( methods -- methods' hooks ) + [ + [ >r canonicalize-specializer-0 r> ] assoc-map + + 0 args set + V{ } clone hooks set + + [ >r canonicalize-specializer-1 r> ] assoc-map + + hooks [ natural-sort ] change + + [ >r canonicalize-specializer-2 r> ] assoc-map + + args get hooks get length + total set + + [ >r canonicalize-specializer-3 r> ] assoc-map + + hooks get + ] with-scope ; + +: drop-n-quot ( n -- quot ) \ drop >quotation ; + +: prepare-method ( method n -- quot ) + [ 1quotation ] [ drop-n-quot ] bi* prepend ; + +: prepare-methods ( methods -- methods' prologue ) + canonicalize-specializers + [ length [ prepare-method ] curry assoc-map ] keep + [ [ get ] curry ] map concat [ ] like ; + +! Part II: Topologically sorting specializers : maximal-element ( seq quot -- n elt ) dupd [ swapd [ call 0 < ] 2curry subset empty? @@ -32,6 +93,10 @@ GENERIC: method-prologue ( combination -- quot ) } cond 2nip ] 2map [ zero? not ] find nip 0 or ; +: sort-methods ( alist -- alist' ) + [ [ first ] bi@ classes< ] topological-sort ; + +! PART III: Creating dispatch quotation : picker ( n -- quot ) { { 0 [ [ dup ] ] } @@ -52,209 +117,171 @@ GENERIC: method-prologue ( combination -- quot ) unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; +: multi-dispatch-quot ( methods generic -- quot ) + "default-multi-method" word-prop 1quotation swap + [ >r multi-predicate r> ] assoc-map reverse alist>quot ; + +! Generic words +PREDICATE: generic < word + "multi-methods" word-prop >boolean ; + : methods ( word -- alist ) "multi-methods" word-prop >alist ; -: make-method-def ( quot classes generic -- quot ) +: make-generic ( generic -- quot ) [ - swap [ declare ] curry % - "multi-combination" word-prop method-prologue % - % + [ methods prepare-methods % sort-methods ] keep + multi-dispatch-quot % ] [ ] make ; -TUPLE: method word def classes generic loc ; +: update-generic ( word -- ) + dup make-generic define ; +! Methods PREDICATE: method-body < word - "multi-method" word-prop >boolean ; + "multi-method-generic" word-prop >boolean ; M: method-body stack-effect - "multi-method" word-prop method-generic stack-effect ; + "multi-method-generic" word-prop stack-effect ; M: method-body crossref? drop t ; -: method-word-name ( classes generic -- string ) +: method-word-name ( specializer generic -- string ) + [ word-name % "-" % unparse % ] "" make ; + +: method-word-props ( specializer generic -- assoc ) [ - word-name % - "-(" % [ "," % ] [ word-name % ] interleave ")" % - ] "" make ; + "multi-method-generic" set + "multi-method-specializer" set + ] H{ } make-assoc ; -: ( quot classes generic -- word ) - #! We xref here because the "multi-method" word-prop isn't - #! set yet so crossref? yields f. - [ make-method-def ] 2keep +: ( specializer generic -- word ) + [ method-word-props ] 2keep method-word-name f - dup rot define - dup xref ; + [ set-word-props ] keep ; -: ( quot classes generic -- method ) - [ ] 3keep f \ method construct-boa - dup method-word over "multi-method" set-word-prop ; +: with-methods ( word quot -- ) + over >r >r "multi-methods" word-prop + r> call r> update-generic ; inline + +: reveal-method ( method classes generic -- ) + [ set-at ] with-methods ; + +: method ( classes word -- method ) + "multi-methods" word-prop at ; + +: create-method ( classes generic -- method ) + 2dup method dup [ + 2nip + ] [ + drop [ dup ] 2keep reveal-method + ] if ; TUPLE: no-method arguments generic ; : no-method ( argument-count generic -- * ) >r narray r> \ no-method construct-boa throw ; inline -: argument-count ( methods -- n ) - dup assoc-empty? [ drop 0 ] [ - keys [ length ] map supremum - ] if ; - -: multi-dispatch-quot ( methods generic -- quot ) - >r [ - [ - >r multi-predicate r> method-word 1quotation - ] assoc-map - ] keep argument-count - r> [ no-method ] 2curry - swap reverse alist>quot ; - -: congruify-methods ( alist -- alist' ) - dup argument-count [ - swap >r object pad-left [ \ f or ] map r> - ] curry assoc-map ; - -: sorted-methods ( alist -- alist' ) - [ [ first ] bi@ classes< ] topological-sort ; - : niceify-method [ dup \ f eq? [ drop f ] when ] map ; M: no-method error. "Type check error" print nl - "Generic word " write dup no-method-generic pprint + "Generic word " write dup generic>> pprint " does not have a method applicable to inputs:" print - dup no-method-arguments short. + dup arguments>> short. nl "Inputs have signature:" print - dup no-method-arguments [ class ] map niceify-method . + dup arguments>> [ class ] map niceify-method . nl - "Defined methods in topological order: " print - no-method-generic - methods congruify-methods sorted-methods keys + "Available methods: " print + generic>> methods keys [ niceify-method ] map stack. ; -TUPLE: standard-combination ; +: make-default-method ( generic -- quot ) + [ 0 swap no-method ] curry ; -M: standard-combination method-prologue drop [ ] ; +: ( generic -- method ) + [ { } swap ] keep + [ drop ] [ make-default-method define ] 2bi ; -M: standard-combination generic-prologue drop [ ] ; +: define-default-method ( generic -- ) + dup "default-multi-method" set-word-prop ; -: make-generic ( generic -- quot ) - dup "multi-combination" word-prop generic-prologue swap - [ methods congruify-methods sorted-methods ] keep - multi-dispatch-quot append ; - -TUPLE: hook-combination var ; - -M: hook-combination method-prologue - drop [ drop ] ; - -M: hook-combination generic-prologue - hook-combination-var [ get ] curry ; - -: update-generic ( word -- ) - dup make-generic define ; - -: define-generic ( word combination -- ) - over "multi-combination" word-prop over = [ - 2drop - ] [ - dupd "multi-combination" set-word-prop - dup H{ } clone "multi-methods" set-word-prop - update-generic - ] if ; - -: define-standard-generic ( word -- ) - T{ standard-combination } define-generic ; - -: GENERIC: - CREATE define-standard-generic ; parsing - -: define-hook-generic ( word var -- ) - hook-combination construct-boa define-generic ; - -: HOOK: - CREATE scan-word define-hook-generic ; parsing - -: method ( classes word -- method ) - "multi-methods" word-prop at ; - -: with-methods ( word quot -- ) - over >r >r "multi-methods" word-prop - r> call r> update-generic ; inline - -: define-method ( quot classes generic -- ) - >r [ bootstrap-word ] map r> - [ ] 2keep - [ set-at ] with-methods ; - -: forget-method ( classes generic -- ) +: forget-method ( specializer generic -- ) [ delete-at ] with-methods ; : method>spec ( method -- spec ) - dup method-classes swap method-generic prefix ; + [ "multi-method-specializer" word-prop ] + [ "multi-method-generic" word-prop ] bi prefix ; + +: define-generic ( word -- ) + dup "multi-methods" word-prop [ + drop + ] [ + [ H{ } clone "multi-methods" set-word-prop ] + [ define-default-method ] + [ update-generic ] + tri + ] if ; + +! Syntax +: GENERIC: + CREATE define-generic ; parsing : parse-method ( -- quot classes generic ) - parse-definition dup 2 tail over second rot first ; + parse-definition [ 2 tail ] [ second ] [ first ] tri ; -: METHOD: - location - >r parse-method [ define-method ] 2keep prefix r> - remember-definition ; parsing +: create-method-in ( specializer generic -- method ) + create-method dup save-location f set-word ; + +: CREATE-METHOD + scan-word scan-object swap create-method-in ; + +: (METHOD:) CREATE-METHOD parse-definition ; + +: METHOD: (METHOD:) define ; parsing ! For compatibility : M: - scan-word 1array scan-word parse-definition - -rot define-method ; parsing + scan-word 1array scan-word create-method-in + parse-definition + define ; parsing ! Definition protocol. We qualify core generics here USE: qualified QUALIFIED: syntax -PREDICATE: generic < word - "multi-combination" word-prop >boolean ; +syntax:M: generic definer drop \ GENERIC: f ; -PREDICATE: standard-generic < word - "multi-combination" word-prop standard-combination? ; - -PREDICATE: hook-generic < word - "multi-combination" word-prop hook-combination? ; - -syntax:M: standard-generic definer drop \ GENERIC: f ; - -syntax:M: standard-generic definition drop f ; - -syntax:M: hook-generic definer drop \ HOOK: f ; - -syntax:M: hook-generic definition drop f ; - -syntax:M: hook-generic synopsis* - dup definer. - dup seeing-word - dup pprint-word - dup "multi-combination" word-prop - hook-combination-var pprint-word stack-effect. ; +syntax:M: generic definition drop f ; PREDICATE: method-spec < array unclip generic? >r [ class? ] all? r> and ; syntax:M: method-spec where - dup unclip method [ method-loc ] [ second where ] ?if ; + dup unclip method [ ] [ first ] ?if where ; syntax:M: method-spec set-where - unclip method set-method-loc ; + unclip method set-where ; syntax:M: method-spec definer - drop \ METHOD: \ ; ; + unclip method definer ; syntax:M: method-spec definition - unclip method dup [ method-def ] when ; + unclip method definition ; syntax:M: method-spec synopsis* - dup definer. - unclip pprint* pprint* ; + unclip method synopsis* ; syntax:M: method-spec forget* - unclip forget-method ; + unclip method forget* ; + +syntax:M: method-body definer + drop \ METHOD: \ ; ; + +syntax:M: method-body synopsis* + dup definer. + [ "multi-method-generic" word-prop pprint-word ] + [ "multi-method-specializer" word-prop pprint* ] bi ; diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor new file mode 100644 index 0000000000..d5baf4914c --- /dev/null +++ b/extra/multi-methods/tests/canonicalize.factor @@ -0,0 +1,66 @@ +IN: multi-methods.tests +USING: multi-methods tools.test math sequences namespaces system +kernel strings ; + +[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test + +: setup-canon-test + 0 args set + V{ } clone hooks set ; + +: canon-test-1 + { integer { cpu x86 } sequence } canonicalize-specializer-1 ; + +[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [ + [ + setup-canon-test + canon-test-1 + ] with-scope +] unit-test + +[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [ + [ + setup-canon-test + canon-test-1 + canonicalize-specializer-2 + ] with-scope +] unit-test + +[ { integer sequence x86 } ] [ + [ + setup-canon-test + canon-test-1 + canonicalize-specializer-2 + args get hooks get length + total set + canonicalize-specializer-3 + ] with-scope +] unit-test + +: example-1 + { + { { { cpu x86 } { os linux } } "a" } + { { { cpu ppc } } "b" } + { { string { os windows } } "c" } + } ; + +[ + { + { { object x86 linux } "a" } + { { object ppc object } "b" } + { { string object windows } "c" } + } + V{ cpu os } +] [ + example-1 canonicalize-specializers +] unit-test + +[ + { + { { object x86 linux } [ drop drop "a" ] } + { { object ppc object } [ drop drop "b" ] } + { { string object windows } [ drop drop "c" ] } + } + [ \ cpu get \ os get ] +] [ + example-1 prepare-methods +] unit-test diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor new file mode 100644 index 0000000000..60ddd32875 --- /dev/null +++ b/extra/multi-methods/tests/definitions.factor @@ -0,0 +1,37 @@ +IN: multi-methods.tests +USING: multi-methods tools.test math sequences namespaces system +kernel strings words compiler.units quotations ; + +\ GENERIC: must-infer +\ create-method-in must-infer +\ define-default-method must-infer + +DEFER: fake +\ fake H{ } clone "multi-methods" set-word-prop + +[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test + +[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ] +[ { } \ fake method-word-props ] unit-test + +[ t ] [ { } \ fake method-body? ] unit-test + +[ + [ ] [ \ fake define-default-method ] unit-test + + [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test + + [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test + + [ t ] [ \ fake make-generic quotation? ] unit-test + + [ ] [ \ fake update-generic ] unit-test + + DEFER: testing + + [ ] [ \ testing define-generic ] unit-test + + [ t ] [ \ testing generic? ] unit-test + + [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test +] with-compilation-unit diff --git a/extra/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor new file mode 100644 index 0000000000..f4bd0a00b2 --- /dev/null +++ b/extra/multi-methods/tests/legacy.factor @@ -0,0 +1,10 @@ +IN: multi-methods.tests +USING: math strings sequences tools.test ; + +GENERIC: legacy-test + +M: integer legacy-test sq ; +M: string legacy-test " hey" append ; + +[ 25 ] [ 5 legacy-test ] unit-test +[ "hello hey" ] [ "hello" legacy-test ] unit-test diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor new file mode 100644 index 0000000000..5e2e86d04b --- /dev/null +++ b/extra/multi-methods/tests/syntax.factor @@ -0,0 +1,58 @@ +IN: multi-methods.tests +USING: multi-methods tools.test math sequences namespaces system +kernel strings definitions prettyprint debugger arrays +hashtables continuations classes assocs ; + +GENERIC: first-test + +[ t ] [ \ first-test generic? ] unit-test + +MIXIN: thing + +SINGLETON: paper INSTANCE: paper thing +SINGLETON: scissors INSTANCE: scissors thing +SINGLETON: rock INSTANCE: rock thing + +GENERIC: beats? + +METHOD: beats? { paper scissors } t ; +METHOD: beats? { scissors rock } t ; +METHOD: beats? { rock paper } t ; +METHOD: beats? { thing thing } f ; + +: play ( obj1 obj2 -- ? ) beats? 2nip ; + +[ { } 3 play ] must-fail +[ t ] [ error get no-method? ] unit-test +[ ] [ error get error. ] unit-test +[ t ] [ paper scissors play ] unit-test +[ f ] [ scissors paper play ] unit-test + +[ t ] [ { beats? paper scissors } method-spec? ] unit-test +[ ] [ { beats? paper scissors } see ] unit-test + +SYMBOL: some-var + +GENERIC: hook-test + +METHOD: hook-test { array { some-var array } } reverse ; +METHOD: hook-test { { some-var array } } class ; +METHOD: hook-test { hashtable { some-var number } } assoc-size ; + +{ 1 2 3 } some-var set +[ { f t t } ] [ { t t f } hook-test ] unit-test +[ fixnum ] [ 3 hook-test ] unit-test +5.0 some-var set +[ 0 ] [ H{ } hook-test ] unit-test + +MIXIN: busted + +TUPLE: busted-1 ; +TUPLE: busted-2 ; INSTANCE: busted-2 busted +TUPLE: busted-3 ; + +GENERIC: busted-sort + +METHOD: busted-sort { busted-1 busted-2 } ; +METHOD: busted-sort { busted-2 busted-3 } ; +METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor new file mode 100644 index 0000000000..ed8bece4ba --- /dev/null +++ b/extra/multi-methods/tests/topological-sort.factor @@ -0,0 +1,18 @@ +IN: multi-methods.tests +USING: kernel multi-methods tools.test math arrays sequences ; + +[ { 1 2 3 4 5 6 } ] [ + { 6 4 5 1 3 2 } [ <=> ] topological-sort +] unit-test + +[ -1 ] [ + { fixnum array } { number sequence } classes< +] unit-test + +[ 0 ] [ + { number sequence } { number sequence } classes< +] unit-test + +[ 1 ] [ + { object object } { number sequence } classes< +] unit-test From a82794a71910cfaea3471a95db65e8d101a95557 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 19:12:48 -0500 Subject: [PATCH 21/46] Fixing error reporting --- extra/multi-methods/multi-methods.factor | 35 ++++++++------------ extra/multi-methods/tests/definitions.factor | 5 +-- extra/multi-methods/tests/syntax.factor | 8 ++++- 3 files changed, 22 insertions(+), 26 deletions(-) diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 0276e1422c..8f9e34b1fb 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -117,9 +117,18 @@ SYMBOL: total unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; +: argument-count ( methods -- n ) + keys 0 [ length max ] reduce ; + +ERROR: no-method arguments generic ; + +: make-default-method ( methods generic -- quot ) + >r argument-count r> [ >r narray r> no-method ] 2curry ; + : multi-dispatch-quot ( methods generic -- quot ) - "default-multi-method" word-prop 1quotation swap - [ >r multi-predicate r> ] assoc-map reverse alist>quot ; + [ make-default-method ] + [ drop [ >r multi-predicate r> ] assoc-map reverse ] + 2bi alist>quot ; ! Generic words PREDICATE: generic < word @@ -178,11 +187,6 @@ M: method-body crossref? drop [ dup ] 2keep reveal-method ] if ; -TUPLE: no-method arguments generic ; - -: no-method ( argument-count generic -- * ) - >r narray r> \ no-method construct-boa throw ; inline - : niceify-method [ dup \ f eq? [ drop f ] when ] map ; M: no-method error. @@ -196,18 +200,8 @@ M: no-method error. dup arguments>> [ class ] map niceify-method . nl "Available methods: " print - generic>> methods keys - [ niceify-method ] map stack. ; - -: make-default-method ( generic -- quot ) - [ 0 swap no-method ] curry ; - -: ( generic -- method ) - [ { } swap ] keep - [ drop ] [ make-default-method define ] 2bi ; - -: define-default-method ( generic -- ) - dup "default-multi-method" set-word-prop ; + generic>> methods canonicalize-specializers drop sort-methods + keys [ niceify-method ] map stack. ; : forget-method ( specializer generic -- ) [ delete-at ] with-methods ; @@ -221,9 +215,8 @@ M: no-method error. drop ] [ [ H{ } clone "multi-methods" set-word-prop ] - [ define-default-method ] [ update-generic ] - tri + bi ] if ; ! Syntax diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 60ddd32875..fea8f0c402 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -4,7 +4,6 @@ kernel strings words compiler.units quotations ; \ GENERIC: must-infer \ create-method-in must-infer -\ define-default-method must-infer DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop @@ -17,11 +16,9 @@ DEFER: fake [ t ] [ { } \ fake method-body? ] unit-test [ - [ ] [ \ fake define-default-method ] unit-test - [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test - [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test + [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test [ t ] [ \ fake make-generic quotation? ] unit-test diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor index 5e2e86d04b..597a1cebeb 100644 --- a/extra/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,7 +1,7 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays -hashtables continuations classes assocs ; +hashtables continuations classes assocs accessors ; GENERIC: first-test @@ -25,6 +25,7 @@ METHOD: beats? { thing thing } f ; [ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test [ ] [ error get error. ] unit-test +[ { { } 3 } ] [ error get arguments>> ] unit-test [ t ] [ paper scissors play ] unit-test [ f ] [ scissors paper play ] unit-test @@ -45,6 +46,11 @@ METHOD: hook-test { hashtable { some-var number } } assoc-size ; 5.0 some-var set [ 0 ] [ H{ } hook-test ] unit-test +"error" some-var set +[ H{ } hook-test ] must-fail +[ t ] [ error get no-method? ] unit-test +[ { H{ } "error" } ] [ error get arguments>> ] unit-test + MIXIN: busted TUPLE: busted-1 ; From 9c19ade9810857c98cf41228f59982736ef53d5b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 19:43:54 -0500 Subject: [PATCH 22/46] Fix library path --- extra/db/postgresql/ffi/ffi.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 7f428bb6b6..ee5ba622e5 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,8 +6,7 @@ IN: db.postgresql.ffi << "postgresql" { { [ os winnt? ] [ "libpq.dll" ] } - { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] } - ! { [ os macosx? ] [ "libpq.dylib" ] } + { [ os macosx? ] [ "libpq.dylib" ] } { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> From 0dd8e462c6dc31065dcdee6d33913edd3a3688e5 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 9 Apr 2008 12:52:49 +1200 Subject: [PATCH 23/46] Minor peg refactorings --- extra/peg/peg.factor | 75 +++++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 35 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3b1d408ae2..7390c15684 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -30,6 +30,9 @@ SYMBOL: fail SYMBOL: lrstack SYMBOL: heads +: failed? ( obj -- ? ) + fail = ; + : delegates ( -- cache ) \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; @@ -66,21 +69,18 @@ C: peg-head #! that maps the position to the parser result. id>> packrat get [ drop H{ } clone ] cache ; +: process-rule-result ( p result -- result ) + [ + nip [ ast>> ] [ remaining>> ] bi input-from pos set + ] [ + pos set fail + ] if* ; + : eval-rule ( rule -- ast ) #! Evaluate a rule, return an ast resulting from it. #! Return fail if the rule failed. The rule has #! stack effect ( input -- parse-result ) - pos get swap - execute -! drop f f - [ - nip - [ ast>> ] [ remaining>> ] bi - input-from pos set - ] [ - pos set - fail - ] if* ; inline + pos get swap execute process-rule-result ; inline : memo ( pos rule -- memo-entry ) #! Return the result from the memo cache. @@ -90,21 +90,29 @@ C: peg-head #! Store an entry in the cache rule-parser input-cache set-at ; -:: (grow-lr) ( r p m h -- ) - p pos set - h involved-set>> clone h (>>eval-set) +: update-m ( ast m -- ) + swap >>ans pos get >>pos drop ; + +: stop-growth? ( ast m -- ? ) + [ failed? pos get ] dip + pos>> <= or ; + +: setup-growth ( h p -- ) + pos set dup involved-set>> clone >>eval-set drop ; + +:: (grow-lr) ( h p r m -- ) + h p setup-growth r eval-rule - dup fail = pos get m pos>> <= or [ + dup m stop-growth? [ drop ] [ - m (>>ans) - pos get m (>>pos) - r p m h (grow-lr) + m update-m + h p r m (grow-lr) ] if ; inline -:: grow-lr ( r p m h -- ast ) +:: grow-lr ( h p r m -- ast ) h p heads get set-at - r p m h (grow-lr) + h p r m (grow-lr) p heads get delete-at m pos>> pos set m ans>> ; inline @@ -128,10 +136,10 @@ C: peg-head | h rule>> r eq? [ m ans>> seed>> m (>>ans) - m ans>> fail = [ + m ans>> failed? [ fail ] [ - r p m h grow-lr + h p r m grow-lr ] if ] [ m ans>> seed>> @@ -150,8 +158,7 @@ C: peg-head r h eval-set>> member? [ h [ r swap remove ] change-eval-set drop r eval-rule - m (>>ans) - pos get m (>>pos) + m update-m m ] [ m @@ -207,20 +214,18 @@ C: peg-head GENERIC: (compile) ( parser -- quot ) +: execute-parser ( word -- result ) + pos get apply-rule dup failed? [ + drop f + ] [ + input-slice swap + ] if ; inline -:: parser-body ( parser -- quot ) +: parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - [let* | rule [ gensym dup parser (compile) 0 1 define-declared dup parser "peg" set-word-prop ] - | - [ - rule pos get apply-rule dup fail = [ - drop f - ] [ - input-slice swap - ] if - ] - ] ; + gensym 2dup swap (compile) 0 1 define-declared swap dupd "peg" set-word-prop + [ execute-parser ] curry ; : compiled-parser ( parser -- word ) #! Look to see if the given parser has been compiled. From 411a13756395cbf142d7212868cc8512eff50aff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 21:29:37 -0500 Subject: [PATCH 24/46] Fix unit test --- extra/multi-methods/tests/definitions.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index fea8f0c402..c112a67776 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -29,6 +29,4 @@ DEFER: fake [ ] [ \ testing define-generic ] unit-test [ t ] [ \ testing generic? ] unit-test - - [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test ] with-compilation-unit From 6c5935a3b0e604afa7606384f66183bbfc87e577 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Apr 2008 23:08:11 -0500 Subject: [PATCH 25/46] add set-os-env, unset-os-env --- core/bootstrap/primitives.factor | 2 ++ core/inference/known-words/known-words.factor | 4 ++++ vm/os-unix.c | 15 +++++++++++++++ vm/primitives.c | 2 ++ vm/run.h | 2 ++ 5 files changed, 25 insertions(+) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 233de6f4ee..9d3c28b068 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -732,6 +732,8 @@ define-builtin { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } { "(os-envs)" "system.private" } + { "set-os-env" "system" } + { "unset-os-env" "system" } { "(set-os-envs)" "system.private" } { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 33a5da87f4..453e2460b0 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -587,6 +587,10 @@ set-primitive-effect \ (os-envs) { } { array } set-primitive-effect +\ set-os-env { string string } { } set-primitive-effect + +\ unset-os-env { string } { } set-primitive-effect + \ (set-os-envs) { array } { } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/vm/os-unix.c b/vm/os-unix.c index 74320288aa..2991cde78c 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -103,6 +103,21 @@ DEFINE_PRIMITIVE(os_envs) dpush(result); } +DEFINE_PRIMITIVE(set_os_env) +{ + char *key = unbox_char_string(); + REGISTER_C_STRING(key); + char *value = unbox_char_string(); + UNREGISTER_C_STRING(key); + setenv(key, value, 1); +} + +DEFINE_PRIMITIVE(unset_os_env) +{ + char *key = unbox_char_string(); + unsetenv(key); +} + DEFINE_PRIMITIVE(set_os_envs) { F_ARRAY *array = untag_array(dpop()); diff --git a/vm/primitives.c b/vm/primitives.c index 533fcebc9a..2906a154a2 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -182,6 +182,8 @@ void *primitives[] = { primitive_set_innermost_stack_frame_quot, primitive_call_clear, primitive_os_envs, + primitive_set_os_env, + primitive_unset_os_env, primitive_set_os_envs, primitive_resize_byte_array, primitive_resize_bit_array, diff --git a/vm/run.h b/vm/run.h index c112c5f587..e2afb08525 100755 --- a/vm/run.h +++ b/vm/run.h @@ -249,6 +249,8 @@ DECLARE_PRIMITIVE(setenv); DECLARE_PRIMITIVE(exit); DECLARE_PRIMITIVE(os_env); DECLARE_PRIMITIVE(os_envs); +DECLARE_PRIMITIVE(set_os_env); +DECLARE_PRIMITIVE(unset_os_env); DECLARE_PRIMITIVE(set_os_envs); DECLARE_PRIMITIVE(eq); DECLARE_PRIMITIVE(millis); From c19505cd844e9fb14fffadf937bdfee7d52089b4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Apr 2008 23:35:28 -0500 Subject: [PATCH 26/46] set-os-env on windows --- vm/os-windows.c | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/vm/os-windows.c b/vm/os-windows.c index 664df9e774..b3fc1c917f 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,6 +215,21 @@ void sleep_millis(DWORD msec) Sleep(msec); } +DEFINE_PRIMITIVE(set_os_env) +{ + char *key = unbox_char_string(); + REGISTER_C_STRING(key); + char *value = unbox_char_string(); + UNREGISTER_C_STRING(key); + SetEnvironmentVariable(key, value); +} + +DEFINE_PRIMITIVE(unset_os_env) +{ + char *key = unbox_char_string(); + SetEnvironmentVariable(key, f); +} + DEFINE_PRIMITIVE(set_os_envs) { not_implemented_error(); From 52bb93cf40a878577ce33ebd8f9766ffeab102cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 00:19:56 -0500 Subject: [PATCH 27/46] Working on faster refresh-all --- extra/tools/vocabs/monitor/monitor.factor | 39 +++++++++++----- extra/tools/vocabs/vocabs.factor | 57 ++++++++++++----------- 2 files changed, 56 insertions(+), 40 deletions(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 071f179676..ada539c60a 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -1,24 +1,39 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -vocabs.loader tools.vocabs namespaces continuations ; +vocabs vocabs.loader tools.vocabs namespaces continuations +sequences splitting assocs ; IN: tools.vocabs.monitor -! Use file system change monitoring to flush the tags/authors -! cache -SYMBOL: vocab-monitor +: vocab-dir>vocab-name ( path -- vocab ) + left-trim-separators right-trim-separators + { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ; -: monitor-thread ( -- ) - vocab-monitor get-global - next-change 2drop - t sources-changed? set-global reset-cache ; +: path>vocab-name ( path -- vocab ) + dup ".factor" tail? [ parent-directory ] when + dup [ vocab-dir>vocab-name ] when ; -: start-monitor-thread +: changed-vocab ( vocab -- ) + dup vocab + [ dup changed-vocabs get-global set-at ] [ drop ] if ; + +: monitor-thread ( path monitor -- ) + #! On OS X, monitors give us the full path, so we chop it + #! off if its there. + next-change drop swap ?head drop + path>vocab-name changed-vocab reset-cache ; + +: start-monitor-thread ( root -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. + (normalize-path) dup t [ monitor-thread t ] 2curry + "Vocabulary monitor" spawn-server drop ; + +: start-monitor-threads ( -- ) [ - "" resource-path t vocab-monitor set-global - [ monitor-thread t ] "Vocabulary monitor" spawn-server drop + vocab-roots get [ start-monitor-thread ] each + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each ] ignore-errors ; -[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook +[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 2f941ad2ce..825d2a6329 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -21,15 +21,15 @@ IN: tools.vocabs : vocab-tests ( vocab -- tests ) [ - dup vocab-tests-file [ , ] when* - vocab-tests-dir [ % ] when* + [ vocab-tests-file [ , ] when* ] + [ vocab-tests-dir [ % ] when* ] bi ] { } make ; : vocab-files ( vocab -- seq ) [ - dup vocab-source-path [ , ] when* - dup vocab-docs-path [ , ] when* - vocab-tests % + [ vocab-source-path [ , ] when* ] + [ vocab-docs-path [ , ] when* ] + [ vocab-tests % ] tri ] { } make ; : source-modified? ( path -- ? ) @@ -56,20 +56,27 @@ IN: tools.vocabs : modified-docs ( vocabs -- seq ) [ vocab-docs-path ] modified ; +SYMBOL: changed-vocabs + +[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook + +: filter-changed ( vocabs -- vocabs' ) + changed-vocabs get [ + [ delete-at* nip ] curry subset + ] when* ; + : to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs - dup modified-sources swap modified-docs ; + child-vocabs filter-changed + [ modified-sources ] [ modified-docs ] bi ; : vocab-heading. ( vocab -- ) nl "==== " write - dup vocab-name swap vocab write-object ":" print + [ vocab-name ] [ vocab write-object ] bi ":" print nl ; : load-error. ( triple -- ) - dup first vocab-heading. - dup second print-error - drop ; + [ first vocab-heading. ] [ second print-error ] bi ; : load-failures. ( failures -- ) [ load-error. nl ] each ; @@ -89,30 +96,24 @@ SYMBOL: failures ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) - 2dup - [ f swap set-vocab-docs-loaded? ] each - [ f swap set-vocab-source-loaded? ] each - append prune require-all load-failures. ; + [ + [ [ f swap set-vocab-source-loaded? ] each ] + [ [ f swap set-vocab-docs-loaded? ] each ] bi* + ] + [ append prune require-all load-failures. ] 2bi ; : refresh ( prefix -- ) to-refresh do-refresh ; -SYMBOL: sources-changed? +: refresh-all ( -- ) "" refresh ; -[ t sources-changed? set-global ] "tools.vocabs" add-init-hook - -: refresh-all ( -- ) - "" refresh f sources-changed? set-global ; - -MEMO: (vocab-file-contents) ( path -- lines ) - dup exists? [ utf8 file-lines ] [ drop f ] if ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-append-path dup [ (vocab-file-contents) ] when ; +MEMO: vocab-file-contents ( vocab name -- seq ) + vocab-append-path dup + [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-append-path [ utf8 set-file-lines - \ (vocab-file-contents) reset-memoized + \ vocab-file-contents reset-memoized ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" @@ -261,7 +262,7 @@ MEMO: all-authors ( -- seq ) : reset-cache ( -- ) root-cache get-global clear-assoc - \ (vocab-file-contents) reset-memoized + \ vocab-file-contents reset-memoized \ all-vocabs-seq reset-memoized \ all-authors reset-memoized \ all-tags reset-memoized ; From 16fa44fc8222b15d81c6bb3295eb3a38b3835f2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 00:22:25 -0500 Subject: [PATCH 28/46] Fix irc loading --- extra/irc/irc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 0105fc53bb..27f82b25eb 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar combinators channels concurrency.messaging fry io io.encodings.8-bit io.sockets kernel math namespaces sequences - sequences.lib singleton splitting strings threads + sequences.lib splitting strings threads continuations classes.tuple ascii accessors ; IN: irc @@ -209,7 +209,7 @@ M: nick-in-use handle-irc ( obj -- ) { "KICK" [ \ kick ] } [ drop \ unhandled ] } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ; + [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; ! Reader : handle-reader-message ( irc-client irc-message -- ) From c5229fcbd1a1148545c47ec6caa57c83ecfd5b40 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 00:32:18 -0500 Subject: [PATCH 29/46] add some docs for environment variables --- core/system/system-docs.factor | 35 ++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index df112bd786..d0b2cfb194 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -7,9 +7,7 @@ ABOUT: "system" ARTICLE: "system" "System interface" { $subsection "cpu" } { $subsection "os" } -"Reading environment variables:" -{ $subsection os-env } -{ $subsection os-envs } +{ $subsection "environment-variables" } "Getting the path to the Factor VM and image:" { $subsection vm } { $subsection image } @@ -19,7 +17,16 @@ ARTICLE: "system" "System interface" { $subsection exit } { $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; -ARTICLE: "cpu" "Processor Detection" +ARTICLE: "environment-variables" "Environment variables" +"Reading environment variables:" +{ $subsection os-env } +{ $subsection os-envs } +"Writing environment variables:" +{ $subsection set-os-env } +{ $subsection unset-os-env } +{ $subsection set-os-envs } ; + +ARTICLE: "cpu" "Processor detection" "Processor detection:" { $subsection cpu } "Supported processors:" @@ -30,7 +37,7 @@ ARTICLE: "cpu" "Processor Detection" "Processor families:" { $subsection x86 } ; -ARTICLE: "os" "Operating System Detection" +ARTICLE: "os" "Operating system detection" "Operating system detection:" { $subsection os } "Supported operating systems:" @@ -98,7 +105,23 @@ HELP: set-os-envs } { $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; -{ os-env os-envs set-os-envs } related-words +HELP: set-os-env ( value key -- ) +{ $values { "value" string } { "key" string } } +{ $description "Set an environment variable." } +{ $notes + "Names and values of environment variables are operating system-specific." +} +{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; + +HELP: unset-os-env ( key -- ) +{ $values { "key" string } } +{ $description "Unset an environment variable." } +{ $notes + "Names and values of environment variables are operating system-specific." +} +{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; + +{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words HELP: image { $values { "path" "a pathname string" } } From d1cc5cc650461cff50e15ba4640f2e746e72dece Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 00:33:29 -0500 Subject: [PATCH 30/46] windows environment variables --- vm/os-windows.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/os-windows.c b/vm/os-windows.c index b3fc1c917f..77a32f6f9f 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -217,17 +217,17 @@ void sleep_millis(DWORD msec) DEFINE_PRIMITIVE(set_os_env) { - char *key = unbox_char_string(); + F_CHAR *key = unbox_u16_string(); REGISTER_C_STRING(key); - char *value = unbox_char_string(); + F_CHAR *value = unbox_u16_string(); UNREGISTER_C_STRING(key); SetEnvironmentVariable(key, value); } DEFINE_PRIMITIVE(unset_os_env) { - char *key = unbox_char_string(); - SetEnvironmentVariable(key, f); + F_CHAR *key = unbox_u16_string(); + SetEnvironmentVariable(key, NULL); } DEFINE_PRIMITIVE(set_os_envs) From c6e1347c6718c793dbb7d3949c48147e2e2259d5 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 8 Apr 2008 22:36:49 -0700 Subject: [PATCH 31/46] Two small spelling fixes --- core/inference/backend/backend-docs.factor | 2 +- extra/io/monitors/monitors-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 1d742e144a..32978d5814 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -4,7 +4,7 @@ kernel.private combinators sequences.private ; HELP: literal-expected { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } -{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ; +{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ; HELP: too-many->r { $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." } diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 76a354b0bd..4f24879e19 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -9,7 +9,7 @@ $nl HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } From 639871900a65a25617fed0ee19342e6cd4971dac Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 8 Apr 2008 23:22:28 -0700 Subject: [PATCH 32/46] Import extra/unionfind, a disjoint set datastructure --- extra/unionfind/authors.txt | 1 + extra/unionfind/summary.txt | 1 + extra/unionfind/unionfind.factor | 71 ++++++++++++++++++++++++++++++++ 3 files changed, 73 insertions(+) create mode 100644 extra/unionfind/authors.txt create mode 100644 extra/unionfind/summary.txt create mode 100644 extra/unionfind/unionfind.factor diff --git a/extra/unionfind/authors.txt b/extra/unionfind/authors.txt new file mode 100644 index 0000000000..16e1588016 --- /dev/null +++ b/extra/unionfind/authors.txt @@ -0,0 +1 @@ +Eric Mertens diff --git a/extra/unionfind/summary.txt b/extra/unionfind/summary.txt new file mode 100644 index 0000000000..c282cc29bb --- /dev/null +++ b/extra/unionfind/summary.txt @@ -0,0 +1 @@ +A efficient implementation of a disjoint-set datastructure diff --git a/extra/unionfind/unionfind.factor b/extra/unionfind/unionfind.factor new file mode 100644 index 0000000000..1f0d8be927 --- /dev/null +++ b/extra/unionfind/unionfind.factor @@ -0,0 +1,71 @@ +USING: accessors arrays combinators kernel math sequences namespaces ; + +IN: unionfind + +> nth ; + +: add-count ( p a -- ) + count [ + ] curry uf get counts>> swap change-nth ; + +: parent ( a -- p ) + uf get parents>> nth ; + +: set-parent ( p a -- ) + uf get parents>> set-nth ; + +: link-sets ( p a -- ) + [ set-parent ] + [ add-count ] 2bi ; + +: rank ( a -- r ) + uf get ranks>> nth ; + +: inc-rank ( a -- ) + uf get ranks>> [ 1+ ] change-nth ; + +: topparent ( a -- p ) + [ parent ] keep + 2dup = [ + [ topparent ] dip + 2dup set-parent + ] unless drop ; + +PRIVATE> + +: ( n -- unionfind ) + [ >array ] + [ 0 ] + [ 1 ] tri + unionfind construct-boa ; + +: equiv-set-size ( a uf -- n ) + uf [ topparent count ] with-variable ; + +: equiv? ( a b uf -- ? ) + uf [ [ topparent ] bi@ = ] with-variable ; + +: equate ( a b uf -- ) + uf [ + [ topparent ] bi@ + 2dup [ rank ] compare sgn + { + { -1 [ swap link-sets ] } + { 1 [ link-sets ] } + { 0 [ + 2dup = + [ 2drop ] + [ + [ link-sets ] + [ drop inc-rank ] 2bi + ] if + ] + } + } case + ] with-variable ; From 8d8c39ecca0496b8e684a810211c6f662ed0ac36 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:53:21 -0500 Subject: [PATCH 33/46] Fix circularity --- core/inference/backend/backend-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 32978d5814..0125f04efa 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -1,6 +1,7 @@ USING: help.syntax help.markup words effects inference.dataflow -inference.state inference.backend kernel sequences +inference.state kernel sequences kernel.private combinators sequences.private ; +IN: inference.backend HELP: literal-expected { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } From 6b16f7082257ab897c9d6e9f0a1cb54c618dbc6e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:53:29 -0500 Subject: [PATCH 34/46] Try a different strategy --- .../tools/vocabs/monitor/monitor-tests.factor | 6 +++++ extra/tools/vocabs/monitor/monitor.factor | 26 +++++++++++++------ 2 files changed, 24 insertions(+), 8 deletions(-) create mode 100644 extra/tools/vocabs/monitor/monitor-tests.factor diff --git a/extra/tools/vocabs/monitor/monitor-tests.factor b/extra/tools/vocabs/monitor/monitor-tests.factor new file mode 100644 index 0000000000..f1eece91c2 --- /dev/null +++ b/extra/tools/vocabs/monitor/monitor-tests.factor @@ -0,0 +1,6 @@ +USING: tools.test tools.vocabs.monitor io.files ; +IN: tools.vocabs.monitor.tests + +[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test +[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test +[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index ada539c60a..b96f76d3ba 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -11,27 +11,37 @@ IN: tools.vocabs.monitor : path>vocab-name ( path -- vocab ) dup ".factor" tail? [ parent-directory ] when - dup [ vocab-dir>vocab-name ] when ; + ; + +: chop-vocab-root ( path -- path' ) + "resource:" prepend-path (normalize-path) + dup vocab-roots get + [ (normalize-path) ] map + [ head? ] with find nip + ?head drop ; + +: path>vocab ( path -- vocab ) + chop-vocab-root path>vocab-name vocab-dir>vocab-name ; : changed-vocab ( vocab -- ) dup vocab [ dup changed-vocabs get-global set-at ] [ drop ] if ; -: monitor-thread ( path monitor -- ) +: monitor-thread ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. - next-change drop swap ?head drop - path>vocab-name changed-vocab reset-cache ; + next-change drop path>vocab changed-vocab reset-cache ; -: start-monitor-thread ( root -- ) +: start-monitor-thread ( monitor -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - (normalize-path) dup t [ monitor-thread t ] 2curry - "Vocabulary monitor" spawn-server drop ; + [ monitor-thread t ] curry + "Vocabulary monitor" spawn-server + drop ; : start-monitor-threads ( -- ) [ - vocab-roots get [ start-monitor-thread ] each + "" resource-path t start-monitor-thread H{ } clone changed-vocabs set-global vocabs [ changed-vocab ] each ] ignore-errors ; From 17931bb5353c3ea994a1bc15890fa7510e93da7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:56:17 -0500 Subject: [PATCH 35/46] Add command-line switch for disabling the refresh-all monitor --- extra/tools/vocabs/monitor/monitor.factor | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index b96f76d3ba..867c3b2903 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel vocabs vocabs.loader tools.vocabs namespaces continuations -sequences splitting assocs ; +sequences splitting assocs command-line ; IN: tools.vocabs.monitor : vocab-dir>vocab-name ( path -- vocab ) @@ -32,18 +32,20 @@ IN: tools.vocabs.monitor #! off if its there. next-change drop path>vocab changed-vocab reset-cache ; -: start-monitor-thread ( monitor -- ) +: start-monitor-thread ( -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ monitor-thread t ] curry - "Vocabulary monitor" spawn-server - drop ; - -: start-monitor-threads ( -- ) [ - "" resource-path t start-monitor-thread + "" resource-path t [ monitor-thread t ] curry + "Vocabulary monitor" spawn-server drop + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each ] ignore-errors ; -[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook +[ + "-no-monitors" cli-args get member? [ + start-monitor-thread + ] unless +] "tools.vocabs.monitor" add-init-hook From 5204d7065c25c8d73b00d9fa96756f9daac1dc0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 03:00:15 -0500 Subject: [PATCH 36/46] Improve docs --- core/inference/inference-docs.factor | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index a837cfce5e..e32c94ed37 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -79,6 +79,18 @@ ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph" "The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form." $nl ; +ARTICLE: "inference-errors" "Inference errors" +"Main wrapper for all inference errors:" +{ $subsection inference-error } +"Specific inference errors:" +{ $subsection no-effect } +{ $subsection literal-expected } +{ $subsection too-many->r } +{ $subsection too-many-r> } +{ $subsection unbalanced-branches-error } +{ $subsection effect-error } +{ $subsection recursive-declare-error } ; + ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." $nl @@ -93,7 +105,8 @@ $nl { $subsection "inference-combinators" } { $subsection "inference-branches" } { $subsection "inference-recursive" } -{ $subsection "inference-limitations" } +{ $subsection "inference-limitations" } +{ $subsection "inference-errors" } { $subsection "dataflow-graphs" } { $subsection "compiler-transforms" } ; @@ -105,16 +118,7 @@ HELP: inference-error { $error-description "Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred." $nl - "The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:" - { $list - { $link no-effect } - { $link literal-expected } - { $link too-many->r } - { $link too-many-r> } - { $link unbalanced-branches-error } - { $link effect-error } - { $link recursive-declare-error } - } + "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "." } ; From 20148a1106dafacee41b5fc1f54d7ef76f3dfcc4 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 9 Apr 2008 01:20:45 -0700 Subject: [PATCH 37/46] Minor typo corrections in cookbook.factor --- extra/help/cookbook/cookbook.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 075ce2d0e8..f1d4ac4ca7 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -224,7 +224,7 @@ $nl ":errors - print 2 compiler errors." ":warnings - print 50 compiler warnings." } -"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations." +"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations." { $references "To learn more about the compiler and static stack effect inference, read these articles:" "compiler" @@ -259,7 +259,7 @@ $nl { $code "#! /usr/bin/env factor -script" } "Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "." $nl -"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes." +"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes." { $references { } "cli" @@ -273,7 +273,7 @@ $nl $nl "Keep the following guidelines in mind to avoid losing your sense of balance:" { $list - "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines." + "Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines." "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code." "If your code looks repetitive, factor it some more." "If after factoring, your code still looks repetitive, introduce combinators." @@ -285,7 +285,7 @@ $nl "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." { "Learn to use the " { $link "inference" } " tool." } { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } - "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution." + "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution." { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." } { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." } @@ -312,7 +312,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" $nl "Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:" { $code "\"inference\" test" } - "In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." } + "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." } { "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." } { "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." } } ; From 02886132f3b667d5eb03edb4a97a337d2f1f3ff4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 12:50:58 -0500 Subject: [PATCH 38/46] add [un]set-os-env tests --- core/system/system-tests.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index 14e34ccb17..d5a48080c2 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -12,3 +12,10 @@ os unix? [ [ ] [ "envs" get set-os-envs ] unit-test [ t ] [ os-envs "envs" get = ] unit-test ] when + +[ ] [ "factor-test-key-1" unset-os-env ] unit-test +[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test +[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test +[ ] [ "factor-test-key-1" unset-os-env ] unit-test +[ f ] [ "factor-test-key-1" os-env ] unit-test + From d748c367c0d373c4f6575931cfecb1f923c98a24 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 14:01:04 -0500 Subject: [PATCH 39/46] ppc64 architecture is now recognized --- build-support/factor.sh | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index ea0c35aa83..4bcd9e3086 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -89,6 +89,11 @@ set_md5sum() { set_gcc() { case $OS in openbsd) ensure_program_installed egcc; CC=egcc;; + netbsd) if [[ $WORD -eq 64 ]] ; then + CC=/usr/pkg/gcc34/bin/gcc + else + CC=gcc + fi ;; *) CC=gcc;; esac } @@ -185,6 +190,7 @@ find_architecture() { i386) ARCH=x86;; i686) ARCH=x86;; amd64) ARCH=x86;; + ppc64) ARCH=ppc;; *86) ARCH=x86;; *86_64) ARCH=x86;; "Power Macintosh") ARCH=ppc;; From 409d984c3c35a233e25b7e3e90e563bf83e9c3b3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 16:57:21 -0500 Subject: [PATCH 40/46] move os_env from run to os-unix.c/os-windows.c --- vm/os-unix.c | 10 ++++++++++ vm/os-windows.c | 21 ++++++++++++++++++--- vm/run.c | 10 ---------- 3 files changed, 28 insertions(+), 13 deletions(-) diff --git a/vm/os-unix.c b/vm/os-unix.c index 2991cde78c..6363ce68a9 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -85,6 +85,16 @@ DEFINE_PRIMITIVE(read_dir) dpush(result); } +DEFINE_PRIMITIVE(os_env) +{ + char *name = unbox_char_string(); + char *value = getenv(name); + if(value == NULL) + dpush(F); + else + box_char_string(value); +} + DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows.c b/vm/os-windows.c index 77a32f6f9f..136168807a 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,19 +215,34 @@ void sleep_millis(DWORD msec) Sleep(msec); } +DEFINE_PRIMITIVE(os_env) +{ + F_CHAR *key = unbox_u16_string(); + F_CHAR *value = safe_malloc(MAX_UNICODE_PATH); + int ret; + ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH); + if(ret == 0) + dpush(F); + else + dpush(tag_object(from_u16_string(value))); + free(value); +} + DEFINE_PRIMITIVE(set_os_env) { F_CHAR *key = unbox_u16_string(); REGISTER_C_STRING(key); F_CHAR *value = unbox_u16_string(); UNREGISTER_C_STRING(key); - SetEnvironmentVariable(key, value); + if(!SetEnvironmentVariable(key, value)) + general_error(ERROR_IO, tag_object(get_error_message()), F, NULL); } DEFINE_PRIMITIVE(unset_os_env) { - F_CHAR *key = unbox_u16_string(); - SetEnvironmentVariable(key, NULL); + if(!SetEnvironmentVariable(unbox_u16_string(), NULL) + && GetLastError() != ERROR_ENVVAR_NOT_FOUND) + general_error(ERROR_IO, tag_object(get_error_message()), F, NULL); } DEFINE_PRIMITIVE(set_os_envs) diff --git a/vm/run.c b/vm/run.c index 282be0a447..ae0c91d9e6 100755 --- a/vm/run.c +++ b/vm/run.c @@ -280,16 +280,6 @@ DEFINE_PRIMITIVE(exit) exit(to_fixnum(dpop())); } -DEFINE_PRIMITIVE(os_env) -{ - char *name = unbox_char_string(); - char *value = getenv(name); - if(value == NULL) - dpush(F); - else - box_char_string(value); -} - DEFINE_PRIMITIVE(eq) { CELL lhs = dpop(); From 2da9aa9d18f529344a057f140aac10e2da96b3af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 16:58:55 -0500 Subject: [PATCH 41/46] Fix Linux/PPC port --- vm/os-linux-ppc.h | 8 ++++++++ vm/os-macosx.h | 8 +++++++- vm/os-unix-ucontext.h | 7 ------- vm/platform.h | 2 -- 4 files changed, 15 insertions(+), 10 deletions(-) delete mode 100644 vm/os-unix-ucontext.h diff --git a/vm/os-linux-ppc.h b/vm/os-linux-ppc.h index 86f0509e38..eb28af53e4 100644 --- a/vm/os-linux-ppc.h +++ b/vm/os-linux-ppc.h @@ -1,4 +1,12 @@ +#include + #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1]; +} + #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP]) diff --git a/vm/os-macosx.h b/vm/os-macosx.h index 4c35087752..701bb8da01 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.h @@ -15,4 +15,10 @@ DLLEXPORT void c_to_factor_toplevel(CELL quot); #ifndef environ extern char ***_NSGetEnviron(void); #define environ (*_NSGetEnviron()) -#endif \ No newline at end of file +#endif + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return ucontext->uc_stack.ss_sp; +} diff --git a/vm/os-unix-ucontext.h b/vm/os-unix-ucontext.h deleted file mode 100644 index 9ed0620a83..0000000000 --- a/vm/os-unix-ucontext.h +++ /dev/null @@ -1,7 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return ucontext->uc_stack.ss_sp; -} diff --git a/vm/platform.h b/vm/platform.h index a8c8ba756f..2f97cb9d1d 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -27,7 +27,6 @@ #include "os-unix.h" #ifdef __APPLE__ - #include "os-unix-ucontext.h" #include "os-macosx.h" #include "mach_signal.h" @@ -84,7 +83,6 @@ #if defined(FACTOR_X86) #include "os-linux-x86.32.h" #elif defined(FACTOR_PPC) - #include "os-unix-ucontext.h" #include "os-linux-ppc.h" #elif defined(FACTOR_ARM) #include "os-linux-arm.h" From 9373df5c4c5614a4a45afa215b26d249d1390611 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 17:04:09 -0500 Subject: [PATCH 42/46] Fix -generations=1 --- vm/data_gc.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/data_gc.h b/vm/data_gc.h index d3b8b6e39e..2490ed8805 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -315,7 +315,7 @@ INLINE void* allot_object(CELL type, CELL a) { CELL *object; - if(nursery->size - ALLOT_BUFFER_ZONE > a) + if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end) From f6e73abc0249e31bbd97918e285ccc851a043528 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 19:30:54 -0500 Subject: [PATCH 43/46] Redo refresh-all --- core/vocabs/loader/loader-tests.factor | 2 + extra/tools/vocabs/monitor/monitor.factor | 7 +- extra/tools/vocabs/vocabs.factor | 116 ++++++++++++++-------- 3 files changed, 80 insertions(+), 45 deletions(-) diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 1191594fe5..45b0d6b019 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -110,6 +110,8 @@ IN: vocabs.loader.tests ] with-compilation-unit ] unit-test +[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test + [ ] [ "vocabs.loader.test.b" refresh ] unit-test [ 3 ] [ "count-me" get-global ] unit-test diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 867c3b2903..826d410480 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -10,8 +10,7 @@ IN: tools.vocabs.monitor { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ; : path>vocab-name ( path -- vocab ) - dup ".factor" tail? [ parent-directory ] when - ; + dup ".factor" tail? [ parent-directory ] when ; : chop-vocab-root ( path -- path' ) "resource:" prepend-path (normalize-path) @@ -23,10 +22,6 @@ IN: tools.vocabs.monitor : path>vocab ( path -- vocab ) chop-vocab-root path>vocab-name vocab-dir>vocab-name ; -: changed-vocab ( vocab -- ) - dup vocab - [ dup changed-vocabs get-global set-at ] [ drop ] if ; - : monitor-thread ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 825d2a6329..211b396c50 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -32,43 +32,6 @@ IN: tools.vocabs [ vocab-tests % ] tri ] { } make ; -: source-modified? ( path -- ? ) - dup source-files get at [ - dup source-file-path - dup exists? [ - utf8 file-lines lines-crc32 - swap source-file-checksum = not - ] [ - 2drop f - ] if - ] [ - exists? - ] ?if ; - -: modified ( seq quot -- seq ) - [ dup ] swap compose { } map>assoc - [ nip ] assoc-subset - [ nip source-modified? ] assoc-subset keys ; inline - -: modified-sources ( vocabs -- seq ) - [ vocab-source-path ] modified ; - -: modified-docs ( vocabs -- seq ) - [ vocab-docs-path ] modified ; - -SYMBOL: changed-vocabs - -[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook - -: filter-changed ( vocabs -- vocabs' ) - changed-vocabs get [ - [ delete-at* nip ] curry subset - ] when* ; - -: to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs filter-changed - [ modified-sources ] [ modified-docs ] bi ; - : vocab-heading. ( vocab -- ) nl "==== " write @@ -95,12 +58,87 @@ SYMBOL: failures failures get ] with-compiler-errors ; -: do-refresh ( modified-sources modified-docs -- ) +: source-modified? ( path -- ? ) + dup source-files get at [ + dup source-file-path + dup exists? [ + utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + 2drop f + ] if + ] [ + exists? + ] ?if ; + +SYMBOL: changed-vocabs + +[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook + +: changed-vocab ( vocab -- ) + dup vocab + [ dup changed-vocabs get-global set-at ] [ drop ] if ; + +: unchanged-vocab ( vocab -- ) + changed-vocabs get-global delete-at ; + +: unchanged-vocabs ( vocabs -- ) + [ unchanged-vocab ] each ; + +: filter-changed ( vocabs -- vocabs' ) + changed-vocabs get [ + [ key? ] curry subset + ] when* ; + +SYMBOL: modified-sources +SYMBOL: modified-docs + +: (to-refresh) ( vocab variable loaded? path -- ) + dup [ + swap [ + pick changed-vocabs get key? [ + source-modified? [ get push ] [ 2drop ] if + ] [ 3drop ] if + ] [ drop get push ] if + ] [ 2drop 2drop ] if ; + +: to-refresh ( prefix -- modified-sources modified-docs unchanged ) + [ + V{ } clone modified-sources set + V{ } clone modified-docs set + + child-vocabs [ + [ + [ + [ modified-sources ] + [ vocab-source-loaded? ] + [ vocab-source-path ] + tri (to-refresh) + ] [ + [ modified-docs ] + [ vocab-docs-loaded? ] + [ vocab-docs-path ] + tri (to-refresh) + ] bi + ] each + + modified-sources get + modified-docs get + ] + [ modified-sources get modified-docs get append swap seq-diff ] bi + ] with-scope ; + +: do-refresh ( modified-sources modified-docs unchanged -- ) + unchanged-vocabs [ [ [ f swap set-vocab-source-loaded? ] each ] [ [ f swap set-vocab-docs-loaded? ] each ] bi* ] - [ append prune require-all load-failures. ] 2bi ; + [ + append prune + [ unchanged-vocabs ] + [ require-all load-failures. ] bi + ] 2bi ; : refresh ( prefix -- ) to-refresh do-refresh ; From 0e723f64cc2cd97e767cccab9f4b3a8ecb197385 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 9 Apr 2008 19:47:10 -0500 Subject: [PATCH 44/46] Add unit tests for monitors --- extra/io/monitors/monitors-tests.factor | 29 +++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 extra/io/monitors/monitors-tests.factor diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor new file mode 100644 index 0000000000..fb687f6876 --- /dev/null +++ b/extra/io/monitors/monitors-tests.factor @@ -0,0 +1,29 @@ +IN: io.monitors.tests +USING: io.monitors tools.test io.files system sequences +continuations namespaces concurrency.count-downs kernel io +threads calendar ; + +os { winnt macosx linux } member? [ + [ "monitor-test" temp-file delete-tree ] ignore-errors + + [ ] [ "monitor-test" temp-file make-directory ] unit-test + + [ ] [ "monitor-test" temp-file t "m" set ] unit-test + + [ ] [ 1 "c" set ] unit-test + + [ ] [ + [ + [ + "m" get next-change drop + dup print flush + "test.txt" tail? not + ] [ ] [ ] while + "c" get count-down + ] "Monitor test thread" spawn drop + ] unit-test + + [ ] [ "monitor-test/test.txt" touch-file ] unit-test + + [ ] [ "c" get 30 seconds await-timeout ] unit-test +] when From b63edfd493bc13c424edd81f96752918115610a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 19:54:48 -0500 Subject: [PATCH 45/46] Add unit tests for monitors --- extra/io/monitors/monitors-tests.factor | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index fb687f6876..4bb5db9f0a 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -1,29 +1,34 @@ IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io -threads calendar ; +threads calendar prettyprint ; os { winnt macosx linux } member? [ [ "monitor-test" temp-file delete-tree ] ignore-errors - [ ] [ "monitor-test" temp-file make-directory ] unit-test + [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test [ ] [ "monitor-test" temp-file t "m" set ] unit-test + [ ] [ 1 "b" set ] unit-test + [ ] [ 1 "c" set ] unit-test [ ] [ [ + "b" get count-down [ "m" get next-change drop - dup print flush - "test.txt" tail? not + dup print flush right-trim-separators + "xyz" tail? not ] [ ] [ ] while "c" get count-down ] "Monitor test thread" spawn drop ] unit-test - [ ] [ "monitor-test/test.txt" touch-file ] unit-test + [ ] [ "b" get await ] unit-test + + [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test [ ] [ "c" get 30 seconds await-timeout ] unit-test ] when From 48a16b542d0f4e5e23956012194c4fe61d76c6b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 20:14:14 -0500 Subject: [PATCH 46/46] Unit test fixes --- core/definitions/definitions-tests.factor | 20 -------------------- extra/io/monitors/monitors-tests.factor | 4 ++++ 2 files changed, 4 insertions(+), 20 deletions(-) diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 3dc28139ea..b20d81ec7c 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -2,26 +2,6 @@ IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units words ; -TUPLE: combination-1 ; - -M: combination-1 perform-combination drop [ ] define ; - -M: combination-1 make-default-method 2drop [ "No method" throw ] ; - -SYMBOL: generic-1 - -[ - generic-1 T{ combination-1 } define-generic - - object \ generic-1 create-method [ ] define -] with-compilation-unit - -[ ] [ - [ - { combination-1 { object generic-1 } } forget-all - ] with-compilation-unit -] unit-test - GENERIC: some-generic ( a -- b ) USE: arrays diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 4bb5db9f0a..7170e824c8 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -31,4 +31,8 @@ os { winnt macosx linux } member? [ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test [ ] [ "c" get 30 seconds await-timeout ] unit-test + + [ ] [ "m" get dispose ] unit-test + + [ "m" get dispose ] must-fail ] when