Annotation of gforth/libcc.fs, revision 1.2
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:
! 64: : .n ( n -- )
! 65: 0 .r ;
! 66:
! 67: : const+ ( n1 "name" -- n2 )
! 68: dup constant 1+ ;
! 69:
! 70: wordlist constant libcc-types
! 71:
! 72: get-current libcc-types set-current
! 73:
! 74: \ index values
! 75: -1
! 76: const+ -- \ end of arguments
! 77: const+ n \ integer cell
! 78: const+ p \ pointer cell
! 79: const+ d \ double
! 80: const+ r \ float
! 81: const+ func \ C function pointer
! 82: const+ void
! 83: drop
! 84:
! 85: set-current
! 86:
! 87: : parse-libcc-type ( "libcc-type" -- u )
! 88: parse-name libcc-types search-wordlist 0= -13 and throw execute ;
! 89:
! 90: : parse-function-types ( "{libcc-type}" "--" "libcc-type" -- )
! 91: here 2 chars allot here begin
! 92: parse-libcc-type dup 0>= while
! 93: c,
! 94: repeat
! 95: drop swap - over char+ c!
! 96: parse-libcc-type 0< -32 and throw swap c! ;
! 97:
! 98: : type-letter ( n -- c )
! 99: chars s" npdrfv" drop + c@ ;
! 100:
! 101: \ count-stacks
! 102:
! 103: : count-stacks-n ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
! 104: 1+ ;
! 105:
! 106: : count-stacks-p ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
! 107: 1+ ;
! 108:
! 109: : count-stacks-d ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
! 110: 2 + ;
! 111:
! 112: : count-stacks-r ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
! 113: swap 1+ swap ;
! 114:
! 115: : count-stacks-func ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
! 116: 1+ ;
! 117:
! 118: : count-stacks-void ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
! 119: ;
! 120:
! 121: create count-stacks-types
! 122: ' count-stacks-n ,
! 123: ' count-stacks-p ,
! 124: ' count-stacks-d ,
! 125: ' count-stacks-r ,
! 126: ' count-stacks-func ,
! 127: ' count-stacks-void ,
! 128:
! 129: : count-stacks ( pars -- fp-change sp-change )
! 130: \ pars is an addr u pair
! 131: 0 0 2swap over + swap u+do
! 132: i c@ cells count-stacks-type + @ execute
! 133: loop ;
! 134:
! 135: \ gen-pars
! 136:
! 137: : gen-par-n ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
! 138: 1- dup ." sp[" .n ." ]" ;
! 139:
! 140: : gen-par-p ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
! 141: ." (void *)(" gen-par-n ." )" ;
! 142:
! 143: : gen-par-d ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
! 144: ." gforthd2ll(" gen-par-n ." ," gen-par-n ." )" ;
! 145:
! 146: : gen-par-r ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
! 147: swap 1- tuck ." fp[" .n ." ]" ;
! 148:
! 149: : gen-par-func ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
! 150: gen-par-p ;
! 151:
! 152: : gen-par-void ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
! 153: -32 throw ;
! 154:
! 155: create gen-par-types
! 156: ' gen-par-n ,
! 157: ' gen-par-p ,
! 158: ' gen-par-d ,
! 159: ' gen-par-r ,
! 160: ' gen-par-func ,
! 161: ' gen-par-void ,
! 162:
! 163: : gen-par ( fp-depth1 sp-depth1 partype -- fp-depth2 sp-depth2 )
! 164: cells gen-par-types @ execute ;
! 165:
! 166: \ the call itself
! 167:
! 168: : gen-wrapped-call { d: pars d: c-name fp-change1 sp-change1 -- }
! 169: c-name type ." ("
! 170: fp-change1 sp-change1 pars over + swap u+do
! 171: i c@ gen-par
! 172: i 1+ i' < if
! 173: ." ,"
! 174: endif
! 175: loop
! 176: 2drop ." )" ;
! 177:
! 178: \ calls for various kinds of return values
! 179:
! 180: : gen-wrapped-void ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
! 181: 2dup 2>r gen-wrapped-call 2r> ;
! 182:
! 183: create gen-wrapped-types
! 184: ' gen-wrapped-n ,
! 185: ' gen-wrapped-p ,
! 186: ' gen-wrapped-d ,
! 187: ' gen-wrapped-r ,
! 188: ' gen-wrapped-func ,
! 189: ' gen-wrapped-void ,
! 190:
! 191: : gen-wrapped-stmt ( pars c-name fp-change1 sp-change1 ret -- fp-change sp-change )
! 192: cells gen-wrapped-types @ execute ;
! 193:
! 194: : gen-wrapper-function ( addr -- )
! 195: \ addr points to the return type index of a c-function descriptor
! 196: c@+ { ret } count 2dup { d: pars } chars + count { d: c-name }
! 197: ." void gforth_c_" c-name type ." _"
! 198: pars 0 +do
! 199: i chars over + c@ type-letter emit
! 200: loop
! 201: ." _" ret type-letter emit .\" (void)\n"
! 202: .\" {\n Cell *sp = gforth_SP;\n Float *fp = gforth_FP;"
! 203: pars c-name 2over count-stacks ret gen-wrapped-stmt .\" ;\n"
! 204: ?dup-if
! 205: ." gforth_SP = sp+" .n .\" ;\n"
! 206: endif
! 207: ?dup-if
! 208: ." gforth_FP = fp+" .n .\" ;\n"
! 209: endif
! 210: ." }\n" ;
! 211:
! 212: : c-function ( "forth-name" "c-name" "{libcc-type}" "--" "libcc-type" -- )
! 213: create here >r 0 , \ place for the wrapper function pointer
! 214: parse-name { d: c-name }
! 215: parse-function-types c-name string,
! 216: r> cell+ gen-wrapper-function
! 217: compile-wrapper-function
! 218: link-wrapper-function
! 219: r> !
! 220: does> ( ... -- ... )
! 221: @ call-c ;
! 222:
! 223:
! 224:
1.1 anton 225:
226:
227: s" Library not found" exception constant err-nolib
228:
229: : library ( "name" "file" -- ) \ gforth
230: \G Dynamically links the library specified by @i{file}. Defines a
231: \G word @i{name} ( -- lib ) that starts the declaration of a
232: \G function from that library.
233: create parse-name open-lib dup 0= err-nolib and throw ,
234: does> ( -- lib )
235: @ ;
236:
237:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to libcc.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth