( Title: C-library binding source generator for pfe File: bindlib.fs Author: David N. Williams License: LGPL Version: 0.5.1 Revised: January 10, 2020 ) \ Copyright (C) 2011, 2012, 2019, 2020 by David N. Williams ( This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or at your option any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. If you take advantage of the option in the LGPL to put a particular version of this library under the GPL, the author[s] would regard it as polite if you would put any direct modifications under the LGPL as well, and include a copy of this request near the beginning of the modified library source. A "direct modification" is one that enhances or extends the library in line with its original concept, as opposed to developing a distinct application or library which might use it. See the file bindlib-example.fs for an example of the syntax for a binding file. CHANGELOG Unattributed changes are by the initial author, David N. Williams. The revision date above may be more recent than the most recent date in the log, when only cosmetic changes have been made. Version 0.5.1 12Jan12 * Changed license from LGPL 2.1 to LGPL 3. 8Dec19 * Fixed a typo in the above line, and updated VERSION$. Version 0.5.0 23Apr11 * Started from hftrans.fs 0.2.2. 30Apr11 * Tested with libmpfr bindings. 1May11 * Added C-WRAP-VAL. * Released. 5May11 * Renamed bindlib-pfe.fs as bindlib.fs. NOTATION AND TERMINOLOGY "_" prefix: Emit to the output stream. ws: One or more whitespace characters, including tab and end of line characters. ws delimited, whitespace delimited: whitespace or the beginnng of a line just before, and whitespace or the end of a line just after, with no embedded whitespace. token: Whitespace delimited sequence of characters without embedded whitespace. input stream: The sequence of lines that constitutes the Forth text input source. "name", "token": The quotes are included. A token in the input stream. It follows from the above that a sequence of one or more tokens may occupy several lines. "lines": Sequence of tokens in the input stream. "is-" prefix: A word that returns a predicate for a property of a stack item without consuming the item. ) decimal \ *** LIBRARY DEPENDENCE s" FORTH-NAME" environment? [IF] s" pfe" compare 0= [ELSE] false [THEN] ( pfe?) CONSTANT PFE-HOST immediate \ DEBUGGING \ true VALUE PARSING-EXT [UNDEFINED] PARSING-EXT [IF] false VALUE PARSING-EXT [THEN] PARSING-EXT PFE-HOST and to PARSING-EXT [UNDEFINED] DSTRINGS-EXT [IF] true VALUE DSTRINGS-EXT [THEN] DSTRINGS-EXT PFE-HOST and to DSTRINGS-EXT cr PARSING-EXT [IF] loadm parsing .( PARSING-EXT loaded) [ELSE] s" parsing.fs" required .( parsing.fs loaded) [THEN] cr : --- ( -- ) s" ---" |s|-seek-instream drop ; immediate true CONSTANT USE-FP s" dstring-utils.fs" required \ loads dstrings DSTRINGS-EXT [IF] .( DSTRINGS-EXT loaded) cr [ELSE] .( dstrings.fs loaded) cr [THEN] \ *** PARAMETERS $" 0.5.1 " $constant version$ dstrings @ free throw --- GLOSSARY-STRINGS: The string space for translation macros and the binding definition stream is allocated here. The user can change default size can bye defining /GLOSSARY-STRINGS before loading this file. This replaces the system string space. --- [UNDEFINED] /GLOSSARY-STRINGS [IF] 64000 constant /GLOSSARY-STRINGS [THEN] /GLOSSARY-STRINGS 4 make-$space value GLOSSARY-STRINGS GLOSSARY-STRINGS dstrings ! \ default string space --- INDEX-STRINGS: This is the string space for concatenation of the pfe index. Concatenation terminates only at the end of the translation, when the index is appended to the output file; and the index string space is freed when the output file is closed. Any cats to the index must restore DSTRINGS to its GLOSSARY-STRINGS default. --- [UNDEFINED] /INDEX-STRINGS [IF] 32000 constant /INDEX-STRINGS [THEN] /INDEX-STRINGS 4 make-$space value INDEX-STRINGS \ *** GENERAL USE \ DEBUGGING : .# ( n -- ) cr ." #" . cr ; [UNDEFINED] (r: [IF] : (r: postpone ( ; immediate [THEN] [UNDEFINED] (f: [IF] : (f: postpone ( ; immediate [THEN] [UNDEFINED] rdrop [IF] : rdrop ( r: a -- ) s" r> drop" evaluate ; immediate [THEN] [UNDEFINED] 2rdrop [IF] : 2rdrop ( r: a b -- ) s" 2r> 2drop" evaluate ; immediate [THEN] [UNDEFINED] sdrop [IF] : sdrop 2drop ; [THEN] [UNDEFINED] sdup [IF] : sdup 2dup ; [THEN] [UNDEFINED] s<> [IF] : s<> compare ; [THEN] [UNDEFINED] s= [IF] : s= compare 0= ; [THEN] [UNDEFINED] parse-area-seek [IF] : parse-area-seek ( "ccc" char -- found? ) >r parse-area@ r> seek -rot parse-area! ; [THEN] [UNDEFINED] parse-area-skip [IF] : parse-area-skip ( char -- ) >r parse-area@ r> skip parse-area! ; [THEN] [UNDEFINED] skip-instream [IF] : skip-instream ( "lines" char -- ) BEGIN parse-area@ parse-area-skip parse-area-empty? WHILE REFILL 0= ABORT" ***char not found in instream" REPEAT ; [THEN] : $@+ ( addr -- ) $@ $+ ; : bl+ ( -- ) $+" " ; : 2bls+ ( -- ) $+" " ; : \n+ ( -- ) \n$ $+ ; : num>$ ( n -- $: n$ ) --- Copy the number as a string into string space. --- num>s >$s-copy ; : fnum>$ (f: x -- $: x$ ) ?cat fnum+ ENDCAT ; : date&time$ ($: -- d&t$ ) ?cat date&time+ ENDCAT ; \ *** INPUT STREAM $variable forth-name$ $variable c-name$ $variable pfe-name$ $variable c-val$ $variable module$ $variable description$ : get-forth-name ( "name" -- ) next-instream-name dup 0= ABORT" ***missing forth name" >$s-copy forth-name$ $! ; : get-c-name ( "name" -- ) next-instream-name dup 0= ABORT" ***missing c function name" >$s-copy c-name$ $! ; : set-pfe-name ( -- ) $+" p4_" forth-name$ $@+ ENDCAT pfe-name$ $! ; : get-c-val ( "<;>" -- ) [char] ; parse |trim| >$s-copy c-val$ $! ; \ *** OUTPUT STREAM 0 VALUE outstream \ output stream fid $VARIABLE binding-outfile$ $VARIABLE dll-outfile$ $VARIABLE date$ : open-outstream ($: .c -- ) --- Open .c for glossary text output, and store the fid in OUTSTREAM. Assume a valid file name. --- $s> ( s) r/w create-file ( fid ior) throw ( fid) to outstream ; : close-outstream ( -- ) outstream close-file throw ; : _s ( s -- ) --- Write the Forth string body to the output stream. --- ?dup IF outstream write-file ( ior) throw ELSE drop THEN ; : _$ ($: $ -- ) $s> _s ; : _bl ( -- ) s" " _s ; : _\n ( -- ) \n$ _$ ; : _CAT$ ( -- ) ENDCAT _$ ; : _binding-header ( -- ) $+" /* Pfe bindings: " binding-outfile$ $@+ \n+ $+" Generated: " date$ $@+ \n+ $+" Generator: " version$ $+ \n+ $+" */" \n+ _CAT$ ; : upto+ ( end.s -- ) --- Cat the input stream up to but not including the string end.s. Leave the input stream positioned just after the terminating string. Note: To get EOL cat'd after the last line, put the terminating string at the start of the next line after the last. --- ( end.s) 2>r BEGIN parse-area@ 2r@ ( end.s) s-separate ( pa.s FALSE | after.s before.s TRUE) 0= WHILE ( pa.s) s+ \n+ refill 0= ABORT" ***Terminating string not found." REPEAT 2rdrop ( before.s) s+ ( after.s) parse-area! ; : _upto ( end.s -- ) upto+ _CAT$ ; : index{ ( -- ) index-strings dstrings ! ; : }index ( -- ) glossary-strings dstrings ! ; : index-header+ ( -- ) index{ \n+ $+" P4_LISTWORDS (" module$ $@+ $+" ) = " \n+ $+" {" \n+ }index ; : _index ( -- ) index{ $+" };" \n+ $+" P4_COUNTWORDS (" module$ $@+ $+` , "` description$ $@+ $+` ");` \n+ _CAT$ }index ; : free-index ( -- ) index-strings free throw ; : _dll ( -- ) $+" /* Pfe module glue: " dll-outfile$ $@+ \n+ $+" Bindings: " binding-outfile$ $@+ \n+ $+" Generated: " date$ $@+ \n+ $+" Generator: " version$ $+ \n+ $+" */" \n+ $+" #define _P4_SOURCE 1" \n+ $+" #define MODULE" \n+ $+" #include " \n+ $+" extern const p4Words P4WORDS(" module$ $@+ $+" );" \n+ $+" P4_MODULE_LIST (" module$ $@+ $+" );" \n+ _CAT$ ; \ *** MODULE DECLARATIONS : LIBRARY ( "" -- ) parse-name ( s) dup 0= ABORT" ***No library name" ( name.s) >$s-copy ($: name) $dup $+ $+" -dll.c" ENDCAT dll-outfile$ $! ($: name) $+ $+" .c" ENDCAT ($: name.c) $dup binding-outfile$ $! ($: name.c) open-outstream date&time$ date$ $! _binding-header ; : END-LIBRARY ( --- ) _index close-outstream dll-outfile$ $@ open-outstream _dll free-index close-outstream s" binding output: " type binding-outfile$ $@ $. cr ; : parse-quoted ( '""' $: -- text$ ) [char] " parse-area-seek 0= ABORT" ***missing quote" [char] " parse >$s-copy ; : MODULE ( ' ""' -- ) parse-name >$s-copy module$ $! parse-quoted description$ $! index-header+ ; : WITH-MODULE ( "" -- ) index{ $+` P4_NEED ("` parse-name s+ $+` "),` \n+ }index ; : forth-ret-type: ( 'list -- ) --- The input address 'list holds the address of the the last node in a single-ended, single-linked list of dstring tokens. Define a word that parses a name, stores it as a dstring into a new node in data space, and links the node to end of the list. --- create , DOES> ( "token" -- ) --- Add a string node containing "token" to the list. The tokens correspond to function return types recognized by the C compiler. A C type consisting of more than one token has to be #define'd as a token before it is encountered in the generated source. For example: c{ #define ulong unsigned long }c The list collects C types that correspond to the same pfe type cast for data or floating-point stack outputs. --- @ ( 'list) parse-name dup 0= ABORT" ***missing c-type token" >$s-copy dup @ here -rot ( node 'list prev.node) , ! here 0 , $! ; variable n-types n-types off variable u-types u-types off variable df-types df-types off n-types forth-ret-type: N-RET-TYPE u-types forth-ret-type: U-RET-TYPE df-types forth-ret-type: DF-RET-TYPE \ built-ins N-RET-TYPE int N-RET-TYPE long U-RET-TYPE char DF-RET-TYPE double \ *** CODE GENERATION : c{ ( -- ) s" }c" _upto _\n ; 32 constant max-#cargs max-#cargs cells constant /ret-types create ret-types here /ret-types allot /ret-types 0 fill \ for $! create double-flags /ret-types allot 0 value #cells 0 value #floats 0 value ret-type : ret-type-$@ ( i -- $: type ) cells ret-types + $@ ; : ret-type-$! ( i $: type -- ) cells dup /ret-types >= ABORT" ***too many c arguments" ret-types + $! ; : double-flag-@ ( i -- double? ) cells double-flags + @ ; : double-flag-! ( double? i -- ) cells double-flags + ! ; \ no overflow check create arg-delims char , c, char ) c, 0 c, : get-arg-types ( "lines" -- ) --- See C-FUNC for the argument syntax. --- bl skip-instream [char] ( parse-area-seek 0= ABORT" ***missing '('" 0 to #cells 0 to #floats BEGIN arg-delims {}parse dup 0= ABORT" ***missing ')'" ( char) >r |trim| sdup s" void" s= IF #cells #floats + r> [char] ) <> or ABORT" ***void not only argument" EXIT THEN #cells #floats + ( i) >r sdup s" double" s= dup r@ double-flag-! IF #floats 1+ to #floats ELSE #cells 1+ to #cells THEN $+" (" s+ $+" )" ENDCAT r> ret-type-$! r> dup [char] , = IF bl skip-instream THEN [char] ) = UNTIL ; : $= ($: a$ b$ -- s: flag ) $s> $s> compare 0= ; : is-type: ( 'list -- ) create , --- Define a word that searches the input list for the string currently on the dstring stack. --- DOES> ($: a$ -- a$ s: found? ) @ @ ( last.node) >r BEGIN r@ WHILE r> dup @ ( prev.node) >r $dup cell+ $@ $= IF rdrop true EXIT THEN REPEAT rdrop false ; n-types is-type: is-n-type u-types is-type: is-u-type df-types is-type: is-df-type 0 value ret? false value ret-double? $variable ret-type$ : get-ret-type ( "token" -- ) next-instream-name sdup s" void" s= IF sdrop false to ret? EXIT THEN >$s-copy false to ret-double? true CASE is-n-type OF $" p4cell" ENDOF is-u-type OF $" p4ucell" ENDOF is-df-type OF $" double" true to ret-double? ENDOF ABORT" ***incorrect return type" ENDCASE ret-type$ $! $drop true to ret? ; : FCode-header+ ( -- ) $+" FCode (" pfe-name$ $@+ $+" )" ; : push-cell? ( -- flag ) ret? ret-double? 0= and ; : push-float? ( -- flag ) ret? ret-double? and ; : ?bump-sp-line+ ( inc -- ) ?dup IF $+" SP += " ( inc) num+ $+" ;" \n+ THEN ; : ?bump-fp-line+ ( inc -- ) ?dup IF $+" FP += " ( inc) num+ $+" ;" \n+ THEN ; : _c-func ( -- ) FCode-header+ \n+ $+" {" \n+ ret? IF 2bls+ ret-type$ $@+ $+" p4ret = (" ret-type$ $@+ $+" )" \n+ THEN 2bls+ c-name$ $@+ $+" (" #cells #floats 2dup + ?dup IF 0 DO i ret-type-$@ $+ i double-flag-@ IF ( #floats) 1- $+" FP[" dup ELSE swap ( #cells) 1- swap $+" SP[" over THEN num+ $+" ]" 2dup + IF $+" , " THEN LOOP THEN 2drop $+" );" \n+ #cells push-cell? IF ?dup IF 1- ?bump-sp-line+ $+" *SP" ELSE $+" *--SP" THEN $+" = p4ret;" \n+ ELSE ?bump-sp-line+ THEN #floats push-float? IF ?dup IF 1- ?bump-fp-line+ $+" *FP" ELSE $+" *--FP" THEN $+" = p4ret;" \n+ ELSE ?bump-fp-line+ THEN $+" }" \n+ _CAT$ ; : index-item+ ( -- ) index{ $+` P4_FXco ("` forth-name$ $@+ $+` ", ` pfe-name$ $@+ $+` )` $+` ,` \n+ }index ; : ?instream-semicolon ( '";"' -- ) next-instream-name s" ;" s<> ABORT" *** missing ';'" ; : C-FUNC ( "lines" -- ) --- Parse and collect data from a function binding declaration across lines with the syntax: tret (t1,...,tn); The syntax starting with tret is that of a C function prototype, except that tret has to be a token, that whitespace is mandatory between and "(", and that the token sequence for an individual argument type must not cross a line. In particular, the semicolon and arguments may be surrounded by whitespace. --- get-forth-name set-pfe-name get-ret-type get-c-name get-arg-types ?instream-semicolon _c-func index-item+ ; : index-value+ ( -- ) index{ $+` P4_OCoN ("` forth-name$ $@+ $+` ", ` c-val$ $@+ $+` )` $+` ,` \n+ }index ; : C-VAL ( "<;>" -- ) --- Syntax: C-VAL ; --- get-forth-name get-c-val index-value+ ; : _c-wrap-val ( -- ) FCode-header+ \n+ $+" { *--SP = (" ret-type$ $@+ $+" ) " c-name$ $@+ $+" ; }" \n+ _CAT$ ; : C-WRAP-VAL ( "lines<;>" -- ) --- This wraps a value in a function, for some cases where pfe barfs. Syntax: C-WRAP-VAL ; --- get-forth-name set-pfe-name get-ret-type next-instream-name sdup end-c@ [char] ; = IF >in-- 1 cut-last THEN >$s-copy c-name$ $! ?instream-semicolon _c-wrap-val index-item+ ;