From fdd6dd68f2f26fd4de82b87e8c052d337023e063 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 30 Jan 2009 14:21:38 -0800 Subject: [PATCH 01/33] Adding tests for sequence and assocs formatting. --- basis/formatting/formatting-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor index c7e9fb985e..c56372f023 100644 --- a/basis/formatting/formatting-tests.factor +++ b/basis/formatting/formatting-tests.factor @@ -77,6 +77,9 @@ IN: formatting.tests [ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test [ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test +[ t ] [ "{ 1, 2, 3 }" { 1 2 3 } "%[%s, %]" sprintf = ] unit-test +[ t ] [ "{ 1:2, 3:4 }" H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf = ] unit-test + [ "%H:%M:%S" strftime ] must-infer @@ -95,3 +98,4 @@ IN: formatting.tests [ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test [ t ] [ "PM" testtime "%p" strftime = ] unit-test + From 01a1e8b6ee53939101fec82cf927067cbe81490e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 26 Feb 2009 05:23:49 -0800 Subject: [PATCH 02/33] Change clamp to have a more realistic stack effect. --- extra/math/compare/compare-docs.factor | 2 +- extra/math/compare/compare-tests.factor | 6 +++--- extra/math/compare/compare.factor | 6 ++++-- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/math/compare/compare-docs.factor b/extra/math/compare/compare-docs.factor index 6c20db10fd..4cbe1a1ae0 100644 --- a/extra/math/compare/compare-docs.factor +++ b/extra/math/compare/compare-docs.factor @@ -18,6 +18,6 @@ HELP: negmin { $description "Returns the most-negative value, or zero if both are positive." } ; HELP: clamp -{ $values { "a" number } { "value" number } { "b" number } { "x" number } } +{ $values { "value" number } { "a" number } { "b" number } { "x" number } } { $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ; diff --git a/extra/math/compare/compare-tests.factor b/extra/math/compare/compare-tests.factor index 272471fe5d..9accc8e98b 100644 --- a/extra/math/compare/compare-tests.factor +++ b/extra/math/compare/compare-tests.factor @@ -15,7 +15,7 @@ IN: math.compare.tests [ -3 ] [ 1 -3 negmin ] unit-test [ -1 ] [ -1 3 negmin ] unit-test -[ 0 ] [ 0 -1 2 clamp ] unit-test -[ 1 ] [ 0 1 2 clamp ] unit-test -[ 2 ] [ 0 3 2 clamp ] unit-test +[ 0 ] [ -1 0 2 clamp ] unit-test +[ 1 ] [ 1 0 2 clamp ] unit-test +[ 2 ] [ 3 0 2 clamp ] unit-test diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor index 826f0ecf16..93a8da7cf3 100644 --- a/extra/math/compare/compare.factor +++ b/extra/math/compare/compare.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2008 John Benediktsson. ! See http://factorcode.org/license.txt for BSD license + USING: math math.order kernel ; + IN: math.compare : absmin ( a b -- x ) @@ -15,5 +17,5 @@ IN: math.compare : negmin ( a b -- x ) 0 min min ; -: clamp ( a value b -- x ) - min max ; +: clamp ( value a b -- x ) + [ max ] [ min ] bi* ; From aa7d24eec68c71b54733cd32193203f11966bd34 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 26 May 2009 22:20:53 -0700 Subject: [PATCH 03/33] Resolved merge. --- basis/bootstrap/compiler/compiler.factor | 2 +- basis/checksums/hmac/hmac-tests.factor | 22 ++++++++-------- basis/checksums/hmac/hmac.factor | 21 ++++++++-------- basis/circular/circular.factor | 4 +-- .../cfg/alias-analysis/alias-analysis.factor | 2 +- .../cfg/intrinsics/allot/allot.factor | 2 +- basis/compiler/cfg/iterator/iterator.factor | 2 +- .../cfg/linear-scan/debugger/debugger.factor | 2 +- .../cfg/linear-scan/linear-scan-tests.factor | 2 +- .../cfg/useless-blocks/useless-blocks.factor | 2 +- .../tree/dead-code/branches/branches.factor | 2 +- basis/compiler/tree/debugger/debugger.factor | 2 +- .../constraints/constraints.factor | 2 +- .../tree/propagation/info/info.factor | 8 +++--- .../tree/propagation/propagation-tests.factor | 6 ++--- basis/compiler/tree/tree.factor | 2 +- basis/core-text/fonts/fonts.factor | 2 +- basis/csv/csv.factor | 2 +- basis/documents/documents-tests.factor | 4 +-- basis/documents/documents.factor | 4 +-- basis/farkup/farkup.factor | 8 +++--- basis/generalizations/generalizations.factor | 2 +- basis/heaps/heaps.factor | 2 +- basis/help/lint/checks/checks.factor | 2 +- basis/hints/hints.factor | 12 ++++----- basis/http/parsers/parsers.factor | 2 +- basis/inspector/inspector.factor | 2 +- basis/inverse/inverse.factor | 2 +- basis/lcs/lcs.factor | 2 +- basis/logging/parser/parser.factor | 2 +- basis/math/bits/bits-tests.factor | 6 ++--- basis/math/functions/functions-docs.factor | 3 ++- basis/math/polynomials/polynomials.factor | 2 +- basis/math/ranges/ranges-docs.factor | 3 +-- basis/math/ranges/ranges-tests.factor | 13 +--------- basis/math/ranges/ranges.factor | 25 +++---------------- basis/math/statistics/statistics-tests.factor | 3 +++ basis/math/statistics/statistics.factor | 9 ++++++- basis/models/models.factor | 3 +-- basis/peg/ebnf/ebnf.factor | 2 +- basis/persistent/vectors/vectors.factor | 6 ++--- basis/porter-stemmer/porter-stemmer.factor | 8 +++--- basis/prettyprint/sections/sections.factor | 8 +++--- .../quoted-printable-tests.factor | 2 +- basis/quoting/quoting.factor | 4 +-- basis/sorting/human/human-tests.factor | 14 +++++++++-- basis/sorting/human/human.factor | 16 ++++++++++-- basis/sorting/title/title-tests.factor | 6 +++++ basis/sorting/title/title.factor | 5 +++- basis/splitting/monotonic/monotonic.factor | 4 +-- .../transforms/transforms.factor | 4 +-- basis/tools/completion/completion.factor | 4 +-- basis/tools/hexdump/hexdump-tests.factor | 2 +- basis/ui/backend/cocoa/cocoa.factor | 2 +- basis/unicode/case/case.factor | 2 +- basis/unicode/collation/collation.factor | 8 +++--- basis/unicode/data/data.factor | 6 ++--- basis/vlists/vlists-tests.factor | 2 +- basis/windows/fonts/fonts.factor | 2 +- basis/xml/xml.factor | 2 +- core/assocs/assocs-docs.factor | 18 +++++++++++-- core/assocs/assocs-tests.factor | 12 --------- core/assocs/assocs.factor | 3 --- core/classes/algebra/algebra.factor | 2 +- core/combinators/combinators-tests.factor | 2 +- core/combinators/combinators.factor | 5 +++- core/continuations/continuations.factor | 2 +- core/destructors/destructors.factor | 2 +- core/generic/math/math.factor | 2 +- core/generic/single/single.factor | 5 ++-- core/math/order/order-docs.factor | 5 ++++ core/math/order/order-tests.factor | 3 +++ core/math/order/order.factor | 1 + core/namespaces/namespaces.factor | 2 +- core/sequences/sequences-docs.factor | 9 ++++--- core/sequences/sequences.factor | 6 ++--- core/splitting/splitting.factor | 6 ++++- core/vectors/vectors-tests.factor | 4 +-- core/vocabs/loader/loader.factor | 2 +- core/vocabs/parser/parser.factor | 2 +- extra/24-game/24-game.factor | 2 +- extra/adsoda/adsoda.factor | 1 - extra/animations/animations.factor | 2 +- extra/bson/reader/reader.factor | 4 +-- extra/dns/dns.factor | 2 +- extra/html/parser/parser.factor | 2 +- extra/irc/messages/messages.factor | 2 +- extra/jamshred/player/player.factor | 4 +-- extra/jamshred/tunnel/tunnel.factor | 14 ++++++++--- extra/mason/notify/server/server.factor | 2 +- extra/math/compare/compare-docs.factor | 5 ---- extra/math/compare/compare-tests.factor | 5 ---- extra/math/compare/compare.factor | 5 ---- .../vectors/homogeneous/homogeneous.factor | 2 +- extra/project-euler/049/049.factor | 2 +- extra/project-euler/059/059.factor | 2 +- extra/project-euler/116/116.factor | 4 +-- extra/project-euler/117/117.factor | 2 +- extra/project-euler/164/164.factor | 2 +- extra/terrain/terrain.factor | 2 +- misc/vim/syntax/factor.vim | 2 +- 101 files changed, 243 insertions(+), 225 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 5e3827efea..0505dcb184 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -69,7 +69,7 @@ nl "." write flush { - new-sequence nth push pop peek flip + new-sequence nth push pop last flip } compile-unoptimized "." write flush diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index ffae146614..70451252f7 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -6,43 +6,43 @@ IN: checksums.hmac.tests [ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ - 16 11 "Hi There" md5 hmac-bytes >string ] unit-test + "Hi There" 16 11 md5 hmac-bytes >string ] unit-test [ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] -[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test +[ "what do ya want for nothing?" "Jefe" md5 hmac-bytes >string ] unit-test [ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ - 16 HEX: aa - 50 HEX: dd md5 hmac-bytes >string + 50 HEX: dd + 16 HEX: aa md5 hmac-bytes >string ] unit-test [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ - 16 11 "Hi There" sha1 hmac-bytes >string + "Hi There" 16 11 sha1 hmac-bytes >string ] unit-test [ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ - "Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string + "what do ya want for nothing?" "Jefe" sha1 hmac-bytes >string ] unit-test [ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ - 16 HEX: aa - 50 HEX: dd sha1 hmac-bytes >string + 50 HEX: dd + 16 HEX: aa sha1 hmac-bytes >string ] unit-test [ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] -[ 20 HEX: b "Hi There" sha-256 hmac-bytes hex-string ] unit-test +[ "Hi There" 20 HEX: b sha-256 hmac-bytes hex-string ] unit-test [ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ] [ - "JefeJefeJefeJefeJefeJefeJefeJefe" - "what do ya want for nothing?" sha-256 hmac-bytes hex-string + "what do ya want for nothing?" + "JefeJefeJefeJefeJefeJefeJefeJefe" sha-256 hmac-bytes hex-string ] unit-test diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index b163766016..9ec78248a1 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -13,27 +13,26 @@ IN: checksums.hmac : ipad ( checksum-state -- seq ) block-size>> HEX: 36 ; -:: init-K ( K checksum checksum-state -- o i ) - checksum-state block-size>> K length < - [ K checksum checksum-bytes ] [ K ] if +:: init-key ( checksum key checksum-state -- o i ) + checksum-state block-size>> key length < + [ key checksum checksum-bytes ] [ key ] if checksum-state block-size>> 0 pad-tail [ checksum-state opad seq-bitxor ] [ checksum-state ipad seq-bitxor ] bi ; PRIVATE> -:: hmac-stream ( K stream checksum -- value ) - K checksum dup initialize-checksum-state - dup :> checksum-state - init-K :> Ki :> Ko +:: hmac-stream ( stream key checksum -- value ) + checksum initialize-checksum-state :> checksum-state + checksum key checksum-state init-key :> Ki :> Ko checksum-state Ki add-checksum-bytes stream add-checksum-stream get-checksum checksum initialize-checksum-state Ko add-checksum-bytes swap add-checksum-bytes get-checksum ; -: hmac-file ( K path checksum -- value ) - [ binary ] dip hmac-stream ; +: hmac-file ( path key checksum -- value ) + [ binary ] 2dip hmac-stream ; -: hmac-bytes ( K seq checksum -- value ) - [ binary ] dip hmac-stream ; +: hmac-bytes ( seq key checksum -- value ) + [ binary ] 2dip hmac-stream ; diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 909b2ed713..ae79e70d73 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -46,13 +46,13 @@ M: growing-circular length length>> ; : full? ( circular -- ? ) [ length ] [ seq>> length ] bi = ; -: set-peek ( elt seq -- ) +: set-last ( elt seq -- ) [ length 1- ] keep set-nth ; PRIVATE> : push-growing-circular ( elt circular -- ) dup full? [ push-circular ] - [ [ 1+ ] change-length set-peek ] if ; + [ [ 1+ ] change-length set-last ] if ; : ( capacity -- growing-circular ) { } new-sequence 0 0 growing-circular boa ; diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index ec8fe62dfb..2a9d2579e3 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -165,7 +165,7 @@ SYMBOL: heap-ac : record-constant-set-slot ( slot# vreg -- ) history [ - dup empty? [ dup peek store? [ dup pop* ] when ] unless + dup empty? [ dup last store? [ dup pop* ] when ] unless store new-action swap ?push ] change-at ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 938dbbccbf..7b407c3ee4 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -19,7 +19,7 @@ IN: compiler.cfg.intrinsics.allot [ second ds-load ] [ ^^load-literal ] bi prefix ; : emit- ( node -- ) - dup node-input-infos peek literal>> + dup node-input-infos last literal>> dup array? [ nip ds-drop diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor index 3444b517ac..a8958733a7 100644 --- a/basis/compiler/cfg/iterator/iterator.factor +++ b/basis/compiler/cfg/iterator/iterator.factor @@ -7,7 +7,7 @@ SYMBOL: node-stack : >node ( cursor -- ) node-stack get push ; : node> ( -- cursor ) node-stack get pop ; -: node@ ( -- cursor ) node-stack get peek ; +: node@ ( -- cursor ) node-stack get last ; : current-node ( -- node ) node@ first ; : iterate-next ( -- cursor ) node@ rest-slice ; : skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index c6481b305e..dad87b62ae 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -23,7 +23,7 @@ IN: compiler.cfg.linear-scan.debugger [ split-children ] map concat check-assigned ; : picture ( uses -- str ) - dup peek 1 + CHAR: space + dup last 1 + CHAR: space [ '[ CHAR: * swap _ set-nth ] each ] keep ; : interval-picture ( interval -- str ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 4ddd1fdc0b..65b932c4a2 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -244,7 +244,7 @@ SYMBOL: max-uses swap int-regs swap vreg boa >>vreg max-uses get random 2 max [ not-taken ] replicate natural-sort [ >>uses ] [ first >>start ] bi - dup uses>> peek >>end + dup uses>> last >>end ] map ] with-scope ; diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor index f543aa4036..05cb13748b 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -37,7 +37,7 @@ IN: compiler.cfg.useless-blocks : delete-conditional? ( bb -- ? ) dup instructions>> [ drop f ] [ - peek class { + last class { ##compare-branch ##compare-imm-branch ##compare-float-branch diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index eba82384ab..fd1b2d5adb 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -28,7 +28,7 @@ M: #branch remove-dead-code* : remove-phi-inputs ( #phi -- ) if-node get children>> - [ dup ends-with-terminate? [ drop f ] [ peek out-d>> ] if ] map + [ dup ends-with-terminate? [ drop f ] [ last out-d>> ] if ] map pad-with-bottom >>phi-in-d drop ; : live-value-indices ( values -- indices ) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index d1a9f5215a..4fc4f4814b 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -191,7 +191,7 @@ SYMBOL: node-count propagate compute-def-use dup check-nodes - peek node-input-infos ; + last node-input-infos ; : final-classes ( quot -- seq ) final-info [ class>> ] map ; diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 2652547aad..31f6cea148 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -83,7 +83,7 @@ TUPLE: implication p q ; C: --> implication : assume-implication ( p q -- ) - [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ] + [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; M: implication assume* diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 4d4b22218d..50762c2b66 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -259,12 +259,12 @@ SYMBOL: value-infos resolve-copy value-infos get assoc-stack null-info or ; : set-value-info ( info value -- ) - resolve-copy value-infos get peek set-at ; + resolve-copy value-infos get last set-at ; : refine-value-info ( info value -- ) resolve-copy value-infos get [ assoc-stack value-info-intersect ] 2keep - peek set-at ; + last set-at ; : value-literal ( value -- obj ? ) value-info >literal< ; @@ -294,10 +294,10 @@ SYMBOL: value-infos dup in-d>> first node-value-info literal>> ; : last-literal ( #call -- obj ) - dup out-d>> peek node-value-info literal>> ; + dup out-d>> last node-value-info literal>> ; : immutable-tuple-boa? ( #call -- ? ) dup word>> \ eq? [ - dup in-d>> peek node-value-info + dup in-d>> last node-value-info literal>> first immutable-tuple-class? ] [ drop f ] if ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index aba8dc9eda..9cb0e41291 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -197,7 +197,7 @@ IN: compiler.tree.propagation.tests { fixnum byte-array } declare [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift - 255 min 0 max + 0 255 clamp ] final-classes ] unit-test @@ -210,7 +210,7 @@ IN: compiler.tree.propagation.tests ] unit-test [ V{ 1.5 } ] [ - [ /f 1.5 min 1.5 max ] final-literals + [ /f 1.5 1.5 clamp ] final-literals ] unit-test [ V{ 1.5 } ] [ @@ -693,4 +693,4 @@ TUPLE: circle me ; [ ] [ circle new dup >>me 1quotation final-info drop ] unit-test ! Joe found an oversight -[ V{ integer } ] [ [ >integer ] final-classes ] unit-test \ No newline at end of file +[ V{ integer } ] [ [ >integer ] final-classes ] unit-test diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 9f9a43df64..c73f2211f0 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -169,7 +169,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; : ends-with-terminate? ( nodes -- ? ) - [ f ] [ peek #terminate? ] if-empty ; + [ f ] [ last #terminate? ] if-empty ; M: vector child-visitor V{ } clone ; M: vector #introduce, #introduce node, ; diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor index 4525509d44..2656811c1f 100644 --- a/basis/core-text/fonts/fonts.factor +++ b/basis/core-text/fonts/fonts.factor @@ -82,7 +82,7 @@ CONSTANT: font-names } : font-name ( string -- string' ) - font-names at-default ; + font-names ?at drop ; : (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 5902999a76..23416d6912 100755 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -63,7 +63,7 @@ PRIVATE> : csv ( stream -- rows ) [ [ (csv) ] { } make ] with-input-stream - dup peek { "" } = [ but-last ] when ; + dup last { "" } = [ but-last ] when ; : file>csv ( path encoding -- csv ) csv ; diff --git a/basis/documents/documents-tests.factor b/basis/documents/documents-tests.factor index b0ff3bc8d8..9f7f25c56e 100644 --- a/basis/documents/documents-tests.factor +++ b/basis/documents/documents-tests.factor @@ -120,7 +120,7 @@ namespaces tools.test make arrays kernel fry ; [ "Goodbye, cruel world." ] [ "d" get doc-string ] unit-test [ "" { 0 9 } { 0 15 } ] [ - "d" get undos>> peek + "d" get undos>> last [ old-string>> ] [ from>> ] [ new-to>> ] tri ] unit-test @@ -150,4 +150,4 @@ namespaces tools.test make arrays kernel fry ; [ ] [ "Hello world" "d" get set-doc-string ] unit-test -[ { "" } ] [ "value" get ] unit-test \ No newline at end of file +[ { "" } ] [ "value" get ] unit-test diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index 104dea6b98..cc2466053b 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -86,7 +86,7 @@ CONSTANT: doc-start { 0 0 } ] [ first swap length 1- + 0 ] if - ] dip peek length + 2array ; + ] dip last length + 2array ; : prepend-first ( str seq -- ) 0 swap [ append ] change-nth ; @@ -191,4 +191,4 @@ PRIVATE> [ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ; : redo ( document -- ) - [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ; \ No newline at end of file + [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ; diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index a008b1d049..4acd1eeab8 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -149,15 +149,15 @@ DEFER: (parse-paragraph) : trim-row ( seq -- seq' ) rest - dup peek empty? [ but-last ] when ; + dup last empty? [ but-last ] when ; -: ?peek ( seq -- elt/f ) - [ f ] [ peek ] if-empty ; +: ?last ( seq -- elt/f ) + [ f ] [ last ] if-empty ; : coalesce ( rows -- rows' ) V{ } clone [ '[ - _ dup ?peek ?peek CHAR: \\ = + _ dup ?last ?last CHAR: \\ = [ [ pop "|" rot 3append ] keep ] when push ] each diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 397166a418..28a1f7dddb 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -76,7 +76,7 @@ MACRO: ncleave ( quots n -- ) MACRO: nspread ( quots n -- ) over empty? [ 2drop [ ] ] [ [ [ but-last ] dip ] - [ [ peek ] dip ] 2bi + [ [ last ] dip ] 2bi swap '[ [ _ _ nspread ] _ ndip @ ] ] if ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 65cb6541f4..f2ccaad1b4 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -76,7 +76,7 @@ M: heap heap-size ( heap -- n ) data>> pop* ; inline : data-peek ( heap -- entry ) - data>> peek ; inline + data>> last ; inline : data-first ( heap -- entry ) data>> first ; inline diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index 4a15f864a6..f8a4e6c15d 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -25,7 +25,7 @@ SYMBOL: vocab-articles [ (eval>string) ] call( code -- output ) "\n" ?tail drop ] keep - peek assert= + last assert= ] vocabs-quot get call( quot -- ) ; : check-examples ( element -- ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index db04033275..cfd6329b1d 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser words definitions kernel sequences assocs arrays -kernel.private fry combinators accessors vectors strings sbufs -byte-arrays byte-vectors io.binary io.streams.string splitting math -math.parser generic generic.single generic.standard classes -hashtables namespaces ; +USING: accessors arrays assocs byte-arrays byte-vectors classes +combinators definitions fry generic generic.single +generic.standard hashtables io.binary io.streams.string kernel +kernel.private math math.parser namespaces parser sbufs +sequences splitting splitting.private strings vectors words ; IN: hints GENERIC: specializer-predicate ( spec -- quot ) @@ -77,7 +77,7 @@ SYNTAX: HINTS: { first first2 first3 first4 } [ { array } "specializer" set-word-prop ] each -{ peek pop* pop } [ +{ last pop* pop } [ { vector } "specializer" set-word-prop ] each diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index 1810617c56..1a80236817 100644 --- a/basis/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -142,7 +142,7 @@ PEG: parse-header-line ( string -- pair ) 'space' , 'attr' , 'space' , - [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional , + [ "=" token , 'space' , 'value' , ] seq* [ last ] action optional , 'space' , ] seq* ; diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index 8cab5b5ad3..82c2487f67 100644 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -91,7 +91,7 @@ PRIVATE> : &back ( -- ) inspector-stack get - dup length 1 <= [ drop ] [ [ pop* ] [ peek reinspect ] bi ] if ; + dup length 1 <= [ drop ] [ [ pop* ] [ last reinspect ] bi ] if ; : &add ( value key -- ) mirror get set-at &push reinspect ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 7690b34410..cf97a0b2c8 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -220,7 +220,7 @@ DEFER: __ \ first4 [ 4array ] define-inverse \ prefix \ unclip define-dual -\ suffix [ dup but-last swap peek ] define-inverse +\ suffix [ dup but-last swap last ] define-inverse \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index d32b199873..ab4fbd60bb 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -34,7 +34,7 @@ PRIVATE> : levenshtein ( old new -- n ) [ levenshtein-initialize ] [ levenshtein-step ] - run-lcs peek peek ; + run-lcs last last ; TUPLE: retain item ; TUPLE: delete item ; diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index 5406d8fcd0..dbc26c7efc 100644 --- a/basis/logging/parser/parser.factor +++ b/basis/logging/parser/parser.factor @@ -66,7 +66,7 @@ PEG: parse-log-line ( string -- entry ) 'log-line' ; building get empty? [ "Warning: log begins with multiline entry" print drop ] [ - message>> first building get peek message>> push + message>> first building get last message>> push ] if ; : parse-log ( lines -- entries ) diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor index ed4e8419c9..b17d9d8b6e 100644 --- a/basis/math/bits/bits-tests.factor +++ b/basis/math/bits/bits-tests.factor @@ -23,9 +23,9 @@ IN: math.bits.tests ] unit-test [ t ] [ - 1067811677921310779 make-bits peek + 1067811677921310779 make-bits last ] unit-test [ t ] [ - 1067811677921310779 >bignum make-bits peek -] unit-test \ No newline at end of file + 1067811677921310779 >bignum make-bits last +] unit-test diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 48da8aa6ec..41800e46da 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -23,9 +23,10 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" "Incrementing, decrementing:" { $subsection 1+ } { $subsection 1- } -"Minimum, maximum:" +"Minimum, maximum, clamping:" { $subsection min } { $subsection max } +{ $subsection clamp } "Complex conjugation:" { $subsection conjugate } "Tests:" diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index fd6eda4a90..0de18b6feb 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -48,7 +48,7 @@ PRIVATE> : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences - [ peek ] bi@ / ; + [ last ] bi@ / ; : (p/mod) ( p p -- p p ) 2dup /-last diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor index e35adb10e5..59053a4c02 100644 --- a/basis/math/ranges/ranges-docs.factor +++ b/basis/math/ranges/ranges-docs.factor @@ -1,5 +1,4 @@ USING: help.syntax help.markup arrays sequences ; - IN: math.ranges ARTICLE: "math.ranges" "Numeric ranges" @@ -24,4 +23,4 @@ $nl { $code "100 1 [a,b] product" } "A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ; -ABOUT: "math.ranges" \ No newline at end of file +ABOUT: "math.ranges" diff --git a/basis/math/ranges/ranges-tests.factor b/basis/math/ranges/ranges-tests.factor index aedd2f7933..e314f72c6b 100644 --- a/basis/math/ranges/ranges-tests.factor +++ b/basis/math/ranges/ranges-tests.factor @@ -22,17 +22,6 @@ IN: math.ranges.tests [ { 0 1/3 2/3 1 } ] [ 0 1 1/3 >array ] unit-test [ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 >array reverse ] unit-test -[ t ] [ 5 [0,b] range-increasing? ] unit-test -[ f ] [ 5 [0,b] range-decreasing? ] unit-test -[ f ] [ -5 [0,b] range-increasing? ] unit-test -[ t ] [ -5 [0,b] range-decreasing? ] unit-test -[ 0 ] [ 5 [0,b] range-min ] unit-test -[ 5 ] [ 5 [0,b] range-max ] unit-test -[ 3 ] [ 3 5 [0,b] clamp-to-range ] unit-test -[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test -[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test -[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test - [ 100 ] [ 1 100 [a,b] [ 2^ [1,b] ] map prune length -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 883be006dc..d28afa1413 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -26,12 +26,16 @@ M: range hashcode* tuple-hashcode ; INSTANCE: range immutable-sequence + -1 1 ? ; inline : (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline : ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline +PRIVATE> + : [a,b] ( a b -- range ) twiddle ; inline : (a,b] ( a b -- range ) twiddle (a, ; inline @@ -45,24 +49,3 @@ INSTANCE: range immutable-sequence : [1,b] ( b -- range ) 1 swap [a,b] ; inline : [0,b) ( b -- range ) 0 swap [a,b) ; inline - -: range-increasing? ( range -- ? ) - step>> 0 > ; - -: range-decreasing? ( range -- ? ) - step>> 0 < ; - -: first-or-peek ( seq head? -- elt ) - [ first ] [ peek ] if ; - -: range-min ( range -- min ) - dup range-increasing? first-or-peek ; - -: range-max ( range -- max ) - dup range-decreasing? first-or-peek ; - -: clamp-to-range ( n range -- n ) - [ range-min max ] [ range-max min ] bi ; - -: sequence-index-range ( seq -- range ) - length [0,b) ; diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index c160d57db7..32ebcbc6a1 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -13,6 +13,9 @@ IN: math.statistics.tests [ 2 ] [ { 1 2 3 } median ] unit-test [ 5/2 ] [ { 1 2 3 4 } median ] unit-test +[ 1 ] [ { 1 } mode ] unit-test +[ 3 ] [ { 1 2 3 3 3 4 5 6 76 7 2 21 1 3 3 3 } mode ] unit-test + [ { } median ] must-fail [ { } upper-median ] must-fail [ { } lower-median ] must-fail diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 3812e79ec5..a1a214b2c0 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators kernel math math.analysis math.functions math.order sequences sorting locals -sequences.private ; +sequences.private assocs fry ; IN: math.statistics : mean ( seq -- x ) @@ -56,6 +56,13 @@ IN: math.statistics : median ( seq -- x ) dup length odd? [ lower-median ] [ medians + 2 / ] if ; +: frequency ( seq -- hashtable ) + H{ } clone [ '[ _ inc-at ] each ] keep ; + +: mode ( seq -- x ) + frequency >alist + [ ] [ [ [ second ] bi@ > ] 2keep ? ] map-reduce first ; + : minmax ( seq -- min max ) #! find the min and max of a seq in one pass [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ; diff --git a/basis/models/models.factor b/basis/models/models.factor index 4f7aafe3e3..19b478eaf9 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -109,5 +109,4 @@ GENERIC: set-range-min-value ( value model -- ) GENERIC: set-range-max-value ( value model -- ) : clamp-value ( value range -- newvalue ) - [ range-min-value max ] keep - range-max-value* min ; + [ range-min-value ] [ range-max-value* ] bi clamp ; diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index f3d555d5a1..4b2eca69b4 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -370,7 +370,7 @@ SYMBOL: ignore-ws ] bind ; M: ebnf (transform) ( ast -- parser ) - rules>> [ (transform) ] map peek ; + rules>> [ (transform) ] map last ; M: ebnf-tokenizer (transform) ( ast -- parser ) elements>> dup "default" = [ diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index ae33b7c39a..5927171aa3 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe dup level>> 1 = [ new-child ] [ - tuck children>> peek (ppush-new-tail) + tuck children>> last (ppush-new-tail) [ swap new-child ] [ swap node-set-last f ] ?if ] if ; @@ -127,13 +127,13 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' ) : ppop-contraction ( node -- node' tail' ) dup children>> length 1 = - [ children>> peek f swap ] + [ children>> last f swap ] [ (ppop-contraction) ] if ; : (ppop-new-tail) ( root -- root' tail' ) dup level>> 1 > [ - dup children>> peek (ppop-new-tail) [ + dup children>> last (ppop-new-tail) [ dup [ swap node-set-last ] [ drop ppop-contraction drop ] diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor index b6eb0ff464..35ed84aaf4 100644 --- a/basis/porter-stemmer/porter-stemmer.factor +++ b/basis/porter-stemmer/porter-stemmer.factor @@ -52,7 +52,7 @@ USING: kernel math parser sequences combinators splitting ; : consonant-end? ( n seq -- ? ) [ length swap - ] keep consonant? ; -: last-is? ( str possibilities -- ? ) [ peek ] dip member? ; +: last-is? ( str possibilities -- ? ) [ last ] dip member? ; : cvc? ( str -- ? ) { @@ -67,7 +67,7 @@ USING: kernel math parser sequences combinators splitting ; pick consonant-seq 0 > [ nip ] [ drop ] if append ; : step1a ( str -- newstr ) - dup peek CHAR: s = [ + dup last CHAR: s = [ { { [ "sses" ?tail ] [ "ss" append ] } { [ "ies" ?tail ] [ "i" append ] } @@ -199,13 +199,13 @@ USING: kernel math parser sequences combinators splitting ; [ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ; : remove-e ( str -- newstr ) - dup peek CHAR: e = [ + dup last CHAR: e = [ dup remove-e? [ but-last-slice ] when ] when ; : ll->l ( str -- newstr ) { - { [ dup peek CHAR: l = not ] [ ] } + { [ dup last CHAR: l = not ] [ ] } { [ dup length 1- over double-consonant? not ] [ ] } { [ dup consonant-seq 1 > ] [ but-last-slice ] } [ ] diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index b4eb40757d..0e0c7afb82 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -153,7 +153,7 @@ TUPLE: block < section sections ; : ( style -- block ) block new-block ; -: pprinter-block ( -- block ) pprinter-stack get peek ; +: pprinter-block ( -- block ) pprinter-stack get last ; : add-section ( section -- ) pprinter-block sections>> push ; @@ -292,7 +292,7 @@ M: colon unindent-first-line? drop t ; ! Long section layout algorithm : chop-break ( seq -- seq ) - dup peek line-break? [ but-last-slice chop-break ] when ; + dup last line-break? [ but-last-slice chop-break ] when ; SYMBOL: prev SYMBOL: next @@ -317,7 +317,7 @@ SYMBOL: next ] { } make { t } split harvest ; : break-group? ( seq -- ? ) - [ first section-fits? ] [ peek section-fits? not ] bi and ; + [ first section-fits? ] [ last section-fits? not ] bi and ; : ?break-group ( seq -- ) dup break-group? [ first latin2 encode >quoted ] unit-test [ 1 ] [ message >quoted string-lines length ] unit-test [ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test [ 4 ] [ message >quoted-lines string-lines length ] unit-test -[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test +[ "===o" ] [ message >quoted-lines string-lines [ last ] "" map-as ] unit-test diff --git a/basis/quoting/quoting.factor b/basis/quoting/quoting.factor index 5b09347c8c..86d8183ac6 100644 --- a/basis/quoting/quoting.factor +++ b/basis/quoting/quoting.factor @@ -9,8 +9,8 @@ IN: quoting { [ length 1 > ] [ first quote? ] - [ [ first ] [ peek ] bi = ] + [ [ first ] [ last ] bi = ] } 1&& ; : unquote ( str -- newstr ) - dup quoted? [ but-last-slice rest-slice >string ] when ; \ No newline at end of file + dup quoted? [ but-last-slice rest-slice >string ] when ; diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor index 20a607188c..68ddf8c3c9 100644 --- a/basis/sorting/human/human-tests.factor +++ b/basis/sorting/human/human-tests.factor @@ -1,4 +1,14 @@ -USING: sorting.human tools.test sorting.slots ; +USING: sorting.human tools.test sorting.slots sorting ; IN: sorting.human.tests -[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test +[ { "x1y" "x2" "x10y" } ] +[ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test + +[ { "4dup" "nip" } ] +[ { "4dup" "nip" } [ human<=> ] sort ] unit-test + +[ { "4dup" "nip" } ] +[ { "nip" "4dup" } [ human<=> ] sort ] unit-test + +[ { "4dup" "4nip" "5drop" "nip" "nip2" "nipd" } ] +[ { "nip" "4dup" "4nip" "5drop" "nip2" "nipd" } [ human<=> ] sort ] unit-test diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index b3dae45a9b..7487f559ed 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -1,9 +1,21 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math.parser peg.ebnf sorting.functor ; +USING: accessors kernel math math.order math.parser peg.ebnf +sequences sorting.functor ; IN: sorting.human : find-numbers ( string -- seq ) [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ; -<< "human" [ find-numbers ] define-sorting >> +! For comparing integers or sequences +TUPLE: hybrid obj ; + +M: hybrid <=> + [ obj>> ] bi@ + 2dup [ integer? ] bi@ xor [ + drop integer? [ +lt+ ] [ +gt+ ] if + ] [ + <=> + ] if ; + +<< "human" [ find-numbers [ hybrid boa ] map ] define-sorting >> diff --git a/basis/sorting/title/title-tests.factor b/basis/sorting/title/title-tests.factor index 65a58e463d..1e978838c5 100644 --- a/basis/sorting/title/title-tests.factor +++ b/basis/sorting/title/title-tests.factor @@ -8,6 +8,9 @@ IN: sorting.title.tests "The Beatles" "A river runs through it" "Another" + "The" + "A" + "Los" "la vida loca" "Basketball" "racquetball" @@ -21,6 +24,7 @@ IN: sorting.title.tests } ; [ { + "A" "Another" "Basketball" "The Beatles" @@ -29,10 +33,12 @@ IN: sorting.title.tests "for the horde" "Los Fujis" "los Fujis" + "Los" "of mice and men" "on belay" "racquetball" "A river runs through it" + "The" "la vida loca" } ] [ diff --git a/basis/sorting/title/title.factor b/basis/sorting/title/title.factor index dbdbf8a8fb..b9a46c41fc 100644 --- a/basis/sorting/title/title.factor +++ b/basis/sorting/title/title.factor @@ -4,4 +4,7 @@ USING: sorting.functor regexp kernel accessors sequences unicode.case ; IN: sorting.title -<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >> +<< "title" [ + >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match + [ to>> tail-slice ] when* +] define-sorting >> diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 2e2ac74e30..088de52766 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -6,9 +6,9 @@ IN: splitting.monotonic quot diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 00d86a1608..c8fd3a6658 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -24,7 +24,7 @@ IN: tools.completion 2dup number= [ drop ] [ nip V{ } clone pick push ] if 1+ - ] keep pick peek push + ] keep pick last push ] each ; : runs ( seq -- newseq ) @@ -78,4 +78,4 @@ IN: tools.completion all-vocabs-seq name-completions ; : chars-matching ( str -- seq ) - name-map keys dup zip completions ; \ No newline at end of file + name-map keys dup zip completions ; diff --git a/basis/tools/hexdump/hexdump-tests.factor b/basis/tools/hexdump/hexdump-tests.factor index 1a8ed35510..75537b0c11 100644 --- a/basis/tools/hexdump/hexdump-tests.factor +++ b/basis/tools/hexdump/hexdump-tests.factor @@ -4,7 +4,7 @@ IN: tools.hexdump.tests [ t ] [ B{ } hexdump "Length: 0, 0h\n" = ] unit-test [ t ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test -[ t ] [ 256 [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test +[ t ] [ 256 iota [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test [ diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index b6c9b43271..aa84ee43c5 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -83,7 +83,7 @@ M: pasteboard set-clipboard-contents dup { 0 0 } = [ drop windows get length 1 <= [ -> center ] [ - windows get peek second window-loc>> + windows get last second window-loc>> dupd first2 -> cascadeTopLeftFromPoint: -> setFrameTopLeftPoint: ] if diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 1ad3931746..79db087220 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -59,7 +59,7 @@ SYMBOL: locale ! Just casing locale, or overall? : fix-sigma-end ( string -- string ) [ "" ] [ - dup peek CHAR: greek-small-letter-sigma = + dup last CHAR: greek-small-letter-sigma = [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when ] if-empty ; inline diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index f8beca3c60..5cab884b3c 100755 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -63,13 +63,13 @@ ducet insert-helpers [ drop { } ] [ [ AAAA ] [ BBBB ] bi 2array ] if ; -: last ( -- char ) - building get empty? [ 0 ] [ building get peek peek ] if ; +: building-last ( -- char ) + building get empty? [ 0 ] [ building get last last ] if ; : blocked? ( char -- ? ) combining-class dup { 0 f } member? - [ drop last non-starter? ] - [ last combining-class = ] if ; + [ drop building-last non-starter? ] + [ building-last combining-class = ] if ; : possible-bases ( -- slice-of-building ) building get dup [ first non-starter? not ] find-last diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 318a56627b..1c6c6afdf3 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -33,9 +33,9 @@ VALUE: name-map : name>char ( name -- char ) name-map at ; inline : char>name ( char -- name ) name-map value-at ; inline : property? ( char property -- ? ) properties at interval-key? ; inline -: ch>lower ( ch -- lower ) simple-lower at-default ; inline -: ch>upper ( ch -- upper ) simple-upper at-default ; inline -: ch>title ( ch -- title ) simple-title at-default ; inline +: ch>lower ( ch -- lower ) simple-lower ?at drop ; inline +: ch>upper ( ch -- upper ) simple-upper ?at drop ; inline +: ch>title ( ch -- title ) simple-title ?at drop ; inline : special-case ( ch -- casing-tuple ) special-casing at ; inline ! For non-existent characters, use Cn diff --git a/basis/vlists/vlists-tests.factor b/basis/vlists/vlists-tests.factor index 3546051364..6df942eb84 100644 --- a/basis/vlists/vlists-tests.factor +++ b/basis/vlists/vlists-tests.factor @@ -16,7 +16,7 @@ IN: vlists.tests [ "foo" VL{ "hi" "there" } t ] [ VL{ "hi" "there" "foo" } dup "v" set - [ peek ] [ ppop ] bi + [ last ] [ ppop ] bi dup "v" get [ vector>> ] bi@ eq? ] unit-test diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index 1753ff1ce1..269e8f8f48 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -7,7 +7,7 @@ IN: windows.fonts { "sans-serif" "Tahoma" } { "serif" "Times New Roman" } { "monospace" "Courier New" } - } at-default ; + } ?at drop ; MEMO:: (cache-font) ( font -- HFONT ) font size>> neg ! nHeight diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 9df7165e6c..cca1b5e2e0 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -11,7 +11,7 @@ IN: xml assoc } { $subsection assoc>map } { $subsection assoc-map-as } ; @@ -236,6 +238,13 @@ HELP: assoc-filter-as { assoc-filter assoc-filter-as } related-words +HELP: assoc-partition +{ $values + { "assoc" assoc } { "quot" quotation } + { "true-assoc" assoc } { "false-assoc" assoc } +} +{ $description "Calls a predicate quotation on each key of the input assoc. If the test yields true, the key/value pair is added to " { $snippet "true-assoc" } "; if false, it's added to " { $snippet "false-assoc" } "." } ; + HELP: assoc-any? { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } } { $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; @@ -331,7 +340,12 @@ HELP: substitute HELP: cache { $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } } -{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." } +{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc. Returns a value either looked up or newly stored in the assoc." } +{ $side-effects "assoc" } ; + +HELP: 2cache +{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } } +{ $description "If a single key composed of the input keys is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the keys/value pair into the assoc. Returns the value stored in the assoc. Returns a value either looked up or newly stored in the assoc." } { $side-effects "assoc" } ; HELP: map>assoc diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index fc74df6d45..c473ac0dfa 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -119,18 +119,6 @@ unit-test } extract-keys ] unit-test -[ f ] [ - "a" H{ { "a" f } } at-default -] unit-test - -[ "b" ] [ - "b" H{ { "a" f } } at-default -] unit-test - -[ "x" ] [ - "a" H{ { "a" "x" } } at-default -] unit-test - [ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [ H{ { "a" [ 1 ] } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index e783ef81c4..d655b99c30 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -82,9 +82,6 @@ PRIVATE> : at ( key assoc -- value/f ) at* drop ; inline -: at-default ( key assoc -- value/key ) - ?at drop ; inline - M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ dup assoc-size ] dip new-assoc [ [ set-at ] with-assoc assoc-each ] keep ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index c774ef1c1d..3c39848d02 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -215,7 +215,7 @@ M: anonymous-complement (classes-intersect?) : min-class ( class seq -- class/f ) over [ classes-intersect? ] curry filter [ drop f ] [ - [ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if + [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if ] if-empty ; GENERIC: (flatten-class) ( class -- ) diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index aae6618ee8..b239b1eac9 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,6 +1,6 @@ USING: alien strings kernel math tools.test io prettyprint namespaces combinators words classes sequences accessors -math.functions arrays ; +math.functions arrays combinators.private ; IN: combinators.tests [ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 7bf76fea30..f293030f25 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -101,6 +101,8 @@ ERROR: no-case object ; [ \ drop prefix ] bi* ] assoc-map alist>quot ; + + : case>quot ( default assoc -- quot ) dup keys { { [ dup empty? ] [ 2drop ] } @@ -160,7 +164,6 @@ ERROR: no-case object ; [ drop linear-case-quot ] } cond ; -! recursive-hashcode : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 7681c2b089..8e14f4a26b 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -152,7 +152,7 @@ ERROR: attempt-all-error ; ] [ [ [ [ , f ] compose [ , drop t ] recover ] curry all? - ] { } make peek swap [ rethrow ] when + ] { } make last swap [ rethrow ] when ] if ; inline TUPLE: condition error restarts continuation ; diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index afc956fae4..9a470d53c1 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -21,7 +21,7 @@ M: object dispose : dispose-each ( seq -- ) [ [ [ dispose ] curry [ , ] recover ] each - ] { } make [ peek rethrow ] unless-empty ; + ] { } make [ last rethrow ] unless-empty ; : with-disposal ( object quot -- ) over [ dispose ] curry [ ] cleanup ; inline diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index c96050ad03..e88c0c02e4 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -15,7 +15,7 @@ PREDICATE: math-class < class quot picker prepend define-predicate-engine ] if-empty ; + [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; M: predicate-engine compile-engine [ compile-predicate-engine ] [ class>> ] bi diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 8b2200aa67..368d060eb9 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -51,6 +51,10 @@ HELP: min { $values { "x" real } { "y" real } { "z" real } } { $description "Outputs the smallest of two real numbers." } ; +HELP: clamp +{ $values { "x" real } { "min" real } { "max" real } { "y" real } } +{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ; + HELP: between? { $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." } @@ -105,6 +109,7 @@ ARTICLE: "math.order" "Linear order protocol" { $subsection "order-specifiers" } "Utilities for comparing objects:" { $subsection after? } +{ $subsection after? } { $subsection before? } { $subsection after=? } { $subsection before=? } diff --git a/core/math/order/order-tests.factor b/core/math/order/order-tests.factor index 665537be5d..edd50d3f55 100644 --- a/core/math/order/order-tests.factor +++ b/core/math/order/order-tests.factor @@ -7,3 +7,6 @@ IN: math.order.tests [ +eq+ ] [ 4 4 <=> ] unit-test [ +gt+ ] [ 4 3 <=> ] unit-test +[ 20 ] [ 20 0 100 clamp ] unit-test +[ 0 ] [ -20 0 100 clamp ] unit-test +[ 100 ] [ 120 0 100 clamp ] unit-test diff --git a/core/math/order/order.factor b/core/math/order/order.factor index a06209bf63..435eec9b96 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -34,6 +34,7 @@ M: real after=? ( obj1 obj2 -- ? ) >= ; : min ( x y -- z ) [ before? ] most ; inline : max ( x y -- z ) [ after? ] most ; inline +: clamp ( x min max -- y ) [ max ] dip min ; inline : between? ( x y z -- ? ) pick after=? [ after=? ] [ 2drop f ] if ; inline diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 64cc328d19..9428445d26 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -12,7 +12,7 @@ IN: namespaces PRIVATE> -: namespace ( -- namespace ) namestack* peek ; inline +: namespace ( -- namespace ) namestack* last ; inline : namestack ( -- namestack ) namestack* clone ; : set-namestack ( namestack -- ) >vector 0 setenv ; : global ( -- g ) 21 getenv { hashtable } declare ; inline diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index b6cfface12..927a404519 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -546,12 +546,12 @@ HELP: join { join concat concat-as } related-words -HELP: peek +HELP: last { $values { "seq" sequence } { "elt" object } } { $description "Outputs the last element of a sequence." } { $errors "Throws an error if the sequence is empty." } ; -{ peek pop pop* } related-words +{ pop pop* } related-words HELP: pop* { $values { "seq" "a resizable mutable sequence" } } @@ -1378,11 +1378,13 @@ ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection second } { $subsection third } { $subsection fourth } +"Extracting the last element:" +{ $subsection last } "Unpacking sequences:" { $subsection first2 } { $subsection first3 } { $subsection first4 } -{ $see-also nth peek } ; +{ $see-also nth } ; ARTICLE: "sequences-add-remove" "Adding and removing sequence elements" "Adding elements:" @@ -1579,7 +1581,6 @@ ARTICLE: "sequences-destructive" "Destructive operations" ARTICLE: "sequences-stacks" "Treating sequences as stacks" "The classical stack operations, modifying a sequence in place:" -{ $subsection peek } { $subsection push } { $subsection pop } { $subsection pop* } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9b0f4c1530..36e4c95470 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -626,7 +626,7 @@ PRIVATE> [ 0 swap copy ] keep ] new-like ; -: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ; +: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ; : pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; @@ -821,7 +821,7 @@ PRIVATE> [ rest ] [ first-unsafe ] bi ; : unclip-last ( seq -- butlast last ) - [ but-last ] [ peek ] bi ; + [ but-last ] [ last ] bi ; : unclip-slice ( seq -- rest-slice first ) [ rest-slice ] [ first-unsafe ] bi ; inline @@ -852,7 +852,7 @@ PRIVATE> [ find-last ] (map-find) ; inline : unclip-last-slice ( seq -- butlast-slice last ) - [ but-last-slice ] [ peek ] bi ; inline + [ but-last-slice ] [ last ] bi ; inline : ( seq -- slice ) dup slice? [ { } like ] when diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index c55a75baa6..5ec396e5ba 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -53,6 +53,8 @@ PRIVATE> [ ] bi@ split1-slice [ ] bi@ [ f ] [ swap ] if-empty ; + : split, ( seq separators -- ) 0 rot (split) ; +PRIVATE> + : split ( seq separators -- pieces ) [ split, ] { } make ; @@ -71,7 +75,7 @@ M: string string-lines but-last-slice [ "\r" ?tail drop "\r" split ] map - ] keep peek "\r" split suffix concat + ] keep last "\r" split suffix concat ] [ 1array ] if ; diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 12e2ea49f7..9052638e7d 100644 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -62,7 +62,7 @@ IN: vectors.tests [ ] [ V{ 1 5 } "funny-stack" get push ] unit-test [ ] [ V{ 2 3 } "funny-stack" get push ] unit-test [ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test -[ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test +[ V{ 1 5 } ] [ "funny-stack" get last ] unit-test [ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test [ "funny-stack" get pop ] must-fail [ "funny-stack" get pop ] must-fail @@ -98,4 +98,4 @@ IN: vectors.tests [ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test -[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test \ No newline at end of file +[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 6561c55b67..2c0f67641d 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -39,7 +39,7 @@ PRIVATE> : vocab-dir+ ( vocab str/f -- path ) [ vocab-name "." split ] dip - [ [ dup peek ] dip append suffix ] when* + [ [ dup last ] dip append suffix ] when* "/" join ; : find-vocab-root ( vocab -- path/f ) diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index ff55f8e68d..ca783c13e6 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -193,7 +193,7 @@ TUPLE: ambiguous-use-error words ; : qualified-search ( name manifest -- word/f ) qualified-vocabs>> - (vocab-search) 0 = [ drop f ] [ peek ] if ; + (vocab-search) 0 = [ drop f ] [ last ] if ; PRIVATE> diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 19928b2e0b..15c610ce7a 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -40,7 +40,7 @@ SYMBOL: commands if ; DEFER: check-status : quit-game ( vector -- ) drop "you're a quitter" print ; -: quit? ( vector -- t/f ) peek "quit" = ; +: quit? ( vector -- t/f ) last "quit" = ; : end-game ( vector -- ) dup victory? [ drop "You WON!" ] diff --git a/extra/adsoda/adsoda.factor b/extra/adsoda/adsoda.factor index 4042528eba..c659e109ce 100755 --- a/extra/adsoda/adsoda.factor +++ b/extra/adsoda/adsoda.factor @@ -58,7 +58,6 @@ t to: remove-hidden-solids? : with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline : dimension ( array -- x ) length 1- ; inline -: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline : change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; inline diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor index a5c7dbdde4..8f416dc799 100644 --- a/extra/animations/animations.factor +++ b/extra/animations/animations.factor @@ -14,4 +14,4 @@ SYMBOL: sleep-period : set-end ( duration -- end-time ) duration>milliseconds millis + ; : loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline : animate ( quot duration -- ) reset-progress set-end loop ; inline -: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline \ No newline at end of file +: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 9f1d8c31d2..6fadcf7679 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -83,7 +83,7 @@ GENERIC: element-binary-read ( length type -- object ) get-state element>> pop ; inline : peek-scope ( -- ht ) - get-state scope>> peek ; inline + get-state scope>> last ; inline : read-elements ( -- ) read-element-type @@ -136,7 +136,7 @@ M: bson-not-eoo element-read ( type -- cont? ) read-int32 drop get-state [scope-changer] change-scope - scope>> peek ; inline + scope>> last ; inline M: bson-object element-data-read ( type -- object ) (object-data-read) ; diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 6d81f2a14b..f16664fb02 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -495,7 +495,7 @@ ERROR: name-error name ; : fully-qualified ( name -- name ) { { [ dup empty? ] [ "." append ] } - { [ dup peek CHAR: . = ] [ ] } + { [ dup last CHAR: . = ] [ ] } { [ t ] [ "." append ] } } cond ; diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 948bd0c954..9fcbffd0db 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -21,7 +21,7 @@ SYMBOL: tagstack : closing-tag? ( string -- ? ) [ f ] - [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ; + [ { [ first CHAR: / = ] [ last CHAR: / = ] } 1|| ] if-empty ; : ( name attributes closing? -- tag ) tag new diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 2006cc24c3..d53ef6924b 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -65,7 +65,7 @@ IRC: rpl-nick-collision "436" nickname : comment ; PREDICATE: channel-mode < mode name>> first "#&" member? ; PREDICATE: participant-mode < channel-mode parameter>> ; PREDICATE: ctcp < privmsg - trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ; + trailing>> { [ length 1 > ] [ first 1 = ] [ last 1 = ] } 1&& ; PREDICATE: action < ctcp trailing>> rest "ACTION" head? ; M: rpl-names post-process-irc-message ( rpl-names -- ) diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 5b92b3a434..3364179920 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -45,10 +45,10 @@ CONSTANT: max-speed 30.0 max-speed [0,b] ; : change-player-speed ( inc player -- ) - [ + speed-range clamp-to-range ] change-speed drop ; + [ + 0 max-speed clamp ] change-speed drop ; : multiply-player-speed ( n player -- ) - [ * speed-range clamp-to-range ] change-speed drop ; + [ * 0 max-speed clamp ] change-speed drop ; : distance-to-move ( seconds-passed player -- distance ) speed>> * ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 7e124dc713..986574ee91 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; +USING: accessors arrays colors combinators fry jamshred.oint +kernel literals locals math math.constants math.matrices +math.order math.quadratic math.ranges math.vectors random +sequences specialized-arrays.float vectors ; FROM: jamshred.oint => distance ; IN: jamshred.tunnel @@ -12,6 +15,9 @@ C: segment : segment-number++ ( segment -- ) [ number>> 1+ ] keep (>>number) ; +: clamp-length ( n seq -- n' ) + 0 swap length clamp ; + : random-color ( -- color ) { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; @@ -25,7 +31,7 @@ CONSTANT: random-rotation-angle $[ pi 20 / ] : (random-segments) ( segments n -- segments ) dup 0 > [ - [ dup peek random-segment over push ] dip 1- (random-segments) + [ dup last random-segment over push ] dip 1- (random-segments) ] [ drop ] if ; CONSTANT: default-segment-radius 1 @@ -53,7 +59,7 @@ CONSTANT: default-segment-radius 1 : sub-tunnel ( from to segments -- segments ) #! return segments between from and to, after clamping from and to to #! valid values - [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; + [ '[ _ clamp-length ] bi@ ] keep ; : nearer-segment ( segment segment oint -- segment ) #! return whichever of the two segments is nearer to the oint @@ -82,7 +88,7 @@ CONSTANT: default-segment-radius 1 ] dip nearer-segment ; : get-segment ( segments n -- segment ) - over sequence-index-range clamp-to-range swap nth ; + over clamp-length swap nth ; : next-segment ( segments current-segment -- segment ) number>> 1+ get-segment ; diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor index 9ed29aef45..5e99b15df5 100644 --- a/extra/mason/notify/server/server.factor +++ b/extra/mason/notify/server/server.factor @@ -45,7 +45,7 @@ builder "BUILDERS" { SYMBOLS: host-name target-os target-cpu message message-arg ; : parse-args ( command-line -- ) - dup peek message-arg set + dup last message-arg set [ { [ host-name set ] diff --git a/extra/math/compare/compare-docs.factor b/extra/math/compare/compare-docs.factor index 4cbe1a1ae0..27e68081a6 100644 --- a/extra/math/compare/compare-docs.factor +++ b/extra/math/compare/compare-docs.factor @@ -16,8 +16,3 @@ HELP: posmax HELP: negmin { $values { "a" number } { "b" number } { "x" number } } { $description "Returns the most-negative value, or zero if both are positive." } ; - -HELP: clamp -{ $values { "value" number } { "a" number } { "b" number } { "x" number } } -{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ; - diff --git a/extra/math/compare/compare-tests.factor b/extra/math/compare/compare-tests.factor index 9accc8e98b..5b30af0e63 100644 --- a/extra/math/compare/compare-tests.factor +++ b/extra/math/compare/compare-tests.factor @@ -14,8 +14,3 @@ IN: math.compare.tests [ 0 ] [ 1 3 negmin ] unit-test [ -3 ] [ 1 -3 negmin ] unit-test [ -1 ] [ -1 3 negmin ] unit-test - -[ 0 ] [ -1 0 2 clamp ] unit-test -[ 1 ] [ 1 0 2 clamp ] unit-test -[ 2 ] [ 3 0 2 clamp ] unit-test - diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor index 93a8da7cf3..b48641d723 100644 --- a/extra/math/compare/compare.factor +++ b/extra/math/compare/compare.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2008 John Benediktsson. ! See http://factorcode.org/license.txt for BSD license - USING: math math.order kernel ; - IN: math.compare : absmin ( a b -- x ) @@ -16,6 +14,3 @@ IN: math.compare : negmin ( a b -- x ) 0 min min ; - -: clamp ( value a b -- x ) - [ max ] [ min ] bi* ; diff --git a/extra/math/vectors/homogeneous/homogeneous.factor b/extra/math/vectors/homogeneous/homogeneous.factor index 218e56dfb5..65f57be514 100644 --- a/extra/math/vectors/homogeneous/homogeneous.factor +++ b/extra/math/vectors/homogeneous/homogeneous.factor @@ -5,7 +5,7 @@ IN: math.vectors.homogeneous : (homogeneous-xyz) ( h -- xyz ) 1 head* ; inline : (homogeneous-w) ( h -- w ) - peek ; inline + last ; inline : h+ ( a b -- c ) 2dup [ (homogeneous-w) ] bi@ over = diff --git a/extra/project-euler/049/049.factor b/extra/project-euler/049/049.factor index 15dd7ed6d2..9ecf942ef6 100644 --- a/extra/project-euler/049/049.factor +++ b/extra/project-euler/049/049.factor @@ -50,7 +50,7 @@ HINTS: count-digits fixnum ; : (find-unusual-terms) ( n seq -- seq/f ) [ [ arithmetic-terms ] with map ] keep - '[ _ [ peek ] dip member? ] find nip ; + '[ _ [ last ] dip member? ] find nip ; : find-unusual-terms ( seq -- seq/? ) unclip-slice over (find-unusual-terms) [ diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor index 9a2fb8c868..1fb5c7c8bb 100644 --- a/extra/project-euler/059/059.factor +++ b/extra/project-euler/059/059.factor @@ -75,7 +75,7 @@ INSTANCE: rollover immutable-sequence ] { } make nip ; inline : most-frequent ( seq -- elt ) - frequency-analysis sort-values keys peek ; + frequency-analysis sort-values keys last ; : crack-key ( seq key-length -- key ) [ " " decrypt ] dip group but-last-slice diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor index 174618e147..2766322323 100644 --- a/extra/project-euler/116/116.factor +++ b/extra/project-euler/116/116.factor @@ -41,10 +41,10 @@ IN: project-euler.116 [ length swap - 1- ] keep ?nth 0 or ; : next ( colortile seq -- ) - [ nth* ] [ peek + ] [ push ] tri ; + [ nth* ] [ last + ] [ push ] tri ; : ways ( length colortile -- permutations ) - V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ; + V{ 1 } clone [ [ next ] 2curry times ] keep last 1- ; : (euler116) ( length -- permutations ) 3 [1,b] [ ways ] with sigma ; diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor index cb485d3ce2..0d4ec78226 100644 --- a/extra/project-euler/117/117.factor +++ b/extra/project-euler/117/117.factor @@ -31,7 +31,7 @@ IN: project-euler.117 [ 4 short tail* sum ] keep push ; : (euler117) ( n -- m ) - V{ 1 } clone tuck [ next ] curry times peek ; + V{ 1 } clone tuck [ next ] curry times last ; PRIVATE> diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor index cea1472c0b..af8b7e49c0 100644 --- a/extra/project-euler/164/164.factor +++ b/extra/project-euler/164/164.factor @@ -18,7 +18,7 @@ IN: project-euler.164 > 0.0 ${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; : clamp-pitch ( pitch -- pitch' ) - 90.0 min -90.0 max ; + -90.0 90.0 clamp ; : walk-forward ( player -- ) dup forward-vector [ v+ ] curry change-velocity drop ; diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 86f4f19147..8da50017c8 100755 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -47,7 +47,7 @@ syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean -syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? at-default unzip +syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip syn keyword factorKeyword case execute-effect dispatch-case-quot no-cond no-case? 3cleave>quot contiguous-range? 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case hash-dispatch-quot case>quot 3cleave wrong-values alist>quot hash-case-table hash-case-quot case-find (distribute-buckets) cond cleave distribute-buckets call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from prepare-index reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head replicate set-fourth peek shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth second change-each join when-empty accumulator immutable-sequence? all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim From e0df03bfb135ed780ece7c76e87e028920fbd178 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 1 Jun 2009 11:20:49 -0700 Subject: [PATCH 04/33] Adding cdfactor script. --- misc/bash/cdfactor.sh | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100755 misc/bash/cdfactor.sh diff --git a/misc/bash/cdfactor.sh b/misc/bash/cdfactor.sh new file mode 100755 index 0000000000..cee2d3ac77 --- /dev/null +++ b/misc/bash/cdfactor.sh @@ -0,0 +1,18 @@ +#!/bin/bash + +# change directories to a factor module +function cdfactor { + code=$(printf "USING: io io.pathnames vocabs vocabs.loader ; " + printf "\"%s\" vocab-source-path (normalize-path) print" $1) + echo $code > $HOME/.cdfactor + fn=$(factor $HOME/.cdfactor) + dn=$(dirname $fn) + echo $dn + if [ -z "$dn" ]; then + echo "Warning: directory '$1' not found" 1>&2 + else + cd $dn + fi +} + + From d99ae5af9246d7fc669f86bd7bfe84811ad8b12d Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 1 Jun 2009 11:21:14 -0700 Subject: [PATCH 05/33] Adding brainf*ck implementation. --- extra/brainfuck/authors.txt | 1 + extra/brainfuck/brainfuck-docs.factor | 49 ++++++++++++++ extra/brainfuck/brainfuck-tests.factor | 10 +++ extra/brainfuck/brainfuck.factor | 93 ++++++++++++++++++++++++++ extra/brainfuck/summary.txt | 1 + 5 files changed, 154 insertions(+) create mode 100644 extra/brainfuck/authors.txt create mode 100644 extra/brainfuck/brainfuck-docs.factor create mode 100644 extra/brainfuck/brainfuck-tests.factor create mode 100644 extra/brainfuck/brainfuck.factor create mode 100644 extra/brainfuck/summary.txt diff --git a/extra/brainfuck/authors.txt b/extra/brainfuck/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/brainfuck/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/brainfuck/brainfuck-docs.factor b/extra/brainfuck/brainfuck-docs.factor new file mode 100644 index 0000000000..c11c05a2e2 --- /dev/null +++ b/extra/brainfuck/brainfuck-docs.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2009 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: help.syntax help.markup brainfuck strings ; + +IN: brainfuck + +HELP: run-brainfuck +{ $values { "code" string } } +{ $description + "A brainfuck program is a sequence of eight commands that are " + "executed sequentially. An instruction pointer begins at the first " + "command, and each command is executed until the program terminates " + "when the instruction pointer moves beyond the last command.\n" + "\n" + "The eight language commands, each consisting of a single character, " + "are the following:\n" + { $table + { "Character" "Meaning" } + { ">" "increment the data pointer (to point to the next cell to the right)." } + { "<" "decrement the data pointer (to point to the next cell to the left)." } + { "+" "increment (increase by one) the byte at the data pointer." } + { "-" "decrement (decrease by one) the byte at the data pointer." } + { "." "output the value of the byte at the data pointer." } + { "," "accept one byte of input, storing its value in the byte at the data pointer." } + { "[" "if the byte at the data pointer is zero, then instead of moving the instruction pointer forward to the next command, jump it forward to the command after the matching ] command*." } + { "]" "if the byte at the data pointer is nonzero, then instead of moving the instruction pointer forward to the next command, jump it back to the command after the matching [ command*." } + } + "\n" + "Brainfuck programs can be translated into C using the following " + "substitutions, assuming ptr is of type unsigned char* and has been " + "initialized to point to an array of zeroed bytes:\n" + { $table + { "Character" "C equivalent" } + { ">" "++ptr;" } + { "<" "--ptr;" } + { "+" "++*ptr;" } + { "-" "--*ptr;" } + { "." "putchar(*ptr);" } + { "," "*ptr=getchar();" } + { "[" "while (*ptr) {" } + { "]" "}" } + } +} ; + +HELP: get-brainfuck +{ $values { "code" string } { "result" string } } +{ $description "Returns the output from a brainfuck program as a result string." } +{ $see-also run-brainfuck } ; diff --git a/extra/brainfuck/brainfuck-tests.factor b/extra/brainfuck/brainfuck-tests.factor new file mode 100644 index 0000000000..10a62b1a0b --- /dev/null +++ b/extra/brainfuck/brainfuck-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: brainfuck multiline tools.test ; + + +[ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-] + >++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++. + ------.--------.>+.>. "> get-brainfuck ] unit-test + diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor new file mode 100644 index 0000000000..d13153713a --- /dev/null +++ b/extra/brainfuck/brainfuck.factor @@ -0,0 +1,93 @@ +! Copyright (C) 2009 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors assocs combinators io io.streams.string kernel math +namespaces sequences strings ; + +IN: brainfuck + +> [ set-at ] [ [ swap ] dip set-at ] 3bi ; + +SYMBOL: tmp + +: ( code -- brainfuck ) + 0 0 0 H{ } clone H{ } clone brainfuck boa + V{ } clone tmp set + dup code>> [ + { + { CHAR: [ [ tmp get push ] } + { CHAR: ] [ tmp get pop (set-loop) ] } + [ 2drop ] + } case + ] assoc-each ; + + +: (get-memory) ( brainfuck -- brainfuck value ) + dup [ dp>> ] [ memory>> ] bi at 0 or ; + +: (set-memory) ( intepreter value -- brainfuck ) + over [ dp>> ] [ memory>> ] bi set-at ; + +: (inc-memory) ( brainfuck -- brainfuck ) + (get-memory) 1 + 255 bitand (set-memory) ; + +: (dec-memory) ( brainfuck -- brainfuck ) + (get-memory) 1 - 255 bitand (set-memory) ; + +: (out-memory) ( brainfuck -- brainfuck ) + (get-memory) 1string write ; + + +: (inc-data) ( brainfuck -- brainfuck ) + [ 1 + ] change-dp ; + +: (dec-data) ( brainfuck -- brainfuck ) + [ 1 - ] change-dp ; + + +: (loop-start) ( brainfuck -- brainfuck ) + (get-memory) 0 = [ dup [ cp>> ] [ loop>> ] bi at >>cp ] when ; + +: (loop-end) ( brainfuck -- brainfuck ) + dup [ cp>> ] [ loop>> ] bi at 1 - >>cp ; + + +: (get-input) ( brainfuck -- brainfuck ) + read1 (set-memory) ; + + +: can-step ( brainfuck -- brainfuck t/f ) + dup [ steps>> 100000 < ] [ cp>> ] [ code>> length ] tri < and ; + +: step ( brainfuck -- brainfuck ) + dup [ cp>> ] [ code>> ] bi nth + { + { CHAR: > [ (inc-data) ] } + { CHAR: < [ (dec-data) ] } + { CHAR: + [ (inc-memory) ] } + { CHAR: - [ (dec-memory) ] } + { CHAR: . [ (out-memory) ] } + { CHAR: , [ (get-input) ] } + { CHAR: [ [ (loop-start) ] } + { CHAR: ] [ (loop-end) ] } + { CHAR: \s [ ] } + { CHAR: \t [ ] } + { CHAR: \r [ ] } + { CHAR: \n [ ] } + [ "invalid input" throw ] + } case [ 1 + ] change-cp [ 1 + ] change-steps ; + +PRIVATE> + +: run-brainfuck ( code -- ) + [ can-step ] [ step ] while drop ; + +: get-brainfuck ( code -- result ) + [ run-brainfuck ] with-string-writer ; + + diff --git a/extra/brainfuck/summary.txt b/extra/brainfuck/summary.txt new file mode 100644 index 0000000000..792dbbae08 --- /dev/null +++ b/extra/brainfuck/summary.txt @@ -0,0 +1 @@ +Brainfuck programming language. From 7f12d582a5e786696a66580ec5597ae14d4e891f Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 1 Jun 2009 14:00:37 -0700 Subject: [PATCH 06/33] Updated test cases. --- extra/brainfuck/brainfuck-tests.factor | 40 +++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/extra/brainfuck/brainfuck-tests.factor b/extra/brainfuck/brainfuck-tests.factor index 10a62b1a0b..452e0a4bdc 100644 --- a/extra/brainfuck/brainfuck-tests.factor +++ b/extra/brainfuck/brainfuck-tests.factor @@ -1,10 +1,48 @@ ! Copyright (C) 2009 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: brainfuck multiline tools.test ; +USING: brainfuck io.streams.string multiline tools.test ; +! Hello World! + [ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-] >++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++. ------.--------.>+.>. "> get-brainfuck ] unit-test +! Addition (single-digit) + +[ "8" ] [ "35" [ ",>++++++[<-------->-],[<+>-]<." + get-brainfuck ] with-string-reader ] unit-test + +! Multiplication (single-digit) + +[ "8\0" ] [ "24" [ <" ,>,>++++++++[<------<------>>-] + <<[>[>+>+<<-]>>[<<+>>-]<<<-] + >>>++++++[<++++++++>-],<.>. "> + get-brainfuck ] with-string-reader ] unit-test + +! Division (single-digit, integer) + +[ "3" ] [ "62" [ <" ,>,>++++++[-<--------<-------->>] + <<[ + >[->+>+<<] + >[-<<- + [>]>>>[<[>>>-<<<[-]]>>]<<] + >>>+ + <<[-<<+>>] + <<<] + >[-]>>>>[-<<<<<+>>>>>] + <<<<++++++[-<++++++++>]<. "> + get-brainfuck ] with-string-reader ] unit-test + +! Uppercase + +[ "A" ] [ "a\n" [ ",----------[----------------------.,----------]" + get-brainfuck ] with-string-reader ] unit-test + +! cat + +[ "ABC" ] [ "ABC\0" [ ",[.,]" get-brainfuck ] with-string-reader ] unit-test + + From 577c450db90f1b7ca4eb01688085ed2a610dfad2 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 2 Jun 2009 00:55:53 +0200 Subject: [PATCH 07/33] FUEL: When creating foo-docs.factor, optionally insert scaffold. --- misc/fuel/factor-mode.el | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index b302fb6b8f..af0f62aa27 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -36,6 +36,13 @@ When set to false, you'll be asked only once." :type 'boolean :group 'factor-mode) +(defcustom factor-mode-cycle-insert-docs-p 'ask + "Whether to insert documentation templates upon creation of doc +file during cycling." + :type '(choice (const :tag "Never" nil) + (const :tag "Always" 'always) + (const :tag "Ask me" 'ask))) + (defcustom factor-mode-use-fuel t "Whether to use the full FUEL facilities in factor mode. @@ -125,7 +132,8 @@ code in the buffer." (defun factor-mode--indent-setter-line () (when (fuel-syntax--at-setter-line) (save-excursion - (let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation)))) + (let ((indent (and (fuel-syntax--at-constructor-line) + (current-indentation)))) (while (not (or indent (bobp) (fuel-syntax--at-begin-of-def) @@ -225,12 +233,32 @@ code in the buffer." (defsubst factor-mode--cycling-setup () (setq factor-mode--cycling-no-ask nil)) +(defun factor-mode--other-file-doc-p (file) + (let ((bn (file-name-nondirectory file))) + (and (string-match "\\(.+\\)-docs.factor" bn) + (expand-file-name (concat (match-string 1 bn) ".factor") + (file-name-directory file))))) + +(defun factor-mode--other-file-check-docs (file) + (when (and factor-mode-cycle-insert-docs-p + (boundp 'fuel-mode) + fuel-mode) + (let ((code-file (factor-mode--other-file-doc-p file))) + (when (and code-file + (or (eq factor-mode-cycle-insert-docs-p 'always) + (y-or-n-p "Insert doc templates? "))) + (save-excursion + (set-buffer (find-file-noselect code-file)) + (fuel-scaffold-help)))))) + (defun factor-mode-visit-other-file (&optional skip) "Cycle between code, tests and docs factor files. With prefix, non-existing files will be skipped." (interactive "P") (let ((file (factor-mode--cycle-next (buffer-file-name) skip))) (unless file (error "No other file found")) + (unless (file-exists-p file) + (factor-mode--other-file-check-docs file)) (find-file file) (unless (file-exists-p file) (set-buffer-modified-p t) From a381d12b6d04bce1a4bb0a73f70836e07221e511 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 2 Jun 2009 03:21:35 +0200 Subject: [PATCH 08/33] FUEL: Automatic insertion of scaffolding in docs and test upon file creation. --- misc/fuel/factor-mode.el | 32 ++++++-------------- misc/fuel/fuel-mode.el | 5 ++- misc/fuel/fuel-scaffold.el | 62 ++++++++++++++++++++++++++++++++++++-- 3 files changed, 72 insertions(+), 27 deletions(-) diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index af0f62aa27..cc8ebe35fb 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -36,13 +36,6 @@ When set to false, you'll be asked only once." :type 'boolean :group 'factor-mode) -(defcustom factor-mode-cycle-insert-docs-p 'ask - "Whether to insert documentation templates upon creation of doc -file during cycling." - :type '(choice (const :tag "Never" nil) - (const :tag "Always" 'always) - (const :tag "Ask me" 'ask))) - (defcustom factor-mode-use-fuel t "Whether to use the full FUEL facilities in factor mode. @@ -233,23 +226,18 @@ code in the buffer." (defsubst factor-mode--cycling-setup () (setq factor-mode--cycling-no-ask nil)) -(defun factor-mode--other-file-doc-p (file) - (let ((bn (file-name-nondirectory file))) - (and (string-match "\\(.+\\)-docs.factor" bn) +(defun factor-mode--code-file (kind &optional file) + (let* ((file (or file (buffer-file-name))) + (bn (file-name-nondirectory file))) + (and (string-match (format "\\(.+\\)-%s\\.factor$" kind) bn) (expand-file-name (concat (match-string 1 bn) ".factor") (file-name-directory file))))) -(defun factor-mode--other-file-check-docs (file) - (when (and factor-mode-cycle-insert-docs-p - (boundp 'fuel-mode) - fuel-mode) - (let ((code-file (factor-mode--other-file-doc-p file))) - (when (and code-file - (or (eq factor-mode-cycle-insert-docs-p 'always) - (y-or-n-p "Insert doc templates? "))) - (save-excursion - (set-buffer (find-file-noselect code-file)) - (fuel-scaffold-help)))))) +(defsubst factor-mode--in-docs (&optional file) + (factor-mode--code-file "docs")) + +(defsubst factor-mode--in-tests (&optional file) + (factor-mode--code-file "tests")) (defun factor-mode-visit-other-file (&optional skip) "Cycle between code, tests and docs factor files. @@ -257,8 +245,6 @@ With prefix, non-existing files will be skipped." (interactive "P") (let ((file (factor-mode--cycle-next (buffer-file-name) skip))) (unless file (error "No other file found")) - (unless (file-exists-p file) - (factor-mode--other-file-check-docs file)) (find-file file) (unless (file-exists-p file) (set-buffer-modified-p t) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 0186392f34..282ef3240f 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -172,7 +172,10 @@ interacting with a factor listener is at your disposal. (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode)) (setq fuel-stack-mode-string "/S") - (when fuel-mode-stack-p (fuel-stack-mode fuel-mode))) + (when fuel-mode-stack-p (fuel-stack-mode fuel-mode)) + + (when (and fuel-mode (not (file-exists-p (buffer-file-name)))) + (fuel-scaffold--maybe-insert))) ;;; Keys: diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index b1c4462503..9b7d9861c7 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/misc/fuel/fuel-scaffold.el @@ -39,6 +39,64 @@ (let ((cmd '(:fuel* (vocab-roots get :get) "fuel"))) (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) +(defun fuel-scaffold--dev-name () + (or fuel-scaffold-developer-name + (let ((cmd '(:fuel* (developer-name get :get) "fuel"))) + (fuel-eval--retort-result (fuel-eval--send/wait cmd))) + "Your name")) + +(defun fuel-scaffold--first-vocab () + (goto-char (point-min)) + (re-search-forward fuel-syntax--current-vocab-regex nil t)) + +(defsubst fuel-scaffold--vocab (file) + (save-excursion + (set-buffer (find-file-noselect file)) + (fuel-scaffold--first-vocab) + (fuel-syntax--current-vocab))) + +(defconst fuel-scaffold--tests-header-format + "! Copyright (C) %s %s +! See http://factorcode.org/license.txt for BSD license. +USING: %s tools.test ; +IN: %s +") + +(defsubst fuel-scaffold--check-auto (var) + (and var (or (eq var 'always) (y-or-n-p "Insert template? ")))) + +(defun fuel-scaffold--tests (parent) + (when (and parent (fuel-scaffold--check-auto fuel-scaffold-test-autoinsert-p)) + (let ((year (format-time-string "%Y")) + (name (fuel-scaffold--dev-name)) + (vocab (fuel-scaffold--vocab parent))) + (insert (format fuel-scaffold--tests-header-format + year name vocab vocab)) + t))) + +(defsubst fuel-scaffold--create-docs (vocab) + (let ((cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help) + "fuel"))) + (fuel-eval--send/wait cmd))) + +(defun fuel-scaffold--help (parent) + (when (and parent (fuel-scaffold--check-auto fuel-scaffold-help-autoinsert-p)) + (let* ((ret (fuel-scaffold--create-docs (fuel-scaffold--vocab parent))) + (file (fuel-eval--retort-result ret))) + (when file + (revert-buffer t t t) + (when (and fuel-scaffold-help-header-only-p + (fuel-scaffold--first-vocab)) + (delete-region (1+ (point)) (point-max)) + (save-buffer)) + (message "Inserting template ... done.")) + (goto-char (point-min))))) + +(defun fuel-scaffold--maybe-insert () + (ignore-errors + (or (fuel-scaffold--tests (factor-mode--in-tests)) + (fuel-scaffold--help (factor-mode--in-docs))))) + ;;; User interface: @@ -73,9 +131,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to (interactive "P") (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) (fuel-completion--read-vocab nil))) - (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help) - "fuel")) - (ret (fuel-eval--send/wait cmd)) + (ret (fuel-scaffold--create-docs vocab)) (file (fuel-eval--retort-result ret))) (unless file (error "Error creating help file" (car (fuel-eval--retort-error ret)))) From 09b08a092468c5521ba878a076b4b116fa8f0f2d Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 2 Jun 2009 04:34:40 +0200 Subject: [PATCH 09/33] FUEL: Better looking tables in help buffers and a fix for in-cell links. --- misc/fuel/fuel-markup.el | 2 +- misc/fuel/fuel-table.el | 59 ++++++++++++++++++++++++++++++++++------ 2 files changed, 52 insertions(+), 9 deletions(-) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 80fe8e830b..cc788fe5dc 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -382,7 +382,7 @@ (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$") (push (list "Word" (match-string-no-properties 1)) rows) (forward-line)) - (while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$") + (while (looking-at " ?\\(.+?\\)\\( +\\(.+\\)\\)?$") (let ((word `($link ,(match-string-no-properties 1) ,(match-string-no-properties 1) word)) diff --git a/misc/fuel/fuel-table.el b/misc/fuel/fuel-table.el index a00b21bf2f..dfab07c540 100644 --- a/misc/fuel/fuel-table.el +++ b/misc/fuel/fuel-table.el @@ -72,21 +72,64 @@ (push (fuel-table--pad-row (reverse frow)) frows))) (reverse frows))) +(defvar fuel-table-corner-lt "┌") +(defvar fuel-table-corner-lb "└") +(defvar fuel-table-corner-rt "┐") +(defvar fuel-table-corner-rb "┘") +(defvar fuel-table-line "─") +(defvar fuel-table-tee-t "┬") +(defvar fuel-table-tee-b "┴") +(defvar fuel-table-tee-l "├") +(defvar fuel-table-tee-r "┤") +(defvar fuel-table-crux "┼") +(defvar fuel-table-sep "│") + +(defun fuel-table--insert-line (widths first last sep) + (insert first fuel-table-line) + (dolist (w widths) + (while (> w 0) + (insert fuel-table-line) + (setq w (1- w))) + (insert fuel-table-line sep fuel-table-line)) + (delete-char -2) + (insert fuel-table-line last) + (newline)) + +(defun fuel-table--insert-first-line (widths) + (fuel-table--insert-line widths + fuel-table-corner-lt + fuel-table-corner-rt + fuel-table-tee-t)) + +(defun fuel-table--insert-middle-line (widths) + (fuel-table--insert-line widths + fuel-table-tee-l + fuel-table-tee-r + fuel-table-crux)) + +(defun fuel-table--insert-last-line (widths) + (fuel-table--insert-line widths + fuel-table-corner-lb + fuel-table-corner-rb + fuel-table-tee-b)) + (defun fuel-table--insert (rows) (let* ((widths (fuel-table--col-widths rows)) - (rows (fuel-table--format-rows rows widths)) - (ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+"))) - (insert ls "\n") + (rows (fuel-table--format-rows rows widths))) + (fuel-table--insert-first-line widths) (dolist (r rows) (let ((ln (length (car r))) (l 0)) (while (< l ln) - (insert (concat "|" (mapconcat 'identity - (mapcar `(lambda (x) (nth ,l x)) r) - " |") - " |\n")) + (insert (concat fuel-table-sep " " + (mapconcat 'identity + (mapcar `(lambda (x) (nth ,l x)) r) + (concat " " fuel-table-sep " ")) + " " fuel-table-sep "\n")) (setq l (1+ l)))) - (insert ls "\n")))) + (fuel-table--insert-middle-line widths)) + (kill-line -1) + (fuel-table--insert-last-line widths))) (provide 'fuel-table) From 7639afb0d743518b86affe921f6884395262da92 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 2 Jun 2009 05:02:39 +0200 Subject: [PATCH 10/33] FUEL: Tiny refactoring. --- misc/fuel/fuel-table.el | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/misc/fuel/fuel-table.el b/misc/fuel/fuel-table.el index dfab07c540..1af2e25712 100644 --- a/misc/fuel/fuel-table.el +++ b/misc/fuel/fuel-table.el @@ -113,20 +113,23 @@ fuel-table-corner-rb fuel-table-tee-b)) +(defun fuel-table--insert-row (r) + (let ((ln (length (car r))) + (l 0)) + (while (< l ln) + (insert (concat fuel-table-sep " " + (mapconcat 'identity + (mapcar `(lambda (x) (nth ,l x)) r) + (concat " " fuel-table-sep " ")) + " " fuel-table-sep "\n")) + (setq l (1+ l))))) + (defun fuel-table--insert (rows) (let* ((widths (fuel-table--col-widths rows)) (rows (fuel-table--format-rows rows widths))) (fuel-table--insert-first-line widths) (dolist (r rows) - (let ((ln (length (car r))) - (l 0)) - (while (< l ln) - (insert (concat fuel-table-sep " " - (mapconcat 'identity - (mapcar `(lambda (x) (nth ,l x)) r) - (concat " " fuel-table-sep " ")) - " " fuel-table-sep "\n")) - (setq l (1+ l)))) + (fuel-table--insert-row r) (fuel-table--insert-middle-line widths)) (kill-line -1) (fuel-table--insert-last-line widths))) From 7922628abbd5f6ba96a2922be7854299c89e85d1 Mon Sep 17 00:00:00 2001 From: Philipp Winkler Date: Fri, 29 May 2009 14:41:24 -0700 Subject: [PATCH 11/33] Add a hand parser. Improves speed from 23 seconds to 0.03 seconds when parsing a 123Kb string. --- basis/json/reader/authors.txt | 2 + basis/json/reader/reader-tests.factor | 2 + basis/json/reader/reader.factor | 134 ++++++++++++++++---------- 3 files changed, 89 insertions(+), 49 deletions(-) diff --git a/basis/json/reader/authors.txt b/basis/json/reader/authors.txt index 44b06f94bc..d269b4ffb5 100644 --- a/basis/json/reader/authors.txt +++ b/basis/json/reader/authors.txt @@ -1 +1,3 @@ Chris Double +Peter Burns +Philipp Winkler diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor index e97d45babe..fa6c8d7d3a 100644 --- a/basis/json/reader/reader-tests.factor +++ b/basis/json/reader/reader-tests.factor @@ -19,6 +19,8 @@ IN: json.reader.tests { 10.25 } [ "1025e-2" json> ] unit-test { 0.125 } [ "0.125" json> ] unit-test { -0.125 } [ "-0.125" json> ] unit-test +{ -0.00125 } [ "-0.125e-2" json> ] unit-test +{ -012.5 } [ "-0.125e+2" json> ] unit-test ! not widely supported by javascript, but allowed in the grammar, and a nice ! feature to get diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 887a7a50e5..1544af55cf 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -1,61 +1,97 @@ -! Copyright (C) 2008 Peter Burns. +! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler ! See http://factorcode.org/license.txt for BSD license. -USING: kernel peg peg.ebnf math.parser math.parser.private strings math -math.functions sequences arrays vectors hashtables assocs -prettyprint json ; +USING: arrays assocs combinators io io.streams.string json +kernel math math.parser math.parser.private sequences strings ; IN: json.reader float ] + [ [ "eE." index ] any? [ >integer ] unless ] bi + ] dip ; -: grammar-list>vector ( seq -- vec ) first2 values swap prefix ; +DEFER: j-string + +: convert-string ( str -- str ) + read1 + { + { CHAR: b [ 8 ] } + { CHAR: f [ 12 ] } + { CHAR: n [ CHAR: \n ] } + { CHAR: r [ CHAR: \r ] } + { CHAR: t [ CHAR: \t ] } + { CHAR: u [ 4 read hex> ] } + [ ] + } case + dup + [ 1string append j-string append ] + [ drop ] if ; + +: j-string ( -- str ) + "\\\"" read-until CHAR: \" = + [ convert-string ] unless ; + +: second-last ( seq -- second-last ) + [ length 2 - ] keep nth ; inline -! Grammar for JSON from RFC 4627 -EBNF: (json>) +: third-last ( seq -- third-last ) + [ length 3 - ] keep nth ; inline + +: last2 ( seq -- second-last last ) + [ second-last ] [ last ] bi ; inline -ws = (" " | "\r" | "\t" | "\n")* +: last3 ( seq -- third-last second-last last ) + [ third-last ] [ last2 ] bi ; inline -true = "true" => [[ t ]] -false = "false" => [[ f ]] -null = "null" => [[ json-null ]] +: v-over-push ( vec -- vec' ) + dup length 2 >= + [ + dup + [ pop ] + [ last ] bi push + ] when ; -hex = [0-9a-fA-F] -char = '\\"' [[ CHAR: " ]] - | "\\\\" [[ CHAR: \ ]] - | "\\/" [[ CHAR: / ]] - | "\\b" [[ 8 ]] - | "\\f" [[ 12 ]] - | "\\n" [[ CHAR: \n ]] - | "\\r" [[ CHAR: \r ]] - | "\\t" [[ CHAR: \t ]] - | "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]] - | [^"\] -string = '"' char*:cs '"' => [[ cs >string ]] +: v-pick-push ( vec -- vec' ) + dup length 3 >= + [ + dup + [ pop ] + [ second-last ] bi push + ] when ; -sign = ("-" | "+")? => [[ "-" = "-" "" ? ]] -digits = [0-9]+ => [[ >string ]] -decimal = "." digits => [[ concat ]] -exp = ("e" | "E") sign digits => [[ concat ]] -number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]] - -elements = value ("," value)* => [[ grammar-list>vector ]] -array = "[" elements?:arr "]" => [[ arr >array ]] - -pair = ws string:key ws ":" value:val => [[ { key val } ]] -members = pair ("," pair)* => [[ grammar-list>vector ]] -object = "{" members?:hash "}" => [[ hash >hashtable ]] - -val = true - | false - | null - | string - | number - | array - | object - -value = ws val:v ws => [[ v ]] - -;EBNF +: (close-hash) ( accum -- accum' ) + dup length 3 >= [ v-over-push ] when + dup dup [ pop ] dip pop swap + zip H{ } assoc-clone-like over push ; + +: scan ( accum char -- accum ) + [ + { + { CHAR: \" [ j-string over push ] } + { CHAR: [ [ V{ } clone over push ] } + { CHAR: , [ v-over-push ] } + { CHAR: ] [ v-over-push dup pop >array over push ] } + { CHAR: { [ 2 [ V{ } clone over push ] times ] } + { CHAR: : [ v-pick-push ] } + { CHAR: } [ (close-hash) ] } + { CHAR: \u000020 [ ] } + { CHAR: \t [ ] } + { CHAR: \r [ ] } + { CHAR: \n [ ] } + { CHAR: t [ 3 read drop t over push ] } + { CHAR: f [ 4 read drop f over push ] } + { CHAR: n [ 3 read drop json-null over push ] } + [ value [ over push ] dip [ scan ] when* ] + } case + ] when* ; +: (json-parser>) ( string -- object ) + [ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ; + PRIVATE> - -: json> ( string -- object ) (json>) ; \ No newline at end of file + +: json> ( string -- object ) + (json-parser>) ; \ No newline at end of file From 81b2a390708fcaa92b05f758126be397294a08c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Jun 2009 18:53:02 -0500 Subject: [PATCH 12/33] compiler.cfg.linear-scan: re-do interval splitting to operate on live ranges; add inactive set processing --- .../linear-scan/allocation/allocation.factor | 212 ++++++++++++++---- .../linear-scan/assignment/assignment.factor | 7 +- .../cfg/linear-scan/linear-scan-tests.factor | 191 ++++++++++++---- .../live-intervals/live-intervals.factor | 3 +- 4 files changed, 314 insertions(+), 99 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 908bf2475b..fa10ecfca4 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences math math.order kernel assocs -accessors vectors fry heaps cpu.architecture combinators -compiler.cfg.registers -compiler.cfg.linear-scan.live-intervals ; +accessors vectors fry heaps cpu.architecture sorting locals +combinators compiler.cfg.registers +compiler.cfg.linear-scan.live-intervals hints ; IN: compiler.cfg.linear-scan.allocation ! Mapping from register classes to sequences of machine registers @@ -27,13 +27,61 @@ SYMBOL: active-intervals : delete-active ( live-interval -- ) dup vreg>> active-intervals-for delq ; -: expire-old-intervals ( n -- ) - active-intervals swap '[ - [ - [ end>> _ < ] partition - [ [ deallocate-register ] each ] dip - ] assoc-map - ] change ; +! Vector of inactive live intervals +SYMBOL: inactive-intervals + +: inactive-intervals-for ( vreg -- seq ) + reg-class>> inactive-intervals get at ; + +: add-inactive ( live-interval -- ) + dup vreg>> inactive-intervals-for push ; + +! Vector of handled live intervals +SYMBOL: handled-intervals + +: add-handled ( live-interval -- ) + handled-intervals get push ; + +: finished? ( n live-interval -- ? ) end>> swap < ; + +: finish ( n live-interval -- keep? ) + nip [ deallocate-register ] [ add-handled ] bi f ; + +: activate ( n live-interval -- keep? ) + nip add-active f ; + +: deactivate ( n live-interval -- keep? ) + nip add-inactive f ; + +: don't-change ( n live-interval -- keep? ) 2drop t ; + +! Moving intervals between active and inactive sets +: process-intervals ( n symbol quots -- ) + ! symbol stores an alist mapping register classes to vectors + [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline + +: covers? ( insn# live-interval -- ? ) + ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ; + +: deactivate-intervals ( n -- ) + ! Any active intervals which have ended are moved to handled + ! Any active intervals which cover the current position + ! are moved to inactive + active-intervals { + { [ 2dup finished? ] [ finish ] } + { [ 2dup covers? not ] [ deactivate ] } + [ don't-change ] + } process-intervals ; + +: activate-intervals ( n -- ) + ! Any inactive intervals which have ended are moved to handled + ! Any inactive intervals which do not cover the current position + ! are moved to active + inactive-intervals { + { [ 2dup finished? ] [ finish ] } + { [ 2dup covers? ] [ activate ] } + [ don't-change ] + } process-intervals ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -66,29 +114,64 @@ SYMBOL: progress : coalesce ( live-interval -- ) dup copy-from>> active-interval - [ [ add-active ] [ delete-active ] bi* ] + [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ] [ reg>> >>reg drop ] 2bi ; ! Splitting -: find-use ( live-interval n quot -- i elt ) - [ uses>> ] 2dip curry find ; inline +: split-range ( live-range n -- before after ) + [ [ from>> ] dip ] + [ 1 + swap to>> ] + 2bi ; -: split-before ( live-interval i -- before ) - [ clone dup uses>> ] dip - [ head >>uses ] [ 1- swap nth >>end ] 2bi ; +: split-last-range? ( last n -- ? ) + swap to>> <= ; -: split-after ( live-interval i -- after ) - [ clone dup uses>> ] dip - [ tail >>uses ] [ swap nth >>start ] 2bi - f >>reg f >>copy-from ; +: split-last-range ( before after last n -- before' after' ) + split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ; -: split-interval ( live-interval n -- before after ) - [ drop ] [ [ > ] find-use drop ] 2bi - [ split-before ] [ split-after ] 2bi ; +: split-ranges ( live-ranges n -- before after ) + [ '[ from>> _ <= ] partition ] + [ + pick empty? [ drop ] [ + [ over last ] dip 2dup split-last-range? + [ split-last-range ] [ 2drop ] if + ] if + ] bi ; + +: split-uses ( uses n -- before after ) + '[ _ <= ] partition ; : record-split ( live-interval before after -- ) - [ >>split-before ] [ >>split-after ] bi* drop ; + [ >>split-before ] [ >>split-after ] bi* drop ; inline + +: check-split ( live-interval -- ) + [ end>> ] [ start>> ] bi - 0 = + [ "BUG: splitting atomic interval" throw ] when ; inline + +: split-before ( before -- before' ) + [ [ ranges>> last ] [ uses>> last ] bi >>to drop ] + [ compute-start/end ] + [ ] + tri ; inline + +: split-after ( after -- after' ) + [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] + [ compute-start/end ] + [ ] + tri ; inline + +:: split-interval ( live-interval n -- before after ) + live-interval check-split + live-interval clone :> before + live-interval clone f >>copy-from f >>reg :> after + live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi* + live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi* + live-interval before after record-split + before split-before + after split-after ; + +HINTS: split-interval live-interval object ; ! Spilling SYMBOL: spill-counts @@ -96,6 +179,9 @@ SYMBOL: spill-counts : next-spill-location ( reg-class -- n ) spill-counts get [ dup 1+ ] change-at ; +: find-use ( live-interval n quot -- i elt ) + [ uses>> ] 2dip curry find ; inline + : interval-to-spill ( active-intervals current -- live-interval ) #! We spill the interval with the most distant use location. start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc @@ -108,8 +194,7 @@ SYMBOL: spill-counts [ >>spill-to ] [ >>reload-from ] bi-curry bi* ; : split-and-spill ( new existing -- before after ) - dup rot start>> split-interval - [ record-split ] [ assign-spill ] 2bi ; + swap start>> split-interval assign-spill ; : reuse-register ( new existing -- ) reg>> >>reg add-active ; @@ -121,7 +206,7 @@ SYMBOL: spill-counts #! of the existing interval again. [ reuse-register ] [ nip delete-active ] - [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ; + [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ; : spill-new ( new existing -- ) #! Our new interval will be used after the active interval @@ -141,37 +226,78 @@ SYMBOL: spill-counts : assign-free-register ( new registers -- ) pop >>reg add-active ; -: assign-register ( new -- ) - dup coalesce? [ - coalesce +: next-intersection ( new inactive -- n ) + 2drop 0 ; + +: intersecting-inactive ( new -- live-intervals ) + dup vreg>> inactive-intervals-for + [ tuck next-intersection ] with { } map>assoc ; + +: fits-in-hole ( new pair -- ) + first reuse-register ; + +: split-before-use ( new pair -- before after ) + ! Find optimal split position + second split-interval ; + +: assign-inactive-register ( new live-intervals -- ) + ! If there is an interval which is inactive for the entire lifetime + ! if the new interval, reuse its vreg. Otherwise, split new so that + ! the first half fits. + sort-values last + 2dup [ end>> ] [ second ] bi* < [ + fits-in-hole ] [ - dup vreg>> free-registers-for - [ assign-blocked-register ] - [ assign-free-register ] + [ split-before-use ] keep + '[ _ fits-in-hole ] [ add-unhandled ] bi* + ] if ; + +: assign-register ( new -- ) + dup coalesce? [ coalesce ] [ + dup vreg>> free-registers-for [ + dup intersecting-inactive + [ assign-blocked-register ] + [ assign-inactive-register ] + if-empty + ] [ assign-free-register ] if-empty ] if ; ! Main loop : reg-classes ( -- seq ) { int-regs double-float-regs } ; inline +: reg-class-assoc ( quot -- assoc ) + [ reg-classes ] dip { } map>assoc ; inline + : init-allocator ( registers -- ) - unhandled-intervals set [ reverse >vector ] assoc-map free-registers set - reg-classes [ 0 ] { } map>assoc spill-counts set - reg-classes [ V{ } clone ] { } map>assoc active-intervals set + [ 0 ] reg-class-assoc spill-counts set + unhandled-intervals set + [ V{ } clone ] reg-class-assoc active-intervals set + [ V{ } clone ] reg-class-assoc inactive-intervals set + V{ } clone handled-intervals set -1 progress set ; : handle-interval ( live-interval -- ) - [ start>> progress set ] - [ start>> expire-old-intervals ] - [ assign-register ] - tri ; + [ + start>> + [ progress set ] + [ deactivate-intervals ] + [ activate-intervals ] tri + ] [ assign-register ] bi ; : (allocate-registers) ( -- ) unhandled-intervals get [ handle-interval ] slurp-heap ; +: finish-allocation ( -- ) + ! Sanity check: all live intervals should've been processed + active-intervals inactive-intervals + [ get values [ handled-intervals get push-all ] each ] bi@ ; + : allocate-registers ( live-intervals machine-registers -- live-intervals ) #! This modifies the input live-intervals. init-allocator - dup init-unhandled - (allocate-registers) ; + init-unhandled + (allocate-registers) + finish-allocation + handled-intervals get ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 0de350c215..4a9b0b231d 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -25,12 +25,7 @@ TUPLE: active-intervals seq ; SYMBOL: unhandled-intervals : add-unhandled ( live-interval -- ) - dup split-before>> [ - [ split-before>> ] [ split-after>> ] bi - [ add-unhandled ] bi@ - ] [ - dup start>> unhandled-intervals get heap-push - ] if ; + dup start>> unhandled-intervals get heap-push ; : init-unhandled ( live-intervals -- ) [ add-unhandled ] each ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e0cbe3774f..cf4daa3ab0 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -12,6 +12,60 @@ compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.debugger ; +[ + { T{ live-range f 1 10 } T{ live-range f 15 15 } } + { T{ live-range f 16 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 15 split-ranges +] unit-test + +[ + { T{ live-range f 1 10 } T{ live-range f 15 16 } } + { T{ live-range f 17 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 16 split-ranges +] unit-test + +[ + { T{ live-range f 1 10 } } + { T{ live-range f 15 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 12 split-ranges +] unit-test + +[ + { T{ live-range f 1 10 } T{ live-range f 15 17 } } + { T{ live-range f 18 20 } } +] [ + { + T{ live-range f 1 10 } + T{ live-range f 15 20 } + } 17 split-ranges +] unit-test + +[ + { } + { T{ live-range f 1 10 } } +] [ + { T{ live-range f 1 10 } } 0 split-ranges +] unit-test + +[ + { T{ live-range f 0 0 } } + { T{ live-range f 1 5 } } +] [ + { T{ live-range f 0 5 } } 0 split-ranges +] unit-test + [ 7 ] [ T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 2 } } } @@ -44,23 +98,26 @@ compiler.cfg.linear-scan.debugger ; [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 1 } - { uses V{ 0 1 } } + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 1 } + { uses V{ 0 1 } } + { ranges V{ T{ live-range f 0 1 } } } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 5 } - { uses V{ 5 } } + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 5 } + { uses V{ 5 } } + { ranges V{ T{ live-range f 5 5 } } } } ] [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 5 } - { uses V{ 0 1 5 } } + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 5 } + { uses V{ 0 1 5 } } + { ranges V{ T{ live-range f 0 5 } } } } 2 split-interval ] unit-test @@ -70,12 +127,14 @@ compiler.cfg.linear-scan.debugger ; { start 0 } { end 0 } { uses V{ 0 } } + { ranges V{ T{ live-range f 0 0 } } } } T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } { start 1 } { end 5 } { uses V{ 1 5 } } + { ranges V{ T{ live-range f 1 5 } } } } ] [ T{ live-interval @@ -83,6 +142,7 @@ compiler.cfg.linear-scan.debugger ; { start 0 } { end 5 } { uses V{ 0 1 5 } } + { ranges V{ T{ live-range f 0 5 } } } } 0 split-interval ] unit-test @@ -173,7 +233,13 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -181,8 +247,20 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 10 } + { uses V{ 0 10 } } + { ranges V{ T{ live-range f 0 10 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 11 } + { end 20 } + { uses V{ 11 20 } } + { ranges V{ T{ live-range f 11 20 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -190,8 +268,20 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 30 } + { end 60 } + { uses V{ 30 60 } } + { ranges V{ T{ live-range f 30 60 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -199,8 +289,20 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 30 } + { end 200 } + { uses V{ 30 200 } } + { ranges V{ T{ live-range f 30 200 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -208,8 +310,20 @@ compiler.cfg.linear-scan.debugger ; [ { - T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } - T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } } + T{ live-interval + { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { start 0 } + { end 100 } + { uses V{ 0 100 } } + { ranges V{ T{ live-range f 0 100 } } } + } + T{ live-interval + { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { start 30 } + { end 100 } + { uses V{ 30 100 } } + { ranges V{ T{ live-range f 30 100 } } } + } } H{ { int-regs { "A" } } } check-linear-scan @@ -272,31 +386,10 @@ USING: math.private compiler.cfg.debugger ; test-cfg first optimize-cfg linear-scan drop ] unit-test -[ 0 1 ] [ - { - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 5 } - { uses V{ 0 1 5 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 3 } - { end 4 } - { uses V{ 3 4 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 3 } } } - { start 2 } - { end 6 } - { uses V{ 2 4 6 } } - } - } [ clone ] map - H{ { int-regs { "A" "B" } } } - allocate-registers - first split-before>> [ start>> ] [ end>> ] bi -] unit-test +: fake-live-ranges ( seq -- seq' ) + [ + clone dup [ start>> ] [ end>> ] bi 1vector >>ranges + ] map ; ! Coalescing interacted badly with splitting [ ] [ @@ -345,7 +438,7 @@ USING: math.private compiler.cfg.debugger ; { end 10 } { uses V{ 9 10 } } } - } + } fake-live-ranges { { int-regs { 0 1 2 3 } } } allocate-registers drop ] unit-test @@ -1100,7 +1193,7 @@ USING: math.private compiler.cfg.debugger ; { end 109 } { uses V{ 103 109 } } } - } + } fake-live-ranges { { int-regs { 0 1 2 3 4 } } } allocate-registers drop ] unit-test @@ -1193,7 +1286,7 @@ USING: math.private compiler.cfg.debugger ; { end 92 } { uses V{ 42 45 78 80 92 } } } - } + } fake-live-ranges { { int-regs { 0 1 2 3 } } } allocate-registers drop ] unit-test diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 78ac9428d8..546443b289 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math math.order fry -compiler.cfg.instructions compiler.cfg.registers +binary-search compiler.cfg.instructions compiler.cfg.registers compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals @@ -109,6 +109,7 @@ M: ##copy-float compute-live-intervals* : compute-start/end ( live-interval -- ) dup ranges>> [ first from>> ] [ last to>> ] bi + 2dup > [ "BUG: start > end" throw ] when [ >>start ] [ >>end ] bi* drop ; : finish-live-intervals ( live-intervals -- ) From 5bb235d38ff2cae5101a03bec6fe073d461f4a0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Jun 2009 17:32:12 -0500 Subject: [PATCH 13/33] compiler.cfg.checker: run if a variable is set --- basis/compiler/cfg/checker/checker.factor | 3 +++ basis/compiler/cfg/optimizer/optimizer.factor | 13 ++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 4aa2088143..4f215f1dc8 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -16,6 +16,9 @@ ERROR: last-insn-not-a-jump insn ; [ ##return? ] [ ##callback-return? ] [ ##jump? ] + [ ##fixnum-add-tail? ] + [ ##fixnum-sub-tail? ] + [ ##fixnum-mul-tail? ] [ ##call? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 8ceafd1693..eda55bef86 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -11,9 +11,19 @@ compiler.cfg.dce compiler.cfg.write-barrier compiler.cfg.liveness compiler.cfg.rpo -compiler.cfg.phi-elimination ; +compiler.cfg.phi-elimination +compiler.cfg.checker ; IN: compiler.cfg.optimizer +SYMBOL: check-optimizer? + +t check-optimizer? set-global + +: ?check ( cfg -- cfg' ) + check-optimizer? get [ + dup check-cfg + ] when ; + : optimize-cfg ( cfg -- cfg' ) [ compute-predecessors @@ -27,4 +37,5 @@ IN: compiler.cfg.optimizer eliminate-dead-code eliminate-write-barriers eliminate-phis + ?check ] with-scope ; From 440b464ec17090bb340581043fcc9111dce1544a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Jun 2009 17:32:37 -0500 Subject: [PATCH 14/33] compiler: more informative trace-compilation --- basis/compiler/compiler.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 7527f6b339..6d0f6f3ace 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -193,7 +193,8 @@ M: optimizing-compiler recompile ( words -- alist ) ] each compile-queue get compile-loop compiled get >alist - ] with-scope ; + ] with-scope + "trace-compilation" get [ "--- compile done" print flush ] when ; : with-optimizer ( quot -- ) [ optimizing-compiler compiler-impl ] dip with-variable ; inline From 1e449c70f64e7c40c0d0c73535b9b4015643cc15 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Jun 2009 17:33:00 -0500 Subject: [PATCH 15/33] vocabs.parser: if bootstrap fails to load a vocab in interactive use list, don't fep --- core/vocabs/parser/parser.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index ca783c13e6..5f393ed65d 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -127,7 +127,10 @@ TUPLE: no-current-vocab ; ] [ drop ] if ; : only-use-vocabs ( vocabs -- ) - clear-manifest [ vocab ] filter [ use-vocab ] each ; + clear-manifest + [ vocab ] filter + [ vocab source-loaded?>> +done+ eq? ] filter + [ use-vocab ] each ; TUPLE: qualified vocab prefix words ; From 04c72d0a728ba55921161129a179cdb50522537a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Jun 2009 18:06:47 -0500 Subject: [PATCH 16/33] Linear scan: correctly compute live spill slots --- .../linear-scan/allocation/allocation.factor | 2 +- .../linear-scan/assignment/assignment.factor | 40 ++++++++++++++----- .../cfg/linear-scan/linear-scan-tests.factor | 25 ++++++++++++ .../cfg/linear-scan/linear-scan.factor | 12 +++--- 4 files changed, 63 insertions(+), 16 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index fa10ecfca4..f8258039e1 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -264,7 +264,7 @@ SYMBOL: spill-counts ] if ; ! Main loop -: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline +CONSTANT: reg-classes { int-regs double-float-regs } : reg-class-assoc ( quot -- assoc ) [ reg-classes ] dip { } map>assoc ; inline diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 4a9b0b231d..6fcd6e7570 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math assocs namespaces sequences heaps -fry make combinators +fry make combinators sets cpu.architecture compiler.cfg.def-use compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.assignment @@ -30,25 +31,44 @@ SYMBOL: unhandled-intervals : init-unhandled ( live-intervals -- ) [ add-unhandled ] each ; +! Mapping spill slots to vregs +SYMBOL: spill-slots + +: spill-slots-for ( vreg -- assoc ) + reg-class>> spill-slots get at ; + +: record-spill ( live-interval -- ) + [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi + 2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ; + : insert-spill ( live-interval -- ) - [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri - dup [ _spill ] [ 3drop ] if ; + [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ; + +: handle-spill ( live-interval -- ) + dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; : expire-old-intervals ( n -- ) active-intervals get [ swap '[ end>> _ = ] partition ] change-seq drop - [ insert-spill ] each ; + [ handle-spill ] each ; + +: record-reload ( live-interval -- ) + [ reload-from>> ] [ vreg>> spill-slots-for ] bi + 2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ; : insert-reload ( live-interval -- ) - [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri - dup [ _reload ] [ 3drop ] if ; + [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; + +: handle-reload ( live-interval -- ) + dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ; : activate-new-intervals ( n -- ) #! Any live intervals which start on the current instruction #! are added to the active set. unhandled-intervals get dup heap-empty? [ 2drop ] [ 2dup heap-peek drop start>> = [ - heap-pop drop [ add-active ] [ insert-reload ] bi + heap-pop drop + [ add-active ] [ handle-reload ] bi activate-new-intervals ] [ 2drop ] if ] if ; @@ -71,8 +91,7 @@ M: insn assign-before drop ; active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ; : compute-live-spill-slots ( -- spill-slots ) - unhandled-intervals get - heap-values [ reload-from>> ] filter + spill-slots get values [ values ] map concat [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ; M: ##gc assign-after @@ -88,6 +107,7 @@ M: insn assign-after drop ; : init-assignment ( live-intervals -- ) active-intervals set unhandled-intervals set + [ H{ } clone ] reg-class-assoc spill-slots set init-unhandled ; : assign-registers-in-block ( bb -- ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index cf4daa3ab0..e4510e884e 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1290,3 +1290,28 @@ USING: math.private compiler.cfg.debugger ; { { int-regs { 0 1 2 3 } } } allocate-registers drop ] unit-test + +! Spill slot liveness was computed incorrectly, leading to a FEP +! early in bootstrap on x86-32 +[ t ] [ + T{ basic-block + { instructions + V{ + T{ ##gc f V int-regs 6 V int-regs 7 } + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f V int-regs 2 D 2 } + T{ ##peek f V int-regs 3 D 3 } + T{ ##peek f V int-regs 4 D 4 } + T{ ##peek f V int-regs 5 D 5 } + T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 2 } + T{ ##replace f V int-regs 2 D 3 } + T{ ##replace f V int-regs 3 D 4 } + T{ ##replace f V int-regs 4 D 5 } + T{ ##replace f V int-regs 5 D 0 } + } + } + } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) + instructions>> first live-spill-slots>> empty? +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 1e6b9d02c8..ffa356bfc2 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -25,13 +25,15 @@ IN: compiler.cfg.linear-scan ! by Omri Traub, Glenn Holloway, Michael D. Smith ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 -: (linear-scan) ( rpo -- ) - dup number-instructions - dup compute-live-intervals - machine-registers allocate-registers assign-registers ; +: (linear-scan) ( rpo machine-registers -- ) + [ + dup number-instructions + dup compute-live-intervals + ] dip + allocate-registers assign-registers ; : linear-scan ( cfg -- cfg' ) [ - dup reverse-post-order (linear-scan) + dup reverse-post-order machine-registers (linear-scan) spill-counts get >>spill-counts ] with-scope ; From 7c207ffa12073ac6e9bb5490d71871f65527eea0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Jun 2009 18:07:22 -0500 Subject: [PATCH 17/33] compiler.cfg.optimizer: disable CFG checker by default --- basis/compiler/cfg/optimizer/optimizer.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index eda55bef86..9d481ef1d2 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -17,8 +17,6 @@ IN: compiler.cfg.optimizer SYMBOL: check-optimizer? -t check-optimizer? set-global - : ?check ( cfg -- cfg' ) check-optimizer? get [ dup check-cfg From 70b75b8dea2a64f1cc32859f6b95b73274b438d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Jun 2009 01:04:12 -0500 Subject: [PATCH 18/33] Linear scan: implement live range intersection --- .../linear-scan/allocation/allocation.factor | 29 ++++++++- .../cfg/linear-scan/linear-scan-tests.factor | 60 +++++++++++++++++++ 2 files changed, 86 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index f8258039e1..7b56bd6150 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -226,18 +226,41 @@ SYMBOL: spill-counts : assign-free-register ( new registers -- ) pop >>reg add-active ; -: next-intersection ( new inactive -- n ) - 2drop 0 ; +: relevant-ranges ( new inactive -- new' inactive' ) + ! Slice off all ranges of 'inactive' that precede the start of 'new' + [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; + +: intersect-live-range ( range1 range2 -- n/f ) + 2dup [ from>> ] bi@ > [ swap ] when + 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ; + +: intersect-live-ranges ( ranges1 ranges2 -- n ) + { + { [ over empty? ] [ 2drop 1/0. ] } + { [ dup empty? ] [ 2drop 1/0. ] } + [ + 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [ + drop + 2dup [ first from>> ] bi@ < + [ [ rest-slice ] dip ] [ rest-slice ] if + intersect-live-ranges + ] if + ] + } cond ; + +: intersect-inactive ( new inactive -- n ) + relevant-ranges intersect-live-ranges ; : intersecting-inactive ( new -- live-intervals ) dup vreg>> inactive-intervals-for - [ tuck next-intersection ] with { } map>assoc ; + [ tuck intersect-inactive ] with { } map>assoc ; : fits-in-hole ( new pair -- ) first reuse-register ; : split-before-use ( new pair -- before after ) ! Find optimal split position + ! Insert move instruction second split-interval ; : assign-inactive-register ( new live-intervals -- ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e4510e884e..ccfc4a1ff7 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1314,4 +1314,64 @@ USING: math.private compiler.cfg.debugger ; } } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) instructions>> first live-spill-slots>> empty? +] unit-test + +[ f ] [ + T{ live-range f 0 10 } + T{ live-range f 20 30 } + intersect-live-range +] unit-test + +[ 10 ] [ + T{ live-range f 0 10 } + T{ live-range f 10 30 } + intersect-live-range +] unit-test + +[ 5 ] [ + T{ live-range f 0 10 } + T{ live-range f 5 30 } + intersect-live-range +] unit-test + +[ 5 ] [ + T{ live-range f 5 30 } + T{ live-range f 0 10 } + intersect-live-range +] unit-test + +[ 5 ] [ + T{ live-range f 5 10 } + T{ live-range f 0 15 } + intersect-live-range +] unit-test + +[ 50 ] [ + { + T{ live-range f 0 10 } + T{ live-range f 20 30 } + T{ live-range f 40 50 } + } + { + T{ live-range f 11 15 } + T{ live-range f 31 35 } + T{ live-range f 50 55 } + } + intersect-live-ranges +] unit-test + +[ 5 ] [ + T{ live-interval + { start 0 } + { end 10 } + { uses { 0 10 } } + { ranges V{ T{ live-range f 0 10 } } } + } + T{ live-interval + { start 5 } + { end 10 } + { uses { 5 10 } } + { ranges V{ T{ live-range f 5 10 } } } + } + intersect-inactive ] unit-test \ No newline at end of file From e4a10254d8620dbc0946bfe408e04c7944c9045f Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 6 Jun 2009 10:07:23 -0700 Subject: [PATCH 19/33] Changed brainfuck from interpreter to compiler, using EBNF's. --- extra/brainfuck/brainfuck.factor | 107 +++++++++++++------------------ 1 file changed, 44 insertions(+), 63 deletions(-) diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor index d13153713a..51c8a100df 100644 --- a/extra/brainfuck/brainfuck.factor +++ b/extra/brainfuck/brainfuck.factor @@ -1,93 +1,74 @@ ! Copyright (C) 2009 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: accessors assocs combinators io io.streams.string kernel math -namespaces sequences strings ; +USING: accessors assocs fry io io.streams.string kernel macros math peg.ebnf sequences strings ; IN: brainfuck > [ set-at ] [ [ swap ] dip set-at ] 3bi ; +: ( -- brainfuck ) + 0 H{ } clone 0 brainfuck boa ; -SYMBOL: tmp +: ops? ( brainfuck -- brainfuck ) + [ 1 + ] change-ops + dup ops>> 10000 > [ "Max operations" throw ] when ; -: ( code -- brainfuck ) - 0 0 0 H{ } clone H{ } clone brainfuck boa - V{ } clone tmp set - dup code>> [ - { - { CHAR: [ [ tmp get push ] } - { CHAR: ] [ tmp get pop (set-loop) ] } - [ 2drop ] - } case - ] assoc-each ; +: (get-mem) ( brainfuck -- brainfuck value ) + dup [ ptr>> ] [ mem>> ] bi at 0 or ; +: (set-mem) ( brainfuck value -- brainfuck ) + over [ ptr>> ] [ mem>> ] bi set-at ; -: (get-memory) ( brainfuck -- brainfuck value ) - dup [ dp>> ] [ memory>> ] bi at 0 or ; +: mem++ ( brainfuck -- brainfuck ) + (get-mem) 1 + 255 bitand (set-mem) ops? ; -: (set-memory) ( intepreter value -- brainfuck ) - over [ dp>> ] [ memory>> ] bi set-at ; +: mem-- ( brainfuck -- brainfuck ) + (get-mem) 1 - 255 bitand (set-mem) ops? ; -: (inc-memory) ( brainfuck -- brainfuck ) - (get-memory) 1 + 255 bitand (set-memory) ; +: mem? ( brainfuck -- brainfuck t/f ) + ops? (get-mem) 0 = not ; -: (dec-memory) ( brainfuck -- brainfuck ) - (get-memory) 1 - 255 bitand (set-memory) ; +: out ( brainfuck -- brainfuck ) + (get-mem) 1string write ops? ; -: (out-memory) ( brainfuck -- brainfuck ) - (get-memory) 1string write ; +: in ( brainfuck -- brainfuck ) + read1 (set-mem) ops? ; +: ptr++ ( brainfuck -- brainfuck ) + [ 1 + ] change-ptr ops? ; -: (inc-data) ( brainfuck -- brainfuck ) - [ 1 + ] change-dp ; +: ptr-- ( brainfuck -- brainfuck ) + [ 1 - ] change-ptr ops? ; -: (dec-data) ( brainfuck -- brainfuck ) - [ 1 - ] change-dp ; +: compose-all ( seq -- quot ) + [ ] [ compose ] reduce ; +EBNF: parse-brainfuck -: (loop-start) ( brainfuck -- brainfuck ) - (get-memory) 0 = [ dup [ cp>> ] [ loop>> ] bi at >>cp ] when ; +inc-ptr = ">" => [[ [ ptr++ ] ]] +dec-ptr = "<" => [[ [ ptr-- ] ]] +inc-mem = "+" => [[ [ mem++ ] ]] +dec-mem = "-" => [[ [ mem-- ] ]] +output = "." => [[ [ out ] ]] +input = "," => [[ [ in ] ]] +space = (" "|"\t"|"\r\n"|"\n") => [[ [ ] ]] +unknown = (.) => [[ "Invalid input" throw ]] -: (loop-end) ( brainfuck -- brainfuck ) - dup [ cp>> ] [ loop>> ] bi at 1 - >>cp ; +ops = inc-ptr | dec-ptr | inc-mem | dec-mem | output | input | space +loop = "[" {loop|ops}* "]" => [[ second compose-all '[ [ mem? ] _ while ] ]] +code = (loop|ops|unknown)* => [[ compose-all ]] -: (get-input) ( brainfuck -- brainfuck ) - read1 (set-memory) ; - - -: can-step ( brainfuck -- brainfuck t/f ) - dup [ steps>> 100000 < ] [ cp>> ] [ code>> length ] tri < and ; - -: step ( brainfuck -- brainfuck ) - dup [ cp>> ] [ code>> ] bi nth - { - { CHAR: > [ (inc-data) ] } - { CHAR: < [ (dec-data) ] } - { CHAR: + [ (inc-memory) ] } - { CHAR: - [ (dec-memory) ] } - { CHAR: . [ (out-memory) ] } - { CHAR: , [ (get-input) ] } - { CHAR: [ [ (loop-start) ] } - { CHAR: ] [ (loop-end) ] } - { CHAR: \s [ ] } - { CHAR: \t [ ] } - { CHAR: \r [ ] } - { CHAR: \n [ ] } - [ "invalid input" throw ] - } case [ 1 + ] change-cp [ 1 + ] change-steps ; +;EBNF PRIVATE> -: run-brainfuck ( code -- ) - [ can-step ] [ step ] while drop ; - -: get-brainfuck ( code -- result ) - [ run-brainfuck ] with-string-writer ; +MACRO: run-brainfuck ( code -- ) + [ ] swap parse-brainfuck [ drop ] 3append ; +: get-brainfuck ( code -- result ) + [ run-brainfuck ] with-string-writer ; inline From e30a9fc4b1226ac0bf74da1732f761e8118a2d8a Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 6 Jun 2009 20:11:59 -0700 Subject: [PATCH 20/33] Add some test cases, remember to flush after running program. --- extra/brainfuck/brainfuck-tests.factor | 3 +++ extra/brainfuck/brainfuck.factor | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/brainfuck/brainfuck-tests.factor b/extra/brainfuck/brainfuck-tests.factor index 452e0a4bdc..4d35089832 100644 --- a/extra/brainfuck/brainfuck-tests.factor +++ b/extra/brainfuck/brainfuck-tests.factor @@ -4,6 +4,9 @@ USING: brainfuck io.streams.string multiline tools.test ; +[ "+" run-brainfuck ] must-infer +[ "+" get-brainfuck ] must-infer + ! Hello World! [ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-] diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor index 51c8a100df..4b4efd1ec3 100644 --- a/extra/brainfuck/brainfuck.factor +++ b/extra/brainfuck/brainfuck.factor @@ -67,7 +67,7 @@ code = (loop|ops|unknown)* => [[ compose-all ]] PRIVATE> MACRO: run-brainfuck ( code -- ) - [ ] swap parse-brainfuck [ drop ] 3append ; + [ ] swap parse-brainfuck [ drop flush ] 3append ; : get-brainfuck ( code -- result ) [ run-brainfuck ] with-string-writer ; inline From 67a36883fec6edfa3f7d025e323ad0f6335db1e2 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sat, 6 Jun 2009 20:44:48 -0700 Subject: [PATCH 21/33] Compile brainfuck a bit more stylishly. --- extra/brainfuck/brainfuck.factor | 60 ++++++++++++++++---------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor index 4b4efd1ec3..6e7f158165 100644 --- a/extra/brainfuck/brainfuck.factor +++ b/extra/brainfuck/brainfuck.factor @@ -1,64 +1,64 @@ ! Copyright (C) 2009 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: accessors assocs fry io io.streams.string kernel macros math peg.ebnf sequences strings ; +USING: accessors assocs fry io io.streams.string kernel macros math +peg.ebnf quotations sequences strings ; IN: brainfuck ( -- brainfuck ) 0 H{ } clone 0 brainfuck boa ; -: ops? ( brainfuck -- brainfuck ) - [ 1 + ] change-ops - dup ops>> 10000 > [ "Max operations" throw ] when ; +: max-ops? ( brainfuck -- brainfuck ) + [ 1 + dup 10000 > [ "Max operations" throw ] when ] change-ops ; -: (get-mem) ( brainfuck -- brainfuck value ) - dup [ ptr>> ] [ mem>> ] bi at 0 or ; +: get-memory ( brainfuck -- brainfuck value ) + dup [ pointer>> ] [ memory>> ] bi at 0 or ; -: (set-mem) ( brainfuck value -- brainfuck ) - over [ ptr>> ] [ mem>> ] bi set-at ; +: set-memory ( brainfuck value -- brainfuck ) + over [ pointer>> ] [ memory>> ] bi set-at ; -: mem++ ( brainfuck -- brainfuck ) - (get-mem) 1 + 255 bitand (set-mem) ops? ; +: (+) ( brainfuck -- brainfuck ) + get-memory 1 + 255 bitand set-memory max-ops? ; -: mem-- ( brainfuck -- brainfuck ) - (get-mem) 1 - 255 bitand (set-mem) ops? ; +: (-) ( brainfuck -- brainfuck ) + get-memory 1 - 255 bitand set-memory max-ops? ; -: mem? ( brainfuck -- brainfuck t/f ) - ops? (get-mem) 0 = not ; +: (?) ( brainfuck -- brainfuck t/f ) + max-ops? get-memory 0 = not ; -: out ( brainfuck -- brainfuck ) - (get-mem) 1string write ops? ; +: (.) ( brainfuck -- brainfuck ) + get-memory 1string write max-ops? ; -: in ( brainfuck -- brainfuck ) - read1 (set-mem) ops? ; +: (,) ( brainfuck -- brainfuck ) + read1 set-memory max-ops? ; -: ptr++ ( brainfuck -- brainfuck ) - [ 1 + ] change-ptr ops? ; +: (>) ( brainfuck -- brainfuck ) + [ 1 + ] change-pointer max-ops? ; -: ptr-- ( brainfuck -- brainfuck ) - [ 1 - ] change-ptr ops? ; +: (<) ( brainfuck -- brainfuck ) + [ 1 - ] change-pointer max-ops? ; : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; EBNF: parse-brainfuck -inc-ptr = ">" => [[ [ ptr++ ] ]] -dec-ptr = "<" => [[ [ ptr-- ] ]] -inc-mem = "+" => [[ [ mem++ ] ]] -dec-mem = "-" => [[ [ mem-- ] ]] -output = "." => [[ [ out ] ]] -input = "," => [[ [ in ] ]] +inc-ptr = ">" => [[ [ (>) ] ]] +dec-ptr = "<" => [[ [ (<) ] ]] +inc-mem = "+" => [[ [ (+) ] ]] +dec-mem = "-" => [[ [ (-) ] ]] +output = "." => [[ [ (.) ] ]] +input = "," => [[ [ (,) ] ]] space = (" "|"\t"|"\r\n"|"\n") => [[ [ ] ]] unknown = (.) => [[ "Invalid input" throw ]] ops = inc-ptr | dec-ptr | inc-mem | dec-mem | output | input | space -loop = "[" {loop|ops}* "]" => [[ second compose-all '[ [ mem? ] _ while ] ]] +loop = "[" {loop|ops}* "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]] code = (loop|ops|unknown)* => [[ compose-all ]] From 360453568779ee07ed6d533a95cd8b89c1e1b202 Mon Sep 17 00:00:00 2001 From: Philipp Winkler Date: Sat, 6 Jun 2009 20:49:44 -0700 Subject: [PATCH 22/33] Fix a error parsing out nested arrays. --- basis/json/reader/reader-tests.factor | 1 + basis/json/reader/reader.factor | 10 ++++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor index fa6c8d7d3a..14a54b89c0 100644 --- a/basis/json/reader/reader-tests.factor +++ b/basis/json/reader/reader-tests.factor @@ -33,6 +33,7 @@ IN: json.reader.tests { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test +{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test { { } } [ "[]" json> ] unit-test { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test { H{ } } [ "{}" json> ] unit-test diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 1544af55cf..9886e316d7 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators io io.streams.string json -kernel math math.parser math.parser.private sequences strings ; +kernel math math.parser math.parser.private prettyprint +sequences strings vectors ; IN: json.reader array over push ; + : (close-hash) ( accum -- accum' ) dup length 3 >= [ v-over-push ] when dup dup [ pop ] dip pop swap zip H{ } assoc-clone-like over push ; : scan ( accum char -- accum ) + ! 2dup . . ! Great for debug... [ { { CHAR: \" [ j-string over push ] } { CHAR: [ [ V{ } clone over push ] } { CHAR: , [ v-over-push ] } - { CHAR: ] [ v-over-push dup pop >array over push ] } + { CHAR: ] [ (close-array) ] } { CHAR: { [ 2 [ V{ } clone over push ] times ] } { CHAR: : [ v-pick-push ] } { CHAR: } [ (close-hash) ] } From 2a5db1abd9315dcda06a720407f8c8d358f2df27 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 7 Jun 2009 07:52:07 -0700 Subject: [PATCH 23/33] brainfuck: Remove concept of operations now that it is compiled. --- extra/brainfuck/brainfuck.factor | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor index 6e7f158165..f22cda4fa3 100644 --- a/extra/brainfuck/brainfuck.factor +++ b/extra/brainfuck/brainfuck.factor @@ -8,13 +8,10 @@ IN: brainfuck ( -- brainfuck ) - 0 H{ } clone 0 brainfuck boa ; - -: max-ops? ( brainfuck -- brainfuck ) - [ 1 + dup 10000 > [ "Max operations" throw ] when ] change-ops ; + 0 H{ } clone brainfuck boa ; : get-memory ( brainfuck -- brainfuck value ) dup [ pointer>> ] [ memory>> ] bi at 0 or ; @@ -23,25 +20,25 @@ TUPLE: brainfuck pointer memory ops ; over [ pointer>> ] [ memory>> ] bi set-at ; : (+) ( brainfuck -- brainfuck ) - get-memory 1 + 255 bitand set-memory max-ops? ; + get-memory 1 + 255 bitand set-memory ; : (-) ( brainfuck -- brainfuck ) - get-memory 1 - 255 bitand set-memory max-ops? ; + get-memory 1 - 255 bitand set-memory ; : (?) ( brainfuck -- brainfuck t/f ) - max-ops? get-memory 0 = not ; + get-memory 0 = not ; : (.) ( brainfuck -- brainfuck ) - get-memory 1string write max-ops? ; + get-memory 1string write ; : (,) ( brainfuck -- brainfuck ) - read1 set-memory max-ops? ; + read1 set-memory ; : (>) ( brainfuck -- brainfuck ) - [ 1 + ] change-pointer max-ops? ; + [ 1 + ] change-pointer ; : (<) ( brainfuck -- brainfuck ) - [ 1 - ] change-pointer max-ops? ; + [ 1 - ] change-pointer ; : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; From 6b86f059e7057ad09752516a648c7eaabff2017f Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 7 Jun 2009 15:21:39 -0700 Subject: [PATCH 24/33] Merge groups of similar operations. --- extra/brainfuck/brainfuck.factor | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor index f22cda4fa3..8a033610ac 100644 --- a/extra/brainfuck/brainfuck.factor +++ b/extra/brainfuck/brainfuck.factor @@ -19,11 +19,11 @@ TUPLE: brainfuck pointer memory ; : set-memory ( brainfuck value -- brainfuck ) over [ pointer>> ] [ memory>> ] bi set-at ; -: (+) ( brainfuck -- brainfuck ) - get-memory 1 + 255 bitand set-memory ; +: (+) ( brainfuck n -- brainfuck ) + [ get-memory ] dip + 255 bitand set-memory ; -: (-) ( brainfuck -- brainfuck ) - get-memory 1 - 255 bitand set-memory ; +: (-) ( brainfuck n -- brainfuck ) + [ get-memory ] dip - 255 bitand set-memory ; : (?) ( brainfuck -- brainfuck t/f ) get-memory 0 = not ; @@ -34,24 +34,24 @@ TUPLE: brainfuck pointer memory ; : (,) ( brainfuck -- brainfuck ) read1 set-memory ; -: (>) ( brainfuck -- brainfuck ) - [ 1 + ] change-pointer ; +: (>) ( brainfuck n -- brainfuck ) + [ dup pointer>> ] dip + >>pointer ; -: (<) ( brainfuck -- brainfuck ) - [ 1 - ] change-pointer ; +: (<) ( brainfuck n -- brainfuck ) + [ dup pointer>> ] dip - >>pointer ; : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; EBNF: parse-brainfuck -inc-ptr = ">" => [[ [ (>) ] ]] -dec-ptr = "<" => [[ [ (<) ] ]] -inc-mem = "+" => [[ [ (+) ] ]] -dec-mem = "-" => [[ [ (-) ] ]] +inc-ptr = (">")+ => [[ length 1quotation [ (>) ] append ]] +dec-ptr = ("<")+ => [[ length 1quotation [ (<) ] append ]] +inc-mem = ("+")+ => [[ length 1quotation [ (+) ] append ]] +dec-mem = ("-")+ => [[ length 1quotation [ (-) ] append ]] output = "." => [[ [ (.) ] ]] input = "," => [[ [ (,) ] ]] -space = (" "|"\t"|"\r\n"|"\n") => [[ [ ] ]] +space = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]] unknown = (.) => [[ "Invalid input" throw ]] ops = inc-ptr | dec-ptr | inc-mem | dec-mem | output | input | space From 4b21217956816d475374879e9550598bc87134be Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 7 Jun 2009 16:18:13 -0700 Subject: [PATCH 25/33] brainfuck: Adding debug (#) operator. --- extra/brainfuck/brainfuck.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor index 8a033610ac..ca72e0b782 100644 --- a/extra/brainfuck/brainfuck.factor +++ b/extra/brainfuck/brainfuck.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license USING: accessors assocs fry io io.streams.string kernel macros math -peg.ebnf quotations sequences strings ; +peg.ebnf prettyprint quotations sequences strings ; IN: brainfuck @@ -40,6 +40,11 @@ TUPLE: brainfuck pointer memory ; : (<) ( brainfuck n -- brainfuck ) [ dup pointer>> ] dip - >>pointer ; +: (#) ( brainfuck -- brainfuck ) + dup + [ "ptr=" write pointer>> pprint ] + [ ",mem=" write memory>> pprint nl ] bi ; + : compose-all ( seq -- quot ) [ ] [ compose ] reduce ; @@ -51,10 +56,11 @@ inc-mem = ("+")+ => [[ length 1quotation [ (+) ] append ]] dec-mem = ("-")+ => [[ length 1quotation [ (-) ] append ]] output = "." => [[ [ (.) ] ]] input = "," => [[ [ (,) ] ]] +debug = "#" => [[ [ (#) ] ]] space = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]] unknown = (.) => [[ "Invalid input" throw ]] -ops = inc-ptr | dec-ptr | inc-mem | dec-mem | output | input | space +ops = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space loop = "[" {loop|ops}* "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]] code = (loop|ops|unknown)* => [[ compose-all ]] From 88e5397b51028ea915bb69422fd20221a160174b Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Sun, 7 Jun 2009 17:39:21 -0700 Subject: [PATCH 26/33] brainfuck: Require loops to be non-empty, add test case. --- extra/brainfuck/brainfuck-tests.factor | 13 ++++++++++++- extra/brainfuck/brainfuck.factor | 2 +- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/extra/brainfuck/brainfuck-tests.factor b/extra/brainfuck/brainfuck-tests.factor index 4d35089832..2fa6b84a19 100644 --- a/extra/brainfuck/brainfuck-tests.factor +++ b/extra/brainfuck/brainfuck-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: brainfuck io.streams.string multiline tools.test ; +USING: brainfuck kernel io.streams.string math math.parser math.ranges +multiline quotations sequences tools.test ; [ "+" run-brainfuck ] must-infer @@ -48,4 +49,14 @@ USING: brainfuck io.streams.string multiline tools.test ; [ "ABC" ] [ "ABC\0" [ ",[.,]" get-brainfuck ] with-string-reader ] unit-test +! Squares of numbers from 0 to 100 + +100 [0,b] [ dup * number>string ] map "\n" join "\n" append 1quotation +[ <" ++++[>+++++<-]>[<+++++>-]+<+[ + >[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+ + >>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<] + <<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++> + [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-] "> + get-brainfuck ] unit-test + diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor index ca72e0b782..f29e7dc8ae 100644 --- a/extra/brainfuck/brainfuck.factor +++ b/extra/brainfuck/brainfuck.factor @@ -61,7 +61,7 @@ space = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]] unknown = (.) => [[ "Invalid input" throw ]] ops = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space -loop = "[" {loop|ops}* "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]] +loop = "[" {loop|ops}+ "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]] code = (loop|ops|unknown)* => [[ compose-all ]] From 9ad9600764cfb6c96b1554c9217c317dbc4d99fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Jun 2009 21:46:28 -0500 Subject: [PATCH 27/33] Remove %dispatch-label since its tehe same on all platforms; fix %gc on PowerPC --- basis/compiler/codegen/codegen.factor | 5 ++++- basis/cpu/architecture/architecture.factor | 1 - basis/cpu/ppc/ppc.factor | 21 ++++++++++++--------- basis/cpu/x86/x86.factor | 3 --- 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7bdaace1db..7602295284 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -8,6 +8,7 @@ continuations.private fry cpu.architecture source-files.errors compiler.errors compiler.alien +compiler.constants compiler.cfg compiler.cfg.instructions compiler.cfg.stack-frame @@ -94,7 +95,9 @@ M: _dispatch generate-insn [ src>> register ] [ temp>> register ] bi %dispatch ; M: _dispatch-label generate-insn - label>> lookup-label %dispatch-label ; + label>> lookup-label + cell 0 % + rc-absolute-cell label-fixup ; : >slot< ( insn -- dst obj slot tag ) { diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 805ba4fd71..556424f50c 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -55,7 +55,6 @@ HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) HOOK: %dispatch cpu ( src temp -- ) -HOOK: %dispatch-label cpu ( label -- ) HOOK: %slot cpu ( dst obj slot tag temp -- ) HOOK: %slot-imm cpu ( dst obj slot tag -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 934b456075..003eccfa18 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -3,10 +3,11 @@ USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words alien alien.accessors alien.c-types literals cpu.architecture -cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers +cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers compiler.cfg.instructions compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.intrinsics -compiler.cfg.stack-frame compiler.units ; +compiler.cfg.stack-frame compiler.cfg.build-stack-frame +compiler.units ; FROM: cpu.ppc.assembler => B ; IN: cpu.ppc @@ -461,16 +462,18 @@ M:: ppc %write-barrier ( src card# table -- ) src card# deck-bits SRWI table scratch-reg card# STBX ; -M: ppc %gc +M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- ) "end" define-label - 12 load-zone-ptr - 11 12 cell LWZ ! nursery.here -> r11 - 12 12 3 cells LWZ ! nursery.end -> r12 - 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here - 11 0 12 CMP ! is here >= end? + temp2 load-zone-ptr + temp1 temp2 cell LWZ + temp2 temp2 3 cells LWZ + temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here + temp1 0 temp2 CMP ! is here >= end? "end" get BLE %prepare-alien-invoke - "minor_gc" f %alien-invoke + 0 3 LI + 0 4 LI + "inline_gc" f %alien-invoke "end" resolve-label ; M: ppc %prologue ( n -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index ef353281e5..b3cb5b56ec 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -91,9 +91,6 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; -M: x86 %dispatch-label ( label -- ) - 0 cell, rc-absolute-cell label-fixup ; - :: (%slot) ( obj slot tag temp -- op ) temp slot obj [+] LEA temp tag neg [+] ; inline From aba4fa7371a2b991a7aa977f61855468cff1dea9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Jun 2009 21:59:13 -0500 Subject: [PATCH 28/33] Recent vocabs.parser change had a regression: vocabs with no roots (scratchpad) were excluded from default use list. Also move with-interactive-vocabs to listener vocab --- basis/help/lint/lint.factor | 2 +- basis/listener/listener-docs.factor | 4 ++ basis/listener/listener.factor | 74 +++++++++++++++++++++- basis/prettyprint/prettyprint-tests.factor | 3 +- core/parser/parser.factor | 62 ------------------ core/vocabs/parser/parser-docs.factor | 5 -- core/vocabs/parser/parser.factor | 10 +-- 7 files changed, 82 insertions(+), 78 deletions(-) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 08cf4b2cd4..4ead01159a 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -3,7 +3,7 @@ USING: assocs continuations fry help help.lint.checks help.topics io kernel namespaces parser sequences source-files.errors vocabs.hierarchy vocabs words classes -locals tools.errors ; +locals tools.errors listener ; FROM: help.lint.checks => all-vocabs ; IN: help.lint diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index 0f13b6dd86..7470ef9daa 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -13,6 +13,10 @@ ARTICLE: "listener-watch" "Watching variables in the listener" "Hiding all visible variables:" { $subsection hide-all-vars } ; +HELP: only-use-vocabs +{ $values { "vocabs" "a sequence of vocabulary specifiers" } } +{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ; + HELP: show-var { $values { "var" "a variable name" } } { $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 4563f61ab7..34d9eac121 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger definitions compiler.units accessors colors prettyprint fry -sets vocabs.parser source-files.errors locals ; +sets vocabs.parser source-files.errors locals vocabs vocabs.loader ; IN: listener GENERIC: stream-read-quot ( stream -- quot/f ) @@ -124,6 +124,78 @@ t error-summary? set-global PRIVATE> +SYMBOL: interactive-vocabs + +{ + "accessors" + "arrays" + "assocs" + "combinators" + "compiler" + "compiler.errors" + "compiler.units" + "continuations" + "debugger" + "definitions" + "editors" + "help" + "help.apropos" + "help.lint" + "help.vocabs" + "inspector" + "io" + "io.files" + "io.pathnames" + "kernel" + "listener" + "math" + "math.order" + "memory" + "namespaces" + "parser" + "prettyprint" + "see" + "sequences" + "slicing" + "sorting" + "stack-checker" + "strings" + "syntax" + "tools.annotations" + "tools.crossref" + "tools.disassembler" + "tools.errors" + "tools.memory" + "tools.profiler" + "tools.test" + "tools.threads" + "tools.time" + "vocabs" + "vocabs.loader" + "vocabs.refresh" + "vocabs.hierarchy" + "words" + "scratchpad" +} interactive-vocabs set-global + +: only-use-vocabs ( vocabs -- ) + clear-manifest + [ vocab ] filter + [ + vocab + [ find-vocab-root not ] + [ source-loaded?>> +done+ eq? ] bi or + ] filter + [ use-vocab ] each ; + +: with-interactive-vocabs ( quot -- ) + [ + manifest set + "scratchpad" set-current-vocab + interactive-vocabs get only-use-vocabs + call + ] with-scope ; inline + : listener ( -- ) [ [ { } (listener) ] with-interactive-vocabs ] with-return ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index cd10278760..a2696b1263 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private continuations generic compiler.units tools.continuations -tools.continuations.private eval accessors make vocabs.parser see ; +tools.continuations.private eval accessors make vocabs.parser see +listener ; IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 8d52dcaa2c..94eb0a865c 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -112,68 +112,6 @@ SYMBOL: bootstrap-syntax call ] with-scope ; inline -SYMBOL: interactive-vocabs - -{ - "accessors" - "arrays" - "assocs" - "combinators" - "compiler" - "compiler.errors" - "compiler.units" - "continuations" - "debugger" - "definitions" - "editors" - "help" - "help.apropos" - "help.lint" - "help.vocabs" - "inspector" - "io" - "io.files" - "io.pathnames" - "kernel" - "listener" - "math" - "math.order" - "memory" - "namespaces" - "parser" - "prettyprint" - "see" - "sequences" - "slicing" - "sorting" - "stack-checker" - "strings" - "syntax" - "tools.annotations" - "tools.crossref" - "tools.disassembler" - "tools.errors" - "tools.memory" - "tools.profiler" - "tools.test" - "tools.threads" - "tools.time" - "vocabs" - "vocabs.loader" - "vocabs.refresh" - "vocabs.hierarchy" - "words" - "scratchpad" -} interactive-vocabs set-global - -: with-interactive-vocabs ( quot -- ) - [ - manifest set - "scratchpad" set-current-vocab - interactive-vocabs get only-use-vocabs - call - ] with-scope ; inline - SYMBOL: print-use-hook print-use-hook [ [ ] ] initialize diff --git a/core/vocabs/parser/parser-docs.factor b/core/vocabs/parser/parser-docs.factor index e54993b6eb..96619a7114 100644 --- a/core/vocabs/parser/parser-docs.factor +++ b/core/vocabs/parser/parser-docs.factor @@ -65,7 +65,6 @@ $nl "Words for working with the current manifest:" { $subsection use-vocab } { $subsection unuse-vocab } -{ $subsection only-use-vocabs } { $subsection add-qualified } { $subsection add-words-from } { $subsection add-words-excluding } @@ -117,10 +116,6 @@ HELP: unuse-vocab { $description "Removes a vocabulary from the current manifest." } { $notes "This word is used to implement " { $link POSTPONE: UNUSE: } "." } ; -HELP: only-use-vocabs -{ $values { "vocabs" "a sequence of vocabulary specifiers" } } -{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ; - HELP: add-qualified { $values { "vocab" "a vocabulary specifier" } { "prefix" string } } { $description "Adds the vocabulary's words, prefixed with the given string, to the current manifest." } diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 5f393ed65d..0bfb607a52 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -52,8 +52,6 @@ M: extra-words equal? C: extra-words -> clear-assoc ] @@ -61,6 +59,8 @@ C: extra-words [ qualified-vocabs>> delete-all ] tri ; +> push ; @@ -126,12 +126,6 @@ TUPLE: no-current-vocab ; 2bi ] [ drop ] if ; -: only-use-vocabs ( vocabs -- ) - clear-manifest - [ vocab ] filter - [ vocab source-loaded?>> +done+ eq? ] filter - [ use-vocab ] each ; - TUPLE: qualified vocab prefix words ; : ( vocab prefix -- qualified ) From aaeeaa1e6f5d4960006106b7af6d6ce2aad4829f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Jun 2009 04:18:57 -0500 Subject: [PATCH 29/33] Fix load errors --- basis/tools/deploy/shaker/shaker.factor | 2 -- extra/fuel/help/help.factor | 3 ++- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 46572de47b..270b55fda6 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -277,8 +277,6 @@ IN: tools.deploy.shaker compiled-generic-crossref compiler-impl compiler.errors:compiler-errors - ! definition-observers - interactive-vocabs lexer-factory print-use-hook root-cache diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 6c43e646df..f20e67f9bc 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -4,7 +4,8 @@ USING: accessors arrays assocs combinators help help.crossref help.markup help.topics io io.streams.string kernel make namespaces parser prettyprint sequences summary help.vocabs -vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see ; +vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see +listener ; IN: fuel.help From 45a21054495eb9ee491995b15d26681c203cea9b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Jun 2009 21:15:52 -0500 Subject: [PATCH 30/33] cpu.x86.assembler: IMUL2 instruction was busted for immediate operands When given a register and an immediate, it would generate imul imm,dst,dst however the 64-bit prefix was generated wrong and if dst was an extended register only the first operand would be an extended register. To fix this, change IMUL2 to not work on immediates anymore, and added a new IMUL3 that takes a destination register, source register, and immediate. Also, change compiler.cfg.two-operand to not two-operandize %mul-imm, since this isn't needed anymore. This fixes the sporadic benchmark.tuple-arrays crash on 64-bit machines. --- .../cfg/two-operand/two-operand.factor | 19 ++++++------- .../cpu/x86/assembler/assembler-tests.factor | 8 ++++++ basis/cpu/x86/assembler/assembler.factor | 28 +++++++++++-------- basis/cpu/x86/x86.factor | 2 +- 4 files changed, 34 insertions(+), 23 deletions(-) diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index a3a83b9d14..d30a02b0d3 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel sequences make compiler.cfg.instructions -compiler.cfg.rpo cpu.architecture ; +USING: accessors kernel sequences make compiler.cfg.instructions +compiler.cfg.local cpu.architecture ; IN: compiler.cfg.two-operand ! On x86, instructions take the form x = x op y ! Our SSA IR is x = y op z -! We don't bother with ##add, ##add-imm or ##sub-imm since x86 -! has a LEA instruction which is effectively a three-operand -! addition +! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm +! since x86 has LEA and IMUL instructions which are effectively +! three-operand addition and multiplication, respectively. : make-copy ( dst src -- insn ) \ ##copy new-insn ; inline @@ -34,7 +34,6 @@ M: ##not convert-two-operand* M: ##sub convert-two-operand* convert-two-operand/integer ; M: ##mul convert-two-operand* convert-two-operand/integer ; -M: ##mul-imm convert-two-operand* convert-two-operand/integer ; M: ##and convert-two-operand* convert-two-operand/integer ; M: ##and-imm convert-two-operand* convert-two-operand/integer ; M: ##or convert-two-operand* convert-two-operand/integer ; @@ -54,9 +53,7 @@ M: insn convert-two-operand* , ; : convert-two-operand ( cfg -- cfg' ) two-operand? [ - dup [ - [ - [ [ convert-two-operand* ] each ] V{ } make - ] change-instructions drop - ] each-basic-block + [ drop ] + [ [ [ convert-two-operand* ] each ] V{ } make ] + local-optimization ] when ; diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 203edf956e..a8c54fa65e 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -64,3 +64,11 @@ IN: cpu.x86.assembler.tests [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test [ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test + +[ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test +[ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test +[ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test +[ { HEX: 48 HEX: 6b HEX: c1 HEX: 03 } ] [ [ RAX RCX 3 IMUL3 ] { } make ] unit-test +[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test + +[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 2b40aa2053..95b85ac2dd 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io.binary kernel combinators -kernel.private math namespaces make sequences words system layouts -math.order accessors cpu.x86.assembler.syntax ; +USING: arrays io.binary kernel combinators kernel.private math +namespaces make sequences words system layouts math.order accessors +cpu.x86.assembler.syntax ; IN: cpu.x86.assembler ! A postfix assembler for x86-32 and x86-64. @@ -402,20 +402,26 @@ M: operand TEST OCT: 204 2-operand ; : SHR ( dst n -- ) BIN: 101 (SHIFT) ; : SAR ( dst n -- ) BIN: 111 (SHIFT) ; -GENERIC: IMUL2 ( dst src -- ) -M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ; -M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ; +: IMUL2 ( dst src -- ) + OCT: 257 extended-opcode (2-operand) ; + +: IMUL3 ( dst src imm -- ) + dup fits-in-byte? [ + [ swap HEX: 6a 2-operand ] dip 1, + ] [ + [ swap HEX: 68 2-operand ] dip 4, + ] if ; : MOVSX ( dst src -- ) - dup register-32? OCT: 143 OCT: 276 extended-opcode ? - over register-16? [ BIN: 1 opcode-or ] when - swapd + swap + over register-32? OCT: 143 OCT: 276 extended-opcode ? + pick register-16? [ BIN: 1 opcode-or ] when (2-operand) ; : MOVZX ( dst src -- ) + swap OCT: 266 extended-opcode - over register-16? [ BIN: 1 opcode-or ] when - swapd + pick register-16? [ BIN: 1 opcode-or ] when (2-operand) ; ! Conditional move diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index b3cb5b56ec..15c54aa7d8 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -108,7 +108,7 @@ M: x86 %add-imm [+] LEA ; M: x86 %sub nip SUB ; M: x86 %sub-imm neg [+] LEA ; M: x86 %mul nip swap IMUL2 ; -M: x86 %mul-imm nip IMUL2 ; +M: x86 %mul-imm IMUL3 ; M: x86 %and nip AND ; M: x86 %and-imm nip AND ; M: x86 %or nip OR ; From 2dcdfa2d8e87964f186eb706e19b9ec7342ff70f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Jun 2009 03:36:16 -0500 Subject: [PATCH 31/33] compiler.cfg: add a declaration to fix tools.deploy.test.11 --- basis/compiler/cfg/cfg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index c3ae15f069..dabc7338d2 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays vectors accessors -namespaces make fry sequences ; +namespaces math make fry sequences ; IN: compiler.cfg TUPLE: basic-block < identity-tuple -id +{ id integer } number { instructions vector } { successors vector } From bcfc0c5759283de15741caf1f5d457b7258b0feb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Jun 2009 18:28:53 -0500 Subject: [PATCH 32/33] circular: Fix rotate-circular --- basis/circular/circular-tests.factor | 1 + basis/circular/circular.factor | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index 3a94e14640..b4a9d547f2 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -13,6 +13,7 @@ circular strings ; [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ ] like ] unit-test +[ [ 3 1 2 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index ae79e70d73..d47b954ecf 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -28,10 +28,10 @@ M: circular virtual-seq seq>> ; circular-wrap (>>start) ; : rotate-circular ( circular -- ) - [ start>> 1 + ] keep circular-wrap (>>start) ; + [ 1 ] dip change-circular-start ; : push-circular ( elt circular -- ) - [ set-first ] [ 1 swap change-circular-start ] bi ; + [ set-first ] [ rotate-circular ] bi ; : ( n -- circular ) 0 ; From 50f4db1ce247d1d30410e505561e85b72780c6b3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 10 Jun 2009 13:06:06 -0500 Subject: [PATCH 33/33] half-precision float vocab --- extra/half-floats/authors.txt | 1 + extra/half-floats/half-floats-tests.factor | 46 ++++++++++++++++++++++ extra/half-floats/half-floats.factor | 42 ++++++++++++++++++++ extra/half-floats/summary.txt | 1 + 4 files changed, 90 insertions(+) create mode 100644 extra/half-floats/authors.txt create mode 100644 extra/half-floats/half-floats-tests.factor create mode 100644 extra/half-floats/half-floats.factor create mode 100644 extra/half-floats/summary.txt diff --git a/extra/half-floats/authors.txt b/extra/half-floats/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/half-floats/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/half-floats/half-floats-tests.factor b/extra/half-floats/half-floats-tests.factor new file mode 100644 index 0000000000..15ad53d611 --- /dev/null +++ b/extra/half-floats/half-floats-tests.factor @@ -0,0 +1,46 @@ +USING: alien.c-types alien.syntax half-floats kernel tools.test ; +IN: half-floats.tests + +[ HEX: 0000 ] [ 0.0 half>bits ] unit-test +[ HEX: 8000 ] [ -0.0 half>bits ] unit-test +[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test +[ HEX: be00 ] [ -1.5 half>bits ] unit-test +[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test +[ HEX: fc00 ] [ -1/0. half>bits ] unit-test +[ HEX: fe00 ] [ 0/0. half>bits ] unit-test + +! too-big floats overflow to infinity +[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test +[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test +[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test +[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test + +! too-small floats flush to zero +[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test +[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test + +[ 0.0 ] [ HEX: 0000 bits>half ] unit-test +[ -0.0 ] [ HEX: 8000 bits>half ] unit-test +[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test +[ -1.5 ] [ HEX: be00 bits>half ] unit-test +[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test +[ -1/0. ] [ HEX: fc00 bits>half ] unit-test +[ 0/0. ] [ HEX: 7e00 bits>half ] unit-test + +C-STRUCT: halves + { "half" "tom" } + { "half" "dick" } + { "half" "harry" } + { "half" "harry-jr" } ; + +[ 8 ] [ "halves" heap-size ] unit-test + +[ 3.0 ] [ + "halves" + 3.0 over set-halves-dick + halves-dick +] unit-test + +[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ] +[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test + diff --git a/extra/half-floats/half-floats.factor b/extra/half-floats/half-floats.factor new file mode 100644 index 0000000000..53f6c6cfb1 --- /dev/null +++ b/extra/half-floats/half-floats.factor @@ -0,0 +1,42 @@ +! (c)2009 Joe Groff bsd license +USING: accessors alien.c-types alien.syntax kernel math math.order +specialized-arrays.direct.functor specialized-arrays.functor ; +IN: half-floats + +: half>bits ( float -- bits ) + float>bits + [ -31 shift 15 shift ] [ + HEX: 7fffffff bitand + dup zero? [ + dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [ + -13 shift + 112 10 shift - + 0 HEX: 7c00 clamp + ] if + ] unless + ] bi bitor ; + +: bits>half ( bits -- float ) + [ -15 shift 31 shift ] [ + HEX: 7fff bitand + dup zero? [ + dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [ + 13 shift + 112 23 shift + + ] if + ] unless + ] bi bitor bits>float ; + +C-STRUCT: half { "ushort" "(bits)" } ; + +<< + +"half" c-type + [ half>bits ] >>unboxer-quot + [ *ushort bits>half ] >>boxer-quot + drop + +"half" define-array +"half" define-direct-array + +>> diff --git a/extra/half-floats/summary.txt b/extra/half-floats/summary.txt new file mode 100644 index 0000000000..b22448f69b --- /dev/null +++ b/extra/half-floats/summary.txt @@ -0,0 +1 @@ +Half-precision float support for FFI