[gforth] / gforth / libcc.fs  

gforth: gforth/libcc.fs

1 : anton 1.1 \ libcc.fs foreign function interface implemented using a C compiler
2 :    
3 : anton 1.69 \ Copyright (C) 2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc.
4 : anton 1.1
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 : anton 1.28 \ as published by the Free Software Foundation, either version 3
10 : anton 1.1 \ 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 : anton 1.28 \ along with this program. If not, see http://www.gnu.org/licenses/.
19 : anton 1.1
20 :    
21 :     \ What this implementation does is this: if it sees a declaration like
22 :    
23 : anton 1.2 \ \ something that tells it that the current library is libc
24 : anton 1.6 \ \c #include <unistd.h>
25 : anton 1.2 \ c-function dlseek lseek n d n -- d
26 : anton 1.1
27 :     \ it genererates C code similar to the following:
28 :    
29 :     \ #include <gforth.h>
30 : anton 1.2 \ #include <unistd.h>
31 : anton 1.1 \
32 : anton 1.2 \ void gforth_c_lseek_ndn_d(void)
33 : anton 1.1 \ {
34 :     \ Cell *sp = gforth_SP;
35 :     \ Float *fp = gforth_FP;
36 : anton 1.2 \ long long result; /* longest type in C */
37 :     \ gforth_ll2d(lseek(sp[3],gforth_d2ll(sp[2],sp[1]),sp[0]),sp[3],sp[2]);
38 :     \ gforth_SP = sp+2;
39 : anton 1.1 \ }
40 :    
41 :     \ Then it compiles this code and dynamically links it into the Gforth
42 :     \ system (batching and caching are future work). It also dynamically
43 :     \ links lseek. Performing DLSEEK then puts the function pointer of
44 : anton 1.2 \ the function pointer of gforth_c_lseek_ndn_d on the stack and
45 :     \ calls CALL-C.
46 :    
47 : anton 1.7 \ ToDo:
48 :    
49 :     \ Batching, caching and lazy evaluation:
50 :    
51 :     \ Batching:
52 :    
53 :     \ New words are deferred, and the corresponding C functions are
54 :     \ collected in one file, until the first word is EXECUTEd; then the
55 :     \ file is compiled and linked into the system, and the word is
56 :     \ resolved.
57 :    
58 :     \ Caching:
59 :    
60 :     \ Instead of compiling all this stuff anew for every execution, we
61 :     \ keep the files around and have an index file containing the function
62 :     \ names and their corresponding .so files. If the needed wrapper name
63 :     \ is already present, it is just linked instead of generating the
64 :     \ wrapper again. This is all done by loading the index file(s?),
65 :     \ which define words for the wrappers in a separate wordlist.
66 :    
67 : pazsan 1.71 \ The files are built in .../lib/gforth$ARCH/$VERSION/libcc/ or
68 :     \ ~/.gforth$ARCH/libcc/$HOST/.
69 : anton 1.7
70 : anton 1.20 \ Todo: conversion between function pointers and xts (both directions)
71 :    
72 :     \ taking an xt and turning it into a function pointer:
73 :    
74 :     \ e.g., assume we have the xt of + and want to create a C function int
75 :     \ gforth_callback_plus(int, int), and then pass the pointer to that
76 :     \ function:
77 :    
78 :     \ There should be Forth code like this:
79 :     \ ] + 0 (bye)
80 :     \ Assume that the start of this code is START
81 :    
82 :     \ Now, there should be a C function:
83 :    
84 :     \ int gforth_callback_plus(int p1, int p2)
85 :     \ {
86 :     \ Cell *sp = gforth_SP;
87 :     \ Float *fp = gforth_FP;
88 :     \ Float *fp = gforth_FP;
89 :     \ Address lp = gforth_LP;
90 :     \ sp -= 2;
91 :     \ sp[0] = p1;
92 :     \ sp[1] = p2;
93 :     \ gforth_engine(START, sp, rp, fp, lp);
94 :     \ sp += 1;
95 :     \ gforth_RP = rp;
96 :     \ gforth_SP = sp;
97 :     \ gforth_FP = fp;
98 :     \ gforth_LP = lp;
99 :     \ return sp[0];
100 :     \ }
101 :    
102 :     \ and the pointer to that function is the C function pointer for the XT of +.
103 :    
104 :     \ Future problems:
105 :     \ how to combine the Forth code generation with inlining
106 :     \ START is not a constant across executions (when caching the C files)
107 :     \ Solution: make START a variable, and store into it on startup with dlsym
108 :    
109 :     \ Syntax:
110 :     \ callback <rettype> <params> <paramtypes> -- <rettype>
111 :    
112 : anton 1.2
113 :     \ data structures
114 :    
115 : anton 1.10 \ For every c-function, we have three words: two anonymous words
116 :     \ created by c-function-ft (first time) and c-function-rt (run-time),
117 :     \ and a named deferred word. The deferred word first points to the
118 :     \ first-time word, then to the run-time word; the run-time word calls
119 :     \ the c function.
120 :    
121 : anton 1.29 [ifundef] parse-name
122 :     ' parse-word alias parse-name
123 :     [then]
124 :     [ifundef] defer!
125 :     : defer! ( xt xt-deferred -- ) \ gforth defer-store
126 :     \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
127 :     >body [ has? rom [IF] ] @ [ [THEN] ] ! ;
128 :     [then]
129 :    
130 :     \ : delete-file 2drop 0 ;
131 : anton 1.12
132 :     require struct.fs
133 : anton 1.56 require mkdir.fs
134 : anton 1.12
135 : anton 1.10 \ c-function-ft word body:
136 : anton 1.12 struct
137 :     cell% field cff-cfr \ xt of c-function-rt word
138 :     cell% field cff-deferred \ xt of c-function deferred word
139 :     cell% field cff-lha \ address of the lib-handle for the lib that
140 :     \ contains the wrapper function of the word
141 : pazsan 1.62 char% field cff-ctype \ call type (function=1, value=0)
142 : anton 1.12 char% field cff-rtype \ return type
143 :     char% field cff-np \ number of parameters
144 :     1 0 field cff-ptypes \ #npar parameter types
145 :     \ counted string: c-name
146 :     end-struct cff%
147 :    
148 : anton 1.14 variable c-source-file-id \ contains the source file id of the current batch
149 :     0 c-source-file-id !
150 :     variable lib-handle-addr \ points to the library handle of the current batch.
151 :     \ the library handle is 0 if the current
152 :     \ batch is not yet compiled.
153 : anton 1.39 here 0 , lib-handle-addr ! \ just make sure LIB-HANDLE always works
154 : anton 1.23 2variable lib-filename \ filename without extension
155 :     2variable lib-modulename \ basename of the file without extension
156 : anton 1.44 2variable libcc-named-dir-v \ directory for named libcc wrapper libraries
157 : pazsan 1.65 Variable libcc-path \ pointer to path of library directories
158 : anton 1.2
159 : anton 1.49 defer replace-rpath ( c-addr1 u1 -- c-addr2 u2 )
160 :     ' noop is replace-rpath
161 : anton 1.35
162 : anton 1.3 : .nb ( n -- )
163 : anton 1.2 0 .r ;
164 :    
165 :     : const+ ( n1 "name" -- n2 )
166 :     dup constant 1+ ;
167 :    
168 : anton 1.10 : front-string { c-addr1 u1 c-addr2 u2 -- c-addr3 u3 }
169 :     \ insert string c-addr2 u2 in buffer c-addr1 u1; c-addr3 u3 is the
170 :     \ remainder of the buffer.
171 :     assert( u1 u2 u>= )
172 :     c-addr2 c-addr1 u2 move
173 :     c-addr1 u1 u2 /string ;
174 :    
175 :     : front-char { c-addr1 u1 c -- c-addr3 u2 }
176 :     \ insert c in buffer c-addr1 u1; c-addr3 u3 is the remainder of
177 :     \ the buffer.
178 :     assert( u1 0 u> )
179 :     c c-addr1 c!
180 :     c-addr1 u1 1 /string ;
181 :    
182 : anton 1.15 : s+ { addr1 u1 addr2 u2 -- addr u }
183 :     u1 u2 + allocate throw { addr }
184 :     addr1 addr u1 move
185 :     addr2 addr u1 + u2 move
186 :     addr u1 u2 +
187 :     ;
188 :    
189 :     : append { addr1 u1 addr2 u2 -- addr u }
190 :     addr1 u1 u2 + dup { u } resize throw { addr }
191 :     addr2 addr u1 + u2 move
192 :     addr u ;
193 :    
194 : anton 1.6 \ linked list stuff (should go elsewhere)
195 :    
196 :     struct
197 :     cell% field list-next
198 :     1 0 field list-payload
199 :     end-struct list%
200 :    
201 :     : list-insert { node list -- }
202 :     list list-next @ node list-next !
203 :     node list list-next ! ;
204 :    
205 :     : list-append { node endlistp -- }
206 :     \ insert node at place pointed to by endlistp
207 :     node endlistp @ list-insert
208 :     node list-next endlistp ! ;
209 :    
210 :     : list-map ( ... list xt -- ... )
211 :     \ xt ( ... node -- ... )
212 :     { xt } begin { node }
213 :     node while
214 :     node xt execute
215 :     node list-next @
216 :     repeat ;
217 :    
218 : pazsan 1.59 2variable c-libs \ library names in a string (without "lib")
219 : anton 1.33
220 : anton 1.53 : add-lib ( c-addr u -- ) \ gforth
221 : anton 1.33 \G Add library lib@i{string} to the list of libraries, where
222 : pazsan 1.59 \G @i{string} is represented by @i{c-addr u}.
223 :     c-libs 2@ d0= IF 0 allocate throw 0 c-libs 2! THEN
224 :     c-libs 2@ s" -l" append 2swap append c-libs 2! ;
225 :    
226 :     : add-libpath ( c-addr u -- ) \ gforth
227 :     \G Add path @i{string} to the list of library search pathes, where
228 :     \G @i{string} is represented by @i{c-addr u}.
229 :     c-libs 2@ d0= IF 0 allocate throw 0 c-libs 2! THEN
230 :     c-libs 2@ s" -L" append 2swap append c-libs 2! ;
231 : anton 1.33
232 : anton 1.6 \ C prefix lines
233 :    
234 :     \ linked list of longcstrings: [ link | count-cell | characters ]
235 :    
236 :     list%
237 :     cell% field c-prefix-count
238 :     1 0 field c-prefix-chars
239 :     end-struct c-prefix%
240 :    
241 :     variable c-prefix-lines 0 c-prefix-lines !
242 :     variable c-prefix-lines-end c-prefix-lines c-prefix-lines-end !
243 :    
244 : anton 1.14 : print-c-prefix-line ( node -- )
245 :     dup c-prefix-chars swap c-prefix-count @ type cr ;
246 :    
247 :     : print-c-prefix-lines ( -- )
248 :     c-prefix-lines @ ['] print-c-prefix-line list-map ;
249 :    
250 : anton 1.61 : write-c-prefix-line ( c-addr u -- )
251 :     c-source-file-id @ dup if
252 :     write-line throw
253 :     else
254 :     drop 2drop
255 :     then ;
256 : pazsan 1.60
257 : anton 1.61 : save-c-prefix-line1 ( c-addr u -- )
258 :     2dup write-c-prefix-line
259 : anton 1.6 align here 0 , c-prefix-lines-end list-append ( c-addr u )
260 :     longstring, ;
261 :    
262 : anton 1.61 defer save-c-prefix-line ( c-addr u -- )
263 :     ' save-c-prefix-line1 is save-c-prefix-line
264 :    
265 : anton 1.18 : \c ( "rest-of-line" -- ) \ gforth backslash-c
266 : anton 1.17 \G One line of C declarations for the C interface
267 : anton 1.6 -1 parse save-c-prefix-line ;
268 :    
269 : pazsan 1.73 s" #include <gforth" arch-modifier s+ s" /" append version-string append s" /libcc.h>" append ( c-addr u )
270 : anton 1.19 2dup save-c-prefix-line drop free throw
271 : anton 1.5
272 : anton 1.6 \ Types (for parsing)
273 : anton 1.5
274 : anton 1.2 wordlist constant libcc-types
275 :    
276 :     get-current libcc-types set-current
277 :    
278 :     \ index values
279 :     -1
280 :     const+ -- \ end of arguments
281 :     const+ n \ integer cell
282 : anton 1.5 const+ a \ address cell
283 : anton 1.2 const+ d \ double
284 :     const+ r \ float
285 :     const+ func \ C function pointer
286 :     const+ void
287 :     drop
288 :    
289 :     set-current
290 :    
291 : pazsan 1.62 \ call types
292 :     0
293 :     const+ c-func
294 :     const+ c-val
295 :     const+ c-var
296 :     drop
297 :    
298 :     : libcc-type ( c-addr u -- u2 )
299 :     libcc-types search-wordlist 0= -13 and throw execute ;
300 :    
301 :     : parse-libcc-type ( "libcc-type" -- u ) parse-name libcc-type ;
302 : anton 1.2
303 : pazsan 1.62 : parse-return-type ( "libcc-type" -- u )
304 :     parse-libcc-type dup 0< -32 and throw ;
305 :    
306 :     : parse-function-types ( "{libcc-type}" "--" "libcc-type" -- addr )
307 :     c-func c, here
308 :     dup 2 chars allot here begin
309 : anton 1.2 parse-libcc-type dup 0>= while
310 :     c,
311 :     repeat
312 : anton 1.3 drop here swap - over char+ c!
313 : pazsan 1.62 parse-return-type swap c! ;
314 :    
315 :     : parse-value-type ( "{--}" "libcc-type" -- addr )
316 :     c-val c, here
317 :     parse-libcc-type dup 0< if drop parse-return-type then
318 :     c, 0 c, ;
319 :    
320 :     : parse-variable-type ( -- addr )
321 :     c-var c, here
322 :     s" a" libcc-type c, 0 c, ;
323 : anton 1.2
324 :     : type-letter ( n -- c )
325 : pazsan 1.52 chars s" nadrfv" drop + c@ ;
326 : anton 1.2
327 :     \ count-stacks
328 :    
329 :     : count-stacks-n ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
330 :     1+ ;
331 :    
332 : anton 1.5 : count-stacks-a ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
333 : anton 1.2 1+ ;
334 :    
335 :     : count-stacks-d ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
336 :     2 + ;
337 :    
338 :     : count-stacks-r ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
339 :     swap 1+ swap ;
340 :    
341 :     : count-stacks-func ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
342 :     1+ ;
343 :    
344 :     : count-stacks-void ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
345 :     ;
346 :    
347 :     create count-stacks-types
348 :     ' count-stacks-n ,
349 : anton 1.5 ' count-stacks-a ,
350 : anton 1.2 ' count-stacks-d ,
351 :     ' count-stacks-r ,
352 :     ' count-stacks-func ,
353 :     ' count-stacks-void ,
354 :    
355 :     : count-stacks ( pars -- fp-change sp-change )
356 :     \ pars is an addr u pair
357 :     0 0 2swap over + swap u+do
358 : anton 1.3 i c@ cells count-stacks-types + @ execute
359 : anton 1.2 loop ;
360 :    
361 :     \ gen-pars
362 :    
363 :     : gen-par-n ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
364 : anton 1.5 ." sp[" 1- dup .nb ." ]" ;
365 : anton 1.2
366 : anton 1.5 : gen-par-a ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
367 : anton 1.2 ." (void *)(" gen-par-n ." )" ;
368 :    
369 :     : gen-par-d ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
370 : anton 1.4 ." gforth_d2ll(" gen-par-n ." ," gen-par-n ." )" ;
371 : anton 1.2
372 :     : gen-par-r ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
373 : anton 1.3 swap 1- tuck ." fp[" .nb ." ]" ;
374 : anton 1.2
375 :     : gen-par-func ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
376 : anton 1.5 gen-par-a ;
377 : anton 1.2
378 :     : gen-par-void ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
379 :     -32 throw ;
380 :    
381 :     create gen-par-types
382 :     ' gen-par-n ,
383 : anton 1.5 ' gen-par-a ,
384 : anton 1.2 ' gen-par-d ,
385 :     ' gen-par-r ,
386 :     ' gen-par-func ,
387 :     ' gen-par-void ,
388 :    
389 :     : gen-par ( fp-depth1 sp-depth1 partype -- fp-depth2 sp-depth2 )
390 : anton 1.3 cells gen-par-types + @ execute ;
391 : anton 1.2
392 :     \ the call itself
393 :    
394 : pazsan 1.62 : gen-wrapped-func { d: pars d: c-name fp-change1 sp-change1 -- }
395 : anton 1.2 c-name type ." ("
396 : anton 1.3 fp-change1 sp-change1 pars over + swap u+do
397 : anton 1.2 i c@ gen-par
398 :     i 1+ i' < if
399 :     ." ,"
400 :     endif
401 :     loop
402 :     2drop ." )" ;
403 :    
404 : pazsan 1.62 : gen-wrapped-const { d: pars d: c-name fp-change1 sp-change1 -- }
405 :     ." (" c-name type ." )" ;
406 :    
407 :     : gen-wrapped-var { d: pars d: c-name fp-change1 sp-change1 -- }
408 :     ." &(" c-name type ." )" ;
409 :    
410 :     create gen-call-types
411 :     ' gen-wrapped-func ,
412 :     ' gen-wrapped-const ,
413 :     ' gen-wrapped-var ,
414 :    
415 :     : gen-wrapped-call ( pars c-name fp-change1 sp-change1 -- )
416 :     5 pick 3 chars - c@ cells gen-call-types + @ execute ;
417 :    
418 : anton 1.2 \ calls for various kinds of return values
419 :    
420 :     : gen-wrapped-void ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
421 :     2dup 2>r gen-wrapped-call 2r> ;
422 :    
423 : anton 1.3 : gen-wrapped-n ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
424 : anton 1.5 2dup gen-par-n 2>r ." =" gen-wrapped-call 2r> ;
425 : anton 1.3
426 : anton 1.5 : gen-wrapped-a ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
427 :     2dup gen-par-n 2>r ." =(Cell)" gen-wrapped-call 2r> ;
428 : anton 1.3
429 :     : gen-wrapped-d ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
430 :     ." gforth_ll2d(" gen-wrapped-void
431 : anton 1.5 ." ," gen-par-n ." ," gen-par-n ." )" ;
432 : anton 1.3
433 :     : gen-wrapped-r ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
434 : anton 1.30 2dup gen-par-r 2>r ." =" gen-wrapped-call 2r> ;
435 : anton 1.3
436 :     : gen-wrapped-func ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
437 : anton 1.5 gen-wrapped-a ;
438 : anton 1.3
439 : anton 1.2 create gen-wrapped-types
440 :     ' gen-wrapped-n ,
441 : anton 1.5 ' gen-wrapped-a ,
442 : anton 1.2 ' gen-wrapped-d ,
443 :     ' gen-wrapped-r ,
444 :     ' gen-wrapped-func ,
445 :     ' gen-wrapped-void ,
446 :    
447 :     : gen-wrapped-stmt ( pars c-name fp-change1 sp-change1 ret -- fp-change sp-change )
448 : anton 1.3 cells gen-wrapped-types + @ execute ;
449 : anton 1.2
450 : anton 1.10 : wrapper-function-name ( addr -- c-addr u )
451 :     \ addr points to the return type index of a c-function descriptor
452 :     count { r-type } count { d: pars }
453 :     pars + count { d: c-name }
454 :     s" gforth_c_" { d: prefix }
455 :     prefix nip c-name nip + pars nip + 3 + { u }
456 :     u allocate throw { c-addr }
457 :     c-addr u
458 :     prefix front-string c-name front-string '_ front-char
459 :     pars bounds u+do
460 :     i c@ type-letter front-char
461 :     loop
462 :     '_ front-char r-type type-letter front-char assert( dup 0= )
463 :     2drop c-addr u ;
464 :    
465 : anton 1.2 : gen-wrapper-function ( addr -- )
466 :     \ addr points to the return type index of a c-function descriptor
467 : anton 1.10 dup { descriptor }
468 : anton 1.13 count { ret } count 2dup { d: pars } chars + count { d: c-name }
469 : pazsan 1.70 ." void "
470 : pazsan 1.72 [ lib-suffix s" .la" str= [IF] ] ." lib" lib-modulename 2@ type ." _LTX_" [ [THEN] ]
471 : pazsan 1.70 descriptor wrapper-function-name 2dup type drop free throw
472 : pazsan 1.54 .\" (GFORTH_ARGS)\n"
473 : anton 1.4 .\" {\n Cell MAYBE_UNUSED *sp = gforth_SP;\n Float MAYBE_UNUSED *fp = gforth_FP;\n "
474 : anton 1.2 pars c-name 2over count-stacks ret gen-wrapped-stmt .\" ;\n"
475 :     ?dup-if
476 : anton 1.3 ." gforth_SP = sp+" .nb .\" ;\n"
477 : anton 1.2 endif
478 :     ?dup-if
479 : anton 1.3 ." gforth_FP = fp+" .nb .\" ;\n"
480 : anton 1.2 endif
481 : anton 1.3 .\" }\n" ;
482 : anton 1.2
483 : anton 1.40 : scan-back { c-addr u1 c -- c-addr u2 }
484 :     \ the last occurence of c in c-addr u1 is at u2-1; if it does not
485 :     \ occur, u2=0.
486 :     c-addr 1- c-addr u1 + 1- u-do
487 :     i c@ c = if
488 :     c-addr i over - 1+ unloop exit endif
489 :     1 -loop
490 :     c-addr 0 ;
491 :    
492 :     : dirname ( c-addr1 u1 -- c-addr2 u2 )
493 :     \ directory name of the file name c-addr1 u1, including the final "/".
494 :     '/ scan-back ;
495 :    
496 :     : basename ( c-addr1 u1 -- c-addr2 u2 )
497 :     \ file name without directory component
498 :     2dup dirname nip /string ;
499 : anton 1.16
500 : anton 1.15 : gen-filename ( x -- c-addr u )
501 : anton 1.35 \ generates a file basename for lib-handle-addr X
502 : anton 1.16 0 <<# ['] #s $10 base-execute #>
503 : anton 1.35 s" gforth_c_" 2swap s+ #>> ;
504 :    
505 : anton 1.40 : libcc-named-dir ( -- c-addr u )
506 : anton 1.43 libcc-named-dir-v 2@ ;
507 : anton 1.40
508 :     : libcc-tmp-dir ( -- c-addr u )
509 : pazsan 1.71 s" ~/.gforth" arch-modifier s+ s" /libcc-tmp/" s+ ;
510 : anton 1.40
511 :     : prepend-dirname ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
512 : anton 1.41 2over s+ 2swap drop free throw ;
513 : anton 1.35
514 : anton 1.42 : open-wrappers ( -- addr|0 )
515 : pazsan 1.73 lib-filename 2@ dirname s" lib" s+
516 :     lib-filename 2@ basename append lib-suffix append
517 : anton 1.42 2dup libcc-named-dir string-prefix? if ( c-addr u )
518 :     \ see if we can open it in the path
519 :     libcc-named-dir nip /string
520 :     libcc-path open-path-file if
521 :     0 exit endif
522 :     ( wfile-id c-addr2 u2 ) rot close-file throw save-mem ( c-addr2 u2 )
523 :     endif
524 :     \ 2dup cr type
525 :     2dup open-lib >r
526 :     drop free throw r> ;
527 :    
528 : anton 1.39 : c-library-name-setup ( c-addr u -- )
529 : anton 1.35 assert( c-source-file-id @ 0= )
530 : anton 1.40 { d: filename }
531 : anton 1.37 here 0 , lib-handle-addr ! filename lib-filename 2!
532 : anton 1.61 filename basename lib-modulename 2!
533 :     ['] write-c-prefix-line is save-c-prefix-line ;
534 : anton 1.39
535 :     : c-library-name-create ( -- )
536 :     lib-filename 2@ s" .c" s+ 2dup w/o create-file throw
537 : anton 1.61 c-source-file-id !
538 :     drop free throw ;
539 : anton 1.39
540 : anton 1.40 : c-named-library-name ( c-addr u -- )
541 : anton 1.39 \ set up filenames for a (possibly new) library; c-addr u is the
542 :     \ basename of the library
543 : anton 1.40 libcc-named-dir prepend-dirname c-library-name-setup
544 : anton 1.37 open-wrappers dup if
545 :     lib-handle-addr @ !
546 :     else
547 : anton 1.56 libcc-named-dir $1ff mkdir-parents drop
548 : anton 1.39 drop c-library-name-create
549 : anton 1.61 c-prefix-lines @ ['] print-c-prefix-line \ first line only
550 :     c-source-file-id @ outfile-execute
551 : anton 1.37 endif ;
552 :    
553 : anton 1.40 : c-tmp-library-name ( c-addr u -- )
554 : anton 1.39 \ set up filenames for a new library; c-addr u is the basename of
555 :     \ the library
556 : anton 1.56 libcc-tmp-dir 2dup $1ff mkdir-parents drop
557 : anton 1.61 prepend-dirname c-library-name-setup c-library-name-create
558 :     ['] print-c-prefix-lines c-source-file-id @ outfile-execute ;
559 : anton 1.39
560 : anton 1.37 : lib-handle ( -- addr )
561 :     lib-handle-addr @ @ ;
562 : anton 1.15
563 : anton 1.12 : init-c-source-file ( -- )
564 : anton 1.37 lib-handle 0= if
565 :     c-source-file-id @ 0= if
566 : anton 1.40 here gen-filename c-tmp-library-name
567 : anton 1.37 endif
568 : anton 1.12 endif ;
569 : anton 1.11
570 :     : c-source-file ( -- file-id )
571 : anton 1.12 c-source-file-id @ assert( dup ) ;
572 : anton 1.11
573 : anton 1.37 : notype-execute ( ... xt -- ... )
574 :     what's type { oldtype } try
575 :     ['] 2drop is type execute 0
576 :     restore
577 :     oldtype is type
578 :     endtry
579 :     throw ;
580 :    
581 :     : c-source-file-execute ( ... xt -- ... )
582 :     \ direct the output of xt to c-source-file, or nothing
583 :     lib-handle if
584 :     notype-execute
585 :     else
586 :     c-source-file outfile-execute
587 :     endif ;
588 :    
589 : anton 1.24 : .lib-error ( -- )
590 :     [ifdef] lib-error
591 :     ['] cr stderr outfile-execute
592 : anton 1.31 lib-error ['] type stderr outfile-execute
593 : anton 1.24 [then] ;
594 : anton 1.23
595 : anton 1.33 DEFER compile-wrapper-function ( -- )
596 : anton 1.35 : compile-wrapper-function1 ( -- )
597 : anton 1.37 lib-handle 0= if
598 :     c-source-file close-file throw
599 :     0 c-source-file-id !
600 : dvdkhlng 1.64 [ libtool-command s" --silent --tag=CC --mode=compile " s+
601 : pazsan 1.58 libtool-cc append s" -I '" append
602 :     s" includedir" getenv append s" '" append ] sliteral
603 : anton 1.37 s" -O -c " s+ lib-filename 2@ append s" .c -o " append
604 :     lib-filename 2@ append s" .lo" append ( c-addr u )
605 : pazsan 1.55 \ 2dup type cr
606 : anton 1.37 2dup system drop free throw $? abort" libtool compile failed"
607 : dvdkhlng 1.64 [ libtool-command s" --silent --tag=CC --mode=link " s+
608 : pazsan 1.55 libtool-cc append libtool-flags append s" -module -rpath " s+ ] sliteral
609 : anton 1.49 lib-filename 2@ dirname replace-rpath s+ s" " append
610 : anton 1.37 lib-filename 2@ append s" .lo -o " append
611 : pazsan 1.72 lib-filename 2@ dirname append s" lib" append
612 :     lib-filename 2@ basename append s" .la" append ( c-addr u )
613 : pazsan 1.59 c-libs 2@ append
614 : pazsan 1.47 \ 2dup type cr
615 : anton 1.37 2dup system drop free throw $? abort" libtool link failed"
616 :     open-wrappers dup 0= if
617 :     .lib-error true abort" open-lib failed"
618 :     endif
619 :     ( lib-handle ) lib-handle-addr @ !
620 : anton 1.23 endif
621 : anton 1.35 lib-filename 2@ drop free throw 0 0 lib-filename 2! ;
622 :     ' compile-wrapper-function1 IS compile-wrapper-function
623 : anton 1.5 \ s" ar rcs xxx.a xxx.o" system
624 :     \ $? abort" ar generated error" ;
625 :    
626 : anton 1.12 : link-wrapper-function { cff -- sym }
627 :     cff cff-rtype wrapper-function-name { d: wrapper-name }
628 : anton 1.23 wrapper-name cff cff-lha @ @ assert( dup ) lib-sym dup 0= if
629 : anton 1.24 .lib-error -&32 throw
630 : anton 1.23 endif
631 : anton 1.10 wrapper-name drop free throw ;
632 : anton 1.8
633 : pazsan 1.62 : c-function-ft ( xt-defr xt-cfr xt-parse "c-name" "type signature" -- )
634 : anton 1.8 \ build time/first time action for c-function
635 : pazsan 1.62 { xt-parse-types } init-c-source-file
636 : anton 1.12 noname create 2, lib-handle-addr @ ,
637 : anton 1.2 parse-name { d: c-name }
638 : pazsan 1.62 xt-parse-types execute c-name string,
639 : anton 1.37 ['] gen-wrapper-function c-source-file-execute
640 : anton 1.8 does> ( ... -- ... )
641 : anton 1.10 dup 2@ { xt-defer xt-cfr }
642 : anton 1.12 dup cff-lha @ @ 0= if
643 :     compile-wrapper-function
644 :     endif
645 :     link-wrapper-function xt-cfr >body !
646 : anton 1.8 xt-cfr xt-defer defer!
647 :     xt-cfr execute ;
648 :    
649 :     : c-function-rt ( -- )
650 :     \ run-time definition for c function; addr is the address where
651 :     \ the sym should be stored
652 :     noname create 0 ,
653 : anton 1.2 does> ( ... -- ... )
654 :     @ call-c ;
655 :    
656 : pazsan 1.62 : (c-function) ( xt-parse "forth-name" "c-name" "{stack effect}" -- )
657 :     { xt-parse-types } defer lastxt dup c-function-rt
658 :     lastxt xt-parse-types c-function-ft
659 :     lastxt swap defer! ;
660 :    
661 :     : c-function ( "forth-name" "c-name" "@{type@}" "---" "type" -- ) \ gforth
662 : anton 1.17 \G Define a Forth word @i{forth-name}. @i{Forth-name} has the
663 :     \G specified stack effect and calls the C function @code{c-name}.
664 : pazsan 1.62 ['] parse-function-types (c-function) ;
665 :    
666 : pazsan 1.68 : c-value ( "forth-name" "c-name" "---" "type" -- ) \ gforth
667 : pazsan 1.62 \G Define a Forth word @i{forth-name}. @i{Forth-name} has the
668 :     \G specified stack effect and gives the C value of @code{c-name}.
669 :     ['] parse-value-type (c-function) ;
670 :    
671 :     : c-variable ( "forth-name" "c-name" -- ) \ gforth
672 :     \G Define a Forth word @i{forth-name}. @i{Forth-name} returns the
673 :     \G address of @code{c-name}.
674 :     ['] parse-variable-type (c-function) ;
675 : anton 1.33
676 : anton 1.53 : clear-libs ( -- ) \ gforth
677 : anton 1.33 \G Clear the list of libs
678 :     c-source-file-id @ if
679 :     compile-wrapper-function
680 :     endif
681 : pazsan 1.59 0. c-libs 2! ;
682 : anton 1.33 clear-libs
683 : anton 1.35
684 :     : c-library-incomplete ( -- )
685 :     true abort" Called function of unfinished named C library" ;
686 :    
687 :     : c-library-name ( c-addr u -- ) \ gforth
688 : anton 1.38 \G Start a C library interface with name @i{c-addr u}.
689 : anton 1.35 clear-libs
690 :     ['] c-library-incomplete is compile-wrapper-function
691 : anton 1.40 c-named-library-name ;
692 : anton 1.35
693 :     : c-library ( "name" -- ) \ gforth
694 :     \G Parsing version of @code{c-library-name}
695 : anton 1.39 parse-name save-mem c-library-name ;
696 : anton 1.35
697 : anton 1.38 : end-c-library ( -- ) \ gforth
698 :     \G Finish and (if necessary) build the latest C library interface.
699 : anton 1.61 ['] save-c-prefix-line1 is save-c-prefix-line
700 : anton 1.35 ['] compile-wrapper-function1 is compile-wrapper-function
701 :     compile-wrapper-function1 ;
702 : anton 1.43
703 :     : init-libcc ( -- )
704 : pazsan 1.71 s" ~/.gforth" arch-modifier s+ s" /libcc-named/" s+ libcc-named-dir-v 2!
705 : pazsan 1.66 [IFDEF] $init
706 :     libcc-path $init
707 : anton 1.43 libcc-named-dir libcc-path also-path
708 :     [ s" libccdir" getenv ] sliteral libcc-path also-path
709 : pazsan 1.45 [THEN]
710 : anton 1.43 ;
711 :    
712 :     init-libcc
713 :    
714 :     :noname ( -- )
715 :     defers 'cold
716 :     init-libcc ;
717 :     is 'cold
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help