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

Added alien.marshall and modified alien.inline accordingly

db4
Jeremy Hughes 2009-07-05 17:28:13 +12:00
parent 284ef4f048
commit 577420b7dd
7 changed files with 287 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
basis/alien/inline/inline.factor
View File

@ -1,20 +1,13 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.inline.compiler alien.libraries
alien.parser arrays assocs effects fry generalizations grouping
io.files io.files.info io.files.temp kernel lexer math
math.order math.ranges multiline namespaces sequences splitting
USING: accessors alien.inline.compiler alien.inline.types
alien.libraries alien.marshall alien.parser arrays assocs
combinators effects fry generalizations grouping io.files
io.files.info io.files.temp kernel lexer locals math math.order
math.ranges multiline namespaces quotations sequences splitting
strings system vocabs.loader vocabs.parser words ;
IN: alien.inline
: factorize-type ( str -- str' )
"const-" ?head drop
"unsigned-" ?head [ "u" prepend ] when
"long-" ?head [ "long" prepend ] when ;
: cify-type ( str -- str' )
{ { CHAR: ~ CHAR: space } } substitute ;
<PRIVATE
SYMBOL: c-library
SYMBOL: library-is-c++
@ -48,6 +41,18 @@ SYMBOL: c-strings
types-effect>params-return factorize-type -roll
concat make-function ;
:: marshalled-function ( function types effect -- word quot effect )
function types effect factor-function
[ in>> ]
[ out>> types [ pointer-to-primitive? ] filter append ]
bi <effect>
[
types [ marshaller ] map \ spread rot
types length \ nkeep
types [ out-arg-unmarshaller ] map \ spread
7 narray >quotation
] dip ;
: prototype-string ( function types effect -- str )
[ [ cify-type ] map ] dip
types-effect>params-return cify-type -rot
@ -95,6 +100,14 @@ PRIVATE>
[ in>> ] keep [ factor-function define-declared ] 3keep
out>> prototype-string' ;
: define-c-marshalled ( function types effect -- prototype )
[ marshalled-function define-declared ] 3keep
prototype-string ;
: define-c-marshalled' ( function effect -- prototype )
[ in>> ] keep [ marshalled-function define-declared ] 3keep
out>> prototype-string' ;
: define-c-link ( str -- )
"-l" prepend compiler-args get push ;
@ -123,4 +136,8 @@ SYNTAX: C-FUNCTION:
function-types-effect define-c-function
append-function-body c-strings get push ;
SYNTAX: C-MARSHALLED:
function-types-effect define-c-marshalled
append-function-body c-strings get push ;
SYNTAX: ;C-LIBRARY compile-c-library ;

1
basis/alien/inline/types/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

32
basis/alien/inline/types/types.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types assocs combinators.short-circuit fry
kernel memoize sequences splitting ;
IN: alien.inline.types
: factorize-type ( str -- str' )
"const-" ?head drop
"unsigned-" ?head [ "u" prepend ] when
"long-" ?head [ "long" prepend ] when ;
: cify-type ( str -- str' )
{ { CHAR: ~ CHAR: space } } substitute ;
: const-type? ( str -- ? )
"const-" head? ;
MEMO: resolved-primitives ( -- seq )
primitive-types [ resolve-typedef ] map ;
: primitive-type? ( type -- ? )
factorize-type resolve-typedef [ resolved-primitives ] dip
'[ _ = ] any? ;
: pointer? ( type -- ? )
[ "*" tail? ] [ "&" tail? ] bi or ;
: type-sans-pointer ( type -- type' )
[ '[ _ = ] "*&" swap any? ] trim-tail ;
: pointer-to-primitive? ( type -- ? )
{ [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;

1
basis/alien/marshall/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

179
basis/alien/marshall/marshall.factor Normal file
View File

@ -0,0 +1,179 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.inline.types
alien.marshall.private
alien.strings byte-arrays classes combinators
combinators.short-circuit destructors fry
io.encodings.utf8 kernel sequences
specialized-arrays.alien
specialized-arrays.bool specialized-arrays.char
specialized-arrays.double specialized-arrays.float
specialized-arrays.int specialized-arrays.long
specialized-arrays.longlong specialized-arrays.ulonglong
specialized-arrays.short specialized-arrays.uchar
specialized-arrays.uint specialized-arrays.ulong
specialized-arrays.ushort strings unix.utilities
vocabs.parser words ;
IN: alien.marshall
<< primitive-types [ "void*" = not ] filter
[ define-primitive-marshallers ] each >>
TUPLE: alien-wrapper { underlying alien } ;
GENERIC: dynamic-cast ( alien-wrapper -- alien-wrapper' )
M: alien-wrapper dynamic-cast ;
: marshall-pointer ( obj -- alien )
{
{ [ dup alien? ] [ ] }
{ [ dup not ] [ ] }
{ [ dup byte-array? ] [ malloc-byte-array ] }
{ [ dup alien-wrapper? ] [ underlying>> ] }
} cond ;
: marshall-void* ( obj -- alien )
marshall-pointer ;
: marshall-void** ( obj -- alien )
[ marshall-void* ] map >void*-array malloc-underlying ;
: marshall-char*-or-string ( n/string -- alien )
dup string?
[ utf8 string>alien malloc-byte-array ]
[ marshall-char* ] if ;
: marshall-char**-or-strings ( seq -- alien )
dup first string?
[ utf8 strings>alien malloc-byte-array ]
[ marshall-char** ] if ;
: primitive-marshaller ( type -- quot/f )
{
{ "bool" [ [ marshall-bool ] ] }
{ "char" [ [ marshall-char ] ] }
{ "uchar" [ [ marshall-uchar ] ] }
{ "short" [ [ marshall-short ] ] }
{ "ushort" [ [ marshall-ushort ] ] }
{ "int" [ [ marshall-int ] ] }
{ "uint" [ [ marshall-uint ] ] }
{ "long" [ [ marshall-long ] ] }
{ "ulong" [ [ marshall-ulong ] ] }
{ "float" [ [ marshall-float ] ] }
{ "double" [ [ marshall-double ] ] }
{ "bool*" [ [ marshall-bool* ] ] }
{ "char*" [ [ marshall-char*-or-string ] ] }
{ "uchar*" [ [ marshall-uchar* ] ] }
{ "short*" [ [ marshall-short* ] ] }
{ "ushort*" [ [ marshall-ushort* ] ] }
{ "int*" [ [ marshall-int* ] ] }
{ "uint*" [ [ marshall-uint* ] ] }
{ "long*" [ [ marshall-long* ] ] }
{ "ulong*" [ [ marshall-ulong* ] ] }
{ "float*" [ [ marshall-float* ] ] }
{ "double*" [ [ marshall-double* ] ] }
{ "bool&" [ [ marshall-bool* ] ] }
{ "char&" [ [ marshall-char* ] ] }
{ "uchar&" [ [ marshall-uchar* ] ] }
{ "short&" [ [ marshall-short* ] ] }
{ "ushort&" [ [ marshall-ushort* ] ] }
{ "int&" [ [ marshall-int* ] ] }
{ "uint&" [ [ marshall-uint* ] ] }
{ "long&" [ [ marshall-long* ] ] }
{ "ulong&" [ [ marshall-ulong* ] ] }
{ "float&" [ [ marshall-float* ] ] }
{ "double&" [ [ marshall-double* ] ] }
{ "void*" [ [ marshall-void* ] ] }
{ "bool**" [ [ marshall-bool** ] ] }
{ "char**" [ [ marshall-char**-or-strings ] ] }
{ "uchar**" [ [ marshall-uchar** ] ] }
{ "short**" [ [ marshall-short** ] ] }
{ "ushort**" [ [ marshall-ushort** ] ] }
{ "int**" [ [ marshall-int** ] ] }
{ "uint**" [ [ marshall-uint** ] ] }
{ "long**" [ [ marshall-long** ] ] }
{ "ulong**" [ [ marshall-ulong** ] ] }
{ "float**" [ [ marshall-float** ] ] }
{ "double**" [ [ marshall-double** ] ] }
{ "void**" [ [ marshall-void** ] ] }
[ drop f ]
} case ;
: marshall-struct ( obj -- byte-array ) ;
: marshaller ( type -- quot )
factorize-type dup primitive-marshaller [ nip ] [
pointer?
[ [ marshall-pointer ] ]
[ [ marshall-struct ] ] if
] if* ;
: unmarshall-char*-to-string ( alien -- string )
utf8 alien>string ;
: unmarshall-bool ( n -- ? )
0 = not ;
: primitive-unmarshaller ( type -- quot/f )
{
{ "bool" [ [ unmarshall-bool ] ] }
{ "char" [ [ ] ] }
{ "uchar" [ [ ] ] }
{ "short" [ [ ] ] }
{ "ushort" [ [ ] ] }
{ "int" [ [ ] ] }
{ "uint" [ [ ] ] }
{ "long" [ [ ] ] }
{ "ulong" [ [ ] ] }
{ "float" [ [ ] ] }
{ "double" [ [ ] ] }
{ "bool*" [ [ *bool ] ] }
{ "char*" [ [ unmarshall-char*-to-string ] ] }
{ "uchar*" [ [ *uchar ] ] }
{ "short*" [ [ *short ] ] }
{ "ushort*" [ [ *ushort ] ] }
{ "int*" [ [ *int ] ] }
{ "uint*" [ [ *uint ] ] }
{ "long*" [ [ *long ] ] }
{ "ulong*" [ [ *ulong ] ] }
{ "float*" [ [ *float ] ] }
{ "double*" [ [ *double ] ] }
{ "bool&" [ [ *bool ] ] }
{ "char&" [ [ *char ] ] }
{ "uchar&" [ [ *uchar ] ] }
{ "short&" [ [ *short ] ] }
{ "ushort&" [ [ *ushort ] ] }
{ "int&" [ [ *int ] ] }
{ "uint&" [ [ *uint ] ] }
{ "long&" [ [ *long ] ] }
{ "ulong&" [ [ *ulong ] ] }
{ "float&" [ [ *float ] ] }
{ "double&" [ [ *double ] ] }
[ drop f ]
} case ;
: unmarshall-struct ( byte-array -- byte-array' ) ;
: pointer-unmarshaller ( type -- quot )
type-sans-pointer current-vocab lookup [
dup superclasses [ alien-wrapper = ] any? [
'[ _ new >>underlying dynamic-cast ]
] [ drop [ ] ] if
] [ [ ] ] if* ;
: unmarshaller ( type -- quot )
factorize-type dup primitive-unmarshaller [ nip ] [
dup pointer?
[ '[ _ pointer-unmarshaller ] ]
[ drop [ unmarshall-struct ] ] if
] if* ;
: out-arg-unmarshaller ( type -- quot )
dup {
[ const-type? not ]
[ factorize-type pointer-to-primitive? ]
} 1&&
[ primitive-unmarshaller ] [ drop [ drop ] ] if ;

1
basis/alien/marshall/private/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

44
basis/alien/marshall/private/private.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.inline arrays
combinators fry functors kernel lexer libc macros math
sequences specialized-arrays.alien ;
IN: alien.marshall.private
: bool>arg ( ? -- 1/0/obj )
{
{ t [ 1 ] }
{ f [ 0 ] }
[ ]
} case ;
MACRO: marshall-x* ( num-quot seq-quot -- alien )
'[ bool>arg dup number? _ _ if ] ;
: malloc-underlying ( obj -- alien )
underlying>> malloc-byte-array ;
FUNCTOR: define-primitive-marshallers ( TYPE -- )
<TYPE> IS <${TYPE}>
>TYPE-array IS >${TYPE}-array
marshall-TYPE DEFINES marshall-${TYPE}
marshall-TYPE* DEFINES marshall-${TYPE}*
marshall-TYPE** DEFINES marshall-${TYPE}**
WHERE
: marshall-TYPE ( n -- byte-array )
dup c-ptr? [ bool>arg ] unless ;
: marshall-TYPE* ( n/seq -- alien )
dup c-ptr? [
[ <TYPE> malloc-byte-array ]
[ >TYPE-array malloc-underlying ]
marshall-x* &free
] unless ;
: marshall-TYPE** ( seq -- alien )
dup c-ptr? [
[ >TYPE-array malloc-underlying ]
map >void*-array malloc-underlying &free
] unless ;
;FUNCTOR
SYNTAX: PRIMITIVE-MARSHALLERS:
";" parse-tokens [ define-primitive-marshallers ] each ;