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

Merge branch 'master' into more_aggressive_coalescing

db4
Slava Pestov 2009-09-27 19:29:50 -05:00
parent 1e841e5086 d3aa0a538b
commit f757b454cc
115 changed files with 754 additions and 574 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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
sequences system libc alien.strings io.encodings.utf8
math.constants ;
USING: alien alien.syntax alien.c-types alien.parser
kernel tools.test sequences system libc alien.strings
io.encodings.utf8 math.constants classes.struct ;
IN: alien.c-types.tests
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 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test
C-UNION: foo
"int"
"int" ;
UNION-STRUCT: foo
{ a int }
{ b int } ;
[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test
[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test
[ f ] [ "char*" parse-c-type 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
[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test
[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test
[ t ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ void* c-type "MyInt*" parse-c-type c-type eq? ] unit-test
TYPEDEF: char MyChar
[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test
[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test
[ 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*" parse-c-type 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
[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test
[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test
[ t ] [ char* c-type MyString c-type eq? ] unit-test
[ t ] [ void* c-type "MyString*" parse-c-type c-type eq? ] unit-test
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
[ 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*>

2
basis/alien/c-types/c-types.factor
View File

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

27
basis/alien/parser/parser-tests.factor Normal file
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

2
basis/cocoa/runtime/runtime.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov
! 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
TYPEDEF: void* SEL

2
basis/cocoa/types/types.factor
View File

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

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

@ -657,7 +657,8 @@ literal: label
def: dst/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
temp: temp1 temp2
@ -667,11 +668,11 @@ literal: data-values tagged-values uninitialized-locs ;
! virtual registers
INSN: _spill
use: src
literal: rep n ;
literal: rep dst ;
INSN: _reload
def: dst
literal: rep n ;
literal: rep src ;
INSN: _spill-area-size
literal: n ;

10
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -34,11 +34,15 @@ IN: compiler.cfg.linear-scan.allocation
[ drop assign-blocked-register ]
} 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 -- )
[ active-intervals get values ] dip
[ '[ [ _ spill ] each ] each ]
[ drop [ delete-all ] each ]
2bi ;
'[ [ _ spill-at-sync-point ] filter-here ] each ;
:: handle-progress ( n sync? -- )
n {

7
basis/compiler/cfg/linear-scan/allocation/state/state.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
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 ;
IN: compiler.cfg.linear-scan.allocation.state
@ -118,7 +118,8 @@ SYMBOL: unhandled-intervals
: next-spill-slot ( rep -- n )
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
SYMBOL: unhandled-sync-points
@ -126,7 +127,7 @@ SYMBOL: unhandled-sync-points
! Mapping from vregs to 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 ;
: init-allocator ( registers -- )

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

@ -33,7 +33,7 @@ ERROR: bad-vreg vreg ;
: (vreg>reg) ( vreg pending -- reg )
! If a live vreg is not in the pending set, then it must
! 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 )
pending-interval-assoc get (vreg>reg) ;

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

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

12
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
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 } } }
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{ _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{ _reload { dst 0 } { rep int-rep } { n 8 } }
T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
}
} member?
] unit-test

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

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

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

@ -240,7 +240,7 @@ CODEGEN: _reload %reload
GENERIC# save-gc-root 1 ( 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 ;
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 -- )
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 ;

24
basis/compiler/tests/codegen.factor
View File

@ -1,9 +1,10 @@
USING: generalizations accessors arrays compiler kernel kernel.private
math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
math.order math.libm math.parser alien.c-types ;
USING: generalizations accessors arrays compiler kernel
kernel.private math hashtables.private math.private namespaces
sequences tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators vectors grouping
make alien.c-types combinators.short-circuit math.order
math.libm math.parser math.functions ;
FROM: math => float ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
@ -432,6 +433,7 @@ cell 4 = [
] compile-call
] unit-test
! Bug in CSSA construction
TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
[ 2 ] [
@ -449,3 +451,13 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
] 2curry each-integer
] compile-call
] 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

42
basis/compression/inflate/inflate.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays
byte-vectors combinators fry grouping hashtables
compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences
sorting ;
USING: accessors arrays assocs byte-vectors combinators
compression.huffman fry hashtables io.binary kernel locals math
math.bitwise math.order math.ranges sequences sorting ;
QUALIFIED-WITH: bitstreams bs
IN: compression.inflate
QUALIFIED-WITH: bitstreams bs
@ -178,41 +177,8 @@ CONSTANT: dist-table
]
[ 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>
: 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 )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi

3
basis/compression/zlib/ffi/ffi.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! 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
<< "zlib" {

3
basis/core-foundation/arrays/arrays.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! 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
TYPEDEF: void* CFArrayRef

4
basis/core-foundation/attributed-strings/attributed-strings.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! 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 ;
IN: core-foundation.attributed-strings

4
basis/core-foundation/bundles/bundles.factor
View File

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

3
basis/core-foundation/data/data.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Joe Groff.
! 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
TYPEDEF: void* CFDataRef

2
basis/core-foundation/dictionaries/dictionaries.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! 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 ;
IN: core-foundation.dictionaries

3
basis/core-foundation/file-descriptors/file-descriptors.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! 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
TYPEDEF: void* CFFileDescriptorRef
TYPEDEF: int CFFileDescriptorNativeDescriptor
TYPEDEF: void* CFFileDescriptorCallBack
TYPEDEF: void* CFFileDescriptorContext*
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
CFAllocatorRef allocator,

4
basis/core-foundation/fsevents/fsevents.factor
View File

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

6
basis/core-foundation/run-loop/run-loop.factor
View File

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

4
basis/core-foundation/strings/strings.factor
View File

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

2
basis/core-foundation/time/time.factor
View File

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

4
basis/core-foundation/timers/timers.factor
View File

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

4
basis/core-foundation/urls/urls.factor
View File

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

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.destructors alien.syntax accessors
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
! CGImageAlphaInfo

6
basis/core-graphics/types/types.factor
View File

@ -1,10 +1,12 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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
<< cell 4 = "float" "double" ? "CGFloat" typedef >>
SYMBOL: CGFloat
<< cell 4 = float double ? \ CGFloat typedef >>
: <CGFloat> ( x -- alien )
cell 4 = [ <float> ] [ <double> ] if ; inline

7
basis/core-text/fonts/fonts.factor
View File

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

4
basis/cpu/architecture/architecture.factor
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-unordered-branch cpu ( label cc src1 src2 -- )
HOOK: %spill cpu ( src rep n -- )
HOOK: %reload cpu ( dst rep n -- )
HOOK: %spill cpu ( src rep dst -- )
HOOK: %reload cpu ( dst rep src -- )
HOOK: %loop-entry cpu ( -- )

8
basis/cpu/ppc/ppc.factor
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 ] }
} case ;
M: ppc %spill ( src rep n -- )
swap [ spill@ ] dip store-to-frame ;
M: ppc %spill ( src rep dst -- )
swap [ n>> spill@ ] dip store-to-frame ;
M: ppc %reload ( dst rep n -- )
swap [ spill@ ] dip load-from-frame ;
M: ppc %reload ( dst rep src -- )
swap [ n>> spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;

28
basis/cpu/x86/32/32.factor
View File

@ -282,6 +282,34 @@ M: x86.32 %callback-value ( ctype -- )
! Unbox EAX
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 -- )
#! a) If we just called an stdcall function in Windows, it

9
basis/cpu/x86/64/64.factor
View File

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

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

@ -142,7 +142,10 @@ M: double-2-rep copy-register* drop MOVUPD ;
M: vector-rep copy-register* drop MOVDQU ;
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 -- )
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 -- )
\ UCOMISD (%compare-float-branch) ;
M:: x86 %spill ( src rep n -- )
n spill@ src rep %copy ;
M:: x86 %reload ( dst rep n -- )
dst n spill@ rep %copy ;
M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
@ -1006,6 +1006,7 @@ enable-fixnum-log2
enable-float-intrinsics
enable-fsqrt
enable-float-min/max
enable-float-functions
install-sse2-check
] when ;

5
basis/db/postgresql/ffi/ffi.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! 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
<< "postgresql" {
@ -68,8 +69,8 @@ TYPEDEF: void* PQconninfoOption*
TYPEDEF: void* PGnotify*
TYPEDEF: void* PQArgBlock*
TYPEDEF: void* PQprintOpt*
TYPEDEF: void* FILE*
TYPEDEF: void* SSL*
TYPEDEF: void* FILE*
LIBRARY: postgresql

2
basis/environment/unix/macosx/macosx.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! 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
FUNCTION: void* _NSGetEnviron ( ) ;

10
basis/glib/glib.factor
View File

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

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

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! 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
io.binary io.encodings.8-bit io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise

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

@ -1,9 +1,9 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel
sequences io.streams.limited fry combinators arrays math checksums
checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
USING: accessors arrays checksums checksums.crc32 combinators
compression.inflate fry grouping images images.loader io
io.binary io.encodings.ascii io.encodings.string kernel locals
math math.bitwise math.ranges sequences sorting ;
IN: images.png
SINGLETON: png-image
@ -78,27 +78,52 @@ ERROR: bad-checksum ;
ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ;
ERROR: unknown-filter-method image ;
: inflate-data ( loading-png -- bytes )
find-compressed-bytes zlib-inflate ;
: png-group-width ( loading-png -- n )
dup color-type>> {
{ 2 [ [ bit-depth>> 8 / 3 * ] [ width>> ] bi * 1 + ] }
{ 6 [ [ bit-depth>> 8 / 4 * ] [ width>> ] bi * 1 + ] }
[ unknown-color-type ]
} case ;
: scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
: filter-png ( groups loading-png -- byte-array )
filter-method>> {
{ filter-none [ reverse-png-filter ] }
[ unknown-filter-method ]
} case ;
: png-bytes-per-pixel ( loading-png -- n )
dup color-type>> {
{ 2 [ scale-bit-depth 3 * ] }
{ 6 [ scale-bit-depth 4 * ] }
[ 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 )
[ [ inflate-data ] [ png-group-width ] bi group ]
[ filter-png ] bi ;
[ inflate-data ] [ png-group-width ] bi group reverse-png-filter ;
: decode-greyscale ( loading-png -- loading-png )
unimplemented-color-type ;

1
basis/images/tiff/tiff.factor
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
strings math.vectors specialized-arrays locals
images.loader ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: images.tiff

2
basis/io/pipes/unix/unix.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! 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 ;
QUALIFIED: io.pipes
SPECIALIZED-ARRAY: int

7
basis/iokit/hid/hid.factor
View File

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

15
basis/math/blas/matrices/matrices.factor
View File

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

10
basis/math/blas/vectors/vectors.factor
View File

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

8
basis/math/floats/env/x86/x86.factor vendored
View File

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

8
basis/math/vectors/simd/functor/functor.factor
View File

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

1
basis/math/vectors/simd/simd-docs.factor
View File

@ -68,6 +68,7 @@ ARTICLE: "math.vectors.simd.words" "SIMD vector words"
{ "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-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 "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
}

22
basis/math/vectors/vectors.factor
View File

@ -55,11 +55,33 @@ PRIVATE>
[ drop call ]
} 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>
: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ;
: vbitor ( u v -- w ) over '[ _ [ bitor ] 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 ;
: vrshift ( u n -- w ) neg '[ _ shift ] map ;

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

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

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

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

6
basis/openssl/libcrypto/libcrypto.factor
View File

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

28
basis/openssl/libssl/libssl.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007 Elie CHAFTARI
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators kernel system namespaces
assocs parser lexer sequences words quotations math.bitwise
alien.libraries ;
USING: alien alien.c-types alien.syntax combinators kernel
system namespaces assocs parser lexer sequences words
quotations math.bitwise alien.libraries ;
IN: openssl.libssl
@ -95,6 +95,17 @@ TYPEDEF: void* SSL*
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
! ===============================================
@ -258,17 +269,6 @@ CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200
: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
{ 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
! ===============================================

158
basis/pango/cairo/cairo.factor
View File

@ -3,8 +3,12 @@
! See http://factorcode.org/license.txt for BSD license.
!
! pangocairo bindings, from pango/pangocairo.h
USING: alien alien.syntax combinators system cairo.ffi
alien.libraries ;
USING: arrays sequences alien alien.c-types alien.destructors
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
<< {
@ -15,6 +19,9 @@ IN: pango.cairo
LIBRARY: pangocairo
TYPEDEF: void* PangoCairoFontMap*
TYPEDEF: void* PangoCairoFont*
FUNCTION: PangoFontMap*
pango_cairo_font_map_new ( ) ;
@ -87,3 +94,150 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
FUNCTION: void
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

9
basis/pango/fonts/fonts.factor
View File

@ -15,6 +15,15 @@ PANGO_STYLE_OBLIQUE
PANGO_STYLE_ITALIC ;
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_ULTRALIGHT 200
CONSTANT: PANGO_WEIGHT_LIGHT 300

152
basis/pango/layouts/layouts.factor
View File

@ -4,12 +4,16 @@
USING: arrays sequences alien alien.c-types alien.destructors
alien.syntax math math.functions math.vectors destructors combinators
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 ;
IN: pango.layouts
LIBRARY: pango
TYPEDEF: void* PangoLayout*
TYPEDEF: void* PangoLayoutIter*
TYPEDEF: void* PangoLayoutLine*
FUNCTION: PangoLayout*
pango_layout_new ( PangoContext* context ) ;
@ -60,149 +64,3 @@ pango_layout_iter_free ( PangoLayoutIter* iter ) ;
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

5
basis/pango/pango.factor
View File

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

6
basis/random/mersenne-twister/mersenne-twister.factor
View File

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

4
basis/tools/disassembler/udis/udis.factor
View File

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

1
basis/ui/pens/gradient/gradient.factor
View File

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

6
basis/ui/pens/polygon/polygon.factor
View File

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

6
basis/ui/pixel-formats/pixel-formats.factor
View File

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

4
basis/unix/bsd/bsd.factor
View File

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

4
basis/unix/getfsstat/macosx/macosx.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! 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
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
FUNCTION: int getfsstat64 ( statfs* buf, int bufsize, int flags ) ;
FUNCTION: int getfsstat64 ( statfs64* buf, int bufsize, int flags ) ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! 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 ;
IN: unix.kqueue

2
basis/unix/kqueue/macosx/macosx.factor
View File

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

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

@ -1,6 +1,6 @@
USING: kernel alien.c-types alien.data alien.strings sequences
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
! Low-level Unix process launching utilities. These are used

4
basis/unix/stat/macosx/macosx.factor
View File

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

2
basis/unix/statvfs/macosx/macosx.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! 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
STRUCT: statvfs

9
basis/unix/types/types.factor
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
TYPEDEF: char int8_t
@ -37,6 +37,12 @@ TYPEDEF: fsfilcnt_t __fsfilcnt_t
TYPEDEF: __uint64_t rlim_t
TYPEDEF: uint32_t id_t
TYPEDEF: void* DIR*
TYPEDEF: void* FILE*
TYPEDEF: void* rlimit*
TYPEDEF: void* rusage*
TYPEDEF: void* sockaddr*
os {
{ linux [ "unix.types.linux" require ] }
{ macosx [ "unix.types.macosx" require ] }
@ -45,3 +51,4 @@ os {
{ netbsd [ "unix.types.netbsd" require ] }
{ winnt [ ] }
} case

39
basis/unix/unix.factor
View File

@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
io vocabs classes.struct ;
io vocabs classes.struct unix.time ;
IN: unix
CONSTANT: PROT_NONE 0
@ -35,12 +35,6 @@ CONSTANT: DT_LNK 10
CONSTANT: DT_SOCK 12
CONSTANT: DT_WHT 14
STRUCT: group
{ gr_name char* }
{ gr_passwd char* }
{ gr_gid int }
{ gr_mem char** } ;
LIBRARY: libc
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 bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ;
@ -86,7 +100,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ;
! FUNCTION: int dup ( int oldd ) ;
: _exit ( status -- * )
#! 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: int fchdir ( int fd ) ;
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 ) ;
{
{ [ os linux? ] [ "unix.linux" require ] }
{ [ os bsd? ] [ "unix.bsd" require ] }
{ [ os solaris? ] [ "unix.solaris" require ] }
} cond
"debugger" vocab [
"unix.debugger" require
] when

3
basis/vm/vm.factor
View File

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

10
basis/windows/advapi32/advapi32.factor
View File

@ -1,5 +1,5 @@
USING: alien.syntax kernel math windows.types windows.kernel32
math.bitwise classes.struct ;
USING: alien.c-types alien.syntax kernel math windows.types
windows.kernel32 math.bitwise classes.struct ;
IN: windows.advapi32
LIBRARY: advapi32
@ -222,15 +222,15 @@ C-ENUM:
SE_WMIGUID_OBJECT
SE_REGISTRY_WOW64_32KEY ;
TYPEDEF: TRUSTEE* PTRUSTEE
STRUCT: TRUSTEE
{ pMultipleTrustee PTRUSTEE }
{ pMultipleTrustee TRUSTEE* }
{ MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION }
{ TrusteeForm TRUSTEE_FORM }
{ TrusteeType TRUSTEE_TYPE }
{ ptstrName LPTSTR } ;
TYPEDEF: TRUSTEE* PTRUSTEE
STRUCT: EXPLICIT_ACCESS
{ grfAccessPermissions DWORD }
{ 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 Release ( ) ;
TYPEDEF: void* IAdviseSink*
COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
HRESULT GetData ( 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 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' )
[
"void*" malloc-object &free

42
basis/windows/com/syntax/syntax.factor
View File

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

2
basis/windows/dinput/dinput.factor
View File

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

4
basis/windows/gdi32/gdi32.factor
View File

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

6
basis/windows/kernel32/kernel32.factor
View File

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

4
basis/windows/ole32/ole32.factor
View File

@ -111,10 +111,6 @@ CONSTANT: COINIT_SPEED_OVER_MEMORY 8
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
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 -- ? )
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
classes.struct combinators io.encodings.utf16n io.files
io.pathnames kernel windows.errors windows.com
windows.com.syntax windows.user32 windows.ole32 windows
specialized-arrays ;
windows.com.syntax windows.types windows.user32
windows.ole32 windows specialized-arrays ;
SPECIALIZED-ARRAY: ushort
IN: windows.shell32

20
basis/windows/types/types.factor
View File

@ -61,6 +61,7 @@ TYPEDEF: ulong ULONG_PTR
TYPEDEF: int INT32
TYPEDEF: uint UINT32
TYPEDEF: uint DWORD32
TYPEDEF: long LONG32
TYPEDEF: ulong ULONG32
TYPEDEF: ulonglong ULONG64
TYPEDEF: long* POINTER_32
@ -75,6 +76,8 @@ TYPEDEF: longlong LARGE_INTEGER
TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
TYPEDEF: size_t SIZE_T
TYPEDEF: ptrdiff_t SSIZE_T
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
@ -201,15 +204,6 @@ TYPEDEF: LONG_PTR SSIZE_T
TYPEDEF: LONGLONG USN
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: void* WNDPROC
@ -343,6 +337,14 @@ TYPEDEF: PFD* LPPFD
TYPEDEF: HANDLE HGLRC
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
{ mask uint }
{ iItem int }

6
basis/windows/user32/user32.factor
View File

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

6
basis/windows/usp10/usp10.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! 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
LIBRARY: usp10
@ -56,6 +57,9 @@ SCRIPT_JUSTIFFY_RESERVED4 ;
STRUCT: SCRIPT_VISATTR
{ flags WORD } ;
TYPEDEF: void* SCRIPT_CACHE*
TYPEDEF: void* ABC*
FUNCTION: HRESULT ScriptShape (
HDC hdc,
SCRIPT_CACHE* psc,

12
basis/windows/winsock/winsock.factor
View File

@ -105,6 +105,8 @@ CONSTANT: SD_BOTH 2
CONSTANT: SOL_SOCKET HEX: ffff
TYPEDEF: void* sockaddr*
STRUCT: sockaddr-in
{ family short }
{ port ushort }
@ -139,13 +141,15 @@ STRUCT: timeval
{ sec long }
{ usec long } ;
TYPEDEF: void* fd_set*
LIBRARY: winsock
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( 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: char* inet_ntoa ( int in-addr ) ;
FUNCTION: int getaddrinfo ( char* nodename,
@ -158,15 +162,15 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
FUNCTION: hostent* gethostbyname ( char* name ) ;
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 closesocket ( SOCKET s ) ;
FUNCTION: int shutdown ( SOCKET s, int how ) ;
FUNCTION: int send ( 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 getpeername ( 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 ) ;
TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED

2
basis/x11/constants/constants.factor
View File

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

8
basis/x11/xlib/xlib.factor
View File

@ -410,10 +410,6 @@ STRUCT: XCharStruct
{ descent short }
{ 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
{ ext_data XExtData* }
{ fid Font }
@ -432,6 +428,10 @@ STRUCT: XFontStruct
{ ascent 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 ) ;
! 8.6 - Drawing Text

3
extra/benchmark/dawes/dawes.factor
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
IN: benchmark.dawes

2
extra/benchmark/dispatch2/dispatch2.factor
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 ;
SPECIALIZED-ARRAY: double
IN: benchmark.dispatch2

2
extra/benchmark/dispatch3/dispatch3.factor
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
specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double

6
extra/benchmark/fasta/fasta.factor
View File

@ -1,7 +1,7 @@
! 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
sequences.private benchmark.reverse-complement hints
io.encodings.ascii byte-arrays specialized-arrays ;
USING: alien.c-types math kernel io io.files locals multiline
assocs sequences sequences.private benchmark.reverse-complement
hints io.encodings.ascii byte-arrays specialized-arrays ;
SPECIALIZED-ARRAY: double
IN: benchmark.fasta

6
extra/benchmark/nbody-simd/nbody-simd.factor
View File

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

7
extra/benchmark/nbody/nbody.factor
View File

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

10
extra/benchmark/raytracer/raytracer.factor
View File

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

5
extra/benchmark/spectral-norm/spectral-norm.factor
View File

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

1
extra/benchmark/struct-arrays/struct-arrays.factor
View File

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

8
extra/freetype/freetype.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! 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 ;
IN: freetype
@ -38,8 +38,8 @@ TYPEDEF: long FT_F26Dot6
FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ;
! circular reference between glyph and face
TYPEDEF: void face
TYPEDEF: void glyph
TYPEDEF: void* face*
TYPEDEF: void* glyph*
STRUCT: glyph
{ library void* }
@ -166,6 +166,8 @@ STRUCT: FT_Bitmap
{ palette_mode char }
{ 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_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;

10
extra/gpu/render/render-docs.factor
View File

@ -1,9 +1,11 @@
! (c)2009 Joe Groff bsd license
USING: alien alien.syntax byte-arrays classes gpu.buffers
gpu.framebuffers gpu.shaders gpu.textures help.markup
USING: alien alien.c-types alien.syntax byte-arrays classes
gpu.buffers gpu.framebuffers gpu.shaders gpu.textures help.markup
help.syntax images kernel math sequences
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: uint
SPECIALIZED-ARRAY: ulong
@ -49,7 +51,7 @@ $nl
"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
{ $list
{ { $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 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."

1
extra/gpu/util/util.factor
View File

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

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