From a366909c25437b49daa3a3a035f500657481ba49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 15:28:22 -0500 Subject: [PATCH 1/4] Removing slip usage from basis --- basis/cocoa/application/application.factor | 2 +- basis/compiler/codegen/codegen.factor | 3 +-- basis/stack-checker/known-words/known-words.factor | 14 +------------- basis/xml/xml.factor | 2 +- 4 files changed, 4 insertions(+), 17 deletions(-) diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 8b33986fc2..66093645c1 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel NSApplicationDelegateReplyFailure ; : with-autorelease-pool ( quot -- ) - NSAutoreleasePool -> new slip -> release ; inline + NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline : NSApp ( -- app ) NSApplication -> sharedApplication ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 47593878fa..c7b67b72b4 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -444,8 +444,7 @@ TUPLE: callback-context ; : do-callback ( quot token -- ) init-catchstack - dup 2 setenv - slip + [ 2 setenv call ] keep wait-to-return ; inline : callback-return-quot ( ctype -- quot ) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 7603324200..56ef67d2a8 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -95,15 +95,6 @@ M: composed infer-call* M: object infer-call* "literal quotation" literal-expected ; -: infer-nslip ( n -- ) - [ infer->r infer-call ] [ infer-r> ] bi ; - -: infer-slip ( -- ) 1 infer-nslip ; - -: infer-2slip ( -- ) 2 infer-nslip ; - -: infer-3slip ( -- ) 3 infer-nslip ; - : infer-ndip ( word n -- ) [ literals get ] 2dip [ '[ _ def>> infer-quot-here ] ] @@ -180,9 +171,6 @@ M: object infer-call* { \ declare [ infer-declare ] } { \ call [ infer-call ] } { \ (call) [ infer-call ] } - { \ slip [ infer-slip ] } - { \ 2slip [ infer-2slip ] } - { \ 3slip [ infer-3slip ] } { \ dip [ infer-dip ] } { \ 2dip [ infer-2dip ] } { \ 3dip [ infer-3dip ] } @@ -216,7 +204,7 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose + declare call (call) dip 2dip 3dip curry compose execute (execute) call-effect-unsafe execute-effect-unsafe if dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index fba2eafaba..9df7165e6c 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -143,7 +143,7 @@ PRIVATE> Date: Sun, 10 May 2009 16:39:17 -0500 Subject: [PATCH 2/4] Removing slip 2slip 3slip nslip --- basis/fry/fry-docs.factor | 1 - .../generalizations-docs.factor | 17 ----------- .../generalizations-tests.factor | 2 -- basis/generalizations/generalizations.factor | 3 -- core/combinators/combinators-docs.factor | 11 ++------ core/kernel/kernel-docs.factor | 12 -------- core/kernel/kernel.factor | 28 ++++--------------- core/quotations/quotations.factor | 2 +- extra/reports/noise/noise.factor | 1 - 9 files changed, 8 insertions(+), 69 deletions(-) diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 5d750775e5..32ad856d00 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -57,7 +57,6 @@ $nl "Here are some built-in combinators rewritten in terms of fried quotations:" { $table { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } - { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 3671511194..d6a3aa948a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -161,22 +161,6 @@ HELP: ndip } } ; -HELP: nslip -{ $values { "n" integer } } -{ $description "A generalization of " { $link slip } " that can work " -"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " -"removed from the stack, the quotation called, and the items restored." -} -{ $examples - { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" } - "Some core words expressed in terms of " { $link nslip } ":" - { $table - { { $link slip } { $snippet "1 nslip" } } - { { $link 2slip } { $snippet "2 nslip" } } - { { $link 3slip } { $snippet "3 nslip" } } - } -} ; - HELP: nkeep { $values { "quot" quotation } { "n" integer } } { $description "A generalization of " { $link keep } " that can work " @@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } -{ $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 7ede271d01..d0f614f9cd 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer -{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 139b7a528a..397166a418 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -60,9 +60,6 @@ MACRO: ntuck ( n -- ) MACRO: ndip ( quot n -- ) [ '[ _ dip ] ] times ; -MACRO: nslip ( n -- ) - '[ [ call ] _ ndip ] ; - MACRO: nkeep ( quot n -- ) tuck '[ _ ndup _ _ ndip ] ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 8b301affbd..1a17e8c1fb 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -62,9 +62,6 @@ $nl ": dip [ ] bi* ;" ": 2dip [ ] [ ] tri* ;" "" - ": slip [ call ] [ ] bi* ;" - ": 2slip [ call ] [ ] [ ] tri* ;" - "" ": nip [ drop ] [ ] bi* ;" ": 2nip [ drop ] [ drop ] [ ] tri* ;" "" @@ -121,7 +118,7 @@ $nl { $subsection both? } { $subsection either? } ; -ARTICLE: "slip-keep-combinators" "Retain stack combinators" +ARTICLE: "retainstack-combinators" "Retain stack combinators" "Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators." $nl "The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" @@ -129,10 +126,6 @@ $nl { $subsection 2dip } { $subsection 3dip } { $subsection 4dip } -"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" -{ $subsection slip } -{ $subsection 2slip } -{ $subsection 3slip } "The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" { $subsection keep } { $subsection 2keep } @@ -259,7 +252,7 @@ ARTICLE: "conditionals" "Conditional combinators" ARTICLE: "dataflow-combinators" "Data flow combinators" "Data flow combinators pass values between quotations:" -{ $subsection "slip-keep-combinators" } +{ $subsection "retainstack-combinators" } { $subsection "cleave-combinators" } { $subsection "spread-combinators" } { $subsection "apply-combinators" } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index e67e2bc0dd..22e0e76451 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -212,18 +212,6 @@ HELP: call-clear ( quot -- ) { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } { $notes "Used to implement " { $link "threads" } "." } ; -HELP: slip -{ $values { "quot" quotation } { "x" object } } -{ $description "Calls a quotation while hiding the top of the stack." } ; - -HELP: 2slip -{ $values { "quot" quotation } { "x" object } { "y" object } } -{ $description "Calls a quotation while hiding the top two stack elements." } ; - -HELP: 3slip -{ $values { "quot" quotation } { "x" object } { "y" object } { "z" object } } -{ $description "Calls a quotation while hiding the top three stack elements." } ; - HELP: keep { $values { "quot" { $quotation "( x -- ... )" } } { "x" object } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6245080225..d6350e0420 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -58,37 +58,19 @@ DEFER: if : ?if ( default cond true false -- ) pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline -! Slippers and dippers. +! Dippers. ! Not declared inline because the compiler special-cases them -: slip ( quot x -- x ) - #! 'slip' and 'dip' can be defined in terms of each other - #! because the JIT special-cases a 'dip' preceeded by - #! a literal quotation. - [ call ] dip ; +: dip ( x quot -- x ) swap [ call ] dip ; -: 2slip ( quot x y -- x y ) - #! '2slip' and '2dip' can be defined in terms of each other - #! because the JIT special-cases a '2dip' preceeded by - #! a literal quotation. - [ call ] 2dip ; +: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ; -: 3slip ( quot x y z -- x y z ) - #! '3slip' and '3dip' can be defined in terms of each other - #! because the JIT special-cases a '3dip' preceeded by - #! a literal quotation. - [ call ] 3dip ; - -: dip ( x quot -- x ) swap slip ; - -: 2dip ( x y quot -- x y ) -rot 2slip ; - -: 3dip ( x y z quot -- x y z ) -roll 3slip ; +: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ; : 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline ! Keepers -: keep ( x quot -- x ) over slip ; inline +: keep ( x quot -- x ) over [ call ] dip ; inline : 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 3245ac1e20..af3c110d61 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -19,7 +19,7 @@ M: quotation call (call) ; M: curry call uncurry call ; -M: compose call uncompose slip call ; +M: compose call uncompose [ call ] dip call ; M: wrapper equal? over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ; diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 89e00f88c5..51196279ff 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -52,7 +52,6 @@ IN: reports.noise { nkeep 5 } { npick 6 } { nrot 5 } - { nslip 5 } { ntuck 6 } { nwith 4 } { over 2 } From 9488e7853294d005742dc56952495dbb0056d1cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 16:39:51 -0500 Subject: [PATCH 3/4] clean up contents and lines words; contents never outputs f now --- basis/io/launcher/unix/unix-tests.factor | 2 +- basis/io/streams/string/string-tests.factor | 2 ++ core/io/io-docs.factor | 8 ++--- core/io/io.factor | 36 ++++++++++++------- .../byte-array/byte-array-tests.factor | 1 + core/sequences/sequences-docs.factor | 8 ++++- core/sequences/sequences.factor | 27 +++++++------- 7 files changed, 54 insertions(+), 30 deletions(-) diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index 99d45e4fd7..852d8171e4 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -48,7 +48,7 @@ concurrency.promises threads unix.process ; try-process ] unit-test -[ f ] [ +[ "" ] [ "cat" "launcher-test-1" temp-file 2array diff --git a/basis/io/streams/string/string-tests.factor b/basis/io/streams/string/string-tests.factor index 967c0d4613..27971f1431 100644 --- a/basis/io/streams/string/string-tests.factor +++ b/basis/io/streams/string/string-tests.factor @@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make tools.test ; IN: io.streams.string.tests +[ "" ] [ "" [ contents ] with-string-reader ] unit-test + [ "line 1" CHAR: l ] [ "line 1\nline 2\nline 3" diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 97b143e989..ac74e6b11e 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -239,13 +239,13 @@ HELP: each-block { $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; 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 } "." } +{ $values { "stream" "an input stream" } { "seq" { $or string byte-array } } } +{ $description "Reads all elements in the given stream until the stream is exhausted. The type of the sequence depends on the stream's element type." } $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 } "." } +{ $values { "seq" { $or string byte-array } } } +{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" diff --git a/core/io/io.factor b/core/io/io.factor index b43098bcd4..669f104a5f 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables generic kernel math namespaces make sequences -continuations destructors assocs ; +continuations destructors assocs combinators ; IN: io SYMBOLS: +byte+ +character+ ; @@ -20,7 +20,9 @@ GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) ERROR: bad-seek-type type ; + SINGLETONS: seek-absolute seek-relative seek-end ; + GENERIC: stream-seek ( n seek-type stream -- ) : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; @@ -68,29 +70,39 @@ SYMBOL: error-stream : bl ( -- ) " " write ; -: 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 -: stream-contents ( stream -- seq ) - [ - [ 65536 read-partial dup ] [ ] produce nip concat f like - ] with-input-stream ; +: lines ( -- seq ) + [ ] accumulator [ each-line ] dip { } like ; + +: stream-lines ( stream -- seq ) + [ lines ] with-input-stream ; : contents ( -- seq ) - input-stream get stream-contents ; + [ 65536 read-partial dup ] [ ] produce nip + element-exemplar concat-as ; + +: stream-contents ( stream -- seq ) + [ contents ] with-input-stream ; : each-block ( quot: ( block -- ) -- ) [ 8192 read-partial ] each-morsel ; inline diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index 0cd35dfa21..43a8373232 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -1,6 +1,7 @@ USING: tools.test io.streams.byte-array io.encodings.binary io.encodings.utf8 io kernel arrays strings namespaces ; +[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index cfd96789b4..b6cfface12 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -533,12 +533,18 @@ HELP: concat { $description "Concatenates a sequence of sequences together into one sequence. If " { $snippet "seq" } " is empty, outputs " { $snippet "{ }" } ", otherwise the resulting sequence is of the same class as the first element of " { $snippet "seq" } "." } { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as the first element of " { $snippet "seq" } "." } ; +HELP: concat-as +{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" sequence } } +{ $description "Concatenates a sequence of sequences together into one sequence with the same type as " { $snippet "exemplar" } "." } +{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } ; + HELP: join { $values { "seq" sequence } { "glue" sequence } { "newseq" sequence } } { $description "Concatenates a sequence of sequences together into one sequence, placing a copy of " { $snippet "glue" } " between each pair of sequences. The resulting sequence is of the same class as " { $snippet "glue" } "." } +{ $notes "If the " { $snippet "glue" } " sequence is empty, this word calls " { $link concat-as } "." } { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "glue" } "." } ; -{ join concat } related-words +{ join concat concat-as } related-words HELP: peek { $values { "seq" sequence } { "elt" object } } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index d60602fc71..dd48501fa0 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -704,13 +704,14 @@ PRIVATE> : sum-lengths ( seq -- n ) 0 [ length + ] reduce ; +: concat-as ( seq exemplar -- newseq ) + swap [ { } ] [ + [ sum-lengths over new-resizable ] keep + [ over push-all ] each + ] if-empty swap like ; + : concat ( seq -- newseq ) - [ { } ] [ - [ sum-lengths ] keep - [ first new-resizable ] keep - [ [ over push-all ] each ] keep - first like - ] if-empty ; + [ { } ] [ dup first concat-as ] if-empty ; PRIVATE> : join ( seq glue -- newseq ) - [ - 2dup joined-length over new-resizable [ - [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi - interleave - ] keep - ] keep like ; + dup empty? [ concat-as ] [ + [ + 2dup joined-length over new-resizable [ + [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi + interleave + ] keep + ] keep like + ] if ; : padding ( seq n elt quot -- newseq ) [ From 04408ba62a321aeb2f0e25666f19373be04b288e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 16:40:19 -0500 Subject: [PATCH 4/4] mason: add retries in another place, and add a type declaration --- extra/mason/common/common.factor | 4 ++-- extra/mason/notify/notify.factor | 12 +++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index d020c68fc4..b7545a3c9e 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -5,12 +5,12 @@ math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar calendar.format arrays mason.config locals system debugger fry -continuations ; +continuations strings ; IN: mason.common SYMBOL: current-git-id -ERROR: output-process-error output process ; +ERROR: output-process-error { output string } { process process } ; M: output-process-error error. [ "Process:" print process>> . nl ] diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 96e31c4a45..c75014e1b0 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io io.sockets io.encodings.utf8 io.files io.launcher kernel make mason.config mason.common mason.email -mason.twitter namespaces sequences prettyprint ; +mason.twitter namespaces sequences prettyprint fry ; IN: mason.notify : status-notify ( input-file args -- ) @@ -14,10 +14,12 @@ IN: mason.notify target-cpu get , target-os get , ] { } make prepend - - swap >>command - swap [ +closed+ ] unless* >>stdin - try-output-process + [ 5 ] 2dip '[ + + _ >>command + _ [ +closed+ ] unless* >>stdin + try-output-process + ] retry ] [ 2drop ] if ; : notify-begin-build ( git-id -- )