(      ^Forth:  ^Forth to C Translator
         File:  hftrans.fs
       Author:  david.n.williams@umich.edu
      Version:  0.1.6
      License:  LGPL
Last revision:  November 22, 2002
)
\ Copyright (C) 2001, 2002 by David N. Williams
(
This library is part of ^Forth.  It 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 2.1 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.

Please see the file POLITENESS included with this distribution.

NOTATION:  a "_" prefix means "emit to the output stream".
)


\ *** INITIAL PFE SCOPE

loadm dstrings
synonym +" cat"   synonym +` cat`
synonym $+ cat    synonym s+ s-cat
loadm floating  \ for FNUM+

only forth also extensions definitions

\ DEBUG TOS
\ false value NOTOS immediate
   true value NOTOS immediate


\ *** PARAMETERS

decimal
10 constant #signif-digs  \ number of FNUM>$ conversion digits
$" 0.1.6 " $constant version$

(
DEFINITION-STRINGS:  The string space for glossary translation
macros and the definition stream is allocated here.  This is the
place to change its size and maximum number of string frames. 
It replaces the system string space, and persists when the
translation quits.  Maybe this should be put in an execution
script.
)
  dstrings @ free ( ior) drop
  64000 4 make-$space value definition-strings
  definition-strings dstrings !  \ DSTRINGS default

(
INDEX-STRINGS:  The parameters below are used to allocate the
string space for the index stream via

    MAKE-INDEX <name> "<title>"

in the translation source, which starts the concatenation of a
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
definition-strings default.
)
  12000 constant /index-strings  \ parameters for MAKE-$SPACE
  4 constant max#-index-frames
  0 value index-strings


\ *** PFE EXTENSIONS

(
In trans-ext.c:  FIXME!!
  2RDROP  SKIP-IN
)


\ *** GENERAL USE

[UNDEFINED] \\ [IF]
  : \\   BEGIN -1 parse 2drop refill 0= UNTIL ; [THEN]

[UNDEFINED] (r: [IF] synonym (r: ( [THEN]

[UNDEFINED] (f: [IF] synonym (f: ( [THEN]

[UNDEFINED] skip [IF]
  : skip  ( addr len char -- addr+i len-i )  \ Baden Tool Belt
    >r BEGIN dup WHILE over c@ r@ =
        WHILE 1 /string REPEAT THEN
    r> drop ;
[THEN]

[UNDEFINED] bl-skip [IF]  \ Baden Tool Belt
  : bl-skip  ( addr len -- addr+i len-i )
    BEGIN dup WHILE over c@ bl <=
        WHILE  1 /string  REPEAT THEN ;
[THEN]

: $evaluate      ($: a$ -- )  $gc-off $s> evaluate $gc-on ;
: CAT$-EVALUATE  ($: -- )     ENDCAT $evaluate ;
: $@+            ( addr -- )  $@ $+ ;

\ Input and output file names:
  $variable infile$
  $variable ext-outfile$
  $variable dll-outfile$

: -end  ( s end.s -- s' )
(
If the string s has the string end.s as a terminating substring,
remove end.s and leave the preceding substring s'.  If end.s is
not a terminating substring of s, leave s'=s.
)
  2>r (r: &end #end) ( #s) dup r@ >=
  IF  \ long enough to have extension
    ( s) 2dup r@ - + ( &s-end) r@ ( #end) 2r@ compare
    0= IF  \ 0 means COMPARE equality, strip end.s
      r@ ( #end) - ( previous.s)
    THEN
  THEN
  2r> 2drop ;

: s-separate  ( buf.s ref.s -- buf.s false | after.s before.s true )
(
Search for the first occurrence of the string ref.s in the
string buf.s.  If found leave true, the string before.s of bytes
in buf.s up to but not including the bytes of ref.s, and the
string after.s of bytes in buf.s that follow those in ref.s.  If
not found, leave false and the original buf.s string.
)
  locals| #ref &ref #buf &buf |
  &buf #buf &ref #ref search ( buf.s FALSE | &found #rem TRUE)
  0= IF false
  ELSE
    ( #rem) dup >r
    ( &found #rem) #ref /string ( after.s)
    &buf #buf r> ( #rem) - ( before.s) true
  THEN ;


\ *** INPUT STREAM

$variable name$   \ bridge between definition
$variable label$  \   and index string spaces

: parse-area@  ( -- unparsed.s )
(
Leave the parse area portion of the input buffer as a string.
Factored from Bernd Paysan's version of Frederick Warren's $>,
comp.lang.forth, March, 2000.  PARSE-AREA@ is a partner to
SOURCE.
)
  source ( &inbuf #inbuf) >in @ ( #parsed) /string ( unparsed.s) ;

: parse-area!  ( unparsed.s -- )
(
The unparsed.s string is assumed to lie at the end of the input
buffer.  Advance the input stream so that unparsed.s is the
parse area.
)
  ( addr len) source nip ( #tib) swap - >in ! ( addr) drop ;

0 [IF]  \ Replaced by REFILL, which also skips eol.
: exhaust-source  ( -- )
  source ( addr num) >in ! ( addr) drop ;
[THEN]

: skip-in  ( char -- )
(
Advance the input stream to just after any leading occurrences
of char.  If the parse area is empty or contains only char
instances, the input stream is left exhausted.
)
  ( char) >r parse-area@ r> skip parse-area! ;

: bl-skip-in  ( char -- )
(
Advance the input stream to just after any leading occurrences
of white space.  If the parse area is empty or contains only
white space, the input stream is left exhausted.
)
  parse-area@ bl-skip parse-area! ;

: skip-past  ( s -- flag )
(
Advance the input stream to just after the next occurrence of
the string and leave true, if found, skipping line ends. If the
string is not found before end of file, leave the input stream
positioned there with false.  Based on the $> reference in
PARSE-AREA@.
)
  ( s) 2>r
  BEGIN
    parse-area@ 2r@ ( area.s s)
    search ( area.s false | &found #rem true)
  0= WHILE  \ not found
    ( area.s) 2drop
    refill 0= IF  \ end of file
\     ( s) 2rdrop false EXIT THEN
      ( s) 2r> 2drop false EXIT THEN
  REPEAT  \ found
  ( &found #rem) nip
  ( #rem) parse-area@ nip ( #rem #area) swap -
  \ advance the input stream over the s body
  ( #before) 2r> nip ( #before #s) + >in +! true ;

: name-"title"  ( `<name> "<title>"` -- $: name title )
(
Get the name and quoted title from the input stream, and leave
them on the string stack, after removing the quotes from
"<title>".  ABORT if <title> is not quoted.

NOTE:  Because of PARSE, in this implementation if the
terminating quote for the title is missing, the end of line is
treated as the second quote.
)
  parse-word ( <name>.s)
  dup 0= ABORT" ***Missing name"
  >$s-copy ($: name$)
\  bl skip-in [char] " parse ( before".s)
  bl-skip-in [char] " parse ( before".s)
  ( before".len) ABORT" ***Missing initial quote"
  ( addr) drop
  [char] " parse ( <title>.s) dup 0= ABORT" ***Missing title"
  >$s-copy ($: title$) ;

: name-"label"  ( `<name> "<label>"` -- )
(
A version of NAME-"TITLE" that stores into NAME$ and LABEL$.
)
  name-"title" ($: name label) label$ $! name$ $! ;


\ *** OUTPUT STREAM

0 value outstream         \ output stream fid
$variable date$
$variable wl-name$        \ to communicate between index header
$variable wl-title$       \   and trailer

true value internal?      \ set to true by HFTRANS, set to false
                          \   by BEGIN-EXTERNAL, and restored to
                          \   true by END-EXTERNAL
false value index?        \ set to false by HFTRANS, supposed to
                          \   be true only if INTERNAL? is true
false value index-items?  \ set to false by MAKE-INDEX, becomes
                          \   true after first item

: open-outstream  ($: <file>.c -- )
(
Open <file>.c for glossary text output, and store the fid in
OUTSTREAM.  Assume a valid file name.  Abort if the file can't
be opened.
)
  $s> ( s) r/w create-file ( fid ior)
  ABORT" ***Can't open output file."
  ( fid) to outstream ;

: close-outstream  ( -- )
  outstream close-file
  ABORT" ***Error closing output file." ;

: num>s  ( n -- n.s )
(
Convert the number according to the current BASE to a Forth
string in transient memory.
)
  <# dup >r abs s>d #s r> sign #> ;

: num>$  ( n -- $: n$ )
(
Copy the number as a string into string space.
)
  num>s >$s-copy ;

: num+  ( n -- )
(
Cat the number as a string into string space.
)
  num>s s+ ;

: fnum>$  (f: num -- $: num$ )
(
Copy a standard Forth external representation of the pfe
floating point number into string space.
)
  base @ >r decimal
  pad #signif-digs 2dup (r: fnum) represent
  ( significand.s exp minus? valid?)
  0= ABORT" ***Floating point number out of range." 
  ( minus?) IF +` -.` ELSE +` .` THEN
  ( exp) >r
  ( significand.s) s+   +` E`   r> ( exp) num+ ENDCAT
  r> base ! ;    

: num0r+  ( +n r -- )
(
Cat the last r digits of the nonnegative number +n as a string
into string space.  If the number has fewer than r digits, fill
with leading zeroes to make r digits.
)
  swap num>s  \ assume no "-"
  rot over - ( r-#digits) dup 0>
  IF    \ need leading "0"'s
    ( r-#digits) 0 DO $" 0" cat LOOP
  ELSE  \ simply truncate
    negate ( #digits-r) /string
  THEN
  s+ ;

: num0r>$  ( +n r -- $: num0r$ )
(
Copy the string conversion of the nonnegative number according
to the spec for NUM0R+ into string space.  Assume there is no
current concatenation.
)
  num0r+ ENDCAT ;

s" -Jan-Feb-Mar-Apr-May-Jun-Jul-Aug-Sep-Oct-Nov-Dec-"
    s, 2constant -mons-

: -mon-  ( month -- month.s )
(
Leave the month string corresponding to month = 1,2,...
)
  1- 4 * -mons- drop  + 5 ;

: cat$>$  endcat ;

: date&time+  ( -- )
(
Cat the current date and time to string space with 0-filled
fields as in "04-Jul-2002 09:02:06".  This version builds
arguments in string space, and cannot be used if a concatenation
is already taking place.
)
  time&date ( sec min hr day mo yr)
  ( yr) num>$       ( mo) -mon- >$s-copy   ( day) 2 num0r>$
  ( hr) 2 num0r>$   ( min) 2 num0r>$       ( sec) 2 num0r>$	
  ARGS{ yr mo day hr min sec }
  day mo yr +"  "
  hr +" :" min +" :" sec ;

: date&time$  ($: -- date$ )  date&time+ ENDCAT ;

: _s  ( s -- )
(
Write the Forth string body to the output stream.
)
  ?dup IF
    outstream write-file
    ABORT" ***Output stream write error."
  ELSE drop THEN ;

: _$  ($: $ -- )
(
Write the dynamic string body to the output stream.
)
  $s> _s ;

: _bl  ( -- )  s"  " _s ;
: _\n  ( -- )  \n$ _$ ;
: bl+  ( -- )  +"  " ;
: \n+  ( -- )  \n$ $+ ;

: _CAT$  ( -- )
(
Terminate and emit the current string concatenation.
)
  ENDCAT _$ ;

: _glossary-header  ( -- )
  +" /*  Pfe module:  " ext-outfile$ $@+ \n+
  +"   ^Forth input:  " infile$ $@+ \n+
  +"           Date:  " date$ $@+ \n+
  +"     Translator:  " version$ $+ \n+
  +" */" \n+ _CAT$ ;

: _upto  ( end.s -- )
(
Write the input stream up to but not including the string end.s
to the output stream.  Leave the input stream positioned just
after the terminating string.  The following adapts code for $>
by Frederick Warren and Bernd Paysan, comp.lang.forth, March,
2000, to use S-SEPARATE.

Note: To get EOL written after the last line, put the
terminating string at the start of the next line after the last.
)
  ( search.s) 2>r
  BEGIN
    source >in @ /string ( instream.s) 2r@ ( search.s)
    s-separate ( instream.s FALSE | after.s before.s TRUE)
  0= WHILE 
    _s _\n
    refill 0= ABORT" ***Terminating string not found."
\ REPEAT 2rdrop
  REPEAT 2r> 2drop
  ( before.s) _s
  ( #after) source nip swap ( #tib #after) - >in ! ( &after) drop ;

: upto+  ( end.s -- )
(
The same as _UPTO except instead of writing to the output
stream, cat to the current CAT$.
)
  ( search.s) 2>r
  BEGIN
    source >in @ /string ( instream.s) 2r@ ( search.s)
    s-separate ( instream.s FALSE | after.s before.s TRUE)
  0= WHILE 
    ( instream.s) s+ \n+
    refill 0= ABORT" ***Terminating string not found."
\ REPEAT 2rdrop
  REPEAT 2r> 2drop
  ( before.s) s+
  ( #after) source nip swap ( #tib #after) - >in ! ( &after) drop ;

: index-header+  ( -- )
(
Initiate INDEX-STRINGS concatenation with the C code preamble
for a pfe index.  Uses WL-NAME$.
)
  index-strings dstrings !
  \n+
  +" P4_LISTWORDS (" wl-name$ $@+ +" ) = " \n+
  +" {" \n+
  definition-strings dstrings ! ;

: _index  ( -- )
(
Assume both INDEX? and INDEX-ITEMS? are true.  Cat \n for the
last entry, without a comma, cat the pfe index postamble, and
emit the index.  Uses WL-NAME$ and WL-TITLE$.
)
    index-strings dstrings !
    \n+
    +" };" \n+
    +" P4_COUNTWORDS (" wl-name$ $@+ +` , "`
        wl-title$ $@+ +` ");` \n+   _CAT$
    definition-strings dstrings ! ;

: _dll  ( -- )
(
Emit the pfe -dll.c file.  Uses WL-NAME$.
)
  +" /*  Pfe module glue:  " dll-outfile$ $@+ \n+
  +"        ^Forth input:  " infile$ $@+ \n+
  +"                Date:  " date$ $@+ \n+
  +"          Translator:  " version$ $+ \n+
  +" */" \n+
  +" #define _P4_SOURCE 1" \n+
  +" #define MODULE" \n+
  +" #include <pfe/def-words.h>" \n+
  +" extern const p4Words P4WORDS("
      wl-name$ $@ ($: wl-name) $dup $+
      +" );" \n+
  +" P4_MODULE_LIST ("
      ($: wl-name) $+ +" );" \n+   _CAT$ ;

: name+   ( -- )  name$ $@+ ;
: label+  ( -- )  label$ $@+ ;


\ *** SCOPE

vocabulary translate

: host[  ( -- )
(
Switch out of translator and into host scope for words to be
interpreted rather than translated.
)
  only forth also postpone extensions definitions ;

: ]host  ( -- )
(
Switch into translator scope.
)
  only forth also postpone extensions
  also translate definitions ;


\ *** MAIN PROGRAM
(
When being loaded, a source file is either the main translation
file, in which case we say it is nonexternal, or it is serving
as an external resource for the main translation, in which case
we say it is external.  This state is tracked by the INTERNAL?
value, which is set to true when a translation starts.  The main
translation file is the only nonexternal file in a translation.
)

: ?free-index  ( -- )  index? IF index-strings free drop THEN ;

: hftrans ( "<name>[.hf]" -- )
(
Save "<name>.hf" in INFILE$, "<name>-ext.c" in EXT-OUTFILE$, and
"<name>-dll.c" in DLL-OUTFILE$.  Open the glossary output file
<name>-ext.c, write its header, and set the output stream to its
fid.  Set the translator scope, so the search order includes the
TRANSLATE vocabulary and assigns new definitions to it.  Set the
initial translation mode to nonexternal.  Set the default index
mode to none.  Interpret the input file <name>.hf.  If an index
is requested and there are index entries, append an index to the
output file, close the output stream and reopen it to
<name>-dll.c, and write the dll file.  Close the output stream.
Restore the host scope, so the search order has EXTENSIONS on
top and new definitions go there.
)
  parse-word ( addr n) s" .hf" -end ( name.s)
  ?dup 0= ABORT" ***No base file name"
  ( name.s) >$s-copy
  ($: name) $dup $+ +" .hf" ENDCAT infile$ $!
  ($: name) $dup $+ +" -dll.c" ENDCAT dll-outfile$ $!
  ($: name) $+ +" -ext.c" ENDCAT
  ($: name-ext.c) $dup ext-outfile$ $!
  ($: name-ext.c) open-outstream
  date&time$ date$ $!
  _glossary-header
  decimal ]host
  true to internal?
  false to index?
  s" Translating " type infile$ $@ $. s"  to " type
      ext-outfile$ $@ $. s"  ... " type
  infile$ $@ $s> included
  index? index-items? and IF
     _index close-outstream
     dll-outfile$ $@ $dup open-outstream
     s" done." type
     cr s" Writing " type ($: dll-outfile) $. s"  ... " type
     _dll
  THEN
  index? IF index-strings free drop THEN
  close-outstream
  s" done." type cr host[ ;


\ *** SOURCE TRANSLATION
(
Most ^Forth words are defined in TRANSLATE.  New words defined
by ^Forth defining words will also be put in TRANSLATE.
)
  ]host  \ translator scope

: BEGIN-EXTERNAL  ( -- )
(
Source modules to be treated as an external resource for a
translation are mentioned using REQUIRES between BEGIN-EXTERNAL
and END-EXTERNAL.

If the current file is being translated [internal], it should
load the external files it REQUIRES to get calling stubs, inlined
source, storage references, etc.  If it is only supplying REQUIRES
for the internal file being translated, it is external and has no
REQUIRES of its own, and should not load external files.  This
word handles that by skipping just past END-EXTERNAL when INTERNAL?
is false, and by setting INTERNAL? to false if it is true, so the
external files are not read as internal.  In the latter case,
END-EXTERNAL is not skipped, and restores INTERNAL? to true.
)
  internal? 0= IF  \ this file is external, no REQUIRES
    s" END-EXTERNAL" skip-past
    0= ABORT" ***END-EXTERNAL not found."
  ELSE  \ this file is internal
    false to internal?  \ the files it REQUIRES are external
    s" config.hf" included  \ gcc regs and pfe includes
  THEN ;

: END-EXTERNAL ( -- )
(
This word should be encountered only if the current file is
internal; otherwise it is skipped.  It restores INTERNAL to true
from the false value set by BEGIN-EXTERNAL.
)
  true to internal? ;

: MAKE-INDEX  ( `<vocname> "<voctitle>"` -- )
(
If INTERNAL? is true, initialize a pfe wordlist.  Here <vocname>
has to be a legal C identifier [label], while <voctitle> is
arbitrary descriptive text not containing any quotes.

If a pfe index is to be made, this word followed by the index
name and title must appear between END-EXTERNAL and the first
definition that is to appear in the index.

Words in the index not only do translation action translator
scope, but are intepretable by pfe when the compiled target
module is loaded.
)
  name-"title" ($: name title)
  internal? IF
    wl-title$ $! wl-name$ $!
    /index-strings max#-index-frames
        make-$space to index-strings
    index-header+
    true to index?  false to index-items?
  ELSE
    ($: name title) $2drop  \ seems more robust this way
  THEN ;

\ The literal text termination string:
here 2 ( addr n) char " c, char } c, 2constant "}-s

: {"  ( -- )  "}-s _upto ;

: c{  ( -- )  s" }c" upto+ ;

: /*  ( -- )
(
Position the input stream just after the next occurrence of */,
skipping all text and white space, including line ends.  This is
for C-style commenting, which is a guard against running ^Forth
source intended for translation without this file, hftrans.fs.

Note that /*** is not legal, while /* ** is.  On the other hand,
***/ is legal because the terminating */ is only parsed, not
executed or WORD'd.
)
  s" */" skip-past 0= ABORT" ***Missing end of comment '*/'." ;

host[

: index-item+  ( -- )
(
Cat a pfe index item to the index.  The only pfe type used here
is that for a normal primitive word, FXco.  I.e., variables,
constants, etc., are assumed to be wrapped as primitive function
calls for interpretation purposes.
)
  index-strings dstrings !
  index-items? IF +` ,` \n+ THEN  \ append comma to previous item
  +`  P4_FXco ("`   name+   +` ", hfi_`   label+   +` )`
  true to index-items?
  definition-strings dstrings ! ;

$" p4char" $constant p4char$
$" p4cell" $constant p4cell$
$" double" $constant double$

: _vdeclare  ($: value type -- )
(
Emit an initialized variable declaration, prefixed by "extern"
if INTERNAL? is false.  To use this word in code that defines
unitialized Forth variables, supply zero for the value.
)
  ARGS{ value type }
  internal? IF
    type bl+ label+ +`  = ` value
  ELSE
    +` extern ` type bl+ label+
  THEN   +` ;` \n+ _CAT$ ;

: _v[n]declare  ( +n $: type -- )
(
Emit an uninitialized variable array declaration with dimension
+n, prefixed by "extern" if INTERNAL? is false.
)
  internal? 0= IF +` extern ` THEN
  ($: type) $+ bl+   label+
      +` [`   ( +n) num+ +` ];` \n+ _CAT$ ;

: _#define-label  ($: text -- )
(
Emit a cpp #define for label$ with the input text as its value.
)
  +` #define `   label+ bl+   ($: text) $+ \n+ _CAT$ ;

$" hf_"  $constant hf_$
$" hfi_" $constant hfi_$
$" p4_"  $constant p4_$

: FCode-header+  ($: prefix -- )
  +` FCode (`   ($: prefix) $+   label+   +` )` ;

: :var  ( -- )
(
Define a word that emits inline code for a Forth variable. 
)
  +` : ` name+
      +`  +"   HF_PUSH((p4cell) &`
      label+   +` );" \n+ _CAT$ ;` \n+ CAT$-EVALUATE ;

: ?index-var  ( -- )
(
If INDEX? is true, emit pfe-interpretable code and cat an index
entry for a target word that leaves a data address on the stack.
)
  index? IF
    hfi_$ FCode-header+ \n+
    +` { *--SP = (p4cell) &`   label+   +` ; }` \n+ _CAT$
    index-item+
  THEN ;

$" SP" $constant SP$   $" FP" $constant FP$

: ?index-con  ($: stack -- )
(
If INDEX? is true, emit pfe-interpretable code and cat an index
entry for a target word that leaves a constant on the stack
named by the input string.
)
  index? IF
    hfi_$ FCode-header+ \n+
    +` { *--`   ($: stack) $+   +`  = `
        label+   +` ; }` \n+ _CAT$
    index-item+
  ELSE $drop THEN ;

: init-variable:  ( `<name> "<label>"` n -- )
(
Define <name> as a word that cats inline code for a Forth
variable initialized to n, and emit a data declaration.  If
INDEX? is true, emit and index an interpretable version.
)
  name-"label" :var
  ( n) num>$ p4cell$ _vdeclare   ?index-var ;

: variable:  ( `<name> "<label>"` -- )
(
The zero initialization here is an implementation issue
only--the user may not assume words defined with VARIABLE: to be
initiliazed.
)
  0 init-variable: ;

: init-fvariable:  ( `<name> "<label>"` f: x -- )
(
Define <name> as a word that cats inline code for a Forth
floating point variable initialized to x, and emit a data
declaration.  If INDEX? is true, emit and index an interpretable
version.
)
  name-"label" :var
  ( x) fnum>$ double$ _vdeclare   ?index-var ;

: fvariable:  ( `<name> "<label>"` -- )
(
The zero initialization here is an implementation issue
only--the user may not assume words defined with FVARIABLE: to be
initiliazed.
)
  0e init-fvariable: ;

: create-allot:  ( `<name> "<label>"` n -- )
(
Define <name> as an inlining word that cats code for a Forth
variable/array of n cells, and emit a data declaration.  If
?INDEX is true, emit and index an interpretable version.
)
  name-"label" :var
  ( n) p4cell$ _v[n]declare   ?index-var ;

: ccreate-allot:  ( `<name> "<label>"` n -- )
(
Define <name> as an inlining word that cats code for a Forth
variable/array of n characters, and emit a data declaration.  If
?INDEX is true, emit and index an interpretable version.
)
  name-"label" :var
  ( n) p4char$ _v[n]declare   ?index-var ;

: fcreate-allot:  ( `<name> "<label>"` n -- )
(
Define <name> as an inlining word that cats code for a Forth
variable/array of n floating point numbers, and emit a data
declaration.  If ?INDEX is true, emit and index an interpretable
version.

)
  name-"label" :var
  ( n) double$ _v[n]declare   ?index-var ;

: constant:  ( `<name> "<label>"` n -- )
(
Define <name> as a Forth word that cats code for a normal Forth
constant.  Emit a cpp define that replaces <label> by n.  If
INDEX? is true, which implies that INTERNAL? is true, add the
constant as an index item.
)
  name-"label" num>$
  ($: n) $dup _#define-label
  +` : ` name+   +`  +"   HF_PUSH(`
      ($: n) $dup $+   +` );" \n+ _CAT$ ;` \n+ CAT$-EVALUATE
  SP$ ?index-con ;

: fconstant:  ( `<name> "<label>"` f: x -- )
(
Define <name> as a Forth word that cats code for a normal Forth
floating point constant.  Emit a cpp define that replaces
<label> by x.  If INDEX? is true, which implies that INTERNAL?
is true, add the constant as an index item.

Note:  Standard floating point notation is used for x, so that C
understands it to be a double, the pfe default.
)
  name-"label" fnum>$
  ($: f) $dup _#define-label
  +` : ` name+   +`  +"   HF_FPUSH(`
      ($: f) $dup $+    +` );" \n+ _CAT$ ;` \n+ CAT$-EVALUATE
  FP$ ?index-con ;

: ext-variable:  ( `<name> "<label>"` -- )
(
Define <name> as a word that cats inline code for a pfe Forth
system variable.  The <label> should be the upper case name used
by pfe following "p4_", e.g., "BASE" for "p4_BASE".  References
to system variables within C{ ... }C should be made through
normal pfe macros.
)
  name-"label"
  +` : ` name+
      +`  +"   HF_PUSH((p4cell) &p4_`
      label+    +` );" \n+ _CAT$ ;` \n+  CAT$-EVALUATE ;

: :pfe-word  ( -- )
(
Define a word that emits a pfe primitive word as a C function
call, inside a TOS wrapper, for use in ^Forth definitions.  Such
words do not go into the index, because they can already be used
interpretively from the pfe dictionary.
)
  +` : ` name+ bl+
      +` +"   HF_SPILL_TOS HF_SPILL_FTOS p4_`   label+
      +` _ ();  HF_FILL_TOS HF_FILL_FTOS" \n+ _CAT$ ;`
  CAT$-EVALUATE ;

: _prototype  ($: prefix -- )
(
Emit a word function prototype, for use with ^Forth definitions.

Note:  Indexed versions of target words are for pfe
interpretation only, so they are not prototyped.
)
  ($: prefix) FCode-header+ +` ;` \n+ _CAT$ ;

: ext-def:  ( `<name> "<label>"` -- )
(
Emit a prototype for a pfe word and define a word that emits the
C function call.  Such words do not go into the index, because
they can already be interpreted normally.
)
  name-"label" :pfe-word p4_$ _prototype ;

: m:  ( `<name> "<label>" ...` -- )
(
Define <name> as a word that emits the text following the header
line, across lines up to ;M.  The "<label>" is ignored, but
required for consistent syntax.
)
  name-"label"
  refill  \ skip to next line
  +" : "  name+ 
  +"  +` " s" ;m"
  upto+ +" ` \n+ _CAT$ ;" CAT$-EVALUATE ;

: index-word  ( -- )
(
Assume that INDEX? is true and that NAME$ holds the name of an
already defined translator word that emits code for a target
word with an arbitrary stack picture.  Emit pfe-interpretable
code and cat an index entry for the target word.
)
  hfi_$ FCode-header+ \n+
  +` { HF_FILL_TOS HF_FILL_FTOS ` \n+ _CAT$
      name$ $@ $evaluate   +`  HF_SPILL_TOS HF_SPILL_FTOS }`
      \n+ _CAT$
  index-item+ ;

: defm:  ( `<name> "<label>" ...` -- )
(
This word differs from M: by making <name> interpretable in the
compiled target when there is an index.  Note that INDEX? is
true only if INTERNAL? is true.
)
  name-"label"
  refill        \ skip to next line
  +" : " name+  \ define word to emit inline code
      +"  +` "   s" ;defm" upto+   +" ` _CAT$ ;" CAT$-EVALUATE
  index? IF index-word THEN ;

: def:  ( `<name> "<label>" ...` -- )
(
Define <name> as a word that cats its pfe function call.  If
INTERNAL? is false emit the function prototype and skip past
;DEF.  Else cat the function header, and if INDEX? is true
append an entry to the pfe index.
)
  name-"label"
  +` : ` name+  \ define word to emit inline function call
      +`  +"   hf_`   label+   +` _ ();" \n+ ;` CAT$-EVALUATE
  index? IF hf_$ _prototype  index-word THEN
  internal? IF
    hf_$ FCode-header+ \n+
    +` {` \n+
  ELSE
    hf_$ _prototype s" ;def" skip-past
  THEN ;

: ;def  ( -- )  +` }` \n+ _CAT$ ;

]host

: s"  ( "ccc<quote>" -- )
\ run:  ( -- addr len )
(
To be translated from the usual S" syntax, but only inside a
^Forth definition.  The string constant is *not* stored as a
counted string.  Rather, the generated C code expresses its body
as an explicitly quoted C string.
)
  [char] " parse ( s)
  +`   HF_FILL_TOS SP -= 2; TOS = `
      ( len) dup num+   +` ;` \n+
  +`   (char *) SP[1] = "`   s+   +` ";` \n+ ;

: ."  ( "ccc<quote>" -- )
(
To be translated from the usual ." syntax, but only inside a
definition.  The string constant is *not* stored as a counted
string.  Note that S" in this definition is the one just above.
)
  s" +`   HF_SPILL_TOS p4_type_ ();` \n+ ; 

: ABORT"  ( "ccc<quote>" -- )
\ does:  ( flag -- )
(
Note that ." in this definition is the one just above.
)
  +`  HF_IF{` \n+
  ." +`  p4_abort_ (); }` \n+ ;

\ WARNING!!  No definition using normal Forth S", .", or ABORT"
\ should follow this point without escaping to host scope!   And
\ watch out in the code below for normal uses of the words
\ overloaded there!


\ *** Control Structures
(
These control structures should appear only between DEF: and
;DEF.  Since they are for translation only, they are not
indexed.
)

: (unloop)+  ( -- )
  +`   hf_index = (int) *RP++; hf_limit = (int) *RP++;` \n+ ;

: DO  ( -- )
\ does:  ( limit index -- )  
  +` { RP -= 2;` \n+
  +`   RP[0] = (p4xt *) hf_index;  RP[1] = (p4xt *) hf_limit;` \n+
  +`   hf_index = TOS; hf_limit = SP[1]; HF_DROP2;` \n+ 
  +`   while (hf_index < hf_limit){` \n+ ;

: LOOP  ( -- )
  +`   hf_index++; }` \n+
  (unloop)+  +`   }` \n+ ;

: +LOOP  ( -- )
\ does:  ( n -- )
  +`   hf_index += TOS; HF_DROP1; }` \n+
  (unloop)+ +`   }` \n+ ;

: i  ( -- n|u )
  +`   HF_PUSH (hf_index);` \n+ ;

: j  ( -- n|u)
  +`   HF_PUSH ((int) *RP);` \n+ ;

: LEAVE  ( -- )
  (unloop)+ +`  break;` \n+ ;

: UNLOOP  ( -- )  (unloop)+ ;

: EXIT  ( -- )  +`  return;` \n+ ;

: IF  ( -- )
\ does:  ( flag -- )
  +` { HF_IF{` \n+ ;

: NIF  ( -- )
\ does:  ( flag -- )
  +` { HF_NIF{` \n+ ;

: ELSE  ( -- )
+` }else{` \n+ ;

: THEN  ( -- )
+` }}` \n+ ;

: BEGIN  ( -- )
+`  do{` \n+ ;

: WHILE  ( -- )
\ does:  ( flag -- )
  +`   HF_IF break ;` \n+ ;

: NWHILE  ( -- )
\ does:  ( flag -- )
  +`   HF_NIF break ;` \n+ ;

: REPEAT  ( -- )
+`   }while ( 1 );` \n+ ;

: UNTIL  ( -- )
\ does:  ( flag -- )
  +`  HF_UNTIL;` \n+ ;

: NUNTIL  ( -- )
\ does:  ( flag -- )
  +`  HF_NUNTIL;` \n+ ;

: RECURSE  ( ? -- ? )
+` hf_` label+ +` _ ();` \n+ ;