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

db4
Slava Pestov 2010-10-31 20:26:29 -05:00
commit 8be8c7f213
88 changed files with 357 additions and 402 deletions

View File

@ -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:"

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ] } ] }
[ invalid-fortran-type ] { 8 [ { [ c:longlong deref ] } ] }
} case ] result?dims ; [ invalid-fortran-type ]
} 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>)

View File

@ -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>> ;

View File

@ -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

View File

@ -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
[ [

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 -- )

View File

@ -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

View File

@ -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 ;

View File

@ -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>> ;

View File

@ -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

View File

@ -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 {

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 )
{ {

View File

@ -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 ;

View File

@ -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 )
@ -350,4 +350,4 @@ M: winnt home
[ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
[ "USERPROFILE" os-env ] [ "USERPROFILE" os-env ]
[ my-documents ] [ my-documents ]
} 0|| ; } 0|| ;

View File

@ -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 )

View File

@ -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 ;

View File

@ -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

View File

@ -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 -- * )

View File

@ -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> ;

View File

@ -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 ]

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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
>> >>

View File

@ -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) ;

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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> ]

View File

@ -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 )

View File

@ -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 )

View File

@ -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>

View File

@ -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>

View File

@ -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> ;

View File

@ -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>

View File

@ -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 ] }

View File

@ -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>

View File

@ -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 )

View File

@ -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

View File

@ -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 ]

View File

@ -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
] ; ] ;

View File

@ -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 )
@ -72,4 +72,4 @@ FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
[ IpAddress>> String>> [ 0 = ] trim-tail utf8 decode , ] [ IpAddress>> String>> [ 0 = ] trim-tail utf8 decode , ]
[ Next>> ] bi dup [ Next>> ] bi dup
] loop drop ] loop drop
] { } make ; ] { } make ;

View File

@ -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
] [ ] [
@ -191,4 +191,4 @@ PRIVATE>
21 2^ <byte-array> reg-query-value-ex ; 21 2^ <byte-array> reg-query-value-ex ;
: read-registry ( key subkey -- registry-info ) : read-registry ( key subkey -- registry-info )
KEY_READ [ reg-query-info-key ] with-open-registry-key ; KEY_READ [ reg-query-info-key ] with-open-registry-key ;

View File

@ -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

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ] }

View File

@ -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
! !

View File

@ -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 ;

View File

@ -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 ]

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 -- )
{ {

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 > ;

View File

@ -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

View File

@ -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>

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 )

View File

@ -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 ;

View File

@ -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 ;
@ -17,4 +17,4 @@ IN: llvm.reader
<buffer> buffer>module ; <buffer> buffer>module ;
: load-into-jit ( path name -- ) : load-into-jit ( path name -- )
[ load-module ] dip add-module ; [ load-module ] dip add-module ;

View File

@ -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> ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 ( -- )

View File

@ -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

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators 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>