Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
7decccf8bb
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.strings alien.c-types alien.data alien.accessors
|
||||
arrays words sequences math kernel namespaces fry cpu.architecture
|
||||
io.encodings.utf8 accessors ;
|
||||
io.encodings.binary io.encodings.utf8 accessors ;
|
||||
IN: alien.arrays
|
||||
|
||||
INSTANCE: array value-type
|
||||
|
|
@ -35,10 +35,7 @@ M: array box-return drop void* box-return ;
|
|||
M: array stack-size drop void* stack-size ;
|
||||
|
||||
M: array c-type-boxer-quot
|
||||
unclip
|
||||
[ array-length ]
|
||||
[ [ require-c-array ] keep ] bi*
|
||||
[ <c-direct-array> ] 2curry ;
|
||||
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
|
|
@ -88,10 +85,14 @@ M: string-type c-type-unboxer
|
|||
drop void* c-type-unboxer ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second '[ _ alien>string ] ;
|
||||
second dup binary =
|
||||
[ drop void* c-type-boxer-quot ]
|
||||
[ '[ _ alien>string ] ] if ;
|
||||
|
||||
M: string-type c-type-unboxer-quot
|
||||
second '[ _ string>alien ] ;
|
||||
second dup binary =
|
||||
[ drop void* c-type-unboxer-quot ]
|
||||
[ '[ _ string>alien ] ] if ;
|
||||
|
||||
M: string-type c-type-getter
|
||||
drop [ alien-cell ] ;
|
||||
|
|
@ -99,8 +100,9 @@ M: string-type c-type-getter
|
|||
M: string-type c-type-setter
|
||||
drop [ set-alien-cell ] ;
|
||||
|
||||
{ char* utf8 } char <pointer> typedef
|
||||
{ char* utf8 } char* typedef
|
||||
char* uchar* typedef
|
||||
{ char* utf8 } uchar <pointer> typedef
|
||||
{ char* binary } byte <pointer> typedef
|
||||
{ char* binary } ubyte <pointer> typedef
|
||||
|
||||
char char* "pointer-c-type" set-word-prop
|
||||
uchar uchar* "pointer-c-type" set-word-prop
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien alien.syntax alien.c-types alien.parser
|
||||
eval kernel tools.test sequences system libc alien.strings
|
||||
io.encodings.utf8 math.constants classes.struct classes
|
||||
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
|
||||
accessors compiler.units ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
|
|
@ -16,34 +16,44 @@ UNION-STRUCT: foo
|
|||
{ a int }
|
||||
{ b int } ;
|
||||
|
||||
[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
|
||||
[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
|
||||
[ t ] [ pointer: void c-type void* c-type = ] unit-test
|
||||
[ t ] [ pointer: int c-type void* c-type = ] unit-test
|
||||
[ t ] [ pointer: int* c-type void* c-type = ] unit-test
|
||||
[ f ] [ pointer: foo c-type void* c-type = ] unit-test
|
||||
[ t ] [ pointer: foo* c-type void* c-type = ] unit-test
|
||||
|
||||
[ t ] [ pointer: char c-type char* c-type = ] unit-test
|
||||
|
||||
[ t ] [ foo heap-size int heap-size = ] unit-test
|
||||
|
||||
TYPEDEF: int MyInt
|
||||
|
||||
[ t ] [ int c-type MyInt c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
|
||||
|
||||
TYPEDEF: char MyChar
|
||||
|
||||
[ t ] [ char c-type MyChar c-type eq? ] unit-test
|
||||
[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
|
||||
[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
|
||||
[ t ] [ int c-type MyInt c-type = ] unit-test
|
||||
[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
|
||||
|
||||
[ 32 ] [ { int 8 } heap-size ] unit-test
|
||||
|
||||
TYPEDEF: char MyChar
|
||||
|
||||
[ t ] [ pointer: char c-type pointer: MyChar c-type = ] unit-test
|
||||
[ t ] [ char* c-type pointer: MyChar c-type = ] unit-test
|
||||
|
||||
TYPEDEF: char MyFunkyChar
|
||||
{ char* ascii } pointer: MyFunkyChar typedef
|
||||
|
||||
[ f ] [ pointer: char c-type pointer: MyFunkyChar c-type = ] unit-test
|
||||
[ { char* ascii } ] [ pointer: MyFunkyChar c-type ] unit-test
|
||||
|
||||
TYPEDEF: char* MyString
|
||||
|
||||
[ t ] [ char* c-type MyString c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
|
||||
[ t ] [ char* c-type MyString c-type = ] unit-test
|
||||
[ t ] [ void* c-type pointer: MyString c-type = ] unit-test
|
||||
|
||||
TYPEDEF: int* MyIntArray
|
||||
|
||||
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
|
||||
|
||||
TYPEDEF: uchar* MyLPBYTE
|
||||
TYPEDEF: char* MyLPBYTE
|
||||
|
||||
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
|
||||
|
||||
|
|
@ -63,7 +73,7 @@ os windows? cpu x86.64? and [
|
|||
|
||||
C-TYPE: opaque
|
||||
|
||||
[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
|
||||
[ t ] [ void* c-type pointer: opaque c-type = ] unit-test
|
||||
[ opaque c-type ] [ no-c-type? ] must-fail-with
|
||||
|
||||
[ """
|
||||
|
|
|
|||
|
|
@ -46,24 +46,17 @@ stack-align? ;
|
|||
|
||||
ERROR: no-c-type name ;
|
||||
|
||||
PREDICATE: c-type-word < word
|
||||
"c-type" word-prop ;
|
||||
|
||||
UNION: c-type-name string c-type-word ;
|
||||
|
||||
! C type protocol
|
||||
GENERIC: c-type ( name -- c-type ) foldable
|
||||
|
||||
GENERIC: resolve-pointer-type ( name -- c-type )
|
||||
PREDICATE: c-type-word < word
|
||||
"c-type" word-prop ;
|
||||
|
||||
<< \ void \ void* "pointer-c-type" set-word-prop >>
|
||||
TUPLE: pointer { to initial: void read-only } ;
|
||||
C: <pointer> pointer
|
||||
|
||||
M: word resolve-pointer-type
|
||||
dup "pointer-c-type" word-prop
|
||||
[ ] [ drop void* ] ?if ;
|
||||
|
||||
M: array resolve-pointer-type
|
||||
first resolve-pointer-type ;
|
||||
UNION: c-type-name
|
||||
c-type-word pointer ;
|
||||
|
||||
: resolve-typedef ( name -- c-type )
|
||||
dup void? [ no-c-type ] when
|
||||
|
|
@ -239,14 +232,13 @@ M: word typedef ( old new -- )
|
|||
{
|
||||
[ nip define-symbol ]
|
||||
[ swap "c-type" set-word-prop ]
|
||||
[
|
||||
swap dup c-type-name? [
|
||||
resolve-pointer-type
|
||||
"pointer-c-type" set-word-prop
|
||||
] [ 2drop ] if
|
||||
]
|
||||
} 2cleave ;
|
||||
|
||||
M: pointer typedef ( old new -- )
|
||||
to>> dup c-type-word?
|
||||
[ swap "pointer-c-type" set-word-prop ]
|
||||
[ 2drop ] if ;
|
||||
|
||||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- c-type )
|
||||
|
|
@ -279,6 +271,10 @@ M: long-long-type box-return ( c-type -- )
|
|||
: if-void ( c-type true false -- )
|
||||
pick void? [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
SYMBOLS:
|
||||
ptrdiff_t intptr_t uintptr_t size_t
|
||||
byte ubyte char* ;
|
||||
|
||||
CONSTANT: primitive-types
|
||||
{
|
||||
char uchar
|
||||
|
|
@ -288,11 +284,39 @@ CONSTANT: primitive-types
|
|||
longlong ulonglong
|
||||
float double
|
||||
void* bool
|
||||
char*
|
||||
}
|
||||
|
||||
SYMBOLS:
|
||||
ptrdiff_t intptr_t uintptr_t size_t
|
||||
char* uchar* ;
|
||||
: (pointer-c-type) ( void* type -- void*' )
|
||||
[ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: resolve-pointer-typedef ( type -- base-type )
|
||||
dup "c-type" word-prop dup word?
|
||||
[ nip resolve-pointer-typedef ] [
|
||||
pointer? [ drop void* ] when
|
||||
] if ;
|
||||
|
||||
: special-pointer-type ( type -- special-type )
|
||||
dup c-type-word? [
|
||||
dup "pointer-c-type" word-prop
|
||||
[ ] [ resolve-pointer-typedef "pointer-c-type" word-prop ] ?if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: primitive-pointer-type? ( type -- ? )
|
||||
dup c-type-word? [
|
||||
resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
|
||||
] [ drop t ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: pointer c-type
|
||||
[ \ void* c-type ] dip
|
||||
to>> dup special-pointer-type
|
||||
[ nip ] [
|
||||
dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if
|
||||
] ?if ;
|
||||
|
||||
: 8-byte-alignment ( c-type -- c-type )
|
||||
{
|
||||
|
|
@ -505,6 +529,9 @@ SYMBOLS:
|
|||
\ uint c-type \ uintptr_t typedef
|
||||
\ uint c-type \ size_t typedef
|
||||
] if
|
||||
|
||||
\ char \ byte typedef
|
||||
\ uchar \ ubyte typedef
|
||||
] with-compilation-unit
|
||||
|
||||
M: char-16-rep rep-component-type drop char ;
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ alien.data alien.fortran alien.fortran.private alien.strings
|
|||
classes.struct arrays assocs byte-arrays combinators fry
|
||||
generalizations io.encodings.ascii kernel macros
|
||||
macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
|
||||
FROM: alien.syntax => pointer: ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: alien.fortran.tests
|
||||
|
||||
|
|
@ -100,16 +101,16 @@ intel-unix-abi fortran-abi [
|
|||
|
||||
! fortran-arg-type>c-type
|
||||
|
||||
[ c:void* { } ]
|
||||
[ pointer: c:int { } ]
|
||||
[ "integer" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ c:void* { } ]
|
||||
[ pointer: { c:int 3 } { } ]
|
||||
[ "integer(3)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ c:void* { } ]
|
||||
[ pointer: { c:int 0 } { } ]
|
||||
[ "integer(*)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ c:void* { } ]
|
||||
[ pointer: fortran_test_record { } ]
|
||||
[
|
||||
[
|
||||
"alien.fortran.tests" use-vocab
|
||||
|
|
@ -117,13 +118,13 @@ intel-unix-abi fortran-abi [
|
|||
] with-manifest
|
||||
] unit-test
|
||||
|
||||
[ c:char* { } ]
|
||||
[ pointer: c:char { } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ c:char* { } ]
|
||||
[ pointer: c:char { } ]
|
||||
[ "character(1)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ c:char* { long } ]
|
||||
[ pointer: { c:char 17 } { long } ]
|
||||
[ "character(17)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
! fortran-ret-type>c-type
|
||||
|
|
@ -131,7 +132,7 @@ intel-unix-abi fortran-abi [
|
|||
[ c:char { } ]
|
||||
[ "character(1)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:char* long } ]
|
||||
[ c:void { pointer: { c:char 17 } long } ]
|
||||
[ "character(17)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:int { } ]
|
||||
|
|
@ -143,22 +144,22 @@ intel-unix-abi fortran-abi [
|
|||
[ c:float { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:void* } ]
|
||||
[ c:void { pointer: { c:float 0 } } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:double { } ]
|
||||
[ "double-precision" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:void* } ]
|
||||
[ c:void { pointer: complex-float } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:void* } ]
|
||||
[ c:void { pointer: complex-double } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:void* } ]
|
||||
[ c:void { pointer: { c:int 0 } } ]
|
||||
[ "integer(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:void* } ]
|
||||
[ c:void { pointer: fortran_test_record } ]
|
||||
[
|
||||
[
|
||||
"alien.fortran.tests" use-vocab
|
||||
|
|
@ -168,19 +169,19 @@ intel-unix-abi fortran-abi [
|
|||
|
||||
! fortran-sig>c-sig
|
||||
|
||||
[ c:float { c:void* c:char* c:void* c:void* c:long } ]
|
||||
[ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
|
||||
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ c:char { c:char* c:char* c:void* c:long } ]
|
||||
[ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
|
||||
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
|
||||
[ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
|
||||
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ c:void { c:void* c:char* c:char* c:void* c:long } ]
|
||||
[ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
|
||||
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
|
|
@ -201,7 +202,7 @@ intel-unix-abi fortran-abi [
|
|||
! [fortran-invoke]
|
||||
[
|
||||
c:void "funpack" "funtimes_"
|
||||
{ c:char* c:void* c:void* c:void* c:void* c:long }
|
||||
{ pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
|
||||
alien-invoke
|
||||
] 6 nkeep
|
||||
! [fortran-results>]
|
||||
|
|
@ -226,7 +227,7 @@ intel-unix-abi fortran-abi [
|
|||
[ { [ drop ] } spread ]
|
||||
} 1 ncleave
|
||||
! [fortran-invoke]
|
||||
[ c:float "funpack" "fun_times_" { void* } alien-invoke ]
|
||||
[ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
|
||||
1 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta aa -- reta aa )
|
||||
|
|
@ -244,7 +245,7 @@ intel-unix-abi fortran-abi [
|
|||
! [fortran-invoke]
|
||||
[
|
||||
c:void "funpack" "fun_times_"
|
||||
{ void* void* }
|
||||
{ pointer: complex-float pointer: { c:float 0 } }
|
||||
alien-invoke
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
|
|
@ -261,7 +262,7 @@ intel-unix-abi fortran-abi [
|
|||
! [fortran-invoke]
|
||||
[
|
||||
c:void "funpack" "fun_times_"
|
||||
{ c:char* long }
|
||||
{ pointer: { c:char 20 } long }
|
||||
alien-invoke
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
|
|
@ -287,7 +288,7 @@ intel-unix-abi fortran-abi [
|
|||
! [fortran-invoke]
|
||||
[
|
||||
c:void "funpack" "fun_times_"
|
||||
{ c:char* long c:char* c:void* c:char* c:long c:long }
|
||||
{ pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long }
|
||||
alien-invoke
|
||||
] 7 nkeep
|
||||
! [fortran-results>]
|
||||
|
|
@ -321,16 +322,16 @@ f2c-abi fortran-abi [
|
|||
[ { c:char 1 } ]
|
||||
[ "character(1)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ c:char* { c:long } ]
|
||||
[ pointer: c:char { c:long } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:char* c:long } ]
|
||||
[ c:void { pointer: c:char c:long } ]
|
||||
[ "character" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:double { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { void* } ]
|
||||
[ c:void { pointer: { c:float 0 } } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
|
|
@ -344,7 +345,7 @@ gfortran-abi fortran-abi [
|
|||
[ c:float { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { void* } ]
|
||||
[ c:void { pointer: { c:float 0 } } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ complex-float { } ]
|
||||
|
|
@ -356,10 +357,10 @@ gfortran-abi fortran-abi [
|
|||
[ { char 1 } ]
|
||||
[ "character(1)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ c:char* { c:long } ]
|
||||
[ pointer: c:char { c:long } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:char* c:long } ]
|
||||
[ c:void { pointer: c:char c:long } ]
|
||||
[ "character" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ complex-float { } ]
|
||||
|
|
@ -368,7 +369,7 @@ gfortran-abi fortran-abi [
|
|||
[ complex-double { } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ c:void { c:void* } ]
|
||||
[ c:void { pointer: { complex-double 3 } } ]
|
||||
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
] with-variable
|
||||
|
|
|
|||
|
|
@ -392,13 +392,13 @@ PRIVATE>
|
|||
|
||||
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
|
||||
parse-fortran-type
|
||||
[ (fortran-type>c-type) resolve-pointer-type ]
|
||||
[ (fortran-type>c-type) <pointer> ]
|
||||
[ added-c-args ] bi ;
|
||||
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
|
||||
parse-fortran-type dup returns-by-value?
|
||||
[ (fortran-ret-type>c-type) { } ] [
|
||||
c:void swap
|
||||
[ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
|
||||
[ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
|
||||
] if ;
|
||||
|
||||
: fortran-arg-types>c-types ( fortran-types -- c-types )
|
||||
|
|
|
|||
|
|
@ -18,20 +18,16 @@ CONSTANT: eleven 11
|
|||
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
|
||||
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
|
||||
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
|
||||
[ void* ] [ "int*" parse-c-type ] unit-test
|
||||
[ void* ] [ "int**" parse-c-type ] unit-test
|
||||
[ void* ] [ "int***" parse-c-type ] unit-test
|
||||
[ void* ] [ "int****" parse-c-type ] unit-test
|
||||
[ char* ] [ "char*" parse-c-type ] unit-test
|
||||
[ void* ] [ "char**" parse-c-type ] unit-test
|
||||
[ void* ] [ "char***" parse-c-type ] unit-test
|
||||
[ void* ] [ "char****" parse-c-type ] unit-test
|
||||
[ pointer: void ] [ "void*" parse-c-type ] unit-test
|
||||
[ pointer: int ] [ "int*" parse-c-type ] unit-test
|
||||
[ pointer: int* ] [ "int**" parse-c-type ] unit-test
|
||||
[ pointer: int** ] [ "int***" parse-c-type ] unit-test
|
||||
[ pointer: int*** ] [ "int****" parse-c-type ] unit-test
|
||||
[ pointer: char ] [ "char*" parse-c-type ] unit-test
|
||||
[ char2 ] [ "char2" parse-c-type ] unit-test
|
||||
[ char* ] [ "char2*" parse-c-type ] unit-test
|
||||
[ pointer: char2 ] [ "char2*" parse-c-type ] unit-test
|
||||
|
||||
[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
|
||||
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
|
||||
|
||||
] with-file-vocabs
|
||||
|
||||
FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
|
||||
|
|
|
|||
|
|
@ -18,22 +18,23 @@ IN: alien.parser
|
|||
{
|
||||
{ [ dup "void" = ] [ drop void ] }
|
||||
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
|
||||
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
|
||||
{ [ dup search ] [ parse-c-type-name ] }
|
||||
{ [ "**" ?tail ] [ drop void* ] }
|
||||
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
|
||||
[ dup search [ ] [ no-word ] ?if ]
|
||||
} cond ;
|
||||
|
||||
: valid-c-type? ( c-type -- ? )
|
||||
{ [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
|
||||
{ [ array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
|
||||
|
||||
: parse-c-type ( string -- type )
|
||||
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
|
||||
|
||||
: scan-c-type ( -- c-type )
|
||||
scan dup "{" =
|
||||
[ drop \ } parse-until >array ]
|
||||
[ parse-c-type ] if ;
|
||||
scan {
|
||||
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
|
||||
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
|
||||
[ parse-c-type ]
|
||||
} cond ;
|
||||
|
||||
: reset-c-type ( word -- )
|
||||
dup "struct-size" word-prop
|
||||
|
|
@ -61,12 +62,20 @@ IN: alien.parser
|
|||
] bi
|
||||
[ parse-c-type ] dip ;
|
||||
|
||||
<PRIVATE
|
||||
GENERIC: return-type-name ( type -- name )
|
||||
|
||||
M: object return-type-name drop "void" ;
|
||||
M: word return-type-name name>> ;
|
||||
M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
|
||||
PRIVATE>
|
||||
|
||||
: parse-arglist ( parameters return -- types effect )
|
||||
[
|
||||
2 group [ first2 normalize-c-arg 2array ] map
|
||||
unzip [ "," ?tail drop ] map
|
||||
]
|
||||
[ [ { } ] [ name>> 1array ] if-void ]
|
||||
[ [ { } ] [ return-type-name 1array ] if-void ]
|
||||
bi* <effect> ;
|
||||
|
||||
: function-quot ( return library function types -- quot )
|
||||
|
|
|
|||
|
|
@ -19,12 +19,25 @@ M: c-type-word definer drop \ C-TYPE: f ;
|
|||
M: c-type-word definition drop f ;
|
||||
M: c-type-word declarations. drop ;
|
||||
|
||||
<PRIVATE
|
||||
GENERIC: pointer-string ( pointer -- string/f )
|
||||
M: object pointer-string drop f ;
|
||||
M: word pointer-string name>> ;
|
||||
M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: pprint-c-type ( c-type -- )
|
||||
M: word pprint-c-type pprint-word ;
|
||||
M: pointer pprint-c-type
|
||||
dup pointer-string
|
||||
[ swap present-text ]
|
||||
[ pprint* ] if* ;
|
||||
M: wrapper pprint-c-type wrapped>> pprint-word ;
|
||||
M: string pprint-c-type text ;
|
||||
M: array pprint-c-type pprint* ;
|
||||
|
||||
M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
|
||||
|
||||
M: typedef-word definer drop \ TYPEDEF: f ;
|
||||
|
||||
M: typedef-word synopsis*
|
||||
|
|
|
|||
|
|
@ -47,3 +47,6 @@ SYNTAX: &:
|
|||
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
|
||||
|
||||
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
|
||||
|
||||
SYNTAX: pointer:
|
||||
scan-c-type <pointer> suffix! ;
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ TYPEDEF: void* cairo_pattern_t
|
|||
|
||||
TYPEDEF: void* cairo_destroy_func_t
|
||||
: cairo-destroy-func ( quot -- callback )
|
||||
[ void { void* } "cdecl" ] dip alien-callback ; inline
|
||||
[ void { pointer: void } "cdecl" ] dip alien-callback ; inline
|
||||
|
||||
! See cairo.h for details
|
||||
STRUCT: cairo_user_data_key_t
|
||||
|
|
@ -79,11 +79,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
|
|||
|
||||
TYPEDEF: void* cairo_write_func_t
|
||||
: cairo-write-func ( quot -- callback )
|
||||
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
|
||||
[ cairo_status_t { pointer: void pointer: uchar int } "cdecl" ] dip alien-callback ; inline
|
||||
|
||||
TYPEDEF: void* cairo_read_func_t
|
||||
: cairo-read-func ( quot -- callback )
|
||||
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
|
||||
[ cairo_status_t { pointer: void pointer: uchar int } "cdecl" ] dip alien-callback ; inline
|
||||
|
||||
! Functions for manipulating state objects
|
||||
FUNCTION: cairo_t*
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: calendar.unix
|
|||
timespec>seconds since-1970 ;
|
||||
|
||||
: get-time ( -- alien )
|
||||
f time <time_t> localtime tm memory>struct ;
|
||||
f time <time_t> localtime ;
|
||||
|
||||
: timezone-name ( -- string )
|
||||
get-time zone>> ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors alien alien.c-types alien.data ascii
|
||||
USING: accessors alien alien.c-types alien.data alien.syntax ascii
|
||||
assocs byte-arrays classes.struct classes.tuple.private classes.tuple
|
||||
combinators compiler.tree.debugger compiler.units destructors
|
||||
io.encodings.utf8 io.pathnames io.streams.string kernel libc
|
||||
|
|
@ -374,6 +374,63 @@ STRUCT: bit-field-test
|
|||
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
|
||||
[ 3 ] [ bit-field-test heap-size ] unit-test
|
||||
|
||||
STRUCT: referent
|
||||
{ y int } ;
|
||||
STRUCT: referrer
|
||||
{ x referent* } ;
|
||||
|
||||
[ 57 ] [
|
||||
[
|
||||
referrer <struct>
|
||||
referent malloc-struct &free
|
||||
57 >>y
|
||||
>>x
|
||||
x>> y>>
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
STRUCT: self-referent
|
||||
{ x self-referent* }
|
||||
{ y int } ;
|
||||
|
||||
[ 75 ] [
|
||||
[
|
||||
self-referent <struct>
|
||||
self-referent malloc-struct &free
|
||||
75 >>y
|
||||
>>x
|
||||
x>> y>>
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
C-TYPE: forward-referent
|
||||
STRUCT: backward-referent
|
||||
{ x forward-referent* }
|
||||
{ y int } ;
|
||||
STRUCT: forward-referent
|
||||
{ x backward-referent* }
|
||||
{ y int } ;
|
||||
|
||||
[ 41 ] [
|
||||
[
|
||||
forward-referent <struct>
|
||||
backward-referent malloc-struct &free
|
||||
41 >>y
|
||||
>>x
|
||||
x>> y>>
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[ 14 ] [
|
||||
[
|
||||
backward-referent <struct>
|
||||
forward-referent malloc-struct &free
|
||||
14 >>y
|
||||
>>x
|
||||
x>> y>>
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
cpu ppc? [
|
||||
STRUCT: ppc-align-test-1
|
||||
{ x longlong }
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@ generalizations generic.parser kernel kernel.private lexer libc
|
|||
locals macros make math math.order parser quotations sequences
|
||||
slots slots.private specialized-arrays vectors words summary
|
||||
namespaces assocs vocabs.parser math.functions
|
||||
classes.struct.bit-accessors bit-arrays ;
|
||||
classes.struct.bit-accessors bit-arrays
|
||||
stack-checker.dependencies ;
|
||||
QUALIFIED: math
|
||||
IN: classes.struct
|
||||
|
||||
|
|
@ -124,6 +125,14 @@ M: struct-bit-slot-spec (writer-quot)
|
|||
|
||||
: (unboxer-quot) ( class -- quot )
|
||||
drop [ >c-ptr ] ;
|
||||
|
||||
MACRO: read-struct-slot ( slot -- )
|
||||
dup type>> depends-on-c-type
|
||||
(reader-quot) ;
|
||||
|
||||
MACRO: write-struct-slot ( slot -- )
|
||||
dup type>> depends-on-c-type
|
||||
(writer-quot) ;
|
||||
PRIVATE>
|
||||
|
||||
M: struct-class boa>object
|
||||
|
|
@ -138,10 +147,11 @@ M: struct-class initial-value* <struct> ; inline
|
|||
GENERIC: struct-slot-values ( struct -- sequence )
|
||||
|
||||
M: struct-class reader-quot
|
||||
nip (reader-quot) ;
|
||||
dup array? [ dup first define-array-vocab drop ] when
|
||||
nip '[ _ read-struct-slot ] ;
|
||||
|
||||
M: struct-class writer-quot
|
||||
nip (writer-quot) ;
|
||||
nip '[ _ write-struct-slot ] ;
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
struct-slots slot-named offset>> ; inline
|
||||
|
|
|
|||
|
|
@ -99,8 +99,8 @@ CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
|
|||
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
|
||||
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
|
||||
|
||||
TYPEDEF: void* sqlite3*
|
||||
TYPEDEF: void* sqlite3_stmt*
|
||||
C-TYPE: sqlite3
|
||||
C-TYPE: sqlite3_stmt
|
||||
TYPEDEF: longlong sqlite3_int64
|
||||
TYPEDEF: ulonglong sqlite3_uint64
|
||||
|
||||
|
|
@ -121,7 +121,7 @@ FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64
|
|||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
|
||||
int "sqlite" "sqlite3_bind_int64"
|
||||
{ sqlite3_stmt* int sqlite3_uint64 } alien-invoke ;
|
||||
{ pointer: sqlite3_stmt int sqlite3_uint64 } alien-invoke ;
|
||||
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
|
||||
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
|
||||
|
|
@ -135,7 +135,7 @@ FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
|
|||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-column-uint64 ( pStmt col -- uint64 )
|
||||
sqlite3_uint64 "sqlite" "sqlite3_column_int64"
|
||||
{ sqlite3_stmt* int } alien-invoke ;
|
||||
{ pointer: sqlite3_stmt int } alien-invoke ;
|
||||
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
|
||||
|
|
|
|||
|
|
@ -94,7 +94,6 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
|
||||
: find-device-axes-callback ( -- alien )
|
||||
[ ! ( lpddoi pvRef -- BOOL )
|
||||
[ DIDEVICEOBJECTINSTANCEW memory>struct ] dip
|
||||
+controller-devices+ get at
|
||||
swap guidType>> {
|
||||
{ [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
|
||||
|
|
@ -142,7 +141,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
|
||||
: find-controller-callback ( -- alien )
|
||||
[ ! ( lpddi pvRef -- BOOL )
|
||||
drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller
|
||||
drop guidInstance>> add-controller
|
||||
DIENUM_CONTINUE
|
||||
] LPDIENUMDEVICESCALLBACKW ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -241,7 +241,7 @@ HOOK: (send) io-backend ( packet addrspec datagram -- )
|
|||
parse-sockaddr ;
|
||||
|
||||
: parse-addrinfo-list ( addrinfo -- seq )
|
||||
[ next>> dup [ addrinfo memory>struct ] when ] follow
|
||||
[ next>> ] follow
|
||||
[ addrinfo>addrspec ] map
|
||||
sift ;
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ TYPEDEF: float GLfloat
|
|||
TYPEDEF: float GLclampf
|
||||
TYPEDEF: double GLdouble
|
||||
TYPEDEF: double GLclampd
|
||||
TYPEDEF: void* GLvoid*
|
||||
C-TYPE: GLvoid
|
||||
|
||||
! Constants
|
||||
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ FUNCTION: void* BIO_f_buffer ( ) ;
|
|||
|
||||
CONSTANT: EVP_MAX_MD_SIZE 64
|
||||
|
||||
TYPEDEF: void* EVP_MD*
|
||||
C-TYPE: EVP_MD
|
||||
C-TYPE: ENGINE
|
||||
|
||||
STRUCT: EVP_MD_CTX
|
||||
|
|
|
|||
|
|
@ -89,8 +89,8 @@ CONSTANT: SSL_ERROR_WANT_ACCEPT 8
|
|||
} ;
|
||||
|
||||
TYPEDEF: void* ssl-method
|
||||
TYPEDEF: void* SSL_CTX*
|
||||
TYPEDEF: void* SSL_SESSION*
|
||||
C-TYPE: SSL_CTX
|
||||
C-TYPE: SSL_SESSION
|
||||
C-TYPE: SSL
|
||||
|
||||
LIBRARY: libssl
|
||||
|
|
@ -99,8 +99,7 @@ LIBRARY: libssl
|
|||
! x509.h
|
||||
! ===============================================
|
||||
|
||||
TYPEDEF: void* X509_NAME*
|
||||
|
||||
C-TYPE: X509_NAME
|
||||
C-TYPE: X509
|
||||
|
||||
FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
|
||||
|
|
|
|||
|
|
@ -116,15 +116,18 @@ M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
|
|||
|
||||
;FUNCTOR
|
||||
|
||||
: (underlying-type) ( word -- c-type ) "c-type" word-prop ; inline
|
||||
|
||||
: underlying-type ( c-type -- c-type' )
|
||||
dup (underlying-type) {
|
||||
GENERIC: underlying-type ( c-type -- c-type' )
|
||||
M: c-type-word underlying-type
|
||||
dup "c-type" word-prop {
|
||||
{ [ dup not ] [ drop no-c-type ] }
|
||||
{ [ dup c-type-name? ] [ nip underlying-type ] }
|
||||
{ [ dup pointer? ] [ 2drop void* ] }
|
||||
{ [ dup c-type-word? ] [ nip underlying-type ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: pointer underlying-type
|
||||
drop void* ;
|
||||
|
||||
: specialized-array-vocab ( c-type -- vocab )
|
||||
[
|
||||
"specialized-arrays.instances." %
|
||||
|
|
@ -140,24 +143,25 @@ PRIVATE>
|
|||
[ specialized-array-vocab ] [ '[ _ define-array ] ] bi
|
||||
generate-vocab ;
|
||||
|
||||
M: c-type-name require-c-array define-array-vocab drop ;
|
||||
|
||||
ERROR: specialized-array-vocab-not-loaded c-type ;
|
||||
|
||||
M: c-type-name c-array-constructor
|
||||
M: c-type-word c-array-constructor
|
||||
underlying-type
|
||||
dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
M: pointer c-array-constructor drop void* c-array-constructor ;
|
||||
|
||||
M: c-type-name c-(array)-constructor
|
||||
M: c-type-word c-(array)-constructor
|
||||
underlying-type
|
||||
dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
M: pointer c-(array)-constructor drop void* c-(array)-constructor ;
|
||||
|
||||
M: c-type-name c-direct-array-constructor
|
||||
M: c-type-word c-direct-array-constructor
|
||||
underlying-type
|
||||
dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
|
||||
|
||||
SYNTAX: SPECIALIZED-ARRAYS:
|
||||
";" parse-tokens [ parse-c-type define-array-vocab use-vocab ] each ;
|
||||
|
|
|
|||
|
|
@ -47,6 +47,9 @@ M: c-type-word depends-on-c-type depends-on-definition ;
|
|||
M: array depends-on-c-type
|
||||
[ word? ] filter [ depends-on-definition ] each ;
|
||||
|
||||
M: pointer depends-on-c-type
|
||||
to>> depends-on-c-type ;
|
||||
|
||||
! Generic words that the current quotation depends on
|
||||
SYMBOL: generic-dependencies
|
||||
|
||||
|
|
|
|||
|
|
@ -49,8 +49,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
|
|||
|
||||
M: x11-ui-backend (make-pixel-format)
|
||||
[ drop dpy get scr get ] dip
|
||||
>glx-visual-int-array glXChooseVisual
|
||||
XVisualInfo memory>struct ;
|
||||
>glx-visual-int-array glXChooseVisual ;
|
||||
|
||||
M: x11-ui-backend (free-pixel-format)
|
||||
handle>> XFree ;
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ M: integer user-groups ( id -- seq )
|
|||
user-name (user-groups) ;
|
||||
|
||||
: all-groups ( -- seq )
|
||||
[ unix.ffi:getgrent dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ;
|
||||
[ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip ;
|
||||
|
||||
: <group-cache> ( -- assoc )
|
||||
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ PRIVATE>
|
|||
|
||||
: all-users ( -- seq )
|
||||
[
|
||||
[ unix.ffi:getpwent dup ] [ unix.ffi:passwd memory>struct passwd>new-passwd ] produce nip
|
||||
[ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
|
||||
] with-pwent ;
|
||||
|
||||
SYMBOL: user-cache
|
||||
|
|
@ -52,10 +52,10 @@ GENERIC: user-passwd ( obj -- passwd/f )
|
|||
|
||||
M: integer user-passwd ( id -- passwd/f )
|
||||
user-cache get
|
||||
[ at ] [ unix.ffi:getpwuid [ unix.ffi:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ;
|
||||
[ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
|
||||
|
||||
M: string user-passwd ( string -- passwd/f )
|
||||
unix.ffi:getpwnam dup [ unix.ffi:passwd memory>struct passwd>new-passwd ] when ;
|
||||
unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
|
||||
|
||||
: user-name ( id -- string )
|
||||
dup user-passwd
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ M: unix new-utmpx-record
|
|||
utmpx-record new ;
|
||||
|
||||
M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
|
||||
[ new-utmpx-record ] dip \ utmpx memory>struct
|
||||
[ new-utmpx-record ] dip
|
||||
{
|
||||
[ ut_user>> _UTX_USERSIZE memory>string >>user ]
|
||||
[ ut_id>> _UTX_IDSIZE memory>string >>id ]
|
||||
|
|
|
|||
|
|
@ -49,8 +49,7 @@ unless
|
|||
: (make-query-interface) ( interfaces -- quot )
|
||||
(query-interface-cases)
|
||||
'[
|
||||
swap GUID memory>struct
|
||||
_ case
|
||||
swap _ case
|
||||
[
|
||||
void* heap-size * rot <displaced-alien> com-add-ref
|
||||
swap 0 set-alien-cell S_OK
|
||||
|
|
|
|||
|
|
@ -11,11 +11,7 @@ TYPEDEF: uchar UCHAR
|
|||
TYPEDEF: uchar BYTE
|
||||
|
||||
TYPEDEF: ushort wchar_t
|
||||
SYMBOL: wchar_t*
|
||||
<<
|
||||
{ char* utf16n } \ wchar_t* typedef
|
||||
\ wchar_t \ wchar_t* "pointer-c-type" set-word-prop
|
||||
>>
|
||||
TYPEDEF: { char* utf16n } wchar_t*
|
||||
|
||||
TYPEDEF: wchar_t WCHAR
|
||||
|
||||
|
|
|
|||
|
|
@ -82,7 +82,6 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
|
|||
: script-string-size ( script-string -- dim )
|
||||
ssa>> ScriptString_pSize
|
||||
dup win32-error=0/f
|
||||
SIZE memory>struct
|
||||
[ cx>> ] [ cy>> ] bi 2array ;
|
||||
|
||||
: dc-metrics ( dc -- metrics )
|
||||
|
|
|
|||
|
|
@ -267,7 +267,7 @@ test-server-slot-values
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- )
|
||||
"IN: classes.tuple.tests TUPLE: invalid-superclass < word ;" eval( -- )
|
||||
] must-fail
|
||||
|
||||
! Dynamically changing inheritance hierarchy
|
||||
|
|
|
|||
|
|
@ -512,9 +512,9 @@ FUNCTION: void cpArbiterIgnore ( cpArbiter* arb ) ;
|
|||
|
||||
TYPED: cpArbiterGetShapes ( arb: cpArbiter -- a: cpShape b: cpShape )
|
||||
dup swappedColl>> 0 = [
|
||||
[ a>> cpShape memory>struct ] [ b>> cpShape memory>struct ] bi
|
||||
[ a>> ] [ b>> ] bi
|
||||
] [
|
||||
[ b>> cpShape memory>struct ] [ a>> cpShape memory>struct ] bi
|
||||
[ b>> ] [ a>> ] bi
|
||||
] if ; inline
|
||||
|
||||
TYPED: cpArbiterIsFirstContact ( arb: cpArbiter -- ? )
|
||||
|
|
|
|||
|
|
@ -50,9 +50,9 @@ CONSTANT: image-bitmap B{
|
|||
x bitnot 7 bitand neg shift 1 bitand 1 = ;
|
||||
|
||||
:: make-ball ( x y -- shape )
|
||||
cpBodyAlloc 1.0 NAN: 0 cpBodyInit cpBody memory>struct
|
||||
cpBodyAlloc 1.0 NAN: 0 cpBodyInit
|
||||
x y cpv >>p :> body
|
||||
cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit cpCircleShape memory>struct
|
||||
cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit
|
||||
[ shape>> 0 >>e ] [ shape>> 0 >>u ] bi drop ;
|
||||
|
||||
TUPLE: chipmunk-world < game-world
|
||||
|
|
@ -76,7 +76,7 @@ M:: chipmunk-world draw-world* ( world -- )
|
|||
3 glPointSize
|
||||
0 0 0 glColor3f
|
||||
GL_POINTS glBegin
|
||||
space bodies>> cpArray memory>struct
|
||||
space bodies>>
|
||||
[ num>> ] [ arr>> swap <direct-void*-array> ] bi [
|
||||
cpBody memory>struct p>> [ x>> ] [ y>> ] bi glVertex2f
|
||||
] each
|
||||
|
|
@ -85,7 +85,7 @@ M:: chipmunk-world draw-world* ( world -- )
|
|||
2 glPointSize
|
||||
1 0 0 glColor3f
|
||||
GL_POINTS glBegin
|
||||
space arbiters>> cpArray memory>struct
|
||||
space arbiters>>
|
||||
[ num>> ] [ arr>> swap <direct-void*-array> ] bi [
|
||||
cpArbiter memory>struct
|
||||
[ numContacts>> ] [ contacts>> swap <direct-cpContact-array> ] bi [
|
||||
|
|
@ -97,7 +97,7 @@ M:: chipmunk-world draw-world* ( world -- )
|
|||
M:: chipmunk-world begin-game-world ( world -- )
|
||||
cpInitChipmunk
|
||||
|
||||
cpSpaceAlloc cpSpaceInit cpSpace memory>struct :> space
|
||||
cpSpaceAlloc cpSpaceInit :> space
|
||||
|
||||
world space >>space drop
|
||||
space 2.0 10000 cpSpaceResizeActiveHash
|
||||
|
|
@ -115,11 +115,11 @@ M:: chipmunk-world begin-game-world ( world -- )
|
|||
] each
|
||||
] each
|
||||
|
||||
space cpBodyAlloc NAN: 0 dup cpBodyInit cpSpaceAddBody cpBody memory>struct :> body
|
||||
space cpBodyAlloc NAN: 0 dup cpBodyInit cpSpaceAddBody :> body
|
||||
body -1000 -10 cpv >>p drop
|
||||
body 400 0 cpv >>v drop
|
||||
|
||||
space cpCircleShapeAlloc body 8 0 0 cpv cpCircleShapeInit cpSpaceAddShape cpCircleShape memory>struct :> shape
|
||||
space cpCircleShapeAlloc body 8 0 0 cpv cpCircleShapeInit cpSpaceAddShape :> shape
|
||||
shape
|
||||
[ shape>> 0 >>e drop ]
|
||||
[ shape>> 0 >>u drop ] bi ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue