--- gforth/libcc.fs 2008/07/10 21:11:57 1.42 +++ gforth/libcc.fs 2009/10/18 17:52:50 1.61 @@ -1,6 +1,6 @@ \ libcc.fs foreign function interface implemented using a C compiler -\ Copyright (C) 2006,2007 Free Software Foundation, Inc. +\ Copyright (C) 2006,2007,2008 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -135,9 +135,8 @@ \ : delete-file 2drop 0 ; require struct.fs +require mkdir.fs - \ counted-string - \ c-function-ft word body: struct cell% field cff-cfr \ xt of c-function-rt word @@ -158,8 +157,11 @@ variable lib-handle-addr \ points to the here 0 , lib-handle-addr ! \ just make sure LIB-HANDLE always works 2variable lib-filename \ filename without extension 2variable lib-modulename \ basename of the file without extension +2variable libcc-named-dir-v \ directory for named libcc wrapper libraries +0 value libcc-path \ pointer to path of library directories -: delete-file 2drop 0 ; +defer replace-rpath ( c-addr1 u1 -- c-addr2 u2 ) +' noop is replace-rpath : .nb ( n -- ) 0 .r ; @@ -217,24 +219,19 @@ end-struct list% node list-next @ repeat ; -\ linked libraries +2variable c-libs \ library names in a string (without "lib") -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 -- ) +: add-lib ( c-addr u -- ) \ gforth \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" to string1 - >r s" -l" append r> c-lib-string 2@ append ; + \G @i{string} is represented by @i{c-addr u}. + c-libs 2@ d0= IF 0 allocate throw 0 c-libs 2! THEN + c-libs 2@ s" -l" append 2swap append c-libs 2! ; + +: add-libpath ( c-addr u -- ) \ gforth +\G Add path @i{string} to the list of library search pathes, where + \G @i{string} is represented by @i{c-addr u}. + c-libs 2@ d0= IF 0 allocate throw 0 c-libs 2! THEN + c-libs 2@ s" -L" append 2swap append c-libs 2! ; \ C prefix lines @@ -254,13 +251,21 @@ variable c-prefix-lines-end c-prefix-lin : print-c-prefix-lines ( -- ) c-prefix-lines @ ['] print-c-prefix-line list-map ; -: save-c-prefix-line ( c-addr u -- ) - c-source-file-id @ ?dup-if - >r 2dup r> write-line throw - then +: write-c-prefix-line ( c-addr u -- ) + c-source-file-id @ dup if + write-line throw + else + drop 2drop + then ; + +: save-c-prefix-line1 ( c-addr u -- ) + 2dup write-c-prefix-line align here 0 , c-prefix-lines-end list-append ( c-addr u ) longstring, ; +defer save-c-prefix-line ( c-addr u -- ) +' save-c-prefix-line1 is save-c-prefix-line + : \c ( "rest-of-line" -- ) \ gforth backslash-c \G One line of C declarations for the C interface -1 parse save-c-prefix-line ; @@ -430,7 +435,7 @@ create gen-wrapped-types dup { descriptor } count { ret } count 2dup { d: pars } chars + count { d: c-name } ." void " lib-modulename 2@ type ." _LTX_" descriptor wrapper-function-name 2dup type drop free throw - .\" (void)\n" + .\" (GFORTH_ARGS)\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" ?dup-if @@ -464,7 +469,7 @@ create gen-wrapped-types s" gforth_c_" 2swap s+ #>> ; : libcc-named-dir ( -- c-addr u ) - s" ~/.gforth/libcc-named/" ; + libcc-named-dir-v 2@ ; : libcc-tmp-dir ( -- c-addr u ) s" ~/.gforth/libcc-tmp/" ; @@ -472,12 +477,6 @@ create gen-wrapped-types : prepend-dirname ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 ) 2over s+ 2swap drop free throw ; -0 value libcc-path -here 1024 dup , 0 , allot to libcc-path \ !! the path words should grow buffers dynamically -libcc-path clear-path -libcc-named-dir libcc-path also-path -\ !! setup path on boot - : open-wrappers ( -- addr|0 ) lib-filename 2@ s" .la" s+ 2dup libcc-named-dir string-prefix? if ( c-addr u ) @@ -495,12 +494,12 @@ libcc-named-dir libcc-path also-path assert( c-source-file-id @ 0= ) { d: filename } here 0 , lib-handle-addr ! filename lib-filename 2! - filename basename lib-modulename 2! ; + filename basename lib-modulename 2! + ['] write-c-prefix-line is save-c-prefix-line ; : c-library-name-create ( -- ) lib-filename 2@ s" .c" s+ 2dup w/o create-file throw - dup c-source-file-id ! - ['] print-c-prefix-lines swap outfile-execute + c-source-file-id ! drop free throw ; : c-named-library-name ( c-addr u -- ) @@ -510,13 +509,18 @@ libcc-named-dir libcc-path also-path open-wrappers dup if lib-handle-addr @ ! else + libcc-named-dir $1ff mkdir-parents drop drop c-library-name-create + c-prefix-lines @ ['] print-c-prefix-line \ first line only + c-source-file-id @ outfile-execute endif ; : c-tmp-library-name ( c-addr u -- ) \ set up filenames for a new library; c-addr u is the basename of \ the library - libcc-tmp-dir prepend-dirname c-library-name-setup c-library-name-create ; + libcc-tmp-dir 2dup $1ff mkdir-parents drop + prepend-dirname c-library-name-setup c-library-name-create + ['] print-c-prefix-lines c-source-file-id @ outfile-execute ; : lib-handle ( -- addr ) lib-handle-addr @ @ ; @@ -558,17 +562,19 @@ DEFER compile-wrapper-function ( -- ) lib-handle 0= if c-source-file close-file throw 0 c-source-file-id ! - [ libtool-command s" --silent --mode=compile gcc -I " s+ - s" includedir" getenv append ] sliteral + [ libtool-command s" --silent --mode=compile " s+ + libtool-cc append s" -I '" append + s" includedir" getenv append s" '" append ] sliteral 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 type cr 2dup system drop free throw $? abort" libtool compile failed" - [ libtool-command s" --silent --mode=link gcc -module -rpath " s+ ] sliteral - lib-filename 2@ dirname s+ s" " append + [ libtool-command s" --silent --mode=link " s+ + libtool-cc append libtool-flags append s" -module -rpath " s+ ] sliteral + lib-filename 2@ dirname replace-rpath s+ s" " append lib-filename 2@ append s" .lo -o " append lib-filename 2@ append s" .la" append ( c-addr u ) - c-libs @ ['] append-l list-map + c-libs 2@ append \ 2dup type cr 2dup system drop free throw $? abort" libtool link failed" open-wrappers dup 0= if @@ -617,12 +623,12 @@ DEFER compile-wrapper-function ( -- ) defer lastxt dup c-function-rt lastxt c-function-ft lastxt swap defer! ; -: clear-libs ( -- ) +: clear-libs ( -- ) \ gforth \G Clear the list of libs c-source-file-id @ if compile-wrapper-function endif - 0 c-libs ! ; + 0. c-libs 2! ; clear-libs : c-library-incomplete ( -- ) @@ -640,5 +646,22 @@ clear-libs : end-c-library ( -- ) \ gforth \G Finish and (if necessary) build the latest C library interface. + ['] save-c-prefix-line1 is save-c-prefix-line ['] compile-wrapper-function1 is compile-wrapper-function compile-wrapper-function1 ; + +: init-libcc ( -- ) + s" ~/.gforth/libcc-named/" libcc-named-dir-v 2! +[IFDEF] make-path + make-path to libcc-path + libcc-named-dir libcc-path also-path + [ s" libccdir" getenv ] sliteral libcc-path also-path +[THEN] +; + +init-libcc + +:noname ( -- ) + defers 'cold + init-libcc ; +is 'cold