[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 : pazsan 1.74 : lib-prefix ( -- addr u ) s" libgf" ;
221 :    
222 : anton 1.53 : add-lib ( c-addr u -- ) \ gforth
223 : anton 1.33 \G Add library lib@i{string} to the list of libraries, where
224 : pazsan 1.59 \G @i{string} is represented by @i{c-addr u}.
225 :     c-libs 2@ d0= IF 0 allocate throw 0 c-libs 2! THEN
226 :     c-libs 2@ s" -l" append 2swap append c-libs 2! ;
227 :    
228 :     : add-libpath ( c-addr u -- ) \ gforth
229 :     \G Add path @i{string} to the list of library search pathes, where
230 :     \G @i{string} is represented by @i{c-addr u}.
231 :     c-libs 2@ d0= IF 0 allocate throw 0 c-libs 2! THEN
232 :     c-libs 2@ s" -L" append 2swap append c-libs 2! ;
233 : anton 1.33
234 : anton 1.6 \ C prefix lines
235 :    
236 :     \ linked list of longcstrings: [ link | count-cell | characters ]
237 :    
238 :     list%
239 :     cell% field c-prefix-count
240 :     1 0 field c-prefix-chars
241 :     end-struct c-prefix%
242 :    
243 :     variable c-prefix-lines 0 c-prefix-lines !
244 :     variable c-prefix-lines-end c-prefix-lines c-prefix-lines-end !
245 :    
246 : anton 1.14 : print-c-prefix-line ( node -- )
247 :     dup c-prefix-chars swap c-prefix-count @ type cr ;
248 :    
249 :     : print-c-prefix-lines ( -- )
250 :     c-prefix-lines @ ['] print-c-prefix-line list-map ;
251 :    
252 : anton 1.61 : write-c-prefix-line ( c-addr u -- )
253 :     c-source-file-id @ dup if
254 :     write-line throw
255 :     else
256 :     drop 2drop
257 :     then ;
258 : pazsan 1.60
259 : anton 1.61 : save-c-prefix-line1 ( c-addr u -- )
260 :     2dup write-c-prefix-line
261 : anton 1.6 align here 0 , c-prefix-lines-end list-append ( c-addr u )
262 :     longstring, ;
263 :    
264 : anton 1.61 defer save-c-prefix-line ( c-addr u -- )
265 :     ' save-c-prefix-line1 is save-c-prefix-line
266 :    
267 : anton 1.18 : \c ( "rest-of-line" -- ) \ gforth backslash-c
268 : anton 1.17 \G One line of C declarations for the C interface
269 : anton 1.6 -1 parse save-c-prefix-line ;
270 :    
271 : pazsan 1.73 s" #include <gforth" arch-modifier s+ s" /" append version-string append s" /libcc.h>" append ( c-addr u )
272 : anton 1.19 2dup save-c-prefix-line drop free throw
273 : anton 1.5
274 : anton 1.6 \ Types (for parsing)
275 : anton 1.5
276 : anton 1.2 wordlist constant libcc-types
277 :    
278 :     get-current libcc-types set-current
279 :    
280 :     \ index values
281 :     -1
282 :     const+ -- \ end of arguments
283 :     const+ n \ integer cell
284 : anton 1.5 const+ a \ address cell
285 : anton 1.2 const+ d \ double
286 :     const+ r \ float
287 :     const+ func \ C function pointer
288 :     const+ void
289 :     drop
290 :    
291 :     set-current
292 :    
293 : pazsan 1.62 \ call types
294 :     0
295 :     const+ c-func
296 :     const+ c-val
297 :     const+ c-var
298 :     drop
299 :    
300 :     : libcc-type ( c-addr u -- u2 )
301 :     libcc-types search-wordlist 0= -13 and throw execute ;
302 :    
303 :     : parse-libcc-type ( "libcc-type" -- u ) parse-name libcc-type ;
304 : anton 1.2
305 : pazsan 1.62 : parse-return-type ( "libcc-type" -- u )
306 :     parse-libcc-type dup 0< -32 and throw ;
307 :    
308 :     : parse-function-types ( "{libcc-type}" "--" "libcc-type" -- addr )
309 :     c-func c, here
310 :     dup 2 chars allot here begin
311 : anton 1.2 parse-libcc-type dup 0>= while
312 :     c,
313 :     repeat
314 : anton 1.3 drop here swap - over char+ c!
315 : pazsan 1.62 parse-return-type swap c! ;
316 :    
317 :     : parse-value-type ( "{--}" "libcc-type" -- addr )
318 :     c-val c, here
319 :     parse-libcc-type dup 0< if drop parse-return-type then
320 :     c, 0 c, ;
321 :    
322 :     : parse-variable-type ( -- addr )
323 :     c-var c, here
324 :     s" a" libcc-type c, 0 c, ;
325 : anton 1.2
326 :     : type-letter ( n -- c )
327 : pazsan 1.52 chars s" nadrfv" drop + c@ ;
328 : anton 1.2
329 :     \ count-stacks
330 :    
331 :     : count-stacks-n ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
332 :     1+ ;
333 :    
334 : anton 1.5 : count-stacks-a ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
335 : anton 1.2 1+ ;
336 :    
337 :     : count-stacks-d ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
338 :     2 + ;
339 :    
340 :     : count-stacks-r ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
341 :     swap 1+ swap ;
342 :    
343 :     : count-stacks-func ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
344 :     1+ ;
345 :    
346 :     : count-stacks-void ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
347 :     ;
348 :    
349 :     create count-stacks-types
350 :     ' count-stacks-n ,
351 : anton 1.5 ' count-stacks-a ,
352 : anton 1.2 ' count-stacks-d ,
353 :     ' count-stacks-r ,
354 :     ' count-stacks-func ,
355 :     ' count-stacks-void ,
356 :    
357 :     : count-stacks ( pars -- fp-change sp-change )
358 :     \ pars is an addr u pair
359 :     0 0 2swap over + swap u+do
360 : anton 1.3 i c@ cells count-stacks-types + @ execute
361 : anton 1.2 loop ;
362 :    
363 :     \ gen-pars
364 :    
365 :     : gen-par-n ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
366 : anton 1.5 ." sp[" 1- dup .nb ." ]" ;
367 : anton 1.2
368 : anton 1.5 : gen-par-a ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
369 : anton 1.2 ." (void *)(" gen-par-n ." )" ;
370 :    
371 :     : gen-par-d ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
372 : anton 1.4 ." gforth_d2ll(" gen-par-n ." ," gen-par-n ." )" ;
373 : anton 1.2
374 :     : gen-par-r ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
375 : anton 1.3 swap 1- tuck ." fp[" .nb ." ]" ;
376 : anton 1.2
377 :     : gen-par-func ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
378 : anton 1.5 gen-par-a ;
379 : anton 1.2
380 :     : gen-par-void ( fp-depth1 sp-depth1 -- fp-depth2 sp-depth2 )
381 :     -32 throw ;
382 :    
383 :     create gen-par-types
384 :     ' gen-par-n ,
385 : anton 1.5 ' gen-par-a ,
386 : anton 1.2 ' gen-par-d ,
387 :     ' gen-par-r ,
388 :     ' gen-par-func ,
389 :     ' gen-par-void ,
390 :    
391 :     : gen-par ( fp-depth1 sp-depth1 partype -- fp-depth2 sp-depth2 )
392 : anton 1.3 cells gen-par-types + @ execute ;
393 : anton 1.2
394 :     \ the call itself
395 :    
396 : pazsan 1.62 : gen-wrapped-func { d: pars d: c-name fp-change1 sp-change1 -- }
397 : anton 1.2 c-name type ." ("
398 : anton 1.3 fp-change1 sp-change1 pars over + swap u+do
399 : anton 1.2 i c@ gen-par
400 :     i 1+ i' < if
401 :     ." ,"
402 :     endif
403 :     loop
404 :     2drop ." )" ;
405 :    
406 : pazsan 1.62 : gen-wrapped-const { d: pars d: c-name fp-change1 sp-change1 -- }
407 :     ." (" c-name type ." )" ;
408 :    
409 :     : gen-wrapped-var { d: pars d: c-name fp-change1 sp-change1 -- }
410 :     ." &(" c-name type ." )" ;
411 :    
412 :     create gen-call-types
413 :     ' gen-wrapped-func ,
414 :     ' gen-wrapped-const ,
415 :     ' gen-wrapped-var ,
416 :    
417 :     : gen-wrapped-call ( pars c-name fp-change1 sp-change1 -- )
418 :     5 pick 3 chars - c@ cells gen-call-types + @ execute ;
419 :    
420 : anton 1.2 \ calls for various kinds of return values
421 :    
422 :     : gen-wrapped-void ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
423 :     2dup 2>r gen-wrapped-call 2r> ;
424 :    
425 : anton 1.3 : gen-wrapped-n ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
426 : anton 1.5 2dup gen-par-n 2>r ." =" gen-wrapped-call 2r> ;
427 : anton 1.3
428 : anton 1.5 : gen-wrapped-a ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
429 :     2dup gen-par-n 2>r ." =(Cell)" gen-wrapped-call 2r> ;
430 : anton 1.3
431 :     : gen-wrapped-d ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
432 :     ." gforth_ll2d(" gen-wrapped-void
433 : anton 1.5 ." ," gen-par-n ." ," gen-par-n ." )" ;
434 : anton 1.3
435 :     : gen-wrapped-r ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
436 : anton 1.30 2dup gen-par-r 2>r ." =" gen-wrapped-call 2r> ;
437 : anton 1.3
438 :     : gen-wrapped-func ( pars c-name fp-change1 sp-change1 -- fp-change sp-change )
439 : anton 1.5 gen-wrapped-a ;
440 : anton 1.3
441 : anton 1.2 create gen-wrapped-types
442 :     ' gen-wrapped-n ,
443 : anton 1.5 ' gen-wrapped-a ,
444 : anton 1.2 ' gen-wrapped-d ,
445 :     ' gen-wrapped-r ,
446 :     ' gen-wrapped-func ,
447 :     ' gen-wrapped-void ,
448 :    
449 :     : gen-wrapped-stmt ( pars c-name fp-change1 sp-change1 ret -- fp-change sp-change )
450 : anton 1.3 cells gen-wrapped-types + @ execute ;
451 : anton 1.2
452 : anton 1.10 : wrapper-function-name ( addr -- c-addr u )
453 :     \ addr points to the return type index of a c-function descriptor
454 :     count { r-type } count { d: pars }
455 :     pars + count { d: c-name }
456 :     s" gforth_c_" { d: prefix }
457 :     prefix nip c-name nip + pars nip + 3 + { u }
458 :     u allocate throw { c-addr }
459 :     c-addr u
460 :     prefix front-string c-name front-string '_ front-char
461 :     pars bounds u+do
462 :     i c@ type-letter front-char
463 :     loop
464 :     '_ front-char r-type type-letter front-char assert( dup 0= )
465 :     2drop c-addr u ;
466 :    
467 : anton 1.2 : gen-wrapper-function ( addr -- )
468 :     \ addr points to the return type index of a c-function descriptor
469 : anton 1.10 dup { descriptor }
470 : anton 1.13 count { ret } count 2dup { d: pars } chars + count { d: c-name }
471 : pazsan 1.70 ." void "
472 : pazsan 1.74 [ lib-suffix s" .la" str= [IF] ] lib-prefix type lib-modulename 2@ type ." _LTX_" [ [THEN] ]
473 : pazsan 1.70 descriptor wrapper-function-name 2dup type drop free throw
474 : pazsan 1.54 .\" (GFORTH_ARGS)\n"
475 : anton 1.4 .\" {\n Cell MAYBE_UNUSED *sp = gforth_SP;\n Float MAYBE_UNUSED *fp = gforth_FP;\n "
476 : anton 1.2 pars c-name 2over count-stacks ret gen-wrapped-stmt .\" ;\n"
477 :     ?dup-if
478 : anton 1.3 ." gforth_SP = sp+" .nb .\" ;\n"
479 : anton 1.2 endif
480 :     ?dup-if
481 : anton 1.3 ." gforth_FP = fp+" .nb .\" ;\n"
482 : anton 1.2 endif
483 : anton 1.3 .\" }\n" ;
484 : anton 1.2
485 : anton 1.40 : scan-back { c-addr u1 c -- c-addr u2 }
486 :     \ the last occurence of c in c-addr u1 is at u2-1; if it does not
487 :     \ occur, u2=0.
488 :     c-addr 1- c-addr u1 + 1- u-do
489 :     i c@ c = if
490 :     c-addr i over - 1+ unloop exit endif
491 :     1 -loop
492 :     c-addr 0 ;
493 :    
494 :     : dirname ( c-addr1 u1 -- c-addr2 u2 )
495 :     \ directory name of the file name c-addr1 u1, including the final "/".
496 :     '/ scan-back ;
497 :    
498 :     : basename ( c-addr1 u1 -- c-addr2 u2 )
499 :     \ file name without directory component
500 :     2dup dirname nip /string ;
501 : anton 1.16
502 : anton 1.15 : gen-filename ( x -- c-addr u )
503 : anton 1.35 \ generates a file basename for lib-handle-addr X
504 : anton 1.16 0 <<# ['] #s $10 base-execute #>
505 : anton 1.35 s" gforth_c_" 2swap s+ #>> ;
506 :    
507 : anton 1.40 : libcc-named-dir ( -- c-addr u )
508 : anton 1.43 libcc-named-dir-v 2@ ;
509 : anton 1.40
510 :     : libcc-tmp-dir ( -- c-addr u )
511 : pazsan 1.71 s" ~/.gforth" arch-modifier s+ s" /libcc-tmp/" s+ ;
512 : anton 1.40
513 :     : prepend-dirname ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
514 : anton 1.41 2over s+ 2swap drop free throw ;
515 : anton 1.35
516 : anton 1.42 : open-wrappers ( -- addr|0 )
517 : pazsan 1.74 lib-filename 2@ dirname lib-prefix s+
518 : pazsan 1.73 lib-filename 2@ basename append lib-suffix append
519 : anton 1.42 2dup libcc-named-dir string-prefix? if ( c-addr u )
520 :     \ see if we can open it in the path
521 :     libcc-named-dir nip /string
522 :     libcc-path open-path-file if
523 :     0 exit endif
524 :     ( wfile-id c-addr2 u2 ) rot close-file throw save-mem ( c-addr2 u2 )
525 :     endif
526 :     \ 2dup cr type
527 :     2dup open-lib >r
528 :     drop free throw r> ;
529 :    
530 : anton 1.39 : c-library-name-setup ( c-addr u -- )
531 : anton 1.35 assert( c-source-file-id @ 0= )
532 : anton 1.40 { d: filename }
533 : anton 1.37 here 0 , lib-handle-addr ! filename lib-filename 2!
534 : anton 1.61 filename basename lib-modulename 2!
535 :     ['] write-c-prefix-line is save-c-prefix-line ;
536 : anton 1.39
537 :     : c-library-name-create ( -- )
538 :     lib-filename 2@ s" .c" s+ 2dup w/o create-file throw
539 : anton 1.61 c-source-file-id !
540 :     drop free throw ;
541 : anton 1.39
542 : anton 1.40 : c-named-library-name ( c-addr u -- )
543 : anton 1.39 \ set up filenames for a (possibly new) library; c-addr u is the
544 :     \ basename of the library
545 : anton 1.40 libcc-named-dir prepend-dirname c-library-name-setup
546 : anton 1.37 open-wrappers dup if
547 :     lib-handle-addr @ !
548 :     else
549 : anton 1.56 libcc-named-dir $1ff mkdir-parents drop
550 : anton 1.39 drop c-library-name-create
551 : anton 1.61 c-prefix-lines @ ['] print-c-prefix-line \ first line only
552 :     c-source-file-id @ outfile-execute
553 : anton 1.37 endif ;
554 :    
555 : anton 1.40 : c-tmp-library-name ( c-addr u -- )
556 : anton 1.39 \ set up filenames for a new library; c-addr u is the basename of
557 :     \ the library
558 : anton 1.56 libcc-tmp-dir 2dup $1ff mkdir-parents drop
559 : anton 1.61 prepend-dirname c-library-name-setup c-library-name-create
560 :     ['] print-c-prefix-lines c-source-file-id @ outfile-execute ;
561 : anton 1.39
562 : anton 1.37 : lib-handle ( -- addr )
563 :     lib-handle-addr @ @ ;
564 : anton 1.15
565 : anton 1.12 : init-c-source-file ( -- )
566 : anton 1.37 lib-handle 0= if
567 :     c-source-file-id @ 0= if
568 : anton 1.40 here gen-filename c-tmp-library-name
569 : anton 1.37 endif
570 : anton 1.12 endif ;
571 : anton 1.11
572 :     : c-source-file ( -- file-id )
573 : anton 1.12 c-source-file-id @ assert( dup ) ;
574 : anton 1.11
575 : anton 1.37 : notype-execute ( ... xt -- ... )
576 :     what's type { oldtype } try
577 :     ['] 2drop is type execute 0
578 :     restore
579 :     oldtype is type
580 :     endtry
581 :     throw ;
582 :    
583 :     : c-source-file-execute ( ... xt -- ... )
584 :     \ direct the output of xt to c-source-file, or nothing
585 :     lib-handle if
586 :     notype-execute
587 :     else
588 :     c-source-file outfile-execute
589 :     endif ;
590 :    
591 : anton 1.24 : .lib-error ( -- )
592 :     [ifdef] lib-error
593 :     ['] cr stderr outfile-execute
594 : anton 1.31 lib-error ['] type stderr outfile-execute
595 : anton 1.24 [then] ;
596 : anton 1.23
597 : anton 1.33 DEFER compile-wrapper-function ( -- )
598 : anton 1.35 : compile-wrapper-function1 ( -- )
599 : anton 1.37 lib-handle 0= if
600 :     c-source-file close-file throw
601 :     0 c-source-file-id !
602 : dvdkhlng 1.64 [ libtool-command s" --silent --tag=CC --mode=compile " s+
603 : pazsan 1.58 libtool-cc append s" -I '" append
604 :     s" includedir" getenv append s" '" append ] sliteral
605 : anton 1.37 s" -O -c " s+ lib-filename 2@ append s" .c -o " append
606 :     lib-filename 2@ append s" .lo" append ( c-addr u )
607 : pazsan 1.55 \ 2dup type cr
608 : anton 1.37 2dup system drop free throw $? abort" libtool compile failed"
609 : dvdkhlng 1.64 [ libtool-command s" --silent --tag=CC --mode=link " s+
610 : pazsan 1.55 libtool-cc append libtool-flags append s" -module -rpath " s+ ] sliteral
611 : anton 1.49 lib-filename 2@ dirname replace-rpath s+ s" " append
612 : anton 1.37 lib-filename 2@ append s" .lo -o " append
613 : pazsan 1.74 lib-filename 2@ dirname append lib-prefix append
614 : pazsan 1.72 lib-filename 2@ basename append s" .la" append ( c-addr u )
615 : pazsan 1.59 c-libs 2@ append
616 : pazsan 1.47 \ 2dup type cr
617 : anton 1.37 2dup system drop free throw $? abort" libtool link failed"
618 :     open-wrappers dup 0= if
619 :     .lib-error true abort" open-lib failed"
620 :     endif
621 :     ( lib-handle ) lib-handle-addr @ !
622 : anton 1.23 endif
623 : anton 1.35 lib-filename 2@ drop free throw 0 0 lib-filename 2! ;
624 :     ' compile-wrapper-function1 IS compile-wrapper-function
625 : anton 1.5 \ s" ar rcs xxx.a xxx.o" system
626 :     \ $? abort" ar generated error" ;
627 :    
628 : anton 1.12 : link-wrapper-function { cff -- sym }
629 :     cff cff-rtype wrapper-function-name { d: wrapper-name }
630 : anton 1.23 wrapper-name cff cff-lha @ @ assert( dup ) lib-sym dup 0= if
631 : anton 1.24 .lib-error -&32 throw
632 : anton 1.23 endif
633 : anton 1.10 wrapper-name drop free throw ;
634 : anton 1.8
635 : pazsan 1.62 : c-function-ft ( xt-defr xt-cfr xt-parse "c-name" "type signature" -- )
636 : anton 1.8 \ build time/first time action for c-function
637 : pazsan 1.62 { xt-parse-types } init-c-source-file
638 : anton 1.12 noname create 2, lib-handle-addr @ ,
639 : anton 1.2 parse-name { d: c-name }
640 : pazsan 1.62 xt-parse-types execute c-name string,
641 : anton 1.37 ['] gen-wrapper-function c-source-file-execute
642 : anton 1.8 does> ( ... -- ... )
643 : anton 1.10 dup 2@ { xt-defer xt-cfr }
644 : anton 1.12 dup cff-lha @ @ 0= if
645 :     compile-wrapper-function
646 :     endif
647 :     link-wrapper-function xt-cfr >body !
648 : anton 1.8 xt-cfr xt-defer defer!
649 :     xt-cfr execute ;
650 :    
651 :     : c-function-rt ( -- )
652 :     \ run-time definition for c function; addr is the address where
653 :     \ the sym should be stored
654 :     noname create 0 ,
655 : anton 1.2 does> ( ... -- ... )
656 :     @ call-c ;
657 :    
658 : pazsan 1.62 : (c-function) ( xt-parse "forth-name" "c-name" "{stack effect}" -- )
659 :     { xt-parse-types } defer lastxt dup c-function-rt
660 :     lastxt xt-parse-types c-function-ft
661 :     lastxt swap defer! ;
662 :    
663 :     : c-function ( "forth-name" "c-name" "@{type@}" "---" "type" -- ) \ gforth
664 : anton 1.17 \G Define a Forth word @i{forth-name}. @i{Forth-name} has the
665 :     \G specified stack effect and calls the C function @code{c-name}.
666 : pazsan 1.62 ['] parse-function-types (c-function) ;
667 :    
668 : pazsan 1.68 : c-value ( "forth-name" "c-name" "---" "type" -- ) \ gforth
669 : pazsan 1.62 \G Define a Forth word @i{forth-name}. @i{Forth-name} has the
670 :     \G specified stack effect and gives the C value of @code{c-name}.
671 :     ['] parse-value-type (c-function) ;
672 :    
673 :     : c-variable ( "forth-name" "c-name" -- ) \ gforth
674 :     \G Define a Forth word @i{forth-name}. @i{Forth-name} returns the
675 :     \G address of @code{c-name}.
676 :     ['] parse-variable-type (c-function) ;
677 : anton 1.33
678 : anton 1.53 : clear-libs ( -- ) \ gforth
679 : anton 1.33 \G Clear the list of libs
680 :     c-source-file-id @ if
681 :     compile-wrapper-function
682 :     endif
683 : pazsan 1.59 0. c-libs 2! ;
684 : anton 1.33 clear-libs
685 : anton 1.35
686 :     : c-library-incomplete ( -- )
687 :     true abort" Called function of unfinished named C library" ;
688 :    
689 :     : c-library-name ( c-addr u -- ) \ gforth
690 : anton 1.38 \G Start a C library interface with name @i{c-addr u}.
691 : anton 1.35 clear-libs
692 :     ['] c-library-incomplete is compile-wrapper-function
693 : anton 1.40 c-named-library-name ;
694 : anton 1.35
695 :     : c-library ( "name" -- ) \ gforth
696 :     \G Parsing version of @code{c-library-name}
697 : anton 1.39 parse-name save-mem c-library-name ;
698 : anton 1.35
699 : anton 1.38 : end-c-library ( -- ) \ gforth
700 :     \G Finish and (if necessary) build the latest C library interface.
701 : anton 1.61 ['] save-c-prefix-line1 is save-c-prefix-line
702 : anton 1.35 ['] compile-wrapper-function1 is compile-wrapper-function
703 :     compile-wrapper-function1 ;
704 : anton 1.43
705 :     : init-libcc ( -- )
706 : pazsan 1.71 s" ~/.gforth" arch-modifier s+ s" /libcc-named/" s+ libcc-named-dir-v 2!
707 : pazsan 1.66 [IFDEF] $init
708 :     libcc-path $init
709 : anton 1.43 libcc-named-dir libcc-path also-path
710 :     [ s" libccdir" getenv ] sliteral libcc-path also-path
711 : pazsan 1.45 [THEN]
712 : anton 1.43 ;
713 :    
714 :     init-libcc
715 :    
716 :     :noname ( -- )
717 :     defers 'cold
718 :     init-libcc ;
719 :     is 'cold
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help