Remove some usages of -rot and tuck
parent
54f82be4e0
commit
1c123e7e22
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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{
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 ]
|
||||||
|
|
|
@ -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 )
|
||||||
[
|
[
|
||||||
|
|
|
@ -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>
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue