( Forth to C translation rules  Rob Chapman Jan 1, 92 )
HEX
( ==== Rule sets ==== )
  RULE-SET interpret  ( dictionary for Forth interpreter rules )
  RULE-SET compiler   ( dictionary for Forth compiler rules )
  RULE-SET c          ( dictionary for C rules )
  RULE-SET comment    ( for exceptional comments )
  RULE-SET postpone   ( for meta compiling behaviours )
  RULE-SET C      ( transparent aligned print-through )

  0 VARIABLE indents   ( how many indents for each new line )
  0 VARIABLE line#	( to keep track of line numbers )

( ==== Rule set transitions ==== )
C RULES
 { Forth }{ forth }{ f }{ F }{ FORTH }[ RULES ]
 { c }[ c RULES ]
 { : }[ interpret RULES  YES prepend !  0 indents ! ]{ : }
 { FINISHED }{ c nl C }
interpret RULES
 { +c }[ c RULES ]
 { ] }{ fc }[ compiler RULES  NO prepend ! ]
 { C }{ Sea }{ sea }[ interpret  C RULES ]
 { FINISHED }{ +c nl fi }
compiler RULES
 { +c }[ c RULES ]
 { [ }{ fi }[ interpret RULES  YES prepend ! ]
 { ] }[ postpone RULES ]
 { C }{ Sea }{ sea }[ compiler  C RULES ]
c RULES
 { fc }{ f }[ compiler RULES   NO prepend ! ]
 { fi }[ interpret RULES  YES prepend ! ]
 { n }[ translate RULES  c ]
 { C }[ C RULES ]
postpone RULES
 { [ }[ compiler RULES ]

( ==== Procedure dictionary ====  )
  DICTIONARY CONSTANT cwords  ( dictionary of c procedures )
  0 VARIABLE hname  ( points to held name )

: CNAME  ( -- s )  GET-WORD  DUP cwords INSERT ;
: SHORT-STRING  ( s -- s' )  HERE SWAP  COUNT 3F AND  DUP C,
   FOR  C@+ SWAP C,  NEXT  DROP  ALIGNED ;
: QUOTE  ( -- )  ` ' HOLD ;
: STRING>C  ( s -- a \ c )   base @ >R  DECIMAL  DUP C@ TUCK + SWAP
   <#  ` } HOLD  FOR  QUOTE  C@- SWAP HOLD  QUOTE  ` , HOLD  NEXT
       QUOTE  C@ #  QUOTE  ` { HOLD  #>  R> base ! ;

( ==== Rule for code which is to be passed though, unfiltered ==== )
C RULES
 { }{ c  nl print line C }

 | } || c  end block    C |
 | { || c  start block  C |
 { ; }{ F ; }


c RULES
( ==== C text output==== )
{ }[ inputq PULL ]{ text }

{ emit }[ EMIT ]
{ emits }[ FOR  DUP EMIT  NEXT  DROP ]
{ type }[ TYPE ]
{ print line C }[ inputq PULL COUNT TYPE SPACE  0 PARSE  HERE COUNT TYPE ]{ C }

{ indent }[ 1 indents +! ]
{ outdent }[ indents @  1 -  0 MAX  indents ! ]

{ new line }{ nl }[ A ]{ emit margin }
{ margin }[ 9 indents @ ]{ emits }

{ _ }[ "  " ]{ text }
{ tab }[ 9 ]{ emit }

{ underbar }[ " _" ]{ text }
{ left  curly bracket }{ lcb }[ " {" ]{ text }
{ right curly bracket }{ rcb }[ " }" ]{ text }

{ forth string }{ fstring }{ "  \count  text  " }
{ \count }[ ." \"  base @  8 base !  OVER C@  <# # # # #>  TYPE  base ! ]
{ short text }[  ( name -- )  COUNT DUP 80 >  IF  1F AND  ENDIF ]{ type }
{ text }[  ( string -- )  COUNT ]{ type }
{ literal }[ base @ >R  DECIMAL  <# DUP ABS #S SIGN #>  R> base ! ]{ type }
{ string }[ STRING>C ]{ type }
{ includes }[ FOR  { nl #include _ " text " }  NEXT ]
{ exts }[ FOR  { nl extern _ void _ text (); }  NEXT ]

( ==== Language construction ==== )
  0 VARIABLE name  ( for making up fake names )

{ \ }[ inputq PULL ]{ tab  /*  _  text  _  */ }

{ comment }[ ` ) PARSE  HERE ]{ /*  _  text  */ }
{ ( comment }[ ` ( SKIP  BL SKIP ]{ _ _ comment }
{ stack comment }[ BL SKIP INPUT C@ ` ( =  IF  { ( comment }  ENDIF ]

{ line number }[ line# @ <# #S #> ]{ tab  /* _ line#  _  type  _  */ }
{ line number }[ ]

{ start procedure }{ procedure name  stack comment  start block }
{ end procedure }{ end block }
{ procedure call }{ new line  convert string () ; }

{ start block }{ sb }{ new line  left curly bracket  indent }
{ end block }{ eb }{ outdent  new line  right curly bracket }

{ start struct }{ struct  start block }
{ end struct   }{ end block  make name }

{ 16bits }{ unsigned _ short }
{ array }{ [ literal ] }

{ qpointer }{ & type name .q[ literal ] }
 
{ get name }[ GET-WORD ]{ convert string }
{ make name }[ 1 name +! ]{ type name }
{ fake name }[ 1 name +! ]{ type name n }
{ type name }[ hname @  IF  { type hname _ }  ELSE  { type name n }  ENDIF ]
{ type hname _ }[ hname @ ]{ convert string  underbar }
{ type name n }[ name @ <# #S #>  " name" COUNT ]{ type type }
{ procedure name }[ line-no @ line# !  CNAME ]{ new line  void _  convert string  ()  line number }
{ convert string }[ inputq STUFF ]{ n }

compiler RULES
( ==== Forth translator ==== )
{ }[ inputq PULL  DUP cwords FIND ]{ ?CALL }

{ ?CALL }[ IF  { call }  ELSE  { make number }  ENDIF ]
{ call }{ +c  procedure call  f }
{ make number }[ SHORT-STRING  DUP NUMBER? ]{ ?LITERAL }
{ ?LITERAL }[ IF  NUMBER { LITERAL }  ELSE  { call }  ENDIF ]

{ \ }[ inputq PULL  { f }  inputq STUFF ]{ +c \ }
{ c }{ +c  nl }

{ cell   }{ c *--sp = sizeof( Cell ) ; f }
{ alignment }{ aligned structure  alignment value }
{ aligned structure }{ c struct lcb void *x; Byte _  y; void *z; rcb align; f }
{ alignment value }{ c *--sp=sizeof(align)-2*sizeof(void*)-1; f }

{ r   }{ c  *--sp = *rp ; f }
{ rfrom  }{ c  *--sp = *rp++ ; f }
{ tor  }{ c  *--rp = *sp++ ; f  }
{ RP! }{ c rp = rp0_ f \ RP! }

{ swap }{ c *--rp = sp[1], sp[1] = sp[0], sp[0] = *rp++; f }
{ dup  }{ c  --sp, sp[0] = sp[1] ;  f }
{ drop }{ c  sp++; f }

{ nup }{ c --sp, sp[0] = sp[1], sp[1] = sp[2]; f }
{ nip }{ c sp[1] = sp[0], sp++; f }

{ SP! }{ c  sp = sp0_; f  \ SP! }
{ DEPTH }{ c  *--rp = sp0_ - sp; nl *--sp = *rp++; f \ DEPTH }
{ plus  }{ c  sp[1] += sp[0] , sp++ ; f }
{ minus }{ c  sp[1] -= sp[0] , sp++ ; f }

{ and }{ c  sp[1] &= sp[0] , sp++ ;  f }
{ or  }{ c  sp[1] |= sp[0] , sp++ ;  f }
{ xor }{ c  sp[1] ^= sp[0] , sp++ ;  f }

{ not   }{ c  sp[0] ^= -1   ; f }
{ left  }{ c  sp[0] <<= 1   ; f }
{ right }{ c  sp[0] = sp[0] / 2  ; f }
{ uturn }{ c  sp[0] >>= 1   ; f }

{ negative? }{ c  sp[0] = (int)sp[0] < 0 ? -1 : 0 ; f }

{ fetch  }{ c   sp[0] =          *(   Cell _ *)sp[0] ;  f }
{ wfetch }{ c   sp[0] = ( Cell )(*( 16bits _ *)sp[0]) ;  f }
{ cfetch }{ c   sp[0] = ( Cell )(*(   Byte _ *)sp[0]) ;  f }
{  store }{ c  *( Cell   _ *)sp[0] =           sp[1], sp+=2 ;  f }
{ wstore }{ c  *( 16bits _ *)sp[0] = ( 16bits )sp[1], sp+=2 ;  f }
{ cstore }{ c  *( Byte   _ *)sp[0] = ( Byte   )sp[1], sp+=2 ;  f }

{ mult }{ c  sp[1] *= sp[0] , sp++ ;  f }
{ udiv }{ c *--rp=sp[0]; nl sp[0] = sp[1] /sp[0]; nl sp[1] %= *rp++; f }

{ ( }[ INPUT  ` ) SCAN-FOR 0=  IF  { ( }  ENDIF  +IN ]{ +c  _ _ comment  f } 

{ ; }{ +c  end procedure  fi }

{ IF }{ c  if(*sp++)  \ IF  start block  f }
{ ELSE }{ +c  end block  nl  else  \ ELSE  start block  f }
{ ENDIF }{ THEN }{ +c  end block  f }

{ BEGIN }{ c  for(;;)  \ BEGIN  start block  f }
{ UNTIL }{ c  if(*sp++) break ; \ UNTIL end block  f }
{ WHILE }{ c  if(!*sp++) break ;  \ WHILE  f }
{ REPEAT }{ AGAIN }{ +c  end block  \ REPEAT  f }
{ FOR }{ c  for(*--rp=*sp++;*rp;(*rp)--)    \ FOR  sb  f }
{ NEXT }{ +c  end block  \ NEXT  nl  rp++ ;  f }

{ LITERAL }{ c  *--sp = literal ;  f  \ LITERAL }
{ EXIT }{ c  return ;  f  \ EXIT }
{ POSTPONE }{ ] POSTPONE }
{ execute }{ c  tick=(void (**)())(*sp++), _  (**tick)(); f }
{ ' }{ c  *--sp = ( Cell ) & underbar  get name .tick ;  f \ ' }
{ " }[ ` " ]{ [ parse string ] c *(char **)--sp = forth string ; f }
{ ." }{ "  COUNT TYPE }
{ ` }[ ' ` EXECUTE ]{ LITERAL }

| SHELL{ || c  shell_nest();  nl  if(setjmp(*ep)==0)  start block  f |
| }SHELL || +c  end block  nl  shell_unest();  f |

{ :II }{ c *--sp=(Cell)COLON_II; f }
{ VII }{ c *--sp=(Cell)VII; f }
{ CII }{ c *--sp=(Cell)CII; f }
{ DII }{ c *--sp=(Cell)DOES_II; f }

{ RECURSIVE }{ RECURSE }{ }

{ -INT? }{ 0 }
{ ?+INT }{ DROP }
{ -INT }{ }
{ +INT }{ }

{ RAM }[ DECIMAL ]{ c sp = ( Cell *)(malloc(32000) + 32); f }
{ SET-STACKS }{ return stack  data stack }
{ return stack }{ c  sp[0] = ( Cell )sp ; f  32 -  32000 +  CELL -  rp0 !  RP! }
{ data stack }{ rp0 @ 64 CELLS - sp0 !  SP! }

{ CLONE }{ dictionary  dictionary space }
{ dictionary }{ c *--sp = ( Cell )&_main ; f  latest ! }
{ dictionary space }{ sp0 @ 64 CELLS - limit !  rp0 @ CELL + 32000 - free ! }

{ vii }{ c *--sp=( Cell )vii; f }
{ colon_ii }{ c *--sp=( Cell )colon_ii; f }
{ does_ii }{ c *--sp=( Cell )does_ii; f }
{ cii }{ c *--sp=( Cell )cii; f }
{ >I }{ >R }
{ I> }{ R> }

interpret RULES
{ }[ inputq PULL INTERPRET-WORD ]

{ TRANSLATOR-INIT }[ ]

{ c }{ +c nl }

{ ?nl }[ in @  5 <  IF  { c }  ELSE  { +c }  ENDIF ]

{ : }{ ?finish  c  start procedure  fc }
{ CONSTANT }{ : LITERAL ; }
{ VARIABLE }[ line-no @ line# ! ]{ CREATE , }
{ TIMEOUT }{ CREATE 0 , }
{ CREATE }{ ?finish  hold name  c  start struct  fi }

  100 QUEUE parameterq ( for holding parameters of a data structure )

{ ALLOT }{ c  Byte  _  fake name  array ;  fi }
{ ,     }{ c  Cell  _  fake name        ;  fi  que parameter }
{ C,    }{ c  Byte  _  fake name        ;  fi  que parameter }
{ W,    }{ c  short _  fake name        ;  fi  que parameter }
{ que parameter }[ parameterq PUSH ]

c RULES
{ parameters , }[ parameterq Q?  FOR  parameterq POP  { literal , }  NEXT ]
{ list parameters }[ parameterq Q?  IF  | ={ parameters , } |  ENDIF ]

interpret RULES
{ QUEUE     }{ CREATE  ire  queue  qname  qpointers  ]CREATE }
{ ire       }{ c Cell _ *i; nl Cell _ *r; nl Cell _ *e; fi }
{ queue     }[ DUP 1 + ]{ c Cell _ q[ literal ]; fi }
{ qname     }{ +c end struct = fi }
{ qpointers }[ DUP DUP ]{ +c lcb qpointer , qpointer , qpointer rcb ; fi }

{ ?finish }[ hname @  IF  { finish struct }  ENDIF ]
{ hold name }[ CNAME  hname ! ]
{ 0hname }[ 0 hname ! ] 
| finish struct || +c end struct  list parameters ;  fi  ]CREATE |

{ ]CREATE }[ hname @ ]{ ": c *--sp=( Cell )& type name ; fc ; c fi 0hname }
{ ": }{ c  new line  void _ convert string  ()  line number  start block  fi }

{ " }[ ` " ]{ parse string c char _ fake name array = string ;  fi }
{ parse string }[ PARSE  HERE DUP C@ 1 +  ALLOT ALIGNED ]

{ IMMEDIATE }{ }

{ ( }[ INPUT  comment RULES ]
{ +( }[ INPUT-LINE  IF  INPUT   comment RULES  ENDIF ]


{ PROMPT }[ BL SKIP  0 ]{ parse string  finish prompt }
{ finish prompt }{ +c  end struct = lcb fstring rcb ; fi  CREATE() }

{ VFM }{ Vfm Stacks Index Threader Externals Includes }
{ Vfm }{ c nl /* _ Virtual _ Forth _ Machinery _ */ fi }
{ Includes }[ " kernel.h" 1 ]{ c includes fi }
{ Externals }[ " vii" " cii" " colon_ii" " does_ii"  4 ]{ c exts fi }
{ Stacks   }{ c Cell _ *sp,*rp; \ Stacks fi }
{ Threader }{ c void _ (***ip)(),(**tick)(); \ Threader  fi }

{ MODULE }{ EXPORT }[ BL WORD  CHAR ` (  IF  ` ) SCAN  ENDIF ]
{ END_MODULE }{ }

comment RULES
{   }[ +IN  inputq 0Q  INPUT  ` ) SCAN-FOR 0=  IF  { +( }  ENDIF  +IN  interpret RULES ]{ ?nl comment  fi }
{ ) }[ DROP            interpret RULES ]

{ Assume virtual Forth machine exists }{ ) VFM ( }

postpone RULES
{ }[ inputq PULL { [ call ] } ]

{ POSTPONE }[ inputq PULL ]{ [ call }
{ POSTPONE EXIT }{ [ 0 , }

DECIMAL
