From 9503efa9a8585de40f35c9634c43a1e0142aa6aa Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 01:38:39 -0500 Subject: [PATCH 01/16] working on sorting.slots --- basis/sorting/slots/slots.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 9a0455c3a7..5b910cb621 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -9,7 +9,7 @@ IN: sorting.slots : short-circuit-comparator ( obj1 obj2 word -- comparator/? ) execute( obj1 obj2 -- obj3 ) - dup +eq+ eq? [ drop f ] when ; inline + dup +eq+ eq? [ drop f ] when ; : slot-comparator ( seq -- quot ) [ @@ -17,12 +17,12 @@ IN: sorting.slots [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat ] [ peek - '[ @ _ short-circuit-comparator ] + '[ _ call( obj1 obj2 -- obj3 obj4 ) _ short-circuit-comparator ] ] bi ; PRIVATE> -MACRO: compare-slots ( sort-specs -- <=> ) +MACRO: compare-slots ( sort-specs -- quot ) #! sort-spec: { accessors comparator } [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; From 7e5ab38ed10e93ce855b8ba06f0198d2649a4731 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 02:04:58 -0500 Subject: [PATCH 02/16] use unclip-last-slice --- basis/sorting/slots/slots.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 5b910cb621..5fbf3d7af9 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -12,13 +12,13 @@ IN: sorting.slots dup +eq+ eq? [ drop f ] when ; : slot-comparator ( seq -- quot ) - [ - but-last-slice - [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat + unclip-last-slice [ + [ + '[ [ _ execute( tuple -- value ) ] bi@ ] + ] map concat ] [ - peek '[ _ call( obj1 obj2 -- obj3 obj4 ) _ short-circuit-comparator ] - ] bi ; + ] bi* ; PRIVATE> From 567bd334a00077948d94d06dee672dc4cb26896e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 11:42:53 -0500 Subject: [PATCH 03/16] modernize openal.other --- extra/openal/other/other.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor index d0429fb3c3..0936c94150 100644 --- a/extra/openal/other/other.factor +++ b/extra/openal/other/other.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: openal.backend alien.c-types kernel alien alien.syntax -shuffle combinators.lib ; +USING: alien.c-types alien.syntax combinators generalizations +kernel openal.backend ; IN: openal.other LIBRARY: alut @@ -9,6 +9,6 @@ LIBRARY: alut FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; M: object load-wav-file ( filename -- format data size frequency ) - 0 f 0 0 - [ 0 alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; + 0 f 0 0 + [ 0 alutLoadWAVFile ] 4 nkeep + { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ; From c1d1fe9b2079c1033f40b869699477eef273dbcc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 13:44:20 -0500 Subject: [PATCH 04/16] minor fixes in sorting --- basis/sorting/slots/slots-docs.factor | 2 +- basis/sorting/slots/slots.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index b427cf2956..24c27eb00c 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -18,7 +18,7 @@ HELP: sort-by-slots } { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples - "Sort by slot c, then b descending:" + "Sort by slot a, then b descending:" { $example "USING: accessors math.order prettyprint sorting.slots ;" "IN: scratchpad" diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 5fbf3d7af9..d3d7f47f99 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -7,7 +7,7 @@ IN: sorting.slots Date: Sat, 18 Apr 2009 13:48:15 -0500 Subject: [PATCH 05/16] make openal.example load, it's still broken.. --- extra/openal/example/example.factor | 45 ++++++++++++++--------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/extra/openal/example/example.factor b/extra/openal/example/example.factor index ae0b50afff..4d979a8fa7 100644 --- a/extra/openal/example/example.factor +++ b/extra/openal/example/example.factor @@ -1,34 +1,33 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! +USING: calendar kernel openal sequences threads ; IN: openal.example -USING: openal kernel alien threads sequences calendar ; : play-hello ( -- ) - init-openal - 1 gen-sources - first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param - source-play - 1000 milliseconds sleep ; + init-openal + 1 gen-sources + first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param + source-play + 1000 milliseconds sleep ; : (play-file) ( source -- ) - 100 milliseconds sleep - dup source-playing? [ (play-file) ] [ drop ] if ; + 100 milliseconds sleep + dup source-playing? [ (play-file) ] [ drop ] if ; : play-file ( filename -- ) - init-openal - create-buffer-from-file - 1 gen-sources - first dup >r AL_BUFFER rot set-source-param r> - dup source-play - check-error - (play-file) ; + init-openal + create-buffer-from-file + 1 gen-sources + first dup [ AL_BUFFER rot set-source-param ] dip + dup source-play + check-error + (play-file) ; : play-wav ( filename -- ) - init-openal - create-buffer-from-wav - 1 gen-sources - first dup >r AL_BUFFER rot set-source-param r> - dup source-play - check-error - (play-file) ; \ No newline at end of file + init-openal + create-buffer-from-wav + 1 gen-sources + first dup [ AL_BUFFER rot set-source-param ] dip + dup source-play + check-error + (play-file) ; From 8820c95964463ac393a138d19011fc69a9344abc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 15:21:12 -0500 Subject: [PATCH 06/16] make x11.io.unix unportable --- basis/x11/io/unix/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/x11/io/unix/tags.txt diff --git a/basis/x11/io/unix/tags.txt b/basis/x11/io/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/x11/io/unix/tags.txt @@ -0,0 +1 @@ +unportable From 0ca924124a44b5abac4e4c7cf469140d141b8154 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 16:44:24 -0500 Subject: [PATCH 07/16] Rewrite sorting.slots --- basis/sorting/slots/slots-docs.factor | 22 ++----- basis/sorting/slots/slots-tests.factor | 89 ++------------------------ basis/sorting/slots/slots.factor | 53 +++++---------- 3 files changed, 27 insertions(+), 137 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index 24c27eb00c..5960c451fe 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -11,7 +11,7 @@ HELP: compare-slots } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; -HELP: sort-by-slots +HELP: sort-by { $values { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } { "seq'" sequence } @@ -32,27 +32,13 @@ HELP: sort-by-slots } } ; -HELP: split-by-slots -{ $values - { "accessor-seqs" "a sequence of sequences of tuple accessors" } - { "quot" quotation } -} -{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ; - -HELP: sort-by -{ $values - { "seq" sequence } { "sort-seq" "a sequence of comparators" } - { "seq'" sequence } -} -{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; - ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" { $subsection compare-slots } "Sorting a sequence of tuples by a slot/comparator pairs:" -{ $subsection sort-by-slots } -"Sorting a sequence by a sequence of comparators:" -{ $subsection sort-by } ; +{ $subsection sort-by } +{ $subsection sort-keys-by } +{ $subsection sort-values-by } ; ABOUT: "sorting.slots" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index e31b9be359..5ebd4438fe 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -24,7 +24,7 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots + } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ @@ -42,43 +42,14 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots + } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by ] unit-test -[ - { - { - T{ sort-test { a 1 } { b 1 } { c 10 } } - T{ sort-test { a 1 } { b 1 } { c 11 } } - } - { T{ sort-test { a 1 } { b 3 } { c 9 } } } - { - T{ sort-test { a 2 } { b 5 } { c 3 } } - T{ sort-test { a 2 } { b 5 } { c 2 } } - } - } -] [ - { - T{ sort-test f 1 3 9 } - T{ sort-test f 1 1 10 } - T{ sort-test f 1 1 11 } - T{ sort-test f 2 5 3 } - T{ sort-test f 2 5 2 } - } - { { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep - [ but-last-slice ] map split-by-slots [ >array ] map -] unit-test - -: split-test ( seq -- seq' ) - { { a>> } { b>> } } split-by-slots ; - -[ split-test ] must-infer +[ { } ] +[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ { } ] -[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test - -[ { } ] -[ { } { } sort-by-slots ] unit-test +[ { } { } sort-by ] unit-test [ { @@ -97,55 +68,7 @@ TUPLE: tuple2 d ; T{ sort-test f 6 f f T{ tuple2 f 3 } } T{ sort-test f 5 f f T{ tuple2 f 3 } } T{ sort-test f 6 f f T{ tuple2 f 2 } } - } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots -] unit-test - -[ - { - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 1 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 2 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 4 } } } - } - } - } -] [ - { - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } - } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map + } { { tuple2>> d>> <=> } { a>> <=> } } sort-by ] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index d3d7f47f99..e3b4bc88ca 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -1,47 +1,28 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit fry kernel macros math.order -sequences words sorting sequences.deep assocs splitting.monotonic -math ; +USING: arrays fry kernel math.order sequences sorting ; IN: sorting.slots -/f ) + execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ; -: short-circuit-comparator ( obj1 obj2 word -- comparator/? ) - execute( obj1 obj2 -- obj3 ) - dup +eq+ eq? [ drop f ] when ; +: execute-accessor ( obj1 obj2 word -- obj1' obj2' ) + '[ _ execute( tuple -- value ) ] bi@ ; -: slot-comparator ( seq -- quot ) - unclip-last-slice [ - [ - '[ [ _ execute( tuple -- value ) ] bi@ ] - ] map concat - ] [ - '[ _ call( obj1 obj2 -- obj3 obj4 ) _ short-circuit-comparator ] - ] bi* ; - -PRIVATE> - -MACRO: compare-slots ( sort-specs -- quot ) +: compare-slots ( obj1 obj2 sort-specs -- <=> ) #! sort-spec: { accessors comparator } - [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; + [ + dup array? [ + unclip-last-slice + [ [ execute-accessor ] each ] dip + ] when execute-comparator + ] with with map-find drop +eq+ or ; -: sort-by-slots ( seq sort-specs -- seq' ) - '[ _ compare-slots ] sort ; +: sort-by-with ( seq sort-specs quot -- seq' ) + swap '[ _ bi@ _ compare-slots ] sort ; inline -MACRO: compare-seq ( seq -- quot ) - [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; +: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ; -: sort-by ( seq sort-seq -- seq' ) - '[ _ compare-seq ] sort ; +: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ; -: sort-keys-by ( seq sort-seq -- seq' ) - '[ [ first ] bi@ _ compare-seq ] sort ; - -: sort-values-by ( seq sort-seq -- seq' ) - '[ [ second ] bi@ _ compare-seq ] sort ; - -MACRO: split-by-slots ( accessor-seqs -- quot ) - [ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat - [ = ] compose ] map - '[ [ _ 2&& ] slice monotonic-slice ] ; +: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ; From 2d8d7f120fef12acec7251a155f7a37c7b176a11 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 16:44:34 -0500 Subject: [PATCH 08/16] sort-by-slots => sort-by --- basis/tools/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 8d882099de..146a119a63 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -75,7 +75,7 @@ M: object file-spec>string ( file-listing spec -- string ) : list-files-slow ( listing-tool -- array ) [ path>> ] [ sort>> ] [ specs>> ] tri '[ [ dup name>> file-info file-listing boa ] map - _ [ sort-by-slots ] when* + _ [ sort-by ] when* [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline From bb06e98dfb304797b518e74594c309aa57ec43bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 16:44:42 -0500 Subject: [PATCH 09/16] Fix compiler warning in jamshred.log --- extra/jamshred/log/log.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor index 33498d8a2e..f2517d1ec3 100644 --- a/extra/jamshred/log/log.factor +++ b/extra/jamshred/log/log.factor @@ -4,7 +4,7 @@ IN: jamshred.log LOG: (jamshred-log) DEBUG : with-jamshred-log ( quot -- ) - "jamshred" swap with-logging ; + "jamshred" swap with-logging ; inline : jamshred-log ( message -- ) [ (jamshred-log) ] with-jamshred-log ; ! ugly... From 49eec252d2f1be2873fc2d541d7b6e4820dc0edf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 18:28:09 -0500 Subject: [PATCH 10/16] scaffold factor-boot-rc on windows instead of .factor-boot-rc --- basis/tools/scaffold/scaffold.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index d02faae3a8..d6414284b4 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -301,8 +301,10 @@ SYMBOL: examples-flag [ home ] dip append-path [ touch-file ] [ "Click to edit: " write . ] bi ; -: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ; +: scaffold-factor-boot-rc ( -- ) + windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; -: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ; +: scaffold-factor-rc ( -- ) + windows? "factor-rc" ".factor-rc" ? scaffold-rc ; : scaffold-emacs ( -- ) ".emacs" scaffold-rc ; From b15cf5f7ea612ec39231977ebff592aa3128d3df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 19:05:57 -0500 Subject: [PATCH 11/16] fix load error --- basis/tools/scaffold/scaffold.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index d6414284b4..8bd06f48fb 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -5,7 +5,8 @@ io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes math alien urls -splitting ascii combinators.short-circuit alarms words.symbol ; +splitting ascii combinators.short-circuit alarms words.symbol +system ; IN: tools.scaffold SYMBOL: developer-name From f22ee5ad8d936b7665c6374afe1aa7128a3106f0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 19:18:41 -0500 Subject: [PATCH 12/16] fix one more bug with scaffold.. --- basis/tools/scaffold/scaffold.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 8bd06f48fb..f35da24266 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -303,9 +303,9 @@ SYMBOL: examples-flag [ touch-file ] [ "Click to edit: " write . ] bi ; : scaffold-factor-boot-rc ( -- ) - windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; + os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; : scaffold-factor-rc ( -- ) - windows? "factor-rc" ".factor-rc" ? scaffold-rc ; + os windows? "factor-rc" ".factor-rc" ? scaffold-rc ; : scaffold-emacs ( -- ) ".emacs" scaffold-rc ; From 2979360d48c2db62c3e51cecbb74f5ad07140876 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 19:52:12 -0500 Subject: [PATCH 13/16] sorting.slots: help lint --- basis/sorting/slots/slots-docs.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index 5960c451fe..beb378d4bd 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -6,8 +6,10 @@ IN: sorting.slots HELP: compare-slots { $values - { "sort-specs" "a sequence of accessors ending with a comparator" } - { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } + { "obj1" object } + { "obj2" object } + { "sort-specs" "a sequence of accessors ending with a comparator" } + { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; @@ -27,7 +29,7 @@ HELP: sort-by " T{ sort-me f 2 3 } T{ sort-me f 3 2 }" " T{ sort-me f 4 3 } T{ sort-me f 2 1 }" "}" - "{ { a>> <=> } { b>> >=< } } sort-by-slots ." + "{ { a>> <=> } { b>> >=< } } sort-by ." "{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}" } } ; From 8891573a77a260c4bb4773c069e97465b478dd2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 19:52:29 -0500 Subject: [PATCH 14/16] windows.dinput.constants: fix warnings --- .../dinput/constants/constants-tests.factor | 5 ++ .../windows/dinput/constants/constants.factor | 56 ++++++++++--------- 2 files changed, 36 insertions(+), 25 deletions(-) create mode 100644 basis/windows/dinput/constants/constants-tests.factor diff --git a/basis/windows/dinput/constants/constants-tests.factor b/basis/windows/dinput/constants/constants-tests.factor new file mode 100644 index 0000000000..67785844fa --- /dev/null +++ b/basis/windows/dinput/constants/constants-tests.factor @@ -0,0 +1,5 @@ +IN: windows.dinput.constants.tests +USING: tools.test windows.dinput.constants.private ; + +[ ] [ define-constants ] unit-test +[ ] [ free-dinput-constants ] unit-test \ No newline at end of file diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index cd1033d418..0f95c6d683 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -27,12 +27,12 @@ SYMBOLS: : (flag) ( thing -- integer ) { - { [ dup word? ] [ execute ] } - { [ dup callable? ] [ call ] } + { [ dup word? ] [ execute( -- value ) ] } + { [ dup callable? ] [ call( -- value ) ] } [ ] } cond ; -: (flags) ( array -- ) +: (flags) ( array -- n ) 0 [ (flag) bitor ] reduce ; : (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien ) @@ -63,14 +63,16 @@ SYMBOLS: ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) - [ { - [ set-DIDATAFORMAT-rgodf ] - [ set-DIDATAFORMAT-dwNumObjs ] - [ set-DIDATAFORMAT-dwDataSize ] - [ set-DIDATAFORMAT-dwFlags ] - [ set-DIDATAFORMAT-dwObjSize ] - [ set-DIDATAFORMAT-dwSize ] - } cleave ] keep ; + [ + { + [ set-DIDATAFORMAT-rgodf ] + [ set-DIDATAFORMAT-dwNumObjs ] + [ set-DIDATAFORMAT-dwDataSize ] + [ set-DIDATAFORMAT-dwFlags ] + [ set-DIDATAFORMAT-dwObjSize ] + [ set-DIDATAFORMAT-dwSize ] + } cleave + ] keep ; : ( dwFlags dwDataSize struct rgodf-array -- alien ) [ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip @@ -78,9 +80,10 @@ SYMBOLS: "DIDATAFORMAT" (DIDATAFORMAT) ; : (malloc-guid-symbol) ( symbol guid -- ) - global swap '[ [ - _ execute [ byte-length malloc ] [ over byte-array>memory ] bi - ] unless* ] change-at ; + '[ + _ execute( -- value ) + [ byte-length malloc ] [ over byte-array>memory ] bi + ] initialize ; : define-guid-constants ( -- ) { @@ -105,7 +108,7 @@ SYMBOLS: } [ first2 (malloc-guid-symbol) ] each ; : define-joystick-format-constant ( -- ) - c_dfDIJoystick2 global [ [ + c_dfDIJoystick2 [ DIDF_ABSAXIS "DIJOYSTATE2" heap-size "DIJOYSTATE2" { @@ -274,10 +277,10 @@ SYMBOLS: { GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } { GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } } - ] unless* ] change-at ; + ] initialize ; : define-mouse-format-constant ( -- ) - c_dfDIMouse2 global [ [ + c_dfDIMouse2 [ DIDF_RELAXIS "DIMOUSESTATE2" heap-size "DIMOUSESTATE2" { @@ -293,13 +296,13 @@ SYMBOLS: { GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } { GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } } - ] unless* ] change-at ; + ] initialize ; ! Not a standard DirectInput format. Included for cross-platform niceness. ! This format returns the keyboard keys in USB HID order rather than Windows ! order : define-hid-keyboard-format-constant ( -- ) - c_dfDIKeyboard_HID global [ [ + c_dfDIKeyboard_HID [ DIDF_RELAXIS 256 f { @@ -560,10 +563,10 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-keyboard-format-constant ( -- ) - c_dfDIKeyboard global [ [ + c_dfDIKeyboard [ DIDF_RELAXIS 256 f { @@ -824,7 +827,7 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-format-constants ( -- ) define-joystick-format-constant @@ -837,7 +840,9 @@ SYMBOLS: define-format-constants ; [ define-constants ] "windows.dinput.constants" add-init-hook -define-constants + +: uninitialize ( variable quot -- ) + [ global ] dip '[ _ when* f ] change-at ; inline : free-dinput-constants ( -- ) { @@ -846,10 +851,11 @@ define-constants GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced - } [ global [ [ free ] when* f ] change-at ] each + } [ [ free ] uninitialize ] each + { c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2 - } [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ; + } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ; PRIVATE> From 54f82be4e0553f5c43dad5f658ede99d11870245 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Sat, 18 Apr 2009 22:28:57 -0400 Subject: [PATCH 15/16] fuel: fix usage of (fuel-eval) It used to take a string, but now takes a sequence of strings. --- extra/fuel/eval/eval.factor | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index ae1c5863a8..019b9105bc 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -59,17 +59,14 @@ t fuel-eval-res-flag set-global [ [ parse-lines ] with-compilation-unit call( -- ) ] curry [ print-error ] recover ; -: (fuel-eval-each) ( lines -- ) - [ (fuel-eval) ] each ; - : (fuel-eval-usings) ( usings -- ) [ "USE: " prepend ] map - (fuel-eval-each) fuel-forget-error fuel-forget-output ; + (fuel-eval) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend (fuel-eval) in set ] when* ; + [ dup "IN: " prepend 1array (fuel-eval) in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) - [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer + [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer (fuel-end-eval) ; From 1c123e7e22f84e7c8eeb0d58e3b7cb54efcdef8d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 21:53:22 -0500 Subject: [PATCH 16/16] Remove some usages of -rot and tuck --- basis/hash2/hash2-tests.factor | 6 ++-- basis/hash2/hash2.factor | 12 ++++--- .../launcher/unix/parser/parser-tests.factor | 14 ++++---- basis/io/launcher/unix/parser/parser.factor | 34 +++++-------------- basis/io/sockets/sockets.factor | 2 +- basis/lists/lists.factor | 3 +- basis/match/match.factor | 3 +- basis/smtp/smtp.factor | 7 ++-- basis/tools/completion/completion.factor | 16 ++++----- basis/ui/gadgets/gadgets.factor | 6 ++-- 10 files changed, 44 insertions(+), 59 deletions(-) diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor index 15bbcb36ef..682680bc50 100644 --- a/basis/hash2/hash2-tests.factor +++ b/basis/hash2/hash2-tests.factor @@ -6,9 +6,9 @@ IN: hash2.tests : sample-hash ( -- hash ) 5 - dup 2 3 "foo" roll set-hash2 - dup 4 2 "bar" roll set-hash2 - dup 4 7 "other" roll set-hash2 ; + [ [ 2 3 "foo" ] dip set-hash2 ] keep + [ [ 4 2 "bar" ] dip set-hash2 ] keep + [ [ 4 7 "other" ] dip set-hash2 ] keep ; [ "foo" ] [ 2 3 sample-hash hash2 ] unit-test [ "bar" ] [ 4 2 sample-hash hash2 ] unit-test diff --git a/basis/hash2/hash2.factor b/basis/hash2/hash2.factor index ffe6926130..aadc0d45a2 100644 --- a/basis/hash2/hash2.factor +++ b/basis/hash2/hash2.factor @@ -1,4 +1,6 @@ -USING: kernel sequences arrays math vectors ; +! Copyright (C) 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences arrays math vectors locals ; IN: hash2 ! Little ad-hoc datastructure used to map two numbers @@ -22,8 +24,8 @@ IN: hash2 : assoc2 ( a b alist -- value ) (assoc2) dup [ third ] when ; inline -: set-assoc2 ( value a b alist -- alist ) - [ rot 3array ] dip ?push ; inline +:: set-assoc2 ( value a b alist -- alist ) + { a b value } alist ?push ; inline : hash2@ ( a b hash2 -- a b bucket hash2 ) [ 2dup hashcode2 ] dip [ length mod ] keep ; inline @@ -31,8 +33,8 @@ IN: hash2 : hash2 ( a b hash2 -- value/f ) hash2@ nth dup [ assoc2 ] [ 3drop f ] if ; -: set-hash2 ( a b value hash2 -- ) - [ -rot ] dip hash2@ [ set-assoc2 ] change-nth ; +:: set-hash2 ( a b value hash2 -- ) + value a b hash2 hash2@ [ set-assoc2 ] change-nth ; : alist>hash2 ( alist size -- hash2 ) [ over [ first3 ] dip set-hash2 ] reduce ; inline diff --git a/basis/io/launcher/unix/parser/parser-tests.factor b/basis/io/launcher/unix/parser/parser-tests.factor index 07502e87a4..90504ccac2 100644 --- a/basis/io/launcher/unix/parser/parser-tests.factor +++ b/basis/io/launcher/unix/parser/parser-tests.factor @@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ; [ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test [ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test [ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test +[ "\"abc def\" \"hey" tokenize-command ] must-fail +[ "\"abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test [ V{ diff --git a/basis/io/launcher/unix/parser/parser.factor b/basis/io/launcher/unix/parser/parser.factor index 97e6dee95f..bcc5f965e9 100644 --- a/basis/io/launcher/unix/parser/parser.factor +++ b/basis/io/launcher/unix/parser/parser.factor @@ -1,33 +1,17 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.parsers kernel sequences strings words ; +USING: peg peg.ebnf arrays sequences strings kernel ; IN: io.launcher.unix.parser ! Our command line parser. Supported syntax: ! foo bar baz -- simple tokens ! foo\ bar -- escaping the space -! 'foo bar' -- quotation ! "foo bar" -- quotation -: 'escaped-char' ( -- parser ) - "\\" token any-char 2seq [ second ] action ; - -: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - 2choice ; inline - -: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' repeat0 swap dup surrounded-by ; - -: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; - -: 'argument' ( -- parser ) - "\"" 'quoted' - "'" 'quoted' - 'unquoted' 3choice - [ >string ] action ; - -PEG: tokenize-command ( command -- ast/f ) - 'argument' " " token repeat1 list-of - " " token repeat0 tuck pack - just ; +EBNF: tokenize-command +space = " " +escaped-char = "\" .:ch => [[ ch ]] +quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]] +unquoted = (escaped-char | [^ "])+ +argument = (quoted | unquoted) => [[ >string ]] +command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]] +;EBNF diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 8dce527553..a0beb1f421 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local ) ] with-destructors ; : ( remote encoding -- stream local ) - [ (client) -rot ] dip swap ; + [ (client) ] dip swap [ ] dip ; SYMBOL: local-address diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 4b0abb7f2d..fecb76f1c0 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -106,7 +106,8 @@ PRIVATE> : deep-sequence>cons ( sequence -- cons ) [ ] keep nil - [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ] + with reduce ; vector) ( acc list quot: ( elt -- elt' ) -- acc ) diff --git a/basis/match/match.factor b/basis/match/match.factor index b21d8c6d73..ec0cb8c9e6 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- ) } cond ; : match-replace ( object pattern1 pattern2 -- result ) - -rot - match [ "Pattern does not match" throw ] unless* + [ match [ "Pattern does not match" throw ] unless* ] dip swap [ replace-patterns ] bind ; : ?1-tail ( seq -- tail/f ) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 822fc92090..605423820b 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -164,9 +164,8 @@ M: plain-auth send-auth : encode-header ( string -- string' ) dup aux>> [ - "=?utf-8?B?" - swap utf8 encode >base64 - "?=" 3append + utf8 encode >base64 + "=?utf-8?B?" "?=" surround ] when ; ERROR: invalid-header-string string ; @@ -205,7 +204,7 @@ ERROR: invalid-header-string string ; now timestamp>rfc822 "Date" set message-id "Message-Id" set "1.0" "MIME-Version" set - "base64" "Content-Transfer-Encoding" set + "quoted-printable" "Content-Transfer-Encoding" set { [ from>> "From" set ] [ to>> ", " join "To" set ] diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 14cec8e85f..99def097a2 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -3,20 +3,20 @@ USING: accessors kernel arrays sequences math namespaces strings io fry vectors words assocs combinators sorting unicode.case unicode.categories math.order vocabs -tools.vocabs unicode.data ; +tools.vocabs unicode.data locals ; IN: tools.completion -: (fuzzy) ( accum ch i full -- accum i ? ) - index-from - [ - [ swap push ] 2keep 1+ t +:: (fuzzy) ( accum i full ch -- accum i full ? ) + ch i full index-from [ + :> i i accum push + accum i 1+ full t ] [ - drop f -1 f + f -1 full f ] if* ; : fuzzy ( full short -- indices ) - dup length -rot 0 -rot - [ -rot [ (fuzzy) ] keep swap ] all? 3drop ; + dup [ length 0 ] curry 2dip + [ (fuzzy) ] all? 3drop ; : (runs) ( runs n seq -- runs n ) [ diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index bc07006d62..32d6c0c8a6 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,7 +3,7 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry ; +concurrency.flags math.order math.rectangles fry locals ; IN: ui.gadgets ! Values for orientation slot @@ -66,8 +66,8 @@ M: gadget children-on nip children>> ; : ((fast-children-on)) ( gadget dim axis -- <=> ) [ swap loc>> v- ] dip v. 0 <=> ; -: (fast-children-on) ( dim axis children -- i ) - -rot '[ _ _ ((fast-children-on)) ] search drop ; +:: (fast-children-on) ( dim axis children -- i ) + children [ dim axis ((fast-children-on)) ] search drop ; PRIVATE>