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

Merge branch 'master' into native-image-loader

db4
Joe Groff 2010-07-07 13:06:37 -07:00
parent 8816b1e215 f82c6e14ad
commit 8a7979da13
67 changed files with 1822 additions and 335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
Factor.app/Contents/Resources/Factor.icns
View File

Binary file not shown.

72
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -287,3 +287,75 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##compare f 6 5 1 cc= }
} test-alias-analysis
] unit-test
! We can't make any assumptions about heap-ac between alien
! calls, since they might callback into Factor code
[
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 1 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 1 0 1 0 }
} test-alias-analysis
] unit-test

38
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -186,6 +186,15 @@ SYMBOL: heap-ac
slot# vreg kill-constant-set-slot
] [ vreg kill-computed-set-slot ] if ;
: init-alias-analysis ( -- )
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone copies set
H{ } clone recent-stores set
HS{ } clone dead-stores set
0 ac-counter set ;
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
@ -277,22 +286,6 @@ M: ##compare analyze-aliases
analyze-aliases
] when ;
GENERIC: eliminate-dead-stores ( insn -- ? )
M: ##set-slot-imm eliminate-dead-stores
insn#>> dead-stores get in? not ;
M: insn eliminate-dead-stores drop t ;
: init-alias-analysis ( -- )
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone copies set
H{ } clone recent-stores set
HS{ } clone dead-stores set
0 ac-counter set ;
: reset-alias-analysis ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
@ -305,6 +298,19 @@ M: insn eliminate-dead-stores drop t ;
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac ;
M: factor-call-insn analyze-aliases
heap-ac get ac>vregs [
[ live-slots get at clear-assoc ]
[ recent-stores get at clear-assoc ] bi
] each ;
GENERIC: eliminate-dead-stores ( insn -- ? )
M: ##set-slot-imm eliminate-dead-stores
insn#>> dead-stores get in? not ;
M: insn eliminate-dead-stores drop t ;
: alias-analysis-step ( insns -- insns' )
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]

26
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit kernel
math math.order sequences assocs namespaces vectors fry arrays
splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
compiler.cfg.predecessors compiler.cfg.renaming
locals math math.order sequences assocs namespaces vectors fry
arrays splitting compiler.cfg.def-use compiler.cfg
compiler.cfg.rpo compiler.cfg.predecessors compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
@ -29,24 +29,18 @@ IN: compiler.cfg.branch-splitting
1vector >>predecessors
] with map ;
: update-predecessor-successor ( pred copy old-bb -- )
'[
[ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
] change-successors drop ;
: update-predecessor-successors ( copies old-bb -- )
[ predecessors>> swap ] keep
'[ _ update-predecessor-successor ] 2each ;
'[ [ _ ] 2dip update-predecessors ] 2each ;
: update-successor-predecessor ( copies old-bb succ -- )
[
swap 1array split swap join V{ } like
] change-predecessors drop ;
:: update-successor-predecessor ( copies old-bb succ -- )
succ
[ { old-bb } split copies join V{ } like ] change-predecessors
drop ;
: update-successor-predecessors ( copies old-bb -- )
dup successors>> [
update-successor-predecessor
] with with each ;
dup successors>>
[ update-successor-predecessor ] with with each ;
: split-branch ( bb -- )
[ new-blocks ] keep

122
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -1,25 +1,26 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays layouts math math.order math.parser
combinators combinators.short-circuit fry make sequences
sequences.generalizations alien alien.private alien.strings
alien.c-types alien.libraries classes.struct namespaces kernel
strings libc locals quotations words cpu.architecture
compiler.utilities compiler.tree compiler.cfg
USING: accessors assocs arrays layouts math math.order
math.parser combinators combinators.short-circuit fry make
sequences sequences.generalizations alien alien.private
alien.strings alien.c-types alien.libraries classes.struct
namespaces kernel strings libc locals quotations words
cpu.architecture compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
compiler.cfg.stacks compiler.cfg.stacks.local
compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
: unbox-parameters ( parameters -- vregs reps )
[
[ length iota <reversed> ] keep
[ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
[ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
2 2 mnmap [ concat ] bi@
]
[ length neg ##inc-d ] bi ;
[ length neg inc-d ] bi ;
: prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
dup large-struct? [
@ -54,7 +55,7 @@ IN: compiler.cfg.builder.alien
struct-return-area set ;
: box-return* ( node -- )
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
return>> [ ] [ base-type box-return ds-push ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
@ -83,49 +84,38 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
[ library>> load-library ]
bi 2dup check-dlsym ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-block ( node quot: ( params -- ) -- )
'[
make-kill-block
params>>
_ [ alien-node-height ] bi
] emit-trivial-block ; inline
: emit-stack-frame ( stack-size params -- )
[ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
[ drop ##stack-frame ]
2bi ;
M: #alien-invoke emit-node
[
{
[ caller-parameters ]
[ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
M:: #alien-indirect emit-node ( node -- )
node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
[ caller-parameters src <gc-map> ##alien-indirect ]
params>>
{
[ caller-parameters ]
[ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
tri
] emit-alien-block ;
} cleave ;
M: #alien-indirect emit-node ( node -- )
params>>
[
ds-pop ^^unbox-any-c-ptr
[ caller-parameters ] dip
<gc-map> ##alien-indirect
]
[ emit-stack-frame ]
[ box-return* ]
tri ;
M: #alien-assembly emit-node
[
{
[ caller-parameters ]
[ quot>> ##alien-assembly ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
params>> {
[ caller-parameters ]
[ quot>> <gc-map> ##alien-assembly ]
[ emit-stack-frame ]
[ box-return* ]
} cleave ;
: callee-parameter ( rep on-stack? -- dst insn )
[ next-vreg dup ] 2dip
@ -148,13 +138,7 @@ M: #alien-assembly emit-node
bi ;
: box-parameters ( vregs reps params -- )
##begin-callback
next-vreg next-vreg ##restore-context
[
next-vreg next-vreg ##save-context
box-parameter
1 ##inc-d D 0 ##replace
] 3each ;
##begin-callback [ box-parameter ds-push ] 3each ;
: callee-parameters ( params -- stack-size )
[ abi>> ] [ return>> ] [ parameters>> ] tri
@ -174,25 +158,29 @@ M: #alien-assembly emit-node
cfg get t >>frame-pointer? drop ;
M: #alien-callback emit-node
dup params>> xt>> dup
params>> dup xt>> dup
[
needs-frame-pointer
##prologue
[
{
[ callee-parameters ]
[ quot>> ##alien-callback ]
begin-word
{
[ callee-parameters ]
[
[
return>> [ ##end-callback ] [
[ D 0 ^^peek ] dip
##end-callback
base-type unbox-return
] if-void
]
[ callback-stack-cleanup ]
} cleave
] emit-alien-block
##epilogue
##return
make-kill-block
quot>> ##alien-callback
] emit-trivial-block
]
[
return>> [ ##end-callback ] [
[ ds-pop ] dip
##end-callback
base-type unbox-return
] if-void
]
[ callback-stack-cleanup ]
} cleave
end-word
] with-cfg-builder ;

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

@ -198,17 +198,17 @@ M: #shuffle emit-node
dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return
: emit-return ( -- )
: end-word ( -- )
##branch
begin-basic-block
make-kill-block
##epilogue
##return ;
M: #return emit-node drop emit-return ;
M: #return emit-node drop end-word ;
M: #return-recursive emit-node
label>> id>> loops get key? [ emit-return ] unless ;
label>> id>> loops get key? [ end-word ] unless ;
! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ;

2
basis/compiler/cfg/finalization/finalization.factor
View File

@ -9,7 +9,7 @@ IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' )
select-representations
schedule-instructions
! schedule-instructions
insert-gc-checks
dup compute-uninitialized-sets
insert-save-contexts

277
basis/compiler/cfg/gc-checks/gc-checks-tests.factor
View File

@ -3,9 +3,85 @@ compiler.cfg.gc-checks.private compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
tools.test kernel vectors namespaces accessors sequences alien
memory classes make combinators.short-circuit byte-arrays ;
memory classes make combinators.short-circuit byte-arrays
compiler.cfg.comparisons ;
IN: compiler.cfg.gc-checks.tests
[ { } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##alien-invoke }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 0 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##allot }
T{ ##alien-invoke }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 0 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##allot }
T{ ##allot }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 0 4 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##allot }
T{ ##alien-invoke }
T{ ##allot }
T{ ##add }
T{ ##sub }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 3 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##alien-invoke }
T{ ##allot }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { { "a" } } ] [ { "a" } { } split-instructions ] unit-test
[ { { } { "a" } } ] [ { "a" } { 0 } split-instructions ] unit-test
[ { { "a" } { } } ] [ { "a" } { 1 } split-instructions ] unit-test
[ { { "a" } { "b" } } ] [ { "a" "b" } { 1 } split-instructions ] unit-test
[ { { } { "a" } { "b" "c" } } ] [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
: test-gc-checks ( -- )
H{ } clone representations set
cfg new 0 get >>entry cfg set ;
@ -25,7 +101,7 @@ V{
[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
[ ] [ 1 get instructions>> allocation-size 123 <alien> size assert= ] unit-test
2 \ vreg-counter set-global
@ -36,58 +112,16 @@ V{
[ first ##check-nursery-branch? ]
} 1&& ;
[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
4 \ vreg-counter set-global
[
: gc-call? ( bb -- ? )
instructions>>
V{
T{ ##call-gc f T{ gc-map } }
T{ ##branch }
}
]
[
<gc-call> instructions>>
] unit-test
} = ;
30 \ vreg-counter set-global
4 \ vreg-counter set-global
V{
T{ ##branch }
} 0 test-bb
V{
T{ ##branch }
} 1 test-bb
V{
T{ ##branch }
} 2 test-bb
V{
T{ ##branch }
} 3 test-bb
V{
T{ ##branch }
} 4 test-bb
0 { 1 2 } edges
1 3 edge
2 3 edge
3 4 edge
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get needs-predecessors drop ] unit-test
[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
[ t ] [ 2 get successors>> first gc-check? ] unit-test
[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
[ t ] [ <gc-call> gc-call? ] unit-test
30 \ vreg-counter set-global
@ -135,6 +169,8 @@ H{
[ ] [ cfg get insert-gc-checks drop ] unit-test
[ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
[ 2 ] [ 2 get predecessors>> length ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
@ -187,5 +223,148 @@ H{
} representations set
[ ] [ cfg get insert-gc-checks drop ] unit-test
[ ] [ 1 get successors>> first successors>> first 3 set ] unit-test
[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
[ 2 ] [ 3 get instructions>> length ] unit-test
! GC check in a block that is its own successor
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##allot f 1 64 byte-array }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 1 edge
1 { 1 2 } edges
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get insert-gc-checks drop ] unit-test
[ ] [
0 get successors>> first predecessors>>
[ first 0 get assert= ]
[ second 1 get [ instructions>> ] bi@ assert= ] bi
] unit-test
[ ] [
0 get successors>> first successors>>
[ first 1 get [ instructions>> ] bi@ assert= ]
[ second gc-call? t assert= ] bi
] unit-test
[ ] [
2 get predecessors>> first predecessors>>
[ first gc-check? t assert= ]
[ second gc-call? t assert= ] bi
] unit-test
! Brave new world of calls in the middle of BBs
! call then allot
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##allot f 1 64 byte-array }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 1 edge
1 2 edge
2 \ vreg-counter set-global
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get insert-gc-checks drop ] unit-test
! The GC check should come after the alien-invoke
[
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 3 4 }
}
] [ 0 get successors>> first instructions>> ] unit-test
! call then allot then call then allot
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##allot f 1 64 byte-array }
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##allot f 2 64 byte-array }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 1 edge
1 2 edge
2 \ vreg-counter set-global
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get insert-gc-checks drop ] unit-test
[
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 3 4 }
}
] [
0 get
successors>> first
instructions>>
] unit-test
[
V{
T{ ##allot f 1 64 byte-array }
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 5 6 }
}
] [
0 get
successors>> first
successors>> first
instructions>>
] unit-test
[
V{
T{ ##allot f 2 64 byte-array }
T{ ##branch }
}
] [
0 get
successors>> first
successors>> first
successors>> first
instructions>>
] unit-test

139
basis/compiler/cfg/gc-checks/gc-checks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators fry kernel layouts locals
math make namespaces sequences cpu.architecture
USING: accessors assocs combinators fry grouping kernel layouts
locals math make namespaces sequences cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
@ -12,12 +12,12 @@ compiler.cfg.instructions
compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks
<PRIVATE
! Garbage collection check insertion. This pass runs after
! representation selection, since it needs to know which vregs
! can contain tagged pointers.
<PRIVATE
: insert-gc-check? ( bb -- ? )
dup kill-block?>>
[ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
@ -25,46 +25,38 @@ IN: compiler.cfg.gc-checks
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
! A GC check for bb consists of two new basic blocks, gc-check
! and gc-call:
!
! gc-check
! / \
! | gc-call
! \ /
! bb
GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
! Any ##phi instructions at the start of bb are transplanted
! into the gc-check block.
:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
seen-allocation? [ call-index , ] when
insn-index 1 + f ;
: <gc-check> ( phis size -- bb )
[ <basic-block> ] 2dip
M: ##phi gc-check-offsets* gc-check-here ;
M: gc-map-insn gc-check-offsets* gc-check-here ;
M: ##allocation gc-check-offsets* 3drop t ;
M: insn gc-check-offsets* 2drop ;
: gc-check-offsets ( insns -- seq )
! A basic block is divided into sections by call and phi
! instructions. For every section with at least one
! allocation, record the offset of its first instruction
! in a sequence.
[
[ % ]
[
cc<= int-rep next-vreg-rep int-rep next-vreg-rep
##check-nursery-branch
] bi*
] V{ } make >>instructions ;
[ 0 f ] dip
[ gc-check-offsets* ] each-index
[ , ] [ drop ] if
] { } make ;
: <gc-call> ( -- bb )
<basic-block>
[ <gc-map> ##call-gc ##branch ] V{ } make
>>instructions t >>unlikely? ;
:: insert-guard ( body check bb -- )
bb predecessors>> check predecessors<<
V{ bb body } check successors<<
V{ check } body predecessors<<
V{ bb } body successors<<
V{ check body } bb predecessors<<
check predecessors>> [ bb check update-successors ] each ;
: (insert-gc-check) ( phis size bb -- )
[ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
:: split-instructions ( insns seq -- insns-seq )
! Divide a basic block into sections, where every section
! other than the first requires a GC check.
[
insns 0 seq [| insns from to |
from to insns subseq ,
insns to
] each
tail ,
] { } make ;
GENERIC: allocation-size* ( insn -- n )
@ -74,22 +66,75 @@ M: ##box-alien allocation-size* drop 5 cells ;
M: ##box-displaced-alien allocation-size* drop 5 cells ;
: allocation-size ( bb -- n )
instructions>>
: allocation-size ( insns -- n )
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
: remove-phis ( bb -- phis )
[ [ ##phi? ] partition ] change-instructions drop ;
: add-gc-checks ( insns-seq -- )
! Insert a GC check at the end of every chunk but the last
! one. This ensures that every section other than the first
! has a GC check in the section immediately preceeding it.
2 <clumps> [
first2 allocation-size
cc<= int-rep next-vreg-rep int-rep next-vreg-rep
\ ##check-nursery-branch new-insn
swap push
] each ;
: insert-gc-check ( bb -- )
[ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
: make-blocks ( insns-seq -- bbs )
[ <basic-block> swap >>instructions ] map ;
: <gc-call> ( -- bb )
<basic-block>
[ <gc-map> ##call-gc ##branch ] V{ } make
>>instructions t >>unlikely? ;
:: connect-gc-checks ( bbs -- )
! Every basic block but the last has two successors:
! the next block, and a GC call.
! Every basic block but the first has two predecessors:
! the previous block, and the previous block's GC call.
bbs length 1 - :> len
len [ <gc-call> ] replicate :> gc-calls
len [| n |
n bbs nth :> bb
n 1 + bbs nth :> next-bb
n gc-calls nth :> gc-call
V{ next-bb gc-call } bb successors<<
V{ next-bb } gc-call successors<<
V{ bb } gc-call predecessors<<
V{ bb gc-call } next-bb predecessors<<
] each-integer ;
:: update-predecessor-phis ( from to bb -- )
to [
[
[
[ dup from eq? [ drop bb ] when ] dip
] assoc-map
] change-inputs drop
] each-phi ;
:: (insert-gc-checks) ( bb bbs -- )
bb predecessors>> bbs first predecessors<<
bb successors>> bbs last successors<<
bb predecessors>> [ bb bbs first update-successors ] each
bb successors>> [
[ bb ] dip bbs last
[ update-predecessors ]
[ update-predecessor-phis ] 3bi
] each ;
: process-block ( bb -- )
dup instructions>> dup gc-check-offsets split-instructions
[ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
(insert-gc-checks) ;
PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
[ needs-predecessors ] dip
[ insert-gc-check ] each
[ process-block ] each
cfg-changed
] unless-empty ;

17
basis/compiler/cfg/instructions/instructions.factor
View File

@ -694,7 +694,7 @@ use: src/int-rep
literal: gc-map ;
INSN: ##alien-assembly
literal: quot ;
literal: quot gc-map ;
INSN: ##begin-callback ;
@ -812,9 +812,6 @@ literal: cc ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
INSN: ##restore-context
temp: temp1/int-rep temp2/int-rep ;
! GC checks
INSN: ##check-nursery-branch
literal: size cc
@ -858,15 +855,21 @@ UNION: conditional-branch-insn
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that contain subroutine calls to functions which
! can callback arbitrary Factor code
UNION: factor-call-insn
##alien-invoke
##alien-indirect
##alien-assembly ;
! Instructions that contain subroutine calls to functions which
! allocate memory
UNION: gc-map-insn
##call-gc
##alien-invoke
##alien-indirect
##box
##box-long-long
##allot-byte-array ;
##allot-byte-array
factor-call-insn ;
M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;

9
basis/compiler/cfg/liveness/liveness.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors assocs sequences sets
USING: kernel accessors assocs namespaces sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis
compiler.cfg.instructions compiler.cfg.registers
cpu.architecture ;
@ -24,7 +24,12 @@ GENERIC: visit-insn ( live-set insn -- live-set )
M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
: fill-gc-map ( live-set insn -- live-set )
gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ;
representations get [
gc-map>> over keys
[ rep-of tagged-rep? ] filter
>>gc-roots
] when
drop ;
M: gc-map-insn visit-insn
[ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;

34
basis/compiler/cfg/save-contexts/save-contexts-tests.factor
View File

@ -1,6 +1,7 @@
USING: accessors compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.save-contexts kernel namespaces tools.test ;
compiler.cfg.save-contexts kernel namespaces tools.test
cpu.x86.assembler.operands cpu.architecture ;
IN: compiler.cfg.save-contexts.tests
0 vreg-counter set-global
@ -38,3 +39,34 @@ V{
] [
0 get instructions>>
] unit-test
4 vreg-counter set-global
V{
T{ ##inc-d f 3 }
T{ ##load-reg-param f 0 RCX int-rep }
T{ ##load-reg-param f 1 RDX int-rep }
T{ ##load-reg-param f 2 R8 int-rep }
T{ ##begin-callback }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
}
} 0 test-bb
0 get insert-save-context
[
V{
T{ ##inc-d f 3 }
T{ ##load-reg-param f 0 RCX int-rep }
T{ ##load-reg-param f 1 RDX int-rep }
T{ ##load-reg-param f 2 R8 int-rep }
T{ ##save-context f 5 6 }
T{ ##begin-callback }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
}
}
] [
0 get instructions>>
] unit-test

50
basis/compiler/cfg/save-contexts/save-contexts.factor
View File

@ -1,30 +1,44 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit
compiler.cfg.instructions compiler.cfg.registers
USING: accessors compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
IN: compiler.cfg.save-contexts
! Insert context saves.
: needs-save-context? ( insns -- ? )
[
{
[ ##unary-float-function? ]
[ ##binary-float-function? ]
[ ##alien-invoke? ]
[ ##alien-indirect? ]
[ ##alien-assembly? ]
} 1||
] any? ;
GENERIC: needs-save-context? ( insn -- ? )
M: ##unary-float-function needs-save-context? drop t ;
M: ##binary-float-function needs-save-context? drop t ;
M: gc-map-insn needs-save-context? drop t ;
M: insn needs-save-context? drop f ;
: bb-needs-save-context? ( insn -- ? )
instructions>> [ needs-save-context? ] any? ;
GENERIC: modifies-context? ( insn -- ? )
M: ##inc-d modifies-context? drop t ;
M: ##inc-r modifies-context? drop t ;
M: ##load-reg-param modifies-context? drop t ;
M: insn modifies-context? drop f ;
: save-context-offset ( bb -- n )
! ##save-context must be placed after instructions that
! modify the context, or instructions that read parameter
! registers.
instructions>> [ modifies-context? not ] find drop ;
: insert-save-context ( bb -- )
dup instructions>> dup needs-save-context? [
tagged-rep next-vreg-rep
tagged-rep next-vreg-rep
\ ##save-context new-insn prefix
>>instructions drop
] [ 2drop ] if ;
dup bb-needs-save-context? [
[
int-rep next-vreg-rep
int-rep next-vreg-rep
\ ##save-context new-insn
] dip
[ save-context-offset ] keep
[ insert-nth ] change-instructions drop
] [ drop ] if ;
: insert-save-contexts ( cfg -- cfg' )
dup [ insert-save-context ] each-basic-block ;

8
basis/compiler/cfg/utilities/utilities.factor
View File

@ -32,13 +32,13 @@ SYMBOL: visited
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
:: update-predecessors ( from to bb -- )
! Update 'to' predecessors for insertion of 'bb' between
! 'from' and 'to'.
! Whenever 'from' appears in the list of predecessors of 'to'
! replace it with 'bb'.
to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
:: update-successors ( from to bb -- )
! Update 'from' successors for insertion of 'bb' between
! 'from' and 'to'.
! Whenever 'to' appears in the list of successors of 'from'
! replace it with 'bb'.
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
:: insert-basic-block ( from to insns -- )

4
basis/compiler/codegen/codegen.factor
View File

@ -254,7 +254,6 @@ CODEGEN: ##compare-integer-imm %compare-integer-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
@ -304,4 +303,5 @@ CODEGEN: ##begin-callback %begin-callback
CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##end-callback %end-callback
M: ##alien-assembly generate-insn quot>> call( -- ) ;
M: ##alien-assembly generate-insn
[ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ;

2
basis/cpu/architecture/architecture.factor
View File

@ -602,8 +602,6 @@ HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
HOOK: %allot-byte-array cpu ( dst size gc-map -- )
HOOK: %restore-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %prepare-var-args cpu ( -- )

7
basis/cpu/x86/32/bootstrap.factor
View File

@ -25,6 +25,7 @@ IN: bootstrap.x86
: nv-reg ( -- reg ) ESI ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: link-reg ( -- reg ) EBX ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
@ -90,15 +91,9 @@ IN: bootstrap.x86
ESP 4 [+] EAX MOV
"begin_callback" jit-call
jit-load-vm
jit-load-context
jit-restore-context
jit-call-quot
jit-load-vm
jit-save-context
ESP [] vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive

6
basis/cpu/x86/64/bootstrap.factor
View File

@ -20,6 +20,7 @@ IN: bootstrap.x86
: nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ;
: link-reg ( -- reg ) R11 ;
: ctx-reg ( -- reg ) R12 ;
: vm-reg ( -- reg ) R13 ;
: ds-reg ( -- reg ) R14 ;
@ -84,15 +85,10 @@ IN: bootstrap.x86
arg1 vm-reg MOV
"begin_callback" jit-call
jit-load-context
jit-restore-context
! call the quotation
arg1 return-reg MOV
jit-call-quot
jit-save-context
arg1 vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive

10
basis/cpu/x86/bootstrap.factor
View File

@ -38,15 +38,17 @@ big-endian off
! Save C callstack pointer
nv-reg context-callstack-save-offset [+] stack-reg MOV
! Load Factor callstack pointer
! Load Factor stack pointers
stack-reg nv-reg context-callstack-bottom-offset [+] MOV
nv-reg jit-update-tib
jit-install-seh
rs-reg nv-reg context-retainstack-offset [+] MOV
ds-reg nv-reg context-datastack-offset [+] MOV
! Call into Factor code
nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
nv-reg CALL
link-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
link-reg CALL
! Load VM into vm-reg; only needed on x86-32, but doesn't
! hurt on x86-64

8
basis/cpu/x86/x86.factor
View File

@ -614,14 +614,6 @@ M: x86 %alien-indirect ( src gc-map -- )
M: x86 %loop-entry 16 alignment [ NOP ] times ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
temp1 %context
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV
ds-reg temp1 "datastack" context-field-offset [+] MOV
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace

6
basis/http/client/client.factor
View File

@ -21,12 +21,8 @@ ERROR: too-many-redirects ;
[ "HTTP/" write version>> write crlf ]
tri ;
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: set-host-header ( request header -- request header )
over url>> url-host "host" pick set-at ;
over url>> host>> "host" pick set-at ;
: set-cookie-header ( header cookies -- header )
unparse-cookie "cookie" pick set-at ;

18
basis/http/server/server-docs.factor
View File

@ -70,38 +70,36 @@ HELP: params
{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
ARTICLE: "http.server.requests" "HTTP request variables"
"The following variables are set by the HTTP server at the beginning of a request."
"The following variables are set by the HTTP server at the beginning of a request. Responder implementations may access these variables."
{ $subsections
request
url
post-request?
responder-nesting
params
}
"Utility words:"
{ $subsections
post-request?
param
set-param
request-params
}
"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
"Additional variables may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
ARTICLE: "http.server.responders" "HTTP server responders"
"Responders process requests and output " { $link "http.responses" } ". To implement a responder, define a new class and implement a method on the following generic word:"
{ $subsections call-responder* }
"The HTTP server dispatches requests to a main responder:"
{ $subsections main-responder }
"The main responder may in turn dispatch it a subordinate dispatcher, and so on."
$nl
"Responders process requests and output " { $link "http.responses" } "; concretely are instances of classes which implement a generic word:"
{ $subsections call-responder* }
"To actually call a subordinate responder, use the following word instead:"
"The main responder may in turn dispatch it a subordinate dispatcher, and so on. To call a subordinate responder, use the following word:"
{ $subsections call-responder }
"A simple implementation of a responder which always outputs the same response:"
{ $subsections
trivial-responder
<trivial-responder>
}
{ $vocab-subsection "Furnace actions" "furnace.actions" }
"In particular, writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead." ;
"Writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead."
{ $vocab-subsection "Furnace actions" "furnace.actions" } ;
ARTICLE: "http.server.variables" "HTTP server variables"
"The following global variables control the behavior of the HTTP server. Both are off by default."

5
basis/http/server/server.factor
View File

@ -75,9 +75,8 @@ SYMBOL: upload-limit
] when ;
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
drop ;
[ ] [ url>> ] [ "host" header dup [ url-decode ] when ] tri
>>host drop ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookie >>cookies ] when* ;

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

@ -31,3 +31,5 @@ IN: math.polynomials.tests
[ t ] [ { 1 1 1 } { 1 1 1 } p= ] unit-test
[ { 0 0 } { 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test
[ { 10 200 3000 } ] [ { 1 10 100 1000 } pdiff ] unit-test

2
basis/math/polynomials/polynomials.factor
View File

@ -88,7 +88,7 @@ PRIVATE>
[ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
dup length v* { 0 } ?head drop ;
dup length iota v* rest ;
: polyval ( x p -- p[x] )
[ length swap powers ] [ nip ] 2bi v. ;

8
basis/prettyprint/backend/backend.factor
View File

@ -226,9 +226,13 @@ M: object pprint-object ( obj -- )
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
: with-extra-nesting-level ( quot -- )
nesting-limit [ dup [ 1 + ] [ f ] if* ] change
[ nesting-limit set ] curry [ ] cleanup ; inline
M: hashtable pprint*
nesting-limit inc
[ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
[ pprint-object ] with-extra-nesting-level ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;

13
basis/prettyprint/prettyprint-tests.factor
View File

@ -374,3 +374,16 @@ TUPLE: final-tuple ; final
] [
[ \ final-tuple see ] with-string-writer "\n" split
] unit-test
[ "H{ { 1 2 } }\n" ] [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test
[ "H{ { 1 ~array~ } }\n" ] [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test
[ "{ ~array~ }\n" ] [ [ { { 1 2 } } short. ] with-string-writer ] unit-test
[ "H{ { 1 { 2 3 } } }\n" ] [
f nesting-limit [
[ H{ { 1 { 2 3 } } } . ] with-string-writer
] with-variable
] unit-test

9
basis/tools/deploy/deploy-tests.factor
View File

@ -2,9 +2,12 @@ USING: tools.test system io io.encodings.ascii io.pathnames
io.files io.files.info io.files.temp kernel tools.deploy.config
tools.deploy.config.editor tools.deploy.backend math sequences
io.launcher arrays namespaces continuations layouts accessors
urls math.parser io.directories tools.deploy.test ;
urls math.parser io.directories tools.deploy tools.deploy.test
vocabs ;
IN: tools.deploy.tests
[ "no such vocab, fool!" deploy ] [ no-vocab? ] must-fail-with
[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
@ -127,3 +130,7 @@ os macosx? [
deploy-test-command ascii [ readln ] with-process-reader
"test.image" temp-file =
] unit-test
[ ] [ "resource:license.txt" "license.txt" temp-file copy-file ] unit-test
[ ] [ "tools.deploy.test.19" shake-and-bake run-temp-image ] unit-test

7
basis/tools/deploy/deploy.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.deploy.backend system vocabs.loader kernel
USING: tools.deploy.backend system vocabs vocabs.loader kernel
combinators tools.deploy.config.editor ;
IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
: deploy ( vocab -- )
dup find-vocab-root [ deploy* ] [ no-vocab ] if ;
: deploy-image-only ( vocab image -- )
[ vm ] 2dip swap dup deploy-config make-deploy-image drop ;

5
basis/tools/deploy/shaker/shaker.factor
View File

@ -21,6 +21,7 @@ QUALIFIED: layouts
QUALIFIED: source-files
QUALIFIED: source-files.errors
QUALIFIED: vocabs
QUALIFIED: vocabs.loader
FROM: alien.libraries.private => >deployed-library-path ;
FROM: namespaces => set ;
FROM: sets => members ;
@ -358,6 +359,7 @@ IN: tools.deploy.shaker
vocabs:dictionary
vocabs:load-vocab-hook
vocabs:vocab-observers
vocabs.loader:add-vocab-root-hook
word
parser-notes
} %
@ -467,7 +469,8 @@ SYMBOL: deploy-vocab
: startup-stripper ( -- )
t "quiet" set-global
f output-stream set-global
V{ "resource:" } clone vocab-roots set-global ;
[ V{ "resource:" } clone vocab-roots set-global ]
"vocabs.loader" startup-hooks get-global set-at ;
: next-method* ( method -- quot )
[ "method-class" word-prop ]

9
basis/tools/deploy/test/19/19.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.encodings.ascii ;
IN: tools.deploy.test.19
: main ( -- )
"vocab:license.txt" ascii file-contents write ;
MAIN: main

1
basis/tools/deploy/test/19/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

15
basis/tools/deploy/test/19/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-name "tools.deploy.test.19" }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-console? t }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-word-props? f }
{ deploy-math? f }
{ deploy-threads? f }
{ deploy-word-defs? f }
}

20
basis/tools/deploy/test/19/license.txt Normal file
View File

@ -0,0 +1,20 @@
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

1
basis/tools/deploy/test/19/resources.txt Normal file
View File

@ -0,0 +1 @@
license.txt

10
basis/ui/tools/traceback/traceback.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces arrays
fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labeled assocs
fry prettyprint sequences inspector models.arrow fonts ui
ui.commands ui.gadgets ui.gadgets.labeled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.borders
ui.gadgets.tables ui.gestures sequences inspector
models.arrow fonts ;
ui.gadgets.tables ui.gestures ui.tools.common ;
QUALIFIED-WITH: ui.tools.inspector i
IN: ui.tools.traceback
@ -45,7 +45,7 @@ M: stack-entry-renderer row-value drop object>> ;
: <retainstack-display> ( model -- gadget )
[ retain>> ] "Retain stack" <stack-display> ;
TUPLE: traceback-gadget < track ;
TUPLE: traceback-gadget < tool ;
: <traceback-gadget> ( model -- gadget )
[

2
basis/unix/ffi/ffi.factor
View File

@ -105,7 +105,7 @@ FUNCTION: uint htonl ( uint n ) ;
FUNCTION: ushort htons ( ushort n ) ;
! FUNCTION: int issetugid ;
FUNCTION: int isatty ( int fildes ) ;
FUNCTION: int ioctl ( int fd, ulong request, c-string argp ) ;
FUNCTION: int ioctl ( int fd, ulong request, void* argp ) ;
FUNCTION: int lchown ( c-string path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ;
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;

4
extra/bson/bson-tests.factor
View File

@ -8,8 +8,8 @@ IN: bson.tests
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } turnaround ] unit-test
[ H{ { "a" "a string" } { "b" H{ { "a" "アップルからの最新のニュースや情報を読む" } } } } ]
[ H{ { "a" "a string" } { "b" H{ { "a" "アップルからの最新のニュースや情報を読む" } } } } turnaround ] unit-test
[ H{ { "a list" { 1 2.234 "hello world" } } } ]
[ H{ { "a list" { 1 2.234 "hello world" } } } turnaround ] unit-test

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

@ -79,9 +79,10 @@ CONSTANT: T_Integer64 HEX: 12
CONSTANT: T_MinKey HEX: FF
CONSTANT: T_MaxKey HEX: 7F
CONSTANT: T_Binary_Function HEX: 1
CONSTANT: T_Binary_Bytes HEX: 2
CONSTANT: T_Binary_UUID HEX: 3
CONSTANT: T_Binary_MD5 HEX: 5
CONSTANT: T_Binary_Custom HEX: 80
CONSTANT: T_Binary_Default HEX: 0
CONSTANT: T_Binary_Function HEX: 1
CONSTANT: T_Binary_Bytes_Deprecated HEX: 2
CONSTANT: T_Binary_UUID HEX: 3
CONSTANT: T_Binary_MD5 HEX: 5
CONSTANT: T_Binary_Custom HEX: 80

9
extra/bson/reader/reader.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bson.constants calendar combinators
combinators.short-circuit io io.binary kernel math locals
io.encodings.utf8 io.encodings
namespaces sequences serialize strings vectors byte-arrays ;
FROM: io.encodings.binary => binary ;
@ -34,10 +35,11 @@ DEFER: read-elements
read-byte-raw first ; inline
: read-cstring ( -- string )
"\0" read-until drop >string ; inline
input-stream get utf8 <decoder>
"\0" swap stream-read-until drop ; inline
: read-sized-string ( length -- string )
read 1 head-slice* >string ; inline
read binary [ read-cstring ] with-byte-reader ; inline
: read-timestamp ( -- timestamp )
8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi <mongo-timestamp> ;
@ -54,7 +56,8 @@ DEFER: read-elements
: bson-binary-read ( -- binary )
read-int32 read-byte
{
{ T_Binary_Bytes [ read ] }
{ T_Binary_Default [ read ] }
{ T_Binary_Bytes_Deprecated [ drop read-int32 read ] }
{ T_Binary_Custom [ read bytes>object ] }
{ T_Binary_Function [ read ] }
[ drop read >string ]

14
extra/bson/writer/writer.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs bson.constants byte-arrays
calendar combinators.short-circuit fry hashtables io io.binary
io.encodings.utf8 io.encodings io.streams.byte-array
kernel linked-assocs literals math math.parser namespaces byte-vectors
quotations sequences serialize strings vectors dlists alien.accessors ;
FROM: words => word? word ;
@ -42,8 +43,11 @@ TYPED: write-int32 ( int: integer -- ) INT32-SIZE (>le) ; inline
TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
TYPED: write-utf8-string ( string: string -- )
output-stream get utf8 <encoder> stream-write ; inline
TYPED: write-cstring ( string: string -- )
get-output [ length ] [ ] bi copy 0 write1 ; inline
write-utf8-string 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE (>le) ; inline
@ -56,7 +60,7 @@ DEFER: write-pair
TYPED: write-byte-array ( binary: byte-array -- )
[ length write-int32 ]
[ T_Binary_Bytes write1 write ] bi ; inline
[ T_Binary_Default write1 write ] bi ; inline
TYPED: write-mdbregexp ( regexp: mdbregexp -- )
[ regexp>> write-cstring ]
@ -94,8 +98,12 @@ TYPED: (serialize-code) ( code: code -- )
[ length write-int32 ]
[ T_Binary_Custom write1 write ] bi ; inline
: write-string-length ( string -- )
[ length>> 1 + ]
[ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
TYPED: write-string ( string: string -- )
'[ _ write-cstring ] with-length-prefix-excl ; inline
dup write-string-length write-cstring ; inline
TYPED: write-boolean ( bool: boolean -- )
[ 1 write1 ] [ 0 write1 ] if ; inline

1
extra/gdbm/authors.txt Normal file
View File

@ -0,0 +1 @@
Dmitry Shubin

1
extra/gdbm/ffi/authors.txt Normal file
View File

@ -0,0 +1 @@
Dmitry Shubin

49
extra/gdbm/ffi/ffi.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2010 Dmitry Shubin.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.libraries alien.syntax classes.struct
combinators system ;
IN: gdbm.ffi
<< "libgdbm" os {
{ [ unix? ] [ "libgdbm.so" ] }
{ [ winnt? ] [ "gdbm.dll" ] }
{ [ macosx? ] [ "libgdbm.dylib" ] }
} cond cdecl add-library >>
LIBRARY: libgdbm
C-GLOBAL: c-string gdbm_version
CONSTANT: GDBM_SYNC HEX: 20
CONSTANT: GDBM_NOLOCK HEX: 40
CONSTANT: GDBM_INSERT 0
CONSTANT: GDBM_REPLACE 1
CONSTANT: GDBM_CACHESIZE 1
CONSTANT: GDBM_SYNCMODE 3
CONSTANT: GDBM_CENTFREE 4
CONSTANT: GDBM_COALESCEBLKS 5
STRUCT: datum { dptr char* } { dsize int } ;
C-TYPE: _GDBM_FILE
TYPEDEF: _GDBM_FILE* GDBM_FILE
CALLBACK: void fatal_func_cb ;
FUNCTION: GDBM_FILE gdbm_open ( c-string name, int block_size, int read_write, int mode, fatal_func_cb fatal_func ) ;
FUNCTION-ALIAS: gdbm-close void gdbm_close ( GDBM_FILE dbf ) ;
FUNCTION: int gdbm_store ( GDBM_FILE dbf, datum key, datum content, int flag ) ;
FUNCTION: datum gdbm_fetch ( GDBM_FILE dbf, datum key ) ;
FUNCTION: int gdbm_delete ( GDBM_FILE dbf, datum key ) ;
FUNCTION: datum gdbm_firstkey ( GDBM_FILE dbf ) ;
FUNCTION: datum gdbm_nextkey ( GDBM_FILE dbf, datum key ) ;
FUNCTION: int gdbm_reorganize ( GDBM_FILE dbf ) ;
FUNCTION: void gdbm_sync ( GDBM_FILE dbf ) ;
FUNCTION: int gdbm_exists ( GDBM_FILE dbf, datum key ) ;
FUNCTION: int gdbm_setopt ( GDBM_FILE dbf, int option, int* value, int size ) ;
FUNCTION: int gdbm_fdesc ( GDBM_FILE dbf ) ;
C-GLOBAL: int gdbm_errno
FUNCTION: c-string gdbm_strerror ( int errno ) ;

147
extra/gdbm/gdbm-docs.factor Normal file
View File

@ -0,0 +1,147 @@
! Copyright (C) 2010 Dmitry Shubin.
! See http://factorcode.org/license.txt for BSD license.
USING: gdbm.ffi gdbm.private help.markup help.syntax kernel math
quotations strings ;
IN: gdbm
HELP: gdbm
{ $class-description "Instance of this class is used as database configuration object. It has following slots:"
{ $table
{ { $slot "name" } "The file name of the database." }
{ { $slot "block-size" } "The size of a single transfer from disk to memory. If the value is less than 512, the file system blocksize is used (this is default)." }
{ { $slot "role" } "Determines what kind of access the user wants to obtain (see below)." }
{ { $slot "sync" } { "Being set to " { $link t } " causes all database operations to be synchronized to the disk." } }
{ { $slot "nolock" } { "Being set to " { $link t } " prevents gdbm from performing any locking on the database file." } }
{ { $slot "mode" } "An integer representing standard UNIX access permissions." }
}
"The " { $slot "role" } " can be set to one of the folowing values:"
{ $table
{ { $snippet "reader" } "The user can only read from existing database." }
{ { $snippet "writer" } "The user can access existing database as reader and writer." }
{ { $snippet "wrcreat" } "Open the database for reading and writing if it exists and create new one otherwise." }
{ { $snippet "newdb" } "Create empty database even if there is already one with the same name." }
}
} ;
HELP: <gdbm>
{ $values { "gdbm" gdbm } }
{ $description "Creates database configuration object with all slots set to their default values. See " { $link gdbm } " for complete slots description." } ;
HELP: gdbm-info
{ $values { "str" string } }
{ $description "Returns version number and build date." } ;
HELP: delete
{ $values { "key" object } }
{ $description "Removes the keyed item from the database." } ;
HELP: gdbm-error-message
{ $values { "error" gdbm-error } { "msg" string } }
{ $description "Returns error message in human readable format." } ;
HELP: exists?
{ $values { "key" object } { "?" boolean } }
{ $description "Searches for a particular key without retreiving it." } ;
HELP: each-key
{ $values { "quot" quotation } }
{ $description "Applies the quotation to the each key in the database." } ;
HELP: each-value
{ $values { "quot" quotation } }
{ $description "Applies the quotation to the each value in the database." } ;
HELP: each-record
{ $values { "quot" quotation } }
{ $description "Applies the quotation to the each key-value pair in the database." } ;
HELP: gdbm-file-descriptor
{ $values { "desc" integer } }
{ $description "Returns the file descriptor of the database. This is used for manual database locking if it was opened with " { $snippet "nolock" } " flag set to " { $link t } "." } ;
HELP: fetch
{ $values
{ "key" object }
{ "content/f" { "the value associated with " { $snippet "key" } " or " { $link f } " if there is no such key" } }
}
{ $description "Looks up a given key and returns value associated with it. This word makes no distinction between a missing value and a value set to " { $link f } "." } ;
HELP: fetch*
{ $values { "key" object } { "content" object } { "?" boolean } }
{ $description "Looks up a given key and returns value associated with it. The boolean flag can decide between the case of a missing value, and a value of " { $link f } "." } ;
HELP: first-key
{ $values { "key/f" object } }
{ $description "Returns first key in the database. This word makes no distinction between an empty database case and a case of a first value set to " { $link f } "." } ;
HELP: first-key*
{ $values { "key" object } { "?" boolean } }
{ $description "Returns first key in the database. The boolean flag can decide between the case of an empty database and a case of a first value set to " { $link f } "." } ;
HELP: insert
{ $values { "key" object } { "content" object } }
{ $description "Inserts record into the database. Throws an error if the key already exists." } ;
HELP: next-key
{ $values { "key" object } { "key/f" object } }
{ $description "Given a key returns next key in the database. This word makes no distinction between reaching the end of the database case and a case of a next value set to " { $link f } "." } ;
HELP: next-key*
{ $values { "key" object } { "next-key" object } { "?" boolean } }
{ $description "Given a key returns next key in the database. The boolean flag can decide between the case of reaching the end of the database and a case of a next value set to " { $link f } "." } ;
HELP: reorganize
{ $description "Reorganisation is a process of shinking the space used by gdbm. This requires creating a new file and moving all elements from old gdbm file to new one." } ;
HELP: replace
{ $values { "key" object } { "content" object } }
{ $description "Inserts record into the database replacing old value with the new one if the key already exists." } ;
HELP: set-block-merging
{ $values { "?" boolean } }
{ $description "If set, this option causes adjacent free blocks to be merged. The default is " { $link f } "." } ;
HELP: set-block-pool
{ $values { "?" boolean } }
{ $description "If set, this option causes all subsequent free blocks to be placed in the global pool. The default is " { $link f } "." } ;
HELP: set-cache-size
{ $values { "size" integer } }
{ $description "Sets the size of the internal bucket cache. The default value is 100. This option may only be set once." } ;
HELP: set-sync-mode
{ $values { "?" boolean } }
{ $description "Turns on or off file system synchronization. The default is " { $link f } "." } ;
HELP: synchronize
{ $description "Performs database synchronization: make sure the disk version of the database has been completely updated." } ;
HELP: with-gdbm
{ $values
{ "gdbm" "a database configuration object" } { "quot" quotation }
}
{ $description "Calls the quotation with a database bound to " { $link current-dbf } " symbol." } ;
ARTICLE: "gdbm" "GNU Database Manager"
"The " { $vocab-link "gdbm" } " vocabulary provides an interface to GNU DataBase Manager. This is a GNU implementation of the standard Unix dbm library, originally developed at Berkeley."
$nl
"This is a very brief manual. For a more detailed description consult the official gdbm documentation."
{ $heading "Basics" }
"All interaction with gdbm database should be realized using special combinator which automates all work for database initialisation and cleanup. All initialisation options are passed to combinator with a database configuration object."
{ $subsections gdbm <gdbm> with-gdbm }
"For actual record manipulation the following words are used:"
{ $subsections insert exists? fetch delete }
{ $heading "Sequential access" }
"It is possible to iterate through all records in the database with"
{ $subsections first-key next-key }
"The following combinators, however, provide more convenient way to do that:"
{ $subsections each-key each-value each-record }
"The order in which records are accessed has nothing to do with the order in which records have been stored. Note that these words can only be used in read-only algorithms since delete operation re-arranges the hash table."
;
ABOUT: "gdbm"

63
extra/gdbm/gdbm-tests.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2010 Dmitry Shubin.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays continuations gdbm io.directories
io.files.temp kernel sequences sets tools.test ;
IN: gdbm.tests
: db-path ( -- filename ) "test.db" temp-file ;
: CLEANUP ( -- ) [ db-path delete-file ] ignore-errors ;
: test.db ( -- gdbm ) <gdbm> db-path >>name ;
: with-test.db ( quot -- ) test.db swap with-gdbm ; inline
CLEANUP
[
test.db reader >>role [ ] with-gdbm
] [ gdbm-file-open-error = ] must-fail-with
[ f ] [ [ "foo" exists? ] with-test.db ] unit-test
[ ] [ [ "foo" 41 insert ] with-test.db ] unit-test
[
db-path [ "foo" 42 insert ] with-gdbm-writer
] [ gdbm-cannot-replace = ] must-fail-with
[ ]
[
[
"foo" 42 replace
"bar" 43 replace
"baz" 44 replace
] with-test.db
] unit-test
[ 42 t ] [ db-path [ "foo" fetch* ] with-gdbm-reader ] unit-test
[ f f ] [ [ "unknown" fetch* ] with-test.db ] unit-test
[
[
300 set-cache-size 300 set-cache-size
] with-test.db
] [ gdbm-option-already-set = ] must-fail-with
[ t ]
[
V{ } [ [ 2array append ] each-record ] with-test.db
V{ "foo" "bar" "baz" 42 43 44 } set=
] unit-test
[ f ]
[
test.db newdb >>role [ "foo" exists? ] with-gdbm
] unit-test
CLEANUP

160
extra/gdbm/gdbm.factor Normal file
View File

@ -0,0 +1,160 @@
! Copyright (C) 2010 Dmitry Shubin.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.destructors
alien.enums alien.syntax classes.struct combinators destructors
gdbm.ffi io.backend kernel libc locals math namespaces sequences
serialize strings ;
IN: gdbm
ENUM: gdbm-role reader writer wrcreat newdb ;
TUPLE: gdbm
{ name string }
{ block-size integer }
{ role initial: wrcreat }
{ sync boolean }
{ nolock boolean }
{ mode integer initial: OCT: 644 } ;
: <gdbm> ( -- gdbm ) gdbm new ;
ENUM: gdbm-error
gdbm-no-error
gdbm-malloc-error
gdbm-block-size-error
gdbm-file-open-error
gdbm-file-write-error
gdbm-file-seek-error
gdbm-file-read-error
gdbm-bad-magic-number
gdbm-empty-database
gdbm-cant-be-reader
gdbm-cant-be-writer
gdbm-reader-cant-delete
gdbm-reader-cant-store
gdbm-reader-cant-reorganize
gdbm-unknown-update
gdbm-item-not-found
gdbm-reorganize-failed
gdbm-cannot-replace
gdbm-illegal-data
gdbm-option-already-set
gdbm-illegal-option ;
<PRIVATE
: gdbm-throw ( -- * ) gdbm_errno gdbm-error number>enum throw ;
: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
SYMBOL: current-dbf
: dbf ( -- dbf ) current-dbf get ;
: get-flag ( gdbm -- n )
[ role>> enum>number ]
[ sync>> GDBM_SYNC 0 ? ]
[ nolock>> GDBM_NOLOCK 0 ? ]
tri bitor bitor ;
: gdbm-open ( gdbm -- dbf )
{
[ name>> normalize-path ]
[ block-size>> ] [ get-flag ] [ mode>> ]
} cleave f gdbm_open [ gdbm-throw ] unless* ;
DESTRUCTOR: gdbm-close
: object>datum ( obj -- datum )
object>bytes [ malloc-byte-array &free ] [ length ] bi
datum <struct-boa> ;
: datum>object* ( datum -- obj ? )
[ dptr>> ] [ dsize>> ] bi over
[ memory>byte-array bytes>object t ] [ drop f ] if ;
: gdbm-store ( key content flag -- )
[
{ [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
gdbm_store check-error
] with-destructors ;
:: (setopt) ( value option -- )
[
int heap-size dup malloc &free :> ( size ptr )
value ptr 0 int set-alien-value
dbf option ptr size gdbm_setopt check-error
] with-destructors ;
: setopt ( value option -- )
[ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
PRIVATE>
: gdbm-info ( -- str ) gdbm_version ;
: gdbm-error-message ( error -- msg )
enum>number gdbm_strerror ;
: replace ( key content -- ) GDBM_REPLACE gdbm-store ;
: insert ( key content -- ) GDBM_INSERT gdbm-store ;
: delete ( key -- )
[ dbf swap object>datum gdbm_delete check-error ]
with-destructors ;
: fetch* ( key -- content ? )
[ dbf swap object>datum gdbm_fetch datum>object* ]
with-destructors ;
: first-key* ( -- key ? )
[ dbf gdbm_firstkey datum>object* ] with-destructors ;
: next-key* ( key -- next-key ? )
[ dbf swap object>datum gdbm_nextkey datum>object* ]
with-destructors ;
: fetch ( key -- content/f ) fetch* drop ;
: first-key ( -- key/f ) first-key* drop ;
: next-key ( key -- key/f ) next-key* drop ;
:: each-key ( ... quot: ( ... key -- ... ) -- ... )
first-key*
[ [ next-key* ] [ quot keep ] do while ] when drop ; inline
: each-value ( ... quot: ( ... value -- ... ) -- ... )
[ fetch ] prepose each-key ; inline
: each-record ( ... quot: ( ... key value -- ... ) -- ... )
[ dup fetch ] prepose each-key ; inline
: reorganize ( -- ) dbf gdbm_reorganize check-error ;
: synchronize ( -- ) dbf gdbm_sync ;
: exists? ( key -- ? )
[ dbf swap object>datum gdbm_exists c-bool> ]
with-destructors ;
: set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
: set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
: set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
: set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
: gdbm-file-descriptor ( -- desc ) dbf gdbm_fdesc ;
: with-gdbm ( gdbm quot -- )
[ gdbm-open &gdbm-close current-dbf set ] prepose curry
[ with-scope ] curry with-destructors ; inline
:: with-gdbm-role ( name role quot -- )
<gdbm> name >>name role >>role quot with-gdbm ; inline
: with-gdbm-reader ( name quot -- )
reader swap with-gdbm-role ; inline
: with-gdbm-writer ( name quot -- )
writer swap with-gdbm-role ; inline

1
extra/gdbm/summary.txt Normal file
View File

@ -0,0 +1 @@
GNU DataBase Manager

2
extra/gdbm/tags.txt Normal file
View File

@ -0,0 +1,2 @@
bindings
database

1
extra/libudev/authors.txt Normal file
View File

@ -0,0 +1 @@
Niklas Waern

446
extra/libudev/libudev.factor Normal file
View File

@ -0,0 +1,446 @@
! Copyright (C) 2010 Niklas Waern.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.libraries alien.syntax
fry kernel sequences unix.types ;
IN: libudev
<< "libudev" "libudev.so" cdecl add-library >>
LIBRARY: libudev
C-TYPE: udev
FUNCTION: udev* udev_ref (
udev* udev ) ;
FUNCTION: void udev_unref (
udev* udev ) ;
FUNCTION: udev* udev_new ( ) ;
CALLBACK: void udev_set_log_fn_callback (
udev* udev
int priority,
c-string file,
int line,
c-string fn,
c-string format ) ;
! va_list args ) ;
FUNCTION: void udev_set_log_fn (
udev* udev,
udev_set_log_fn_callback log_fn ) ;
FUNCTION: int udev_get_log_priority (
udev* udev ) ;
FUNCTION: void udev_set_log_priority (
udev* udev,
int priority ) ;
FUNCTION: c-string udev_get_sys_path (
udev* udev ) ;
FUNCTION: c-string udev_get_dev_path (
udev* udev ) ;
FUNCTION: void* udev_get_userdata (
udev* udev ) ;
FUNCTION: void udev_set_userdata (
udev* udev,
void* userdata ) ;
C-TYPE: udev_list_entry
FUNCTION: udev_list_entry* udev_list_entry_get_next (
udev_list_entry* list_entry ) ;
FUNCTION: udev_list_entry* udev_list_entry_get_by_name (
udev_list_entry* list_entry,
c-string name ) ;
FUNCTION: c-string udev_list_entry_get_name (
udev_list_entry* list_entry ) ;
FUNCTION: c-string udev_list_entry_get_value (
udev_list_entry* list_entry ) ;
! Helper to iterate over all entries of a list.
: udev_list_entry_foreach ( ... first_entry quot: ( ... x -- ... ) -- ... )
[ [ dup ] ] dip '[ [ @ ] keep udev_list_entry_get_next ]
while drop ; inline
! Get all list entries _as_ a list
: udev-list-entries ( first_entry -- seq )
[ ] collector [ udev_list_entry_foreach ] dip ;
C-TYPE: udev_device
FUNCTION: udev_device* udev_device_ref (
udev_device* udev_device ) ;
FUNCTION: void udev_device_unref (
udev_device* udev_device ) ;
FUNCTION: udev* udev_device_get_udev (
udev_device* udev_device ) ;
FUNCTION: udev_device* udev_device_new_from_syspath (
udev* udev,
c-string syspath ) ;
FUNCTION: udev_device* udev_device_new_from_devnum (
udev* udev,
char type,
dev_t devnum ) ;
FUNCTION: udev_device* udev_device_new_from_subsystem_sysname (
udev* udev,
c-string subsystem,
c-string sysname ) ;
FUNCTION: udev_device* udev_device_get_parent (
udev_device* udev_device ) ;
FUNCTION: udev_device* udev_device_get_parent_with_subsystem_devtype (
udev_device* udev_device,
c-string subsystem,
c-string devtype ) ;
FUNCTION: c-string udev_device_get_devpath (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_subsystem (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_devtype (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_syspath (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_sysname (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_sysnum (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_devnode (
udev_device* udev_device ) ;
FUNCTION: udev_list_entry* udev_device_get_devlinks_list_entry (
udev_device* udev_device ) ;
FUNCTION: udev_list_entry* udev_device_get_properties_list_entry (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_property_value (
udev_device* udev_device,
c-string key ) ;
FUNCTION: c-string udev_device_get_driver (
udev_device* udev_device ) ;
FUNCTION: dev_t udev_device_get_devnum (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_action (
udev_device* udev_device ) ;
FUNCTION: ulonglong udev_device_get_seqnum (
udev_device* udev_device ) ;
FUNCTION: c-string udev_device_get_sysattr_value (
udev_device* udev_device,
c-string sysattr ) ;
C-TYPE: udev_monitor
FUNCTION: udev_monitor* udev_monitor_ref (
udev_monitor* udev_monitor ) ;
FUNCTION: void udev_monitor_unref (
udev_monitor* udev_monitor ) ;
FUNCTION: udev* udev_monitor_get_udev (
udev_monitor* udev_monitor ) ;
FUNCTION: udev_monitor* udev_monitor_new_from_netlink (
udev* udev,
c-string name ) ;
FUNCTION: udev_monitor* udev_monitor_new_from_socket (
udev* udev,
c-string socket_path ) ;
FUNCTION: int udev_monitor_enable_receiving (
udev_monitor* udev_monitor ) ;
FUNCTION: int udev_monitor_set_receive_buffer_size (
udev_monitor* udev_monitor,
int size ) ;
FUNCTION: int udev_monitor_get_fd (
udev_monitor* udev_monitor ) ;
FUNCTION: udev_device* udev_monitor_receive_device (
udev_monitor* udev_monitor ) ;
FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype (
udev_monitor* udev_monitor,
c-string subsystem,
c-string devtype ) ;
FUNCTION: int udev_monitor_filter_update (
udev_monitor* udev_monitor ) ;
FUNCTION: int udev_monitor_filter_remove (
udev_monitor* udev_monitor ) ;
C-TYPE: udev_enumerate
FUNCTION: udev_enumerate* udev_enumerate_ref (
udev_enumerate* udev_enumerate ) ;
FUNCTION: void udev_enumerate_unref (
udev_enumerate* udev_enumerate ) ;
FUNCTION: udev* udev_enumerate_get_udev (
udev_enumerate* udev_enumerate ) ;
FUNCTION: udev_enumerate* udev_enumerate_new (
udev* udev ) ;
FUNCTION: int udev_enumerate_add_match_subsystem (
udev_enumerate* udev_enumerate,
c-string subsystem ) ;
FUNCTION: int udev_enumerate_add_nomatch_subsystem (
udev_enumerate* udev_enumerate,
c-string subsystem ) ;
FUNCTION: int udev_enumerate_add_match_sysattr (
udev_enumerate* udev_enumerate,
c-string sysattr,
c-string value ) ;
FUNCTION: int udev_enumerate_add_nomatch_sysattr (
udev_enumerate* udev_enumerate,
c-string sysattr,
c-string value ) ;
FUNCTION: int udev_enumerate_add_match_property (
udev_enumerate* udev_enumerate,
c-string property,
c-string value ) ;
FUNCTION: int udev_enumerate_add_match_sysname (
udev_enumerate* udev_enumerate,
c-string sysname ) ;
FUNCTION: int udev_enumerate_add_syspath (
udev_enumerate* udev_enumerate,
c-string syspath ) ;
FUNCTION: int udev_enumerate_scan_devices (
udev_enumerate* udev_enumerate ) ;
FUNCTION: int udev_enumerate_scan_subsystems (
udev_enumerate* udev_enumerate ) ;
FUNCTION: udev_list_entry* udev_enumerate_get_list_entry (
udev_enumerate* udev_enumerate ) ;
C-TYPE: udev_queue
FUNCTION: udev_queue* udev_queue_ref (
udev_queue* udev_queue ) ;
FUNCTION: void udev_queue_unref (
udev_queue* udev_queue ) ;
FUNCTION: udev* udev_queue_get_udev (
udev_queue* udev_queue ) ;
FUNCTION: udev_queue* udev_queue_new (
udev* udev ) ;
FUNCTION: ulonglong udev_queue_get_kernel_seqnum (
udev_queue* udev_queue ) ;
FUNCTION: ulonglong udev_queue_get_udev_seqnum (
udev_queue* udev_queue ) ;
FUNCTION: int udev_queue_get_udev_is_active (
udev_queue* udev_queue ) ;
FUNCTION: int udev_queue_get_queue_is_empty (
udev_queue* udev_queue ) ;
FUNCTION: int udev_queue_get_seqnum_is_finished (
udev_queue* udev_queue,
ulonglong seqnum ) ;
FUNCTION: int udev_queue_get_seqnum_sequence_is_finished (
udev_queue* udev_queue,
ulonglong start,
ulonglong end ) ;
FUNCTION: udev_list_entry* udev_queue_get_queued_list_entry (
udev_queue* udev_queue ) ;
FUNCTION: udev_list_entry* udev_queue_get_failed_list_entry (
udev_queue* udev_queue ) ;

1
extra/libudev/platforms.txt Normal file
View File

@ -0,0 +1 @@
linux

1
extra/libudev/summary.txt Normal file
View File

@ -0,0 +1 @@
Bindings to libudev

1
extra/libudev/tags.txt Normal file
View File

@ -0,0 +1 @@
bindings

5
extra/mason/config/config.factor
View File

@ -17,11 +17,6 @@ SYMBOL: builder-from
! Who receives build report e-mails.
SYMBOL: builder-recipients
! (Optional) twitter credentials for status updates.
SYMBOL: builder-twitter-username
SYMBOL: builder-twitter-password
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu

11
extra/mason/twitter/twitter.factor
View File

@ -1,14 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger fry kernel mason.config namespaces twitter ;
IN: mason.twitter
: mason-tweet ( message -- )
builder-twitter-username get builder-twitter-password get and
[
[
builder-twitter-username get twitter-username set
builder-twitter-password get twitter-password set
'[ _ tweet ] try
] with-scope
] [ drop ] if ;
twitter-access-token get [ '[ _ tweet ] try ] [ drop ] if ;

1
extra/oauth/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

26
extra/oauth/oauth-tests.factor Normal file
View File

@ -0,0 +1,26 @@
USING: oauth oauth.private tools.test accessors kernel assocs
strings namespaces ;
IN: oauth.tests
[ "%26&b" ] [ "&" "b" hmac-key ] unit-test
[ "%26&" ] [ "&" f hmac-key ] unit-test
[ "B&http%3A%2F%2Ftwitter.com&a%3Db" ] [
"http://twitter.com"
"B"
{ { "a" "b" } }
signature-base-string
] unit-test
[ "Z5tUa83q43qiy6dGGCb92bN/4ik=" ] [
"ABC" "DEF" <token> consumer-token set
"http://twitter.com"
<request-token-params>
12345 >>timestamp
54321 >>nonce
<request-token-request>
post-data>>
"oauth_signature" swap at
>string
] unit-test

159
extra/oauth/oauth.factor Normal file
View File

@ -0,0 +1,159 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs base64 calendar checksums.hmac
checksums.sha combinators fry http http.client kernel locals
make math namespaces present random sequences sorting strings
urls urls.encoding ;
IN: oauth
SYMBOL: consumer-token
TUPLE: token key secret user-data ;
: <token> ( key secret -- token )
token new
swap >>secret
swap >>key ;
<PRIVATE
TUPLE: token-params
consumer-token
timestamp
nonce ;
: new-token-params ( class -- params )
new
consumer-token get >>consumer-token
now timestamp>unix-time >integer >>timestamp
random-32 >>nonce ; inline
:: signature-base-string ( url request-method params -- string )
[
request-method % "&" %
url present url-encode-full % "&" %
params assoc>query url-encode-full %
] "" make ;
: hmac-key ( consumer-secret token-secret -- key )
[ url-encode-full ] [ "" or url-encode-full ] bi* "&" glue ;
: make-token-params ( params quot -- assoc )
'[
"1.0" "oauth_version" set
"HMAC-SHA1" "oauth_signature_method" set
_
[
[ consumer-token>> key>> "oauth_consumer_key" set ]
[ timestamp>> "oauth_timestamp" set ]
[ nonce>> "oauth_nonce" set ]
tri
] bi
] H{ } make-assoc ; inline
:: sign-params ( url request-method consumer-token request-token params -- signed-params )
params >alist sort-keys :> params
url request-method params signature-base-string :> sbs
consumer-token secret>> request-token dup [ secret>> ] when hmac-key :> key
sbs key sha1 hmac-bytes >base64 >string :> signature
params { "oauth_signature" signature } prefix ;
: extract-user-data ( assoc -- assoc' )
[
drop
{ "oauth_token" "oauth_token_secret" } member? not
] assoc-filter ;
: parse-token ( response data -- token )
nip
query>assoc
[ [ "oauth_token" ] dip at ]
[ [ "oauth_token_secret" ] dip at ]
[ extract-user-data ]
tri
[ <token> ] dip >>user-data ;
PRIVATE>
TUPLE: request-token-params < token-params
{ callback-url initial: "oob" } ;
: <request-token-params> ( -- params )
request-token-params new-token-params ;
<PRIVATE
:: <token-request> ( url consumer-token request-token params -- request )
url "POST" consumer-token request-token params sign-params
url
<post-request> ;
: make-request-token-params ( params -- assoc )
[ callback-url>> "oauth_callback" set ] make-token-params ;
: <request-token-request> ( url params -- request )
[ consumer-token>> f ] [ make-request-token-params ] bi
<token-request> ;
PRIVATE>
: obtain-request-token ( url params -- token )
<request-token-request> http-request parse-token ;
TUPLE: access-token-params < token-params request-token verifier ;
: <access-token-params> ( -- params )
access-token-params new-token-params ;
<PRIVATE
: make-access-token-params ( params -- assoc )
[
[ request-token>> key>> "oauth_token" set ]
[ verifier>> "oauth_verifier" set ]
bi
] make-token-params ;
: <access-token-request> ( url params -- request )
[ consumer-token>> ]
[ request-token>> ]
[ make-access-token-params ] tri
<token-request> ;
PRIVATE>
: obtain-access-token ( url params -- token )
<access-token-request> http-request parse-token ;
SYMBOL: access-token
TUPLE: oauth-request-params < token-params access-token ;
: <oauth-request-params> ( -- params )
oauth-request-params new-token-params
access-token get >>access-token ;
<PRIVATE
:: signed-oauth-request-params ( request params -- params )
request url>>
request method>>
params consumer-token>>
params access-token>>
params
[
access-token>> key>> "oauth_token" set
namespace request post-data>> assoc-union! drop
] make-token-params
sign-params ;
: build-auth-string ( params -- string )
[ [ present url-encode-full ] bi@ "\"" "\"" surround "=" glue ] { } assoc>map
", " join "OAuth realm=\"\", " prepend ;
PRIVATE>
: set-oauth ( request params -- request )
dupd signed-oauth-request-params build-auth-string
"Authorization" set-header ;

2
extra/twitter/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Joe Groff
Slava Pestov

25
extra/twitter/prettyprint/prettyprint.factor
View File

@ -23,7 +23,8 @@ CONSTANT: tweet-username-style
CONSTANT: tweet-text-style
H{
{ font-name "sans-serif" }
{ font-size 18 }
{ font-size 16 }
{ wrap-margin 500 }
}
CONSTANT: tweet-metadata-style
@ -36,18 +37,20 @@ CONSTANT: tweet-metadata-style
[
[ dup user>> user-image [ image. ] when* ] with-cell
[
tweet-text-style [
tweet-username-style [
dup user>> screen-name>> write
] with-style
" " write dup text>> print
H{ { wrap-margin 600 } } [
tweet-text-style [
tweet-username-style [
dup user>> screen-name>> write
] with-style
" " write dup text>> print
tweet-metadata-style [
dup created-at>> write
" via " write
dup source>> write
tweet-metadata-style [
dup created-at>> write
" via " write
dup source>> write
] with-style
] with-style
] with-style
] with-nesting
] with-cell
] with-row
] tabular-output nl

46
extra/twitter/twitter.factor
View File

@ -1,17 +1,49 @@
! Copyright (C) 2009 Joe Groff.
! Copyright (C) 2009, 2010 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences
urls.secure fry ;
urls.secure fry oauth urls ;
IN: twitter
! Configuration
SYMBOLS: twitter-username twitter-password twitter-source ;
SYMBOLS: twitter-source twitter-consumer-token twitter-access-token ;
twitter-source [ "factor" ] initialize
: set-twitter-credentials ( username password -- )
[ twitter-username set ] [ twitter-password set ] bi* ;
<PRIVATE
: with-twitter-oauth ( quot -- )
[
twitter-consumer-token get consumer-token set
twitter-access-token get access-token set
call
] with-scope ; inline
PRIVATE>
! obtain-twitter-request-token and obtain-twitter-access-token
! should use https: URLs but Twitter sends a 301 Redirect back
! to the same URL. Twitter bug?
: obtain-twitter-request-token ( -- request-token )
[
"https://twitter.com/oauth/request_token"
<request-token-params>
obtain-request-token
] with-twitter-oauth ;
: twitter-authorize-url ( token -- url )
"https://twitter.com/oauth/authorize" >url
swap key>> "oauth_token" set-query-param ;
: obtain-twitter-access-token ( request-token verifier -- access-token )
[
[ "https://twitter.com/oauth/access_token" ] 2dip
<access-token-params>
swap >>verifier
swap >>request-token
obtain-access-token
] with-twitter-oauth ;
<PRIVATE
@ -20,12 +52,11 @@ MACRO: keys-boa ( keys class -- )
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
! Twitter requests
: twitter-url ( string -- url )
"https://twitter.com/statuses/" ".json" surround ;
: set-request-twitter-auth ( request -- request )
twitter-username get twitter-password get set-basic-auth ;
[ <oauth-request-params> set-oauth ] with-twitter-oauth ;
: twitter-request ( request -- data )
set-request-twitter-auth
@ -45,6 +76,7 @@ TUPLE: twitter-status
in-reply-to-user-id
favorited?
user ;
TUPLE: twitter-user
id
name

BIN
misc/icons/Factor.ico
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 15 KiB

After

Width:  |  Height:  |  Size: 15 KiB

BIN
misc/icons/Factor_128x128.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 12 KiB

After

Width:  |  Height:  |  Size: 16 KiB

BIN
misc/icons/Factor_16x16.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 783 B

After

Width:  |  Height:  |  Size: 3.3 KiB

BIN
misc/icons/Factor_32x32.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 2.3 KiB

After

Width:  |  Height:  |  Size: 4.9 KiB

BIN
misc/icons/Factor_48x48.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.4 KiB

After

Width:  |  Height:  |  Size: 7.1 KiB