Remove some usages of -rot and tuck

db4
Slava Pestov 2009-04-18 21:53:22 -05:00
parent 54f82be4e0
commit 1c123e7e22
10 changed files with 44 additions and 59 deletions

View File

@ -6,9 +6,9 @@ IN: hash2.tests
: sample-hash ( -- hash ) : sample-hash ( -- hash )
5 <hash2> 5 <hash2>
dup 2 3 "foo" roll set-hash2 [ [ 2 3 "foo" ] dip set-hash2 ] keep
dup 4 2 "bar" roll set-hash2 [ [ 4 2 "bar" ] dip set-hash2 ] keep
dup 4 7 "other" roll set-hash2 ; [ [ 4 7 "other" ] dip set-hash2 ] keep ;
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test [ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test [ "bar" ] [ 4 2 sample-hash hash2 ] unit-test

View File

@ -1,4 +1,6 @@
USING: kernel sequences arrays math vectors ; ! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math vectors locals ;
IN: hash2 IN: hash2
! Little ad-hoc datastructure used to map two numbers ! Little ad-hoc datastructure used to map two numbers
@ -22,8 +24,8 @@ IN: hash2
: assoc2 ( a b alist -- value ) : assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline (assoc2) dup [ third ] when ; inline
: set-assoc2 ( value a b alist -- alist ) :: set-assoc2 ( value a b alist -- alist )
[ rot 3array ] dip ?push ; inline { a b value } alist ?push ; inline
: hash2@ ( a b hash2 -- a b bucket hash2 ) : hash2@ ( a b hash2 -- a b bucket hash2 )
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline [ 2dup hashcode2 ] dip [ length mod ] keep ; inline
@ -31,8 +33,8 @@ IN: hash2
: hash2 ( a b hash2 -- value/f ) : hash2 ( a b hash2 -- value/f )
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ; hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
: set-hash2 ( a b value hash2 -- ) :: set-hash2 ( a b value hash2 -- )
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ; value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
: alist>hash2 ( alist size -- hash2 ) : alist>hash2 ( alist size -- hash2 )
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline <hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline

View File

@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ;
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test [ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test [ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test [ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test [ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test [ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test [ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test [ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
[ "'abc def' \"hey" tokenize-command ] must-fail [ "\"abc def\" \"hey" tokenize-command ] must-fail
[ "'abc def" tokenize-command ] must-fail [ "\"abc def" tokenize-command ] must-fail
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test [ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
[ [
V{ V{

View File

@ -1,33 +1,17 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: peg peg.parsers kernel sequences strings words ; USING: peg peg.ebnf arrays sequences strings kernel ;
IN: io.launcher.unix.parser IN: io.launcher.unix.parser
! Our command line parser. Supported syntax: ! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens ! foo bar baz -- simple tokens
! foo\ bar -- escaping the space ! foo\ bar -- escaping the space
! 'foo bar' -- quotation
! "foo bar" -- quotation ! "foo bar" -- quotation
: 'escaped-char' ( -- parser ) EBNF: tokenize-command
"\\" token any-char 2seq [ second ] action ; space = " "
escaped-char = "\" .:ch => [[ ch ]]
: 'quoted-char' ( delimiter -- parser' ) quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
'escaped-char' unquoted = (escaped-char | [^ "])+
swap [ member? not ] curry satisfy argument = (quoted | unquoted) => [[ >string ]]
2choice ; inline command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
;EBNF
: 'quoted' ( delimiter -- parser )
dup 'quoted-char' repeat0 swap dup surrounded-by ;
: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
: 'argument' ( -- parser )
"\"" 'quoted'
"'" 'quoted'
'unquoted' 3choice
[ >string ] action ;
PEG: tokenize-command ( command -- ast/f )
'argument' " " token repeat1 list-of
" " token repeat0 tuck pack
just ;

View File

@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local )
] with-destructors ; ] with-destructors ;
: <client> ( remote encoding -- stream local ) : <client> ( remote encoding -- stream local )
[ (client) -rot ] dip <encoder-duplex> swap ; [ (client) ] dip swap [ <encoder-duplex> ] dip ;
SYMBOL: local-address SYMBOL: local-address

View File

@ -106,7 +106,8 @@ PRIVATE>
: deep-sequence>cons ( sequence -- cons ) : deep-sequence>cons ( sequence -- cons )
[ <reversed> ] keep nil [ <reversed> ] keep nil
[ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
with reduce ;
<PRIVATE <PRIVATE
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc ) :: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )

View File

@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- )
} cond ; } cond ;
: match-replace ( object pattern1 pattern2 -- result ) : match-replace ( object pattern1 pattern2 -- result )
-rot [ match [ "Pattern does not match" throw ] unless* ] dip swap
match [ "Pattern does not match" throw ] unless*
[ replace-patterns ] bind ; [ replace-patterns ] bind ;
: ?1-tail ( seq -- tail/f ) : ?1-tail ( seq -- tail/f )

View File

@ -164,9 +164,8 @@ M: plain-auth send-auth
: encode-header ( string -- string' ) : encode-header ( string -- string' )
dup aux>> [ dup aux>> [
"=?utf-8?B?" utf8 encode >base64
swap utf8 encode >base64 "=?utf-8?B?" "?=" surround
"?=" 3append
] when ; ] when ;
ERROR: invalid-header-string string ; ERROR: invalid-header-string string ;
@ -205,7 +204,7 @@ ERROR: invalid-header-string string ;
now timestamp>rfc822 "Date" set now timestamp>rfc822 "Date" set
message-id "Message-Id" set message-id "Message-Id" set
"1.0" "MIME-Version" set "1.0" "MIME-Version" set
"base64" "Content-Transfer-Encoding" set "quoted-printable" "Content-Transfer-Encoding" set
{ {
[ from>> "From" set ] [ from>> "From" set ]
[ to>> ", " join "To" set ] [ to>> ", " join "To" set ]

View File

@ -3,20 +3,20 @@
USING: accessors kernel arrays sequences math namespaces USING: accessors kernel arrays sequences math namespaces
strings io fry vectors words assocs combinators sorting strings io fry vectors words assocs combinators sorting
unicode.case unicode.categories math.order vocabs unicode.case unicode.categories math.order vocabs
tools.vocabs unicode.data ; tools.vocabs unicode.data locals ;
IN: tools.completion IN: tools.completion
: (fuzzy) ( accum ch i full -- accum i ? ) :: (fuzzy) ( accum i full ch -- accum i full ? )
index-from ch i full index-from [
[ :> i i accum push
[ swap push ] 2keep 1+ t accum i 1+ full t
] [ ] [
drop f -1 f f -1 full f
] if* ; ] if* ;
: fuzzy ( full short -- indices ) : fuzzy ( full short -- indices )
dup length <vector> -rot 0 -rot dup [ length <vector> 0 ] curry 2dip
[ -rot [ (fuzzy) ] keep swap ] all? 3drop ; [ (fuzzy) ] all? 3drop ;
: (runs) ( runs n seq -- runs n ) : (runs) ( runs n seq -- runs n )
[ [

View File

@ -3,7 +3,7 @@
USING: accessors arrays hashtables kernel models math namespaces USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads binary-search vectors dlists deques models threads
concurrency.flags math.order math.rectangles fry ; concurrency.flags math.order math.rectangles fry locals ;
IN: ui.gadgets IN: ui.gadgets
! Values for orientation slot ! Values for orientation slot
@ -66,8 +66,8 @@ M: gadget children-on nip children>> ;
: ((fast-children-on)) ( gadget dim axis -- <=> ) : ((fast-children-on)) ( gadget dim axis -- <=> )
[ swap loc>> v- ] dip v. 0 <=> ; [ swap loc>> v- ] dip v. 0 <=> ;
: (fast-children-on) ( dim axis children -- i ) :: (fast-children-on) ( dim axis children -- i )
-rot '[ _ _ ((fast-children-on)) ] search drop ; children [ dim axis ((fast-children-on)) ] search drop ;
PRIVATE> PRIVATE>