From a18c5816e036fabdb2a116b2038c44096ae6cffb Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Thu, 30 Apr 2009 08:29:49 -0500 Subject: [PATCH 01/10] refactoring cocoa.dialogs for directories --- basis/cocoa/dialogs/dialogs.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor index 84a1ad46a3..7761286127 100644 --- a/basis/cocoa/dialogs/dialogs.factor +++ b/basis/cocoa/dialogs/dialogs.factor @@ -12,6 +12,9 @@ IN: cocoa.dialogs dup 1 -> setResolvesAliases: dup 1 -> setAllowsMultipleSelection: ; +: ( -- panel ) + dup 1 -> setCanChooseDirectories: ; + : ( -- panel ) NSSavePanel -> savePanel dup 1 -> setCanChooseFiles: @@ -21,10 +24,12 @@ IN: cocoa.dialogs CONSTANT: NSOKButton 1 CONSTANT: NSCancelButton 0 -: open-panel ( -- paths ) - +: (open-panel) ( panel -- paths ) dup -> runModal NSOKButton = [ -> filenames CF>string-array ] [ drop f ] if ; + +: open-panel ( -- paths ) (open-panel) ; +: open-dir-panel ( -- paths ) (open-panel) ; : split-path ( path -- dir file ) "/" split1-last [ ] bi@ ; From 5038cb3ba61b8fc6555000a567411113839c74d2 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Thu, 30 Apr 2009 08:30:45 -0500 Subject: [PATCH 02/10] added run-desc in io.launcher --- basis/io/launcher/launcher.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index f5809223fc..838c09c657 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -3,9 +3,9 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors environment -io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.ports debugger prettyprint summary -calendar ; +io io.encodings.ascii io.backend io.timeouts io.pipes +io.pipes.private io.encodings io.streams.duplex io.ports +debugger prettyprint summary calendar ; IN: io.launcher TUPLE: process < identity-tuple @@ -265,3 +265,5 @@ M: object run-pipeline-element { [ os winnt? ] [ "io.launcher.windows.nt" require ] } [ ] } cond + +: run-desc ( desc -- result ) ascii f swap stream-read-until drop ; From 0c718a047c32779e95d65fad4f3d720bffd2b9e9 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 1 May 2009 10:40:33 -0500 Subject: [PATCH 03/10] frp docs fixed --- extra/ui/frp/frp-docs.factor | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index a6f625cc59..af44567e46 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -1,36 +1,46 @@ -USING: ui.frp help.syntax help.markup monads sequences ; +USING: help.markup help.syntax models monads sequences +ui.gadgets.buttons ui.gadgets.tracks ; IN: ui.frp ! Layout utilities HELP: , +{ $values { "uiitem" "a gadget or model" } } { $description "Used in a series of gadgets created by a box, accumulating the gadget" } ; HELP: -> +{ $values { "uiitem" "a gadget or model" } { "model" model } } { $description "Like " { $link , } "but passes its model on for further use." } ; HELP: +{ $values { "gadgets" "a list of gadgets" } { "track" track } } { $syntax "[ gadget , gadget , ... ] " } { $description "Creates an horizontal track containing the gadgets listed in the quotation" } ; HELP: +{ $values { "gadgets" "a list of gadgets" } { "track" track } } { $syntax "[ gadget , gadget , ... ] " } { $description "Creates an vertical track containing the gadgets listed in the quotation" } ; ! Gadgets HELP: +{ $values { "text" "the button's label" } { "button" button } } { $description "Creates an button whose model updates on clicks" } ; HELP: -{ $description "Creates a model that merges the updates of two others" } ; +{ $values { "models" "a list of models" } { "model" merge-model } } +{ $description "Creates a model that merges the updates of others" } ; HELP: +{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } } { $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ; HELP: +{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; HELP: switch +{ $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; ARTICLE: { "frp" "instances" } "FRP Instances" -"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. " -"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ; +"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. " +"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ; From 471fe2c2729c2359cf841909f155bac04bdb6cd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 10:41:27 -0500 Subject: [PATCH 04/10] rename lines to stream-lines rename cnotents to stream-contents --- basis/ftp/client/client.factor | 2 +- basis/io/encodings/string/string.factor | 2 +- basis/xmode/code2html/code2html.factor | 2 +- core/checksums/checksums.factor | 2 +- core/io/files/files.factor | 4 ++-- core/io/io-docs.factor | 15 +++++++++++++-- core/io/io.factor | 10 ++++++++-- core/parser/parser.factor | 2 +- extra/contributors/contributors.factor | 2 +- extra/mason/common/common.factor | 2 +- 10 files changed, 30 insertions(+), 13 deletions(-) diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index 14877110d3..9d51ba259e 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -66,7 +66,7 @@ ERROR: ftp-error got expected ; : list ( url -- ftp-response ) utf8 open-passive-client ftp-list - lines + stream-lines swap >>strings read-response 226 ftp-assert parse-list ; diff --git a/basis/io/encodings/string/string.factor b/basis/io/encodings/string/string.factor index 5e57a943a9..3659939fb0 100644 --- a/basis/io/encodings/string/string.factor +++ b/basis/io/encodings/string/string.factor @@ -4,7 +4,7 @@ USING: io io.streams.byte-array ; IN: io.encodings.string : decode ( byte-array encoding -- string ) - contents ; + stream-contents ; : encode ( string encoding -- byte-array ) [ write ] with-byte-writer ; diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor index 3fb5a532c9..b5141f6cc4 100644 --- a/basis/xmode/code2html/code2html.factor +++ b/basis/xmode/code2html/code2html.factor @@ -24,7 +24,7 @@ IN: xmode.code2html [XML XML] ; :: htmlize-stream ( path stream -- xml ) - stream lines + stream stream-lines [ "" ] [ path over first find-mode htmlize-lines ] if-empty :> input default-stylesheet :> stylesheet diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 98d36b21c3..82918b6f81 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -13,7 +13,7 @@ GENERIC: checksum-stream ( stream checksum -- value ) GENERIC: checksum-lines ( lines checksum -- value ) M: checksum checksum-stream - [ contents ] dip checksum-bytes ; + [ stream-contents ] dip checksum-bytes ; M: checksum checksum-lines [ B{ CHAR: \n } join ] dip checksum-bytes ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1bc282e956..0f3041e670 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -20,13 +20,13 @@ HOOK: (file-appender) io-backend ( path -- stream ) swap normalize-path (file-appender) swap ; : file-lines ( path encoding -- seq ) - lines ; + stream-lines ; : with-file-reader ( path encoding quot -- ) [ ] dip with-input-stream ; inline : file-contents ( path encoding -- seq ) - contents ; + stream-contents ; : with-file-writer ( path encoding quot -- ) [ ] dip with-output-stream ; inline diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 740152f294..96222eaa55 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -221,10 +221,14 @@ HELP: bl { $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." } $io-error ; -HELP: lines +HELP: stream-lines { $values { "stream" "an input stream" } { "seq" "a sequence of strings" } } { $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ; +HELP: lines +{ $values { "seq" "a sequence of strings" } } +{ $description "Reads lines of text until from the " { $link input-stream } " until it is exhausted, collecting them in a sequence of strings." } ; + HELP: each-line { $values { "quot" { $quotation "( str -- )" } } } { $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ; @@ -233,11 +237,16 @@ HELP: each-block { $values { "quot" { $quotation "( block -- )" } } } { $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; -HELP: contents +HELP: stream-contents { $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } { $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." } $io-error ; +HELP: contents +{ $values { "seq" "a string, byte array or " { $link f } } } +{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs" { $link f } "." } +$io-error ; + ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl @@ -347,9 +356,11 @@ $nl "First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" { $subsection stream-print } "Processing lines one by one:" +{ $subsection stream-lines } { $subsection lines } { $subsection each-line } "Processing blocks of data:" +{ $subsection stream-contents } { $subsection contents } { $subsection each-block } "Copying the contents of one stream to another:" diff --git a/core/io/io.factor b/core/io/io.factor index 74bba7769e..b43098bcd4 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -68,9 +68,12 @@ SYMBOL: error-stream : bl ( -- ) " " write ; -: lines ( stream -- seq ) +: stream-lines ( stream -- seq ) [ [ readln dup ] [ ] produce nip ] with-input-stream ; +: lines ( -- seq ) + input-stream get stream-lines ; + : each-line ( quot -- ) [ readln ] each-morsel ; inline -: contents ( stream -- seq ) +: stream-contents ( stream -- seq ) [ [ 65536 read-partial dup ] [ ] produce nip concat f like ] with-input-stream ; +: contents ( -- seq ) + input-stream get stream-contents ; + : each-block ( quot: ( block -- ) -- ) [ 8192 read-partial ] each-morsel ; inline diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7908f40cbe..7915dc69e0 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -272,7 +272,7 @@ print-use-hook [ [ ] ] initialize : parse-stream ( stream name -- quot ) [ [ - lines dup parse-fresh + stream-lines dup parse-fresh [ nip ] [ finish-parsing ] 2bi forget-smudged ] with-source-file diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 1879c52826..73bee76c0a 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -7,7 +7,7 @@ IN: contributors : changelog ( -- authors ) image parent-directory [ - "git log --pretty=format:%an" ascii lines + "git log --pretty=format:%an" ascii stream-lines ] with-directory ; : patch-counts ( authors -- assoc ) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 285a684f06..b255b351f0 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -16,7 +16,7 @@ M: output-process-error error. : try-output-process ( command -- ) >process +stdout+ >>stderr utf8 - [ contents ] [ dup wait-for-process ] bi* + [ stream-contents ] [ dup wait-for-process ] bi* 0 = [ 2drop ] [ output-process-error ] if ; HOOK: really-delete-tree os ( path -- ) From d9a9e16fd78b36558d547027e9f670b2161c4ea5 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 1 May 2009 11:06:20 -0500 Subject: [PATCH 05/10] added file-trees vocab --- extra/file-trees/file-trees-tests.factor | 4 ++++ extra/file-trees/file-trees.factor | 23 +++++++++++++++++++++++ 2 files changed, 27 insertions(+) create mode 100644 extra/file-trees/file-trees-tests.factor create mode 100644 extra/file-trees/file-trees.factor diff --git a/extra/file-trees/file-trees-tests.factor b/extra/file-trees/file-trees-tests.factor new file mode 100644 index 0000000000..dbb8f9f5d8 --- /dev/null +++ b/extra/file-trees/file-trees-tests.factor @@ -0,0 +1,4 @@ +USING: kernel file-trees ; +IN: file-trees.tests +{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3" +"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop \ No newline at end of file diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor new file mode 100644 index 0000000000..788291c0a2 --- /dev/null +++ b/extra/file-trees/file-trees.factor @@ -0,0 +1,23 @@ +USING: accessors delegate delegate.protocols io.pathnames +kernel locals namespaces sequences vectors +tools.annotations prettyprint ; +IN: file-trees + +TUPLE: tree node children ; +CONSULT: sequence-protocol tree children>> [ node>> ] map ; + +: ( start -- tree ) V{ } clone + [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; + +DEFER: (tree-insert) + +: tree-insert ( path tree -- ) [ unclip ] [ children>> ] bi* (tree-insert) ; +:: (tree-insert) ( path-rest path-head tree-children -- ) + tree-children [ node>> path-head node>> = ] find nip + [ path-rest swap tree-insert ] + [ + path-head tree-children push + path-rest [ path-head tree-insert ] unless-empty + ] if* ; +: create-tree ( file-list -- tree ) [ path-components ] map + t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file From ac2557b4a78416c7d60e93d9a20438b222aa9a71 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 1 May 2009 11:06:48 -0500 Subject: [PATCH 06/10] frp changes --- extra/ui/frp/frp.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index f5c0f1bd10..aa7c44ee03 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -14,11 +14,12 @@ M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ; M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ; M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; -: ( model quot -- table ) - frp-table new-line-gadget dup >>renderer swap >>quot swap >>model +: ( model -- table ) + frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color transparent >>column-line-color ; +: ( model -- table ) [ 1array ] >>quot ; : ( -- field ) f ; ! Layout utilities @@ -27,11 +28,11 @@ GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; -GENERIC: , ( object -- ) +GENERIC: , ( uiitem -- ) M: gadget , make:, ; M: model , activate-model ; -GENERIC: -> ( object -- model ) +GENERIC: -> ( uiitem -- model ) M: gadget -> dup make:, output-model ; M: model -> dup , ; M: table -> dup , selected-value>> ; From 28ec9c3a3be7f21a4dfe463b7e06380cc0e93f26 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 15:56:16 -0500 Subject: [PATCH 07/10] fix spacing in io docs --- core/io/io-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 96222eaa55..3469a81064 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -239,12 +239,12 @@ HELP: each-block HELP: stream-contents { $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } -{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." } +{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." } $io-error ; HELP: contents { $values { "seq" "a string, byte array or " { $link f } } } -{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs" { $link f } "." } +{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" From ce7ad9a42d28ebfe2d370757ec7b384c9c6c67a3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 16:38:04 -0500 Subject: [PATCH 08/10] fix unit tests that call lines or contents --- basis/io/launcher/unix/unix-tests.factor | 14 +++++++------- .../io/servers/connection/connection-tests.factor | 2 +- basis/io/sockets/secure/unix/unix-tests.factor | 2 +- .../io/streams/byte-array/byte-array-tests.factor | 4 ++-- basis/ui/tools/listener/listener-tests.factor | 4 ++-- core/io/streams/c/c-tests.factor | 2 +- extra/irc/gitbot/gitbot.factor | 2 +- 7 files changed, 15 insertions(+), 15 deletions(-) diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index f375bb41e8..99d45e4fd7 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -33,7 +33,7 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ ] [ @@ -52,7 +52,7 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ ] [ @@ -70,14 +70,14 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ t ] [ "env" >>command { { "A" "B" } } >>environment - ascii lines + ascii stream-lines "A=B" swap member? ] unit-test @@ -86,7 +86,7 @@ concurrency.promises threads unix.process ; "env" >>command { { "A" "B" } } >>environment +replace-environment+ >>environment-mode - ascii lines + ascii stream-lines ] unit-test [ "hi\n" ] [ @@ -113,13 +113,13 @@ concurrency.promises threads unix.process ; "append-test" temp-file utf8 file-contents ] unit-test -[ t ] [ "ls" utf8 contents >boolean ] unit-test +[ t ] [ "ls" utf8 stream-contents >boolean ] unit-test [ "Hello world.\n" ] [ "cat" utf8 [ "Hello world.\n" write output-stream get dispose - input-stream get contents + input-stream get stream-contents ] with-stream ] unit-test diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index ae79290f0a..ab99531eb4 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ; dup start-server* sockets>> first addr>> port>> "port" set ] unit-test -[ "Hello world." ] [ "localhost" "port" get ascii drop contents ] unit-test +[ "Hello world." ] [ "localhost" "port" get ascii drop stream-contents ] unit-test diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor index 7c4dcc17d1..f87ad93fbd 100644 --- a/basis/io/sockets/secure/unix/unix-tests.factor +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ; : client-test ( -- string ) [ - "127.0.0.1" "port" get ?promise ascii drop contents + "127.0.0.1" "port" get ?promise ascii drop stream-contents ] with-secure-context ; [ ] [ [ class name>> write ] server-test ] unit-test diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor index 3cf52c6a78..0cd35dfa21 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/basis/io/streams/byte-array/byte-array-tests.factor @@ -6,7 +6,7 @@ io.encodings.utf8 io kernel arrays strings namespaces ; [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test -[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test +[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 stream-contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ B{ 0 121 120 0 0 0 0 0 0 } binary @@ -26,4 +26,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ; 0 seek-end input-stream get stream-seek read1 ] with-byte-reader -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 45b94344a6..e06e17374f 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -75,7 +75,7 @@ CONSTANT: text "Hello world.\nThis is a test." [ ] [ [ "interactor" get register-self - "interactor" get contents "promise" get fulfill + "interactor" get stream-contents "promise" get fulfill ] in-thread ] unit-test @@ -150,4 +150,4 @@ CONSTANT: text "Hello world.\nThis is a test." [ ] [ "l" set ] unit-test [ ] [ "l" get com-scroll-up ] unit-test -[ ] [ "l" get com-scroll-down ] unit-test \ No newline at end of file +[ ] [ "l" get com-scroll-down ] unit-test diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 3dde9152d0..6a82d6d545 100644 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -5,6 +5,6 @@ IN: io.streams.c.tests [ "hello world" ] [ "hello world" "test.txt" temp-file ascii set-file-contents - "test.txt" temp-file "rb" fopen contents + "test.txt" temp-file "rb" fopen stream-contents >string ] unit-test diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index d145b3bd2c..161a81d555 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -33,7 +33,7 @@ M: object handle-message drop ; "--pretty=format:%h %an: %s" , ".." glue , ] { } make - latin1 [ input-stream get lines ] with-process-reader ; + latin1 [ lines ] with-process-reader ; : updates ( from to -- lines ) git-log reverse From 0ad6d1fb7b40ee570008fab3af190a49004b6570 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 19:58:24 -0500 Subject: [PATCH 09/10] add a few usages of iota, remove most 1+ and 1- from core --- basis/random/random.factor | 2 +- core/assocs/assocs.factor | 4 +-- core/bootstrap/primitives.factor | 2 +- core/checksums/crc32/crc32.factor | 2 +- core/classes/tuple/tuple-docs.factor | 2 +- core/classes/tuple/tuple.factor | 4 +-- core/combinators/combinators.factor | 4 +-- core/continuations/continuations-tests.factor | 2 +- core/generic/single/single.factor | 4 +-- core/generic/standard/standard.factor | 2 +- core/growable/growable.factor | 2 +- core/hashtables/hashtables.factor | 10 +++--- core/io/pathnames/pathnames.factor | 6 ++-- core/io/streams/sequence/sequence.factor | 4 +-- core/kernel/kernel-tests.factor | 2 +- core/layouts/layouts.factor | 6 ++-- core/lexer/lexer.factor | 4 +-- core/math/floats/floats-tests.factor | 4 +-- core/math/integers/integers-tests.factor | 4 +-- core/math/integers/integers.factor | 10 +++--- core/math/math.factor | 12 +++---- core/namespaces/namespaces.factor | 4 +-- core/quotations/quotations.factor | 4 +-- core/sequences/sequences.factor | 36 +++++++++---------- core/sorting/sorting.factor | 12 +++---- core/splitting/splitting.factor | 2 +- core/syntax/syntax-docs.factor | 4 +-- 27 files changed, 77 insertions(+), 77 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index ebde3802b4..d972e1e7ac 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -54,7 +54,7 @@ PRIVATE> : randomize ( seq -- seq ) dup length [ dup 1 > ] - [ [ random ] [ 1- ] bi [ pick exchange ] keep ] + [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ] while drop ; : delete-random ( seq -- elt ) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ec56cffff7..e783ef81c4 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -32,7 +32,7 @@ M: assoc assoc-like drop ; 3drop f ] [ 3dup nth-unsafe at* - [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if + [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if ] if ; inline recursive : search-alist ( key alist -- pair/f i/f ) @@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) assoc-size 0 = ; : assoc-stack ( key seq -- value ) - [ length 1- ] keep (assoc-stack) ; flushable + [ length 1 - ] keep (assoc-stack) ; flushable : assoc-subset? ( assoc1 assoc2 -- ? ) [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index c0d51477ca..ec79185754 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -513,4 +513,4 @@ tuple } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number -"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared +"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared diff --git a/core/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor index 47da144d4d..7655ec8482 100644 --- a/core/checksums/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320 CONSTANT: crc32-table V{ } -256 [ +256 iota [ 8 [ [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless ] times >bignum diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index d76faddf15..4c55001aa1 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -254,7 +254,7 @@ ARTICLE: "tuple-examples" "Tuple examples" " } ;" "" ": next-position ( role -- newrole )" - " positions [ index 1+ ] keep nth ;" + " positions [ index 1 + ] keep nth ;" "" ": promote ( employee -- employee )" " [ 1.2 * ] change-salary" diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index fb1e613b3e..225176f4e5 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -165,7 +165,7 @@ ERROR: bad-superclass class ; { [ , ] [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ] - [ superclasses length 1- , ] + [ superclasses length 1 - , ] [ superclasses [ [ , ] [ hashcode , ] bi ] each ] } cleave ] { } make ; @@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x ) M: tuple tuple-hashcode [ - [ class hashcode ] [ tuple-size ] [ ] tri + [ class hashcode ] [ tuple-size iota ] [ ] tri [ rot ] dip [ swapd array-nth hashcode* sequence-hashcode-step ] 2curry each diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 1438edf3fa..7bf76fea30 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -123,7 +123,7 @@ ERROR: no-case object ; [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ; : hash-dispatch-quot ( table -- quot ) - [ length 1- [ fixnum-bitand ] curry ] keep + [ length 1 - [ fixnum-bitand ] curry ] keep [ dispatch ] curry append ; : hash-case-quot ( default assoc -- quot ) @@ -162,7 +162,7 @@ ERROR: no-case object ; ! recursive-hashcode : recursive-hashcode ( n obj quot -- code ) - pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline + pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline ! These go here, not in sequences and hashtables, since those ! two cannot depend on us diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index f4eeeefb77..6409fc588e 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -4,7 +4,7 @@ kernel.private accessors eval ; IN: continuations.tests : (callcc1-test) ( n obj -- n' obj ) - [ 1- dup ] dip ?push + [ 1 - dup ] dip ?push over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 4fe9ce5a36..d8fa04edd6 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -178,7 +178,7 @@ M: echelon-dispatch-engine compile-engine M: tuple-dispatch-engine compile-engine tuple assumed [ echelons>> compile-engines - dup keys supremum 1+ f + dup keys supremum 1 + f [ swap update ] keep ] with-variable ; @@ -253,4 +253,4 @@ M: single-combination perform-combination [ mega-cache-quot define ] [ define-inline-cache-quot ] 2tri - ] with-combination ; \ No newline at end of file + ] with-combination ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 96c273e3f8..c8d1acba8f 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -28,7 +28,7 @@ CONSTANT: simple-combination T{ standard-combination f 0 } { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] + [ 1 - (picker) [ dip swap ] curry ] } case ; M: standard-combination picker diff --git a/core/growable/growable.factor b/core/growable/growable.factor index c4970f98bd..684aab1158 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -35,7 +35,7 @@ M: growable set-length ( n seq -- ) ] if (>>length) ; -: new-size ( old -- new ) 1+ 3 * ; inline +: new-size ( old -- new ) 1 + 3 * ; inline : ensure ( n seq -- n seq ) growable-check diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index f95a7a7e67..0914134bb6 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -34,7 +34,7 @@ TUPLE: hashtable [ no-key ] [ 2dup hash@ (key@) ] if ; inline : ( n -- array ) - 1+ next-power-of-2 4 * ((empty)) ; inline + 1 + next-power-of-2 4 * ((empty)) ; inline : init-hash ( hash -- ) 0 >>count 0 >>deleted drop ; inline @@ -61,10 +61,10 @@ TUPLE: hashtable 1 fixnum+fast set-slot ; inline : hash-count+ ( hash -- ) - [ 1+ ] change-count drop ; inline + [ 1 + ] change-count drop ; inline : hash-deleted+ ( hash -- ) - [ 1+ ] change-deleted drop ; inline + [ 1 + ] change-deleted drop ; inline : (rehash) ( hash alist -- ) swap [ swapd set-at ] curry assoc-each ; inline @@ -77,7 +77,7 @@ TUPLE: hashtable [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline : grow-hash ( hash -- ) - [ [ >alist ] [ assoc-size 1+ ] bi ] keep + [ [ >alist ] [ assoc-size 1 + ] bi ] keep [ reset-hash ] keep swap (rehash) ; @@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- ) PRIVATE> M: hashtable >alist - [ array>> [ length 2/ ] keep ] [ assoc-size ] bi [ + [ array>> [ length 2/ iota ] keep ] [ assoc-size ] bi [ [ [ [ 1 fixnum-shift-fast ] dip diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index eba3e6a19f..30e9e6c206 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -17,7 +17,7 @@ SYMBOL: current-directory [ path-separator? ] trim-head ; : last-path-separator ( path -- n ? ) - [ length 1- ] keep [ path-separator? ] find-last-from ; + [ length 1 - ] keep [ path-separator? ] find-last-from ; HOOK: root-directory? io-backend ( path -- ? ) @@ -30,7 +30,7 @@ ERROR: no-parent-directory path ; dup root-directory? [ trim-tail-separators dup last-path-separator [ - 1+ cut + 1 + cut ] [ drop "." swap ] if @@ -113,7 +113,7 @@ PRIVATE> : file-name ( path -- string ) dup root-directory? [ trim-tail-separators - dup last-path-separator [ 1+ tail ] [ + dup last-path-separator [ 1 + tail ] [ drop special-path? [ file-name ] when ] if ] unless ; diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor index 0f922a37cc..036bab2213 100644 --- a/core/io/streams/sequence/sequence.factor +++ b/core/io/streams/sequence/sequence.factor @@ -12,7 +12,7 @@ SLOT: i [ i>> ] [ underlying>> ] bi ; inline : next ( stream -- ) - [ 1+ ] change-i drop ; inline + [ 1 + ] change-i drop ; inline : sequence-read1 ( stream -- elt/f ) [ >sequence-stream< ?nth ] [ next ] bi ; inline @@ -45,4 +45,4 @@ M: growable stream-write1 push ; M: growable stream-write push-all ; M: growable stream-flush drop ; -INSTANCE: growable plain-writer \ No newline at end of file +INSTANCE: growable plain-writer diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index b58c744b05..5a88db4f9e 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -114,7 +114,7 @@ IN: kernel.tests ! Regression : (loop) ( a b c d -- ) [ pick ] dip swap [ pick ] dip swap - < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive + < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive : loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 00b9500211..42898fc085 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -49,13 +49,13 @@ SYMBOL: mega-cache-size cell-bits (first-bignum) ; inline : most-positive-fixnum ( -- n ) - first-bignum 1- ; inline + first-bignum 1 - ; inline : most-negative-fixnum ( -- n ) first-bignum neg ; inline : (max-array-capacity) ( b -- n ) - 5 - 2^ 1- ; inline + 5 - 2^ 1 - ; inline : max-array-capacity ( -- n ) cell-bits (max-array-capacity) ; inline @@ -64,7 +64,7 @@ SYMBOL: mega-cache-size bootstrap-cell-bits (first-bignum) ; : bootstrap-most-positive-fixnum ( -- n ) - bootstrap-first-bignum 1- ; + bootstrap-first-bignum 1 - ; : bootstrap-most-negative-fixnum ( -- n ) bootstrap-first-bignum neg ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 75341f0204..60157033d7 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ; : next-line ( lexer -- ) dup [ line>> ] [ text>> ] bi ?nth >>line-text dup line-text>> length >>line-length - [ 1+ ] change-line + [ 1 + ] change-line 0 >>column drop ; @@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if + 2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if ] change-lexer-column ; : still-parsing? ( lexer -- ? ) diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 9f8f7b06fc..097e2c14aa 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -50,8 +50,8 @@ IN: math.floats.tests [ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ] unit-test -[ 2.0 ] [ 1.0 1+ ] unit-test -[ 0.0 ] [ 1.0 1- ] unit-test +[ 2.0 ] [ 1.0 1 + ] unit-test +[ 0.0 ] [ 1.0 1 - ] unit-test [ t ] [ 0.0 zero? ] unit-test [ t ] [ -0.0 zero? ] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 6bd3e9b094..a9469ae91a 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -206,8 +206,8 @@ unit-test [ 2. ] [ 2 1 ratio>float ] unit-test [ .5 ] [ 1 2 ratio>float ] unit-test [ .75 ] [ 3 4 ratio>float ] unit-test -[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test -[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test +[ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test +[ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test [ 0.4 ] [ 6 15 ratio>float ] unit-test [ HEX: 3fe553522d230931 ] diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 868d9fc02e..bb7fc107b2 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; : fixnum-log2 ( x -- n ) - 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ; + 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ; M: fixnum (log2) fixnum-log2 ; @@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ; ! provided with absolutely no warranty." ! First step: pre-scaling -: twos ( x -- y ) dup 1- bitxor log2 ; inline +: twos ( x -- y ) dup 1 - bitxor log2 ; inline : scale-denonimator ( den -- scaled-den scale' ) dup twos neg [ shift ] keep ; inline @@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ; ! Second step: loop : shift-mantissa ( scale mantissa -- scale' mantissa' ) - [ 1+ ] [ 2/ ] bi* ; inline + [ 1 + ] [ 2/ ] bi* ; inline : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) [ 2dup /i log2 53 > ] @@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ; ! Third step: post-scaling : unscaled-float ( mantissa -- n ) - 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline + 52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline : scale-float ( scale mantissa -- float' ) [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline @@ -126,7 +126,7 @@ M: bignum (log2) bignum-log2 ; ] [ pre-scale /f-loop over odd? - [ zero? [ 1+ ] unless ] [ drop ] if + [ zero? [ 1 + ] unless ] [ drop ] if post-scale ] if ] if ; inline diff --git a/core/math/math.factor b/core/math/math.factor index 993d8d0e76..8e0000326f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -63,7 +63,7 @@ PRIVATE> : neg ( x -- -x ) 0 swap - ; inline : recip ( x -- y ) 1 swap / ; inline : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline -: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline +: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable : 2^ ( n -- 2^n ) 1 swap shift ; inline : even? ( n -- ? ) 1 bitand zero? ; @@ -103,13 +103,13 @@ M: float fp-infinity? ( float -- ? ) ] if ; : next-power-of-2 ( m -- n ) - dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline + dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline : power-of-2? ( n -- ? ) - dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable + dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable : align ( m w -- n ) - 1- [ + ] keep bitnot bitand ; inline + 1 - [ + ] keep bitnot bitand ; inline @@ -160,6 +160,6 @@ PRIVATE> [ call ] 2keep rot [ drop ] [ - [ 1- ] dip find-last-integer + [ 1 - ] dip find-last-integer ] if ] if ; inline recursive diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 310816cbf7..64cc328d19 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -29,8 +29,8 @@ PRIVATE> : inc ( variable -- ) 1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline : bind ( ns quot -- ) swap >n call ndrop ; inline -: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ; +: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ; : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline : with-scope ( quot -- ) 5 swap bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline -: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline \ No newline at end of file +: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 2c3b41ca4e..3245ac1e20 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -48,12 +48,12 @@ M: object literalize ; M: wrapper literalize ; -M: curry length quot>> length 1+ ; +M: curry length quot>> length 1 + ; M: curry nth over 0 = [ nip obj>> literalize ] - [ [ 1- ] dip quot>> nth ] + [ [ 1 - ] dip quot>> nth ] if ; INSTANCE: curry immutable-sequence diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 79195d1938..d60602fc71 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -198,7 +198,7 @@ C: reversed M: reversed virtual-seq seq>> ; -M: reversed virtual@ seq>> [ length swap - 1- ] keep ; +M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; M: reversed length seq>> length ; @@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence ] 3keep ; inline : (copy) ( dst i src j n -- dst ) - dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; + dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ; inline recursive : prepare-subseq ( from to seq -- dst i src j n ) @@ -460,7 +460,7 @@ PRIVATE> [ nip find-last-integer ] (find-from) ; inline : find-last ( seq quot -- i elt ) - [ [ 1- ] dip find-last-integer ] (find) ; inline + [ [ 1 - ] dip find-last-integer ] (find) ; inline : all? ( seq quot -- ? ) (each) all-integers? ; inline @@ -556,7 +556,7 @@ PRIVATE> [ empty? not ] filter ; : mismatch ( seq1 seq2 -- i ) - [ min-length ] 2keep + [ min-length iota ] 2keep [ 2nth-unsafe = not ] 2curry find drop ; inline @@ -595,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : (filter-here) ( quot: ( elt -- ? ) store scan seq -- ) 2dup length < [ [ move ] 3keep - [ nth-unsafe pick call [ 1+ ] when ] 2keep - [ 1+ ] dip + [ nth-unsafe pick call [ 1 + ] when ] 2keep + [ 1 + ] dip (filter-here) ] [ nip set-length drop ] if ; inline recursive @@ -612,20 +612,20 @@ PRIVATE> [ eq? not ] with filter-here ; : prefix ( seq elt -- newseq ) - over [ over length 1+ ] dip [ + over [ over length 1 + ] dip [ [ 0 swap set-nth-unsafe ] keep [ 1 swap copy ] keep ] new-like ; : suffix ( seq elt -- newseq ) - over [ over length 1+ ] dip [ + over [ over length 1 + ] dip [ [ [ over length ] dip set-nth-unsafe ] keep [ 0 swap copy ] keep ] new-like ; -: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ; +: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ; -: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; +: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; 2over = [ 2drop 2drop ] [ - [ [ 2over + pick ] dip move [ 1+ ] dip ] keep + [ [ 2over + pick ] dip move [ 1 + ] dip ] keep move-backward ] if ; @@ -641,13 +641,13 @@ PRIVATE> 2over = [ 2drop 2drop ] [ - [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep + [ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep move-forward ] if ; : (open-slice) ( shift from to seq ? -- ) [ - [ [ 1- ] bi@ ] dip move-forward + [ [ 1 - ] bi@ ] dip move-forward ] [ [ over - ] 2dip move-backward ] if ; @@ -667,7 +667,7 @@ PRIVATE> check-slice [ over [ - ] dip ] dip open-slice ; : delete-nth ( n seq -- ) - [ dup 1+ ] dip delete-slice ; + [ dup 1 + ] dip delete-slice ; : snip ( from to seq -- head tail ) [ swap head ] [ swap tail ] bi-curry bi* ; inline @@ -679,10 +679,10 @@ PRIVATE> snip-slice surround ; : remove-nth ( n seq -- seq' ) - [ [ { } ] dip dup 1+ ] dip replace-slice ; + [ [ { } ] dip dup 1 + ] dip replace-slice ; : pop ( seq -- elt ) - [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; + [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ; : exchange ( m n seq -- ) [ nip bounds-check 2drop ] @@ -692,7 +692,7 @@ PRIVATE> : reverse-here ( seq -- ) [ length 2/ ] [ length ] [ ] tri - [ [ over - 1- ] dip exchange-unsafe ] 2curry each ; + [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; : reverse ( seq -- newseq ) [ @@ -799,7 +799,7 @@ PRIVATE> PRIVATE> : start* ( subseq seq n -- i ) - pick length pick length swap - 1+ + pick length pick length swap - 1 + [ (start) ] find-from swap [ 3drop ] dip ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 30ecb70ed9..f2fa6b8771 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -29,13 +29,13 @@ TUPLE: merge [ [ [ 2drop ] dip nth-unsafe ] dip push ] [ pick 2 = [ [ - [ 2drop dup 1+ ] dip + [ 2drop dup 1 + ] dip [ nth-unsafe ] curry bi@ ] dip [ push ] curry bi@ ] [ pick 3 = [ [ - [ 2drop dup 1+ dup 1+ ] dip + [ 2drop dup 1 + dup 1 + ] dip [ nth-unsafe ] curry tri@ ] dip [ push ] curry tri@ ] [ [ nip subseq ] dip push-all ] if @@ -57,10 +57,10 @@ TUPLE: merge [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline : l-next ( merge -- ) - [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline + [ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline : r-next ( merge -- ) - [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline + [ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline : decide ( merge -- ? ) [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline @@ -129,8 +129,8 @@ TUPLE: merge while 2drop ; inline : each-pair ( seq quot -- ) - [ [ length 1+ 2/ ] keep ] dip - [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline + [ [ length 1 + 2/ ] keep ] dip + [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline : (sort-pairs) ( i1 i2 seq quot accum -- ) [ 2dup length = ] 2dip rot [ diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 6d833c792e..c55a75baa6 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -55,7 +55,7 @@ PRIVATE> : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop - [ [ swap subseq , ] 2keep 1+ swap (split) ] + [ [ swap subseq , ] 2keep 1 + swap (split) ] [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index e8f86faa9d..fff355fb95 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -749,7 +749,7 @@ HELP: " "" @@ -760,7 +760,7 @@ HELP: Date: Fri, 1 May 2009 22:14:26 -0500 Subject: [PATCH 10/10] Adding output>sequence and input nil [ t ] [ pi [ pi ] matches? ] unit-test [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test -[ ] [ 3 [ _ ] undo ] unit-test +[ ] [ 3 [ __ ] undo ] unit-test [ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test [ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test @@ -88,4 +90,7 @@ TUPLE: funny-tuple ; : ( -- funny-tuple ) \ funny-tuple boa ; : funny-tuple ( -- ) "OOPS" throw ; -[ ] [ [ ] [undo] drop ] unit-test \ No newline at end of file +[ ] [ [ ] [undo] drop ] unit-test + +[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test +[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input __ +sequences.private combinators mirrors splitting combinators.smart +combinators.short-circuit fry words.symbol generalizations +classes ; IN: inverse ERROR: fail ; M: fail summary drop "Matching failed" ; -: assure ( ? -- ) [ fail ] unless ; +: assure ( ? -- ) [ fail ] unless ; inline -: =/fail ( obj1 obj2 -- ) = assure ; +: =/fail ( obj1 obj2 -- ) = assure ; inline ! Inverse of a quotation @@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ; \ pick [ [ pick ] dip =/fail ] define-inverse \ tuck [ swapd [ =/fail ] keep ] define-inverse +\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse +\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse +\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse +\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse + \ not define-involution -\ >boolean [ { t f } memq? assure ] define-inverse +\ >boolean [ dup { t f } memq? assure ] define-inverse \ tuple>array \ >tuple define-dual \ reverse define-involution -\ undo 1 [ [ call ] curry ] define-pop-inverse -\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse +\ undo 1 [ ] define-pop-inverse +\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse \ exp \ log define-dual \ sq \ sqrt define-dual @@ -173,16 +178,13 @@ ERROR: missing-literal ; 2curry ] define-pop-inverse -DEFER: _ -\ _ [ drop ] define-inverse +DEFER: __ +\ __ [ drop ] define-inverse : both ( object object -- object ) dupd assert= ; \ both [ dup ] define-inverse -: assure-length ( seq length -- seq ) - over length =/fail ; - { { >array array? } { >vector vector? } @@ -194,14 +196,23 @@ DEFER: _ { >string string? } { >sbuf sbuf? } { >quotation quotation? } -} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each +} [ '[ dup _ execute assure ] define-inverse ] assoc-each -! These actually work on all seqs--should they? -\ 1array [ 1 assure-length first ] define-inverse -\ 2array [ 2 assure-length first2 ] define-inverse -\ 3array [ 3 assure-length first3 ] define-inverse -\ 4array [ 4 assure-length first4 ] define-inverse -\ narray 1 [ [ firstn ] curry ] define-pop-inverse +: assure-length ( seq length -- ) + swap length =/fail ; inline + +: assure-array ( array -- array ) + dup array? assure ; inline + +: undo-narray ( array n -- ... ) + [ assure-array ] dip + [ assure-length ] [ firstn ] 2bi ; inline + +\ 1array [ 1 undo-narray ] define-inverse +\ 2array [ 2 undo-narray ] define-inverse +\ 3array [ 3 undo-narray ] define-inverse +\ 4array [ 4 undo-narray ] define-inverse +\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse \ first [ 1array ] define-inverse \ first2 [ 2array ] define-inverse @@ -214,6 +225,12 @@ DEFER: _ \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse +: assure-same-class ( obj1 obj2 -- ) + [ class ] bi@ = assure ; inline + +\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ inputsequence ] ] define-pop-inverse + ! Constructor inverse : deconstruct-pred ( class -- quot ) "predicate" word-prop [ dupd call assure ] curry ; @@ -245,7 +262,7 @@ DEFER: _ ] recover ; inline : true-out ( quot effect -- quot' ) - out>> '[ @ __ ndrop t ] ; + out>> '[ @ _ ndrop t ] ; : false-recover ( effect -- quot ) in>> [ ndrop f ] curry [ recover-fail ] curry ;