steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

assocs: Add of and ?of. Change all the things at once! Fixes #701.

db4
Doug Coleman 2013-03-23 14:35:01 -07:00
parent ccb46e62d4
commit 8c19602ae9
48 changed files with 145 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/classes/struct/struct-tests.factor
View File

@ -65,13 +65,13 @@ STRUCT: struct-test-bar
make-mirror >alist
] unit-test
[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test
[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test
[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test
[ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
[ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } ?of ] unit-test
[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } ?of ] unit-test
[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } ?of ] unit-test
[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } ?of ] unit-test
[ { "nonexist" "bool" } f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } ?of ] unit-test
[ "nonexist" f ] [ S{ struct-test-foo } make-mirror "nonexist" ?of ] unit-test
[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" ?of ] unit-test
[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }

2
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -95,7 +95,7 @@ M: #phi propagate-before ( #phi -- )
new [| key value | key old [ value union ] change-at ] assoc-each ;
: include-child-constraints ( i -- )
infer-children-data get nth constraints swap at last
infer-children-data get nth constraints of last
constraints get last update-constraints ;
: branch-phi-constraints ( output values booleans -- )

26
basis/furnace/auth/providers/couchdb/couchdb.factor
View File

@ -45,9 +45,9 @@ TUPLE: couchdb-auth-provider
make-mirror H{ } assoc-like ;
: is-couchdb-conflict-error? ( error -- ? )
{ [ couchdb-error? ] [ data>> "error" swap at "conflict" = ] } 1&& ;
{ [ couchdb-error? ] [ data>> "error" of "conflict" = ] } 1&& ;
: is-couchdb-not-found-error? ( error -- ? )
{ [ couchdb-error? ] [ data>> "error" swap at "not_found" = ] } 1&& ;
{ [ couchdb-error? ] [ data>> "error" of "not_found" = ] } 1&& ;
: get-url ( url -- url' )
couchdb-auth-provider get
@ -73,15 +73,15 @@ TUPLE: couchdb-auth-provider
over [ (reserve) ] [ 2drop t ] if ;
: unreserve ( couch-rval -- )
[ "id" swap at get-url ]
[ "rev" swap at "rev" set-query-param ]
[ "id" of get-url ]
[ "rev" of "rev" set-query-param ]
bi
couch-delete drop ;
: unreserve-from-id ( id -- )
[
get-url dup couch-get
"_rev" swap at "rev" set-query-param
"_rev" of "rev" set-query-param
couch-delete drop
] [
dup is-couchdb-not-found-error? [ 2drop ] [ rethrow ] if
@ -110,7 +110,7 @@ TUPLE: couchdb-auth-provider
! Should be given a view URL.
: ((get-user)) ( couchdb-url -- user/f )
couch-get
"rows" swap at dup empty? [ drop f ] [ first "value" swap at ] if ;
"rows" of dup empty? [ drop f ] [ first "value" of ] if ;
: (get-user) ( username -- user/f )
couchdb-auth-provider get
@ -171,8 +171,8 @@ TUPLE: couchdb-auth-provider
: unify-users ( old new -- new )
swap
[ "_rev" swap at "_rev" rot set-at ]
[ "_id" swap at "_id" rot set-at ]
[ "_rev" of "_rev" rot set-at ]
[ "_id" of "_id" rot set-at ]
[ swap assoc-union ]
2tri ;
@ -182,15 +182,15 @@ TUPLE: couchdb-auth-provider
! (This word is called by the 'update-user' method.)
: check-update ( old new -- ? )
[
2dup [ "email" swap at ] same? not [
[ "email" swap at ] bi@
2dup [ "email" of ] same? not [
[ "email" of ] bi@
[ drop "email" reservation-id unreserve-from-id ]
[ nip "email" reserve ]
2bi
] [ 2drop t ] if
] [
2dup [ "username" swap at ] same? not [
[ "username" swap at ] bi@
2dup [ "username" of ] same? not [
[ "username" of ] bi@
[ drop "username" reservation-id unreserve-from-id ]
[ nip "username" reserve ]
2bi
@ -217,7 +217,7 @@ M: couchdb-auth-provider new-user ( user provider -- user/f )
M: couchdb-auth-provider update-user ( user provider -- )
couchdb-auth-provider [
[ username>> (get-user)/throw-on-no-user dup ]
[ drop "_id" swap at get-url ]
[ drop "_id" of get-url ]
[ user>user-hash swapd
2dup check-update drop
unify-users >json swap couch-put drop

2
basis/hashtables/identity/identity-tests.factor
View File

@ -11,7 +11,7 @@ CONSTANT: will
}
: please-stand-up ( assoc key -- value )
swap at ;
of ;
[ t ] [ will the-real-slim-shady please-stand-up ] unit-test
[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test

2
basis/hashtables/sequences/sequences-tests.factor
View File

@ -15,7 +15,7 @@ IN: hashtables.identity.tests
[ 1001 ] [
SH{ } clone 1001 0 4 "asdf" <slice> pick set-at
"asdf" swap at
"asdf" of
] unit-test
[ { { "asdf" 1000 } } ] [ SH{ { "asdf" 1000 } } >alist ] unit-test

10
basis/html/streams/streams.factor
View File

@ -29,10 +29,10 @@ TUPLE: html-sub-stream < html-writer style parent ;
[ data>> ] [ style>> ] [ parent>> ] tri ;
: object-link-tag ( xml style -- xml )
presented swap at [ url-of [ simple-link ] when* ] when* ;
presented of [ url-of [ simple-link ] when* ] when* ;
: href-link-tag ( xml style -- xml )
href swap at [ simple-link ] when* ;
href of [ simple-link ] when* ;
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
@ -58,7 +58,7 @@ TUPLE: html-sub-stream < html-writer style parent ;
"font-family: " % % "; " % ;
MACRO: make-css ( pairs -- str )
[ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
[ '[ _ of [ _ execute ] when* ] ] { } assoc>map
'[ [ _ cleave ] "" make ] ;
: span-css-style ( style -- str )
@ -81,7 +81,7 @@ MACRO: make-css ( pairs -- str )
"vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ;
: img-tag ( xml style -- xml )
image swap at [ nip image-path simple-image ] when* ;
image of [ nip image-path simple-image ] when* ;
: format-html-span ( string style stream -- )
[
@ -113,7 +113,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;"
{ border-color border-css, }
{ inset padding-css, }
} make-css
] [ wrap-margin swap at [ pre-css append ] unless ] bi
] [ wrap-margin of [ pre-css append ] unless ] bi
" display: inline-block;" append ;
: div-tag ( xml style -- xml' )

2
basis/http/http.factor
View File

@ -222,5 +222,5 @@ TUPLE: post-data data params content-type content-encoding ;
: parse-content-type ( content-type -- type encoding )
";" split1
parse-content-type-attributes "charset" swap at
parse-content-type-attributes "charset" of
[ dup mime-type-encoding encoding>name ] unless* ;

4
basis/io/launcher/windows/windows-tests.factor
View File

@ -173,7 +173,7 @@ IN: io.launcher.windows.tests
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"A" swap at
"A" of
] unit-test
[ f ] [
@ -185,7 +185,7 @@ IN: io.launcher.windows.tests
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
"USERPROFILE" of "XXX" =
] unit-test
2 [

2
basis/linked-assocs/linked-assocs-tests.factor
View File

@ -14,7 +14,7 @@ IN: linked-assocs.test
<linked-hash> 1 "b" pick set-at
2 "c" pick set-at
3 "a" pick set-at
"c" swap at*
"c" ?of
] unit-test
{ { 2 3 4 } { "c" "a" "d" } 3 } [

2
basis/math/statistics/statistics-tests.factor
View File

@ -103,7 +103,7 @@ IN: math.statistics.tests
V{ 2 5 8 }
} [
10 iota [ 3 mod ] collect-by
[ 0 swap at ] [ 1 swap at ] [ 2 swap at ] tri
[ 0 of ] [ 1 of ] [ 2 of ] tri
] unit-test
[ 0 ] [ { 1 } { 1 } sample-cov ] unit-test

2
basis/mime/multipart/multipart-tests.factor
View File

@ -32,7 +32,7 @@ IN: mime.multipart.tests
[ t ] [
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
"file1" swap at filename>> "up.txt" =
"file1" of filename>> "up.txt" =
] unit-test
SYMBOL: mime-test-server

2
basis/mime/multipart/multipart.factor
View File

@ -81,7 +81,7 @@ ERROR: end-of-stream multipart ;
drop
] [
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
[ content-disposition>> "name" swap at unquote ]
[ content-disposition>> "name" of unquote ]
[ mime-parts>> set-at ] tri
] if ;

4
basis/peg/ebnf/ebnf.factor
View File

@ -555,14 +555,14 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
'ebnf' (parse) check-parse-result ast>> transform ;
: ebnf>quot ( string -- hashtable quot )
parse-ebnf dup dup parser [ main swap at compile ] with-variable
parse-ebnf dup dup parser [ main of compile ] with-variable
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
PRIVATE>
SYNTAX: <EBNF
"EBNF>"
reset-tokenizer parse-multiline-string parse-ebnf main swap at
reset-tokenizer parse-multiline-string parse-ebnf main of
suffix! reset-tokenizer ;
SYNTAX: [EBNF

2
basis/stack-checker/branches/branches.factor
View File

@ -78,7 +78,7 @@ SYMBOLS: combinator quotations ;
terminated? branch-variable ;
: terminate-branches ( seq -- )
[ terminated? swap at ] all? [ terminate ] when ;
[ terminated? of ] all? [ terminate ] when ;
: compute-phi-function ( seq -- )
[ quotation active-variable sift quotations set ]

2
basis/tools/walker/debug/debug.factor
View File

@ -26,5 +26,5 @@ IN: tools.walker.debug
send-synchronous drop
p ?promise
variables>> walker-continuation swap at
variables>> walker-continuation of
value>> data>> ;

4
basis/tools/walker/walker.factor
View File

@ -23,8 +23,8 @@ DEFER: start-walker-thread
: get-walker-thread ( -- status continuation thread )
walker-thread tget [
[ variables>> walker-status swap at ]
[ variables>> walker-continuation swap at ]
[ variables>> walker-status of ]
[ variables>> walker-continuation of ]
[ ] tri
] [
f <model>

10
basis/ui/gadgets/panes/panes.factor
View File

@ -199,9 +199,9 @@ MEMO: specified-font ( assoc -- font )
#! We memoize here to avoid creating lots of duplicate font objects.
[ monospace-font <font> ] dip
{
[ font-name swap at >>name ]
[ font-name of >>name ]
[
font-style swap at {
font-style of {
{ f [ ] }
{ plain [ ] }
{ bold [ t >>bold? ] }
@ -209,9 +209,9 @@ MEMO: specified-font ( assoc -- font )
{ bold-italic [ t >>bold? t >>italic? ] }
} case
]
[ font-size swap at >>size ]
[ foreground swap at >>foreground ]
[ background swap at >>background ]
[ font-size of >>size ]
[ foreground of >>foreground ]
[ background of >>background ]
} cleave
derive-font ;

2
basis/unicode/collation/collation.factor
View File

@ -31,7 +31,7 @@ TUPLE: weight primary secondary tertiary ignorable? ;
: help-one ( assoc key -- )
! Need to be more general? Not for DUCET, apparently
2 head 2dup swap key? [ 2drop ] [
[ [ 1string swap at ] with { } map-as concat ]
[ [ 1string of ] with { } map-as concat ]
[ swap set-at ] 2bi
] if ;

2
basis/unicode/data/data.factor
View File

@ -92,7 +92,7 @@ PRIVATE>
: (chain-decomposed) ( hash value -- newvalue )
[
2dup swap at
2dup of
[ (chain-decomposed) ] [ 1array nip ] ?if
] with map concat ;

6
basis/xml/elements/elements.factor
View File

@ -63,12 +63,12 @@ IN: xml.elements
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-version ( alist -- version )
T{ name { space "" } { main "version" } } swap at
T{ name { space "" } { main "version" } } of
[ good-version ] [ versionless-prolog ] if*
dup set-version ;
: prolog-encoding ( alist -- encoding )
T{ name { space "" } { main "encoding" } } swap at
T{ name { space "" } { main "encoding" } } of
"UTF-8" or ;
: yes/no>bool ( string -- t/f )
@ -79,7 +79,7 @@ IN: xml.elements
} case ;
: prolog-standalone ( alist -- version )
T{ name { space "" } { main "standalone" } } swap at
T{ name { space "" } { main "standalone" } } of
[ yes/no>bool ] [ f ] if* ;
: prolog-attrs ( alist -- prolog )

2
basis/xml/syntax/syntax.factor
View File

@ -72,7 +72,7 @@ SYNTAX: XML-NS:
DEFER: interpolate-sequence
: get-interpolated ( interpolated -- quot )
var>> '[ [ _ swap at ] keep ] ;
var>> '[ [ _ of ] keep ] ;
: ?present ( object -- string )
dup [ present ] when ;

2
basis/xmode/marker/marker.factor
View File

@ -311,7 +311,7 @@ M: mark-previous-rule handle-rule-start
: tokenize-line ( line-context line rules -- line-context' seq )
[
"MAIN" swap at -rot
"MAIN" of -rot
init-token-marker
mark-token-loop
mark-remaining

10
core/assocs/assocs-docs.factor
View File

@ -236,7 +236,7 @@ HELP: key?
{ $values { "key" object } { "assoc" assoc } { "?" boolean } }
{ $description "Tests if an assoc contains a key." } ;
{ at at* key? ?at } related-words
{ at at* key? ?at of ?of } related-words
HELP: at
{ $values { "key" object } { "assoc" assoc } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } }
@ -246,6 +246,14 @@ HELP: ?at
{ $values { "key" object } { "assoc" assoc } { "value/key" "the value associated to the key, or the key if the key is not present in the assoc" } { "?" "a " { $link boolean } " indicating if the key was present" } }
{ $description "Looks up the value associated with a key. If the key was not present, an error can be thrown without extra stack shuffling. This word handles assocs that store " { $link f } "." } ;
HELP: of
{ $values { "assoc" assoc } { "key" object } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } }
{ $description "Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to " { $link f } "; if the difference is important, use " { $link ?of } "." } ;
HELP: ?of
{ $values { "assoc" assoc } { "key" object } { "value/key" "the value associated to the key, or the key if the key is not present in the assoc" } { "?" "a " { $link boolean } " indicating if the key was present" } }
{ $description "Looks up the value associated with a key. If the key was not present, an error can be thrown without extra stack shuffling. This word handles assocs that store " { $link f } "." } ;
HELP: assoc-each
{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... )" } } }
{ $description "Applies a quotation to each entry in the assoc." }

6
core/assocs/assocs.factor
View File

@ -97,6 +97,12 @@ PRIVATE>
: at ( key assoc -- value/f )
at* drop ; inline
: ?of ( assoc key -- value/key ? )
swap ?at ; inline
: of ( assoc key -- value/f )
swap at ; inline
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ dup assoc-size ] dip new-assoc
[ [ set-at ] with-assoc assoc-each ] keep ; inline

2
core/classes/classes.factor
View File

@ -198,7 +198,7 @@ GENERIC: metaclass-changed ( use class -- )
: (define-class) ( word props -- )
reset-caches
2dup "metaclass" swap at check-metaclass
2dup "metaclass" of check-metaclass
{
[ 2drop update-map- ]
[ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]

2
core/hashtables/hashtables-tests.factor
View File

@ -177,4 +177,4 @@ H{ } "x" set
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
[ "A" ] [ 100 iota [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
[ "A" ] [ 100 iota [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 of ] unit-test

6
extra/asn1/asn1.factor
View File

@ -100,10 +100,10 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
: set-objtype ( syntax -- )
builtin-syntax 2array [
elements get tagclass>> swap at
elements get encoding>> swap at
elements get tagclass>> of
elements get encoding>> of
elements get tag>>
swap at [
of [
elements get objtype<<
] when*
] each ;

4
extra/assocs/extras/extras.factor
View File

@ -5,13 +5,11 @@ USING: arrays assocs assocs.private kernel math sequences ;
IN: assocs.extras
: of ( assoc key -- value ) swap at ; inline
: assoc-harvest ( assoc -- assoc' )
[ nip empty? not ] assoc-filter ; inline
: deep-at ( assoc seq -- value/f )
[ swap at ] each ; inline
[ of ] each ; inline
: zip-as ( keys values exemplar -- assoc )
dup sequence? [

4
extra/bit/ly/ly.factor
View File

@ -8,8 +8,6 @@ SYMBOLS: bitly-api-user bitly-api-key ;
<PRIVATE
: of ( assoc key -- value ) swap at ;
: <bitly-url> ( path -- url )
"http://api.bitly.com/v3/" prepend >url
bitly-api-user get "login" set-query-param
@ -25,7 +23,7 @@ ERROR: bad-response json status ;
] unless ;
: json-data ( url -- json )
http-get nip json> check-status "data" swap at ;
http-get nip json> check-status "data" of ;
: get-short-url ( short-url path -- data )
<bitly-url> swap "shortUrl" set-query-param json-data ;

2
extra/bitcoin/client/client.factor
View File

@ -64,7 +64,7 @@ IN: bitcoin.client
payload bitcoin-url <post-request>
basic-auth "Authorization" set-header
dup post-data>> data>> length "Content-Length" set-header
http-request nip >string json> "result" swap at ;
http-request nip >string json> "result" of ;
PRIVATE>

2
extra/bson/constants/constants.factor
View File

@ -42,7 +42,7 @@ CONSTRUCTOR: dbref ( ref id -- dbref ) ;
} 2cleave ; inline
: assoc>dbref ( assoc -- dbref )
[ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
[ "$ref" of ] [ "$id" of ] [ "$db" of ] tri
dbref boa ; inline
: dbref-assoc? ( assoc -- ? )

10
extra/couchdb/couchdb-tests.factor
View File

@ -14,7 +14,7 @@ IN: couchdb.tests
[ couch get delete-db ] must-fail
[ ] [ couch get ensure-db ] unit-test
[ ] [ couch get ensure-db ] unit-test
[ 0 ] [ couch get db-info "doc_count" swap at ] unit-test
[ 0 ] [ couch get db-info "doc_count" of ] unit-test
[ ] [ couch get compact-db ] unit-test
[ t ] [ couch get server>> next-uuid string? ] unit-test
[ ] [ H{
@ -25,13 +25,13 @@ IN: couchdb.tests
{ "Author" "Rusty" }
{ "PostedDate" "2006-08-15T17:30:12Z-04:00" }
} save-doc ] unit-test
[ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test
[ t ] [ couch get all-docs "rows" of first "id" of dup "id" set string? ] unit-test
[ t ] [ "id" get dup load-doc id> = ] unit-test
[ ] [ "id" get load-doc save-doc ] unit-test
[ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test
[ "Rusty" ] [ "id" get load-doc "Author" of ] unit-test
[ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
[ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test
[ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test
[ "Alex" ] [ "id" get load-doc "Author" of ] unit-test
[ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" of ] unit-test
[ ] [ H{
{ "_id" "_design/posts" }
{ "language" "javascript" }

16
extra/couchdb/couchdb.factor
View File

@ -21,10 +21,10 @@ C: <couchdb-error> couchdb-error
M: couchdb-error error. ( error -- )
"CouchDB Error: " write data>>
"error" over at [ print ] when*
"reason" swap at [ print ] when* ;
"reason" of [ print ] when* ;
PREDICATE: file-exists-error < couchdb-error
data>> "error" swap at "file_exists" = ;
data>> "error" of "file_exists" = ;
! http tools
: couch-http-request ( request -- data )
@ -83,7 +83,7 @@ CONSTANT: default-uuids-to-cache 100
[ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
: uuids-get ( server -- uuids )
uuids-url couch-get "uuids" swap at >vector ;
uuids-url couch-get "uuids" of >vector ;
: get-uuids ( server -- server )
dup uuids-get [ nip ] curry change-uuids ;
@ -129,11 +129,11 @@ C: <db> db
>json utf8 encode "application/json" <post-data> swap >>data ;
! documents
: id> ( assoc -- id ) "_id" swap at ;
: id> ( assoc -- id ) "_id" of ;
: >id ( assoc id -- assoc ) "_id" pick set-at ;
: rev> ( assoc -- rev ) "_rev" swap at ;
: rev> ( assoc -- rev ) "_rev" of ;
: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
: attachments> ( assoc -- attachments ) "_attachments" swap at ;
: attachments> ( assoc -- attachments ) "_attachments" of ;
: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
:: copy-key ( to from to-key from-key -- )
@ -174,8 +174,8 @@ C: <db> db
: delete-doc ( assoc -- deletion-revision )
[
[ doc-url % ]
[ "?rev=" % "_rev" swap at % ] bi
] "" make couch-delete response-ok "rev" swap at ;
[ "?rev=" % "_rev" of % ] bi
] "" make couch-delete response-ok "rev" of ;
: remove-keys ( assoc keys -- )
swap [ delete-at ] curry each ;

2
extra/fuel/xref/xref.factor
View File

@ -60,7 +60,7 @@ PRIVATE>
: vocab-usage-xref ( vocab -- seq ) vocab-usage [ vocab>xref ] map ;
: doc-location ( word -- loc ) props>> "help-loc" swap at get-loc ;
: doc-location ( word -- loc ) props>> "help-loc" of get-loc ;
: article-location ( name -- loc ) lookup-article loc>> get-loc ;

4
extra/google/translate/translate.factor
View File

@ -31,8 +31,8 @@ ERROR: response-error response error ;
: query-response>text ( response -- text )
json> check-response
"responseData" swap at
"translatedText" swap at ;
"responseData" of
"translatedText" of ;
: (translate) ( text from to -- text' )
parameters>assoc

2
extra/hacker-news/hacker-news.factor
View File

@ -26,7 +26,7 @@ TUPLE: post title postedBy points id url commentCount postedAgo ;
: hacker-news-items ( -- seq )
"http://api.ihackernews.com/page" http-get nip
json> "items" swap at items> ;
json> "items" of items> ;
: write-title ( title url -- )
'[

6
extra/io/streams/256color/256color.factor
View File

@ -84,9 +84,9 @@ M: 256color stream-nl stream>> stream-nl ;
M: 256color stream-format
[
[ foreground swap at [ color>foreground ] [ "" ] if* ]
[ background swap at [ color>background ] [ "" ] if* ]
[ font-style swap at [ font-styles ] [ "" ] if* ]
[ foreground of [ color>foreground ] [ "" ] if* ]
[ background of [ color>background ] [ "" ] if* ]
[ font-style of [ font-styles ] [ "" ] if* ]
tri 3append [ "\e[0m" surround ] unless-empty
] dip stream>> stream-write ;

2
extra/irc/client/internals/internals-tests.factor
View File

@ -223,7 +223,7 @@ M: mb-writer dispose drop ;
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line
participants>> "ircuser" swap at
participants>> "ircuser" of
] unit-test
] spawning-irc

6
extra/mongodb/connection/connection.factor
View File

@ -32,10 +32,10 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
: master-node ( mdb -- node )
nodes>> t swap at ;
nodes>> t of ;
: slave-node ( mdb -- node )
nodes>> f swap at ;
nodes>> f of ;
: with-connection ( connection quot -- * )
[ mdb-connection ] dip with-variable ; inline
@ -74,7 +74,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: get-nonce ( -- nonce )
getnonce-cmd make-cmd send-cmd
[ "nonce" swap at ] [ f ] if* ;
[ "nonce" of ] [ f ] if* ;
: auth? ( mdb -- ? )
[ username>> ] [ pwd-digest>> ] bi and ;

2
extra/mongodb/driver/driver.factor
View File

@ -105,7 +105,7 @@ SYNTAX: r/
[ mdb-pool get ] dip with-mdb-pool ; inline
: >id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep
[ MDB_OID_FIELD of ] keep
H{ } clone [ set-at ] keep ;
: <mdb> ( db host port -- mdb )

2
extra/oauth/oauth-tests.factor
View File

@ -21,6 +21,6 @@ IN: oauth.tests
54321 >>nonce
<request-token-request>
post-data>>
"oauth_signature" swap at
"oauth_signature" of
>string
] unit-test

14
extra/pdf/canvas/canvas.factor
View File

@ -31,7 +31,7 @@ foreground background page-color inset line-height metrics ;
: set-style ( canvas style -- canvas )
{
[
font-name swap at "sans-serif" or {
font-name of "sans-serif" or {
{ "sans-serif" [ "Helvetica" ] }
{ "serif" [ "Times" ] }
{ "monospace" [ "Courier" ] }
@ -39,21 +39,21 @@ foreground background page-color inset line-height metrics ;
} case [ dup font>> ] dip >>name drop
]
[
font-size swap at 12 or
font-size of 12 or
[ dup font>> ] dip >>size drop
]
[
font-style swap at [ dup font>> ] dip {
font-style of [ dup font>> ] dip {
{ bold [ t f ] }
{ italic [ f t ] }
{ bold-italic [ t t ] }
[ drop f f ]
} case [ >>bold? ] [ >>italic? ] bi* drop
]
[ foreground swap at COLOR: black or >>foreground ]
[ background swap at f or >>background ]
[ page-color swap at f or >>page-color ]
[ inset swap at { 0 0 } or >>inset ]
[ foreground of COLOR: black or >>foreground ]
[ background of f or >>background ]
[ page-color of f or >>page-color ]
[ inset of { 0 0 } or >>inset ]
} cleave
dup font>> font-metrics
[ >>metrics ] [ height>> '[ _ max ] change-line-height ] bi ;

6
extra/quadtrees/quadtrees-tests.factor
View File

@ -61,17 +61,17 @@ IN: quadtrees.tests
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
{ 0.25 0.25 } swap at*
{ 0.25 0.25 } ?of
] unit-test
[ f f ] [
[ { 1.0 1.0 } f ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
{ 1.0 1.0 } swap at*
{ 1.0 1.0 } ?of
] unit-test
[ { "a" "c" } ] [

10
extra/reddit/reddit.factor
View File

@ -30,7 +30,7 @@ display_name id header_img header_size header_title name over18
public_description subscribers title url ;
: parse-data ( assoc -- obj )
[ "data" swap at ] [ "kind" swap at ] bi {
[ "data" of ] [ "kind" of ] bi {
{ "t1" [ comment ] }
{ "t2" [ user ] }
{ "t3" [ story ] }
@ -41,10 +41,10 @@ public_description subscribers title url ;
TUPLE: page url data before after ;
: json-page ( url -- page )
>url dup http-get nip json> "data" swap at {
[ "children" swap at [ parse-data ] map ]
[ "before" swap at [ f ] when-json-null ]
[ "after" swap at [ f ] when-json-null ]
>url dup http-get nip json> "data" of {
[ "children" of [ parse-data ] map ]
[ "before" of [ f ] when-json-null ]
[ "after" of [ f ] when-json-null ]
} cleave \ page boa ;
: get-user ( username -- page )

24
extra/trees/avl/avl-tests.factor
View File

@ -88,7 +88,7 @@ IN: trees.avl.tests
[ "another eight" ] [ ! ERROR!
<avl> "seven" 7 pick set-at
"another eight" 8 pick set-at 8 swap at
"another eight" 8 pick set-at 8 of
] unit-test
: test-tree ( -- tree )
@ -102,16 +102,16 @@ IN: trees.avl.tests
! test set-at, at, at*
[ t ] [ test-tree avl? ] unit-test
[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
[ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
[ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
[ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
[ "nine" ] [ test-tree 9 swap at ] unit-test
[ "replaced four" ] [ test-tree 4 swap at ] unit-test
[ "replaced seven" ] [ test-tree 7 swap at ] unit-test
[ "seven" ] [ <avl> "seven" 7 pick set-at 7 of ] unit-test
[ "seven" t ] [ <avl> "seven" 7 pick set-at 7 ?of ] unit-test
[ 8 f ] [ <avl> "seven" 7 pick set-at 8 ?of ] unit-test
[ "seven" ] [ <avl> "seven" 7 pick set-at 7 of ] unit-test
[ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 of ] unit-test
[ "nine" ] [ test-tree 9 of ] unit-test
[ "replaced four" ] [ test-tree 4 of ] unit-test
[ "replaced seven" ] [ test-tree 7 of ] unit-test
! test delete-at--all errors!
[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
[ f ] [ test-tree 9 over delete-at 9 of ] unit-test
[ "replaced seven" ] [ test-tree 9 over delete-at 7 of ] unit-test
[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 of ] unit-test

4
extra/trees/splay/splay-tests.factor
View File

@ -5,7 +5,7 @@ sequences random sets make grouping ;
IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
100 iota [ drop 100 random swap at drop ] with each ;
100 iota [ drop 100 random of drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
iota <splay> [ [ conjoin ] curry each ] keep ;
@ -18,7 +18,7 @@ IN: trees.splay.tests
[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test
[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test
[ f ] [ <splay> f 4 pick set-at 4 swap at ] unit-test
[ f ] [ <splay> f 4 pick set-at 4 of ] unit-test
! Ensure that f can be a value
[ t ] [ <splay> f 4 pick set-at 4 swap key? ] unit-test

22
extra/trees/trees-tests.factor
View File

@ -11,17 +11,17 @@ IN: trees.tests
} clone ;
! test set-at, at, at*
[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
[ "seven" t ] [ <tree> "seven" 7 pick set-at 7 swap at* ] unit-test
[ f f ] [ <tree> "seven" 7 pick set-at 8 swap at* ] unit-test
[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
[ "replacement" ] [ <tree> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
[ "replaced four" ] [ test-tree 4 swap at ] unit-test
[ "nine" ] [ test-tree 9 swap at ] unit-test
[ "seven" ] [ <tree> "seven" 7 pick set-at 7 of ] unit-test
[ "seven" t ] [ <tree> "seven" 7 pick set-at 7 ?of ] unit-test
[ 8 f ] [ <tree> "seven" 7 pick set-at 8 ?of ] unit-test
[ "seven" ] [ <tree> "seven" 7 pick set-at 7 of ] unit-test
[ "replacement" ] [ <tree> "seven" 7 pick set-at "replacement" 7 pick set-at 7 of ] unit-test
[ "replaced four" ] [ test-tree 4 of ] unit-test
[ "nine" ] [ test-tree 9 of ] unit-test
! test delete-at
[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test
[ f ] [ test-tree 9 over delete-at 9 of ] unit-test
[ "replaced seven" ] [ test-tree 9 over delete-at 7 of ] unit-test
[ "replaced four" ] [ test-tree 9 over delete-at 4 of ] unit-test
[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test
[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 of ] unit-test

2
extra/twitter/twitter.factor
View File

@ -50,7 +50,7 @@ PRIVATE>
! Utilities
MACRO: keys-boa ( keys class -- )
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
[ [ '[ _ of ] ] map ] dip '[ _ cleave _ boa ] ;
! Twitter requests
: status-url ( string -- url )