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

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

@ -58,7 +58,7 @@ IN: cocoa.subclassing
] [
class sel imp types add-method
] if* ;
: redefine-objc-methods ( methods name -- )
dup class-exists? [
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
@ -92,7 +92,7 @@ SYNTAX: CLASS:
[ sift { "self" "selector" } prepend ] tri* ;
: parse-method-body ( names -- quot )
[ [ make-local ] map ] H{ } make-assoc
[ [ make-local ] map ] H{ } make
(parse-lambda) <lambda> ?rewrite-closures first ;
SYNTAX: METHOD:

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

@ -180,9 +180,9 @@ M: #push emit-node
: make-input-map ( #shuffle -- assoc )
! Assoc maps high-level IR values to stack locations.
[
[ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
[ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
] H{ } make-assoc ;
[ in-d>> <reversed> [ <ds-loc> swap ,, ] each-index ]
[ in-r>> <reversed> [ <rs-loc> swap ,, ] each-index ] bi
] H{ } make ;
: make-output-seq ( values mapping input-map -- vregs )
'[ _ 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.
USING: arrays alien alien.c-types alien.data alien.syntax kernel
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
cache core-foundation core-foundation.strings
core-foundation.attributed-strings core-foundation.utilities
@ -41,9 +41,9 @@ ERROR: not-a-string object ;
dup string? [ not-a-string ] unless
] 2dip
[
kCTForegroundColorAttributeName set
kCTFontAttributeName set
] H{ } make-assoc <CFAttributedString> &CFRelease
kCTForegroundColorAttributeName ,,
kCTFontAttributeName ,,
] H{ } make <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString
] with-destructors ;

18
basis/functors/functors.factor
View File

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

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

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

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

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
! 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
locals.rewrite.closures locals.types make namespaces parser
quotations sequences splitting words vocabs.parser ;
@ -14,15 +14,15 @@ SYMBOL: in-lambda?
: make-local ( name -- word )
"!" ?tail [
<local-reader>
dup <local-writer> dup name>> set
dup <local-writer> dup name>> ,,
] [ <local> ] if
dup dup name>> set ;
dup dup name>> ,, ;
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
[ [ make-local ] map ] H{ } make ;
: parse-local-defs ( -- words assoc )
[ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
[ "|" [ make-local ] map-tokens ] H{ } make ;
SINGLETON: lambda-parser
@ -36,7 +36,7 @@ SYMBOL: locals
[ use-words @ ]
[ unuse-words ] tri
] with-scope ; inline
: (parse-lambda) ( assoc -- quot )
[ \ ] parse-until >quotation ] ((parse-lambda)) ;
@ -46,10 +46,14 @@ SYMBOL: locals
?rewrite-closures ;
: 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 )
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 )
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
math.order math.parser random system calendar summary calendar.format
accessors sets hashtables base64 debugger classes prettyprint words ;
FROM: namespaces => set ;
IN: smtp
SYMBOL: smtp-domain
@ -194,18 +193,18 @@ ERROR: invalid-header-string string ;
: email>headers ( email -- assoc )
[
now timestamp>rfc822 "Date" set
message-id "Message-Id" set
"1.0" "MIME-Version" set
"base64" "Content-Transfer-Encoding" set
now timestamp>rfc822 "Date" ,,
message-id "Message-Id" ,,
"1.0" "MIME-Version" ,,
"base64" "Content-Transfer-Encoding" ,,
{
[ from>> "From" set ]
[ to>> ", " join "To" set ]
[ cc>> ", " join [ "Cc" set ] unless-empty ]
[ subject>> "Subject" set ]
[ email-content-type "Content-Type" set ]
[ from>> "From" ,, ]
[ to>> ", " join "To" ,, ]
[ cc>> ", " join [ "Cc" ,, ] unless-empty ]
[ subject>> "Subject" ,, ]
[ email-content-type "Content-Type" ,, ]
} cleave
] { } make-assoc ;
] H{ } make ;
: (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 )
[
"6.0" "CFBundleInfoDictionaryVersion" set
"APPL" "CFBundlePackageType" set
"6.0" "CFBundleInfoDictionaryVersion" ,,
"APPL" "CFBundlePackageType" ,,
file-name "CFBundleName" set
file-name "CFBundleName" ,,
[ "CFBundleExecutable" set ]
[ "org.factor." prepend "CFBundleIdentifier" set ] bi
[ "CFBundleExecutable" ,, ]
[ "org.factor." prepend "CFBundleIdentifier" ,, ] bi
[ "Icon.icns" "CFBundleIconFile" set ] when
] H{ } make-assoc ;
[ "Icon.icns" "CFBundleIconFile" ,, ] when
] H{ } make ;
: create-app-plist ( icon? executable bundle-name -- )
[ app-plist ] keep

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

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces make quotations
splitting ui.gestures unicode.case unicode.categories tr fry ;
math assocs words generic make quotations splitting
ui.gestures unicode.case unicode.categories tr fry ;
IN: ui.commands
SYMBOL: +nullary+
@ -37,9 +37,9 @@ GENERIC: command-word ( command -- word )
[
commands>>
[ drop ] assoc-filter
[ '[ _ invoke-command ] swap set ] assoc-each
[ '[ _ invoke-command ] swap ,, ] assoc-each
] each
] H{ } make-assoc ;
] H{ } make ;
: update-gestures ( class -- )
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
compiler.units help.tips concurrency.flags concurrency.mailboxes
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
sequences strings threads vocabs vocabs.refresh vocabs.loader
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
@ -103,9 +103,9 @@ M: input (print-input)
M: word (print-input)
"Command: "
[
"sans-serif" font-name set
bold font-style set
] H{ } make-assoc format . ;
"sans-serif" font-name ,,
bold font-style ,,
] H{ } make format . ;
: print-input ( object interactor -- )
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
ascii sets combinators locals math.ranges sorting make
strings.parser io.encodings.utf8 memoize simple-flat-file ;
FROM: namespaces => set ;
IN: unicode.data
<PRIVATE
@ -174,7 +173,7 @@ C: <code-point> code-point
: set-code-point ( seq -- )
4 head [ multihex ] map first4
<code-point> swap first set ;
<code-point> swap first ,, ;
! Extra properties
: parse-properties ( -- {{[a,b],prop}} )
@ -197,7 +196,7 @@ C: <code-point> code-point
: load-special-casing ( -- special-casing )
"vocab:unicode/data/SpecialCasing.txt" data
[ length 5 = ] filter
[ [ set-code-point ] each ] H{ } make-assoc ;
[ [ set-code-point ] each ] H{ } make ;
load-data {
[ 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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.private
combinators kernel math math.order namespaces sequences sorting
vectors words ;
combinators kernel make math math.order namespaces sequences
sorting vectors words ;
FROM: classes => members ;
RENAME: members sets => set-members
IN: classes.algebra
@ -285,4 +285,4 @@ ERROR: topological-sort-failed ;
] if-empty ;
: 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.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra.private classes.private kernel
kernel.private namespaces sequences words ;
kernel.private make namespaces sequences words ;
IN: classes.builtin
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 (flatten-class) dup set ;
M: builtin-class (flatten-class) dup ,, ;
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 )
[
{
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
[ [ bootstrap-word ] map "participants" set ]
[ "metaclass" set ]
[ dup [ bootstrap-word ] when "superclass" ,, ]
[ [ bootstrap-word ] map "members" ,, ]
[ [ bootstrap-word ] map "participants" ,, ]
[ "metaclass" ,, ]
} spread
] H{ } make-assoc ;
] H{ } make ;
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.
USING: words accessors sequences kernel assocs combinators
classes classes.private classes.algebra classes.algebra.private
classes.builtin namespaces arrays math quotations ;
classes.builtin namespaces arrays math quotations make ;
IN: classes.intersection
PREDICATE: intersection-class < class
@ -48,7 +48,7 @@ M: anonymous-intersection (flatten-class)
participants>> [ full-cover ] [
[ flatten-class keys ]
[ intersect-flattened-classes ] map-reduce
[ dup set ] each
[ dup ,, ] each
] if-empty ;
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?
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?)
{

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
combinators definitions kernel make namespaces sequences sets
words ;
FROM: namespaces => set ;
IN: generic
! Method combination protocol
@ -118,9 +117,9 @@ M: method crossref?
: method-word-props ( class generic -- assoc )
[
"method-generic" set
"method-class" set
] H{ } make-assoc ;
"method-generic" ,,
"method-class" ,,
] H{ } make ;
: <method> ( class generic -- method )
check-method

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

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
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
quoting fry ;
IN: html.parser
@ -94,11 +94,11 @@ SYMBOL: tagstack
dup sequence-parse-end? [
drop
] [
[ parse-key/value swap set ] [ (parse-attributes) ] bi
[ parse-key/value swap ,, ] [ (parse-attributes) ] bi
] if ;
: parse-attributes ( sequence-parser -- hashtable )
[ (parse-attributes) ] H{ } make-assoc ;
[ (parse-attributes) ] H{ } make ;
: (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 )
[
"multi-method-generic" set
"multi-method-specializer" set
] H{ } make-assoc ;
"multi-method-generic" ,,
"multi-method-specializer" ,,
] H{ } make ;
: <method> ( specializer generic -- word )
[ method-word-props ] 2keep

22
extra/oauth/oauth.factor
View File

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