<plist version="1.0">
<dict>
<key>IBFramework Version</key>
- <string>629</string>
+ <string>677</string>
<key>IBOldestOS</key>
<integer>5</integer>
<key>IBOpenObjects</key>
- <array>
- <integer>305</integer>
- </array>
+ <array/>
<key>IBSystem Version</key>
- <string>9G55</string>
+ <string>9J61</string>
<key>targetFramework</key>
<string>IBCocoaFramework</string>
</dict>
-{
- IBClasses = (
- {
- ACTIONS = {
- newFactorWorkspace = id;
- runFactorFile = id;
- saveFactorImage = id;
- saveFactorImageAs = id;
- showFactorHelp = id;
- };
- CLASS = FirstResponder;
- LANGUAGE = ObjC;
- SUPERCLASS = NSObject;
- }
- );
- IBVersion = 1;
-}
\ No newline at end of file
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>IBClasses</key>
+ <array>
+ <dict>
+ <key>ACTIONS</key>
+ <dict>
+ <key>newFactorWorkspace</key>
+ <string>id</string>
+ <key>runFactorFile</key>
+ <string>id</string>
+ <key>saveFactorImage</key>
+ <string>id</string>
+ <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>
<?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">
<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>
- <string>439.0</string>
+ <string>677</string>
+ <key>IBOldestOS</key>
+ <integer>5</integer>
<key>IBOpenObjects</key>
<array>
- <integer>29</integer>
+ <integer>293</integer>
</array>
<key>IBSystem Version</key>
- <string>8R218</string>
+ <string>9J61</string>
+ <key>targetFramework</key>
+ <string>IBCocoaFramework</string>
</dict>
</plist>
--- /dev/null
+Jeremy Hughes
--- /dev/null
+Jeremy Hughes
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators fry generalizations
+io.encodings.ascii io.files io.files.temp io.launcher kernel
+locals sequences system ;
+IN: alien.inline.compiler
+
+SYMBOL: C
+SYMBOL: C++
+
+: library-suffix ( -- str )
+ os {
+ { [ dup macosx? ] [ drop ".dylib" ] }
+ { [ dup unix? ] [ drop ".so" ] }
+ { [ dup windows? ] [ drop ".dll" ] }
+ } cond ;
+
+: src-suffix ( lang -- str )
+ {
+ { C [ ".c" ] }
+ { C++ [ ".cpp" ] }
+ } case ;
+
+: compiler ( lang -- str )
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+: link-command ( in out lang -- descr )
+ compiler os {
+ { [ dup linux? ]
+ [ drop { "-shared" "-o" } ] }
+ { [ dup macosx? ]
+ [ drop { "-g" "-prebind" "-dynamiclib" "-o" } ] }
+ [ name>> "unimplemented for: " prepend throw ]
+ } cond swap prefix prepend prepend ;
+
+:: compile-to-object ( lang contents name -- )
+ name ".o" append temp-file
+ contents name lang src-suffix append temp-file
+ [ ascii set-file-contents ] keep 2array
+ { "-fPIC" "-c" "-o" } lang compiler prefix prepend
+ try-process ;
+
+:: link-object ( lang args name -- )
+ args name [ "lib" prepend library-suffix append ]
+ [ ".o" append ] bi [ temp-file ] bi@ 2array
+ lang link-command try-process ;
+
+:: compile-to-library ( lang args contents name -- )
+ lang contents name compile-to-object
+ lang args name link-object ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline.compiler alien.inline.types
+alien.libraries alien.parser arrays assocs effects fry
+generalizations grouping io.files io.files.info io.files.temp
+kernel lexer math math.order math.ranges multiline namespaces
+sequences splitting strings system vocabs.loader
+vocabs.parser words ;
+IN: alien.inline
+
+<PRIVATE
+SYMBOL: c-library
+SYMBOL: library-is-c++
+SYMBOL: compiler-args
+SYMBOL: c-strings
+
+: function-types-effect ( -- function types effect )
+ scan scan swap ")" parse-tokens
+ [ "(" subseq? not ] filter swap parse-arglist ;
+
+: arg-list ( types -- params )
+ CHAR: a swap length CHAR: a + [a,b]
+ [ 1string ] map ;
+
+: factor-function ( function types effect -- word quot effect )
+ annotate-effect [ c-library get ] 3dip
+ [ [ factorize-type ] map ] dip
+ types-effect>params-return factorize-type -roll
+ concat make-function ;
+
+: prototype-string ( function types effect -- str )
+ [ [ cify-type ] map ] dip
+ types-effect>params-return cify-type -rot
+ [ " " join ] map ", " join
+ "(" prepend ")" append 3array " " join
+ library-is-c++ get [ "extern \"C\" " prepend ] when ;
+
+: prototype-string' ( function types return -- str )
+ [ dup arg-list ] <effect> prototype-string ;
+
+: append-function-body ( prototype-str -- str )
+ " {\n" append parse-here append "\n}\n" append ;
+
+
+: library-path ( -- str )
+ "lib" c-library get library-suffix
+ 3array concat temp-file ;
+
+: compile-library? ( -- ? )
+ library-path dup exists? [
+ current-vocab vocab-source-path
+ [ file-info modified>> ] bi@ <=> +lt+ =
+ ] [ drop t ] if ;
+
+: compile-library ( -- )
+ library-is-c++ get [ C++ ] [ C ] if
+ compiler-args get
+ c-strings get "\n" join
+ c-library get compile-to-library ;
+PRIVATE>
+
+: define-c-library ( name -- )
+ c-library set
+ V{ } clone c-strings set
+ V{ } clone compiler-args set ;
+
+: compile-c-library ( -- )
+ compile-library? [ compile-library ] when
+ c-library get library-path "cdecl" add-library ;
+
+: define-c-function ( function types effect -- )
+ [ factor-function define-declared ] 3keep prototype-string
+ append-function-body c-strings get push ;
+
+: define-c-function' ( function effect -- )
+ [ in>> ] keep [ factor-function define-declared ] 3keep
+ out>> prototype-string'
+ append-function-body c-strings get push ;
+
+: define-c-link ( str -- )
+ "-l" prepend compiler-args get push ;
+
+: define-c-framework ( str -- )
+ "-framework" swap compiler-args get '[ _ push ] bi@ ;
+
+: define-c-link/framework ( str -- )
+ os macosx? [ define-c-framework ] [ define-c-link ] if ;
+
+: define-c-include ( str -- )
+ "#include " prepend c-strings get push ;
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan define-c-link ;
+
+SYNTAX: C-FRAMEWORK: scan define-c-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
+
+SYNTAX: C-INCLUDE: scan define-c-include ;
+
+SYNTAX: C-FUNCTION:
+ function-types-effect define-c-function ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.inline alien.inline.private io.files
+io.directories kernel ;
+IN: alien.inline.tests
+
+C-LIBRARY: const
+
+C-FUNCTION: const-int add ( int a, int b )
+ return a + b;
+;
+
+;C-LIBRARY
+
+{ 2 1 } [ add ] must-infer-as
+[ 5 ] [ 2 3 add ] unit-test
+
+<< library-path dup exists? [ delete-file ] [ drop ] if >>
+
+
+C-LIBRARY: cpplib
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-FUNCTION: const-char* hello ( )
+ std::string s("hello world");
+ return s.c_str();
+;
+
+;C-LIBRARY
+
+{ 0 1 } [ hello ] must-infer-as
+[ "hello world" ] [ hello ] unit-test
+
+<< library-path dup exists? [ delete-file ] [ drop ] if >>
+
+
+C-LIBRARY: compile-error
+
+C-FUNCTION: char* breakme ( )
+ return not a string;
+;
+
+<< [ compile-c-library ] must-fail >>
+
+<< library-path dup exists? [ delete-file ] [ drop ] if >>
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators.short-circuit
+continuations effects fry kernel math memoize sequences
+splitting ;
+IN: alien.inline.types
+
+: factorize-type ( str -- str' )
+ "const-" ?head drop
+ "unsigned-" ?head [ "u" prepend ] when
+ "long-" ?head [ "long" prepend ] when ;
+
+: cify-type ( str -- str' )
+ { { CHAR: - CHAR: space } } substitute ;
+
+: const-type? ( str -- ? )
+ "const-" head? ;
+
+MEMO: resolved-primitives ( -- seq )
+ primitive-types [ resolve-typedef ] map ;
+
+: primitive-type? ( type -- ? )
+ [
+ factorize-type resolve-typedef [ resolved-primitives ] dip
+ '[ _ = ] any?
+ ] [ 2drop f ] recover ;
+
+: pointer? ( type -- ? )
+ [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+ [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+ { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: types-effect>params-return ( types effect -- params return )
+ [ in>> zip ]
+ [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
+ 2bi ;
+
+: annotate-effect ( types effect -- types effect' )
+ [ in>> ] [ out>> ] bi [
+ zip
+ [ over pointer-to-primitive? [ ">" prepend ] when ]
+ assoc-map unzip
+ ] dip <effect> ;
}
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
+"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $subsection POSTPONE: C-UNION: }
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
+"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: bit-sets.tests
+USING: bit-sets tools.test bit-arrays ;
+
+[ ?{ t f t f t f } ] [
+ ?{ t f f f t f }
+ ?{ f f t f t f } bit-set-union
+] unit-test
+
+[ ?{ f f f f t f } ] [
+ ?{ t f f f t f }
+ ?{ f f t f t f } bit-set-intersect
+] unit-test
+
+[ ?{ t f t f f f } ] [
+ ?{ t t t f f f }
+ ?{ f t f f t t } bit-set-diff
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+IN: bit-sets
+
+<PRIVATE
+
+: bit-set-map ( seq1 seq2 quot -- seq )
+ [ 2drop length>> ]
+ [
+ [
+ [ [ length ] bi@ assert= ]
+ [ [ underlying>> ] bi@ ] 2bi
+ ] dip 2map
+ ] 3bi bit-array boa ; inline
+
+PRIVATE>
+
+: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+
+HINTS: bit-set-union bit-array bit-array ;
+
+: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+
+HINTS: bit-set-intersect bit-array bit-array ;
+
+: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+
+HINTS: bit-set-diff bit-array bit-array ;
\ No newline at end of file
--- /dev/null
+Efficient bitwise operations on bit arrays
<cairo> &cairo_destroy
@
] make-memory-bitmap
- BGRA >>component-order ; inline
+ BGRA >>component-order
+ ubyte-components >>component-type ; inline
: dummy-cairo ( -- cr )
#! Sometimes we want a dummy context; eg with Pango, we want
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting grouping math sequences namespaces make
-io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart math.ranges fry combinators
-accessors locals checksums.stream multiline literals
-generalizations ;
+USING: accessors checksums checksums.common checksums.stream
+combinators combinators.smart fry generalizations grouping
+io.binary kernel literals locals make math math.bitwise
+math.ranges multiline namespaces sbufs sequences
+sequences.private splitting strings ;
IN: checksums.sha
SINGLETON: sha1
: prepare-M-256 ( n seq -- )
{
- [ [ 16 - ] dip nth ]
- [ [ 15 - ] dip nth s0-256 ]
- [ [ 7 - ] dip nth ]
- [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+ [ [ 16 - ] dip nth-unsafe ]
+ [ [ 15 - ] dip nth-unsafe s0-256 ]
+ [ [ 7 - ] dip nth-unsafe ]
+ [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
[ ]
- } 2cleave set-nth ; inline
+ } 2cleave set-nth-unsafe ; inline
: prepare-M-512 ( n seq -- )
{
- [ [ 16 - ] dip nth ]
- [ [ 15 - ] dip nth s0-512 ]
- [ [ 7 - ] dip nth ]
- [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+ [ [ 16 - ] dip nth-unsafe ]
+ [ [ 15 - ] dip nth-unsafe s0-512 ]
+ [ [ 7 - ] dip nth-unsafe ]
+ [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
[ ]
- } 2cleave set-nth ; inline
+ } 2cleave set-nth-unsafe ; inline
: ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ; inline
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
:: T1-256 ( n M H sha2 -- T1 )
- n M nth
- n sha2 K>> nth +
+ n M nth-unsafe
+ n sha2 K>> nth-unsafe +
e H slice3 ch w+
- e H nth S1-256 w+
- h H nth w+ ; inline
+ e H nth-unsafe S1-256 w+
+ h H nth-unsafe w+ ; inline
: T2-256 ( H -- T2 )
- [ a swap nth S0-256 ]
+ [ a swap nth-unsafe S0-256 ]
[ a swap slice3 maj w+ ] bi ; inline
:: T1-512 ( n M H sha2 -- T1 )
- n M nth
- n sha2 K>> nth +
+ n M nth-unsafe
+ n sha2 K>> nth-unsafe +
e H slice3 ch w+
- e H nth S1-512 w+
- h H nth w+ ; inline
+ e H nth-unsafe S1-512 w+
+ h H nth-unsafe w+ ; inline
: T2-512 ( H -- T2 )
- [ a swap nth S0-512 ]
+ [ a swap nth-unsafe S0-512 ]
[ a swap slice3 maj w+ ] bi ; inline
: update-H ( T1 T2 H -- )
- h g pick exchange
- g f pick exchange
- f e pick exchange
- pick d pick nth w+ e pick set-nth
- d c pick exchange
- c b pick exchange
- b a pick exchange
- [ w+ a ] dip set-nth ; inline
+ h g pick exchange-unsafe
+ g f pick exchange-unsafe
+ f e pick exchange-unsafe
+ pick d pick nth-unsafe w+ e pick set-nth-unsafe
+ d c pick exchange-unsafe
+ c b pick exchange-unsafe
+ b a pick exchange-unsafe
+ [ w+ a ] dip set-nth-unsafe ; inline
: prepare-message-schedule ( seq sha2 -- w-seq )
[ word-size>> <sliced-groups> [ be> ] map ]
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
: seq>byte-array ( seq n -- string )
- '[ _ >be ] map B{ } join ;
+ '[ _ >be ] map B{ } concat-as ;
: sha1>checksum ( sha2 -- bytes )
H>> 4 seq>byte-array ;
drop
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
-
-
: sha1-W ( t seq -- )
{
- [ [ 3 - ] dip nth ]
- [ [ 8 - ] dip nth bitxor ]
- [ [ 14 - ] dip nth bitxor ]
- [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+ [ [ 3 - ] dip nth-unsafe ]
+ [ [ 8 - ] dip nth-unsafe bitxor ]
+ [ [ 14 - ] dip nth-unsafe bitxor ]
+ [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
[ ]
- } 2cleave set-nth ;
+ } 2cleave set-nth-unsafe ;
: prepare-sha1-message-schedule ( seq -- w-seq )
4 <sliced-groups> [ be> ] map
} case ;
:: inner-loop ( n H W K -- temp )
- a H nth :> A
- b H nth :> B
- c H nth :> C
- d H nth :> D
- e H nth :> E
+ a H nth-unsafe :> A
+ b H nth-unsafe :> B
+ c H nth-unsafe :> C
+ d H nth-unsafe :> D
+ e H nth-unsafe :> E
[
A 5 bitroll-32
E
- n K nth
+ n K nth-unsafe
- n W nth
+ n W nth-unsafe
] sum-outputs 32 bits ;
:: process-sha1-chunk ( bytes H W K state -- )
80 [
H W K inner-loop
- d H nth e H set-nth
- c H nth d H set-nth
- b H nth 30 bitroll-32 c H set-nth
- a H nth b H set-nth
- a H set-nth
+ d H nth-unsafe e H set-nth-unsafe
+ c H nth-unsafe d H set-nth-unsafe
+ b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
+ a H nth-unsafe b H set-nth-unsafe
+ a H set-nth-unsafe
] each
state [ H [ w+ ] 2map ] change-H drop ; inline
"NSOpenGLPixelFormat"
"NSOpenGLView"
"NSOpenPanel"
+ "NSPanel"
"NSPasteboard"
"NSPropertyListSerialization"
"NSResponder"
IN: cocoa.windows
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." } ;
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." } ;
ARTICLE: "cocoa-window-utils" "Cocoa window utilities"
sequences math.bitwise ;
IN: cocoa.windows
+! Window styles
CONSTANT: NSBorderlessWindowMask 0
CONSTANT: NSTitledWindowMask 1
CONSTANT: NSClosableWindowMask 2
CONSTANT: NSMiniaturizableWindowMask 4
CONSTANT: NSResizableWindowMask 8
+! Additional panel-only styles
+CONSTANT: NSUtilityWindowMask 16
+CONSTANT: NSDocModalWindowMask 64
+CONSTANT: NSNonactivatingPanelMask 128
+CONSTANT: NSHUDWindowMask HEX: 1000
+
CONSTANT: NSBackingStoreRetained 0
CONSTANT: NSBackingStoreNonretained 1
CONSTANT: NSBackingStoreBuffered 2
-: standard-window-type ( -- n )
- {
- NSTitledWindowMask
- NSClosableWindowMask
- NSMiniaturizableWindowMask
- NSResizableWindowMask
- } flags ; inline
-
-: <NSWindow> ( rect -- window )
- NSWindow -> alloc swap
- standard-window-type NSBackingStoreBuffered 1
+: <NSWindow> ( rect style class -- window )
+ [ -> alloc ] curry 2dip NSBackingStoreBuffered 1
-> initWithContentRect:styleMask:backing:defer: ;
-: <ViewWindow> ( view rect -- window )
- <NSWindow> [ swap -> setContentView: ] keep
+: class-for-style ( style -- NSWindow/NSPanel )
+ HEX: 1ff0 bitand zero? NSWindow NSPanel ? ;
+
+: <ViewWindow> ( view rect style -- window )
+ dup class-for-style <NSWindow> [ swap -> setContentView: ] keep
dup dup -> contentView -> setInitialFirstResponder:
dup 1 -> setAcceptsMouseMovedEvents:
dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
- [ NSWindow ] dip
+ dup -> class swap
[ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ;
--- /dev/null
+IN: compiler.cfg.branch-folding.tests
+USING: compiler.cfg.branch-folding compiler.cfg.instructions
+compiler.cfg compiler.cfg.registers compiler.cfg.debugger
+arrays compiler.cfg.phi-elimination compiler.cfg.dce
+compiler.cfg.predecessors kernel accessors assocs
+sequences classes namespaces tools.test cpu.architecture ;
+
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 { } }
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+[ ] [ cfg new 0 get >>entry fold-branches compute-predecessors eliminate-phis drop ] unit-test
+
+[ 1 ] [ 1 get successors>> length ] unit-test
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ 2 ] [ 4 get instructions>> length ] unit-test
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+} 1 test-bb
+
+V{
+ T{ ##copy f V int-regs 2 V int-regs 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 V{ } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+1 get V int-regs 1 2array
+2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+
+test-diamond
+
+[ ] [
+ cfg new 0 get >>entry
+ compute-predecessors
+ fold-branches
+ compute-predecessors
+ eliminate-dead-code
+ drop
+] unit-test
+
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel sequences vectors
+compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.branch-folding
+
+! Fold comparisons where both inputs are the same. Predecessors must be
+! recomputed after this
+
+: fold-branch? ( bb -- ? )
+ instructions>> last {
+ [ ##compare-branch? ]
+ [ [ src1>> ] [ src2>> ] bi = ]
+ } 1&& ;
+
+: chosen-successor ( bb -- succ )
+ [ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
+ [ successors>> ]
+ bi nth ;
+
+: fold-branch ( bb -- )
+ dup chosen-successor 1vector >>successors
+ instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
+
+: fold-branches ( cfg -- cfg' )
+ dup [
+ dup fold-branch?
+ [ fold-branch ] [ drop ] if
+ ] each-basic-block
+ f >>post-order ;
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel math sequences
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
+IN: compiler.cfg.branch-splitting
+
+! Predecessors must be recomputed after this
+
+: split-branch-for ( bb predecessor -- )
+ [
+ [
+ <basic-block>
+ swap
+ [ instructions>> [ clone ] map >>instructions ]
+ [ successors>> clone >>successors ]
+ bi
+ ] keep
+ ] dip
+ [ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
+ drop ;
+
+: split-branch ( bb -- )
+ dup predecessors>> [ split-branch-for ] with each ;
+
+: split-branches? ( bb -- ? )
+ {
+ [ successors>> empty? ]
+ [ predecessors>> length 1 > ]
+ [ instructions>> [ defs-vregs ] any? not ]
+ [ instructions>> [ temp-vregs ] any? not ]
+ } 1&& ;
+
+: split-branches ( cfg -- cfg' )
+ dup [
+ dup split-branches? [ split-branch ] [ drop ] if
+ ] each-basic-block
+ f >>post-order ;
[ 3 fixnum+fast ]
[ fixnum*fast ]
[ 3 fixnum*fast ]
+ [ 3 swap fixnum*fast ]
[ fixnum-shift-fast ]
[ 10 fixnum-shift-fast ]
[ -10 fixnum-shift-fast ]
[ 0 fixnum-shift-fast ]
+ [ 10 swap fixnum-shift-fast ]
+ [ -10 swap fixnum-shift-fast ]
+ [ 0 swap fixnum-shift-fast ]
[ fixnum-bitnot ]
[ eq? ]
[ "hi" eq? ]
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
-compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
-SYMBOL: first-basic-block
-
-! Basic block after prologue, makes recursion faster
-SYMBOL: current-label-start
: add-procedure ( -- )
basic-block get current-word get current-label get
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
-GENERIC: emit-node ( node -- next )
+GENERIC: emit-node ( node -- )
: check-basic-block ( node -- node' )
basic-block get [ drop f ] unless ; inline
: emit-nodes ( nodes -- )
- [ current-node emit-node check-basic-block ] iterate-nodes ;
+ [ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
- #! We store the basic block after the prologue as a loop
- #! labeled by the current word, so that self-recursive
- #! calls can skip an epilogue/prologue.
##prologue
##branch
- begin-basic-block
- basic-block get first-basic-block set ;
+ begin-basic-block ;
: (build-cfg) ( nodes word label -- )
[
begin-word
- V{ } clone node-stack set
emit-nodes
] with-cfg-builder ;
] with-variable
] keep ;
-: local-recursive-call ( basic-block -- next )
+: emit-loop-call ( basic-block -- )
##branch
basic-block get successors>> push
- stop-iterating ;
+ basic-block off ;
-: emit-call ( word height -- next )
- {
- { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
- { [ terminate-call? ] [ ##call stop-iterating ] }
- { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
- { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
- [ drop ##epilogue ##jump stop-iterating ]
- } cond ;
+: emit-call ( word -- )
+ dup loops get key?
+ [ loops get at emit-loop-call ]
+ [ ##call ##branch begin-basic-block ]
+ if ;
! #recursive
-: recursive-height ( #recursive -- n )
- [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
-
-: emit-recursive ( #recursive -- next )
- [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
+: emit-recursive ( #recursive -- )
+ [ label>> id>> emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
-: emit-loop ( node -- next )
+: emit-loop ( node -- )
##loop-entry
##branch
begin-basic-block
- [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
- iterate-next ;
+ [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
M: #recursive emit-node
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
] with-scope ;
: emit-if ( node -- )
- children>> [ emit-branch ] map
+ children>> [ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
- } cond iterate-next ;
+ } cond ;
! #dispatch
M: #dispatch emit-node
- ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
+ ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
- [ emit-intrinsic ] [ swap call-height emit-call ] if ;
+ [ emit-intrinsic ] [ nip emit-call ] if ;
! #call-recursive
-M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
+M: #call-recursive emit-node label>> id>> emit-call ;
! #push
M: #push emit-node
- literal>> ^^load-literal ds-push iterate-next ;
+ literal>> ^^load-literal ds-push ;
! #shuffle
M: #shuffle emit-node
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
- [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
- iterate-next ;
+ [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
! #return
M: #return emit-node
- drop ##epilogue ##return stop-iterating ;
+ drop ##epilogue ##return ;
M: #return-recursive emit-node
label>> id>> loops get key?
- [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+ [ ##epilogue ##return ] unless ;
! #terminate
-M: #terminate emit-node drop stop-iterating ;
+M: #terminate emit-node drop ##no-tco basic-block off ;
! FFI
: return-size ( ctype -- n )
: alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ;
-: emit-alien-node ( node quot -- next )
+: emit-alien-node ( node quot -- )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
- ##branch begin-basic-block iterate-next ; inline
+ ##branch begin-basic-block ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
dup params>> xt>> dup
[
##prologue
- dup [ ##alien-callback ] emit-alien-node drop
+ dup [ ##alien-callback ] emit-alien-node
##epilogue
params>> ##callback-return
- ] with-cfg-builder
- iterate-next ;
+ ] with-cfg-builder ;
! No-op nodes
-M: #introduce emit-node drop iterate-next ;
+M: #introduce emit-node drop ;
-M: #copy emit-node drop iterate-next ;
+M: #copy emit-node drop ;
-M: #enter-recursive emit-node drop iterate-next ;
+M: #enter-recursive emit-node drop ;
-M: #phi emit-node drop iterate-next ;
+M: #phi emit-node drop ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors
-namespaces math make fry sequences ;
+USING: kernel arrays vectors accessors assocs sets
+namespaces math make fry sequences
+combinators.short-circuit
+compiler.cfg.instructions ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
V{ } clone >>predecessors
\ basic-block counter >>id ;
+: empty-block? ( bb -- ? )
+ instructions>> {
+ [ length 1 = ]
+ [ first ##branch? ]
+ } 1&& ;
+
+SYMBOL: visited
+
+: (skip-empty-blocks) ( bb -- bb' )
+ dup visited get key? [
+ dup empty-block? [
+ dup visited get conjoin
+ successors>> first (skip-empty-blocks)
+ ] when
+ ] unless ;
+
+: skip-empty-blocks ( bb -- bb' )
+ H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
+
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop
[ ##fixnum-add-tail? ]
[ ##fixnum-sub-tail? ]
[ ##fixnum-mul-tail? ]
- [ ##call? ]
+ [ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-loop-entry ;
-Slava Pestov
\ No newline at end of file
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test compiler.cfg kernel accessors compiler.cfg.dce
+compiler.cfg.instructions compiler.cfg.registers cpu.architecture ;
+IN: compiler.cfg.dce.tests
+
+: test-dce ( insns -- insns' )
+ <basic-block> swap >>instructions
+ cfg new swap >>entry
+ eliminate-dead-code
+ entry>> instructions>> ;
+
+[ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} ] [ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} ] [ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
! vregs which participate in side effects and thus are always live
SYMBOL: live-vregs
+: live-vreg? ( vreg -- ? )
+ live-vregs get key? ;
+
+! vregs which are the result of an allocation
+SYMBOL: allocations
+
+: allocation? ( vreg -- ? )
+ allocations get key? ;
+
: init-dead-code ( -- )
H{ } clone liveness-graph set
- H{ } clone live-vregs set ;
+ H{ } clone live-vregs set
+ H{ } clone allocations set ;
+
+GENERIC: build-liveness-graph ( insn -- )
+
+: add-edges ( insn register -- )
+ [ uses-vregs ] dip liveness-graph get [ union ] change-at ;
+
+: setter-liveness-graph ( insn vreg -- )
+ dup allocation? [ add-edges ] [ 2drop ] if ;
+
+M: ##set-slot build-liveness-graph
+ dup obj>> setter-liveness-graph ;
+
+M: ##set-slot-imm build-liveness-graph
+ dup obj>> setter-liveness-graph ;
+
+M: ##write-barrier build-liveness-graph
+ dup src>> setter-liveness-graph ;
+
+M: ##flushable build-liveness-graph
+ dup dst>> add-edges ;
-GENERIC: update-liveness-graph ( insn -- )
+M: ##allot build-liveness-graph
+ [ dst>> allocations get conjoin ]
+ [ call-next-method ] bi ;
-M: ##flushable update-liveness-graph
- [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+M: insn build-liveness-graph drop ;
-: record-live ( vregs -- )
+GENERIC: compute-live-vregs ( insn -- )
+
+: (record-live) ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
- [ liveness-graph get at record-live ]
+ [ liveness-graph get at (record-live) ]
bi
] if
] each ;
-M: insn update-liveness-graph uses-vregs record-live ;
+: record-live ( insn -- )
+ uses-vregs (record-live) ;
+
+: setter-live-vregs ( insn vreg -- )
+ allocation? [ drop ] [ record-live ] if ;
+
+M: ##set-slot compute-live-vregs
+ dup obj>> setter-live-vregs ;
+
+M: ##set-slot-imm compute-live-vregs
+ dup obj>> setter-live-vregs ;
+
+M: ##write-barrier compute-live-vregs
+ dup src>> setter-live-vregs ;
+
+M: ##flushable compute-live-vregs drop ;
+
+M: insn compute-live-vregs
+ record-live ;
GENERIC: live-insn? ( insn -- ? )
-M: ##flushable live-insn? dst>> live-vregs get key? ;
+M: ##flushable live-insn? dst>> live-vreg? ;
+
+M: ##set-slot live-insn? obj>> live-vreg? ;
+
+M: ##set-slot-imm live-insn? obj>> live-vreg? ;
+
+M: ##write-barrier live-insn? src>> live-vreg? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
init-dead-code
- [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
- [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
- [ ]
- tri ;
\ No newline at end of file
+ dup
+ [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
+ [ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
+ [ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ]
+ tri ;
--- /dev/null
+Dead code elimination
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences quotations namespaces io
+USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.liveness compiler.cfg.optimizer
-compiler.cfg.mr ;
+compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;
+
+: test-bb ( insns n -- )
+ [ <basic-block> swap >>number swap >>instructions ] keep set ;
+
+: test-diamond ( -- )
+ 1 get 1vector 0 get (>>successors)
+ 2 get 3 get V{ } 2sequence 1 get (>>successors)
+ 4 get 1vector 2 get (>>successors)
+ 4 get 1vector 3 get (>>successors) ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel compiler.cfg.instructions ;
+USING: accessors arrays kernel assocs compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##phi uses-vregs inputs>> ;
+M: ##phi uses-vregs inputs>> values ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs
-cpu.architecture compiler.cfg.rpo
-compiler.cfg.liveness compiler.cfg.instructions
+compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.hats ;
IN: compiler.cfg.gc-checks
: gc? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
-: object-pointer-regs ( basic-block -- vregs )
- live-in keys [ reg-class>> int-regs eq? ] filter ;
-
: insert-gc-check ( basic-block -- )
dup gc? [
- [ i i f f \ ##gc new-insn prefix ] change-instructions drop
+ [ i i f \ ##gc new-insn prefix ] change-instructions drop
] [ drop ] if ;
: insert-gc-checks ( cfg -- cfg' )
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.liveness compiler.cfg.local ;
-IN: compiler.cfg.height
-
-! Combine multiple stack height changes into one at the
-! start of the basic block.
-
-SYMBOL: ds-height
-SYMBOL: rs-height
-
-GENERIC: compute-heights ( insn -- )
-
-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn' )
-
-: normalize-inc-d/r ( insn stack -- insn' )
- swap n>> '[ _ - ] change f ; inline
-
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
-
-GENERIC: loc-stack ( loc -- stack )
-
-M: ds-loc loc-stack drop ds-height ;
-M: rs-loc loc-stack drop rs-height ;
-
-GENERIC: <loc> ( n stack -- loc )
-
-M: ds-loc <loc> drop <ds-loc> ;
-M: rs-loc <loc> drop <rs-loc> ;
-
-: normalize-peek/replace ( insn -- insn' )
- [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
-
-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
-
-M: insn normalize-height* ;
-
-: height-step ( insns -- insns' )
- 0 ds-height set
- 0 rs-height set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map sift ] with-scope ] bi
- ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
- rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
-
-: normalize-height ( cfg -- cfg' )
- [ drop ] [ height-step ] local-optimization ;
+++ /dev/null
-Stack height normalization coalesces height changes at start of basic block
! Subroutine calls
INSN: ##stack-frame stack-frame ;
-INSN: ##call word { height integer } ;
+INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
+! Dummy instruction that simply inhibits TCO
+INSN: ##no-tco ;
+
! Jump tables
INSN: ##dispatch src temp ;
{ cc/= cc= }
} at ;
+: swap-cc ( cc -- cc' )
+ H{
+ { cc< cc> }
+ { cc<= cc>= }
+ { cc> cc< }
+ { cc>= cc<= }
+ { cc= cc= }
+ { cc/= cc/= }
+ } at ;
+
: evaluate-cc ( result cc -- ? )
H{
{ cc< { +lt+ } }
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
-INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
+INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
+
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces
combinators fry locals
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
-compiler.cfg.iterator
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.registers ;
0 cc= ^^compare-imm
ds-push ;
-: (emit-fixnum-imm-op) ( infos insn -- dst )
- ds-drop
- [ ds-pop ]
- [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
- [ ]
- tri*
- call ; inline
+: tag-literal ( n -- tagged )
+ literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+: emit-fixnum-imm-op1 ( infos insn -- dst )
+ [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
+
+: emit-fixnum-imm-op2 ( infos insn -- dst )
+ [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
: (emit-fixnum-op) ( insn -- dst )
[ 2inputs ] dip call ; inline
:: emit-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
infos second value-info-small-tagged?
- [ infos imm-insn (emit-fixnum-imm-op) ]
- [ insn (emit-fixnum-op) ]
- if
+ [ infos imm-insn emit-fixnum-imm-op2 ]
+ [ insn (emit-fixnum-op) ] if
+ ds-push
+ ] ; inline
+
+:: emit-commutative-fixnum-op ( node insn imm-insn -- )
+ [let | infos [ node node-input-infos ] |
+ {
+ { [ infos first value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op1 ] }
+ { [ infos second value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op2 ] }
+ [ insn (emit-fixnum-op) ]
+ } cond
ds-push
] ; inline
} case
ds-push
] [ drop emit-primitive ] if ;
-
+
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
-: (emit-fixnum*fast-imm) ( infos -- dst )
- ds-drop
- [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
+: (emit-fixnum*fast-imm1) ( infos -- dst )
+ [ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ;
+
+: (emit-fixnum*fast-imm2) ( infos -- dst )
+ [ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
: emit-fixnum*fast ( node -- )
node-input-infos
- dup second value-info-small-fixnum?
- [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
+ dup first value-info-small-fixnum? drop f
+ [
+ (emit-fixnum*fast-imm1)
+ ] [
+ dup second value-info-small-fixnum?
+ [ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if
+ ] if
ds-push ;
+: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
+ [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
+
+: emit-eq ( node -- )
+ cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
+
: emit-fixnum-comparison ( node cc -- )
- [ ^^compare ] [ ^^compare-imm ] bi-curry
- emit-fixnum-op ;
+ (emit-fixnum-comparison) emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
-: emit-fixnum-overflow-op ( quot quot-tail -- next )
- [ 2inputs 1 ##inc-d ] 2dip
- tail-call? [
- ##epilogue
- nip call
- stop-iterating
- ] [
- drop call
- ##branch
- begin-basic-block
- iterate-next
- ] if ; inline
+: emit-fixnum-overflow-op ( quot -- next )
+ [ 2inputs 1 ##inc-d ] dip call ##branch
+ begin-basic-block ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture
compiler.cfg.hats
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
-compiler.cfg.intrinsics.misc
-compiler.cfg.iterator ;
+compiler.cfg.intrinsics.misc ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
-: emit-intrinsic ( node word -- node/f )
+: emit-intrinsic ( node word -- )
{
- { \ kernel.private:tag [ drop emit-tag iterate-next ] }
- { \ kernel.private:getenv [ emit-getenv iterate-next ] }
- { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
- { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
- { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
- { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
- { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
- { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
- { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
- { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
- { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
- { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
- { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
- { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
- { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
- { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
- { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
- { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
- { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
- { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
- { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
- { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
- { \ slots.private:slot [ emit-slot iterate-next ] }
- { \ slots.private:set-slot [ emit-set-slot iterate-next ] }
- { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
- { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
- { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
- { \ arrays:<array> [ emit-<array> iterate-next ] }
- { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
- { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
- { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
- { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
- { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
- { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
- { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
- { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
- { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
+ { \ kernel.private:tag [ drop emit-tag ] }
+ { \ kernel.private:getenv [ emit-getenv ] }
+ { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
+ { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
+ { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+ { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+ { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+ { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+ { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+ { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+ { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+ { \ kernel:eq? [ emit-eq ] }
+ { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+ { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+ { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+ { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+ { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+ { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+ { \ math.private:float< [ drop cc< emit-float-comparison ] }
+ { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+ { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+ { \ math.private:float> [ drop cc> emit-float-comparison ] }
+ { \ math.private:float= [ drop cc= emit-float-comparison ] }
+ { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+ { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { \ slots.private:slot [ emit-slot ] }
+ { \ slots.private:set-slot [ emit-set-slot ] }
+ { \ strings.private:string-nth [ drop emit-string-nth ] }
+ { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
+ { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+ { \ arrays:<array> [ emit-<array> ] }
+ { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
+ { \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
+ { \ kernel:<wrapper> [ emit-simple-allot ] }
+ { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+ { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+ { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+ { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
} case ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.cfg.iterator
-
-SYMBOL: node-stack
-
-: >node ( cursor -- ) node-stack get push ;
-: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get last ;
-: current-node ( -- node ) node@ first ;
-: iterate-next ( -- cursor ) node@ rest-slice ;
-: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
-
-: iterate-nodes ( cursor quot: ( -- ) -- )
- over empty? [
- 2drop
- ] [
- [ swap >node call node> drop ] keep iterate-nodes
- ] if ; inline recursive
-
-DEFER: (tail-call?)
-
-: tail-phi? ( cursor -- ? )
- [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
-
-: (tail-call?) ( cursor -- ? )
- [ t ] [
- [
- first
- [ #return? ]
- [ #return-recursive? ]
- [ #terminate? ] tri or or
- ] [ tail-phi? ] bi or
- ] if-empty ;
-
-: tail-call? ( -- ? )
- node-stack get [
- rest-slice
- [ t ] [ (tail-call?) ] if-empty
- ] all? ;
-
-: terminate-call? ( -- ? )
- node-stack get last
- rest-slice [ f ] [ first #terminate? ] if-empty ;
+++ /dev/null
-Utility for iterating for high-level IR
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs heaps kernel namespaces sequences
+USING: accessors assocs heaps kernel namespaces sequences fry math
+math.order combinators arrays sorting compiler.utilities
+compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation
+: active-positions ( new assoc -- )
+ [ vreg>> active-intervals-for ] dip
+ '[ [ 0 ] dip reg>> _ add-use-position ] each ;
+
+: inactive-positions ( new assoc -- )
+ [ [ vreg>> inactive-intervals-for ] keep ] dip
+ '[
+ [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
+ _ add-use-position
+ ] each ;
+
+: register-status ( new -- free-pos )
+ dup free-positions
+ [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+ >alist alist-max ;
+
+: no-free-registers? ( result -- ? )
+ second 0 = ; inline
+
+: register-partially-available ( new result -- )
+ [ second split-before-use ] keep
+ '[ _ register-available ] [ add-unhandled ] bi* ;
+
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
- dup vreg>> free-registers-for [
- dup intersecting-inactive
- [ assign-blocked-register ]
- [ assign-inactive-register ]
- if-empty
- ] [ assign-free-register ]
- if-empty
+ dup register-status {
+ { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
+ { [ 2dup register-available? ] [ register-available ] }
+ [ register-partially-available ]
+ } cond
] if ;
: handle-interval ( live-interval -- )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences
+combinators.short-circuit
+compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
+: avoids-inactive-intervals? ( live-interval -- ? )
+ dup vreg>> inactive-intervals-for
+ [ intervals-intersect? not ] with all? ;
+
: coalesce? ( live-interval -- ? )
- [ start>> ] [ copy-from>> active-interval ] bi
- dup [ end>> = ] [ 2drop f ] if ;
+ {
+ [ copy-from>> active-interval ]
+ [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
+ [ avoids-inactive-intervals? ]
+ } 1&& ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
[ reg>> >>reg drop ]
2bi ;
+
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting
+math sequences sets sorting splitting namespaces
+combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling
+ERROR: bad-live-ranges interval ;
+
+: check-ranges ( live-interval -- )
+ check-allocation? get [
+ dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
+ [ drop ] [ bad-live-ranges ] if
+ ] [ drop ] if ;
+
+: trim-before-ranges ( live-interval -- )
+ [ ranges>> ] [ uses>> last ] bi
+ [ '[ from>> _ <= ] filter-here ]
+ [ swap last (>>to) ]
+ 2bi ;
+
+: trim-after-ranges ( live-interval -- )
+ [ ranges>> ] [ uses>> first ] bi
+ [ '[ to>> _ >= ] filter-here ]
+ [ swap first (>>from) ]
+ 2bi ;
+
: split-for-spill ( live-interval n -- before after )
split-interval
+ {
+ [ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
+ [ [ compute-start/end ] bi@ ]
+ [ [ check-ranges ] bi@ ]
+ [ ]
+ } 2cleave ;
+
+: assign-spill ( live-interval -- )
+ dup vreg>> assign-spill-slot >>spill-to drop ;
+
+: assign-reload ( live-interval -- )
+ dup vreg>> assign-spill-slot >>reload-from drop ;
+
+: split-and-spill ( live-interval n -- before after )
+ split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
+
+: find-use-position ( live-interval new -- n )
+ [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
+
+: find-use-positions ( live-intervals new assoc -- )
+ '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
+
+: active-positions ( new assoc -- )
+ [ [ vreg>> active-intervals-for ] keep ] dip
+ find-use-positions ;
+
+: inactive-positions ( new assoc -- )
[
- [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
- [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
- ]
- [ [ compute-start/end ] bi@ ]
- [ ]
- 2tri ;
-
-: find-use ( live-interval n quot -- i elt )
- [ uses>> ] 2dip curry find ; inline
-
-: interval-to-spill ( active-intervals current -- live-interval )
- #! We spill the interval with the most distant use location.
- start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>>
- [ over vreg>> reg-class>> next-spill-location ] unless*
- [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
-
-: split-and-spill ( new existing -- before after )
- swap start>> split-for-spill assign-spill ;
-
-: spill-existing ( new existing -- )
- #! Our new interval will be used before the active interval
- #! with the most distant use location. Spill the existing
- #! interval, then process the new interval and the tail end
- #! of the existing interval again.
- [ reuse-register ]
- [ nip delete-active ]
- [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
-
-: spill-new ( new existing -- )
- #! Our new interval will be used after the active interval
- #! with the most distant use location. Split the new
- #! interval, then process both parts of the new interval
- #! again.
- [ dup split-and-spill add-unhandled ] dip spill-existing ;
-
-: spill-existing? ( new existing -- ? )
- #! Test if 'new' will be used before 'existing'.
- over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
+ [ vreg>> inactive-intervals-for ] keep
+ [ '[ _ intervals-intersect? ] filter ] keep
+ ] dip
+ find-use-positions ;
-: assign-blocked-register ( new -- )
- [ dup vreg>> active-intervals-for ] keep interval-to-spill
- 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+: spill-status ( new -- use-pos )
+ H{ } clone
+ [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+ >alist alist-max ;
+
+: spill-new? ( new pair -- ? )
+ [ uses>> first ] [ second ] bi* > ;
+: spill-new ( new pair -- )
+ drop
+ {
+ [ trim-after-ranges ]
+ [ compute-start/end ]
+ [ assign-reload ]
+ [ add-unhandled ]
+ } cleave ;
+
+: split-intersecting? ( live-interval new reg -- ? )
+ { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
+
+: split-live-out ( live-interval -- )
+ {
+ [ trim-before-ranges ]
+ [ compute-start/end ]
+ [ assign-spill ]
+ [ add-handled ]
+ } cleave ;
+
+: split-live-in ( live-interval -- )
+ {
+ [ trim-after-ranges ]
+ [ compute-start/end ]
+ [ assign-reload ]
+ [ add-unhandled ]
+ } cleave ;
+
+: (split-intersecting) ( live-interval new -- )
+ start>> {
+ { [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] }
+ { [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] }
+ [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
+ } cond ;
+
+: (split-intersecting-active) ( active new -- )
+ [ drop delete-active ]
+ [ (split-intersecting) ] 2bi ;
+
+: split-intersecting-active ( new reg -- )
+ [ [ vreg>> active-intervals-for ] keep ] dip
+ [ '[ _ _ split-intersecting? ] filter ] 2keep drop
+ '[ _ (split-intersecting-active) ] each ;
+
+: (split-intersecting-inactive) ( inactive new -- )
+ [ drop delete-inactive ]
+ [ (split-intersecting) ] 2bi ;
+
+: split-intersecting-inactive ( new reg -- )
+ [ [ vreg>> inactive-intervals-for ] keep ] dip
+ [ '[ _ _ split-intersecting? ] filter ] 2keep drop
+ '[ _ (split-intersecting-inactive) ] each ;
+
+: split-intersecting ( new reg -- )
+ [ split-intersecting-active ]
+ [ split-intersecting-inactive ]
+ 2bi ;
+
+: spill-available ( new pair -- )
+ [ first split-intersecting ] [ register-available ] 2bi ;
+
+: spill-partially-available ( new pair -- )
+ [ second 1 - split-and-spill add-unhandled ] keep
+ spill-available ;
+
+: assign-blocked-register ( new -- )
+ dup spill-status {
+ { [ 2dup spill-new? ] [ spill-new ] }
+ { [ 2dup register-available? ] [ spill-available ] }
+ [ spill-partially-available ]
+ } cond ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting
+math sequences sets sorting splitting namespaces
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting
'[ _ <= ] partition ;
: record-split ( live-interval before after -- )
- [ >>split-next drop ]
- [ [ >>split-before ] [ >>split-after ] bi* drop ]
- 2bi ; inline
+ [ >>split-before ] [ >>split-after ] bi* drop ; inline
ERROR: splitting-too-early ;
+ERROR: splitting-too-late ;
+
ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- )
- [ [ start>> ] dip > [ splitting-too-early ] when ]
- [ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
- 2bi ; inline
+ check-allocation? get [
+ [ [ start>> ] dip > [ splitting-too-early ] when ]
+ [ [ end>> ] dip <= [ splitting-too-late ] when ]
+ [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
+ 2tri
+ ] [ 2drop ] if ; inline
: split-before ( before -- before' )
f >>spill-to ; inline
HINTS: split-interval live-interval object ;
-: reuse-register ( new existing -- )
- reg>> >>reg add-active ;
-
-: relevant-ranges ( new inactive -- new' inactive' )
- ! Slice off all ranges of 'inactive' that precede the start of 'new'
- [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
-
-: intersect-live-range ( range1 range2 -- n/f )
- 2dup [ from>> ] bi@ > [ swap ] when
- 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
-
-: intersect-live-ranges ( ranges1 ranges2 -- n )
- {
- { [ over empty? ] [ 2drop 1/0. ] }
- { [ dup empty? ] [ 2drop 1/0. ] }
- [
- 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
- drop
- 2dup [ first from>> ] bi@ <
- [ [ rest-slice ] dip ] [ rest-slice ] if
- intersect-live-ranges
- ] if
- ]
- } cond ;
-
-: intersect-inactive ( new inactive active-regs -- n/f )
- ! If the interval's register is currently in use, we cannot
- ! re-use it.
- 2dup [ reg>> ] dip key?
- [ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
-
-: intersecting-inactive ( new -- live-intervals )
- dup vreg>>
- [ inactive-intervals-for ]
- [ active-intervals-for [ reg>> ] map unique ] bi
- '[ tuck _ intersect-inactive ] with { } map>assoc
- [ nip ] assoc-filter ;
+: split-between-blocks ( new n -- before after )
+ split-interval
+ 2dup [ compute-start/end ] bi@ ;
: insert-use-for-copy ( seq n -- seq' )
- [ 1array split1 ] keep [ 1 - ] keep 2array glue ;
+ [ '[ _ < ] filter ]
+ [ nip dup 1 + 2array ]
+ [ 1 + '[ _ > ] filter ]
+ 2tri 3append ;
: split-before-use ( new n -- before after )
- ! Find optimal split position
- ! Insert move instruction
- [ '[ _ insert-use-for-copy ] change-uses ] keep
- 1 - split-interval
- 2dup [ compute-start/end ] bi@ ;
-
-: assign-inactive-register ( new live-intervals -- )
- ! If there is an interval which is inactive for the entire lifetime
- ! if the new interval, reuse its vreg. Otherwise, split new so that
- ! the first half fits.
- sort-values last
- 2dup [ end>> ] [ second ] bi* < [
- first reuse-register
+ 1 -
+ 2dup swap covers? [
+ [ '[ _ insert-use-for-copy ] change-uses ] keep
+ split-between-blocks
+ 2dup >>split-next drop
] [
- [ second split-before-use ] keep
- '[ _ first reuse-register ] [ add-unhandled ] bi*
+ split-between-blocks
] if ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
-kernel math namespaces sequences vectors
+kernel math math.order namespaces sequences vectors
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
-! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than this one. This ensures that we can catch
+! infinite loop situations. We also ensure that all live
+! intervals added to the handled set have an end index strictly
+! smaller than this one. This helps catch bugs.
+SYMBOL: progress
+
+: check-unhandled ( live-interval -- )
+ start>> progress get <= [ "check-unhandled" throw ] when ; inline
-: free-registers-for ( vreg -- seq )
- reg-class>> free-registers get at ;
+: check-handled ( live-interval -- )
+ end>> progress get > [ "check-handled" throw ] when ; inline
-: deallocate-register ( live-interval -- )
- [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+! Mapping from register classes to sequences of machine registers
+SYMBOL: registers
! Vector of active live intervals
SYMBOL: active-intervals
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
+: delete-inactive ( live-interval -- )
+ dup vreg>> inactive-intervals-for delq ;
+
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
- handled-intervals get push ;
+ [ check-handled ] [ handled-intervals get push ] bi ;
: finished? ( n live-interval -- ? ) end>> swap < ;
: finish ( n live-interval -- keep? )
- nip [ deallocate-register ] [ add-handled ] bi f ;
+ nip add-handled f ;
SYMBOL: check-allocation?
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
- start>> progress get <= [ "No progress" throw ] when ; inline
-
: add-unhandled ( live-interval -- )
- [ check-progress ]
+ [ check-unhandled ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
+! Mapping from register classes to spill counts
SYMBOL: spill-counts
-: next-spill-location ( reg-class -- n )
+: next-spill-slot ( reg-class -- n )
spill-counts get [ dup 1 + ] change-at ;
+! Mapping from vregs to spill slots
+SYMBOL: spill-slots
+
+: assign-spill-slot ( vreg -- n )
+ spill-slots get [ reg-class>> next-spill-slot ] cache ;
+
: init-allocator ( registers -- )
- [ reverse >vector ] assoc-map free-registers set
- [ 0 ] reg-class-assoc spill-counts set
+ registers set
<min-heap> unhandled-intervals set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
+ [ 0 ] reg-class-assoc spill-counts set
+ H{ } clone spill-slots set
-1 progress set ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
\ No newline at end of file
+ unhandled-intervals get heap-push-all ;
+
+! A utility used by register-status and spill-status words
+: free-positions ( new -- assoc )
+ vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+
+: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
+
+: register-available? ( new result -- ? )
+ [ end>> ] [ second ] bi* < ; inline
+
+: register-available ( new result -- )
+ first >>reg add-active ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets
+fry make combinators sets locals
cpu.architecture
+compiler.cfg
compiler.cfg.def-use
+compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
: init-unhandled ( live-intervals -- )
[ add-unhandled ] each ;
-! Mapping spill slots to vregs
-SYMBOL: spill-slots
+! Mapping from basic blocks to values which are live at the start
+SYMBOL: register-live-ins
-: spill-slots-for ( vreg -- assoc )
- reg-class>> spill-slots get at ;
+! Mapping from basic blocks to values which are live at the end
+SYMBOL: register-live-outs
-ERROR: already-spilled ;
-
-: record-spill ( live-interval -- )
- [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ already-spilled ] [ set-at ] if ;
+: init-assignment ( live-intervals -- )
+ V{ } clone pending-intervals set
+ <min-heap> unhandled-intervals set
+ H{ } clone register-live-ins set
+ H{ } clone register-live-outs set
+ init-unhandled ;
: 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 -- )
- dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+ dup spill-to>> [ insert-spill ] [ drop ] if ;
+
+: first-split ( live-interval -- live-interval' )
+ dup split-before>> [ first-split ] [ ] ?if ;
+
+: next-interval ( live-interval -- live-interval' )
+ split-next>> first-split ;
: insert-copy ( live-interval -- )
- [ split-next>> reg>> ]
- [ reg>> ]
- [ vreg>> reg-class>> ]
- tri _copy ;
+ {
+ [ next-interval reg>> ]
+ [ reg>> ]
+ [ vreg>> reg-class>> ]
+ [ end>> ]
+ } cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- )
- dup [ spill-to>> not ] [ split-next>> ] bi and
- [ insert-copy ] [ drop ] if ;
+ dup split-next>> [ insert-copy ] [ drop ] if ;
: expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ;
-ERROR: already-reloaded ;
-
-: record-reload ( live-interval -- )
- [ reload-from>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ delete-at ] [ already-reloaded ] if ;
-
: insert-reload ( live-interval -- )
- [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
+ {
+ [ reg>> ]
+ [ vreg>> reg-class>> ]
+ [ reload-from>> ]
+ [ start>> ]
+ } cleave f swap \ _reload boa , ;
: handle-reload ( live-interval -- )
- dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
+ dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction
] [ 2drop ] if
] if ;
+: prepare-insn ( n -- )
+ [ expire-old-intervals ] [ activate-new-intervals ] bi ;
+
GENERIC: assign-registers-in-insn ( insn -- )
: register-mapping ( live-intervals -- alist )
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+ [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
-: active-intervals ( insn -- intervals )
- insn#>> pending-intervals get [ covers? ] with filter ;
+SYMBOL: check-assignment?
+
+ERROR: overlapping-registers intervals ;
+
+: check-assignment ( intervals -- )
+ dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
+ dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
+
+: active-intervals ( n -- intervals )
+ pending-intervals get [ covers? ] with filter
+ check-assignment? get [ dup check-assignment ] when ;
M: vreg-insn assign-registers-in-insn
- dup [ active-intervals ] [ all-vregs ] bi
- '[ vreg>> _ member? ] filter
+ dup [ all-vregs ] [ insn#>> active-intervals ] bi
+ '[ _ [ vreg>> = ] with find nip ] map
register-mapping
>>regs drop ;
-: compute-live-registers ( insn -- regs )
- active-intervals register-mapping ;
-
-: compute-live-spill-slots ( -- spill-slots )
- spill-slots get values [ values ] map concat
- [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
-
M: ##gc assign-registers-in-insn
+ ! This works because ##gc is always the first instruction
+ ! in a block.
dup call-next-method
- dup compute-live-registers >>live-registers
- compute-live-spill-slots >>live-spill-slots
+ basic-block get register-live-ins get at >>live-values
drop ;
M: insn assign-registers-in-insn drop ;
-: init-assignment ( live-intervals -- )
- V{ } clone pending-intervals set
- <min-heap> unhandled-intervals set
- [ H{ } clone ] reg-class-assoc spill-slots set
- init-unhandled ;
+: compute-live-spill-slots ( vregs -- assoc )
+ spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
+
+: compute-live-registers ( n -- assoc )
+ active-intervals register-mapping ;
+
+ERROR: bad-live-values live-values ;
+
+: check-live-values ( assoc -- assoc )
+ check-assignment? get [
+ dup values [ not ] any? [ bad-live-values ] when
+ ] when ;
+
+: compute-live-values ( vregs n -- assoc )
+ ! If a live vreg is not in active or inactive, then it must have been
+ ! spilled.
+ [ compute-live-spill-slots ] [ compute-live-registers ] bi*
+ assoc-union check-live-values ;
+
+: begin-block ( bb -- )
+ dup basic-block set
+ dup block-from prepare-insn
+ [ [ live-in ] [ block-from ] bi compute-live-values ] keep
+ register-live-ins get set-at ;
+
+: end-block ( bb -- )
+ [ [ live-out ] [ block-to ] bi compute-live-values ] keep
+ register-live-outs get set-at ;
+
+ERROR: bad-vreg vreg ;
+
+: vreg-at-start ( vreg bb -- state )
+ register-live-ins get at ?at [ bad-vreg ] unless ;
+
+: vreg-at-end ( vreg bb -- state )
+ register-live-outs get at ?at [ bad-vreg ] unless ;
-: assign-registers-in-block ( bb -- )
- [
+:: assign-registers-in-block ( bb -- )
+ bb [
[
+ bb begin-block
[
- [
- insn#>>
- [ expire-old-intervals ]
- [ activate-new-intervals ]
- bi
- ]
- [ assign-registers-in-insn ]
- [ , ]
- tri
+ {
+ [ insn#>> 1 - prepare-insn ]
+ [ insn#>> prepare-insn ]
+ [ assign-registers-in-insn ]
+ [ , ]
+ } cleave
] each
+ bb end-block
] V{ } make
] change-instructions drop ;
-: assign-registers ( rpo live-intervals -- )
- init-assignment
+: assign-registers ( live-intervals rpo -- )
+ [ init-assignment ] dip
[ assign-registers-in-block ] each ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays math strings fry
-prettyprint compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation ;
+namespaces prettyprint compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- )
] [ 1array ] if ;
: check-linear-scan ( live-intervals machine-registers -- )
- [ [ clone ] map ] dip allocate-registers
+ [
+ [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
+ live-intervals set
+ ] dip allocate-registers
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
-math.order grouping
+math.order grouping strings strings.private
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.liveness
compiler.cfg.predecessors
compiler.cfg.rpo
+compiler.cfg.linearization
+compiler.cfg.debugger
compiler.cfg.linear-scan
+compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.spilling
-compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.debugger ;
+FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
+
check-allocation? on
+check-assignment? on
+check-numbering? on
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
-[ 7 ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 7 10 } }
- }
- 4 [ >= ] find-use nip
-] unit-test
-
-[ 4 ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 4 10 } }
- }
- 4 [ >= ] find-use nip
-] unit-test
-
-[ f ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 4 10 } }
- }
- 100 [ >= ] find-use nip
-] unit-test
-
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
} 0 split-for-spill [ f >>split-next ] bi@
] unit-test
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 0 }
+ { uses V{ 0 } }
+ { ranges V{ T{ live-range f 0 0 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 20 }
+ { end 30 }
+ { uses V{ 20 30 } }
+ { ranges V{ T{ live-range f 20 30 } } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 30 }
+ { uses V{ 0 20 30 } }
+ { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
+ } 10 split-for-spill [ f >>split-next ] bi@
+] unit-test
+
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 10 }
- { uses V{ 3 10 } }
- }
-] [
- {
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 15 }
- { uses V{ 1 3 7 10 15 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 8 }
- { uses V{ 3 4 8 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 10 }
- { uses V{ 3 10 } }
- }
+ { start 0 }
+ { end 4 }
+ { uses V{ 0 1 4 } }
+ { ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
- { end 5 }
- { uses V{ 5 } }
+ { end 10 }
+ { uses V{ 5 10 } }
+ { ranges V{ T{ live-range f 5 10 } } }
}
- interval-to-spill
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 1 10 } }
+ { ranges V{ T{ live-range f 0 10 } } }
+ } 5 split-before-use [ f >>split-next ] bi@
] unit-test
-[ t ] [
+[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 5 }
- { end 15 }
- { uses V{ 5 10 15 } }
+ { start 0 }
+ { end 4 }
+ { uses V{ 0 1 4 } }
+ { ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 20 } }
+ { start 5 }
+ { end 10 }
+ { uses V{ 5 10 } }
+ { ranges V{ T{ live-range f 5 10 } } }
}
- spill-existing?
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 10 }
+ { uses V{ 0 1 4 5 10 } }
+ { ranges V{ T{ live-range f 0 10 } } }
+ } 5 split-before-use [ f >>split-next ] bi@
] unit-test
-[ f ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 5 }
- { end 15 }
- { uses V{ 5 10 15 } }
+[
+ {
+ 3
+ 10
}
+] [
+ H{
+ { int-regs
+ V{
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { reg 1 }
+ { start 1 }
+ { end 15 }
+ { uses V{ 1 3 7 10 15 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { reg 2 }
+ { start 3 }
+ { end 8 }
+ { uses V{ 3 4 8 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { reg 3 }
+ { start 3 }
+ { end 10 }
+ { uses V{ 3 10 } }
+ }
+ }
+ }
+ } active-intervals set
+ H{ } inactive-intervals set
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 7 20 } }
+ { start 5 }
+ { end 5 }
+ { uses V{ 5 } }
}
- spill-existing?
+ spill-status
] unit-test
-[ t ] [
+[
+ {
+ 1
+ 1/0.
+ }
+] [
+ H{
+ { int-regs
+ V{
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { reg 1 }
+ { start 1 }
+ { end 15 }
+ { uses V{ 1 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { reg 2 }
+ { start 3 }
+ { end 8 }
+ { uses V{ 3 8 } }
+ }
+ }
+ }
+ } active-intervals set
+ H{ } inactive-intervals set
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 7 20 } }
- }
- spill-existing?
+ spill-status
] unit-test
[ ] [
[ ] [ 10 20 2 400 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 ]
}
}
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
- instructions>> first live-spill-slots>> empty?
+ instructions>> first
+ live-values>> assoc-empty?
] with-scope
] unit-test
intersect-live-ranges
] unit-test
+[ f ] [
+ {
+ T{ live-range f 0 10 }
+ T{ live-range f 20 30 }
+ T{ live-range f 40 50 }
+ }
+ {
+ T{ live-range f 11 15 }
+ T{ live-range f 31 36 }
+ T{ live-range f 51 55 }
+ }
+ intersect-live-ranges
+] unit-test
+
[ 5 ] [
T{ live-interval
{ start 0 }
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
- H{ }
- intersect-inactive
+ relevant-ranges intersect-live-ranges
+] unit-test
+
+! register-status had problems because it used map>assoc where the sequence
+! had multiple keys
+[ { 0 10 } ] [
+ H{ { int-regs { 0 1 } } } registers set
+ H{
+ { int-regs
+ {
+ T{ live-interval
+ { vreg V int-regs 1 }
+ { start 0 }
+ { end 20 }
+ { reg 0 }
+ { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
+ { uses V{ 0 2 10 20 } }
+ }
+
+ T{ live-interval
+ { vreg V int-regs 2 }
+ { start 4 }
+ { end 40 }
+ { reg 0 }
+ { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } }
+ { uses V{ 4 6 30 40 } }
+ }
+ }
+ }
+ } inactive-intervals set
+ H{
+ { int-regs
+ {
+ T{ live-interval
+ { vreg V int-regs 3 }
+ { start 0 }
+ { end 40 }
+ { reg 1 }
+ { ranges V{ T{ live-range f 0 40 } } }
+ { uses V{ 0 40 } }
+ }
+ }
+ }
+ } active-intervals set
+
+ T{ live-interval
+ { vreg V int-regs 4 }
+ { start 8 }
+ { end 10 }
+ { ranges V{ T{ live-range f 8 10 } } }
+ { uses V{ 8 10 } }
+ }
+ register-status
] unit-test
! Bug in live spill slots calculation
-T{ basic-block
- { id 205651 }
- { number 0 }
- { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-T{ basic-block
- { id 205652 }
- { number 1 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 703128 }
- { loc D 1 }
- }
- T{ ##peek
- { dst V int-regs 703129 }
- { loc D 0 }
- }
- T{ ##copy
- { dst V int-regs 703134 }
- { src V int-regs 703128 }
- }
- T{ ##copy
- { dst V int-regs 703135 }
- { src V int-regs 703129 }
- }
- T{ ##compare-imm-branch
- { src1 V int-regs 703128 }
- { src2 5 }
- { cc cc/= }
- }
- }
- }
-} 1 set
+V{
+ T{ ##peek
+ { dst V int-regs 703128 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 703129 }
+ { loc D 0 }
+ }
+ T{ ##copy
+ { dst V int-regs 703134 }
+ { src V int-regs 703128 }
+ }
+ T{ ##copy
+ { dst V int-regs 703135 }
+ { src V int-regs 703129 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 703128 }
+ { src2 5 }
+ { cc cc/= }
+ }
+} 1 test-bb
-T{ basic-block
- { id 205653 }
- { number 2 }
- { instructions
- V{
- T{ ##copy
- { dst V int-regs 703134 }
- { src V int-regs 703129 }
- }
- T{ ##copy
- { dst V int-regs 703135 }
- { src V int-regs 703128 }
- }
- T{ ##branch }
- }
- }
-} 2 set
+V{
+ T{ ##copy
+ { dst V int-regs 703134 }
+ { src V int-regs 703129 }
+ }
+ T{ ##copy
+ { dst V int-regs 703135 }
+ { src V int-regs 703128 }
+ }
+ T{ ##branch }
+} 2 test-bb
-T{ basic-block
- { id 205655 }
- { number 3 }
- { instructions
- V{
- T{ ##replace
- { src V int-regs 703134 }
- { loc D 0 }
- }
- T{ ##replace
- { src V int-regs 703135 }
- { loc D 1 }
- }
- T{ ##epilogue }
- T{ ##return }
- }
- }
-} 3 set
+V{
+ T{ ##replace
+ { src V int-regs 703134 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 703135 }
+ { loc D 1 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+} 3 test-bb
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
3 get 1vector 2 get (>>successors)
+SYMBOL: linear-scan-result
+
:: test-linear-scan-on-cfg ( regs -- )
- [ ] [
+ [
cfg new 0 get >>entry
compute-predecessors
compute-liveness
- reverse-post-order
+ dup reverse-post-order
{ { int-regs regs } } (linear-scan)
- ] unit-test ;
+ flatten-cfg 1array mr.
+ ] with-scope ;
+
+! This test has a critical edge -- do we care about these?
-{ 1 2 } test-linear-scan-on-cfg
+! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
-T{ basic-block
- { id 201486 }
- { number 0 }
- { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-T{ basic-block
- { id 201487 }
- { number 1 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 689473 }
- { loc D 2 }
- }
- T{ ##peek
- { dst V int-regs 689474 }
- { loc D 1 }
- }
- T{ ##peek
- { dst V int-regs 689475 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 V int-regs 689473 }
- { src2 5 }
- { cc cc/= }
- }
- }
- }
-} 1 set
+V{
+ T{ ##peek
+ { dst V int-regs 689473 }
+ { loc D 2 }
+ }
+ T{ ##peek
+ { dst V int-regs 689474 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 689475 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 689473 }
+ { src2 5 }
+ { cc cc/= }
+ }
+} 1 test-bb
-T{ basic-block
- { id 201488 }
- { number 2 }
- { instructions
- V{
- T{ ##copy
- { dst V int-regs 689481 }
- { src V int-regs 689475 }
- }
- T{ ##copy
- { dst V int-regs 689482 }
- { src V int-regs 689474 }
- }
- T{ ##copy
- { dst V int-regs 689483 }
- { src V int-regs 689473 }
- }
- T{ ##branch }
- }
- }
-} 2 set
+V{
+ T{ ##copy
+ { dst V int-regs 689481 }
+ { src V int-regs 689475 }
+ }
+ T{ ##copy
+ { dst V int-regs 689482 }
+ { src V int-regs 689474 }
+ }
+ T{ ##copy
+ { dst V int-regs 689483 }
+ { src V int-regs 689473 }
+ }
+ T{ ##branch }
+} 2 test-bb
-T{ basic-block
- { id 201489 }
- { number 3 }
- { instructions
- V{
- T{ ##copy
- { dst V int-regs 689481 }
- { src V int-regs 689473 }
- }
- T{ ##copy
- { dst V int-regs 689482 }
- { src V int-regs 689475 }
- }
- T{ ##copy
- { dst V int-regs 689483 }
- { src V int-regs 689474 }
- }
- T{ ##branch }
- }
- }
-} 3 set
+V{
+ T{ ##copy
+ { dst V int-regs 689481 }
+ { src V int-regs 689473 }
+ }
+ T{ ##copy
+ { dst V int-regs 689482 }
+ { src V int-regs 689475 }
+ }
+ T{ ##copy
+ { dst V int-regs 689483 }
+ { src V int-regs 689474 }
+ }
+ T{ ##branch }
+} 3 test-bb
-T{ basic-block
- { id 201490 }
- { number 4 }
- { instructions
- V{
- T{ ##replace
- { src V int-regs 689481 }
- { loc D 0 }
- }
- T{ ##replace
- { src V int-regs 689482 }
- { loc D 1 }
- }
- T{ ##replace
- { src V int-regs 689483 }
- { loc D 2 }
- }
- T{ ##epilogue }
- T{ ##return }
- }
- }
-} 4 set
-
-: test-diamond ( -- )
- 1 get 1vector 0 get (>>successors)
- 2 get 3 get V{ } 2sequence 1 get (>>successors)
- 4 get 1vector 2 get (>>successors)
- 4 get 1vector 3 get (>>successors) ;
+V{
+ T{ ##replace
+ { src V int-regs 689481 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 689482 }
+ { loc D 1 }
+ }
+ T{ ##replace
+ { src V int-regs 689483 }
+ { loc D 2 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! Similar to the above
! [ swap dup [ rot ] when ]
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
-T{ basic-block
- { id 201538 }
- { number 1 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 689600 }
- { loc D 1 }
- }
- T{ ##peek
- { dst V int-regs 689601 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 V int-regs 689600 }
- { src2 5 }
- { cc cc/= }
- }
- }
- }
-} 1 set
+V{
+ T{ ##peek
+ { dst V int-regs 689600 }
+ { loc D 1 }
+ }
+ T{ ##peek
+ { dst V int-regs 689601 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 689600 }
+ { src2 5 }
+ { cc cc/= }
+ }
+} 1 test-bb
-T{ basic-block
- { id 201539 }
- { number 2 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 689604 }
- { loc D 2 }
- }
- T{ ##copy
- { dst V int-regs 689607 }
- { src V int-regs 689604 }
- }
- T{ ##copy
- { dst V int-regs 689608 }
- { src V int-regs 689600 }
- }
- T{ ##copy
- { dst V int-regs 689610 }
- { src V int-regs 689601 }
- }
- T{ ##branch }
- }
- }
-} 2 set
+V{
+ T{ ##peek
+ { dst V int-regs 689604 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 689607 }
+ { src V int-regs 689604 }
+ }
+ T{ ##copy
+ { dst V int-regs 689608 }
+ { src V int-regs 689600 }
+ }
+ T{ ##copy
+ { dst V int-regs 689610 }
+ { src V int-regs 689601 }
+ }
+ T{ ##branch }
+} 2 test-bb
-T{ basic-block
- { id 201540 }
- { number 3 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 689609 }
- { loc D 2 }
- }
- T{ ##copy
- { dst V int-regs 689607 }
- { src V int-regs 689600 }
- }
- T{ ##copy
- { dst V int-regs 689608 }
- { src V int-regs 689601 }
- }
- T{ ##copy
- { dst V int-regs 689610 }
- { src V int-regs 689609 }
- }
- T{ ##branch }
- }
- }
-} 3 set
+V{
+ T{ ##peek
+ { dst V int-regs 689609 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 689607 }
+ { src V int-regs 689600 }
+ }
+ T{ ##copy
+ { dst V int-regs 689608 }
+ { src V int-regs 689601 }
+ }
+ T{ ##copy
+ { dst V int-regs 689610 }
+ { src V int-regs 689609 }
+ }
+ T{ ##branch }
+} 3 test-bb
-T{ basic-block
- { id 201541 }
- { number 4 }
- { instructions
- V{
- T{ ##replace
- { src V int-regs 689607 }
- { loc D 0 }
- }
- T{ ##replace
- { src V int-regs 689608 }
- { loc D 1 }
- }
- T{ ##replace
- { src V int-regs 689610 }
- { loc D 2 }
- }
- T{ ##epilogue }
- T{ ##return }
- }
- }
-} 4 set
+V{
+ T{ ##replace
+ { src V int-regs 689607 }
+ { loc D 0 }
+ }
+ T{ ##replace
+ { src V int-regs 689608 }
+ { loc D 1 }
+ }
+ T{ ##replace
+ { src V int-regs 689610 }
+ { loc D 2 }
+ }
+ T{ ##epilogue }
+ T{ ##return }
+} 4 test-bb
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! compute-live-registers was inaccurate since it didn't take
! lifetime holes into account
-T{ basic-block
- { id 0 }
- { number 0 }
- { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-T{ basic-block
- { id 1 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 0 }
- { loc D 0 }
- }
- T{ ##compare-imm-branch
- { src1 V int-regs 0 }
- { src2 5 }
- { cc cc/= }
- }
- }
- }
-} 1 set
+V{
+ T{ ##peek
+ { dst V int-regs 0 }
+ { loc D 0 }
+ }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 0 }
+ { src2 5 }
+ { cc cc/= }
+ }
+} 1 test-bb
-T{ basic-block
- { id 2 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 1 }
- { loc D 1 }
- }
- T{ ##copy
- { dst V int-regs 2 }
- { src V int-regs 1 }
- }
- T{ ##branch }
- }
- }
-} 2 set
+V{
+ T{ ##peek
+ { dst V int-regs 1 }
+ { loc D 1 }
+ }
+ T{ ##copy
+ { dst V int-regs 2 }
+ { src V int-regs 1 }
+ }
+ T{ ##branch }
+} 2 test-bb
-T{ basic-block
- { id 3 }
- { instructions
- V{
- T{ ##peek
- { dst V int-regs 3 }
- { loc D 2 }
- }
- T{ ##copy
- { dst V int-regs 2 }
- { src V int-regs 3 }
- }
- T{ ##branch }
- }
- }
-} 3 set
+V{
+ T{ ##peek
+ { dst V int-regs 3 }
+ { loc D 2 }
+ }
+ T{ ##copy
+ { dst V int-regs 2 }
+ { src V int-regs 3 }
+ }
+ T{ ##branch }
+} 3 test-bb
-T{ basic-block
- { id 4 }
- { instructions
- V{
- T{ ##replace
- { src V int-regs 2 }
- { loc D 0 }
- }
- T{ ##return }
- }
- }
-} 4 set
+V{
+ T{ ##replace
+ { src V int-regs 2 }
+ { loc D 0 }
+ }
+ T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
+
+! 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 3 4 } test-linear-scan-on-cfg
\ No newline at end of file
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+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 ] unit-test
+
+[ _spill ] [ 2 get instructions>> first class ] unit-test
+
+[ _spill ] [ 3 get instructions>> second class ] unit-test
+
+[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
+
+[ _reload ] [ 4 get instructions>> first class ] unit-test
+
+! Resolve pass
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##replace f V int-regs 1 D 0 }
+ T{ ##replace f V int-regs 2 D 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 4 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 5 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 6 test-bb
+
+0 get 1 get V{ } 1sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get V{ } 1sequence >>successors drop
+3 get 4 get V{ } 1sequence >>successors drop
+4 get 5 get 6 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
+
+! A more complicated failure case with resolve that came up after the above
+! got fixed
+V{ T{ ##branch } } 0 test-bb
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 4 D 0 }
+ T{ ##branch }
+} 1 test-bb
+V{ T{ ##branch } } 2 test-bb
+V{ T{ ##branch } } 3 test-bb
+V{
+
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f V int-regs 4 D 4 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##branch }
+} 4 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb
+V{ T{ ##return } } 6 test-bb
+V{ T{ ##branch } } 7 test-bb
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 5 D 1 }
+ T{ ##peek f V int-regs 6 D 2 }
+ T{ ##peek f V int-regs 7 D 3 }
+ T{ ##peek f V int-regs 8 D 4 }
+ T{ ##replace f V int-regs 5 D 1 }
+ T{ ##replace f V int-regs 6 D 2 }
+ T{ ##replace f V int-regs 7 D 3 }
+ T{ ##replace f V int-regs 8 D 4 }
+ T{ ##branch }
+} 8 test-bb
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##return }
+} 9 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 7 get V{ } 2sequence >>successors drop
+7 get 8 get 1vector >>successors drop
+8 get 9 get 1vector >>successors drop
+2 get 3 get 5 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 9 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
+
+[ _spill ] [ 1 get instructions>> second class ] unit-test
+[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
+
+! Resolve pass should insert this
+[ _reload ] [ 5 get instructions>> first class ] unit-test
+
+! Some random bug
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 0 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 0 D 3 }
+ T{ ##branch }
+} 2 test-bb
+
+V{ T{ ##branch } } 3 test-bb
+
+V{
+ T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+! Spilling an interval immediately after its activated;
+! and the interval does not have a use at the activation point
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{ T{ ##branch } } 4 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 5 test-bb
+
+1 get 1vector 0 get (>>successors)
+2 get 4 get V{ } 2sequence 1 get (>>successors)
+5 get 1vector 4 get (>>successors)
+3 get 1vector 2 get (>>successors)
+5 get 1vector 3 get (>>successors)
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+! Reduction of push-all regression, x86-32
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##load-immediate { dst V int-regs 61 } }
+ T{ ##peek { dst V int-regs 62 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 64 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 69 }
+ { obj V int-regs 64 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } }
+ T{ ##slot-imm
+ { dst V int-regs 85 }
+ { obj V int-regs 62 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 69 }
+ { src2 V int-regs 85 }
+ { cc cc> }
+ }
+} 1 test-bb
+
+V{
+ T{ ##slot-imm
+ { dst V int-regs 97 }
+ { obj V int-regs 62 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##replace { src V int-regs 79 } { loc D 3 } }
+ T{ ##replace { src V int-regs 62 } { loc D 4 } }
+ T{ ##replace { src V int-regs 79 } { loc D 1 } }
+ T{ ##replace { src V int-regs 62 } { loc D 2 } }
+ T{ ##replace { src V int-regs 61 } { loc D 5 } }
+ T{ ##replace { src V int-regs 62 } { loc R 0 } }
+ T{ ##replace { src V int-regs 69 } { loc R 1 } }
+ T{ ##replace { src V int-regs 97 } { loc D 0 } }
+ T{ ##call { word resize-array } }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 98 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 100 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 100 }
+ { obj V int-regs 98 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 108 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 110 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 112 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 114 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 116 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 119 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } }
+ T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } }
+ T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } }
+ T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } }
+ T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } }
+ T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } }
+ T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##replace { src V int-regs 120 } { loc D 0 } }
+ T{ ##replace { src V int-regs 109 } { loc D 3 } }
+ T{ ##replace { src V int-regs 111 } { loc D 4 } }
+ T{ ##replace { src V int-regs 113 } { loc D 1 } }
+ T{ ##replace { src V int-regs 115 } { loc D 2 } }
+ T{ ##replace { src V int-regs 117 } { loc D 5 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 5 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 4 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+3 get 5 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Another reduction of push-all
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 85 } { loc D 0 } }
+ T{ ##slot-imm
+ { dst V int-regs 89 }
+ { obj V int-regs 85 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 91 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 96 }
+ { obj V int-regs 91 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##add
+ { dst V int-regs 109 }
+ { src1 V int-regs 89 }
+ { src2 V int-regs 96 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 115 }
+ { obj V int-regs 85 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 118 }
+ { obj V int-regs 115 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 109 }
+ { src2 V int-regs 118 }
+ { cc cc> }
+ }
+} 1 test-bb
+
+V{
+ T{ ##add-imm
+ { dst V int-regs 128 }
+ { src1 V int-regs 109 }
+ { src2 8 }
+ }
+ T{ ##load-immediate { dst V int-regs 129 } { val 24 } }
+ T{ ##inc-d { n 4 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 109 } { loc D 2 } }
+ T{ ##replace { src V int-regs 85 } { loc D 3 } }
+ T{ ##replace { src V int-regs 128 } { loc D 0 } }
+ T{ ##replace { src V int-regs 85 } { loc D 1 } }
+ T{ ##replace { src V int-regs 89 } { loc D 4 } }
+ T{ ##replace { src V int-regs 96 } { loc R 0 } }
+ T{ ##fixnum-mul
+ { src1 V int-regs 128 }
+ { src2 V int-regs 129 }
+ { temp1 V int-regs 132 }
+ { temp2 V int-regs 133 }
+ }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 134 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 140 }
+ { obj V int-regs 134 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 140 } { loc D 0 } }
+ T{ ##replace { src V int-regs 134 } { loc R 0 } }
+ T{ ##call { word resize-array } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 141 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 143 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 143 }
+ { obj V int-regs 141 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##write-barrier
+ { src V int-regs 141 }
+ { card# V int-regs 145 }
+ { table V int-regs 146 }
+ }
+ T{ ##inc-d { n -1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##peek { dst V int-regs 156 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 158 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 160 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 162 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 164 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 167 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } }
+ T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } }
+ T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } }
+ T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } }
+ T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } }
+ T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##inc-d { n 3 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } }
+ T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } }
+ T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } }
+ T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } }
+ T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } }
+ T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } }
+ T{ ##branch }
+} 5 test-bb
+
+V{
+ T{ ##set-slot-imm
+ { src V int-regs 163 }
+ { obj V int-regs 161 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##replace { src V int-regs 168 } { loc D 0 } }
+ T{ ##replace { src V int-regs 157 } { loc D 3 } }
+ T{ ##replace { src V int-regs 159 } { loc D 4 } }
+ T{ ##replace { src V int-regs 161 } { loc D 1 } }
+ T{ ##replace { src V int-regs 163 } { loc D 2 } }
+ T{ ##replace { src V int-regs 165 } { loc D 5 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 6 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 5 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Another push-all reduction to demonstrate numbering anamoly
+V{ T{ ##prologue } T{ ##branch } }
+0 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 1 } { loc D 0 } }
+ T{ ##slot-imm
+ { dst V int-regs 5 }
+ { obj V int-regs 1 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 7 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 12 }
+ { obj V int-regs 7 }
+ { slot 1 }
+ { tag 6 }
+ }
+ T{ ##add
+ { dst V int-regs 25 }
+ { src1 V int-regs 5 }
+ { src2 V int-regs 12 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 25 }
+ { src2 V int-regs 5 }
+ { cc cc> }
+ }
+}
+1 test-bb
+
+V{
+ T{ ##slot-imm
+ { dst V int-regs 41 }
+ { obj V int-regs 1 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 44 }
+ { obj V int-regs 41 }
+ { slot 1 }
+ { tag 6 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 25 }
+ { src2 V int-regs 44 }
+ { cc cc> }
+ }
+}
+2 test-bb
+
+V{
+ T{ ##add-imm
+ { dst V int-regs 54 }
+ { src1 V int-regs 25 }
+ { src2 8 }
+ }
+ T{ ##load-immediate { dst V int-regs 55 } { val 24 } }
+ T{ ##inc-d { n 4 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 25 } { loc D 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 3 } }
+ T{ ##replace { src V int-regs 5 } { loc D 4 } }
+ T{ ##replace { src V int-regs 1 } { loc D 1 } }
+ T{ ##replace { src V int-regs 54 } { loc D 0 } }
+ T{ ##replace { src V int-regs 12 } { loc R 0 } }
+ T{ ##fixnum-mul
+ { src1 V int-regs 54 }
+ { src2 V int-regs 55 }
+ { temp1 V int-regs 58 }
+ { temp2 V int-regs 59 }
+ }
+ T{ ##branch }
+}
+3 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 60 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 66 }
+ { obj V int-regs 60 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 66 } { loc D 0 } }
+ T{ ##replace { src V int-regs 60 } { loc R 0 } }
+ T{ ##call { word resize-string } }
+ T{ ##branch }
+}
+4 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 67 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 68 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 68 }
+ { obj V int-regs 67 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##write-barrier
+ { src V int-regs 67 }
+ { card# V int-regs 75 }
+ { table V int-regs 76 }
+ }
+ T{ ##inc-d { n -1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##peek { dst V int-regs 94 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 96 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 98 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 100 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 102 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 106 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } }
+ T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } }
+ T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } }
+ T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } }
+ T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } }
+ T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } }
+ T{ ##branch }
+}
+5 test-bb
+
+V{
+ T{ ##inc-d { n 3 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } }
+ T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } }
+ T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } }
+ T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } }
+ T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } }
+ T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } }
+ T{ ##branch }
+}
+6 test-bb
+
+V{
+ T{ ##load-immediate
+ { dst V int-regs 78 }
+ { val 4611686018427387896 }
+ }
+ T{ ##and
+ { dst V int-regs 81 }
+ { src1 V int-regs 97 }
+ { src2 V int-regs 78 }
+ }
+ T{ ##set-slot-imm
+ { src V int-regs 81 }
+ { obj V int-regs 95 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n -2 } }
+ T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } }
+ T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } }
+ T{ ##branch }
+}
+7 test-bb
+
+V{
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } }
+ T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } }
+ T{ ##branch }
+}
+8 test-bb
+
+V{
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##replace { src V int-regs 117 } { loc D 0 } }
+ T{ ##replace { src V int-regs 110 } { loc D 1 } }
+ T{ ##replace { src V int-regs 111 } { loc D 2 } }
+ T{ ##replace { src V int-regs 112 } { loc D 3 } }
+ T{ ##epilogue }
+ T{ ##return }
+}
+9 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 8 get V{ } 2sequence >>successors drop
+2 get 3 get 6 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+5 get 7 get 1vector >>successors drop
+6 get 7 get 1vector >>successors drop
+7 get 9 get 1vector >>successors drop
+8 get 9 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces make
+USING: kernel accessors namespaces make locals
cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
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
! References:
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
-: (linear-scan) ( rpo machine-registers -- )
- [
- dup number-instructions
- dup compute-live-intervals
- ] dip
- allocate-registers assign-registers ;
+:: (linear-scan) ( rpo machine-registers -- )
+ rpo number-instructions
+ rpo compute-live-intervals machine-registers allocate-registers
+ rpo assign-registers
+ rpo resolve-data-flow
+ rpo check-numbering ;
: linear-scan ( cfg -- cfg' )
[
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
-binary-search combinators compiler.cfg.instructions compiler.cfg.registers
+combinators compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
V{ } clone >>ranges
swap >>vreg ;
-: block-from ( bb -- n ) instructions>> first insn#>> ;
+: block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
live-intervals set
<reversed> [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
+
+: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
+ [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+ 2dup [ from>> ] bi@ > [ swap ] when
+ 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+ {
+ { [ over empty? ] [ 2drop f ] }
+ { [ dup empty? ] [ 2drop f ] }
+ [
+ 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+ drop
+ 2dup [ first from>> ] bi@ <
+ [ [ rest-slice ] dip ] [ rest-slice ] if
+ intersect-live-ranges
+ ] if
+ ]
+ } cond ;
+
+: intervals-intersect? ( interval1 interval2 -- ? )
+ relevant-ranges intersect-live-ranges >boolean ; inline
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math sequences ;
+USING: kernel accessors math sequences grouping namespaces ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
- ] each drop ;
\ No newline at end of file
+ ] each drop ;
+
+SYMBOL: check-numbering?
+
+ERROR: bad-numbering bb ;
+
+: check-block-numbering ( bb -- )
+ dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
+ [ drop ] [ bad-numbering ] if ;
+
+: check-numbering ( rpo -- )
+ check-numbering? get [ [ check-block-numbering ] each ] [ drop ] if ;
\ No newline at end of file
--- /dev/null
+USING: accessors arrays classes compiler.cfg
+compiler.cfg.debugger compiler.cfg.instructions
+compiler.cfg.linear-scan.debugger
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.numbering
+compiler.cfg.linear-scan.allocation.state
+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
+
+H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+H{ } clone spill-temps set
+
+[
+ {
+ T{ _copy { dst 5 } { src 4 } { class int-regs } }
+ T{ _spill { src 1 } { class int-regs } { n 10 } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ T{ _spill { src 1 } { class float-regs } { n 20 } }
+ T{ _copy { dst 1 } { src 0 } { class float-regs } }
+ T{ _reload { dst 0 } { class float-regs } { n 20 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
+ T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
+ T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _spill { src 2 } { class int-regs } { n 10 } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _spill { src 0 } { class int-regs } { n 10 } }
+ T{ _copy { dst 0 } { src 2 } { class int-regs } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ { }
+] [
+ {
+ T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _spill { src 3 } { class int-regs } { n 4 } }
+ T{ _reload { dst 2 } { class int-regs } { n 1 } }
+ }
+] [
+ {
+ T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
+ T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+
+[
+ {
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _spill { src 4 } { class int-regs } { n 10 } }
+ T{ _copy { dst 4 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ T{ _reload { dst 3 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _copy { dst 9 } { src 1 } { class int-regs } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _spill { src 4 } { class int-regs } { n 10 } }
+ T{ _copy { dst 4 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ T{ _reload { dst 3 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sequences
-compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ;
+USING: accessors arrays assocs classes.parser classes.tuple
+combinators combinators.short-circuit fry hashtables kernel locals
+make math math.order namespaces sequences sets words parser
+compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve
-: add-mapping ( from to -- )
- 2drop
- ;
+SYMBOL: spill-temps
-: resolve-value-data-flow ( bb to vreg -- )
- live-intervals get at
- [ [ block-to ] dip child-interval-at ]
- [ [ block-from ] dip child-interval-at ]
- bi-curry bi* 2dup = [ 2drop ] [
- add-mapping
+: spill-temp ( reg-class -- n )
+ spill-temps get [ next-spill-slot ] cache ;
+
+<<
+
+TUPLE: operation from to reg-class ;
+
+SYNTAX: OPERATION:
+ CREATE-CLASS dup save-location
+ [ operation { } define-tuple-class ]
+ [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
+
+>>
+
+OPERATION: register->memory
+OPERATION: memory->register
+OPERATION: register->register
+
+! This should never come up because of how spill slots are assigned,
+! so make it an error.
+: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
+
+: add-mapping ( from to reg-class -- )
+ over spill-slot? [
+ pick spill-slot?
+ [ memory->memory ]
+ [ register->memory ] if
+ ] [
+ pick spill-slot?
+ [ memory->register ]
+ [ register->register ] if
+ ] if ;
+
+:: resolve-value-data-flow ( bb to vreg -- )
+ vreg bb vreg-at-end
+ vreg to vreg-at-start
+ 2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
+
+: compute-mappings ( bb to -- mappings )
+ [
+ dup live-in keys
+ [ resolve-value-data-flow ] with with each
+ ] { } make ;
+
+GENERIC: >insn ( operation -- )
+
+M: register->memory >insn
+ [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
+
+M: memory->register >insn
+ [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
+
+M: register->register >insn
+ [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
+
+SYMBOL: froms
+SYMBOL: tos
+
+SINGLETONS: memory register ;
+
+: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
+
+: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
+
+: from-reg ( operation -- seq )
+ [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+
+: to-reg ( operation -- seq )
+ [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+
+: start? ( operations -- pair )
+ from-reg tos get key? not ;
+
+: independent-assignment? ( operations -- pair )
+ to-reg froms get key? not ;
+
+: set-tos/froms ( operations -- )
+ [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
+ [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
+ bi ;
+
+:: (trace-chain) ( obj hashtable -- )
+ obj to-reg froms get at* [
+ dup ,
+ obj over hashtable clone [ maybe-set-at ] keep swap
+ [ (trace-chain) ] [ 2drop ] if
+ ] [
+ drop
] if ;
-: resolve-mappings ( bb to -- )
- 2drop
- ;
+: trace-chain ( obj -- seq )
+ [
+ dup ,
+ dup dup associate (trace-chain)
+ ] { } make prune reverse ;
+
+: trace-chains ( seq -- seq' )
+ [ trace-chain ] map concat ;
+
+ERROR: resolve-error ;
+
+: split-cycle ( operations -- chain spilled-operation )
+ unclip [
+ [ set-tos/froms ]
+ [
+ [ start? ] find nip
+ [ resolve-error ] unless* trace-chain
+ ] bi
+ ] dip ;
+
+: break-cycle-n ( operations -- operations' )
+ split-cycle [
+ [ from>> ]
+ [ reg-class>> spill-temp <spill-slot> ]
+ [ reg-class>> ]
+ tri \ register->memory boa
+ ] [
+ [ reg-class>> spill-temp <spill-slot> ]
+ [ to>> ]
+ [ reg-class>> ]
+ tri \ memory->register boa
+ ] bi [ 1array ] bi@ surround ;
+
+: break-cycle ( operations -- operations' )
+ dup length {
+ { 1 [ ] }
+ [ drop break-cycle-n ]
+ } case ;
+
+: (group-cycles) ( seq -- )
+ [
+ dup set-tos/froms
+ unclip trace-chain
+ [ diff ] keep , (group-cycles)
+ ] unless-empty ;
+
+: group-cycles ( seq -- seqs )
+ [ (group-cycles) ] { } make ;
+
+: remove-dead-mappings ( seq -- seq' )
+ prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
+
+: parallel-mappings ( operations -- seq )
+ [
+ [ independent-assignment? not ] partition %
+ [ start? not ] partition
+ [ trace-chain ] map concat dup %
+ diff group-cycles [ break-cycle ] map concat %
+ ] { } make remove-dead-mappings ;
+
+: mapping-instructions ( mappings -- insns )
+ [
+ [ set-tos/froms ] [ parallel-mappings ] bi
+ [ [ >insn ] each ] { } make
+ ] with-scope ;
+
+: fork? ( from to -- ? )
+ {
+ [ drop successors>> length 1 >= ]
+ [ nip predecessors>> length 1 = ]
+ } 2&& ; inline
+
+: insert-position/fork ( from to -- before after )
+ nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
+
+: join? ( from to -- ? )
+ {
+ [ drop successors>> length 1 = ]
+ [ nip predecessors>> length 1 >= ]
+ } 2&& ; 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 ;
: resolve-edge-data-flow ( bb to -- )
- [ 2dup live-in [ resolve-value-data-flow ] with with each ]
- [ resolve-mappings ]
- 2bi ;
+ [ compute-mappings ] [ perform-mappings ] 2bi ;
: resolve-block-data-flow ( bb -- )
- dup successors>> [
- resolve-edge-data-flow
- ] with each ;
+ dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- )
- [ resolve-block-data-flow ] each ;
\ No newline at end of file
+ H{ } clone spill-temps set
+ [ resolve-block-data-flow ] each ;
#! don't need to branch.
[ number>> ] bi@ 1 - = ; inline
-: branch-to-branch? ( successor -- ? )
- #! A branch to a block containing just a jump return is cloned.
- instructions>> dup length 2 = [
- [ first ##epilogue? ]
- [ second [ ##return? ] [ ##jump? ] bi or ] bi and
- ] [ drop f ] if ;
-
: emit-branch ( basic-block successor -- )
- {
- { [ 2dup useless-branch? ] [ 2drop ] }
- { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
- [ nip number>> _branch ]
- } cond ;
+ 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
[ successors>> [ number>> _dispatch-label ] each ]
bi* ;
-: gc-root-registers ( n live-registers -- n )
- [
- [ second 2array , ]
- [ first reg-class>> reg-size + ]
- 2bi
- ] each ;
-
-: gc-root-spill-slots ( n live-spill-slots -- n )
+: (compute-gc-roots) ( n live-values -- n )
[
- dup first reg-class>> int-regs eq? [
- [ second <spill-slot> 2array , ]
- [ first reg-class>> reg-size + ]
- 2bi
- ] [ drop ] if
- ] each ;
+ [ nip 2array , ]
+ [ drop reg-class>> reg-size + ]
+ 3bi
+ ] assoc-each ;
-: oop-registers ( regs -- regs' )
- [ first reg-class>> int-regs eq? ] filter ;
+: oop-values ( regs -- regs' )
+ [ drop reg-class>> int-regs eq? ] assoc-filter ;
-: data-registers ( regs -- regs' )
- [ first reg-class>> double-float-regs eq? ] filter ;
+: data-values ( regs -- regs' )
+ [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
-:: compute-gc-roots ( live-registers live-spill-slots -- alist )
+: compute-gc-roots ( live-values -- alist )
[
- 0
+ [ 0 ] dip
! we put float registers last; the GC doesn't actually scan them
- live-registers oop-registers gc-root-registers
- live-spill-slots gc-root-spill-slots
- live-registers data-registers gc-root-registers
+ [ oop-values (compute-gc-roots) ]
+ [ data-values (compute-gc-roots) ] bi
drop
] { } make ;
-: count-gc-roots ( live-registers live-spill-slots -- n )
+: count-gc-roots ( live-values -- n )
! Size of GC root area, minus the float registers
- [ oop-registers length ] bi@ + ;
+ oop-values assoc-size ;
M: ##gc linearize-insn
nip
[ temp1>> ]
[ temp2>> ]
[
- [ live-registers>> ] [ live-spill-slots>> ] bi
+ live-values>>
[ compute-gc-roots ]
[ count-gc-roots ]
[ gc-roots-size ]
- 2tri
+ tri
] tri
_gc
] with-regs ;
--- /dev/null
+USING: compiler.cfg compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.liveness accessors tools.test cpu.architecture ;
+IN: compiler.cfg.liveness.tests
+
+[
+ H{
+ { "A" H{ { V int-regs 1 V int-regs 1 } { V int-regs 4 V int-regs 4 } } }
+ { "B" H{ { V int-regs 3 V int-regs 3 } { V int-regs 2 V int-regs 2 } } }
+ }
+] [
+ <basic-block> V{
+ T{ ##phi f V int-regs 0 { { "A" V int-regs 1 } { "B" V int-regs 2 } } }
+ T{ ##phi f V int-regs 1 { { "B" V int-regs 3 } { "A" V int-regs 4 } } }
+ } >>instructions compute-phi-live-in
+] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
-dlists compiler.cfg.def-use compiler.cfg.instructions
+hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo ;
IN: compiler.cfg.liveness
! is in conrrespondence with a predecessor
SYMBOL: phi-live-ins
-: phi-live-in ( predecessor basic-block -- set )
- [ predecessors>> index ] keep phi-live-ins get at
- dup [ nth ] [ 2drop f ] if ;
+: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
! Assoc mapping basic blocks to sets of vregs
SYMBOL: live-outs
[ nip kill-set ]
2bi assoc-diff ;
+: conjoin-at ( value key assoc -- )
+ [ dupd ?set-at ] change-at ;
+
: compute-phi-live-in ( basic-block -- phi-live-in )
- instructions>> [ ##phi? ] filter
- [ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ;
+ instructions>> [ ##phi? ] filter [ f ] [
+ H{ } clone [
+ '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
+ ] keep
+ ] if-empty ;
: update-live-in ( basic-block -- changed? )
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
-USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
-sequences.private math sbufs math.private slots.private strings ;
+USING: accessors arrays compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.def-use
+compiler.cfg.instructions fry kernel kernel.private math
+math.private sbufs sequences sequences.private sets
+slots.private strings tools.test vectors ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
} [
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each
+
+[ t ]
+[
+ [
+ HEX: 7fff fixnum-bitand 13 fixnum-shift-fast
+ 112 23 fixnum-shift-fast fixnum+fast
+ ] test-mr first instructions>> [ ##add? ] any?
+] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
+compiler.cfg.tco
compiler.cfg.predecessors
-compiler.cfg.useless-blocks
-compiler.cfg.height
+compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
+compiler.cfg.branch-splitting
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
+compiler.cfg.branch-folding
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
] when ;
: optimize-cfg ( cfg -- cfg' )
+ ! Note that compute-predecessors has to be called several times.
+ ! The passes that need this document it.
[
+ optimize-tail-calls
compute-predecessors
- delete-useless-blocks
delete-useless-conditionals
- normalize-height
+ split-branches
+ compute-predecessors
stack-analysis
compute-liveness
alias-analysis
value-numbering
+ fold-branches
+ compute-predecessors
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
--- /dev/null
+IN: compiler.cfg.phi-elimination.tests
+USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
+compiler.cfg.debugger compiler.cfg.phi-elimination kernel accessors
+sequences classes namespaces tools.test cpu.architecture arrays ;
+
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 { } }
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ 2 ] [ 4 get instructions>> length ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo fry kernel sequences ;
+USING: accessors assocs fry kernel sequences
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.phi-elimination
: insert-copy ( predecessor input output -- )
'[ _ _ swap ##copy ] add-instructions ;
-: eliminate-phi ( bb ##phi -- )
- [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
- '[ _ insert-copy ] 2each ;
+: eliminate-phi ( ##phi -- )
+ [ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
: eliminate-phi-step ( bb -- )
- dup [
- [ ##phi? ] partition
- [ [ eliminate-phi ] with each ] dip
- ] change-instructions drop ;
+ instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
: eliminate-phis ( cfg -- cfg' )
dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences compiler.cfg.rpo ;
+USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
+compiler.cfg.instructions ;
IN: compiler.cfg.predecessors
-: predecessors-step ( bb -- )
+: update-predecessors ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
+: update-phi ( bb ##phi -- )
+ [
+ swap predecessors>>
+ '[ drop _ memq? ] assoc-filter
+ ] change-inputs drop ;
+
+: update-phis ( bb -- )
+ dup instructions>> [
+ dup ##phi? [ update-phi ] [ 2drop ] if
+ ] with each ;
+
: compute-predecessors ( cfg -- cfg' )
- [ [ V{ } clone >>predecessors drop ] each-basic-block ]
- [ [ predecessors-step ] each-basic-block ]
- [ ]
- tri ;
+ {
+ [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+ [ [ update-predecessors ] each-basic-block ]
+ [ [ update-phis ] each-basic-block ]
+ [ ]
+ } cleave ;
SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
-! Stack locations
+! Stack locations -- 'n' is an index starting from the top of the stack
+! going down. So 0 is the top of the stack, 1 is what would be the top
+! of the stack after a 'drop', and so on.
+
+! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
+! an ##inc-d 1 becomes D 1 after ##inc-d 1.
TUPLE: loc { n read-only } ;
TUPLE: ds-loc < loc ;
--- /dev/null
+IN: compiler.cfg.stack-analysis.merge.tests
+USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
+compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg compiler.cfg.registers compiler.cfg.debugger
+cpu.architecture make assocs
+sequences kernel classes ;
+
+[
+ { D 0 }
+ { V int-regs 0 V int-regs 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ [ merge-locs locs>vregs>> keys ] { } make first inputs>> values
+] unit-test
+
+[
+ { D 0 }
+ ##peek
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state>
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ [ merge-locs locs>vregs>> keys ] { } make drop
+ ] keep first instructions>> first class
+] unit-test
+
+[
+ 0 ##inc-d
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state> -1 >>ds-height
+ <state> 2array
+
+ [ merge-ds-heights ds-height>> ] { } make drop
+ ] keep first instructions>> first class
+] unit-test
+
+[
+ 0
+ { D 0 }
+ { 1 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
+ ] keep
+ [ instructions>> length ] map
+] unit-test
+
+[
+ -1
+ { D -1 }
+ { 1 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
+ <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
+
+ [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
+ [ ds-height>> ] [ locs>vregs>> keys ] bi
+ ] keep
+ [ instructions>> length ] map
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs sequences accessors fry combinators grouping
+sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.stack-analysis.state ;
+IN: compiler.cfg.stack-analysis.merge
+
+! XXX critical edges
+
+: initial-state ( bb states -- state ) 2drop <state> ;
+
+: single-predecessor ( bb states -- state ) nip first clone ;
+
+: save-ds-height ( n -- )
+ dup 0 = [ drop ] [ ##inc-d ] if ;
+
+: merge-ds-heights ( state predecessors states -- state )
+ [ ds-height>> ] map dup all-equal?
+ [ nip first >>ds-height ]
+ [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
+
+: save-rs-height ( n -- )
+ dup 0 = [ drop ] [ ##inc-r ] if ;
+
+: merge-rs-heights ( state predecessors states -- state )
+ [ rs-height>> ] map dup all-equal?
+ [ nip first >>rs-height ]
+ [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
+
+: assoc-map-values ( assoc quot -- assoc' )
+ '[ _ dip ] assoc-map ; inline
+
+: translate-locs ( assoc state -- assoc' )
+ '[ _ translate-loc ] assoc-map-values ;
+
+: untranslate-locs ( assoc state -- assoc' )
+ '[ _ untranslate-loc ] assoc-map-values ;
+
+: collect-locs ( loc-maps states -- assoc )
+ ! assoc maps locs to sequences
+ [ untranslate-locs ] 2map
+ [ [ keys ] map concat prune ] keep
+ '[ dup _ [ at ] with map ] H{ } map>assoc ;
+
+: insert-peek ( predecessor loc state -- vreg )
+ '[ _ _ translate-loc ^^peek ] add-instructions ;
+
+: merge-loc ( predecessors vregs loc state -- vreg )
+ ! Insert a ##phi in the current block where the input
+ ! is the vreg storing loc from each predecessor block
+ [ dup ] 3dip
+ '[ [ ] [ _ _ insert-peek ] ?if ] 2map
+ dup all-equal? [ nip first ] [ zip ^^phi ] if ;
+
+:: merge-locs ( state predecessors states -- state )
+ states [ locs>vregs>> ] map states collect-locs
+ [| key value |
+ key
+ predecessors value key state merge-loc
+ ] assoc-map
+ state translate-locs
+ state (>>locs>vregs)
+ state ;
+
+: merge-actual-loc ( vregs -- vreg/f )
+ dup all-equal? [ first ] [ drop f ] if ;
+
+:: merge-actual-locs ( state states -- state )
+ states [ actual-locs>vregs>> ] map states collect-locs
+ [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
+ state translate-locs
+ state (>>actual-locs>vregs)
+ state ;
+
+: merge-changed-locs ( state states -- state )
+ [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
+ over translate-locs
+ >>changed-locs ;
+
+ERROR: cannot-merge-poisoned states ;
+
+: multiple-predecessors ( bb states -- state )
+ dup [ not ] any? [
+ 2drop <state>
+ ] [
+ dup [ poisoned?>> ] any? [
+ cannot-merge-poisoned
+ ] [
+ [ state new ] 2dip
+ [ predecessors>> ] dip
+ {
+ [ merge-ds-heights ]
+ [ merge-rs-heights ]
+ [ merge-locs ]
+ [ nip merge-actual-locs ]
+ [ nip merge-changed-locs ]
+ } 2cleave
+ ] if
+ ] if ;
+
+: merge-states ( bb states -- state )
+ ! If any states are poisoned, save all registers
+ ! to the stack in each branch
+ dup length {
+ { 0 [ initial-state ] }
+ { 1 [ single-predecessor ] }
+ [ drop multiple-predecessors ]
+ } case ;
compiler.cfg.predecessors compiler.cfg.stack-analysis
compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
-compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
-compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
-sets namespaces ;
+compiler.cfg.checker compiler.cfg.rpo
+compiler.cfg.dce compiler.cfg.registers
+sets namespaces arrays cpu.architecture ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
-: check-for-redundant-ops ( cfg -- )
- [
- instructions>>
- [
- [ ##peek? ] filter [ loc>> ] map duplicates empty?
- [ "Redundant peeks" throw ] unless
- ] [
- [ ##replace? ] filter [ loc>> ] map duplicates empty?
- [ "Redundant replaces" throw ] unless
- ] bi
- ] each-basic-block ;
-
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
compute-predecessors
- delete-useless-blocks
- delete-useless-conditionals
- normalize-height
stack-analysis
- dup check-cfg
- dup check-for-redundant-ops ;
+ dup check-cfg ;
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
-local-only? off
-
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
] unit-test
+
+! Correct height tracking
+[ t ] [
+ [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
+ reverse-post-order 3 swap nth
+ instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
+ 2array { D 1 D 0 } set=
+] unit-test
+
+[ D 1 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 2 }
+ T{ ##inc-d f -1 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get instructions>> second loc>>
+] unit-test
+
+! Do inserted ##peeks reference the correct stack location if
+! an ##inc-d/r was also inserted?
+[ D 0 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##call f \ + -1 }
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get instructions>> [ ##peek? ] find nip loc>>
+] unit-test
+
+! Missing ##replace
+[ t ] [
+ [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
+ reverse-post-order last
+ instructions>> [ ##replace? ] filter [ loc>> ] map
+ { D 0 D 1 D 2 } set=
+] unit-test
+
+! Inserted ##peeks reference the wrong stack location
+[ t ] [
+ [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
+ eliminate-dead-code reverse-post-order 3 swap nth
+ instructions>> [ ##peek? ] filter [ loc>> ] map
+ { R 0 D 0 D 1 } set=
+] unit-test
+
+[ D 0 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get instructions>> [ ##peek? ] find nip loc>>
+] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces math sequences fry grouping
-sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use
-compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
-compiler.cfg.hats compiler.cfg ;
+sets make combinators
+compiler.cfg
+compiler.cfg.copy-prop
+compiler.cfg.def-use
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.stack-analysis.state
+compiler.cfg.stack-analysis.merge ;
IN: compiler.cfg.stack-analysis
-! Convert stack operations to register operations
-
-! If 'poisoned' is set, disregard height information. This is set if we don't have
-! height change information for an instruction.
-TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
-
-: <state> ( -- state )
- state new
- H{ } clone >>locs>vregs
- H{ } clone >>actual-locs>vregs
- H{ } clone >>changed-locs
- 0 >>ds-height
- 0 >>rs-height ;
-
-M: state clone
- call-next-method
- [ clone ] change-locs>vregs
- [ clone ] change-actual-locs>vregs
- [ clone ] change-changed-locs ;
-
-: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
-
-: record-peek ( dst loc -- )
- state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
-
-: changed-loc ( loc -- )
- state get changed-locs>> conjoin ;
-
-: record-replace ( src loc -- )
- dup changed-loc state get locs>vregs>> set-at ;
-
-GENERIC: height-for ( loc -- n )
-
-M: ds-loc height-for drop state get ds-height>> ;
-M: rs-loc height-for drop state get rs-height>> ;
-
-: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
-
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
-M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
-
-GENERIC: untranslate-loc ( loc -- loc' )
-
-M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
-M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
-
: redundant-replace? ( vreg loc -- ? )
- dup untranslate-loc n>> 0 <
+ dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
- [ changed-locs>> ] [ locs>vregs>> ] bi '[
- _ at swap 2dup redundant-replace?
- [ 2drop ] [ untranslate-loc ##replace ] if
- ] assoc-each ;
-
-: clear-state ( state -- )
- [ locs>vregs>> clear-assoc ]
- [ actual-locs>vregs>> clear-assoc ]
- [ changed-locs>> clear-assoc ]
- tri ;
+ [ changed-locs>> keys ] [ locs>vregs>> ] bi '[
+ dup _ at swap 2dup redundant-replace?
+ [ 2drop ] [ state get untranslate-loc ##replace ] if
+ ] each ;
ERROR: poisoned-state state ;
: sync-state ( -- )
state get {
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+ [ ds-height>> save-ds-height ]
+ [ rs-height>> save-rs-height ]
[ save-changed-locs ]
[ clear-state ]
} cleave ;
! Abstract interpretation
GENERIC: visit ( insn -- )
+M: ##inc-d visit
+ n>> state get [ + ] change-ds-height drop ;
+
+M: ##inc-r visit
+ n>> state get [ + ] change-rs-height drop ;
+
! Instructions which don't have any effect on the stack
UNION: neutral-insn
+ ##effect
##flushable
- ##effect ;
+ ##no-tco ;
M: neutral-insn visit , ;
##dispatch
##loop-entry ;
-SYMBOL: local-only?
-
-t local-only? set-global
-
: back-edge? ( from to -- ? )
[ number>> ] bi@ > ;
: sync-state? ( -- ? )
basic-block get successors>>
- [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
- local-only? get or ;
+ [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
M: sync-if-back-edge visit
sync-state? [ sync-state ] when , ;
-: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
-
-M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
-
-: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
-
-M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
-
: eliminate-peek ( dst src -- )
! the requested stack location is already in 'src'
[ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit
- dup
- [ dst>> ] [ loc>> translate-loc ] bi
- dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+ [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
+ [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
M: ##replace visit
- [ src>> resolve ] [ loc>> translate-loc ] bi
+ [ src>> resolve ] [ loc>> state get translate-loc ] bi
record-replace ;
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
-M: ##call visit
- [ call-next-method ] [ height>> adjust-d ] bi ;
-
! Instructions that poison the stack state
UNION: poison-insn
##jump
##fixnum-add
##fixnum-sub
##alien-invoke
- ##alien-indirect ;
+ ##alien-indirect
+ ##alien-callback ;
M: kill-vreg-insn visit sync-state , ;
-: visit-alien-node ( node -- )
- params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
-
-M: ##alien-invoke visit
- [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-indirect visit
- [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-callback visit , ;
-
! Maps basic-blocks to states
SYMBOLS: state-in state-out ;
-: initial-state ( bb states -- state ) 2drop <state> ;
-
-: single-predecessor ( bb states -- state ) nip first clone ;
-
-ERROR: must-equal-failed seq ;
-
-: must-equal ( seq -- elt )
- dup all-equal? [ first ] [ must-equal-failed ] if ;
-
-: merge-heights ( state predecessors states -- state )
- nip
- [ [ ds-height>> ] map must-equal >>ds-height ]
- [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
-
-: insert-peek ( predecessor loc -- vreg )
- ! XXX critical edges
- '[ _ ^^peek ] add-instructions ;
-
-: merge-loc ( predecessors locs>vregs loc -- vreg )
- ! Insert a ##phi in the current block where the input
- ! is the vreg storing loc from each predecessor block
- [ '[ [ _ ] dip at ] map ] keep
- '[ [ ] [ _ insert-peek ] ?if ] 2map
- dup all-equal? [ first ] [ ^^phi ] if ;
-
-: (merge-locs) ( predecessors assocs -- assoc )
- dup [ keys ] map concat prune
- [ [ 2nip ] [ merge-loc ] 3bi ] with with
- H{ } map>assoc ;
-
-: merge-locs ( state predecessors states -- state )
- [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
-
-: merge-loc' ( locs>vregs loc -- vreg )
- ! Insert a ##phi in the current block where the input
- ! is the vreg storing loc from each predecessor block
- '[ [ _ ] dip at ] map
- dup all-equal? [ first ] [ drop f ] if ;
-
-: merge-actual-locs ( state predecessors states -- state )
- nip
- [ actual-locs>vregs>> ] map
- dup [ keys ] map concat prune
- [ [ nip ] [ merge-loc' ] 2bi ] with
- H{ } map>assoc
- [ nip ] assoc-filter
- >>actual-locs>vregs ;
-
-: merge-changed-locs ( state predecessors states -- state )
- nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
-
-ERROR: cannot-merge-poisoned states ;
-
-: multiple-predecessors ( bb states -- state )
- dup [ not ] any? [
- [ <state> ] 2dip
- sift merge-heights
- ] [
- dup [ poisoned?>> ] any? [
- cannot-merge-poisoned
- ] [
- [ state new ] 2dip
- [ predecessors>> ] dip
- {
- [ merge-locs ]
- [ merge-actual-locs ]
- [ merge-heights ]
- [ merge-changed-locs ]
- } 2cleave
- ] if
- ] if ;
-
-: merge-states ( bb states -- state )
- ! If any states are poisoned, save all registers
- ! to the stack in each branch
- dup length {
- { 0 [ initial-state ] }
- { 1 [ single-predecessor ] }
- [ drop multiple-predecessors ]
- } case ;
-
: block-in-state ( bb -- states )
dup predecessors>> state-out get '[ _ at ] map merge-states ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets math
+compiler.cfg.registers ;
+IN: compiler.cfg.stack-analysis.state
+
+TUPLE: state
+locs>vregs actual-locs>vregs changed-locs
+{ ds-height integer }
+{ rs-height integer }
+poisoned? ;
+
+: <state> ( -- state )
+ state new
+ H{ } clone >>locs>vregs
+ H{ } clone >>actual-locs>vregs
+ H{ } clone >>changed-locs
+ 0 >>ds-height
+ 0 >>rs-height ;
+
+M: state clone
+ call-next-method
+ [ clone ] change-locs>vregs
+ [ clone ] change-actual-locs>vregs
+ [ clone ] change-changed-locs ;
+
+: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
+
+: record-peek ( dst loc -- )
+ state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
+
+: changed-loc ( loc -- )
+ state get changed-locs>> conjoin ;
+
+: record-replace ( src loc -- )
+ dup changed-loc state get locs>vregs>> set-at ;
+
+: clear-state ( state -- )
+ 0 >>ds-height 0 >>rs-height
+ [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
+ [ clear-assoc ] tri@ ;
+
+GENERIC# translate-loc 1 ( loc state -- loc' )
+M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
+
+GENERIC# untranslate-loc 1 ( loc state -- loc' )
+M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
: gc-root-offset ( n -- n' ) gc-root-base + ;
-: gc-roots-size ( live-registers live-spill-slots -- n )
- [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
+: gc-roots-size ( live-values -- n )
+ keys [ reg-class>> reg-size ] sigma ;
: (stack-frame-size) ( stack-frame -- n )
[
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel math
+namespaces sequences fry combinators
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.instructions ;
+IN: compiler.cfg.tco
+
+! Tail call optimization. You must run compute-predecessors after this
+
+: return? ( bb -- ? )
+ skip-empty-blocks
+ instructions>> {
+ [ length 2 = ]
+ [ first ##epilogue? ]
+ [ second ##return? ]
+ } 1&& ;
+
+: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
+
+: tail-call? ( bb -- ? )
+ {
+ [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
+ [ successors>> first return? ]
+ } 1&& ;
+
+: word-tail-call? ( bb -- ? )
+ instructions>> penultimate ##call? ;
+
+: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
+ '[
+ instructions>>
+ [ pop* ] [ pop ] [ ] tri
+ [ [ \ ##epilogue new-insn ] dip push ]
+ [ _ dip push ] bi
+ ]
+ [ successors>> delete-all ]
+ bi ; inline
+
+: convert-word-tail-call ( bb -- )
+ [ word>> \ ##jump new-insn ] convert-tail-call ;
+
+: loop-tail-call? ( bb -- ? )
+ instructions>> penultimate
+ { [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ;
+
+: convert-loop-tail-call ( bb -- )
+ ! If a word calls itself, this becomes a loop in the CFG.
+ [ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ]
+ [ successors>> delete-all ]
+ [ [ cfg get entry>> successors>> first ] dip successors>> push ]
+ tri ;
+
+: fixnum-tail-call? ( bb -- ? )
+ instructions>> penultimate
+ { [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
+
+GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
+
+M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
+M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
+M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
+
+: convert-fixnum-tail-call ( bb -- )
+ [
+ [ src1>> ] [ src2>> ] [ ] tri
+ convert-fixnum-tail-call*
+ ] convert-tail-call ;
+
+: optimize-tail-call ( bb -- )
+ dup tail-call? [
+ {
+ { [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
+ { [ dup word-tail-call? ] [ convert-word-tail-call ] }
+ { [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
+ [ drop ]
+ } cond
+ ] [ drop ] if ;
+
+: optimize-tail-calls ( cfg -- cfg' )
+ dup cfg set
+ dup [ optimize-tail-call ] each-basic-block
+ f >>post-order ;
\ No newline at end of file
+++ /dev/null
-Eliminating unreachable basic blocks and unconditional jumps
+++ /dev/null
-IN: compiler.cfg.useless-blocks.tests
-USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
-compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
-
-{
- [ [ drop 1 ] when ]
- [ [ drop 1 ] unless ]
-} [
- [ [ ] ] dip
- '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
-] each
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
-IN: compiler.cfg.useless-blocks
-
-: update-predecessor-for-delete ( bb -- )
- ! We have to replace occurrences of bb with bb's successor
- ! in bb's predecessor's list of successors.
- dup predecessors>> first [
- [
- 2dup eq? [ drop successors>> first ] [ nip ] if
- ] with map
- ] change-successors drop ;
-
-: update-successor-for-delete ( bb -- )
- ! We have to replace occurrences of bb with bb's predecessor
- ! in bb's sucessor's list of predecessors.
- dup successors>> first [
- [
- 2dup eq? [ drop predecessors>> first ] [ nip ] if
- ] with map
- ] change-predecessors drop ;
-
-: delete-basic-block ( bb -- )
- [ update-predecessor-for-delete ]
- [ update-successor-for-delete ]
- bi ;
-
-: delete-basic-block? ( bb -- ? )
- {
- [ instructions>> length 1 = ]
- [ predecessors>> length 1 = ]
- [ successors>> length 1 = ]
- [ instructions>> first ##branch? ]
- } 1&& ;
-
-: delete-useless-blocks ( cfg -- cfg' )
- dup [
- dup delete-basic-block? [ delete-basic-block ] [ drop ] if
- ] each-basic-block
- f >>post-order ;
-
-: delete-conditional? ( bb -- ? )
- dup instructions>> [ drop f ] [
- last class {
- ##compare-branch
- ##compare-imm-branch
- ##compare-float-branch
- } memq? [ successors>> first2 eq? ] [ drop f ] if
- ] if-empty ;
-
-: delete-conditional ( bb -- )
- dup successors>> first 1vector >>successors
- [ but-last \ ##branch new-insn suffix ] change-instructions
- drop ;
-
-: delete-useless-conditionals ( cfg -- cfg' )
- dup [
- dup delete-conditional? [ delete-conditional ] [ drop ] if
- ] each-basic-block
- f >>post-order ;
--- /dev/null
+Eliminating unreachable basic blocks and unconditional jumps
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences math combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.useless-conditionals
+
+: delete-conditional? ( bb -- ? )
+ {
+ [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
+ [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
+ } 1&& ;
+
+: delete-conditional ( bb -- )
+ [ first skip-empty-blocks 1vector ] change-successors
+ instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
+
+: delete-useless-conditionals ( cfg -- cfg' )
+ dup [
+ dup delete-conditional? [ delete-conditional ] [ drop ] if
+ ] each-basic-block
+ f >>post-order ;
: stop-iterating ( -- next ) end-basic-block f ;
-: call-height ( ##call -- n )
- [ out-d>> length ] [ in-d>> length ] bi - ;
-
: emit-primitive ( node -- )
- [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
+ word>> ##call ##branch begin-basic-block ;
: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline
+
: init-value-graph ( -- )
0 vn-counter set
<bihash> exprs>vns set
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors combinators namespaces
-math fry
-compiler.cfg.hats
-compiler.cfg.instructions
+USING: accessors locals combinators combinators.short-circuit arrays
+fry kernel layouts math namespaces sequences cpu.architecture
+math.bitwise compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.simplify ;
IN: compiler.cfg.value-numbering.rewrite
GENERIC: rewrite ( insn -- insn' )
-M: ##mul-imm rewrite
- dup src2>> dup power-of-2? [
- [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
- dup number-values
- ] [ drop ] if ;
+M: insn rewrite ;
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
- [ cc>> cc/= eq? ]
- [ src2>> \ f tag-number eq? ] bi and
+ {
+ [ cc>> cc/= eq? ]
+ [ src2>> \ f tag-number eq? ]
+ } 1&&
] [ drop f ] if ; inline
: rewrite-boolean-comparison? ( insn -- ? )
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
- [ src1>> vreg>expr tag-fixnum-expr? ]
- [ src2>> tag-mask get bitand 0 = ]
- bi and ; inline
+ {
+ [ src1>> vreg>expr tag-fixnum-expr? ]
+ [ src2>> tag-mask get bitand 0 = ]
+ } 1&& ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
] when ;
-: flip-comparison? ( insn -- ? )
- dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
-
-: flip-comparison ( insn -- insn' )
- [ dst>> ]
- [ src2>> ]
- [ src1>> vreg>vn vn>constant ] tri
- cc= i \ ##compare-imm new-insn ;
-
-M: ##compare rewrite
- dup flip-comparison? [
- flip-comparison
- dup number-values
- rewrite
- ] when ;
+:: >compare-imm ( insn swap? -- insn' )
+ insn dst>>
+ insn src1>>
+ insn src2>> swap? [ swap ] when vreg>constant
+ insn cc>> swap? [ swap-cc ] when
+ i \ ##compare-imm new-insn ; inline
+
+! M: ##compare rewrite
+! dup [ src1>> ] [ src2>> ] bi
+! [ vreg>expr constant-expr? ] bi@ 2array {
+! { { f t } [ f >compare-imm ] }
+! { { t f } [ t >compare-imm ] }
+! [ drop ]
+! } case ;
+
+:: >compare-imm-branch ( insn swap? -- insn' )
+ insn src1>>
+ insn src2>> swap? [ swap ] when vreg>constant
+ insn cc>> swap? [ swap-cc ] when
+ \ ##compare-imm-branch new-insn ; inline
+
+! M: ##compare-branch rewrite
+! dup [ src1>> ] [ src2>> ] bi
+! [ vreg>expr constant-expr? ] bi@ 2array {
+! { { f t } [ f >compare-imm-branch ] }
+! { { t f } [ t >compare-imm-branch ] }
+! [ drop ]
+! } case ;
: rewrite-redundant-comparison? ( insn -- ? )
- [ src1>> vreg>expr compare-expr? ]
- [ src2>> \ f tag-number = ]
- [ cc>> { cc= cc/= } memq? ]
- tri and and ; inline
+ {
+ [ src1>> vreg>expr compare-expr? ]
+ [ src2>> \ f tag-number = ]
+ [ cc>> { cc= cc/= } memq? ]
+ } 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
] when
] when ;
-M: insn rewrite ;
+: constant-fold ( insn -- insn' )
+ dup dst>> vreg>expr dup constant-expr? [
+ [ dst>> ] [ value>> ] bi* \ ##load-immediate new-insn
+ dup number-values
+ ] [
+ drop
+ ] if ;
+
+: (new-imm-insn) ( insn dst src1 n op -- new-insn/insn )
+ [ cell-bits bits ] dip over small-enough? [
+ new-insn dup number-values nip
+ ] [
+ 2drop 2drop
+ ] if constant-fold ; inline
+
+: new-imm-insn ( insn dst src n op -- n' op' )
+ 2dup [ sgn ] dip 2array
+ {
+ { { -1 ##add-imm } [ drop neg \ ##sub-imm (new-imm-insn) ] }
+ { { -1 ##sub-imm } [ drop neg \ ##add-imm (new-imm-insn) ] }
+ [ drop (new-imm-insn) ]
+ } case ; inline
+
+: combine-imm? ( insn op -- ? )
+ [ src1>> vreg>expr op>> ] dip = ;
+
+: (combine-imm) ( insn quot op -- insn )
+ [
+ {
+ [ ]
+ [ dst>> ]
+ [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
+ [ src2>> ]
+ } cleave
+ ] [ call ] [ ] tri* new-imm-insn ; inline
+
+:: combine-imm ( insn quot op -- insn )
+ insn op combine-imm? [
+ insn quot op (combine-imm)
+ ] [
+ insn
+ ] if ; inline
+
+M: ##add-imm rewrite
+ {
+ { [ dup \ ##add-imm combine-imm? ] [ [ + ] \ ##add-imm (combine-imm) ] }
+ { [ dup \ ##sub-imm combine-imm? ] [ [ - ] \ ##sub-imm (combine-imm) ] }
+ [ ]
+ } cond ;
+
+M: ##sub-imm rewrite
+ {
+ { [ dup \ ##add-imm combine-imm? ] [ [ - ] \ ##add-imm (combine-imm) ] }
+ { [ dup \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] }
+ [ ]
+ } cond ;
+
+M: ##mul-imm rewrite
+ dup src2>> dup power-of-2? [
+ [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
+ dup number-values
+ ] [
+ drop [ * ] \ ##mul-imm combine-imm
+ ] if ;
+
+M: ##and-imm rewrite [ bitand ] \ ##and-imm combine-imm ;
+
+M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ;
+
+M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ;
+
+: rewrite-add? ( insn -- ? )
+ src2>> {
+ [ vreg>expr constant-expr? ]
+ [ vreg>constant small-enough? ]
+ } 1&& ;
+
+M: ##add rewrite
+ dup rewrite-add? [
+ [ dst>> ]
+ [ src1>> ]
+ [ src2>> vreg>constant ] tri \ ##add-imm new-insn
+ dup number-values
+ ] when ;
+
+M: ##sub rewrite constant-fold ;
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.expressions locals ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
[ 2drop f ]
} cond ; inline
+: simplify-sub ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] }
+ { [ dup expr-zero? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
: useless-shift? ( in1 in2 -- ? )
over op>> \ ##shl-imm eq?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
dup op>> {
{ \ ##add [ simplify-add ] }
{ \ ##add-imm [ simplify-add ] }
+ { \ ##sub [ simplify-sub ] }
+ { \ ##sub-imm [ simplify-sub ] }
{ \ ##shr-imm [ simplify-shift ] }
{ \ ##sar-imm [ simplify-shift ] }
[ 2drop f ]
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
+M: ##no-tco generate-insn drop ;
+
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
}
] [
[ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Regression from Doug's value numbering changes
+[ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
+[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
\ No newline at end of file
[ t ] [ f [ f eq? ] compile-call ] unit-test
+cell 8 = [
+ [ HEX: 40400000 ] [
+ HEX: 4200 [ HEX: 7fff fixnum-bitand 13 fixnum-shift-fast 112 23 fixnum-shift-fast fixnum+fast ]
+ compile-call
+ ] unit-test
+] when
+
! regression
[ 3 ] [
100001 f <array> 3 100000 pick set-nth
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
sorting.private combinators.short-circuit grouping prettyprint
+generalizations
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
] unit-test
+
+[ [ ] ] [
+ [
+ 20 f <array>
+ [ 0 swap nth ] keep
+ [ 1 swap nth ] keep
+ [ 2 swap nth ] keep
+ [ 3 swap nth ] keep
+ [ 4 swap nth ] keep
+ [ 5 swap nth ] keep
+ [ 6 swap nth ] keep
+ [ 7 swap nth ] keep
+ [ 8 swap nth ] keep
+ [ 9 swap nth ] keep
+ [ 10 swap nth ] keep
+ [ 11 swap nth ] keep
+ [ 12 swap nth ] keep
+ 14 ndrop
+ ] cleaned-up-tree nodes>quot
+] unit-test
\ No newline at end of file
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
-fry locals definitions classes.algebra
+fry locals definitions classes classes.algebra generic
stack-checker.state
stack-checker.backend
compiler.tree
compiler.tree.dead-code.liveness ;
IN: compiler.tree.dead-code.simple
-: flushable? ( word -- ? )
- [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
+GENERIC: flushable? ( word -- ? )
+
+M: predicate flushable? drop t ;
+
+M: word flushable? "flushable" word-prop ;
+
+M: method-body flushable? "method-generic" word-prop flushable? ;
: flushable-call? ( #call -- ? )
dup word>> dup flushable? [
TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
-
-! Make sure that initial-quot: doesn't inhibit unboxing
-TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
-
-[ 1 ] [
- [ initial-quot-tuple new x>> ] count-unboxed-allocations
-] unit-test
\ No newline at end of file
: ?check ( nodes -- nodes' )
check-optimizer? get [
- compute-def-use
dup check-nodes
] when ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private arrays vectors fry
-math.order namespaces assocs ;
+math math.order namespaces assocs ;
IN: compiler.utilities
: flattener ( seq quot -- seq vector quot' )
SYMBOL: yield-hook
yield-hook [ [ ] ] initialize
+
+: alist-max ( alist -- pair )
+ [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
\ No newline at end of file
: make-bitmap-image ( dim quot -- image )
'[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap
- ARGB >>component-order ; inline
+ ARGB >>component-order
+ ubyte-components >>component-type ; inline
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types alien.syntax arrays kernel
+USING: locals alien.c-types alien.syntax arrays kernel fry
math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture make compiler compiler.units
M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
- src HEX: ffffffff ADD
+ temp src HEX: ffffffff [+] LEA
+ building get length cell - :> start
0 rc-absolute-cell rel-here
! Go
- src HEX: 7f [+] JMP
+ temp HEX: 7f [+] JMP
+ building get length :> end
! Fix up the displacement above
cell code-alignment
- [ 7 + building get dup pop* push ]
+ [ end start - + building get dup pop* push ]
[ align-code ]
bi ;
align-stack incr-stack-reg ;
: with-aligned-stack ( n quot -- )
- [ [ align-sub ] [ call ] bi* ]
- [ [ align-add ] [ drop ] bi* ] 2bi ; inline
+ '[ align-sub @ ] [ align-add ] bi ; inline
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this
- stack-reg swap 3 cells - SUB ;
+ 3 cells - decr-stack-reg ;
M: object %load-param-reg 3drop ;
M: x86.64 stack-reg RSP ;
M:: x86.64 %dispatch ( src temp -- )
+ building get length :> start
! Load jump table base.
temp HEX: ffffffff MOV
0 rc-absolute-cell rel-here
! Add jump table base
- src temp ADD
- src HEX: 7f [+] JMP
+ temp src ADD
+ temp HEX: 7f [+] JMP
+ building get length :> end
! Fix up the displacement above
cell code-alignment
- [ 15 + building get dup pop* push ]
+ [ end start - 2 - + building get dup pop* push ]
[ align-code ]
bi ;
--- /dev/null
+IN: disjoint-sets.testes
+USING: tools.test disjoint-sets namespaces slots.private ;
+
+SYMBOL: +blah+
+-405534154 +blah+ 1 set-slot
+
+SYMBOL: uf
+
+[ ] [
+ <disjoint-set> uf set
+ +blah+ uf get add-atom
+ 19026 uf get add-atom
+ 19026 +blah+ uf get equate
+] unit-test
+
+[ 2 ] [ 19026 uf get equiv-set-size ] unit-test
USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations
tools.crossref vocabs.hierarchy prettyprint source-files
-source-files.errors assocs vocabs vocabs.loader splitting
+source-files.errors assocs vocabs.loader splitting
accessors debugger help.topics ;
+FROM: vocabs => vocab-name >vocab-link ;
IN: editors
TUPLE: no-edit-hook ;
SYMBOL: edit-hook
: available-editors ( -- seq )
- "editors" all-child-vocabs-seq [ vocab-name ] map ;
+ "editors" child-vocabs no-roots no-prefixes [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors
[ parse-definition* ] dip
parsed ;
-: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
-
SYNTAX: `TUPLE:
scan-param parsed
scan {
DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
: create-device-change-window ( -- )
- <zero-window-rect> create-window
+ <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
[
(device-notification-filter)
DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
[ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test\r
\r
[ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test\r
+\r
+: nover-test ( -- a b c d e f g )\r
+ 1 2 3 4 3 nover ;\r
+\r
+[ 1 2 3 4 1 2 3 ] [ nover-test ] unit-test\r
1- [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: nover ( n -- )
- dup '[ _ 1 + npick ] n*quot ;
+ dup 1 + '[ _ npick ] n*quot ;
MACRO: ndup ( n -- )
dup '[ _ npick ] n*quot ;
: data-nth ( n heap -- entry )
data>> nth-unsafe ; inline
-: up-value ( n heap -- entry )
- [ up ] dip data-nth ; inline
-
: left-value ( n heap -- entry )
[ left ] dip data-nth ; inline
: data-pop* ( heap -- )
data>> pop* ; inline
-: data-peek ( heap -- entry )
- data>> last ; inline
-
: data-first ( heap -- entry )
data>> first ; inline
2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
-: swap-down ( m heap -- )
- [ child ] 2keep data-exchange ;
-
DEFER: down-heap
: (down-heap) ( m heap -- )
[ dup name>> >lower ] { } map>assoc ;
: vocab-candidates ( -- candidates )
- all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
+ all-vocabs-recursive no-roots no-prefixes
+ [ dup vocab-name >lower ] { } map>assoc ;
: help-candidates ( seq -- candidates )
[ [ >link ] [ article-title >lower ] bi ] { } map>assoc
assocs sequences make words accessors arrays help.topics vocabs
vocabs.hierarchy help.vocabs namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.syntax xml.writer math.parser ;
+sorting debugger html xml.syntax xml.writer math.parser
+sets hashtables ;
FROM: io.encodings.ascii => ascii ;
FROM: ascii => ascii? ;
IN: help.html
{ CHAR: / "__slash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
+ { CHAR: # "__hash__" }
} at [ % ] [ , ] ?if
] [ number>string "__" "__" surround % ] if ;
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
- #! Hack.
- all-vocabs values concat
- vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
+ all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
: all-topics ( -- topics )
[
source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ;
+FROM: vocabs => child-vocabs ;
IN: help.lint
SYMBOL: lint-failures
] check-something
] [ drop ] if ;
-: check-words ( words -- ) [ check-word ] each ;
-
: check-article ( article -- )
[ with-interactive-vocabs ] vocabs-quot set
>link dup '[
: help-lint ( prefix -- )
[
- all-vocabs-seq [ vocab-name ] map all-vocabs set
+ auto-use? off
+ all-vocab-names all-vocabs set
group-articles vocab-articles set
child-vocabs
[ check-vocab ] each
make namespaces prettyprint sequences sets sorting summary
vocabs vocabs.files vocabs.hierarchy vocabs.loader
vocabs.metadata words words.symbol definitions.icons ;
+FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs
: about ( vocab -- )
$heading ;
: $vocabs ( seq -- )
- [ vocab-row ] map vocab-headings prefix $table ;
+ convert-prefixes [ vocab-row ] map vocab-headings prefix $table ;
: $vocab-roots ( assoc -- )
[
] unless-empty ;
: describe-children ( vocab -- )
- vocab-name all-child-vocabs $vocab-roots ;
+ vocab-name child-vocabs
+ $vocab-roots ;
: files. ( seq -- )
snippet-style get [
[ loading-bitmap>bytes >>bitmap ]
[ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ header>> height>> 0 < not >>upside-down? ]
- [ bitmap>component-order >>component-order ]
+ [ bitmap>component-order >>component-order ubyte-components >>component-type ]
} cleave ;
USING: images tools.test kernel accessors ;
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
57 57 57 255
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
USING: combinators kernel accessors sequences math arrays ;
IN: images
-SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
-R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
+SINGLETONS:
+ A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+ INTENSITY DEPTH DEPTH-STENCIL R RG
+ ubyte-components ushort-components uint-components
+ half-components float-components
+ byte-integer-components ubyte-integer-components
+ short-integer-components ushort-integer-components
+ int-integer-components uint-integer-components
+ u-5-5-5-1-components u-5-6-5-components
+ u-10-10-10-2-components
+ u-24-components u-24-8-components
+ float-32-u-8-components
+ u-9-9-9-e5-components
+ float-11-11-10-components ;
-UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
+UNION: component-order
+ A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+ INTENSITY DEPTH DEPTH-STENCIL R RG ;
-: bytes-per-pixel ( component-order -- n )
+UNION: component-type
+ ubyte-components ushort-components uint-components
+ half-components float-components
+ byte-integer-components ubyte-integer-components
+ short-integer-components ushort-integer-components
+ int-integer-components uint-integer-components
+ u-5-5-5-1-components u-5-6-5-components
+ u-10-10-10-2-components
+ u-24-components u-24-8-components
+ float-32-u-8-components
+ u-9-9-9-e5-components
+ float-11-11-10-components ;
+
+UNION: unnormalized-integer-components
+ byte-integer-components ubyte-integer-components
+ short-integer-components ushort-integer-components
+ int-integer-components uint-integer-components ;
+
+UNION: signed-unnormalized-integer-components
+ byte-integer-components
+ short-integer-components
+ int-integer-components ;
+
+UNION: unsigned-unnormalized-integer-components
+ ubyte-integer-components
+ ushort-integer-components
+ uint-integer-components ;
+
+UNION: packed-components
+ u-5-5-5-1-components u-5-6-5-components
+ u-10-10-10-2-components
+ u-24-components u-24-8-components
+ float-32-u-8-components
+ u-9-9-9-e5-components
+ float-11-11-10-components ;
+
+UNION: alpha-channel BGRA RGBA ABGR ARGB LA A INTENSITY ;
+
+UNION: alpha-channel-precedes-colors ABGR ARGB XBGR XRGB ;
+
+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 )
+
+: bytes-per-component ( component-type -- n )
+ {
+ { ubyte-components [ 1 ] }
+ { ushort-components [ 2 ] }
+ { uint-components [ 4 ] }
+ { 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 ;
+
+: bytes-per-packed-pixel ( component-type -- n )
+ {
+ { u-5-5-5-1-components [ 2 ] }
+ { u-5-6-5-components [ 2 ] }
+ { u-10-10-10-2-components [ 4 ] }
+ { u-24-components [ 4 ] }
+ { u-24-8-components [ 4 ] }
+ { u-9-9-9-e5-components [ 4 ] }
+ { float-11-11-10-components [ 4 ] }
+ { float-32-u-8-components [ 8 ] }
+ } case ;
+
+: component-count ( component-order -- n )
{
+ { A [ 1 ] }
{ L [ 1 ] }
{ LA [ 2 ] }
{ BGR [ 3 ] }
{ XRGB [ 4 ] }
{ BGRX [ 4 ] }
{ XBGR [ 4 ] }
- { R16G16B16 [ 6 ] }
- { R32G32B32 [ 12 ] }
- { R16G16B16A16 [ 8 ] }
- { R32G32B32A32 [ 16 ] }
+ { INTENSITY [ 1 ] }
+ { DEPTH [ 1 ] }
+ { DEPTH-STENCIL [ 1 ] }
+ { R [ 1 ] }
+ { RG [ 2 ] }
} case ;
-TUPLE: image dim component-order upside-down? bitmap ;
-
-: <image> ( -- image ) image new ; inline
-
-: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+: (bytes-per-pixel) ( component-order component-type -- n )
+ dup packed-components?
+ [ nip bytes-per-packed-pixel ] [
+ [ component-count ] [ bytes-per-component ] bi* *
+ ] if ;
-GENERIC: load-image* ( path class -- image )
+: bytes-per-pixel ( image -- n )
+ [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
<PRIVATE
: pixel@ ( x y image -- start end bitmap )
[ dim>> first * + ]
- [ component-order>> bytes-per-pixel [ * dup ] keep + ]
+ [ bytes-per-pixel [ * dup ] keep + ]
[ bitmap>> ] tri ;
: set-subseq ( new-value from to victim -- )
: setup-bitmap ( image -- )
dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
BGR >>component-order
+ ubyte-components >>component-type
f >>upside-down?
dup dim>> first2 * 3 * 0 <array> >>bitmap
drop ;
[ <image> ] dip {
[ png-image-bytes >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
- [ drop RGB >>component-order ]
+ [ drop RGB >>component-order ubyte-components >>component-type ]
} cleave ;
: decode-indexed-color ( loading-png -- loading-png )
<image> over matrix-dim >>dim\r
swap flip flatten\r
[ 128 * 128 + 0 max 255 min >fixnum ] map\r
- >byte-array >>bitmap L >>component-order ;\r
+ >byte-array >>bitmap L >>component-order ubyte-components >>component-type ;\r
\r
:: matrix-zoom ( m f -- m' )\r
m matrix-dim f v*n coord-matrix\r
[
{
{
- T{ image f { 2 2 } L 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{ 1 2 5 6 } }
+ 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 f B{ 11 12 15 16 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 9 10 13 14 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 11 12 15 16 } }
}
}
] [
1 16 [a,b] >byte-array >>bitmap
{ 4 4 } >>dim
L >>component-order
+ ubyte-components >>component-type
{ 2 2 } tesselate
] unit-test
[
{
{
- T{ image f { 2 2 } L f B{ 1 2 4 5 } }
- T{ image f { 1 2 } L f B{ 3 6 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 1 2 4 5 } }
+ 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 { 1 1 } L f B{ 9 } }
+ T{ image f { 2 1 } L ubyte-components f B{ 7 8 } }
+ T{ image f { 1 1 } L ubyte-components f B{ 9 } }
}
}
] [
1 9 [a,b] >byte-array >>bitmap
{ 3 3 } >>dim
L >>component-order
+ ubyte-components >>component-type
{ 2 2 } tesselate
-] unit-test
\ No newline at end of file
+] unit-test
'[ _ tesselate-columns ] map ;
: 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 )
clone
[ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
:: 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'
tess-dim { bpp 1 } v* :> tess-dim'
image bitmap>> image-dim' tess-dim' tesselate-bitmap
- [ [ image <tile-image> ] map ] map ;
\ No newline at end of file
+ [ [ image <tile-image> ] map ] map ;
[ unknown-component-order ]
} case >>bitmap ;
-: ifd-component-order ( ifd -- byte-order )
+: ifd-component-order ( ifd -- component-order component-type )
bits-per-sample find-tag {
- { { 32 32 32 32 } [ R32G32B32A32 ] }
- { { 32 32 32 } [ R32G32B32 ] }
- { { 16 16 16 16 } [ R16G16B16A16 ] }
- { { 16 16 16 } [ R16G16B16 ] }
- { { 8 8 8 8 } [ RGBA ] }
- { { 8 8 8 } [ RGB ] }
- { 8 [ LA ] }
+ { { 32 32 32 32 } [ RGBA float-components ] }
+ { { 32 32 32 } [ RGB float-components ] }
+ { { 16 16 16 16 } [ RGBA ushort-components ] }
+ { { 16 16 16 } [ RGB ushort-components ] }
+ { { 8 8 8 8 } [ RGBA ubyte-components ] }
+ { { 8 8 8 } [ RGB ubyte-components ] }
+ { 8 [ LA ubyte-components ] }
[ unknown-component-order ]
} case ;
: ifd>image ( ifd -- image )
[ <image> ] dip {
[ [ 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 ]
} cleave ;
IN: io.servers.connection
TUPLE: threaded-server
-{ name initial: "server" }
-{ log-level initial: DEBUG }
-secure insecure
-{ secure-config initial-quot: [ <secure-config> ] }
-{ sockets initial-quot: [ V{ } clone ] }
+name
+log-level
+secure
+insecure
+secure-config
+sockets
max-connections
semaphore
-{ timeout initial-quot: [ 1 minutes ] }
+timeout
encoding
-{ handler initial: [ "No handler quotation" throw ] }
-{ ready initial-quot: [ <flag> ] } ;
+handler
+ready ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
: new-threaded-server ( encoding class -- threaded-server )
new
+ "server" >>name
+ DEBUG >>log-level
+ <secure-config> >>secure-config
+ V{ } clone >>sockets
+ 1 minutes >>timeout
+ [ "No handler quotation" throw ] >>handler
+ <flag> >>ready
swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
+
+SYNTAX: $$
+ scan-word execute( accum -- accum ) dup pop [ >quotation ] keep
+ [ output>sequence ] 2curry call( -- object ) parsed ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax math sequences ;
+USING: assocs help.markup help.syntax math sequences ;
IN: math.bitwise
HELP: bitfield
}
} ;
+HELP: symbols>flags
+{ $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
+{ $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ui.gadgets.worlds ;"
+ "IN: scratchpad"
+ "CONSTANT: window-controls>flags H{"
+ " { close-button 1 }"
+ " { minimize-button 2 }"
+ " { maximize-button 4 }"
+ " { resize-handles 8 }"
+ " { small-title-bar 16 }"
+ " { normal-title-bar 32 }"
+ "}"
+ "{ resize-handles close-button small-title-bar } window-controls>flags symbols>flags ."
+ "25"
+ }
+} ;
+
HELP: mask
{ $values
{ "x" integer } { "n" integer }
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences accessors math.bits
-sequences.private words namespaces macros hints
-combinators fry io.binary combinators.smart ;
+USING: arrays assocs kernel math sequences accessors
+math.bits sequences.private words namespaces macros
+hints combinators fry io.binary combinators.smart ;
IN: math.bitwise
! utilities
MACRO: flags ( values -- )
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
+: symbols>flags ( symbols assoc -- flag-bits )
+ [ at ] curry map
+ 0 [ bitor ] reduce ;
+
! bitfield
<PRIVATE
: ceiling ( x -- y ) neg floor neg ; foldable
+: floor-to ( x step -- y )
+ dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ;
+
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays columns kernel math math.bits
-math.order math.vectors sequences sequences.private fry ;
+USING: accessors arrays columns kernel locals math math.bits
+math.functions math.order math.vectors sequences
+sequences.private fry ;
IN: math.matrices
! Matrices
#! Make a nxn identity matrix.
dup [ [ = 1 0 ? ] with map ] curry map ;
+:: rotation-matrix3 ( axis theta -- matrix )
+ theta cos :> c
+ theta sin :> s
+ axis first3 :> z :> y :> x
+ x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array
+ x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array
+ x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array
+ 3array ;
+
+:: rotation-matrix4 ( axis theta -- matrix )
+ theta cos :> c
+ theta sin :> s
+ axis first3 :> z :> y :> x
+ x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array
+ x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array
+ x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array
+ { 0.0 0.0 0.0 1.0 } 4array ;
+
+:: translation-matrix4 ( offset -- matrix )
+ offset first3 :> z :> y :> x
+ {
+ { 1.0 0.0 0.0 x }
+ { 0.0 1.0 0.0 y }
+ { 0.0 0.0 1.0 z }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
+: >scale-factors ( number/sequence -- x y z )
+ dup number? [ dup dup ] [ first3 ] if ;
+
+:: scale-matrix3 ( factors -- matrix )
+ factors >scale-factors :> z :> y :> x
+ {
+ { x 0.0 0.0 }
+ { 0.0 y 0.0 }
+ { 0.0 0.0 z }
+ } ;
+
+:: scale-matrix4 ( factors -- matrix )
+ factors >scale-factors :> z :> y :> x
+ {
+ { x 0.0 0.0 0.0 }
+ { 0.0 y 0.0 0.0 }
+ { 0.0 0.0 z 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
+: ortho-matrix4 ( dim -- matrix )
+ [ recip ] map scale-matrix4 ;
+
+:: frustum-matrix4 ( xy-dim near far -- matrix )
+ xy-dim first2 :> y :> x
+ near x /f :> xf
+ near y /f :> yf
+ near far + near far - /f :> zf
+ 2 near far * * near far - /f :> wf
+
+ {
+ { xf 0.0 0.0 0.0 }
+ { 0.0 yf 0.0 0.0 }
+ { 0.0 0.0 zf wf }
+ { 0.0 0.0 -1.0 0.0 }
+ } ;
+
+:: skew-matrix4 ( theta -- matrix )
+ theta tan :> zf
+
+ {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 1.0 0.0 0.0 }
+ { 0.0 zf 1.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
! Matrix operations
: mneg ( m -- m ) [ vneg ] map ;
HELP: sieve
{ $values { "n" "the greatest odd number to consider" } { "arr" "a bit array" } }
-{ $description "Return a bit array containing a primality bit for every odd number between 3 and " { $snippet "n" } " (inclusive). " { $snippet ">index" } " can be used to retrieve the index of an odd number to be tested." } ;
+{ $description "Apply Eratostene sieve up to " { $snippet "n" } ". Primality can then be tested using " { $link sieve } "." } ;
-HELP: >index
-{ $values { "n" "an odd number" } { "i" "the corresponding index" } }
-{ $description "Retrieve the index corresponding to the odd number on the stack." } ;
-
-{ sieve >index } related-words
+HELP: marked-prime?
+{ $values { "n" "an integer" } { "arr" "a byte array returned by " { $link sieve } } { "?" "a boolean" } }
+{ $description "Check whether a number between 3 and the limit given to " { $link sieve } " has been marked as a prime number."} ;
-USING: bit-arrays math.primes.erato tools.test ;
+USING: byte-arrays math math.bitwise math.primes.erato sequences tools.test ;
-[ ?{ t t t f t t f t t f t f f t } ] [ 29 sieve ] unit-test
+[ B{ 255 251 247 126 } ] [ 100 sieve ] unit-test
+[ 1 100 sieve marked-prime? ] [ bounds-error? ] must-fail-with
+[ 120 100 sieve marked-prime? ] [ bounds-error? ] must-fail-with
+[ f ] [ 119 100 sieve marked-prime? ] unit-test
+[ t ] [ 113 100 sieve marked-prime? ] unit-test
+
+! There are 25997 primes below 300000. 1 must be removed and 3 5 7 added.
+[ 25997 ] [ 299999 sieve [ bit-count ] sigma 2 + ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel math math.functions math.ranges sequences ;
+USING: arrays byte-arrays kernel math math.bitwise math.functions math.order
+math.ranges sequences sequences.private ;
IN: math.primes.erato
-: >index ( n -- i )
- 3 - 2 /i ; inline
+<PRIVATE
-: index> ( i -- n )
- 2 * 3 + ; inline
+CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 }
-: mark-multiples ( i arr -- )
- [ index> [ sq >index ] keep ] dip
- [ length 1 - swap <range> f swap ] keep
- [ set-nth ] curry with each ;
+: bit-pos ( n -- byte/f mask/f )
+ 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ;
-: maybe-mark-multiples ( i arr -- )
- 2dup nth [ mark-multiples ] [ 2drop ] if ;
+: marked-unsafe? ( n arr -- ? )
+ [ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ;
-: init-sieve ( n -- arr )
- >index 1 + <bit-array> dup set-bits ;
+: unmark ( n arr -- )
+ [ bit-pos swap ] dip
+ over [ [ swap unmask ] change-nth-unsafe ] [ 3drop ] if ;
+
+: upper-bound ( arr -- n ) length 30 * 1 - ;
+
+: unmark-multiples ( i arr -- )
+ 2dup marked-unsafe? [
+ [ [ dup sq ] [ upper-bound ] bi* rot <range> ] keep
+ [ unmark ] curry each
+ ] [
+ 2drop
+ ] if ;
+
+: init-sieve ( n -- arr ) 29 + 30 /i 255 <array> >byte-array ;
+
+PRIVATE>
: sieve ( n -- arr )
- [ init-sieve ] [ sqrt >index [0,b] ] bi
- over [ maybe-mark-multiples ] curry each ; foldable
+ init-sieve [ 2 swap upper-bound sqrt [a,b] ] keep
+ [ [ unmark-multiples ] curry each ] keep ;
+
+: marked-prime? ( n arr -- ? )
+ 2dup upper-bound 2 swap between? [ bounds-error ] unless
+ over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
\ No newline at end of file
USING: help.markup help.syntax math sequences ;
IN: math.primes.factors
-{ factors group-factors unique-factors } related-words
+{ divisors factors group-factors unique-factors } related-words
HELP: factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
HELP: totient
{ $values { "n" "a positive integer" } { "t" integer } }
{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " that are relatively prime to " { $snippet "n" } "." } } ;
+
+HELP: divisors
+{ $values { "n" "a positive integer" } { "seq" sequence } }
+{ $description { "Return the ordered list of divisors of " { $snippet "n" } ", including 1 and " { $snippet "n" } "." } } ;
-USING: math.primes.factors tools.test ;
+USING: math.primes.factors sequences tools.test ;
{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
{ { } } [ -5 factors ] unit-test
{ 0 } [ 1 totient ] unit-test
{ { 425612003 } } [ 425612003 factors ] unit-test
{ { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
+{ { 1 2 3 4 6 8 12 24 } } [ 24 divisors ] unit-test
+{ 24 } [ 360 divisors length ] unit-test
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel make math math.functions
-math.primes sequences ;
+math.primes math.ranges sequences sequences.product sorting ;
IN: math.primes.factors
<PRIVATE
{ [ dup 2 < ] [ drop 0 ] }
[ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
} cond ; foldable
+
+: divisors ( n -- seq )
+ group-factors [ first2 [0,b] [ ^ ] with map ] map
+ [ product ] product-map natural-sort ;
-USING: arrays math math.primes math.primes.miller-rabin
-tools.test ;
+USING: arrays kernel math math.primes math.primes.miller-rabin
+sequences tools.test ;
IN: math.primes.tests
{ 1237 } [ 1234 next-prime ] unit-test
{ { 4999963 4999999 5000011 5000077 5000081 } }
[ 4999962 5000082 primes-between >array ] unit-test
+{ { 8999981 8999993 9000011 9000041 } }
+[ 8999980 9000045 primes-between >array ] unit-test
+
[ 2 ] [ 1 next-prime ] unit-test
[ 3 ] [ 2 next-prime ] unit-test
[ 5 ] [ 3 next-prime ] unit-test
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
[ 49 ] [ 50 random-prime log2 ] unit-test
+
+[ t ] [ 5000077 dup find-relative-prime coprime? ] unit-test
+
+[ 5 t { 14 14 14 14 14 } ]
+[ 5 15 unique-primes [ length ] [ [ prime? ] all? ] [ [ log2 ] map ] tri ] unit-test
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.bitwise math.functions
-math.order math.primes.erato math.primes.miller-rabin
-math.ranges random sequences sets fry ;
+USING: combinators combinators.short-circuit fry kernel math
+math.bitwise math.functions math.order math.primes.erato
+math.primes.erato.private math.primes.miller-rabin math.ranges
+literals random sequences sets vectors ;
IN: math.primes
<PRIVATE
-: look-in-bitmap ( n -- ? ) >index 4999999 sieve nth ;
+: look-in-bitmap ( n -- ? ) $[ 8999999 sieve ] marked-unsafe? ; inline
-: really-prime? ( n -- ? )
- dup 5000000 < [ look-in-bitmap ] [ miller-rabin ] if ; foldable
+: (prime?) ( n -- ? )
+ dup 8999999 <= [ look-in-bitmap ] [ miller-rabin ] if ;
+
+! In order not to reallocate large vectors, we compute the upper bound
+! of the number of primes in a given interval. We use a double inequality given
+! by Pierre Dusart in http://www.ams.org/mathscinet-getitem?mr=99d:11133
+! for x > 598. Under this limit, we know that there are at most 108 primes.
+: upper-pi ( x -- y )
+ dup log [ / ] [ 1.2762 swap / 1 + ] bi * ceiling ;
+
+: lower-pi ( x -- y )
+ dup log [ / ] [ 0.992 swap / 1 + ] bi * floor ;
+
+: <primes-vector> ( low high -- vector )
+ swap [ [ upper-pi ] [ lower-pi ] bi* - >integer
+ 108 max 10000 min <vector> ] keep
+ 3 < [ [ 2 swap push ] keep ] when ;
+
+: simple? ( n -- ? ) { [ even? ] [ 3 mod 0 = ] [ 5 mod 0 = ] } 1|| ;
PRIVATE>
: prime? ( n -- ? )
{
- { [ dup 2 < ] [ drop f ] }
- { [ dup even? ] [ 2 = ] }
- [ really-prime? ]
+ { [ dup 7 < ] [ { 2 3 5 } member? ] }
+ { [ dup simple? ] [ drop f ] }
+ [ (prime?) ]
} cond ; foldable
: next-prime ( n -- p )
dup 2 < [
drop 2
] [
- next-odd [ dup really-prime? ] [ 2 + ] until
+ next-odd [ dup prime? ] [ 2 + ] until
] if ; foldable
: primes-between ( low high -- seq )
- [ dup 3 max dup even? [ 1 + ] when ] dip
- 2 <range> [ prime? ] filter
- swap 3 < [ 2 prefix ] when ;
+ [ [ 3 max dup even? [ 1 + ] when ] dip 2 <range> ]
+ [ <primes-vector> ] 2bi
+ [ '[ [ prime? ] _ push-if ] each ] keep clone ;
: primes-upto ( n -- seq ) 2 swap primes-between ;
: unique-primes ( n numbits -- seq )
2dup 2^ estimated-primes > [ too-few-primes ] when
- 2dup '[ _ random-prime ] replicate
+ 2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
+
+[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
\ No newline at end of file
{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;\r
\r
HELP: <range>\r
-{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "range" range } }\r
+{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "step" real } { "range" range } }\r
{ $description "Creates a new " { $link range } " model." } ;\r
\r
HELP: range-model\r
tools.test models.range ;\r
\r
! Test <range> \r
-: setup-range ( -- range ) 0 0 0 255 <range> ;\r
+: setup-range ( -- range ) 0 0 0 255 1 <range> ;\r
+: setup-stepped-range ( -- range ) 0 0 0 255 2 <range> ;\r
\r
! clamp-value should not go past range ends\r
[ 0 ] [ -10 setup-range clamp-value ] unit-test\r
[ 255 ] [ 2000 setup-range clamp-value ] unit-test\r
[ 14 ] [ 14 setup-range clamp-value ] unit-test\r
\r
+! step-value\r
+[ 14 ] [ 15 setup-stepped-range step-value ] unit-test\r
+\r
! range min/max/page values should be correct\r
[ 0 ] [ setup-range range-page-value ] unit-test\r
[ 0 ] [ setup-range range-min-value ] unit-test\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors kernel models arrays sequences math math.order\r
-models.product ;\r
+models.product generalizations math.functions ;\r
FROM: models.product => product ;\r
IN: models.range\r
\r
TUPLE: range < product ;\r
\r
-: <range> ( value page min max -- range )\r
- 4array [ <model> ] map range new-product ;\r
+: <range> ( value page min max step -- range )\r
+ 5 narray [ <model> ] map range new-product ;\r
\r
: range-model ( range -- model ) dependencies>> first ;\r
: range-page ( range -- model ) dependencies>> second ;\r
: range-min ( range -- model ) dependencies>> third ;\r
: range-max ( range -- model ) dependencies>> fourth ;\r
+: range-step ( range -- model ) dependencies>> 4 swap nth ;\r
+\r
+: step-value ( value range -- value' )\r
+ range-step value>> floor-to ;\r
\r
M: range range-value\r
- [ range-model value>> ] keep clamp-value ;\r
+ [ range-model value>> ] [ clamp-value ] [ step-value ] tri ;\r
\r
M: range range-page-value range-page value>> ;\r
\r
HELP: gen-framebuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
+{ $description "Wrapper for " { $link glGenFramebuffers } " to handle the common case of generating a single framebuffer ID." } ;
HELP: gen-renderbuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
+{ $description "Wrapper for " { $link glGenRenderbuffers } " to handle the common case of generating a single render buffer ID." } ;
HELP: delete-framebuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
+{ $description "Wrapper for " { $link glDeleteFramebuffers } " to handle the common case of deleting a single framebuffer ID." } ;
HELP: delete-renderbuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
+{ $description "Wrapper for " { $link glDeleteRenderbuffers } " to handle the common case of deleting a single render buffer ID." } ;
{ gen-framebuffer delete-framebuffer } related-words
{ gen-renderbuffer delete-renderbuffer } related-words
HELP: framebuffer-incomplete?
{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebuffer } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
HELP: check-framebuffer
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebuffer } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
HELP: with-framebuffer
{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
-{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
+{ $description "Binds framebuffer " { $snippet "id" } " for drawing in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
-ABOUT: "gl-utilities"
\ No newline at end of file
+ABOUT: "gl-utilities"
IN: opengl.framebuffers
: gen-framebuffer ( -- id )
- [ glGenFramebuffersEXT ] (gen-gl-object) ;
+ [ glGenFramebuffers ] (gen-gl-object) ;
: gen-renderbuffer ( -- id )
- [ glGenRenderbuffersEXT ] (gen-gl-object) ;
+ [ glGenRenderbuffers ] (gen-gl-object) ;
: delete-framebuffer ( id -- )
- [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
+ [ glDeleteFramebuffers ] (delete-gl-object) ;
: delete-renderbuffer ( id -- )
- [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
+ [ glDeleteRenderbuffers ] (delete-gl-object) ;
: framebuffer-incomplete? ( -- status/f )
- GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
- dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
+ GL_DRAW_FRAMEBUFFER glCheckFramebufferStatus
+ dup GL_FRAMEBUFFER_COMPLETE = f rot ? ;
: framebuffer-error ( status -- * )
{
- { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
- { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
+ { GL_FRAMEBUFFER_COMPLETE [ "framebuffer complete" ] }
+ { GL_FRAMEBUFFER_UNSUPPORTED [ "framebuffer configuration unsupported" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT [ "framebuffer incomplete (incomplete attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT [ "framebuffer incomplete (missing attachment)" ] }
{ GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
{ GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT [ "framebuffer incomplete (multisample counts don't match)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER [ "framebuffer incomplete (read buffer has no attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE [ "framebuffer incomplete (multisample counts don't match)" ] }
[ drop gl-error "unknown framebuffer error" ]
} case throw ;
framebuffer-incomplete? [ framebuffer-error ] when* ;
: with-framebuffer ( id quot -- )
- [ GL_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] dip
- [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
+ [ GL_DRAW_FRAMEBUFFER swap glBindFramebuffer ] dip
+ [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer ] [ ] cleanup ; inline
: with-draw-read-framebuffers ( draw-id read-id quot -- )
[
- [ GL_DRAW_FRAMEBUFFER_EXT swap glBindFramebufferEXT ]
- [ GL_READ_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] bi*
+ [ GL_DRAW_FRAMEBUFFER swap glBindFramebuffer ]
+ [ GL_READ_FRAMEBUFFER swap glBindFramebuffer ] bi*
] dip
[
- GL_DRAW_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
- GL_READ_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
+ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer
+ GL_READ_FRAMEBUFFER 0 glBindFramebuffer
] [ ] cleanup ; inline
: framebuffer-attachment ( attachment -- id )
- GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
- 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
+ GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
+ 0 <uint> [ glGetFramebufferAttachmentParameteriv ] keep *uint ;
CONSTANT: GL_NONE HEX: 0
CONSTANT: GL_LEFT HEX: 0406
CONSTANT: GL_RIGHT HEX: 0407
-
+CONSTANT: GL_FRONT_LEFT HEX: 0400
CONSTANT: GL_FRONT_RIGHT HEX: 0401
CONSTANT: GL_BACK_LEFT HEX: 0402
CONSTANT: GL_BACK_RIGHT HEX: 0403
CONSTANT: GL_RGB HEX: 1907
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
CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31
CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35
GL-FUNCTION: void glTexSubImage3D { glTexSubImage3DEXT } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ;
+! GL_ARB_imaging
+
+
+CONSTANT: GL_CONSTANT_COLOR HEX: 8001
+CONSTANT: GL_ONE_MINUS_CONSTANT_COLOR HEX: 8002
+CONSTANT: GL_CONSTANT_ALPHA HEX: 8003
+CONSTANT: GL_ONE_MINUS_CONSTANT_ALPHA HEX: 8004
+CONSTANT: GL_BLEND_COLOR HEX: 8005
+CONSTANT: GL_FUNC_ADD HEX: 8006
+CONSTANT: GL_MIN HEX: 8007
+CONSTANT: GL_MAX HEX: 8008
+CONSTANT: GL_BLEND_EQUATION HEX: 8009
+CONSTANT: GL_FUNC_SUBTRACT HEX: 800A
+CONSTANT: GL_FUNC_REVERSE_SUBTRACT HEX: 800B
+
+
! OpenGL 1.3
GL-FUNCTION: void glMultiDrawElements { glMultiDrawElementsEXT } ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ;
GL-FUNCTION: void glPointParameterf { glPointParameterfARB } ( GLenum pname, GLfloat param ) ;
GL-FUNCTION: void glPointParameterfv { glPointParameterfvARB } ( GLenum pname, GLfloat* params ) ;
+GL-FUNCTION: void glPointParameteri { glPointParameteriARB } ( GLenum pname, GLint param ) ;
+GL-FUNCTION: void glPointParameteriv { glPointParameterivARB } ( GLenum pname, GLint* params ) ;
GL-FUNCTION: void glSecondaryColor3b { glSecondaryColor3bEXT } ( GLbyte red, GLbyte green, GLbyte blue ) ;
GL-FUNCTION: void glSecondaryColor3bv { glSecondaryColor3bvEXT } ( GLbyte* v ) ;
GL-FUNCTION: void glSecondaryColor3d { glSecondaryColor3dEXT } ( GLdouble red, GLdouble green, GLdouble blue ) ;
CONSTANT: GL_STENCIL_BACK_REF HEX: 8CA3
CONSTANT: GL_STENCIL_BACK_VALUE_MASK HEX: 8CA4
CONSTANT: GL_STENCIL_BACK_WRITEMASK HEX: 8CA5
-CONSTANT: GL_BLEND_EQUATION HEX: 8009
ALIAS: GL_BLEND_EQUATION_RGB GL_BLEND_EQUATION
TYPEDEF: char GLchar
CONSTANT: GL_COMPRESSED_SRGB_ALPHA HEX: 8C49
CONSTANT: GL_COMPRESSED_SLUMINANCE HEX: 8C4A
CONSTANT: GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B
+CONSTANT: GL_FLOAT_MAT2x3 HEX: 8B65
+CONSTANT: GL_FLOAT_MAT2x4 HEX: 8B66
+CONSTANT: GL_FLOAT_MAT3x2 HEX: 8B67
+CONSTANT: GL_FLOAT_MAT3x4 HEX: 8B68
+CONSTANT: GL_FLOAT_MAT4x2 HEX: 8B69
+CONSTANT: GL_FLOAT_MAT4x3 HEX: 8B6A
GL-FUNCTION: void glUniformMatrix2x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix2x4fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
-! GL_EXT_framebuffer_object
-
-
-CONSTANT: GL_INVALID_FRAMEBUFFER_OPERATION_EXT HEX: 0506
-CONSTANT: GL_MAX_RENDERBUFFER_SIZE_EXT HEX: 84E8
-CONSTANT: GL_FRAMEBUFFER_BINDING_EXT HEX: 8CA6
-CONSTANT: GL_RENDERBUFFER_BINDING_EXT HEX: 8CA7
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT HEX: 8CD0
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT HEX: 8CD1
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT HEX: 8CD2
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT HEX: 8CD3
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT HEX: 8CD4
-CONSTANT: GL_FRAMEBUFFER_COMPLETE_EXT HEX: 8CD5
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT HEX: 8CD6
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT HEX: 8CD7
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT HEX: 8CDB
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT HEX: 8CDC
-CONSTANT: GL_FRAMEBUFFER_UNSUPPORTED_EXT HEX: 8CDD
-CONSTANT: GL_MAX_COLOR_ATTACHMENTS_EXT HEX: 8CDF
-CONSTANT: GL_COLOR_ATTACHMENT0_EXT HEX: 8CE0
-CONSTANT: GL_COLOR_ATTACHMENT1_EXT HEX: 8CE1
-CONSTANT: GL_COLOR_ATTACHMENT2_EXT HEX: 8CE2
-CONSTANT: GL_COLOR_ATTACHMENT3_EXT HEX: 8CE3
-CONSTANT: GL_COLOR_ATTACHMENT4_EXT HEX: 8CE4
-CONSTANT: GL_COLOR_ATTACHMENT5_EXT HEX: 8CE5
-CONSTANT: GL_COLOR_ATTACHMENT6_EXT HEX: 8CE6
-CONSTANT: GL_COLOR_ATTACHMENT7_EXT HEX: 8CE7
-CONSTANT: GL_COLOR_ATTACHMENT8_EXT HEX: 8CE8
-CONSTANT: GL_COLOR_ATTACHMENT9_EXT HEX: 8CE9
-CONSTANT: GL_COLOR_ATTACHMENT10_EXT HEX: 8CEA
-CONSTANT: GL_COLOR_ATTACHMENT11_EXT HEX: 8CEB
-CONSTANT: GL_COLOR_ATTACHMENT12_EXT HEX: 8CEC
-CONSTANT: GL_COLOR_ATTACHMENT13_EXT HEX: 8CED
-CONSTANT: GL_COLOR_ATTACHMENT14_EXT HEX: 8CEE
-CONSTANT: GL_COLOR_ATTACHMENT15_EXT HEX: 8CEF
-CONSTANT: GL_DEPTH_ATTACHMENT_EXT HEX: 8D00
-CONSTANT: GL_STENCIL_ATTACHMENT_EXT HEX: 8D20
-CONSTANT: GL_FRAMEBUFFER_EXT HEX: 8D40
-CONSTANT: GL_RENDERBUFFER_EXT HEX: 8D41
-CONSTANT: GL_RENDERBUFFER_WIDTH_EXT HEX: 8D42
-CONSTANT: GL_RENDERBUFFER_HEIGHT_EXT HEX: 8D43
-CONSTANT: GL_RENDERBUFFER_INTERNAL_FORMAT_EXT HEX: 8D44
-CONSTANT: GL_STENCIL_INDEX1_EXT HEX: 8D46
-CONSTANT: GL_STENCIL_INDEX4_EXT HEX: 8D47
-CONSTANT: GL_STENCIL_INDEX8_EXT HEX: 8D48
-CONSTANT: GL_STENCIL_INDEX16_EXT HEX: 8D49
-CONSTANT: GL_RENDERBUFFER_RED_SIZE_EXT HEX: 8D50
-CONSTANT: GL_RENDERBUFFER_GREEN_SIZE_EXT HEX: 8D51
-CONSTANT: GL_RENDERBUFFER_BLUE_SIZE_EXT HEX: 8D52
-CONSTANT: GL_RENDERBUFFER_ALPHA_SIZE_EXT HEX: 8D53
-CONSTANT: GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54
-CONSTANT: GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55
-
-GL-FUNCTION: void glBindFramebufferEXT { } ( GLenum target, GLuint framebuffer ) ;
-GL-FUNCTION: void glBindRenderbufferEXT { } ( GLenum target, GLuint renderbuffer ) ;
-GL-FUNCTION: GLenum glCheckFramebufferStatusEXT { } ( GLenum target ) ;
-GL-FUNCTION: void glDeleteFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ;
-GL-FUNCTION: void glDeleteRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ;
-GL-FUNCTION: void glFramebufferRenderbufferEXT { } ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ;
-GL-FUNCTION: void glFramebufferTexture1DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
-GL-FUNCTION: void glFramebufferTexture2DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
-GL-FUNCTION: void glFramebufferTexture3DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
-GL-FUNCTION: void glGenFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ;
-GL-FUNCTION: void glGenRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ;
-GL-FUNCTION: void glGenerateMipmapEXT { } ( GLenum target ) ;
-GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT { } ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glGetRenderbufferParameterivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
-GL-FUNCTION: GLboolean glIsFramebufferEXT { } ( GLuint framebuffer ) ;
-GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ;
-GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
-
-
-! GL_EXT_framebuffer_blit
-
-
-GL-FUNCTION: void glBlitFramebufferEXT { } ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1,
+! OpenGL 3.0
+
+
+TYPEDEF: ushort GLhalf
+
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER HEX: 88FD
+CONSTANT: GL_SAMPLER_CUBE_SHADOW HEX: 8DC5
+CONSTANT: GL_UNSIGNED_INT_VEC2 HEX: 8DC6
+CONSTANT: GL_UNSIGNED_INT_VEC3 HEX: 8DC7
+CONSTANT: GL_UNSIGNED_INT_VEC4 HEX: 8DC8
+CONSTANT: GL_INT_SAMPLER_1D HEX: 8DC9
+CONSTANT: GL_INT_SAMPLER_2D HEX: 8DCA
+CONSTANT: GL_INT_SAMPLER_3D HEX: 8DCB
+CONSTANT: GL_INT_SAMPLER_CUBE HEX: 8DCC
+CONSTANT: GL_INT_SAMPLER_2D_RECT HEX: 8DCD
+CONSTANT: GL_INT_SAMPLER_1D_ARRAY HEX: 8DCE
+CONSTANT: GL_INT_SAMPLER_2D_ARRAY HEX: 8DCF
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D HEX: 8DD1
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D HEX: 8DD2
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D HEX: 8DD3
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE HEX: 8DD4
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT HEX: 8DD5
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY HEX: 8DD6
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY HEX: 8DD7
+CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET HEX: 8904
+CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET HEX: 8905
+
+CONSTANT: GL_RGBA32F HEX: 8814
+CONSTANT: GL_RGB32F HEX: 8815
+CONSTANT: GL_RGBA16F HEX: 881A
+CONSTANT: GL_RGB16F HEX: 881B
+CONSTANT: GL_TEXTURE_RED_TYPE HEX: 8C10
+CONSTANT: GL_TEXTURE_GREEN_TYPE HEX: 8C11
+CONSTANT: GL_TEXTURE_BLUE_TYPE HEX: 8C12
+CONSTANT: GL_TEXTURE_ALPHA_TYPE HEX: 8C13
+CONSTANT: GL_TEXTURE_DEPTH_TYPE HEX: 8C16
+CONSTANT: GL_UNSIGNED_NORMALIZED HEX: 8C17
+
+CONSTANT: GL_QUERY_WAIT HEX: 8E13
+CONSTANT: GL_QUERY_NO_WAIT HEX: 8E14
+CONSTANT: GL_QUERY_BY_REGION_WAIT HEX: 8E15
+CONSTANT: GL_QUERY_BY_REGION_NO_WAIT HEX: 8E16
+
+CONSTANT: GL_HALF_FLOAT HEX: 140B
+
+CONSTANT: GL_MAP_READ_BIT HEX: 0001
+CONSTANT: GL_MAP_WRITE_BIT HEX: 0002
+CONSTANT: GL_MAP_INVALIDATE_RANGE_BIT HEX: 0004
+CONSTANT: GL_MAP_INVALIDATE_BUFFER_BIT HEX: 0008
+CONSTANT: GL_MAP_FLUSH_EXPLICIT_BIT HEX: 0010
+CONSTANT: GL_MAP_UNSYNCHRONIZED_BIT HEX: 0020
+
+CONSTANT: GL_R8 HEX: 8229
+CONSTANT: GL_R16 HEX: 822A
+CONSTANT: GL_RG8 HEX: 822B
+CONSTANT: GL_RG16 HEX: 822C
+CONSTANT: GL_R16F HEX: 822D
+CONSTANT: GL_R32F HEX: 822E
+CONSTANT: GL_RG16F HEX: 822F
+CONSTANT: GL_RG32F HEX: 8230
+CONSTANT: GL_R8I HEX: 8231
+CONSTANT: GL_R8UI HEX: 8232
+CONSTANT: GL_R16I HEX: 8233
+CONSTANT: GL_R16UI HEX: 8234
+CONSTANT: GL_R32I HEX: 8235
+CONSTANT: GL_R32UI HEX: 8236
+CONSTANT: GL_RG8I HEX: 8237
+CONSTANT: GL_RG8UI HEX: 8238
+CONSTANT: GL_RG16I HEX: 8239
+CONSTANT: GL_RG16UI HEX: 823A
+CONSTANT: GL_RG32I HEX: 823B
+CONSTANT: GL_RG32UI HEX: 823C
+CONSTANT: GL_RG HEX: 8227
+CONSTANT: GL_COMPRESSED_RED HEX: 8225
+CONSTANT: GL_COMPRESSED_RG HEX: 8226
+CONSTANT: GL_RG_INTEGER HEX: 8228
+
+CONSTANT: GL_VERTEX_ARRAY_BINDING HEX: 85B5
+
+CONSTANT: GL_CLAMP_READ_COLOR HEX: 891C
+CONSTANT: GL_FIXED_ONLY HEX: 891D
+
+CONSTANT: GL_DEPTH_COMPONENT32F HEX: 8CAC
+CONSTANT: GL_DEPTH32F_STENCIL8 HEX: 8CAD
+
+CONSTANT: GL_RGB9_E5 HEX: 8C3D
+CONSTANT: GL_UNSIGNED_INT_5_9_9_9_REV HEX: 8C3E
+CONSTANT: GL_TEXTURE_SHARED_SIZE HEX: 8C3F
+
+CONSTANT: GL_R11F_G11F_B10F HEX: 8C3A
+CONSTANT: GL_UNSIGNED_INT_10F_11F_11F_REV HEX: 8C3B
+
+CONSTANT: GL_INVALID_FRAMEBUFFER_OPERATION HEX: 0506
+CONSTANT: GL_MAX_RENDERBUFFER_SIZE HEX: 84E8
+CONSTANT: GL_FRAMEBUFFER_BINDING HEX: 8CA6
+CONSTANT: GL_RENDERBUFFER_BINDING HEX: 8CA7
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE HEX: 8CD0
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME HEX: 8CD1
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL HEX: 8CD2
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE HEX: 8CD3
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_COLOR_ENCODING HEX: 8210
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_COMPONENT_TYPE HEX: 8211
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_RED_SIZE HEX: 8212
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE HEX: 8213
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE HEX: 8214
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE HEX: 8215
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE HEX: 8216
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE HEX: 8217
+CONSTANT: GL_FRAMEBUFFER_DEFAULT HEX: 8218
+CONSTANT: GL_FRAMEBUFFER_UNDEFINED HEX: 8219
+CONSTANT: GL_DEPTH_STENCIL_ATTACHMENT HEX: 821A
+CONSTANT: GL_FRAMEBUFFER_COMPLETE HEX: 8CD5
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT HEX: 8CD6
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT HEX: 8CD7
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER HEX: 8CDB
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER HEX: 8CDC
+CONSTANT: GL_FRAMEBUFFER_UNSUPPORTED HEX: 8CDD
+CONSTANT: GL_MAX_COLOR_ATTACHMENTS HEX: 8CDF
+CONSTANT: GL_COLOR_ATTACHMENT0 HEX: 8CE0
+CONSTANT: GL_COLOR_ATTACHMENT1 HEX: 8CE1
+CONSTANT: GL_COLOR_ATTACHMENT2 HEX: 8CE2
+CONSTANT: GL_COLOR_ATTACHMENT3 HEX: 8CE3
+CONSTANT: GL_COLOR_ATTACHMENT4 HEX: 8CE4
+CONSTANT: GL_COLOR_ATTACHMENT5 HEX: 8CE5
+CONSTANT: GL_COLOR_ATTACHMENT6 HEX: 8CE6
+CONSTANT: GL_COLOR_ATTACHMENT7 HEX: 8CE7
+CONSTANT: GL_COLOR_ATTACHMENT8 HEX: 8CE8
+CONSTANT: GL_COLOR_ATTACHMENT9 HEX: 8CE9
+CONSTANT: GL_COLOR_ATTACHMENT10 HEX: 8CEA
+CONSTANT: GL_COLOR_ATTACHMENT11 HEX: 8CEB
+CONSTANT: GL_COLOR_ATTACHMENT12 HEX: 8CEC
+CONSTANT: GL_COLOR_ATTACHMENT13 HEX: 8CED
+CONSTANT: GL_COLOR_ATTACHMENT14 HEX: 8CEE
+CONSTANT: GL_COLOR_ATTACHMENT15 HEX: 8CEF
+CONSTANT: GL_DEPTH_ATTACHMENT HEX: 8D00
+CONSTANT: GL_STENCIL_ATTACHMENT HEX: 8D20
+CONSTANT: GL_FRAMEBUFFER HEX: 8D40
+CONSTANT: GL_RENDERBUFFER HEX: 8D41
+CONSTANT: GL_RENDERBUFFER_WIDTH HEX: 8D42
+CONSTANT: GL_RENDERBUFFER_HEIGHT HEX: 8D43
+CONSTANT: GL_RENDERBUFFER_INTERNAL_FORMAT HEX: 8D44
+CONSTANT: GL_STENCIL_INDEX1 HEX: 8D46
+CONSTANT: GL_STENCIL_INDEX4 HEX: 8D47
+CONSTANT: GL_STENCIL_INDEX8 HEX: 8D48
+CONSTANT: GL_STENCIL_INDEX16 HEX: 8D49
+CONSTANT: GL_RENDERBUFFER_RED_SIZE HEX: 8D50
+CONSTANT: GL_RENDERBUFFER_GREEN_SIZE HEX: 8D51
+CONSTANT: GL_RENDERBUFFER_BLUE_SIZE HEX: 8D52
+CONSTANT: GL_RENDERBUFFER_ALPHA_SIZE HEX: 8D53
+CONSTANT: GL_RENDERBUFFER_DEPTH_SIZE HEX: 8D54
+CONSTANT: GL_RENDERBUFFER_STENCIL_SIZE HEX: 8D55
+
+CONSTANT: GL_READ_FRAMEBUFFER HEX: 8CA8
+CONSTANT: GL_DRAW_FRAMEBUFFER HEX: 8CA9
+
+ALIAS: GL_DRAW_FRAMEBUFFER_BINDING GL_FRAMEBUFFER_BINDING
+CONSTANT: GL_READ_FRAMEBUFFER_BINDING HEX: 8CAA
+
+CONSTANT: GL_RENDERBUFFER_SAMPLES HEX: 8CAB
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE HEX: 8D56
+CONSTANT: GL_MAX_SAMPLES HEX: 8D57
+
+CONSTANT: GL_DEPTH_STENCIL HEX: 84F9
+CONSTANT: GL_UNSIGNED_INT_24_8 HEX: 84FA
+CONSTANT: GL_DEPTH24_STENCIL8 HEX: 88F0
+CONSTANT: GL_TEXTURE_STENCIL_SIZE HEX: 88F1
+
+CONSTANT: GL_RGBA32UI HEX: 8D70
+CONSTANT: GL_RGB32UI HEX: 8D71
+
+CONSTANT: GL_RGBA16UI HEX: 8D76
+CONSTANT: GL_RGB16UI HEX: 8D77
+
+CONSTANT: GL_RGBA8UI HEX: 8D7C
+CONSTANT: GL_RGB8UI HEX: 8D7D
+
+CONSTANT: GL_RGBA32I HEX: 8D82
+CONSTANT: GL_RGB32I HEX: 8D83
+
+CONSTANT: GL_RGBA16I HEX: 8D88
+CONSTANT: GL_RGB16I HEX: 8D89
+
+CONSTANT: GL_RGBA8I HEX: 8D8E
+CONSTANT: GL_RGB8I HEX: 8D8F
+
+CONSTANT: GL_RED_INTEGER HEX: 8D94
+CONSTANT: GL_GREEN_INTEGER HEX: 8D95
+CONSTANT: GL_BLUE_INTEGER HEX: 8D96
+CONSTANT: GL_RGB_INTEGER HEX: 8D98
+CONSTANT: GL_RGBA_INTEGER HEX: 8D99
+CONSTANT: GL_BGR_INTEGER HEX: 8D9A
+CONSTANT: GL_BGRA_INTEGER HEX: 8D9B
+
+CONSTANT: GL_FLOAT_32_UNSIGNED_INT_24_8_REV HEX: 8DAD
+
+CONSTANT: GL_TEXTURE_1D_ARRAY HEX: 8C18
+CONSTANT: GL_TEXTURE_2D_ARRAY HEX: 8C1A
+
+CONSTANT: GL_PROXY_TEXTURE_2D_ARRAY HEX: 8C1B
+
+CONSTANT: GL_PROXY_TEXTURE_1D_ARRAY HEX: 8C19
+
+CONSTANT: GL_TEXTURE_BINDING_1D_ARRAY HEX: 8C1C
+CONSTANT: GL_TEXTURE_BINDING_2D_ARRAY HEX: 8C1D
+CONSTANT: GL_MAX_ARRAY_TEXTURE_LAYERS HEX: 88FF
+
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER HEX: 8CD4
+
+CONSTANT: GL_SAMPLER_1D_ARRAY HEX: 8DC0
+CONSTANT: GL_SAMPLER_2D_ARRAY HEX: 8DC1
+CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW HEX: 8DC3
+CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW HEX: 8DC4
+
+CONSTANT: GL_COMPRESSED_RED_RGTC1 HEX: 8DBB
+CONSTANT: GL_COMPRESSED_SIGNED_RED_RGTC1 HEX: 8DBC
+CONSTANT: GL_COMPRESSED_RG_RGTC2 HEX: 8DBD
+CONSTANT: GL_COMPRESSED_SIGNED_RG_RGTC2 HEX: 8DBE
+
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER HEX: 8C8E
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START HEX: 8C84
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE HEX: 8C85
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING HEX: 8C8F
+CONSTANT: GL_INTERLEAVED_ATTRIBS HEX: 8C8C
+CONSTANT: GL_SEPARATE_ATTRIBS HEX: 8C8D
+CONSTANT: GL_PRIMITIVES_GENERATED HEX: 8C87
+CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN HEX: 8C88
+CONSTANT: GL_RASTERIZER_DISCARD HEX: 8C89
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS HEX: 8C8A
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS HEX: 8C8B
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS HEX: 8C80
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS HEX: 8C83
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE HEX: 8C7F
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH HEX: 8C76
+
+CONSTANT: GL_FRAMEBUFFER_SRGB HEX: 8DB9
+
+CONSTANT: GL_MAJOR_VERSION HEX: 821B
+CONSTANT: GL_MINOR_VERSION HEX: 821C
+CONSTANT: GL_NUM_EXTENSIONS HEX: 821D
+CONSTANT: GL_CONTEXT_FLAGS HEX: 821E
+CONSTANT: GL_INDEX HEX: 8222
+CONSTANT: GL_DEPTH_BUFFER HEX: 8223
+CONSTANT: GL_STENCIL_BUFFER HEX: 8224
+CONSTANT: GL_CONTEXT_FLAG_FORWARD_COMPATIBLE_BIT HEX: 0001
+
+ALIAS: GL_COMPARE_REF_TO_TEXTURE GL_COMPARE_R_TO_TEXTURE
+ALIAS: GL_MAX_VARYING_COMPONENTS GL_MAX_VARYING_FLOATS
+ALIAS: GL_MAX_CLIP_DISTANCES GL_MAX_CLIP_PLANES
+ALIAS: GL_CLIP_DISTANCE0 GL_CLIP_PLANE0
+ALIAS: GL_CLIP_DISTANCE1 GL_CLIP_PLANE1
+ALIAS: GL_CLIP_DISTANCE2 GL_CLIP_PLANE2
+ALIAS: GL_CLIP_DISTANCE3 GL_CLIP_PLANE3
+ALIAS: GL_CLIP_DISTANCE4 GL_CLIP_PLANE4
+ALIAS: GL_CLIP_DISTANCE5 GL_CLIP_PLANE5
+
+GL-FUNCTION: void glVertexAttribIPointer { glVertexAttribIPointerEXT } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ;
+
+GL-FUNCTION: void glGetVertexAttribIiv { glGetVertexAttribIivEXT } ( GLuint index, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetVertexAttribIuiv { glGetVertexAttribIuivEXT } ( GLuint index, GLenum pname, GLuint* params ) ;
+
+GL-FUNCTION: void glUniform1ui { glUniform1uiEXT } ( GLint location, GLuint v0 ) ;
+GL-FUNCTION: void glUniform2ui { glUniform2uiEXT } ( GLint location, GLuint v0, GLuint v1 ) ;
+GL-FUNCTION: void glUniform3ui { glUniform3uiEXT } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ;
+GL-FUNCTION: void glUniform4ui { glUniform4uiEXT } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ;
+
+GL-FUNCTION: void glUniform1uiv { glUniform1uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform2uiv { glUniform2uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform3uiv { glUniform3uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform4uiv { glUniform4uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+
+GL-FUNCTION: void glGetUniformuiv { glGetUniformuivEXT } ( GLuint program, GLint location, GLuint* params ) ;
+
+GL-FUNCTION: void glBindFragDataLocation { glBindFragDataLocationEXT } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
+GL-FUNCTION: GLint glGetFragDataLocation { glGetFragDataLocationEXT } ( GLuint program, GLchar* name ) ;
+
+GL-FUNCTION: void glBeginConditionalRender { glBeginConditionalRenderNV } ( GLuint id, GLenum mode ) ;
+GL-FUNCTION: void glEndConditionalRender { glEndConditionalRenderNV } ( ) ;
+
+GL-FUNCTION: void glBindVertexArray { glBindVertexArrayAPPLE } ( GLuint array ) ;
+GL-FUNCTION: void glDeleteVertexArrays { glDeleteVertexArraysAPPLE } ( GLsizei n, GLuint* arrays ) ;
+GL-FUNCTION: void glGenVertexArrays { glGenVertexArraysAPPLE } ( GLsizei n, GLuint* arrays ) ;
+GL-FUNCTION: GLboolean glIsVertexArray { glIsVertexArrayAPPLE } ( GLuint array ) ;
+
+GL-FUNCTION: void glClampColor { glClampColorARB } ( GLenum target, GLenum clamp ) ;
+
+GL-FUNCTION: void glBindFramebuffer { glBindFramebufferEXT } ( GLenum target, GLuint framebuffer ) ;
+GL-FUNCTION: void glBindRenderbuffer { glBindRenderbufferEXT } ( GLenum target, GLuint renderbuffer ) ;
+GL-FUNCTION: GLenum glCheckFramebufferStatus { glCheckFramebufferStatusEXT } ( GLenum target ) ;
+GL-FUNCTION: void glDeleteFramebuffers { glDeleteFramebuffersEXT } ( GLsizei n, GLuint* framebuffers ) ;
+GL-FUNCTION: void glDeleteRenderbuffers { glDeleteRenderbuffersEXT } ( GLsizei n, GLuint* renderbuffers ) ;
+GL-FUNCTION: void glFramebufferRenderbuffer { glFramebufferRenderbufferEXT } ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ;
+GL-FUNCTION: void glFramebufferTexture1D { glFramebufferTexture1DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTexture2D { glFramebufferTexture2DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTexture3D { glFramebufferTexture3DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
+GL-FUNCTION: void glFramebufferTextureLayer { glFramebufferTextureLayerEXT }
+ ( GLenum target, GLenum attachment,
+ GLuint texture, GLint level, GLint layer ) ;
+GL-FUNCTION: void glGenFramebuffers { glGenFramebuffersEXT } ( GLsizei n, GLuint* framebuffers ) ;
+GL-FUNCTION: void glGenRenderbuffers { glGenRenderbuffersEXT } ( GLsizei n, GLuint* renderbuffers ) ;
+GL-FUNCTION: void glGenerateMipmap { glGenerateMipmapEXT } ( GLenum target ) ;
+GL-FUNCTION: void glGetFramebufferAttachmentParameteriv { glGetFramebufferAttachmentParameterivEXT } ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetRenderbufferParameteriv { glGetRenderbufferParameterivEXT } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: GLboolean glIsFramebuffer { glIsFramebufferEXT } ( GLuint framebuffer ) ;
+GL-FUNCTION: GLboolean glIsRenderbuffer { glIsRenderbufferEXT } ( GLuint renderbuffer ) ;
+GL-FUNCTION: void glRenderbufferStorage { glRenderbufferStorageEXT } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
+
+GL-FUNCTION: void glBlitFramebuffer { glBlitFramebufferEXT }
+ ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1,
GLint dstX0, GLint dstY0, GLint dstX1, GLint dstY1,
GLbitfield mask, GLenum filter ) ;
-CONSTANT: GL_READ_FRAMEBUFFER_EXT HEX: 8CA8
-CONSTANT: GL_DRAW_FRAMEBUFFER_EXT HEX: 8CA9
+GL-FUNCTION: void glRenderbufferStorageMultisample { glRenderbufferStorageMultisampleEXT } (
+ GLenum target, GLsizei samples,
+ GLenum internalformat,
+ GLsizei width, GLsizei height ) ;
-ALIAS: GL_DRAW_FRAMEBUFFER_BINDING_EXT GL_FRAMEBUFFER_BINDING_EXT
-CONSTANT: GL_READ_FRAMEBUFFER_BINDING_EXT HEX: 8CAA
+GL-FUNCTION: void glTexParameterIiv { glTexParameterIivEXT } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glTexParameterIuiv { glTexParameterIuivEXT } ( GLenum target, GLenum pname, GLuint* params ) ;
+GL-FUNCTION: void glGetTexParameterIiv { glGetTexParameterIivEXT } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetTexParameterIuiv { glGetTexParameterIuivEXT } ( GLenum target, GLenum pname, GLuint* params ) ;
+GL-FUNCTION: void glColorMaski { glColorMaskIndexedEXT }
+ ( GLuint buf, GLboolean r, GLboolean g, GLboolean b, GLboolean a ) ;
-! GL_EXT_framebuffer_multisample
+GL-FUNCTION: void glGetBooleani_v { glGetBooleanIndexedvEXT } ( GLenum value, GLuint index, GLboolean* data ) ;
+GL-FUNCTION: void glGetIntegeri_v { glGetIntegerIndexedvEXT } ( GLenum value, GLuint index, GLint* data ) ;
-GL-FUNCTION: void glRenderbufferStorageMultisampleEXT { } (
- GLenum target, GLsizei samples,
- GLenum internalformat,
- GLsizei width, GLsizei height ) ;
+GL-FUNCTION: void glEnablei { glEnableIndexedEXT } ( GLenum target, GLuint index ) ;
-CONSTANT: GL_RENDERBUFFER_SAMPLES_EXT HEX: 8CAB
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56
-CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57
+GL-FUNCTION: void glDisablei { glDisableIndexedEXT } ( GLenum target, GLuint index ) ;
+GL-FUNCTION: GLboolean glIsEnabledi { glIsEnabledIndexedEXT } ( GLenum target, GLuint index ) ;
-! GL_ARB_texture_float
+GL-FUNCTION: void glBindBufferRange { glBindBufferRangeEXT } ( GLenum target, GLuint index, GLuint buffer,
+ GLintptr offset, GLsizeiptr size ) ;
+GL-FUNCTION: void glBindBufferBase { glBindBufferBaseEXT } ( GLenum target, GLuint index, GLuint buffer ) ;
+GL-FUNCTION: void glBeginTransformFeedback { glBeginTransformFeedbackEXT } ( GLenum primitiveMode ) ;
+GL-FUNCTION: void glEndTransformFeedback { glEndTransformFeedbackEXT } ( ) ;
-CONSTANT: GL_RGBA32F_ARB HEX: 8814
-CONSTANT: GL_RGB32F_ARB HEX: 8815
-CONSTANT: GL_ALPHA32F_ARB HEX: 8816
-CONSTANT: GL_INTENSITY32F_ARB HEX: 8817
-CONSTANT: GL_LUMINANCE32F_ARB HEX: 8818
-CONSTANT: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819
-CONSTANT: GL_RGBA16F_ARB HEX: 881A
-CONSTANT: GL_RGB16F_ARB HEX: 881B
-CONSTANT: GL_ALPHA16F_ARB HEX: 881C
-CONSTANT: GL_INTENSITY16F_ARB HEX: 881D
-CONSTANT: GL_LUMINANCE16F_ARB HEX: 881E
-CONSTANT: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F
-CONSTANT: GL_TEXTURE_RED_TYPE_ARB HEX: 8C10
-CONSTANT: GL_TEXTURE_GREEN_TYPE_ARB HEX: 8C11
-CONSTANT: GL_TEXTURE_BLUE_TYPE_ARB HEX: 8C12
-CONSTANT: GL_TEXTURE_ALPHA_TYPE_ARB HEX: 8C13
-CONSTANT: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14
-CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
-CONSTANT: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16
-CONSTANT: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17
-
-
-! GL_EXT_gpu_shader4
-
-
-GL-FUNCTION: void glVertexAttribI1iEXT { } ( GLuint index, GLint x ) ;
-GL-FUNCTION: void glVertexAttribI2iEXT { } ( GLuint index, GLint x, GLint y ) ;
-GL-FUNCTION: void glVertexAttribI3iEXT { } ( GLuint index, GLint x, GLint y, GLint z ) ;
-GL-FUNCTION: void glVertexAttribI4iEXT { } ( GLuint index, GLint x, GLint y, GLint z, GLint w ) ;
-
-GL-FUNCTION: void glVertexAttribI1uiEXT { } ( GLuint index, GLuint x ) ;
-GL-FUNCTION: void glVertexAttribI2uiEXT { } ( GLuint index, GLuint x, GLuint y ) ;
-GL-FUNCTION: void glVertexAttribI3uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z ) ;
-GL-FUNCTION: void glVertexAttribI4uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z, GLuint w ) ;
-
-GL-FUNCTION: void glVertexAttribI1ivEXT { } ( GLuint index, GLint* v ) ;
-GL-FUNCTION: void glVertexAttribI2ivEXT { } ( GLuint index, GLint* v ) ;
-GL-FUNCTION: void glVertexAttribI3ivEXT { } ( GLuint index, GLint* v ) ;
-GL-FUNCTION: void glVertexAttribI4ivEXT { } ( GLuint index, GLint* v ) ;
-
-GL-FUNCTION: void glVertexAttribI1uivEXT { } ( GLuint index, GLuint* v ) ;
-GL-FUNCTION: void glVertexAttribI2uivEXT { } ( GLuint index, GLuint* v ) ;
-GL-FUNCTION: void glVertexAttribI3uivEXT { } ( GLuint index, GLuint* v ) ;
-GL-FUNCTION: void glVertexAttribI4uivEXT { } ( GLuint index, GLuint* v ) ;
-
-GL-FUNCTION: void glVertexAttribI4bvEXT { } ( GLuint index, GLbyte* v ) ;
-GL-FUNCTION: void glVertexAttribI4svEXT { } ( GLuint index, GLshort* v ) ;
-GL-FUNCTION: void glVertexAttribI4ubvEXT { } ( GLuint index, GLubyte* v ) ;
-GL-FUNCTION: void glVertexAttribI4usvEXT { } ( GLuint index, GLushort* v ) ;
-
-GL-FUNCTION: void glVertexAttribIPointerEXT { } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ;
-
-GL-FUNCTION: void glGetVertexAttribIivEXT { } ( GLuint index, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glGetVertexAttribIuivEXT { } ( GLuint index, GLenum pname, GLuint* params ) ;
-
-GL-FUNCTION: void glUniform1uiEXT { } ( GLint location, GLuint v0 ) ;
-GL-FUNCTION: void glUniform2uiEXT { } ( GLint location, GLuint v0, GLuint v1 ) ;
-GL-FUNCTION: void glUniform3uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ;
-GL-FUNCTION: void glUniform4uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ;
-
-GL-FUNCTION: void glUniform1uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-GL-FUNCTION: void glUniform2uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-GL-FUNCTION: void glUniform3uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-
-GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
-
-GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
-GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
-
-CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
-CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
-CONSTANT: GL_SAMPLER_2D_ARRAY_EXT HEX: 8DC1
-CONSTANT: GL_SAMPLER_BUFFER_EXT HEX: 8DC2
-CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW_EXT HEX: 8DC3
-CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW_EXT HEX: 8DC4
-CONSTANT: GL_SAMPLER_CUBE_SHADOW_EXT HEX: 8DC5
-CONSTANT: GL_UNSIGNED_INT_VEC2_EXT HEX: 8DC6
-CONSTANT: GL_UNSIGNED_INT_VEC3_EXT HEX: 8DC7
-CONSTANT: GL_UNSIGNED_INT_VEC4_EXT HEX: 8DC8
-CONSTANT: GL_INT_SAMPLER_1D_EXT HEX: 8DC9
-CONSTANT: GL_INT_SAMPLER_2D_EXT HEX: 8DCA
-CONSTANT: GL_INT_SAMPLER_3D_EXT HEX: 8DCB
-CONSTANT: GL_INT_SAMPLER_CUBE_EXT HEX: 8DCC
-CONSTANT: GL_INT_SAMPLER_2D_RECT_EXT HEX: 8DCD
-CONSTANT: GL_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DCE
-CONSTANT: GL_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DCF
-CONSTANT: GL_INT_SAMPLER_BUFFER_EXT HEX: 8DD0
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_EXT HEX: 8DD1
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_EXT HEX: 8DD2
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D_EXT HEX: 8DD3
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE_EXT HEX: 8DD4
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT_EXT HEX: 8DD5
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DD6
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DD7
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER_EXT HEX: 8DD8
-CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET_EXT HEX: 8904
-CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET_EXT HEX: 8905
+GL-FUNCTION: void glTransformFeedbackVaryings { glTransformFeedbackVaryingsEXT } ( GLuint program, GLsizei count,
+ GLchar** varyings, GLenum bufferMode ) ;
+GL-FUNCTION: void glGetTransformFeedbackVarying { glGetTransformFeedbackVaryingEXT } ( GLuint program, GLuint index,
+ GLsizei bufSize, GLsizei* length,
+ GLsizei* size, GLenum* type, GLchar* name ) ;
+
+GL-FUNCTION: void glClearBufferiv { } ( GLenum buffer, GLint drawbuffer, GLint* value ) ;
+GL-FUNCTION: void glClearBufferuiv { } ( GLenum buffer, GLint drawbuffer, GLuint* value ) ;
+GL-FUNCTION: void glClearBufferfv { } ( GLenum buffer, GLint drawbuffer, GLfloat* value ) ;
+GL-FUNCTION: void glClearBufferfi { } ( GLenum buffer, GLint drawbuffer, GLfloat depth, GLint stencil ) ;
+
+GL-FUNCTION: GLubyte* glGetStringi { } ( GLenum value, GLuint index ) ;
+
+GL-FUNCTION: GLvoid* glMapBufferRange { } ( GLenum target, GLintptr offset, GLsizeiptr length, GLbitfield access ) ;
+GL-FUNCTION: void glFlushMappedBufferRange { glFlushMappedBufferRangeAPPLE } ( GLenum target, GLintptr offset, GLsizeiptr size ) ;
+
+
+! OpenGL 3.1
+
+CONSTANT: GL_RED_SNORM HEX: 8F90
+CONSTANT: GL_RG_SNORM HEX: 8F91
+CONSTANT: GL_RGB_SNORM HEX: 8F92
+CONSTANT: GL_RGBA_SNORM HEX: 8F93
+CONSTANT: GL_R8_SNORM HEX: 8F94
+CONSTANT: GL_RG8_SNORM HEX: 8F95
+CONSTANT: GL_RGB8_SNORM HEX: 8F96
+CONSTANT: GL_RGBA8_SNORM HEX: 8F97
+CONSTANT: GL_R16_SNORM HEX: 8F98
+CONSTANT: GL_RG16_SNORM HEX: 8F99
+CONSTANT: GL_RGB16_SNORM HEX: 8F9A
+CONSTANT: GL_RGBA16_SNORM HEX: 8F9B
+CONSTANT: GL_SIGNED_NORMALIZED HEX: 8F9C
+
+CONSTANT: GL_PRIMITIVE_RESTART HEX: 8F9D
+CONSTANT: GL_PRIMITIVE_RESTART_INDEX HEX: 8F9E
+
+CONSTANT: GL_COPY_READ_BUFFER HEX: 8F36
+CONSTANT: GL_COPY_WRITE_BUFFER HEX: 8F37
+
+CONSTANT: GL_UNIFORM_BUFFER HEX: 8A11
+CONSTANT: GL_UNIFORM_BUFFER_BINDING HEX: 8A28
+CONSTANT: GL_UNIFORM_BUFFER_START HEX: 8A29
+CONSTANT: GL_UNIFORM_BUFFER_SIZE HEX: 8A2A
+CONSTANT: GL_MAX_VERTEX_UNIFORM_BLOCKS HEX: 8A2B
+CONSTANT: GL_MAX_GEOMETRY_UNIFORM_BLOCKS HEX: 8A2C
+CONSTANT: GL_MAX_FRAGMENT_UNIFORM_BLOCKS HEX: 8A2D
+CONSTANT: GL_MAX_COMBINED_UNIFORM_BLOCKS HEX: 8A2E
+CONSTANT: GL_MAX_UNIFORM_BUFFER_BINDINGS HEX: 8A2F
+CONSTANT: GL_MAX_UNIFORM_BLOCK_SIZE HEX: 8A30
+CONSTANT: GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS HEX: 8A31
+CONSTANT: GL_MAX_COMBINED_GEOMETRY_UNIFORM_COMPONENTS HEX: 8A32
+CONSTANT: GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS HEX: 8A33
+CONSTANT: GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT HEX: 8A34
+CONSTANT: GL_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH HEX: 8A35
+CONSTANT: GL_ACTIVE_UNIFORM_BLOCKS HEX: 8A36
+CONSTANT: GL_UNIFORM_TYPE HEX: 8A37
+CONSTANT: GL_UNIFORM_SIZE HEX: 8A38
+CONSTANT: GL_UNIFORM_NAME_LENGTH HEX: 8A39
+CONSTANT: GL_UNIFORM_BLOCK_INDEX HEX: 8A3A
+CONSTANT: GL_UNIFORM_OFFSET HEX: 8A3B
+CONSTANT: GL_UNIFORM_ARRAY_STRIDE HEX: 8A3C
+CONSTANT: GL_UNIFORM_MATRIX_STRIDE HEX: 8A3D
+CONSTANT: GL_UNIFORM_IS_ROW_MAJOR HEX: 8A3E
+CONSTANT: GL_UNIFORM_BLOCK_BINDING HEX: 8A3F
+CONSTANT: GL_UNIFORM_BLOCK_DATA_SIZE HEX: 8A40
+CONSTANT: GL_UNIFORM_BLOCK_NAME_LENGTH HEX: 8A41
+CONSTANT: GL_UNIFORM_BLOCK_ACTIVE_UNIFORMS HEX: 8A42
+CONSTANT: GL_UNIFORM_BLOCK_ACTIVE_UNIFORM_INDICES HEX: 8A43
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER HEX: 8A44
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_GEOMETRY_SHADER HEX: 8A45
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER HEX: 8A46
+CONSTANT: GL_INVALID_INDEX HEX: FFFFFFFF
+
+CONSTANT: GL_TEXTURE_RECTANGLE HEX: 84F5
+CONSTANT: GL_TEXTURE_BINDING_RECTANGLE HEX: 84F6
+CONSTANT: GL_PROXY_TEXTURE_RECTANGLE HEX: 84F7
+CONSTANT: GL_MAX_RECTANGLE_TEXTURE_SIZE HEX: 84F8
+CONSTANT: GL_SAMPLER_2D_RECT HEX: 8B63
+CONSTANT: GL_SAMPLER_2D_RECT_SHADOW HEX: 8B64
+
+CONSTANT: GL_SAMPLER_BUFFER HEX: 8DC2
+CONSTANT: GL_INT_SAMPLER_BUFFER HEX: 8DD0
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER HEX: 8DD8
+
+CONSTANT: GL_TEXTURE_BUFFER HEX: 8C2A
+
+CONSTANT: GL_MAX_TEXTURE_BUFFER_SIZE HEX: 8C2B
+CONSTANT: GL_TEXTURE_BINDING_BUFFER HEX: 8C2C
+CONSTANT: GL_TEXTURE_BUFFER_DATA_STORE_BINDING HEX: 8C2D
+CONSTANT: GL_TEXTURE_BUFFER_FORMAT HEX: 8C2E
+
+GL-FUNCTION: void glDrawArraysInstanced { glDrawArraysInstancedARB } ( GLenum mode, GLint first, GLsizei count, GLsizei primcount ) ;
+GL-FUNCTION: void glDrawElementsInstanced { glDrawElementsInstancedARB } ( GLenum mode, GLsizei count, GLenum type, GLvoid* indices, GLsizei primcount ) ;
+GL-FUNCTION: void glTexBuffer { glTexBufferEXT } ( GLenum target, GLenum internalformat, GLuint buffer ) ;
+GL-FUNCTION: void glPrimitiveRestartIndex { } ( GLuint index ) ;
+
+GL-FUNCTION: void glGetUniformIndices { } ( GLuint program, GLsizei uniformCount, GLchar** uniformNames, GLuint* uniformIndices ) ;
+GL-FUNCTION: void glGetActiveUniformsiv { } ( GLuint program, GLsizei uniformCount, GLuint* uniformIndices, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetActiveUniformName { } ( GLuint program, GLuint uniformIndex, GLsizei bufSize, GLsizei* length, GLchar* uniformName ) ;
+GL-FUNCTION: GLuint glGetUniformBlockIndex { } ( GLuint program, GLchar* uniformBlockName ) ;
+GL-FUNCTION: void glGetActiveUniformBlockiv { } ( GLuint program, GLuint uniformBlockIndex, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetActiveUniformBlockName { } ( GLuint program, GLuint uniformBlockIndex, GLsizei bufSize, GLsizei* length, GLchar* uniformName ) ;
+GL-FUNCTION: void glUniformBlockBinding { } ( GLuint buffer, GLuint uniformBlockIndex, GLuint uniformBlockBinding ) ;
+
+GL-FUNCTION: void glCopyBufferSubData { glCopyBufferSubDataEXT } ( GLenum readtarget, GLenum writetarget, GLintptr readoffset, GLintptr writeoffset, GLsizeiptr size ) ;
! GL_EXT_geometry_shader4
GL-FUNCTION: void glProgramParameteriEXT { } ( GLuint program, GLenum pname, GLint value ) ;
GL-FUNCTION: void glFramebufferTextureEXT { } ( GLenum target, GLenum attachment,
GLuint texture, GLint level ) ;
-GL-FUNCTION: void glFramebufferTextureLayerEXT { } ( GLenum target, GLenum attachment,
- GLuint texture, GLint level, GLint layer ) ;
-GL-FUNCTION: void glFramebufferTextureFaceEXT { } ( GLenum target, GLenum attachment,
- GLuint texture, GLint level, GLenum face ) ;
CONSTANT: GL_GEOMETRY_SHADER_EXT HEX: 8DD9
CONSTANT: GL_GEOMETRY_VERTICES_OUT_EXT HEX: 8DDA
CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS_EXT HEX: 8C29
CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_EXT HEX: 8DDD
CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_EXT HEX: 8DDE
-CONSTANT: GL_MAX_VARYING_COMPONENTS_EXT HEX: 8B4B
CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS_EXT HEX: 8DDF
CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT HEX: 8DE0
CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS_EXT HEX: 8DE1
CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS_EXT HEX: 8DA8
CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_EXT HEX: 8DA9
CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED_EXT HEX: 8DA7
-ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER_EXT GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT
CONSTANT: GL_PROGRAM_POINT_SIZE_EXT HEX: 8642
-! GL_EXT_texture_integer
+! GL_EXT_framebuffer_object
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA
-GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
-GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
-GL-FUNCTION: void glTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
-GL-FUNCTION: void glGetTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glGetTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
+! GL_ARB_texture_float
+
+CONSTANT: GL_ALPHA32F_ARB HEX: 8816
+CONSTANT: GL_INTENSITY32F_ARB HEX: 8817
+CONSTANT: GL_LUMINANCE32F_ARB HEX: 8818
+CONSTANT: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819
+CONSTANT: GL_ALPHA16F_ARB HEX: 881C
+CONSTANT: GL_INTENSITY16F_ARB HEX: 881D
+CONSTANT: GL_LUMINANCE16F_ARB HEX: 881E
+CONSTANT: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F
+CONSTANT: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14
+CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
-CONSTANT: GL_RGBA_INTEGER_MODE_EXT HEX: 8D9E
+! GL_EXT_texture_integer
-CONSTANT: GL_RGBA32UI_EXT HEX: 8D70
-CONSTANT: GL_RGB32UI_EXT HEX: 8D71
CONSTANT: GL_ALPHA32UI_EXT HEX: 8D72
CONSTANT: GL_INTENSITY32UI_EXT HEX: 8D73
CONSTANT: GL_LUMINANCE32UI_EXT HEX: 8D74
CONSTANT: GL_LUMINANCE_ALPHA32UI_EXT HEX: 8D75
-CONSTANT: GL_RGBA16UI_EXT HEX: 8D76
-CONSTANT: GL_RGB16UI_EXT HEX: 8D77
CONSTANT: GL_ALPHA16UI_EXT HEX: 8D78
CONSTANT: GL_INTENSITY16UI_EXT HEX: 8D79
CONSTANT: GL_LUMINANCE16UI_EXT HEX: 8D7A
CONSTANT: GL_LUMINANCE_ALPHA16UI_EXT HEX: 8D7B
-CONSTANT: GL_RGBA8UI_EXT HEX: 8D7C
-CONSTANT: GL_RGB8UI_EXT HEX: 8D7D
CONSTANT: GL_ALPHA8UI_EXT HEX: 8D7E
CONSTANT: GL_INTENSITY8UI_EXT HEX: 8D7F
CONSTANT: GL_LUMINANCE8UI_EXT HEX: 8D80
CONSTANT: GL_LUMINANCE_ALPHA8UI_EXT HEX: 8D81
-CONSTANT: GL_RGBA32I_EXT HEX: 8D82
-CONSTANT: GL_RGB32I_EXT HEX: 8D83
CONSTANT: GL_ALPHA32I_EXT HEX: 8D84
CONSTANT: GL_INTENSITY32I_EXT HEX: 8D85
CONSTANT: GL_LUMINANCE32I_EXT HEX: 8D86
CONSTANT: GL_LUMINANCE_ALPHA32I_EXT HEX: 8D87
-CONSTANT: GL_RGBA16I_EXT HEX: 8D88
-CONSTANT: GL_RGB16I_EXT HEX: 8D89
CONSTANT: GL_ALPHA16I_EXT HEX: 8D8A
CONSTANT: GL_INTENSITY16I_EXT HEX: 8D8B
CONSTANT: GL_LUMINANCE16I_EXT HEX: 8D8C
CONSTANT: GL_LUMINANCE_ALPHA16I_EXT HEX: 8D8D
-CONSTANT: GL_RGBA8I_EXT HEX: 8D8E
-CONSTANT: GL_RGB8I_EXT HEX: 8D8F
CONSTANT: GL_ALPHA8I_EXT HEX: 8D90
CONSTANT: GL_INTENSITY8I_EXT HEX: 8D91
CONSTANT: GL_LUMINANCE8I_EXT HEX: 8D92
CONSTANT: GL_LUMINANCE_ALPHA8I_EXT HEX: 8D93
-CONSTANT: GL_RED_INTEGER_EXT HEX: 8D94
-CONSTANT: GL_GREEN_INTEGER_EXT HEX: 8D95
-CONSTANT: GL_BLUE_INTEGER_EXT HEX: 8D96
CONSTANT: GL_ALPHA_INTEGER_EXT HEX: 8D97
-CONSTANT: GL_RGB_INTEGER_EXT HEX: 8D98
-CONSTANT: GL_RGBA_INTEGER_EXT HEX: 8D99
-CONSTANT: GL_BGR_INTEGER_EXT HEX: 8D9A
-CONSTANT: GL_BGRA_INTEGER_EXT HEX: 8D9B
-CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C
-CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D
-
-
-! GL_EXT_transform_feedback
-
-
-GL-FUNCTION: void glBindBufferRangeEXT { } ( GLenum target, GLuint index, GLuint buffer,
- GLintptr offset, GLsizeiptr size ) ;
-GL-FUNCTION: void glBindBufferOffsetEXT { } ( GLenum target, GLuint index, GLuint buffer,
- GLintptr offset ) ;
-GL-FUNCTION: void glBindBufferBaseEXT { } ( GLenum target, GLuint index, GLuint buffer ) ;
-
-GL-FUNCTION: void glBeginTransformFeedbackEXT { } ( GLenum primitiveMode ) ;
-GL-FUNCTION: void glEndTransformFeedbackEXT { } ( ) ;
-
-GL-FUNCTION: void glTransformFeedbackVaryingsEXT { } ( GLuint program, GLsizei count,
- GLchar** varyings, GLenum bufferMode ) ;
-GL-FUNCTION: void glGetTransformFeedbackVaryingEXT { } ( GLuint program, GLuint index,
- GLsizei bufSize, GLsizei* length,
- GLsizei* size, GLenum* type, GLchar* name ) ;
+CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C
+CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D
-GL-FUNCTION: void glGetIntegerIndexedvEXT { } ( GLenum param, GLuint index, GLint* values ) ;
-GL-FUNCTION: void glGetBooleanIndexedvEXT { } ( GLenum param, GLuint index, GLboolean* values ) ;
-
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_EXT HEX: 8C8E
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START_EXT HEX: 8C84
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE_EXT HEX: 8C85
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING_EXT HEX: 8C8F
-CONSTANT: GL_INTERLEAVED_ATTRIBS_EXT HEX: 8C8C
-CONSTANT: GL_SEPARATE_ATTRIBS_EXT HEX: 8C8D
-CONSTANT: GL_PRIMITIVES_GENERATED_EXT HEX: 8C87
-CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN_EXT HEX: 8C88
-CONSTANT: GL_RASTERIZER_DISCARD_EXT HEX: 8C89
-CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS_EXT HEX: 8C8A
-CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS_EXT HEX: 8C8B
-CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS_EXT HEX: 8C80
-CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS_EXT HEX: 8C83
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE_EXT HEX: 8C7F
-CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH_EXT HEX: 8C76
+GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
+GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+! This vocab only exports forward-compatible OpenGL 3.x symbols.
+! For legacy OpenGL and extensions, use opengl.gl
+
+QUALIFIED-WITH: opengl.gl gl
+IN: opengl.gl3
+
+ALIAS: GL_DEPTH_BUFFER_BIT gl:GL_DEPTH_BUFFER_BIT
+ALIAS: GL_STENCIL_BUFFER_BIT gl:GL_STENCIL_BUFFER_BIT
+ALIAS: GL_COLOR_BUFFER_BIT gl:GL_COLOR_BUFFER_BIT
+ALIAS: GL_FALSE gl:GL_FALSE
+ALIAS: GL_TRUE gl:GL_TRUE
+ALIAS: GL_POINTS gl:GL_POINTS
+ALIAS: GL_LINES gl:GL_LINES
+ALIAS: GL_LINE_LOOP gl:GL_LINE_LOOP
+ALIAS: GL_LINE_STRIP gl:GL_LINE_STRIP
+ALIAS: GL_TRIANGLES gl:GL_TRIANGLES
+ALIAS: GL_TRIANGLE_STRIP gl:GL_TRIANGLE_STRIP
+ALIAS: GL_TRIANGLE_FAN gl:GL_TRIANGLE_FAN
+ALIAS: GL_NEVER gl:GL_NEVER
+ALIAS: GL_LESS gl:GL_LESS
+ALIAS: GL_EQUAL gl:GL_EQUAL
+ALIAS: GL_LEQUAL gl:GL_LEQUAL
+ALIAS: GL_GREATER gl:GL_GREATER
+ALIAS: GL_NOTEQUAL gl:GL_NOTEQUAL
+ALIAS: GL_GEQUAL gl:GL_GEQUAL
+ALIAS: GL_ALWAYS gl:GL_ALWAYS
+ALIAS: GL_ZERO gl:GL_ZERO
+ALIAS: GL_ONE gl:GL_ONE
+ALIAS: GL_SRC_COLOR gl:GL_SRC_COLOR
+ALIAS: GL_ONE_MINUS_SRC_COLOR gl:GL_ONE_MINUS_SRC_COLOR
+ALIAS: GL_SRC_ALPHA gl:GL_SRC_ALPHA
+ALIAS: GL_ONE_MINUS_SRC_ALPHA gl:GL_ONE_MINUS_SRC_ALPHA
+ALIAS: GL_DST_ALPHA gl:GL_DST_ALPHA
+ALIAS: GL_ONE_MINUS_DST_ALPHA gl:GL_ONE_MINUS_DST_ALPHA
+ALIAS: GL_DST_COLOR gl:GL_DST_COLOR
+ALIAS: GL_ONE_MINUS_DST_COLOR gl:GL_ONE_MINUS_DST_COLOR
+ALIAS: GL_SRC_ALPHA_SATURATE gl:GL_SRC_ALPHA_SATURATE
+ALIAS: GL_NONE gl:GL_NONE
+ALIAS: GL_FRONT_LEFT gl:GL_FRONT_LEFT
+ALIAS: GL_FRONT_RIGHT gl:GL_FRONT_RIGHT
+ALIAS: GL_BACK_LEFT gl:GL_BACK_LEFT
+ALIAS: GL_BACK_RIGHT gl:GL_BACK_RIGHT
+ALIAS: GL_FRONT gl:GL_FRONT
+ALIAS: GL_BACK gl:GL_BACK
+ALIAS: GL_LEFT gl:GL_LEFT
+ALIAS: GL_RIGHT gl:GL_RIGHT
+ALIAS: GL_FRONT_AND_BACK gl:GL_FRONT_AND_BACK
+ALIAS: GL_NO_ERROR gl:GL_NO_ERROR
+ALIAS: GL_INVALID_ENUM gl:GL_INVALID_ENUM
+ALIAS: GL_INVALID_VALUE gl:GL_INVALID_VALUE
+ALIAS: GL_INVALID_OPERATION gl:GL_INVALID_OPERATION
+ALIAS: GL_OUT_OF_MEMORY gl:GL_OUT_OF_MEMORY
+ALIAS: GL_CW gl:GL_CW
+ALIAS: GL_CCW gl:GL_CCW
+ALIAS: GL_POINT_SIZE gl:GL_POINT_SIZE
+ALIAS: GL_POINT_SIZE_RANGE gl:GL_POINT_SIZE_RANGE
+ALIAS: GL_POINT_SIZE_GRANULARITY gl:GL_POINT_SIZE_GRANULARITY
+ALIAS: GL_LINE_SMOOTH gl:GL_LINE_SMOOTH
+ALIAS: GL_LINE_WIDTH gl:GL_LINE_WIDTH
+ALIAS: GL_LINE_WIDTH_RANGE gl:GL_LINE_WIDTH_RANGE
+ALIAS: GL_LINE_WIDTH_GRANULARITY gl:GL_LINE_WIDTH_GRANULARITY
+ALIAS: GL_POLYGON_SMOOTH gl:GL_POLYGON_SMOOTH
+ALIAS: GL_CULL_FACE gl:GL_CULL_FACE
+ALIAS: GL_CULL_FACE_MODE gl:GL_CULL_FACE_MODE
+ALIAS: GL_FRONT_FACE gl:GL_FRONT_FACE
+ALIAS: GL_DEPTH_RANGE gl:GL_DEPTH_RANGE
+ALIAS: GL_DEPTH_TEST gl:GL_DEPTH_TEST
+ALIAS: GL_DEPTH_WRITEMASK gl:GL_DEPTH_WRITEMASK
+ALIAS: GL_DEPTH_CLEAR_VALUE gl:GL_DEPTH_CLEAR_VALUE
+ALIAS: GL_DEPTH_FUNC gl:GL_DEPTH_FUNC
+ALIAS: GL_STENCIL_TEST gl:GL_STENCIL_TEST
+ALIAS: GL_STENCIL_CLEAR_VALUE gl:GL_STENCIL_CLEAR_VALUE
+ALIAS: GL_STENCIL_FUNC gl:GL_STENCIL_FUNC
+ALIAS: GL_STENCIL_VALUE_MASK gl:GL_STENCIL_VALUE_MASK
+ALIAS: GL_STENCIL_FAIL gl:GL_STENCIL_FAIL
+ALIAS: GL_STENCIL_PASS_DEPTH_FAIL gl:GL_STENCIL_PASS_DEPTH_FAIL
+ALIAS: GL_STENCIL_PASS_DEPTH_PASS gl:GL_STENCIL_PASS_DEPTH_PASS
+ALIAS: GL_STENCIL_REF gl:GL_STENCIL_REF
+ALIAS: GL_STENCIL_WRITEMASK gl:GL_STENCIL_WRITEMASK
+ALIAS: GL_VIEWPORT gl:GL_VIEWPORT
+ALIAS: GL_DITHER gl:GL_DITHER
+ALIAS: GL_BLEND_DST gl:GL_BLEND_DST
+ALIAS: GL_BLEND_SRC gl:GL_BLEND_SRC
+ALIAS: GL_BLEND gl:GL_BLEND
+ALIAS: GL_LOGIC_OP_MODE gl:GL_LOGIC_OP_MODE
+ALIAS: GL_COLOR_LOGIC_OP gl:GL_COLOR_LOGIC_OP
+ALIAS: GL_DRAW_BUFFER gl:GL_DRAW_BUFFER
+ALIAS: GL_READ_BUFFER gl:GL_READ_BUFFER
+ALIAS: GL_SCISSOR_BOX gl:GL_SCISSOR_BOX
+ALIAS: GL_SCISSOR_TEST gl:GL_SCISSOR_TEST
+ALIAS: GL_COLOR_CLEAR_VALUE gl:GL_COLOR_CLEAR_VALUE
+ALIAS: GL_COLOR_WRITEMASK gl:GL_COLOR_WRITEMASK
+ALIAS: GL_DOUBLEBUFFER gl:GL_DOUBLEBUFFER
+ALIAS: GL_STEREO gl:GL_STEREO
+ALIAS: GL_LINE_SMOOTH_HINT gl:GL_LINE_SMOOTH_HINT
+ALIAS: GL_POLYGON_SMOOTH_HINT gl:GL_POLYGON_SMOOTH_HINT
+ALIAS: GL_UNPACK_SWAP_BYTES gl:GL_UNPACK_SWAP_BYTES
+ALIAS: GL_UNPACK_LSB_FIRST gl:GL_UNPACK_LSB_FIRST
+ALIAS: GL_UNPACK_ROW_LENGTH gl:GL_UNPACK_ROW_LENGTH
+ALIAS: GL_UNPACK_SKIP_ROWS gl:GL_UNPACK_SKIP_ROWS
+ALIAS: GL_UNPACK_SKIP_PIXELS gl:GL_UNPACK_SKIP_PIXELS
+ALIAS: GL_UNPACK_ALIGNMENT gl:GL_UNPACK_ALIGNMENT
+ALIAS: GL_PACK_SWAP_BYTES gl:GL_PACK_SWAP_BYTES
+ALIAS: GL_PACK_LSB_FIRST gl:GL_PACK_LSB_FIRST
+ALIAS: GL_PACK_ROW_LENGTH gl:GL_PACK_ROW_LENGTH
+ALIAS: GL_PACK_SKIP_ROWS gl:GL_PACK_SKIP_ROWS
+ALIAS: GL_PACK_SKIP_PIXELS gl:GL_PACK_SKIP_PIXELS
+ALIAS: GL_PACK_ALIGNMENT gl:GL_PACK_ALIGNMENT
+ALIAS: GL_MAX_TEXTURE_SIZE gl:GL_MAX_TEXTURE_SIZE
+ALIAS: GL_MAX_VIEWPORT_DIMS gl:GL_MAX_VIEWPORT_DIMS
+ALIAS: GL_SUBPIXEL_BITS gl:GL_SUBPIXEL_BITS
+ALIAS: GL_TEXTURE_1D gl:GL_TEXTURE_1D
+ALIAS: GL_TEXTURE_2D gl:GL_TEXTURE_2D
+ALIAS: GL_POLYGON_OFFSET_UNITS gl:GL_POLYGON_OFFSET_UNITS
+ALIAS: GL_POLYGON_OFFSET_POINT gl:GL_POLYGON_OFFSET_POINT
+ALIAS: GL_POLYGON_OFFSET_LINE gl:GL_POLYGON_OFFSET_LINE
+ALIAS: GL_POLYGON_OFFSET_FILL gl:GL_POLYGON_OFFSET_FILL
+ALIAS: GL_POLYGON_OFFSET_FACTOR gl:GL_POLYGON_OFFSET_FACTOR
+ALIAS: GL_TEXTURE_BINDING_1D gl:GL_TEXTURE_BINDING_1D
+ALIAS: GL_TEXTURE_BINDING_2D gl:GL_TEXTURE_BINDING_2D
+ALIAS: GL_TEXTURE_WIDTH gl:GL_TEXTURE_WIDTH
+ALIAS: GL_TEXTURE_HEIGHT gl:GL_TEXTURE_HEIGHT
+ALIAS: GL_TEXTURE_INTERNAL_FORMAT gl:GL_TEXTURE_INTERNAL_FORMAT
+ALIAS: GL_TEXTURE_BORDER_COLOR gl:GL_TEXTURE_BORDER_COLOR
+ALIAS: GL_TEXTURE_BORDER gl:GL_TEXTURE_BORDER
+ALIAS: GL_TEXTURE_RED_SIZE gl:GL_TEXTURE_RED_SIZE
+ALIAS: GL_TEXTURE_GREEN_SIZE gl:GL_TEXTURE_GREEN_SIZE
+ALIAS: GL_TEXTURE_BLUE_SIZE gl:GL_TEXTURE_BLUE_SIZE
+ALIAS: GL_TEXTURE_ALPHA_SIZE gl:GL_TEXTURE_ALPHA_SIZE
+ALIAS: GL_DONT_CARE gl:GL_DONT_CARE
+ALIAS: GL_FASTEST gl:GL_FASTEST
+ALIAS: GL_NICEST gl:GL_NICEST
+ALIAS: GL_BYTE gl:GL_BYTE
+ALIAS: GL_UNSIGNED_BYTE gl:GL_UNSIGNED_BYTE
+ALIAS: GL_SHORT gl:GL_SHORT
+ALIAS: GL_UNSIGNED_SHORT gl:GL_UNSIGNED_SHORT
+ALIAS: GL_INT gl:GL_INT
+ALIAS: GL_UNSIGNED_INT gl:GL_UNSIGNED_INT
+ALIAS: GL_FLOAT gl:GL_FLOAT
+ALIAS: GL_DOUBLE gl:GL_DOUBLE
+ALIAS: GL_CLEAR gl:GL_CLEAR
+ALIAS: GL_AND gl:GL_AND
+ALIAS: GL_AND_REVERSE gl:GL_AND_REVERSE
+ALIAS: GL_COPY gl:GL_COPY
+ALIAS: GL_AND_INVERTED gl:GL_AND_INVERTED
+ALIAS: GL_NOOP gl:GL_NOOP
+ALIAS: GL_XOR gl:GL_XOR
+ALIAS: GL_OR gl:GL_OR
+ALIAS: GL_NOR gl:GL_NOR
+ALIAS: GL_EQUIV gl:GL_EQUIV
+ALIAS: GL_INVERT gl:GL_INVERT
+ALIAS: GL_OR_REVERSE gl:GL_OR_REVERSE
+ALIAS: GL_COPY_INVERTED gl:GL_COPY_INVERTED
+ALIAS: GL_OR_INVERTED gl:GL_OR_INVERTED
+ALIAS: GL_NAND gl:GL_NAND
+ALIAS: GL_SET gl:GL_SET
+ALIAS: GL_TEXTURE gl:GL_TEXTURE
+ALIAS: GL_COLOR gl:GL_COLOR
+ALIAS: GL_DEPTH gl:GL_DEPTH
+ALIAS: GL_STENCIL gl:GL_STENCIL
+ALIAS: GL_STENCIL_INDEX gl:GL_STENCIL_INDEX
+ALIAS: GL_DEPTH_COMPONENT gl:GL_DEPTH_COMPONENT
+ALIAS: GL_RED gl:GL_RED
+ALIAS: GL_GREEN gl:GL_GREEN
+ALIAS: GL_BLUE gl:GL_BLUE
+ALIAS: GL_ALPHA gl:GL_ALPHA
+ALIAS: GL_RGB gl:GL_RGB
+ALIAS: GL_RGBA gl:GL_RGBA
+ALIAS: GL_POINT gl:GL_POINT
+ALIAS: GL_LINE gl:GL_LINE
+ALIAS: GL_FILL gl:GL_FILL
+ALIAS: GL_KEEP gl:GL_KEEP
+ALIAS: GL_REPLACE gl:GL_REPLACE
+ALIAS: GL_INCR gl:GL_INCR
+ALIAS: GL_DECR gl:GL_DECR
+ALIAS: GL_VENDOR gl:GL_VENDOR
+ALIAS: GL_RENDERER gl:GL_RENDERER
+ALIAS: GL_VERSION gl:GL_VERSION
+ALIAS: GL_EXTENSIONS gl:GL_EXTENSIONS
+ALIAS: GL_NEAREST gl:GL_NEAREST
+ALIAS: GL_LINEAR gl:GL_LINEAR
+ALIAS: GL_NEAREST_MIPMAP_NEAREST gl:GL_NEAREST_MIPMAP_NEAREST
+ALIAS: GL_LINEAR_MIPMAP_NEAREST gl:GL_LINEAR_MIPMAP_NEAREST
+ALIAS: GL_NEAREST_MIPMAP_LINEAR gl:GL_NEAREST_MIPMAP_LINEAR
+ALIAS: GL_LINEAR_MIPMAP_LINEAR gl:GL_LINEAR_MIPMAP_LINEAR
+ALIAS: GL_TEXTURE_MAG_FILTER gl:GL_TEXTURE_MAG_FILTER
+ALIAS: GL_TEXTURE_MIN_FILTER gl:GL_TEXTURE_MIN_FILTER
+ALIAS: GL_TEXTURE_WRAP_S gl:GL_TEXTURE_WRAP_S
+ALIAS: GL_TEXTURE_WRAP_T gl:GL_TEXTURE_WRAP_T
+ALIAS: GL_PROXY_TEXTURE_1D gl:GL_PROXY_TEXTURE_1D
+ALIAS: GL_PROXY_TEXTURE_2D gl:GL_PROXY_TEXTURE_2D
+ALIAS: GL_REPEAT gl:GL_REPEAT
+ALIAS: GL_R3_G3_B2 gl:GL_R3_G3_B2
+ALIAS: GL_RGB4 gl:GL_RGB4
+ALIAS: GL_RGB5 gl:GL_RGB5
+ALIAS: GL_RGB8 gl:GL_RGB8
+ALIAS: GL_RGB10 gl:GL_RGB10
+ALIAS: GL_RGB12 gl:GL_RGB12
+ALIAS: GL_RGB16 gl:GL_RGB16
+ALIAS: GL_RGBA2 gl:GL_RGBA2
+ALIAS: GL_RGBA4 gl:GL_RGBA4
+ALIAS: GL_RGB5_A1 gl:GL_RGB5_A1
+ALIAS: GL_RGBA8 gl:GL_RGBA8
+ALIAS: GL_RGB10_A2 gl:GL_RGB10_A2
+ALIAS: GL_RGBA12 gl:GL_RGBA12
+ALIAS: GL_RGBA16 gl:GL_RGBA16
+ALIAS: GL_UNSIGNED_BYTE_3_3_2 gl:GL_UNSIGNED_BYTE_3_3_2
+ALIAS: GL_UNSIGNED_SHORT_4_4_4_4 gl:GL_UNSIGNED_SHORT_4_4_4_4
+ALIAS: GL_UNSIGNED_SHORT_5_5_5_1 gl:GL_UNSIGNED_SHORT_5_5_5_1
+ALIAS: GL_UNSIGNED_INT_8_8_8_8 gl:GL_UNSIGNED_INT_8_8_8_8
+ALIAS: GL_UNSIGNED_INT_10_10_10_2 gl:GL_UNSIGNED_INT_10_10_10_2
+ALIAS: GL_TEXTURE_BINDING_3D gl:GL_TEXTURE_BINDING_3D
+ALIAS: GL_PACK_SKIP_IMAGES gl:GL_PACK_SKIP_IMAGES
+ALIAS: GL_PACK_IMAGE_HEIGHT gl:GL_PACK_IMAGE_HEIGHT
+ALIAS: GL_UNPACK_SKIP_IMAGES gl:GL_UNPACK_SKIP_IMAGES
+ALIAS: GL_UNPACK_IMAGE_HEIGHT gl:GL_UNPACK_IMAGE_HEIGHT
+ALIAS: GL_TEXTURE_3D gl:GL_TEXTURE_3D
+ALIAS: GL_PROXY_TEXTURE_3D gl:GL_PROXY_TEXTURE_3D
+ALIAS: GL_TEXTURE_DEPTH gl:GL_TEXTURE_DEPTH
+ALIAS: GL_TEXTURE_WRAP_R gl:GL_TEXTURE_WRAP_R
+ALIAS: GL_MAX_3D_TEXTURE_SIZE gl:GL_MAX_3D_TEXTURE_SIZE
+ALIAS: GL_UNSIGNED_BYTE_2_3_3_REV gl:GL_UNSIGNED_BYTE_2_3_3_REV
+ALIAS: GL_UNSIGNED_SHORT_5_6_5 gl:GL_UNSIGNED_SHORT_5_6_5
+ALIAS: GL_UNSIGNED_SHORT_5_6_5_REV gl:GL_UNSIGNED_SHORT_5_6_5_REV
+ALIAS: GL_UNSIGNED_SHORT_4_4_4_4_REV gl:GL_UNSIGNED_SHORT_4_4_4_4_REV
+ALIAS: GL_UNSIGNED_SHORT_1_5_5_5_REV gl:GL_UNSIGNED_SHORT_1_5_5_5_REV
+ALIAS: GL_UNSIGNED_INT_8_8_8_8_REV gl:GL_UNSIGNED_INT_8_8_8_8_REV
+ALIAS: GL_UNSIGNED_INT_2_10_10_10_REV gl:GL_UNSIGNED_INT_2_10_10_10_REV
+ALIAS: GL_BGR gl:GL_BGR
+ALIAS: GL_BGRA gl:GL_BGRA
+ALIAS: GL_MAX_ELEMENTS_VERTICES gl:GL_MAX_ELEMENTS_VERTICES
+ALIAS: GL_MAX_ELEMENTS_INDICES gl:GL_MAX_ELEMENTS_INDICES
+ALIAS: GL_CLAMP_TO_EDGE gl:GL_CLAMP_TO_EDGE
+ALIAS: GL_TEXTURE_MIN_LOD gl:GL_TEXTURE_MIN_LOD
+ALIAS: GL_TEXTURE_MAX_LOD gl:GL_TEXTURE_MAX_LOD
+ALIAS: GL_TEXTURE_BASE_LEVEL gl:GL_TEXTURE_BASE_LEVEL
+ALIAS: GL_TEXTURE_MAX_LEVEL gl:GL_TEXTURE_MAX_LEVEL
+ALIAS: GL_SMOOTH_POINT_SIZE_RANGE gl:GL_SMOOTH_POINT_SIZE_RANGE
+ALIAS: GL_SMOOTH_POINT_SIZE_GRANULARITY gl:GL_SMOOTH_POINT_SIZE_GRANULARITY
+ALIAS: GL_SMOOTH_LINE_WIDTH_RANGE gl:GL_SMOOTH_LINE_WIDTH_RANGE
+ALIAS: GL_SMOOTH_LINE_WIDTH_GRANULARITY gl:GL_SMOOTH_LINE_WIDTH_GRANULARITY
+ALIAS: GL_ALIASED_LINE_WIDTH_RANGE gl:GL_ALIASED_LINE_WIDTH_RANGE
+ALIAS: GL_CONSTANT_COLOR gl:GL_CONSTANT_COLOR
+ALIAS: GL_ONE_MINUS_CONSTANT_COLOR gl:GL_ONE_MINUS_CONSTANT_COLOR
+ALIAS: GL_CONSTANT_ALPHA gl:GL_CONSTANT_ALPHA
+ALIAS: GL_ONE_MINUS_CONSTANT_ALPHA gl:GL_ONE_MINUS_CONSTANT_ALPHA
+ALIAS: GL_BLEND_COLOR gl:GL_BLEND_COLOR
+ALIAS: GL_FUNC_ADD gl:GL_FUNC_ADD
+ALIAS: GL_MIN gl:GL_MIN
+ALIAS: GL_MAX gl:GL_MAX
+ALIAS: GL_BLEND_EQUATION gl:GL_BLEND_EQUATION
+ALIAS: GL_FUNC_SUBTRACT gl:GL_FUNC_SUBTRACT
+ALIAS: GL_FUNC_REVERSE_SUBTRACT gl:GL_FUNC_REVERSE_SUBTRACT
+ALIAS: GL_TEXTURE0 gl:GL_TEXTURE0
+ALIAS: GL_TEXTURE1 gl:GL_TEXTURE1
+ALIAS: GL_TEXTURE2 gl:GL_TEXTURE2
+ALIAS: GL_TEXTURE3 gl:GL_TEXTURE3
+ALIAS: GL_TEXTURE4 gl:GL_TEXTURE4
+ALIAS: GL_TEXTURE5 gl:GL_TEXTURE5
+ALIAS: GL_TEXTURE6 gl:GL_TEXTURE6
+ALIAS: GL_TEXTURE7 gl:GL_TEXTURE7
+ALIAS: GL_TEXTURE8 gl:GL_TEXTURE8
+ALIAS: GL_TEXTURE9 gl:GL_TEXTURE9
+ALIAS: GL_TEXTURE10 gl:GL_TEXTURE10
+ALIAS: GL_TEXTURE11 gl:GL_TEXTURE11
+ALIAS: GL_TEXTURE12 gl:GL_TEXTURE12
+ALIAS: GL_TEXTURE13 gl:GL_TEXTURE13
+ALIAS: GL_TEXTURE14 gl:GL_TEXTURE14
+ALIAS: GL_TEXTURE15 gl:GL_TEXTURE15
+ALIAS: GL_TEXTURE16 gl:GL_TEXTURE16
+ALIAS: GL_TEXTURE17 gl:GL_TEXTURE17
+ALIAS: GL_TEXTURE18 gl:GL_TEXTURE18
+ALIAS: GL_TEXTURE19 gl:GL_TEXTURE19
+ALIAS: GL_TEXTURE20 gl:GL_TEXTURE20
+ALIAS: GL_TEXTURE21 gl:GL_TEXTURE21
+ALIAS: GL_TEXTURE22 gl:GL_TEXTURE22
+ALIAS: GL_TEXTURE23 gl:GL_TEXTURE23
+ALIAS: GL_TEXTURE24 gl:GL_TEXTURE24
+ALIAS: GL_TEXTURE25 gl:GL_TEXTURE25
+ALIAS: GL_TEXTURE26 gl:GL_TEXTURE26
+ALIAS: GL_TEXTURE27 gl:GL_TEXTURE27
+ALIAS: GL_TEXTURE28 gl:GL_TEXTURE28
+ALIAS: GL_TEXTURE29 gl:GL_TEXTURE29
+ALIAS: GL_TEXTURE30 gl:GL_TEXTURE30
+ALIAS: GL_TEXTURE31 gl:GL_TEXTURE31
+ALIAS: GL_ACTIVE_TEXTURE gl:GL_ACTIVE_TEXTURE
+ALIAS: GL_MULTISAMPLE gl:GL_MULTISAMPLE
+ALIAS: GL_SAMPLE_ALPHA_TO_COVERAGE gl:GL_SAMPLE_ALPHA_TO_COVERAGE
+ALIAS: GL_SAMPLE_ALPHA_TO_ONE gl:GL_SAMPLE_ALPHA_TO_ONE
+ALIAS: GL_SAMPLE_COVERAGE gl:GL_SAMPLE_COVERAGE
+ALIAS: GL_SAMPLE_BUFFERS gl:GL_SAMPLE_BUFFERS
+ALIAS: GL_SAMPLES gl:GL_SAMPLES
+ALIAS: GL_SAMPLE_COVERAGE_VALUE gl:GL_SAMPLE_COVERAGE_VALUE
+ALIAS: GL_SAMPLE_COVERAGE_INVERT gl:GL_SAMPLE_COVERAGE_INVERT
+ALIAS: GL_TEXTURE_CUBE_MAP gl:GL_TEXTURE_CUBE_MAP
+ALIAS: GL_TEXTURE_BINDING_CUBE_MAP gl:GL_TEXTURE_BINDING_CUBE_MAP
+ALIAS: GL_TEXTURE_CUBE_MAP_POSITIVE_X gl:GL_TEXTURE_CUBE_MAP_POSITIVE_X
+ALIAS: GL_TEXTURE_CUBE_MAP_NEGATIVE_X gl:GL_TEXTURE_CUBE_MAP_NEGATIVE_X
+ALIAS: GL_TEXTURE_CUBE_MAP_POSITIVE_Y gl:GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+ALIAS: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y gl:GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+ALIAS: GL_TEXTURE_CUBE_MAP_POSITIVE_Z gl:GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+ALIAS: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z gl:GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
+ALIAS: GL_PROXY_TEXTURE_CUBE_MAP gl:GL_PROXY_TEXTURE_CUBE_MAP
+ALIAS: GL_MAX_CUBE_MAP_TEXTURE_SIZE gl:GL_MAX_CUBE_MAP_TEXTURE_SIZE
+ALIAS: GL_COMPRESSED_RGB gl:GL_COMPRESSED_RGB
+ALIAS: GL_COMPRESSED_RGBA gl:GL_COMPRESSED_RGBA
+ALIAS: GL_TEXTURE_COMPRESSION_HINT gl:GL_TEXTURE_COMPRESSION_HINT
+ALIAS: GL_TEXTURE_COMPRESSED_IMAGE_SIZE gl:GL_TEXTURE_COMPRESSED_IMAGE_SIZE
+ALIAS: GL_TEXTURE_COMPRESSED gl:GL_TEXTURE_COMPRESSED
+ALIAS: GL_NUM_COMPRESSED_TEXTURE_FORMATS gl:GL_NUM_COMPRESSED_TEXTURE_FORMATS
+ALIAS: GL_COMPRESSED_TEXTURE_FORMATS gl:GL_COMPRESSED_TEXTURE_FORMATS
+ALIAS: GL_CLAMP_TO_BORDER gl:GL_CLAMP_TO_BORDER
+ALIAS: GL_BLEND_DST_RGB gl:GL_BLEND_DST_RGB
+ALIAS: GL_BLEND_SRC_RGB gl:GL_BLEND_SRC_RGB
+ALIAS: GL_BLEND_DST_ALPHA gl:GL_BLEND_DST_ALPHA
+ALIAS: GL_BLEND_SRC_ALPHA gl:GL_BLEND_SRC_ALPHA
+ALIAS: GL_POINT_FADE_THRESHOLD_SIZE gl:GL_POINT_FADE_THRESHOLD_SIZE
+ALIAS: GL_DEPTH_COMPONENT16 gl:GL_DEPTH_COMPONENT16
+ALIAS: GL_DEPTH_COMPONENT24 gl:GL_DEPTH_COMPONENT24
+ALIAS: GL_DEPTH_COMPONENT32 gl:GL_DEPTH_COMPONENT32
+ALIAS: GL_MIRRORED_REPEAT gl:GL_MIRRORED_REPEAT
+ALIAS: GL_MAX_TEXTURE_LOD_BIAS gl:GL_MAX_TEXTURE_LOD_BIAS
+ALIAS: GL_TEXTURE_LOD_BIAS gl:GL_TEXTURE_LOD_BIAS
+ALIAS: GL_INCR_WRAP gl:GL_INCR_WRAP
+ALIAS: GL_DECR_WRAP gl:GL_DECR_WRAP
+ALIAS: GL_TEXTURE_DEPTH_SIZE gl:GL_TEXTURE_DEPTH_SIZE
+ALIAS: GL_TEXTURE_COMPARE_MODE gl:GL_TEXTURE_COMPARE_MODE
+ALIAS: GL_TEXTURE_COMPARE_FUNC gl:GL_TEXTURE_COMPARE_FUNC
+ALIAS: GL_BUFFER_SIZE gl:GL_BUFFER_SIZE
+ALIAS: GL_BUFFER_USAGE gl:GL_BUFFER_USAGE
+ALIAS: GL_QUERY_COUNTER_BITS gl:GL_QUERY_COUNTER_BITS
+ALIAS: GL_CURRENT_QUERY gl:GL_CURRENT_QUERY
+ALIAS: GL_QUERY_RESULT gl:GL_QUERY_RESULT
+ALIAS: GL_QUERY_RESULT_AVAILABLE gl:GL_QUERY_RESULT_AVAILABLE
+ALIAS: GL_ARRAY_BUFFER gl:GL_ARRAY_BUFFER
+ALIAS: GL_ELEMENT_ARRAY_BUFFER gl:GL_ELEMENT_ARRAY_BUFFER
+ALIAS: GL_ARRAY_BUFFER_BINDING gl:GL_ARRAY_BUFFER_BINDING
+ALIAS: GL_ELEMENT_ARRAY_BUFFER_BINDING gl:GL_ELEMENT_ARRAY_BUFFER_BINDING
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING gl:GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING
+ALIAS: GL_READ_ONLY gl:GL_READ_ONLY
+ALIAS: GL_WRITE_ONLY gl:GL_WRITE_ONLY
+ALIAS: GL_READ_WRITE gl:GL_READ_WRITE
+ALIAS: GL_BUFFER_ACCESS gl:GL_BUFFER_ACCESS
+ALIAS: GL_BUFFER_MAPPED gl:GL_BUFFER_MAPPED
+ALIAS: GL_BUFFER_MAP_POINTER gl:GL_BUFFER_MAP_POINTER
+ALIAS: GL_STREAM_DRAW gl:GL_STREAM_DRAW
+ALIAS: GL_STREAM_READ gl:GL_STREAM_READ
+ALIAS: GL_STREAM_COPY gl:GL_STREAM_COPY
+ALIAS: GL_STATIC_DRAW gl:GL_STATIC_DRAW
+ALIAS: GL_STATIC_READ gl:GL_STATIC_READ
+ALIAS: GL_STATIC_COPY gl:GL_STATIC_COPY
+ALIAS: GL_DYNAMIC_DRAW gl:GL_DYNAMIC_DRAW
+ALIAS: GL_DYNAMIC_READ gl:GL_DYNAMIC_READ
+ALIAS: GL_DYNAMIC_COPY gl:GL_DYNAMIC_COPY
+ALIAS: GL_SAMPLES_PASSED gl:GL_SAMPLES_PASSED
+ALIAS: GL_BLEND_EQUATION_RGB gl:GL_BLEND_EQUATION_RGB
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_ENABLED gl:GL_VERTEX_ATTRIB_ARRAY_ENABLED
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_SIZE gl:GL_VERTEX_ATTRIB_ARRAY_SIZE
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_STRIDE gl:GL_VERTEX_ATTRIB_ARRAY_STRIDE
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_TYPE gl:GL_VERTEX_ATTRIB_ARRAY_TYPE
+ALIAS: GL_CURRENT_VERTEX_ATTRIB gl:GL_CURRENT_VERTEX_ATTRIB
+ALIAS: GL_VERTEX_PROGRAM_POINT_SIZE gl:GL_VERTEX_PROGRAM_POINT_SIZE
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_POINTER gl:GL_VERTEX_ATTRIB_ARRAY_POINTER
+ALIAS: GL_STENCIL_BACK_FUNC gl:GL_STENCIL_BACK_FUNC
+ALIAS: GL_STENCIL_BACK_FAIL gl:GL_STENCIL_BACK_FAIL
+ALIAS: GL_STENCIL_BACK_PASS_DEPTH_FAIL gl:GL_STENCIL_BACK_PASS_DEPTH_FAIL
+ALIAS: GL_STENCIL_BACK_PASS_DEPTH_PASS gl:GL_STENCIL_BACK_PASS_DEPTH_PASS
+ALIAS: GL_MAX_DRAW_BUFFERS gl:GL_MAX_DRAW_BUFFERS
+ALIAS: GL_DRAW_BUFFER0 gl:GL_DRAW_BUFFER0
+ALIAS: GL_DRAW_BUFFER1 gl:GL_DRAW_BUFFER1
+ALIAS: GL_DRAW_BUFFER2 gl:GL_DRAW_BUFFER2
+ALIAS: GL_DRAW_BUFFER3 gl:GL_DRAW_BUFFER3
+ALIAS: GL_DRAW_BUFFER4 gl:GL_DRAW_BUFFER4
+ALIAS: GL_DRAW_BUFFER5 gl:GL_DRAW_BUFFER5
+ALIAS: GL_DRAW_BUFFER6 gl:GL_DRAW_BUFFER6
+ALIAS: GL_DRAW_BUFFER7 gl:GL_DRAW_BUFFER7
+ALIAS: GL_DRAW_BUFFER8 gl:GL_DRAW_BUFFER8
+ALIAS: GL_DRAW_BUFFER9 gl:GL_DRAW_BUFFER9
+ALIAS: GL_DRAW_BUFFER10 gl:GL_DRAW_BUFFER10
+ALIAS: GL_DRAW_BUFFER11 gl:GL_DRAW_BUFFER11
+ALIAS: GL_DRAW_BUFFER12 gl:GL_DRAW_BUFFER12
+ALIAS: GL_DRAW_BUFFER13 gl:GL_DRAW_BUFFER13
+ALIAS: GL_DRAW_BUFFER14 gl:GL_DRAW_BUFFER14
+ALIAS: GL_DRAW_BUFFER15 gl:GL_DRAW_BUFFER15
+ALIAS: GL_BLEND_EQUATION_ALPHA gl:GL_BLEND_EQUATION_ALPHA
+ALIAS: GL_MAX_VERTEX_ATTRIBS gl:GL_MAX_VERTEX_ATTRIBS
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_NORMALIZED gl:GL_VERTEX_ATTRIB_ARRAY_NORMALIZED
+ALIAS: GL_MAX_TEXTURE_IMAGE_UNITS gl:GL_MAX_TEXTURE_IMAGE_UNITS
+ALIAS: GL_FRAGMENT_SHADER gl:GL_FRAGMENT_SHADER
+ALIAS: GL_VERTEX_SHADER gl:GL_VERTEX_SHADER
+ALIAS: GL_MAX_FRAGMENT_UNIFORM_COMPONENTS gl:GL_MAX_FRAGMENT_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_VERTEX_UNIFORM_COMPONENTS gl:GL_MAX_VERTEX_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_VARYING_FLOATS gl:GL_MAX_VARYING_FLOATS
+ALIAS: GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS gl:GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS
+ALIAS: GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS gl:GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS
+ALIAS: GL_SHADER_TYPE gl:GL_SHADER_TYPE
+ALIAS: GL_FLOAT_VEC2 gl:GL_FLOAT_VEC2
+ALIAS: GL_FLOAT_VEC3 gl:GL_FLOAT_VEC3
+ALIAS: GL_FLOAT_VEC4 gl:GL_FLOAT_VEC4
+ALIAS: GL_INT_VEC2 gl:GL_INT_VEC2
+ALIAS: GL_INT_VEC3 gl:GL_INT_VEC3
+ALIAS: GL_INT_VEC4 gl:GL_INT_VEC4
+ALIAS: GL_BOOL gl:GL_BOOL
+ALIAS: GL_BOOL_VEC2 gl:GL_BOOL_VEC2
+ALIAS: GL_BOOL_VEC3 gl:GL_BOOL_VEC3
+ALIAS: GL_BOOL_VEC4 gl:GL_BOOL_VEC4
+ALIAS: GL_FLOAT_MAT2 gl:GL_FLOAT_MAT2
+ALIAS: GL_FLOAT_MAT3 gl:GL_FLOAT_MAT3
+ALIAS: GL_FLOAT_MAT4 gl:GL_FLOAT_MAT4
+ALIAS: GL_SAMPLER_1D gl:GL_SAMPLER_1D
+ALIAS: GL_SAMPLER_2D gl:GL_SAMPLER_2D
+ALIAS: GL_SAMPLER_3D gl:GL_SAMPLER_3D
+ALIAS: GL_SAMPLER_CUBE gl:GL_SAMPLER_CUBE
+ALIAS: GL_SAMPLER_1D_SHADOW gl:GL_SAMPLER_1D_SHADOW
+ALIAS: GL_SAMPLER_2D_SHADOW gl:GL_SAMPLER_2D_SHADOW
+ALIAS: GL_DELETE_STATUS gl:GL_DELETE_STATUS
+ALIAS: GL_COMPILE_STATUS gl:GL_COMPILE_STATUS
+ALIAS: GL_LINK_STATUS gl:GL_LINK_STATUS
+ALIAS: GL_VALIDATE_STATUS gl:GL_VALIDATE_STATUS
+ALIAS: GL_INFO_LOG_LENGTH gl:GL_INFO_LOG_LENGTH
+ALIAS: GL_ATTACHED_SHADERS gl:GL_ATTACHED_SHADERS
+ALIAS: GL_ACTIVE_UNIFORMS gl:GL_ACTIVE_UNIFORMS
+ALIAS: GL_ACTIVE_UNIFORM_MAX_LENGTH gl:GL_ACTIVE_UNIFORM_MAX_LENGTH
+ALIAS: GL_SHADER_SOURCE_LENGTH gl:GL_SHADER_SOURCE_LENGTH
+ALIAS: GL_ACTIVE_ATTRIBUTES gl:GL_ACTIVE_ATTRIBUTES
+ALIAS: GL_ACTIVE_ATTRIBUTE_MAX_LENGTH gl:GL_ACTIVE_ATTRIBUTE_MAX_LENGTH
+ALIAS: GL_FRAGMENT_SHADER_DERIVATIVE_HINT gl:GL_FRAGMENT_SHADER_DERIVATIVE_HINT
+ALIAS: GL_SHADING_LANGUAGE_VERSION gl:GL_SHADING_LANGUAGE_VERSION
+ALIAS: GL_CURRENT_PROGRAM gl:GL_CURRENT_PROGRAM
+ALIAS: GL_POINT_SPRITE_COORD_ORIGIN gl:GL_POINT_SPRITE_COORD_ORIGIN
+ALIAS: GL_LOWER_LEFT gl:GL_LOWER_LEFT
+ALIAS: GL_UPPER_LEFT gl:GL_UPPER_LEFT
+ALIAS: GL_STENCIL_BACK_REF gl:GL_STENCIL_BACK_REF
+ALIAS: GL_STENCIL_BACK_VALUE_MASK gl:GL_STENCIL_BACK_VALUE_MASK
+ALIAS: GL_STENCIL_BACK_WRITEMASK gl:GL_STENCIL_BACK_WRITEMASK
+ALIAS: GL_PIXEL_PACK_BUFFER gl:GL_PIXEL_PACK_BUFFER
+ALIAS: GL_PIXEL_UNPACK_BUFFER gl:GL_PIXEL_UNPACK_BUFFER
+ALIAS: GL_PIXEL_PACK_BUFFER_BINDING gl:GL_PIXEL_PACK_BUFFER_BINDING
+ALIAS: GL_PIXEL_UNPACK_BUFFER_BINDING gl:GL_PIXEL_UNPACK_BUFFER_BINDING
+ALIAS: GL_FLOAT_MAT2x3 gl:GL_FLOAT_MAT2x3
+ALIAS: GL_FLOAT_MAT2x4 gl:GL_FLOAT_MAT2x4
+ALIAS: GL_FLOAT_MAT3x2 gl:GL_FLOAT_MAT3x2
+ALIAS: GL_FLOAT_MAT3x4 gl:GL_FLOAT_MAT3x4
+ALIAS: GL_FLOAT_MAT4x2 gl:GL_FLOAT_MAT4x2
+ALIAS: GL_FLOAT_MAT4x3 gl:GL_FLOAT_MAT4x3
+ALIAS: GL_SRGB gl:GL_SRGB
+ALIAS: GL_SRGB8 gl:GL_SRGB8
+ALIAS: GL_SRGB_ALPHA gl:GL_SRGB_ALPHA
+ALIAS: GL_SRGB8_ALPHA8 gl:GL_SRGB8_ALPHA8
+ALIAS: GL_COMPRESSED_SRGB gl:GL_COMPRESSED_SRGB
+ALIAS: GL_COMPRESSED_SRGB_ALPHA gl:GL_COMPRESSED_SRGB_ALPHA
+ALIAS: GL_COMPARE_REF_TO_TEXTURE gl:GL_COMPARE_REF_TO_TEXTURE
+ALIAS: GL_CLIP_DISTANCE0 gl:GL_CLIP_DISTANCE0
+ALIAS: GL_CLIP_DISTANCE1 gl:GL_CLIP_DISTANCE1
+ALIAS: GL_CLIP_DISTANCE2 gl:GL_CLIP_DISTANCE2
+ALIAS: GL_CLIP_DISTANCE3 gl:GL_CLIP_DISTANCE3
+ALIAS: GL_CLIP_DISTANCE4 gl:GL_CLIP_DISTANCE4
+ALIAS: GL_CLIP_DISTANCE5 gl:GL_CLIP_DISTANCE5
+ALIAS: GL_MAX_CLIP_DISTANCES gl:GL_MAX_CLIP_DISTANCES
+ALIAS: GL_MAJOR_VERSION gl:GL_MAJOR_VERSION
+ALIAS: GL_MINOR_VERSION gl:GL_MINOR_VERSION
+ALIAS: GL_NUM_EXTENSIONS gl:GL_NUM_EXTENSIONS
+ALIAS: GL_CONTEXT_FLAGS gl:GL_CONTEXT_FLAGS
+ALIAS: GL_DEPTH_BUFFER gl:GL_DEPTH_BUFFER
+ALIAS: GL_STENCIL_BUFFER gl:GL_STENCIL_BUFFER
+ALIAS: GL_COMPRESSED_RED gl:GL_COMPRESSED_RED
+ALIAS: GL_COMPRESSED_RG gl:GL_COMPRESSED_RG
+ALIAS: GL_CONTEXT_FLAG_FORWARD_COMPATIBLE_BIT gl:GL_CONTEXT_FLAG_FORWARD_COMPATIBLE_BIT
+ALIAS: GL_RGBA32F gl:GL_RGBA32F
+ALIAS: GL_RGB32F gl:GL_RGB32F
+ALIAS: GL_RGBA16F gl:GL_RGBA16F
+ALIAS: GL_RGB16F gl:GL_RGB16F
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_INTEGER gl:GL_VERTEX_ATTRIB_ARRAY_INTEGER
+ALIAS: GL_MAX_ARRAY_TEXTURE_LAYERS gl:GL_MAX_ARRAY_TEXTURE_LAYERS
+ALIAS: GL_MIN_PROGRAM_TEXEL_OFFSET gl:GL_MIN_PROGRAM_TEXEL_OFFSET
+ALIAS: GL_MAX_PROGRAM_TEXEL_OFFSET gl:GL_MAX_PROGRAM_TEXEL_OFFSET
+ALIAS: GL_CLAMP_READ_COLOR gl:GL_CLAMP_READ_COLOR
+ALIAS: GL_FIXED_ONLY gl:GL_FIXED_ONLY
+ALIAS: GL_MAX_VARYING_COMPONENTS gl:GL_MAX_VARYING_COMPONENTS
+ALIAS: GL_TEXTURE_1D_ARRAY gl:GL_TEXTURE_1D_ARRAY
+ALIAS: GL_PROXY_TEXTURE_1D_ARRAY gl:GL_PROXY_TEXTURE_1D_ARRAY
+ALIAS: GL_TEXTURE_2D_ARRAY gl:GL_TEXTURE_2D_ARRAY
+ALIAS: GL_PROXY_TEXTURE_2D_ARRAY gl:GL_PROXY_TEXTURE_2D_ARRAY
+ALIAS: GL_TEXTURE_BINDING_1D_ARRAY gl:GL_TEXTURE_BINDING_1D_ARRAY
+ALIAS: GL_TEXTURE_BINDING_2D_ARRAY gl:GL_TEXTURE_BINDING_2D_ARRAY
+ALIAS: GL_R11F_G11F_B10F gl:GL_R11F_G11F_B10F
+ALIAS: GL_UNSIGNED_INT_10F_11F_11F_REV gl:GL_UNSIGNED_INT_10F_11F_11F_REV
+ALIAS: GL_RGB9_E5 gl:GL_RGB9_E5
+ALIAS: GL_UNSIGNED_INT_5_9_9_9_REV gl:GL_UNSIGNED_INT_5_9_9_9_REV
+ALIAS: GL_TEXTURE_SHARED_SIZE gl:GL_TEXTURE_SHARED_SIZE
+ALIAS: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH gl:GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_MODE gl:GL_TRANSFORM_FEEDBACK_BUFFER_MODE
+ALIAS: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS gl:GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS
+ALIAS: GL_TRANSFORM_FEEDBACK_VARYINGS gl:GL_TRANSFORM_FEEDBACK_VARYINGS
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_START gl:GL_TRANSFORM_FEEDBACK_BUFFER_START
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE gl:GL_TRANSFORM_FEEDBACK_BUFFER_SIZE
+ALIAS: GL_PRIMITIVES_GENERATED gl:GL_PRIMITIVES_GENERATED
+ALIAS: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN gl:GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN
+ALIAS: GL_RASTERIZER_DISCARD gl:GL_RASTERIZER_DISCARD
+ALIAS: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS gl:GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS
+ALIAS: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS gl:GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS
+ALIAS: GL_INTERLEAVED_ATTRIBS gl:GL_INTERLEAVED_ATTRIBS
+ALIAS: GL_SEPARATE_ATTRIBS gl:GL_SEPARATE_ATTRIBS
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER gl:GL_TRANSFORM_FEEDBACK_BUFFER
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING gl:GL_TRANSFORM_FEEDBACK_BUFFER_BINDING
+ALIAS: GL_RGBA32UI gl:GL_RGBA32UI
+ALIAS: GL_RGB32UI gl:GL_RGB32UI
+ALIAS: GL_RGBA16UI gl:GL_RGBA16UI
+ALIAS: GL_RGB16UI gl:GL_RGB16UI
+ALIAS: GL_RGBA8UI gl:GL_RGBA8UI
+ALIAS: GL_RGB8UI gl:GL_RGB8UI
+ALIAS: GL_RGBA32I gl:GL_RGBA32I
+ALIAS: GL_RGB32I gl:GL_RGB32I
+ALIAS: GL_RGBA16I gl:GL_RGBA16I
+ALIAS: GL_RGB16I gl:GL_RGB16I
+ALIAS: GL_RGBA8I gl:GL_RGBA8I
+ALIAS: GL_RGB8I gl:GL_RGB8I
+ALIAS: GL_RED_INTEGER gl:GL_RED_INTEGER
+ALIAS: GL_GREEN_INTEGER gl:GL_GREEN_INTEGER
+ALIAS: GL_BLUE_INTEGER gl:GL_BLUE_INTEGER
+ALIAS: GL_RGB_INTEGER gl:GL_RGB_INTEGER
+ALIAS: GL_RGBA_INTEGER gl:GL_RGBA_INTEGER
+ALIAS: GL_BGR_INTEGER gl:GL_BGR_INTEGER
+ALIAS: GL_BGRA_INTEGER gl:GL_BGRA_INTEGER
+ALIAS: GL_SAMPLER_1D_ARRAY gl:GL_SAMPLER_1D_ARRAY
+ALIAS: GL_SAMPLER_2D_ARRAY gl:GL_SAMPLER_2D_ARRAY
+ALIAS: GL_SAMPLER_1D_ARRAY_SHADOW gl:GL_SAMPLER_1D_ARRAY_SHADOW
+ALIAS: GL_SAMPLER_2D_ARRAY_SHADOW gl:GL_SAMPLER_2D_ARRAY_SHADOW
+ALIAS: GL_SAMPLER_CUBE_SHADOW gl:GL_SAMPLER_CUBE_SHADOW
+ALIAS: GL_UNSIGNED_INT_VEC2 gl:GL_UNSIGNED_INT_VEC2
+ALIAS: GL_UNSIGNED_INT_VEC3 gl:GL_UNSIGNED_INT_VEC3
+ALIAS: GL_UNSIGNED_INT_VEC4 gl:GL_UNSIGNED_INT_VEC4
+ALIAS: GL_INT_SAMPLER_1D gl:GL_INT_SAMPLER_1D
+ALIAS: GL_INT_SAMPLER_2D gl:GL_INT_SAMPLER_2D
+ALIAS: GL_INT_SAMPLER_3D gl:GL_INT_SAMPLER_3D
+ALIAS: GL_INT_SAMPLER_CUBE gl:GL_INT_SAMPLER_CUBE
+ALIAS: GL_INT_SAMPLER_1D_ARRAY gl:GL_INT_SAMPLER_1D_ARRAY
+ALIAS: GL_INT_SAMPLER_2D_ARRAY gl:GL_INT_SAMPLER_2D_ARRAY
+ALIAS: GL_UNSIGNED_INT_SAMPLER_1D gl:GL_UNSIGNED_INT_SAMPLER_1D
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D gl:GL_UNSIGNED_INT_SAMPLER_2D
+ALIAS: GL_UNSIGNED_INT_SAMPLER_3D gl:GL_UNSIGNED_INT_SAMPLER_3D
+ALIAS: GL_UNSIGNED_INT_SAMPLER_CUBE gl:GL_UNSIGNED_INT_SAMPLER_CUBE
+ALIAS: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY gl:GL_UNSIGNED_INT_SAMPLER_1D_ARRAY
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY gl:GL_UNSIGNED_INT_SAMPLER_2D_ARRAY
+ALIAS: GL_QUERY_WAIT gl:GL_QUERY_WAIT
+ALIAS: GL_QUERY_NO_WAIT gl:GL_QUERY_NO_WAIT
+ALIAS: GL_QUERY_BY_REGION_WAIT gl:GL_QUERY_BY_REGION_WAIT
+ALIAS: GL_QUERY_BY_REGION_NO_WAIT gl:GL_QUERY_BY_REGION_NO_WAIT
+ALIAS: GL_DEPTH_COMPONENT32F gl:GL_DEPTH_COMPONENT32F
+ALIAS: GL_DEPTH32F_STENCIL8 gl:GL_DEPTH32F_STENCIL8
+ALIAS: GL_FLOAT_32_UNSIGNED_INT_24_8_REV gl:GL_FLOAT_32_UNSIGNED_INT_24_8_REV
+ALIAS: GL_INVALID_FRAMEBUFFER_OPERATION gl:GL_INVALID_FRAMEBUFFER_OPERATION
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_COLOR_ENCODING gl:GL_FRAMEBUFFER_ATTACHMENT_COLOR_ENCODING
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_COMPONENT_TYPE gl:GL_FRAMEBUFFER_ATTACHMENT_COMPONENT_TYPE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_RED_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_RED_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE
+ALIAS: GL_FRAMEBUFFER_DEFAULT gl:GL_FRAMEBUFFER_DEFAULT
+ALIAS: GL_FRAMEBUFFER_UNDEFINED gl:GL_FRAMEBUFFER_UNDEFINED
+ALIAS: GL_DEPTH_STENCIL_ATTACHMENT gl:GL_DEPTH_STENCIL_ATTACHMENT
+ALIAS: GL_INDEX gl:GL_INDEX
+ALIAS: GL_MAX_RENDERBUFFER_SIZE gl:GL_MAX_RENDERBUFFER_SIZE
+ALIAS: GL_DEPTH_STENCIL gl:GL_DEPTH_STENCIL
+ALIAS: GL_UNSIGNED_INT_24_8 gl:GL_UNSIGNED_INT_24_8
+ALIAS: GL_DEPTH24_STENCIL8 gl:GL_DEPTH24_STENCIL8
+ALIAS: GL_TEXTURE_STENCIL_SIZE gl:GL_TEXTURE_STENCIL_SIZE
+ALIAS: GL_TEXTURE_RED_TYPE gl:GL_TEXTURE_RED_TYPE
+ALIAS: GL_TEXTURE_GREEN_TYPE gl:GL_TEXTURE_GREEN_TYPE
+ALIAS: GL_TEXTURE_BLUE_TYPE gl:GL_TEXTURE_BLUE_TYPE
+ALIAS: GL_TEXTURE_ALPHA_TYPE gl:GL_TEXTURE_ALPHA_TYPE
+ALIAS: GL_TEXTURE_DEPTH_TYPE gl:GL_TEXTURE_DEPTH_TYPE
+ALIAS: GL_UNSIGNED_NORMALIZED gl:GL_UNSIGNED_NORMALIZED
+ALIAS: GL_FRAMEBUFFER_BINDING gl:GL_FRAMEBUFFER_BINDING
+ALIAS: GL_DRAW_FRAMEBUFFER_BINDING gl:GL_DRAW_FRAMEBUFFER_BINDING
+ALIAS: GL_RENDERBUFFER_BINDING gl:GL_RENDERBUFFER_BINDING
+ALIAS: GL_READ_FRAMEBUFFER gl:GL_READ_FRAMEBUFFER
+ALIAS: GL_DRAW_FRAMEBUFFER gl:GL_DRAW_FRAMEBUFFER
+ALIAS: GL_READ_FRAMEBUFFER_BINDING gl:GL_READ_FRAMEBUFFER_BINDING
+ALIAS: GL_RENDERBUFFER_SAMPLES gl:GL_RENDERBUFFER_SAMPLES
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE gl:GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME gl:GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL gl:GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE gl:GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER gl:GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER
+ALIAS: GL_FRAMEBUFFER_COMPLETE gl:GL_FRAMEBUFFER_COMPLETE
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT gl:GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT gl:GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER gl:GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER gl:GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER
+ALIAS: GL_FRAMEBUFFER_UNSUPPORTED gl:GL_FRAMEBUFFER_UNSUPPORTED
+ALIAS: GL_MAX_COLOR_ATTACHMENTS gl:GL_MAX_COLOR_ATTACHMENTS
+ALIAS: GL_COLOR_ATTACHMENT0 gl:GL_COLOR_ATTACHMENT0
+ALIAS: GL_COLOR_ATTACHMENT1 gl:GL_COLOR_ATTACHMENT1
+ALIAS: GL_COLOR_ATTACHMENT2 gl:GL_COLOR_ATTACHMENT2
+ALIAS: GL_COLOR_ATTACHMENT3 gl:GL_COLOR_ATTACHMENT3
+ALIAS: GL_COLOR_ATTACHMENT4 gl:GL_COLOR_ATTACHMENT4
+ALIAS: GL_COLOR_ATTACHMENT5 gl:GL_COLOR_ATTACHMENT5
+ALIAS: GL_COLOR_ATTACHMENT6 gl:GL_COLOR_ATTACHMENT6
+ALIAS: GL_COLOR_ATTACHMENT7 gl:GL_COLOR_ATTACHMENT7
+ALIAS: GL_COLOR_ATTACHMENT8 gl:GL_COLOR_ATTACHMENT8
+ALIAS: GL_COLOR_ATTACHMENT9 gl:GL_COLOR_ATTACHMENT9
+ALIAS: GL_COLOR_ATTACHMENT10 gl:GL_COLOR_ATTACHMENT10
+ALIAS: GL_COLOR_ATTACHMENT11 gl:GL_COLOR_ATTACHMENT11
+ALIAS: GL_COLOR_ATTACHMENT12 gl:GL_COLOR_ATTACHMENT12
+ALIAS: GL_COLOR_ATTACHMENT13 gl:GL_COLOR_ATTACHMENT13
+ALIAS: GL_COLOR_ATTACHMENT14 gl:GL_COLOR_ATTACHMENT14
+ALIAS: GL_COLOR_ATTACHMENT15 gl:GL_COLOR_ATTACHMENT15
+ALIAS: GL_DEPTH_ATTACHMENT gl:GL_DEPTH_ATTACHMENT
+ALIAS: GL_STENCIL_ATTACHMENT gl:GL_STENCIL_ATTACHMENT
+ALIAS: GL_FRAMEBUFFER gl:GL_FRAMEBUFFER
+ALIAS: GL_RENDERBUFFER gl:GL_RENDERBUFFER
+ALIAS: GL_RENDERBUFFER_WIDTH gl:GL_RENDERBUFFER_WIDTH
+ALIAS: GL_RENDERBUFFER_HEIGHT gl:GL_RENDERBUFFER_HEIGHT
+ALIAS: GL_RENDERBUFFER_INTERNAL_FORMAT gl:GL_RENDERBUFFER_INTERNAL_FORMAT
+ALIAS: GL_STENCIL_INDEX1 gl:GL_STENCIL_INDEX1
+ALIAS: GL_STENCIL_INDEX4 gl:GL_STENCIL_INDEX4
+ALIAS: GL_STENCIL_INDEX8 gl:GL_STENCIL_INDEX8
+ALIAS: GL_STENCIL_INDEX16 gl:GL_STENCIL_INDEX16
+ALIAS: GL_RENDERBUFFER_RED_SIZE gl:GL_RENDERBUFFER_RED_SIZE
+ALIAS: GL_RENDERBUFFER_GREEN_SIZE gl:GL_RENDERBUFFER_GREEN_SIZE
+ALIAS: GL_RENDERBUFFER_BLUE_SIZE gl:GL_RENDERBUFFER_BLUE_SIZE
+ALIAS: GL_RENDERBUFFER_ALPHA_SIZE gl:GL_RENDERBUFFER_ALPHA_SIZE
+ALIAS: GL_RENDERBUFFER_DEPTH_SIZE gl:GL_RENDERBUFFER_DEPTH_SIZE
+ALIAS: GL_RENDERBUFFER_STENCIL_SIZE gl:GL_RENDERBUFFER_STENCIL_SIZE
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE gl:GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE
+ALIAS: GL_MAX_SAMPLES gl:GL_MAX_SAMPLES
+ALIAS: GL_FRAMEBUFFER_SRGB gl:GL_FRAMEBUFFER_SRGB
+ALIAS: GL_HALF_FLOAT gl:GL_HALF_FLOAT
+ALIAS: GL_MAP_READ_BIT gl:GL_MAP_READ_BIT
+ALIAS: GL_MAP_WRITE_BIT gl:GL_MAP_WRITE_BIT
+ALIAS: GL_MAP_INVALIDATE_RANGE_BIT gl:GL_MAP_INVALIDATE_RANGE_BIT
+ALIAS: GL_MAP_INVALIDATE_BUFFER_BIT gl:GL_MAP_INVALIDATE_BUFFER_BIT
+ALIAS: GL_MAP_FLUSH_EXPLICIT_BIT gl:GL_MAP_FLUSH_EXPLICIT_BIT
+ALIAS: GL_MAP_UNSYNCHRONIZED_BIT gl:GL_MAP_UNSYNCHRONIZED_BIT
+ALIAS: GL_COMPRESSED_RED_RGTC1 gl:GL_COMPRESSED_RED_RGTC1
+ALIAS: GL_COMPRESSED_SIGNED_RED_RGTC1 gl:GL_COMPRESSED_SIGNED_RED_RGTC1
+ALIAS: GL_COMPRESSED_RG_RGTC2 gl:GL_COMPRESSED_RG_RGTC2
+ALIAS: GL_COMPRESSED_SIGNED_RG_RGTC2 gl:GL_COMPRESSED_SIGNED_RG_RGTC2
+ALIAS: GL_RG gl:GL_RG
+ALIAS: GL_RG_INTEGER gl:GL_RG_INTEGER
+ALIAS: GL_R8 gl:GL_R8
+ALIAS: GL_R16 gl:GL_R16
+ALIAS: GL_RG8 gl:GL_RG8
+ALIAS: GL_RG16 gl:GL_RG16
+ALIAS: GL_R16F gl:GL_R16F
+ALIAS: GL_R32F gl:GL_R32F
+ALIAS: GL_RG16F gl:GL_RG16F
+ALIAS: GL_RG32F gl:GL_RG32F
+ALIAS: GL_R8I gl:GL_R8I
+ALIAS: GL_R8UI gl:GL_R8UI
+ALIAS: GL_R16I gl:GL_R16I
+ALIAS: GL_R16UI gl:GL_R16UI
+ALIAS: GL_R32I gl:GL_R32I
+ALIAS: GL_R32UI gl:GL_R32UI
+ALIAS: GL_RG8I gl:GL_RG8I
+ALIAS: GL_RG8UI gl:GL_RG8UI
+ALIAS: GL_RG16I gl:GL_RG16I
+ALIAS: GL_RG16UI gl:GL_RG16UI
+ALIAS: GL_RG32I gl:GL_RG32I
+ALIAS: GL_RG32UI gl:GL_RG32UI
+ALIAS: GL_VERTEX_ARRAY_BINDING gl:GL_VERTEX_ARRAY_BINDING
+ALIAS: GL_SAMPLER_2D_RECT gl:GL_SAMPLER_2D_RECT
+ALIAS: GL_SAMPLER_2D_RECT_SHADOW gl:GL_SAMPLER_2D_RECT_SHADOW
+ALIAS: GL_SAMPLER_BUFFER gl:GL_SAMPLER_BUFFER
+ALIAS: GL_INT_SAMPLER_2D_RECT gl:GL_INT_SAMPLER_2D_RECT
+ALIAS: GL_INT_SAMPLER_BUFFER gl:GL_INT_SAMPLER_BUFFER
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D_RECT gl:GL_UNSIGNED_INT_SAMPLER_2D_RECT
+ALIAS: GL_UNSIGNED_INT_SAMPLER_BUFFER gl:GL_UNSIGNED_INT_SAMPLER_BUFFER
+ALIAS: GL_TEXTURE_BUFFER gl:GL_TEXTURE_BUFFER
+ALIAS: GL_MAX_TEXTURE_BUFFER_SIZE gl:GL_MAX_TEXTURE_BUFFER_SIZE
+ALIAS: GL_TEXTURE_BINDING_BUFFER gl:GL_TEXTURE_BINDING_BUFFER
+ALIAS: GL_TEXTURE_BUFFER_DATA_STORE_BINDING gl:GL_TEXTURE_BUFFER_DATA_STORE_BINDING
+ALIAS: GL_TEXTURE_BUFFER_FORMAT gl:GL_TEXTURE_BUFFER_FORMAT
+ALIAS: GL_TEXTURE_RECTANGLE gl:GL_TEXTURE_RECTANGLE
+ALIAS: GL_TEXTURE_BINDING_RECTANGLE gl:GL_TEXTURE_BINDING_RECTANGLE
+ALIAS: GL_PROXY_TEXTURE_RECTANGLE gl:GL_PROXY_TEXTURE_RECTANGLE
+ALIAS: GL_MAX_RECTANGLE_TEXTURE_SIZE gl:GL_MAX_RECTANGLE_TEXTURE_SIZE
+ALIAS: GL_RED_SNORM gl:GL_RED_SNORM
+ALIAS: GL_RG_SNORM gl:GL_RG_SNORM
+ALIAS: GL_RGB_SNORM gl:GL_RGB_SNORM
+ALIAS: GL_RGBA_SNORM gl:GL_RGBA_SNORM
+ALIAS: GL_R8_SNORM gl:GL_R8_SNORM
+ALIAS: GL_RG8_SNORM gl:GL_RG8_SNORM
+ALIAS: GL_RGB8_SNORM gl:GL_RGB8_SNORM
+ALIAS: GL_RGBA8_SNORM gl:GL_RGBA8_SNORM
+ALIAS: GL_R16_SNORM gl:GL_R16_SNORM
+ALIAS: GL_RG16_SNORM gl:GL_RG16_SNORM
+ALIAS: GL_RGB16_SNORM gl:GL_RGB16_SNORM
+ALIAS: GL_RGBA16_SNORM gl:GL_RGBA16_SNORM
+ALIAS: GL_SIGNED_NORMALIZED gl:GL_SIGNED_NORMALIZED
+ALIAS: GL_PRIMITIVE_RESTART gl:GL_PRIMITIVE_RESTART
+ALIAS: GL_PRIMITIVE_RESTART_INDEX gl:GL_PRIMITIVE_RESTART_INDEX
+ALIAS: GL_COPY_READ_BUFFER gl:GL_COPY_READ_BUFFER
+ALIAS: GL_COPY_WRITE_BUFFER gl:GL_COPY_WRITE_BUFFER
+ALIAS: GL_UNIFORM_BUFFER gl:GL_UNIFORM_BUFFER
+ALIAS: GL_UNIFORM_BUFFER_BINDING gl:GL_UNIFORM_BUFFER_BINDING
+ALIAS: GL_UNIFORM_BUFFER_START gl:GL_UNIFORM_BUFFER_START
+ALIAS: GL_UNIFORM_BUFFER_SIZE gl:GL_UNIFORM_BUFFER_SIZE
+ALIAS: GL_MAX_VERTEX_UNIFORM_BLOCKS gl:GL_MAX_VERTEX_UNIFORM_BLOCKS
+ALIAS: GL_MAX_FRAGMENT_UNIFORM_BLOCKS gl:GL_MAX_FRAGMENT_UNIFORM_BLOCKS
+ALIAS: GL_MAX_COMBINED_UNIFORM_BLOCKS gl:GL_MAX_COMBINED_UNIFORM_BLOCKS
+ALIAS: GL_MAX_UNIFORM_BUFFER_BINDINGS gl:GL_MAX_UNIFORM_BUFFER_BINDINGS
+ALIAS: GL_MAX_UNIFORM_BLOCK_SIZE gl:GL_MAX_UNIFORM_BLOCK_SIZE
+ALIAS: GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS gl:GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS gl:GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS
+ALIAS: GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT gl:GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT
+ALIAS: GL_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH gl:GL_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH
+ALIAS: GL_ACTIVE_UNIFORM_BLOCKS gl:GL_ACTIVE_UNIFORM_BLOCKS
+ALIAS: GL_UNIFORM_TYPE gl:GL_UNIFORM_TYPE
+ALIAS: GL_UNIFORM_SIZE gl:GL_UNIFORM_SIZE
+ALIAS: GL_UNIFORM_NAME_LENGTH gl:GL_UNIFORM_NAME_LENGTH
+ALIAS: GL_UNIFORM_BLOCK_INDEX gl:GL_UNIFORM_BLOCK_INDEX
+ALIAS: GL_UNIFORM_OFFSET gl:GL_UNIFORM_OFFSET
+ALIAS: GL_UNIFORM_ARRAY_STRIDE gl:GL_UNIFORM_ARRAY_STRIDE
+ALIAS: GL_UNIFORM_MATRIX_STRIDE gl:GL_UNIFORM_MATRIX_STRIDE
+ALIAS: GL_UNIFORM_IS_ROW_MAJOR gl:GL_UNIFORM_IS_ROW_MAJOR
+ALIAS: GL_UNIFORM_BLOCK_BINDING gl:GL_UNIFORM_BLOCK_BINDING
+ALIAS: GL_UNIFORM_BLOCK_DATA_SIZE gl:GL_UNIFORM_BLOCK_DATA_SIZE
+ALIAS: GL_UNIFORM_BLOCK_NAME_LENGTH gl:GL_UNIFORM_BLOCK_NAME_LENGTH
+ALIAS: GL_UNIFORM_BLOCK_ACTIVE_UNIFORMS gl:GL_UNIFORM_BLOCK_ACTIVE_UNIFORMS
+ALIAS: GL_UNIFORM_BLOCK_ACTIVE_UNIFORM_INDICES gl:GL_UNIFORM_BLOCK_ACTIVE_UNIFORM_INDICES
+ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER
+ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER
+ALIAS: GL_INVALID_INDEX gl:GL_INVALID_INDEX
+
+ALIAS: glCullFace gl:glCullFace
+ALIAS: glFrontFace gl:glFrontFace
+ALIAS: glHint gl:glHint
+ALIAS: glLineWidth gl:glLineWidth
+ALIAS: glPointSize gl:glPointSize
+ALIAS: glPolygonMode gl:glPolygonMode
+ALIAS: glScissor gl:glScissor
+ALIAS: glTexParameterf gl:glTexParameterf
+ALIAS: glTexParameterfv gl:glTexParameterfv
+ALIAS: glTexParameteri gl:glTexParameteri
+ALIAS: glTexParameteriv gl:glTexParameteriv
+ALIAS: glTexImage1D gl:glTexImage1D
+ALIAS: glTexImage2D gl:glTexImage2D
+ALIAS: glDrawBuffer gl:glDrawBuffer
+ALIAS: glClear gl:glClear
+ALIAS: glClearColor gl:glClearColor
+ALIAS: glClearStencil gl:glClearStencil
+ALIAS: glClearDepth gl:glClearDepth
+ALIAS: glStencilMask gl:glStencilMask
+ALIAS: glColorMask gl:glColorMask
+ALIAS: glDepthMask gl:glDepthMask
+ALIAS: glDisable gl:glDisable
+ALIAS: glEnable gl:glEnable
+ALIAS: glFinish gl:glFinish
+ALIAS: glFlush gl:glFlush
+ALIAS: glBlendFunc gl:glBlendFunc
+ALIAS: glLogicOp gl:glLogicOp
+ALIAS: glStencilFunc gl:glStencilFunc
+ALIAS: glStencilOp gl:glStencilOp
+ALIAS: glDepthFunc gl:glDepthFunc
+ALIAS: glPixelStoref gl:glPixelStoref
+ALIAS: glPixelStorei gl:glPixelStorei
+ALIAS: glReadBuffer gl:glReadBuffer
+ALIAS: glReadPixels gl:glReadPixels
+ALIAS: glGetBooleanv gl:glGetBooleanv
+ALIAS: glGetDoublev gl:glGetDoublev
+ALIAS: glGetError gl:glGetError
+ALIAS: glGetFloatv gl:glGetFloatv
+ALIAS: glGetIntegerv gl:glGetIntegerv
+ALIAS: glGetString gl:glGetString
+ALIAS: glGetTexImage gl:glGetTexImage
+ALIAS: glGetTexParameterfv gl:glGetTexParameterfv
+ALIAS: glGetTexParameteriv gl:glGetTexParameteriv
+ALIAS: glGetTexLevelParameterfv gl:glGetTexLevelParameterfv
+ALIAS: glGetTexLevelParameteriv gl:glGetTexLevelParameteriv
+ALIAS: glIsEnabled gl:glIsEnabled
+ALIAS: glDepthRange gl:glDepthRange
+ALIAS: glViewport gl:glViewport
+ALIAS: glDrawArrays gl:glDrawArrays
+ALIAS: glDrawElements gl:glDrawElements
+ALIAS: glGetPointerv gl:glGetPointerv
+ALIAS: glPolygonOffset gl:glPolygonOffset
+ALIAS: glCopyTexImage1D gl:glCopyTexImage1D
+ALIAS: glCopyTexImage2D gl:glCopyTexImage2D
+ALIAS: glCopyTexSubImage1D gl:glCopyTexSubImage1D
+ALIAS: glCopyTexSubImage2D gl:glCopyTexSubImage2D
+ALIAS: glTexSubImage1D gl:glTexSubImage1D
+ALIAS: glTexSubImage2D gl:glTexSubImage2D
+ALIAS: glBindTexture gl:glBindTexture
+ALIAS: glDeleteTextures gl:glDeleteTextures
+ALIAS: glGenTextures gl:glGenTextures
+ALIAS: glIsTexture gl:glIsTexture
+ALIAS: glBlendColor gl:glBlendColor
+ALIAS: glBlendEquation gl:glBlendEquation
+ALIAS: glDrawRangeElements gl:glDrawRangeElements
+ALIAS: glTexImage3D gl:glTexImage3D
+ALIAS: glTexSubImage3D gl:glTexSubImage3D
+ALIAS: glCopyTexSubImage3D gl:glCopyTexSubImage3D
+ALIAS: glActiveTexture gl:glActiveTexture
+ALIAS: glSampleCoverage gl:glSampleCoverage
+ALIAS: glCompressedTexImage3D gl:glCompressedTexImage3D
+ALIAS: glCompressedTexImage2D gl:glCompressedTexImage2D
+ALIAS: glCompressedTexImage1D gl:glCompressedTexImage1D
+ALIAS: glCompressedTexSubImage3D gl:glCompressedTexSubImage3D
+ALIAS: glCompressedTexSubImage2D gl:glCompressedTexSubImage2D
+ALIAS: glCompressedTexSubImage1D gl:glCompressedTexSubImage1D
+ALIAS: glGetCompressedTexImage gl:glGetCompressedTexImage
+ALIAS: glBlendFuncSeparate gl:glBlendFuncSeparate
+ALIAS: glMultiDrawArrays gl:glMultiDrawArrays
+ALIAS: glMultiDrawElements gl:glMultiDrawElements
+ALIAS: glPointParameterf gl:glPointParameterf
+ALIAS: glPointParameterfv gl:glPointParameterfv
+ALIAS: glPointParameteri gl:glPointParameteri
+ALIAS: glPointParameteriv gl:glPointParameteriv
+ALIAS: glGenQueries gl:glGenQueries
+ALIAS: glDeleteQueries gl:glDeleteQueries
+ALIAS: glIsQuery gl:glIsQuery
+ALIAS: glBeginQuery gl:glBeginQuery
+ALIAS: glEndQuery gl:glEndQuery
+ALIAS: glGetQueryiv gl:glGetQueryiv
+ALIAS: glGetQueryObjectiv gl:glGetQueryObjectiv
+ALIAS: glGetQueryObjectuiv gl:glGetQueryObjectuiv
+ALIAS: glBindBuffer gl:glBindBuffer
+ALIAS: glDeleteBuffers gl:glDeleteBuffers
+ALIAS: glGenBuffers gl:glGenBuffers
+ALIAS: glIsBuffer gl:glIsBuffer
+ALIAS: glBufferData gl:glBufferData
+ALIAS: glBufferSubData gl:glBufferSubData
+ALIAS: glGetBufferSubData gl:glGetBufferSubData
+ALIAS: glMapBuffer gl:glMapBuffer
+ALIAS: glUnmapBuffer gl:glUnmapBuffer
+ALIAS: glGetBufferParameteriv gl:glGetBufferParameteriv
+ALIAS: glGetBufferPointerv gl:glGetBufferPointerv
+ALIAS: glBlendEquationSeparate gl:glBlendEquationSeparate
+ALIAS: glDrawBuffers gl:glDrawBuffers
+ALIAS: glStencilOpSeparate gl:glStencilOpSeparate
+ALIAS: glStencilFuncSeparate gl:glStencilFuncSeparate
+ALIAS: glStencilMaskSeparate gl:glStencilMaskSeparate
+ALIAS: glAttachShader gl:glAttachShader
+ALIAS: glBindAttribLocation gl:glBindAttribLocation
+ALIAS: glCompileShader gl:glCompileShader
+ALIAS: glCreateProgram gl:glCreateProgram
+ALIAS: glCreateShader gl:glCreateShader
+ALIAS: glDeleteProgram gl:glDeleteProgram
+ALIAS: glDeleteShader gl:glDeleteShader
+ALIAS: glDetachShader gl:glDetachShader
+ALIAS: glDisableVertexAttribArray gl:glDisableVertexAttribArray
+ALIAS: glEnableVertexAttribArray gl:glEnableVertexAttribArray
+ALIAS: glGetActiveAttrib gl:glGetActiveAttrib
+ALIAS: glGetActiveUniform gl:glGetActiveUniform
+ALIAS: glGetAttachedShaders gl:glGetAttachedShaders
+ALIAS: glGetAttribLocation gl:glGetAttribLocation
+ALIAS: glGetProgramiv gl:glGetProgramiv
+ALIAS: glGetProgramInfoLog gl:glGetProgramInfoLog
+ALIAS: glGetShaderiv gl:glGetShaderiv
+ALIAS: glGetShaderInfoLog gl:glGetShaderInfoLog
+ALIAS: glGetShaderSource gl:glGetShaderSource
+ALIAS: glGetUniformLocation gl:glGetUniformLocation
+ALIAS: glGetUniformfv gl:glGetUniformfv
+ALIAS: glGetUniformiv gl:glGetUniformiv
+ALIAS: glGetVertexAttribdv gl:glGetVertexAttribdv
+ALIAS: glGetVertexAttribfv gl:glGetVertexAttribfv
+ALIAS: glGetVertexAttribiv gl:glGetVertexAttribiv
+ALIAS: glGetVertexAttribPointerv gl:glGetVertexAttribPointerv
+ALIAS: glIsProgram gl:glIsProgram
+ALIAS: glIsShader gl:glIsShader
+ALIAS: glLinkProgram gl:glLinkProgram
+ALIAS: glShaderSource gl:glShaderSource
+ALIAS: glUseProgram gl:glUseProgram
+ALIAS: glUniform1f gl:glUniform1f
+ALIAS: glUniform2f gl:glUniform2f
+ALIAS: glUniform3f gl:glUniform3f
+ALIAS: glUniform4f gl:glUniform4f
+ALIAS: glUniform1i gl:glUniform1i
+ALIAS: glUniform2i gl:glUniform2i
+ALIAS: glUniform3i gl:glUniform3i
+ALIAS: glUniform4i gl:glUniform4i
+ALIAS: glUniform1fv gl:glUniform1fv
+ALIAS: glUniform2fv gl:glUniform2fv
+ALIAS: glUniform3fv gl:glUniform3fv
+ALIAS: glUniform4fv gl:glUniform4fv
+ALIAS: glUniform1iv gl:glUniform1iv
+ALIAS: glUniform2iv gl:glUniform2iv
+ALIAS: glUniform3iv gl:glUniform3iv
+ALIAS: glUniform4iv gl:glUniform4iv
+ALIAS: glUniformMatrix2fv gl:glUniformMatrix2fv
+ALIAS: glUniformMatrix3fv gl:glUniformMatrix3fv
+ALIAS: glUniformMatrix4fv gl:glUniformMatrix4fv
+ALIAS: glValidateProgram gl:glValidateProgram
+ALIAS: glVertexAttrib1d gl:glVertexAttrib1d
+ALIAS: glVertexAttrib1dv gl:glVertexAttrib1dv
+ALIAS: glVertexAttrib1f gl:glVertexAttrib1f
+ALIAS: glVertexAttrib1fv gl:glVertexAttrib1fv
+ALIAS: glVertexAttrib1s gl:glVertexAttrib1s
+ALIAS: glVertexAttrib1sv gl:glVertexAttrib1sv
+ALIAS: glVertexAttrib2d gl:glVertexAttrib2d
+ALIAS: glVertexAttrib2dv gl:glVertexAttrib2dv
+ALIAS: glVertexAttrib2f gl:glVertexAttrib2f
+ALIAS: glVertexAttrib2fv gl:glVertexAttrib2fv
+ALIAS: glVertexAttrib2s gl:glVertexAttrib2s
+ALIAS: glVertexAttrib2sv gl:glVertexAttrib2sv
+ALIAS: glVertexAttrib3d gl:glVertexAttrib3d
+ALIAS: glVertexAttrib3dv gl:glVertexAttrib3dv
+ALIAS: glVertexAttrib3f gl:glVertexAttrib3f
+ALIAS: glVertexAttrib3fv gl:glVertexAttrib3fv
+ALIAS: glVertexAttrib3s gl:glVertexAttrib3s
+ALIAS: glVertexAttrib3sv gl:glVertexAttrib3sv
+ALIAS: glVertexAttrib4Nbv gl:glVertexAttrib4Nbv
+ALIAS: glVertexAttrib4Niv gl:glVertexAttrib4Niv
+ALIAS: glVertexAttrib4Nsv gl:glVertexAttrib4Nsv
+ALIAS: glVertexAttrib4Nub gl:glVertexAttrib4Nub
+ALIAS: glVertexAttrib4Nubv gl:glVertexAttrib4Nubv
+ALIAS: glVertexAttrib4Nuiv gl:glVertexAttrib4Nuiv
+ALIAS: glVertexAttrib4Nusv gl:glVertexAttrib4Nusv
+ALIAS: glVertexAttrib4bv gl:glVertexAttrib4bv
+ALIAS: glVertexAttrib4d gl:glVertexAttrib4d
+ALIAS: glVertexAttrib4dv gl:glVertexAttrib4dv
+ALIAS: glVertexAttrib4f gl:glVertexAttrib4f
+ALIAS: glVertexAttrib4fv gl:glVertexAttrib4fv
+ALIAS: glVertexAttrib4iv gl:glVertexAttrib4iv
+ALIAS: glVertexAttrib4s gl:glVertexAttrib4s
+ALIAS: glVertexAttrib4sv gl:glVertexAttrib4sv
+ALIAS: glVertexAttrib4ubv gl:glVertexAttrib4ubv
+ALIAS: glVertexAttrib4uiv gl:glVertexAttrib4uiv
+ALIAS: glVertexAttrib4usv gl:glVertexAttrib4usv
+ALIAS: glVertexAttribPointer gl:glVertexAttribPointer
+ALIAS: glUniformMatrix2x3fv gl:glUniformMatrix2x3fv
+ALIAS: glUniformMatrix3x2fv gl:glUniformMatrix3x2fv
+ALIAS: glUniformMatrix2x4fv gl:glUniformMatrix2x4fv
+ALIAS: glUniformMatrix4x2fv gl:glUniformMatrix4x2fv
+ALIAS: glUniformMatrix3x4fv gl:glUniformMatrix3x4fv
+ALIAS: glUniformMatrix4x3fv gl:glUniformMatrix4x3fv
+ALIAS: glColorMaski gl:glColorMaski
+ALIAS: glGetBooleani_v gl:glGetBooleani_v
+ALIAS: glGetIntegeri_v gl:glGetIntegeri_v
+ALIAS: glEnablei gl:glEnablei
+ALIAS: glDisablei gl:glDisablei
+ALIAS: glIsEnabledi gl:glIsEnabledi
+ALIAS: glBeginTransformFeedback gl:glBeginTransformFeedback
+ALIAS: glEndTransformFeedback gl:glEndTransformFeedback
+ALIAS: glBindBufferRange gl:glBindBufferRange
+ALIAS: glBindBufferBase gl:glBindBufferBase
+ALIAS: glTransformFeedbackVaryings gl:glTransformFeedbackVaryings
+ALIAS: glGetTransformFeedbackVarying gl:glGetTransformFeedbackVarying
+ALIAS: glClampColor gl:glClampColor
+ALIAS: glBeginConditionalRender gl:glBeginConditionalRender
+ALIAS: glEndConditionalRender gl:glEndConditionalRender
+ALIAS: glVertexAttribIPointer gl:glVertexAttribIPointer
+ALIAS: glGetVertexAttribIiv gl:glGetVertexAttribIiv
+ALIAS: glGetVertexAttribIuiv gl:glGetVertexAttribIuiv
+ALIAS: glGetUniformuiv gl:glGetUniformuiv
+ALIAS: glBindFragDataLocation gl:glBindFragDataLocation
+ALIAS: glGetFragDataLocation gl:glGetFragDataLocation
+ALIAS: glUniform1ui gl:glUniform1ui
+ALIAS: glUniform2ui gl:glUniform2ui
+ALIAS: glUniform3ui gl:glUniform3ui
+ALIAS: glUniform4ui gl:glUniform4ui
+ALIAS: glUniform1uiv gl:glUniform1uiv
+ALIAS: glUniform2uiv gl:glUniform2uiv
+ALIAS: glUniform3uiv gl:glUniform3uiv
+ALIAS: glUniform4uiv gl:glUniform4uiv
+ALIAS: glTexParameterIiv gl:glTexParameterIiv
+ALIAS: glTexParameterIuiv gl:glTexParameterIuiv
+ALIAS: glGetTexParameterIiv gl:glGetTexParameterIiv
+ALIAS: glGetTexParameterIuiv gl:glGetTexParameterIuiv
+ALIAS: glClearBufferiv gl:glClearBufferiv
+ALIAS: glClearBufferuiv gl:glClearBufferuiv
+ALIAS: glClearBufferfv gl:glClearBufferfv
+ALIAS: glClearBufferfi gl:glClearBufferfi
+ALIAS: glGetStringi gl:glGetStringi
+ALIAS: glDrawArraysInstanced gl:glDrawArraysInstanced
+ALIAS: glDrawElementsInstanced gl:glDrawElementsInstanced
+ALIAS: glTexBuffer gl:glTexBuffer
+ALIAS: glPrimitiveRestartIndex gl:glPrimitiveRestartIndex
+ALIAS: glIsRenderbuffer gl:glIsRenderbuffer
+ALIAS: glBindRenderbuffer gl:glBindRenderbuffer
+ALIAS: glDeleteRenderbuffers gl:glDeleteRenderbuffers
+ALIAS: glGenRenderbuffers gl:glGenRenderbuffers
+ALIAS: glRenderbufferStorage gl:glRenderbufferStorage
+ALIAS: glGetRenderbufferParameteriv gl:glGetRenderbufferParameteriv
+ALIAS: glIsFramebuffer gl:glIsFramebuffer
+ALIAS: glBindFramebuffer gl:glBindFramebuffer
+ALIAS: glDeleteFramebuffers gl:glDeleteFramebuffers
+ALIAS: glGenFramebuffers gl:glGenFramebuffers
+ALIAS: glCheckFramebufferStatus gl:glCheckFramebufferStatus
+ALIAS: glFramebufferTexture1D gl:glFramebufferTexture1D
+ALIAS: glFramebufferTexture2D gl:glFramebufferTexture2D
+ALIAS: glFramebufferTexture3D gl:glFramebufferTexture3D
+ALIAS: glFramebufferRenderbuffer gl:glFramebufferRenderbuffer
+ALIAS: glGetFramebufferAttachmentParameteriv gl:glGetFramebufferAttachmentParameteriv
+ALIAS: glGenerateMipmap gl:glGenerateMipmap
+ALIAS: glBlitFramebuffer gl:glBlitFramebuffer
+ALIAS: glRenderbufferStorageMultisample gl:glRenderbufferStorageMultisample
+ALIAS: glFramebufferTextureLayer gl:glFramebufferTextureLayer
+ALIAS: glMapBufferRange gl:glMapBufferRange
+ALIAS: glFlushMappedBufferRange gl:glFlushMappedBufferRange
+ALIAS: glBindVertexArray gl:glBindVertexArray
+ALIAS: glDeleteVertexArrays gl:glDeleteVertexArrays
+ALIAS: glGenVertexArrays gl:glGenVertexArrays
+ALIAS: glIsVertexArray gl:glIsVertexArray
+ALIAS: glGetUniformIndices gl:glGetUniformIndices
+ALIAS: glGetActiveUniformsiv gl:glGetActiveUniformsiv
+ALIAS: glGetActiveUniformName gl:glGetActiveUniformName
+ALIAS: glGetUniformBlockIndex gl:glGetUniformBlockIndex
+ALIAS: glGetActiveUniformBlockiv gl:glGetActiveUniformBlockiv
+ALIAS: glGetActiveUniformBlockName gl:glGetActiveUniformBlockName
+ALIAS: glUniformBlockBinding gl:glUniformBlockBinding
+ALIAS: glCopyBufferSubData gl:glCopyBufferSubData
--- /dev/null
+Forward-compatible subset of OpenGL 3.1
{ $description "Binds texture " { $snippet "id" } " to texture target " { $snippet "target" } " of texture unit " { $snippet "unit" } ". Equivalent to " { $snippet "unit glActiveTexture target id glBindTexture" } "." } ;
HELP: set-draw-buffers
-{ $values { "buffers" "A sequence of buffer words (e.g. " { $snippet "GL_BACK" } ", " { $snippet "GL_COLOR_ATTACHMENT0_EXT" } ")"} }
+{ $values { "buffers" "A sequence of buffer words (e.g. " { $snippet "GL_BACK" } ", " { $snippet "GL_COLOR_ATTACHMENT0" } ")"} }
{ $description "Wrapper for " { $link glDrawBuffers } ". Sets up the buffers named in the sequence for simultaneous drawing." } ;
HELP: do-attribs
{ HEX: 0503 "Stack overflow" }
{ HEX: 0504 "Stack underflow" }
{ HEX: 0505 "Out of memory" }
+ { HEX: 0506 "Invalid framebuffer operation" }
} at "Unknown error" or ;
TUPLE: gl-error code string ;
: (gen-gl-object) ( quot -- id )
[ 1 0 <uint> ] dip keep *uint ; inline
-: gen-gl-buffer ( -- id )
- [ glGenBuffers ] (gen-gl-object) ;
-
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
+: gen-gl-buffer ( -- id )
+ [ glGenBuffers ] (gen-gl-object) ;
+
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
GL_ARRAY_BUFFER swap _ with-gl-buffer
] with-gl-buffer ; inline
+: gen-vertex-array ( -- id )
+ [ glGenVertexArrays ] (gen-gl-object) ;
+
+: delete-vertex-array ( id -- )
+ [ glDeleteVertexArrays ] (delete-gl-object) ;
+
+:: with-vertex-array ( id quot -- )
+ id glBindVertexArray
+ quot [ 0 glBindVertexArray ] [ ] cleanup ; inline
+
: <gl-buffer> ( target data hint -- id )
pick gen-gl-buffer [
[
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
- glLoadIdentity ;
\ No newline at end of file
+ glLoadIdentity ;
! Programs
+: <mrt-gl-program> ( shaders frag-data-locations -- program )
+ glCreateProgram
+ [
+ [ swap [ glAttachShader ] with each ]
+ [ swap [ first2 swap glBindFragDataLocation ] with each ] bi-curry bi*
+ ]
+ [ glLinkProgram ]
+ [ ] tri
+ gl-error ;
+
: <gl-program> ( shaders -- program )
- glCreateProgram swap
- [ dupd glAttachShader ] each
- [ glLinkProgram ] keep
+ glCreateProgram
+ [ swap [ glAttachShader ] with each ]
+ [ glLinkProgram ]
+ [ ] tri
gl-error ;
: (gl-program?) ( object -- ? )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test opengl.textures opengl.textures.private
-images kernel namespaces accessors sequences ;
+USING: tools.test opengl.gl opengl.textures opengl.textures.private
+images kernel namespaces accessors sequences literals ;
IN: opengl.textures.tests
[
{ { 10 30 } { 30 300 } }
}
[ [ image new swap >>dim ] map ] map image-locs
-] unit-test
\ No newline at end of file
+] unit-test
+
+${ GL_RGBA8 GL_RGBA GL_UNSIGNED_BYTE }
+[ RGBA ubyte-components (image-format) ] unit-test
+
+${ GL_RGBA8 GL_BGRA GL_UNSIGNED_BYTE }
+[ BGRA ubyte-components (image-format) ] unit-test
+
+${ GL_RGBA8 GL_BGRA GL_UNSIGNED_INT_8_8_8_8_REV }
+[ ARGB ubyte-components (image-format) ] unit-test
+
+${ GL_RGBA32F GL_RGBA GL_FLOAT }
+[ RGBA float-components (image-format) ] unit-test
+
+${ GL_RGBA32UI GL_BGRA_INTEGER GL_UNSIGNED_INT }
+[ BGRA uint-integer-components (image-format) ] unit-test
+
+${ GL_RGB9_E5 GL_RGB GL_UNSIGNED_INT_5_9_9_9_REV }
+[ BGR u-9-9-9-e5-components (image-format) ] unit-test
+
+${ GL_R11F_G11F_B10F GL_RGB GL_UNSIGNED_INT_10F_11F_11F_REV }
+[ BGR float-11-11-10-components (image-format) ] unit-test
opengl opengl.gl opengl.capabilities combinators images
images.tesselation grouping specialized-arrays.float sequences math
math.vectors math.matrices generalizations fry arrays namespaces
-system ;
+system locals literals ;
IN: opengl.textures
SYMBOL: non-power-of-2-textures?
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
-GENERIC: component-order>format ( component-order -- format type )
+ERROR: unsupported-component-order component-order component-type ;
+
+CONSTANT: image-internal-formats H{
+ { { A ubyte-components } $ GL_ALPHA8 }
+ { { A ushort-components } $ GL_ALPHA16 }
+ { { A half-components } $ GL_ALPHA16F_ARB }
+ { { A float-components } $ GL_ALPHA32F_ARB }
+ { { A byte-integer-components } $ GL_ALPHA8I_EXT }
+ { { A ubyte-integer-components } $ GL_ALPHA8UI_EXT }
+ { { A short-integer-components } $ GL_ALPHA16I_EXT }
+ { { A ushort-integer-components } $ GL_ALPHA16UI_EXT }
+ { { A int-integer-components } $ GL_ALPHA32I_EXT }
+ { { A uint-integer-components } $ GL_ALPHA32UI_EXT }
+
+ { { L ubyte-components } $ GL_LUMINANCE8 }
+ { { L ushort-components } $ GL_LUMINANCE16 }
+ { { L half-components } $ GL_LUMINANCE16F_ARB }
+ { { L float-components } $ GL_LUMINANCE32F_ARB }
+ { { L byte-integer-components } $ GL_LUMINANCE8I_EXT }
+ { { L ubyte-integer-components } $ GL_LUMINANCE8UI_EXT }
+ { { L short-integer-components } $ GL_LUMINANCE16I_EXT }
+ { { L ushort-integer-components } $ GL_LUMINANCE16UI_EXT }
+ { { L int-integer-components } $ GL_LUMINANCE32I_EXT }
+ { { L uint-integer-components } $ GL_LUMINANCE32UI_EXT }
+
+ { { R ubyte-components } $ GL_R8 }
+ { { R ushort-components } $ GL_R16 }
+ { { R half-components } $ GL_R16F }
+ { { R float-components } $ GL_R32F }
+ { { R byte-integer-components } $ GL_R8I }
+ { { R ubyte-integer-components } $ GL_R8UI }
+ { { R short-integer-components } $ GL_R16I }
+ { { R ushort-integer-components } $ GL_R16UI }
+ { { R int-integer-components } $ GL_R32I }
+ { { R uint-integer-components } $ GL_R32UI }
+
+ { { INTENSITY ubyte-components } $ GL_INTENSITY8 }
+ { { INTENSITY ushort-components } $ GL_INTENSITY16 }
+ { { INTENSITY half-components } $ GL_INTENSITY16F_ARB }
+ { { INTENSITY float-components } $ GL_INTENSITY32F_ARB }
+ { { INTENSITY byte-integer-components } $ GL_INTENSITY8I_EXT }
+ { { INTENSITY ubyte-integer-components } $ GL_INTENSITY8UI_EXT }
+ { { INTENSITY short-integer-components } $ GL_INTENSITY16I_EXT }
+ { { INTENSITY ushort-integer-components } $ GL_INTENSITY16UI_EXT }
+ { { INTENSITY int-integer-components } $ GL_INTENSITY32I_EXT }
+ { { INTENSITY uint-integer-components } $ GL_INTENSITY32UI_EXT }
+
+ { { DEPTH ushort-components } $ GL_DEPTH_COMPONENT16 }
+ { { DEPTH u-24-components } $ GL_DEPTH_COMPONENT24 }
+ { { DEPTH uint-components } $ GL_DEPTH_COMPONENT32 }
+ { { DEPTH float-components } $ GL_DEPTH_COMPONENT32F }
+
+ { { LA ubyte-components } $ GL_LUMINANCE8_ALPHA8 }
+ { { LA ushort-components } $ GL_LUMINANCE16_ALPHA16 }
+ { { LA half-components } $ GL_LUMINANCE_ALPHA16F_ARB }
+ { { LA float-components } $ GL_LUMINANCE_ALPHA32F_ARB }
+ { { LA byte-integer-components } $ GL_LUMINANCE_ALPHA8I_EXT }
+ { { LA ubyte-integer-components } $ GL_LUMINANCE_ALPHA8UI_EXT }
+ { { LA short-integer-components } $ GL_LUMINANCE_ALPHA16I_EXT }
+ { { LA ushort-integer-components } $ GL_LUMINANCE_ALPHA16UI_EXT }
+ { { LA int-integer-components } $ GL_LUMINANCE_ALPHA32I_EXT }
+ { { LA uint-integer-components } $ GL_LUMINANCE_ALPHA32UI_EXT }
+
+ { { RG ubyte-components } $ GL_RG8 }
+ { { RG ushort-components } $ GL_RG16 }
+ { { RG half-components } $ GL_RG16F }
+ { { RG float-components } $ GL_RG32F }
+ { { RG byte-integer-components } $ GL_RG8I }
+ { { RG ubyte-integer-components } $ GL_RG8UI }
+ { { RG short-integer-components } $ GL_RG16I }
+ { { RG ushort-integer-components } $ GL_RG16UI }
+ { { RG int-integer-components } $ GL_RG32I }
+ { { RG uint-integer-components } $ GL_RG32UI }
+
+ { { DEPTH-STENCIL u-24-8-components } $ GL_DEPTH24_STENCIL8 }
+ { { DEPTH-STENCIL float-32-u-8-components } $ GL_DEPTH32F_STENCIL8 }
+
+ { { RGB ubyte-components } $ GL_RGB8 }
+ { { RGB ushort-components } $ GL_RGB16 }
+ { { RGB half-components } $ GL_RGB16F }
+ { { RGB float-components } $ GL_RGB32F }
+ { { RGB byte-integer-components } $ GL_RGB8I }
+ { { RGB ubyte-integer-components } $ GL_RGB8UI }
+ { { RGB byte-integer-components } $ GL_RGB8I }
+ { { RGB ubyte-integer-components } $ GL_RGB8UI }
+ { { RGB short-integer-components } $ GL_RGB16I }
+ { { RGB ushort-integer-components } $ GL_RGB16UI }
+ { { RGB int-integer-components } $ GL_RGB32I }
+ { { RGB uint-integer-components } $ GL_RGB32UI }
+ { { RGB u-5-6-5-components } $ GL_RGB5 }
+ { { RGB u-9-9-9-e5-components } $ GL_RGB9_E5 }
+ { { RGB float-11-11-10-components } $ GL_R11F_G11F_B10F }
+
+ { { RGBA ubyte-components } $ GL_RGBA8 }
+ { { RGBA ushort-components } $ GL_RGBA16 }
+ { { RGBA half-components } $ GL_RGBA16F }
+ { { RGBA float-components } $ GL_RGBA32F }
+ { { RGBA byte-integer-components } $ GL_RGBA8I }
+ { { RGBA ubyte-integer-components } $ GL_RGBA8UI }
+ { { RGBA byte-integer-components } $ GL_RGBA8I }
+ { { RGBA ubyte-integer-components } $ GL_RGBA8UI }
+ { { RGBA short-integer-components } $ GL_RGBA16I }
+ { { RGBA ushort-integer-components } $ GL_RGBA16UI }
+ { { RGBA int-integer-components } $ GL_RGBA32I }
+ { { RGBA uint-integer-components } $ GL_RGBA32UI }
+ { { RGBA u-5-5-5-1-components } $ GL_RGB5_A1 }
+ { { RGBA u-10-10-10-2-components } $ GL_RGB10_A2 }
+}
+
+GENERIC: fix-internal-component-order ( order -- order' )
+
+M: object fix-internal-component-order ;
+M: BGR fix-internal-component-order drop RGB ;
+M: BGRA fix-internal-component-order drop RGBA ;
+M: ARGB fix-internal-component-order drop RGBA ;
+M: ABGR fix-internal-component-order drop RGBA ;
+M: RGBX fix-internal-component-order drop RGBA ;
+M: BGRX fix-internal-component-order drop RGBA ;
+M: XRGB fix-internal-component-order drop RGBA ;
+M: XBGR fix-internal-component-order drop RGBA ;
+
+: image-internal-format ( component-order component-type -- internal-format )
+ 2dup
+ [ fix-internal-component-order ] dip 2array image-internal-formats at
+ [ 2nip ] [ unsupported-component-order ] if* ;
+
+: reversed-type? ( component-type -- ? )
+ { u-9-9-9-e5-components float-11-11-10-components } member? ;
+
+: (component-order>format) ( component-order component-type -- gl-format )
+ dup unnormalized-integer-components? [
+ swap {
+ { A [ drop GL_ALPHA_INTEGER_EXT ] }
+ { L [ drop GL_LUMINANCE_INTEGER_EXT ] }
+ { R [ drop GL_RED_INTEGER ] }
+ { LA [ drop GL_LUMINANCE_ALPHA_INTEGER_EXT ] }
+ { RG [ drop GL_RG_INTEGER ] }
+ { BGR [ drop GL_BGR_INTEGER ] }
+ { RGB [ drop GL_RGB_INTEGER ] }
+ { BGRA [ drop GL_BGRA_INTEGER ] }
+ { RGBA [ drop GL_RGBA_INTEGER ] }
+ { BGRX [ drop GL_BGRA_INTEGER ] }
+ { RGBX [ drop GL_RGBA_INTEGER ] }
+ [ swap unsupported-component-order ]
+ } case
+ ] [
+ swap {
+ { A [ drop GL_ALPHA ] }
+ { L [ drop GL_LUMINANCE ] }
+ { R [ drop GL_RED ] }
+ { LA [ drop GL_LUMINANCE_ALPHA ] }
+ { RG [ drop GL_RG ] }
+ { BGR [ reversed-type? GL_RGB GL_BGR ? ] }
+ { RGB [ reversed-type? GL_BGR GL_RGB ? ] }
+ { BGRA [ drop GL_BGRA ] }
+ { RGBA [ drop GL_RGBA ] }
+ { ARGB [ drop GL_BGRA ] }
+ { ABGR [ drop GL_RGBA ] }
+ { BGRX [ drop GL_BGRA ] }
+ { RGBX [ drop GL_RGBA ] }
+ { XRGB [ drop GL_BGRA ] }
+ { XBGR [ drop GL_RGBA ] }
+ { INTENSITY [ drop GL_INTENSITY ] }
+ { DEPTH [ drop GL_DEPTH_COMPONENT ] }
+ { DEPTH-STENCIL [ drop GL_DEPTH_STENCIL ] }
+ [ swap unsupported-component-order ]
+ } case
+ ] if ;
+
+GENERIC: (component-type>type) ( component-order component-type -- gl-type )
+
+M: object (component-type>type) unsupported-component-order ;
+
+: four-channel-alpha-first? ( component-order component-type -- ? )
+ over component-count 4 =
+ [ drop alpha-channel-precedes-colors? ]
+ [ unsupported-component-order ] if ;
+
+: not-alpha-first ( component-order component-type -- )
+ over alpha-channel-precedes-colors?
+ [ unsupported-component-order ]
+ [ 2drop ] if ;
+
+M: ubyte-components (component-type>type)
+ drop alpha-channel-precedes-colors?
+ [ GL_UNSIGNED_INT_8_8_8_8_REV ]
+ [ GL_UNSIGNED_BYTE ] if ;
+
+M: ushort-components (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
+M: uint-components (component-type>type) not-alpha-first GL_UNSIGNED_INT ;
+M: half-components (component-type>type) not-alpha-first GL_HALF_FLOAT ;
+M: float-components (component-type>type) not-alpha-first GL_FLOAT ;
+M: byte-integer-components (component-type>type) not-alpha-first GL_BYTE ;
+M: ubyte-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_BYTE ;
+M: short-integer-components (component-type>type) not-alpha-first GL_SHORT ;
+M: ushort-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
+M: int-integer-components (component-type>type) not-alpha-first GL_INT ;
+M: uint-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_INT ;
+
+M: u-5-5-5-1-components (component-type>type)
+ four-channel-alpha-first?
+ [ GL_UNSIGNED_SHORT_1_5_5_5_REV ]
+ [ GL_UNSIGNED_SHORT_5_5_5_1 ] if ;
+
+M: u-5-6-5-components (component-type>type) 2drop GL_UNSIGNED_SHORT_5_6_5 ;
-M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
-M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
-M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
-M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
-M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
-M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
-M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
-M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
+M: u-10-10-10-2-components (component-type>type)
+ four-channel-alpha-first?
+ [ GL_UNSIGNED_INT_2_10_10_10_REV ]
+ [ GL_UNSIGNED_INT_10_10_10_2 ] if ;
+
+M: u-24-components (component-type>type)
+ over DEPTH =
+ [ 2drop GL_UNSIGNED_INT ] [ unsupported-component-order ] if ;
+
+M: u-24-8-components (component-type>type)
+ over DEPTH-STENCIL =
+ [ 2drop GL_UNSIGNED_INT_24_8 ] [ unsupported-component-order ] if ;
+
+M: u-9-9-9-e5-components (component-type>type)
+ over BGR =
+ [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ] [ unsupported-component-order ] if ;
+
+M: float-11-11-10-components (component-type>type)
+ over BGR =
+ [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ] [ unsupported-component-order ] if ;
+
+: image-data-format ( component-order component-type -- gl-format gl-type )
+ [ (component-order>format) ] [ (component-type>type) ] 2bi ;
SLOT: display-list
DEFER: make-texture
+: (image-format) ( component-order component-type -- internal-format format type )
+ [ image-internal-format ] [ image-data-format ] 2bi ;
+
+: image-format ( image -- internal-format format type )
+ [ component-order>> ] [ component-type>> ] bi (image-format) ;
+
<PRIVATE
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
[ dup 1 = [ next-power-of-2 ] unless ] map
] unless ;
-: tex-image ( image bitmap -- )
- [
- [ GL_TEXTURE_2D 0 GL_RGBA ] dip
- [ dim>> adjust-texture-dim first2 0 ]
- [ component-order>> component-order>format ] bi
- ] dip
- 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 -- )
[ GL_TEXTURE_2D 0 0 0 ] dip
[ dim>> first2 ]
- [ component-order>> component-order>format ]
+ [ image-format [ drop ] 2dip ]
[ bitmap>> ] tri
glTexSubImage2D ;
[ dup image-locs ] dip
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
-: draw-textured-grid ( grid -- )
- [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
-
: grid-has-alpha? ( grid -- ? )
first first image>> has-alpha? ;
IN: persistent.vectors
HELP: PV{
-{ $syntax "elements... }" }
+{ $syntax "PV{ elements... }" }
{ $description "Parses a literal " { $link persistent-vector } "." } ;
HELP: >persistent-vector
[ "Hi" ] [ "Hi" present ] unit-test
[ "+" ] [ \ + present ] unit-test
[ "kernel" ] [ "kernel" vocab present ] unit-test
-[ ] [ all-vocabs-seq [ present ] map drop ] unit-test
\ No newline at end of file
+[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test
\ No newline at end of file
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
] unit-test
+
+TUPLE: tuple-with-declared-slot { x integer } ;
+
+[
+ {
+ "USING: math ;"
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-declared-slot see ] with-string-writer "\n" split
+] unit-test
+
+TUPLE: tuple-with-read-only-slot { x read-only } ;
+
+[
+ {
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-read-only-slot { x read-only } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-read-only-slot see ] with-string-writer "\n" split
+] unit-test
+
+TUPLE: tuple-with-initial-slot { x initial: 123 } ;
+
+[
+ {
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-initial-slot see ] with-string-writer "\n" split
+] unit-test
+
+TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
+
+[
+ {
+ "USING: math ;"
+ "IN: prettyprint.tests"
+ "TUPLE: tuple-with-initial-declared-slot"
+ " { x integer initial: 123 } ;"
+ ""
+ }
+] [
+ [ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
+] unit-test
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs fry generalizations grouping
-kernel lexer macros make math math.order math.vectors
+USING: accessors arrays assocs effects fry generalizations
+grouping kernel lexer macros math math.order math.vectors
namespaces parser quotations sequences sequences.private
-splitting.monotonic stack-checker strings unicode.case
-words effects ;
+splitting.monotonic stack-checker strings unicode.case words ;
IN: roman
<PRIVATE
ERROR: roman-range-error n ;
-: roman-range-check ( n -- )
- dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
+: roman-range-check ( n -- n )
+ dup 1 3999 between? [ roman-range-error ] unless ;
: roman-digit-index ( ch -- n )
1string roman-digits index ; inline
-: roman<= ( ch1 ch2 -- ? )
+: roman>= ( ch1 ch2 -- ? )
[ roman-digit-index ] bi@ >= ;
: roman>n ( ch -- n )
roman-digit-index roman-values nth ;
-: (>roman) ( n -- )
- roman-values roman-digits [
- [ /mod swap ] dip <repetition> concat %
- ] 2each drop ;
-
: (roman>) ( seq -- n )
[ [ roman>n ] map ] [ all-eq? ] bi
[ sum ] [ first2 swap - ] if ;
PRIVATE>
: >roman ( n -- str )
- dup roman-range-check [ (>roman) ] "" make ;
+ roman-range-check
+ roman-values roman-digits [
+ [ /mod swap ] dip <repetition> concat
+ ] 2map "" concat-as nip ;
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
- >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
+ >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
<PRIVATE
PRIVATE>
<<
+
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
dup infer [ in>> ] [ out>> ] bi
[ "string" <repetition> ] bi@ <effect> define-declared ;
+
>>
ROMAN-OP: +
dup name>> ,
dup class>> object eq? [
dup class>> ,
- initial: ,
- dup initial>> ,
] unless
dup read-only>> [
read-only ,
] when
+ dup [ class>> object eq? not ] [ initial>> ] bi or [
+ initial: ,
+ dup initial>> ,
+ ] when
drop
] { } make ;
help.markup splitting io.streams.byte-array io.encodings.string
io.encodings.utf8 io.encodings.binary combinators accessors
locals prettyprint compiler.units sequences.private
-classes.tuple.private ;
+classes.tuple.private vocabs.loader ;
IN: serialize
GENERIC: (serialize) ( obj -- )
(deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
- (deserialize) (deserialize) 2dup lookup
+ (deserialize) (deserialize) 2dup [ require ] keep lookup
dup [ 2nip ] [
drop
2array unparse "Unknown word: " prepend throw
USE: specialized-arrays.functor
IN: specialized-arrays.alien
-<< "void*" define-array >>
\ No newline at end of file
+<< "void*" define-array >>
+<< "ptrdiff_t" define-array >>
"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" }
"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:"
{ $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."
--- /dev/null
+
+: spill-integer-base ( -- n )
+ stack-frame get spill-counts>> double-float-regs swap at
+ double-float-regs reg-size * ;
+
+: spill-integer@ ( n -- offset )
+ cells spill-integer-base + param@ ;
+
+: spill-float@ ( n -- offset )
+ double-float-regs reg-size * param@ ;
+
+: (stack-frame-size) ( stack-frame -- n )
+ [
+ {
+ [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+ [ gc-roots>> cells ]
+ [ params>> ]
+ [ return>> ]
+ } cleave
+ ] sum-outputs ;
\ No newline at end of file
: thread-registered? ( thread -- ? )
id>> threads key? ;
+ERROR: already-stopped thread ;
+
: check-unregistered ( thread -- thread )
- dup thread-registered?
- [ "Thread already stopped" throw ] when ;
+ dup thread-registered? [ already-stopped ] when ;
+
+ERROR: not-running thread ;
: check-registered ( thread -- thread )
- dup thread-registered?
- [ "Thread is not running" throw ] unless ;
+ dup thread-registered? [ not-running ] unless ;
<PRIVATE
[ ] [ M\ string blah-generic watch ] unit-test
[ "hi" ] [ "hi" blah-generic ] unit-test
+
+! See how well watch interacts with optimizations.
+GENERIC: my-generic ( a -- b )
+M: object my-generic ;
+
+\ my-generic watch
+
+: some-code ( -- )
+ f my-generic drop ;
+
+[ ] [ some-code ] unit-test
\ No newline at end of file
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry tools.continuations ;
+tools.time generic inspector fry tools.continuations
+locals generalizations macros ;
IN: tools.annotations
GENERIC: reset ( word -- )
<PRIVATE
-: stack-values ( names -- alist )
- [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
-
-: trace-message ( word quot str -- )
- "--- " write write bl over .
- [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
- [ simple-table. ] unless-empty flush ; inline
+:: trace-quot ( word effect quot str -- quot' )
+ effect quot call :> values
+ values length :> n
+ [
+ "--- " write str write bl word .
+ n ndup n narray values swap zip simple-table.
+ flush
+ ] ; inline
-: entering ( str -- ) [ in>> ] "Entering" trace-message ;
+MACRO: entering ( word -- quot )
+ dup stack-effect [ in>> ] "Entering" trace-quot ;
-: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
+MACRO: leaving ( word -- quot )
+ dup stack-effect [ out>> ] "Leaving" trace-quot ;
: (watch) ( word def -- def )
over '[ _ entering @ _ leaving ] ;
all-words name-completions ;
: vocabs-matching ( str -- seq )
- all-vocabs-seq name-completions ;
+ all-vocabs-recursive no-roots no-prefixes name-completions ;
: chars-matching ( str -- seq )
name-map keys dup zip completions ;
[ nip require ]
} 2cleave ;
+: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
+
+: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
+
+: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
+
+: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
+
<PRIVATE
: tests-file-string ( vocab -- string )
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
-: with-gl-context ( handle quot -- )
- '[ select-gl-context @ ]
- [ flush-gl-context gl-error ] bi ; inline
-
HOOK: (with-ui) ui-backend ( quot -- )
HOOK: (grab-input) ui-backend ( handle -- )
cocoa.views cocoa.windows combinators command-line
core-foundation core-foundation.run-loop core-graphics
core-graphics.types destructors fry generalizations io.thread
-kernel libc literals locals math math.rectangles memory
+kernel libc literals locals math math.bitwise math.rectangles memory
namespaces sequences specialized-arrays.int threads ui
ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
M: cocoa-ui-backend (fullscreen?) ( world -- ? )
handle>> view>> -> isInFullScreenMode zero? not ;
+CONSTANT: window-control>styleMask
+ H{
+ { close-button $ NSClosableWindowMask }
+ { minimize-button $ NSMiniaturizableWindowMask }
+ { maximize-button 0 }
+ { resize-handles $ NSResizableWindowMask }
+ { small-title-bar $[ NSTitledWindowMask NSUtilityWindowMask bitor ] }
+ { normal-title-bar $ NSTitledWindowMask }
+ }
+
+: world>styleMask ( world -- n )
+ window-controls>> window-control>styleMask symbols>flags ;
+
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
with-world-pixel-format :> view
- view world world>NSRect <ViewWindow> :> window
+ view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window
view -> release
world view register-window
window world window-loc>> auto-position
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
handle>> [
- window>> f -> performClose:
+ window>> -> close
] when*
] when* ;
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs cocoa kernel math
-cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
-cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gestures core-foundation.strings core-graphics core-graphics.types
-threads combinators math.rectangles ;
+USING: accessors alien alien.c-types alien.strings arrays assocs
+cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes
+cocoa.views cocoa.application cocoa.pasteboard cocoa.types
+cocoa.windows sequences io.encodings.ascii ui ui.private ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types threads
+combinators math.rectangles ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
[ drop dim>> first2 ]
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: {
{ +superclass+ "NSOpenGLView" }
{ +name+ "FactorView" }
[ 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" }
[ nip undo-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.
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
windows.messages windows.types windows.offscreen windows.nt
threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render math.bitwise locals
-accessors math.rectangles math.order calendar ascii
+accessors math.rectangles math.order calendar ascii sets
io.encodings.utf16n windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes struct-arrays ;
IN: ui.backend.windows
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
-: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
-: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+CONSTANT: window-control>style
+ H{
+ { close-button 0 }
+ { minimize-button $ WS_MINIMIZEBOX }
+ { maximize-button $ WS_MAXIMIZEBOX }
+ { resize-handles $ WS_THICKFRAME }
+ { small-title-bar $ WS_CAPTION }
+ { normal-title-bar $ WS_CAPTION }
+ }
+
+CONSTANT: window-control>ex-style
+ H{
+ { close-button 0 }
+ { minimize-button 0 }
+ { maximize-button 0 }
+ { resize-handles $ WS_EX_WINDOWEDGE }
+ { small-title-bar $ WS_EX_TOOLWINDOW }
+ { normal-title-bar $ WS_EX_APPWINDOW }
+ }
+
+: needs-sysmenu? ( controls -- ? )
+ { close-button minimize-button maximize-button } intersects? ;
+
+: has-titlebar? ( controls -- ? )
+ { small-title-bar normal-title-bar } intersects? ;
+
+: world>style ( world -- n )
+ window-controls>>
+ [ window-control>style symbols>flags ]
+ [ needs-sysmenu? [ WS_SYSMENU bitor ] when ]
+ [ has-titlebar? [ WS_POPUP bitor ] unless ] tri ;
+
+: world>ex-style ( world -- n )
+ window-controls>> window-control>ex-style symbols>flags ;
: get-RECT-top-left ( RECT -- x y )
[ RECT-left ] keep RECT-top ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
+ dup { 0 0 } = [ 2drop ] [ swap window [ (>>dim) ] [ drop ] if* ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- swap window (>>window-loc) ;
+ swap window [ (>>window-loc) ] [ drop ] if* ;
CONSTANT: wm-keydown-codes
H{
RegisterClassEx win32-error=0/f
] [ drop ] if ;
-: adjust-RECT ( RECT -- )
- style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+: adjust-RECT ( RECT style ex-style -- )
+ [ 0 ] dip AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
[ window-loc>> ] [ dim>> ] bi <RECT> ;
CW_USEDEFAULT over set-RECT-left
CW_USEDEFAULT swap set-RECT-top ;
-: make-adjusted-RECT ( rect -- RECT )
- make-RECT
- dup get-RECT-top-left [ zero? ] both? swap
- dup adjust-RECT
+: make-adjusted-RECT ( rect style ex-style -- RECT )
+ [
+ make-RECT
+ dup get-RECT-top-left [ zero? ] both? swap
+ dup
+ ] 2dip adjust-RECT
swap [ dup default-position-RECT ] when ;
: get-window-class ( -- class-name )
dup
] change-global ;
-: create-window ( rect -- hwnd )
- make-adjusted-RECT
+:: create-window ( rect style ex-style -- hwnd )
+ rect style ex-style make-adjusted-RECT
[ get-window-class f ] dip
[
[ ex-style ] 2dip
- { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
+ WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
] dip get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
[ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
with-world-pixel-format ;
+: disable-close-button ( hwnd -- )
+ 0 GetSystemMenu
+ SC_CLOSE MF_BYCOMMAND MF_GRAYED bitor EnableMenuItem drop ;
+
+: ?disable-close-button ( world hwnd -- )
+ swap window-controls>> close-button swap member? not
+ [ disable-close-button ] [ drop ] if ;
+
M: windows-ui-backend (open-window) ( world -- )
- [ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
+ [
+ dup
+ [ ] [ world>style ] [ world>ex-style ] tri create-window
+ [ ?disable-close-button ]
+ [ [ f f ] dip f f <win> >>handle setup-gl ] 2bi
+ ]
[ dup handle>> hWnd>> register-window ]
[ handle>> hWnd>> show-window ] tri ;
} cleave ;
: exit-fullscreen ( world -- )
- handle>> hWnd>>
+ dup handle>> hWnd>>
{
- [
- GWL_STYLE GetWindowLong
- fullscreen-flags bitor
- ]
- [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
+ [ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
[
f
over hwnd>RECT get-RECT-dimensions
: max-descent ( seq -- n )
[ descent>> ] map ?supremum ;
-: max-text-height ( seq -- y )
- [ ascent>> ] filter [ height>> ] map ?supremum ;
-
: max-graphics-height ( seq -- y )
[ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
orientation>> vertical = "\n" "" ? ;
: gadget-seq-text ( seq gadget -- )
- gadget-text-separator swap
- [ dup % ] [ gadget-text* ] interleave drop ;
+ gadget-text-separator '[ _ % ] [ gadget-text* ] interleave ;
M: gadget gadget-text*
[ children>> ] keep gadget-seq-text ;
add-incremental
] [ next-line ] bi ;
-: ?pane-nl ( pane -- )
- [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
- [ pane-nl ] bi ;
-
: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
: pane-write ( seq pane -- )
] [ drop ] if ;
: end-selection ( pane -- )
- f >>selecting?
- hand-moved?
+ dup selecting?>> hand-moved? or
+ [ f >>selecting? ] dip
[ [ com-copy-selection ] [ request-focus ] bi ]
[ [ relayout-1 ] [ focus-input ] bi ]
if ;
[ ] [
<gadget> dup "g" set
- 10 1 0 100 <range> 20 1 0 100 <range> 2array <product>
+ 10 1 0 100 1 <range> 20 1 0 100 1 <range> 2array <product>
<viewport> "v" set
] unit-test
} set-gestures
: <scroller-model> ( -- model )
- 0 0 0 0 <range> 0 0 0 0 <range> 2array <product> ;
+ 0 0 0 0 1 <range> 0 0 0 0 1 <range> 2array <product> ;
M: viewport pref-dim* gadget-child pref-viewport-dim ;
HELP: elevator
{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
-HELP: find-elevator
-{ $values { "gadget" gadget } { "elevator/f" { $maybe elevator } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
-
HELP: slider
{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
$nl
TUPLE: slider < track elevator thumb saved line ;
-: slider-value ( gadget -- n ) model>> range-value >fixnum ;
+: slider-value ( gadget -- n ) model>> range-value ;
: slider-page ( gadget -- n ) model>> range-page-value ;
+: slider-min ( gadget -- n ) model>> range-min-value ;
: slider-max ( gadget -- n ) model>> range-max-value ;
: slider-max* ( gadget -- n ) model>> range-max-value* ;
+: slider-length ( gadget -- n ) [ slider-max ] [ slider-min ] bi - ;
+: slider-length* ( gadget -- n ) [ slider-max* ] [ slider-min ] bi - ;
+
: slide-by ( amount slider -- ) model>> move-by ;
: slide-by-page ( amount slider -- ) model>> move-by-page ;
TUPLE: elevator < gadget direction ;
-: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
-
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
CONSTANT: elevator-padding 4
CONSTANT: min-thumb-dim 30
: visible-portion ( slider -- n )
- [ slider-page ] [ slider-max 1 max ] bi / 1 min ;
+ [ slider-page ]
+ [ slider-length 1 max ]
+ bi / 1 min ;
: thumb-dim ( slider -- h )
[
#! x*n is the screen position of the thumb, and conversely
#! for x/n. The '1 max' calls avoid division by zero.
[ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
- [ slider-max* 1 max ]
+ [ slider-length* 1 max ]
bi / ;
: slider>screen ( m slider -- n ) slider-scale * ;
swap >>orientation ;
: thumb-loc ( slider -- loc )
- [ slider-value ] keep slider>screen elevator-padding + ;
+ [ slider-value ]
+ [ slider-min - ]
+ [ slider>screen elevator-padding + ] tri ;
: layout-thumb-loc ( thumb slider -- )
[ thumb-loc ] [ orientation>> ] bi n*v
[ <up-button> f track-add ]
[ <down-button> f track-add ]
[ drop <gadget> { 1 1 } >>dim f track-add ]
- } cleave ;
\ No newline at end of file
+ } cleave ;
+
if ;
: row-action? ( table -- ? )
- [ [ mouse-row ] keep valid-line? ]
- [ single-click?>> hand-click# get 2 = or ] bi and ;
+ single-click?>> hand-click# get 2 = or ;
<PRIVATE
: table-button-up ( table -- )
- dup row-action? [ row-action ] [ update-selected-value ] if ;
+ dup [ mouse-row ] keep valid-line? [
+ dup row-action? [ row-action ] [ update-selected-value ] if
+ ] [ drop ] if ;
PRIVATE>
USING: ui.gadgets ui.render ui.text ui.text.private
ui.gestures ui.backend help.markup help.syntax
-models opengl sequences strings ;
+models opengl sequences strings destructors ;
IN: ui.gadgets.worlds
HELP: user-input
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ;
-HELP: select-gl-context
-{ $values { "handle" "a backend-specific handle" } }
+HELP: context-world
+{ $var-description "Holds the " { $link world } " whose OpenGL context was most recently made active by " { $link set-gl-context } "." } ;
+
+HELP: set-gl-context
+{ $values { "world" world } }
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
+HELP: window-resource
+{ $values { "resource" disposable } { "resource" disposable } }
+{ $description "Marks " { $snippet "resource" } " to be destroyed with " { $link dispose } " when the window with the currently active OpenGL context (set by " { $link set-gl-context } ") is closed. " { $snippet "resource" } " is left unmodified at the top of the stack." } ;
+
HELP: flush-gl-context
{ $values { "handle" "a backend-specific handle" } }
{ $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;
{ { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." }
{ { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
{ { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
+ { { $snippet "window-controls" } " - the set of " { $link "ui.gadgets.worlds-window-controls" } " with which the world window was created." }
}
} ;
{ $subsection "ui.gadgets.worlds-subclassing" }
{ $subsection "gl-utilities" }
{ $subsection "text-rendering" } ;
+
ui.pixel-formats destructors literals strings ;
IN: ui.gadgets.worlds
+SYMBOLS:
+ close-button
+ minimize-button
+ maximize-button
+ resize-handles
+ small-title-bar
+ normal-title-bar ;
+
CONSTANT: default-world-pixel-format-attributes
{ windowed double-buffered T{ depth-bits { value 16 } } }
+CONSTANT: default-world-window-controls
+ {
+ normal-title-bar
+ close-button
+ minimize-button
+ maximize-button
+ resize-handles
+ }
+
TUPLE: world < track
active? focused? grab-input?
layers
title status status-owner
text-handle handle images
window-loc
- pixel-format-attributes ;
+ pixel-format-attributes
+ window-controls
+ window-resources ;
TUPLE: world-attributes
{ world-class initial: world }
{ title string initial: "Factor Window" }
status
gadgets
- { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
+ { pixel-format-attributes initial: $ default-world-pixel-format-attributes }
+ { window-controls initial: $ default-world-window-controls } ;
: <world-attributes> ( -- world-attributes )
world-attributes new ; inline
'[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when
] [ 2drop ] if ;
+SYMBOL: context-world
+
+: window-resource ( resource -- resource )
+ dup context-world get-global window-resources>> push ;
+
+: set-gl-context ( world -- )
+ [ context-world set-global ]
+ [ handle>> select-gl-context ] bi ;
+
+: with-gl-context ( world quot -- )
+ '[ set-gl-context @ ]
+ [ handle>> flush-gl-context gl-error ] bi ; inline
+
ERROR: no-world-found ;
: find-gl-context ( gadget -- )
find-world dup
- [ handle>> select-gl-context ] [ no-world-found ] if ;
+ [ set-gl-context ] [ no-world-found ] if ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
t >>root?
f >>active?
{ 0 0 } >>window-loc
- f >>grab-input? ;
+ f >>grab-input?
+ V{ } clone >>window-resources ;
: apply-world-attributes ( world attributes -- world )
{
[ title>> >>title ]
[ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ]
+ [ window-controls>> >>window-controls ]
[ grab-input?>> >>grab-input? ]
[ gadgets>> [ 1 track-add ] each ]
} cleave ;
[ call-next-method ]
[
dup handle>>
- [ select-gl-context resize-world ]
- [ drop ] if*
+ [ [ set-gl-context ] [ resize-world ] bi ]
+ [ drop ] if
] bi ;
GENERIC: draw-world* ( world -- )
dup draw-world? [
dup world [
[
- dup handle>> [ draw-world* ] with-gl-context
+ dup [ draw-world* ] with-gl-context
flush-layout-cache-hook get call( -- )
] [
over <world-error> ui-error
"Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's parent."
$nl
"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
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
{ $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+
{ $description "Control key modifier." } ;
{ $subsection zoom-out-action } ;
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 copy-action }
{ $subsection paste-action }
{ $subsection delete-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:"
{ $table
{ { $strong "Keyboard gesture" } { $strong "Action gesture" } }
{ { $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+ } \"c\" }" } { $snippet "copy-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+ } \"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." ;
combinators.short-circuit ;
IN: ui.gestures
+: get-gesture-handler ( gesture gadget -- quot )
+ class superclasses [ "gestures" word-prop ] map assoc-stack ;
+
GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture
[ nip ]
- [ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi
+ [ get-gesture-handler ] 2bi
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 ;
: gesture-queue ( -- deque ) \ gesture-queue get ;
cut-action copy-action paste-action
delete-action select-all-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
undo-action redo-action
cut-action copy-action paste-action
delete-action select-all-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
{
{ "z" undo-action }
- { "Z" redo-action }
+ { "y" redo-action }
{ "x" cut-action }
{ "c" copy-action }
{ "v" paste-action }
{ "a" select-all-action }
+ { "n" new-action }
+ { "o" open-action }
+ { "s" save-action }
+ { "S" save-as-action }
+ { "w" close-action }
}
! Modifiers
M: word-completion row-color
[ vocabulary>> ] [ manifest>> ] bi* {
+ { [ dup not ] [ COLOR: black ] }
{ [ 2dup search-vocabs>> memq? ] [ COLOR: black ] }
{ [ over ".private" tail? ] [ COLOR: dark-red ] }
[ COLOR: dark-gray ]
[ ] [ "h" get history-recall-previous ] unit-test
[ "22" ] [ "d" get doc-string ] unit-test
+
+[ ] [ <document> "d" set ] unit-test
+[ ] [ "d" get <history> "h" set ] unit-test
+
+[ ] [ "aaa" "d" get set-doc-string ] unit-test
+[ T{ input f "aaa" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "" "d" get set-doc-string ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ ] [ " " "d" get set-doc-string ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+
<PRIVATE
+: (save-history) ( input index elements -- )
+ 2dup length > [
+ [ [ T{ input f "" } ] dip push ] keep
+ (save-history)
+ ] [ set-nth ] if ;
+
: save-history ( history -- )
[ document>> doc-string ] keep
- '[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
+ '[ <input> _ [ index>> ] [ elements>> ] bi (save-history) ]
unless-empty ;
: update-document ( history -- )
} define-command-map
tool "common" f {
- { T{ key-down f { A+ } "s" } save }
{ T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all }
{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
+HELP: close-window
+{ $values { "gadget" gadget } }
+{ $description "Close the native window containing " { $snippet "gadget" } "." } ;
+
HELP: world-attributes
{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
{ { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
{ { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
{ { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
+ { { $snippet "window-controls" } " is a sequence of " { $link "ui.gadgets.worlds-window-controls" } " that will be placed in the window." }
} ;
HELP: set-fullscreen
HELP: beep
{ $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"
{ $table
{ "color" { "an instance of " { $link color } } }
{ $subsection "ui-backend" } ;
ABOUT: "ui"
+
+HELP: close-button
+{ $description "Asks for a close button to be available for a window. Without a close button, a window cannot be closed by the user and must be closed by the program using " { $link close-window } "." } ;
+
+HELP: minimize-button
+{ $description "Asks for a minimize button to be available for a window." } ;
+
+HELP: maximize-button
+{ $description "Asks for a maximize button to be available for a window." } ;
+
+HELP: resize-handles
+{ $description "Asks for resize controls to be available for a window. Without resize controls, the window size will not be changeable by the user." } ;
+
+HELP: small-title-bar
+{ $description "Asks for a window to have a small title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available. A small title bar may have other side effects in the window system, such as causing the window to not show up in the system task switcher and to float over other Factor windows." } ;
+
+HELP: normal-title-bar
+{ $description "Asks for a window to have a title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available." } ;
+
+ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls"
+"The following window controls can be placed in a " { $link world } " window:"
+{ $subsection close-button }
+{ $subsection minimize-button }
+{ $subsection maximize-button }
+{ $subsection resize-handles }
+{ $subsection small-title-bar }
+{ $subsection normal-title-bar }
+"Provide a sequence of these values in the " { $snippet "window-controls" } " slot of the " { $link world-attributes } " tuple you pass to " { $link open-window } "." ;
: set-up-window ( world -- )
{
- [ handle>> select-gl-context ]
+ [ set-gl-context ]
[ [ title>> ] keep set-title ]
[ begin-world ]
[ resize-world ]
: (ungraft-world) ( world -- )
{
- [ handle>> select-gl-context ]
+ [ set-gl-context ]
[ text-handle>> [ dispose ] when* ]
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
[ end-world ]
+ [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
} cleave ;
M: world ungraft*
windows get empty? not ;
: ?attributes ( gadget title/attributes -- attributes )
- dup string? [ world-attributes new swap >>title ] when
+ dup string? [ world-attributes new swap >>title ] [ clone ] if
swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
PRIVATE>
: raise-window ( gadget -- )
find-world raise-window* ;
+: topmost-window ( -- world )
+ windows get last second ;
+
HOOK: close-window ui-backend ( gadget -- )
M: object close-window
"The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that."
$nl "Operations for graphemes:"
{ $subsection first-grapheme }
+{ $subsection first-grapheme-from }
{ $subsection last-grapheme }
+{ $subsection last-grapheme-from }
{ $subsection >graphemes }
{ $subsection string-reverse }
"Operations on words:"
{ $subsection first-word }
+{ $subsection first-word-from }
+{ $subsection last-word }
+{ $subsection last-word-from }
{ $subsection >words } ;
HELP: first-grapheme
{ $values { "str" string } { "i" "an index" } }
{ $description "Finds the index of the start of the last grapheme of the string. This can be used to traverse the graphemes of a string backwards." } ;
+HELP: first-grapheme-from
+{ $values { "start" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the length of the first grapheme of the string, starting from the given index. This can be used repeatedly to efficiently traverse the graphemes of the string, using slices." } ;
+
+HELP: last-grapheme-from
+{ $values { "end" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the index of the start of the last grapheme of the string, starting from the given index. This can be used to traverse the graphemes of a string backwards." } ;
+
HELP: >graphemes
{ $values { "str" string } { "graphemes" "an array of strings" } }
{ $description "Divides a string into a sequence of individual graphemes." } ;
HELP: first-word
{ $values { "str" string } { "i" "index" } }
-{ $description "Finds the length of the first word in the string." } ;
+{ $description "Finds the index of the end of the first word in the string." } ;
+
+HELP: last-word
+{ $values { "str" string } { "i" "index" } }
+{ $description "Finds the index of the beginning of the last word in the string." } ;
+
+HELP: first-word-from
+{ $values { "start" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the end of the first word in the string, starting from the given index." } ;
+
+HELP: last-word-from
+{ $values { "end" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the start of the word that the index is contained in." } ;
HELP: >words
{ $values { "str" string } { "words" "an array of strings" } }
[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
+[ 4 ] [ 2 "what am I saying" first-word-from ] unit-test
+[ 0 ] [ 2 "what am I saying" last-word-from ] unit-test
+[ 16 ] [ 11 "what am I saying" first-word-from ] unit-test
+[ 10 ] [ 11 "what am I saying" last-word-from ] unit-test
+
: grapheme-break-test ( -- filename )
"vocab:unicode/breaks/GraphemeBreakTest.txt" ;
: connect ( class1 class2 -- ) 1 set-table ;
: disconnect ( class1 class2 -- ) 0 set-table ;
-: break-around ( classes1 classes2 -- )
- [ disconnect ] [ swap disconnect ] 2bi ;
-
: make-grapheme-table ( -- )
{ CR } { LF } connect
{ Control CR LF } graphemes disconnect
: grapheme-break? ( class1 class2 -- ? )
grapheme-table nth nth not ;
-: chars ( i str n -- str[i] str[i+n] )
- swap [ dupd + ] dip [ ?nth ] curry bi@ ;
-
PRIVATE>
: first-grapheme ( str -- i )
word-break-next nip
]
} 2|| ;
+
+: first-word-from ( start str -- i )
+ over tail-slice first-word + ;
+
+: last-word ( str -- i )
+ [ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
+
+: last-word-from ( end str -- i )
+ swap head-slice last-word ;
: reset-cache ( -- )
root-cache get-global clear-assoc
\ vocab-file-contents reset-memoized
- \ all-vocabs-seq reset-memoized
+ \ all-vocabs-recursive reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;
"Loading vocabulary hierarchies:"\r
{ $subsection load }\r
{ $subsection load-all }\r
-"Getting all vocabularies on disk:"\r
+"Getting all vocabularies from disk:"\r
{ $subsection all-vocabs }\r
-{ $subsection all-vocabs-seq }\r
-"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"\r
+{ $subsection all-vocabs-recursive }\r
+"Getting all vocabularies from disk whose names which match a string prefix:"\r
+{ $subsection child-vocabs }\r
+{ $subsection child-vocabs-recursive }\r
+"Words for modifying output:"\r
+{ $subsection no-roots }\r
+{ $subsection no-prefixes }\r
+"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"\r
{ $subsection all-tags }\r
{ $subsection all-authors } ;\r
\r
ABOUT: "vocabs.hierarchy"\r
\r
-HELP: all-vocabs\r
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }\r
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;\r
-\r
HELP: load\r
{ $values { "prefix" string } }\r
{ $description "Load all vocabularies that match the provided prefix." }\r
HELP: load-all\r
{ $description "Load all vocabularies in the source tree." } ;\r
\r
-HELP: all-vocabs-under\r
-{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }\r
-{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;\r
! Copyright (C) 2007, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays assocs combinators.short-circuit fry\r
+USING: accessors arrays assocs combinators.short-circuit fry\r
io.directories io.files io.files.info io.pathnames kernel make\r
memoize namespaces sequences sorting splitting vocabs sets\r
vocabs.loader vocabs.metadata vocabs.errors ;\r
+RENAME: child-vocabs vocabs => vocabs:child-vocabs\r
IN: vocabs.hierarchy\r
\r
+TUPLE: vocab-prefix name ;\r
+\r
+C: <vocab-prefix> vocab-prefix\r
+\r
+M: vocab-prefix vocab-name name>> ;\r
+\r
<PRIVATE\r
\r
: vocab-subdirs ( dir -- dirs )\r
] filter\r
] with-directory-files natural-sort ;\r
\r
-: (all-child-vocabs) ( root name -- vocabs )\r
- [\r
- vocab-dir append-path dup exists?\r
- [ vocab-subdirs ] [ drop { } ] if\r
- ] keep\r
- [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;\r
-\r
: vocab-dir? ( root name -- ? )\r
over\r
[ ".factor" vocab-dir+ append-path exists? ]\r
[ 2drop f ]\r
if ;\r
\r
-: vocabs-in-dir ( root name -- )\r
- dupd (all-child-vocabs) [\r
- 2dup vocab-dir? [ dup >vocab-link , ] when\r
- vocabs-in-dir\r
- ] with each ;\r
+: (child-vocabs) ( root prefix -- vocabs )\r
+ [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
+ [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]\r
+ [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]\r
+ 2tri ;\r
\r
-PRIVATE>\r
+: ((child-vocabs-recursive)) ( root name -- )\r
+ dupd vocab-name (child-vocabs)\r
+ [ dup , ((child-vocabs-recursive)) ] with each ;\r
\r
-: all-vocabs ( -- assoc )\r
- vocab-roots get [\r
- dup [ "" vocabs-in-dir ] { } make\r
- ] { } map>assoc ;\r
-\r
-: all-vocabs-under ( prefix -- vocabs )\r
- [\r
- [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each\r
- ] { } make ;\r
+: (child-vocabs-recursive) ( root name -- seq )\r
+ [ ((child-vocabs-recursive)) ] { } make ;\r
\r
-MEMO: all-vocabs-seq ( -- seq )\r
- "" all-vocabs-under ;\r
+: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;\r
\r
-<PRIVATE\r
+: one-level-only? ( name prefix -- ? )\r
+ ?head [ "." split1 nip not ] dip and ;\r
\r
: unrooted-child-vocabs ( prefix -- seq )\r
+ [ vocabs no-rooted ] dip\r
dup empty? [ CHAR: . suffix ] unless\r
- vocabs\r
- [ find-vocab-root not ] filter\r
- [\r
- vocab-name swap ?head CHAR: . rot member? not and\r
- ] with filter\r
- [ vocab ] map ;\r
+ '[ vocab-name _ one-level-only? ] filter ;\r
+\r
+: unrooted-child-vocabs-recursive ( prefix -- seq )\r
+ vocabs:child-vocabs no-rooted ;\r
\r
PRIVATE>\r
\r
-: all-child-vocabs ( prefix -- assoc )\r
- vocab-roots get [\r
- dup pick (all-child-vocabs) [ >vocab-link ] map\r
- ] { } map>assoc\r
- swap unrooted-child-vocabs f swap 2array suffix ;\r
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;\r
\r
-: all-child-vocabs-seq ( prefix -- assoc )\r
- vocab-roots get swap '[\r
- dup _ (all-child-vocabs)\r
- [ vocab-dir? ] with filter\r
- ] map concat ;\r
+: convert-prefixes ( seq -- seq' )\r
+ [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;\r
+\r
+: remove-redundant-prefixes ( seq -- seq' )\r
+ #! Hack.\r
+ [ vocab-prefix? ] partition\r
+ [\r
+ [ vocab-name ] map unique\r
+ '[ name>> _ key? not ] filter\r
+ convert-prefixes\r
+ ] keep\r
+ append ;\r
+\r
+: no-roots ( assoc -- seq ) values concat ;\r
+\r
+: child-vocabs ( prefix -- assoc )\r
+ [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]\r
+ [ unrooted-child-vocabs [ vocab ] map f swap 2array ]\r
+ bi suffix ;\r
+\r
+: all-vocabs ( -- assoc )\r
+ "" child-vocabs ;\r
+\r
+: child-vocabs-recursive ( prefix -- assoc )\r
+ [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]\r
+ [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]\r
+ bi suffix ;\r
+\r
+MEMO: all-vocabs-recursive ( -- assoc )\r
+ "" child-vocabs-recursive ;\r
+\r
+: all-vocab-names ( -- seq )\r
+ all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;\r
+\r
+: child-vocab-names ( prefix -- seq )\r
+ child-vocabs no-roots no-prefixes [ vocab-name ] map ;\r
\r
<PRIVATE\r
\r
: filter-unportable ( seq -- seq' )\r
[ vocab-name unportable? not ] filter ;\r
\r
+: collect-vocabs ( quot -- seq )\r
+ [ all-vocabs-recursive no-roots no-prefixes ] dip\r
+ gather natural-sort ; inline\r
+\r
PRIVATE>\r
\r
: (load) ( prefix -- failures )\r
- all-vocabs-under\r
+ child-vocabs-recursive no-roots no-prefixes\r
filter-unportable\r
require-all ;\r
\r
: load-all ( -- )\r
"" load ;\r
\r
-MEMO: all-tags ( -- seq )\r
- all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
+MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
\r
-MEMO: all-authors ( -- seq )\r
- all-vocabs-seq [ vocab-authors ] gather natural-sort ;
\ No newline at end of file
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r
swap >>dim
swap >>bitmap
BGRX >>component-order
+ ubyte-components >>component-type
t >>upside-down? ;
: with-memory-dc ( quot: ( hDC -- ) -- )
:: make-bitmap-image ( dim dc quot -- image )
dim dc make-bitmap [ &DeleteObject drop ] dip
quot dip
- dim bitmap>image ; inline
\ No newline at end of file
+ dim bitmap>image ; inline
CONSTANT: SWP_DEFERERASE 8192
CONSTANT: SWP_ASYNCWINDOWPOS 16384
+CONSTANT: MF_ENABLED HEX: 0000
+CONSTANT: MF_GRAYED HEX: 0001
+CONSTANT: MF_DISABLED HEX: 0002
+CONSTANT: MF_STRING HEX: 0000
+CONSTANT: MF_BITMAP HEX: 0004
+CONSTANT: MF_UNCHECKED HEX: 0000
+CONSTANT: MF_CHECKED HEX: 0008
+CONSTANT: MF_POPUP HEX: 0010
+CONSTANT: MF_MENUBARBREAK HEX: 0020
+CONSTANT: MF_MENUBREAK HEX: 0040
+CONSTANT: MF_UNHILITE HEX: 0000
+CONSTANT: MF_HILITE HEX: 0080
+CONSTANT: MF_OWNERDRAW HEX: 0100
+CONSTANT: MF_USECHECKBITMAPS HEX: 0200
+CONSTANT: MF_BYCOMMAND HEX: 0000
+CONSTANT: MF_BYPOSITION HEX: 0400
+CONSTANT: MF_SEPARATOR HEX: 0800
+CONSTANT: MF_DEFAULT HEX: 1000
+CONSTANT: MF_SYSMENU HEX: 2000
+CONSTANT: MF_HELP HEX: 4000
+CONSTANT: MF_RIGHTJUSTIFY HEX: 4000
+CONSTANT: MF_MOUSESELECT HEX: 8000
LIBRARY: user32
! FUNCTION: DrawTextW
! FUNCTION: EditWndProc
FUNCTION: BOOL EmptyClipboard ( ) ;
-! FUNCTION: EnableMenuItem
+FUNCTION: BOOL EnableMenuItem ( HMENU hMenu, UINT uIDEnableItem, UINT uEnable ) ;
! FUNCTION: EnableScrollBar
! FUNCTION: EnableWindow
! FUNCTION: EndDeferWindowPos
! FUNCTION: GetSubMenu
! FUNCTION: GetSysColor
FUNCTION: HBRUSH GetSysColorBrush ( int nIndex ) ;
-! FUNCTION: GetSystemMenu
+FUNCTION: HMENU GetSystemMenu ( HWND hWnd, BOOL bRevert ) ;
! FUNCTION: GetSystemMetrics
! FUNCTION: GetTabbedTextExtentA
! FUNCTION: GetTabbedTextExtentW
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test
+
+[ "" ] [ "" 10 wrap-string ] unit-test
+[ "Hello" ] [ "\nHello\n" 10 wrap-string ] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: wrap tools.test ;
+
+[ { } ] [ { } 10 10 wrap ] unit-test
[
line-ideal set
line-max set
- initialize
- [ wrap-step ] reduce
- min-cost
- post-process
+ [ { } ] [
+ initialize
+ [ wrap-step ] reduce
+ min-cost
+ post-process
+ ] if-empty
] with-scope ;
">>"
"call-next-method"
"initial:"
- "initial-quot:"
"read-only"
"call("
"execute("
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
} "\n" join eval( -- tuple )
-] [ error>> unexpected-eof? ] must-fail-with
-
-
-[ ] [
- <" USE: sequences
- IN: classes.tuple.tests
- TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
- eval( -- )
-] unit-test
+] [ error>> unexpected-eof? ] must-fail-with
\ No newline at end of file
: parse-long-slot-name ( -- spec )
[ scan , \ } parse-until % ] { } make ;
-: parse-slot-name ( string/f -- ? )
+: parse-slot-name-delim ( end-delim string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
{
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
- { [ dup ";" = ] [ drop f ] }
+ { [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
- } cond ;
+ } cond nip ;
+
+: parse-tuple-slots-delim ( end-delim -- )
+ dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+
+: parse-slot-name ( string/f -- ? )
+ ";" swap parse-slot-name-delim ;
: parse-tuple-slots ( -- )
- scan parse-slot-name [ parse-tuple-slots ] when ;
+ ";" parse-tuple-slots-delim ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
-
-TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
-SLOT: winner?
-
-[ t ] [ lucky-number new n>> integer? ] unit-test
-
-: compiled-lucky-number ( -- tuple ) lucky-number new ;
-
-[ t ] [ compiled-lucky-number n>> integer? ] unit-test
-
-! Reshaping initial-quot:
-lucky-number new dup n>> 2array "luckiest-number" set
-
-[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
-
-[ ] [ "USING: accessors random ; IN: classes.tuple.tests TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } { winner? initial-quot: [ t ] } ;" eval( -- ) ] unit-test
-
-[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
-[ t ] [ "luckiest-number" get first winner?>> ] unit-test
-
-! invalid-quot: together with type declaration
-TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ;
-
-[ t ] [ decl-initial-quot new x>> integer? ] unit-test
-
-: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ;
-
-[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test
-
-! invalid-quot: with read-only
-TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ;
-
-[ t ] [ read-only-initial-quot new x>> integer? ] unit-test
-
-: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ;
-
-[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test
-
-! Specifying both initial: and initial-quot: should fail
-2 [
- [
- "IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;"
- eval( -- )
- ]
- [ error>> duplicate-initial-values? ]
- must-fail-with
-] times
PRIVATE>
-: initial-quots? ( class -- ? )
- all-slots [ initial-quot>> ] any? ;
-
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ;
-: tuple-initial-quots-quot ( class -- quot )
- all-slots [ initial-quot>> ] filter
- [
- [
- [ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot ,
- ] each
- ] [ ] make f like ;
-
: tuple-prototype ( class -- prototype )
- [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
+ [ initial-values ] keep over [ ] any?
[ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
- dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
- dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
+ dup tuple-prototype "prototype" set-word-prop ;
: prepare-slots ( slots superclass -- slots' )
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: calculate-initial-value ( slot-spec -- value )
- dup initial>> [ ] [
- dup initial-quot>>
- [ call( -- obj ) ] [ drop f ] ?if
- ] ?if ;
-
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ calculate-initial-value ] map ]
+ [ drop [ initial>> ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
M: tuple hashcode* tuple-hashcode ;
M: tuple-class new
- dup "prototype" word-prop [
- first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
- ] [
- tuple-layout <tuple>
- ] ?if ;
+ dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]
HELP: math-generic
{ $class-description "The class of generic words using " { $link math-combination } "." } ;
-HELP: last/first
-{ $values { "seq" sequence } { "pair" "a two-element array" } }
-{ $description "Creates an array holding the first and last element of the sequence." } ;
+
<PRIVATE
-: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
-
: bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ;
HELP: skip
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
-{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
+{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise). Tabulations used as separators instead of spaces will be flagged as an error." } ;
HELP: change-lexer-column
{ $values { "lexer" lexer } { "quot" { $quotation "( col line -- newcol )" } } }
: <lexer> ( text -- lexer )
lexer new-lexer ;
+ERROR: unexpected want got ;
+
+PREDICATE: unexpected-tab < unexpected
+ got>> CHAR: \t = ;
+
+: forbid-tab ( c -- c )
+ [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ;
+
: skip ( i seq ? -- n )
over length
- [ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ;
+ [ [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop ] dip or ;
: change-lexer-column ( lexer quot -- )
[ [ column>> ] [ line-text>> ] bi ] prepose keep
: scan ( -- str/f ) lexer get parse-token ;
-ERROR: unexpected want got ;
-
PREDICATE: unexpected-eof < unexpected
got>> not ;
[ f f ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 11 "hi" } } at ] map-find
] unit-test
+
+USE: make
+
+[ { "a" 1 "b" 1 "c" } ]
+[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
\ No newline at end of file
<PRIVATE
+: ((each)) ( seq -- n quot )
+ [ length ] keep [ nth-unsafe ] curry ; inline
+
: (each) ( seq quot -- n quot' )
- [ [ length ] keep [ nth-unsafe ] curry ] dip compose ; inline
+ [ ((each)) ] dip compose ; inline
+
+: (each-index) ( seq quot -- n quot' )
+ [ ((each)) [ keep ] curry ] dip compose ; inline
: (collect) ( quot into -- quot' )
[ [ keep ] dip set-nth-unsafe ] 2curry ; inline
: follow ( obj quot -- seq )
[ dup ] swap [ keep ] curry produce nip ; inline
-: prepare-index ( seq quot -- seq n quot )
- [ dup length ] dip ; inline
-
: each-index ( seq quot -- )
- prepare-index 2each ; inline
+ (each-index) each-integer ; inline
: interleave ( seq between quot -- )
- swap [ drop ] [ [ 2dip call ] 2curry ] 2bi
- [ [ 0 = ] 2dip if ] 2curry
- each-index ; inline
+ pick empty? [ 3drop ] [
+ [ [ drop first-unsafe ] dip call ]
+ [ [ rest-slice ] 2dip [ bi* ] 2curry each ]
+ 3bi
+ ] if ; inline
: map-index ( seq quot -- newseq )
- prepare-index 2map ; inline
+ [ dup length iota ] dip 2map ; inline
: reduce-index ( seq identity quot -- )
swapd each-index ; inline
-USING: kernel help.markup help.syntax sequences quotations assocs ;
+USING: assocs hashtables help.markup help.syntax kernel
+quotations sequences ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;
+
[ f ] [ { } { 1 } intersects? ] unit-test
[ f ] [ { 1 } { } intersects? ] unit-test
+
words sequences.private assocs alien quotations hashtables ;
IN: slots
-TUPLE: slot-spec name offset class initial initial-quot read-only ;
+TUPLE: slot-spec name offset class initial read-only ;
PREDICATE: reader < word "reader" word-prop ;
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
- { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
[ bad-slot-attribute ]
} case
ERROR: bad-initial-value name ;
-ERROR: duplicate-initial-values slot ;
-
-: check-duplicate-initial-values ( slot-spec -- slot-spec )
- dup [ initial>> ] [ initial-quot>> ] bi and
- [ duplicate-initial-values ] when ;
-
: check-initial-value ( slot-spec -- slot-spec )
- check-duplicate-initial-values
dup initial>> [
[ ] [
dup [ initial>> ] [ class>> ] bi instance?
"initial:" "syntax" lookup define-symbol
- "initial-quot:" "syntax" lookup define-symbol
-
"read-only" "syntax" lookup define-symbol
"call(" [ \ call-effect parse-call( ] define-core-syntax
PRIVATE>
: run-benchmark ( vocab -- )
- [ "=== " write vocab-name print flush ] [
+ [ "=== " write print flush ] [
[ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
[ swap errors ]
recover get set-at
[
V{ } clone timings set
V{ } clone errors set
- "benchmark" all-child-vocabs-seq
+ "benchmark" child-vocab-names
[ run-benchmark ] each
timings get
errors get
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators kernel locals math
+math.ranges memoize sequences strings hashtables
+math.parser grouping ;
+IN: benchmark.hashtables
+
+MEMO: strings ( -- str )
+ 1 100 [a,b] 1 [ + ] accumulate nip [ number>string ] map ;
+
+:: add-delete-mix ( hash keys -- )
+ keys [| k |
+ 0 k hash set-at
+ k hash delete-at
+ ] each
+
+ keys [
+ 0 swap hash set-at
+ ] each
+
+ keys [
+ hash delete-at
+ ] each ;
+
+:: store-lookup-mix ( hash keys -- )
+ keys [
+ 0 swap hash set-at
+ ] each
+
+ keys [
+ hash at
+ ] map drop
+
+ keys [
+ hash [ 1 + ] change-at
+ ] each ;
+
+: string-mix ( hash -- )
+ strings
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi ;
+
+TUPLE: collision value ;
+
+M: collision hashcode* value>> hashcode* 15 bitand ;
+
+: collision-mix ( hash -- )
+ strings 30 head [ collision boa ] map
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi ;
+
+: small-mix ( hash -- )
+ strings 10 group [
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi
+ ] with each ;
+
+: hashtable-benchmark ( -- )
+ H{ } clone
+ 10000 [
+ dup {
+ [ small-mix ]
+ [ clear-assoc ]
+ [ string-mix ]
+ [ clear-assoc ]
+ [ collision-mix ]
+ [ clear-assoc ]
+ } cleave
+ ] times
+ drop ;
+
+MAIN: hashtable-benchmark
\ No newline at end of file
io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
sequences serialize arrays calendar io.encodings ;
+FROM: kernel.private => declare ;
+FROM: io.encodings.private => (read-until) ;
+
IN: bson.reader
<PRIVATE
TUPLE: element { type integer } name ;
TUPLE: state
- { size initial: -1 } { read initial: 0 } exemplar
+ { size initial: -1 } exemplar
result scope element ;
: <state> ( exemplar -- state )
clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
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-eoo < integer T_EOO = ;
-PREDICATE: bson-double < integer T_Double = ;
-PREDICATE: bson-integer < integer T_Integer = ;
PREDICATE: bson-string < integer T_String = ;
PREDICATE: bson-object < integer T_Object = ;
+PREDICATE: bson-oid < integer T_OID = ;
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-boolean < integer T_Boolean = ;
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-function < integer T_Binary_Function = ;
PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
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-data-read ( type -- object )
: get-state ( -- state )
state get ; inline
-: count-bytes ( count -- )
- [ get-state ] dip '[ _ + ] change-read drop ; inline
-
: read-int32 ( -- int32 )
- 4 [ read byte-array>number ] [ count-bytes ] bi ; inline
+ 4 read byte-array>number ; inline
: read-longlong ( -- longlong )
- 8 [ read byte-array>number ] [ count-bytes ] bi ; inline
+ 8 read byte-array>number ; inline
: 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 )
- 1 [ read ] [ count-bytes ] bi ; inline
+ 1 read ; inline
: read-byte ( -- byte )
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 )
- input-stream get utf8 <decoder>
- "\0" swap stream-read-until drop ; inline
+ "\0" input-stream get utf8 utf8-read-until drop ; inline
: read-sized-string ( length -- string )
drop read-cstring ; inline
M: bson-object element-data-read ( type -- object )
(object-data-read) ;
-M: bson-array element-data-read ( type -- object )
- (object-data-read) ;
-
M: bson-string element-data-read ( type -- object )
drop
read-int32 read-sized-string ;
+M: bson-array element-data-read ( type -- object )
+ (object-data-read) ;
+
M: bson-integer element-data-read ( type -- object )
drop
read-int32 ;
USE: tools.continuations
-: stream>assoc ( exemplar -- assoc bytes-read )
+: stream>assoc ( exemplar -- assoc )
<state> dup state
[ read-int32 >>size read-elements ] with-variable
- [ result>> ] [ read>> ] bi ;
+ result>> ;
namespaces quotations sequences sequences.private serialize strings
words combinators.short-circuit literals ;
+FROM: io.encodings.utf8.private => char>utf8 ;
+FROM: kernel.private => declare ;
+
IN: bson.writer
<PRIVATE
SYMBOL: shared-buffer
+CONSTANT: CHAR-SIZE 1
CONSTANT: INT32-SIZE 4
-CONSTANT: CHAR-SIZE 1
CONSTANT: INT64-SIZE 8
: (buffer) ( -- buffer )
shared-buffer get
- [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
-
-: >le-stream ( x n -- )
- swap
- '[ _ swap nth-byte 0 B{ 0 }
- [ set-nth-unsafe ] keep write ] each ; inline
-
+ [ BV{ } clone [ shared-buffer set ] keep ] unless*
+ { byte-vector } declare ; inline
+
PRIVATE>
: reset-buffer ( buffer -- )
: ensure-buffer ( -- )
(buffer) drop ; inline
-: with-buffer ( quot -- byte-vector )
+: with-buffer ( quot: ( -- ) -- byte-vector )
[ (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 )
- [ (buffer) [ length ] keep ] dip call
- length swap [ - ] keep ; inline
+ [ (buffer) [ length ] keep ] dip
+ call length swap [ - ] keep ; inline
-: with-length-prefix ( quot: ( -- ) -- )
- [ B{ 0 0 0 0 } write ] prepose with-length
- [ INT32-SIZE >le ] dip (buffer)
- '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
- [ INT32-SIZE ] dip each-integer ; 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: ( -- ) -- )
+ [ INT32-SIZE >le ] (with-length-prefix) ; inline
+
: with-length-prefix-excl ( quot: ( -- ) -- )
- [ B{ 0 0 0 0 } write ] prepose with-length
- [ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
- '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
- [ INT32-SIZE ] dip each-integer ; inline
+ [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
<PRIVATE
-GENERIC: bson-type? ( obj -- type ) foldable flushable
-GENERIC: bson-write ( obj -- )
+GENERIC: bson-type? ( obj -- type )
+GENERIC: bson-write ( obj -- )
M: t 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: integer bson-type? ( integer -- type ) drop T_Integer ;
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: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
-: write-utf8-string ( string -- )
- output-stream get utf8 <encoder> stream-write ; inline
+: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
-: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline
-: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline
-: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline
+: write-byte ( byte -- ) CHAR-SIZE >le write ; inline
+: write-int32 ( int -- ) INT32-SIZE >le write ; inline
+: write-double ( real -- ) double>bits INT64-SIZE >le write ; 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-type ( obj -- obj ) [ bson-type? write-byte ] keep ; 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 -- )
drop 0 write-byte ;
M: t bson-write ( t -- )
drop 1 write-byte ;
-M: string bson-write ( obj -- )
- '[ _ write-cstring ] with-length-prefix-excl ;
-
M: integer bson-write ( num -- )
write-int32 ;
[ '[ _ bson-write ] with-buffer ] with-scope ; inline
: assoc>stream ( assoc -- )
- bson-write ; inline
+ { assoc } declare bson-write ; inline
: mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
- [ oid? ] [ byte-array? ] } 1|| ;
\ No newline at end of file
+ [ oid? ] [ byte-array? ] } 1|| ; inline
\ No newline at end of file
framebuffer framebuffer-dim ;
: outlining-supported? ( -- ? )
- "2.0" {
+ "3.0" {
"GL_ARB_shader_objects"
"GL_ARB_draw_buffers"
"GL_ARB_multitexture"
- } has-gl-version-or-extensions? {
"GL_EXT_framebuffer_object"
"GL_ARB_texture_float"
- } has-gl-extensions? and ;
+ } has-gl-version-or-extensions? ;
: pass1-program ( -- program )
vertex-shader-source <vertex-shader> check-gl-shader
GL_TEXTURE_2D 0 iformat dim first2 0 xformat GL_UNSIGNED_BYTE f glTexImage2D ;
:: (attach-framebuffer-texture) ( texture attachment -- )
- GL_FRAMEBUFFER_EXT attachment GL_TEXTURE_2D texture 0 glFramebufferTexture2DEXT
+ GL_DRAW_FRAMEBUFFER attachment GL_TEXTURE_2D texture 0 glFramebufferTexture2D
gl-error ;
: (make-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer )
3array gen-framebuffer dup [
- swap GL_COLOR_ATTACHMENT0_EXT
- GL_COLOR_ATTACHMENT1_EXT
- GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each
+ swap GL_COLOR_ATTACHMENT0
+ GL_COLOR_ATTACHMENT1
+ GL_DEPTH_ATTACHMENT 3array [ (attach-framebuffer-texture) ] 2each
check-framebuffer
] with-framebuffer ;
: (make-framebuffer-textures) ( draw dim -- draw color normal depth )
{
[ drop ]
- [ GL_RGBA16F_ARB GL_RGBA [ >>color-texture ] (framebuffer-texture>>draw) ]
- [ GL_RGBA16F_ARB GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ]
+ [ GL_RGBA16F GL_RGBA [ >>color-texture ] (framebuffer-texture>>draw) ]
+ [ GL_RGBA16F GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ]
[
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT
[ >>depth-texture ] (framebuffer-texture>>draw)
[ drop ] [ remake-framebuffer ] if ;
: clear-framebuffer ( -- )
- GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
+ GL_COLOR_ATTACHMENT0 glDrawBuffer
0.15 0.15 0.15 1.0 glClearColor
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_COLOR_ATTACHMENT1_EXT glDrawBuffer
+ GL_COLOR_ATTACHMENT1 glDrawBuffer
0.0 0.0 0.0 0.0 glClearColor
GL_COLOR_BUFFER_BIT glClear ;
: (pass1) ( geom draw -- )
dup framebuffer>> [
clear-framebuffer
- { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
+ { GL_COLOR_ATTACHMENT0 GL_COLOR_ATTACHMENT1 } set-draw-buffers
pass1-program>> (draw-cel-shaded-bunny)
] with-framebuffer ;
horizontal <slider> 1 >>line ;
: <color-sliders> ( -- gadget model )
- 3 [ 0 0 0 255 <range> ] replicate
+ 3 [ 0 0 0 255 1 <range> ] replicate
[ <filled-pile> { 5 5 } >>gap [ <color-slider> add-gadget ] reduce ]
[ [ range-model ] map <product> ]
bi ;
[ { 111 222 } ]
[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
+
+: test-3map ( -- seq )
+ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
+
+[ { 111 222 } ] [ test-3map ] unit-test
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generalizations kernel math sequences
-sequences.private ;
+sequences.private fry ;
IN: cursors
GENERIC: cursor-done? ( cursor -- ? )
: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
- 3 nover 3array [ cursor-done? ] any?
- [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+ [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
+ [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
: cursor-until3 ( cursor cursor quot -- )
[ find-done3? not ]
- [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+ [ drop [ cursor-advance ] tri@ ]
+ bi-curry bi-curry bi-curry bi-curry while ; inline
: cursor-each3 ( cursor cursor quot -- )
[ f ] compose cursor-until3 ; inline
parser prettyprint sequences summary help.vocabs
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
listener ;
-
+FROM: vocabs.hierarchy => child-vocabs ;
IN: fuel.help
<PRIVATE
[ fuel-vocab-help-table ] bi*
[ 2array ] [ drop f ] if*
] if-empty
- ] { } assoc>map [ ] filter ;
+ ] { } assoc>map sift ;
: fuel-vocab-children-help ( name -- element )
- all-child-vocabs fuel-vocab-list ; inline
+ child-vocabs fuel-vocab-list ; inline
: fuel-vocab-describe-words ( name -- element )
[ words. ] with-string-writer \ describe-words swap 2array ; inline
: article-location ( name -- loc ) article loc>> get-loc ;
-: get-vocabs ( -- seq ) all-vocabs-seq [ vocab-name ] map ;
+: get-vocabs ( -- seq ) all-vocab-names ;
: get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ;
USING: accessors game-input game-loop kernel math ui.gadgets
-ui.gadgets.worlds ui.gestures ;
+ui.gadgets.worlds ui.gestures threads ;
IN: game-worlds
TUPLE: game-world < world
GENERIC: tick-length ( world -- millis )
M: game-world draw*
- swap >>tick-slice draw-world ;
+ swap >>tick-slice relayout-1 yield ;
M: game-world begin-world
open-game-input
[ -1.5 ] [ HEX: be00 bits>half ] unit-test
[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
-[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
+[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
C-STRUCT: halves
{ "half" "tom" }
--- /dev/null
+IN: histogram\r
+USING: help.markup help.syntax sequences hashtables quotations assocs ;\r
+\r
+HELP: histogram\r
+{ $values\r
+ { "seq" sequence }\r
+ { "hashtable" hashtable }\r
+}\r
+{ $examples \r
+ { $example "! Count the number of times an element appears in a sequence."\r
+ "USING: prettyprint histogram ;"\r
+ "\"aaabc\" histogram ."\r
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"\r
+ }\r
+}\r
+{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;\r
+\r
+HELP: histogram*\r
+{ $values\r
+ { "hashtable" hashtable } { "seq" sequence }\r
+ { "hashtable" hashtable }\r
+}\r
+{ $examples \r
+ { $example "! Count the number of times the elements of two sequences appear."\r
+ "USING: prettyprint histogram ;"\r
+ "\"aaabc\" histogram \"aaaaaabc\" histogram* ."\r
+ "H{ { 97 9 } { 98 2 } { 99 2 } }"\r
+ }\r
+}\r
+{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;\r
+\r
+HELP: sequence>assoc\r
+{ $values\r
+ { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }\r
+ { "assoc" assoc }\r
+}\r
+{ $examples \r
+ { $example "! Iterate over a sequence and increment the count at each element"\r
+ "USING: assocs prettyprint histogram ;"\r
+ "\"aaabc\" [ inc-at ] H{ } sequence>assoc ."\r
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"\r
+ }\r
+}\r
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;\r
+\r
+HELP: sequence>assoc*\r
+{ $values\r
+ { "assoc" assoc } { "seq" sequence } { "quot" quotation }\r
+ { "assoc" assoc }\r
+}\r
+{ $examples \r
+ { $example "! Iterate over a sequence and add the counts to an existing assoc"\r
+ "USING: assocs prettyprint histogram kernel ;"\r
+ "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."\r
+ "H{ { 97 5 } { 98 2 } { 99 1 } }"\r
+ }\r
+}\r
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ;\r
+\r
+HELP: sequence>hashtable\r
+{ $values\r
+ { "seq" sequence } { "quot" quotation }\r
+ { "hashtable" hashtable }\r
+}\r
+{ $examples \r
+ { $example "! Count the number of times an element occurs in a sequence"\r
+ "USING: assocs prettyprint histogram ;"\r
+ "\"aaabc\" [ inc-at ] sequence>hashtable ."\r
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"\r
+ }\r
+}\r
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ;\r
+\r
+ARTICLE: "histogram" "Computing histograms"\r
+"Counting elements in a sequence:"\r
+{ $subsection histogram }\r
+{ $subsection histogram* }\r
+"Combinators for implementing histogram:"\r
+{ $subsection sequence>assoc }\r
+{ $subsection sequence>assoc* }\r
+{ $subsection sequence>hashtable } ;\r
+\r
+ABOUT: "histogram"\r
--- /dev/null
+IN: histogram.tests\r
+USING: help.markup help.syntax tools.test histogram ;\r
+\r
+[\r
+ H{\r
+ { 97 2 }\r
+ { 98 2 }\r
+ { 99 2 }\r
+ }\r
+] [\r
+ "aabbcc" histogram\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel sequences assocs fry ;\r
+IN: histogram\r
+\r
+<PRIVATE\r
+\r
+: (sequence>assoc) ( seq quot assoc -- assoc )\r
+ [ swap curry each ] keep ; inline\r
+\r
+PRIVATE>\r
+\r
+: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )\r
+ rot (sequence>assoc) ; inline\r
+\r
+: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )\r
+ clone (sequence>assoc) ; inline\r
+\r
+: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )\r
+ H{ } sequence>assoc ; inline\r
+\r
+: histogram* ( hashtable seq -- hashtable )\r
+ [ inc-at ] sequence>assoc* ;\r
+\r
+: histogram ( seq -- hashtable )\r
+ [ inc-at ] sequence>hashtable ;\r
+\r
+: collect-values ( seq quot: ( obj hashtable -- ) -- hash )\r
+ '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline\r
USING: kernel accessors grouping sequences combinators
math specialized-arrays.direct.uint byte-arrays fry
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
<PRIVATE
: add-dummy-alpha ( seq -- seq' )
3 <groups> [ 255 suffix ] map concat ;
-: normalize-floats ( byte-array -- byte-array )
- byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+: normalize-floats ( float-array -- byte-array )
+ [ 255.0 * >integer ] B{ } map-as ;
+GENERIC: normalize-component-type* ( image component-type -- image )
GENERIC: normalize-component-order* ( image component-order -- image )
: normalize-component-order ( image -- image )
+ dup component-type>> '[ _ normalize-component-type* ] change-bitmap
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
-M: RGBA normalize-component-order* drop ;
-
-M: R32G32B32A32 normalize-component-order*
- drop normalize-floats ;
-
-M: R32G32B32 normalize-component-order*
- drop normalize-floats add-dummy-alpha ;
+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 ;
-: RGB16>8 ( bitmap -- bitmap' )
+: ushorts>ubytes ( bitmap -- bitmap' )
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-M: R16G16B16A16 normalize-component-order*
- drop RGB16>8 ;
+M: ushort-components normalize-component-type*
+ drop ushorts>ubytes ;
-M: R16G16B16 normalize-component-order*
- drop RGB16>8 add-dummy-alpha ;
+M: ubyte-components normalize-component-type*
+ drop ;
+
+M: RGBA normalize-component-order* drop ;
: BGR>RGB ( bitmap -- pixels )
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
CONSTANT: IEXTEN OCT: 0100000
M: linux lookup-baud ( n -- n )
- dup H{
- { 0 OCT: 0000000 }
- { 50 OCT: 0000001 }
- { 75 OCT: 0000002 }
- { 110 OCT: 0000003 }
- { 134 OCT: 0000004 }
- { 150 OCT: 0000005 }
- { 200 OCT: 0000006 }
- { 300 OCT: 0000007 }
- { 600 OCT: 0000010 }
- { 1200 OCT: 0000011 }
- { 1800 OCT: 0000012 }
- { 2400 OCT: 0000013 }
- { 4800 OCT: 0000014 }
- { 9600 OCT: 0000015 }
- { 19200 OCT: 0000016 }
- { 38400 OCT: 0000017 }
+ H{
+ { 0 OCT: 0000000 }
+ { 50 OCT: 0000001 }
+ { 75 OCT: 0000002 }
+ { 110 OCT: 0000003 }
+ { 134 OCT: 0000004 }
+ { 150 OCT: 0000005 }
+ { 200 OCT: 0000006 }
+ { 300 OCT: 0000007 }
+ { 600 OCT: 0000010 }
+ { 1200 OCT: 0000011 }
+ { 1800 OCT: 0000012 }
+ { 2400 OCT: 0000013 }
+ { 4800 OCT: 0000014 }
+ { 9600 OCT: 0000015 }
+ { 19200 OCT: 0000016 }
+ { 38400 OCT: 0000017 }
{ 57600 OCT: 0010001 }
{ 115200 OCT: 0010002 }
{ 230400 OCT: 0010003 }
sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
accessors words mongodb.driver strings math.parser bson.writer ;
FROM: mongodb.driver => find ;
+FROM: memory => gc ;
IN: mongodb.benchmark
: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
[ 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-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _
'[ [ [ _ execute( -- quot ) ] dip
- [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each
+ [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
print-separator ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- )
+++ /dev/null
-Sascha Matzke
+++ /dev/null
-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
+++ /dev/null
-mongo-message-monitor - a small proxy to introspect messages send to MongoDB
[ opcode>> ] keep [ >>opcode ] dip
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 )
drop
[ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
- [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ;
+ [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ;
: read-header ( message -- message )
read-int32 >>length
image new
swap >>dim
swap >>bitmap
- L >>component-order ;
+ L >>component-order
+ ubyte-components >>component-type ;
:: perlin-noise-unsafe ( table point -- value )
point unit-cube :> cube
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors http.client kernel unicode.categories
-sequences urls splitting combinators splitting.monotonic
-combinators.short-circuit assocs unicode.case arrays
-math.parser calendar.format make fry present globs
-multiline regexp.combinators regexp ;
+USING: accessors arrays assocs calendar.format combinators
+combinators.short-circuit fry globs http.client kernel make
+math.parser multiline namespaces present regexp
+regexp.combinators sequences sets splitting splitting.monotonic
+unicode.case unicode.categories urls ;
IN: robots
! visit-time is GMT, request-rate is pages/second
! crawl-rate is seconds
+SYMBOL: robot-identities
+robot-identities [ { "FactorSpider" } ] initialize
+
TUPLE: robots site sitemap rules rules-quot ;
: <robots> ( site sitemap rules -- robots )
derive-urls [ <glob> ] map <and> <not>
] bi 2array <or> '[ _ matches? ] ;
+: relevant-rules ( robots -- rules )
+ [
+ user-agents>> [
+ robot-identities get [ swap glob-matches? ] with any?
+ ] any?
+ ] filter ;
+
PRIVATE>
: parse-robots.txt ( string -- sitemaps rules-seq )
: (make-reflection-depthbuffer) ( -- depthbuffer )
gen-renderbuffer [
- GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT
- GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT
+ GL_RENDERBUFFER swap glBindRenderbuffer
+ GL_RENDERBUFFER GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorage
] keep ;
: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
gen-framebuffer dup [
- swap [ GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT ] dip
- glFramebufferRenderbufferEXT
+ swap [ GL_DRAW_FRAMEBUFFER GL_DEPTH_ATTACHMENT GL_RENDERBUFFER ] dip
+ glFramebufferRenderbuffer
] with-framebuffer ;
: (plane-program) ( -- program )
: (reflection-face) ( gadget face -- )
swap reflection-texture>> [
- GL_FRAMEBUFFER_EXT
- GL_COLOR_ATTACHMENT0_EXT
- ] 2dip 0 glFramebufferTexture2DEXT
+ GL_DRAW_FRAMEBUFFER
+ GL_COLOR_ATTACHMENT0
+ ] 2dip 0 glFramebufferTexture2D
check-framebuffer ;
: (draw-reflection-texture) ( gadget -- )
<image>
swap >>bitmap
RGBA >>component-order
+ ubyte-components >>component-type
terrain-segment-size >>dim ;
: terrain-segment ( terrain at -- image )
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel tokyo.alien.tcadb tokyo.assoc-functor ;
+IN: tokyo.abstractdb
+
+<< "tcadb" "abstractdb" define-tokyo-assoc-api >>
+
+: <tokyo-abstractdb> ( name -- tokyo-abstractdb )
+ tcadbnew [ swap tcadbopen drop ] keep
+ tokyo-abstractdb new [ (>>handle) ] keep ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Higher level API for Tokyo Cabinet's Abstract database API. Implements the associative protocol.
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bindings for Tokyo Cabinet's Abstract database API
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators kernel tokyo.alien.tchdb tokyo.alien.tcutil
+tokyo.alien.tcbdb tokyo.alien.tcfdb tokyo.alien.tctdb ;
+IN: tokyo.alien.tcadb
+
+LIBRARY: tokyocabinet
+
+TYPEDEF: void* TCADB
+
+C-ENUM:
+ ADBOVOID
+ ADBOMDB
+ ADBONDB
+ ADBOHDB
+ ADBOBDB
+ ADBOFDB
+ ADBOTDB
+ ADBOSKEL ;
+
+FUNCTION: TCADB* tcadbnew ( ) ;
+FUNCTION: void tcadbdel ( TCADB* adb ) ;
+FUNCTION: bool tcadbopen ( TCADB* adb, char* name ) ;
+FUNCTION: bool tcadbclose ( TCADB* adb ) ;
+FUNCTION: bool tcadbput ( TCADB* adb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcadbput2 ( TCADB* adb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcadbputkeep ( TCADB* adb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcadbputkeep2 ( TCADB* adb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcadbputcat ( TCADB* adb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcadbputcat2 ( TCADB* adb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcadbout ( TCADB* adb, void* kbuf, int ksiz ) ;
+FUNCTION: bool tcadbout2 ( TCADB* adb, char* kstr ) ;
+FUNCTION: void* tcadbget ( TCADB* adb, void* kbuf, int ksiz, int* sp ) ;
+FUNCTION: char* tcadbget2 ( TCADB* adb, char* kstr ) ;
+FUNCTION: int tcadbvsiz ( TCADB* adb, void* kbuf, int ksiz ) ;
+FUNCTION: int tcadbvsiz2 ( TCADB* adb, char* kstr ) ;
+FUNCTION: bool tcadbiterinit ( TCADB* adb ) ;
+FUNCTION: void* tcadbiternext ( TCADB* adb, int* sp ) ;
+FUNCTION: char* tcadbiternext2 ( TCADB* adb ) ;
+FUNCTION: TCLIST* tcadbfwmkeys ( TCADB* adb, void* pbuf, int psiz, int max ) ;
+FUNCTION: TCLIST* tcadbfwmkeys2 ( TCADB* adb, char* pstr, int max ) ;
+FUNCTION: int tcadbaddint ( TCADB* adb, void* kbuf, int ksiz, int num ) ;
+FUNCTION: double tcadbadddouble ( TCADB* adb, void* kbuf, int ksiz, double num ) ;
+FUNCTION: bool tcadbsync ( TCADB* adb ) ;
+FUNCTION: bool tcadboptimize ( TCADB* adb, char* params ) ;
+FUNCTION: bool tcadbvanish ( TCADB* adb ) ;
+FUNCTION: bool tcadbcopy ( TCADB* adb, char* path ) ;
+FUNCTION: bool tcadbtranbegin ( TCADB* adb ) ;
+FUNCTION: bool tcadbtrancommit ( TCADB* adb ) ;
+FUNCTION: bool tcadbtranabort ( TCADB* adb ) ;
+FUNCTION: char* tcadbpath ( TCADB* adb ) ;
+FUNCTION: ulonglong tcadbrnum ( TCADB* adb ) ;
+FUNCTION: ulonglong tcadbsize ( TCADB* adb ) ;
+FUNCTION: TCLIST* tcadbmisc ( TCADB* adb, char* name, TCLIST* args ) ;
+
+! -----
+
+TYPEDEF: void* ADBSKEL
+
+TYPEDEF: void* ADBMAPPROC
+
+FUNCTION: bool tcadbsetskel ( TCADB* adb, ADBSKEL* skel ) ;
+FUNCTION: int tcadbomode ( TCADB* adb ) ;
+FUNCTION: void* tcadbreveal ( TCADB* adb ) ;
+FUNCTION: bool tcadbputproc ( TCADB* adb, void* kbuf, int ksiz, void* vbuf, int vsiz, TCPDPROC proc, void* op ) ;
+FUNCTION: bool tcadbforeach ( TCADB* adb, TCITER iter, void* op ) ;
+FUNCTION: bool tcadbmapbdb ( TCADB* adb, TCLIST* keys, TCBDB* bdb, ADBMAPPROC proc, void* op, longlong csiz ) ;
+FUNCTION: bool tcadbmapbdbemit ( void* map, char* kbuf, int ksiz, char* vbuf, int vsiz ) ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bindings for Tokyo Cabinet's B+ Tree database API
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators kernel tokyo.alien.tchdb tokyo.alien.tcutil ;
+IN: tokyo.alien.tcbdb
+
+LIBRARY: tokyocabinet
+
+TYPEDEF: void* TCBDB
+
+CONSTANT: BDBFOPEN HDBFOPEN
+CONSTANT: BDBFFATAL HDBFFATAL
+
+CONSTANT: BDBTLARGE 1
+CONSTANT: BDBTDEFLATE 2
+CONSTANT: BDBTBZIP 4
+CONSTANT: BDBTTCBS 8
+CONSTANT: BDBTEXCODEC 16
+
+CONSTANT: BDBOREADER 1
+CONSTANT: BDBOWRITER 2
+CONSTANT: BDBOCREAT 4
+CONSTANT: BDBOTRUNC 8
+CONSTANT: BDBONOLCK 16
+CONSTANT: BDBOLCKNB 32
+CONSTANT: BDBOTSYNC 64
+
+TYPEDEF: void* BDBCUR
+
+C-ENUM:
+ BDBCPCURRENT
+ BDBCPBEFORE
+ BDBCPAFTER ;
+
+FUNCTION: char* tcbdberrmsg ( int ecode ) ;
+FUNCTION: TCBDB* tcbdbnew ( ) ;
+FUNCTION: void tcbdbdel ( TCBDB* bdb ) ;
+FUNCTION: int tcbdbecode ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbsetmutex ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbsetcmpfunc ( TCBDB* bdb, TCCMP cmp, void* cmpop ) ;
+FUNCTION: bool tcbdbtune ( TCBDB* bdb, int lmemb, int nmemb, longlong bnum, char apow, char fpow, uchar opts ) ;
+FUNCTION: bool tcbdbsetcache ( TCBDB* bdb, int lcnum, int ncnum ) ;
+FUNCTION: bool tcbdbsetxmsiz ( TCBDB* bdb, longlong xmsiz ) ;
+FUNCTION: bool tcbdbopen ( TCBDB* bdb, char* path, int omode ) ;
+FUNCTION: bool tcbdbclose ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbput ( TCBDB* bdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcbdbput2 ( TCBDB* bdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcbdbputkeep ( TCBDB* bdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcbdbputkeep2 ( TCBDB* bdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcbdbputcat ( TCBDB* bdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcbdbputcat2 ( TCBDB* bdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcbdbputdup ( TCBDB* bdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcbdbputdup2 ( TCBDB* bdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcbdbputdup3 ( TCBDB* bdb, void* kbuf, int ksiz, TCLIST* vals ) ;
+FUNCTION: bool tcbdbout ( TCBDB* bdb, void* kbuf, int ksiz ) ;
+FUNCTION: bool tcbdbout2 ( TCBDB* bdb, char* kstr ) ;
+FUNCTION: bool tcbdbout3 ( TCBDB* bdb, void* kbuf, int ksiz ) ;
+FUNCTION: void* tcbdbget ( TCBDB* bdb, void* kbuf, int ksiz, int* sp ) ;
+FUNCTION: char* tcbdbget2 ( TCBDB* bdb, char* kstr ) ;
+FUNCTION: void* tcbdbget3 ( TCBDB* bdb, void* kbuf, int ksiz, int* sp ) ;
+FUNCTION: TCLIST* tcbdbget4 ( TCBDB* bdb, void* kbuf, int ksiz ) ;
+FUNCTION: int tcbdbvnum ( TCBDB* bdb, void* kbuf, int ksiz ) ;
+FUNCTION: int tcbdbvnum2 ( TCBDB* bdb, char* kstr ) ;
+FUNCTION: int tcbdbvsiz ( TCBDB* bdb, void* kbuf, int ksiz ) ;
+FUNCTION: int tcbdbvsiz2 ( TCBDB* bdb, char* kstr ) ;
+FUNCTION: TCLIST* tcbdbrange ( TCBDB* bdb, void* bkbuf, int bksiz, bool binc, void* ekbuf, int eksiz, bool einc, int max ) ;
+FUNCTION: TCLIST* tcbdbrange2 ( TCBDB* bdb, char* bkstr, bool binc, char* ekstr, bool einc, int max ) ;
+FUNCTION: TCLIST* tcbdbfwmkeys ( TCBDB* bdb, void* pbuf, int psiz, int max ) ;
+FUNCTION: TCLIST* tcbdbfwmkeys2 ( TCBDB* bdb, char* pstr, int max ) ;
+FUNCTION: int tcbdbaddint ( TCBDB* bdb, void* kbuf, int ksiz, int num ) ;
+FUNCTION: double tcbdbadddouble ( TCBDB* bdb, void* kbuf, int ksiz, double num ) ;
+FUNCTION: bool tcbdbsync ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdboptimize ( TCBDB* bdb, int lmemb, int nmemb, longlong bnum, char apow, char fpow, uchar opts ) ;
+FUNCTION: bool tcbdbvanish ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbcopy ( TCBDB* bdb, char* path ) ;
+FUNCTION: bool tcbdbtranbegin ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbtrancommit ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbtranabort ( TCBDB* bdb ) ;
+FUNCTION: char* tcbdbpath ( TCBDB* bdb ) ;
+FUNCTION: ulonglong tcbdbrnum ( TCBDB* bdb ) ;
+FUNCTION: ulonglong tcbdbfsiz ( TCBDB* bdb ) ;
+FUNCTION: BDBCUR* tcbdbcurnew ( TCBDB* bdb ) ;
+FUNCTION: void tcbdbcurdel ( BDBCUR* cur ) ;
+FUNCTION: bool tcbdbcurfirst ( BDBCUR* cur ) ;
+FUNCTION: bool tcbdbcurlast ( BDBCUR* cur ) ;
+FUNCTION: bool tcbdbcurjump ( BDBCUR* cur, void* kbuf, int ksiz ) ;
+FUNCTION: bool tcbdbcurjump2 ( BDBCUR* cur, char* kstr ) ;
+FUNCTION: bool tcbdbcurprev ( BDBCUR* cur ) ;
+FUNCTION: bool tcbdbcurnext ( BDBCUR* cur ) ;
+FUNCTION: bool tcbdbcurput ( BDBCUR* cur, void* vbuf, int vsiz, int cpmode ) ;
+FUNCTION: bool tcbdbcurput2 ( BDBCUR* cur, char* vstr, int cpmode ) ;
+FUNCTION: bool tcbdbcurout ( BDBCUR* cur ) ;
+FUNCTION: void* tcbdbcurkey ( BDBCUR* cur, int* sp ) ;
+FUNCTION: char* tcbdbcurkey2 ( BDBCUR* cur ) ;
+FUNCTION: void* tcbdbcurkey3 ( BDBCUR* cur, int* sp ) ;
+FUNCTION: void* tcbdbcurval ( BDBCUR* cur, int* sp ) ;
+FUNCTION: char* tcbdbcurval2 ( BDBCUR* cur ) ;
+FUNCTION: void* tcbdbcurval3 ( BDBCUR* cur, int* sp ) ;
+FUNCTION: bool tcbdbcurrec ( BDBCUR* cur, TCXSTR* kxstr, TCXSTR* vxstr ) ;
+
+! -----------
+
+FUNCTION: void tcbdbsetecode ( TCBDB* bdb, int ecode, char* filename, int line, char* func ) ;
+FUNCTION: void tcbdbsetdbgfd ( TCBDB* bdb, int fd ) ;
+FUNCTION: int tcbdbdbgfd ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbhasmutex ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbmemsync ( TCBDB* bdb, bool phys ) ;
+FUNCTION: bool tcbdbcacheclear ( TCBDB* bdb ) ;
+FUNCTION: TCCMP tcbdbcmpfunc ( TCBDB* bdb ) ;
+FUNCTION: void* tcbdbcmpop ( TCBDB* bdb ) ;
+FUNCTION: uint tcbdblmemb ( TCBDB* bdb ) ;
+FUNCTION: uint tcbdbnmemb ( TCBDB* bdb ) ;
+FUNCTION: ulonglong tcbdblnum ( TCBDB* bdb ) ;
+FUNCTION: ulonglong tcbdbnnum ( TCBDB* bdb ) ;
+FUNCTION: ulonglong tcbdbbnum ( TCBDB* bdb ) ;
+FUNCTION: uint tcbdbalign ( TCBDB* bdb ) ;
+FUNCTION: uint tcbdbfbpmax ( TCBDB* bdb ) ;
+FUNCTION: ulonglong tcbdbinode ( TCBDB* bdb ) ;
+FUNCTION: tokyo_time_t tcbdbmtime ( TCBDB* bdb ) ;
+FUNCTION: uchar tcbdbflags ( TCBDB* bdb ) ;
+FUNCTION: uchar tcbdbopts ( TCBDB* bdb ) ;
+FUNCTION: char* tcbdbopaque ( TCBDB* bdb ) ;
+FUNCTION: ulonglong tcbdbbnumused ( TCBDB* bdb ) ;
+FUNCTION: bool tcbdbsetlsmax ( TCBDB* bdb, uint lsmax ) ;
+FUNCTION: bool tcbdbsetcapnum ( TCBDB* bdb, ulonglong capnum ) ;
+FUNCTION: bool tcbdbsetcodecfunc ( TCBDB* bdb, TCCODEC enc, void* encop, TCCODEC dec, void* decop ) ;
+FUNCTION: bool tcbdbputdupback ( TCBDB* bdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcbdbputdupback2 ( TCBDB* bdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcbdbputproc ( TCBDB* bdb, void* kbuf, int ksiz, void* vbuf, int vsiz, TCPDPROC proc, void* op ) ;
+FUNCTION: bool tcbdbcurjumpback ( BDBCUR* cur, void* kbuf, int ksiz ) ;
+FUNCTION: bool tcbdbcurjumpback2 ( BDBCUR* cur, char* kstr ) ;
+FUNCTION: bool tcbdbforeach ( TCBDB* bdb, TCITER iter, void* op ) ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bindings for Tokyo Cabinet's Fixed Length database API
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators kernel tokyo.alien.tcutil ;
+IN: tokyo.alien.tcfdb
+
+TYPEDEF: void* TCFDB
+
+CONSTANT: FDBFOPEN 1
+CONSTANT: FDBFFATAL 2
+
+CONSTANT: FDBOREADER 1
+CONSTANT: FDBOWRITER 2
+CONSTANT: FDBOCREAT 4
+CONSTANT: FDBOTRUNC 8
+CONSTANT: FDBONOLCK 16
+CONSTANT: FDBOLCKNB 32
+CONSTANT: FDBOTSYNC 64
+
+CONSTANT: FDBIDMIN -1
+CONSTANT: FDBIDPREV -2
+CONSTANT: FDBIDMAX -3
+CONSTANT: FDBIDNEXT -4
+
+FUNCTION: char* tcfdberrmsg ( int ecode ) ;
+FUNCTION: TCFDB* tcfdbnew ( ) ;
+FUNCTION: void tcfdbdel ( TCFDB* fdb ) ;
+FUNCTION: int tcfdbecode ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbsetmutex ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbtune ( TCFDB* fdb, int width, longlong limsiz ) ;
+FUNCTION: bool tcfdbopen ( TCFDB* fdb, char* path, int omode ) ;
+FUNCTION: bool tcfdbclose ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbput ( TCFDB* fdb, longlong id, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcfdbput2 ( TCFDB* fdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcfdbput3 ( TCFDB* fdb, char* kstr, void* vstr ) ;
+FUNCTION: bool tcfdbputkeep ( TCFDB* fdb, longlong id, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcfdbputkeep2 ( TCFDB* fdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcfdbputkeep3 ( TCFDB* fdb, char* kstr, void* vstr ) ;
+FUNCTION: bool tcfdbputcat ( TCFDB* fdb, longlong id, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcfdbputcat2 ( TCFDB* fdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcfdbputcat3 ( TCFDB* fdb, char* kstr, void* vstr ) ;
+FUNCTION: bool tcfdbout ( TCFDB* fdb, longlong id ) ;
+FUNCTION: bool tcfdbout2 ( TCFDB* fdb, void* kbuf, int ksiz ) ;
+FUNCTION: bool tcfdbout3 ( TCFDB* fdb, char* kstr ) ;
+FUNCTION: void* tcfdbget ( TCFDB* fdb, longlong id, int* sp ) ;
+FUNCTION: void* tcfdbget2 ( TCFDB* fdb, void* kbuf, int ksiz, int* sp ) ;
+FUNCTION: char* tcfdbget3 ( TCFDB* fdb, char* kstr ) ;
+FUNCTION: int tcfdbget4 ( TCFDB* fdb, longlong id, void* vbuf, int max ) ;
+FUNCTION: int tcfdbvsiz ( TCFDB* fdb, longlong id ) ;
+FUNCTION: int tcfdbvsiz2 ( TCFDB* fdb, void* kbuf, int ksiz ) ;
+FUNCTION: int tcfdbvsiz3 ( TCFDB* fdb, char* kstr ) ;
+FUNCTION: bool tcfdbiterinit ( TCFDB* fdb ) ;
+FUNCTION: ulonglong tcfdbiternext ( TCFDB* fdb ) ;
+FUNCTION: void* tcfdbiternext2 ( TCFDB* fdb, int* sp ) ;
+FUNCTION: char* tcfdbiternext3 ( TCFDB* fdb ) ;
+FUNCTION: ulonglong* tcfdbrange ( TCFDB* fdb, longlong lower, longlong upper, int max, int* np ) ;
+FUNCTION: TCLIST* tcfdbrange2 ( TCFDB* fdb, void* lbuf, int lsiz, void* ubuf, int usiz, int max ) ;
+FUNCTION: TCLIST* tcfdbrange3 ( TCFDB* fdb, char* lstr, char* ustr, int max ) ;
+FUNCTION: TCLIST* tcfdbrange4 ( TCFDB* fdb, void* ibuf, int isiz, int max ) ;
+FUNCTION: TCLIST* tcfdbrange5 ( TCFDB* fdb, void* istr, int max ) ;
+FUNCTION: int tcfdbaddint ( TCFDB* fdb, longlong id, int num ) ;
+FUNCTION: double tcfdbadddouble ( TCFDB* fdb, longlong id, double num ) ;
+FUNCTION: bool tcfdbsync ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdboptimize ( TCFDB* fdb, int width, longlong limsiz ) ;
+FUNCTION: bool tcfdbvanish ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbcopy ( TCFDB* fdb, char* path ) ;
+FUNCTION: bool tcfdbtranbegin ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbtrancommit ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbtranabort ( TCFDB* fdb ) ;
+FUNCTION: char* tcfdbpath ( TCFDB* fdb ) ;
+FUNCTION: ulonglong tcfdbrnum ( TCFDB* fdb ) ;
+FUNCTION: ulonglong tcfdbfsiz ( TCFDB* fdb ) ;
+
+! --------
+
+FUNCTION: void tcfdbsetecode ( TCFDB* fdb, int ecode, char* filename, int line, char* func ) ;
+FUNCTION: void tcfdbsetdbgfd ( TCFDB* fdb, int fd ) ;
+FUNCTION: int tcfdbdbgfd ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbhasmutex ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbmemsync ( TCFDB* fdb, bool phys ) ;
+FUNCTION: ulonglong tcfdbmin ( TCFDB* fdb ) ;
+FUNCTION: ulonglong tcfdbmax ( TCFDB* fdb ) ;
+FUNCTION: uint tcfdbwidth ( TCFDB* fdb ) ;
+FUNCTION: ulonglong tcfdblimsiz ( TCFDB* fdb ) ;
+FUNCTION: ulonglong tcfdblimid ( TCFDB* fdb ) ;
+FUNCTION: ulonglong tcfdbinode ( TCFDB* fdb ) ;
+FUNCTION: tokyo_time_t tcfdbmtime ( TCFDB* fdb ) ;
+FUNCTION: int tcfdbomode ( TCFDB* fdb ) ;
+FUNCTION: uchar tcfdbtype ( TCFDB* fdb ) ;
+FUNCTION: uchar tcfdbflags ( TCFDB* fdb ) ;
+FUNCTION: char* tcfdbopaque ( TCFDB* fdb ) ;
+FUNCTION: bool tcfdbputproc ( TCFDB* fdb, longlong id, void* vbuf, int vsiz, TCPDPROC proc, void* op ) ;
+FUNCTION: bool tcfdbforeach ( TCFDB* fdb, TCITER iter, void* op ) ;
+FUNCTION: longlong tcfdbkeytoid ( char* kbuf, int ksiz ) ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bindings for Tokyo Cabinet's Hash database API
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators kernel tokyo.alien.tcutil ;
+IN: tokyo.alien.tchdb
+
+LIBRARY: tokyocabinet
+
+TYPEDEF: void* TCHDB*
+
+CONSTANT: HDBFOPEN 1
+CONSTANT: HDBFFATAL 2
+
+CONSTANT: HDBTLARGE 1
+CONSTANT: HDBTDEFLATE 2
+CONSTANT: HDBTBZIP 4
+CONSTANT: HDBTTCBS 8
+CONSTANT: HDBTEXCODEC 16
+
+CONSTANT: HDBOREADER 1
+CONSTANT: HDBOWRITER 2
+CONSTANT: HDBOCREAT 4
+CONSTANT: HDBOTRUNC 8
+CONSTANT: HDBONOLCK 16
+CONSTANT: HDBOLCKNB 32
+CONSTANT: HDBOTSYNC 64
+
+FUNCTION: char* tchdberrmsg ( int ecode ) ;
+FUNCTION: TCHDB* tchdbnew ( ) ;
+FUNCTION: void tchdbdel ( TCHDB* hdb ) ;
+FUNCTION: int tchdbecode ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbsetmutex ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbtune ( TCHDB* hdb, longlong bnum, char apow, char fpow, uchar opts ) ;
+FUNCTION: bool tchdbsetcache ( TCHDB* hdb, int rcnum ) ;
+FUNCTION: bool tchdbsetxmsiz ( TCHDB* hdb, longlong xmsiz ) ;
+FUNCTION: bool tchdbopen ( TCHDB* hdb, char* path, int omode ) ;
+FUNCTION: bool tchdbclose ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbput ( TCHDB* hdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tchdbput2 ( TCHDB* hdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tchdbputkeep ( TCHDB* hdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tchdbputkeep2 ( TCHDB* hdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tchdbputcat ( TCHDB* hdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tchdbputcat2 ( TCHDB* hdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tchdbputasync ( TCHDB* hdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tchdbputasync2 ( TCHDB* hdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tchdbout ( TCHDB* hdb, void* kbuf, int ksiz ) ;
+FUNCTION: bool tchdbout2 ( TCHDB* hdb, char* kstr ) ;
+FUNCTION: void* tchdbget ( TCHDB* hdb, void* kbuf, int ksiz, int* sp ) ;
+FUNCTION: char* tchdbget2 ( TCHDB* hdb, char* kstr ) ;
+FUNCTION: int tchdbget3 ( TCHDB* hdb, void* kbuf, int ksiz, void* vbuf, int max ) ;
+FUNCTION: int tchdbvsiz ( TCHDB* hdb, void* kbuf, int ksiz ) ;
+FUNCTION: int tchdbvsiz2 ( TCHDB* hdb, char* kstr ) ;
+FUNCTION: bool tchdbiterinit ( TCHDB* hdb ) ;
+FUNCTION: void* tchdbiternext ( TCHDB* hdb, int* sp ) ;
+FUNCTION: char* tchdbiternext2 ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbiternext3 ( TCHDB* hdb, TCXSTR* kxstr, TCXSTR* vxstr ) ;
+FUNCTION: TCLIST* tchdbfwmkeys ( TCHDB* hdb, void* pbuf, int psiz, int max ) ;
+FUNCTION: TCLIST* tchdbfwmkeys2 ( TCHDB* hdb, char* pstr, int max ) ;
+FUNCTION: int tchdbaddint ( TCHDB* hdb, void* kbuf, int ksiz, int num ) ;
+FUNCTION: double tchdbadddouble ( TCHDB* hdb, void* kbuf, int ksiz, double num ) ;
+FUNCTION: bool tchdbsync ( TCHDB* hdb ) ;
+FUNCTION: bool tchdboptimize ( TCHDB* hdb, longlong bnum, char apow, char fpow, uchar opts ) ;
+FUNCTION: bool tchdbvanish ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbcopy ( TCHDB* hdb, char* path ) ;
+FUNCTION: bool tchdbtranbegin ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbtrancommit ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbtranabort ( TCHDB* hdb ) ;
+FUNCTION: char* tchdbpath ( TCHDB* hdb ) ;
+FUNCTION: ulonglong tchdbrnum ( TCHDB* hdb ) ;
+FUNCTION: ulonglong tchdbfsiz ( TCHDB* hdb ) ;
+
+! --------
+
+FUNCTION: void tchdbsetecode ( TCHDB* hdb, int ecode, char* filename, int line, char* func ) ;
+FUNCTION: void tchdbsettype ( TCHDB* hdb, uchar type ) ;
+FUNCTION: void tchdbsetdbgfd ( TCHDB* hdb, int fd ) ;
+FUNCTION: int tchdbdbgfd ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbhasmutex ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbmemsync ( TCHDB* hdb, bool phys ) ;
+FUNCTION: bool tchdbcacheclear ( TCHDB* hdb ) ;
+FUNCTION: ulonglong tchdbbnum ( TCHDB* hdb ) ;
+FUNCTION: uint tchdbalign ( TCHDB* hdb ) ;
+FUNCTION: uint tchdbfbpmax ( TCHDB* hdb ) ;
+FUNCTION: ulonglong tchdbxmsiz ( TCHDB* hdb ) ;
+FUNCTION: ulonglong tchdbinode ( TCHDB* hdb ) ;
+FUNCTION: tokyo_time_t tchdbmtime ( TCHDB* hdb ) ;
+FUNCTION: int tchdbomode ( TCHDB* hdb ) ;
+FUNCTION: uchar tchdbtype ( TCHDB* hdb ) ;
+FUNCTION: uchar tchdbflags ( TCHDB* hdb ) ;
+FUNCTION: uchar tchdbopts ( TCHDB* hdb ) ;
+FUNCTION: char* tchdbopaque ( TCHDB* hdb ) ;
+FUNCTION: ulonglong tchdbbnumused ( TCHDB* hdb ) ;
+FUNCTION: bool tchdbsetcodecfunc ( TCHDB* hdb, TCCODEC enc, void* encop, TCCODEC dec, void* decop ) ;
+FUNCTION: void tchdbcodecfunc ( TCHDB* hdb, TCCODEC* ep, void* *eop, TCCODEC* dp, void* *dop ) ;
+FUNCTION: bool tchdbputproc ( TCHDB* hdb, void* kbuf, int ksiz, void* vbuf, int vsiz, TCPDPROC proc, void* op ) ;
+FUNCTION: void* tchdbgetnext ( TCHDB* hdb, void* kbuf, int ksiz, int* sp ) ;
+FUNCTION: char* tchdbgetnext2 ( TCHDB* hdb, char* kstr ) ;
+FUNCTION: char* tchdbgetnext3 ( TCHDB* hdb, char* kbuf, int ksiz, int* sp, char* *vbp, int* vsp ) ;
+FUNCTION: bool tchdbforeach ( TCHDB* hdb, TCITER iter, void* op ) ;
+FUNCTION: bool tchdbtranvoid ( TCHDB* hdb ) ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bindings for Tokyo Tyrant's Remote database API
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators kernel system tokyo.alien.tchdb tokyo.alien.tcutil
+tokyo.alien.tctdb ;
+IN: tokyo.alien.tcrdb
+
+<< "tokyotyrant" {
+ { [ os macosx? ] [ "/opt/local/lib/libtokyotyrant.dylib" ] }
+ { [ os unix? ] [ "libtokyotyrant.so" ] }
+ { [ os windows? ] [ "tokyotyrant.dll" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: tokyotyrant
+
+TYPEDEF: void* TCRDB*
+! C-STRUCT: TCRDB
+! { "pthread_mutex_t" mmtx }
+! { "pthread_key_t" eckey }
+! { "char*" host }
+! { "int" port }
+! { "char*" expr }
+! { "int" fd }
+! { "TTSOCK*" sock }
+! { "double" timeout }
+! { "int" opts } ;
+
+C-ENUM:
+ TTESUCCESS
+ TTEINVALID
+ TTENOHOST
+ TTEREFUSED
+ TTESEND
+ TTERECV
+ TTEKEEP
+ TTENOREC ;
+CONSTANT: TTEMISC 9999
+
+CONSTANT: RDBTRECON 1
+CONSTANT: RDBXOLCKREC 1
+CONSTANT: RDBXOLCKGLB 2
+CONSTANT: RDBROCHKCON 1
+CONSTANT: RDBMONOULOG 1
+
+FUNCTION: char* tcrdberrmsg ( int ecode ) ;
+FUNCTION: TCRDB* tcrdbnew ( ) ;
+FUNCTION: void tcrdbdel ( TCRDB* rdb ) ;
+FUNCTION: int tcrdbecode ( TCRDB* rdb ) ;
+FUNCTION: bool tcrdbtune ( TCRDB* rdb, double timeout, int opts ) ;
+FUNCTION: bool tcrdbopen ( TCRDB* rdb, char* host, int port ) ;
+FUNCTION: bool tcrdbopen2 ( TCRDB* rdb, char* expr ) ;
+FUNCTION: bool tcrdbclose ( TCRDB* rdb ) ;
+FUNCTION: bool tcrdbput ( TCRDB* rdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcrdbput2 ( TCRDB* rdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcrdbputkeep ( TCRDB* rdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcrdbputkeep2 ( TCRDB* rdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcrdbputcat ( TCRDB* rdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcrdbputcat2 ( TCRDB* rdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcrdbputshl ( TCRDB* rdb, void* kbuf, int ksiz, void* vbuf, int vsiz, int width ) ;
+FUNCTION: bool tcrdbputshl2 ( TCRDB* rdb, char* kstr, char* vstr, int width ) ;
+FUNCTION: bool tcrdbputnr ( TCRDB* rdb, void* kbuf, int ksiz, void* vbuf, int vsiz ) ;
+FUNCTION: bool tcrdbputnr2 ( TCRDB* rdb, char* kstr, char* vstr ) ;
+FUNCTION: bool tcrdbout ( TCRDB* rdb, void* kbuf, int ksiz ) ;
+FUNCTION: bool tcrdbout2 ( TCRDB* rdb, char* kstr ) ;
+FUNCTION: void* tcrdbget ( TCRDB* rdb, void* kbuf, int ksiz, int* sp ) ;
+FUNCTION: char* tcrdbget2 ( TCRDB* rdb, char* kstr ) ;
+FUNCTION: bool tcrdbget3 ( TCRDB* rdb, TCMAP* recs ) ;
+FUNCTION: int tcrdbvsiz ( TCRDB* rdb, void* kbuf, int ksiz ) ;
+FUNCTION: int tcrdbvsiz2 ( TCRDB* rdb, char* kstr ) ;
+FUNCTION: bool tcrdbiterinit ( TCRDB* rdb ) ;
+FUNCTION: void* tcrdbiternext ( TCRDB* rdb, int* sp ) ;
+FUNCTION: char* tcrdbiternext2 ( TCRDB* rdb ) ;
+FUNCTION: TCLIST* tcrdbfwmkeys ( TCRDB* rdb, void* pbuf, int psiz, int max ) ;
+FUNCTION: TCLIST* tcrdbfwmkeys2 ( TCRDB* rdb, char* pstr, int max ) ;
+FUNCTION: int tcrdbaddint ( TCRDB* rdb, void* kbuf, int ksiz, int num ) ;
+FUNCTION: double tcrdbadddouble ( TCRDB* rdb, void* kbuf, int ksiz, double num ) ;
+FUNCTION: void* tcrdbext ( TCRDB* rdb, char* name, int opts, void* kbuf, int ksiz, void* vbuf, int vsiz, int* sp ) ;
+FUNCTION: char* tcrdbext2 ( TCRDB* rdb, char* name, int opts, char* kstr, char* vstr ) ;
+FUNCTION: bool tcrdbsync ( TCRDB* rdb ) ;
+FUNCTION: bool tcrdboptimize ( TCRDB* rdb, char* params ) ;
+FUNCTION: bool tcrdbvanish ( TCRDB* rdb ) ;
+FUNCTION: bool tcrdbcopy ( TCRDB* rdb, char* path ) ;
+FUNCTION: bool tcrdbrestore ( TCRDB* rdb, char* path, ulonglong ts, int opts ) ;
+FUNCTION: bool tcrdbsetmst ( TCRDB* rdb, char* host, int port, int opts ) ;
+FUNCTION: bool tcrdbsetmst2 ( TCRDB* rdb, char* expr, int opts ) ;
+FUNCTION: char* tcrdbexpr ( TCRDB* rdb ) ;
+FUNCTION: ulonglong tcrdbrnum ( TCRDB* rdb ) ;
+FUNCTION: ulonglong tcrdbsize ( TCRDB* rdb ) ;
+FUNCTION: char* tcrdbstat ( TCRDB* rdb ) ;
+FUNCTION: TCLIST* tcrdbmisc ( TCRDB* rdb, char* name, int opts, TCLIST* args ) ;
+
+CONSTANT: RDBITLEXICAL TDBITLEXICAL
+CONSTANT: RDBITDECIMAL TDBITDECIMAL
+CONSTANT: RDBITOPT TDBITOPT
+CONSTANT: RDBITVOID TDBITVOID
+CONSTANT: RDBITKEEP TDBITKEEP
+
+TYPEDEF: void* RDBQRY*
+! C-STRUCT: RDBQRY
+! { "TCRDB*" rdb }
+! { "TCLIST*" args } ;
+
+CONSTANT: RDBQCSTREQ TDBQCSTREQ
+CONSTANT: RDBQCSTRINC TDBQCSTRINC
+CONSTANT: RDBQCSTRBW TDBQCSTRBW
+CONSTANT: RDBQCSTREW TDBQCSTREW
+CONSTANT: RDBQCSTRAND TDBQCSTRAND
+CONSTANT: RDBQCSTROR TDBQCSTROR
+CONSTANT: RDBQCSTROREQ TDBQCSTROREQ
+CONSTANT: RDBQCSTRRX TDBQCSTRRX
+CONSTANT: RDBQCNUMEQ TDBQCNUMEQ
+CONSTANT: RDBQCNUMGT TDBQCNUMGT
+CONSTANT: RDBQCNUMGE TDBQCNUMGE
+CONSTANT: RDBQCNUMLT TDBQCNUMLT
+CONSTANT: RDBQCNUMLE TDBQCNUMLE
+CONSTANT: RDBQCNUMBT TDBQCNUMBT
+CONSTANT: RDBQCNUMOREQ TDBQCNUMOREQ
+CONSTANT: RDBQCNEGATE TDBQCNEGATE
+CONSTANT: RDBQCNOIDX TDBQCNOIDX
+
+CONSTANT: RDBQOSTRASC TDBQOSTRASC
+CONSTANT: RDBQOSTRDESC TDBQOSTRDESC
+CONSTANT: RDBQONUMASC TDBQONUMASC
+CONSTANT: RDBQONUMDESC TDBQONUMDESC
+
+FUNCTION: bool tcrdbtblput ( TCRDB* rdb, void* pkbuf, int pksiz, TCMAP* cols ) ;
+FUNCTION: bool tcrdbtblputkeep ( TCRDB* rdb, void* pkbuf, int pksiz, TCMAP* cols ) ;
+FUNCTION: bool tcrdbtblputcat ( TCRDB* rdb, void* pkbuf, int pksiz, TCMAP* cols ) ;
+FUNCTION: bool tcrdbtblout ( TCRDB* rdb, void* pkbuf, int pksiz ) ;
+FUNCTION: TCMAP* tcrdbtblget ( TCRDB* rdb, void* pkbuf, int pksiz ) ;
+FUNCTION: bool tcrdbtblsetindex ( TCRDB* rdb, char* name, int type ) ;
+FUNCTION: longlong tcrdbtblgenuid ( TCRDB* rdb ) ;
+FUNCTION: RDBQRY* tcrdbqrynew ( TCRDB* rdb ) ;
+FUNCTION: void tcrdbqrydel ( RDBQRY* qry ) ;
+FUNCTION: void tcrdbqryaddcond ( RDBQRY* qry, char* name, int op, char* expr ) ;
+FUNCTION: void tcrdbqrysetorder ( RDBQRY* qry, char* name, int type ) ;
+FUNCTION: void tcrdbqrysetlimit ( RDBQRY* qry, int max, int skip ) ;
+FUNCTION: TCLIST* tcrdbqrysearch ( RDBQRY* qry ) ;
+FUNCTION: bool tcrdbqrysearchout ( RDBQRY* qry ) ;
+FUNCTION: TCLIST* tcrdbqrysearchget ( RDBQRY* qry ) ;
+FUNCTION: TCMAP* tcrdbqryrescols ( TCLIST* res, int index ) ;
+FUNCTION: int tcrdbqrysearchcount ( RDBQRY* qry ) ;
+
+FUNCTION: void tcrdbsetecode ( TCRDB* rdb, int ecode ) ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bindings for Tokyo Cabinet's Table database API
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators kernel tokyo.alien.tchdb tokyo.alien.tcutil ;
+IN: tokyo.alien.tctdb
+
+LIBRARY: tokyocabinet
+
+TYPEDEF: void* TDBIDX*
+TYPEDEF: void* TCTDB*
+
+CONSTANT: TDBFOPEN HDBFOPEN
+CONSTANT: TDBFFATAL HDBFFATAL
+
+CONSTANT: TDBTLARGE 1
+CONSTANT: TDBTDEFLATE 2
+CONSTANT: TDBTBZIP 4
+CONSTANT: TDBTTCBS 8
+CONSTANT: TDBTEXCODEC 16
+
+CONSTANT: TDBOREADER 1
+CONSTANT: TDBOWRITER 2
+CONSTANT: TDBOCREAT 4
+CONSTANT: TDBOTRUNC 8
+CONSTANT: TDBONOLCK 16
+CONSTANT: TDBOLCKNB 32
+CONSTANT: TDBOTSYNC 64
+
+C-ENUM:
+ TDBITLEXICAL
+ TDBITDECIMAL ;
+
+CONSTANT: TDBITOPT 9998
+CONSTANT: TDBITVOID 9999
+CONSTANT: TDBITKEEP 16777216
+
+TYPEDEF: void* TDBCOND*
+TYPEDEF: void* TDBQRY*
+
+C-ENUM:
+ TDBQCSTREQ
+ TDBQCSTRINC
+ TDBQCSTRBW
+ TDBQCSTREW
+ TDBQCSTRAND
+ TDBQCSTROR
+ TDBQCSTROREQ
+ TDBQCSTRRX
+ TDBQCNUMEQ
+ TDBQCNUMGT
+ TDBQCNUMGE
+ TDBQCNUMLT
+ TDBQCNUMLE
+ TDBQCNUMBT
+ TDBQCNUMOREQ ;
+
+CONSTANT: TDBQCNEGATE 16777216
+CONSTANT: TDBQCNOIDX 33554432
+
+C-ENUM:
+ TDBQOSTRASC
+ TDBQOSTRDESC
+ TDBQONUMASC
+ TDBQONUMDESC ;
+
+CONSTANT: TDBQPPUT 1
+CONSTANT: TDBQPOUT 2
+CONSTANT: TDBQPSTOP 16777216
+
+! int (*)(const void *pkbuf, int pksiz, TCMAP *cols, void *op);
+TYPEDEF: void* TDBQRYPROC
+
+FUNCTION: char* tctdberrmsg ( int ecode ) ;
+FUNCTION: TCTDB* tctdbnew ( ) ;
+FUNCTION: void tctdbdel ( TCTDB* tdb ) ;
+FUNCTION: int tctdbecode ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbsetmutex ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbtune ( TCTDB* tdb, longlong bnum, char apow, char fpow, uchar opts ) ;
+FUNCTION: bool tctdbsetcache ( TCTDB* tdb, int rcnum, int lcnum, int ncnum ) ;
+FUNCTION: bool tctdbsetxmsiz ( TCTDB* tdb, longlong xmsiz ) ;
+FUNCTION: bool tctdbopen ( TCTDB* tdb, char* path, int omode ) ;
+FUNCTION: bool tctdbclose ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbput ( TCTDB* tdb, void* pkbuf, int pksiz, TCMAP* cols ) ;
+FUNCTION: bool tctdbput2 ( TCTDB* tdb, void* pkbuf, int pksiz, void* cbuf, int csiz ) ;
+FUNCTION: bool tctdbput3 ( TCTDB* tdb, char* pkstr, char* cstr ) ;
+FUNCTION: bool tctdbputkeep ( TCTDB* tdb, void* pkbuf, int pksiz, TCMAP* cols ) ;
+FUNCTION: bool tctdbputkeep2 ( TCTDB* tdb, void* pkbuf, int pksiz, void* cbuf, int csiz ) ;
+FUNCTION: bool tctdbputkeep3 ( TCTDB* tdb, char* pkstr, char* cstr ) ;
+FUNCTION: bool tctdbputcat ( TCTDB* tdb, void* pkbuf, int pksiz, TCMAP* cols ) ;
+FUNCTION: bool tctdbputcat2 ( TCTDB* tdb, void* pkbuf, int pksiz, void* cbuf, int csiz ) ;
+FUNCTION: bool tctdbputcat3 ( TCTDB* tdb, char* pkstr, char* cstr ) ;
+FUNCTION: bool tctdbout ( TCTDB* tdb, void* pkbuf, int pksiz ) ;
+FUNCTION: bool tctdbout2 ( TCTDB* tdb, char* pkstr ) ;
+FUNCTION: TCMAP* tctdbget ( TCTDB* tdb, void* pkbuf, int pksiz ) ;
+FUNCTION: char* tctdbget2 ( TCTDB* tdb, void* pkbuf, int pksiz, int* sp ) ;
+FUNCTION: char* tctdbget3 ( TCTDB* tdb, char* pkstr ) ;
+FUNCTION: int tctdbvsiz ( TCTDB* tdb, void* pkbuf, int pksiz ) ;
+FUNCTION: int tctdbvsiz2 ( TCTDB* tdb, char* pkstr ) ;
+FUNCTION: bool tctdbiterinit ( TCTDB* tdb ) ;
+FUNCTION: void* tctdbiternext ( TCTDB* tdb, int* sp ) ;
+FUNCTION: char* tctdbiternext2 ( TCTDB* tdb ) ;
+FUNCTION: TCLIST* tctdbfwmkeys ( TCTDB* tdb, void* pbuf, int psiz, int max ) ;
+FUNCTION: TCLIST* tctdbfwmkeys2 ( TCTDB* tdb, char* pstr, int max ) ;
+FUNCTION: int tctdbaddint ( TCTDB* tdb, void* pkbuf, int pksiz, int num ) ;
+FUNCTION: double tctdbadddouble ( TCTDB* tdb, void* pkbuf, int pksiz, double num ) ;
+FUNCTION: bool tctdbsync ( TCTDB* tdb ) ;
+FUNCTION: bool tctdboptimize ( TCTDB* tdb, longlong bnum, char apow, char fpow, uchar opts ) ;
+FUNCTION: bool tctdbvanish ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbcopy ( TCTDB* tdb, char* path ) ;
+FUNCTION: bool tctdbtranbegin ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbtrancommit ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbtranabort ( TCTDB* tdb ) ;
+FUNCTION: char* tctdbpath ( TCTDB* tdb ) ;
+FUNCTION: ulonglong tctdbrnum ( TCTDB* tdb ) ;
+FUNCTION: ulonglong tctdbfsiz ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbsetindex ( TCTDB* tdb, char* name, int type ) ;
+FUNCTION: longlong tctdbgenuid ( TCTDB* tdb ) ;
+FUNCTION: TDBQRY* tctdbqrynew ( TCTDB* tdb ) ;
+FUNCTION: void tctdbqrydel ( TDBQRY* qry ) ;
+FUNCTION: void tctdbqryaddcond ( TDBQRY* qry, char* name, int op, char* expr ) ;
+FUNCTION: void tctdbqrysetorder ( TDBQRY* qry, char* name, int type ) ;
+FUNCTION: void tctdbqrysetlimit ( TDBQRY* qry, int max, int skip ) ;
+FUNCTION: TCLIST* tctdbqrysearch ( TDBQRY* qry ) ;
+FUNCTION: bool tctdbqrysearchout ( TDBQRY* qry ) ;
+FUNCTION: bool tctdbqryproc ( TDBQRY* qry, TDBQRYPROC proc, void* op ) ;
+FUNCTION: char* tctdbqryhint ( TDBQRY* qry ) ;
+
+! =======
+
+FUNCTION: void tctdbsetecode ( TCTDB* tdb, int ecode, char* filename, int line, char* func ) ;
+FUNCTION: void tctdbsetdbgfd ( TCTDB* tdb, int fd ) ;
+FUNCTION: int tctdbdbgfd ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbhasmutex ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbmemsync ( TCTDB* tdb, bool phys ) ;
+FUNCTION: ulonglong tctdbbnum ( TCTDB* tdb ) ;
+FUNCTION: uint tctdbalign ( TCTDB* tdb ) ;
+FUNCTION: uint tctdbfbpmax ( TCTDB* tdb ) ;
+FUNCTION: ulonglong tctdbinode ( TCTDB* tdb ) ;
+FUNCTION: tokyo_time_t tctdbmtime ( TCTDB* tdb ) ;
+FUNCTION: uchar tctdbflags ( TCTDB* tdb ) ;
+FUNCTION: uchar tctdbopts ( TCTDB* tdb ) ;
+FUNCTION: char* tctdbopaque ( TCTDB* tdb ) ;
+FUNCTION: ulonglong tctdbbnumused ( TCTDB* tdb ) ;
+FUNCTION: int tctdbinum ( TCTDB* tdb ) ;
+FUNCTION: longlong tctdbuidseed ( TCTDB* tdb ) ;
+FUNCTION: bool tctdbsetuidseed ( TCTDB* tdb, longlong seed ) ;
+FUNCTION: bool tctdbsetcodecfunc ( TCTDB* tdb, TCCODEC enc, void* encop, TCCODEC dec, void* decop ) ;
+FUNCTION: bool tctdbputproc ( TCTDB* tdb, void* pkbuf, int pksiz, void* cbuf, int csiz, TCPDPROC proc, void* op ) ;
+FUNCTION: bool tctdbforeach ( TCTDB* tdb, TCITER iter, void* op ) ;
+FUNCTION: bool tctdbqryproc2 ( TDBQRY* qry, TDBQRYPROC proc, void* op ) ;
+FUNCTION: bool tctdbqrysearchout2 ( TDBQRY* qry ) ;
+FUNCTION: int tctdbstrtoindextype ( char* str ) ;
+FUNCTION: int tctdbqrycount ( TDBQRY* qry ) ;
+FUNCTION: int tctdbqrystrtocondop ( char* str ) ;
+FUNCTION: int tctdbqrystrtoordertype ( char* str ) ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bindings for Tokyo Cabinet's Utils API
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators kernel system ;
+IN: tokyo.alien.tcutil
+
+<< "tokyocabinet" {
+ { [ os macosx? ] [ "/opt/local/lib/libtokyocabinet.dylib" ] }
+ { [ os unix? ] [ "libtokyocabinet.so" ] }
+ { [ os windows? ] [ "tokyocabinet.dll" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: tokyocabinet
+
+C-ENUM:
+ TCDBTHASH
+ TCDBTBTREE
+ TCDBTFIXED
+ TCDBTTABLE ;
+
+! FIXME: on windows 64bits this isn't correct, because long is 32bits there, and time_t is int64
+TYPEDEF: long tokyo_time_t
+
+TYPEDEF: void* TCLIST*
+
+FUNCTION: TCLIST* tclistnew ( ) ;
+FUNCTION: TCLIST* tclistnew2 ( int anum ) ;
+FUNCTION: void tclistdel ( TCLIST* list ) ;
+FUNCTION: int tclistnum ( TCLIST* list ) ;
+FUNCTION: void* tclistval ( TCLIST* list, int index, int* sp ) ;
+FUNCTION: char* tclistval2 ( TCLIST* list, int index ) ;
+FUNCTION: void tclistpush ( TCLIST* list, void* ptr, int size ) ;
+FUNCTION: void tclistpush2 ( TCLIST* list, char* str ) ;
+FUNCTION: void tcfree ( void* ptr ) ;
+
+TYPEDEF: void* TCCMP
+TYPEDEF: void* TCCODEC
+TYPEDEF: void* TCPDPROC
+TYPEDEF: void* TCITER
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays assocs destructors fry functors
+kernel locals sequences serialize tokyo.alien.tcutil tokyo.utils vectors ;
+IN: tokyo.assoc-functor
+
+FUNCTOR: define-tokyo-assoc-api ( T N -- )
+
+DBGET IS ${T}get
+DBPUT IS ${T}put
+DBOUT IS ${T}out
+DBDEL IS ${T}del
+DBRNUM IS ${T}rnum
+DBITERINIT IS ${T}iterinit
+DBITERNEXT IS ${T}iternext
+DBVANISH IS ${T}vanish
+
+DBKEYS DEFINES tokyo-${N}-keys
+
+TYPE DEFINES-CLASS tokyo-${N}
+
+WHERE
+
+TUPLE: TYPE handle disposed ;
+
+INSTANCE: TYPE assoc
+
+M: TYPE dispose* [ DBDEL f ] change-handle drop ;
+
+M: TYPE at* ( key db -- value/f ? )
+ handle>> swap object>bytes dup length 0 <int>
+ DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
+
+M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
+
+: DBKEYS ( db -- keys )
+ [ assoc-size <vector> ] [ handle>> ] bi
+ dup DBITERINIT drop 0 <int>
+ [ 2dup DBITERNEXT dup ] [
+ [ memory>object ] [ tcfree ] bi
+ [ pick ] dip swap push
+ ] while 3drop ;
+
+M: TYPE >alist ( db -- alist )
+ [ DBKEYS dup ] keep '[ dup _ at 2array ] change-each ;
+
+M: TYPE set-at ( value key db -- )
+ handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ;
+
+M: TYPE delete-at ( key db -- )
+ handle>> swap object>bytes dup length DBOUT drop ;
+
+M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ;
+
+M: TYPE equal? assoc= ;
+
+M: TYPE hashcode* assoc-hashcode ;
+
+;FUNCTOR
\ No newline at end of file
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Functor used to implement the assoc protocol on the different db apis in Tokyo
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel tokyo.alien.tcrdb tokyo.assoc-functor ;
+IN: tokyo.remotedb
+
+<< "tcrdb" "remotedb" define-tokyo-assoc-api >>
+
+: <tokyo-remotedb> ( host port -- tokyo-remotedb )
+ [ tcrdbnew dup ] 2dip tcrdbopen drop
+ tokyo-remotedb new [ (>>handle) ] keep ;
--- /dev/null
+Higher level API for Tokyo Tyrant's Remote database API. Implements the associative protocol.
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Some utility words used by the tokyo vocabs
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.streams.memory serialize kernel ;
+IN: tokyo.utils
+
+: with-memory-reader ( memory quot -- )
+ [ <memory-stream> ] dip with-input-stream* ; inline
+
+: memory>object ( memory -- object )
+ [ deserialize ] with-memory-reader ;
f swap open-window* ;
: into-window ( world quot -- world )
- [ dup handle>> ] dip with-gl-context ; inline
+ [ dup ] dip with-gl-context ; inline
--- /dev/null
+Syntax and combinators for manipulating algebraic data types
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays classes classes.singleton classes.tuple help.markup
+help.syntax kernel multiline slots quotations ;
+IN: variants
+
+HELP: VARIANT:
+{ $syntax <"
+VARIANT: class-name
+ singleton
+ singleton
+ tuple: { slot slot slot ... }
+ .
+ .
+ .
+ ; "> }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $examples { $code <"
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+"> } } ;
+
+HELP: match
+{ $values { "branches" array } }
+{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
+{ $examples { $example <"
+USING: kernel math prettyprint variants ;
+IN: scratchpad
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+
+: list-length ( list -- length )
+ {
+ { nil [ 0 ] }
+ { cons [ nip list-length 1 + ] }
+ } match ;
+
+1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
+"> "4" } } ;
+
+HELP: unboa
+{ $values { "class" class } }
+{ $description "Decomposes a tuple of type " { $snippet "class" } " into its component slot values by order of arguments. The inverse of " { $link boa } "." } ;
+
+HELP: variant-class
+{ $class-description "This class comprises class names that have been defined with " { $link POSTPONE: VARIANT: } ". When a " { $snippet "variant-class" } " is used as the type of a specialized " { $link tuple } " slot, the variant's first member type is used as the default " { $link initial-value } "." } ;
+
+{ POSTPONE: VARIANT: variant-class match } related-words
+
+ARTICLE: "variants" "Algebraic data types"
+"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
+{ $subsection POSTPONE: VARIANT: }
+{ $subsection variant-class }
+{ $subsection match } ;
+
+ABOUT: "variants"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel math tools.test variants ;
+IN: variants.tests
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+
+[ t ] [ nil list? ] unit-test
+[ t ] [ 1 nil <cons> list? ] unit-test
+[ f ] [ 1 list? ] unit-test
+
+: list-length ( list -- length )
+ {
+ { nil [ 0 ] }
+ { cons [ nip list-length 1 + ] }
+ } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays classes classes.mixin classes.parser
+classes.singleton classes.tuple classes.tuple.parser
+classes.union combinators inverse kernel lexer macros make
+parser quotations sequences slots splitting words ;
+IN: variants
+
+PREDICATE: variant-class < mixin-class "variant" word-prop ;
+
+M: variant-class initial-value*
+ dup members [ no-initial-value ]
+ [ nip first dup word? [ initial-value* ] unless ] if-empty ;
+
+: define-tuple-class-and-boa-word ( class superclass slots -- )
+ pick [ define-tuple-class ] dip
+ dup name>> "<" ">" surround create-in swap define-boa-word ;
+
+: define-variant-member ( member -- class )
+ dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
+
+: define-variant-class ( class members -- )
+ [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
+ [ define-variant-member swap add-mixin-instance ] with each ;
+
+: parse-variant-tuple-member ( name -- member )
+ create-class-in tuple
+ "{" expect
+ [ "}" parse-tuple-slots-delim ] { } make
+ 3array ;
+
+: parse-variant-member ( name -- member )
+ ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
+
+: parse-variant-members ( -- members )
+ [ scan dup ";" = not ]
+ [ parse-variant-member ] produce nip ;
+
+SYNTAX: VARIANT:
+ CREATE-CLASS
+ parse-variant-members
+ define-variant-class ;
+
+MACRO: unboa ( class -- )
+ <wrapper> \ boa [ ] 2sequence [undo] ;
+
+GENERIC# (match-branch) 1 ( class quot -- class quot' )
+
+M: singleton-class (match-branch)
+ \ drop prefix ;
+M: object (match-branch)
+ over \ unboa [ ] 2sequence prepend ;
+
+: ?class ( object -- class )
+ dup word? [ class ] unless ;
+
+MACRO: match ( branches -- )
+ [ dup callable? [ first2 (match-branch) 2array ] unless ] map
+ [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
+
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel furnace.actions html.forms
-http.server.dispatchers db db.tuples db.types urls
-furnace.redirection multiline http namespaces ;
+USING: accessors furnace.actions furnace.redirection
+html.forms http http.server http.server.dispatchers
+io.directories io.encodings.utf8 io.files io.pathnames
+kernel math.parser multiline namespaces sequences urls ;
IN: webapps.imagebin
-TUPLE: imagebin < dispatcher ;
-
-TUPLE: image id path ;
-
-image "IMAGE" {
- { "id" "ID" INTEGER +db-assigned-id+ }
- { "path" "PATH" { VARCHAR 256 } +not-null+ }
-} define-persistent
+TUPLE: imagebin < dispatcher path n ;
: <uploaded-image-action> ( -- action )
<page-action>
{ imagebin "uploaded-image" } >>template ;
-SYMBOL: my-post-data
+: next-image-path ( -- path )
+ imagebin get
+ [ path>> ] [ n>> number>string ] bi append-path ;
+
+M: imagebin call-responder*
+ [ imagebin set ] [ call-next-method ] bi ;
+
+: move-image ( mime-file -- )
+ next-image-path
+ [ [ temporary-path>> ] dip move-file ]
+ [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
+
: <upload-image-action> ( -- action )
<page-action>
{ imagebin "upload-image" } >>template
[
-
- ! request get post-data>> my-post-data set-global
- ! image new
- ! "file" value
- ! insert-tuple
+ "file1" param [ move-image ] when*
+ "file2" param [ move-image ] when*
+ "file3" param [ move-image ] when*
"uploaded-image" <redirect>
] >>submit ;
-: <imagebin> ( -- responder )
+: <imagebin> ( image-directory -- responder )
imagebin new-dispatcher
+ swap [ make-directories ] [ >>path ] bi
+ 0 >>n
<upload-image-action> "" add-responder
<upload-image-action> "upload-image" add-responder
<uploaded-image-action> "uploaded-image" add-responder ;
+"resource:images" <imagebin> main-responder set-global
<html>
<head><title>Uploaded</title></head>
<body>
-hi from uploaded-image
+You uploaded something!
</body>
</html>
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel
-cocoa
-cocoa.application
-cocoa.types
-cocoa.classes
-cocoa.windows
-core-graphics.types ;
+USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
+core-graphics.types kernel math.bitwise ;
IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ;
+: window-style ( -- n )
+ {
+ NSClosableWindowMask
+ NSMiniaturizableWindowMask
+ NSResizableWindowMask
+ NSTitledWindowMask
+ } flags ;
+
: <WebWindow> ( -- id )
- <WebView> rect <ViewWindow> ;
+ <WebView> rect window-style <ViewWindow> ;
: load-url ( window url -- )
[ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;
--- /dev/null
+Open windows with different control sets
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs kernel locals sequences ui
+ui.gadgets ui.gadgets.worlds ;
+IN: window-controls-demo
+
+CONSTANT: window-control-sets-to-test
+ H{
+ { "No controls" { } }
+ { "Normal title bar" { normal-title-bar } }
+ { "Small title bar" { small-title-bar close-button } }
+ { "Close button" { normal-title-bar close-button } }
+ { "Close and minimize buttons" { normal-title-bar close-button minimize-button } }
+ { "Minimize button" { normal-title-bar minimize-button } }
+ { "Close, minimize, and maximize buttons" { normal-title-bar close-button minimize-button maximize-button } }
+ { "Resizable" { normal-title-bar close-button minimize-button maximize-button resize-handles } }
+ }
+
+TUPLE: window-controls-demo-world < world
+ windows ;
+
+M: window-controls-demo-world end-world
+ windows>> [ close-window ] each ;
+
+M: window-controls-demo-world pref-dim*
+ drop { 400 400 } ;
+
+: attributes-template ( -- x )
+ T{ world-attributes
+ { world-class window-controls-demo-world }
+ } clone ;
+
+: window-controls-demo ( -- )
+ attributes-template V{ } clone window-control-sets-to-test
+ [| title attributes windows controls |
+ f attributes
+ title >>title
+ controls >>window-controls
+ open-window*
+ windows >>windows
+ windows push
+ ] with with assoc-each ;
+
+MAIN: window-controls-demo
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
-syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
(beginning-of-line)
(when (fuel-syntax--at-begin-of-def) 0)))
+(defsubst factor-mode--previous-non-empty ()
+ (forward-line -1)
+ (while (and (not (bobp))
+ (fuel-syntax--looking-at-emptiness))
+ (forward-line -1)))
+
(defun factor-mode--indent-setter-line ()
(when (fuel-syntax--at-setter-line)
- (save-excursion
- (let ((indent (and (fuel-syntax--at-constructor-line)
- (current-indentation))))
- (while (not (or indent
- (bobp)
- (fuel-syntax--at-begin-of-def)
- (fuel-syntax--at-end-of-def)))
- (if (fuel-syntax--at-constructor-line)
- (setq indent (fuel-syntax--increased-indentation))
- (forward-line -1)))
- indent))))
+ (or (save-excursion
+ (let ((indent (and (fuel-syntax--at-constructor-line)
+ (current-indentation))))
+ (while (not (or indent
+ (bobp)
+ (fuel-syntax--at-begin-of-def)
+ (fuel-syntax--at-end-of-def)))
+ (if (fuel-syntax--at-constructor-line)
+ (setq indent (fuel-syntax--increased-indentation))
+ (forward-line -1)))
+ indent))
+ (save-excursion
+ (factor-mode--previous-non-empty)
+ (current-indentation)))))
(defun factor-mode--indent-continuation ()
(save-excursion
- (forward-line -1)
- (while (and (not (bobp))
- (fuel-syntax--looking-at-emptiness))
- (forward-line -1))
+ (factor-mode--previous-non-empty)
(cond ((or (fuel-syntax--at-end-of-def)
(fuel-syntax--at-setter-line))
(fuel-syntax--decreased-indentation))