version 1.22, 2007/10/29 15:56:31
|
version 1.33, 2008/04/28 08:42:59
|
Line 1
|
Line 1
|
\ libcc.fs foreign function interface implemented using a C compiler |
\ libcc.fs foreign function interface implemented using a C compiler |
|
|
\ Copyright (C) 2006 Free Software Foundation, Inc. |
\ Copyright (C) 2006,2007 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
|
|
\ What this implementation does is this: if it sees a declaration like |
\ What this implementation does is this: if it sees a declaration like |
Line 124
|
Line 123
|
\ first-time word, then to the run-time word; the run-time word calls |
\ first-time word, then to the run-time word; the run-time word calls |
\ the c function. |
\ the c function. |
|
|
: delete-file 2drop 0 ; |
[ifundef] parse-name |
|
' parse-word alias parse-name |
|
[then] |
|
[ifundef] defer! |
|
: defer! ( xt xt-deferred -- ) \ gforth defer-store |
|
\G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}. |
|
>body [ has? rom [IF] ] @ [ [THEN] ] ! ; |
|
[then] |
|
|
|
\ : delete-file 2drop 0 ; |
|
|
require struct.fs |
require struct.fs |
|
|
Line 147 variable c-source-file-id \ contains the
|
Line 155 variable c-source-file-id \ contains the
|
variable lib-handle-addr \ points to the library handle of the current batch. |
variable lib-handle-addr \ points to the library handle of the current batch. |
\ the library handle is 0 if the current |
\ the library handle is 0 if the current |
\ batch is not yet compiled. |
\ batch is not yet compiled. |
2variable lib-filename \ filename without extension |
2variable lib-filename \ filename without extension |
|
2variable lib-modulename \ basename of the file without extension |
|
|
: .nb ( n -- ) |
: .nb ( n -- ) |
0 .r ; |
0 .r ; |
Line 205 end-struct list%
|
Line 214 end-struct list%
|
node list-next @ |
node list-next @ |
repeat ; |
repeat ; |
|
|
|
\ linked libraries |
|
|
|
list% |
|
cell% 2* field c-lib-string |
|
end-struct c-lib% |
|
|
|
variable c-libs \ linked list of library names (without "lib") |
|
|
|
: add-lib ( c-addr u -- ) |
|
\G Add library lib@i{string} to the list of libraries, where |
|
\G @i{string} is represented by @i{c-addr u}. |
|
c-lib% %size allocate throw dup >r |
|
c-lib-string 2! |
|
r> c-libs list-insert ; |
|
|
|
: append-l ( c-addr1 u1 node -- c-addr2 u2 ) |
|
\ append " -l<nodelib>" to string1 |
|
>r s" -l" append r> c-lib-string 2@ append ; |
|
|
\ C prefix lines |
\ C prefix lines |
|
|
\ linked list of longcstrings: [ link | count-cell | characters ] |
\ linked list of longcstrings: [ link | count-cell | characters ] |
Line 363 create gen-par-types
|
Line 391 create gen-par-types
|
." ," gen-par-n ." ," gen-par-n ." )" ; |
." ," gen-par-n ." ," gen-par-n ." )" ; |
|
|
: gen-wrapped-r ( pars c-name fp-change1 sp-change1 -- fp-change sp-change ) |
: gen-wrapped-r ( pars c-name fp-change1 sp-change1 -- fp-change sp-change ) |
2dup gen-par-r 2>r ." =" gen-wrapped-void 2r> ; |
2dup gen-par-r 2>r ." =" gen-wrapped-call 2r> ; |
|
|
: gen-wrapped-func ( pars c-name fp-change1 sp-change1 -- fp-change sp-change ) |
: gen-wrapped-func ( pars c-name fp-change1 sp-change1 -- fp-change sp-change ) |
gen-wrapped-a ; |
gen-wrapped-a ; |
Line 398 create gen-wrapped-types
|
Line 426 create gen-wrapped-types
|
\ addr points to the return type index of a c-function descriptor |
\ addr points to the return type index of a c-function descriptor |
dup { descriptor } |
dup { descriptor } |
count { ret } count 2dup { d: pars } chars + count { d: c-name } |
count { ret } count 2dup { d: pars } chars + count { d: c-name } |
." void " descriptor wrapper-function-name 2dup type drop free throw |
." void " lib-modulename 2@ type ." _LTX_" descriptor wrapper-function-name 2dup type drop free throw |
.\" (void)\n" |
.\" (void)\n" |
.\" {\n Cell MAYBE_UNUSED *sp = gforth_SP;\n Float MAYBE_UNUSED *fp = gforth_FP;\n " |
.\" {\n Cell MAYBE_UNUSED *sp = gforth_SP;\n Float MAYBE_UNUSED *fp = gforth_FP;\n " |
pars c-name 2over count-stacks ret gen-wrapped-stmt .\" ;\n" |
pars c-name 2over count-stacks ret gen-wrapped-stmt .\" ;\n" |
Line 418 create gen-wrapped-types
|
Line 446 create gen-wrapped-types
|
: gen-filename ( x -- c-addr u ) |
: gen-filename ( x -- c-addr u ) |
\ generates a filename without extension for lib-handle-addr X |
\ generates a filename without extension for lib-handle-addr X |
0 <<# ['] #s $10 base-execute #> |
0 <<# ['] #s $10 base-execute #> |
tempdir s" /gforth-c-" s+ 2swap append #>> ; |
tempdir s" /gforth_c_" s+ 2swap append #>> ; |
|
|
: init-c-source-file ( -- ) |
: init-c-source-file ( -- ) |
c-source-file-id @ 0= if |
c-source-file-id @ 0= if |
here 0 , dup lib-handle-addr ! gen-filename 2dup lib-filename 2! |
here 0 , dup lib-handle-addr ! gen-filename 2dup lib-filename 2! |
|
2dup tempdir nip 1+ /string lib-modulename 2! |
s" .c" s+ 2dup w/o create-file throw dup c-source-file-id ! |
s" .c" s+ 2dup w/o create-file throw dup c-source-file-id ! |
['] print-c-prefix-lines swap outfile-execute |
['] print-c-prefix-lines swap outfile-execute |
drop free throw |
drop free throw |
Line 431 create gen-wrapped-types
|
Line 460 create gen-wrapped-types
|
: c-source-file ( -- file-id ) |
: c-source-file ( -- file-id ) |
c-source-file-id @ assert( dup ) ; |
c-source-file-id @ assert( dup ) ; |
|
|
DEFER compile-wrapper-function |
: .lib-error ( -- ) |
|
[ifdef] lib-error |
|
['] cr stderr outfile-execute |
|
lib-error ['] type stderr outfile-execute |
|
[then] ; |
|
|
|
DEFER compile-wrapper-function ( -- ) |
:NONAME ( -- ) |
:NONAME ( -- ) |
c-source-file close-file throw |
c-source-file close-file throw |
0 c-source-file-id ! |
0 c-source-file-id ! |
[ s" libtool --silent --mode=link gcc -module -I " |
[ libtool-command s" --silent --mode=compile gcc -I " s+ |
s" includedir" getenv append s" -rpath " append ] sliteral |
s" includedir" getenv append ] sliteral |
tempdir s+ s" -O -c " append lib-filename 2@ append s" .c -o " append |
s" -O -c " s+ lib-filename 2@ append s" .c -o " append |
|
lib-filename 2@ append s" .lo" append ( c-addr u ) |
|
\ cr 2dup type |
|
2dup system drop free throw $? abort" libtool compile failed" |
|
[ libtool-command s" --silent --mode=link gcc -module -rpath " s+ ] sliteral |
|
tempdir s+ s" " append |
|
lib-filename 2@ append s" .lo -o " append |
lib-filename 2@ append s" .la" append ( c-addr u ) |
lib-filename 2@ append s" .la" append ( c-addr u ) |
\ s" gcc -fPIC -shared -Wl,-soname," lib-filename 2@ s+ |
c-libs @ ['] append-l list-map |
\ s" .so.1 -Wl,-export_dynamic -o " append lib-filename 2@ append |
2dup type cr |
\ [ s" .so.1 -O -I " s" includedir" getenv append s" " append ] sliteral |
2dup system drop free throw $? abort" libtool link failed" |
\ append lib-filename 2@ append s" .c" append ( c-addr u ) |
lib-filename 2@ s" .la" s+ |
~~ 2dup type 2dup system drop free throw |
\ 2dup type cr |
$? abort" compiler generated error" \ !! call dlerror |
2dup open-lib dup 0= if |
tempdir s" /.libs/" s+ lib-filename 2@ append s" .so.0" append |
.lib-error true abort" open-lib failed" |
2dup type |
endif |
2dup open-lib dup 0= abort" open-lib failed" \ !! call dlerror |
|
( lib-handle ) lib-handle-addr @ ! |
( lib-handle ) lib-handle-addr @ ! |
2dup delete-file throw drop free throw |
2dup delete-file throw drop free throw |
lib-filename 2@ s" .c" s+ 2dup delete-file throw drop free throw |
lib-filename 2@ s" .c" s+ 2dup delete-file throw drop free throw |
Line 457 DEFER compile-wrapper-function
|
Line 497 DEFER compile-wrapper-function
|
|
|
: link-wrapper-function { cff -- sym } |
: link-wrapper-function { cff -- sym } |
cff cff-rtype wrapper-function-name { d: wrapper-name } |
cff cff-rtype wrapper-function-name { d: wrapper-name } |
wrapper-name cff cff-lha @ @ assert( dup ) lib-sym dup 0= -&32 and throw |
wrapper-name cff cff-lha @ @ assert( dup ) lib-sym dup 0= if |
|
.lib-error -&32 throw |
|
endif |
wrapper-name drop free throw ; |
wrapper-name drop free throw ; |
|
|
: c-function-ft ( xt-defr xt-cfr "c-name" "{libcc-type}" "--" "libcc-type" -- ) |
: c-function-ft ( xt-defr xt-cfr "c-name" "{libcc-type}" "--" "libcc-type" -- ) |
Line 488 DEFER compile-wrapper-function
|
Line 530 DEFER compile-wrapper-function
|
\G specified stack effect and calls the C function @code{c-name}. |
\G specified stack effect and calls the C function @code{c-name}. |
defer lastxt dup c-function-rt lastxt c-function-ft |
defer lastxt dup c-function-rt lastxt c-function-ft |
lastxt swap defer! ; |
lastxt swap defer! ; |
|
|
|
: clear-libs ( -- ) |
|
\G Clear the list of libs |
|
c-source-file-id @ if |
|
compile-wrapper-function |
|
endif |
|
0 c-libs ! ; |
|
clear-libs |