Merge branch 'master' of git://factorcode.org/git/factor
commit
8be8c7f213
|
@ -38,16 +38,6 @@ HELP: set-alien-value
|
||||||
{ $description "Stores a value at a byte offset from a base C pointer." }
|
{ $description "Stores a value at a byte offset from a base C pointer." }
|
||||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||||
|
|
||||||
HELP: define-deref
|
|
||||||
{ $values { "c-type" "a C type" } }
|
|
||||||
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
|
|
||||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
|
||||||
|
|
||||||
HELP: define-out
|
|
||||||
{ $values { "c-type" "a C type" } }
|
|
||||||
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
|
|
||||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
|
||||||
|
|
||||||
HELP: char
|
HELP: char
|
||||||
{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
|
{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
|
||||||
HELP: uchar
|
HELP: uchar
|
||||||
|
@ -121,39 +111,10 @@ $nl
|
||||||
ARTICLE: "c-out-params" "Output parameters in C"
|
ARTICLE: "c-out-params" "Output parameters in C"
|
||||||
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
||||||
$nl
|
$nl
|
||||||
"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
|
"To wrap Factor data for consumption by the FFI, we use a utility word that constructs a byte array of the correct size and converts the Factor object to a C value stored into that byte array:"
|
||||||
{ $subsections
|
{ $subsections <ref> }
|
||||||
<char>
|
"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using this word:"
|
||||||
<uchar>
|
{ $subsections deref } ;
|
||||||
<short>
|
|
||||||
<ushort>
|
|
||||||
<int>
|
|
||||||
<uint>
|
|
||||||
<long>
|
|
||||||
<ulong>
|
|
||||||
<longlong>
|
|
||||||
<ulonglong>
|
|
||||||
<float>
|
|
||||||
<double>
|
|
||||||
<void*>
|
|
||||||
}
|
|
||||||
"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
|
|
||||||
{ $subsections
|
|
||||||
*char
|
|
||||||
*uchar
|
|
||||||
*short
|
|
||||||
*ushort
|
|
||||||
*int
|
|
||||||
*uint
|
|
||||||
*long
|
|
||||||
*ulong
|
|
||||||
*longlong
|
|
||||||
*ulonglong
|
|
||||||
*float
|
|
||||||
*double
|
|
||||||
*void*
|
|
||||||
}
|
|
||||||
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
|
|
||||||
|
|
||||||
ARTICLE: "c-types.primitives" "Primitive C types"
|
ARTICLE: "c-types.primitives" "Primitive C types"
|
||||||
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||||
|
|
|
@ -2,24 +2,25 @@ USING: alien alien.syntax alien.c-types alien.parser
|
||||||
eval kernel tools.test sequences system libc alien.strings
|
eval kernel tools.test sequences system libc alien.strings
|
||||||
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
|
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
|
||||||
accessors compiler.units ;
|
accessors compiler.units ;
|
||||||
|
FROM: alien.c-types => short ;
|
||||||
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 <ref> char deref ] unit-test
|
||||||
[ -1 ] [ -1 <short> *short ] unit-test
|
[ -1 ] [ -1 short <ref> short deref ] unit-test
|
||||||
[ -1 ] [ -1 <int> *int ] unit-test
|
[ -1 ] [ -1 int <ref> int deref ] unit-test
|
||||||
|
|
||||||
! I don't care if this throws an error or works, but at least
|
! I don't care if this throws an error or works, but at least
|
||||||
! it should be consistent between platforms
|
! it should be consistent between platforms
|
||||||
[ -1 ] [ -1.0 <int> *int ] unit-test
|
[ -1 ] [ -1.0 int <ref> int deref ] unit-test
|
||||||
[ -1 ] [ -1.0 <long> *long ] unit-test
|
[ -1 ] [ -1.0 long <ref> long deref ] unit-test
|
||||||
[ -1 ] [ -1.0 <longlong> *longlong ] unit-test
|
[ -1 ] [ -1.0 longlong <ref> longlong deref ] unit-test
|
||||||
[ 1 ] [ 1.0 <uint> *uint ] unit-test
|
[ 1 ] [ 1.0 uint <ref> uint deref ] unit-test
|
||||||
[ 1 ] [ 1.0 <ulong> *ulong ] unit-test
|
[ 1 ] [ 1.0 ulong <ref> ulong deref ] unit-test
|
||||||
[ 1 ] [ 1.0 <ulonglong> *ulonglong ] unit-test
|
[ 1 ] [ 1.0 ulonglong <ref> ulonglong deref ] unit-test
|
||||||
|
|
||||||
UNION-STRUCT: foo
|
UNION-STRUCT: foo
|
||||||
{ a int }
|
{ a int }
|
||||||
|
@ -62,11 +63,11 @@ TYPEDEF: int* MyIntArray
|
||||||
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
|
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
0 B{ 1 2 3 4 } <displaced-alien> void* <ref>
|
||||||
] must-fail
|
] must-fail
|
||||||
|
|
||||||
os windows? cpu x86.64? and [
|
os windows? cpu x86.64? and [
|
||||||
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
|
[ -2147467259 ] [ 2147500037 long <ref> long deref ] unit-test
|
||||||
] when
|
] when
|
||||||
|
|
||||||
[ 0 ] [ -10 uchar c-type-clamp ] unit-test
|
[ 0 ] [ -10 uchar c-type-clamp ] unit-test
|
||||||
|
|
|
@ -1,12 +1,9 @@
|
||||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: byte-arrays arrays assocs delegate kernel kernel.private math
|
USING: accessors alien alien.accessors arrays byte-arrays
|
||||||
math.order math.parser namespaces make parser sequences strings
|
classes combinators compiler.units cpu.architecture delegate
|
||||||
words splitting cpu.architecture alien alien.accessors
|
fry kernel layouts locals macros math math.order quotations
|
||||||
alien.strings quotations layouts system compiler.units io
|
sequences system words words.symbol ;
|
||||||
io.files io.encodings.binary io.streams.memory accessors
|
|
||||||
combinators effects continuations fry classes vocabs
|
|
||||||
vocabs.loader words.symbol macros ;
|
|
||||||
QUALIFIED: math
|
QUALIFIED: math
|
||||||
IN: alien.c-types
|
IN: alien.c-types
|
||||||
|
|
||||||
|
@ -21,9 +18,6 @@ SYMBOLS:
|
||||||
|
|
||||||
SINGLETON: void
|
SINGLETON: void
|
||||||
|
|
||||||
DEFER: <int>
|
|
||||||
DEFER: *char
|
|
||||||
|
|
||||||
TUPLE: abstract-c-type
|
TUPLE: abstract-c-type
|
||||||
{ class class initial: object }
|
{ class class initial: object }
|
||||||
{ boxed-class class initial: object }
|
{ boxed-class class initial: object }
|
||||||
|
@ -111,8 +105,6 @@ M: c-type-name base-type c-type ;
|
||||||
|
|
||||||
M: c-type base-type ;
|
M: c-type base-type ;
|
||||||
|
|
||||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
|
||||||
|
|
||||||
GENERIC: heap-size ( name -- size )
|
GENERIC: heap-size ( name -- size )
|
||||||
|
|
||||||
M: abstract-c-type heap-size size>> ;
|
M: abstract-c-type heap-size size>> ;
|
||||||
|
@ -170,19 +162,6 @@ TUPLE: long-long-type < c-type ;
|
||||||
: <long-long-type> ( -- c-type )
|
: <long-long-type> ( -- c-type )
|
||||||
long-long-type new ;
|
long-long-type new ;
|
||||||
|
|
||||||
: define-deref ( c-type -- )
|
|
||||||
[ name>> CHAR: * prefix "alien.c-types" create ]
|
|
||||||
[ '[ 0 _ alien-value ] ]
|
|
||||||
bi (( c-ptr -- value )) define-inline ;
|
|
||||||
|
|
||||||
: define-out ( c-type -- )
|
|
||||||
[ name>> "alien.c-types" constructor-word ]
|
|
||||||
[ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
|
|
||||||
(( value -- c-ptr )) define-inline ;
|
|
||||||
|
|
||||||
: define-primitive-type ( c-type name -- )
|
|
||||||
[ typedef ] [ define-deref ] [ define-out ] tri ;
|
|
||||||
|
|
||||||
: if-void ( c-type true false -- )
|
: if-void ( c-type true false -- )
|
||||||
pick void? [ drop nip call ] [ nip call ] if ; inline
|
pick void? [ drop nip call ] [ nip call ] if ; inline
|
||||||
|
|
||||||
|
@ -247,7 +226,7 @@ M: pointer c-type
|
||||||
[ >c-ptr ] >>unboxer-quot
|
[ >c-ptr ] >>unboxer-quot
|
||||||
"allot_alien" >>boxer
|
"allot_alien" >>boxer
|
||||||
"alien_offset" >>unboxer
|
"alien_offset" >>unboxer
|
||||||
\ void* define-primitive-type
|
\ void* typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -260,7 +239,7 @@ M: pointer c-type
|
||||||
"from_signed_2" >>boxer
|
"from_signed_2" >>boxer
|
||||||
"to_signed_2" >>unboxer
|
"to_signed_2" >>unboxer
|
||||||
[ >fixnum ] >>unboxer-quot
|
[ >fixnum ] >>unboxer-quot
|
||||||
\ short define-primitive-type
|
\ short typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -273,7 +252,7 @@ M: pointer c-type
|
||||||
"from_unsigned_2" >>boxer
|
"from_unsigned_2" >>boxer
|
||||||
"to_unsigned_2" >>unboxer
|
"to_unsigned_2" >>unboxer
|
||||||
[ >fixnum ] >>unboxer-quot
|
[ >fixnum ] >>unboxer-quot
|
||||||
\ ushort define-primitive-type
|
\ ushort typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -286,7 +265,7 @@ M: pointer c-type
|
||||||
"from_signed_1" >>boxer
|
"from_signed_1" >>boxer
|
||||||
"to_signed_1" >>unboxer
|
"to_signed_1" >>unboxer
|
||||||
[ >fixnum ] >>unboxer-quot
|
[ >fixnum ] >>unboxer-quot
|
||||||
\ char define-primitive-type
|
\ char typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -299,7 +278,7 @@ M: pointer c-type
|
||||||
"from_unsigned_1" >>boxer
|
"from_unsigned_1" >>boxer
|
||||||
"to_unsigned_1" >>unboxer
|
"to_unsigned_1" >>unboxer
|
||||||
[ >fixnum ] >>unboxer-quot
|
[ >fixnum ] >>unboxer-quot
|
||||||
\ uchar define-primitive-type
|
\ uchar typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
math:float >>class
|
math:float >>class
|
||||||
|
@ -313,7 +292,7 @@ M: pointer c-type
|
||||||
"to_float" >>unboxer
|
"to_float" >>unboxer
|
||||||
float-rep >>rep
|
float-rep >>rep
|
||||||
[ >float ] >>unboxer-quot
|
[ >float ] >>unboxer-quot
|
||||||
\ float define-primitive-type
|
\ float typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
math:float >>class
|
math:float >>class
|
||||||
|
@ -326,7 +305,7 @@ M: pointer c-type
|
||||||
"to_double" >>unboxer
|
"to_double" >>unboxer
|
||||||
double-rep >>rep
|
double-rep >>rep
|
||||||
[ >float ] >>unboxer-quot
|
[ >float ] >>unboxer-quot
|
||||||
\ double define-primitive-type
|
\ double typedef
|
||||||
|
|
||||||
cell 8 = [
|
cell 8 = [
|
||||||
<c-type>
|
<c-type>
|
||||||
|
@ -340,7 +319,7 @@ M: pointer c-type
|
||||||
"from_signed_4" >>boxer
|
"from_signed_4" >>boxer
|
||||||
"to_signed_4" >>unboxer
|
"to_signed_4" >>unboxer
|
||||||
[ >fixnum ] >>unboxer-quot
|
[ >fixnum ] >>unboxer-quot
|
||||||
\ int define-primitive-type
|
\ int typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -353,7 +332,7 @@ M: pointer c-type
|
||||||
"from_unsigned_4" >>boxer
|
"from_unsigned_4" >>boxer
|
||||||
"to_unsigned_4" >>unboxer
|
"to_unsigned_4" >>unboxer
|
||||||
[ >fixnum ] >>unboxer-quot
|
[ >fixnum ] >>unboxer-quot
|
||||||
\ uint define-primitive-type
|
\ uint typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -366,7 +345,7 @@ M: pointer c-type
|
||||||
"from_signed_cell" >>boxer
|
"from_signed_cell" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
[ >integer ] >>unboxer-quot
|
[ >integer ] >>unboxer-quot
|
||||||
\ longlong define-primitive-type
|
\ longlong typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -379,14 +358,14 @@ M: pointer c-type
|
||||||
"from_unsigned_cell" >>boxer
|
"from_unsigned_cell" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
[ >integer ] >>unboxer-quot
|
[ >integer ] >>unboxer-quot
|
||||||
\ ulonglong define-primitive-type
|
\ ulonglong typedef
|
||||||
|
|
||||||
os windows? [
|
os windows? [
|
||||||
\ int c-type \ long define-primitive-type
|
\ int c-type \ long typedef
|
||||||
\ uint c-type \ ulong define-primitive-type
|
\ uint c-type \ ulong typedef
|
||||||
] [
|
] [
|
||||||
\ longlong c-type \ long define-primitive-type
|
\ longlong c-type \ long typedef
|
||||||
\ ulonglong c-type \ ulong define-primitive-type
|
\ ulonglong c-type \ ulong typedef
|
||||||
] if
|
] if
|
||||||
|
|
||||||
\ longlong c-type \ ptrdiff_t typedef
|
\ longlong c-type \ ptrdiff_t typedef
|
||||||
|
@ -406,7 +385,7 @@ M: pointer c-type
|
||||||
"from_signed_cell" >>boxer
|
"from_signed_cell" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
[ >integer ] >>unboxer-quot
|
[ >integer ] >>unboxer-quot
|
||||||
\ int define-primitive-type
|
\ int typedef
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -419,7 +398,7 @@ M: pointer c-type
|
||||||
"from_unsigned_cell" >>boxer
|
"from_unsigned_cell" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
[ >integer ] >>unboxer-quot
|
[ >integer ] >>unboxer-quot
|
||||||
\ uint define-primitive-type
|
\ uint typedef
|
||||||
|
|
||||||
<long-long-type>
|
<long-long-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -431,7 +410,7 @@ M: pointer c-type
|
||||||
"from_signed_8" >>boxer
|
"from_signed_8" >>boxer
|
||||||
"to_signed_8" >>unboxer
|
"to_signed_8" >>unboxer
|
||||||
[ >integer ] >>unboxer-quot
|
[ >integer ] >>unboxer-quot
|
||||||
\ longlong define-primitive-type
|
\ longlong typedef
|
||||||
|
|
||||||
<long-long-type>
|
<long-long-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -443,10 +422,10 @@ M: pointer c-type
|
||||||
"from_unsigned_8" >>boxer
|
"from_unsigned_8" >>boxer
|
||||||
"to_unsigned_8" >>unboxer
|
"to_unsigned_8" >>unboxer
|
||||||
[ >integer ] >>unboxer-quot
|
[ >integer ] >>unboxer-quot
|
||||||
\ ulonglong define-primitive-type
|
\ ulonglong typedef
|
||||||
|
|
||||||
\ int c-type \ long define-primitive-type
|
\ int c-type \ long typedef
|
||||||
\ uint c-type \ ulong define-primitive-type
|
\ uint c-type \ ulong typedef
|
||||||
|
|
||||||
\ int c-type \ ptrdiff_t typedef
|
\ int c-type \ ptrdiff_t typedef
|
||||||
\ int c-type \ intptr_t typedef
|
\ int c-type \ intptr_t typedef
|
||||||
|
@ -459,7 +438,7 @@ M: pointer c-type
|
||||||
[ >c-bool ] >>unboxer-quot
|
[ >c-bool ] >>unboxer-quot
|
||||||
[ c-bool> ] >>boxer-quot
|
[ c-bool> ] >>boxer-quot
|
||||||
object >>boxed-class
|
object >>boxed-class
|
||||||
\ bool define-primitive-type
|
\ bool typedef
|
||||||
|
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
||||||
|
@ -489,3 +468,12 @@ M: double-2-rep rep-component-type drop double ;
|
||||||
: c-type-clamp ( value c-type -- value' )
|
: c-type-clamp ( value c-type -- value' )
|
||||||
dup { float double } member-eq?
|
dup { float double } member-eq?
|
||||||
[ drop ] [ c-type-interval clamp ] if ; inline
|
[ drop ] [ c-type-interval clamp ] if ; inline
|
||||||
|
|
||||||
|
: <ref> ( value c-type -- c-ptr )
|
||||||
|
[ heap-size <byte-array> ] keep
|
||||||
|
'[ 0 _ set-alien-value ] keep ; inline
|
||||||
|
|
||||||
|
: deref ( c-ptr c-type -- value )
|
||||||
|
[ 0 ] dip alien-value ; inline
|
||||||
|
|
||||||
|
: little-endian? ( -- ? ) 1 int <ref> char deref 1 = ; foldable
|
||||||
|
|
|
@ -192,10 +192,10 @@ intel-unix-abi fortran-abi [
|
||||||
{
|
{
|
||||||
[ {
|
[ {
|
||||||
[ ascii string>alien ]
|
[ ascii string>alien ]
|
||||||
[ <longlong> ]
|
[ longlong <ref> ]
|
||||||
[ <float> ]
|
[ float <ref> ]
|
||||||
[ <complex-float> ]
|
[ <complex-float> ]
|
||||||
[ 1 0 ? <short> ]
|
[ 1 0 ? c:short <ref> ]
|
||||||
} spread ]
|
} spread ]
|
||||||
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
|
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
|
||||||
} 5 ncleave
|
} 5 ncleave
|
||||||
|
@ -211,7 +211,7 @@ intel-unix-abi fortran-abi [
|
||||||
[ drop ]
|
[ drop ]
|
||||||
[ drop ]
|
[ drop ]
|
||||||
[ drop ]
|
[ drop ]
|
||||||
[ *float ]
|
[ float deref ]
|
||||||
[ drop ]
|
[ drop ]
|
||||||
[ drop ]
|
[ drop ]
|
||||||
} spread
|
} spread
|
||||||
|
@ -280,7 +280,7 @@ intel-unix-abi fortran-abi [
|
||||||
{
|
{
|
||||||
[ {
|
[ {
|
||||||
[ ascii string>alien ]
|
[ ascii string>alien ]
|
||||||
[ <float> ]
|
[ float <ref> ]
|
||||||
[ ascii string>alien ]
|
[ ascii string>alien ]
|
||||||
} spread ]
|
} spread ]
|
||||||
[ { [ length ] [ drop ] [ length ] } spread ]
|
[ { [ length ] [ drop ] [ length ] } spread ]
|
||||||
|
@ -298,7 +298,7 @@ intel-unix-abi fortran-abi [
|
||||||
[ ascii alien>nstring ]
|
[ ascii alien>nstring ]
|
||||||
[ ]
|
[ ]
|
||||||
[ ascii alien>nstring ]
|
[ ascii alien>nstring ]
|
||||||
[ *float ]
|
[ float deref ]
|
||||||
[ ]
|
[ ]
|
||||||
[ ascii alien>nstring ]
|
[ ascii alien>nstring ]
|
||||||
} spread
|
} spread
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
! (c) 2009 Joe Groff, see BSD license
|
! (c) 2009 Joe Groff, see BSD license
|
||||||
USING: accessors alien alien.c-types alien.complex alien.data
|
USING: accessors alien alien.complex alien.c-types alien.data
|
||||||
alien.parser grouping alien.strings alien.syntax arrays ascii
|
alien.parser grouping alien.strings alien.syntax arrays ascii
|
||||||
assocs byte-arrays combinators combinators.short-circuit fry
|
assocs byte-arrays combinators combinators.short-circuit fry
|
||||||
generalizations kernel lexer macros math math.parser namespaces
|
generalizations kernel lexer macros math math.parser namespaces
|
||||||
|
@ -211,11 +211,11 @@ GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
|
||||||
M: integer-type (fortran-arg>c-args)
|
M: integer-type (fortran-arg>c-args)
|
||||||
[
|
[
|
||||||
size>> {
|
size>> {
|
||||||
{ f [ [ <int> ] [ drop ] ] }
|
{ f [ [ c:int <ref> ] [ drop ] ] }
|
||||||
{ 1 [ [ <char> ] [ drop ] ] }
|
{ 1 [ [ c:char <ref> ] [ drop ] ] }
|
||||||
{ 2 [ [ <short> ] [ drop ] ] }
|
{ 2 [ [ c:short <ref> ] [ drop ] ] }
|
||||||
{ 4 [ [ <int> ] [ drop ] ] }
|
{ 4 [ [ c:int <ref> ] [ drop ] ] }
|
||||||
{ 8 [ [ <longlong> ] [ drop ] ] }
|
{ 8 [ [ c:longlong <ref> ] [ drop ] ] }
|
||||||
[ invalid-fortran-type ]
|
[ invalid-fortran-type ]
|
||||||
} case
|
} case
|
||||||
] args?dims ;
|
] args?dims ;
|
||||||
|
@ -226,9 +226,9 @@ M: logical-type (fortran-arg>c-args)
|
||||||
M: real-type (fortran-arg>c-args)
|
M: real-type (fortran-arg>c-args)
|
||||||
[
|
[
|
||||||
size>> {
|
size>> {
|
||||||
{ f [ [ <float> ] [ drop ] ] }
|
{ f [ [ c:float <ref> ] [ drop ] ] }
|
||||||
{ 4 [ [ <float> ] [ drop ] ] }
|
{ 4 [ [ c:float <ref> ] [ drop ] ] }
|
||||||
{ 8 [ [ <double> ] [ drop ] ] }
|
{ 8 [ [ c:double <ref> ] [ drop ] ] }
|
||||||
[ invalid-fortran-type ]
|
[ invalid-fortran-type ]
|
||||||
} case
|
} case
|
||||||
] args?dims ;
|
] args?dims ;
|
||||||
|
@ -244,14 +244,14 @@ M: real-complex-type (fortran-arg>c-args)
|
||||||
] args?dims ;
|
] args?dims ;
|
||||||
|
|
||||||
M: double-precision-type (fortran-arg>c-args)
|
M: double-precision-type (fortran-arg>c-args)
|
||||||
[ drop [ <double> ] [ drop ] ] args?dims ;
|
[ drop [ c:double <ref> ] [ drop ] ] args?dims ;
|
||||||
|
|
||||||
M: double-complex-type (fortran-arg>c-args)
|
M: double-complex-type (fortran-arg>c-args)
|
||||||
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
|
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
|
||||||
|
|
||||||
M: character-type (fortran-arg>c-args)
|
M: character-type (fortran-arg>c-args)
|
||||||
fix-character-type single-char?
|
fix-character-type single-char?
|
||||||
[ [ first <char> ] [ drop ] ]
|
[ [ first c:char <ref> ] [ drop ] ]
|
||||||
[ [ ascii string>alien ] [ length ] ] if ;
|
[ [ ascii string>alien ] [ length ] ] if ;
|
||||||
|
|
||||||
M: misc-type (fortran-arg>c-args)
|
M: misc-type (fortran-arg>c-args)
|
||||||
|
@ -263,23 +263,25 @@ GENERIC: (fortran-result>) ( type -- quots )
|
||||||
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
|
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
|
||||||
|
|
||||||
M: integer-type (fortran-result>)
|
M: integer-type (fortran-result>)
|
||||||
[ size>> {
|
[
|
||||||
{ f [ { [ *int ] } ] }
|
size>> {
|
||||||
{ 1 [ { [ *char ] } ] }
|
{ f [ { [ c:int deref ] } ] }
|
||||||
{ 2 [ { [ *short ] } ] }
|
{ 1 [ { [ c:char deref ] } ] }
|
||||||
{ 4 [ { [ *int ] } ] }
|
{ 2 [ { [ c:short deref ] } ] }
|
||||||
{ 8 [ { [ *longlong ] } ] }
|
{ 4 [ { [ c:int deref ] } ] }
|
||||||
|
{ 8 [ { [ c:longlong deref ] } ] }
|
||||||
[ invalid-fortran-type ]
|
[ invalid-fortran-type ]
|
||||||
} case ] result?dims ;
|
} case
|
||||||
|
] result?dims ;
|
||||||
|
|
||||||
M: logical-type (fortran-result>)
|
M: logical-type (fortran-result>)
|
||||||
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
|
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
|
||||||
|
|
||||||
M: real-type (fortran-result>)
|
M: real-type (fortran-result>)
|
||||||
[ size>> {
|
[ size>> {
|
||||||
{ f [ { [ *float ] } ] }
|
{ f [ { [ c:float deref ] } ] }
|
||||||
{ 4 [ { [ *float ] } ] }
|
{ 4 [ { [ c:float deref ] } ] }
|
||||||
{ 8 [ { [ *double ] } ] }
|
{ 8 [ { [ c:double deref ] } ] }
|
||||||
[ invalid-fortran-type ]
|
[ invalid-fortran-type ]
|
||||||
} case ] result?dims ;
|
} case ] result?dims ;
|
||||||
|
|
||||||
|
@ -292,14 +294,14 @@ M: real-complex-type (fortran-result>)
|
||||||
} case ] result?dims ;
|
} case ] result?dims ;
|
||||||
|
|
||||||
M: double-precision-type (fortran-result>)
|
M: double-precision-type (fortran-result>)
|
||||||
[ drop { [ *double ] } ] result?dims ;
|
[ drop { [ c:double deref ] } ] result?dims ;
|
||||||
|
|
||||||
M: double-complex-type (fortran-result>)
|
M: double-complex-type (fortran-result>)
|
||||||
[ drop { [ *complex-double ] } ] result?dims ;
|
[ drop { [ *complex-double ] } ] result?dims ;
|
||||||
|
|
||||||
M: character-type (fortran-result>)
|
M: character-type (fortran-result>)
|
||||||
fix-character-type single-char?
|
fix-character-type single-char?
|
||||||
[ { [ *char 1string ] } ]
|
[ { [ c:char deref 1string ] } ]
|
||||||
[ { [ ] [ ascii alien>nstring ] } ] if ;
|
[ { [ ] [ ascii alien>nstring ] } ] if ;
|
||||||
|
|
||||||
M: misc-type (fortran-result>)
|
M: misc-type (fortran-result>)
|
||||||
|
|
|
@ -21,7 +21,7 @@ IN: calendar.unix
|
||||||
timespec>duration since-1970 ;
|
timespec>duration since-1970 ;
|
||||||
|
|
||||||
: get-time ( -- alien )
|
: get-time ( -- alien )
|
||||||
f time <time_t> localtime ;
|
f time time_t <ref> localtime ;
|
||||||
|
|
||||||
: timezone-name ( -- string )
|
: timezone-name ( -- string )
|
||||||
get-time zone>> ;
|
get-time zone>> ;
|
||||||
|
|
|
@ -275,7 +275,8 @@ M: cucumber equal? "The cucumber has no equal" throw ;
|
||||||
|
|
||||||
[ 4294967295 B{ 255 255 255 255 } -1 ]
|
[ 4294967295 B{ 255 255 255 255 } -1 ]
|
||||||
[
|
[
|
||||||
-1 <int> -1 <int>
|
-1 int <ref>
|
||||||
|
-1 int <ref>
|
||||||
[ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
|
[ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
|
||||||
compile-call
|
compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -6,6 +6,8 @@ sbufs strings.private slots.private alien math.order
|
||||||
alien.accessors alien.c-types alien.data alien.syntax alien.strings
|
alien.accessors alien.c-types alien.data alien.syntax alien.strings
|
||||||
namespaces libc io.encodings.ascii classes compiler.test ;
|
namespaces libc io.encodings.ascii classes compiler.test ;
|
||||||
FROM: math => float ;
|
FROM: math => float ;
|
||||||
|
FROM: alien.c-types => short ;
|
||||||
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: compiler.tests.intrinsics
|
IN: compiler.tests.intrinsics
|
||||||
|
|
||||||
! Make sure that intrinsic ops compile to correct code.
|
! Make sure that intrinsic ops compile to correct code.
|
||||||
|
@ -429,46 +431,46 @@ ERROR: bug-in-fixnum* x y a b ;
|
||||||
[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
|
[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
|
||||||
|
|
||||||
"s" get [
|
"s" get [
|
||||||
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
|
[ "hello world" ] [ "s" get void* <ref> [ { byte-array } declare void* deref ] compile-call ascii alien>string ] unit-test
|
||||||
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
|
[ "hello world" ] [ "s" get void* <ref> [ { c-ptr } declare void* deref ] compile-call ascii alien>string ] unit-test
|
||||||
|
|
||||||
[ ] [ "s" get free ] unit-test
|
[ ] [ "s" get free ] unit-test
|
||||||
] when
|
] when
|
||||||
|
|
||||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
|
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare void* <ref> ] compile-call void* deref ] unit-test
|
||||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
|
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare void* <ref> ] compile-call void* deref ] unit-test
|
||||||
[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-call *void* ] unit-test
|
[ f ] [ f [ { POSTPONE: f } declare void* <ref> ] compile-call void* deref ] unit-test
|
||||||
|
|
||||||
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||||
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
||||||
|
|
||||||
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
[ -100 ] [ -100 char <ref> [ { byte-array } declare char deref ] compile-call ] unit-test
|
||||||
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
[ 156 ] [ -100 uchar <ref> [ { byte-array } declare uchar deref ] compile-call ] unit-test
|
||||||
|
|
||||||
[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
|
[ -100 ] [ -100 [ char <ref> ] [ { fixnum } declare ] prepend compile-call char deref ] unit-test
|
||||||
[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
|
[ 156 ] [ -100 [ uchar <ref> ] [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test
|
||||||
|
|
||||||
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
|
[ -1000 ] [ -1000 short <ref> [ { byte-array } declare short deref ] compile-call ] unit-test
|
||||||
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
|
[ 64536 ] [ -1000 ushort <ref> [ { byte-array } declare ushort deref ] compile-call ] unit-test
|
||||||
|
|
||||||
[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
|
[ -1000 ] [ -1000 [ short <ref> ] [ { fixnum } declare ] prepend compile-call short deref ] unit-test
|
||||||
[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
|
[ 64536 ] [ -1000 [ ushort <ref> ] [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test
|
||||||
|
|
||||||
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
|
[ -100000 ] [ -100000 int <ref> [ { byte-array } declare int deref ] compile-call ] unit-test
|
||||||
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
|
[ 4294867296 ] [ -100000 uint <ref> [ { byte-array } declare uint deref ] compile-call ] unit-test
|
||||||
|
|
||||||
[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
|
[ -100000 ] [ -100000 [ int <ref> ] [ { fixnum } declare ] prepend compile-call int deref ] unit-test
|
||||||
[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
|
[ 4294867296 ] [ -100000 [ uint <ref> ] [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
|
||||||
|
|
||||||
[ t ] [ pi pi <double> *double = ] unit-test
|
[ t ] [ pi pi double <ref> double deref = ] unit-test
|
||||||
|
|
||||||
[ t ] [ pi <double> [ { byte-array } declare *double ] compile-call pi = ] unit-test
|
[ t ] [ pi double <ref> [ { byte-array } declare double deref ] compile-call pi = ] unit-test
|
||||||
|
|
||||||
! Silly
|
! Silly
|
||||||
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
|
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep c:float deref pi - -0.001 0.001 between? ] unit-test
|
||||||
[ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
|
[ t ] [ pi c:float <ref> [ { byte-array } declare c:float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
|
||||||
|
|
||||||
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
|
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep double deref pi = ] unit-test
|
||||||
|
|
||||||
[ 4 ] [
|
[ 4 ] [
|
||||||
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
|
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
|
||||||
|
@ -532,12 +534,14 @@ ERROR: bug-in-fixnum* x y a b ;
|
||||||
] compile-call
|
] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! These tests must fail because we're not allowed to store
|
||||||
|
! a pointer to a byte array inside of an alien object
|
||||||
[
|
[
|
||||||
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
|
B{ 0 0 0 0 } [ { byte-array } declare void* <ref> ] compile-call
|
||||||
] must-fail
|
] must-fail
|
||||||
|
|
||||||
[
|
[
|
||||||
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
|
B{ 0 0 0 0 } [ { c-ptr } declare void* <ref> ] compile-call
|
||||||
] must-fail
|
] must-fail
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
@ -17,6 +17,7 @@ compiler.tree.propagation.info
|
||||||
compiler.tree.checker
|
compiler.tree.checker
|
||||||
compiler.tree.debugger ;
|
compiler.tree.debugger ;
|
||||||
FROM: math => float ;
|
FROM: math => float ;
|
||||||
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: compiler.tree.cleanup.tests
|
IN: compiler.tree.cleanup.tests
|
||||||
|
|
||||||
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||||
|
@ -244,22 +245,22 @@ cell-bits 32 = [
|
||||||
] when
|
] when
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ B{ 1 0 } *short 0 number= ]
|
[ B{ 1 0 } c:short deref 0 number= ]
|
||||||
\ number= inlined?
|
\ number= inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ B{ 1 0 } *short 0 { number number } declare number= ]
|
[ B{ 1 0 } c:short deref 0 { number number } declare number= ]
|
||||||
\ number= inlined?
|
\ number= inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ B{ 1 0 } *short 0 = ]
|
[ B{ 1 0 } c:short deref 0 = ]
|
||||||
\ number= inlined?
|
\ number= inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
|
[ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ]
|
||||||
\ number= inlined?
|
\ number= inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -36,15 +36,15 @@ ERROR: zlib-failed n string ;
|
||||||
|
|
||||||
: compress ( byte-array -- compressed )
|
: compress ( byte-array -- compressed )
|
||||||
[
|
[
|
||||||
[ compressed-size <byte-array> dup length <ulong> ] keep [
|
[ compressed-size <byte-array> dup length ulong <ref> ] keep [
|
||||||
dup length compression.zlib.ffi:compress zlib-error
|
dup length compression.zlib.ffi:compress zlib-error
|
||||||
] 3keep drop *ulong head
|
] 3keep drop ulong deref head
|
||||||
] keep length <compressed> ;
|
] keep length <compressed> ;
|
||||||
|
|
||||||
: uncompress ( compressed -- byte-array )
|
: uncompress ( compressed -- byte-array )
|
||||||
[
|
[
|
||||||
length>> [ <byte-array> ] keep <ulong> 2dup
|
length>> [ <byte-array> ] keep ulong <ref> 2dup
|
||||||
] [
|
] [
|
||||||
data>> dup length
|
data>> dup length
|
||||||
compression.zlib.ffi:uncompress zlib-error
|
compression.zlib.ffi:uncompress zlib-error
|
||||||
] bi *ulong head ;
|
] bi ulong deref head ;
|
||||||
|
|
|
@ -30,14 +30,14 @@ FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType th
|
||||||
GENERIC: <CFNumber> ( number -- alien )
|
GENERIC: <CFNumber> ( number -- alien )
|
||||||
|
|
||||||
M: integer <CFNumber>
|
M: integer <CFNumber>
|
||||||
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
[ f kCFNumberLongLongType ] dip longlong <ref> CFNumberCreate ;
|
||||||
|
|
||||||
M: float <CFNumber>
|
M: float <CFNumber>
|
||||||
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
[ f kCFNumberDoubleType ] dip double <ref> CFNumberCreate ;
|
||||||
|
|
||||||
M: t <CFNumber>
|
M: t <CFNumber>
|
||||||
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
drop f kCFNumberIntType 1 int <ref> CFNumberCreate ;
|
||||||
|
|
||||||
M: f <CFNumber>
|
M: f <CFNumber>
|
||||||
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
drop f kCFNumberIntType 0 int <ref> CFNumberCreate ;
|
||||||
|
|
||||||
|
|
|
@ -5,11 +5,12 @@ macros math math.vectors namespaces quotations sequences system
|
||||||
compiler.cfg.comparisons compiler.cfg.intrinsics
|
compiler.cfg.comparisons compiler.cfg.intrinsics
|
||||||
compiler.codegen.fixup cpu.architecture cpu.x86
|
compiler.codegen.fixup cpu.architecture cpu.x86
|
||||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
|
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
|
||||||
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: cpu.x86.sse
|
IN: cpu.x86.sse
|
||||||
|
|
||||||
! Scalar floating point with SSE2
|
! Scalar floating point with SSE2
|
||||||
M: x86 %load-float <float> float-rep %load-vector ;
|
M: x86 %load-float c:float <ref> float-rep %load-vector ;
|
||||||
M: x86 %load-double <double> double-rep %load-vector ;
|
M: x86 %load-double c:double <ref> double-rep %load-vector ;
|
||||||
|
|
||||||
M: float-rep copy-register* drop MOVAPS ;
|
M: float-rep copy-register* drop MOVAPS ;
|
||||||
M: double-rep copy-register* drop MOVAPS ;
|
M: double-rep copy-register* drop MOVAPS ;
|
||||||
|
|
|
@ -38,12 +38,12 @@ M: double-rep copy-memory* copy-memory-x87 ;
|
||||||
|
|
||||||
M: x86 %load-float
|
M: x86 %load-float
|
||||||
0 [] FLDS
|
0 [] FLDS
|
||||||
<float> rc-absolute rel-binary-literal
|
float <ref> rc-absolute rel-binary-literal
|
||||||
shuffle-down FSTP ;
|
shuffle-down FSTP ;
|
||||||
|
|
||||||
M: x86 %load-double
|
M: x86 %load-double
|
||||||
0 [] FLDL
|
0 [] FLDL
|
||||||
<double> rc-absolute rel-binary-literal
|
double <ref> rc-absolute rel-binary-literal
|
||||||
shuffle-down FSTP ;
|
shuffle-down FSTP ;
|
||||||
|
|
||||||
:: binary-op ( dst src1 src2 quot -- )
|
:: binary-op ( dst src1 src2 quot -- )
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: endian
|
||||||
SINGLETONS: big-endian little-endian ;
|
SINGLETONS: big-endian little-endian ;
|
||||||
|
|
||||||
: compute-native-endianness ( -- class )
|
: compute-native-endianness ( -- class )
|
||||||
1 <int> *char 0 = big-endian little-endian ? ;
|
1 int <ref> char deref 0 = big-endian little-endian ? ;
|
||||||
|
|
||||||
SYMBOL: native-endianness
|
SYMBOL: native-endianness
|
||||||
native-endianness [ compute-native-endianness ] initialize
|
native-endianness [ compute-native-endianness ] initialize
|
||||||
|
|
|
@ -17,7 +17,7 @@ M: unix set-os-env ( value key -- ) swap 1 setenv io-error ;
|
||||||
M: unix unset-os-env ( key -- ) unsetenv io-error ;
|
M: unix unset-os-env ( key -- ) unsetenv io-error ;
|
||||||
|
|
||||||
M: unix (os-envs) ( -- seq )
|
M: unix (os-envs) ( -- seq )
|
||||||
environ *void* utf8 alien>strings ;
|
environ void* deref utf8 alien>strings ;
|
||||||
|
|
||||||
: set-void* ( value alien -- ) 0 set-alien-cell ;
|
: set-void* ( value alien -- ) 0 set-alien-cell ;
|
||||||
|
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (c) 2008 Slava Pestov
|
! Copyright (c) 2008, 2010 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs namespaces kernel sequences sets
|
USING: accessors assocs namespaces kernel sequences sets
|
||||||
destructors combinators fry logging
|
destructors combinators fry logging io.encodings.utf8
|
||||||
io.encodings.utf8 io.encodings.string io.binary random
|
io.encodings.string io.binary io.sockets.secure random checksums
|
||||||
checksums checksums.sha urls
|
checksums.sha urls
|
||||||
html.forms
|
html.forms
|
||||||
http.server
|
http.server
|
||||||
http.server.filters
|
http.server.filters
|
||||||
|
@ -79,7 +79,7 @@ GENERIC: logged-in-username ( realm -- username )
|
||||||
swap >>default
|
swap >>default
|
||||||
users-in-db >>users
|
users-in-db >>users
|
||||||
sha-256 >>checksum
|
sha-256 >>checksum
|
||||||
t >>secure ; inline
|
ssl-supported? >>secure ; inline
|
||||||
|
|
||||||
: users ( -- provider )
|
: users ( -- provider )
|
||||||
realm get users>> ;
|
realm get users>> ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors combinators namespaces fry urls urls.secure
|
USING: kernel accessors combinators namespaces fry urls http
|
||||||
http http.server http.server.redirection http.server.responses
|
http.server http.server.redirection http.server.responses
|
||||||
http.server.remapping http.server.filters furnace.utilities ;
|
http.server.remapping http.server.filters furnace.utilities ;
|
||||||
IN: furnace.redirection
|
IN: furnace.redirection
|
||||||
|
|
||||||
|
|
|
@ -23,15 +23,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
||||||
|
|
||||||
: create-dinput ( -- )
|
: create-dinput ( -- )
|
||||||
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
|
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
|
||||||
f <void*> [ f DirectInput8Create ole32-error ] keep *void*
|
f void* <ref> [ f DirectInput8Create ole32-error ] keep void* deref
|
||||||
+dinput+ set-global ;
|
+dinput+ set-global ;
|
||||||
|
|
||||||
: delete-dinput ( -- )
|
: delete-dinput ( -- )
|
||||||
+dinput+ [ com-release f ] change-global ;
|
+dinput+ [ com-release f ] change-global ;
|
||||||
|
|
||||||
: device-for-guid ( guid -- device )
|
: device-for-guid ( guid -- device )
|
||||||
+dinput+ get-global swap f <void*>
|
+dinput+ get-global swap f void* <ref>
|
||||||
[ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
|
[ f IDirectInput8W::CreateDevice ole32-error ] keep void* deref ;
|
||||||
|
|
||||||
: set-coop-level ( device -- )
|
: set-coop-level ( device -- )
|
||||||
+device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
|
+device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
|
||||||
|
@ -303,8 +303,8 @@ CONSTANT: pov-values
|
||||||
} 2cleave ;
|
} 2cleave ;
|
||||||
|
|
||||||
: read-device-buffer ( device buffer count -- buffer count' )
|
: read-device-buffer ( device buffer count -- buffer count' )
|
||||||
[ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
|
[ DIDEVICEOBJECTDATA heap-size ] 2dip uint <ref>
|
||||||
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
|
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep uint deref ;
|
||||||
|
|
||||||
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
|
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
|
||||||
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {
|
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {
|
||||||
|
|
|
@ -129,7 +129,7 @@ ARTICLE: "http.client.errors" "HTTP client errors"
|
||||||
ARTICLE: "http.client" "HTTP client"
|
ARTICLE: "http.client" "HTTP client"
|
||||||
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
|
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
|
||||||
$nl
|
$nl
|
||||||
"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "."
|
"For HTTPS support, you must load the " { $vocab-link "io.sockets.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "io.sockets.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "."
|
||||||
$nl
|
$nl
|
||||||
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
|
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
|
|
|
@ -146,7 +146,7 @@ M: stdin dispose*
|
||||||
|
|
||||||
: wait-for-stdin ( stdin -- size )
|
: wait-for-stdin ( stdin -- size )
|
||||||
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
|
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
|
||||||
[ size>> ssize_t heap-size swap io:stream-read *int ]
|
[ size>> ssize_t heap-size swap io:stream-read int deref ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
:: refill-stdin ( buffer stdin size -- )
|
:: refill-stdin ( buffer stdin size -- )
|
||||||
|
@ -167,11 +167,11 @@ M: stdin refill
|
||||||
M: stdin cancel-operation
|
M: stdin cancel-operation
|
||||||
[ size>> ] [ control>> ] bi [ cancel-operation ] bi@ ;
|
[ size>> ] [ control>> ] bi [ cancel-operation ] bi@ ;
|
||||||
|
|
||||||
: control-write-fd ( -- fd ) &: control_write *uint ;
|
: control-write-fd ( -- fd ) &: control_write uint deref ;
|
||||||
|
|
||||||
: size-read-fd ( -- fd ) &: size_read *uint ;
|
: size-read-fd ( -- fd ) &: size_read uint deref ;
|
||||||
|
|
||||||
: data-read-fd ( -- fd ) &: stdin_read *uint ;
|
: data-read-fd ( -- fd ) &: stdin_read uint deref ;
|
||||||
|
|
||||||
: <stdin> ( -- stdin )
|
: <stdin> ( -- stdin )
|
||||||
stdin new-disposable
|
stdin new-disposable
|
||||||
|
|
|
@ -6,6 +6,6 @@ IN: io.directories.unix.linux
|
||||||
|
|
||||||
M: linux find-next-file ( DIR* -- dirent )
|
M: linux find-next-file ( DIR* -- dirent )
|
||||||
dirent <struct>
|
dirent <struct>
|
||||||
f <void*>
|
f void* <ref>
|
||||||
[ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
|
[ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
|
||||||
*void* [ drop f ] unless ;
|
void* deref [ drop f ] unless ;
|
||||||
|
|
|
@ -37,9 +37,9 @@ HOOK: find-next-file os ( DIR* -- byte-array )
|
||||||
|
|
||||||
M: unix find-next-file ( DIR* -- byte-array )
|
M: unix find-next-file ( DIR* -- byte-array )
|
||||||
dirent <struct>
|
dirent <struct>
|
||||||
f <void*>
|
f void* <ref>
|
||||||
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
|
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
|
||||||
*void* [ drop f ] unless ;
|
void* deref [ drop f ] unless ;
|
||||||
|
|
||||||
: dirent-type>file-type ( ch -- type )
|
: dirent-type>file-type ( ch -- type )
|
||||||
{
|
{
|
||||||
|
|
|
@ -13,8 +13,8 @@ TUPLE: macosx-file-system-info < unix-file-system-info
|
||||||
io-size owner type-id filesystem-subtype ;
|
io-size owner type-id filesystem-subtype ;
|
||||||
|
|
||||||
M: macosx file-systems ( -- array )
|
M: macosx file-systems ( -- array )
|
||||||
f <void*> dup 0 getmntinfo64 dup io-error
|
f void* <ref> dup 0 getmntinfo64 dup io-error
|
||||||
[ *void* ] dip <direct-statfs64-array>
|
[ void* deref ] dip <direct-statfs64-array>
|
||||||
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
|
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
|
||||||
|
|
||||||
M: macosx new-file-system-info macosx-file-system-info new ;
|
M: macosx new-file-system-info macosx-file-system-info new ;
|
||||||
|
|
|
@ -131,7 +131,7 @@ M: winnt init-io ( -- )
|
||||||
ERROR: invalid-file-size n ;
|
ERROR: invalid-file-size n ;
|
||||||
|
|
||||||
: handle>file-size ( handle -- n )
|
: handle>file-size ( handle -- n )
|
||||||
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
|
0 ulonglong <ref> [ GetFileSizeEx win32-error=0/f ] keep ulonglong deref ;
|
||||||
|
|
||||||
ERROR: seek-before-start n ;
|
ERROR: seek-before-start n ;
|
||||||
|
|
||||||
|
@ -249,7 +249,7 @@ M: winnt init-stdio
|
||||||
GetLastError ERROR_ALREADY_EXISTS = not ;
|
GetLastError ERROR_ALREADY_EXISTS = not ;
|
||||||
|
|
||||||
: set-file-pointer ( handle length method -- )
|
: set-file-pointer ( handle length method -- )
|
||||||
[ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
|
[ [ handle>> ] dip d>w/w uint <ref> ] dip SetFilePointer
|
||||||
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
|
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
|
||||||
|
|
||||||
M: windows (file-reader) ( path -- stream )
|
M: windows (file-reader) ( path -- stream )
|
||||||
|
|
|
@ -180,12 +180,12 @@ M: windows wait-for-processes ( -- ? )
|
||||||
GetCurrentProcess ! source process
|
GetCurrentProcess ! source process
|
||||||
swap handle>> ! handle
|
swap handle>> ! handle
|
||||||
GetCurrentProcess ! target process
|
GetCurrentProcess ! target process
|
||||||
f <void*> [ ! target handle
|
f void* <ref> [ ! target handle
|
||||||
DUPLICATE_SAME_ACCESS ! desired access
|
DUPLICATE_SAME_ACCESS ! desired access
|
||||||
TRUE ! inherit handle
|
TRUE ! inherit handle
|
||||||
0 ! options
|
0 ! options
|
||||||
DuplicateHandle win32-error=0/f
|
DuplicateHandle win32-error=0/f
|
||||||
] keep *void* <win32-handle> &dispose ;
|
] keep void* deref <win32-handle> &dispose ;
|
||||||
|
|
||||||
! /dev/null simulation
|
! /dev/null simulation
|
||||||
: null-input ( -- pipe )
|
: null-input ( -- pipe )
|
||||||
|
|
|
@ -32,7 +32,7 @@ TUPLE: win32-monitor < monitor port ;
|
||||||
[ recursive>> 1 0 ? ]
|
[ recursive>> 1 0 ? ]
|
||||||
} cleave
|
} cleave
|
||||||
FILE_NOTIFY_CHANGE_ALL
|
FILE_NOTIFY_CHANGE_ALL
|
||||||
0 <uint>
|
0 uint <ref>
|
||||||
(make-overlapped)
|
(make-overlapped)
|
||||||
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
|
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel namespaces continuations destructors io
|
USING: accessors kernel namespaces continuations destructors io
|
||||||
debugger io.sockets io.sockets.private sequences summary
|
debugger io.sockets io.sockets.private sequences summary
|
||||||
|
@ -11,6 +11,10 @@ SYMBOL: secure-socket-timeout
|
||||||
|
|
||||||
SYMBOL: secure-socket-backend
|
SYMBOL: secure-socket-backend
|
||||||
|
|
||||||
|
HOOK: ssl-supported? secure-socket-backend ( -- ? )
|
||||||
|
|
||||||
|
M: object ssl-supported? f ;
|
||||||
|
|
||||||
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
|
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
|
||||||
|
|
||||||
TUPLE: secure-config
|
TUPLE: secure-config
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
! Copyright (C) 2007, 2010, Slava Pestov, Elie CHAFTARI.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors unix byte-arrays kernel sequences namespaces
|
USING: accessors unix byte-arrays kernel sequences namespaces
|
||||||
math math.order combinators init alien alien.c-types
|
math math.order combinators init alien alien.c-types
|
||||||
|
@ -11,6 +11,8 @@ unix.ffi ;
|
||||||
FROM: io.ports => shutdown ;
|
FROM: io.ports => shutdown ;
|
||||||
IN: io.sockets.secure.unix
|
IN: io.sockets.secure.unix
|
||||||
|
|
||||||
|
M: openssl ssl-supported? t ;
|
||||||
|
|
||||||
M: ssl-handle handle-fd file>> handle-fd ;
|
M: ssl-handle handle-fd file>> handle-fd ;
|
||||||
|
|
||||||
: syscall-error ( r -- * )
|
: syscall-error ( r -- * )
|
||||||
|
|
|
@ -106,10 +106,10 @@ M: ipv4 make-sockaddr ( inet -- sockaddr )
|
||||||
swap
|
swap
|
||||||
[ port>> htons >>port ]
|
[ port>> htons >>port ]
|
||||||
[ host>> "0.0.0.0" or ]
|
[ host>> "0.0.0.0" or ]
|
||||||
[ inet-pton *uint >>addr ] tri ;
|
[ inet-pton uint deref >>addr ] tri ;
|
||||||
|
|
||||||
M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
|
M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
|
||||||
[ addr>> <uint> ] dip inet-ntop <ipv4> ;
|
[ addr>> uint <ref> ] dip inet-ntop <ipv4> ;
|
||||||
|
|
||||||
TUPLE: inet4 < ipv4 { port integer read-only } ;
|
TUPLE: inet4 < ipv4 { port integer read-only } ;
|
||||||
|
|
||||||
|
@ -368,8 +368,8 @@ M: inet present
|
||||||
C: <inet> inet
|
C: <inet> inet
|
||||||
|
|
||||||
M: string resolve-host
|
M: string resolve-host
|
||||||
f prepare-addrinfo f <void*>
|
f prepare-addrinfo f void* <ref>
|
||||||
[ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
|
[ getaddrinfo addrinfo-error ] keep void* deref addrinfo memory>struct
|
||||||
[ parse-addrinfo-list ] keep freeaddrinfo ;
|
[ parse-addrinfo-list ] keep freeaddrinfo ;
|
||||||
|
|
||||||
M: string with-port <inet> ;
|
M: string with-port <inet> ;
|
||||||
|
|
|
@ -16,7 +16,7 @@ IN: io.sockets.unix
|
||||||
socket dup io-error <fd> init-fd |dispose ;
|
socket dup io-error <fd> init-fd |dispose ;
|
||||||
|
|
||||||
: set-socket-option ( fd level opt -- )
|
: set-socket-option ( fd level opt -- )
|
||||||
[ handle-fd ] 2dip 1 <int> dup byte-length setsockopt io-error ;
|
[ handle-fd ] 2dip 1 int <ref> dup byte-length setsockopt io-error ;
|
||||||
|
|
||||||
M: unix addrinfo-error ( n -- )
|
M: unix addrinfo-error ( n -- )
|
||||||
[ gai_strerror throw ] unless-zero ;
|
[ gai_strerror throw ] unless-zero ;
|
||||||
|
@ -39,11 +39,11 @@ M: unix addrspec-of-family ( af -- addrspec )
|
||||||
|
|
||||||
! Client sockets - TCP and Unix domain
|
! Client sockets - TCP and Unix domain
|
||||||
M: object (get-local-address) ( handle remote -- sockaddr )
|
M: object (get-local-address) ( handle remote -- sockaddr )
|
||||||
[ handle-fd ] dip empty-sockaddr/size <int>
|
[ handle-fd ] dip empty-sockaddr/size int <ref>
|
||||||
[ getsockname io-error ] 2keep drop ;
|
[ getsockname io-error ] 2keep drop ;
|
||||||
|
|
||||||
M: object (get-remote-address) ( handle local -- sockaddr )
|
M: object (get-remote-address) ( handle local -- sockaddr )
|
||||||
[ handle-fd ] dip empty-sockaddr/size <int>
|
[ handle-fd ] dip empty-sockaddr/size int <ref>
|
||||||
[ getpeername io-error ] 2keep drop ;
|
[ getpeername io-error ] 2keep drop ;
|
||||||
|
|
||||||
: init-client-socket ( fd -- )
|
: init-client-socket ( fd -- )
|
||||||
|
@ -101,7 +101,7 @@ M: object (server) ( addrspec -- handle )
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: do-accept ( server addrspec -- fd sockaddr )
|
: do-accept ( server addrspec -- fd sockaddr )
|
||||||
[ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
|
[ handle>> handle-fd ] [ empty-sockaddr/size int <ref> ] bi*
|
||||||
[ accept ] 2keep drop ; inline
|
[ accept ] 2keep drop ; inline
|
||||||
|
|
||||||
M: object (accept) ( server addrspec -- fd sockaddr )
|
M: object (accept) ( server addrspec -- fd sockaddr )
|
||||||
|
@ -138,7 +138,7 @@ CONSTANT: packet-size 65536
|
||||||
packet-size ! nbytes
|
packet-size ! nbytes
|
||||||
0 ! flags
|
0 ! flags
|
||||||
sockaddr ! from
|
sockaddr ! from
|
||||||
len <int> ! fromlen
|
len int <ref> ! fromlen
|
||||||
recvfrom dup 0 >=
|
recvfrom dup 0 >=
|
||||||
[ receive-buffer get-global swap memory>byte-array sockaddr ]
|
[ receive-buffer get-global swap memory>byte-array sockaddr ]
|
||||||
[ drop f f ]
|
[ drop f f ]
|
||||||
|
|
|
@ -48,11 +48,11 @@ M: win32-socket dispose* ( stream -- )
|
||||||
opened-socket ;
|
opened-socket ;
|
||||||
|
|
||||||
M: object (get-local-address) ( socket addrspec -- sockaddr )
|
M: object (get-local-address) ( socket addrspec -- sockaddr )
|
||||||
[ handle>> ] dip empty-sockaddr/size <int>
|
[ handle>> ] dip empty-sockaddr/size int <ref>
|
||||||
[ getsockname socket-error ] 2keep drop ;
|
[ getsockname socket-error ] 2keep drop ;
|
||||||
|
|
||||||
M: object (get-remote-address) ( socket addrspec -- sockaddr )
|
M: object (get-remote-address) ( socket addrspec -- sockaddr )
|
||||||
[ handle>> ] dip empty-sockaddr/size <int>
|
[ handle>> ] dip empty-sockaddr/size int <ref>
|
||||||
[ getpeername socket-error ] 2keep drop ;
|
[ getpeername socket-error ] 2keep drop ;
|
||||||
|
|
||||||
: bind-socket ( win32-socket sockaddr len -- )
|
: bind-socket ( win32-socket sockaddr len -- )
|
||||||
|
@ -87,7 +87,7 @@ M: windows (raw) ( addrspec -- handle )
|
||||||
[ SOCK_RAW server-socket ] with-destructors ;
|
[ SOCK_RAW server-socket ] with-destructors ;
|
||||||
|
|
||||||
: malloc-int ( n -- alien )
|
: malloc-int ( n -- alien )
|
||||||
<int> malloc-byte-array ; inline
|
int <ref> malloc-byte-array ; inline
|
||||||
|
|
||||||
M: winnt WSASocket-flags ( -- DWORD )
|
M: winnt WSASocket-flags ( -- DWORD )
|
||||||
WSA_FLAG_OVERLAPPED ;
|
WSA_FLAG_OVERLAPPED ;
|
||||||
|
@ -181,7 +181,8 @@ TUPLE: AcceptEx-args port
|
||||||
} cleave AcceptEx drop winsock-error ; inline
|
} cleave AcceptEx drop winsock-error ; inline
|
||||||
|
|
||||||
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
|
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
|
||||||
f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
|
f void* <ref> 0 int <ref> f void* <ref>
|
||||||
|
[ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;
|
||||||
|
|
||||||
: extract-remote-address ( AcceptEx -- sockaddr )
|
: extract-remote-address ( AcceptEx -- sockaddr )
|
||||||
[
|
[
|
||||||
|
@ -246,7 +247,7 @@ TUPLE: WSARecvFrom-args port
|
||||||
[
|
[
|
||||||
[ port>> addr>> empty-sockaddr dup ]
|
[ port>> addr>> empty-sockaddr dup ]
|
||||||
[ lpFrom>> ]
|
[ lpFrom>> ]
|
||||||
[ lpFromLen>> *int ]
|
[ lpFromLen>> int deref ]
|
||||||
tri memcpy
|
tri memcpy
|
||||||
] bi ; inline
|
] bi ; inline
|
||||||
|
|
||||||
|
@ -278,7 +279,7 @@ TUPLE: WSASendTo-args port
|
||||||
swap make-send-buffer >>lpBuffers
|
swap make-send-buffer >>lpBuffers
|
||||||
1 >>dwBufferCount
|
1 >>dwBufferCount
|
||||||
0 >>dwFlags
|
0 >>dwFlags
|
||||||
0 <uint> >>lpNumberOfBytesSent
|
0 uint <ref> >>lpNumberOfBytesSent
|
||||||
(make-overlapped) >>lpOverlapped ; inline
|
(make-overlapped) >>lpOverlapped ; inline
|
||||||
|
|
||||||
: call-WSASendTo ( WSASendTo -- )
|
: call-WSASendTo ( WSASendTo -- )
|
||||||
|
|
|
@ -156,9 +156,9 @@ TUPLE: mach-error error-code error-string ;
|
||||||
io-objects-from-iterator* [ release-io-object ] dip ;
|
io-objects-from-iterator* [ release-io-object ] dip ;
|
||||||
|
|
||||||
: properties-from-io-object ( o -- o nsdictionary )
|
: properties-from-io-object ( o -- o nsdictionary )
|
||||||
dup f <void*> [
|
dup f void* <ref> [
|
||||||
kCFAllocatorDefault kNilOptions
|
kCFAllocatorDefault kNilOptions
|
||||||
IORegistryEntryCreateCFProperties mach-error
|
IORegistryEntryCreateCFProperties mach-error
|
||||||
]
|
]
|
||||||
keep *void* ;
|
keep void* deref ;
|
||||||
|
|
||||||
|
|
|
@ -41,6 +41,6 @@ SYMBOL: half
|
||||||
2 >>align
|
2 >>align
|
||||||
2 >>align-first
|
2 >>align-first
|
||||||
[ >float ] >>unboxer-quot
|
[ >float ] >>unboxer-quot
|
||||||
\ half define-primitive-type
|
\ half typedef
|
||||||
|
|
||||||
>>
|
>>
|
||||||
|
|
|
@ -142,7 +142,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
||||||
[ 1 { uint } ] dip with-out-parameters ; inline
|
[ 1 { uint } ] dip with-out-parameters ; inline
|
||||||
|
|
||||||
: (delete-gl-object) ( id quot -- )
|
: (delete-gl-object) ( id quot -- )
|
||||||
[ 1 swap <uint> ] dip call ; inline
|
[ 1 swap uint <ref> ] dip call ; inline
|
||||||
|
|
||||||
: gen-gl-buffer ( -- id )
|
: gen-gl-buffer ( -- id )
|
||||||
[ glGenBuffers ] (gen-gl-object) ;
|
[ glGenBuffers ] (gen-gl-object) ;
|
||||||
|
|
|
@ -8,7 +8,7 @@ SPECIALIZED-ARRAY: uint
|
||||||
IN: opengl.shaders
|
IN: opengl.shaders
|
||||||
|
|
||||||
: with-gl-shader-source-ptr ( string quot -- )
|
: with-gl-shader-source-ptr ( string quot -- )
|
||||||
swap ascii malloc-string [ <void*> swap call ] keep free ; inline
|
swap ascii malloc-string [ void* <ref> swap call ] keep free ; inline
|
||||||
|
|
||||||
: <gl-shader> ( source kind -- shader )
|
: <gl-shader> ( source kind -- shader )
|
||||||
glCreateShader dup rot
|
glCreateShader dup rot
|
||||||
|
@ -47,7 +47,7 @@ IN: opengl.shaders
|
||||||
: gl-shader-info-log ( shader -- log )
|
: gl-shader-info-log ( shader -- log )
|
||||||
dup gl-shader-info-log-length dup [
|
dup gl-shader-info-log-length dup [
|
||||||
1 calloc &free
|
1 calloc &free
|
||||||
[ 0 <int> swap glGetShaderInfoLog ] keep
|
[ 0 int <ref> swap glGetShaderInfoLog ] keep
|
||||||
ascii alien>string
|
ascii alien>string
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
@ -90,7 +90,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
|
||||||
: gl-program-info-log ( program -- log )
|
: gl-program-info-log ( program -- log )
|
||||||
dup gl-program-info-log-length dup [
|
dup gl-program-info-log-length dup [
|
||||||
1 calloc &free
|
1 calloc &free
|
||||||
[ 0 <int> swap glGetProgramInfoLog ] keep
|
[ 0 int <ref> swap glGetProgramInfoLog ] keep
|
||||||
ascii alien>string
|
ascii alien>string
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
@ -107,7 +107,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
|
||||||
|
|
||||||
: gl-program-shaders ( program -- shaders )
|
: gl-program-shaders ( program -- shaders )
|
||||||
dup gl-program-shaders-length 2 *
|
dup gl-program-shaders-length 2 *
|
||||||
0 <int>
|
0 int <ref>
|
||||||
over <uint-array>
|
over <uint-array>
|
||||||
[ glGetAttachedShaders ] keep [ zero? not ] filter ;
|
[ glGetAttachedShaders ] keep [ zero? not ] filter ;
|
||||||
|
|
||||||
|
|
|
@ -90,8 +90,8 @@ ERROR: too-many-samples seq n ;
|
||||||
secure-random-generator get swap with-random ; inline
|
secure-random-generator get swap with-random ; inline
|
||||||
|
|
||||||
: uniform-random-float ( min max -- n )
|
: uniform-random-float ( min max -- n )
|
||||||
4 random-bytes underlying>> *uint >float
|
4 random-bytes underlying>> uint deref >float
|
||||||
4 random-bytes underlying>> *uint >float
|
4 random-bytes underlying>> uint deref >float
|
||||||
2.0 32 ^ * +
|
2.0 32 ^ * +
|
||||||
[ over - 2.0 -64 ^ * ] dip
|
[ over - 2.0 -64 ^ * ] dip
|
||||||
* + ; inline
|
* + ; inline
|
||||||
|
|
|
@ -94,7 +94,7 @@ $nl
|
||||||
""
|
""
|
||||||
"FUNCTION: void get_device_info ( int* length ) ;"
|
"FUNCTION: void get_device_info ( int* length ) ;"
|
||||||
""
|
""
|
||||||
"0 <int> [ get_device_info ] keep <direct-int-array> ."
|
"0 int <ref> [ get_device_info ] keep <direct-int-array> ."
|
||||||
}
|
}
|
||||||
"For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "."
|
"For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "."
|
||||||
$nl
|
$nl
|
||||||
|
|
|
@ -11,23 +11,23 @@ LIBRARY: libc
|
||||||
FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
|
FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
|
||||||
|
|
||||||
: make-int-array ( seq -- byte-array )
|
: make-int-array ( seq -- byte-array )
|
||||||
[ <int> ] map concat ;
|
[ int <ref> ] map concat ;
|
||||||
|
|
||||||
: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
|
: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
|
||||||
over [ f 0 sysctl io-error ] dip ;
|
over [ f 0 sysctl io-error ] dip ;
|
||||||
|
|
||||||
: sysctl-query ( seq n -- byte-array )
|
: sysctl-query ( seq n -- byte-array )
|
||||||
[ [ make-int-array ] [ length ] bi ] dip
|
[ [ make-int-array ] [ length ] bi ] dip
|
||||||
[ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
|
[ <byte-array> ] [ uint <ref> ] bi (sysctl-query) ;
|
||||||
|
|
||||||
: sysctl-query-string ( seq -- n )
|
: sysctl-query-string ( seq -- n )
|
||||||
4096 sysctl-query utf8 alien>string ;
|
4096 sysctl-query utf8 alien>string ;
|
||||||
|
|
||||||
: sysctl-query-uint ( seq -- n )
|
: sysctl-query-uint ( seq -- n )
|
||||||
4 sysctl-query *uint ;
|
4 sysctl-query uint deref ;
|
||||||
|
|
||||||
: sysctl-query-ulonglong ( seq -- n )
|
: sysctl-query-ulonglong ( seq -- n )
|
||||||
8 sysctl-query *ulonglong ;
|
8 sysctl-query ulonglong deref ;
|
||||||
|
|
||||||
: machine ( -- str ) { 6 1 } sysctl-query-string ;
|
: machine ( -- str ) { 6 1 } sysctl-query-string ;
|
||||||
: model ( -- str ) { 6 2 } sysctl-query-string ;
|
: model ( -- str ) { 6 2 } sysctl-query-string ;
|
||||||
|
|
|
@ -95,10 +95,10 @@ M: winnt available-virtual-mem ( -- n )
|
||||||
|
|
||||||
: computer-name ( -- string )
|
: computer-name ( -- string )
|
||||||
MAX_COMPUTERNAME_LENGTH 1 +
|
MAX_COMPUTERNAME_LENGTH 1 +
|
||||||
[ <byte-array> dup ] keep <uint>
|
[ <byte-array> dup ] keep uint <ref>
|
||||||
GetComputerName win32-error=0/f alien>native-string ;
|
GetComputerName win32-error=0/f alien>native-string ;
|
||||||
|
|
||||||
: username ( -- string )
|
: username ( -- string )
|
||||||
UNLEN 1 +
|
UNLEN 1 +
|
||||||
[ <byte-array> dup ] keep <uint>
|
[ <byte-array> dup ] keep uint <ref>
|
||||||
GetUserName win32-error=0/f alien>native-string ;
|
GetUserName win32-error=0/f alien>native-string ;
|
||||||
|
|
|
@ -128,7 +128,7 @@ CONSTANT: window-control>styleMask
|
||||||
|
|
||||||
: make-context-transparent ( view -- )
|
: make-context-transparent ( view -- )
|
||||||
-> openGLContext
|
-> openGLContext
|
||||||
0 <int> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
|
0 int <ref> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
|
||||||
|
|
||||||
M:: cocoa-ui-backend (open-window) ( world -- )
|
M:: cocoa-ui-backend (open-window) ( world -- )
|
||||||
world [ [ dim>> ] dip <FactorView> ]
|
world [ [ dim>> ] dip <FactorView> ]
|
||||||
|
|
|
@ -332,7 +332,7 @@ CLASS: FactorView < NSOpenGLView NSTextInput
|
||||||
]
|
]
|
||||||
|
|
||||||
: sync-refresh-to-screen ( GLView -- )
|
: sync-refresh-to-screen ( GLView -- )
|
||||||
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
|
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 int <ref>
|
||||||
CGLSetParameter drop ;
|
CGLSetParameter drop ;
|
||||||
|
|
||||||
: <FactorView> ( dim pixel-format -- view )
|
: <FactorView> ( dim pixel-format -- view )
|
||||||
|
|
|
@ -16,6 +16,7 @@ ui.pixel-formats.private memoize classes colors
|
||||||
specialized-arrays classes.struct alien.data ;
|
specialized-arrays classes.struct alien.data ;
|
||||||
FROM: namespaces => set ;
|
FROM: namespaces => set ;
|
||||||
SPECIALIZED-ARRAY: POINT
|
SPECIALIZED-ARRAY: POINT
|
||||||
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: ui.backend.windows
|
IN: ui.backend.windows
|
||||||
|
|
||||||
SINGLETON: windows-ui-backend
|
SINGLETON: windows-ui-backend
|
||||||
|
@ -66,7 +67,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
|
||||||
>WGL_ARB
|
>WGL_ARB
|
||||||
[ drop f ] [
|
[ drop f ] [
|
||||||
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
|
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
|
||||||
first <int> { int }
|
first int <ref> { int }
|
||||||
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
|
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
|
||||||
with-out-parameters
|
with-out-parameters
|
||||||
] if-empty ;
|
] if-empty ;
|
||||||
|
@ -168,7 +169,7 @@ M: windows-ui-backend (pixel-format-attribute)
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: lo-word ( wparam -- lo ) <short> *short ; inline
|
: lo-word ( wparam -- lo ) c:short <ref> c:short deref ; inline
|
||||||
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
|
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
|
||||||
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
|
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
|
||||||
: GET_APPCOMMAND_LPARAM ( lParam -- appCommand )
|
: GET_APPCOMMAND_LPARAM ( lParam -- appCommand )
|
||||||
|
|
|
@ -22,10 +22,10 @@ GENERIC: group-struct ( obj -- group/f )
|
||||||
|
|
||||||
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
|
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
|
||||||
[ \ unix.ffi:group <struct> ] dip over 4096
|
[ \ unix.ffi:group <struct> ] dip over 4096
|
||||||
[ <byte-array> ] keep f <void*> ;
|
[ <byte-array> ] keep f void* <ref> ;
|
||||||
|
|
||||||
: check-group-struct ( group-struct ptr -- group-struct/f )
|
: check-group-struct ( group-struct ptr -- group-struct/f )
|
||||||
*void* [ drop f ] unless ;
|
void* deref [ drop f ] unless ;
|
||||||
|
|
||||||
M: integer group-struct ( id -- group/f )
|
M: integer group-struct ( id -- group/f )
|
||||||
(group-struct)
|
(group-struct)
|
||||||
|
@ -67,13 +67,13 @@ ERROR: no-group string ;
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: >groups ( byte-array n -- groups )
|
: >groups ( byte-array n -- groups )
|
||||||
[ 4 grouping:group ] dip head-slice [ *uint group-name ] map ;
|
[ 4 grouping:group ] dip head-slice [ uint deref group-name ] map ;
|
||||||
|
|
||||||
: (user-groups) ( string -- seq )
|
: (user-groups) ( string -- seq )
|
||||||
#! first group is -1337, legacy unix code
|
#! first group is -1337, legacy unix code
|
||||||
-1337 unix.ffi:NGROUPS_MAX [ 4 * <byte-array> ] keep
|
-1337 unix.ffi:NGROUPS_MAX [ 4 * <byte-array> ] keep
|
||||||
<int> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
|
int <ref> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
|
||||||
[ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
|
[ 4 tail-slice ] [ int deref 1 - ] bi* >groups ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -22,5 +22,3 @@ TYPEDEF: __uint32_t fflags_t
|
||||||
TYPEDEF: long ssize_t
|
TYPEDEF: long ssize_t
|
||||||
TYPEDEF: int pid_t
|
TYPEDEF: int pid_t
|
||||||
TYPEDEF: long time_t
|
TYPEDEF: long time_t
|
||||||
|
|
||||||
ALIAS: <time_t> <long>
|
|
||||||
|
|
|
@ -32,4 +32,4 @@ TYPEDEF: ulonglong __fsfilcnt64_t
|
||||||
TYPEDEF: ulonglong ino64_t
|
TYPEDEF: ulonglong ino64_t
|
||||||
TYPEDEF: ulonglong off64_t
|
TYPEDEF: ulonglong off64_t
|
||||||
|
|
||||||
ALIAS: <time_t> <long>
|
: <time_t> ( n -- long ) long <ref> ;
|
||||||
|
|
|
@ -33,7 +33,3 @@ TYPEDEF: char[512] io_string_t
|
||||||
TYPEDEF: kern_return_t IOReturn
|
TYPEDEF: kern_return_t IOReturn
|
||||||
|
|
||||||
TYPEDEF: uint IOOptionBits
|
TYPEDEF: uint IOOptionBits
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
ALIAS: <time_t> <long>
|
|
||||||
|
|
|
@ -17,8 +17,6 @@ TYPEDEF: long ssize_t
|
||||||
TYPEDEF: int pid_t
|
TYPEDEF: int pid_t
|
||||||
TYPEDEF: int time_t
|
TYPEDEF: int time_t
|
||||||
|
|
||||||
ALIAS: <time_t> <int>
|
|
||||||
|
|
||||||
cell-bits {
|
cell-bits {
|
||||||
{ 32 [ "unix.types.netbsd.32" require ] }
|
{ 32 [ "unix.types.netbsd.32" require ] }
|
||||||
{ 64 [ "unix.types.netbsd.64" require ] }
|
{ 64 [ "unix.types.netbsd.64" require ] }
|
||||||
|
|
|
@ -17,5 +17,3 @@ TYPEDEF: __uint32_t fflags_t
|
||||||
TYPEDEF: long ssize_t
|
TYPEDEF: long ssize_t
|
||||||
TYPEDEF: int pid_t
|
TYPEDEF: int pid_t
|
||||||
TYPEDEF: int time_t
|
TYPEDEF: int time_t
|
||||||
|
|
||||||
ALIAS: <time_t> <int>
|
|
|
@ -8,14 +8,14 @@ IN: unix.utilities
|
||||||
SPECIALIZED-ARRAY: void*
|
SPECIALIZED-ARRAY: void*
|
||||||
|
|
||||||
: more? ( alien -- ? )
|
: more? ( alien -- ? )
|
||||||
{ [ ] [ *void* ] } 1&& ;
|
{ [ ] [ void* deref ] } 1&& ;
|
||||||
|
|
||||||
: advance ( void* -- void* )
|
: advance ( void* -- void* )
|
||||||
cell swap <displaced-alien> ;
|
cell swap <displaced-alien> ;
|
||||||
|
|
||||||
: alien>strings ( alien encoding -- strings )
|
: alien>strings ( alien encoding -- strings )
|
||||||
[ [ dup more? ] ] dip
|
[ [ dup more? ] ] dip
|
||||||
'[ [ advance ] [ *void* _ alien>string ] bi ]
|
'[ [ advance ] [ void* deref _ alien>string ] bi ]
|
||||||
produce nip ;
|
produce nip ;
|
||||||
|
|
||||||
: strings>alien ( strings encoding -- array )
|
: strings>alien ( strings encoding -- array )
|
||||||
|
|
|
@ -187,3 +187,4 @@ SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
|
||||||
USE: vocabs.loader
|
USE: vocabs.loader
|
||||||
|
|
||||||
{ "urls" "prettyprint" } "urls.prettyprint" require-when
|
{ "urls" "prettyprint" } "urls.prettyprint" require-when
|
||||||
|
{ "urls" "io.sockets.secure" } "urls.secure" require-when
|
||||||
|
|
|
@ -58,7 +58,7 @@ C: <test-implementation> test-implementation
|
||||||
dup +guinea-pig-implementation+ set [ drop
|
dup +guinea-pig-implementation+ set [ drop
|
||||||
|
|
||||||
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
||||||
E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
||||||
20 1array [
|
20 1array [
|
||||||
+guinea-pig-implementation+ get
|
+guinea-pig-implementation+ get
|
||||||
[ 20 IInherited::setX ]
|
[ 20 IInherited::setX ]
|
||||||
|
|
|
@ -11,7 +11,7 @@ IN: windows.com.syntax
|
||||||
MACRO: com-invoke ( n return parameters -- )
|
MACRO: com-invoke ( n return parameters -- )
|
||||||
[ 2nip length ] 3keep
|
[ 2nip length ] 3keep
|
||||||
'[
|
'[
|
||||||
_ npick *void* _ cell * alien-cell _ _
|
_ npick void* deref _ cell * alien-cell _ _
|
||||||
stdcall alien-indirect
|
stdcall alien-indirect
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
|
|
|
@ -63,7 +63,7 @@ TYPEDEF: FIXED_INFO* PFIXED_INFO
|
||||||
FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
|
FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
|
||||||
|
|
||||||
: get-fixed-info ( -- FIXED_INFO )
|
: get-fixed-info ( -- FIXED_INFO )
|
||||||
FIXED_INFO <struct> dup byte-length <ulong>
|
FIXED_INFO <struct> dup byte-length ulong <ref>
|
||||||
[ GetNetworkParams n>win32-error-check ] 2keep drop ;
|
[ GetNetworkParams n>win32-error-check ] 2keep drop ;
|
||||||
|
|
||||||
: dns-server-ips ( -- sequence )
|
: dns-server-ips ( -- sequence )
|
||||||
|
|
|
@ -21,7 +21,7 @@ CONSTANT: registry-value-max-length 16384
|
||||||
[ key subkey mode ] dip n>win32-error-string
|
[ key subkey mode ] dip n>win32-error-string
|
||||||
open-key-failed
|
open-key-failed
|
||||||
] if
|
] if
|
||||||
] keep *uint ;
|
] keep uint deref ;
|
||||||
|
|
||||||
:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
|
:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
|
||||||
hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
|
hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
|
||||||
|
@ -29,8 +29,8 @@ CONSTANT: registry-value-max-length 16384
|
||||||
DWORD <c-object>
|
DWORD <c-object>
|
||||||
f :> ret!
|
f :> ret!
|
||||||
[ RegCreateKeyEx ret! ] 2keep
|
[ RegCreateKeyEx ret! ] 2keep
|
||||||
[ *uint ]
|
[ uint deref ]
|
||||||
[ *uint REG_CREATED_NEW_KEY = ] bi*
|
[ uint deref REG_CREATED_NEW_KEY = ] bi*
|
||||||
ret ERROR_SUCCESS = [
|
ret ERROR_SUCCESS = [
|
||||||
[
|
[
|
||||||
hKey lpSubKey 0 lpClass dwOptions samDesired
|
hKey lpSubKey 0 lpClass dwOptions samDesired
|
||||||
|
@ -67,11 +67,11 @@ CONSTANT: registry-value-max-length 16384
|
||||||
length 2 * <byte-array> ;
|
length 2 * <byte-array> ;
|
||||||
|
|
||||||
:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
|
:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
|
||||||
buffer length <uint> :> pdword
|
buffer length uint <ref> :> pdword
|
||||||
key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep
|
key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep
|
||||||
rot :> ret
|
rot :> ret
|
||||||
ret ERROR_SUCCESS = [
|
ret ERROR_SUCCESS = [
|
||||||
*uint head
|
uint deref head
|
||||||
] [
|
] [
|
||||||
ret ERROR_MORE_DATA = [
|
ret ERROR_MORE_DATA = [
|
||||||
2drop
|
2drop
|
||||||
|
@ -116,7 +116,7 @@ TUPLE: registry-enum-key ;
|
||||||
key
|
key
|
||||||
MAX_PATH
|
MAX_PATH
|
||||||
dup TCHAR <c-array> dup :> class-buffer
|
dup TCHAR <c-array> dup :> class-buffer
|
||||||
swap <int> dup :> class-buffer-length
|
swap int <ref> dup :> class-buffer-length
|
||||||
f
|
f
|
||||||
DWORD <c-object> dup :> sub-keys
|
DWORD <c-object> dup :> sub-keys
|
||||||
DWORD <c-object> dup :> longest-subkey
|
DWORD <c-object> dup :> longest-subkey
|
||||||
|
@ -130,13 +130,13 @@ TUPLE: registry-enum-key ;
|
||||||
ret ERROR_SUCCESS = [
|
ret ERROR_SUCCESS = [
|
||||||
key
|
key
|
||||||
class-buffer
|
class-buffer
|
||||||
sub-keys *uint
|
sub-keys uint deref
|
||||||
longest-subkey *uint
|
longest-subkey uint deref
|
||||||
longest-class-string *uint
|
longest-class-string uint deref
|
||||||
#values *uint
|
#values uint deref
|
||||||
max-value *uint
|
max-value uint deref
|
||||||
max-value-data *uint
|
max-value-data uint deref
|
||||||
security-descriptor *uint
|
security-descriptor uint deref
|
||||||
last-write-time FILETIME>timestamp
|
last-write-time FILETIME>timestamp
|
||||||
registry-info boa
|
registry-info boa
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -42,9 +42,9 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
|
||||||
f ! piDx
|
f ! piDx
|
||||||
f ! pTabdef
|
f ! pTabdef
|
||||||
f ! pbInClass
|
f ! pbInClass
|
||||||
f <void*> ! pssa
|
f void* <ref> ! pssa
|
||||||
[ ScriptStringAnalyse ] keep
|
[ ScriptStringAnalyse ] keep
|
||||||
[ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
|
[ ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
|
||||||
|
|
||||||
: set-dc-colors ( dc font -- )
|
: set-dc-colors ( dc font -- )
|
||||||
[ background>> color>RGB SetBkColor drop ]
|
[ background>> color>RGB SetBkColor drop ]
|
||||||
|
@ -103,7 +103,7 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
M: script-string dispose*
|
M: script-string dispose*
|
||||||
ssa>> <void*> ScriptStringFree ole32-error ;
|
ssa>> void* <ref> ScriptStringFree ole32-error ;
|
||||||
|
|
||||||
SYMBOL: cached-script-strings
|
SYMBOL: cached-script-strings
|
||||||
|
|
||||||
|
|
|
@ -28,11 +28,11 @@ TUPLE: x-clipboard atom contents ;
|
||||||
CurrentTime XConvertSelection drop ;
|
CurrentTime XConvertSelection drop ;
|
||||||
|
|
||||||
: snarf-property ( prop-return -- string )
|
: snarf-property ( prop-return -- string )
|
||||||
dup *void* [ *void* utf8 alien>string ] [ drop f ] if ;
|
dup void* deref [ void* deref utf8 alien>string ] [ drop f ] if ;
|
||||||
|
|
||||||
: window-property ( win prop delete? -- string )
|
: window-property ( win prop delete? -- string )
|
||||||
[ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
|
[ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
|
||||||
0 <Atom> 0 <int> 0 <ulong> 0 <ulong> f <void*>
|
0 Atom <ref> 0 int <ref> 0 ulong <ref> 0 ulong <ref> f void* <ref>
|
||||||
[ XGetWindowProperty drop ] keep snarf-property ;
|
[ XGetWindowProperty drop ] keep snarf-property ;
|
||||||
|
|
||||||
: selection-from-event ( event window -- string )
|
: selection-from-event ( event window -- string )
|
||||||
|
@ -53,7 +53,7 @@ TUPLE: x-clipboard atom contents ;
|
||||||
[ dpy get ] dip
|
[ dpy get ] dip
|
||||||
[ requestor>> ]
|
[ requestor>> ]
|
||||||
[ property>> XA_TIMESTAMP 32 PropModeReplace ]
|
[ property>> XA_TIMESTAMP 32 PropModeReplace ]
|
||||||
[ time>> <int> ] tri
|
[ time>> int <ref> ] tri
|
||||||
1 XChangeProperty drop ;
|
1 XChangeProperty drop ;
|
||||||
|
|
||||||
: send-notify ( evt prop -- )
|
: send-notify ( evt prop -- )
|
||||||
|
|
|
@ -1,9 +1,8 @@
|
||||||
! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
|
! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel math math.bitwise math.vectors
|
USING: accessors alien.c-types kernel math math.bitwise
|
||||||
namespaces sequences arrays fry classes.struct literals
|
math.vectors namespaces sequences arrays fry classes.struct
|
||||||
x11 x11.xlib x11.constants x11.events
|
literals x11 x11.xlib x11.constants x11.events x11.glx ;
|
||||||
x11.glx ;
|
|
||||||
IN: x11.windows
|
IN: x11.windows
|
||||||
|
|
||||||
CONSTANT: create-window-mask
|
CONSTANT: create-window-mask
|
||||||
|
@ -79,7 +78,7 @@ CONSTANT: event-mask
|
||||||
dpy get swap XDestroyWindow drop ;
|
dpy get swap XDestroyWindow drop ;
|
||||||
|
|
||||||
: set-closable ( win -- )
|
: set-closable ( win -- )
|
||||||
dpy get swap XA_WM_DELETE_WINDOW <Atom> 1
|
dpy get swap XA_WM_DELETE_WINDOW Atom <ref> 1
|
||||||
XSetWMProtocols drop ;
|
XSetWMProtocols drop ;
|
||||||
|
|
||||||
: map-window ( win -- ) dpy get swap XMapWindow drop ;
|
: map-window ( win -- ) dpy get swap XMapWindow drop ;
|
||||||
|
|
|
@ -42,7 +42,7 @@ SYMBOL: keysym
|
||||||
|
|
||||||
: prepare-lookup ( -- )
|
: prepare-lookup ( -- )
|
||||||
buf-size <uint-array> keybuf set
|
buf-size <uint-array> keybuf set
|
||||||
0 <KeySym> keysym set ;
|
0 KeySym <ref> keysym set ;
|
||||||
|
|
||||||
: finish-lookup ( len -- string keysym )
|
: finish-lookup ( len -- string keysym )
|
||||||
keybuf get swap 2 * head utf16n decode
|
keybuf get swap 2 * head utf16n decode
|
||||||
|
@ -51,7 +51,7 @@ SYMBOL: keysym
|
||||||
: lookup-string ( event xic -- string keysym )
|
: lookup-string ( event xic -- string keysym )
|
||||||
[
|
[
|
||||||
prepare-lookup
|
prepare-lookup
|
||||||
swap keybuf get buf-size keysym get 0 <int>
|
swap keybuf get buf-size keysym get 0 int <ref>
|
||||||
XwcLookupString
|
XwcLookupString
|
||||||
finish-lookup
|
finish-lookup
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
|
@ -5,7 +5,7 @@ x11.constants x11.xinput2.ffi ;
|
||||||
IN: x11.xinput2
|
IN: x11.xinput2
|
||||||
|
|
||||||
: (xi2-available?) ( display -- ? )
|
: (xi2-available?) ( display -- ? )
|
||||||
2 0 [ <int> ] bi@
|
2 0 [ int <ref> ] bi@
|
||||||
XIQueryVersion
|
XIQueryVersion
|
||||||
{
|
{
|
||||||
{ BadRequest [ f ] }
|
{ BadRequest [ f ] }
|
||||||
|
|
|
@ -48,17 +48,11 @@ TYPEDEF: int Bool
|
||||||
TYPEDEF: ulong VisualID
|
TYPEDEF: ulong VisualID
|
||||||
TYPEDEF: ulong Time
|
TYPEDEF: ulong Time
|
||||||
|
|
||||||
ALIAS: <XID> <ulong>
|
: *XID ( bytes -- n ) ulong deref ;
|
||||||
ALIAS: <Window> <XID>
|
|
||||||
ALIAS: <Drawable> <XID>
|
|
||||||
ALIAS: <KeySym> <XID>
|
|
||||||
ALIAS: <Atom> <ulong>
|
|
||||||
|
|
||||||
ALIAS: *XID *ulong
|
|
||||||
ALIAS: *Window *XID
|
ALIAS: *Window *XID
|
||||||
ALIAS: *Drawable *XID
|
ALIAS: *Drawable *XID
|
||||||
ALIAS: *KeySym *XID
|
ALIAS: *KeySym *XID
|
||||||
ALIAS: *Atom *ulong
|
: *Atom ( bytes -- n ) ulong deref ;
|
||||||
!
|
!
|
||||||
! 2 - Display Functions
|
! 2 - Display Functions
|
||||||
!
|
!
|
||||||
|
|
|
@ -22,9 +22,9 @@ ERROR: invalid-demangle-args name ;
|
||||||
"_Z" head? ;
|
"_Z" head? ;
|
||||||
|
|
||||||
:: demangle ( mangled-name -- c++-name )
|
:: demangle ( mangled-name -- c++-name )
|
||||||
0 <ulong> :> length
|
0 ulong <ref> :> length
|
||||||
0 <int> :> status [
|
0 int <ref> :> status [
|
||||||
mangled-name ascii string>alien f length status __cxa_demangle &(free) :> demangled-buf
|
mangled-name ascii string>alien f length status __cxa_demangle &(free) :> demangled-buf
|
||||||
mangled-name status *int demangle-error
|
mangled-name status int deref demangle-error
|
||||||
demangled-buf ascii alien>string
|
demangled-buf ascii alien>string
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
|
@ -122,7 +122,7 @@ ERROR: audio-context-not-available device-name ;
|
||||||
|
|
||||||
:: flush-source ( al-source -- )
|
:: flush-source ( al-source -- )
|
||||||
al-source alSourceStop
|
al-source alSourceStop
|
||||||
0 c:<uint> :> dummy-buffer
|
0 c:uint c:<ref> :> dummy-buffer
|
||||||
al-source AL_BUFFERS_PROCESSED get-source-param [
|
al-source AL_BUFFERS_PROCESSED get-source-param [
|
||||||
al-source 1 dummy-buffer alSourceUnqueueBuffers
|
al-source 1 dummy-buffer alSourceUnqueueBuffers
|
||||||
] times
|
] times
|
||||||
|
@ -161,7 +161,7 @@ ERROR: audio-context-not-available device-name ;
|
||||||
audio-clip t >>done? drop
|
audio-clip t >>done? drop
|
||||||
] [
|
] [
|
||||||
al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData
|
al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData
|
||||||
al-source 1 al-buffer c:<uint> alSourceQueueBuffers
|
al-source 1 al-buffer c:uint c:<ref> alSourceQueueBuffers
|
||||||
] if
|
] if
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
|
@ -190,10 +190,10 @@ M: static-audio-clip (update-audio-clip)
|
||||||
|
|
||||||
M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- )
|
M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- )
|
||||||
audio-clip al-source>> :> al-source
|
audio-clip al-source>> :> al-source
|
||||||
0 c:<uint> :> buffer
|
0 c:uint c:<ref> :> buffer
|
||||||
al-source AL_BUFFERS_PROCESSED get-source-param [
|
al-source AL_BUFFERS_PROCESSED get-source-param [
|
||||||
al-source 1 buffer alSourceUnqueueBuffers
|
al-source 1 buffer alSourceUnqueueBuffers
|
||||||
audio-clip buffer c:*uint queue-clip-buffer
|
audio-clip buffer c:uint c:deref queue-clip-buffer
|
||||||
] times ;
|
] times ;
|
||||||
|
|
||||||
: update-audio-clip ( audio-clip -- )
|
: update-audio-clip ( audio-clip -- )
|
||||||
|
@ -256,7 +256,7 @@ M: audio-engine dispose*
|
||||||
audio-engine get-available-source :> al-source
|
audio-engine get-available-source :> al-source
|
||||||
|
|
||||||
al-source [
|
al-source [
|
||||||
1 0 c:<uint> [ alGenBuffers ] keep c:*uint :> al-buffer
|
1 0 c:uint c:<ref> [ alGenBuffers ] keep c:uint c:deref :> al-buffer
|
||||||
al-buffer audio { [ openal-format ] [ data>> ] [ size>> ] [ sample-rate>> ] } cleave
|
al-buffer audio { [ openal-format ] [ data>> ] [ size>> ] [ sample-rate>> ] } cleave
|
||||||
alBufferData
|
alBufferData
|
||||||
|
|
||||||
|
@ -301,7 +301,7 @@ M: audio-clip dispose*
|
||||||
|
|
||||||
M: static-audio-clip dispose*
|
M: static-audio-clip dispose*
|
||||||
[ call-next-method ]
|
[ call-next-method ]
|
||||||
[ [ 1 ] dip al-buffer>> c:<uint> alDeleteBuffers ] bi ;
|
[ [ 1 ] dip al-buffer>> c:uint c:<ref> alDeleteBuffers ] bi ;
|
||||||
|
|
||||||
M: streaming-audio-clip dispose*
|
M: streaming-audio-clip dispose*
|
||||||
[ call-next-method ]
|
[ call-next-method ]
|
||||||
|
|
|
@ -157,7 +157,7 @@ ERROR: no-vorbis-in-ogg ;
|
||||||
[ init-vorbis-codec ] if ;
|
[ init-vorbis-codec ] if ;
|
||||||
|
|
||||||
: get-pending-decoded-audio ( vorbis-stream -- pcm len )
|
: get-pending-decoded-audio ( vorbis-stream -- pcm len )
|
||||||
dsp-state>> f <void*> [ vorbis_synthesis_pcmout ] keep *void* swap ;
|
dsp-state>> f void* <ref> [ vorbis_synthesis_pcmout ] keep void* deref swap ;
|
||||||
|
|
||||||
: float>short-sample ( float -- short )
|
: float>short-sample ( float -- short )
|
||||||
-32767.5 * 0.5 - >integer -32768 32767 clamp ; inline
|
-32767.5 * 0.5 - >integer -32768 32767 clamp ; inline
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: ui.gadgets.panes prettyprint io sequences ;
|
USING: io kernel math.parser sequences ui.gadgets.panes ;
|
||||||
IN: benchmark.ui-panes
|
IN: benchmark.ui-panes
|
||||||
|
|
||||||
: ui-pane-benchmark ( -- )
|
: ui-pane-benchmark ( -- )
|
||||||
<pane> <pane-stream> [ 10000 iota [ . ] each ] with-output-stream* ;
|
[ 10000 iota [ number>string print ] each ] make-pane drop ;
|
||||||
|
|
||||||
MAIN: ui-pane-benchmark
|
MAIN: ui-pane-benchmark
|
||||||
|
|
|
@ -10,13 +10,13 @@ IN: cuda.contexts
|
||||||
: create-context ( device flags -- context )
|
: create-context ( device flags -- context )
|
||||||
swap
|
swap
|
||||||
[ CUcontext <c-object> ] 2dip
|
[ CUcontext <c-object> ] 2dip
|
||||||
[ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
|
[ cuCtxCreate cuda-error ] 3keep 2drop void* deref ; inline
|
||||||
|
|
||||||
: sync-context ( -- )
|
: sync-context ( -- )
|
||||||
cuCtxSynchronize cuda-error ; inline
|
cuCtxSynchronize cuda-error ; inline
|
||||||
|
|
||||||
: context-device ( -- n )
|
: context-device ( -- n )
|
||||||
CUdevice <c-object> [ cuCtxGetDevice cuda-error ] keep *int ; inline
|
CUdevice <c-object> [ cuCtxGetDevice cuda-error ] keep int deref ; inline
|
||||||
|
|
||||||
: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
|
: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
|
||||||
|
|
||||||
|
|
|
@ -16,7 +16,7 @@ TUPLE: cuda-error code ;
|
||||||
dup CUDA_SUCCESS = [ drop ] [ \ cuda-error boa throw ] if ;
|
dup CUDA_SUCCESS = [ drop ] [ \ cuda-error boa throw ] if ;
|
||||||
|
|
||||||
: cuda-version ( -- n )
|
: cuda-version ( -- n )
|
||||||
c:int <c-object> [ cuDriverGetVersion cuda-error ] keep c:*int ;
|
c:int <c-object> [ cuDriverGetVersion cuda-error ] keep c:int c:deref ;
|
||||||
|
|
||||||
: init-cuda ( -- )
|
: init-cuda ( -- )
|
||||||
0 cuInit cuda-error ; inline
|
0 cuInit cuda-error ; inline
|
||||||
|
|
|
@ -8,10 +8,11 @@ prettyprint sequences ;
|
||||||
IN: cuda.devices
|
IN: cuda.devices
|
||||||
|
|
||||||
: #cuda-devices ( -- n )
|
: #cuda-devices ( -- n )
|
||||||
int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
|
int <c-object> [ cuDeviceGetCount cuda-error ] keep int deref ;
|
||||||
|
|
||||||
: n>cuda-device ( n -- device )
|
: n>cuda-device ( n -- device )
|
||||||
[ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
|
[ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep
|
||||||
|
drop int deref ;
|
||||||
|
|
||||||
: enumerate-cuda-devices ( -- devices )
|
: enumerate-cuda-devices ( -- devices )
|
||||||
#cuda-devices iota [ n>cuda-device ] map ;
|
#cuda-devices iota [ n>cuda-device ] map ;
|
||||||
|
@ -34,17 +35,17 @@ IN: cuda.devices
|
||||||
: cuda-device-capability ( n -- pair )
|
: cuda-device-capability ( n -- pair )
|
||||||
[ int <c-object> int <c-object> ] dip
|
[ int <c-object> int <c-object> ] dip
|
||||||
[ cuDeviceComputeCapability cuda-error ]
|
[ cuDeviceComputeCapability cuda-error ]
|
||||||
[ drop [ *int ] bi@ ] 3bi 2array ;
|
[ drop [ int deref ] bi@ ] 3bi 2array ;
|
||||||
|
|
||||||
: cuda-device-memory ( n -- bytes )
|
: cuda-device-memory ( n -- bytes )
|
||||||
[ uint <c-object> ] dip
|
[ uint <c-object> ] dip
|
||||||
[ cuDeviceTotalMem cuda-error ]
|
[ cuDeviceTotalMem cuda-error ]
|
||||||
[ drop *uint ] 2bi ;
|
[ drop uint deref ] 2bi ;
|
||||||
|
|
||||||
: cuda-device-attribute ( attribute n -- n )
|
: cuda-device-attribute ( attribute n -- n )
|
||||||
[ int <c-object> ] 2dip
|
[ int <c-object> ] 2dip
|
||||||
[ cuDeviceGetAttribute cuda-error ]
|
[ cuDeviceGetAttribute cuda-error ]
|
||||||
[ 2drop *int ] 3bi ;
|
[ 2drop int deref ] 3bi ;
|
||||||
|
|
||||||
: cuda-device. ( n -- )
|
: cuda-device. ( n -- )
|
||||||
{
|
{
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: cuda.gl
|
||||||
: create-gl-cuda-context ( device flags -- context )
|
: create-gl-cuda-context ( device flags -- context )
|
||||||
swap
|
swap
|
||||||
[ CUcontext <c-object> ] 2dip
|
[ CUcontext <c-object> ] 2dip
|
||||||
[ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
|
[ cuGLCtxCreate cuda-error ] 3keep 2drop void* deref ; inline
|
||||||
|
|
||||||
: with-gl-cuda-context ( device flags quot -- )
|
: with-gl-cuda-context ( device flags quot -- )
|
||||||
[ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
|
[ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
|
||||||
|
@ -15,20 +15,20 @@ IN: cuda.gl
|
||||||
: gl-buffer>resource ( gl-buffer flags -- resource )
|
: gl-buffer>resource ( gl-buffer flags -- resource )
|
||||||
enum>number
|
enum>number
|
||||||
[ CUgraphicsResource <c-object> ] 2dip
|
[ CUgraphicsResource <c-object> ] 2dip
|
||||||
[ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop *void* ; inline
|
[ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop void* deref ; inline
|
||||||
|
|
||||||
: buffer>resource ( buffer flags -- resource )
|
: buffer>resource ( buffer flags -- resource )
|
||||||
[ handle>> ] dip gl-buffer>resource ; inline
|
[ handle>> ] dip gl-buffer>resource ; inline
|
||||||
|
|
||||||
: map-resource ( resource -- device-ptr size )
|
: map-resource ( resource -- device-ptr size )
|
||||||
[ 1 swap <void*> f cuGraphicsMapResources cuda-error ] [
|
[ 1 swap void* <ref> f cuGraphicsMapResources cuda-error ] [
|
||||||
[ CUdeviceptr <c-object> uint <c-object> ] dip
|
[ CUdeviceptr <c-object> uint <c-object> ] dip
|
||||||
[ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
|
[ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
|
||||||
[ *uint ] [ *uint ] bi*
|
[ uint deref ] [ uint deref ] bi*
|
||||||
] bi ; inline
|
] bi ; inline
|
||||||
|
|
||||||
: unmap-resource ( resource -- )
|
: unmap-resource ( resource -- )
|
||||||
1 swap <void*> f cuGraphicsUnmapResources cuda-error ; inline
|
1 swap void* <ref> f cuGraphicsUnmapResources cuda-error ; inline
|
||||||
|
|
||||||
DESTRUCTOR: unmap-resource
|
DESTRUCTOR: unmap-resource
|
||||||
|
|
||||||
|
|
|
@ -75,7 +75,7 @@ PRIVATE>
|
||||||
|
|
||||||
: load-module ( path -- module )
|
: load-module ( path -- module )
|
||||||
[ CUmodule <c-object> ] dip
|
[ CUmodule <c-object> ] dip
|
||||||
[ cuModuleLoad cuda-error ] 2keep drop c:*void* ;
|
[ cuModuleLoad cuda-error ] 2keep drop c:void* c:deref ;
|
||||||
|
|
||||||
: unload-module ( module -- )
|
: unload-module ( module -- )
|
||||||
cuModuleUnload cuda-error ;
|
cuModuleUnload cuda-error ;
|
||||||
|
@ -152,7 +152,7 @@ MACRO: cuda-arguments ( c-types abi -- quot: ( args... function -- ) )
|
||||||
|
|
||||||
: get-function-ptr ( module string -- function )
|
: get-function-ptr ( module string -- function )
|
||||||
[ CUfunction <c-object> ] 2dip
|
[ CUfunction <c-object> ] 2dip
|
||||||
[ cuModuleGetFunction cuda-error ] 3keep 2drop c:*void* ;
|
[ cuModuleGetFunction cuda-error ] 3keep 2drop c:void* c:deref ;
|
||||||
|
|
||||||
: cached-module ( module-name -- alien )
|
: cached-module ( module-name -- alien )
|
||||||
lookup-cuda-library
|
lookup-cuda-library
|
||||||
|
@ -172,7 +172,7 @@ MACRO: cuda-invoke ( module-name function-name arguments -- )
|
||||||
: cuda-global* ( module-name symbol-name -- device-ptr size )
|
: cuda-global* ( module-name symbol-name -- device-ptr size )
|
||||||
[ CUdeviceptr <c-object> c:uint <c-object> ] 2dip
|
[ CUdeviceptr <c-object> c:uint <c-object> ] 2dip
|
||||||
[ cached-module ] dip
|
[ cached-module ] dip
|
||||||
'[ _ _ cuModuleGetGlobal cuda-error ] 2keep [ c:*uint ] bi@ ; inline
|
'[ _ _ cuModuleGetGlobal cuda-error ] 2keep [ c:uint c:deref ] bi@ ; inline
|
||||||
|
|
||||||
: cuda-global ( module-name symbol-name -- device-ptr )
|
: cuda-global ( module-name symbol-name -- device-ptr )
|
||||||
cuda-global* drop ; inline
|
cuda-global* drop ; inline
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: cuda.memory
|
||||||
: cuda-malloc ( n -- ptr )
|
: cuda-malloc ( n -- ptr )
|
||||||
[ CUdeviceptr <c-object> ] dip
|
[ CUdeviceptr <c-object> ] dip
|
||||||
'[ _ cuMemAlloc cuda-error ] keep
|
'[ _ cuMemAlloc cuda-error ] keep
|
||||||
c:*int ; inline
|
c:int c:deref ; inline
|
||||||
|
|
||||||
: cuda-malloc-type ( n type -- ptr )
|
: cuda-malloc-type ( n type -- ptr )
|
||||||
c:heap-size * cuda-malloc ; inline
|
c:heap-size * cuda-malloc ; inline
|
||||||
|
|
|
@ -67,9 +67,9 @@ PRIVATE>
|
||||||
:: ecdsa-sign ( DGST -- sig )
|
:: ecdsa-sign ( DGST -- sig )
|
||||||
ec-key-handle :> KEY
|
ec-key-handle :> KEY
|
||||||
KEY ECDSA_size dup ssl-error <byte-array> :> SIG
|
KEY ECDSA_size dup ssl-error <byte-array> :> SIG
|
||||||
0 <uint> :> LEN
|
0 uint <ref> :> LEN
|
||||||
0 DGST dup length SIG LEN KEY ECDSA_sign ssl-error
|
0 DGST dup length SIG LEN KEY ECDSA_sign ssl-error
|
||||||
LEN *uint SIG resize ;
|
LEN uint deref SIG resize ;
|
||||||
|
|
||||||
: ecdsa-verify ( dgst sig -- ? )
|
: ecdsa-verify ( dgst sig -- ? )
|
||||||
ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
|
ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
|
||||||
|
|
|
@ -57,7 +57,7 @@ TUPLE: buffer < gpu-object
|
||||||
} case ; inline
|
} case ; inline
|
||||||
|
|
||||||
: get-buffer-int ( target enum -- value )
|
: get-buffer-int ( target enum -- value )
|
||||||
0 <int> [ glGetBufferParameteriv ] keep *int ; inline
|
0 int <ref> [ glGetBufferParameteriv ] keep int deref ; inline
|
||||||
|
|
||||||
: bind-buffer ( buffer -- target )
|
: bind-buffer ( buffer -- target )
|
||||||
[ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; inline
|
[ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; inline
|
||||||
|
|
|
@ -18,7 +18,8 @@ TUPLE: renderbuffer < gpu-object
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: get-framebuffer-int ( enum -- value )
|
: get-framebuffer-int ( enum -- value )
|
||||||
GL_RENDERBUFFER swap 0 <int> [ glGetRenderbufferParameteriv ] keep *int ;
|
GL_RENDERBUFFER swap 0 int <ref>
|
||||||
|
[ glGetRenderbufferParameteriv ] keep int deref ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -199,7 +199,7 @@ TR: hyphens>underscores "-" "_" ;
|
||||||
name length 1 + :> name-buffer-length
|
name length 1 + :> name-buffer-length
|
||||||
{
|
{
|
||||||
index name-buffer-length dup
|
index name-buffer-length dup
|
||||||
[ f 0 <int> 0 <int> ] dip <byte-array>
|
[ f 0 int <ref> 0 int <ref> ] dip <byte-array>
|
||||||
[ glGetTransformFeedbackVarying ] 3keep
|
[ glGetTransformFeedbackVarying ] 3keep
|
||||||
ascii alien>string
|
ascii alien>string
|
||||||
vertex-attribute assert-feedback-attribute
|
vertex-attribute assert-feedback-attribute
|
||||||
|
|
|
@ -416,11 +416,11 @@ M: mask-state set-gpu-state*
|
||||||
[ set-gpu-state* ] if ; inline
|
[ set-gpu-state* ] if ; inline
|
||||||
|
|
||||||
: get-gl-bool ( enum -- value )
|
: get-gl-bool ( enum -- value )
|
||||||
0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
|
0 uchar <ref> [ glGetBooleanv ] keep uchar deref c-bool> ;
|
||||||
: get-gl-int ( enum -- value )
|
: get-gl-int ( enum -- value )
|
||||||
0 <int> [ glGetIntegerv ] keep *int ;
|
0 int <ref> [ glGetIntegerv ] keep int deref ;
|
||||||
: get-gl-float ( enum -- value )
|
: get-gl-float ( enum -- value )
|
||||||
0 <float> [ glGetFloatv ] keep *float ;
|
0 c:float <ref> [ glGetFloatv ] keep c:float deref ;
|
||||||
|
|
||||||
: get-gl-bools ( enum count -- value )
|
: get-gl-bools ( enum count -- value )
|
||||||
<byte-array> [ glGetBooleanv ] keep [ c-bool> ] { } map-as ;
|
<byte-array> [ glGetBooleanv ] keep [ c-bool> ] { } map-as ;
|
||||||
|
|
|
@ -171,8 +171,8 @@ ERROR: undefined-find-nth m n seq quot ;
|
||||||
[ [ name>> { "form" "input" } member? ] filter ] map ;
|
[ [ name>> { "form" "input" } member? ] filter ] map ;
|
||||||
|
|
||||||
: find-html-objects ( vector string -- vector' )
|
: find-html-objects ( vector string -- vector' )
|
||||||
dupd find-opening-tags-by-name
|
over find-opening-tags-by-name
|
||||||
[ first2 find-between* ] curry map ;
|
[ first2 find-between* ] with map ;
|
||||||
|
|
||||||
: form-action ( vector -- string )
|
: form-action ( vector -- string )
|
||||||
[ name>> "form" = ] find nip "action" attribute ;
|
[ name>> "form" = ] find nip "action" attribute ;
|
||||||
|
|
|
@ -38,7 +38,7 @@ SYMBOL: js-context
|
||||||
: eval-js ( string -- result-string )
|
: eval-js ( string -- result-string )
|
||||||
[ js-context get dup ] dip
|
[ js-context get dup ] dip
|
||||||
JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
|
JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
|
||||||
[ JSEvaluateScript ] keep *void*
|
[ JSEvaluateScript ] keep void* deref
|
||||||
dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
|
dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
|
||||||
|
|
||||||
: eval-js-standalone ( string -- result-string )
|
: eval-js-standalone ( string -- result-string )
|
||||||
|
|
|
@ -25,9 +25,9 @@ TUPLE: jit ee mps ;
|
||||||
LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
|
LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
|
||||||
|
|
||||||
: remove-provider ( provider -- )
|
: remove-provider ( provider -- )
|
||||||
current-jit ee>> value>> swap value>> f <void*> f <void*>
|
current-jit ee>> value>> swap value>> f void* <ref> f void* <ref>
|
||||||
[ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
|
[ LLVMRemoveModuleProvider drop ] 2keep void* deref [ llvm-throw ] when*
|
||||||
*void* module new swap >>value
|
void* deref module new swap >>value
|
||||||
[ value>> remove-functions ] with-disposal ;
|
[ value>> remove-functions ] with-disposal ;
|
||||||
|
|
||||||
: remove-module ( name -- )
|
: remove-module ( name -- )
|
||||||
|
@ -44,5 +44,5 @@ TUPLE: jit ee mps ;
|
||||||
|
|
||||||
: function-pointer ( name -- alien )
|
: function-pointer ( name -- alien )
|
||||||
current-jit ee>> value>> dup
|
current-jit ee>> value>> dup
|
||||||
rot f <void*> [ LLVMFindFunction drop ] keep
|
rot f void* <ref> [ LLVMFindFunction drop ] keep
|
||||||
*void* LLVMGetPointerToGlobal ;
|
void* deref LLVMGetPointerToGlobal ;
|
||||||
|
|
|
@ -7,9 +7,9 @@ IN: llvm.reader
|
||||||
|
|
||||||
: buffer>module ( buffer -- module )
|
: buffer>module ( buffer -- module )
|
||||||
[
|
[
|
||||||
value>> f <void*> f <void*>
|
value>> f void* <ref> f void* <ref>
|
||||||
[ LLVMParseBitcode drop ] 2keep
|
[ LLVMParseBitcode drop ] 2keep
|
||||||
*void* [ llvm-throw ] when* *void*
|
void* deref [ llvm-throw ] when* void* deref
|
||||||
module new swap >>value
|
module new swap >>value
|
||||||
] with-disposal ;
|
] with-disposal ;
|
||||||
|
|
||||||
|
|
|
@ -33,9 +33,9 @@ M: engine dispose* value>> LLVMDisposeExecutionEngine ;
|
||||||
|
|
||||||
: (engine) ( provider -- engine )
|
: (engine) ( provider -- engine )
|
||||||
[
|
[
|
||||||
value>> f <void*> f <void*>
|
value>> f void* <ref> f void* <ref>
|
||||||
[ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
|
[ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
|
||||||
*void* [ llvm-throw ] when* *void*
|
void* deref [ llvm-throw ] when* void* deref
|
||||||
]
|
]
|
||||||
[ t >>disposed drop ] bi
|
[ t >>disposed drop ] bi
|
||||||
engine <dispose> ;
|
engine <dispose> ;
|
||||||
|
@ -57,6 +57,6 @@ TUPLE: buffer value disposed ;
|
||||||
M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
|
M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
|
||||||
|
|
||||||
: <buffer> ( path -- module )
|
: <buffer> ( path -- module )
|
||||||
f <void*> f <void*>
|
f void* <ref> f void* <ref>
|
||||||
[ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
|
[ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
|
||||||
*void* [ llvm-throw ] when* *void* buffer <dispose> ;
|
void* deref [ llvm-throw ] when* void* deref buffer <dispose> ;
|
||||||
|
|
|
@ -9,6 +9,6 @@ LIBRARY: alut
|
||||||
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
|
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
|
||||||
|
|
||||||
M: macosx load-wav-file ( path -- format data size frequency )
|
M: macosx load-wav-file ( path -- format data size frequency )
|
||||||
0 <int> f <void*> 0 <int> 0 <int>
|
0 int <ref> f void* <ref> 0 int <ref> 0 int <ref>
|
||||||
[ alutLoadWAVFile ] 4 nkeep
|
[ alutLoadWAVFile ] 4 nkeep
|
||||||
[ [ [ *int ] dip *void* ] dip *int ] dip *int ;
|
[ [ [ int deref ] dip void* deref ] dip int deref ] dip int deref ;
|
||||||
|
|
|
@ -9,6 +9,9 @@ LIBRARY: alut
|
||||||
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
|
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
|
||||||
|
|
||||||
M: object load-wav-file ( filename -- format data size frequency )
|
M: object load-wav-file ( filename -- format data size frequency )
|
||||||
0 <int> f <void*> 0 <int> 0 <int>
|
0 int <ref>
|
||||||
[ 0 <char> alutLoadWAVFile ] 4 nkeep
|
f void* <ref>
|
||||||
{ [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
|
0 int <ref>
|
||||||
|
0 int <ref>
|
||||||
|
[ 0 char <ref> alutLoadWAVFile ] 4 nkeep
|
||||||
|
{ [ int deref ] [ void* deref ] [ int deref ] [ int deref ] } spread ;
|
||||||
|
|
|
@ -264,13 +264,13 @@ DESTRUCTOR: alcDestroyContext
|
||||||
alSourcei ;
|
alSourcei ;
|
||||||
|
|
||||||
: get-source-param ( source param -- value )
|
: get-source-param ( source param -- value )
|
||||||
0 <uint> dup [ alGetSourcei ] dip *uint ;
|
0 uint <ref> dup [ alGetSourcei ] dip uint deref ;
|
||||||
|
|
||||||
: set-buffer-param ( source param value -- )
|
: set-buffer-param ( source param value -- )
|
||||||
alBufferi ;
|
alBufferi ;
|
||||||
|
|
||||||
: get-buffer-param ( source param -- value )
|
: get-buffer-param ( source param -- value )
|
||||||
0 <uint> dup [ alGetBufferi ] dip *uint ;
|
0 uint <ref> dup [ alGetBufferi ] dip uint deref ;
|
||||||
|
|
||||||
: source-play ( source -- ) alSourcePlay ;
|
: source-play ( source -- ) alSourcePlay ;
|
||||||
|
|
||||||
|
|
|
@ -29,33 +29,33 @@ ERROR: cl-error err ;
|
||||||
str-alien str-buffer dup length memcpy str-alien ;
|
str-alien str-buffer dup length memcpy str-alien ;
|
||||||
|
|
||||||
:: opencl-square ( in -- out )
|
:: opencl-square ( in -- out )
|
||||||
0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
|
0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
|
||||||
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep first
|
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep first
|
||||||
CL_DEVICE_TYPE_DEFAULT 1 f <void*> [ f clGetDeviceIDs cl-success ] keep *void* :> device-id
|
CL_DEVICE_TYPE_DEFAULT 1 f void* <ref> [ f clGetDeviceIDs cl-success ] keep void* deref :> device-id
|
||||||
f 1 device-id <void*> f f 0 <int> [ clCreateContext ] keep *int cl-success :> context
|
f 1 device-id void* <ref> f f 0 int <ref> [ clCreateContext ] keep int deref cl-success :> context
|
||||||
context device-id 0 0 <int> [ clCreateCommandQueue ] keep *int cl-success :> queue
|
context device-id 0 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success :> queue
|
||||||
|
|
||||||
[
|
[
|
||||||
context 1 kernel-source cl-string-array <void*>
|
context 1 kernel-source cl-string-array void* <ref>
|
||||||
f 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
|
f 0 int <ref> [ clCreateProgramWithSource ] keep int deref cl-success
|
||||||
[ 0 f f f f clBuildProgram cl-success ]
|
[ 0 f f f f clBuildProgram cl-success ]
|
||||||
[ "square" cl-string-array 0 <int> [ clCreateKernel ] keep *int cl-success ]
|
[ "square" cl-string-array 0 int <ref> [ clCreateKernel ] keep int deref cl-success ]
|
||||||
[ ] tri
|
[ ] tri
|
||||||
] with-destructors :> ( kernel program )
|
] with-destructors :> ( kernel program )
|
||||||
|
|
||||||
context CL_MEM_READ_ONLY in byte-length f
|
context CL_MEM_READ_ONLY in byte-length f
|
||||||
0 <int> [ clCreateBuffer ] keep *int cl-success :> input
|
0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> input
|
||||||
|
|
||||||
context CL_MEM_WRITE_ONLY in byte-length f
|
context CL_MEM_WRITE_ONLY in byte-length f
|
||||||
0 <int> [ clCreateBuffer ] keep *int cl-success :> output
|
0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> output
|
||||||
|
|
||||||
queue input CL_TRUE 0 in byte-length in 0 f f clEnqueueWriteBuffer cl-success
|
queue input CL_TRUE 0 in byte-length in 0 f f clEnqueueWriteBuffer cl-success
|
||||||
|
|
||||||
kernel 0 cl_mem heap-size input <void*> clSetKernelArg cl-success
|
kernel 0 cl_mem heap-size input void* <ref> clSetKernelArg cl-success
|
||||||
kernel 1 cl_mem heap-size output <void*> clSetKernelArg cl-success
|
kernel 1 cl_mem heap-size output void* <ref> clSetKernelArg cl-success
|
||||||
kernel 2 uint heap-size in length <uint> clSetKernelArg cl-success
|
kernel 2 uint heap-size in length uint <ref> clSetKernelArg cl-success
|
||||||
|
|
||||||
queue kernel 1 f in length <ulonglong> f
|
queue kernel 1 f in length ulonglong <ref> f
|
||||||
0 f f clEnqueueNDRangeKernel cl-success
|
0 f f clEnqueueNDRangeKernel cl-success
|
||||||
|
|
||||||
queue clFinish cl-success
|
queue clFinish cl-success
|
||||||
|
|
|
@ -32,7 +32,7 @@ __kernel void square(
|
||||||
cl-read-access num-bytes in <cl-buffer> &dispose :> in-buffer
|
cl-read-access num-bytes in <cl-buffer> &dispose :> in-buffer
|
||||||
cl-write-access num-bytes f <cl-buffer> &dispose :> out-buffer
|
cl-write-access num-bytes f <cl-buffer> &dispose :> out-buffer
|
||||||
|
|
||||||
kernel in-buffer out-buffer num-floats <uint> 3array
|
kernel in-buffer out-buffer num-floats uint <ref> 3array
|
||||||
{ num-floats } [ ] cl-queue-kernel &dispose drop
|
{ num-floats } [ ] cl-queue-kernel &dispose drop
|
||||||
|
|
||||||
cl-finish
|
cl-finish
|
||||||
|
|
|
@ -17,7 +17,7 @@ ERROR: cl-error err ;
|
||||||
dup f = [ cl-error ] [ drop ] if ; inline
|
dup f = [ cl-error ] [ drop ] if ; inline
|
||||||
|
|
||||||
: info-data-size ( handle name info-quot -- size_t )
|
: info-data-size ( handle name info-quot -- size_t )
|
||||||
[ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
|
[ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
|
||||||
|
|
||||||
: info-data-bytes ( handle name info-quot size -- bytes )
|
: info-data-bytes ( handle name info-quot size -- bytes )
|
||||||
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
|
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
|
||||||
|
@ -26,7 +26,7 @@ ERROR: cl-error err ;
|
||||||
[ 3dup info-data-size info-data-bytes ] dip call ; inline
|
[ 3dup info-data-size info-data-bytes ] dip call ; inline
|
||||||
|
|
||||||
: 2info-data-size ( handle1 handle2 name info-quot -- size_t )
|
: 2info-data-size ( handle1 handle2 name info-quot -- size_t )
|
||||||
[ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
|
[ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
|
||||||
|
|
||||||
: 2info-data-bytes ( handle1 handle2 name info-quot size -- bytes )
|
: 2info-data-bytes ( handle1 handle2 name info-quot size -- bytes )
|
||||||
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
|
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
|
||||||
|
@ -35,22 +35,22 @@ ERROR: cl-error err ;
|
||||||
[ 4dup 2info-data-size 2info-data-bytes ] dip call ; inline
|
[ 4dup 2info-data-size 2info-data-bytes ] dip call ; inline
|
||||||
|
|
||||||
: info-bool ( handle name quot -- ? )
|
: info-bool ( handle name quot -- ? )
|
||||||
[ *uint CL_TRUE = ] info ; inline
|
[ uint deref CL_TRUE = ] info ; inline
|
||||||
|
|
||||||
: info-ulong ( handle name quot -- ulong )
|
: info-ulong ( handle name quot -- ulong )
|
||||||
[ *ulonglong ] info ; inline
|
[ ulonglong deref ] info ; inline
|
||||||
|
|
||||||
: info-int ( handle name quot -- int )
|
: info-int ( handle name quot -- int )
|
||||||
[ *int ] info ; inline
|
[ int deref ] info ; inline
|
||||||
|
|
||||||
: info-uint ( handle name quot -- uint )
|
: info-uint ( handle name quot -- uint )
|
||||||
[ *uint ] info ; inline
|
[ uint deref ] info ; inline
|
||||||
|
|
||||||
: info-size_t ( handle name quot -- size_t )
|
: info-size_t ( handle name quot -- size_t )
|
||||||
[ *size_t ] info ; inline
|
[ size_t deref ] info ; inline
|
||||||
|
|
||||||
: 2info-size_t ( handle1 handle2 name quot -- size_t )
|
: 2info-size_t ( handle1 handle2 name quot -- size_t )
|
||||||
[ *size_t ] 2info ; inline
|
[ size_t deref ] 2info ; inline
|
||||||
|
|
||||||
: info-string ( handle name quot -- string )
|
: info-string ( handle name quot -- string )
|
||||||
[ ascii decode 1 head* ] info ; inline
|
[ ascii decode 1 head* ] info ; inline
|
||||||
|
@ -311,7 +311,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
|
||||||
|
|
||||||
: platform-devices ( platform-id -- devices )
|
: platform-devices ( platform-id -- devices )
|
||||||
CL_DEVICE_TYPE_ALL [
|
CL_DEVICE_TYPE_ALL [
|
||||||
0 f 0 <uint> [ clGetDeviceIDs cl-success ] keep *uint
|
0 f 0 uint <ref> [ clGetDeviceIDs cl-success ] keep uint deref
|
||||||
] [
|
] [
|
||||||
rot dup <void*-array> [ f clGetDeviceIDs cl-success ] keep
|
rot dup <void*-array> [ f clGetDeviceIDs cl-success ] keep
|
||||||
] 2bi ; inline
|
] 2bi ; inline
|
||||||
|
@ -340,7 +340,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
|
||||||
[ length ]
|
[ length ]
|
||||||
[ strings>char*-array ]
|
[ strings>char*-array ]
|
||||||
[ [ length ] size_t-array{ } map-as ] tri
|
[ [ length ] size_t-array{ } map-as ] tri
|
||||||
0 <int> [ clCreateProgramWithSource ] keep *int cl-success
|
0 int <ref> [ clCreateProgramWithSource ] keep int deref cl-success
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
:: (build-program) ( program-handle device options -- program )
|
:: (build-program) ( program-handle device options -- program )
|
||||||
|
@ -403,7 +403,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
|
||||||
[ clGetEventProfilingInfo ] info-ulong ;
|
[ clGetEventProfilingInfo ] info-ulong ;
|
||||||
|
|
||||||
: bind-kernel-arg-buffer ( kernel index buffer -- )
|
: bind-kernel-arg-buffer ( kernel index buffer -- )
|
||||||
[ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
|
[ handle>> ] [ cl_mem heap-size ] [ handle>> void* deref ] tri*
|
||||||
clSetKernelArg cl-success ; inline
|
clSetKernelArg cl-success ; inline
|
||||||
|
|
||||||
: bind-kernel-arg-data ( kernel index byte-array -- )
|
: bind-kernel-arg-data ( kernel index byte-array -- )
|
||||||
|
@ -425,7 +425,7 @@ PRIVATE>
|
||||||
] dip bind ; inline
|
] dip bind ; inline
|
||||||
|
|
||||||
: cl-platforms ( -- platforms )
|
: cl-platforms ( -- platforms )
|
||||||
0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
|
0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
|
||||||
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep
|
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep
|
||||||
[
|
[
|
||||||
dup
|
dup
|
||||||
|
@ -437,14 +437,14 @@ PRIVATE>
|
||||||
: <cl-context> ( devices -- cl-context )
|
: <cl-context> ( devices -- cl-context )
|
||||||
[ f ] dip
|
[ f ] dip
|
||||||
[ length ] [ [ id>> ] void*-array{ } map-as ] bi
|
[ length ] [ [ id>> ] void*-array{ } map-as ] bi
|
||||||
f f 0 <int> [ clCreateContext ] keep *int cl-success
|
f f 0 int <ref> [ clCreateContext ] keep int deref cl-success
|
||||||
cl-context new-disposable swap >>handle ;
|
cl-context new-disposable swap >>handle ;
|
||||||
|
|
||||||
: <cl-queue> ( context device out-of-order? profiling? -- command-queue )
|
: <cl-queue> ( context device out-of-order? profiling? -- command-queue )
|
||||||
[ [ handle>> ] [ id>> ] bi* ] 2dip
|
[ [ handle>> ] [ id>> ] bi* ] 2dip
|
||||||
[ [ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE ] [ 0 ] if ]
|
[ [ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE ] [ 0 ] if ]
|
||||||
[ [ CL_QUEUE_PROFILING_ENABLE ] [ 0 ] if ] bi* bitor
|
[ [ CL_QUEUE_PROFILING_ENABLE ] [ 0 ] if ] bi* bitor
|
||||||
0 <int> [ clCreateCommandQueue ] keep *int cl-success
|
0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success
|
||||||
cl-queue new-disposable swap >>handle ;
|
cl-queue new-disposable swap >>handle ;
|
||||||
|
|
||||||
: cl-out-of-order-execution? ( command-queue -- ? )
|
: cl-out-of-order-execution? ( command-queue -- ? )
|
||||||
|
@ -462,7 +462,7 @@ PRIVATE>
|
||||||
[ buffer-access-constant ]
|
[ buffer-access-constant ]
|
||||||
[ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor
|
[ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor
|
||||||
] 2dip
|
] 2dip
|
||||||
0 <int> [ clCreateBuffer ] keep *int cl-success
|
0 int <ref> [ clCreateBuffer ] keep int deref cl-success
|
||||||
cl-buffer new-disposable swap >>handle ;
|
cl-buffer new-disposable swap >>handle ;
|
||||||
|
|
||||||
: cl-read-buffer ( buffer-range -- byte-array )
|
: cl-read-buffer ( buffer-range -- byte-array )
|
||||||
|
@ -488,7 +488,7 @@ PRIVATE>
|
||||||
[ [ buffer>> handle>> ] [ offset>> ] bi ]
|
[ [ buffer>> handle>> ] [ offset>> ] bi ]
|
||||||
tri* swapd
|
tri* swapd
|
||||||
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
|
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
|
||||||
f <void*> [ clEnqueueCopyBuffer cl-success ] keep *void* cl-event
|
f void* <ref> [ clEnqueueCopyBuffer cl-success ] keep void* deref cl-event
|
||||||
new-disposable swap >>handle ;
|
new-disposable swap >>handle ;
|
||||||
|
|
||||||
: cl-queue-read-buffer ( buffer-range alien dependent-events -- event )
|
: cl-queue-read-buffer ( buffer-range alien dependent-events -- event )
|
||||||
|
@ -496,7 +496,7 @@ PRIVATE>
|
||||||
[ (current-cl-queue) handle>> ] dip
|
[ (current-cl-queue) handle>> ] dip
|
||||||
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
|
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
|
||||||
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
|
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
|
||||||
f <void*> [ clEnqueueReadBuffer cl-success ] keep *void* cl-event
|
f void* <ref> [ clEnqueueReadBuffer cl-success ] keep void* <ref> cl-event
|
||||||
new-disposable swap >>handle ;
|
new-disposable swap >>handle ;
|
||||||
|
|
||||||
: cl-queue-write-buffer ( buffer-range alien dependent-events -- event )
|
: cl-queue-write-buffer ( buffer-range alien dependent-events -- event )
|
||||||
|
@ -504,7 +504,7 @@ PRIVATE>
|
||||||
[ (current-cl-queue) handle>> ] dip
|
[ (current-cl-queue) handle>> ] dip
|
||||||
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
|
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
|
||||||
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
|
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
|
||||||
f <void*> [ clEnqueueWriteBuffer cl-success ] keep *void* cl-event
|
f void* <ref> [ clEnqueueWriteBuffer cl-success ] keep void* deref cl-event
|
||||||
new-disposable swap >>handle ;
|
new-disposable swap >>handle ;
|
||||||
|
|
||||||
: <cl-sampler> ( normalized-coords? addressing-mode filter-mode -- sampler )
|
: <cl-sampler> ( normalized-coords? addressing-mode filter-mode -- sampler )
|
||||||
|
@ -512,7 +512,7 @@ PRIVATE>
|
||||||
[ [ CL_TRUE ] [ CL_FALSE ] if ]
|
[ [ CL_TRUE ] [ CL_FALSE ] if ]
|
||||||
[ addressing-mode-constant ]
|
[ addressing-mode-constant ]
|
||||||
[ filter-mode-constant ]
|
[ filter-mode-constant ]
|
||||||
tri* 0 <int> [ clCreateSampler ] keep *int cl-success
|
tri* 0 int <ref> [ clCreateSampler ] keep int deref cl-success
|
||||||
cl-sampler new-disposable swap >>handle ;
|
cl-sampler new-disposable swap >>handle ;
|
||||||
|
|
||||||
: cl-normalized-coords? ( sampler -- ? )
|
: cl-normalized-coords? ( sampler -- ? )
|
||||||
|
@ -531,7 +531,7 @@ PRIVATE>
|
||||||
|
|
||||||
: <cl-kernel> ( program kernel-name -- kernel )
|
: <cl-kernel> ( program kernel-name -- kernel )
|
||||||
[ handle>> ] [ ascii encode 0 suffix ] bi*
|
[ handle>> ] [ ascii encode 0 suffix ] bi*
|
||||||
0 <int> [ clCreateKernel ] keep *int cl-success
|
0 int <ref> [ clCreateKernel ] keep int deref cl-success
|
||||||
cl-kernel new-disposable swap >>handle ; inline
|
cl-kernel new-disposable swap >>handle ; inline
|
||||||
|
|
||||||
: cl-kernel-name ( kernel -- string )
|
: cl-kernel-name ( kernel -- string )
|
||||||
|
@ -549,7 +549,7 @@ PRIVATE>
|
||||||
kernel handle>>
|
kernel handle>>
|
||||||
sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi
|
sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi
|
||||||
dependent-events [ length ] [ [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty ] bi
|
dependent-events [ length ] [ [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty ] bi
|
||||||
f <void*> [ clEnqueueNDRangeKernel cl-success ] keep *void*
|
f void* <ref> [ clEnqueueNDRangeKernel cl-success ] keep void* deref
|
||||||
cl-event new-disposable swap >>handle ;
|
cl-event new-disposable swap >>handle ;
|
||||||
|
|
||||||
: cl-event-type ( event -- command-type )
|
: cl-event-type ( event -- command-type )
|
||||||
|
@ -573,7 +573,7 @@ PRIVATE>
|
||||||
|
|
||||||
: cl-marker ( -- event )
|
: cl-marker ( -- event )
|
||||||
(current-cl-queue)
|
(current-cl-queue)
|
||||||
f <void*> [ clEnqueueMarker cl-success ] keep *void* cl-event new-disposable
|
f void* <ref> [ clEnqueueMarker cl-success ] keep void* deref cl-event new-disposable
|
||||||
swap >>handle ; inline
|
swap >>handle ; inline
|
||||||
|
|
||||||
: cl-barrier ( -- )
|
: cl-barrier ( -- )
|
||||||
|
|
|
@ -28,14 +28,14 @@ INSTANCE: TYPE assoc
|
||||||
M: TYPE dispose* [ DBDEL f ] change-handle drop ;
|
M: TYPE dispose* [ DBDEL f ] change-handle drop ;
|
||||||
|
|
||||||
M: TYPE at* ( key db -- value/f ? )
|
M: TYPE at* ( key db -- value/f ? )
|
||||||
handle>> swap object>bytes dup length 0 <int>
|
handle>> swap object>bytes dup length 0 int <ref>
|
||||||
DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
|
DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
|
||||||
|
|
||||||
M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
|
M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
|
||||||
|
|
||||||
: DBKEYS ( db -- keys )
|
: DBKEYS ( db -- keys )
|
||||||
[ assoc-size <vector> ] [ handle>> ] bi
|
[ assoc-size <vector> ] [ handle>> ] bi
|
||||||
dup DBITERINIT drop 0 <int>
|
dup DBITERINIT drop 0 int <ref>
|
||||||
[ 2dup DBITERNEXT dup ] [
|
[ 2dup DBITERNEXT dup ] [
|
||||||
[ memory>object ] [ tcfree ] bi
|
[ memory>object ] [ tcfree ] bi
|
||||||
[ pick ] dip swap push
|
[ pick ] dip swap push
|
||||||
|
|
|
@ -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 hashtables http
|
USING: accessors assocs combinators hashtables http
|
||||||
http.client json.reader kernel macros namespaces sequences
|
http.client json.reader kernel macros namespaces sequences
|
||||||
urls.secure fry oauth urls system ;
|
io.sockets.secure fry oauth urls ;
|
||||||
IN: twitter
|
IN: twitter
|
||||||
|
|
||||||
! Configuration
|
! Configuration
|
||||||
|
@ -20,9 +20,8 @@ twitter-source [ "factor" ] initialize
|
||||||
] with-scope ; inline
|
] with-scope ; inline
|
||||||
|
|
||||||
: twitter-url ( string -- string' )
|
: twitter-url ( string -- string' )
|
||||||
os windows?
|
ssl-supported?
|
||||||
"http://twitter.com/"
|
"https://twitter.com/" "http://twitter.com/" ? prepend ;
|
||||||
"https://twitter.com/" ? prepend ;
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue