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

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

db4
Joe Groff 2009-07-16 09:56:18 -05:00
parent e90c947062 4931ab0d5f
commit 622b5954fe
36 changed files with 1880 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
basis/compiler/cfg/block-joining/block-joining.factor Normal file
View File

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

22
basis/compiler/cfg/instructions/instructions.factor
View File

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

10
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

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

3
basis/compiler/cfg/optimizer/optimizer.factor
View File

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

3
basis/compiler/cfg/tco/tco.factor
View File

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

71
basis/compiler/tree/propagation/known-words/known-words.factor
View File

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

25
basis/compiler/tree/propagation/propagation-tests.factor
View File

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

2
basis/compiler/tree/propagation/transforms/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Daniel Ehrenberg

191
basis/compiler/tree/propagation/transforms/transforms.factor Normal file
View File

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

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

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

94
basis/stack-checker/transforms/transforms.factor
View File

@ -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
basis/alien/inline/authors.txt → extra/alien/inline/authors.txt
View File

0
basis/alien/inline/compiler/authors.txt → extra/alien/inline/compiler/authors.txt
View File

77
extra/alien/inline/compiler/compiler-docs.factor Normal file
View File

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

38
basis/alien/inline/compiler/compiler.factor → extra/alien/inline/compiler/compiler.factor
View File

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

108
basis/alien/inline/inline-docs.factor → extra/alien/inline/inline-docs.factor
View File

@ -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" } "." } ;

88
basis/alien/inline/inline.factor → extra/alien/inline/inline.factor
View File

@ -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
basis/alien/inline/types/authors.txt → extra/alien/inline/syntax/authors.txt
View File

100
extra/alien/inline/syntax/syntax-docs.factor Normal file
View File

@ -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" } "." } ;

4
basis/alien/inline/inline-tests.factor → extra/alien/inline/syntax/syntax-tests.factor
View File

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

31
extra/alien/inline/syntax/syntax.factor Normal file
View File

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

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

@ -0,0 +1 @@
Jeremy Hughes

30
basis/alien/inline/types/types.factor → extra/alien/inline/types/types.factor
View File

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

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

@ -0,0 +1 @@
Jeremy Hughes

638
extra/alien/marshall/marshall-docs.factor Normal file
View File

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

303
extra/alien/marshall/marshall.factor Normal file
View File

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

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

@ -0,0 +1 @@
Jeremy Hughes

60
extra/alien/marshall/private/private.factor Normal file
View File

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

1
extra/alien/marshall/structs/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

19
extra/alien/marshall/structs/structs-docs.factor Normal file
View File

@ -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."
} ;

50
extra/alien/marshall/structs/structs.factor Normal file
View File

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

1
extra/alien/marshall/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

83
extra/alien/marshall/syntax/syntax-docs.factor Normal file
View File

@ -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."
} ;

76
extra/alien/marshall/syntax/syntax-tests.factor Normal file
View File

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

50
extra/alien/marshall/syntax/syntax.factor Normal file
View File

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

8
extra/benchmark/benchmark.factor
View File

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