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

Merge branch 'master' of git://factorcode.org/git/factor into llvm

db4
Matthew Willis 2009-06-23 14:02:08 +09:00
parent ded676e4e3 85acbf4abc
commit 2f80903224
43 changed files with 946 additions and 727 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib generated
View File

@ -3,15 +3,13 @@
<plist version="1.0"> <plist version="1.0">
<dict> <dict>
<key>IBFramework Version</key> <key>IBFramework Version</key>
<string>629</string> <string>677</string>
<key>IBOldestOS</key> <key>IBOldestOS</key>
<integer>5</integer> <integer>5</integer>
<key>IBOpenObjects</key> <key>IBOpenObjects</key>
<array> <array/>
<integer>305</integer>
</array>
<key>IBSystem Version</key> <key>IBSystem Version</key>
<string>9G55</string> <string>9J61</string>
<key>targetFramework</key> <key>targetFramework</key>
<string>IBCocoaFramework</string> <string>IBCocoaFramework</string>
</dict> </dict>

BIN
Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib generated
View File

Binary file not shown.

49
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib generated
View File

@ -1,17 +1,32 @@
{ <?xml version="1.0" encoding="UTF-8"?>
IBClasses = ( <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
{ <plist version="1.0">
ACTIONS = { <dict>
newFactorWorkspace = id; <key>IBClasses</key>
runFactorFile = id; <array>
saveFactorImage = id; <dict>
saveFactorImageAs = id; <key>ACTIONS</key>
showFactorHelp = id; <dict>
}; <key>newFactorWorkspace</key>
CLASS = FirstResponder; <string>id</string>
LANGUAGE = ObjC; <key>runFactorFile</key>
SUPERCLASS = NSObject; <string>id</string>
} <key>saveFactorImage</key>
); <string>id</string>
IBVersion = 1; <key>saveFactorImageAs</key>
} <string>id</string>
<key>showFactorHelp</key>
<string>id</string>
</dict>
<key>CLASS</key>
<string>FirstResponder</string>
<key>LANGUAGE</key>
<string>ObjC</string>
<key>SUPERCLASS</key>
<string>NSObject</string>
</dict>
</array>
<key>IBVersion</key>
<string>1</string>
</dict>
</plist>

19
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib generated
View File

@ -1,21 +1,18 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0"> <plist version="1.0">
<dict> <dict>
<key>IBDocumentLocation</key>
<string>1266 155 525 491 0 0 2560 1578 </string>
<key>IBEditorPositions</key>
<dict>
<key>29</key>
<string>326 905 270 44 0 0 2560 1578 </string>
</dict>
<key>IBFramework Version</key> <key>IBFramework Version</key>
<string>439.0</string> <string>677</string>
<key>IBOldestOS</key>
<integer>5</integer>
<key>IBOpenObjects</key> <key>IBOpenObjects</key>
<array> <array>
<integer>29</integer> <integer>293</integer>
</array> </array>
<key>IBSystem Version</key> <key>IBSystem Version</key>
<string>8R218</string> <string>9J61</string>
<key>targetFramework</key>
<string>IBCocoaFramework</string>
</dict> </dict>
</plist> </plist>

BIN
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib generated
View File

Binary file not shown.

3
basis/cairo/cairo.factor
View File

@ -31,7 +31,8 @@ ERROR: cairo-error message ;
<cairo> &cairo_destroy <cairo> &cairo_destroy
@ @
] make-memory-bitmap ] make-memory-bitmap
BGRA >>component-order ; inline BGRA >>component-order
ubyte-components >>component-type ; inline
: dummy-cairo ( -- cr ) : dummy-cairo ( -- cr )
#! Sometimes we want a dummy context; eg with Pango, we want #! Sometimes we want a dummy context; eg with Pango, we want

4
basis/cocoa/windows/windows-docs.factor
View File

@ -2,11 +2,11 @@ USING: help.markup help.syntax ;
IN: cocoa.windows IN: cocoa.windows
HELP: <NSWindow> HELP: <NSWindow>
{ $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } } { $values { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "class" "an Objective-C class" } { "window" "an " { $snippet "NSWindow" } } }
{ $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions." } ; { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions." } ;
HELP: <ViewWindow> HELP: <ViewWindow>
{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } } { $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "window" "an " { $snippet "NSWindow" } } }
{ $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ; { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ;
ARTICLE: "cocoa-window-utils" "Cocoa window utilities" ARTICLE: "cocoa-window-utils" "Cocoa window utilities"

32
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -40,16 +40,23 @@ ERROR: already-spilled ;
2dup key? [ already-spilled ] [ set-at ] if ; 2dup key? [ already-spilled ] [ set-at ] if ;
: insert-spill ( live-interval -- ) : insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ; {
[ reg>> ]
[ vreg>> reg-class>> ]
[ spill-to>> ]
[ end>> ]
} cleave f swap \ _spill boa , ;
: handle-spill ( live-interval -- ) : handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
: insert-copy ( live-interval -- ) : insert-copy ( live-interval -- )
[ split-next>> reg>> ] {
[ reg>> ] [ split-next>> reg>> ]
[ vreg>> reg-class>> ] [ reg>> ]
tri _copy ; [ vreg>> reg-class>> ]
[ end>> ]
} cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- ) : handle-copy ( live-interval -- )
dup [ spill-to>> not ] [ split-next>> ] bi and dup [ spill-to>> not ] [ split-next>> ] bi and
@ -68,7 +75,12 @@ ERROR: already-reloaded ;
2dup key? [ delete-at ] [ already-reloaded ] if ; 2dup key? [ delete-at ] [ already-reloaded ] if ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; {
[ reg>> ]
[ vreg>> reg-class>> ]
[ reload-from>> ]
[ end>> ]
} cleave f swap \ _reload boa , ;
: handle-reload ( live-interval -- ) : handle-reload ( live-interval -- )
dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ; dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
@ -102,7 +114,9 @@ M: vreg-insn assign-registers-in-insn
>>regs drop ; >>regs drop ;
: compute-live-registers ( insn -- regs ) : compute-live-registers ( insn -- regs )
active-intervals register-mapping ; [ active-intervals ] [ temp-vregs ] bi
'[ vreg>> _ memq? not ] filter
register-mapping ;
: compute-live-spill-slots ( -- spill-slots ) : compute-live-spill-slots ( -- spill-slots )
spill-slots get values [ values ] map concat spill-slots get values [ values ] map concat
@ -139,6 +153,6 @@ M: insn assign-registers-in-insn drop ;
] V{ } make ] V{ } make
] change-instructions drop ; ] change-instructions drop ;
: assign-registers ( rpo live-intervals -- ) : assign-registers ( live-intervals rpo -- )
init-assignment [ init-assignment ] dip
[ assign-registers-in-block ] each ; [ assign-registers-in-block ] each ;

9
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays math strings fry USING: accessors kernel sequences sets arrays math strings fry
prettyprint compiler.cfg.linear-scan.live-intervals namespaces prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation ; compiler.cfg.linear-scan.allocation compiler.cfg ;
IN: compiler.cfg.linear-scan.debugger IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- ) : check-assigned ( live-intervals -- )
@ -34,3 +34,6 @@ IN: compiler.cfg.linear-scan.debugger
: live-intervals. ( seq -- ) : live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ; [ interval-picture ] map simple-table. ;
: test-bb ( insns n -- )
[ <basic-block> swap >>number swap >>instructions ] keep set ;

635
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -10,6 +10,8 @@ compiler.cfg.registers
compiler.cfg.liveness compiler.cfg.liveness
compiler.cfg.predecessors compiler.cfg.predecessors
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.linearization
compiler.cfg.debugger
compiler.cfg.linear-scan compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
@ -410,7 +412,7 @@ SYMBOL: max-uses
[ ] [ 10 20 2 400 random-test ] unit-test [ ] [ 10 20 2 400 random-test ] unit-test
[ ] [ 10 20 4 300 random-test ] unit-test [ ] [ 10 20 4 300 random-test ] unit-test
USING: math.private compiler.cfg.debugger ; USING: math.private ;
[ ] [ [ ] [
[ float+ float>fixnum 3 fixnum*fast ] [ float+ float>fixnum 3 fixnum*fast ]
@ -1417,194 +1419,149 @@ USING: math.private compiler.cfg.debugger ;
! Bug in live spill slots calculation ! Bug in live spill slots calculation
T{ basic-block V{ T{ ##prologue } T{ ##branch } } 0 test-bb
{ id 205651 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block V{
{ id 205652 } T{ ##peek
{ number 1 } { dst V int-regs 703128 }
{ instructions { loc D 1 }
V{ }
T{ ##peek T{ ##peek
{ dst V int-regs 703128 } { dst V int-regs 703129 }
{ loc D 1 } { loc D 0 }
} }
T{ ##peek T{ ##copy
{ dst V int-regs 703129 } { dst V int-regs 703134 }
{ loc D 0 } { src V int-regs 703128 }
} }
T{ ##copy T{ ##copy
{ dst V int-regs 703134 } { dst V int-regs 703135 }
{ src V int-regs 703128 } { src V int-regs 703129 }
} }
T{ ##copy T{ ##compare-imm-branch
{ dst V int-regs 703135 } { src1 V int-regs 703128 }
{ src V int-regs 703129 } { src2 5 }
} { cc cc/= }
T{ ##compare-imm-branch }
{ src1 V int-regs 703128 } } 1 test-bb
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block V{
{ id 205653 } T{ ##copy
{ number 2 } { dst V int-regs 703134 }
{ instructions { src V int-regs 703129 }
V{ }
T{ ##copy T{ ##copy
{ dst V int-regs 703134 } { dst V int-regs 703135 }
{ src V int-regs 703129 } { src V int-regs 703128 }
} }
T{ ##copy T{ ##branch }
{ dst V int-regs 703135 } } 2 test-bb
{ src V int-regs 703128 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block V{
{ id 205655 } T{ ##replace
{ number 3 } { src V int-regs 703134 }
{ instructions { loc D 0 }
V{ }
T{ ##replace T{ ##replace
{ src V int-regs 703134 } { src V int-regs 703135 }
{ loc D 0 } { loc D 1 }
} }
T{ ##replace T{ ##epilogue }
{ src V int-regs 703135 } T{ ##return }
{ loc D 1 } } 3 test-bb
}
T{ ##epilogue }
T{ ##return }
}
}
} 3 set
1 get 1vector 0 get (>>successors) 1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors) 2 get 3 get V{ } 2sequence 1 get (>>successors)
3 get 1vector 2 get (>>successors) 3 get 1vector 2 get (>>successors)
SYMBOL: linear-scan-result
:: test-linear-scan-on-cfg ( regs -- ) :: test-linear-scan-on-cfg ( regs -- )
[ ] [ [ ] [
cfg new 0 get >>entry cfg new 0 get >>entry
compute-predecessors compute-predecessors
compute-liveness compute-liveness
reverse-post-order dup reverse-post-order
{ { int-regs regs } } (linear-scan) { { int-regs regs } } (linear-scan)
flatten-cfg 1array mr.
] unit-test ; ] unit-test ;
{ 1 2 } test-linear-scan-on-cfg ! This test has a critical edge -- do we care about these?
! { 1 2 } test-linear-scan-on-cfg
! Bug in inactive interval handling ! Bug in inactive interval handling
! [ rot dup [ -rot ] when ] ! [ rot dup [ -rot ] when ]
T{ basic-block V{ T{ ##prologue } T{ ##branch } } 0 test-bb
{ id 201486 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block V{
{ id 201487 } T{ ##peek
{ number 1 } { dst V int-regs 689473 }
{ instructions { loc D 2 }
V{ }
T{ ##peek T{ ##peek
{ dst V int-regs 689473 } { dst V int-regs 689474 }
{ loc D 2 } { loc D 1 }
} }
T{ ##peek T{ ##peek
{ dst V int-regs 689474 } { dst V int-regs 689475 }
{ loc D 1 } { loc D 0 }
} }
T{ ##peek T{ ##compare-imm-branch
{ dst V int-regs 689475 } { src1 V int-regs 689473 }
{ loc D 0 } { src2 5 }
} { cc cc/= }
T{ ##compare-imm-branch }
{ src1 V int-regs 689473 } } 1 test-bb
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block V{
{ id 201488 } T{ ##copy
{ number 2 } { dst V int-regs 689481 }
{ instructions { src V int-regs 689475 }
V{ }
T{ ##copy T{ ##copy
{ dst V int-regs 689481 } { dst V int-regs 689482 }
{ src V int-regs 689475 } { src V int-regs 689474 }
} }
T{ ##copy T{ ##copy
{ dst V int-regs 689482 } { dst V int-regs 689483 }
{ src V int-regs 689474 } { src V int-regs 689473 }
} }
T{ ##copy T{ ##branch }
{ dst V int-regs 689483 } } 2 test-bb
{ src V int-regs 689473 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block V{
{ id 201489 } T{ ##copy
{ number 3 } { dst V int-regs 689481 }
{ instructions { src V int-regs 689473 }
V{ }
T{ ##copy T{ ##copy
{ dst V int-regs 689481 } { dst V int-regs 689482 }
{ src V int-regs 689473 } { src V int-regs 689475 }
} }
T{ ##copy T{ ##copy
{ dst V int-regs 689482 } { dst V int-regs 689483 }
{ src V int-regs 689475 } { src V int-regs 689474 }
} }
T{ ##copy T{ ##branch }
{ dst V int-regs 689483 } } 3 test-bb
{ src V int-regs 689474 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block V{
{ id 201490 } T{ ##replace
{ number 4 } { src V int-regs 689481 }
{ instructions { loc D 0 }
V{ }
T{ ##replace T{ ##replace
{ src V int-regs 689481 } { src V int-regs 689482 }
{ loc D 0 } { loc D 1 }
} }
T{ ##replace T{ ##replace
{ src V int-regs 689482 } { src V int-regs 689483 }
{ loc D 1 } { loc D 2 }
} }
T{ ##replace T{ ##epilogue }
{ src V int-regs 689483 } T{ ##return }
{ loc D 2 } } 4 test-bb
}
T{ ##epilogue }
T{ ##return }
}
}
} 4 set
: test-diamond ( -- ) : test-diamond ( -- )
1 get 1vector 0 get (>>successors) 1 get 1vector 0 get (>>successors)
@ -1625,102 +1582,78 @@ T{ basic-block
{ instructions V{ T{ ##prologue } T{ ##branch } } } { instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set } 0 set
T{ basic-block V{
{ id 201538 } T{ ##peek
{ number 1 } { dst V int-regs 689600 }
{ instructions { loc D 1 }
V{ }
T{ ##peek T{ ##peek
{ dst V int-regs 689600 } { dst V int-regs 689601 }
{ loc D 1 } { loc D 0 }
} }
T{ ##peek T{ ##compare-imm-branch
{ dst V int-regs 689601 } { src1 V int-regs 689600 }
{ loc D 0 } { src2 5 }
} { cc cc/= }
T{ ##compare-imm-branch }
{ src1 V int-regs 689600 } } 1 test-bb
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block V{
{ id 201539 } T{ ##peek
{ number 2 } { dst V int-regs 689604 }
{ instructions { loc D 2 }
V{ }
T{ ##peek T{ ##copy
{ dst V int-regs 689604 } { dst V int-regs 689607 }
{ loc D 2 } { src V int-regs 689604 }
} }
T{ ##copy T{ ##copy
{ dst V int-regs 689607 } { dst V int-regs 689608 }
{ src V int-regs 689604 } { src V int-regs 689600 }
} }
T{ ##copy T{ ##copy
{ dst V int-regs 689608 } { dst V int-regs 689610 }
{ src V int-regs 689600 } { src V int-regs 689601 }
} }
T{ ##copy T{ ##branch }
{ dst V int-regs 689610 } } 2 test-bb
{ src V int-regs 689601 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block V{
{ id 201540 } T{ ##peek
{ number 3 } { dst V int-regs 689609 }
{ instructions { loc D 2 }
V{ }
T{ ##peek T{ ##copy
{ dst V int-regs 689609 } { dst V int-regs 689607 }
{ loc D 2 } { src V int-regs 689600 }
} }
T{ ##copy T{ ##copy
{ dst V int-regs 689607 } { dst V int-regs 689608 }
{ src V int-regs 689600 } { src V int-regs 689601 }
} }
T{ ##copy T{ ##copy
{ dst V int-regs 689608 } { dst V int-regs 689610 }
{ src V int-regs 689601 } { src V int-regs 689609 }
} }
T{ ##copy T{ ##branch }
{ dst V int-regs 689610 } } 3 test-bb
{ src V int-regs 689609 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block V{
{ id 201541 } T{ ##replace
{ number 4 } { src V int-regs 689607 }
{ instructions { loc D 0 }
V{ }
T{ ##replace T{ ##replace
{ src V int-regs 689607 } { src V int-regs 689608 }
{ loc D 0 } { loc D 1 }
} }
T{ ##replace T{ ##replace
{ src V int-regs 689608 } { src V int-regs 689610 }
{ loc D 1 } { loc D 2 }
} }
T{ ##replace T{ ##epilogue }
{ src V int-regs 689610 } T{ ##return }
{ loc D 2 } } 4 test-bb
}
T{ ##epilogue }
T{ ##return }
}
}
} 4 set
test-diamond test-diamond
@ -1729,76 +1662,130 @@ test-diamond
! compute-live-registers was inaccurate since it didn't take ! compute-live-registers was inaccurate since it didn't take
! lifetime holes into account ! lifetime holes into account
T{ basic-block V{ T{ ##prologue } T{ ##branch } } 0 test-bb
{ id 0 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block V{
{ id 1 } T{ ##peek
{ instructions { dst V int-regs 0 }
V{ { loc D 0 }
T{ ##peek }
{ dst V int-regs 0 } T{ ##compare-imm-branch
{ loc D 0 } { src1 V int-regs 0 }
} { src2 5 }
T{ ##compare-imm-branch { cc cc/= }
{ src1 V int-regs 0 } }
{ src2 5 } } 1 test-bb
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block V{
{ id 2 } T{ ##peek
{ instructions { dst V int-regs 1 }
V{ { loc D 1 }
T{ ##peek }
{ dst V int-regs 1 } T{ ##copy
{ loc D 1 } { dst V int-regs 2 }
} { src V int-regs 1 }
T{ ##copy }
{ dst V int-regs 2 } T{ ##branch }
{ src V int-regs 1 } } 2 test-bb
}
T{ ##branch }
}
}
} 2 set
T{ basic-block V{
{ id 3 } T{ ##peek
{ instructions { dst V int-regs 3 }
V{ { loc D 2 }
T{ ##peek }
{ dst V int-regs 3 } T{ ##copy
{ loc D 2 } { dst V int-regs 2 }
} { src V int-regs 3 }
T{ ##copy }
{ dst V int-regs 2 } T{ ##branch }
{ src V int-regs 3 } } 3 test-bb
}
T{ ##branch }
}
}
} 3 set
T{ basic-block V{
{ id 4 } T{ ##replace
{ instructions { src V int-regs 2 }
V{ { loc D 0 }
T{ ##replace }
{ src V int-regs 2 } T{ ##return }
{ loc D 0 } } 4 test-bb
}
T{ ##return }
}
}
} 4 set
test-diamond test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg { 1 2 3 4 } test-linear-scan-on-cfg
! Inactive interval handling: splitting active interval
! if it fits in lifetime hole only partially
V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
V{
T{ ##peek f V int-regs 2 R 0 }
T{ ##compare-imm-branch f V int-regs 2 5 cc= }
} 1 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 2 }
T{ ##branch }
} 3 test-bb
V{
T{ ##replace f V int-regs 3 R 2 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##return }
} 4 test-bb
test-diamond
{ 1 2 } test-linear-scan-on-cfg
USING: classes ;
[ ] [
1 get instructions>> first regs>> V int-regs 0 swap at
2 get instructions>> first regs>> V int-regs 1 swap at assert=
] unit-test
[ _copy ] [ 3 get instructions>> second class ] unit-test
! Resolve pass; make sure the spilling is done correctly
V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
V{
T{ ##peek f V int-regs 2 R 0 }
T{ ##compare-imm-branch f V int-regs 2 5 cc= }
} 1 test-bb
V{
T{ ##branch }
} 2 test-bb
V{
T{ ##replace f V int-regs 3 R 1 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 2 }
T{ ##replace f V int-regs 0 D 2 }
T{ ##branch }
} 3 test-bb
V{
T{ ##replace f V int-regs 3 R 2 }
T{ ##return }
} 4 test-bb
test-diamond
{ 1 2 } test-linear-scan-on-cfg
[ _spill ] [ 2 get instructions>> first class ] unit-test
[ _spill ] [ 3 get instructions>> second class ] unit-test
[ _reload ] [ 4 get instructions>> first class ] unit-test

16
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make USING: kernel accessors namespaces make locals
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.rpo compiler.cfg.rpo
@ -9,7 +9,8 @@ compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment ; compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.resolve ;
IN: compiler.cfg.linear-scan IN: compiler.cfg.linear-scan
! References: ! References:
@ -26,12 +27,11 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith ! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( rpo machine-registers -- ) :: (linear-scan) ( rpo machine-registers -- )
[ rpo number-instructions
dup number-instructions rpo compute-live-intervals machine-registers allocate-registers
dup compute-live-intervals rpo assign-registers
] dip rpo resolve-data-flow ;
allocate-registers assign-registers ;
: linear-scan ( cfg -- cfg' ) : linear-scan ( cfg -- cfg' )
[ [

65
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor Normal file
View File

@ -0,0 +1,65 @@
USING: accessors arrays compiler.cfg compiler.cfg.instructions
compiler.cfg.linear-scan.debugger
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
namespaces tools.test vectors ;
IN: compiler.cfg.linear-scan.resolve.tests
[ { 1 2 3 4 5 6 } ] [
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
] unit-test
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 0 test-bb
V{
T{ ##replace f V int-regs 0 D 1 }
T{ ##return }
} 1 test-bb
1 get 1vector 0 get (>>successors)
cfg new 0 get >>entry
compute-predecessors
dup reverse-post-order number-instructions
drop
CONSTANT: test-live-interval-1
T{ live-interval
{ start 0 }
{ end 6 }
{ uses V{ 0 6 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
{ spill-to 0 }
{ vreg V int-regs 0 }
}
[ f ] [
0 get test-live-interval-1 spill-to
] unit-test
[ 0 ] [
1 get test-live-interval-1 spill-to
] unit-test
CONSTANT: test-live-interval-2
T{ live-interval
{ start 0 }
{ end 6 }
{ uses V{ 0 6 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
{ reload-from 0 }
{ vreg V int-regs 0 }
}
[ 0 ] [
0 get test-live-interval-2 reload-from
] unit-test
[ f ] [
1 get test-live-interval-2 reload-from
] unit-test

116
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -1,34 +1,118 @@
! Copyright (C) 2009 Slava Pestov ! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences USING: accessors assocs kernel math namespaces sequences
compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ; classes.tuple classes.parser parser fry words make arrays
locals combinators compiler.cfg.linear-scan.live-intervals
compiler.cfg.liveness compiler.cfg.instructions ;
IN: compiler.cfg.linear-scan.resolve IN: compiler.cfg.linear-scan.resolve
: add-mapping ( from to -- ) <<
2drop
; TUPLE: operation from to reg-class ;
SYNTAX: OPERATION:
CREATE-CLASS dup save-location
[ operation { } define-tuple-class ]
[
[ scan-word scan-word ] keep
'[
[ [ _ execute ] [ _ execute ] bi* ]
[ vreg>> reg-class>> ]
bi _ boa ,
] (( from to -- )) define-declared
] bi ;
>>
: reload-from ( bb live-interval -- n/f )
2dup [ block-from ] [ start>> ] bi* =
[ nip reload-from>> ] [ 2drop f ] if ;
: spill-to ( bb live-interval -- n/f )
2dup [ block-to ] [ end>> ] bi* =
[ nip spill-to>> ] [ 2drop f ] if ;
OPERATION: memory->memory spill-to>> reload-from>>
OPERATION: register->memory reg>> reload-from>>
OPERATION: memory->register spill-to>> reg>>
OPERATION: register->register reg>> reg>>
:: add-mapping ( bb1 bb2 li1 li2 -- )
bb2 li2 reload-from [
bb1 li1 spill-to
[ li1 li2 memory->memory ]
[ li1 li2 register->memory ] if
] [
bb1 li1 spill-to
[ li1 li2 memory->register ]
[ li1 li2 register->register ] if
] if ;
: resolve-value-data-flow ( bb to vreg -- ) : resolve-value-data-flow ( bb to vreg -- )
[ 2dup ] dip
live-intervals get at live-intervals get at
[ [ block-to ] dip child-interval-at ] [ [ block-to ] dip child-interval-at ]
[ [ block-from ] dip child-interval-at ] [ [ block-from ] dip child-interval-at ]
bi-curry bi* 2dup = [ 2drop ] [ bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;
add-mapping
: compute-mappings ( bb to -- mappings )
[
dup live-in keys
[ resolve-value-data-flow ] with with each
] { } make ;
GENERIC: >insn ( operation -- )
M: memory->memory >insn
[ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
M: register->memory >insn
[ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
M: memory->register >insn
[ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
: mapping-instructions ( mappings -- insns )
[ [ >insn ] each ] { } make ;
: fork? ( from to -- ? )
[ successors>> length 1 >= ]
[ predecessors>> length 1 = ] bi* and ; inline
: insert-position/fork ( from to -- before after )
nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
: join? ( from to -- ? )
[ successors>> length 1 = ]
[ predecessors>> length 1 >= ] bi* and ; inline
: insert-position/join ( from to -- before after )
drop instructions>> dup pop 1array ;
: insert-position ( bb to -- before after )
{
{ [ 2dup fork? ] [ insert-position/fork ] }
{ [ 2dup join? ] [ insert-position/join ] }
} cond ;
: 3append-here ( seq2 seq1 seq3 -- )
#! Mutate seq1
swap '[ _ push-all ] bi@ ;
: perform-mappings ( mappings bb to -- )
pick empty? [ 3drop ] [
[ mapping-instructions ] 2dip
insert-position 3append-here
] if ; ] if ;
: resolve-mappings ( bb to -- )
2drop
;
: resolve-edge-data-flow ( bb to -- ) : resolve-edge-data-flow ( bb to -- )
[ dup live-in [ resolve-value-data-flow ] with with each ] [ compute-mappings ] [ perform-mappings ] 2bi ;
[ resolve-mappings ]
2bi ;
: resolve-block-data-flow ( bb -- ) : resolve-block-data-flow ( bb -- )
dup successors>> [ dup successors>> [ resolve-edge-data-flow ] with each ;
resolve-edge-data-flow
] with each ;
: resolve-data-flow ( rpo -- ) : resolve-data-flow ( rpo -- )
[ resolve-block-data-flow ] each ; [ resolve-block-data-flow ] each ;

3
basis/core-graphics/core-graphics.factor
View File

@ -140,4 +140,5 @@ PRIVATE>
: make-bitmap-image ( dim quot -- image ) : make-bitmap-image ( dim quot -- image )
'[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap '[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap
ARGB >>component-order ; inline ARGB >>component-order
ubyte-components >>component-type ; inline

2
basis/images/bitmap/loading/loading.factor
View File

@ -370,5 +370,5 @@ M: bitmap-image load-image* ( path bitmap-image -- bitmap )
[ loading-bitmap>bytes >>bitmap ] [ loading-bitmap>bytes >>bitmap ]
[ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ] [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ header>> height>> 0 < not >>upside-down? ] [ header>> height>> 0 < not >>upside-down? ]
[ bitmap>component-order >>component-order ] [ bitmap>component-order >>component-order ubyte-components >>component-type ]
} cleave ; } cleave ;

4
basis/images/images-tests.factor
View File

@ -3,7 +3,7 @@
USING: images tools.test kernel accessors ; USING: images tools.test kernel accessors ;
IN: images.tests IN: images.tests
[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{ [ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
@ -19,7 +19,7 @@ IN: images.tests
57 57 57 255 57 57 57 255
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{ } ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0

74
basis/images/images.factor
View File

@ -3,12 +3,58 @@
USING: combinators kernel accessors sequences math arrays ; USING: combinators kernel accessors sequences math arrays ;
IN: images IN: images
SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR SINGLETONS:
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
ubyte-components ushort-components
half-components float-components
byte-integer-components ubyte-integer-components
short-integer-components ushort-integer-components
int-integer-components uint-integer-components ;
UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; UNION: component-order
L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
: bytes-per-pixel ( component-order -- n ) UNION: component-type
ubyte-components ushort-components
half-components float-components
byte-integer-components ubyte-integer-components
short-integer-components ushort-integer-components
int-integer-components uint-integer-components ;
UNION: unnormalized-integer-components
byte-integer-components ubyte-integer-components
short-integer-components ushort-integer-components
int-integer-components uint-integer-components ;
UNION: alpha-channel BGRA RGBA ABGR ARGB ;
TUPLE: image dim component-order component-type upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path class -- image )
DEFER: bytes-per-pixel
<PRIVATE
: bytes-per-component ( component-type -- n )
{
{ ubyte-components [ 1 ] }
{ ushort-components [ 2 ] }
{ half-components [ 2 ] }
{ float-components [ 4 ] }
{ byte-integer-components [ 1 ] }
{ ubyte-integer-components [ 1 ] }
{ short-integer-components [ 2 ] }
{ ushort-integer-components [ 2 ] }
{ int-integer-components [ 4 ] }
{ uint-integer-components [ 4 ] }
} case ;
: component-count ( component-order -- n )
{ {
{ L [ 1 ] } { L [ 1 ] }
{ LA [ 2 ] } { LA [ 2 ] }
@ -22,25 +68,11 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
{ XRGB [ 4 ] } { XRGB [ 4 ] }
{ BGRX [ 4 ] } { BGRX [ 4 ] }
{ XBGR [ 4 ] } { XBGR [ 4 ] }
{ R16G16B16 [ 6 ] }
{ R32G32B32 [ 12 ] }
{ R16G16B16A16 [ 8 ] }
{ R32G32B32A32 [ 16 ] }
} case ; } case ;
TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path class -- image )
<PRIVATE
: pixel@ ( x y image -- start end bitmap ) : pixel@ ( x y image -- start end bitmap )
[ dim>> first * + ] [ dim>> first * + ]
[ component-order>> bytes-per-pixel [ * dup ] keep + ] [ bytes-per-pixel [ * dup ] keep + ]
[ bitmap>> ] tri ; [ bitmap>> ] tri ;
: set-subseq ( new-value from to victim -- ) : set-subseq ( new-value from to victim -- )
@ -48,6 +80,10 @@ GENERIC: load-image* ( path class -- image )
PRIVATE> PRIVATE>
: bytes-per-pixel ( image -- n )
[ component-order>> component-count ]
[ component-type>> bytes-per-component ] bi * ;
: pixel-at ( x y image -- pixel ) : pixel-at ( x y image -- pixel )
pixel@ subseq ; pixel@ subseq ;

1
basis/images/jpeg/jpeg.factor
View File

@ -298,6 +298,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: setup-bitmap ( image -- ) : setup-bitmap ( image -- )
dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
BGR >>component-order BGR >>component-order
ubyte-components >>component-type
f >>upside-down? f >>upside-down?
dup dim>> first2 * 3 * 0 <array> >>bitmap dup dim>> first2 * 3 * 0 <array> >>bitmap
drop ; drop ;

2
basis/images/png/png.factor
View File

@ -85,7 +85,7 @@ ERROR: unimplemented-color-type image ;
[ <image> ] dip { [ <image> ] dip {
[ png-image-bytes >>bitmap ] [ png-image-bytes >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ] [ [ width>> ] [ height>> ] bi 2array >>dim ]
[ drop RGB >>component-order ] [ drop RGB >>component-order ubyte-components >>component-type ]
} cleave ; } cleave ;
: decode-indexed-color ( loading-png -- loading-png ) : decode-indexed-color ( loading-png -- loading-png )

2
basis/images/processing/processing.factor
View File

@ -17,7 +17,7 @@ IN: images.processing
<image> over matrix-dim >>dim <image> over matrix-dim >>dim
swap flip flatten swap flip flatten
[ 128 * 128 + 0 max 255 min >fixnum ] map [ 128 * 128 + 0 max 255 min >fixnum ] map
>byte-array >>bitmap L >>component-order ; >byte-array >>bitmap L >>component-order ubyte-components >>component-type ;
:: matrix-zoom ( m f -- m' ) :: matrix-zoom ( m f -- m' )
m matrix-dim f v*n coord-matrix m matrix-dim f v*n coord-matrix

18
basis/images/tesselation/tesselation-tests.factor
View File

@ -10,12 +10,12 @@ IN: images.tesselation
[ [
{ {
{ {
T{ image f { 2 2 } L f B{ 1 2 5 6 } } T{ image f { 2 2 } L ubyte-components f B{ 1 2 5 6 } }
T{ image f { 2 2 } L f B{ 3 4 7 8 } } T{ image f { 2 2 } L ubyte-components f B{ 3 4 7 8 } }
} }
{ {
T{ image f { 2 2 } L f B{ 9 10 13 14 } } T{ image f { 2 2 } L ubyte-components f B{ 9 10 13 14 } }
T{ image f { 2 2 } L f B{ 11 12 15 16 } } T{ image f { 2 2 } L ubyte-components f B{ 11 12 15 16 } }
} }
} }
] [ ] [
@ -23,18 +23,19 @@ IN: images.tesselation
1 16 [a,b] >byte-array >>bitmap 1 16 [a,b] >byte-array >>bitmap
{ 4 4 } >>dim { 4 4 } >>dim
L >>component-order L >>component-order
ubyte-components >>component-type
{ 2 2 } tesselate { 2 2 } tesselate
] unit-test ] unit-test
[ [
{ {
{ {
T{ image f { 2 2 } L f B{ 1 2 4 5 } } T{ image f { 2 2 } L ubyte-components f B{ 1 2 4 5 } }
T{ image f { 1 2 } L f B{ 3 6 } } T{ image f { 1 2 } L ubyte-components f B{ 3 6 } }
} }
{ {
T{ image f { 2 1 } L f B{ 7 8 } } T{ image f { 2 1 } L ubyte-components f B{ 7 8 } }
T{ image f { 1 1 } L f B{ 9 } } T{ image f { 1 1 } L ubyte-components f B{ 9 } }
} }
} }
] [ ] [
@ -42,5 +43,6 @@ IN: images.tesselation
1 9 [a,b] >byte-array >>bitmap 1 9 [a,b] >byte-array >>bitmap
{ 3 3 } >>dim { 3 3 } >>dim
L >>component-order L >>component-order
ubyte-components >>component-type
{ 2 2 } tesselate { 2 2 } tesselate
] unit-test ] unit-test

4
basis/images/tesselation/tesselation.factor
View File

@ -19,7 +19,7 @@ IN: images.tesselation
'[ _ tesselate-columns ] map ; '[ _ tesselate-columns ] map ;
: tile-width ( tile-bitmap original-image -- width ) : tile-width ( tile-bitmap original-image -- width )
[ first length ] [ component-order>> bytes-per-pixel ] bi* /i ; [ first length ] [ bytes-per-pixel ] bi* /i ;
: <tile-image> ( tile-bitmap original-image -- tile-image ) : <tile-image> ( tile-bitmap original-image -- tile-image )
clone clone
@ -28,7 +28,7 @@ IN: images.tesselation
[ [ over tile-width ] [ length ] bi 2array >>dim ] bi ; [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
:: tesselate ( image tess-dim -- image-grid ) :: tesselate ( image tess-dim -- image-grid )
image component-order>> bytes-per-pixel :> bpp image bytes-per-pixel :> bpp
image dim>> { bpp 1 } v* :> image-dim' image dim>> { bpp 1 } v* :> image-dim'
tess-dim { bpp 1 } v* :> tess-dim' tess-dim { bpp 1 } v* :> tess-dim'
image bitmap>> image-dim' tess-dim' tesselate-bitmap image bitmap>> image-dim' tess-dim' tesselate-bitmap

18
basis/images/tiff/tiff.factor
View File

@ -484,15 +484,15 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ] [ unknown-component-order ]
} case >>bitmap ; } case >>bitmap ;
: ifd-component-order ( ifd -- byte-order ) : ifd-component-order ( ifd -- component-order component-type )
bits-per-sample find-tag { bits-per-sample find-tag {
{ { 32 32 32 32 } [ R32G32B32A32 ] } { { 32 32 32 32 } [ RGBA float-components ] }
{ { 32 32 32 } [ R32G32B32 ] } { { 32 32 32 } [ RGB float-components ] }
{ { 16 16 16 16 } [ R16G16B16A16 ] } { { 16 16 16 16 } [ RGBA ushort-components ] }
{ { 16 16 16 } [ R16G16B16 ] } { { 16 16 16 } [ RGB ushort-components ] }
{ { 8 8 8 8 } [ RGBA ] } { { 8 8 8 8 } [ RGBA ubyte-components ] }
{ { 8 8 8 } [ RGB ] } { { 8 8 8 } [ RGB ubyte-components ] }
{ 8 [ LA ] } { 8 [ LA ubyte-components ] }
[ unknown-component-order ] [ unknown-component-order ]
} case ; } case ;
@ -507,7 +507,7 @@ ERROR: unknown-component-order ifd ;
: ifd>image ( ifd -- image ) : ifd>image ( ifd -- image )
[ <image> ] dip { [ <image> ] dip {
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
[ ifd-component-order >>component-order ] [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ]
[ bitmap>> >>bitmap ] [ bitmap>> >>bitmap ]
} cleave ; } cleave ;

10
basis/opengl/gl/gl.factor
View File

@ -356,10 +356,6 @@ CONSTANT: GL_DITHER HEX: 0BD0
CONSTANT: GL_RGB HEX: 1907 CONSTANT: GL_RGB HEX: 1907
CONSTANT: GL_RGBA HEX: 1908 CONSTANT: GL_RGBA HEX: 1908
! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt
CONSTANT: GL_BGR_EXT HEX: 80E0
CONSTANT: GL_BGRA_EXT HEX: 80E1
! Implementation limits ! Implementation limits
CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31 CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31
CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35 CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35
@ -1801,6 +1797,12 @@ CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56
CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57 CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57
! GL_ARB_half_float_pixel, GL_ARB_half_float_vertex
CONSTANT: GL_HALF_FLOAT_ARB HEX: 140B
! GL_ARB_texture_float ! GL_ARB_texture_float

71
basis/opengl/textures/textures.factor
View File

@ -4,7 +4,7 @@ USING: accessors assocs cache colors.constants destructors kernel
opengl opengl.gl opengl.capabilities combinators images opengl opengl.gl opengl.capabilities combinators images
images.tesselation grouping specialized-arrays.float sequences math images.tesselation grouping specialized-arrays.float sequences math
math.vectors math.matrices generalizations fry arrays namespaces math.vectors math.matrices generalizations fry arrays namespaces
system ; system locals ;
IN: opengl.textures IN: opengl.textures
SYMBOL: non-power-of-2-textures? SYMBOL: non-power-of-2-textures?
@ -22,16 +22,46 @@ SYMBOL: non-power-of-2-textures?
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
GENERIC: component-order>format ( component-order -- format type ) GENERIC: component-type>type ( component-type -- internal-format type )
GENERIC: component-order>format ( type component-order -- type format )
GENERIC: component-order>integer-format ( type component-order -- type format )
M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ; ERROR: unsupported-component-order component-order ;
M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; M: ubyte-components component-type>type drop GL_RGBA8 GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: ushort-components component-type>type drop GL_RGBA16 GL_UNSIGNED_SHORT ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; M: half-components component-type>type drop GL_RGBA16F_ARB GL_HALF_FLOAT_ARB ;
M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; M: float-components component-type>type drop GL_RGBA32F_ARB GL_FLOAT ;
M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ; M: byte-integer-components component-type>type drop GL_RGBA8I_EXT GL_BYTE ;
M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ; M: short-integer-components component-type>type drop GL_RGBA16I_EXT GL_SHORT ;
M: int-integer-components component-type>type drop GL_RGBA32I_EXT GL_INT ;
M: ubyte-integer-components component-type>type drop GL_RGBA8I_EXT GL_UNSIGNED_BYTE ;
M: ushort-integer-components component-type>type drop GL_RGBA16I_EXT GL_UNSIGNED_SHORT ;
M: uint-integer-components component-type>type drop GL_RGBA32I_EXT GL_UNSIGNED_INT ;
M: RGB component-order>format drop GL_RGB ;
M: BGR component-order>format drop GL_BGR ;
M: RGBA component-order>format drop GL_RGBA ;
M: ARGB component-order>format
swap GL_UNSIGNED_BYTE =
[ drop GL_UNSIGNED_INT_8_8_8_8_REV GL_BGRA ]
[ unsupported-component-order ] if ;
M: BGRA component-order>format drop GL_BGRA ;
M: BGRX component-order>format drop GL_BGRA ;
M: LA component-order>format drop GL_LUMINANCE_ALPHA ;
M: L component-order>format drop GL_LUMINANCE ;
M: object component-order>format unsupported-component-order ;
M: RGB component-order>integer-format drop GL_RGB_INTEGER_EXT ;
M: BGR component-order>integer-format drop GL_BGR_INTEGER_EXT ;
M: RGBA component-order>integer-format drop GL_RGBA_INTEGER_EXT ;
M: BGRA component-order>integer-format drop GL_BGRA_INTEGER_EXT ;
M: BGRX component-order>integer-format drop GL_BGRA_INTEGER_EXT ;
M: LA component-order>integer-format drop GL_LUMINANCE_ALPHA_INTEGER_EXT ;
M: L component-order>integer-format drop GL_LUMINANCE_INTEGER_EXT ;
M: object component-order>integer-format unsupported-component-order ;
SLOT: display-list SLOT: display-list
@ -50,18 +80,25 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
[ dup 1 = [ next-power-of-2 ] unless ] map [ dup 1 = [ next-power-of-2 ] unless ] map
] unless ; ] unless ;
: tex-image ( image bitmap -- ) : image-format ( image -- internal-format format type )
dup component-type>>
[ nip component-type>type ]
[ [
[ GL_TEXTURE_2D 0 GL_RGBA ] dip unnormalized-integer-components?
[ dim>> adjust-texture-dim first2 0 ] [ component-order>> component-order>integer-format ]
[ component-order>> component-order>format ] bi [ component-order>> component-order>format ] if
] dip ] 2bi swap ;
glTexImage2D ;
:: tex-image ( image bitmap -- )
image image-format :> type :> format :> internal-format
GL_TEXTURE_2D 0 internal-format
image dim>> adjust-texture-dim first2 0
format type bitmap glTexImage2D ;
: tex-sub-image ( image -- ) : tex-sub-image ( image -- )
[ GL_TEXTURE_2D 0 0 0 ] dip [ GL_TEXTURE_2D 0 0 0 ] dip
[ dim>> first2 ] [ dim>> first2 ]
[ component-order>> component-order>format ] [ image-format [ drop ] 2dip ]
[ bitmap>> ] tri [ bitmap>> ] tri
glTexSubImage2D ; glTexSubImage2D ;

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

@ -74,7 +74,7 @@ $nl
"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:" "Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
{ $heading "Input quotation declaration" } { $heading "Input quotation declaration" }
"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:" "Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } { $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"The following is correct:" "The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter." "The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."

60
basis/ui/backend/cocoa/views/views.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2006, 2008 Slava Pestov ! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays assocs cocoa kernel math USING: accessors alien alien.c-types alien.strings arrays assocs
cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences cocoa.views cocoa.application cocoa.pasteboard cocoa.types
ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds cocoa.windows sequences io.encodings.ascii ui ui.private ui.gadgets
ui.gestures core-foundation.strings core-graphics core-graphics.types ui.gadgets.private ui.gadgets.worlds ui.gestures
threads combinators math.rectangles ; core-foundation.strings core-graphics core-graphics.types threads
combinators math.rectangles ;
IN: ui.backend.cocoa.views IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- ) : send-mouse-moved ( view event -- )
@ -121,6 +122,25 @@ CONSTANT: key-codes
[ drop dim>> first2 ] [ drop dim>> first2 ]
2bi <CGRect> ; 2bi <CGRect> ;
CONSTANT: selector>action H{
{ "undo:" undo-action }
{ "redo:" redo-action }
{ "cut:" cut-action }
{ "copy:" copy-action }
{ "paste:" paste-action }
{ "delete:" delete-action }
{ "selectAll:" select-all-action }
{ "newDocument:" new-action }
{ "openDocument:" open-action }
{ "saveDocument:" save-action }
{ "saveDocumentAs:" save-as-action }
{ "revertDocumentToSaved:" revert-action }
}
: validate-action ( world selector -- ? validated? )
selector>action at
[ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
CLASS: { CLASS: {
{ +superclass+ "NSOpenGLView" } { +superclass+ "NSOpenGLView" }
{ +name+ "FactorView" } { +name+ "FactorView" }
@ -197,6 +217,14 @@ CLASS: {
[ nip send-key-up-event ] [ nip send-key-up-event ]
} }
{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" }
[
nip -> action
2dup [ window ] [ ascii alien>string ] bi* validate-action
[ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
]
}
{ "undo:" "id" { "id" "SEL" "id" } { "undo:" "id" { "id" "SEL" "id" }
[ nip undo-action send-action$ ] [ nip undo-action send-action$ ]
} }
@ -225,6 +253,26 @@ CLASS: {
[ nip select-all-action send-action$ ] [ nip select-all-action send-action$ ]
} }
{ "newDocument:" "id" { "id" "SEL" "id" }
[ nip new-action send-action$ ]
}
{ "openDocument:" "id" { "id" "SEL" "id" }
[ nip open-action send-action$ ]
}
{ "saveDocument:" "id" { "id" "SEL" "id" }
[ nip save-action send-action$ ]
}
{ "saveDocumentAs:" "id" { "id" "SEL" "id" }
[ nip save-as-action send-action$ ]
}
{ "revertDocumentToSaved:" "id" { "id" "SEL" "id" }
[ nip revert-action send-action$ ]
}
! Multi-touch gestures: this is undocumented. ! Multi-touch gestures: this is undocumented.
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html ! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
{ "magnifyWithEvent:" "void" { "id" "SEL" "id" } { "magnifyWithEvent:" "void" { "id" "SEL" "id" }

56
basis/ui/gestures/gestures-docs.factor
View File

@ -13,9 +13,20 @@ $nl
"Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's parent." "Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's parent."
$nl $nl
"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." } "The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." }
{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ; { $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } ". If you define a method on " { $snippet "handle-gesture" } ", you should also override " { $link handles-gesture? } "." } ;
{ propagate-gesture handle-gesture set-gestures } related-words HELP: handles-gesture?
{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } }
{ $contract "Returns a true value if " { $snippet "gadget" } " would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method."
$nl
"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class and returns true if a handler is present for " { $snippet "gesture" } "." }
{ $notes "This word is used in Factor's MacOS X UI to validate menu items." } ;
HELP: parents-handle-gesture?
{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } }
{ $contract "Returns a true value if " { $snippet "gadget" } " or any of its ancestors would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method." } ;
{ propagate-gesture handle-gesture handles-gesture? set-gestures } related-words
HELP: propagate-gesture HELP: propagate-gesture
{ $values { "gesture" "a gesture" } { "gadget" gadget } } { $values { "gesture" "a gesture" } { "gadget" gadget } }
@ -86,6 +97,30 @@ HELP: select-all-action
{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." } { $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
{ $examples { $code "select-all-action" } } ; { $examples { $code "select-all-action" } } ;
HELP: new-action
{ $class-description "Gesture sent when the " { $emphasis "new" } " standard window system action is invoked." }
{ $examples { $code "new-action" } } ;
HELP: open-action
{ $class-description "Gesture sent when the " { $emphasis "open" } " standard window system action is invoked." }
{ $examples { $code "open-action" } } ;
HELP: save-action
{ $class-description "Gesture sent when the " { $emphasis "save" } " standard window system action is invoked." }
{ $examples { $code "save-action" } } ;
HELP: save-as-action
{ $class-description "Gesture sent when the " { $emphasis "save as" } " standard window system action is invoked." }
{ $examples { $code "save-as-action" } } ;
HELP: revert-action
{ $class-description "Gesture sent when the " { $emphasis "revert" } " standard window system action is invoked." }
{ $examples { $code "revert-action" } } ;
HELP: close-action
{ $class-description "Gesture sent when the " { $emphasis "close" } " standard window system action is invoked." }
{ $examples { $code "close-action" } } ;
HELP: C+ HELP: C+
{ $description "Control key modifier." } ; { $description "Control key modifier." } ;
@ -350,21 +385,34 @@ $nl
{ $subsection zoom-out-action } ; { $subsection zoom-out-action } ;
ARTICLE: "action-gestures" "Action gestures" ARTICLE: "action-gestures" "Action gestures"
"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent." "Action gestures exist to keep keyboard shortcuts for common application operations consistent."
{ $subsection undo-action }
{ $subsection redo-action }
{ $subsection cut-action } { $subsection cut-action }
{ $subsection copy-action } { $subsection copy-action }
{ $subsection paste-action } { $subsection paste-action }
{ $subsection delete-action } { $subsection delete-action }
{ $subsection select-all-action } { $subsection select-all-action }
{ $subsection new-action }
{ $subsection open-action }
{ $subsection save-action }
{ $subsection save-as-action }
{ $subsection revert-action }
{ $subsection close-action }
"The following keyboard gestures, if not handled directly, send action gestures:" "The following keyboard gestures, if not handled directly, send action gestures:"
{ $table { $table
{ { $strong "Keyboard gesture" } { $strong "Action gesture" } } { { $strong "Keyboard gesture" } { $strong "Action gesture" } }
{ { $snippet "T{ key-down f { C+ } \"z\" }" } { $snippet "undo-action" } } { { $snippet "T{ key-down f { C+ } \"z\" }" } { $snippet "undo-action" } }
{ { $snippet "T{ key-down f { C+ } \"Z\" }" } { $snippet "redo-action" } } { { $snippet "T{ key-down f { C+ } \"y\" }" } { $snippet "redo-action" } }
{ { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "cut-action" } } { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "cut-action" } }
{ { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "copy-action" } } { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "copy-action" } }
{ { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "paste-action" } } { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "paste-action" } }
{ { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "select-all-action" } } { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "select-all-action" } }
{ { $snippet "T{ key-down f { C+ } \"n\" }" } { $snippet "new-action" } }
{ { $snippet "T{ key-down f { C+ } \"o\" }" } { $snippet "open-action" } }
{ { $snippet "T{ key-down f { C+ } \"s\" }" } { $snippet "save-action" } }
{ { $snippet "T{ key-down f { C+ } \"S\" }" } { $snippet "save-as-action" } }
{ { $snippet "T{ key-down f { C+ } \"w\" }" } { $snippet "close-action" } }
} }
"Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ; "Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ;

28
basis/ui/gestures/gestures.factor
View File

@ -7,13 +7,24 @@ sets columns fry deques ui.gadgets ui.gadgets.private ascii
combinators.short-circuit ; combinators.short-circuit ;
IN: ui.gestures IN: ui.gestures
: get-gesture-handler ( gesture gadget -- quot )
class superclasses [ "gestures" word-prop ] map assoc-stack ;
GENERIC: handle-gesture ( gesture gadget -- ? ) GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture M: object handle-gesture
[ nip ] [ nip ]
[ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi [ get-gesture-handler ] 2bi
dup [ call( gadget -- ) f ] [ 2drop t ] if ; dup [ call( gadget -- ) f ] [ 2drop t ] if ;
GENERIC: handles-gesture? ( gesture gadget -- ? )
M: object handles-gesture? ( gesture gadget -- ? )
get-gesture-handler >boolean ;
: parents-handle-gesture? ( gesture gadget -- ? )
[ handles-gesture? not ] with each-parent not ;
: set-gestures ( class hash -- ) "gestures" set-word-prop ; : set-gestures ( class hash -- ) "gestures" set-word-prop ;
: gesture-queue ( -- deque ) \ gesture-queue get ; : gesture-queue ( -- deque ) \ gesture-queue get ;
@ -82,23 +93,32 @@ undo-action redo-action
cut-action copy-action paste-action cut-action copy-action paste-action
delete-action select-all-action delete-action select-all-action
left-action right-action up-action down-action left-action right-action up-action down-action
zoom-in-action zoom-out-action ; zoom-in-action zoom-out-action
new-action open-action save-action save-as-action
revert-action close-action ;
UNION: action UNION: action
undo-action redo-action undo-action redo-action
cut-action copy-action paste-action cut-action copy-action paste-action
delete-action select-all-action delete-action select-all-action
left-action right-action up-action down-action left-action right-action up-action down-action
zoom-in-action zoom-out-action ; zoom-in-action zoom-out-action
new-action open-action save-action save-as-action
revert-action close-action ;
CONSTANT: action-gestures CONSTANT: action-gestures
{ {
{ "z" undo-action } { "z" undo-action }
{ "Z" redo-action } { "y" redo-action }
{ "x" cut-action } { "x" cut-action }
{ "c" copy-action } { "c" copy-action }
{ "v" paste-action } { "v" paste-action }
{ "a" select-all-action } { "a" select-all-action }
{ "n" new-action }
{ "o" open-action }
{ "s" save-action }
{ "S" save-as-action }
{ "w" close-action }
} }
! Modifiers ! Modifiers

4
basis/ui/ui-docs.factor
View File

@ -81,6 +81,10 @@ HELP: with-ui
HELP: beep HELP: beep
{ $description "Plays the system beep sound." } ; { $description "Plays the system beep sound." } ;
HELP: topmost-window
{ $values { "world" world } }
{ $description "Returns the " { $link world } " representing the currently focused window." } ;
ARTICLE: "ui-glossary" "UI glossary" ARTICLE: "ui-glossary" "UI glossary"
{ $table { $table
{ "color" { "an instance of " { $link color } } } { "color" { "an instance of " { $link color } } }

3
basis/ui/ui.factor
View File

@ -224,6 +224,9 @@ PRIVATE>
: raise-window ( gadget -- ) : raise-window ( gadget -- )
find-world raise-window* ; find-world raise-window* ;
: topmost-window ( -- world )
windows get last second ;
HOOK: close-window ui-backend ( gadget -- ) HOOK: close-window ui-backend ( gadget -- )
M: object close-window M: object close-window

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

@ -2,13 +2,16 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
io.binary io.encodings.string io.encodings.utf8 kernel math namespaces io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
sequences serialize arrays calendar io.encodings ; sequences serialize arrays calendar io.encodings ;
FROM: kernel.private => declare ;
FROM: io.encodings.private => (read-until) ;
IN: bson.reader IN: bson.reader
<PRIVATE <PRIVATE
TUPLE: element { type integer } name ; TUPLE: element { type integer } name ;
TUPLE: state TUPLE: state
{ size initial: -1 } { read initial: 0 } exemplar { size initial: -1 } exemplar
result scope element ; result scope element ;
: <state> ( exemplar -- state ) : <state> ( exemplar -- state )
@ -17,25 +20,25 @@ TUPLE: state
clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
V{ } clone [ T_Object "" element boa swap push ] keep >>element ; V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
PREDICATE: bson-eoo < integer T_EOO = ;
PREDICATE: bson-not-eoo < integer T_EOO > ; PREDICATE: bson-not-eoo < integer T_EOO > ;
PREDICATE: bson-eoo < integer T_EOO = ;
PREDICATE: bson-double < integer T_Double = ;
PREDICATE: bson-integer < integer T_Integer = ;
PREDICATE: bson-string < integer T_String = ; PREDICATE: bson-string < integer T_String = ;
PREDICATE: bson-object < integer T_Object = ; PREDICATE: bson-object < integer T_Object = ;
PREDICATE: bson-oid < integer T_OID = ;
PREDICATE: bson-array < integer T_Array = ; PREDICATE: bson-array < integer T_Array = ;
PREDICATE: bson-integer < integer T_Integer = ;
PREDICATE: bson-double < integer T_Double = ;
PREDICATE: bson-date < integer T_Date = ;
PREDICATE: bson-binary < integer T_Binary = ; PREDICATE: bson-binary < integer T_Binary = ;
PREDICATE: bson-boolean < integer T_Boolean = ;
PREDICATE: bson-regexp < integer T_Regexp = ; PREDICATE: bson-regexp < integer T_Regexp = ;
PREDICATE: bson-null < integer T_NULL = ;
PREDICATE: bson-ref < integer T_DBRef = ;
PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
PREDICATE: bson-binary-function < integer T_Binary_Function = ; PREDICATE: bson-binary-function < integer T_Binary_Function = ;
PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
PREDICATE: bson-binary-custom < integer T_Binary_Custom = ; PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
PREDICATE: bson-oid < integer T_OID = ;
PREDICATE: bson-boolean < integer T_Boolean = ;
PREDICATE: bson-date < integer T_Date = ;
PREDICATE: bson-null < integer T_NULL = ;
PREDICATE: bson-ref < integer T_DBRef = ;
GENERIC: element-read ( type -- cont? ) GENERIC: element-read ( type -- cont? )
GENERIC: element-data-read ( type -- object ) GENERIC: element-data-read ( type -- object )
@ -47,27 +50,27 @@ GENERIC: element-binary-read ( length type -- object )
: get-state ( -- state ) : get-state ( -- state )
state get ; inline state get ; inline
: count-bytes ( count -- )
[ get-state ] dip '[ _ + ] change-read drop ; inline
: read-int32 ( -- int32 ) : read-int32 ( -- int32 )
4 [ read byte-array>number ] [ count-bytes ] bi ; inline 4 read byte-array>number ; inline
: read-longlong ( -- longlong ) : read-longlong ( -- longlong )
8 [ read byte-array>number ] [ count-bytes ] bi ; inline 8 read byte-array>number ; inline
: read-double ( -- double ) : read-double ( -- double )
8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline 8 read byte-array>number bits>double ; inline
: read-byte-raw ( -- byte-raw ) : read-byte-raw ( -- byte-raw )
1 [ read ] [ count-bytes ] bi ; inline 1 read ; inline
: read-byte ( -- byte ) : read-byte ( -- byte )
read-byte-raw first ; inline read-byte-raw first ; inline
: utf8-read-until ( seps stream encoding -- string/f sep/f )
[ { utf8 } declare decode-char dup [ dup rot member? ] [ 2drop f t ] if ]
3curry (read-until) ;
: read-cstring ( -- string ) : read-cstring ( -- string )
input-stream get utf8 <decoder> "\0" input-stream get utf8 utf8-read-until drop ; inline
"\0" swap stream-read-until drop ; inline
: read-sized-string ( length -- string ) : read-sized-string ( length -- string )
drop read-cstring ; inline drop read-cstring ; inline
@ -141,13 +144,13 @@ M: bson-not-eoo element-read ( type -- cont? )
M: bson-object element-data-read ( type -- object ) M: bson-object element-data-read ( type -- object )
(object-data-read) ; (object-data-read) ;
M: bson-array element-data-read ( type -- object )
(object-data-read) ;
M: bson-string element-data-read ( type -- object ) M: bson-string element-data-read ( type -- object )
drop drop
read-int32 read-sized-string ; read-int32 read-sized-string ;
M: bson-array element-data-read ( type -- object )
(object-data-read) ;
M: bson-integer element-data-read ( type -- object ) M: bson-integer element-data-read ( type -- object )
drop drop
read-int32 ; read-int32 ;
@ -191,7 +194,7 @@ PRIVATE>
USE: tools.continuations USE: tools.continuations
: stream>assoc ( exemplar -- assoc bytes-read ) : stream>assoc ( exemplar -- assoc )
<state> dup state <state> dup state
[ read-int32 >>size read-elements ] with-variable [ read-int32 >>size read-elements ] with-variable
[ result>> ] [ read>> ] bi ; result>> ;

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

@ -6,24 +6,23 @@ io.encodings.utf8 io.streams.byte-array kernel math math.parser
namespaces quotations sequences sequences.private serialize strings namespaces quotations sequences sequences.private serialize strings
words combinators.short-circuit literals ; words combinators.short-circuit literals ;
FROM: io.encodings.utf8.private => char>utf8 ;
FROM: kernel.private => declare ;
IN: bson.writer IN: bson.writer
<PRIVATE <PRIVATE
SYMBOL: shared-buffer SYMBOL: shared-buffer
CONSTANT: CHAR-SIZE 1
CONSTANT: INT32-SIZE 4 CONSTANT: INT32-SIZE 4
CONSTANT: CHAR-SIZE 1
CONSTANT: INT64-SIZE 8 CONSTANT: INT64-SIZE 8
: (buffer) ( -- buffer ) : (buffer) ( -- buffer )
shared-buffer get shared-buffer get
[ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline [ BV{ } clone [ shared-buffer set ] keep ] unless*
{ byte-vector } declare ; inline
: >le-stream ( x n -- )
swap
'[ _ swap nth-byte 0 B{ 0 }
[ set-nth-unsafe ] keep write ] each ; inline
PRIVATE> PRIVATE>
@ -33,40 +32,38 @@ PRIVATE>
: ensure-buffer ( -- ) : ensure-buffer ( -- )
(buffer) drop ; inline (buffer) drop ; inline
: with-buffer ( quot -- byte-vector ) : with-buffer ( quot: ( -- ) -- byte-vector )
[ (buffer) [ reset-buffer ] keep dup ] dip [ (buffer) [ reset-buffer ] keep dup ] dip
with-output-stream* dup encoder? [ stream>> ] when ; inline with-output-stream* ; inline
: with-length ( quot: ( -- ) -- bytes-written start-index ) : with-length ( quot: ( -- ) -- bytes-written start-index )
[ (buffer) [ length ] keep ] dip call [ (buffer) [ length ] keep ] dip
length swap [ - ] keep ; inline call length swap [ - ] keep ; inline
: (with-length-prefix) ( quot: ( -- ) length-quot: ( bytes-written -- length ) -- )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
[ call ] dip (buffer) copy ; inline
: with-length-prefix ( quot: ( -- ) -- ) : with-length-prefix ( quot: ( -- ) -- )
[ B{ 0 0 0 0 } write ] prepose with-length [ INT32-SIZE >le ] (with-length-prefix) ; inline
[ INT32-SIZE >le ] dip (buffer)
'[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
[ INT32-SIZE ] dip each-integer ; inline
: with-length-prefix-excl ( quot: ( -- ) -- ) : with-length-prefix-excl ( quot: ( -- ) -- )
[ B{ 0 0 0 0 } write ] prepose with-length [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
[ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
'[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
[ INT32-SIZE ] dip each-integer ; inline
<PRIVATE <PRIVATE
GENERIC: bson-type? ( obj -- type ) foldable flushable GENERIC: bson-type? ( obj -- type )
GENERIC: bson-write ( obj -- ) GENERIC: bson-write ( obj -- )
M: t bson-type? ( boolean -- type ) drop T_Boolean ; M: t bson-type? ( boolean -- type ) drop T_Boolean ;
M: f bson-type? ( boolean -- type ) drop T_Boolean ; M: f bson-type? ( boolean -- type ) drop T_Boolean ;
M: real bson-type? ( real -- type ) drop T_Double ;
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: string bson-type? ( string -- type ) drop T_String ; M: string bson-type? ( string -- type ) drop T_String ;
M: integer bson-type? ( integer -- type ) drop T_Integer ; M: integer bson-type? ( integer -- type ) drop T_Integer ;
M: assoc bson-type? ( assoc -- type ) drop T_Object ; M: assoc bson-type? ( assoc -- type ) drop T_Object ;
M: real bson-type? ( real -- type ) drop T_Double ;
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: timestamp bson-type? ( timestamp -- type ) drop T_Date ; M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ; M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
@ -76,28 +73,27 @@ M: word bson-type? ( word -- type ) drop T_Binary ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
: write-utf8-string ( string -- ) : write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
output-stream get utf8 <encoder> stream-write ; inline
: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline : write-byte ( byte -- ) CHAR-SIZE >le write ; inline
: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline : write-int32 ( int -- ) INT32-SIZE >le write ; inline
: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline : write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline
: write-eoo ( -- ) T_EOO write-byte ; inline : write-eoo ( -- ) T_EOO write-byte ; inline
: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
M: string bson-write ( obj -- )
'[ _ write-cstring ] with-length-prefix-excl ;
M: f bson-write ( f -- ) M: f bson-write ( f -- )
drop 0 write-byte ; drop 0 write-byte ;
M: t bson-write ( t -- ) M: t bson-write ( t -- )
drop 1 write-byte ; drop 1 write-byte ;
M: string bson-write ( obj -- )
'[ _ write-cstring ] with-length-prefix-excl ;
M: integer bson-write ( num -- ) M: integer bson-write ( num -- )
write-int32 ; write-int32 ;
@ -153,8 +149,8 @@ PRIVATE>
[ '[ _ bson-write ] with-buffer ] with-scope ; inline [ '[ _ bson-write ] with-buffer ] with-scope ; inline
: assoc>stream ( assoc -- ) : assoc>stream ( assoc -- )
bson-write ; inline { assoc } declare bson-write ; inline
: mdb-special-value? ( value -- ? ) : mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ] { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
[ oid? ] [ byte-array? ] } 1|| ; [ oid? ] [ byte-array? ] } 1|| ; inline

32
extra/images/normalization/normalization.factor
View File

@ -3,7 +3,8 @@
USING: kernel accessors grouping sequences combinators USING: kernel accessors grouping sequences combinators
math specialized-arrays.direct.uint byte-arrays fry math specialized-arrays.direct.uint byte-arrays fry
specialized-arrays.direct.ushort specialized-arrays.uint specialized-arrays.direct.ushort specialized-arrays.uint
specialized-arrays.ushort specialized-arrays.float images ; specialized-arrays.ushort specialized-arrays.float images
half-floats ;
IN: images.normalization IN: images.normalization
<PRIVATE <PRIVATE
@ -11,30 +12,31 @@ IN: images.normalization
: add-dummy-alpha ( seq -- seq' ) : add-dummy-alpha ( seq -- seq' )
3 <groups> [ 255 suffix ] map concat ; 3 <groups> [ 255 suffix ] map concat ;
: normalize-floats ( byte-array -- byte-array ) : normalize-floats ( float-array -- byte-array )
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ; [ 255.0 * >integer ] B{ } map-as ;
GENERIC: normalize-component-type* ( image component-type -- image )
GENERIC: normalize-component-order* ( image component-order -- image ) GENERIC: normalize-component-order* ( image component-order -- image )
: normalize-component-order ( image -- image ) : normalize-component-order ( image -- image )
dup component-type>> '[ _ normalize-component-type* ] change-bitmap
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ; dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
M: RGBA normalize-component-order* drop ; M: float-components normalize-component-type*
drop byte-array>float-array normalize-floats ;
M: half-components normalize-component-type*
drop byte-array>half-array normalize-floats ;
M: R32G32B32A32 normalize-component-order* : ushorts>ubytes ( bitmap -- bitmap' )
drop normalize-floats ;
M: R32G32B32 normalize-component-order*
drop normalize-floats add-dummy-alpha ;
: RGB16>8 ( bitmap -- bitmap' )
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
M: R16G16B16A16 normalize-component-order* M: ushort-components normalize-component-type*
drop RGB16>8 ; drop ushorts>ubytes ;
M: R16G16B16 normalize-component-order* M: ubyte-components normalize-component-type*
drop RGB16>8 add-dummy-alpha ; drop ;
M: RGBA normalize-component-order* drop ;
: BGR>RGB ( bitmap -- pixels ) : BGR>RGB ( bitmap -- pixels )
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline

34
extra/io/serial/unix/linux/linux.factor
View File

@ -95,23 +95,23 @@ CONSTANT: PENDIN OCT: 0040000
CONSTANT: IEXTEN OCT: 0100000 CONSTANT: IEXTEN OCT: 0100000
M: linux lookup-baud ( n -- n ) M: linux lookup-baud ( n -- n )
dup H{ H{
{ 0 OCT: 0000000 } { 0 OCT: 0000000 }
{ 50 OCT: 0000001 } { 50 OCT: 0000001 }
{ 75 OCT: 0000002 } { 75 OCT: 0000002 }
{ 110 OCT: 0000003 } { 110 OCT: 0000003 }
{ 134 OCT: 0000004 } { 134 OCT: 0000004 }
{ 150 OCT: 0000005 } { 150 OCT: 0000005 }
{ 200 OCT: 0000006 } { 200 OCT: 0000006 }
{ 300 OCT: 0000007 } { 300 OCT: 0000007 }
{ 600 OCT: 0000010 } { 600 OCT: 0000010 }
{ 1200 OCT: 0000011 } { 1200 OCT: 0000011 }
{ 1800 OCT: 0000012 } { 1800 OCT: 0000012 }
{ 2400 OCT: 0000013 } { 2400 OCT: 0000013 }
{ 4800 OCT: 0000014 } { 4800 OCT: 0000014 }
{ 9600 OCT: 0000015 } { 9600 OCT: 0000015 }
{ 19200 OCT: 0000016 } { 19200 OCT: 0000016 }
{ 38400 OCT: 0000017 } { 38400 OCT: 0000017 }
{ 57600 OCT: 0010001 } { 57600 OCT: 0010001 }
{ 115200 OCT: 0010002 } { 115200 OCT: 0010002 }
{ 230400 OCT: 0010003 } { 230400 OCT: 0010003 }

5
extra/mongodb/benchmark/benchmark.factor
View File

@ -2,6 +2,7 @@ USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-a
sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
accessors words mongodb.driver strings math.parser bson.writer ; accessors words mongodb.driver strings math.parser bson.writer ;
FROM: mongodb.driver => find ; FROM: mongodb.driver => find ;
FROM: memory => gc ;
IN: mongodb.benchmark IN: mongodb.benchmark
@ -175,7 +176,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) : deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
[ 0 ] dip call( i -- doc ) assoc>bv [ 0 ] dip call( i -- doc ) assoc>bv
'[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; '[ trial-size [ _ binary [ H{ } stream>assoc drop ] with-byte-reader ] times ] ;
: check-for-key ( assoc key -- ) : check-for-key ( assoc key -- )
CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
@ -246,7 +247,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) ) : [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _ '[ _ swap _
'[ [ [ _ execute( -- quot ) ] dip '[ [ [ _ execute( -- quot ) ] dip
[ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
print-separator ] ; print-separator ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- ) : run-serialization-bench ( doc-word-seq feat-seq -- )

1
extra/mongodb/mmm/authors.txt
View File

@ -1 +0,0 @@
Sascha Matzke

101
extra/mongodb/mmm/mmm.factor
View File

@ -1,101 +0,0 @@
USING: accessors fry io io.encodings.binary io.servers.connection
io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
namespaces prettyprint tools.walker calendar calendar.format bson.writer.private
json.writer mongodb.operations.private mongodb.operations ;
IN: mongodb.mmm
SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ;
GENERIC: dump-message ( message -- )
: check-options ( -- )
mmm-port get [ 27040 mmm-port set ] unless
mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
mmm-server-port get [ 27017 mmm-server-port set ] unless
mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
: read-msg-binary ( -- )
read-int32
[ write-int32 ] keep
4 - read write ;
: read-request-header ( -- msg-stub )
mdb-msg new
read-int32 MSG-HEADER-SIZE - >>length
read-int32 >>req-id
read-int32 >>resp-id
read-int32 >>opcode ;
: read-request ( -- msg-stub binary )
binary [ read-msg-binary ] with-byte-writer
[ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
: dump-request ( msg-stub binary -- )
[ mmm-dump-output get ] 2dip
'[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
: read-reply ( -- binary )
binary [ read-msg-binary ] with-byte-writer ;
: forward-request-read-reply ( msg-stub binary -- binary )
[ mmm-server get binary ] 2dip
'[ _ opcode>> _ write flush
OP_Query =
[ read-reply ]
[ f ] if ] with-client ;
: dump-reply ( binary -- )
[ mmm-dump-output get ] dip
'[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
: message-prefix ( message -- prefix message )
[ now timestamp>http-string ] dip
[ class name>> ] keep
[ "%s: %s" sprintf ] dip ; inline
M: mdb-query-msg dump-message ( message -- )
message-prefix
[ collection>> ] keep
query>> >json
"%s -> %s: %s \n" printf ;
M: mdb-insert-msg dump-message ( message -- )
message-prefix
[ collection>> ] keep
objects>> >json
"%s -> %s : %s \n" printf ;
M: mdb-reply-msg dump-message ( message -- )
message-prefix
[ cursor>> ] keep
[ start#>> ] keep
[ returned#>> ] keep
objects>> >json
"%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ;
M: mdb-msg dump-message ( message -- )
message-prefix drop "%s \n" printf ;
: forward-reply ( binary -- )
write flush ;
: handle-mmm-connection ( -- )
read-request
[ dump-request ] 2keep
forward-request-read-reply
[ dump-reply ] keep
forward-reply ;
: start-mmm-server ( -- )
output-stream get mmm-dump-output set
binary <threaded-server> [ mmm-t-srv set ] keep
"127.0.0.1" mmm-port get <inet4> >>insecure
[ handle-mmm-connection ] >>handler
start-server* ;
: run-mmm ( -- )
check-options
start-mmm-server ;
MAIN: run-mmm

1
extra/mongodb/mmm/summary.txt
View File

@ -1 +0,0 @@
mongo-message-monitor - a small proxy to introspect messages send to MongoDB

50
extra/mongodb/operations/operations.factor
View File

@ -64,61 +64,13 @@ GENERIC: (read-message) ( message opcode -- message )
[ opcode>> ] keep [ >>opcode ] dip [ opcode>> ] keep [ >>opcode ] dip
flags>> >>flags ; flags>> >>flags ;
M: mdb-query-op (read-message) ( msg-stub opcode -- message )
drop
[ mdb-query-msg new ] dip copy-header
read-cstring >>collection
read-int32 >>skip#
read-int32 >>return#
H{ } stream>assoc change-bytes-read >>query
dup length>> bytes-read> >
[ H{ } stream>assoc change-bytes-read >>returnfields ] when ;
M: mdb-insert-op (read-message) ( msg-stub opcode -- message )
drop
[ mdb-insert-msg new ] dip copy-header
read-cstring >>collection
V{ } clone >>objects
[ '[ _ length>> bytes-read> > ] ] keep tuck
'[ H{ } stream>assoc change-bytes-read _ objects>> push ]
while ;
M: mdb-delete-op (read-message) ( msg-stub opcode -- message )
drop
[ mdb-delete-msg new ] dip copy-header
read-cstring >>collection
H{ } stream>assoc change-bytes-read >>selector ;
M: mdb-getmore-op (read-message) ( msg-stub opcode -- message )
drop
[ mdb-getmore-msg new ] dip copy-header
read-cstring >>collection
read-int32 >>return#
read-longlong >>cursor ;
M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message )
drop
[ mdb-killcursors-msg new ] dip copy-header
read-int32 >>cursors#
V{ } clone >>cursors
[ [ cursors#>> ] keep
'[ read-longlong _ cursors>> push ] times ] keep ;
M: mdb-update-op (read-message) ( msg-stub opcode -- message )
drop
[ mdb-update-msg new ] dip copy-header
read-cstring >>collection
read-int32 >>upsert?
H{ } stream>assoc change-bytes-read >>selector
H{ } stream>assoc change-bytes-read >>object ;
M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
drop drop
[ <mdb-reply-msg> ] dip copy-header [ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor read-longlong >>cursor
read-int32 >>start# read-int32 >>start#
read-int32 [ >>returned# ] keep read-int32 [ >>returned# ] keep
[ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ;
: read-header ( message -- message ) : read-header ( message -- message )
read-int32 >>length read-int32 >>length

3
extra/noise/noise.factor
View File

@ -64,7 +64,8 @@ HINTS: hashes { byte-array fixnum fixnum fixnum } ;
image new image new
swap >>dim swap >>dim
swap >>bitmap swap >>bitmap
L >>component-order ; L >>component-order
ubyte-components >>component-type ;
:: perlin-noise-unsafe ( table point -- value ) :: perlin-noise-unsafe ( table point -- value )
point unit-cube :> cube point unit-cube :> cube

1
extra/terrain/generation/generation.factor
View File

@ -36,6 +36,7 @@ TUPLE: segment image ;
<image> <image>
swap >>bitmap swap >>bitmap
RGBA >>component-order RGBA >>component-order
ubyte-components >>component-type
terrain-segment-size >>dim ; terrain-segment-size >>dim ;
: terrain-segment ( terrain at -- image ) : terrain-segment ( terrain at -- image )

2
extra/tokyo/alien/tctdb/tctdb.factor
View File

@ -76,7 +76,7 @@ FUNCTION: void tctdbdel ( TCTDB* tdb ) ;
FUNCTION: int tctdbecode ( TCTDB* tdb ) ; FUNCTION: int tctdbecode ( TCTDB* tdb ) ;
FUNCTION: bool tctdbsetmutex ( TCTDB* tdb ) ; FUNCTION: bool tctdbsetmutex ( TCTDB* tdb ) ;
FUNCTION: bool tctdbtune ( TCTDB* tdb, longlong bnum, char apow, char fpow, uchar opts ) ; FUNCTION: bool tctdbtune ( TCTDB* tdb, longlong bnum, char apow, char fpow, uchar opts ) ;
FUNCTION: bool tctdbsetcache ( TCTDB* tdb, int32_t rcnum, int32_t lcnum, int32_t ncnum ) ; FUNCTION: bool tctdbsetcache ( TCTDB* tdb, int rcnum, int lcnum, int ncnum ) ;
FUNCTION: bool tctdbsetxmsiz ( TCTDB* tdb, longlong xmsiz ) ; FUNCTION: bool tctdbsetxmsiz ( TCTDB* tdb, longlong xmsiz ) ;
FUNCTION: bool tctdbopen ( TCTDB* tdb, char* path, int omode ) ; FUNCTION: bool tctdbopen ( TCTDB* tdb, char* path, int omode ) ;
FUNCTION: bool tctdbclose ( TCTDB* tdb ) ; FUNCTION: bool tctdbclose ( TCTDB* tdb ) ;