Merge branch 'master' into global_optimization

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

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 <string> "Hi There" md5 hmac-bytes >string ] unit-test
+    "Hi There" 16 11 <string> 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 <string>
-    50 HEX: dd <repetition> md5 hmac-bytes >string
+    50 HEX: dd <repetition>
+    16 HEX: aa <string> md5 hmac-bytes >string
 ] unit-test
 
 [
     "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
 ] [
-    16 11 <string> "Hi There" sha1 hmac-bytes >string
+    "Hi There" 16 11 <string> 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 <string>
-    50 HEX: dd <repetition> sha1 hmac-bytes >string
+    50 HEX: dd <repetition>
+    16 HEX: aa <string> sha1 hmac-bytes >string
 ] unit-test
 
 [ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
-[ 20 HEX: b <string> "Hi There" sha-256 hmac-bytes hex-string ] unit-test
+[ "Hi There" 20 HEX: b <string> 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

basis/checksums/hmac/hmac.factor

@@ -13,27 +13,26 @@ IN: checksums.hmac
 
 : ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
 
-:: 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 <file-reader> ] dip hmac-stream ;
+: hmac-file ( path key checksum -- value )
+    [ binary <file-reader> ] 2dip hmac-stream ;
 
-: hmac-bytes ( K seq checksum -- value )
-    [ binary <byte-reader> ] dip hmac-stream ;
+: hmac-bytes ( seq key checksum -- value )
+    [ binary <byte-reader> ] 2dip hmac-stream ;

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 ;
 
 : <growing-circular> ( capacity -- growing-circular )
     { } new-sequence 0 0 growing-circular boa ;

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 ;
 

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -19,7 +19,7 @@ IN: compiler.cfg.intrinsics.allot
     [ second ds-load ] [ ^^load-literal ] bi prefix ;
 
 : emit-<tuple-boa> ( node -- )
-    dup node-input-infos peek literal>>
+    dup node-input-infos last literal>>
     dup array? [
         nip
         ds-drop

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 ;

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 <string>
+    dup last 1 + CHAR: space <string>
     [ '[ CHAR: * swap _ set-nth ] each ] keep ;
 
 : interval-picture ( interval -- str )

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 ;
 

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

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 )

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 ;

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*

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>> \ <tuple-boa> eq? [
-        dup in-d>> peek node-value-info
+        dup in-d>> last node-value-info
         literal>> first immutable-tuple-class?
     ] [ drop f ] if ;

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
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

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, ;

basis/concurrency/distributed/distributed.factor

@@ -13,9 +13,8 @@ SYMBOL: local-node
     [ first2 get-process send ] [ stop-this-server ] if* ;
 
 : <node-server> ( addrspec -- threaded-server )
-    <threaded-server>
+    binary <threaded-server>
         swap >>insecure
-        binary >>encoding
         "concurrency.distributed" >>name
         [ handle-node-client ] >>handler ;
 

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
 

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

basis/cpu/x86/features/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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

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
+
+<PRIVATE
+
+FUNCTION: bool check_sse2 ( ) ;
+
+FUNCTION: longlong read_timestamp_counter ( ) ;
+
+PRIVATE>
+
+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

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 )
     <file-reader> csv ;

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
+[ { "" } ] [ "value" get ] unit-test

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 ;
+    [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;

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

basis/ftp/server/server.factor

@@ -341,12 +341,11 @@ M: ftp-server handle-client* ( server -- )
     ] with-destructors ;
 
 : <ftp-server> ( 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 -- )
     <ftp-server> start-server ;

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 ;

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

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 -- )

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
 

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* ;
 

basis/http/server/server.factor

@@ -269,7 +269,7 @@ M: http-server handle-client*
     ] with-destructors ;
 
 : <http-server> ( -- server )
-    http-server new-threaded-server
+    ascii http-server new-threaded-server
         "http.server" >>name
         "http" protocol-port >>insecure
         "https" protocol-port >>secure ;

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 ;
 

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

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 <threaded-server> } ". 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: <threaded-server>
-{ $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" } "." } ;

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 ] [ <threaded-server> listen-on empty? ] unit-test
+[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
 
 [ f ] [
-    <threaded-server>
+    ascii <threaded-server>
         25 internet-server >>insecure
     listen-on
     empty?
@@ -19,16 +19,16 @@ concurrency.promises io.encodings.ascii io threads calendar ;
     and
 ] unit-test
 
-[ ] [ <threaded-server> init-server drop ] unit-test
+[ ] [ ascii <threaded-server> init-server drop ] unit-test
 
 [ 10 ] [
-    <threaded-server>
+    ascii <threaded-server>
         10 >>max-connections
     init-server semaphore>> count>> 
 ] unit-test
 
 [ ] [
-    <threaded-server>
+    ascii <threaded-server>
         5 >>max-connections
         0 >>insecure
         [ "Hello world." write stop-this-server ] >>handler

basis/io/servers/connection/connection.factor

@@ -27,18 +27,18 @@ ready ;
 
 : internet-server ( port -- addrspec ) f swap <inet> ;
 
-: 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> >>secure-config
         [ "No handler quotation" throw ] >>handler
         <flag> >>ready ; inline
 
-: <threaded-server> ( -- threaded-server )
+: <threaded-server> ( encoding -- threaded-server )
     threaded-server new-threaded-server ;
 
 GENERIC: handle-client* ( threaded-server -- )

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 ;

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 )

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
+    1067811677921310779 >bignum make-bits last
+] unit-test

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:"

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

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

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

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"
+ABOUT: "math.ranges"

basis/math/ranges/ranges-tests.factor

@@ -22,17 +22,6 @@ IN: math.ranges.tests
 [ { 0 1/3 2/3 1 } ] [ 0 1 1/3 <range> >array ] unit-test
 [ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >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
+] unit-test

basis/math/ranges/ranges.factor

@@ -26,12 +26,16 @@ M: range hashcode* tuple-hashcode ;
 
 INSTANCE: range immutable-sequence
 
+<PRIVATE
+
 : twiddle ( a b -- a b step ) 2dup > -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 <range> ; inline
 
 : (a,b] ( a b -- range ) twiddle (a, <range> ; 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) ;

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

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 ;

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 ;

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" = [

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 ]

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 ] }
         [ ]

basis/prettyprint/sections/sections.factor

@@ -153,7 +153,7 @@ TUPLE: block < section sections ;
 : <block> ( 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 <fresh-line ] [ drop ] if ;
@@ -355,4 +355,4 @@ M: block long-section ( block -- )
     ] with-scope ; inline
 
 : with-pprint ( obj quot -- )
-    make-pprint drop do-pprint ; inline
+    make-pprint drop do-pprint ; inline

basis/quoted-printable/quoted-printable-tests.factor

@@ -27,4 +27,4 @@ and we didn't know hów tö do thât"> 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

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 ;
+    dup quoted? [ but-last-slice rest-slice >string ] when ;

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

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 >>

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"
     }
 ] [

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 >>

basis/splitting/monotonic/monotonic.factor

@@ -6,9 +6,9 @@ IN: splitting.monotonic
 
 <PRIVATE
 
-: ,, ( obj -- ) building get peek push ;
+: ,, ( obj -- ) building get last push ;
 : v, ( -- ) V{ } clone , ;
-: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
+: ,v ( -- ) building get dup last empty? [ dup pop* ] when drop ;
 
 : (monotonic-split) ( seq quot -- newseq )
     [

basis/stack-checker/transforms/transforms.factor

@@ -57,8 +57,8 @@ IN: stack-checker.transforms
     [
         [ no-case ]
     ] [
-        dup peek callable? [
-            dup peek swap but-last
+        dup last callable? [
+            dup last swap but-last
         ] [
             [ no-case ] swap
         ] if case>quot

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 } }

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 ;

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" ;
+
 <PRIVATE
 
 : check-annotate-twice ( word -- word )
@@ -29,17 +30,19 @@ ERROR: cannot-annotate-twice word ;
         cannot-annotate-twice
     ] when ;
 
-: save-unannotated-def ( word -- )
-    dup def>> "unannotated-def" set-word-prop ;
-
-: (annotate) ( word quot -- )
-    [ dup def>> ] dip call( old -- new ) define ;
-
 PRIVATE>
 
-: annotate ( word quot -- )
+GENERIC# annotate 1 ( word quot -- )
+
+M: generic annotate
+    [ "methods" word-prop values ] dip '[ _ annotate ] each ;
+
+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 ;
 
 <PRIVATE
 
@@ -77,19 +80,11 @@ PRIVATE>
 : 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
 

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 ;
+    name-map keys dup zip completions ;

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
 
 
 [

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 <CGPoint> -> cascadeTopLeftFromPoint:
             -> setFrameTopLeftPoint:
         ] if

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
 

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

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

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
 

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

basis/xml/xml.factor

@@ -11,7 +11,7 @@ IN: xml
 <PRIVATE
 
 : add-child ( object -- )
-    xml-stack get peek second push ;
+    xml-stack get last second push ;
 
 : push-xml ( object -- )
     V{ } clone 2array xml-stack get push ;

build-support/factor.sh

@@ -174,6 +174,7 @@ find_os() {
         CYGWIN_NT-5.2-WOW64) OS=winnt;;
         *CYGWIN_NT*) OS=winnt;;
         *CYGWIN*) OS=winnt;;
+        MINGW32*) OS=winnt;;
         *darwin*) OS=macosx;;
         *Darwin*) OS=macosx;;
         *linux*) OS=linux;;

core/assocs/assocs-docs.factor

@@ -66,7 +66,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
 { $see-also at* assoc-size } ;
 
 ARTICLE: "assocs-values" "Transposed assoc operations"
-"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
+"default Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
 { $subsection value-at }
 { $subsection value-at* }
 { $subsection value? }
@@ -119,7 +119,9 @@ $nl
 { $subsection assoc-any? }
 { $subsection assoc-all? }
 "Additional combinators:"
+{ $subsection assoc-partition }
 { $subsection cache }
+{ $subsection 2cache }
 { $subsection map>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

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 ] }

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 ;

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 -- )

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 ;

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

core/combinators/combinators.factor

@@ -101,6 +101,8 @@ ERROR: no-case object ;
         [ \ drop prefix ] bi*
     ] assoc-map alist>quot ;
 
+<PRIVATE
+
 : (distribute-buckets) ( buckets pair keys -- )
     dup t eq? [
         drop [ swap adjoin ] curry each
@@ -150,6 +152,8 @@ ERROR: no-case object ;
         ] [ ] make , , \ if ,
     ] [ ] make ;
 
+PRIVATE>
+
 : 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
 

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 ;

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

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

core/generic/math/math.factor

@@ -15,7 +15,7 @@ PREDICATE: math-class < class
 
 <PRIVATE
 
-: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
+: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
 
 : bootstrap-words ( classes -- classes' )
     [ bootstrap-word ] map ;

core/generic/single/single.factor

@@ -3,7 +3,8 @@
 USING: accessors arrays assocs classes classes.algebra
 combinators definitions generic hashtables kernel
 kernel.private layouts math namespaces quotations
-sequences words generic.single.private effects make ;
+sequences words generic.single.private effects make
+combinators.private ;
 IN: generic.single
 
 ERROR: no-method object generic ;
@@ -234,7 +235,7 @@ M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
     quote-methods
     prune-redundant-predicates
     class-predicates
-    [ peek ] [ alist>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

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
 

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=? }

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

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

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

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* }

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
 
 : <flat-slice> ( seq -- slice )
     dup slice? [ { } like ] when

core/splitting/splitting.factor

@@ -53,6 +53,8 @@ PRIVATE>
     [ <reversed> ] bi@ split1-slice [ <reversed> ] bi@
     [ f ] [ swap ] if-empty ;
 
+<PRIVATE
+
 : (split) ( separators n seq -- )
     3dup rot [ member? ] curry find-from drop
     [ [ swap subseq , ] 2keep 1 + swap (split) ]
@@ -60,6 +62,8 @@ PRIVATE>
 
 : 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 ;

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
+[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test

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 )

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>
 

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!" ]