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
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 )
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
\ ##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 ]
! 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
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
! 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? [
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 -- ? )
[ 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-assembly emit-node
+M: #alien-indirect emit-node ( node -- )
+ params>>
[
- {
- [ caller-parameters ]
- [ quot>> ##alien-assembly ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave
- ] emit-alien-block ;
+ ds-pop ^^unbox-any-c-ptr
+ [ caller-parameters ] dip
+ <gc-map> ##alien-indirect
+ ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ tri ;
+
+M: #alien-assembly emit-node
+ 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
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
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 ;
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 ;
: finalize-cfg ( cfg -- cfg' )
select-representations
- schedule-instructions
+ ! schedule-instructions
insert-gc-checks
dup compute-uninitialized-sets
insert-save-contexts
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 ;
[ 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
[ 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
-
-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
+4 \ vreg-counter set-global
-[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+[ t ] [ <gc-call> gc-call? ] unit-test
30 \ vreg-counter set-global
[ ] [ 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
} 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
! 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
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 ;
: 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
-
-! Any ##phi instructions at the start of bb are transplanted
-! into the gc-check block.
-
-: <gc-check> ( phis size -- bb )
- [ <basic-block> ] 2dip
- [
- [ % ]
- [
- cc<= int-rep next-vreg-rep int-rep next-vreg-rep
- ##check-nursery-branch
- ] bi*
- ] V{ } make >>instructions ;
-
-: <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<<
+GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
- V{ check body } bb predecessors<<
+:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
+ seen-allocation? [ call-index , ] when
+ insn-index 1 + f ;
- check predecessors>> [ bb check update-successors ] each ;
+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 ;
-: (insert-gc-check) ( phis size bb -- )
- [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+: 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.
+ [
+ [ 0 f ] dip
+ [ gc-check-offsets* ] each-index
+ [ , ] [ drop ] if
+ ] { } make ;
+
+:: 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 )
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 ;
+
+: make-blocks ( insns-seq -- bbs )
+ [ <basic-block> swap >>instructions ] map ;
-: insert-gc-check ( bb -- )
- [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
+: <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 ;
literal: gc-map ;
INSN: ##alien-assembly
-literal: quot ;
+literal: quot gc-map ;
INSN: ##begin-callback ;
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
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 ;
! 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 ;
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 ;
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
] [
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
! 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 ;
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 -- )
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
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 ;
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 ( -- )
: 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 ;
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
: 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 ;
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
! 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
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
[ "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 ;
{ $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."
] 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* ;
[ 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
+
[ 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. ;
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 ;
] [
[ \ 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
+
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
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
-! 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 ;
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 ;
vocabs:dictionary
vocabs:load-vocab-hook
vocabs:vocab-observers
+ vocabs.loader:add-vocab-root-hook
word
parser-notes
} %
: 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 ]
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
--- /dev/null
+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 }
+}
--- /dev/null
+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.
--- /dev/null
+license.txt
-! 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
: <retainstack-display> ( model -- gadget )
[ retain>> ] "Retain stack" <stack-display> ;
-TUPLE: traceback-gadget < track ;
+TUPLE: traceback-gadget < tool ;
: <traceback-gadget> ( model -- gadget )
[
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 ) ;
[ 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
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
! 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 ;
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> ;
: 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 ]
! 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 ;
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
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 ]
[ 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
--- /dev/null
+Dmitry Shubin
--- /dev/null
+Dmitry Shubin
--- /dev/null
+! 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 ) ;
--- /dev/null
+! 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"
--- /dev/null
+! 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
--- /dev/null
+! 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
+
--- /dev/null
+GNU DataBase Manager
--- /dev/null
+bindings
+database
--- /dev/null
+Niklas Waern
--- /dev/null
+! 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 ) ;
+
+
+
--- /dev/null
+Bindings to libudev
! 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
-! 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 ;
\ No newline at end of file
+ twitter-access-token get [ '[ _ tweet ] try ] [ drop ] if ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+Joe Groff
+Slava Pestov
CONSTANT: tweet-text-style
H{
{ font-name "sans-serif" }
- { font-size 18 }
+ { font-size 16 }
+ { wrap-margin 500 }
}
CONSTANT: tweet-metadata-style
[
[ dup user>> user-image [ image. ] when* ] with-cell
[
- tweet-text-style [
- tweet-username-style [
- dup user>> screen-name>> write
+ 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
+ ] with-style
] with-style
- " " write dup text>> print
-
- tweet-metadata-style [
- dup created-at>> write
- " via " write
- dup source>> write
- ] with-style
- ] with-style
+ ] with-nesting
] with-cell
] with-row
] tabular-output nl
-! 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
[ [ '[ _ 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
in-reply-to-user-id
favorited?
user ;
+
TUPLE: twitter-user
id
name