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

CVS Admin

gforth: gforth/libcc.fs

ViewCVS and CVS Help