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

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

db4
Slava Pestov 2010-10-31 20:26:29 -05:00
parent 68712ed84c 675a420717
commit 8be8c7f213
88 changed files with 357 additions and 402 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
basis/alien/c-types/c-types-docs.factor
View File

@ -38,16 +38,6 @@ HELP: set-alien-value
{ $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." } ;
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
{ $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
@ -121,39 +111,10 @@ $nl
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."
$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:"
{ $subsections
<char>
<uchar>
<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." ;
"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 <ref> }
"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:"
{ $subsections deref } ;
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:"

23
basis/alien/c-types/c-types-tests.factor
View File

@ -2,24 +2,25 @@ USING: alien alien.syntax alien.c-types alien.parser
eval kernel tools.test sequences system libc alien.strings
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
accessors compiler.units ;
FROM: alien.c-types => short ;
IN: alien.c-types.tests
CONSTANT: xyz 123
[ 492 ] [ { int xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test
[ -1 ] [ -1 char <ref> char deref ] unit-test
[ -1 ] [ -1 short <ref> short deref ] unit-test
[ -1 ] [ -1 int <ref> int deref ] unit-test
! I don't care if this throws an error or works, but at least
! it should be consistent between platforms
[ -1 ] [ -1.0 <int> *int ] unit-test
[ -1 ] [ -1.0 <long> *long ] unit-test
[ -1 ] [ -1.0 <longlong> *longlong ] unit-test
[ 1 ] [ 1.0 <uint> *uint ] unit-test
[ 1 ] [ 1.0 <ulong> *ulong ] unit-test
[ 1 ] [ 1.0 <ulonglong> *ulonglong ] unit-test
[ -1 ] [ -1.0 int <ref> int deref ] unit-test
[ -1 ] [ -1.0 long <ref> long deref ] unit-test
[ -1 ] [ -1.0 longlong <ref> longlong deref ] unit-test
[ 1 ] [ 1.0 uint <ref> uint deref ] unit-test
[ 1 ] [ 1.0 ulong <ref> ulong deref ] unit-test
[ 1 ] [ 1.0 ulonglong <ref> ulonglong deref ] unit-test
UNION-STRUCT: foo
{ a int }
@ -62,11 +63,11 @@ TYPEDEF: int* MyIntArray
[ 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
os windows? cpu x86.64? and [
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
[ -2147467259 ] [ 2147500037 long <ref> long deref ] unit-test
] when
[ 0 ] [ -10 uchar c-type-clamp ] unit-test

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

@ -1,12 +1,9 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs delegate kernel kernel.private math
math.order math.parser namespaces make parser sequences strings
words splitting cpu.architecture alien alien.accessors
alien.strings quotations layouts system compiler.units io
io.files io.encodings.binary io.streams.memory accessors
combinators effects continuations fry classes vocabs
vocabs.loader words.symbol macros ;
USING: accessors alien alien.accessors arrays byte-arrays
classes combinators compiler.units cpu.architecture delegate
fry kernel layouts locals macros math math.order quotations
sequences system words words.symbol ;
QUALIFIED: math
IN: alien.c-types
@ -21,9 +18,6 @@ SYMBOLS:
SINGLETON: void
DEFER: <int>
DEFER: *char
TUPLE: abstract-c-type
{ 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 ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( name -- 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 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 -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
@ -247,7 +226,7 @@ M: pointer c-type
[ >c-ptr ] >>unboxer-quot
"allot_alien" >>boxer
"alien_offset" >>unboxer
\ void* define-primitive-type
\ void* typedef
<c-type>
fixnum >>class
@ -260,7 +239,7 @@ M: pointer c-type
"from_signed_2" >>boxer
"to_signed_2" >>unboxer
[ >fixnum ] >>unboxer-quot
\ short define-primitive-type
\ short typedef
<c-type>
fixnum >>class
@ -273,7 +252,7 @@ M: pointer c-type
"from_unsigned_2" >>boxer
"to_unsigned_2" >>unboxer
[ >fixnum ] >>unboxer-quot
\ ushort define-primitive-type
\ ushort typedef
<c-type>
fixnum >>class
@ -286,7 +265,7 @@ M: pointer c-type
"from_signed_1" >>boxer
"to_signed_1" >>unboxer
[ >fixnum ] >>unboxer-quot
\ char define-primitive-type
\ char typedef
<c-type>
fixnum >>class
@ -299,7 +278,7 @@ M: pointer c-type
"from_unsigned_1" >>boxer
"to_unsigned_1" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uchar define-primitive-type
\ uchar typedef
<c-type>
math:float >>class
@ -313,7 +292,7 @@ M: pointer c-type
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
\ float define-primitive-type
\ float typedef
<c-type>
math:float >>class
@ -326,7 +305,7 @@ M: pointer c-type
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
\ double define-primitive-type
\ double typedef
cell 8 = [
<c-type>
@ -340,7 +319,7 @@ M: pointer c-type
"from_signed_4" >>boxer
"to_signed_4" >>unboxer
[ >fixnum ] >>unboxer-quot
\ int define-primitive-type
\ int typedef
<c-type>
fixnum >>class
@ -353,7 +332,7 @@ M: pointer c-type
"from_unsigned_4" >>boxer
"to_unsigned_4" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uint define-primitive-type
\ uint typedef
<c-type>
integer >>class
@ -366,7 +345,7 @@ M: pointer c-type
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
[ >integer ] >>unboxer-quot
\ longlong define-primitive-type
\ longlong typedef
<c-type>
integer >>class
@ -379,14 +358,14 @@ M: pointer c-type
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
[ >integer ] >>unboxer-quot
\ ulonglong define-primitive-type
\ ulonglong typedef
os windows? [
\ int c-type \ long define-primitive-type
\ uint c-type \ ulong define-primitive-type
\ int c-type \ long typedef
\ uint c-type \ ulong typedef
] [
\ longlong c-type \ long define-primitive-type
\ ulonglong c-type \ ulong define-primitive-type
\ longlong c-type \ long typedef
\ ulonglong c-type \ ulong typedef
] if
\ longlong c-type \ ptrdiff_t typedef
@ -406,7 +385,7 @@ M: pointer c-type
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
[ >integer ] >>unboxer-quot
\ int define-primitive-type
\ int typedef
<c-type>
integer >>class
@ -419,7 +398,7 @@ M: pointer c-type
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
[ >integer ] >>unboxer-quot
\ uint define-primitive-type
\ uint typedef
<long-long-type>
integer >>class
@ -431,7 +410,7 @@ M: pointer c-type
"from_signed_8" >>boxer
"to_signed_8" >>unboxer
[ >integer ] >>unboxer-quot
\ longlong define-primitive-type
\ longlong typedef
<long-long-type>
integer >>class
@ -443,10 +422,10 @@ M: pointer c-type
"from_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
[ >integer ] >>unboxer-quot
\ ulonglong define-primitive-type
\ ulonglong typedef
\ int c-type \ long define-primitive-type
\ uint c-type \ ulong define-primitive-type
\ int c-type \ long typedef
\ uint c-type \ ulong typedef
\ int c-type \ ptrdiff_t typedef
\ int c-type \ intptr_t typedef
@ -459,7 +438,7 @@ M: pointer c-type
[ >c-bool ] >>unboxer-quot
[ c-bool> ] >>boxer-quot
object >>boxed-class
\ bool define-primitive-type
\ bool typedef
] with-compilation-unit
@ -489,3 +468,12 @@ M: double-2-rep rep-component-type drop double ;
: c-type-clamp ( value c-type -- value' )
dup { float double } member-eq?
[ 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

12
basis/alien/fortran/fortran-tests.factor
View File

@ -192,10 +192,10 @@ intel-unix-abi fortran-abi [
{
[ {
[ ascii string>alien ]
[ <longlong> ]
[ <float> ]
[ longlong <ref> ]
[ float <ref> ]
[ <complex-float> ]
[ 1 0 ? <short> ]
[ 1 0 ? c:short <ref> ]
} spread ]
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
} 5 ncleave
@ -211,7 +211,7 @@ intel-unix-abi fortran-abi [
[ drop ]
[ drop ]
[ drop ]
[ *float ]
[ float deref ]
[ drop ]
[ drop ]
} spread
@ -280,7 +280,7 @@ intel-unix-abi fortran-abi [
{
[ {
[ ascii string>alien ]
[ <float> ]
[ float <ref> ]
[ ascii string>alien ]
} spread ]
[ { [ length ] [ drop ] [ length ] } spread ]
@ -298,7 +298,7 @@ intel-unix-abi fortran-abi [
[ ascii alien>nstring ]
[ ]
[ ascii alien>nstring ]
[ *float ]
[ float deref ]
[ ]
[ ascii alien>nstring ]
} spread

50
basis/alien/fortran/fortran.factor
View File

@ -1,5 +1,5 @@
! (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
assocs byte-arrays combinators combinators.short-circuit fry
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)
[
size>> {
{ f [ [ <int> ] [ drop ] ] }
{ 1 [ [ <char> ] [ drop ] ] }
{ 2 [ [ <short> ] [ drop ] ] }
{ 4 [ [ <int> ] [ drop ] ] }
{ 8 [ [ <longlong> ] [ drop ] ] }
{ f [ [ c:int <ref> ] [ drop ] ] }
{ 1 [ [ c:char <ref> ] [ drop ] ] }
{ 2 [ [ c:short <ref> ] [ drop ] ] }
{ 4 [ [ c:int <ref> ] [ drop ] ] }
{ 8 [ [ c:longlong <ref> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
@ -226,9 +226,9 @@ M: logical-type (fortran-arg>c-args)
M: real-type (fortran-arg>c-args)
[
size>> {
{ f [ [ <float> ] [ drop ] ] }
{ 4 [ [ <float> ] [ drop ] ] }
{ 8 [ [ <double> ] [ drop ] ] }
{ f [ [ c:float <ref> ] [ drop ] ] }
{ 4 [ [ c:float <ref> ] [ drop ] ] }
{ 8 [ [ c:double <ref> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
@ -244,14 +244,14 @@ M: real-complex-type (fortran-arg>c-args)
] args?dims ;
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)
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
M: character-type (fortran-arg>c-args)
fix-character-type single-char?
[ [ first <char> ] [ drop ] ]
[ [ first c:char <ref> ] [ drop ] ]
[ [ ascii string>alien ] [ length ] ] if ;
M: misc-type (fortran-arg>c-args)
@ -263,23 +263,25 @@ GENERIC: (fortran-result>) ( type -- quots )
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
M: integer-type (fortran-result>)
[ size>> {
{ f [ { [ *int ] } ] }
{ 1 [ { [ *char ] } ] }
{ 2 [ { [ *short ] } ] }
{ 4 [ { [ *int ] } ] }
{ 8 [ { [ *longlong ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
[
size>> {
{ f [ { [ c:int deref ] } ] }
{ 1 [ { [ c:char deref ] } ] }
{ 2 [ { [ c:short deref ] } ] }
{ 4 [ { [ c:int deref ] } ] }
{ 8 [ { [ c:longlong deref ] } ] }
[ invalid-fortran-type ]
} case
] result?dims ;
M: logical-type (fortran-result>)
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
M: real-type (fortran-result>)
[ size>> {
{ f [ { [ *float ] } ] }
{ 4 [ { [ *float ] } ] }
{ 8 [ { [ *double ] } ] }
{ f [ { [ c:float deref ] } ] }
{ 4 [ { [ c:float deref ] } ] }
{ 8 [ { [ c:double deref ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
@ -292,14 +294,14 @@ M: real-complex-type (fortran-result>)
} case ] result?dims ;
M: double-precision-type (fortran-result>)
[ drop { [ *double ] } ] result?dims ;
[ drop { [ c:double deref ] } ] result?dims ;
M: double-complex-type (fortran-result>)
[ drop { [ *complex-double ] } ] result?dims ;
M: character-type (fortran-result>)
fix-character-type single-char?
[ { [ *char 1string ] } ]
[ { [ c:char deref 1string ] } ]
[ { [ ] [ ascii alien>nstring ] } ] if ;
M: misc-type (fortran-result>)

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

@ -21,7 +21,7 @@ IN: calendar.unix
timespec>duration since-1970 ;
: get-time ( -- alien )
f time <time_t> localtime ;
f time time_t <ref> localtime ;
: timezone-name ( -- string )
get-time zone>> ;

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

@ -275,7 +275,8 @@ M: cucumber equal? "The cucumber has no equal" throw ;
[ 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 ]
compile-call
] unit-test

52
basis/compiler/tests/intrinsics.factor
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
namespaces libc io.encodings.ascii classes compiler.test ;
FROM: math => float ;
FROM: alien.c-types => short ;
QUALIFIED-WITH: alien.c-types c
IN: compiler.tests.intrinsics
! 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
"s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] 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> [ { byte-array } declare void* deref ] 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
] when
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
[ f ] [ f [ { POSTPONE: f } 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* <ref> ] compile-call void* deref ] 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
[ -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
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
[ -100 ] [ -100 char <ref> [ { byte-array } declare char deref ] 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
[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
[ -100 ] [ -100 [ char <ref> ] [ { fixnum } declare ] prepend compile-call char deref ] 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
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
[ -1000 ] [ -1000 short <ref> [ { byte-array } declare short deref ] 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
[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
[ -1000 ] [ -1000 [ short <ref> ] [ { fixnum } declare ] prepend compile-call short deref ] 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
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
[ -100000 ] [ -100000 int <ref> [ { byte-array } declare int deref ] 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
[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
[ -100000 ] [ -100000 [ int <ref> ] [ { fixnum } declare ] prepend compile-call int deref ] 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
[ 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 <float> [ { byte-array } declare *float ] compile-call 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 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 ] [
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
@ -532,12 +534,14 @@ ERROR: bug-in-fixnum* x y a b ;
] compile-call
] 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
[
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
[

9
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -17,6 +17,7 @@ compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
IN: compiler.tree.cleanup.tests
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
@ -244,22 +245,22 @@ cell-bits 32 = [
] when
[ t ] [
[ B{ 1 0 } *short 0 number= ]
[ B{ 1 0 } c:short deref 0 number= ]
\ number= inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 { number number } declare number= ]
[ B{ 1 0 } c:short deref 0 { number number } declare number= ]
\ number= inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 = ]
[ B{ 1 0 } c:short deref 0 = ]
\ number= inlined?
] unit-test
[ 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?
] unit-test

8
basis/compression/zlib/zlib.factor
View File

@ -36,15 +36,15 @@ ERROR: zlib-failed n string ;
: 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
] 3keep drop *ulong head
] 3keep drop ulong deref head
] keep length <compressed> ;
: uncompress ( compressed -- byte-array )
[
length>> [ <byte-array> ] keep <ulong> 2dup
length>> [ <byte-array> ] keep ulong <ref> 2dup
] [
data>> dup length
compression.zlib.ffi:uncompress zlib-error
] bi *ulong head ;
] bi ulong deref head ;

8
basis/core-foundation/numbers/numbers.factor
View File

@ -30,14 +30,14 @@ FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType th
GENERIC: <CFNumber> ( number -- alien )
M: integer <CFNumber>
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
[ f kCFNumberLongLongType ] dip longlong <ref> CFNumberCreate ;
M: float <CFNumber>
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
[ f kCFNumberDoubleType ] dip double <ref> CFNumberCreate ;
M: t <CFNumber>
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
drop f kCFNumberIntType 1 int <ref> CFNumberCreate ;
M: f <CFNumber>
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
drop f kCFNumberIntType 0 int <ref> CFNumberCreate ;

5
basis/cpu/x86/sse/sse.factor
View File

@ -5,11 +5,12 @@ macros math math.vectors namespaces quotations sequences system
compiler.cfg.comparisons compiler.cfg.intrinsics
compiler.codegen.fixup cpu.architecture cpu.x86
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
QUALIFIED-WITH: alien.c-types c
IN: cpu.x86.sse
! Scalar floating point with SSE2
M: x86 %load-float <float> float-rep %load-vector ;
M: x86 %load-double <double> double-rep %load-vector ;
M: x86 %load-float c:float <ref> float-rep %load-vector ;
M: x86 %load-double c:double <ref> double-rep %load-vector ;
M: float-rep copy-register* drop MOVAPS ;
M: double-rep copy-register* drop MOVAPS ;

4
basis/cpu/x86/x87/x87.factor
View File

@ -38,12 +38,12 @@ M: double-rep copy-memory* copy-memory-x87 ;
M: x86 %load-float
0 [] FLDS
<float> rc-absolute rel-binary-literal
float <ref> rc-absolute rel-binary-literal
shuffle-down FSTP ;
M: x86 %load-double
0 [] FLDL
<double> rc-absolute rel-binary-literal
double <ref> rc-absolute rel-binary-literal
shuffle-down FSTP ;
:: binary-op ( dst src1 src2 quot -- )

2
basis/endian/endian.factor
View File

@ -7,7 +7,7 @@ IN: endian
SINGLETONS: big-endian little-endian ;
: 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
native-endianness [ compute-native-endianness ] initialize

2
basis/environment/unix/unix.factor
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 (os-envs) ( -- seq )
environ *void* utf8 alien>strings ;
environ void* deref utf8 alien>strings ;
: set-void* ( value alien -- ) 0 set-alien-cell ;

10
basis/furnace/auth/auth.factor
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.
USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry logging
io.encodings.utf8 io.encodings.string io.binary random
checksums checksums.sha urls
destructors combinators fry logging io.encodings.utf8
io.encodings.string io.binary io.sockets.secure random checksums
checksums.sha urls
html.forms
http.server
http.server.filters
@ -79,7 +79,7 @@ GENERIC: logged-in-username ( realm -- username )
swap >>default
users-in-db >>users
sha-256 >>checksum
t >>secure ; inline
ssl-supported? >>secure ; inline
: users ( -- provider )
realm get users>> ;

6
basis/furnace/redirection/redirection.factor
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.
USING: kernel accessors combinators namespaces fry urls urls.secure
http http.server http.server.redirection http.server.responses
USING: kernel accessors combinators namespaces fry urls http
http.server http.server.redirection http.server.responses
http.server.remapping http.server.filters furnace.utilities ;
IN: furnace.redirection

10
basis/game/input/dinput/dinput.factor
View File

@ -23,15 +23,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
: create-dinput ( -- )
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 ;
: delete-dinput ( -- )
+dinput+ [ com-release f ] change-global ;
: device-for-guid ( guid -- device )
+dinput+ get-global swap f <void*>
[ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
+dinput+ get-global swap f void* <ref>
[ f IDirectInput8W::CreateDevice ole32-error ] keep void* deref ;
: set-coop-level ( device -- )
+device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
@ -303,8 +303,8 @@ CONSTANT: pov-values
} 2cleave ;
: read-device-buffer ( device buffer count -- buffer count' )
[ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
[ DIDEVICEOBJECTDATA heap-size ] 2dip uint <ref>
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep uint deref ;
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {

2
basis/http/client/client-docs.factor
View File

@ -129,7 +129,7 @@ ARTICLE: "http.client.errors" "HTTP client errors"
ARTICLE: "http.client" "HTTP client"
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
$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
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
{ $subsections

8
basis/io/backend/unix/unix.factor
View File

@ -146,7 +146,7 @@ M: stdin dispose*
: wait-for-stdin ( stdin -- size )
[ 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 ;
:: refill-stdin ( buffer stdin size -- )
@ -167,11 +167,11 @@ M: stdin refill
M: stdin cancel-operation
[ 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 new-disposable

4
basis/io/directories/unix/linux/linux.factor
View File

@ -6,6 +6,6 @@ IN: io.directories.unix.linux
M: linux find-next-file ( DIR* -- dirent )
dirent <struct>
f <void*>
f void* <ref>
[ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
void* deref [ drop f ] unless ;

4
basis/io/directories/unix/unix.factor
View File

@ -37,9 +37,9 @@ HOOK: find-next-file os ( DIR* -- byte-array )
M: unix find-next-file ( DIR* -- byte-array )
dirent <struct>
f <void*>
f void* <ref>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
void* deref [ drop f ] unless ;
: dirent-type>file-type ( ch -- type )
{

4
basis/io/files/info/unix/macosx/macosx.factor
View File

@ -13,8 +13,8 @@ TUPLE: macosx-file-system-info < unix-file-system-info
io-size owner type-id filesystem-subtype ;
M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip <direct-statfs64-array>
f void* <ref> dup 0 getmntinfo64 dup io-error
[ void* deref ] dip <direct-statfs64-array>
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: macosx new-file-system-info macosx-file-system-info new ;

6
basis/io/files/windows/windows.factor
View File

@ -131,7 +131,7 @@ M: winnt init-io ( -- )
ERROR: invalid-file-size 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 ;
@ -249,7 +249,7 @@ M: winnt init-stdio
GetLastError ERROR_ALREADY_EXISTS = not ;
: 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 ;
M: windows (file-reader) ( path -- stream )
@ -350,4 +350,4 @@ M: winnt home
[ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
[ "USERPROFILE" os-env ]
[ my-documents ]
} 0|| ;
} 0|| ;

4
basis/io/launcher/windows/windows.factor
View File

@ -180,12 +180,12 @@ M: windows wait-for-processes ( -- ? )
GetCurrentProcess ! source process
swap handle>> ! handle
GetCurrentProcess ! target process
f <void*> [ ! target handle
f void* <ref> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
0 ! options
DuplicateHandle win32-error=0/f
] keep *void* <win32-handle> &dispose ;
] keep void* deref <win32-handle> &dispose ;
! /dev/null simulation
: null-input ( -- pipe )

2
basis/io/monitors/windows/windows.factor
View File

@ -32,7 +32,7 @@ TUPLE: win32-monitor < monitor port ;
[ recursive>> 1 0 ? ]
} cleave
FILE_NOTIFY_CHANGE_ALL
0 <uint>
0 uint <ref>
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;

6
basis/io/sockets/secure/secure.factor
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.
USING: accessors kernel namespaces continuations destructors io
debugger io.sockets io.sockets.private sequences summary
@ -11,6 +11,10 @@ SYMBOL: secure-socket-timeout
SYMBOL: secure-socket-backend
HOOK: ssl-supported? secure-socket-backend ( -- ? )
M: object ssl-supported? f ;
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
TUPLE: secure-config

4
basis/io/sockets/secure/unix/unix.factor
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.
USING: accessors unix byte-arrays kernel sequences namespaces
math math.order combinators init alien alien.c-types
@ -11,6 +11,8 @@ unix.ffi ;
FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
M: openssl ssl-supported? t ;
M: ssl-handle handle-fd file>> handle-fd ;
: syscall-error ( r -- * )

8
basis/io/sockets/sockets.factor
View File

@ -106,10 +106,10 @@ M: ipv4 make-sockaddr ( inet -- sockaddr )
swap
[ port>> htons >>port ]
[ 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 )
[ addr>> <uint> ] dip inet-ntop <ipv4> ;
[ addr>> uint <ref> ] dip inet-ntop <ipv4> ;
TUPLE: inet4 < ipv4 { port integer read-only } ;
@ -368,8 +368,8 @@ M: inet present
C: <inet> inet
M: string resolve-host
f prepare-addrinfo f <void*>
[ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
f prepare-addrinfo f void* <ref>
[ getaddrinfo addrinfo-error ] keep void* deref addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo ;
M: string with-port <inet> ;

10
basis/io/sockets/unix/unix.factor
View File

@ -16,7 +16,7 @@ IN: io.sockets.unix
socket dup io-error <fd> init-fd |dispose ;
: 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 -- )
[ gai_strerror throw ] unless-zero ;
@ -39,11 +39,11 @@ M: unix addrspec-of-family ( af -- addrspec )
! Client sockets - TCP and Unix domain
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 ;
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 ;
: init-client-socket ( fd -- )
@ -101,7 +101,7 @@ M: object (server) ( addrspec -- handle )
] with-destructors ;
: 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
M: object (accept) ( server addrspec -- fd sockaddr )
@ -138,7 +138,7 @@ CONSTANT: packet-size 65536
packet-size ! nbytes
0 ! flags
sockaddr ! from
len <int> ! fromlen
len int <ref> ! fromlen
recvfrom dup 0 >=
[ receive-buffer get-global swap memory>byte-array sockaddr ]
[ drop f f ]

13
basis/io/sockets/windows/windows.factor
View File

@ -48,11 +48,11 @@ M: win32-socket dispose* ( stream -- )
opened-socket ;
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 ;
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 ;
: bind-socket ( win32-socket sockaddr len -- )
@ -87,7 +87,7 @@ M: windows (raw) ( addrspec -- handle )
[ SOCK_RAW server-socket ] with-destructors ;
: malloc-int ( n -- alien )
<int> malloc-byte-array ; inline
int <ref> malloc-byte-array ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
@ -181,7 +181,8 @@ TUPLE: AcceptEx-args port
} cleave AcceptEx drop winsock-error ; inline
: (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 )
[
@ -246,7 +247,7 @@ TUPLE: WSARecvFrom-args port
[
[ port>> addr>> empty-sockaddr dup ]
[ lpFrom>> ]
[ lpFromLen>> *int ]
[ lpFromLen>> int deref ]
tri memcpy
] bi ; inline
@ -278,7 +279,7 @@ TUPLE: WSASendTo-args port
swap make-send-buffer >>lpBuffers
1 >>dwBufferCount
0 >>dwFlags
0 <uint> >>lpNumberOfBytesSent
0 uint <ref> >>lpNumberOfBytesSent
(make-overlapped) >>lpOverlapped ; inline
: call-WSASendTo ( WSASendTo -- )

4
basis/iokit/iokit.factor
View File

@ -156,9 +156,9 @@ TUPLE: mach-error error-code error-string ;
io-objects-from-iterator* [ release-io-object ] dip ;
: properties-from-io-object ( o -- o nsdictionary )
dup f <void*> [
dup f void* <ref> [
kCFAllocatorDefault kNilOptions
IORegistryEntryCreateCFProperties mach-error
]
keep *void* ;
keep void* deref ;

2
basis/math/floats/half/half.factor
View File

@ -41,6 +41,6 @@ SYMBOL: half
2 >>align
2 >>align-first
[ >float ] >>unboxer-quot
\ half define-primitive-type
\ half typedef
>>

2
basis/opengl/opengl.factor
View File

@ -142,7 +142,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
[ 1 { uint } ] dip with-out-parameters ; inline
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
[ 1 swap uint <ref> ] dip call ; inline
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;

8
basis/opengl/shaders/shaders.factor
View File

@ -8,7 +8,7 @@ SPECIALIZED-ARRAY: uint
IN: opengl.shaders
: 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 )
glCreateShader dup rot
@ -47,7 +47,7 @@ IN: opengl.shaders
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup [
1 calloc &free
[ 0 <int> swap glGetShaderInfoLog ] keep
[ 0 int <ref> swap glGetShaderInfoLog ] keep
ascii alien>string
] with-destructors ;
@ -90,7 +90,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup [
1 calloc &free
[ 0 <int> swap glGetProgramInfoLog ] keep
[ 0 int <ref> swap glGetProgramInfoLog ] keep
ascii alien>string
] with-destructors ;
@ -107,7 +107,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length 2 *
0 <int>
0 int <ref>
over <uint-array>
[ glGetAttachedShaders ] keep [ zero? not ] filter ;

4
basis/random/random.factor
View File

@ -90,8 +90,8 @@ ERROR: too-many-samples seq n ;
secure-random-generator get swap with-random ; inline
: uniform-random-float ( min max -- n )
4 random-bytes underlying>> *uint >float
4 random-bytes underlying>> *uint >float
4 random-bytes underlying>> uint deref >float
4 random-bytes underlying>> uint deref >float
2.0 32 ^ * +
[ over - 2.0 -64 ^ * ] dip
* + ; inline

2
basis/specialized-arrays/specialized-arrays-docs.factor
View File

@ -94,7 +94,7 @@ $nl
""
"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" } "."
$nl

8
basis/system-info/macosx/macosx.factor
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 ) ;
: make-int-array ( seq -- byte-array )
[ <int> ] map concat ;
[ int <ref> ] map concat ;
: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
over [ f 0 sysctl io-error ] dip ;
: sysctl-query ( seq n -- byte-array )
[ [ make-int-array ] [ length ] bi ] dip
[ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
[ <byte-array> ] [ uint <ref> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
4096 sysctl-query utf8 alien>string ;
: sysctl-query-uint ( seq -- n )
4 sysctl-query *uint ;
4 sysctl-query uint deref ;
: sysctl-query-ulonglong ( seq -- n )
8 sysctl-query *ulonglong ;
8 sysctl-query ulonglong deref ;
: machine ( -- str ) { 6 1 } sysctl-query-string ;
: model ( -- str ) { 6 2 } sysctl-query-string ;

4
basis/system-info/windows/windows.factor
View File

@ -95,10 +95,10 @@ M: winnt available-virtual-mem ( -- n )
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep <uint>
[ <byte-array> dup ] keep uint <ref>
GetComputerName win32-error=0/f alien>native-string ;
: username ( -- string )
UNLEN 1 +
[ <byte-array> dup ] keep <uint>
[ <byte-array> dup ] keep uint <ref>
GetUserName win32-error=0/f alien>native-string ;

2
basis/ui/backend/cocoa/cocoa.factor
View File

@ -128,7 +128,7 @@ CONSTANT: window-control>styleMask
: make-context-transparent ( view -- )
-> openGLContext
0 <int> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
0 int <ref> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]

2
basis/ui/backend/cocoa/views/views.factor
View File

@ -332,7 +332,7 @@ CLASS: FactorView < NSOpenGLView NSTextInput
]
: sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 int <ref>
CGLSetParameter drop ;
: <FactorView> ( dim pixel-format -- view )

5
basis/ui/backend/windows/windows.factor
View File

@ -16,6 +16,7 @@ ui.pixel-formats.private memoize classes colors
specialized-arrays classes.struct alien.data ;
FROM: namespaces => set ;
SPECIALIZED-ARRAY: POINT
QUALIFIED-WITH: alien.c-types c
IN: ui.backend.windows
SINGLETON: windows-ui-backend
@ -66,7 +67,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
first <int> { int }
first int <ref> { int }
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
with-out-parameters
] if-empty ;
@ -168,7 +169,7 @@ M: windows-ui-backend (pixel-format-attribute)
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
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
: GET_APPCOMMAND_LPARAM ( lParam -- appCommand )

10
basis/unix/groups/groups.factor
View File

@ -22,10 +22,10 @@ GENERIC: group-struct ( obj -- group/f )
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
[ \ 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 )
*void* [ drop f ] unless ;
void* deref [ drop f ] unless ;
M: integer group-struct ( id -- group/f )
(group-struct)
@ -67,13 +67,13 @@ ERROR: no-group string ;
<PRIVATE
: >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 )
#! first group is -1337, legacy unix code
-1337 unix.ffi:NGROUPS_MAX [ 4 * <byte-array> ] keep
<int> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
[ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
int <ref> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
[ 4 tail-slice ] [ int deref 1 - ] bi* >groups ;
PRIVATE>

2
basis/unix/types/freebsd/freebsd.factor
View File

@ -22,5 +22,3 @@ TYPEDEF: __uint32_t fflags_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: long time_t
ALIAS: <time_t> <long>

2
basis/unix/types/linux/linux.factor
View File

@ -32,4 +32,4 @@ TYPEDEF: ulonglong __fsfilcnt64_t
TYPEDEF: ulonglong ino64_t
TYPEDEF: ulonglong off64_t
ALIAS: <time_t> <long>
: <time_t> ( n -- long ) long <ref> ;

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

@ -33,7 +33,3 @@ TYPEDEF: char[512] io_string_t
TYPEDEF: kern_return_t IOReturn
TYPEDEF: uint IOOptionBits
ALIAS: <time_t> <long>

2
basis/unix/types/netbsd/netbsd.factor
View File

@ -17,8 +17,6 @@ TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
ALIAS: <time_t> <int>
cell-bits {
{ 32 [ "unix.types.netbsd.32" require ] }
{ 64 [ "unix.types.netbsd.64" require ] }

2
basis/unix/types/openbsd/openbsd.factor
View File

@ -17,5 +17,3 @@ TYPEDEF: __uint32_t fflags_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
ALIAS: <time_t> <int>

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

@ -8,14 +8,14 @@ IN: unix.utilities
SPECIALIZED-ARRAY: void*
: more? ( alien -- ? )
{ [ ] [ *void* ] } 1&& ;
{ [ ] [ void* deref ] } 1&& ;
: advance ( void* -- void* )
cell swap <displaced-alien> ;
: alien>strings ( alien encoding -- strings )
[ [ dup more? ] ] dip
'[ [ advance ] [ *void* _ alien>string ] bi ]
'[ [ advance ] [ void* deref _ alien>string ] bi ]
produce nip ;
: strings>alien ( strings encoding -- array )

1
basis/urls/urls.factor
View File

@ -187,3 +187,4 @@ SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
USE: vocabs.loader
{ "urls" "prettyprint" } "urls.prettyprint" require-when
{ "urls" "io.sockets.secure" } "urls.secure" require-when

2
basis/windows/com/com-tests.factor
View File

@ -58,7 +58,7 @@ C: <test-implementation> test-implementation
dup +guinea-pig-implementation+ set [ drop
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 [
+guinea-pig-implementation+ get
[ 20 IInherited::setX ]

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

@ -11,7 +11,7 @@ IN: windows.com.syntax
MACRO: com-invoke ( n return parameters -- )
[ 2nip length ] 3keep
'[
_ npick *void* _ cell * alien-cell _ _
_ npick void* deref _ cell * alien-cell _ _
stdcall alien-indirect
] ;

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

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

28
basis/windows/registry/registry.factor
View File

@ -21,7 +21,7 @@ CONSTANT: registry-value-max-length 16384
[ key subkey mode ] dip n>win32-error-string
open-key-failed
] if
] keep *uint ;
] keep uint deref ;
:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
@ -29,8 +29,8 @@ CONSTANT: registry-value-max-length 16384
DWORD <c-object>
f :> ret!
[ RegCreateKeyEx ret! ] 2keep
[ *uint ]
[ *uint REG_CREATED_NEW_KEY = ] bi*
[ uint deref ]
[ uint deref REG_CREATED_NEW_KEY = ] bi*
ret ERROR_SUCCESS = [
[
hKey lpSubKey 0 lpClass dwOptions samDesired
@ -67,11 +67,11 @@ CONSTANT: registry-value-max-length 16384
length 2 * <byte-array> ;
:: 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
rot :> ret
ret ERROR_SUCCESS = [
*uint head
uint deref head
] [
ret ERROR_MORE_DATA = [
2drop
@ -116,7 +116,7 @@ TUPLE: registry-enum-key ;
key
MAX_PATH
dup TCHAR <c-array> dup :> class-buffer
swap <int> dup :> class-buffer-length
swap int <ref> dup :> class-buffer-length
f
DWORD <c-object> dup :> sub-keys
DWORD <c-object> dup :> longest-subkey
@ -130,13 +130,13 @@ TUPLE: registry-enum-key ;
ret ERROR_SUCCESS = [
key
class-buffer
sub-keys *uint
longest-subkey *uint
longest-class-string *uint
#values *uint
max-value *uint
max-value-data *uint
security-descriptor *uint
sub-keys uint deref
longest-subkey uint deref
longest-class-string uint deref
#values uint deref
max-value uint deref
max-value-data uint deref
security-descriptor uint deref
last-write-time FILETIME>timestamp
registry-info boa
] [
@ -191,4 +191,4 @@ PRIVATE>
21 2^ <byte-array> reg-query-value-ex ;
: 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 ;

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

@ -42,9 +42,9 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
f ! piDx
f ! pTabdef
f ! pbInClass
f <void*> ! pssa
f void* <ref> ! pssa
[ ScriptStringAnalyse ] keep
[ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
[ ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
: set-dc-colors ( dc font -- )
[ background>> color>RGB SetBkColor drop ]
@ -103,7 +103,7 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
PRIVATE>
M: script-string dispose*
ssa>> <void*> ScriptStringFree ole32-error ;
ssa>> void* <ref> ScriptStringFree ole32-error ;
SYMBOL: cached-script-strings

6
basis/x11/clipboard/clipboard.factor
View File

@ -28,11 +28,11 @@ TUPLE: x-clipboard atom contents ;
CurrentTime XConvertSelection drop ;
: 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 )
[ [ 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 ;
: selection-from-event ( event window -- string )
@ -53,7 +53,7 @@ TUPLE: x-clipboard atom contents ;
[ dpy get ] dip
[ requestor>> ]
[ property>> XA_TIMESTAMP 32 PropModeReplace ]
[ time>> <int> ] tri
[ time>> int <ref> ] tri
1 XChangeProperty drop ;
: send-notify ( evt prop -- )

9
basis/x11/windows/windows.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.bitwise math.vectors
namespaces sequences arrays fry classes.struct literals
x11 x11.xlib x11.constants x11.events
x11.glx ;
USING: accessors alien.c-types kernel math math.bitwise
math.vectors namespaces sequences arrays fry classes.struct
literals x11 x11.xlib x11.constants x11.events x11.glx ;
IN: x11.windows
CONSTANT: create-window-mask
@ -79,7 +78,7 @@ CONSTANT: event-mask
dpy get swap XDestroyWindow drop ;
: set-closable ( win -- )
dpy get swap XA_WM_DELETE_WINDOW <Atom> 1
dpy get swap XA_WM_DELETE_WINDOW Atom <ref> 1
XSetWMProtocols drop ;
: map-window ( win -- ) dpy get swap XMapWindow drop ;

4
basis/x11/xim/xim.factor
View File

@ -42,7 +42,7 @@ SYMBOL: keysym
: prepare-lookup ( -- )
buf-size <uint-array> keybuf set
0 <KeySym> keysym set ;
0 KeySym <ref> keysym set ;
: finish-lookup ( len -- string keysym )
keybuf get swap 2 * head utf16n decode
@ -51,7 +51,7 @@ SYMBOL: keysym
: lookup-string ( event xic -- string keysym )
[
prepare-lookup
swap keybuf get buf-size keysym get 0 <int>
swap keybuf get buf-size keysym get 0 int <ref>
XwcLookupString
finish-lookup
] with-scope ;

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

@ -5,7 +5,7 @@ x11.constants x11.xinput2.ffi ;
IN: x11.xinput2
: (xi2-available?) ( display -- ? )
2 0 [ <int> ] bi@
2 0 [ int <ref> ] bi@
XIQueryVersion
{
{ BadRequest [ f ] }

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

@ -48,17 +48,11 @@ TYPEDEF: int Bool
TYPEDEF: ulong VisualID
TYPEDEF: ulong Time
ALIAS: <XID> <ulong>
ALIAS: <Window> <XID>
ALIAS: <Drawable> <XID>
ALIAS: <KeySym> <XID>
ALIAS: <Atom> <ulong>
ALIAS: *XID *ulong
: *XID ( bytes -- n ) ulong deref ;
ALIAS: *Window *XID
ALIAS: *Drawable *XID
ALIAS: *KeySym *XID
ALIAS: *Atom *ulong
: *Atom ( bytes -- n ) ulong deref ;
!
! 2 - Display Functions
!

6
extra/alien/cxx/demangle/libstdcxx/libstdcxx.factor
View File

@ -22,9 +22,9 @@ ERROR: invalid-demangle-args name ;
"_Z" head? ;
:: demangle ( mangled-name -- c++-name )
0 <ulong> :> length
0 <int> :> status [
0 ulong <ref> :> length
0 int <ref> :> status [
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
] with-destructors ;

12
extra/audio/engine/engine.factor
View File

@ -122,7 +122,7 @@ ERROR: audio-context-not-available device-name ;
:: flush-source ( al-source -- )
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 1 dummy-buffer alSourceUnqueueBuffers
] times
@ -161,7 +161,7 @@ ERROR: audio-context-not-available device-name ;
audio-clip t >>done? drop
] [
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
] unless ;
@ -190,10 +190,10 @@ M: static-audio-clip (update-audio-clip)
M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- )
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 1 buffer alSourceUnqueueBuffers
audio-clip buffer c:*uint queue-clip-buffer
audio-clip buffer c:uint c:deref queue-clip-buffer
] times ;
: update-audio-clip ( audio-clip -- )
@ -256,7 +256,7 @@ M: audio-engine dispose*
audio-engine get-available-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
alBufferData
@ -301,7 +301,7 @@ M: audio-clip dispose*
M: static-audio-clip dispose*
[ 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*
[ call-next-method ]

2
extra/audio/vorbis/vorbis.factor
View File

@ -157,7 +157,7 @@ ERROR: no-vorbis-in-ogg ;
[ init-vorbis-codec ] if ;
: 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 )
-32767.5 * 0.5 - >integer -32768 32767 clamp ; inline

4
extra/benchmark/ui-panes/ui-panes.factor
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
: 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

4
extra/cuda/contexts/contexts.factor
View File

@ -10,13 +10,13 @@ IN: cuda.contexts
: create-context ( device flags -- context )
swap
[ CUcontext <c-object> ] 2dip
[ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
[ cuCtxCreate cuda-error ] 3keep 2drop void* deref ; inline
: sync-context ( -- )
cuCtxSynchronize cuda-error ; inline
: 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

2
extra/cuda/cuda.factor
View File

@ -16,7 +16,7 @@ TUPLE: cuda-error code ;
dup CUDA_SUCCESS = [ drop ] [ \ cuda-error boa throw ] if ;
: 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 ( -- )
0 cuInit cuda-error ; inline

11
extra/cuda/devices/devices.factor
View File

@ -8,10 +8,11 @@ prettyprint sequences ;
IN: cuda.devices
: #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 )
[ 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 )
#cuda-devices iota [ n>cuda-device ] map ;
@ -34,17 +35,17 @@ IN: cuda.devices
: cuda-device-capability ( n -- pair )
[ int <c-object> int <c-object> ] dip
[ cuDeviceComputeCapability cuda-error ]
[ drop [ *int ] bi@ ] 3bi 2array ;
[ drop [ int deref ] bi@ ] 3bi 2array ;
: cuda-device-memory ( n -- bytes )
[ uint <c-object> ] dip
[ cuDeviceTotalMem cuda-error ]
[ drop *uint ] 2bi ;
[ drop uint deref ] 2bi ;
: cuda-device-attribute ( attribute n -- n )
[ int <c-object> ] 2dip
[ cuDeviceGetAttribute cuda-error ]
[ 2drop *int ] 3bi ;
[ 2drop int deref ] 3bi ;
: cuda-device. ( n -- )
{

10
extra/cuda/gl/gl.factor
View File

@ -7,7 +7,7 @@ IN: cuda.gl
: create-gl-cuda-context ( device flags -- context )
swap
[ 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 -- )
[ 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 )
enum>number
[ CUgraphicsResource <c-object> ] 2dip
[ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop *void* ; inline
[ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop void* deref ; inline
: buffer>resource ( buffer flags -- resource )
[ handle>> ] dip gl-buffer>resource ; inline
: 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
[ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
[ *uint ] [ *uint ] bi*
[ uint deref ] [ uint deref ] bi*
] bi ; inline
: unmap-resource ( resource -- )
1 swap <void*> f cuGraphicsUnmapResources cuda-error ; inline
1 swap void* <ref> f cuGraphicsUnmapResources cuda-error ; inline
DESTRUCTOR: unmap-resource

6
extra/cuda/libraries/libraries.factor
View File

@ -75,7 +75,7 @@ PRIVATE>
: load-module ( path -- module )
[ CUmodule <c-object> ] dip
[ cuModuleLoad cuda-error ] 2keep drop c:*void* ;
[ cuModuleLoad cuda-error ] 2keep drop c:void* c:deref ;
: unload-module ( module -- )
cuModuleUnload cuda-error ;
@ -152,7 +152,7 @@ MACRO: cuda-arguments ( c-types abi -- quot: ( args... function -- ) )
: get-function-ptr ( module string -- function )
[ 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 )
lookup-cuda-library
@ -172,7 +172,7 @@ MACRO: cuda-invoke ( module-name function-name arguments -- )
: cuda-global* ( module-name symbol-name -- device-ptr size )
[ CUdeviceptr <c-object> c:uint <c-object> ] 2dip
[ 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* drop ; inline

2
extra/cuda/memory/memory.factor
View File

@ -10,7 +10,7 @@ IN: cuda.memory
: cuda-malloc ( n -- ptr )
[ CUdeviceptr <c-object> ] dip
'[ _ cuMemAlloc cuda-error ] keep
c:*int ; inline
c:int c:deref ; inline
: cuda-malloc-type ( n type -- ptr )
c:heap-size * cuda-malloc ; inline

4
extra/ecdsa/ecdsa.factor
View File

@ -67,9 +67,9 @@ PRIVATE>
:: ecdsa-sign ( DGST -- sig )
ec-key-handle :> KEY
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
LEN *uint SIG resize ;
LEN uint deref SIG resize ;
: ecdsa-verify ( dgst sig -- ? )
ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;

2
extra/gpu/buffers/buffers.factor
View File

@ -57,7 +57,7 @@ TUPLE: buffer < gpu-object
} case ; inline
: get-buffer-int ( target enum -- value )
0 <int> [ glGetBufferParameteriv ] keep *int ; inline
0 int <ref> [ glGetBufferParameteriv ] keep int deref ; inline
: bind-buffer ( buffer -- target )
[ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; inline

3
extra/gpu/framebuffers/framebuffers.factor
View File

@ -18,7 +18,8 @@ TUPLE: renderbuffer < gpu-object
<PRIVATE
: get-framebuffer-int ( enum -- value )
GL_RENDERBUFFER swap 0 <int> [ glGetRenderbufferParameteriv ] keep *int ;
GL_RENDERBUFFER swap 0 int <ref>
[ glGetRenderbufferParameteriv ] keep int deref ;
PRIVATE>

2
extra/gpu/shaders/shaders.factor
View File

@ -199,7 +199,7 @@ TR: hyphens>underscores "-" "_" ;
name length 1 + :> name-buffer-length
{
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
ascii alien>string
vertex-attribute assert-feedback-attribute

6
extra/gpu/state/state.factor
View File

@ -416,11 +416,11 @@ M: mask-state set-gpu-state*
[ set-gpu-state* ] if ; inline
: 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 )
0 <int> [ glGetIntegerv ] keep *int ;
0 int <ref> [ glGetIntegerv ] keep int deref ;
: 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 )
<byte-array> [ glGetBooleanv ] keep [ c-bool> ] { } map-as ;

4
extra/html/parser/analyzer/analyzer.factor
View File

@ -171,8 +171,8 @@ ERROR: undefined-find-nth m n seq quot ;
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( vector string -- vector' )
dupd find-opening-tags-by-name
[ first2 find-between* ] curry map ;
over find-opening-tags-by-name
[ first2 find-between* ] with map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip "action" attribute ;

2
extra/javascriptcore/javascriptcore.factor
View File

@ -38,7 +38,7 @@ SYMBOL: js-context
: eval-js ( string -- result-string )
[ js-context get dup ] dip
JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
[ JSEvaluateScript ] keep *void*
[ JSEvaluateScript ] keep void* deref
dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
: eval-js-standalone ( string -- result-string )

10
extra/llvm/jit/jit.factor
View File

@ -25,9 +25,9 @@ TUPLE: jit ee mps ;
LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
: remove-provider ( provider -- )
current-jit ee>> value>> swap value>> f <void*> f <void*>
[ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
*void* module new swap >>value
current-jit ee>> value>> swap value>> f void* <ref> f void* <ref>
[ LLVMRemoveModuleProvider drop ] 2keep void* deref [ llvm-throw ] when*
void* deref module new swap >>value
[ value>> remove-functions ] with-disposal ;
: remove-module ( name -- )
@ -44,5 +44,5 @@ TUPLE: jit ee mps ;
: function-pointer ( name -- alien )
current-jit ee>> value>> dup
rot f <void*> [ LLVMFindFunction drop ] keep
*void* LLVMGetPointerToGlobal ;
rot f void* <ref> [ LLVMFindFunction drop ] keep
void* deref LLVMGetPointerToGlobal ;

6
extra/llvm/reader/reader.factor
View File

@ -7,9 +7,9 @@ IN: llvm.reader
: buffer>module ( buffer -- module )
[
value>> f <void*> f <void*>
value>> f void* <ref> f void* <ref>
[ LLVMParseBitcode drop ] 2keep
*void* [ llvm-throw ] when* *void*
void* deref [ llvm-throw ] when* void* deref
module new swap >>value
] with-disposal ;
@ -17,4 +17,4 @@ IN: llvm.reader
<buffer> buffer>module ;
: load-into-jit ( path name -- )
[ load-module ] dip add-module ;
[ load-module ] dip add-module ;

8
extra/llvm/wrappers/wrappers.factor
View File

@ -33,9 +33,9 @@ M: engine dispose* value>> LLVMDisposeExecutionEngine ;
: (engine) ( provider -- engine )
[
value>> f <void*> f <void*>
value>> f void* <ref> f void* <ref>
[ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
*void* [ llvm-throw ] when* *void*
void* deref [ llvm-throw ] when* void* deref
]
[ t >>disposed drop ] bi
engine <dispose> ;
@ -57,6 +57,6 @@ TUPLE: buffer value disposed ;
M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
: <buffer> ( path -- module )
f <void*> f <void*>
f void* <ref> f void* <ref>
[ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
*void* [ llvm-throw ] when* *void* buffer <dispose> ;
void* deref [ llvm-throw ] when* void* deref buffer <dispose> ;

4
extra/openal/alut/macosx/macosx.factor
View File

@ -9,6 +9,6 @@ LIBRARY: alut
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* 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
[ [ [ *int ] dip *void* ] dip *int ] dip *int ;
[ [ [ int deref ] dip void* deref ] dip int deref ] dip int deref ;

9
extra/openal/alut/other/other.factor
View File

@ -9,6 +9,9 @@ LIBRARY: alut
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 )
0 <int> f <void*> 0 <int> 0 <int>
[ 0 <char> alutLoadWAVFile ] 4 nkeep
{ [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
0 int <ref>
f void* <ref>
0 int <ref>
0 int <ref>
[ 0 char <ref> alutLoadWAVFile ] 4 nkeep
{ [ int deref ] [ void* deref ] [ int deref ] [ int deref ] } spread ;

4
extra/openal/openal.factor
View File

@ -264,13 +264,13 @@ DESTRUCTOR: alcDestroyContext
alSourcei ;
: 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 -- )
alBufferi ;
: get-buffer-param ( source param -- value )
0 <uint> dup [ alGetBufferi ] dip *uint ;
0 uint <ref> dup [ alGetBufferi ] dip uint deref ;
: source-play ( source -- ) alSourcePlay ;

26
extra/opencl/ffi/ffi-tests.factor
View File

@ -29,33 +29,33 @@ ERROR: cl-error err ;
str-alien str-buffer dup length memcpy str-alien ;
:: 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
CL_DEVICE_TYPE_DEFAULT 1 f <void*> [ f clGetDeviceIDs cl-success ] keep *void* :> device-id
f 1 device-id <void*> f f 0 <int> [ clCreateContext ] keep *int cl-success :> context
context device-id 0 0 <int> [ clCreateCommandQueue ] keep *int cl-success :> queue
CL_DEVICE_TYPE_DEFAULT 1 f void* <ref> [ f clGetDeviceIDs cl-success ] keep void* deref :> device-id
f 1 device-id void* <ref> f f 0 int <ref> [ clCreateContext ] keep int deref cl-success :> context
context device-id 0 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success :> queue
[
context 1 kernel-source cl-string-array <void*>
f 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
context 1 kernel-source cl-string-array void* <ref>
f 0 int <ref> [ clCreateProgramWithSource ] keep int deref 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
] with-destructors :> ( kernel program )
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
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
kernel 0 cl_mem heap-size input <void*> clSetKernelArg cl-success
kernel 1 cl_mem heap-size output <void*> clSetKernelArg cl-success
kernel 2 uint heap-size in length <uint> clSetKernelArg cl-success
kernel 0 cl_mem heap-size input void* <ref> clSetKernelArg cl-success
kernel 1 cl_mem heap-size output void* <ref> 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
queue clFinish cl-success

2
extra/opencl/opencl-tests.factor
View File

@ -32,7 +32,7 @@ __kernel void square(
cl-read-access num-bytes in <cl-buffer> &dispose :> in-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
cl-finish

44
extra/opencl/opencl.factor
View File

@ -17,7 +17,7 @@ ERROR: cl-error err ;
dup f = [ cl-error ] [ drop ] if ; inline
: 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 )
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
: 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 )
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
: info-bool ( handle name quot -- ? )
[ *uint CL_TRUE = ] info ; inline
[ uint deref CL_TRUE = ] info ; inline
: info-ulong ( handle name quot -- ulong )
[ *ulonglong ] info ; inline
[ ulonglong deref ] info ; inline
: info-int ( handle name quot -- int )
[ *int ] info ; inline
[ int deref ] info ; inline
: info-uint ( handle name quot -- uint )
[ *uint ] info ; inline
[ uint deref ] info ; inline
: 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 )
[ *size_t ] 2info ; inline
[ size_t deref ] 2info ; inline
: info-string ( handle name quot -- string )
[ 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 )
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
] 2bi ; inline
@ -340,7 +340,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
[ length ]
[ strings>char*-array ]
[ [ 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 ;
:: (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 ;
: 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
: bind-kernel-arg-data ( kernel index byte-array -- )
@ -425,7 +425,7 @@ PRIVATE>
] dip bind ; inline
: 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
@ -437,14 +437,14 @@ PRIVATE>
: <cl-context> ( devices -- cl-context )
[ f ] dip
[ 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-queue> ( context device out-of-order? profiling? -- command-queue )
[ [ handle>> ] [ id>> ] bi* ] 2dip
[ [ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE ] [ 0 ] if ]
[ [ 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-out-of-order-execution? ( command-queue -- ? )
@ -462,7 +462,7 @@ PRIVATE>
[ buffer-access-constant ]
[ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor
] 2dip
0 <int> [ clCreateBuffer ] keep *int cl-success
0 int <ref> [ clCreateBuffer ] keep int deref cl-success
cl-buffer new-disposable swap >>handle ;
: cl-read-buffer ( buffer-range -- byte-array )
@ -488,7 +488,7 @@ PRIVATE>
[ [ buffer>> handle>> ] [ offset>> ] bi ]
tri* swapd
] 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 ;
: cl-queue-read-buffer ( buffer-range alien dependent-events -- event )
@ -496,7 +496,7 @@ PRIVATE>
[ (current-cl-queue) handle>> ] dip
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
] 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 ;
: cl-queue-write-buffer ( buffer-range alien dependent-events -- event )
@ -504,7 +504,7 @@ PRIVATE>
[ (current-cl-queue) handle>> ] dip
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
] 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 ;
: <cl-sampler> ( normalized-coords? addressing-mode filter-mode -- sampler )
@ -512,7 +512,7 @@ PRIVATE>
[ [ CL_TRUE ] [ CL_FALSE ] if ]
[ addressing-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-normalized-coords? ( sampler -- ? )
@ -531,7 +531,7 @@ PRIVATE>
: <cl-kernel> ( program kernel-name -- kernel )
[ 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-name ( kernel -- string )
@ -549,7 +549,7 @@ PRIVATE>
kernel handle>>
sizes [ length f ] [ [ ] size_t-array{ } map-as f ] 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-type ( event -- command-type )
@ -573,7 +573,7 @@ PRIVATE>
: cl-marker ( -- event )
(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
: cl-barrier ( -- )

4
extra/tokyo/assoc-functor/assoc-functor.factor
View File

@ -28,14 +28,14 @@ INSTANCE: TYPE assoc
M: TYPE dispose* [ DBDEL f ] change-handle drop ;
M: TYPE at* ( key db -- value/f ? )
handle>> swap object>bytes dup length 0 <int>
handle>> swap object>bytes dup length 0 int <ref>
DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
: DBKEYS ( db -- keys )
[ assoc-size <vector> ] [ handle>> ] bi
dup DBITERINIT drop 0 <int>
dup DBITERINIT drop 0 int <ref>
[ 2dup DBITERNEXT dup ] [
[ memory>object ] [ tcfree ] bi
[ pick ] dip swap push

7
extra/twitter/twitter.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences
urls.secure fry oauth urls system ;
io.sockets.secure fry oauth urls ;
IN: twitter
! Configuration
@ -20,9 +20,8 @@ twitter-source [ "factor" ] initialize
] with-scope ; inline
: twitter-url ( string -- string' )
os windows?
"http://twitter.com/"
"https://twitter.com/" ? prepend ;
ssl-supported?
"https://twitter.com/" "http://twitter.com/" ? prepend ;
PRIVATE>