Merge branch 'master' into more_aggressive_coalescing

db4
Slava Pestov 2009-09-27 19:29:50 -05:00
commit f757b454cc
115 changed files with 754 additions and 574 deletions

40
basis/alien/c-types/c-types-tests.factor Normal file → Executable file
View File

@ -1,50 +1,50 @@
USING: alien alien.syntax alien.c-types kernel tools.test USING: alien alien.syntax alien.c-types alien.parser
sequences system libc alien.strings io.encodings.utf8 kernel tools.test sequences system libc alien.strings
math.constants ; io.encodings.utf8 math.constants classes.struct ;
IN: alien.c-types.tests IN: alien.c-types.tests
CONSTANT: xyz 123 CONSTANT: xyz 123
[ 492 ] [ { "int" xyz } heap-size ] unit-test [ 492 ] [ { int xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test [ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test [ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test [ -1 ] [ -1 <int> *int ] unit-test
C-UNION: foo UNION-STRUCT: foo
"int" { a int }
"int" ; { b int } ;
[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test [ f ] [ "char*" parse-c-type c-type void* c-type eq? ] unit-test
[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test [ t ] [ "char**" parse-c-type c-type void* c-type eq? ] unit-test
[ t ] [ "foo" heap-size "int" heap-size = ] unit-test [ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt TYPEDEF: int MyInt
[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test [ t ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test [ t ] [ void* c-type "MyInt*" parse-c-type c-type eq? ] unit-test
TYPEDEF: char MyChar TYPEDEF: char MyChar
[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test [ t ] [ char c-type MyChar c-type eq? ] unit-test
[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test [ f ] [ void* c-type "MyChar*" parse-c-type c-type eq? ] unit-test
[ t ] [ "char*" c-type "MyChar*" c-type eq? ] unit-test [ t ] [ "char*" parse-c-type c-type "MyChar*" parse-c-type c-type eq? ] unit-test
[ 32 ] [ { "int" 8 } heap-size ] unit-test [ 32 ] [ { int 8 } heap-size ] unit-test
TYPEDEF: char* MyString TYPEDEF: char* MyString
[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test [ t ] [ char* c-type MyString c-type eq? ] unit-test
[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test [ t ] [ void* c-type "MyString*" parse-c-type c-type eq? ] unit-test
TYPEDEF: int* MyIntArray TYPEDEF: int* MyIntArray
[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test [ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE TYPEDEF: uchar* MyLPBYTE
[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test [ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[ [
0 B{ 1 2 3 4 } <displaced-alien> <void*> 0 B{ 1 2 3 4 } <displaced-alien> <void*>

View File

@ -60,6 +60,8 @@ GENERIC: c-type ( name -- c-type ) foldable
GENERIC: resolve-pointer-type ( name -- c-type ) GENERIC: resolve-pointer-type ( name -- c-type )
<< \ void \ void* "pointer-c-type" set-word-prop >>
M: word resolve-pointer-type M: word resolve-pointer-type
dup "pointer-c-type" word-prop dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ; [ ] [ drop void* ] ?if ;

View File

@ -0,0 +1,27 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax
tools.test vocabs.parser ;
IN: alien.parser.tests
TYPEDEF: char char2
[ int ] [ "int" parse-c-type ] unit-test
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
[ void* ] [ "int*" parse-c-type ] unit-test
[ void* ] [ "int**" parse-c-type ] unit-test
[ void* ] [ "int***" parse-c-type ] unit-test
[ void* ] [ "int****" parse-c-type ] unit-test
[ char* ] [ "char*" parse-c-type ] unit-test
[ void* ] [ "char**" parse-c-type ] unit-test
[ void* ] [ "char***" parse-c-type ] unit-test
[ void* ] [ "char****" parse-c-type ] unit-test
[ char2 ] [ "char2" parse-c-type ] unit-test
[ char* ] [ "char2*" parse-c-type ] unit-test
SYMBOL: not-c-type
[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
! uncomment this when string C type parsing goes away
! [ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with

View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov ! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax classes.struct ; USING: alien.c-types alien.syntax classes.struct ;
IN: cocoa.runtime IN: cocoa.runtime
TYPEDEF: void* SEL TYPEDEF: void* SEL

View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov ! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators kernel layouts USING: alien.c-types alien.syntax combinators kernel layouts
classes.struct core-graphics.types ; classes.struct cocoa.runtime core-graphics.types ;
IN: cocoa.types IN: cocoa.types
TYPEDEF: long NSInteger TYPEDEF: long NSInteger

View File

@ -657,7 +657,8 @@ literal: label
def: dst/int-rep def: dst/int-rep
use: src1/int-rep src2/int-rep ; use: src1/int-rep src2/int-rep ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot TUPLE: spill-slot { n integer } ;
C: <spill-slot> spill-slot
INSN: _gc INSN: _gc
temp: temp1 temp2 temp: temp1 temp2
@ -667,11 +668,11 @@ literal: data-values tagged-values uninitialized-locs ;
! virtual registers ! virtual registers
INSN: _spill INSN: _spill
use: src use: src
literal: rep n ; literal: rep dst ;
INSN: _reload INSN: _reload
def: dst def: dst
literal: rep n ; literal: rep src ;
INSN: _spill-area-size INSN: _spill-area-size
literal: n ; literal: n ;

View File

@ -34,11 +34,15 @@ IN: compiler.cfg.linear-scan.allocation
[ drop assign-blocked-register ] [ drop assign-blocked-register ]
} cond ; } cond ;
: spill-at-sync-point ( live-interval n -- ? )
! If the live interval has a usage at 'n', don't spill it,
! since this means its being defined by the sync point
! instruction. Output t if this is the case.
2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
: handle-sync-point ( n -- ) : handle-sync-point ( n -- )
[ active-intervals get values ] dip [ active-intervals get values ] dip
[ '[ [ _ spill ] each ] each ] '[ [ _ spill-at-sync-point ] filter-here ] each ;
[ drop [ delete-all ] each ]
2bi ;
:: handle-progress ( n sync? -- ) :: handle-progress ( n sync? -- )
n { n {

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps USING: accessors assocs combinators cpu.architecture fry heaps
kernel math math.order namespaces sequences vectors kernel math math.order namespaces sequences vectors
compiler.cfg compiler.cfg.registers compiler.cfg compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state IN: compiler.cfg.linear-scan.allocation.state
@ -118,7 +118,8 @@ SYMBOL: unhandled-intervals
: next-spill-slot ( rep -- n ) : next-spill-slot ( rep -- n )
rep-size cfg get rep-size cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ; [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
<spill-slot> ;
! Minheap of sync points which still need to be processed ! Minheap of sync points which still need to be processed
SYMBOL: unhandled-sync-points SYMBOL: unhandled-sync-points
@ -126,7 +127,7 @@ SYMBOL: unhandled-sync-points
! Mapping from vregs to spill slots ! Mapping from vregs to spill slots
SYMBOL: spill-slots SYMBOL: spill-slots
: vreg-spill-slot ( vreg -- n ) : vreg-spill-slot ( vreg -- spill-slot )
spill-slots get [ rep-of next-spill-slot ] cache ; spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- ) : init-allocator ( registers -- )

View File

@ -33,7 +33,7 @@ ERROR: bad-vreg vreg ;
: (vreg>reg) ( vreg pending -- reg ) : (vreg>reg) ( vreg pending -- reg )
! If a live vreg is not in the pending set, then it must ! If a live vreg is not in the pending set, then it must
! have been spilled. ! have been spilled.
?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ; ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
: vreg>reg ( vreg -- reg ) : vreg>reg ( vreg -- reg )
pending-interval-assoc get (vreg>reg) ; pending-interval-assoc get (vreg>reg) ;

View File

@ -92,7 +92,7 @@ H{
{ end 2 } { end 2 }
{ uses V{ 0 1 } } { uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 2 } } } { ranges V{ T{ live-range f 0 2 } } }
{ spill-to 0 } { spill-to T{ spill-slot f 0 } }
} }
T{ live-interval T{ live-interval
{ vreg 1 } { vreg 1 }
@ -100,7 +100,7 @@ H{
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } } { ranges V{ T{ live-range f 5 5 } } }
{ reload-from 0 } { reload-from T{ spill-slot f 0 } }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -119,7 +119,7 @@ H{
{ end 1 } { end 1 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } } { ranges V{ T{ live-range f 0 1 } } }
{ spill-to 4 } { spill-to T{ spill-slot f 4 } }
} }
T{ live-interval T{ live-interval
{ vreg 2 } { vreg 2 }
@ -127,7 +127,7 @@ H{
{ end 5 } { end 5 }
{ uses V{ 1 5 } } { uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } } { ranges V{ T{ live-range f 1 5 } } }
{ reload-from 4 } { reload-from T{ spill-slot f 4 } }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -146,7 +146,7 @@ H{
{ end 1 } { end 1 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } } { ranges V{ T{ live-range f 0 1 } } }
{ spill-to 8 } { spill-to T{ spill-slot f 8 } }
} }
T{ live-interval T{ live-interval
{ vreg 3 } { vreg 3 }
@ -154,7 +154,7 @@ H{
{ end 30 } { end 30 }
{ uses V{ 20 30 } } { uses V{ 20 30 } }
{ ranges V{ T{ live-range f 20 30 } } } { ranges V{ T{ live-range f 20 30 } } }
{ reload-from 8 } { reload-from T{ spill-slot f 8 } }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -1042,8 +1042,8 @@ V{
[ _spill ] [ 1 get instructions>> second class ] unit-test [ _spill ] [ 1 get instructions>> second class ] unit-test
[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test [ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test [ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test [ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test
! Resolve pass should insert this ! Resolve pass should insert this
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test [ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test

View File

@ -17,7 +17,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
[ [
{ {
T{ _reload { dst 1 } { rep int-rep } { n 0 } } T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
} }
] [ ] [
[ [
@ -27,7 +27,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
[ [
{ {
T{ _spill { src 1 } { rep int-rep } { n 0 } } T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
} }
] [ ] [
[ [
@ -54,14 +54,14 @@ H{ } clone spill-temps set
{ { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } } { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
mapping-instructions { mapping-instructions {
{ {
T{ _spill { src 0 } { rep int-rep } { n 8 } } T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } } T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
T{ _reload { dst 1 } { rep int-rep } { n 8 } } T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
} }
{ {
T{ _spill { src 1 } { rep int-rep } { n 8 } } T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } } T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
T{ _reload { dst 0 } { rep int-rep } { n 8 } } T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
} }
} member? } member?
] unit-test ] unit-test

View File

@ -34,10 +34,10 @@ SYMBOL: spill-temps
] if ; ] if ;
: memory->register ( from to -- ) : memory->register ( from to -- )
swap [ first2 ] [ first n>> ] bi* _reload ; swap [ first2 ] [ first ] bi* _reload ;
: register->memory ( from to -- ) : register->memory ( from to -- )
[ first2 ] [ first n>> ] bi* _spill ; [ first2 ] [ first ] bi* _spill ;
: temp->register ( from to -- ) : temp->register ( from to -- )
nip [ first ] [ second ] [ second spill-temp ] tri _reload ; nip [ first ] [ second ] [ second spill-temp ] tri _reload ;

View File

@ -240,7 +240,7 @@ CODEGEN: _reload %reload
GENERIC# save-gc-root 1 ( gc-root operand temp -- ) GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- ) M:: spill-slot save-gc-root ( gc-root operand temp -- )
temp int-rep operand n>> %reload temp int-rep operand %reload
gc-root temp %save-gc-root ; gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ; M: object save-gc-root drop %save-gc-root ;
@ -253,7 +253,7 @@ GENERIC# load-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot load-gc-root ( gc-root operand temp -- ) M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root gc-root temp %load-gc-root
temp int-rep operand n>> %spill ; temp int-rep operand %spill ;
M: object load-gc-root drop %load-gc-root ; M: object load-gc-root drop %load-gc-root ;

View File

@ -1,9 +1,10 @@
USING: generalizations accessors arrays compiler kernel kernel.private USING: generalizations accessors arrays compiler kernel
math hashtables.private math.private namespaces sequences tools.test kernel.private math hashtables.private math.private namespaces
namespaces.private slots.private sequences.private byte-arrays alien sequences tools.test namespaces.private slots.private
alien.accessors layouts words definitions compiler.units io sequences.private byte-arrays alien alien.accessors layouts
combinators vectors grouping make alien.c-types combinators.short-circuit words definitions compiler.units io combinators vectors grouping
math.order math.libm math.parser alien.c-types ; make alien.c-types combinators.short-circuit math.order
math.libm math.parser math.functions ;
FROM: math => float ; FROM: math => float ;
QUALIFIED: namespaces.private QUALIFIED: namespaces.private
IN: compiler.tests.codegen IN: compiler.tests.codegen
@ -432,6 +433,7 @@ cell 4 = [
] compile-call ] compile-call
] unit-test ] unit-test
! Bug in CSSA construction
TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ; TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
[ 2 ] [ [ 2 ] [
@ -449,3 +451,13 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
] 2curry each-integer ] 2curry each-integer
] compile-call ] compile-call
] unit-test ] unit-test
! Bug in linear scan's partial sync point logic
[ t ] [
[ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call
1.168852488727981 1.e-9 ~
] unit-test
[ 65537.0 ] [
[ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call
] unit-test

View File

@ -1,10 +1,9 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays USING: accessors arrays assocs byte-vectors combinators
byte-vectors combinators fry grouping hashtables compression.huffman fry hashtables io.binary kernel locals math
compression.huffman images io.binary kernel locals math.bitwise math.order math.ranges sequences sorting ;
math math.bitwise math.order math.ranges multiline sequences QUALIFIED-WITH: bitstreams bs
sorting ;
IN: compression.inflate IN: compression.inflate
QUALIFIED-WITH: bitstreams bs QUALIFIED-WITH: bitstreams bs
@ -178,41 +177,8 @@ CONSTANT: dist-table
] ]
[ produce ] keep call suffix concat ; [ produce ] keep call suffix concat ;
! [ produce ] keep dip swap suffix
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ;
:: png-unfilter-line ( prev curr filter -- curr' )
prev :> c
prev 3 tail-slice :> b
curr :> a
curr 3 tail-slice :> x
x length [0,b)
filter {
{ 0 [ drop ] }
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case
curr 3 tail ;
PRIVATE> PRIVATE>
: reverse-png-filter' ( lines -- byte-array )
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + ] B{ } map-as ;
: reverse-png-filter ( lines -- byte-array )
dup first length 0 <array> prefix
[ { 0 0 } prepend ] map
2 clump [
first2 dup [ third ] [ [ 0 2 ] dip set-nth ] bi
png-unfilter-line
] map B{ } concat-as ;
: zlib-inflate ( bytes -- bytes ) : zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader> bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi [ check-zlib-header ] [ inflate-loop ] bi

View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators system alien.libraries ; USING: alien alien.c-types alien.syntax combinators system
alien.libraries ;
IN: compression.zlib.ffi IN: compression.zlib.ffi
<< "zlib" { << "zlib" {

View File

@ -1,6 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel sequences fry ; USING: alien.c-types alien.syntax core-foundation kernel
sequences fry ;
IN: core-foundation.arrays IN: core-foundation.arrays
TYPEDEF: void* CFArrayRef TYPEDEF: void* CFArrayRef

View File

@ -1,6 +1,8 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel destructors core-foundation USING: alien.c-types alien.syntax kernel destructors
core-foundation core-foundation.dictionaries
core-foundation.strings
core-foundation.utilities ; core-foundation.utilities ;
IN: core-foundation.attributed-strings IN: core-foundation.attributed-strings

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel sequences core-foundation USING: alien.c-types alien.syntax kernel sequences
core-foundation.urls ; core-foundation core-foundation.urls ;
IN: core-foundation.bundles IN: core-foundation.bundles
TYPEDEF: void* CFBundleRef TYPEDEF: void* CFBundleRef

View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Joe Groff. ! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax kernel math sequences ; USING: alien.c-types alien.syntax core-foundation kernel math
sequences ;
IN: core-foundation.data IN: core-foundation.data
TYPEDEF: void* CFDataRef TYPEDEF: void* CFDataRef

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax core-foundation kernel assocs USING: alien.c-types alien.syntax core-foundation kernel assocs
specialized-arrays math sequences accessors ; specialized-arrays math sequences accessors ;
IN: core-foundation.dictionaries IN: core-foundation.dictionaries

View File

@ -1,11 +1,12 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel math.bitwise core-foundation ; USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
IN: core-foundation.file-descriptors IN: core-foundation.file-descriptors
TYPEDEF: void* CFFileDescriptorRef TYPEDEF: void* CFFileDescriptorRef
TYPEDEF: int CFFileDescriptorNativeDescriptor TYPEDEF: int CFFileDescriptorNativeDescriptor
TYPEDEF: void* CFFileDescriptorCallBack TYPEDEF: void* CFFileDescriptorCallBack
TYPEDEF: void* CFFileDescriptorContext*
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
CFAllocatorRef allocator, CFAllocatorRef allocator,

View File

@ -4,8 +4,8 @@ USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals continuations combinators io.encodings.utf8 destructors locals
arrays specialized-arrays classes.struct core-foundation arrays specialized-arrays classes.struct core-foundation
core-foundation.run-loop core-foundation.strings core-foundation.arrays core-foundation.run-loop
core-foundation.time ; core-foundation.strings core-foundation.time unix.types ;
IN: core-foundation.fsevents IN: core-foundation.fsevents
SPECIALIZED-ARRAY: void* SPECIALIZED-ARRAY: void*

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax kernel math namespaces USING: accessors alien alien.c-types alien.syntax kernel math
sequences destructors combinators threads heaps deques calendar namespaces sequences destructors combinators threads heaps
core-foundation core-foundation.strings deques calendar core-foundation core-foundation.strings
core-foundation.file-descriptors core-foundation.timers core-foundation.file-descriptors core-foundation.timers
core-foundation.time ; core-foundation.time ;
IN: core-foundation.run-loop IN: core-foundation.run-loop

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.strings io.encodings.string kernel USING: alien.c-types alien.syntax alien.strings io.encodings.string
sequences byte-arrays io.encodings.utf8 math core-foundation kernel sequences byte-arrays io.encodings.utf8 math core-foundation
core-foundation.arrays destructors parser fry alien words ; core-foundation.arrays destructors parser fry alien words ;
IN: core-foundation.strings IN: core-foundation.strings

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: calendar alien.syntax ; USING: calendar alien.c-types alien.syntax ;
IN: core-foundation.time IN: core-foundation.time
TYPEDEF: double CFTimeInterval TYPEDEF: double CFTimeInterval

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax system math kernel calendar core-foundation USING: alien.c-types alien.syntax system math kernel calendar
core-foundation.time ; core-foundation core-foundation.time ;
IN: core-foundation.timers IN: core-foundation.timers
TYPEDEF: void* CFRunLoopTimerRef TYPEDEF: void* CFRunLoopTimerRef

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel core-foundation.strings USING: alien.c-types alien.syntax kernel core-foundation.strings
core-foundation ; core-foundation core-foundation.urls ;
IN: core-foundation.urls IN: core-foundation.urls
CONSTANT: kCFURLPOSIXPathStyle 0 CONSTANT: kCFURLPOSIXPathStyle 0

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.destructors alien.syntax accessors USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors destructors fry kernel math math.bitwise sequences libc colors
images images.memory core-graphics.types core-foundation.utilities ; images images.memory core-graphics.types core-foundation.utilities
opengl.gl ;
IN: core-graphics IN: core-graphics
! CGImageAlphaInfo ! CGImageAlphaInfo

View File

@ -1,10 +1,12 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax classes.struct kernel layouts USING: accessors alien.c-types alien.syntax classes.struct kernel layouts
math math.rectangles arrays ; math math.rectangles arrays literals ;
FROM: alien.c-types => float ;
IN: core-graphics.types IN: core-graphics.types
<< cell 4 = "float" "double" ? "CGFloat" typedef >> SYMBOL: CGFloat
<< cell 4 = float double ? \ CGFloat typedef >>
: <CGFloat> ( x -- alien ) : <CGFloat> ( x -- alien )
cell 4 = [ <float> ] [ <double> ] if ; inline cell 4 = [ <float> ] [ <double> ] if ; inline

View File

@ -1,8 +1,9 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.syntax assocs core-foundation USING: accessors alien.c-types alien.syntax assocs core-foundation
core-foundation.strings core-text.utilities destructors init core-foundation.dictionaries core-foundation.strings
kernel math memoize fonts combinators ; core-graphics.types core-text.utilities destructors init
kernel math memoize fonts combinators unix.types ;
IN: core-text.fonts IN: core-text.fonts
TYPEDEF: void* CTFontRef TYPEDEF: void* CTFontRef

View File

@ -309,8 +309,8 @@ HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
HOOK: %spill cpu ( src rep n -- ) HOOK: %spill cpu ( src rep dst -- )
HOOK: %reload cpu ( dst rep n -- ) HOOK: %reload cpu ( dst rep src -- )
HOOK: %loop-entry cpu ( -- ) HOOK: %loop-entry cpu ( -- )

View File

@ -630,11 +630,11 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] } { stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ; } case ;
M: ppc %spill ( src rep n -- ) M: ppc %spill ( src rep dst -- )
swap [ spill@ ] dip store-to-frame ; swap [ n>> spill@ ] dip store-to-frame ;
M: ppc %reload ( dst rep n -- ) M: ppc %reload ( dst rep src -- )
swap [ spill@ ] dip load-from-frame ; swap [ n>> spill@ ] dip load-from-frame ;
M: ppc %loop-entry ; M: ppc %loop-entry ;

View File

@ -282,6 +282,34 @@ M: x86.32 %callback-value ( ctype -- )
! Unbox EAX ! Unbox EAX
unbox-return ; unbox-return ;
GENERIC: float-function-param ( stack-slot dst src -- )
M:: spill-slot float-function-param ( stack-slot dst src -- )
! We can clobber dst here since its going to contain the
! final result
dst src double-rep %copy
stack-slot dst double-rep %copy ;
M: register float-function-param
nip double-rep %copy ;
: float-function-return ( reg -- )
ESP [] FSTPL
ESP [] MOVSD
ESP 16 ADD ;
M:: x86.32 %unary-float-function ( dst src func -- )
ESP -16 [+] dst src float-function-param
ESP 16 SUB
func f %alien-invoke
dst float-function-return ;
M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
ESP -16 [+] dst src1 float-function-param
ESP -8 [+] dst src2 float-function-param
ESP 16 SUB
func f %alien-invoke
dst float-function-return ;
M: x86.32 %cleanup ( params -- ) M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it #! a) If we just called an stdcall function in Windows, it

View File

@ -218,8 +218,8 @@ M: x86.64 %callback-value ( ctype -- )
! Unbox former top of data stack to return registers ! Unbox former top of data stack to return registers
unbox-return ; unbox-return ;
: float-function-param ( i spill-slot -- ) : float-function-param ( i src -- )
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ; [ float-regs param-regs nth ] dip double-rep %copy ;
: float-function-return ( reg -- ) : float-function-return ( reg -- )
float-regs return-reg double-rep %copy ; float-regs return-reg double-rep %copy ;
@ -230,6 +230,8 @@ M:: x86.64 %unary-float-function ( dst src func -- )
dst float-function-return ; dst float-function-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src1 might equal dst; otherwise it will be a spill slot
! src2 is always a spill slot
0 src1 float-function-param 0 src1 float-function-param
1 src2 float-function-param 1 src2 float-function-param
func f %alien-invoke func f %alien-invoke
@ -249,9 +251,6 @@ M:: x86.64 %call-gc ( gc-root-count temp -- )
! x86-64. ! x86-64.
enable-alien-4-intrinsics enable-alien-4-intrinsics
! Enable fast calling of libc math functions
enable-float-functions
USE: vocabs.loader USE: vocabs.loader
{ {

View File

@ -142,7 +142,10 @@ M: double-2-rep copy-register* drop MOVUPD ;
M: vector-rep copy-register* drop MOVDQU ; M: vector-rep copy-register* drop MOVDQU ;
M: x86 %copy ( dst src rep -- ) M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [ copy-register* ] if ; 2over eq? [ 3drop ] [
[ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
copy-register*
] if ;
M: x86 %fixnum-add ( label dst src1 src2 -- ) M: x86 %fixnum-add ( label dst src1 src2 -- )
int-rep two-operand ADD JO ; int-rep two-operand ADD JO ;
@ -954,11 +957,8 @@ M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- ) M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
\ UCOMISD (%compare-float-branch) ; \ UCOMISD (%compare-float-branch) ;
M:: x86 %spill ( src rep n -- ) M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
n spill@ src rep %copy ; M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
M:: x86 %reload ( dst rep n -- )
dst n spill@ rep %copy ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
@ -1006,6 +1006,7 @@ enable-fixnum-log2
enable-float-intrinsics enable-float-intrinsics
enable-fsqrt enable-fsqrt
enable-float-min/max enable-float-min/max
enable-float-functions
install-sse2-check install-sse2-check
] when ; ] when ;

View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2008 Doug Coleman. ! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! tested on debian linux with postgresql 8.1 ! tested on debian linux with postgresql 8.1
USING: alien alien.syntax combinators system alien.libraries ; USING: alien alien.c-types alien.syntax combinators system
alien.libraries ;
IN: db.postgresql.ffi IN: db.postgresql.ffi
<< "postgresql" { << "postgresql" {
@ -68,8 +69,8 @@ TYPEDEF: void* PQconninfoOption*
TYPEDEF: void* PGnotify* TYPEDEF: void* PGnotify*
TYPEDEF: void* PQArgBlock* TYPEDEF: void* PQArgBlock*
TYPEDEF: void* PQprintOpt* TYPEDEF: void* PQprintOpt*
TYPEDEF: void* FILE*
TYPEDEF: void* SSL* TYPEDEF: void* SSL*
TYPEDEF: void* FILE*
LIBRARY: postgresql LIBRARY: postgresql

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax system environment.unix ; USING: alien.c-types alien.syntax system environment.unix ;
IN: environment.unix.macosx IN: environment.unix.macosx
FUNCTION: void* _NSGetEnviron ( ) ; FUNCTION: void* _NSGetEnviron ( ) ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Matthew Willis. ! Copyright (C) 2008 Matthew Willis.
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license ! See http://factorcode.org/license.txt for BSD license
USING: alien alien.syntax alien.destructors combinators system USING: alien alien.c-types alien.syntax alien.destructors
alien.libraries ; combinators system alien.libraries ;
IN: glib IN: glib
<< <<
@ -27,12 +27,10 @@ TYPEDEF: void* gpointer
TYPEDEF: int gint TYPEDEF: int gint
TYPEDEF: bool gboolean TYPEDEF: bool gboolean
FUNCTION: void FUNCTION: void g_free ( gpointer mem ) ;
g_free ( gpointer mem ) ;
LIBRARY: gobject LIBRARY: gobject
FUNCTION: void FUNCTION: void g_object_unref ( gpointer object ) ;
g_object_unref ( gpointer object ) ;
DESTRUCTOR: g_object_unref DESTRUCTOR: g_object_unref

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators USING: accessors alien.c-types arrays byte-arrays combinators
compression.run-length fry grouping images images.loader io compression.run-length fry grouping images images.loader io
io.binary io.encodings.8-bit io.encodings.binary io.binary io.encodings.8-bit io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise io.encodings.string io.streams.limited kernel math math.bitwise

View File

@ -1,9 +1,9 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors images io io.binary io.encodings.ascii USING: accessors arrays checksums checksums.crc32 combinators
io.encodings.binary io.encodings.string io.files io.files.info kernel compression.inflate fry grouping images images.loader io
sequences io.streams.limited fry combinators arrays math checksums io.binary io.encodings.ascii io.encodings.string kernel locals
checksums.crc32 compression.inflate grouping byte-arrays images.loader ; math math.bitwise math.ranges sequences sorting ;
IN: images.png IN: images.png
SINGLETON: png-image SINGLETON: png-image
@ -78,27 +78,52 @@ ERROR: bad-checksum ;
ERROR: unknown-color-type n ; ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ; ERROR: unimplemented-color-type image ;
ERROR: unknown-filter-method image ;
: inflate-data ( loading-png -- bytes ) : inflate-data ( loading-png -- bytes )
find-compressed-bytes zlib-inflate ; find-compressed-bytes zlib-inflate ;
: png-group-width ( loading-png -- n ) : scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
dup color-type>> {
{ 2 [ [ bit-depth>> 8 / 3 * ] [ width>> ] bi * 1 + ] }
{ 6 [ [ bit-depth>> 8 / 4 * ] [ width>> ] bi * 1 + ] }
[ unknown-color-type ]
} case ;
: filter-png ( groups loading-png -- byte-array ) : png-bytes-per-pixel ( loading-png -- n )
filter-method>> { dup color-type>> {
{ filter-none [ reverse-png-filter ] } { 2 [ scale-bit-depth 3 * ] }
[ unknown-filter-method ] { 6 [ scale-bit-depth 4 * ] }
} case ; [ unknown-color-type ]
} case ; inline
: png-group-width ( loading-png -- n )
! 1 + is for the filter type, 1 byte preceding each line
[ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ;
:: png-unfilter-line ( prev curr filter -- curr' )
prev :> c
prev 3 tail-slice :> b
curr :> a
curr 3 tail-slice :> x
x length [0,b)
filter {
{ filter-none [ drop ] }
{ filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
{ filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case
curr 3 tail ;
: reverse-png-filter ( lines -- byte-array )
dup first length 0 <array> prefix
[ { 0 0 } prepend ] map
2 clump [
first2 dup [ third ] [ [ 0 2 ] dip set-nth ] bi
png-unfilter-line
] map B{ } concat-as ;
: png-image-bytes ( loading-png -- byte-array ) : png-image-bytes ( loading-png -- byte-array )
[ [ inflate-data ] [ png-group-width ] bi group ] [ inflate-data ] [ png-group-width ] bi group reverse-png-filter ;
[ filter-png ] bi ;
: decode-greyscale ( loading-png -- loading-png ) : decode-greyscale ( loading-png -- loading-png )
unimplemented-color-type ; unimplemented-color-type ;

View File

@ -7,6 +7,7 @@ io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors specialized-arrays locals strings math.vectors specialized-arrays locals
images.loader ; images.loader ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: float
IN: images.tiff IN: images.tiff

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: system kernel unix math sequences USING: alien.c-types system kernel unix math sequences
io.backend.unix io.ports specialized-arrays accessors ; io.backend.unix io.ports specialized-arrays accessors ;
QUALIFIED: io.pipes QUALIFIED: io.pipes
SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: int

View File

@ -1,6 +1,7 @@
USING: iokit alien alien.syntax alien.c-types kernel USING: iokit alien alien.syntax alien.c-types kernel system
system core-foundation core-foundation.data core-foundation core-foundation.arrays core-foundation.data
core-foundation.dictionaries ; core-foundation.dictionaries core-foundation.run-loop
core-foundation.strings core-foundation.time ;
IN: iokit.hid IN: iokit.hid
CONSTANT: kIOHIDDeviceKey "IOHIDDevice" CONSTANT: kIOHIDDeviceKey "IOHIDDevice"

View File

@ -1,10 +1,11 @@
USING: accessors alien alien.c-types alien.data arrays USING: accessors alien alien.c-types alien.complex
byte-arrays combinators combinators.short-circuit fry alien.data arrays byte-arrays combinators
kernel locals macros math math.blas.ffi math.blas.vectors combinators.short-circuit fry kernel locals macros math
math.blas.vectors.private math.complex math.functions math.blas.ffi math.blas.vectors math.blas.vectors.private
math.order functors words sequences sequences.merged math.complex math.functions math.order functors words
sequences.private shuffle parser prettyprint.backend sequences sequences.merged sequences.private shuffle
prettyprint.custom ascii specialized-arrays ; parser prettyprint.backend prettyprint.custom ascii
specialized-arrays ;
FROM: alien.c-types => float ; FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double

View File

@ -1,8 +1,8 @@
USING: accessors alien alien.c-types arrays ascii byte-arrays combinators USING: accessors alien alien.c-types alien.complex arrays ascii
combinators.short-circuit fry kernel math math.blas.ffi byte-arrays combinators combinators.short-circuit fry kernel
math.complex math.functions math.order sequences sequences.private math math.blas.ffi math.complex math.functions math.order
functors words locals parser prettyprint.backend prettyprint.custom sequences sequences.private functors words locals parser
specialized-arrays ; prettyprint.backend prettyprint.custom specialized-arrays ;
FROM: alien.c-types => float ; FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double

View File

@ -1,7 +1,7 @@
USING: accessors alien.syntax arrays assocs biassocs USING: accessors alien.c-types alien.syntax arrays assocs
classes.struct combinators cpu.x86.features kernel literals biassocs classes.struct combinators cpu.x86.features kernel
math math.bitwise math.floats.env math.floats.env.private literals math math.bitwise math.floats.env
system ; math.floats.env.private system ;
IN: math.floats.env.x86 IN: math.floats.env.x86
STRUCT: sse-env STRUCT: sse-env

View File

@ -111,6 +111,7 @@ N [ 16 T heap-size /i ]
A DEFINES-CLASS ${T}-${N} A DEFINES-CLASS ${T}-${N}
A-boa DEFINES ${A}-boa A-boa DEFINES ${A}-boa
A-with DEFINES ${A}-with A-with DEFINES ${A}-with
A-cast DEFINES ${A}-cast
>A DEFINES >${A} >A DEFINES >${A}
A{ DEFINES ${A}{ A{ DEFINES ${A}{
@ -170,6 +171,9 @@ SYNTAX: A{ \ } [ >A ] parse-literal ;
\ A-boa \ A-rep \ A define-boa-custom-inlining \ A-boa \ A-rep \ A define-boa-custom-inlining
] when ] when
: A-cast ( simd-array -- simd-array' )
underlying>> \ A boa ; inline
INSTANCE: A sequence INSTANCE: A sequence
<PRIVATE <PRIVATE
@ -228,6 +232,7 @@ A/2-with IS ${A/2}-with
A DEFINES-CLASS ${T}-${N} A DEFINES-CLASS ${T}-${N}
A-boa DEFINES ${A}-boa A-boa DEFINES ${A}-boa
A-with DEFINES ${A}-with A-with DEFINES ${A}-with
A-cast DEFINES ${A}-cast
>A DEFINES >${A} >A DEFINES >${A}
A{ DEFINES ${A}{ A{ DEFINES ${A}{
@ -295,6 +300,9 @@ M: A pprint* pprint-object ;
\ A-rep 2 boa-effect \ A-boa set-stack-effect \ A-rep 2 boa-effect \ A-boa set-stack-effect
: A-cast ( simd-array -- simd-array' )
[ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline
INSTANCE: A sequence INSTANCE: A sequence
: A-vv->v-op ( v1 v2 quot -- v3 ) : A-vv->v-op ( v1 v2 quot -- v3 )

View File

@ -68,6 +68,7 @@ ARTICLE: "math.vectors.simd.words" "SIMD vector words"
{ "Word" "Stack effect" "Description" } { "Word" "Stack effect" "Description" }
{ { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" } { { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
{ { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" } { { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" }
{ { $snipept "type-cast" } { $snippet "( simd-array -- simd-array' )" } "creates a new SIMD array where the underlying data is taken from another SIMD array, with no format conversion" }
{ { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" } { { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
{ { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" } { { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
} }

View File

@ -55,11 +55,33 @@ PRIVATE>
[ drop call ] [ drop call ]
} case ; inline } case ; inline
: fp-bitwise-unary ( x seq quot -- z )
swap element-type {
{ c:double [ [ double>bits ] dip call bits>double ] }
{ c:float [ [ float>bits ] dip call bits>float ] }
[ drop call ]
} case ; inline
PRIVATE> PRIVATE>
: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ; : vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ;
: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ; : vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; : vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ;
: vand ( u v -- w ) [ and ] 2map ;
: vor ( u v -- w ) [ or ] 2map ;
: vxor ( u v -- w ) [ xor ] 2map ;
: vnot ( u -- w ) [ not ] map ;
: v< ( u v -- w ) [ < ] { } 2map-as ;
: v<= ( u v -- w ) [ <= ] { } 2map-as ;
: v>= ( u v -- w ) [ >= ] { } 2map-as ;
: v> ( u v -- w ) [ > ] { } 2map-as ;
: vunordered? ( u v -- w ) [ unordered? ] { } 2map-as ;
: v= ( u v -- w ) [ = ] { } 2map-as ;
: v? ( ? u v -- w ) [ ? ] pick 3map-as ;
: vlshift ( u n -- w ) '[ _ shift ] map ; : vlshift ( u n -- w ) '[ _ shift ] map ;
: vrshift ( u n -- w ) neg '[ _ shift ] map ; : vrshift ( u n -- w ) neg '[ _ shift ] map ;

View File

@ -3,9 +3,9 @@
! This file is based on the gl.h that comes with xorg-x11 6.8.2 ! This file is based on the gl.h that comes with xorg-x11 6.8.2
USING: alien alien.syntax combinators kernel parser sequences USING: alien alien.c-types alien.syntax combinators kernel parser
system words opengl.gl.extensions ; sequences system words opengl.gl.extensions ;
FROM: alien.c-types => short ;
IN: opengl.gl IN: opengl.gl
TYPEDEF: uint GLenum TYPEDEF: uint GLenum

2
basis/opengl/gl/windows/windows.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: alien.syntax kernel windows.types ; USING: alien.c-types alien.syntax kernel windows.types ;
IN: opengl.gl.windows IN: opengl.gl.windows
LIBRARY: gl LIBRARY: gl

View File

@ -5,6 +5,7 @@ kernel opengl opengl.gl opengl.capabilities combinators images
images.tesselation grouping sequences math math.vectors images.tesselation grouping sequences math math.vectors
math.matrices generalizations fry arrays namespaces system math.matrices generalizations fry arrays namespaces system
locals literals specialized-arrays ; locals literals specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: float
IN: opengl.textures IN: opengl.textures

View File

@ -103,15 +103,15 @@ FUNCTION: void* BIO_f_buffer ( ) ;
CONSTANT: EVP_MAX_MD_SIZE 64 CONSTANT: EVP_MAX_MD_SIZE 64
TYPEDEF: void* EVP_MD*
TYPEDEF: void* ENGINE*
STRUCT: EVP_MD_CTX STRUCT: EVP_MD_CTX
{ digest EVP_MD* } { digest EVP_MD* }
{ engine ENGINE* } { engine ENGINE* }
{ flags ulong } { flags ulong }
{ md_data void* } ; { md_data void* } ;
TYPEDEF: void* EVP_MD*
TYPEDEF: void* ENGINE*
! Initialize ciphers and digest tables ! Initialize ciphers and digest tables
FUNCTION: void OpenSSL_add_all_ciphers ( ) ; FUNCTION: void OpenSSL_add_all_ciphers ( ) ;

View File

@ -1,9 +1,9 @@
! Copyright (C) 2007 Elie CHAFTARI ! Copyright (C) 2007 Elie CHAFTARI
! Portions copyright (C) 2008 Slava Pestov ! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators kernel system namespaces USING: alien alien.c-types alien.syntax combinators kernel
assocs parser lexer sequences words quotations math.bitwise system namespaces assocs parser lexer sequences words
alien.libraries ; quotations math.bitwise alien.libraries ;
IN: openssl.libssl IN: openssl.libssl
@ -95,6 +95,17 @@ TYPEDEF: void* SSL*
LIBRARY: libssl LIBRARY: libssl
! ===============================================
! x509.h
! ===============================================
TYPEDEF: void* X509_NAME*
TYPEDEF: void* X509*
FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
! =============================================== ! ===============================================
! ssl.h ! ssl.h
! =============================================== ! ===============================================
@ -258,17 +269,6 @@ CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200
: SSL_SESS_CACHE_NO_INTERNAL ( -- n ) : SSL_SESS_CACHE_NO_INTERNAL ( -- n )
{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
! ===============================================
! x509.h
! ===============================================
TYPEDEF: void* X509_NAME*
TYPEDEF: void* X509*
FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
! =============================================== ! ===============================================
! x509_vfy.h ! x509_vfy.h
! =============================================== ! ===============================================

View File

@ -3,8 +3,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
! pangocairo bindings, from pango/pangocairo.h ! pangocairo bindings, from pango/pangocairo.h
USING: alien alien.syntax combinators system cairo.ffi USING: arrays sequences alien alien.c-types alien.destructors
alien.libraries ; alien.libraries alien.syntax math math.functions math.vectors
destructors combinators colors fonts accessors assocs namespaces
kernel pango pango.fonts pango.layouts glib unicode.data images
cache init system math.rectangles fry memoize io.encodings.utf8
classes.struct cairo cairo.ffi ;
IN: pango.cairo IN: pango.cairo
<< { << {
@ -15,6 +19,9 @@ IN: pango.cairo
LIBRARY: pangocairo LIBRARY: pangocairo
TYPEDEF: void* PangoCairoFontMap*
TYPEDEF: void* PangoCairoFont*
FUNCTION: PangoFontMap* FUNCTION: PangoFontMap*
pango_cairo_font_map_new ( ) ; pango_cairo_font_map_new ( ) ;
@ -87,3 +94,150 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
FUNCTION: void FUNCTION: void
pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ; pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
SYMBOL: dpi
72 dpi set-global
: set-layout-font ( font layout -- )
swap cache-font-description pango_layout_set_font_description ;
: set-layout-text ( str layout -- )
#! Replace nulls with something else since Pango uses null-terminated
#! strings
swap -1 pango_layout_set_text ;
: layout-extents ( layout -- ink-rect logical-rect )
PangoRectangle <struct>
PangoRectangle <struct>
[ pango_layout_get_extents ] 2keep
[ PangoRectangle>rect ] bi@ ;
: layout-baseline ( layout -- baseline )
pango_layout_get_iter &pango_layout_iter_free
pango_layout_iter_get_baseline
pango>float ;
: set-foreground ( cr font -- )
foreground>> set-source-color ;
: fill-background ( cr font dim -- )
[ background>> set-source-color ]
[ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
: rect-translate-x ( rect x -- rect' )
'[ _ 0 2array v- ] change-loc ;
: first-line ( layout -- line )
layout>> 0 pango_layout_get_line_readonly ;
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
0 0 <int> [ pango_layout_line_index_to_x ] keep
*int pango>float ;
: x>line-offset ( layout x -- n )
#! n is an index into the UTF8 encoding of the text
[
[ first-line ] dip
float>pango 0 <int> 0 <int>
[ pango_layout_line_x_to_index drop ] 2keep
[ *int ] bi@ swap
] [ drop string>> ] 2bi utf8-index> + ;
: selection-start/end ( selection -- start end )
selection>> [ start>> ] [ end>> ] bi ;
: selection-rect ( layout -- rect )
[ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
[ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
: fill-selection-background ( cr layout -- )
dup selection>> [
[ selection>> color>> set-source-color ]
[
[ selection-rect ] [ ink-rect>> loc>> first ] bi
rect-translate-x
fill-rect
] 2bi
] [ 2drop ] if ;
: text-position ( layout -- loc )
[ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
: set-text-position ( cr loc -- )
first2 cairo_move_to ;
: draw-layout ( layout -- image )
dup ink-rect>> dim>> [ >fixnum ] map [
swap {
[ layout>> pango_cairo_update_layout ]
[ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
[ fill-selection-background ]
[ text-position set-text-position ]
[ font>> set-foreground ]
[ layout>> pango_cairo_show_layout ]
} 2cleave
] make-bitmap-image ;
: escape-nulls ( str -- str' )
{ { 0 CHAR: zero-width-no-break-space } } substitute ;
: unpack-selection ( layout string/selection -- layout )
dup selection? [
[ string>> escape-nulls >>string ] [ >>selection ] bi
] [ escape-nulls >>string ] if ; inline
: set-layout-resolution ( layout -- )
pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
: <PangoLayout> ( text font -- layout )
dummy-cairo pango_cairo_create_layout |g_object_unref
[ set-layout-resolution ] keep
[ set-layout-font ] keep
[ set-layout-text ] keep ;
: glyph-height ( font string -- y )
swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
MEMO: missing-font-metrics ( font -- metrics )
#! Pango doesn't provide x-height and cap-height but Core Text does, so we
#! simulate them on Pango.
[
[ metrics new ] dip
[ "x" glyph-height >>x-height ]
[ "Y" glyph-height >>cap-height ] bi
] with-destructors ;
: layout-metrics ( layout -- metrics )
dup font>> missing-font-metrics clone
swap
[ layout>> layout-baseline >>ascent ]
[ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
dup [ height>> ] [ ascent>> ] bi - >>descent ;
: <layout> ( font string -- line )
[
layout new-disposable
swap unpack-selection
swap >>font
dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
dup layout-metrics >>metrics
dup draw-layout >>image
] with-destructors ;
M: layout dispose* layout>> g_object_unref ;
SYMBOL: cached-layouts
: cached-layout ( font string -- layout )
cached-layouts get [ <layout> ] 2cache ;
: cached-line ( font string -- line )
cached-layout layout>> first-line ;
[ <cache-assoc> cached-layouts set-global ] "pango.cairo" add-init-hook

View File

@ -15,6 +15,15 @@ PANGO_STYLE_OBLIQUE
PANGO_STYLE_ITALIC ; PANGO_STYLE_ITALIC ;
TYPEDEF: int PangoWeight TYPEDEF: int PangoWeight
TYPEDEF: void* PangoFont*
TYPEDEF: void* PangoFontFamily*
TYPEDEF: void* PangoFontFace*
TYPEDEF: void* PangoFontMap*
TYPEDEF: void* PangoFontMetrics*
TYPEDEF: void* PangoFontDescription*
TYPEDEF: void* PangoGlyphString*
TYPEDEF: void* PangoLanguage*
CONSTANT: PANGO_WEIGHT_THIN 100 CONSTANT: PANGO_WEIGHT_THIN 100
CONSTANT: PANGO_WEIGHT_ULTRALIGHT 200 CONSTANT: PANGO_WEIGHT_ULTRALIGHT 200
CONSTANT: PANGO_WEIGHT_LIGHT 300 CONSTANT: PANGO_WEIGHT_LIGHT 300

View File

@ -4,12 +4,16 @@
USING: arrays sequences alien alien.c-types alien.destructors USING: arrays sequences alien alien.c-types alien.destructors
alien.syntax math math.functions math.vectors destructors combinators alien.syntax math math.functions math.vectors destructors combinators
colors fonts accessors assocs namespaces kernel pango pango.fonts colors fonts accessors assocs namespaces kernel pango pango.fonts
pango.cairo cairo cairo.ffi glib unicode.data images cache init glib unicode.data images cache init
math.rectangles fry memoize io.encodings.utf8 classes.struct ; math.rectangles fry memoize io.encodings.utf8 classes.struct ;
IN: pango.layouts IN: pango.layouts
LIBRARY: pango LIBRARY: pango
TYPEDEF: void* PangoLayout*
TYPEDEF: void* PangoLayoutIter*
TYPEDEF: void* PangoLayoutLine*
FUNCTION: PangoLayout* FUNCTION: PangoLayout*
pango_layout_new ( PangoContext* context ) ; pango_layout_new ( PangoContext* context ) ;
@ -60,149 +64,3 @@ pango_layout_iter_free ( PangoLayoutIter* iter ) ;
DESTRUCTOR: pango_layout_iter_free DESTRUCTOR: pango_layout_iter_free
TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
SYMBOL: dpi
72 dpi set-global
: set-layout-font ( font layout -- )
swap cache-font-description pango_layout_set_font_description ;
: set-layout-text ( str layout -- )
#! Replace nulls with something else since Pango uses null-terminated
#! strings
swap -1 pango_layout_set_text ;
: set-layout-resolution ( layout -- )
pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
: <PangoLayout> ( text font -- layout )
dummy-cairo pango_cairo_create_layout |g_object_unref
[ set-layout-resolution ] keep
[ set-layout-font ] keep
[ set-layout-text ] keep ;
: layout-extents ( layout -- ink-rect logical-rect )
PangoRectangle <struct>
PangoRectangle <struct>
[ pango_layout_get_extents ] 2keep
[ PangoRectangle>rect ] bi@ ;
: glyph-height ( font string -- y )
swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
MEMO: missing-font-metrics ( font -- metrics )
#! Pango doesn't provide x-height and cap-height but Core Text does, so we
#! simulate them on Pango.
[
[ metrics new ] dip
[ "x" glyph-height >>x-height ]
[ "Y" glyph-height >>cap-height ] bi
] with-destructors ;
: layout-baseline ( layout -- baseline )
pango_layout_get_iter &pango_layout_iter_free
pango_layout_iter_get_baseline
pango>float ;
: set-foreground ( cr font -- )
foreground>> set-source-color ;
: fill-background ( cr font dim -- )
[ background>> set-source-color ]
[ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
: rect-translate-x ( rect x -- rect' )
'[ _ 0 2array v- ] change-loc ;
: first-line ( layout -- line )
layout>> 0 pango_layout_get_line_readonly ;
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
0 0 <int> [ pango_layout_line_index_to_x ] keep
*int pango>float ;
: x>line-offset ( layout x -- n )
#! n is an index into the UTF8 encoding of the text
[
[ first-line ] dip
float>pango 0 <int> 0 <int>
[ pango_layout_line_x_to_index drop ] 2keep
[ *int ] bi@ swap
] [ drop string>> ] 2bi utf8-index> + ;
: selection-start/end ( selection -- start end )
selection>> [ start>> ] [ end>> ] bi ;
: selection-rect ( layout -- rect )
[ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
[ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
: fill-selection-background ( cr layout -- )
dup selection>> [
[ selection>> color>> set-source-color ]
[
[ selection-rect ] [ ink-rect>> loc>> first ] bi
rect-translate-x
fill-rect
] 2bi
] [ 2drop ] if ;
: text-position ( layout -- loc )
[ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
: set-text-position ( cr loc -- )
first2 cairo_move_to ;
: layout-metrics ( layout -- metrics )
dup font>> missing-font-metrics clone
swap
[ layout>> layout-baseline >>ascent ]
[ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
dup [ height>> ] [ ascent>> ] bi - >>descent ;
: draw-layout ( layout -- image )
dup ink-rect>> dim>> [ >fixnum ] map [
swap {
[ layout>> pango_cairo_update_layout ]
[ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
[ fill-selection-background ]
[ text-position set-text-position ]
[ font>> set-foreground ]
[ layout>> pango_cairo_show_layout ]
} 2cleave
] make-bitmap-image ;
: escape-nulls ( str -- str' )
{ { 0 CHAR: zero-width-no-break-space } } substitute ;
: unpack-selection ( layout string/selection -- layout )
dup selection? [
[ string>> escape-nulls >>string ] [ >>selection ] bi
] [ escape-nulls >>string ] if ; inline
: <layout> ( font string -- line )
[
layout new-disposable
swap unpack-selection
swap >>font
dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
dup layout-metrics >>metrics
dup draw-layout >>image
] with-destructors ;
M: layout dispose* layout>> g_object_unref ;
SYMBOL: cached-layouts
: cached-layout ( font string -- layout )
cached-layouts get [ <layout> ] 2cache ;
: cached-line ( font string -- line )
cached-layout layout>> first-line ;
[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook

View File

@ -23,8 +23,9 @@ CONSTANT: PANGO_SCALE 1024
: pango>float ( n -- x ) PANGO_SCALE /f ; inline : pango>float ( n -- x ) PANGO_SCALE /f ; inline
: float>pango ( x -- n ) PANGO_SCALE * >integer ; inline : float>pango ( x -- n ) PANGO_SCALE * >integer ; inline
FUNCTION: PangoContext* TYPEDEF: void* PangoContext*
pango_context_new ( ) ;
FUNCTION: PangoContext* pango_context_new ( ) ;
STRUCT: PangoRectangle STRUCT: PangoRectangle
{ x int } { x int }

View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! mersenne twister based on ! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: kernel math namespaces sequences sequences.private system USING: alien.c-types kernel math namespaces sequences
init accessors math.ranges random math.bitwise combinators sequences.private system init accessors math.ranges random
specialized-arrays fry ; math.bitwise combinators specialized-arrays fry ;
SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: uint
IN: random.mersenne-twister IN: random.mersenne-twister

View File

@ -31,7 +31,7 @@ STRUCT: ud
{ inp_hook void* } { inp_hook void* }
{ inp_curr uchar } { inp_curr uchar }
{ inp_fill uchar } { inp_fill uchar }
{ inp_file FILE* } { inp_file void* }
{ inp_ctr uchar } { inp_ctr uchar }
{ inp_buff uchar* } { inp_buff uchar* }
{ inp_buff_end uchar* } { inp_buff_end uchar* }
@ -68,7 +68,7 @@ STRUCT: ud
{ c3 uchar } { c3 uchar }
{ inp_cache uchar[256] } { inp_cache uchar[256] }
{ inp_sess uchar[64] } { inp_sess uchar[64] }
{ itab_entry ud_itab_entry* } ; { itab_entry void* } ;
FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ;

View File

@ -3,6 +3,7 @@
USING: kernel accessors math math.vectors locals sequences USING: kernel accessors math math.vectors locals sequences
specialized-arrays colors arrays combinators specialized-arrays colors arrays combinators
opengl opengl.gl ui.pens ui.pens.caching ; opengl opengl.gl ui.pens ui.pens.caching ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: float
IN: ui.pens.gradient IN: ui.pens.gradient

View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors help.markup help.syntax kernel opengl USING: accessors alien.c-types colors help.markup help.syntax
opengl.gl sequences math.vectors ui.gadgets ui.pens kernel opengl opengl.gl sequences math.vectors ui.gadgets
specialized-arrays ; ui.pens specialized-arrays ;
SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: float
IN: ui.pens.polygon IN: ui.pens.polygon

View File

@ -1,6 +1,6 @@
USING: accessors assocs classes destructors functors kernel USING: alien.c-types accessors assocs classes destructors
lexer math parser sequences specialized-arrays ui.backend functors kernel lexer math parser sequences specialized-arrays
words ; ui.backend words ;
SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: int
IN: ui.pixel-formats IN: ui.pixel-formats

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Slava Pestov. ! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax classes.struct combinators system USING: alien.c-types alien.syntax classes.struct combinators
vocabs.loader ; system unix.types vocabs.loader ;
IN: unix IN: unix
CONSTANT: MAXPATHLEN 1024 CONSTANT: MAXPATHLEN 1024

View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.c-types alien.syntax unix.statfs.macosx ;
IN: unix.getfsstat.macosx IN: unix.getfsstat.macosx
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
FUNCTION: int getfsstat64 ( statfs* buf, int bufsize, int flags ) ; FUNCTION: int getfsstat64 ( statfs64* buf, int bufsize, int flags ) ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax system sequences vocabs.loader words USING: alien.c-types alien.syntax system sequences vocabs.loader words
accessors ; accessors ;
IN: unix.kqueue IN: unix.kqueue

View File

@ -1,4 +1,4 @@
USING: alien.syntax classes.struct ; USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue IN: unix.kqueue
STRUCT: kevent STRUCT: kevent

View File

@ -1,6 +1,6 @@
USING: kernel alien.c-types alien.data alien.strings sequences USING: kernel alien.c-types alien.data alien.strings sequences
math alien.syntax unix namespaces continuations threads assocs math alien.syntax unix namespaces continuations threads assocs
io.backend.unix io.encodings.utf8 unix.utilities fry ; io.backend.unix io.encodings.utf8 unix.types unix.utilities fry ;
IN: unix.process IN: unix.process
! Low-level Unix process launching utilities. These are used ! Low-level Unix process launching utilities. These are used

View File

@ -1,8 +1,8 @@
USING: alien.c-types arrays accessors combinators classes.struct USING: alien.c-types arrays accessors combinators classes.struct
alien.syntax ; alien.syntax unix.time unix.types ;
IN: unix.stat IN: unix.stat
! Mac OS X ppc ! Mac OS X
! stat64 structure ! stat64 structure
STRUCT: stat STRUCT: stat

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax classes.struct ; USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.macosx IN: unix.statvfs.macosx
STRUCT: statvfs STRUCT: statvfs

View File

@ -1,4 +1,4 @@
USING: kernel system alien.syntax combinators vocabs.loader ; USING: kernel system alien.c-types alien.syntax combinators vocabs.loader ;
IN: unix.types IN: unix.types
TYPEDEF: char int8_t TYPEDEF: char int8_t
@ -37,6 +37,12 @@ TYPEDEF: fsfilcnt_t __fsfilcnt_t
TYPEDEF: __uint64_t rlim_t TYPEDEF: __uint64_t rlim_t
TYPEDEF: uint32_t id_t TYPEDEF: uint32_t id_t
TYPEDEF: void* DIR*
TYPEDEF: void* FILE*
TYPEDEF: void* rlimit*
TYPEDEF: void* rusage*
TYPEDEF: void* sockaddr*
os { os {
{ linux [ "unix.types.linux" require ] } { linux [ "unix.types.linux" require ] }
{ macosx [ "unix.types.macosx" require ] } { macosx [ "unix.types.macosx" require ] }
@ -45,3 +51,4 @@ os {
{ netbsd [ "unix.types.netbsd" require ] } { netbsd [ "unix.types.netbsd" require ] }
{ winnt [ ] } { winnt [ ] }
} case } case

View File

@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types stack-checker macros locals generalizations unix.types
io vocabs classes.struct ; io vocabs classes.struct unix.time ;
IN: unix IN: unix
CONSTANT: PROT_NONE 0 CONSTANT: PROT_NONE 0
@ -35,12 +35,6 @@ CONSTANT: DT_LNK 10
CONSTANT: DT_SOCK 12 CONSTANT: DT_SOCK 12
CONSTANT: DT_WHT 14 CONSTANT: DT_WHT 14
STRUCT: group
{ gr_name char* }
{ gr_passwd char* }
{ gr_gid int }
{ gr_mem char** } ;
LIBRARY: libc LIBRARY: libc
FUNCTION: char* strerror ( int errno ) ; FUNCTION: char* strerror ( int errno ) ;
@ -68,6 +62,26 @@ MACRO:: unix-system-call ( quot -- )
] ]
] ; ] ;
<<
{
{ [ os linux? ] [ "unix.linux" require ] }
{ [ os bsd? ] [ "unix.bsd" require ] }
{ [ os solaris? ] [ "unix.solaris" require ] }
} cond
"debugger" vocab [
"unix.debugger" require
] when
>>
STRUCT: group
{ gr_name char* }
{ gr_passwd char* }
{ gr_gid int }
{ gr_mem char** } ;
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ; FUNCTION: int chdir ( char* path ) ;
@ -86,7 +100,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ;
! FUNCTION: int dup ( int oldd ) ; ! FUNCTION: int dup ( int oldd ) ;
: _exit ( status -- * ) : _exit ( status -- * )
#! We throw to give this a terminating stack effect. #! We throw to give this a terminating stack effect.
"int" f "_exit" { "int" } alien-invoke "Exit failed" throw ; int f "_exit" { int } alien-invoke "Exit failed" throw ;
FUNCTION: void endpwent ( ) ; FUNCTION: void endpwent ( ) ;
FUNCTION: int fchdir ( int fd ) ; FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
@ -207,12 +221,3 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{
{ [ os linux? ] [ "unix.linux" require ] }
{ [ os bsd? ] [ "unix.bsd" require ] }
{ [ os solaris? ] [ "unix.solaris" require ] }
} cond
"debugger" vocab [
"unix.debugger" require
] when

View File

@ -1,9 +1,10 @@
! Copyright (C) 2009 Phil Dawes. ! Copyright (C) 2009 Phil Dawes.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct alien.syntax ; USING: classes.struct alien.c-types alien.syntax ;
IN: vm IN: vm
TYPEDEF: void* cell TYPEDEF: void* cell
TYPEDEF: void* context*
STRUCT: zone STRUCT: zone
{ start cell } { start cell }

View File

@ -1,5 +1,5 @@
USING: alien.syntax kernel math windows.types windows.kernel32 USING: alien.c-types alien.syntax kernel math windows.types
math.bitwise classes.struct ; windows.kernel32 math.bitwise classes.struct ;
IN: windows.advapi32 IN: windows.advapi32
LIBRARY: advapi32 LIBRARY: advapi32
@ -222,15 +222,15 @@ C-ENUM:
SE_WMIGUID_OBJECT SE_WMIGUID_OBJECT
SE_REGISTRY_WOW64_32KEY ; SE_REGISTRY_WOW64_32KEY ;
TYPEDEF: TRUSTEE* PTRUSTEE
STRUCT: TRUSTEE STRUCT: TRUSTEE
{ pMultipleTrustee PTRUSTEE } { pMultipleTrustee TRUSTEE* }
{ MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION } { MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION }
{ TrusteeForm TRUSTEE_FORM } { TrusteeForm TRUSTEE_FORM }
{ TrusteeType TRUSTEE_TYPE } { TrusteeType TRUSTEE_TYPE }
{ ptstrName LPTSTR } ; { ptstrName LPTSTR } ;
TYPEDEF: TRUSTEE* PTRUSTEE
STRUCT: EXPLICIT_ACCESS STRUCT: EXPLICIT_ACCESS
{ grfAccessPermissions DWORD } { grfAccessPermissions DWORD }
{ grfAccessMode ACCESS_MODE } { grfAccessMode ACCESS_MODE }

6
basis/windows/com/com.factor Normal file → Executable file
View File

@ -10,6 +10,8 @@ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
ULONG AddRef ( ) ULONG AddRef ( )
ULONG Release ( ) ; ULONG Release ( ) ;
TYPEDEF: void* IAdviseSink*
COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046} COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
@ -27,6 +29,10 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
HRESULT DragLeave ( ) HRESULT DragLeave ( )
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: com-query-interface ( interface iid -- interface' ) : com-query-interface ( interface iid -- interface' )
[ [
"void*" malloc-object &free "void*" malloc-object &free

View File

@ -1,8 +1,8 @@
USING: alien alien.c-types alien.accessors effects kernel USING: alien alien.c-types alien.accessors alien.parser
windows.ole32 parser lexer splitting grouping sequences effects kernel windows.ole32 parser lexer splitting grouping
namespaces assocs quotations generalizations accessors words sequences namespaces assocs quotations generalizations
macros alien.syntax fry arrays layouts math classes.struct accessors words macros alien.syntax fry arrays layouts math
windows.kernel32 ; classes.struct windows.kernel32 ;
IN: windows.com.syntax IN: windows.com.syntax
<PRIVATE <PRIVATE
@ -14,7 +14,7 @@ MACRO: com-invoke ( n return parameters -- )
"stdcall" alien-indirect "stdcall" alien-indirect
] ; ] ;
TUPLE: com-interface-definition name parent iid functions ; TUPLE: com-interface-definition word parent iid functions ;
C: <com-interface-definition> com-interface-definition C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ; TUPLE: com-function-definition name return parameters ;
@ -25,22 +25,25 @@ SYMBOL: +com-interface-definitions+
[ H{ } +com-interface-definitions+ set-global ] [ H{ } +com-interface-definitions+ set-global ]
unless unless
ERROR: no-com-interface interface ;
: find-com-interface-definition ( name -- definition ) : find-com-interface-definition ( name -- definition )
dup "f" = [ drop f ] [ [
dup +com-interface-definitions+ get-global at* dup +com-interface-definitions+ get-global at*
[ nip ] [ nip ] [ drop no-com-interface ] if
[ " COM interface hasn't been defined" prepend throw ] ] [ f ] if* ;
if
] if ;
: save-com-interface-definition ( definition -- ) : save-com-interface-definition ( definition -- )
dup name>> +com-interface-definitions+ get-global set-at ; dup word>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition ) : (parse-com-function) ( tokens -- definition )
[ second ] [ second ]
[ first ] [ first ]
[ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ] [
tri 3 tail [ CHAR: , swap remove ] map
2 group [ first2 normalize-c-arg 2array ] map
{ void* "this" } prefix
] tri
<com-function-definition> ; <com-function-definition> ;
: parse-com-functions ( -- functions ) : parse-com-functions ( -- functions )
@ -48,10 +51,11 @@ unless
[ (parse-com-function) ] map ; [ (parse-com-function) ] map ;
: (iid-word) ( definition -- word ) : (iid-word) ( definition -- word )
name>> "-iid" append create-in ; word>> name>> "-iid" append create-in ;
: (function-word) ( function interface -- word ) : (function-word) ( function interface -- word )
name>> "::" rot name>> 3append create-in ; swap [ word>> name>> "::" ] [ name>> ] bi*
3append create-in ;
: family-tree ( definition -- definitions ) : family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if* dup parent>> [ family-tree ] [ { } ] if*
@ -79,7 +83,7 @@ unless
: define-words-for-com-interface ( definition -- ) : define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ] [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
[ name>> "com-interface" swap typedef ] [ word>> void* swap typedef ]
[ [
dup family-tree-functions dup family-tree-functions
[ (define-word-for-function) ] with each-index [ (define-word-for-function) ] with each-index
@ -89,8 +93,8 @@ unless
PRIVATE> PRIVATE>
SYNTAX: COM-INTERFACE: SYNTAX: COM-INTERFACE:
scan CREATE-C-TYPE
scan find-com-interface-definition scan-object find-com-interface-definition
scan string>guid scan string>guid
parse-com-functions parse-com-functions
<com-interface-definition> <com-interface-definition>

View File

@ -1,6 +1,6 @@
USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
alien alien.c-types alien.syntax kernel system namespaces math alien alien.c-types alien.syntax kernel system namespaces math
classes.struct ; classes.struct windows.types ;
IN: windows.dinput IN: windows.dinput
LIBRARY: dinput LIBRARY: dinput

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.destructors kernel windows.types USING: alien alien.c-types alien.syntax alien.destructors
math.bitwise ; kernel windows.types math.bitwise ;
IN: windows.gdi32 IN: windows.gdi32
CONSTANT: BI_RGB 0 CONSTANT: BI_RGB 0

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel windows.types multiline USING: alien alien.c-types alien.syntax kernel windows.types
classes.struct ; multiline classes.struct ;
IN: windows.kernel32 IN: windows.kernel32
CONSTANT: MAX_PATH 260 CONSTANT: MAX_PATH 260
@ -543,7 +543,7 @@ STRUCT: DCB
TYPEDEF: DCB* PDCB TYPEDEF: DCB* PDCB
TYPEDEF: DCB* LPDCB TYPEDEF: DCB* LPDCB
STRUCT: COMM_CONFIG STRUCT: COMMCONFIG
{ dwSize DWORD } { dwSize DWORD }
{ wVersion WORD } { wVersion WORD }
{ wReserved WORD } { wReserved WORD }

View File

@ -111,10 +111,6 @@ CONSTANT: COINIT_SPEED_OVER_MEMORY 8
FUNCTION: HRESULT OleInitialize ( void* reserved ) ; FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ; FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? ) : succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ; 0 HEX: 7FFFFFFF between? ;

4
basis/windows/shell32/shell32.factor Normal file → Executable file
View File

@ -3,8 +3,8 @@
USING: alien alien.c-types alien.strings alien.syntax USING: alien alien.c-types alien.strings alien.syntax
classes.struct combinators io.encodings.utf16n io.files classes.struct combinators io.encodings.utf16n io.files
io.pathnames kernel windows.errors windows.com io.pathnames kernel windows.errors windows.com
windows.com.syntax windows.user32 windows.ole32 windows windows.com.syntax windows.types windows.user32
specialized-arrays ; windows.ole32 windows specialized-arrays ;
SPECIALIZED-ARRAY: ushort SPECIALIZED-ARRAY: ushort
IN: windows.shell32 IN: windows.shell32

View File

@ -61,6 +61,7 @@ TYPEDEF: ulong ULONG_PTR
TYPEDEF: int INT32 TYPEDEF: int INT32
TYPEDEF: uint UINT32 TYPEDEF: uint UINT32
TYPEDEF: uint DWORD32 TYPEDEF: uint DWORD32
TYPEDEF: long LONG32
TYPEDEF: ulong ULONG32 TYPEDEF: ulong ULONG32
TYPEDEF: ulonglong ULONG64 TYPEDEF: ulonglong ULONG64
TYPEDEF: long* POINTER_32 TYPEDEF: long* POINTER_32
@ -75,6 +76,8 @@ TYPEDEF: longlong LARGE_INTEGER
TYPEDEF: ulonglong ULARGE_INTEGER TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
TYPEDEF: size_t SIZE_T
TYPEDEF: ptrdiff_t SSIZE_T
TYPEDEF: wchar_t* LPCSTR TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR TYPEDEF: wchar_t* LPWSTR
@ -201,15 +204,6 @@ TYPEDEF: LONG_PTR SSIZE_T
TYPEDEF: LONGLONG USN TYPEDEF: LONGLONG USN
TYPEDEF: UINT_PTR WPARAM TYPEDEF: UINT_PTR WPARAM
TYPEDEF: RECT* LPRECT
TYPEDEF: void* PWNDCLASS
TYPEDEF: void* PWNDCLASSEX
TYPEDEF: void* LPWNDCLASS
TYPEDEF: void* LPWNDCLASSEX
TYPEDEF: void* MSGBOXPARAMSA
TYPEDEF: void* MSGBOXPARAMSW
TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
TYPEDEF: size_t socklen_t TYPEDEF: size_t socklen_t
TYPEDEF: void* WNDPROC TYPEDEF: void* WNDPROC
@ -343,6 +337,14 @@ TYPEDEF: PFD* LPPFD
TYPEDEF: HANDLE HGLRC TYPEDEF: HANDLE HGLRC
TYPEDEF: HANDLE HRGN TYPEDEF: HANDLE HRGN
TYPEDEF: void* PWNDCLASS
TYPEDEF: void* PWNDCLASSEX
TYPEDEF: void* LPWNDCLASS
TYPEDEF: void* LPWNDCLASSEX
TYPEDEF: void* MSGBOXPARAMSA
TYPEDEF: void* MSGBOXPARAMSW
TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
STRUCT: LVITEM STRUCT: LVITEM
{ mask uint } { mask uint }
{ iItem int } { iItem int }

View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math USING: alien alien.c-types alien.syntax parser namespaces
windows.types generalizations math.bitwise classes.struct kernel math windows.types generalizations math.bitwise
literals ; classes.struct literals windows.kernel32 ;
IN: windows.user32 IN: windows.user32
! HKL for ActivateKeyboardLayout ! HKL for ActivateKeyboardLayout

View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.destructors classes.struct ; USING: alien.c-types alien.syntax alien.destructors classes.struct
windows.types ;
IN: windows.usp10 IN: windows.usp10
LIBRARY: usp10 LIBRARY: usp10
@ -56,6 +57,9 @@ SCRIPT_JUSTIFFY_RESERVED4 ;
STRUCT: SCRIPT_VISATTR STRUCT: SCRIPT_VISATTR
{ flags WORD } ; { flags WORD } ;
TYPEDEF: void* SCRIPT_CACHE*
TYPEDEF: void* ABC*
FUNCTION: HRESULT ScriptShape ( FUNCTION: HRESULT ScriptShape (
HDC hdc, HDC hdc,
SCRIPT_CACHE* psc, SCRIPT_CACHE* psc,

View File

@ -105,6 +105,8 @@ CONSTANT: SD_BOTH 2
CONSTANT: SOL_SOCKET HEX: ffff CONSTANT: SOL_SOCKET HEX: ffff
TYPEDEF: void* sockaddr*
STRUCT: sockaddr-in STRUCT: sockaddr-in
{ family short } { family short }
{ port ushort } { port ushort }
@ -139,13 +141,15 @@ STRUCT: timeval
{ sec long } { sec long }
{ usec long } ; { usec long } ;
TYPEDEF: void* fd_set*
LIBRARY: winsock LIBRARY: winsock
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ; FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ; FUNCTION: ushort htons ( ushort n ) ;
FUNCTION: ushort ntohs ( ushort n ) ; FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ; FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ;
FUNCTION: int listen ( void* socket, int backlog ) ; FUNCTION: int listen ( void* socket, int backlog ) ;
FUNCTION: char* inet_ntoa ( int in-addr ) ; FUNCTION: char* inet_ntoa ( int in-addr ) ;
FUNCTION: int getaddrinfo ( char* nodename, FUNCTION: int getaddrinfo ( char* nodename,
@ -158,15 +162,15 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
FUNCTION: hostent* gethostbyname ( char* name ) ; FUNCTION: hostent* gethostbyname ( char* name ) ;
FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ; FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ;
FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ; FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
FUNCTION: int closesocket ( SOCKET s ) ; FUNCTION: int closesocket ( SOCKET s ) ;
FUNCTION: int shutdown ( SOCKET s, int how ) ; FUNCTION: int shutdown ( SOCKET s, int how ) ;
FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ; FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ; FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
TYPEDEF: uint SERVICETYPE TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED TYPEDEF: OVERLAPPED WSAOVERLAPPED

View File

@ -3,7 +3,7 @@
! Based on X.h ! Based on X.h
USING: alien alien.syntax math x11.xlib ; USING: alien alien.c-types alien.syntax math x11.xlib ;
IN: x11.constants IN: x11.constants
TYPEDEF: ulong Mask TYPEDEF: ulong Mask

View File

@ -410,10 +410,6 @@ STRUCT: XCharStruct
{ descent short } { descent short }
{ attributes ushort } ; { attributes ushort } ;
X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
STRUCT: XFontStruct STRUCT: XFontStruct
{ ext_data XExtData* } { ext_data XExtData* }
{ fid Font } { fid Font }
@ -432,6 +428,10 @@ STRUCT: XFontStruct
{ ascent int } { ascent int }
{ descent int } ; { descent int } ;
X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
! 8.6 - Drawing Text ! 8.6 - Drawing Text

View File

@ -1,4 +1,5 @@
USING: sequences kernel math specialized-arrays fry ; USING: alien.c-types sequences kernel math specialized-arrays
fry ;
SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: int
IN: benchmark.dawes IN: benchmark.dawes

View File

@ -1,4 +1,4 @@
USING: make math sequences splitting grouping USING: alien.c-types make math sequences splitting grouping
kernel columns specialized-arrays bit-arrays ; kernel columns specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double
IN: benchmark.dispatch2 IN: benchmark.dispatch2

View File

@ -1,4 +1,4 @@
USING: sequences math mirrors splitting grouping USING: alien.c-types sequences math mirrors splitting grouping
kernel make assocs alien.syntax columns kernel make assocs alien.syntax columns
specialized-arrays bit-arrays ; specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double

View File

@ -1,7 +1,7 @@
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2 ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
USING: math kernel io io.files locals multiline assocs sequences USING: alien.c-types math kernel io io.files locals multiline
sequences.private benchmark.reverse-complement hints assocs sequences sequences.private benchmark.reverse-complement
io.encodings.ascii byte-arrays specialized-arrays ; hints io.encodings.ascii byte-arrays specialized-arrays ;
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double
IN: benchmark.fasta IN: benchmark.fasta

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry kernel locals math math.constants USING: accessors alien.c-types fry kernel locals math
math.functions math.vectors math.vectors.simd prettyprint math.constants math.functions math.vectors math.vectors.simd
combinators.smart sequences hints classes.struct prettyprint combinators.smart sequences hints classes.struct
specialized-arrays ; specialized-arrays ;
SIMD: double SIMD: double
IN: benchmark.nbody-simd IN: benchmark.nbody-simd

View File

@ -1,8 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors specialized-arrays fry kernel locals math USING: accessors specialized-arrays fry kernel
math.constants math.functions math.vectors prettyprint locals math math.constants math.functions math.vectors
combinators.smart sequences hints arrays ; prettyprint combinators.smart sequences hints arrays ;
FROM: alien.c-types => double ;
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double
IN: benchmark.nbody IN: benchmark.nbody

View File

@ -1,10 +1,10 @@
! Factor port of the raytracer benchmark from ! Factor port of the raytracer benchmark from
! http://www.ffconsultancy.com/free/ray_tracer/languages.html ! http://www.ffconsultancy.com/free/ray_tracer/languages.html
USING: arrays accessors specialized-arrays io
USING: arrays accessors specialized-arrays io io.files io.files io.files.temp io.encodings.binary kernel math
io.files.temp io.encodings.binary kernel math math.constants math.constants math.functions math.vectors math.parser make
math.functions math.vectors math.parser make sequences sequences sequences.private words hints ;
sequences.private words hints ; FROM: alien.c-types => double ;
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double
IN: benchmark.raytracer IN: benchmark.raytracer

View File

@ -1,7 +1,8 @@
! Factor port of ! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: specialized-arrays kernel math math.functions USING: alien.c-types specialized-arrays kernel math
math.vectors sequences prettyprint words hints locals ; math.functions math.vectors sequences prettyprint words hints
locals ;
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm IN: benchmark.spectral-norm

View File

@ -3,6 +3,7 @@
USING: accessors classes.struct combinators.smart fry kernel USING: accessors classes.struct combinators.smart fry kernel
math math.functions math.order math.parser sequences math math.functions math.order math.parser sequences
specialized-arrays io ; specialized-arrays io ;
FROM: alien.c-types => float ;
IN: benchmark.struct-arrays IN: benchmark.struct-arrays
STRUCT: point { x float } { y float } { z float } ; STRUCT: point { x float } { y float } { z float } ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel system combinators USING: alien alien.c-types alien.syntax kernel system combinators
alien.libraries classes.struct ; alien.libraries classes.struct ;
IN: freetype IN: freetype
@ -38,8 +38,8 @@ TYPEDEF: long FT_F26Dot6
FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ; FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ;
! circular reference between glyph and face ! circular reference between glyph and face
TYPEDEF: void face TYPEDEF: void* face*
TYPEDEF: void glyph TYPEDEF: void* glyph*
STRUCT: glyph STRUCT: glyph
{ library void* } { library void* }
@ -166,6 +166,8 @@ STRUCT: FT_Bitmap
{ palette_mode char } { palette_mode char }
{ palette void* } ; { palette void* } ;
TYPEDEF: void* FT_Face*
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ; FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ; FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;

View File

@ -1,9 +1,11 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: alien alien.syntax byte-arrays classes gpu.buffers USING: alien alien.c-types alien.syntax byte-arrays classes
gpu.framebuffers gpu.shaders gpu.textures help.markup gpu.buffers gpu.framebuffers gpu.shaders gpu.textures help.markup
help.syntax images kernel math sequences help.syntax images kernel math sequences
specialized-arrays strings ; specialized-arrays strings ;
SPECIALIZED-ARRAY: float QUALIFIED-WITH: alien.c-types c
QUALIFIED-WITH: math m
SPECIALIZED-ARRAY: c:float
SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: ulong SPECIALIZED-ARRAY: ulong
@ -49,7 +51,7 @@ $nl
"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:" "Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
{ $list { $list
{ { $link int-uniform } "s and " { $link uint-uniform } "s take their values from Factor " { $link integer } "s." } { { $link int-uniform } "s and " { $link uint-uniform } "s take their values from Factor " { $link integer } "s." }
{ { $link float-uniform } "s take their values from Factor " { $link float } "s." } { { $link float-uniform } "s take their values from Factor " { $link m:float } "s." }
{ { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." } { { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
{ { $link texture-uniform } "s take their values from " { $link texture } " objects." } { { $link texture-uniform } "s take their values from " { $link texture } " objects." }
{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type." { "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type."

View File

@ -1,6 +1,7 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
specialized-arrays ; specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: float
IN: gpu.util IN: gpu.util

Some files were not shown because too many files have changed in this diff Show More