Annotation of gforth/libcc.fs, revision 1.5

1.1       anton       1: \ libcc.fs     foreign function interface implemented using a C compiler
                      2: 
                      3: \ Copyright (C) 2006 Free Software Foundation, Inc.
                      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
                     20: 
                     21: 
                     22: \ What this implementation does is this: if it sees a declaration like
                     23: 
1.2       anton      24: \ \ something that tells it to include <unistd.h>
                     25: \ \ something that tells it that the current library is libc
                     26: 
                     27: \ c-function dlseek lseek n d n -- d
1.1       anton      28: 
                     29: \ it genererates C code similar to the following:
                     30: 
                     31: \ #include <gforth.h>
1.2       anton      32: \ #include <unistd.h>
1.1       anton      33: \ 
1.2       anton      34: \ void gforth_c_lseek_ndn_d(void)
1.1       anton      35: \ {
                     36: \   Cell *sp = gforth_SP;
                     37: \   Float *fp = gforth_FP;
1.2       anton      38: \   long long result;  /* longest type in C */
                     39: \   gforth_ll2d(lseek(sp[3],gforth_d2ll(sp[2],sp[1]),sp[0]),sp[3],sp[2]);
                     40: \   gforth_SP = sp+2;
1.1       anton      41: \ }
                     42: 
                     43: \ Then it compiles this code and dynamically links it into the Gforth
                     44: \ system (batching and caching are future work).  It also dynamically
                     45: \ links lseek.  Performing DLSEEK then puts the function pointer of
1.2       anton      46: \ the function pointer of gforth_c_lseek_ndn_d on the stack and
                     47: \ calls CALL-C.
                     48: 
                     49: \ other things to do:
                     50: 
                     51: \ c-variable forth-name c-name
                     52: \ c-constant forth-name c-name
                     53: 
                     54: 
                     55: \ data structures
                     56: 
                     57: \ c-function word body:
                     58: \  cell function pointer
                     59: \  char return type index
                     60: \  char parameter count n
                     61: \  char*n parameters (type indices)
                     62: \  counted string: c-name
                     63: 
1.3       anton      64: : .nb ( n -- )
1.2       anton      65:     0 .r ;
                     66: 
                     67: : const+ ( n1 "name" -- n2 )
                     68:     dup constant 1+ ;
                     69: 
1.5     ! anton      70: \ dlerror
        !            71: 
        !            72: \ require lib.fs
        !            73: 
        !            74: \ library libc libc.so.6
        !            75: \ libc sleep int (int) sleep
        !            76: \ libc dlerror (ptr) dlerror
        !            77: 
1.2       anton      78: wordlist constant libcc-types
                     79: 
                     80: get-current libcc-types set-current
                     81: 
                     82: \ index values
                     83: -1
                     84: const+ -- \ end of arguments
                     85: const+ n \ integer cell
1.5     ! anton      86: const+ a \ address cell
1.2       anton      87: const+ d \ double
                     88: const+ r \ float
                     89: const+ func \ C function pointer
                     90: const+ void
                     91: drop
                     92: 
                     93: set-current
                     94: 
                     95: : parse-libcc-type ( "libcc-type" -- u )
                     96:     parse-name libcc-types search-wordlist 0= -13 and throw execute ;
                     97: 
                     98: : parse-function-types ( "{libcc-type}" "--" "libcc-type" -- )
                     99:     here 2 chars allot here begin
                    100:        parse-libcc-type dup 0>= while
                    101:            c,
                    102:     repeat
1.3       anton     103:     drop here swap - over char+ c!
                    104:     parse-libcc-type dup 0< -32 and throw swap c! ;
1.2       anton     105: 
                    106: : type-letter ( n -- c )
1.5     ! anton     107:     chars s" nadrfv" drop + c@ ;
1.2       anton     108: 
                    109: \ count-stacks
                    110: 
                    111: : count-stacks-n ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    112:     1+ ;
                    113: 
1.5     ! anton     114: : count-stacks-a ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
1.2       anton     115:     1+ ;
                    116: 
                    117: : count-stacks-d ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    118:     2 + ;
                    119: 
                    120: : count-stacks-r ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    121:     swap 1+ swap ;
                    122: 
                    123: : count-stacks-func ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    124:     1+ ;
                    125: 
                    126: : count-stacks-void ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
                    127: ;
                    128: 
                    129: create count-stacks-types
                    130: ' count-stacks-n ,
1.5     ! anton     131: ' count-stacks-a ,
1.2       anton     132: ' count-stacks-d ,
                    133: ' count-stacks-r ,
                    134: ' count-stacks-func ,
                    135: ' count-stacks-void ,
                    136: 
                    137: : count-stacks ( pars -- fp-change sp-change )
                    138:     \ pars is an addr u pair
                    139:     0 0 2swap over + swap u+do
1.3       anton     140:        i c@ cells count-stacks-types + @ execute
1.2       anton     141:     loop ;
                    142: 
                    143: \ gen-pars
                    144: 
                    145: : gen-par-n ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.5     ! anton     146:     ." sp[" 1- dup .nb ." ]" ;
1.2       anton     147: 
1.5     ! anton     148: : gen-par-a ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.2       anton     149:     ." (void *)(" gen-par-n ." )" ;
                    150: 
                    151: : gen-par-d ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.4       anton     152:     ." gforth_d2ll(" gen-par-n ." ," gen-par-n ." )" ;
1.2       anton     153: 
                    154: : gen-par-r ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.3       anton     155:     swap 1- tuck ." fp[" .nb ." ]" ;
1.2       anton     156: 
                    157: : gen-par-func ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
1.5     ! anton     158:     gen-par-a ;
1.2       anton     159: 
                    160: : gen-par-void ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
                    161:     -32 throw ;
                    162: 
                    163: create gen-par-types
                    164: ' gen-par-n ,
1.5     ! anton     165: ' gen-par-a ,
1.2       anton     166: ' gen-par-d ,
                    167: ' gen-par-r ,
                    168: ' gen-par-func ,
                    169: ' gen-par-void ,
                    170: 
                    171: : gen-par ( fp-depth1 sp-depth1 partype -- fp-depth2 sp-depth2 )
1.3       anton     172:     cells gen-par-types + @ execute ;
1.2       anton     173: 
                    174: \ the call itself
                    175: 
                    176: : gen-wrapped-call { d: pars d: c-name fp-change1 sp-change1 -- }
                    177:     c-name type ." ("
1.3       anton     178:     fp-change1 sp-change1 pars over + swap u+do 
1.2       anton     179:        i c@ gen-par
                    180:        i 1+ i' < if
                    181:            ." ,"
                    182:        endif
                    183:     loop
                    184:     2drop ." )" ;
                    185: 
                    186: \ calls for various kinds of return values
                    187: 
                    188: : gen-wrapped-void ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
                    189:     2dup 2>r gen-wrapped-call 2r> ;
                    190: 
1.3       anton     191: : gen-wrapped-n ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
1.5     ! anton     192:     2dup gen-par-n 2>r ." =" gen-wrapped-call 2r> ;
1.3       anton     193: 
1.5     ! anton     194: : gen-wrapped-a ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
        !           195:     2dup gen-par-n 2>r ." =(Cell)" gen-wrapped-call 2r> ;
1.3       anton     196: 
                    197: : gen-wrapped-d ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
                    198:     ." gforth_ll2d(" gen-wrapped-void
1.5     ! anton     199:     ." ," gen-par-n ." ," gen-par-n ." )" ;
1.3       anton     200: 
                    201: : gen-wrapped-r ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
1.5     ! anton     202:     2dup gen-par-r 2>r ." =" gen-wrapped-void 2r> ;
1.3       anton     203: 
                    204: : gen-wrapped-func ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
1.5     ! anton     205:     gen-wrapped-a ;
1.3       anton     206: 
1.2       anton     207: create gen-wrapped-types
                    208: ' gen-wrapped-n ,
1.5     ! anton     209: ' gen-wrapped-a ,
1.2       anton     210: ' gen-wrapped-d ,
                    211: ' gen-wrapped-r ,
                    212: ' gen-wrapped-func ,
                    213: ' gen-wrapped-void ,
                    214: 
                    215: : gen-wrapped-stmt ( pars c-name fp-change1 sp-change1 ret -- fp-change sp-change )
1.3       anton     216:     cells gen-wrapped-types + @ execute ;
1.2       anton     217: 
                    218: : gen-wrapper-function ( addr -- )
                    219:     \ addr points to the return type index of a c-function descriptor
                    220:     c@+ { ret } count 2dup { d: pars } chars + count { d: c-name }
1.5     ! anton     221:     .\" #include \"engine/libcc.h\"\n"
1.2       anton     222:     ." void gforth_c_" c-name type ." _"
1.5     ! anton     223:     pars bounds u+do
        !           224:        i c@ type-letter emit
1.2       anton     225:     loop
                    226:     ." _" ret type-letter emit .\" (void)\n"
1.4       anton     227:     .\" {\n  Cell MAYBE_UNUSED *sp = gforth_SP;\n  Float MAYBE_UNUSED *fp = gforth_FP;\n  "
1.2       anton     228:     pars c-name 2over count-stacks ret gen-wrapped-stmt .\" ;\n"
                    229:     ?dup-if
1.3       anton     230:        ."   gforth_SP = sp+" .nb .\" ;\n"
1.2       anton     231:     endif
                    232:     ?dup-if
1.3       anton     233:        ."   gforth_FP = fp+" .nb .\" ;\n"
1.2       anton     234:     endif
1.3       anton     235:     .\" }\n" ;
1.2       anton     236: 
1.5     ! anton     237: : compile-wrapper-function ( -- )
        !           238:     s" gcc -fPIC -shared -Wl,-soname,xxx.so.1 -Wl,-export_dynamic -o xxx.so.1 -O xxx.c" system
        !           239:     $? abort" compiler generated error" ;
        !           240: \    s" ar rcs xxx.a xxx.o" system
        !           241: \    $? abort" ar generated error" ;
        !           242: 
        !           243: : link-wrapper-function ( -- )
        !           244:     s" /home/anton/gforth/xxx.so.1" open-lib ( lib-handle )
        !           245:     s" gforth_c_strlen_a_n" rot lib-sym dup 0= -32 and throw ;
        !           246: 
1.2       anton     247: : c-function ( "forth-name" "c-name" "{libcc-type}" "--" "libcc-type" -- )
                    248:     create here >r 0 , \ place for the wrapper function pointer
                    249:     parse-name { d: c-name }
                    250:     parse-function-types c-name string,
1.5     ! anton     251:     r@ cell+
        !           252:     s" xxx.c" w/o create-file throw ( file-id )
        !           253:     dup >r >outfile gen-wrapper-function outfile<
        !           254:     r> close-file throw
        !           255:     compile-wrapper-function
        !           256:     link-wrapper-function
        !           257:     r> !
1.2       anton     258:   does> ( ... -- ... )
                    259:     @ call-c ;
                    260: 
                    261: 
                    262: 
1.1       anton     263: 
                    264: 
                    265: s" Library not found" exception constant err-nolib
                    266: 
                    267: : library ( "name" "file" -- ) \ gforth
                    268: \G Dynamically links the library specified by @i{file}.  Defines a
                    269: \G word @i{name} ( -- lib ) that starts the declaration of a
                    270: \G function from that library.
                    271:     create parse-name open-lib dup 0= err-nolib and throw ,
                    272:   does> ( -- lib )
                    273:     @ ;
                    274: 
1.3       anton     275: \ test
1.1       anton     276: 
1.5     ! anton     277: \ test all parameter and return types
        !           278: 
        !           279: \ cr .( #include "engine/libcc.h")
        !           280: \ cr .( #include <unistd.h>)
        !           281: \ cr ." typedef void (* func)(int);
        !           282: \ cr ." int test1(int,char*,long,double,void (*)(int));"
        !           283: \ cr ." Cell *test2(void);"
        !           284: \ cr ." int test3(void);"
        !           285: \ cr ." float test4(void);"
        !           286: \ cr ." func test5(void);"
        !           287: \ cr ." void test6(void);"
        !           288: \ cr
        !           289: 
        !           290: \ c-function dlseek lseek n d n -- d
        !           291: \ c-function n test1 n a d r func -- n
        !           292: \ c-function a test2 -- a
        !           293: \ c-function d test3 -- d
        !           294: \ c-function r test4 -- r
        !           295: \ c-function func test5 -- func
        !           296: \ c-function void test6 -- void
        !           297: 
        !           298: c-function strlen strlen a -- n
        !           299: 
        !           300: cr s\" fooo\0" 2dup dump drop .s strlen cr .s cr

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>