Merge branch 'master' of git://factorcode.org/git/factor
commit
622b5954fe
|
@ -0,0 +1,44 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel sequences math
|
||||
compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.block-joining
|
||||
|
||||
! Joining blocks that are not calls and are connected by a single CFG edge.
|
||||
! Predecessors must be recomputed after this. Also this pass does not
|
||||
! update ##phi nodes and should therefore only run before stack analysis.
|
||||
|
||||
: kill-vreg-block? ( bb -- ? )
|
||||
instructions>> {
|
||||
[ length 2 >= ]
|
||||
[ penultimate kill-vreg-insn? ]
|
||||
} 1&& ;
|
||||
|
||||
: predecessor ( bb -- pred )
|
||||
predecessors>> first ; inline
|
||||
|
||||
: join-block? ( bb -- ? )
|
||||
{
|
||||
[ kill-vreg-block? not ]
|
||||
[ predecessors>> length 1 = ]
|
||||
[ predecessor kill-vreg-block? not ]
|
||||
[ predecessor successors>> length 1 = ]
|
||||
[ [ predecessor ] keep back-edge? not ]
|
||||
} 1&& ;
|
||||
|
||||
: join-instructions ( bb pred -- )
|
||||
[ instructions>> ] bi@ dup pop* push-all ;
|
||||
|
||||
: update-successors ( bb pred -- )
|
||||
[ successors>> ] dip (>>successors) ;
|
||||
|
||||
: join-block ( bb pred -- )
|
||||
[ join-instructions ] [ update-successors ] 2bi ;
|
||||
|
||||
: join-blocks ( cfg -- cfg' )
|
||||
dup post-order [
|
||||
dup join-block?
|
||||
[ dup predecessor join-block ] [ drop ] if
|
||||
] each
|
||||
cfg-changed ;
|
|
@ -223,3 +223,25 @@ INSN: _reload dst class n ;
|
|||
INSN: _copy dst src class ;
|
||||
INSN: _spill-counts counts ;
|
||||
|
||||
! Instructions that poison the stack state
|
||||
UNION: poison-insn
|
||||
##jump
|
||||
##return
|
||||
##callback-return
|
||||
##fixnum-mul-tail
|
||||
##fixnum-add-tail
|
||||
##fixnum-sub-tail ;
|
||||
|
||||
! Instructions that kill all live vregs
|
||||
UNION: kill-vreg-insn
|
||||
poison-insn
|
||||
##stack-frame
|
||||
##call
|
||||
##prologue
|
||||
##epilogue
|
||||
##fixnum-mul
|
||||
##fixnum-add
|
||||
##fixnum-sub
|
||||
##alien-invoke
|
||||
##alien-indirect
|
||||
##alien-callback ;
|
||||
|
|
|
@ -122,10 +122,10 @@ M: ##copy-float compute-live-intervals*
|
|||
dup ranges>> [ first from>> ] [ last to>> ] bi
|
||||
[ >>start ] [ >>end ] bi* drop ;
|
||||
|
||||
: check-start/end ( live-interval -- )
|
||||
[ [ start>> ] [ uses>> first ] bi assert= ]
|
||||
[ [ end>> ] [ uses>> last ] bi assert= ]
|
||||
bi ;
|
||||
ERROR: bad-live-interval live-interval ;
|
||||
|
||||
: check-start ( live-interval -- )
|
||||
dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
|
||||
|
||||
: finish-live-intervals ( live-intervals -- )
|
||||
! Since live intervals are computed in a backward order, we have
|
||||
|
@ -135,7 +135,7 @@ M: ##copy-float compute-live-intervals*
|
|||
[ ranges>> reverse-here ]
|
||||
[ uses>> reverse-here ]
|
||||
[ compute-start/end ]
|
||||
[ check-start/end ]
|
||||
[ check-start ]
|
||||
} cleave
|
||||
] each ;
|
||||
|
||||
|
|
|
@ -6,6 +6,7 @@ compiler.cfg.predecessors
|
|||
compiler.cfg.useless-conditionals
|
||||
compiler.cfg.stack-analysis
|
||||
compiler.cfg.branch-splitting
|
||||
compiler.cfg.block-joining
|
||||
compiler.cfg.alias-analysis
|
||||
compiler.cfg.value-numbering
|
||||
compiler.cfg.dce
|
||||
|
@ -31,6 +32,8 @@ SYMBOL: check-optimizer?
|
|||
delete-useless-conditionals
|
||||
compute-predecessors
|
||||
split-branches
|
||||
join-blocks
|
||||
compute-predecessors
|
||||
stack-analysis
|
||||
compute-liveness
|
||||
alias-analysis
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel math
|
||||
namespaces sequences fry combinators
|
||||
compiler.utilities
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
|
@ -19,8 +20,6 @@ IN: compiler.cfg.tco
|
|||
[ second ##return? ]
|
||||
} 1&& ;
|
||||
|
||||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
||||
: tail-call? ( bb -- ? )
|
||||
{
|
||||
[ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
|
||||
|
|
|
@ -14,7 +14,8 @@ compiler.tree.propagation.nodes
|
|||
compiler.tree.propagation.slots
|
||||
compiler.tree.propagation.simple
|
||||
compiler.tree.propagation.constraints
|
||||
compiler.tree.propagation.call-effect ;
|
||||
compiler.tree.propagation.call-effect
|
||||
compiler.tree.propagation.transforms ;
|
||||
IN: compiler.tree.propagation.known-words
|
||||
|
||||
\ fixnum
|
||||
|
@ -227,39 +228,6 @@ generic-comparison-ops [
|
|||
] "outputs" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
} [
|
||||
[
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
bitand-fixnum-integer
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal< [
|
||||
0 most-positive-fixnum between?
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
||||
] when
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
{ numerator denominator }
|
||||
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
|
||||
|
||||
|
@ -314,15 +282,6 @@ generic-comparison-ops [
|
|||
"outputs" set-word-prop
|
||||
] each
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop 0 <hashtable> ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ slot [
|
||||
dup literal?>>
|
||||
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
||||
|
@ -346,29 +305,3 @@ generic-comparison-ops [
|
|||
bi
|
||||
] [ 2drop object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ instance? [
|
||||
in-d>> second value-info literal>> dup class?
|
||||
[ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ equal? [
|
||||
! If first input has a known type and second input is an
|
||||
! object, we convert this to [ swap equal? ].
|
||||
in-d>> first2 value-info class>> object class= [
|
||||
value-info class>> \ equal? specific-method
|
||||
[ swap equal? ] f ?
|
||||
] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
: inline-new ( class -- quot/f )
|
||||
dup tuple-class? [
|
||||
dup inlined-dependency depends-on
|
||||
[ all-slots [ initial>> literalize ] map ]
|
||||
[ tuple-layout '[ _ <tuple-boa> ] ]
|
||||
bi append [ drop ] prepend >quotation
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ new [
|
||||
in-d>> first value-info literal>> inline-new
|
||||
] "custom-inlining" set-word-prop
|
||||
|
|
|
@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
|
|||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
specialized-arrays.double system sorting math.libm
|
||||
math.intervals quotations ;
|
||||
math.intervals quotations effects ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||
|
@ -717,3 +717,26 @@ M: number whatever drop foo ;
|
|||
: that-thing ( -- class ) foo ;
|
||||
|
||||
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
|
||||
|
||||
GENERIC: whatever2 ( x -- y )
|
||||
M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
|
||||
M: f whatever2 ;
|
||||
|
||||
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
|
||||
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
|
||||
[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
|
||||
[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
|
||||
|
||||
[ f ] [ [ instance? ] { instance? } inlined? ] unit-test
|
||||
[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
|
||||
[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
|
||||
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
|
@ -0,0 +1,191 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences words fry generic accessors classes.tuple
|
||||
classes classes.algebra definitions stack-checker.state quotations
|
||||
classes.tuple.private math math.partial-dispatch math.private
|
||||
math.intervals layouts math.order vectors hashtables
|
||||
combinators effects generalizations assocs sets
|
||||
combinators.short-circuit sequences.private locals
|
||||
stack-checker
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.transforms
|
||||
|
||||
\ equal? [
|
||||
! If first input has a known type and second input is an
|
||||
! object, we convert this to [ swap equal? ].
|
||||
in-d>> first2 value-info class>> object class= [
|
||||
value-info class>> \ equal? specific-method
|
||||
[ swap equal? ] f ?
|
||||
] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
} [
|
||||
[
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
bitand-fixnum-integer
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal< [
|
||||
0 most-positive-fixnum between?
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
||||
] when
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop 0 <hashtable> ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
ERROR: bad-partial-eval quot word ;
|
||||
|
||||
: check-effect ( quot word -- )
|
||||
2dup [ infer ] [ stack-effect ] bi* effect<=
|
||||
[ 2drop ] [ bad-partial-eval ] if ;
|
||||
|
||||
:: define-partial-eval ( word quot n -- )
|
||||
word [
|
||||
in-d>> n tail*
|
||||
[ value-info ] map
|
||||
dup [ literal?>> ] all? [
|
||||
[ literal>> ] map
|
||||
n firstn
|
||||
quot call dup [
|
||||
[ n ndrop ] prepose
|
||||
dup word check-effect
|
||||
] when
|
||||
] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop ;
|
||||
|
||||
: inline-new ( class -- quot/f )
|
||||
dup tuple-class? [
|
||||
dup inlined-dependency depends-on
|
||||
[ all-slots [ initial>> literalize ] map ]
|
||||
[ tuple-layout '[ _ <tuple-boa> ] ]
|
||||
bi append >quotation
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ new [ inline-new ] 1 define-partial-eval
|
||||
|
||||
\ instance? [
|
||||
dup class?
|
||||
[ "predicate" word-prop ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Shuffling
|
||||
: nths-quot ( indices -- quot )
|
||||
[ [ '[ _ swap nth ] ] map ] [ length ] bi
|
||||
'[ _ cleave _ narray ] ;
|
||||
|
||||
\ shuffle [
|
||||
shuffle-mapping nths-quot
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Index search
|
||||
\ index [
|
||||
dup sequence? [
|
||||
dup length 4 >= [
|
||||
dup length zip >hashtable '[ _ at ]
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
: memq-quot ( seq -- newquot )
|
||||
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ cond ] curry ;
|
||||
|
||||
\ memq? [
|
||||
dup sequence? [ memq-quot ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Membership testing
|
||||
: member-quot ( seq -- newquot )
|
||||
dup length 4 <= [
|
||||
[ drop f ] swap
|
||||
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
||||
] [
|
||||
unique [ key? ] curry
|
||||
] if ;
|
||||
|
||||
\ member? [
|
||||
dup sequence? [ member-quot ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Fast at for integer maps
|
||||
CONSTANT: lookup-table-at-max 256
|
||||
|
||||
: lookup-table-at? ( assoc -- ? )
|
||||
#! Can we use a fast byte array test here?
|
||||
{
|
||||
[ assoc-size 4 > ]
|
||||
[ values [ ] all? ]
|
||||
[ keys [ integer? ] all? ]
|
||||
[ keys [ 0 lookup-table-at-max between? ] all? ]
|
||||
} 1&& ;
|
||||
|
||||
: lookup-table-seq ( assoc -- table )
|
||||
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
|
||||
|
||||
: lookup-table-quot ( seq -- newquot )
|
||||
lookup-table-seq
|
||||
'[
|
||||
_ over integer? [
|
||||
2dup bounds-check? [
|
||||
nth-unsafe dup >boolean
|
||||
] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if
|
||||
] ;
|
||||
|
||||
: fast-lookup-table-at? ( assoc -- ? )
|
||||
values {
|
||||
[ [ integer? ] all? ]
|
||||
[ [ 0 254 between? ] all? ]
|
||||
} 1&& ;
|
||||
|
||||
: fast-lookup-table-seq ( assoc -- table )
|
||||
lookup-table-seq [ 255 or ] B{ } map-as ;
|
||||
|
||||
: fast-lookup-table-quot ( seq -- newquot )
|
||||
fast-lookup-table-seq
|
||||
'[
|
||||
_ over integer? [
|
||||
2dup bounds-check? [
|
||||
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
|
||||
] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if
|
||||
] ;
|
||||
|
||||
: at-quot ( assoc -- quot )
|
||||
dup lookup-table-at? [
|
||||
dup fast-lookup-table-at? [
|
||||
fast-lookup-table-quot
|
||||
] [
|
||||
lookup-table-quot
|
||||
] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ at* [ at-quot ] 1 define-partial-eval
|
|
@ -27,4 +27,6 @@ SYMBOL: yield-hook
|
|||
yield-hook [ [ ] ] initialize
|
||||
|
||||
: alist-max ( alist -- pair )
|
||||
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
|
||||
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
|
||||
|
||||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
|
|
@ -107,97 +107,3 @@ IN: stack-checker.transforms
|
|||
] 1 define-transform
|
||||
|
||||
\ boa t "no-compile" set-word-prop
|
||||
|
||||
! Fast at for integer maps
|
||||
CONSTANT: lookup-table-at-max 256
|
||||
|
||||
: lookup-table-at? ( assoc -- ? )
|
||||
#! Can we use a fast byte array test here?
|
||||
{
|
||||
[ assoc-size 4 > ]
|
||||
[ values [ ] all? ]
|
||||
[ keys [ integer? ] all? ]
|
||||
[ keys [ 0 lookup-table-at-max between? ] all? ]
|
||||
} 1&& ;
|
||||
|
||||
: lookup-table-seq ( assoc -- table )
|
||||
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
|
||||
|
||||
: lookup-table-quot ( seq -- newquot )
|
||||
lookup-table-seq
|
||||
'[
|
||||
_ over integer? [
|
||||
2dup bounds-check? [
|
||||
nth-unsafe dup >boolean
|
||||
] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if
|
||||
] ;
|
||||
|
||||
: fast-lookup-table-at? ( assoc -- ? )
|
||||
values {
|
||||
[ [ integer? ] all? ]
|
||||
[ [ 0 254 between? ] all? ]
|
||||
} 1&& ;
|
||||
|
||||
: fast-lookup-table-seq ( assoc -- table )
|
||||
lookup-table-seq [ 255 or ] B{ } map-as ;
|
||||
|
||||
: fast-lookup-table-quot ( seq -- newquot )
|
||||
fast-lookup-table-seq
|
||||
'[
|
||||
_ over integer? [
|
||||
2dup bounds-check? [
|
||||
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
|
||||
] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if
|
||||
] ;
|
||||
|
||||
: at-quot ( assoc -- quot )
|
||||
dup lookup-table-at? [
|
||||
dup fast-lookup-table-at? [
|
||||
fast-lookup-table-quot
|
||||
] [
|
||||
lookup-table-quot
|
||||
] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ at* [ at-quot ] 1 define-transform
|
||||
|
||||
! Membership testing
|
||||
: member-quot ( seq -- newquot )
|
||||
dup length 4 <= [
|
||||
[ drop f ] swap
|
||||
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
||||
] [
|
||||
unique [ key? ] curry
|
||||
] if ;
|
||||
|
||||
\ member? [
|
||||
dup sequence? [ member-quot ] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
: memq-quot ( seq -- newquot )
|
||||
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ cond ] curry ;
|
||||
|
||||
\ memq? [
|
||||
dup sequence? [ memq-quot ] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Index search
|
||||
\ index [
|
||||
dup sequence? [
|
||||
dup length 4 >= [
|
||||
dup length zip >hashtable '[ _ at ]
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Shuffling
|
||||
: nths-quot ( indices -- quot )
|
||||
[ [ '[ _ swap nth ] ] map ] [ length ] bi
|
||||
'[ _ cleave _ narray ] ;
|
||||
|
||||
\ shuffle [
|
||||
shuffle-mapping nths-quot
|
||||
] 1 define-transform
|
||||
|
|
|
@ -0,0 +1,77 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel strings words.symbol sequences ;
|
||||
IN: alien.inline.compiler
|
||||
|
||||
HELP: C
|
||||
{ $var-description "A symbol representing C source." } ;
|
||||
|
||||
HELP: C++
|
||||
{ $var-description "A symbol representing C++ source." } ;
|
||||
|
||||
HELP: compile-to-library
|
||||
{ $values
|
||||
{ "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
|
||||
}
|
||||
{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
|
||||
"in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
|
||||
{ $snippet "args" } " is a sequence of arguments for the linking stage." }
|
||||
{ $notes
|
||||
{ $list
|
||||
"C and C++ are the only supported languages."
|
||||
{ "Source and object files are placed in " { $snippet "resource:temp" } "." } }
|
||||
} ;
|
||||
|
||||
HELP: compiler
|
||||
{ $values
|
||||
{ "lang" symbol }
|
||||
{ "str" string }
|
||||
}
|
||||
{ $description "Returns a compiler name based on OS and source language." }
|
||||
{ $see-also compiler-descr } ;
|
||||
|
||||
HELP: compiler-descr
|
||||
{ $values
|
||||
{ "lang" symbol }
|
||||
{ "descr" "a process description" }
|
||||
}
|
||||
{ $description "Returns a compiler process description based on OS and source language." }
|
||||
{ $see-also compiler } ;
|
||||
|
||||
HELP: inline-library-file
|
||||
{ $values
|
||||
{ "name" string }
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
|
||||
|
||||
HELP: inline-libs-directory
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
|
||||
|
||||
HELP: library-path
|
||||
{ $values
|
||||
{ "str" string }
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
|
||||
|
||||
HELP: library-suffix
|
||||
{ $values
|
||||
{ "str" string }
|
||||
}
|
||||
{ $description "The appropriate shared library suffix for the current OS." } ;
|
||||
|
||||
HELP: link-descr
|
||||
{ $values
|
||||
{ "descr" sequence }
|
||||
}
|
||||
{ $description "Returns part of a process description. OS dependent." } ;
|
||||
|
||||
ARTICLE: "alien.inline.compiler" "Inline C compiler"
|
||||
{ $vocab-link "alien.inline.compiler" }
|
||||
;
|
||||
|
||||
ABOUT: "alien.inline.compiler"
|
|
@ -22,35 +22,37 @@ SYMBOL: C++
|
|||
{ [ dup windows? ] [ drop ".dll" ] }
|
||||
} cond ;
|
||||
|
||||
: library-path ( str -- str' )
|
||||
'[ "lib" % _ % library-suffix % ] "" make temp-file ;
|
||||
|
||||
: src-suffix ( lang -- str )
|
||||
{
|
||||
{ C [ ".c" ] }
|
||||
{ C++ [ ".cpp" ] }
|
||||
} case ;
|
||||
: library-path ( str -- path )
|
||||
'[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
|
||||
|
||||
HOOK: compiler os ( lang -- str )
|
||||
|
||||
M: word compiler ( lang -- str )
|
||||
M: word compiler
|
||||
{
|
||||
{ C [ "gcc" ] }
|
||||
{ C++ [ "g++" ] }
|
||||
} case ;
|
||||
|
||||
M: openbsd compiler ( lang -- str )
|
||||
M: openbsd compiler
|
||||
{
|
||||
{ C [ "gcc" ] }
|
||||
{ C++ [ "eg++" ] }
|
||||
} case ;
|
||||
|
||||
M: windows compiler
|
||||
{
|
||||
{ C [ "gcc" ] }
|
||||
{ C++ [ "gcc" ] }
|
||||
} case ;
|
||||
|
||||
HOOK: compiler-descr os ( lang -- descr )
|
||||
|
||||
M: word compiler-descr compiler 1array ;
|
||||
M: macosx compiler-descr
|
||||
call-next-method cpu x86.64?
|
||||
[ { "-arch" "x86_64" } append ] when ;
|
||||
M: windows compiler-descr
|
||||
call-next-method { "-x" "c++" } append ;
|
||||
|
||||
HOOK: link-descr os ( -- descr )
|
||||
|
||||
|
@ -58,9 +60,18 @@ M: word link-descr { "-shared" "-o" } ;
|
|||
M: macosx link-descr
|
||||
{ "-g" "-prebind" "-dynamiclib" "-o" }
|
||||
cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
|
||||
M: windows link-descr { "-lstdc++" "-mno-cygwin" "-o" } ;
|
||||
|
||||
: link-command ( in out lang -- descr )
|
||||
compiler-descr link-descr append prepend prepend ;
|
||||
<PRIVATE
|
||||
: src-suffix ( lang -- str )
|
||||
{
|
||||
{ C [ ".c" ] }
|
||||
{ C++ [ ".cpp" ] }
|
||||
} case ;
|
||||
|
||||
: link-command ( args in out lang -- descr )
|
||||
[ 2array ] dip compiler-descr link-descr
|
||||
append prepend prepend ;
|
||||
|
||||
:: compile-to-object ( lang contents name -- )
|
||||
name ".o" append temp-file
|
||||
|
@ -71,8 +82,9 @@ M: macosx link-descr
|
|||
|
||||
:: link-object ( lang args name -- )
|
||||
args name [ library-path ]
|
||||
[ ".o" append temp-file ] bi 2array
|
||||
[ ".o" append temp-file ] bi
|
||||
lang link-command try-process ;
|
||||
PRIVATE>
|
||||
|
||||
:: compile-to-library ( lang args contents name -- )
|
||||
lang contents name compile-to-object
|
|
@ -3,108 +3,12 @@
|
|||
USING: help.markup help.syntax kernel strings effects quotations ;
|
||||
IN: alien.inline
|
||||
|
||||
<PRIVATE
|
||||
: $binding-note ( x -- )
|
||||
drop
|
||||
{ "This word requires that certain variables are correctly bound. "
|
||||
"Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
|
||||
|
||||
HELP: ;C-LIBRARY
|
||||
{ $syntax ";C-LIBRARY" }
|
||||
{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
|
||||
{ $see-also POSTPONE: compile-c-library } ;
|
||||
|
||||
HELP: C-FRAMEWORK:
|
||||
{ $syntax "C-FRAMEWORK: name" }
|
||||
{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
|
||||
{ $see-also POSTPONE: c-use-framework } ;
|
||||
|
||||
HELP: C-FUNCTION:
|
||||
{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
|
||||
{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.inline prettyprint ;"
|
||||
"IN: cmath.ffi"
|
||||
""
|
||||
"C-LIBRARY: cmathlib"
|
||||
""
|
||||
"C-FUNCTION: int add ( int a, int b )"
|
||||
" return a + b;"
|
||||
";"
|
||||
""
|
||||
";C-LIBRARY"
|
||||
""
|
||||
"1 2 add ."
|
||||
"3" }
|
||||
}
|
||||
{ $see-also POSTPONE: define-c-function } ;
|
||||
|
||||
HELP: C-INCLUDE:
|
||||
{ $syntax "C-INCLUDE: name" }
|
||||
{ $description "Appends an include line to the C library in scope." }
|
||||
{ $see-also POSTPONE: c-include } ;
|
||||
|
||||
HELP: C-LIBRARY:
|
||||
{ $syntax "C-LIBRARY: name" }
|
||||
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.inline ;"
|
||||
"IN: rectangle.ffi"
|
||||
""
|
||||
"C-LIBRARY: rectlib"
|
||||
""
|
||||
"C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
|
||||
""
|
||||
"C-FUNCTION: int area ( rectangle c )"
|
||||
" return c.width * c.height;"
|
||||
";"
|
||||
""
|
||||
";C-LIBRARY"
|
||||
"" }
|
||||
}
|
||||
{ $see-also POSTPONE: define-c-library } ;
|
||||
|
||||
HELP: C-LINK/FRAMEWORK:
|
||||
{ $syntax "C-LINK/FRAMEWORK: name" }
|
||||
{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
|
||||
{ $see-also POSTPONE: c-link-to/use-framework } ;
|
||||
|
||||
HELP: C-LINK:
|
||||
{ $syntax "C-LINK: name" }
|
||||
{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
|
||||
{ $see-also POSTPONE: c-link-to } ;
|
||||
|
||||
HELP: C-STRUCTURE:
|
||||
{ $syntax "C-STRUCTURE: name pairs ... ;" }
|
||||
{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
|
||||
{ $see-also POSTPONE: define-c-struct } ;
|
||||
|
||||
HELP: C-TYPEDEF:
|
||||
{ $syntax "C-TYPEDEF: old new" }
|
||||
{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
|
||||
{ $see-also POSTPONE: define-c-typedef } ;
|
||||
|
||||
HELP: COMPILE-AS-C++
|
||||
{ $syntax "COMPILE-AS-C++" }
|
||||
{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
|
||||
|
||||
HELP: DELETE-C-LIBRARY:
|
||||
{ $syntax "DELETE-C-LIBRARY: name" }
|
||||
{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
|
||||
{ $notes
|
||||
{ $list
|
||||
{ "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
|
||||
"This word is mainly useful for unit tests."
|
||||
}
|
||||
}
|
||||
{ $see-also POSTPONE: delete-inline-library } ;
|
||||
|
||||
HELP: RAW-C:
|
||||
{ $syntax "RAW-C:" "body" ";" }
|
||||
{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
|
||||
|
||||
CONSTANT: foo "abc"
|
||||
PRIVATE>
|
||||
|
||||
HELP: compile-c-library
|
||||
{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
|
||||
|
@ -204,8 +108,6 @@ HELP: with-c-library
|
|||
}
|
||||
{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
|
||||
|
||||
ARTICLE: "alien.inline" "Inline C"
|
||||
{ $vocab-link "alien.inline" }
|
||||
;
|
||||
|
||||
ABOUT: "alien.inline"
|
||||
HELP: raw-c
|
||||
{ $values { "str" string } }
|
||||
{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
|
|
@ -9,43 +9,20 @@ splitting strings system vocabs.loader vocabs.parser words
|
|||
alien.c-types alien.structs make parser continuations ;
|
||||
IN: alien.inline
|
||||
|
||||
<PRIVATE
|
||||
SYMBOL: c-library
|
||||
SYMBOL: library-is-c++
|
||||
SYMBOL: compiler-args
|
||||
SYMBOL: linker-args
|
||||
SYMBOL: c-strings
|
||||
|
||||
<PRIVATE
|
||||
: cleanup-variables ( -- )
|
||||
{ c-library library-is-c++ compiler-args c-strings }
|
||||
{ c-library library-is-c++ linker-args c-strings }
|
||||
[ off ] each ;
|
||||
|
||||
: function-types-effect ( -- function types effect )
|
||||
scan scan swap ")" parse-tokens
|
||||
[ "(" subseq? not ] filter swap parse-arglist ;
|
||||
|
||||
: arg-list ( types -- params )
|
||||
CHAR: a swap length CHAR: a + [a,b]
|
||||
[ 1string ] map ;
|
||||
|
||||
: factor-function ( function types effect -- word quot effect )
|
||||
annotate-effect [ c-library get ] 3dip
|
||||
[ [ factorize-type ] map ] dip
|
||||
types-effect>params-return factorize-type -roll
|
||||
concat make-function ;
|
||||
|
||||
: prototype-string ( function types effect -- str )
|
||||
[ [ cify-type ] map ] dip
|
||||
types-effect>params-return cify-type -rot
|
||||
[ " " join ] map ", " join
|
||||
"(" prepend ")" append 3array " " join
|
||||
library-is-c++ get [ "extern \"C\" " prepend ] when ;
|
||||
|
||||
: prototype-string' ( function types return -- str )
|
||||
[ dup arg-list ] <effect> prototype-string ;
|
||||
|
||||
: append-function-body ( prototype-str body -- str )
|
||||
[ swap % " {\n" % % "\n}\n" % ] "" make ;
|
||||
|
||||
: compile-library? ( -- ? )
|
||||
c-library get library-path dup exists? [
|
||||
file get [
|
||||
|
@ -56,7 +33,7 @@ SYMBOL: c-strings
|
|||
|
||||
: compile-library ( -- )
|
||||
library-is-c++ get [ C++ ] [ C ] if
|
||||
compiler-args get
|
||||
linker-args get
|
||||
c-strings get "\n" join
|
||||
c-library get compile-to-library ;
|
||||
|
||||
|
@ -64,10 +41,33 @@ SYMBOL: c-strings
|
|||
[ current-vocab name>> % "_" % % ] "" make ;
|
||||
PRIVATE>
|
||||
|
||||
: append-function-body ( prototype-str body -- str )
|
||||
[ swap % " {\n" % % "\n}\n" % ] "" make ;
|
||||
|
||||
: function-types-effect ( -- function types effect )
|
||||
scan scan swap ")" parse-tokens
|
||||
[ "(" subseq? not ] filter swap parse-arglist ;
|
||||
|
||||
: prototype-string ( function types effect -- str )
|
||||
[ [ cify-type ] map ] dip
|
||||
types-effect>params-return cify-type -rot
|
||||
[ " " join ] map ", " join
|
||||
"(" prepend ")" append 3array " " join
|
||||
library-is-c++ get [ "extern \"C\" " prepend ] when ;
|
||||
|
||||
: prototype-string' ( function types return -- str )
|
||||
[ dup arg-list ] <effect> prototype-string ;
|
||||
|
||||
: factor-function ( function types effect -- word quot effect )
|
||||
annotate-effect [ c-library get ] 3dip
|
||||
[ [ factorize-type ] map ] dip
|
||||
types-effect>params-return factorize-type -roll
|
||||
concat make-function ;
|
||||
|
||||
: define-c-library ( name -- )
|
||||
c-library-name c-library set
|
||||
V{ } clone c-strings set
|
||||
V{ } clone compiler-args set ;
|
||||
V{ } clone linker-args set ;
|
||||
|
||||
: compile-c-library ( -- )
|
||||
compile-library? [ compile-library ] when
|
||||
|
@ -87,10 +87,10 @@ PRIVATE>
|
|||
] dip append-function-body c-strings get push ;
|
||||
|
||||
: c-link-to ( str -- )
|
||||
"-l" prepend compiler-args get push ;
|
||||
"-l" prepend linker-args get push ;
|
||||
|
||||
: c-use-framework ( str -- )
|
||||
"-framework" swap compiler-args get '[ _ push ] bi@ ;
|
||||
"-framework" swap linker-args get '[ _ push ] bi@ ;
|
||||
|
||||
: c-link-to/use-framework ( str -- )
|
||||
os macosx? [ c-use-framework ] [ c-link-to ] if ;
|
||||
|
@ -122,29 +122,5 @@ PRIVATE>
|
|||
[ [ define-c-library ] dip call compile-c-library ]
|
||||
[ cleanup-variables ] [ ] cleanup ; inline
|
||||
|
||||
SYNTAX: C-LIBRARY: scan define-c-library ;
|
||||
|
||||
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
|
||||
|
||||
SYNTAX: C-LINK: scan c-link-to ;
|
||||
|
||||
SYNTAX: C-FRAMEWORK: scan c-use-framework ;
|
||||
|
||||
SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
|
||||
|
||||
SYNTAX: C-INCLUDE: scan c-include ;
|
||||
|
||||
SYNTAX: C-FUNCTION:
|
||||
function-types-effect parse-here define-c-function ;
|
||||
|
||||
SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
|
||||
|
||||
SYNTAX: C-STRUCTURE:
|
||||
scan parse-definition define-c-struct ;
|
||||
|
||||
SYNTAX: ;C-LIBRARY compile-c-library ;
|
||||
|
||||
SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
|
||||
|
||||
SYNTAX: RAW-C:
|
||||
[ "\n" % parse-here % "\n" % c-strings get push ] "" make ;
|
||||
: raw-c ( str -- )
|
||||
[ "\n" % % "\n" % ] "" make c-strings get push ;
|
|
@ -0,0 +1,100 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax alien.inline ;
|
||||
IN: alien.inline.syntax
|
||||
|
||||
HELP: ;C-LIBRARY
|
||||
{ $syntax ";C-LIBRARY" }
|
||||
{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
|
||||
{ $see-also POSTPONE: compile-c-library } ;
|
||||
|
||||
HELP: C-FRAMEWORK:
|
||||
{ $syntax "C-FRAMEWORK: name" }
|
||||
{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
|
||||
{ $see-also POSTPONE: c-use-framework } ;
|
||||
|
||||
HELP: C-FUNCTION:
|
||||
{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
|
||||
{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.inline.syntax prettyprint ;"
|
||||
"IN: cmath.ffi"
|
||||
""
|
||||
"C-LIBRARY: cmathlib"
|
||||
""
|
||||
"C-FUNCTION: int add ( int a, int b )"
|
||||
" return a + b;"
|
||||
";"
|
||||
""
|
||||
";C-LIBRARY"
|
||||
""
|
||||
"1 2 add ."
|
||||
"3" }
|
||||
}
|
||||
{ $see-also POSTPONE: define-c-function } ;
|
||||
|
||||
HELP: C-INCLUDE:
|
||||
{ $syntax "C-INCLUDE: name" }
|
||||
{ $description "Appends an include line to the C library in scope." }
|
||||
{ $see-also POSTPONE: c-include } ;
|
||||
|
||||
HELP: C-LIBRARY:
|
||||
{ $syntax "C-LIBRARY: name" }
|
||||
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.inline.syntax ;"
|
||||
"IN: rectangle.ffi"
|
||||
""
|
||||
"C-LIBRARY: rectlib"
|
||||
""
|
||||
"C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
|
||||
""
|
||||
"C-FUNCTION: int area ( rectangle c )"
|
||||
" return c.width * c.height;"
|
||||
";"
|
||||
""
|
||||
";C-LIBRARY"
|
||||
"" }
|
||||
}
|
||||
{ $see-also POSTPONE: define-c-library } ;
|
||||
|
||||
HELP: C-LINK/FRAMEWORK:
|
||||
{ $syntax "C-LINK/FRAMEWORK: name" }
|
||||
{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
|
||||
{ $see-also POSTPONE: c-link-to/use-framework } ;
|
||||
|
||||
HELP: C-LINK:
|
||||
{ $syntax "C-LINK: name" }
|
||||
{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
|
||||
{ $see-also POSTPONE: c-link-to } ;
|
||||
|
||||
HELP: C-STRUCTURE:
|
||||
{ $syntax "C-STRUCTURE: name pairs ... ;" }
|
||||
{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
|
||||
{ $see-also POSTPONE: define-c-struct } ;
|
||||
|
||||
HELP: C-TYPEDEF:
|
||||
{ $syntax "C-TYPEDEF: old new" }
|
||||
{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
|
||||
{ $see-also POSTPONE: define-c-typedef } ;
|
||||
|
||||
HELP: COMPILE-AS-C++
|
||||
{ $syntax "COMPILE-AS-C++" }
|
||||
{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
|
||||
|
||||
HELP: DELETE-C-LIBRARY:
|
||||
{ $syntax "DELETE-C-LIBRARY: name" }
|
||||
{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
|
||||
{ $notes
|
||||
{ $list
|
||||
{ "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
|
||||
"This word is mainly useful for unit tests."
|
||||
}
|
||||
}
|
||||
{ $see-also POSTPONE: delete-inline-library } ;
|
||||
|
||||
HELP: RAW-C:
|
||||
{ $syntax "RAW-C:" "body" ";" }
|
||||
{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.inline alien.inline.private io.directories io.files
|
||||
USING: alien.inline alien.inline.syntax io.directories io.files
|
||||
kernel namespaces tools.test alien.c-types alien.structs ;
|
||||
IN: alien.inline.tests
|
||||
IN: alien.inline.syntax.tests
|
||||
|
||||
DELETE-C-LIBRARY: test
|
||||
C-LIBRARY: test
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.inline lexer multiline namespaces parser ;
|
||||
IN: alien.inline.syntax
|
||||
|
||||
|
||||
SYNTAX: C-LIBRARY: scan define-c-library ;
|
||||
|
||||
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
|
||||
|
||||
SYNTAX: C-LINK: scan c-link-to ;
|
||||
|
||||
SYNTAX: C-FRAMEWORK: scan c-use-framework ;
|
||||
|
||||
SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
|
||||
|
||||
SYNTAX: C-INCLUDE: scan c-include ;
|
||||
|
||||
SYNTAX: C-FUNCTION:
|
||||
function-types-effect parse-here define-c-function ;
|
||||
|
||||
SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
|
||||
|
||||
SYNTAX: C-STRUCTURE:
|
||||
scan parse-definition define-c-struct ;
|
||||
|
||||
SYNTAX: ;C-LIBRARY compile-c-library ;
|
||||
|
||||
SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
|
||||
|
||||
SYNTAX: RAW-C: parse-here raw-c ;
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -5,16 +5,21 @@ continuations effects fry kernel math 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? ;
|
||||
: factorize-type ( str -- str' )
|
||||
cify-type
|
||||
"const " ?head drop
|
||||
"unsigned " ?head [ "u" prepend ] when
|
||||
"long " ?head [ "long" prepend ] when
|
||||
" const" ?tail drop ;
|
||||
|
||||
: const-pointer? ( str -- ? )
|
||||
cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
|
||||
|
||||
: pointer-to-const? ( str -- ? )
|
||||
cify-type "const " head? ;
|
||||
|
||||
MEMO: resolved-primitives ( -- seq )
|
||||
primitive-types [ resolve-typedef ] map ;
|
||||
|
@ -26,14 +31,21 @@ MEMO: resolved-primitives ( -- seq )
|
|||
] [ 2drop f ] recover ;
|
||||
|
||||
: pointer? ( type -- ? )
|
||||
[ "*" tail? ] [ "&" tail? ] bi or ;
|
||||
factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
|
||||
|
||||
: type-sans-pointer ( type -- type' )
|
||||
[ '[ _ = ] "*&" swap any? ] trim-tail ;
|
||||
factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
|
||||
|
||||
: pointer-to-primitive? ( type -- ? )
|
||||
factorize-type
|
||||
{ [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
|
||||
|
||||
: pointer-to-non-const-primitive? ( str -- ? )
|
||||
{
|
||||
[ pointer-to-const? not ]
|
||||
[ factorize-type pointer-to-primitive? ]
|
||||
} 1&& ;
|
||||
|
||||
: types-effect>params-return ( types effect -- params return )
|
||||
[ in>> zip ]
|
||||
[ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -0,0 +1,638 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations sequences
|
||||
strings alien alien.c-types math byte-arrays ;
|
||||
IN: alien.marshall
|
||||
|
||||
<PRIVATE
|
||||
: $memory-note ( arg -- )
|
||||
drop "This word returns a pointer to unmanaged memory."
|
||||
print-element ;
|
||||
|
||||
: $c-ptr-note ( arg -- )
|
||||
drop "Does nothing if its argument is a non false c-ptr."
|
||||
print-element ;
|
||||
|
||||
: $see-article ( arg -- )
|
||||
drop { "See " { $vocab-link "alien.inline" } "." }
|
||||
print-element ;
|
||||
PRIVATE>
|
||||
|
||||
HELP: ?malloc-byte-array
|
||||
{ $values
|
||||
{ "c-type" c-type }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
|
||||
{ $snippet "malloc-byte-array" } "."
|
||||
}
|
||||
{ $notes $memory-note } ;
|
||||
|
||||
HELP: alien-wrapper
|
||||
{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
|
||||
|
||||
HELP: unmarshall-cast
|
||||
{ $values
|
||||
{ "alien-wrapper" alien-wrapper }
|
||||
{ "alien-wrapper'" alien-wrapper }
|
||||
}
|
||||
{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
|
||||
|
||||
HELP: marshall-bool
|
||||
{ $values
|
||||
{ "?" "a generalized boolean" }
|
||||
{ "n" "0 or 1" }
|
||||
}
|
||||
{ $description "Marshalls objects to bool." }
|
||||
{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
|
||||
|
||||
HELP: marshall-bool*
|
||||
{ $values
|
||||
{ "?/seq" "t/f or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
|
||||
"otherwise returns a pointer to a single bool value."
|
||||
}
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-bool**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "Takes a one or two dimensional array of generalized booleans "
|
||||
"and returns a pointer to the equivalent C structure."
|
||||
}
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-primitive
|
||||
{ $values
|
||||
{ "n" number }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description "Marshall numbers to C primitives."
|
||||
$nl
|
||||
"Factor marshalls numbers to primitives for FFI calls, so all "
|
||||
"this word does is convert " { $snippet "t" } " to " { $snippet "1" }
|
||||
", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
|
||||
"pass through untouched."
|
||||
} ;
|
||||
|
||||
HELP: marshall-char*
|
||||
{ $values
|
||||
{ "n/seq" "number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-char**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-char**-or-strings
|
||||
{ $values
|
||||
{ "seq" "a sequence of strings" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "Marshalls an array of strings or characters to an array of C strings." }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-char*-or-string
|
||||
{ $values
|
||||
{ "n/string" "a number or string" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-double*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-double**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-float*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-float**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-int*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-int**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-long*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-long**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-longlong*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-longlong**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-non-pointer
|
||||
{ $values
|
||||
{ "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
|
||||
{ "byte-array" byte-array }
|
||||
}
|
||||
{ $description "Converts argument to a byte array." }
|
||||
{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
|
||||
|
||||
HELP: marshall-pointer
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "Converts argument to a C pointer." }
|
||||
{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
|
||||
|
||||
HELP: marshall-short*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-short**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-uchar*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-uchar**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-uint*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-uint**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-ulong*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-ulong**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-ulonglong*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-ulonglong**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-ushort*
|
||||
{ $values
|
||||
{ "n/seq" "a number or sequence" }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-ushort**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description $see-article }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshall-void**
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "Marshalls a sequence of objects to an array of pointers to void." }
|
||||
{ $notes { $list $c-ptr-note $memory-note } } ;
|
||||
|
||||
HELP: marshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
|
||||
|
||||
HELP: out-arg-unmarshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
|
||||
"for all types except pointers to non-const primitives."
|
||||
} ;
|
||||
|
||||
HELP: pointer-unmarshaller
|
||||
{ $values
|
||||
{ "type" " a C type string" }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
|
||||
" named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
|
||||
"wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
|
||||
}
|
||||
{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
|
||||
|
||||
HELP: primitive-marshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot/f" "a quotation or f" }
|
||||
}
|
||||
{ $description "Returns a quotation to marshall objects to the argument type." }
|
||||
{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
|
||||
|
||||
HELP: primitive-unmarshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot/f" "a quotation or f" }
|
||||
}
|
||||
{ $description "Returns a quotation to unmarshall objects from the argument type." }
|
||||
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
|
||||
|
||||
HELP: struct-field-unmarshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Like " { $link unmarshaller } " but returns a quotation that "
|
||||
"does not call " { $snippet "free" } " on its argument."
|
||||
}
|
||||
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
|
||||
|
||||
HELP: struct-primitive-unmarshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot/f" "a quotation or f" }
|
||||
}
|
||||
{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
|
||||
"does not call " { $snippet "free" } " on its argument." }
|
||||
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
|
||||
|
||||
HELP: struct-unmarshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Returns a quotation which wraps its argument in the subclass of "
|
||||
{ $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
|
||||
}
|
||||
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
|
||||
|
||||
HELP: struct-wrapper
|
||||
{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
|
||||
|
||||
HELP: unmarshall-bool
|
||||
{ $values
|
||||
{ "n" number }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Unmarshalls a number to a boolean." } ;
|
||||
|
||||
HELP: unmarshall-bool*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Unmarshalls a C pointer to a boolean." } ;
|
||||
|
||||
HELP: unmarshall-bool*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
|
||||
|
||||
HELP: unmarshall-char*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-char*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-char*-to-string
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "string" string }
|
||||
}
|
||||
{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
|
||||
|
||||
HELP: unmarshall-char*-to-string-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "string" string }
|
||||
}
|
||||
{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
|
||||
|
||||
HELP: unmarshall-double*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-double*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-float*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-float*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-int*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-int*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-long*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-long*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-longlong*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-longlong*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-short*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-short*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-uchar*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-uchar*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-uint*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-uint*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-ulong*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-ulong*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-ulonglong*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-ulonglong*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-ushort*
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshall-ushort*-free
|
||||
{ $values
|
||||
{ "alien" alien }
|
||||
{ "n" number }
|
||||
}
|
||||
{ $description $see-article } ;
|
||||
|
||||
HELP: unmarshaller
|
||||
{ $values
|
||||
{ "type" "a C type string" }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
|
||||
|
||||
ARTICLE: "alien.marshall" "C marshalling"
|
||||
{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
|
||||
"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
|
||||
|
||||
{ $subheading "Important words" }
|
||||
"Wrap an alien:" { $subsection alien-wrapper }
|
||||
"Wrap a struct:" { $subsection struct-wrapper }
|
||||
"Get the marshaller for a C type:" { $subsection marshaller }
|
||||
"Get the unmarshaller for a C type:" { $subsection marshaller }
|
||||
"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
|
||||
"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
|
||||
$nl
|
||||
"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
|
||||
"invoked directly."
|
||||
$nl
|
||||
"Most marshalling words allow non false c-ptrs to pass through unchanged."
|
||||
|
||||
{ $subheading "Primitive marshallers" }
|
||||
{ $subsection marshall-primitive } "for marshalling primitive values."
|
||||
{ $subsection marshall-int* }
|
||||
"marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
|
||||
"to a C array, otherwise returns a pointer to a single value."
|
||||
{ $subsection marshall-int** }
|
||||
"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
|
||||
|
||||
{ $subheading "Primitive unmarshallers" }
|
||||
{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
|
||||
" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
|
||||
{ $subsection unmarshall-int* }
|
||||
"unmarshalls a pointer to primitive. Returns a number. "
|
||||
"Assumes the pointer is not an array (if it is, only the first value is returned). "
|
||||
"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
|
||||
" and must be unmarshalled by hand."
|
||||
{ $subsection unmarshall-int*-free }
|
||||
"unmarshalls a pointer to primitive, and then frees the pointer."
|
||||
$nl
|
||||
"Primitive values require no unmarshalling. The factor FFI already does this."
|
||||
;
|
||||
|
||||
ABOUT: "alien.marshall"
|
|
@ -0,0 +1,303 @@
|
|||
! 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 libc 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.short specialized-arrays.uchar
|
||||
specialized-arrays.uint specialized-arrays.ulong
|
||||
specialized-arrays.ulonglong specialized-arrays.ushort strings
|
||||
unix.utilities vocabs.parser words libc.private struct-arrays ;
|
||||
IN: alien.marshall
|
||||
|
||||
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
|
||||
filter [ define-primitive-marshallers ] each >>
|
||||
|
||||
TUPLE: alien-wrapper { underlying alien } ;
|
||||
TUPLE: struct-wrapper < alien-wrapper disposed ;
|
||||
|
||||
GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
|
||||
|
||||
M: alien-wrapper unmarshall-cast ;
|
||||
M: struct-wrapper unmarshall-cast ;
|
||||
|
||||
M: struct-wrapper dispose* underlying>> free ;
|
||||
|
||||
: marshall-pointer ( obj -- alien )
|
||||
{
|
||||
{ [ dup alien? ] [ ] }
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup byte-array? ] [ malloc-byte-array ] }
|
||||
{ [ dup alien-wrapper? ] [ underlying>> ] }
|
||||
{ [ dup struct-array? ] [ underlying>> ] }
|
||||
} cond ;
|
||||
|
||||
: marshall-primitive ( n -- n )
|
||||
[ bool>arg ] ptr-pass-through ;
|
||||
|
||||
ALIAS: marshall-void* marshall-pointer
|
||||
|
||||
: marshall-void** ( seq -- alien )
|
||||
[ marshall-void* ] void*-array{ } map-as malloc-underlying ;
|
||||
|
||||
: (marshall-char*-or-string) ( n/string -- alien )
|
||||
dup string?
|
||||
[ utf8 string>alien malloc-byte-array ]
|
||||
[ (marshall-char*) ] if ;
|
||||
|
||||
: marshall-char*-or-string ( n/string -- alien )
|
||||
[ (marshall-char*-or-string) ] ptr-pass-through ;
|
||||
|
||||
: (marshall-char**-or-strings) ( seq -- alien )
|
||||
[ marshall-char*-or-string ] void*-array{ } map-as
|
||||
malloc-underlying ;
|
||||
|
||||
: marshall-char**-or-strings ( seq -- alien )
|
||||
[ (marshall-char**-or-strings) ] ptr-pass-through ;
|
||||
|
||||
: marshall-bool ( ? -- n )
|
||||
>boolean [ 1 ] [ 0 ] if ;
|
||||
|
||||
: (marshall-bool*) ( ?/seq -- alien )
|
||||
[ marshall-bool <bool> malloc-byte-array ]
|
||||
[ >bool-array malloc-underlying ]
|
||||
marshall-x* ;
|
||||
|
||||
: marshall-bool* ( ?/seq -- alien )
|
||||
[ (marshall-bool*) ] ptr-pass-through ;
|
||||
|
||||
: (marshall-bool**) ( seq -- alien )
|
||||
[ marshall-bool* ] map >void*-array malloc-underlying ;
|
||||
|
||||
: marshall-bool** ( seq -- alien )
|
||||
[ (marshall-bool**) ] ptr-pass-through ;
|
||||
|
||||
: unmarshall-bool ( n -- ? )
|
||||
0 = not ;
|
||||
|
||||
: unmarshall-bool* ( alien -- ? )
|
||||
*bool unmarshall-bool ;
|
||||
|
||||
: unmarshall-bool*-free ( alien -- ? )
|
||||
[ *bool unmarshall-bool ] keep add-malloc free ;
|
||||
|
||||
: primitive-marshaller ( type -- quot/f )
|
||||
{
|
||||
{ "bool" [ [ marshall-bool ] ] }
|
||||
{ "boolean" [ [ marshall-bool ] ] }
|
||||
{ "char" [ [ marshall-primitive ] ] }
|
||||
{ "uchar" [ [ marshall-primitive ] ] }
|
||||
{ "short" [ [ marshall-primitive ] ] }
|
||||
{ "ushort" [ [ marshall-primitive ] ] }
|
||||
{ "int" [ [ marshall-primitive ] ] }
|
||||
{ "uint" [ [ marshall-primitive ] ] }
|
||||
{ "long" [ [ marshall-primitive ] ] }
|
||||
{ "ulong" [ [ marshall-primitive ] ] }
|
||||
{ "long" [ [ marshall-primitive ] ] }
|
||||
{ "ulong" [ [ marshall-primitive ] ] }
|
||||
{ "float" [ [ marshall-primitive ] ] }
|
||||
{ "double" [ [ marshall-primitive ] ] }
|
||||
{ "bool*" [ [ marshall-bool* ] ] }
|
||||
{ "boolean*" [ [ 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* ] ] }
|
||||
{ "longlong*" [ [ marshall-longlong* ] ] }
|
||||
{ "ulonglong*" [ [ marshall-ulonglong* ] ] }
|
||||
{ "float*" [ [ marshall-float* ] ] }
|
||||
{ "double*" [ [ marshall-double* ] ] }
|
||||
{ "bool&" [ [ marshall-bool* ] ] }
|
||||
{ "boolean&" [ [ 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* ] ] }
|
||||
{ "longlong&" [ [ marshall-longlong* ] ] }
|
||||
{ "ulonglong&" [ [ marshall-ulonglong* ] ] }
|
||||
{ "float&" [ [ marshall-float* ] ] }
|
||||
{ "double&" [ [ marshall-double* ] ] }
|
||||
{ "void*" [ [ marshall-void* ] ] }
|
||||
{ "bool**" [ [ marshall-bool** ] ] }
|
||||
{ "boolean**" [ [ 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** ] ] }
|
||||
{ "longlong**" [ [ marshall-longlong** ] ] }
|
||||
{ "ulonglong**" [ [ marshall-ulonglong** ] ] }
|
||||
{ "float**" [ [ marshall-float** ] ] }
|
||||
{ "double**" [ [ marshall-double** ] ] }
|
||||
{ "void**" [ [ marshall-void** ] ] }
|
||||
[ drop f ]
|
||||
} case ;
|
||||
|
||||
: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
|
||||
{
|
||||
{ [ dup byte-array? ] [ ] }
|
||||
{ [ dup alien-wrapper? ]
|
||||
[ [ underlying>> ] [ class name>> heap-size ] bi
|
||||
memory>byte-array ] }
|
||||
} cond ;
|
||||
|
||||
|
||||
: marshaller ( type -- quot )
|
||||
factorize-type dup primitive-marshaller [ nip ] [
|
||||
pointer?
|
||||
[ [ marshall-pointer ] ]
|
||||
[ [ marshall-non-pointer ] ] if
|
||||
] if* ;
|
||||
|
||||
|
||||
: unmarshall-char*-to-string ( alien -- string )
|
||||
utf8 alien>string ;
|
||||
|
||||
: unmarshall-char*-to-string-free ( alien -- string )
|
||||
[ unmarshall-char*-to-string ] keep add-malloc free ;
|
||||
|
||||
: primitive-unmarshaller ( type -- quot/f )
|
||||
{
|
||||
{ "bool" [ [ unmarshall-bool ] ] }
|
||||
{ "boolean" [ [ unmarshall-bool ] ] }
|
||||
{ "char" [ [ ] ] }
|
||||
{ "uchar" [ [ ] ] }
|
||||
{ "short" [ [ ] ] }
|
||||
{ "ushort" [ [ ] ] }
|
||||
{ "int" [ [ ] ] }
|
||||
{ "uint" [ [ ] ] }
|
||||
{ "long" [ [ ] ] }
|
||||
{ "ulong" [ [ ] ] }
|
||||
{ "longlong" [ [ ] ] }
|
||||
{ "ulonglong" [ [ ] ] }
|
||||
{ "float" [ [ ] ] }
|
||||
{ "double" [ [ ] ] }
|
||||
{ "bool*" [ [ unmarshall-bool*-free ] ] }
|
||||
{ "boolean*" [ [ unmarshall-bool*-free ] ] }
|
||||
{ "char*" [ [ ] ] }
|
||||
{ "uchar*" [ [ unmarshall-uchar*-free ] ] }
|
||||
{ "short*" [ [ unmarshall-short*-free ] ] }
|
||||
{ "ushort*" [ [ unmarshall-ushort*-free ] ] }
|
||||
{ "int*" [ [ unmarshall-int*-free ] ] }
|
||||
{ "uint*" [ [ unmarshall-uint*-free ] ] }
|
||||
{ "long*" [ [ unmarshall-long*-free ] ] }
|
||||
{ "ulong*" [ [ unmarshall-ulong*-free ] ] }
|
||||
{ "longlong*" [ [ unmarshall-long*-free ] ] }
|
||||
{ "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
|
||||
{ "float*" [ [ unmarshall-float*-free ] ] }
|
||||
{ "double*" [ [ unmarshall-double*-free ] ] }
|
||||
{ "bool&" [ [ unmarshall-bool*-free ] ] }
|
||||
{ "boolean&" [ [ unmarshall-bool*-free ] ] }
|
||||
{ "char&" [ [ ] ] }
|
||||
{ "uchar&" [ [ unmarshall-uchar*-free ] ] }
|
||||
{ "short&" [ [ unmarshall-short*-free ] ] }
|
||||
{ "ushort&" [ [ unmarshall-ushort*-free ] ] }
|
||||
{ "int&" [ [ unmarshall-int*-free ] ] }
|
||||
{ "uint&" [ [ unmarshall-uint*-free ] ] }
|
||||
{ "long&" [ [ unmarshall-long*-free ] ] }
|
||||
{ "ulong&" [ [ unmarshall-ulong*-free ] ] }
|
||||
{ "longlong&" [ [ unmarshall-longlong*-free ] ] }
|
||||
{ "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
|
||||
{ "float&" [ [ unmarshall-float*-free ] ] }
|
||||
{ "double&" [ [ unmarshall-double*-free ] ] }
|
||||
[ drop f ]
|
||||
} case ;
|
||||
|
||||
: struct-primitive-unmarshaller ( type -- quot/f )
|
||||
{
|
||||
{ "bool" [ [ unmarshall-bool ] ] }
|
||||
{ "boolean" [ [ unmarshall-bool ] ] }
|
||||
{ "char" [ [ ] ] }
|
||||
{ "uchar" [ [ ] ] }
|
||||
{ "short" [ [ ] ] }
|
||||
{ "ushort" [ [ ] ] }
|
||||
{ "int" [ [ ] ] }
|
||||
{ "uint" [ [ ] ] }
|
||||
{ "long" [ [ ] ] }
|
||||
{ "ulong" [ [ ] ] }
|
||||
{ "longlong" [ [ ] ] }
|
||||
{ "ulonglong" [ [ ] ] }
|
||||
{ "float" [ [ ] ] }
|
||||
{ "double" [ [ ] ] }
|
||||
{ "bool*" [ [ unmarshall-bool* ] ] }
|
||||
{ "boolean*" [ [ unmarshall-bool* ] ] }
|
||||
{ "char*" [ [ ] ] }
|
||||
{ "uchar*" [ [ unmarshall-uchar* ] ] }
|
||||
{ "short*" [ [ unmarshall-short* ] ] }
|
||||
{ "ushort*" [ [ unmarshall-ushort* ] ] }
|
||||
{ "int*" [ [ unmarshall-int* ] ] }
|
||||
{ "uint*" [ [ unmarshall-uint* ] ] }
|
||||
{ "long*" [ [ unmarshall-long* ] ] }
|
||||
{ "ulong*" [ [ unmarshall-ulong* ] ] }
|
||||
{ "longlong*" [ [ unmarshall-long* ] ] }
|
||||
{ "ulonglong*" [ [ unmarshall-ulong* ] ] }
|
||||
{ "float*" [ [ unmarshall-float* ] ] }
|
||||
{ "double*" [ [ unmarshall-double* ] ] }
|
||||
{ "bool&" [ [ unmarshall-bool* ] ] }
|
||||
{ "boolean&" [ [ unmarshall-bool* ] ] }
|
||||
{ "char&" [ [ unmarshall-char* ] ] }
|
||||
{ "uchar&" [ [ unmarshall-uchar* ] ] }
|
||||
{ "short&" [ [ unmarshall-short* ] ] }
|
||||
{ "ushort&" [ [ unmarshall-ushort* ] ] }
|
||||
{ "int&" [ [ unmarshall-int* ] ] }
|
||||
{ "uint&" [ [ unmarshall-uint* ] ] }
|
||||
{ "long&" [ [ unmarshall-long* ] ] }
|
||||
{ "ulong&" [ [ unmarshall-ulong* ] ] }
|
||||
{ "longlong&" [ [ unmarshall-longlong* ] ] }
|
||||
{ "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
|
||||
{ "float&" [ [ unmarshall-float* ] ] }
|
||||
{ "double&" [ [ unmarshall-double* ] ] }
|
||||
[ drop f ]
|
||||
} case ;
|
||||
|
||||
|
||||
: ?malloc-byte-array ( c-type -- alien )
|
||||
dup alien? [ malloc-byte-array ] unless ;
|
||||
|
||||
: struct-unmarshaller ( type -- quot )
|
||||
current-vocab lookup [
|
||||
dup superclasses [ \ struct-wrapper = ] any? [
|
||||
'[ ?malloc-byte-array _ new swap >>underlying ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
|
||||
: pointer-unmarshaller ( type -- quot )
|
||||
type-sans-pointer current-vocab lookup [
|
||||
dup superclasses [ \ alien-wrapper = ] any? [
|
||||
'[ _ new swap >>underlying unmarshall-cast ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
|
||||
: unmarshaller ( type -- quot )
|
||||
factorize-type dup primitive-unmarshaller [ nip ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
|
||||
: struct-field-unmarshaller ( type -- quot )
|
||||
factorize-type dup struct-primitive-unmarshaller [ nip ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
|
||||
: out-arg-unmarshaller ( type -- quot )
|
||||
dup pointer-to-non-const-primitive?
|
||||
[ factorize-type primitive-unmarshaller ]
|
||||
[ drop [ drop ] ] if ;
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -0,0 +1,60 @@
|
|||
! 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 libc.private
|
||||
combinators.short-circuit ;
|
||||
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 ] ;
|
||||
|
||||
: ptr-pass-through ( obj quot -- alien )
|
||||
over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
|
||||
|
||||
: malloc-underlying ( obj -- alien )
|
||||
underlying>> malloc-byte-array ;
|
||||
|
||||
FUNCTOR: define-primitive-marshallers ( TYPE -- )
|
||||
<TYPE> IS <${TYPE}>
|
||||
*TYPE IS *${TYPE}
|
||||
>TYPE-array IS >${TYPE}-array
|
||||
marshall-TYPE DEFINES marshall-${TYPE}
|
||||
(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
|
||||
(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
|
||||
marshall-TYPE* DEFINES marshall-${TYPE}*
|
||||
marshall-TYPE** DEFINES marshall-${TYPE}**
|
||||
marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
|
||||
marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
|
||||
unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
|
||||
unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
|
||||
WHERE
|
||||
<PRIVATE
|
||||
: (marshall-TYPE*) ( n/seq -- alien )
|
||||
[ <TYPE> malloc-byte-array ]
|
||||
[ >TYPE-array malloc-underlying ]
|
||||
marshall-x* ;
|
||||
PRIVATE>
|
||||
: marshall-TYPE* ( n/seq -- alien )
|
||||
[ (marshall-TYPE*) ] ptr-pass-through ;
|
||||
<PRIVATE
|
||||
: (marshall-TYPE**) ( seq -- alien )
|
||||
[ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
|
||||
PRIVATE>
|
||||
: marshall-TYPE** ( seq -- alien )
|
||||
[ (marshall-TYPE**) ] ptr-pass-through ;
|
||||
: unmarshall-TYPE* ( alien -- n )
|
||||
*TYPE ; inline
|
||||
: unmarshall-TYPE*-free ( alien -- n )
|
||||
[ unmarshall-TYPE* ] keep add-malloc free ;
|
||||
;FUNCTOR
|
||||
|
||||
SYNTAX: PRIMITIVE-MARSHALLERS:
|
||||
";" parse-tokens [ define-primitive-marshallers ] each ;
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes help.markup help.syntax kernel quotations words
|
||||
alien.marshall.structs strings alien.structs alien.marshall ;
|
||||
IN: alien.marshall.structs
|
||||
|
||||
HELP: define-marshalled-struct
|
||||
{ $values
|
||||
{ "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
|
||||
}
|
||||
{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
|
||||
|
||||
HELP: define-struct-tuple
|
||||
{ $values
|
||||
{ "name" string }
|
||||
}
|
||||
{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
|
||||
"and accessor words."
|
||||
} ;
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.marshall arrays assocs
|
||||
classes.tuple combinators destructors generalizations generic
|
||||
kernel libc locals parser quotations sequences slots words
|
||||
alien.structs lexer vocabs.parser fry effects ;
|
||||
IN: alien.marshall.structs
|
||||
|
||||
<PRIVATE
|
||||
: define-struct-accessor ( class name quot -- )
|
||||
[ "accessors" create create-method dup make-inline ] dip define ;
|
||||
|
||||
: define-struct-getter ( class name word type -- )
|
||||
[ ">>" append \ underlying>> ] 2dip
|
||||
struct-field-unmarshaller \ call 4array >quotation
|
||||
define-struct-accessor ;
|
||||
|
||||
: define-struct-setter ( class name word type -- )
|
||||
[ "(>>" prepend ")" append ] 2dip
|
||||
marshaller [ underlying>> ] \ bi* roll 4array >quotation
|
||||
define-struct-accessor ;
|
||||
|
||||
: define-struct-accessors ( class name type reader writer -- )
|
||||
[ dup define-protocol-slot ] 3dip
|
||||
[ drop swap define-struct-getter ]
|
||||
[ nip swap define-struct-setter ] 5 nbi ;
|
||||
|
||||
: define-struct-constructor ( class -- )
|
||||
{
|
||||
[ name>> "<" prepend ">" append create-in ]
|
||||
[ '[ _ new ] ]
|
||||
[ name>> '[ _ malloc-object >>underlying ] append ]
|
||||
[ name>> 1array ]
|
||||
} cleave { } swap <effect> define-declared ;
|
||||
PRIVATE>
|
||||
|
||||
:: define-struct-tuple ( name -- )
|
||||
name create-in :> class
|
||||
class struct-wrapper { } define-tuple-class
|
||||
class define-struct-constructor
|
||||
name c-type fields>> [
|
||||
class swap
|
||||
{
|
||||
[ name>> { { CHAR: space CHAR: - } } substitute ]
|
||||
[ type>> ] [ reader>> ] [ writer>> ]
|
||||
} cleave define-struct-accessors
|
||||
] each ;
|
||||
|
||||
: define-marshalled-struct ( name vocab fields -- )
|
||||
[ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -0,0 +1,83 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations words
|
||||
alien.inline alien.syntax effects alien.marshall
|
||||
alien.marshall.structs strings sequences alien.inline.syntax ;
|
||||
IN: alien.marshall.syntax
|
||||
|
||||
HELP: CM-FUNCTION:
|
||||
{ $syntax "CM-FUNCTION: return name args\n body\n;" }
|
||||
{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
|
||||
"of arguments and return values."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
|
||||
"IN: example"
|
||||
""
|
||||
"C-LIBRARY: exlib"
|
||||
""
|
||||
"C-INCLUDE: <stdio.h>"
|
||||
"CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
|
||||
" *x = a + b;"
|
||||
" *y = a - b;"
|
||||
" char* s = (char*) malloc(sizeof(char) * 64);"
|
||||
" sprintf(s, \"sum %i, diff %i\", *x, *y);"
|
||||
" return s;"
|
||||
";"
|
||||
""
|
||||
";C-LIBRARY"
|
||||
""
|
||||
"8 5 0 0 sum_diff . . ."
|
||||
"3\n13\n\"sum 13, diff 3\""
|
||||
}
|
||||
}
|
||||
{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
|
||||
|
||||
HELP: CM-STRUCTURE:
|
||||
{ $syntax "CM-STRUCTURE: name fields ... ;" }
|
||||
{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
|
||||
"Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
|
||||
}
|
||||
{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
|
||||
|
||||
HELP: M-FUNCTION:
|
||||
{ $syntax "M-FUNCTION: return name args ;" }
|
||||
{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
|
||||
"of arguments and return values."
|
||||
}
|
||||
{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
|
||||
|
||||
HELP: M-STRUCTURE:
|
||||
{ $syntax "M-STRUCTURE: name fields ... ;" }
|
||||
{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
|
||||
"Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
|
||||
}
|
||||
{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
|
||||
|
||||
HELP: define-c-marshalled
|
||||
{ $values
|
||||
{ "name" string } { "types" sequence } { "effect" effect } { "body" string }
|
||||
}
|
||||
{ $description "Defines a C function and a factor word which calls it with marshalling of "
|
||||
"args and return values."
|
||||
}
|
||||
{ $see-also define-c-marshalled' } ;
|
||||
|
||||
HELP: define-c-marshalled'
|
||||
{ $values
|
||||
{ "name" string } { "effect" effect } { "body" string }
|
||||
}
|
||||
{ $description "Like " { $link define-c-marshalled } ". "
|
||||
"The effect elements must be C type strings."
|
||||
} ;
|
||||
|
||||
HELP: marshalled-function
|
||||
{ $values
|
||||
{ "name" string } { "types" sequence } { "effect" effect }
|
||||
{ "word" word } { "quot" quotation } { "effect" effect }
|
||||
}
|
||||
{ $description "Defines a word which calls the named C function. Arguments, "
|
||||
"return value, and output parameters are marshalled and unmarshalled."
|
||||
} ;
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.inline.syntax alien.marshall.syntax destructors
|
||||
tools.test accessors kernel ;
|
||||
IN: alien.marshall.syntax.tests
|
||||
|
||||
DELETE-C-LIBRARY: test
|
||||
C-LIBRARY: test
|
||||
|
||||
C-INCLUDE: <stdlib.h>
|
||||
C-INCLUDE: <string.h>
|
||||
|
||||
C-TYPEDEF: char bool
|
||||
|
||||
CM-FUNCTION: void outarg1 ( int* a )
|
||||
*a += 2;
|
||||
;
|
||||
|
||||
CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
|
||||
unsigned long* x = malloc(sizeof(unsigned long*));
|
||||
*b = 10 + *b;
|
||||
*x = a + *b;
|
||||
return x;
|
||||
;
|
||||
|
||||
CM-STRUCTURE: wedge
|
||||
{ "double" "degrees" } ;
|
||||
|
||||
CM-STRUCTURE: sundial
|
||||
{ "double" "radius" }
|
||||
{ "wedge" "wedge" } ;
|
||||
|
||||
CM-FUNCTION: double hours ( sundial* d )
|
||||
return d->wedge.degrees / 30;
|
||||
;
|
||||
|
||||
CM-FUNCTION: void change_time ( double hours, sundial* d )
|
||||
d->wedge.degrees = hours * 30;
|
||||
;
|
||||
|
||||
CM-FUNCTION: bool c_not ( bool p )
|
||||
return !p;
|
||||
;
|
||||
|
||||
CM-FUNCTION: char* upcase ( const-char* s )
|
||||
int len = strlen(s);
|
||||
char* t = malloc(sizeof(char) * len);
|
||||
int i;
|
||||
for (i = 0; i < len; i++)
|
||||
t[i] = toupper(s[i]);
|
||||
t[i] = '\0';
|
||||
return t;
|
||||
;
|
||||
|
||||
;C-LIBRARY
|
||||
|
||||
{ 1 1 } [ outarg1 ] must-infer-as
|
||||
[ 3 ] [ 1 outarg1 ] unit-test
|
||||
[ 3 ] [ t outarg1 ] unit-test
|
||||
[ 2 ] [ f outarg1 ] unit-test
|
||||
|
||||
{ 2 2 } [ outarg2 ] must-infer-as
|
||||
[ 18 15 ] [ 3 5 outarg2 ] unit-test
|
||||
|
||||
{ 1 1 } [ hours ] must-infer-as
|
||||
[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
|
||||
|
||||
{ 2 0 } [ change_time ] must-infer-as
|
||||
[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
|
||||
|
||||
{ 1 1 } [ c_not ] must-infer-as
|
||||
[ f ] [ "x" c_not ] unit-test
|
||||
[ f ] [ 0 c_not ] unit-test
|
||||
|
||||
{ 1 1 } [ upcase ] must-infer-as
|
||||
[ "ABC" ] [ "abc" upcase ] unit-test
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.inline alien.inline.types alien.marshall
|
||||
combinators effects generalizations kernel locals make namespaces
|
||||
quotations sequences words alien.marshall.structs lexer parser
|
||||
vocabs.parser multiline ;
|
||||
IN: alien.marshall.syntax
|
||||
|
||||
:: marshalled-function ( name types effect -- word quot effect )
|
||||
name types effect factor-function
|
||||
[ in>> ]
|
||||
[ out>> types [ pointer-to-non-const-primitive? ] filter append ]
|
||||
bi <effect>
|
||||
[
|
||||
[
|
||||
types [ marshaller ] map , \ spread , ,
|
||||
types length , \ nkeep ,
|
||||
types [ out-arg-unmarshaller ] map
|
||||
effect out>> dup empty?
|
||||
[ drop ] [ first unmarshaller prefix ] if
|
||||
, \ spread ,
|
||||
] [ ] make
|
||||
] dip ;
|
||||
|
||||
: define-c-marshalled ( name types effect body -- )
|
||||
[
|
||||
[ marshalled-function define-declared ]
|
||||
[ prototype-string ] 3bi
|
||||
] dip append-function-body c-strings get push ;
|
||||
|
||||
: define-c-marshalled' ( name effect body -- )
|
||||
[
|
||||
[ in>> ] keep
|
||||
[ marshalled-function define-declared ]
|
||||
[ out>> prototype-string' ] 3bi
|
||||
] dip append-function-body c-strings get push ;
|
||||
|
||||
SYNTAX: CM-FUNCTION:
|
||||
function-types-effect parse-here define-c-marshalled ;
|
||||
|
||||
SYNTAX: M-FUNCTION:
|
||||
function-types-effect marshalled-function define-declared ;
|
||||
|
||||
SYNTAX: M-STRUCTURE:
|
||||
scan current-vocab parse-definition
|
||||
define-marshalled-struct ;
|
||||
|
||||
SYNTAX: CM-STRUCTURE:
|
||||
scan current-vocab parse-definition
|
||||
[ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy
|
||||
arrays assocs io.styles io help.markup prettyprint sequences
|
||||
continuations debugger math namespaces memory ;
|
||||
continuations debugger math namespaces memory fry ;
|
||||
IN: benchmark
|
||||
|
||||
<PRIVATE
|
||||
|
@ -12,9 +12,12 @@ SYMBOL: errors
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: (run-benchmark) ( vocab -- time )
|
||||
[ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
|
||||
|
||||
: run-benchmark ( vocab -- )
|
||||
[ "=== " write print flush ] [
|
||||
[ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
|
||||
[ [ require ] [ (run-benchmark) ] [ ] tri timings ]
|
||||
[ swap errors ]
|
||||
recover get set-at
|
||||
] bi ;
|
||||
|
@ -24,6 +27,7 @@ PRIVATE>
|
|||
V{ } clone timings set
|
||||
V{ } clone errors set
|
||||
"benchmark" child-vocab-names
|
||||
[ find-vocab-root ] filter
|
||||
[ run-benchmark ] each
|
||||
timings get
|
||||
errors get
|
||||
|
|
Loading…
Reference in New Issue