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

using the new H{ } make.

db4
John Benediktsson 2012-07-19 09:50:09 -07:00
parent 04320d27f4
commit 559b5bfa5b
21 changed files with 110 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/cocoa/subclassing/subclassing.factor
View File

@ -92,7 +92,7 @@ SYNTAX: CLASS:
[ sift { "self" "selector" } prepend ] tri* ; [ sift { "self" "selector" } prepend ] tri* ;
: parse-method-body ( names -- quot ) : parse-method-body ( names -- quot )
[ [ make-local ] map ] H{ } make-assoc [ [ make-local ] map ] H{ } make
(parse-lambda) <lambda> ?rewrite-closures first ; (parse-lambda) <lambda> ?rewrite-closures first ;
SYNTAX: METHOD: SYNTAX: METHOD:

6
basis/compiler/cfg/builder/builder.factor
View File

@ -180,9 +180,9 @@ M: #push emit-node
: make-input-map ( #shuffle -- assoc ) : make-input-map ( #shuffle -- assoc )
! Assoc maps high-level IR values to stack locations. ! Assoc maps high-level IR values to stack locations.
[ [
[ in-d>> <reversed> [ <ds-loc> swap set ] each-index ] [ in-d>> <reversed> [ <ds-loc> swap ,, ] each-index ]
[ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi [ in-r>> <reversed> [ <rs-loc> swap ,, ] each-index ] bi
] H{ } make-assoc ; ] H{ } make ;
: make-output-seq ( values mapping input-map -- vregs ) : make-output-seq ( values mapping input-map -- vregs )
'[ _ at _ at peek-loc ] map ; '[ _ at _ at peek-loc ] map ;

8
basis/core-text/core-text.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.data alien.syntax kernel USING: arrays alien alien.c-types alien.data alien.syntax kernel
destructors accessors fry words hashtables strings sequences destructors accessors fry words hashtables strings sequences
memoize assocs math math.order math.vectors math.rectangles memoize assocs make math math.order math.vectors math.rectangles
math.functions locals init namespaces combinators fonts colors math.functions locals init namespaces combinators fonts colors
cache core-foundation core-foundation.strings cache core-foundation core-foundation.strings
core-foundation.attributed-strings core-foundation.utilities core-foundation.attributed-strings core-foundation.utilities
@ -41,9 +41,9 @@ ERROR: not-a-string object ;
dup string? [ not-a-string ] unless dup string? [ not-a-string ] unless
] 2dip ] 2dip
[ [
kCTForegroundColorAttributeName set kCTForegroundColorAttributeName ,,
kCTFontAttributeName set kCTFontAttributeName ,,
] H{ } make-assoc <CFAttributedString> &CFRelease ] H{ } make <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString CTLineCreateWithAttributedString
] with-destructors ; ] with-destructors ;

18
basis/functors/functors.factor
View File

@ -147,23 +147,19 @@ DEFER: ;FUNCTOR delimiter
: pop-functor-words ( -- ) : pop-functor-words ( -- )
functor-words unuse-words ; functor-words unuse-words ;
: (parse-bindings) ( end -- ) : (parse-bindings) ( end -- words )
dup parse-binding dup [ [ dup parse-binding dup ]
first2 [ make-local ] dip 2array , [ first2 [ make-local ] dip 2array ]
(parse-bindings) produce 2nip ;
] [ 2drop ] if ;
: with-bindings ( quot -- words assoc ) : with-bindings ( quot -- words assoc )
'[ in-lambda? on H{ } make ; inline
in-lambda? on
_ H{ } make-assoc
] { } make swap ; inline
: parse-bindings ( end -- words assoc ) : parse-bindings ( end -- words assoc )
[ [
namespace use-words building get use-words
(parse-bindings) (parse-bindings)
namespace unuse-words building get unuse-words
] with-bindings ; ] with-bindings ;
: parse-functor-body ( -- form ) : parse-functor-body ( -- form )

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

@ -156,10 +156,10 @@ TUPLE: couchdb-auth-provider
: (new-user) ( user -- user/f ) : (new-user) ( user -- user/f )
dup dup
[ [
[ username>> "username" set ] [ username>> "username" ,, ]
[ email>> "email" set ] [ email>> "email" ,, ]
bi bi
] H{ } make-assoc ] H{ } make
reserve-multiple reserve-multiple
[ [
user>user-hash >json user>user-hash >json
@ -203,22 +203,19 @@ PRIVATE>
couchdb-auth-provider new swap >>username-view swap >>base-url ; couchdb-auth-provider new swap >>username-view swap >>base-url ;
M: couchdb-auth-provider get-user ( username provider -- user/f ) M: couchdb-auth-provider get-user ( username provider -- user/f )
[ couchdb-auth-provider [
couchdb-auth-provider set
(get-user) [ user-hash>user ] [ f ] if* (get-user) [ user-hash>user ] [ f ] if*
] with-scope ; ] with-variable ;
M: couchdb-auth-provider new-user ( user provider -- user/f ) M: couchdb-auth-provider new-user ( user provider -- user/f )
[ couchdb-auth-provider [
couchdb-auth-provider set
dup (new-user) [ dup (new-user) [
username>> couchdb-auth-provider get get-user username>> couchdb-auth-provider get get-user
] [ drop f ] if ] [ drop f ] if
] with-scope ; ] with-variable ;
M: couchdb-auth-provider update-user ( user provider -- ) M: couchdb-auth-provider update-user ( user provider -- )
[ couchdb-auth-provider [
couchdb-auth-provider set
[ username>> (get-user)/throw-on-no-user dup ] [ username>> (get-user)/throw-on-no-user dup ]
[ drop "_id" swap at get-url ] [ drop "_id" swap at get-url ]
[ user>user-hash swapd [ user>user-hash swapd
@ -226,4 +223,4 @@ M: couchdb-auth-provider update-user ( user provider -- )
unify-users >json swap couch-put drop unify-users >json swap couch-put drop
] ]
tri tri
] with-scope ; ] with-variable ;

18
basis/locals/parser/parser.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. ! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators effects.parser USING: accessors arrays assocs combinators effects.parser
generic.parser kernel lexer locals.errors fry generic.parser kernel lexer locals.errors fry
locals.rewrite.closures locals.types make namespaces parser locals.rewrite.closures locals.types make namespaces parser
quotations sequences splitting words vocabs.parser ; quotations sequences splitting words vocabs.parser ;
@ -14,15 +14,15 @@ SYMBOL: in-lambda?
: make-local ( name -- word ) : make-local ( name -- word )
"!" ?tail [ "!" ?tail [
<local-reader> <local-reader>
dup <local-writer> dup name>> set dup <local-writer> dup name>> ,,
] [ <local> ] if ] [ <local> ] if
dup dup name>> set ; dup dup name>> ,, ;
: make-locals ( seq -- words assoc ) : make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ; [ [ make-local ] map ] H{ } make ;
: parse-local-defs ( -- words assoc ) : parse-local-defs ( -- words assoc )
[ "|" [ make-local ] map-tokens ] H{ } make-assoc ; [ "|" [ make-local ] map-tokens ] H{ } make ;
SINGLETON: lambda-parser SINGLETON: lambda-parser
@ -46,10 +46,14 @@ SYMBOL: locals
?rewrite-closures ; ?rewrite-closures ;
: parse-multi-def ( locals -- multi-def ) : parse-multi-def ( locals -- multi-def )
[ ")" [ make-local ] map-tokens ] with-variables <multi-def> ; [ [ ")" [ make-local ] map-tokens ] H{ } make ] dip
swap assoc-union! drop <multi-def> ;
: parse-def ( name/paren locals -- def ) : parse-def ( name/paren locals -- def )
over "(" = [ nip parse-multi-def ] [ [ make-local ] with-variables <def> ] if ; over "(" =
[ nip parse-multi-def ]
[ [ [ make-local ] H{ } make ] dip swap assoc-union! drop <def> ]
if ;
M: lambda-parser parse-quotation ( -- quotation ) M: lambda-parser parse-quotation ( -- quotation )
H{ } clone (parse-lambda) ; H{ } clone (parse-lambda) ;

21
basis/smtp/smtp.factor
View File

@ -7,7 +7,6 @@ io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
kernel logging sequences combinators splitting assocs strings kernel logging sequences combinators splitting assocs strings
math.order math.parser random system calendar summary calendar.format math.order math.parser random system calendar summary calendar.format
accessors sets hashtables base64 debugger classes prettyprint words ; accessors sets hashtables base64 debugger classes prettyprint words ;
FROM: namespaces => set ;
IN: smtp IN: smtp
SYMBOL: smtp-domain SYMBOL: smtp-domain
@ -194,18 +193,18 @@ ERROR: invalid-header-string string ;
: email>headers ( email -- assoc ) : email>headers ( email -- assoc )
[ [
now timestamp>rfc822 "Date" set now timestamp>rfc822 "Date" ,,
message-id "Message-Id" set message-id "Message-Id" ,,
"1.0" "MIME-Version" set "1.0" "MIME-Version" ,,
"base64" "Content-Transfer-Encoding" set "base64" "Content-Transfer-Encoding" ,,
{ {
[ from>> "From" set ] [ from>> "From" ,, ]
[ to>> ", " join "To" set ] [ to>> ", " join "To" ,, ]
[ cc>> ", " join [ "Cc" set ] unless-empty ] [ cc>> ", " join [ "Cc" ,, ] unless-empty ]
[ subject>> "Subject" set ] [ subject>> "Subject" ,, ]
[ email-content-type "Content-Type" set ] [ email-content-type "Content-Type" ,, ]
} cleave } cleave
] { } make-assoc ; ] H{ } make ;
: (send-email) ( headers email -- ) : (send-email) ( headers email -- )
[ [

14
basis/tools/deploy/macosx/macosx.factor
View File

@ -22,16 +22,16 @@ IN: tools.deploy.macosx
: app-plist ( icon? executable bundle-name -- assoc ) : app-plist ( icon? executable bundle-name -- assoc )
[ [
"6.0" "CFBundleInfoDictionaryVersion" set "6.0" "CFBundleInfoDictionaryVersion" ,,
"APPL" "CFBundlePackageType" set "APPL" "CFBundlePackageType" ,,
file-name "CFBundleName" set file-name "CFBundleName" ,,
[ "CFBundleExecutable" set ] [ "CFBundleExecutable" ,, ]
[ "org.factor." prepend "CFBundleIdentifier" set ] bi [ "org.factor." prepend "CFBundleIdentifier" ,, ] bi
[ "Icon.icns" "CFBundleIconFile" set ] when [ "Icon.icns" "CFBundleIconFile" ,, ] when
] H{ } make-assoc ; ] H{ } make ;
: create-app-plist ( icon? executable bundle-name -- ) : create-app-plist ( icon? executable bundle-name -- )
[ app-plist ] keep [ app-plist ] keep

8
basis/ui/commands/commands.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces make quotations math assocs words generic make quotations splitting
splitting ui.gestures unicode.case unicode.categories tr fry ; ui.gestures unicode.case unicode.categories tr fry ;
IN: ui.commands IN: ui.commands
SYMBOL: +nullary+ SYMBOL: +nullary+
@ -37,9 +37,9 @@ GENERIC: command-word ( command -- word )
[ [
commands>> commands>>
[ drop ] assoc-filter [ drop ] assoc-filter
[ '[ _ invoke-command ] swap set ] assoc-each [ '[ _ invoke-command ] swap ,, ] assoc-each
] each ] each
] H{ } make-assoc ; ] H{ } make ;
: update-gestures ( class -- ) : update-gestures ( class -- )
dup command-gestures set-gestures ; dup command-gestures set-gestures ;

8
basis/ui/tools/listener/listener.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays assocs calendar combinators locals
source-files.errors colors.constants combinators.short-circuit source-files.errors colors.constants combinators.short-circuit
compiler.units help.tips concurrency.flags concurrency.mailboxes compiler.units help.tips concurrency.flags concurrency.mailboxes
continuations destructors documents documents.elements fry hashtables continuations destructors documents documents.elements fry hashtables
help help.markup io io.styles kernel lexer listener math models sets help help.markup io io.styles kernel lexer listener make math models sets
models.delay models.arrow namespaces parser prettyprint quotations models.delay models.arrow namespaces parser prettyprint quotations
sequences strings threads vocabs vocabs.refresh vocabs.loader sequences strings threads vocabs vocabs.refresh vocabs.loader
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
@ -103,9 +103,9 @@ M: input (print-input)
M: word (print-input) M: word (print-input)
"Command: " "Command: "
[ [
"sans-serif" font-name set "sans-serif" font-name ,,
bold font-style set bold font-style ,,
] H{ } make-assoc format . ; ] H{ } make format . ;
: print-input ( object interactor -- ) : print-input ( object interactor -- )
output>> [ (print-input) ] with-output-stream* ; output>> [ (print-input) ] with-output-stream* ;

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

@ -6,7 +6,6 @@ math.parser math.order byte-arrays namespaces math.bitwise
compiler.units parser io.encodings.ascii interval-maps compiler.units parser io.encodings.ascii interval-maps
ascii sets combinators locals math.ranges sorting make ascii sets combinators locals math.ranges sorting make
strings.parser io.encodings.utf8 memoize simple-flat-file ; strings.parser io.encodings.utf8 memoize simple-flat-file ;
FROM: namespaces => set ;
IN: unicode.data IN: unicode.data
<PRIVATE <PRIVATE
@ -174,7 +173,7 @@ C: <code-point> code-point
: set-code-point ( seq -- ) : set-code-point ( seq -- )
4 head [ multihex ] map first4 4 head [ multihex ] map first4
<code-point> swap first set ; <code-point> swap first ,, ;
! Extra properties ! Extra properties
: parse-properties ( -- {{[a,b],prop}} ) : parse-properties ( -- {{[a,b],prop}} )
@ -197,7 +196,7 @@ C: <code-point> code-point
: load-special-casing ( -- special-casing ) : load-special-casing ( -- special-casing )
"vocab:unicode/data/SpecialCasing.txt" data "vocab:unicode/data/SpecialCasing.txt" data
[ length 5 = ] filter [ length 5 = ] filter
[ [ set-code-point ] each ] H{ } make-assoc ; [ [ set-code-point ] each ] H{ } make ;
load-data { load-data {
[ process-names name-map swap assoc-union! drop ] [ process-names name-map swap assoc-union! drop ]

6
core/classes/algebra/algebra.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2010 Slava Pestov. ! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.private USING: accessors arrays assocs classes classes.private
combinators kernel math math.order namespaces sequences sorting combinators kernel make math math.order namespaces sequences
vectors words ; sorting vectors words ;
FROM: classes => members ; FROM: classes => members ;
RENAME: members sets => set-members RENAME: members sets => set-members
IN: classes.algebra IN: classes.algebra
@ -285,4 +285,4 @@ ERROR: topological-sort-failed ;
] if-empty ; ] if-empty ;
: flatten-class ( class -- assoc ) : flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ; [ (flatten-class) ] H{ } make ;

4
core/classes/builtin/builtin.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2010 Slava Pestov. ! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra.private classes.private kernel USING: classes classes.algebra.private classes.private kernel
kernel.private namespaces sequences words ; kernel.private make namespaces sequences words ;
IN: classes.builtin IN: classes.builtin
SYMBOL: builtins SYMBOL: builtins
@ -21,7 +21,7 @@ M: builtin-class rank-class drop 0 ;
M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ; M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
M: builtin-class (flatten-class) dup set ; M: builtin-class (flatten-class) dup ,, ;
M: builtin-class (classes-intersect?) eq? ; M: builtin-class (classes-intersect?) eq? ;

10
core/classes/classes.factor
View File

@ -154,12 +154,12 @@ M: sequence implementors [ implementors ] gather ;
: make-class-props ( superclass members participants metaclass -- assoc ) : make-class-props ( superclass members participants metaclass -- assoc )
[ [
{ {
[ dup [ bootstrap-word ] when "superclass" set ] [ dup [ bootstrap-word ] when "superclass" ,, ]
[ [ bootstrap-word ] map "members" set ] [ [ bootstrap-word ] map "members" ,, ]
[ [ bootstrap-word ] map "participants" set ] [ [ bootstrap-word ] map "participants" ,, ]
[ "metaclass" set ] [ "metaclass" ,, ]
} spread } spread
] H{ } make-assoc ; ] H{ } make ;
GENERIC: metaclass-changed ( use class -- ) GENERIC: metaclass-changed ( use class -- )

4
core/classes/intersection/intersection.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: words accessors sequences kernel assocs combinators USING: words accessors sequences kernel assocs combinators
classes classes.private classes.algebra classes.algebra.private classes classes.private classes.algebra classes.algebra.private
classes.builtin namespaces arrays math quotations ; classes.builtin namespaces arrays math quotations make ;
IN: classes.intersection IN: classes.intersection
PREDICATE: intersection-class < class PREDICATE: intersection-class < class
@ -48,7 +48,7 @@ M: anonymous-intersection (flatten-class)
participants>> [ full-cover ] [ participants>> [ full-cover ] [
[ flatten-class keys ] [ flatten-class keys ]
[ intersect-flattened-classes ] map-reduce [ intersect-flattened-classes ] map-reduce
[ dup set ] each [ dup ,, ] each
] if-empty ; ] if-empty ;
M: anonymous-intersection class-name M: anonymous-intersection class-name

2
core/classes/tuple/tuple.factor
View File

@ -344,7 +344,7 @@ M: tuple-class rank-class drop 1 ;
M: tuple-class instance? M: tuple-class instance?
dup echelon-of layout-class-offset tuple-instance? ; dup echelon-of layout-class-offset tuple-instance? ;
M: tuple-class (flatten-class) dup set ; M: tuple-class (flatten-class) dup ,, ;
M: tuple-class (classes-intersect?) M: tuple-class (classes-intersect?)
{ {

7
core/generic/generic.factor
View File

@ -4,7 +4,6 @@ USING: accessors arrays assocs classes classes.algebra
classes.algebra.private classes.maybe classes.private classes.algebra.private classes.maybe classes.private
combinators definitions kernel make namespaces sequences sets combinators definitions kernel make namespaces sequences sets
words ; words ;
FROM: namespaces => set ;
IN: generic IN: generic
! Method combination protocol ! Method combination protocol
@ -118,9 +117,9 @@ M: method crossref?
: method-word-props ( class generic -- assoc ) : method-word-props ( class generic -- assoc )
[ [
"method-generic" set "method-generic" ,,
"method-class" set "method-class" ,,
] H{ } make-assoc ; ] H{ } make ;
: <method> ( class generic -- method ) : <method> ( class generic -- method )
check-method check-method

24
extra/benchmark/partial-sums/partial-sums.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math math.functions kernel io io.styles prettyprint USING: make math math.functions kernel io io.styles prettyprint
combinators hints fry namespaces sequences ; combinators hints fry sequences ;
IN: benchmark.partial-sums IN: benchmark.partial-sums
! Helper words ! Helper words
@ -24,17 +24,17 @@ IN: benchmark.partial-sums
: partial-sums ( n -- results ) : partial-sums ( n -- results )
[ [
{ {
[ 2/3^k \ 2/3^k set ] [ 2/3^k \ 2/3^k ,, ]
[ k^-0.5 \ k^-0.5 set ] [ k^-0.5 \ k^-0.5 ,, ]
[ 1/k(k+1) \ 1/k(k+1) set ] [ 1/k(k+1) \ 1/k(k+1) ,, ]
[ flint-hills \ flint-hills set ] [ flint-hills \ flint-hills ,, ]
[ cookson-hills \ cookson-hills set ] [ cookson-hills \ cookson-hills ,, ]
[ harmonic \ harmonic set ] [ harmonic \ harmonic ,, ]
[ riemann-zeta \ riemann-zeta set ] [ riemann-zeta \ riemann-zeta ,, ]
[ alternating-harmonic \ alternating-harmonic set ] [ alternating-harmonic \ alternating-harmonic ,, ]
[ gregory \ gregory set ] [ gregory \ gregory ,, ]
} cleave } cleave
] { } make-assoc ; ] { } make ;
HINTS: partial-sums fixnum ; HINTS: partial-sums fixnum ;

6
extra/html/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables sequences.parser USING: accessors arrays hashtables sequences.parser
html.parser.utils kernel namespaces sequences math html.parser.utils kernel namespaces sequences make math
unicode.case unicode.categories combinators.short-circuit unicode.case unicode.categories combinators.short-circuit
quoting fry ; quoting fry ;
IN: html.parser IN: html.parser
@ -94,11 +94,11 @@ SYMBOL: tagstack
dup sequence-parse-end? [ dup sequence-parse-end? [
drop drop
] [ ] [
[ parse-key/value swap set ] [ (parse-attributes) ] bi [ parse-key/value swap ,, ] [ (parse-attributes) ] bi
] if ; ] if ;
: parse-attributes ( sequence-parser -- hashtable ) : parse-attributes ( sequence-parser -- hashtable )
[ (parse-attributes) ] H{ } make-assoc ; [ (parse-attributes) ] H{ } make ;
: (parse-tag) ( string -- string' hashtable ) : (parse-tag) ( string -- string' hashtable )
[ [

6
extra/multi-methods/multi-methods.factor
View File

@ -164,9 +164,9 @@ M: method-body crossref?
: method-word-props ( specializer generic -- assoc ) : method-word-props ( specializer generic -- assoc )
[ [
"multi-method-generic" set "multi-method-generic" ,,
"multi-method-specializer" set "multi-method-specializer" ,,
] H{ } make-assoc ; ] H{ } make ;
: <method> ( specializer generic -- word ) : <method> ( specializer generic -- word )
[ method-word-props ] 2keep [ method-word-props ] 2keep

22
extra/oauth/oauth.factor
View File

@ -40,17 +40,17 @@ nonce ;
: make-token-params ( params quot -- assoc ) : make-token-params ( params quot -- assoc )
'[ '[
"1.0" "oauth_version" set "1.0" "oauth_version" ,,
"HMAC-SHA1" "oauth_signature_method" set "HMAC-SHA1" "oauth_signature_method" ,,
_ _
[ [
[ consumer-token>> key>> "oauth_consumer_key" set ] [ consumer-token>> key>> "oauth_consumer_key" ,, ]
[ timestamp>> "oauth_timestamp" set ] [ timestamp>> "oauth_timestamp" ,, ]
[ nonce>> "oauth_nonce" set ] [ nonce>> "oauth_nonce" ,, ]
tri tri
] bi ] bi
] H{ } make-assoc ; inline ] H{ } make ; inline
:: sign-params ( url request-method consumer-token request-token params -- signed-params ) :: sign-params ( url request-method consumer-token request-token params -- signed-params )
params sort-keys :> params params sort-keys :> params
@ -90,7 +90,7 @@ TUPLE: request-token-params < token-params
<post-request> ; <post-request> ;
: make-request-token-params ( params -- assoc ) : make-request-token-params ( params -- assoc )
[ callback-url>> "oauth_callback" set ] make-token-params ; [ callback-url>> "oauth_callback" ,, ] make-token-params ;
: <request-token-request> ( url params -- request ) : <request-token-request> ( url params -- request )
[ consumer-token>> f ] [ make-request-token-params ] bi [ consumer-token>> f ] [ make-request-token-params ] bi
@ -110,8 +110,8 @@ TUPLE: access-token-params < token-params request-token verifier ;
: make-access-token-params ( params -- assoc ) : make-access-token-params ( params -- assoc )
[ [
[ request-token>> key>> "oauth_token" set ] [ request-token>> key>> "oauth_token" ,, ]
[ verifier>> "oauth_verifier" set ] [ verifier>> "oauth_verifier" ,, ]
bi bi
] make-token-params ; ] make-token-params ;
@ -143,8 +143,8 @@ TUPLE: oauth-request-params < token-params access-token ;
params access-token>> params access-token>>
params params
[ [
access-token>> key>> "oauth_token" set access-token>> key>> "oauth_token" ,,
namespace request post-data>> assoc-union! drop request post-data>> %%
] make-token-params ] make-token-params
sign-params ; sign-params ;