From: Slava Pestov Date: Mon, 1 Jun 2009 08:12:32 +0000 (-0500) Subject: Merge branch 'master' into global_optimization X-Git-Tag: 0.97~6168^2~3 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=9e987e86427b4de5fd91994a1e18a93560e4802f;hp=d558545b65870e64c16fa1d5688d6e90dc692886 Merge branch 'master' into global_optimization --- 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 2385a4c65a..d0bb792f72 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -161,7 +161,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 c12e5bdd86..9daf27451c 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 bfbc824846..030d8503e9 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -246,7 +246,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 91c337e43a..cbe006b4d7 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -43,7 +43,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/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index ca1c5762f6..52627f2ed9 100644 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -13,9 +13,8 @@ SYMBOL: local-node [ first2 get-process send ] [ stop-this-server ] if* ; : ( addrspec -- threaded-server ) - + binary swap >>insecure - binary >>encoding "concurrency.distributed" >>name [ handle-node-client ] >>handler ; 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/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 4492a3d762..cf84b083fe 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -305,10 +305,7 @@ os windows? [ 4 "double" c-type (>>align) ] unless -FUNCTION: bool check_sse2 ( ) ; - -: sse2? ( -- ? ) - check_sse2 ; +USING: cpu.x86.features cpu.x86.features.private ; "-no-sse2" (command-line) member? [ [ { check_sse2 } compile ] with-optimizer diff --git a/basis/cpu/x86/features/authors.txt b/basis/cpu/x86/features/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/cpu/x86/features/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/cpu/x86/features/features-tests.factor b/basis/cpu/x86/features/features-tests.factor new file mode 100644 index 0000000000..69847cacfa --- /dev/null +++ b/basis/cpu/x86/features/features-tests.factor @@ -0,0 +1,7 @@ +IN: cpu.x86.features.tests +USING: cpu.x86.features tools.test kernel sequences math system ; + +cpu x86? [ + [ t ] [ sse2? { t f } member? ] unit-test + [ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test +] when \ No newline at end of file diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor new file mode 100644 index 0000000000..bc4818d6af --- /dev/null +++ b/basis/cpu/x86/features/features.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: system kernel math alien.syntax ; +IN: cpu.x86.features + + + +HOOK: sse2? cpu ( -- ? ) + +M: x86.32 sse2? check_sse2 ; + +M: x86.64 sse2? t ; + +HOOK: instruction-count cpu ( -- n ) + +M: x86 instruction-count read_timestamp_counter ; + +: count-instructions ( quot -- n ) + instruction-count [ call ] dip instruction-count swap - ; 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/ftp/server/server.factor b/basis/ftp/server/server.factor index 8438aae94e..c9518bdef1 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -341,12 +341,11 @@ M: ftp-server handle-client* ( server -- ) ] with-destructors ; : ( directory port -- server ) - ftp-server new-threaded-server + latin1 ftp-server new-threaded-server swap >>insecure swap canonicalize-path >>serving-directory "ftp.server" >>name - 5 minutes >>timeout - latin1 >>encoding ; + 5 minutes >>timeout ; : ftpd ( directory port -- ) start-server ; 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/http/server/server.factor b/basis/http/server/server.factor index c838471e3f..8682c97c73 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -269,7 +269,7 @@ M: http-server handle-client* ] with-destructors ; : ( -- server ) - http-server new-threaded-server + ascii http-server new-threaded-server "http.server" >>name "http" protocol-port >>insecure "https" protocol-port >>secure ; 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/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 67c7cb13dd..0e8a8576fb 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -79,12 +79,12 @@ HELP: threaded-server { $class-description "The class of threaded servers. New instances are created with " { $link } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ; HELP: new-threaded-server -{ $values { "class" class } { "threaded-server" threaded-server } } +{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } } { $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ; HELP: -{ $values { "threaded-server" threaded-server } } -{ $description "Creates a new threaded server. Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ; +{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } } +{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ; HELP: remote-address { $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ; diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index ab99531eb4..14100d3f04 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -3,10 +3,10 @@ USING: tools.test io.servers.connection io.sockets namespaces io.servers.connection.private kernel accessors sequences concurrency.promises io.encodings.ascii io threads calendar ; -[ t ] [ listen-on empty? ] unit-test +[ t ] [ ascii listen-on empty? ] unit-test [ f ] [ - + ascii 25 internet-server >>insecure listen-on empty? @@ -19,16 +19,16 @@ concurrency.promises io.encodings.ascii io threads calendar ; and ] unit-test -[ ] [ init-server drop ] unit-test +[ ] [ ascii init-server drop ] unit-test [ 10 ] [ - + ascii 10 >>max-connections init-server semaphore>> count>> ] unit-test [ ] [ - + ascii 5 >>max-connections 0 >>insecure [ "Hello world." write stop-this-server ] >>handler diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 8eafe1b5bf..df6c21e7cc 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -27,18 +27,18 @@ ready ; : internet-server ( port -- addrspec ) f swap ; -: new-threaded-server ( class -- threaded-server ) +: new-threaded-server ( encoding class -- threaded-server ) new + swap >>encoding "server" >>name DEBUG >>log-level - ascii >>encoding 1 minutes >>timeout V{ } clone >>sockets >>secure-config [ "No handler quotation" throw ] >>handler >>ready ; inline -: ( -- threaded-server ) +: ( encoding -- threaded-server ) threaded-server new-threaded-server ; GENERIC: handle-client* ( threaded-server -- ) 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/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 66d813bab8..0bdc6ce00b 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -162,3 +162,4 @@ IN: math.functions.tests [ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test [ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test +[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test \ No newline at end of file diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a1bf9480d5..5d88eba9fa 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -34,8 +34,9 @@ M: integer ^n M: ratio ^n [ >fraction ] dip [ ^n ] curry bi@ / ; -M: float ^n - (^n) ; +M: float ^n (^n) ; + +M: complex ^n (^n) ; : integer^ ( x y -- z ) dup 0 > [ ^n ] [ neg ^n recip ] if ; inline 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/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index 005f5f7af8..8d73d85fb5 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -39,11 +39,6 @@ HELP: breakpoint-if { $values { "quot" { $quotation "( -- ? )" } } { "word" word } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; -HELP: annotate-methods -{ $values - { "word" word } { "quot" quotation } } -{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ; - HELP: reset { $values { "word" word } } diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index bbd2ac2ca8..c312b54edb 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -39,6 +39,9 @@ M: object another-generic ; [ "" ] [ [ 3 another-generic drop ] with-string-writer ] unit-test +! reset should do the right thing for generic words +[ ] [ \ another-generic watch ] unit-test + GENERIC: blah-generic ( a -- b ) M: string blah-generic ; diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 3cb74fb00b..3aac371a6a 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -9,8 +9,7 @@ IN: tools.annotations GENERIC: reset ( word -- ) M: generic reset - [ call-next-method ] - [ subwords [ reset ] each ] bi ; + subwords [ reset ] each ; M: word reset dup "unannotated-def" word-prop [ @@ -22,6 +21,8 @@ M: word reset ERROR: cannot-annotate-twice word ; +M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ; + > "unannotated-def" set-word-prop ; +PRIVATE> -: (annotate) ( word quot -- ) - [ dup def>> ] dip call( old -- new ) define ; +GENERIC# annotate 1 ( word quot -- ) -PRIVATE> +M: generic annotate + [ "methods" word-prop values ] dip '[ _ annotate ] each ; -: annotate ( word quot -- ) +M: word annotate [ check-annotate-twice ] dip - [ over save-unannotated-def (annotate) ] with-compilation-unit ; + [ + [ dup def>> 2dup "unannotated-def" set-word-prop ] dip + call( old -- new ) define + ] with-compilation-unit ; : watch-vars ( word vars -- ) dupd '[ [ _ _ ] dip (watch-vars) ] annotate ; -GENERIC# annotate-methods 1 ( word quot -- ) - -M: generic annotate-methods - [ "methods" word-prop values ] dip [ annotate ] curry each ; - -M: word annotate-methods - annotate ; - : breakpoint ( word -- ) - [ add-breakpoint ] annotate-methods ; + [ add-breakpoint ] annotate ; : breakpoint-if ( word quot -- ) - '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ; + '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ; SYMBOL: word-timing 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 c21cac2632..75607b0258 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 7fc3eae00c..62ab9f86ae 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -85,9 +85,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/classes/parser/parser.factor b/core/classes/parser/parser.factor index bd2e6ea4a0..0697537d12 100644 --- a/core/classes/parser/parser.factor +++ b/core/classes/parser/parser.factor @@ -6,7 +6,7 @@ IN: classes.parser : save-class-location ( class -- ) location remember-class ; -: create-class-in ( word -- word ) +: create-class-in ( string -- word ) current-vocab create dup save-class-location dup predicate-word dup set-word save-location ; 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-docs.factor b/core/destructors/destructors-docs.factor index 0b6ca15f31..536ee19c8b 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -26,7 +26,7 @@ HELP: with-disposal HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error only. Destructors are run in reverse order from the order in which they were registered." } { $notes "Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:" { $code 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/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor index a6ccc95bf5..1fb5ad1116 100644 --- a/core/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -59,7 +59,7 @@ M: utf16be decode-char ] [ append-nums ] if ; : begin-utf16le ( stream byte -- stream char ) - over stream-read1 [ double-le ] [ drop replacement-char ] if* ; + over stream-read1 dup [ double-le ] [ 2drop replacement-char ] if ; M: utf16le decode-char drop dup stream-read1 dup [ begin-utf16le ] when nip ; @@ -68,36 +68,34 @@ M: utf16le decode-char : encode-first ( char -- byte1 byte2 ) -10 shift - dup -8 shift BIN: 11011000 bitor - swap HEX: FF bitand ; + [ -8 shift BIN: 11011000 bitor ] [ HEX: FF bitand ] bi ; : encode-second ( char -- byte3 byte4 ) BIN: 1111111111 bitand - dup -8 shift BIN: 11011100 bitor - swap BIN: 11111111 bitand ; + [ -8 shift BIN: 11011100 bitor ] [ BIN: 11111111 bitand ] bi ; -: stream-write2 ( stream char1 char2 -- ) - rot [ stream-write1 ] curry bi@ ; +: stream-write2 ( char1 char2 stream -- ) + [ stream-write1 ] curry bi@ ; -: char>utf16be ( stream char -- ) - dup HEX: FFFF > [ - HEX: 10000 - - 2dup encode-first stream-write2 - encode-second stream-write2 - ] [ h>b/b swap stream-write2 ] if ; +: char>utf16be ( char stream -- ) + over HEX: FFFF > [ + [ HEX: 10000 - ] dip + [ [ encode-first ] dip stream-write2 ] + [ [ encode-second ] dip stream-write2 ] 2bi + ] [ [ h>b/b swap ] dip stream-write2 ] if ; M: utf16be encode-char ( char stream encoding -- ) - drop swap char>utf16be ; + drop char>utf16be ; -: char>utf16le ( char stream -- ) - dup HEX: FFFF > [ - HEX: 10000 - - 2dup encode-first swap stream-write2 - encode-second swap stream-write2 - ] [ h>b/b stream-write2 ] if ; +: char>utf16le ( stream char -- ) + over HEX: FFFF > [ + [ HEX: 10000 - ] dip + [ [ encode-first swap ] dip stream-write2 ] + [ [ encode-second swap ] dip stream-write2 ] 2bi + ] [ [ h>b/b ] dip stream-write2 ] if ; M: utf16le encode-char ( char stream encoding -- ) - drop swap char>utf16le ; + drop char>utf16le ; ! UTF-16 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/backtrack/backtrack-docs.factor b/extra/backtrack/backtrack-docs.factor new file mode 100644 index 0000000000..c654ac234f --- /dev/null +++ b/extra/backtrack/backtrack-docs.factor @@ -0,0 +1,53 @@ +! Copyright (c) 2009 Samuel Tardieu. +! See See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: backtrack + +HELP: fail +{ $description "Signal that the current alternative is not acceptable. This will cause either backtracking to occur, or a failure to be signalled, as explained in the " { $link amb } " word description." } +{ $see-also amb cut-amb } +; + +HELP: amb +{ $values + { "seq" "the alternatives" } + { "elt" "one of the alternatives" } +} +{ $description "The amb (ambiguous) word saves the state of the current computation (through the " { $vocab-link "continuations" } " vocabulary) and returns the first alternative. When " { $link fail } " is invoked, the saved state will be restored and the next alternative will be returned. When there are no more alternatives, " { $link fail } " will go up one level to the location of the previous " { $link amb } " call. If there are no more calls up the chain, an error will be signalled." } +{ $see-also fail cut-amb } +; + +HELP: cut-amb +{ $description "Reset the amb system. Calling this word resets the whole stack of " { $link amb } " calls and should not be done lightly."} +{ $see-also amb fail } +; + +HELP: amb-execute +{ $values + { "seq" "a list of words" } +} +{ $description "Execute the first word in the list, and go to the next one if " { $link fail } " is called." } ; + +HELP: if-amb +{ $values + { "true" "a quotation with stack effect ( -- ? )" } + { "false" "a quotation" } + { "?" "a boolean" } +} +{ $description "Execute the first quotation and returns " { $link t } " if it returns " { $link t } " itself. If it fails with " { $link fail } " or returns " { $link f } ", then the second quotation is executed and " { $link f } " is returned." } ; + +HELP: amb-all +{ $values + { "quot" "a quotation with stack effect ( -- )" } +} +{ $description "Execute all the alternatives in the quotation by calling " { $link fail } " repeatedly at the end." } +{ $see-also bag-of fail } +; + +HELP: bag-of +{ $values + { "quot" "a quotation with stack effect ( -- result )" } + { "seq" "a sequence" } +} +{ $description "Execute all the alternatives in the quotation and collect the results." } +{ $see-also amb-all } ; \ No newline at end of file diff --git a/extra/backtrack/backtrack-tests.factor b/extra/backtrack/backtrack-tests.factor new file mode 100644 index 0000000000..d8e9830532 --- /dev/null +++ b/extra/backtrack/backtrack-tests.factor @@ -0,0 +1,15 @@ +! Copyright (c) 2009 Samuel Tardieu. +! See See http://factorcode.org/license.txt for BSD license. +USING: backtrack math tools.test ; + +cut-amb +[ 1 ] [ { 1 2 } amb ] unit-test +[ V{ { 1 2 } } ] [ [ { 1 2 } ] bag-of ] unit-test +[ V{ 1 2 } ] [ [ { 1 2 } amb ] bag-of ] unit-test +[ cut-amb { } amb ] must-fail +[ fail ] must-fail +[ V{ 1 10 2 20 } ] [ [ { 1 2 } amb { 1 10 } amb * ] bag-of ] unit-test +[ V{ 7 -1 } ] [ [ 3 4 { + - } amb-execute ] bag-of ] unit-test +[ "foo" t ] [ [ "foo" t ] [ "bar" ] if-amb ] unit-test +[ "bar" f ] [ [ "foo" f ] [ "bar" ] if-amb ] unit-test +[ "bar" f ] [ [ "foo" fail ] [ "bar" ] if-amb ] unit-test diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 9bef16d609..e4e13c3363 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -29,6 +29,10 @@ MACRO: checkpoint ( quot -- quot' ) [ 1quotation ] assoc-map ] bi '[ _ 0 unsafe-number-from-to nip _ case ] ; -: if-amb ( true false -- ) +: if-amb ( true false -- ? ) [ [ { t f } amb ] [ '[ @ require t ] ] [ '[ @ f ] ] tri* if - ] with-scope ; inline + ] amb-preserve ; inline : cut-amb ( -- ) f failure set ; + +: amb-all ( quot -- ) + [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline + +: bag-of ( quot -- seq ) + V{ } clone [ '[ @ _ push ] amb-all ] keep ; 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/cursors/authors.txt b/extra/cursors/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/cursors/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor new file mode 100644 index 0000000000..3c98608b72 --- /dev/null +++ b/extra/cursors/cursors-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: cursors math tools.test make ; +IN: cursors.tests + +[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test +[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test +[ f f ] [ { 2 4 } [ odd? ] find ] unit-test + +[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test +[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test + +[ t ] [ { } [ odd? ] all? ] unit-test +[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test +[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test + +[ t ] [ { } [ odd? ] all? ] unit-test +[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test +[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test + +[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor new file mode 100644 index 0000000000..059129f22e --- /dev/null +++ b/extra/cursors/cursors.factor @@ -0,0 +1,99 @@ +! Copyright (C) 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math sequences sequences.private ; +IN: cursors + +GENERIC: cursor-done? ( cursor -- ? ) +GENERIC: cursor-get-unsafe ( cursor -- obj ) +GENERIC: cursor-advance ( cursor -- ) +GENERIC: cursor-valid? ( cursor -- ? ) +GENERIC: cursor-write ( obj cursor -- ) + +ERROR: cursor-ended cursor ; + +: cursor-get ( cursor -- obj ) + dup cursor-done? + [ cursor-ended ] [ cursor-get-unsafe ] if ; inline + +: find-done? ( quot cursor -- ? ) + dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline + +: cursor-until ( quot cursor -- ) + [ find-done? not ] + [ cursor-advance drop ] bi-curry bi-curry while ; inline + +: cursor-each ( cursor quot -- ) + [ f ] compose swap cursor-until ; inline + +: cursor-find ( cursor quot -- obj ? ) + swap [ cursor-until ] keep + dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline + +: cursor-any? ( cursor quot -- ? ) + cursor-find nip ; inline + +: cursor-all? ( cursor quot -- ? ) + [ not ] compose cursor-any? not ; inline + +: cursor-map-quot ( quot to -- quot' ) + [ [ call ] dip cursor-write ] 2curry ; inline + +: cursor-map ( from to quot -- ) + swap cursor-map-quot cursor-each ; inline + +: cursor-write-if ( obj quot to -- ) + [ over [ call ] dip ] dip + [ cursor-write ] 2curry when ; inline + +: cursor-filter-quot ( quot to -- quot' ) + [ cursor-write-if ] 2curry ; inline + +: cursor-filter ( from to quot -- ) + swap cursor-filter-quot cursor-each ; inline + +TUPLE: from-sequence { seq sequence } { n integer } ; + +: >from-sequence< ( from-sequence -- n seq ) + [ n>> ] [ seq>> ] bi ; inline + +M: from-sequence cursor-done? ( cursor -- ? ) + >from-sequence< length >= ; + +M: from-sequence cursor-valid? + >from-sequence< bounds-check? not ; + +M: from-sequence cursor-get-unsafe + >from-sequence< nth-unsafe ; + +M: from-sequence cursor-advance + [ 1+ ] change-n drop ; + +: >input ( seq -- cursor ) + 0 from-sequence boa ; inline + +: iterate ( seq quot iterator -- ) + [ >input ] 2dip call ; inline + +: each ( seq quot -- ) [ cursor-each ] iterate ; inline +: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline +: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline +: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline + +TUPLE: to-sequence { seq sequence } { exemplar sequence } ; + +M: to-sequence cursor-write + seq>> push ; + +: freeze ( cursor -- seq ) + [ seq>> ] [ exemplar>> ] bi like ; inline + +: >output ( seq -- cursor ) + [ [ length ] keep new-resizable ] keep + to-sequence boa ; inline + +: transform ( seq quot transformer -- newseq ) + [ [ >input ] [ >output ] bi ] 2dip + [ call ] [ 2drop freeze ] 3bi ; inline + +: map ( seq quot -- ) [ cursor-map ] transform ; inline +: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index 9af94aa4ed..0756c5c975 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -28,7 +28,7 @@ PRIVATE> : make-descriptive ( word -- ) dup [ ] [ def>> ] [ stack-effect ] tri [descriptive] - '[ drop _ ] annotate-methods ; + '[ drop _ ] annotate ; : define-descriptive ( word def effect -- ) [ drop "descriptive-definition" set-word-prop ] 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/fuel/remote/remote.factor b/extra/fuel/remote/remote.factor index d13aff800a..d3b48efac6 100644 --- a/extra/fuel/remote/remote.factor +++ b/extra/fuel/remote/remote.factor @@ -11,9 +11,8 @@ IN: fuel.remote [ [ print-error-and-restarts ] error-hook set listener ] with-scope ; : server ( port -- server ) - + utf8 "tty-server" >>name - utf8 >>encoding swap local-server >>insecure [ start-listener ] >>handler f >>timeout ; diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index 3e3279ece7..608667bae7 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -23,13 +23,13 @@ IN: fuel.xref dup dup >vocab-link where normalize-loc 4array ; : sort-xrefs ( seq -- seq' ) - [ [ first ] dip first <=> ] sort ; inline + [ [ first ] dip first <=> ] sort ; : format-xrefs ( seq -- seq' ) - [ word? ] filter [ word>xref ] map ; inline + [ word? ] filter [ word>xref ] map ; : filter-prefix ( seq prefix -- seq ) - [ drop-prefix nip length 0 = ] curry filter prune ; inline + [ drop-prefix nip length 0 = ] curry filter prune ; MEMO: (vocab-words) ( name -- seq ) >vocab-link words [ name>> ] map ; @@ -37,10 +37,10 @@ MEMO: (vocab-words) ( name -- seq ) : current-words ( -- seq ) manifest get [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@ - assoc-union keys ; inline + assoc-union keys ; : vocabs-words ( names -- seq ) - prune [ (vocab-words) ] map concat ; inline + prune [ (vocab-words) ] map concat ; PRIVATE> 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/images/processing/rotation/authors.txt b/extra/images/processing/rotation/authors.txt new file mode 100644 index 0000000000..09801441c8 --- /dev/null +++ b/extra/images/processing/rotation/authors.txt @@ -0,0 +1,2 @@ +Kobi Lurie +Doug Coleman diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor new file mode 100755 index 0000000000..493f09b145 --- /dev/null +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2009 Kobi Lurie, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors fry images.loader images.normalization +images.processing.rotation kernel literals math sequences +tools.test images.processing.rotation.private ; +IN: images.processing.rotation.tests + +: first-row ( seq^2 -- seq ) first ; +: first-col ( seq^2 -- item ) harvest [ first ] map ; +: last-row ( seq^2 -- item ) last ; +: last-col ( seq^2 -- item ) harvest [ last ] map ; +: end-of-first-row ( seq^2 -- item ) first-row last ; +: first-of-first-row ( seq^2 -- item ) first-row first ; +: end-of-last-row ( seq^2 -- item ) last-row last ; +: first-of-last-row ( seq^2 -- item ) last-row first ; + +<< + +: clone-image ( image -- new-image ) + clone [ clone ] change-bitmap ; + +>> + +CONSTANT: pasted-image + $[ + "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" + load-image normalize-image clone-image + ] + +CONSTANT: pasted-image90 + $[ + "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" + load-image normalize-image clone-image + ] + +CONSTANT: lake-image + $[ + "vocab:images/processing/rotation/test-bitmaps/lake.bmp" + load-image preprocess + ] + +[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test +[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test +[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test +[ t ] [ + pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each = +] unit-test + +[ t ] [ + pasted-image 90 rotate + pasted-image90 = +] unit-test + +[ t ] [ + "vocab:images/processing/rotation/test-bitmaps/small.bmp" + load-image 90 rotate + "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp" + load-image normalize-image = +] unit-test + +[ t ] [ + lake-image + [ first-of-first-row ] + [ 90 (rotate) end-of-first-row ] bi = +] unit-test + +[ t ] +[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test + +[ t ] +[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test + +[ t ] +[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test + +[ t ] +[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test diff --git a/extra/images/processing/rotation/rotation.factor b/extra/images/processing/rotation/rotation.factor new file mode 100644 index 0000000000..c10bfa0ee0 --- /dev/null +++ b/extra/images/processing/rotation/rotation.factor @@ -0,0 +1,71 @@ +! Copyright (C) 2009 Kobi Lurie. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays colors combinators +combinators.short-circuit fry grouping images images.bitmap +images.loader images.normalization kernel locals math sequences ; +IN: images.processing.rotation + +ERROR: unsupported-rotation degrees ; + +> length ] [ dim>> second ] bi /i ; + +: image>byte-rows ( image -- byte-rows ) + [ bitmap>> ] [ row-length ] bi group rows-remove-pad ; + +: (seperate-to-pixels) ( byte-rows image -- pixel-rows ) + component-order>> bytes-per-pixel '[ _ group ] map ; + +: image>pixel-rows ( image -- pixel-rows ) + [ image>byte-rows ] keep (seperate-to-pixels) ; + +: flatten-table ( seq^3 -- seq ) + [ concat ] map concat ; + +: preprocess ( image -- pixelrows ) + normalize-image image>pixel-rows ; + +: ?reverse-dimensions ( image n -- ) + { 270 90 } member? [ [ reverse ] change-dim ] when drop ; + +: normalize-degree ( n -- n' ) 360 rem ; + +: processing-effect ( image quot -- image' ) + '[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline + +:: rotate' ( image n -- image ) + n normalize-degree :> n' + image preprocess :> pixel-table + image n' ?reverse-dimensions + pixel-table n' (rotate) :> table-rotated + image table-rotated flatten-table >>bitmap ; + +PRIVATE> + +: rotate ( image n -- image' ) + normalize-degree + [ '[ _ (rotate) ] processing-effect ] [ ?reverse-dimensions ] 2bi ; + +: reflect-y-axis ( image -- image ) + [ [ reverse ] map ] processing-effect ; + +: reflect-x-axis ( image -- image ) + [ reverse ] processing-effect ; diff --git a/extra/images/processing/rotation/test-bitmaps/PastedImage.bmp b/extra/images/processing/rotation/test-bitmaps/PastedImage.bmp new file mode 100755 index 0000000000..8edfedd4b5 Binary files /dev/null and b/extra/images/processing/rotation/test-bitmaps/PastedImage.bmp differ diff --git a/extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp b/extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp new file mode 100755 index 0000000000..2aa6ef1e27 Binary files /dev/null and b/extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp differ diff --git a/extra/images/processing/rotation/test-bitmaps/lake.bmp b/extra/images/processing/rotation/test-bitmaps/lake.bmp new file mode 100755 index 0000000000..431e4ef8ae Binary files /dev/null and b/extra/images/processing/rotation/test-bitmaps/lake.bmp differ diff --git a/extra/images/processing/rotation/test-bitmaps/small-rotated.bmp b/extra/images/processing/rotation/test-bitmaps/small-rotated.bmp new file mode 100755 index 0000000000..571ea835ff Binary files /dev/null and b/extra/images/processing/rotation/test-bitmaps/small-rotated.bmp differ diff --git a/extra/images/processing/rotation/test-bitmaps/small.bmp b/extra/images/processing/rotation/test-bitmaps/small.bmp new file mode 100755 index 0000000000..72748574bd Binary files /dev/null and b/extra/images/processing/rotation/test-bitmaps/small.bmp differ 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/managed-server/authors.txt b/extra/managed-server/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/managed-server/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/managed-server/chat/authors.txt b/extra/managed-server/chat/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/managed-server/chat/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor new file mode 100644 index 0000000000..8835e3d8a6 --- /dev/null +++ b/extra/managed-server/chat/chat.factor @@ -0,0 +1,132 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators combinators.smart +destructors fry io io.encodings.utf8 kernel managed-server +namespaces parser sequences sorting splitting strings.parser +unicode.case unicode.categories calendar calendar.format +locals multiline io.encodings.binary io.encodings.string +prettyprint ; +IN: managed-server.chat + +TUPLE: chat-server < managed-server ; + +SYMBOL: commands +commands [ H{ } clone ] initialize + +SYMBOL: chat-docs +chat-docs [ H{ } clone ] initialize + +CONSTANT: line-beginning "-!- " + +: handle-me ( string -- ) + [ + [ "* " username " " ] dip + ] "" append-outputs-as send-everyone ; + +: handle-quit ( string -- ) + client [ (>>object) ] [ t >>quit? drop ] bi ; + +: handle-help ( string -- ) + [ + "Commands: " + commands get keys natural-sort ", " join append print flush + ] [ + chat-docs get ?at + [ print flush ] + [ "Unknown command: " prepend print flush ] if + ] if-empty ; + +: usage ( string -- ) + chat-docs get at print flush ; + +: username-taken-string ( username -- string ) + "The username ``" "'' is already in use; try again." surround ; + +: warn-name-changed ( old new -- ) + [ + [ line-beginning "``" ] 2dip + [ "'' is now known as ``" ] dip "''" + ] "" append-outputs-as send-everyone ; + +: handle-nick ( string -- ) + [ + "nick" usage + ] [ + dup clients key? [ + username-taken-string print flush + ] [ + [ username swap warn-name-changed ] + [ username clients rename-at ] + [ client (>>username) ] tri + ] if + ] if-empty ; + +:: add-command ( quot docs key -- ) + quot key commands get set-at + docs key chat-docs get set-at ; + +[ handle-help ] +<" Syntax: /help [command] +Displays the documentation for a command."> +"help" add-command + +[ drop clients keys [ "``" "''" surround ] map ", " join print flush ] +<" Syntax: /who +Shows the list of connected users."> +"who" add-command + +[ drop gmt timestamp>rfc822 print flush ] +<" Syntax: /time +Returns the current GMT time."> "time" add-command + +[ handle-nick ] +<" Syntax: /nick nickname +Changes your nickname."> +"nick" add-command + +[ handle-me ] +<" Syntax: /me action"> +"me" add-command + +[ handle-quit ] +<" Syntax: /quit [message] +Disconnects a user from the chat server."> "quit" add-command + +: handle-command ( string -- ) + dup " " split1 swap >lower commands get at* [ + call( string -- ) drop + ] [ + 2drop "Unknown command: " prepend print flush + ] if ; + +: ( port -- managed-server ) + "chat-server" utf8 chat-server new-managed-server ; + +: handle-chat ( string -- ) + [ + [ username ": " ] dip + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-login + "Username: " write flush + readln ; + +M: chat-server handle-client-join + [ + line-beginning username " has joined" + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-client-disconnect + [ + line-beginning username " has quit " + client object>> dup [ "\"" dup surround ] when + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-already-logged-in + username username-taken-string print flush ; + +M: chat-server handle-managed-client* + readln dup f = [ t client (>>quit?) ] when + [ + "/" ?head [ handle-command ] [ handle-chat ] if + ] unless-empty ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor new file mode 100644 index 0000000000..4d4a440525 --- /dev/null +++ b/extra/managed-server/managed-server.factor @@ -0,0 +1,92 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar continuations destructors io +io.encodings.binary io.servers.connection io.sockets +io.streams.duplex fry kernel locals math math.ranges multiline +namespaces prettyprint random sequences sets splitting threads +tools.continuations ; +IN: managed-server + +TUPLE: managed-server < threaded-server clients ; + +TUPLE: managed-client +input-stream output-stream local-address remote-address +username object quit? ; + +HOOK: handle-login threaded-server ( -- username ) +HOOK: handle-managed-client* managed-server ( -- ) +HOOK: handle-already-logged-in managed-server ( -- ) +HOOK: handle-client-join managed-server ( -- ) +HOOK: handle-client-disconnect managed-server ( -- ) + +ERROR: already-logged-in username ; + +M: managed-server handle-already-logged-in already-logged-in ; +M: managed-server handle-client-join ; +M: managed-server handle-client-disconnect ; + +: server ( -- managed-client ) managed-server get ; +: client ( -- managed-client ) managed-client get ; +: clients ( -- assoc ) server clients>> ; +: client-streams ( -- assoc ) clients values ; +: username ( -- string ) client username>> ; +: everyone-else ( -- assoc ) + clients [ drop username = not ] assoc-filter ; +: everyone-else-streams ( -- assoc ) everyone-else values ; + +ERROR: no-such-client username ; + +> ] dip '[ _ print flush ] with-output-stream* ; + +PRIVATE> + +: send-client ( seq username -- ) + clients ?at [ no-such-client ] [ (send-client) ] if ; + +: send-everyone ( seq -- ) + [ client-streams ] dip '[ _ (send-client) ] each ; + +: send-everyone-else ( seq -- ) + [ everyone-else-streams ] dip '[ _ (send-client) ] each ; + + ( username -- managed-client ) + managed-client new + swap >>username + input-stream get >>input-stream + output-stream get >>output-stream + local-address get >>local-address + remote-address get >>remote-address ; + +: check-logged-in ( username -- username ) + dup clients key? [ handle-already-logged-in ] when ; + +: add-managed-client ( -- ) + client username check-logged-in clients set-at ; + +: delete-managed-client ( -- ) + username server clients>> delete-at ; + +: handle-managed-client ( -- ) + handle-login managed-client set + add-managed-client handle-client-join + [ handle-managed-client* client quit?>> not ] loop ; + +PRIVATE> + +M: managed-server handle-client* + managed-server set + [ handle-managed-client ] + [ delete-managed-client handle-client-disconnect ] + [ ] cleanup ; + +: new-managed-server ( port name encoding class -- server ) + new-threaded-server + swap >>name + swap >>insecure + f >>timeout + H{ } clone >>clients ; inline 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 6c20db10fd..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 { "a" number } { "value" 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..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 ] [ 0 -1 2 clamp ] unit-test -[ 1 ] [ 0 1 2 clamp ] unit-test -[ 2 ] [ 0 3 2 clamp ] unit-test - diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor index 826f0ecf16..b48641d723 100644 --- a/extra/math/compare/compare.factor +++ b/extra/math/compare/compare.factor @@ -14,6 +14,3 @@ IN: math.compare : negmin ( a b -- x ) 0 min min ; - -: clamp ( a value b -- x ) - min max ; 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/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor index 25c4c88203..8e56143664 100644 --- a/extra/mongodb/mmm/mmm.factor +++ b/extra/mongodb/mmm/mmm.factor @@ -89,9 +89,8 @@ M: mdb-msg dump-message ( message -- ) : start-mmm-server ( -- ) output-stream get mmm-dump-output set - [ mmm-t-srv set ] keep + binary [ mmm-t-srv set ] keep "127.0.0.1" mmm-port get >>insecure - binary >>encoding [ handle-mmm-connection ] >>handler start-server* ; @@ -99,4 +98,4 @@ M: mdb-msg dump-message ( message -- ) check-options start-mmm-server ; -MAIN: run-mmm \ No newline at end of file +MAIN: run-mmm diff --git a/extra/nurbs/nurbs-tests.factor b/extra/nurbs/nurbs-tests.factor index db606f9c5c..191c2af7ca 100644 --- a/extra/nurbs/nurbs-tests.factor +++ b/extra/nurbs/nurbs-tests.factor @@ -11,13 +11,13 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ] ! unit circle as NURBS 3 { { 1.0 0.0 1.0 } - { $ √2/2 $ √2/2 $ √2/2 } + ${ √2/2 √2/2 √2/2 } { 0.0 1.0 1.0 } - { $ -√2/2 $ √2/2 $ √2/2 } + ${ -√2/2 √2/2 √2/2 } { -1.0 0.0 1.0 } - { $ -√2/2 $ -√2/2 $ √2/2 } + ${ -√2/2 -√2/2 √2/2 } { 0.0 -1.0 1.0 } - { $ √2/2 $ -√2/2 $ √2/2 } + ${ √2/2 -√2/2 √2/2 } { 1.0 0.0 1.0 } } { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } test-nurbs set @@ -26,7 +26,7 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ] [ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test 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 } " word." } diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 5847426fae..42aa7e903a 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -88,7 +88,7 @@ M: terrain-world tick-length yaw>> 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/extra/time-server/time-server.factor b/extra/time-server/time-server.factor index 28debf17cd..500f0276d7 100644 --- a/extra/time-server/time-server.factor +++ b/extra/time-server/time-server.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.servers.connection accessors threads -calendar calendar.format ; +USING: accessors calendar calendar.format io io.encodings.ascii +io.servers.connection threads ; IN: time-server : handle-time-client ( -- ) now timestamp>rfc822 print ; : ( -- threaded-server ) - + ascii "time-server" >>name 1234 >>insecure [ handle-time-client ] >>handler ; diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index 4ba38ad06a..0c7395f7f0 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -3,9 +3,8 @@ accessors kernel ; IN: tty-server : ( port -- ) - + utf8 "tty-server" >>name - utf8 >>encoding swap local-server >>insecure [ listener ] >>handler start-server ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 52d64f0f9e..12b7ccda24 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -166,9 +166,7 @@ posting "POSTINGS" [ f [ deposit-blog-slots ] - [ "id" value >>id ] - [ update-tuple ] - tri + [ "id" value >>id update-tuple ] bi "$planet/admin" >>path 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 diff --git a/unmaintained/modules/rpc-server/rpc-server.factor b/unmaintained/modules/rpc-server/rpc-server.factor index 525ff35a09..0c881adef6 100644 --- a/unmaintained/modules/rpc-server/rpc-server.factor +++ b/unmaintained/modules/rpc-server/rpc-server.factor @@ -2,36 +2,44 @@ USING: accessors assocs continuations effects io io.encodings.binary io.servers.connection kernel memoize namespaces parser sets sequences serialize threads vocabs vocabs.parser words ; - IN: modules.rpc-server SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global : do-rpc ( args word -- bytes ) - [ execute ] curry with-datastack object>bytes ; inline + [ execute ] curry with-datastack object>bytes ; inline MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline -: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize - swap at "executer" get execute( args word -- bytes ) write flush ; - -: (serve) ( -- ) deserialize dup serving-vocabs get-global index - [ process ] [ drop ] if ; - -: start-serving-vocabs ( -- ) [ - 5000 >>insecure binary >>encoding [ (serve) ] >>handler - start-server ] in-thread ; - -: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when - current-vocab serving-vocabs get-global adjoin - "get-words" create-in - in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry - (( -- words )) define-inline ; +: process ( vocabspec -- ) + vocab-words [ deserialize ] dip deserialize + swap at "executer" get execute( args word -- bytes ) write flush ; + +: (serve) ( -- ) + deserialize dup serving-vocabs get-global index + [ process ] [ drop ] if ; + +: start-serving-vocabs ( -- ) + [ + binary + 5000 >>insecure + [ (serve) ] >>handler + start-server + ] in-thread ; + +: (service) ( -- ) + serving-vocabs get-global empty? [ start-serving-vocabs ] when + current-vocab serving-vocabs get-global adjoin + "get-words" create-in + in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry + (( -- words )) define-inline ; SYNTAX: service \ do-rpc "executer" set (service) ; SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ; load-vocab-hook [ - [ dup words>> values - \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ] -append ] change-global \ No newline at end of file + [ + dup words>> values + \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each + ] append +] change-global diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index afda9d31cd..a879712190 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -55,6 +55,10 @@ DEF(bool,check_sse2,(void)): mov %edx,%eax ret +DEF(long long,read_timestamp_counter,(void)): + rdtsc + ret + DEF(void,primitive_inline_cache_miss,(void)): mov (%esp),%ebx DEF(void,primitive_inline_cache_miss_tail,(void)): @@ -69,4 +73,5 @@ DEF(void,primitive_inline_cache_miss_tail,(void)): #ifdef WINDOWS .section .drectve .ascii " -export:check_sse2" + .ascii " -export:read_timestamp_counter" #endif diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 8cf7423239..5cc3c98f33 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -72,6 +72,13 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi call *ARG3 /* call memcpy */ ret /* return _with new stack_ */ +DEF(long long,read_timestamp_counter,(void)): + mov $0,%rax + rdtsc + shl $32,%rdx + or %rdx,%rax + ret + DEF(void,primitive_inline_cache_miss,(void)): mov (%rsp),%rbx DEF(void,primitive_inline_cache_miss_tail,(void)):