( C-Inside rules for interactive objects  Rob Chapman  Jan 7, 2000 )

( ==== Declaration specification accumulators ==== )
 DICTIONARY CONSTANT names  \ holds declared names
" " VARIABLE name      \ points to newest name declared
  0 VARIABLE cname     \ C name to use if different
  0 VARIABLE fname	   \ Forth name if different
  0 VARIABLE last      \ points to last name declared
  0 VARIABLE ret-size  \ size of a return value
  0 VARIABLE ret-spec  \ pointer to array of string pointers
  0 VARIABLE spec-size \ size accumulator
 20 QUEUE sizeq        \ size of parameters
 20 QUEUE specq        \ pointers to names of declaration specifiers (dec-spec)
 20 QUEUE paraq        \ parameter queue of pointers to string pointer arrays

\ The dec-specs are accumulated in the specq
\ Complete specs are kept in paraq as an array of pointers to the dec-specs
\ Names are local to the current unknown
\ History is added for names for a glossary

( ==== Filling up ==== )
: ADD-SPEC  ( -- )  FIRST-WORD specq PUSH ;
: APPEND-TAG  ( -- )  GET-WORD  ( get tag )
   specq POP HERE $!  HERE "  " COUNT +$ ( put type in free space )
   HERE SWAP COUNT +$           ( append the tag )
   HERE MAKE-WORD specq PUSH ;  ( make permanent and push as spec )
: ADD-TYPE  ( n -- )  ADD-SPEC  spec-size @ MAX spec-size ! ;
: NEW-SPEC  ( -- a )  specq Q?  DUP  1 + CELLS ALLOCATE DUP >R  !+
   specq Q?  FOR  specq PULL SWAP !+  NEXT  DROP  R> ;
: ANOTHER-NEW-NAME  ( s -- )  MAKE-WORD  DUP name !  DUP cname !  DUP names FIND 0=
   IF  DUP names INSERT  DUP names ADJUNCT  NUP !  ENDIF  names ADJUNCT @ fname ! ;
: NEW-NAME  ( s -- )  ANOTHER-NEW-NAME
   NEW-SPEC ret-spec !  spec-size @ ret-size !  0 spec-size ! ;
: NEW-PARAM  ( s -- )  MAKE-WORD  specq PUSH
   NEW-SPEC  paraq PUSH  spec-size @ sizeq PUSH  0 spec-size ! ;
: REMEMBER  ( -- )  FIRST-WORD cname ! ;

: [CHECK]  ( -- )  vgc 1 + C@  ` [ =  IF  " *" specq PUSH  3 spec-size !  ENDIF ;

( ==== Specifiying Forth names for C functions ==== )
: LINK-NAMES  ( forth name \ c name -- )  DUP names INSERT  names ADJUNCT ! ;

: FNAMES:  ( -- )
   BEGIN  INPUT-LINE DROP  CHAR  WHILE
     BEGIN  CHAR  WHILE  GET-WORD  GET-WORD  LINK-NAMES  REPEAT
   REPEAT ;

( ==== Queries ==== )
: RET@  ( -- n )  ret-size @ ;
: ARG@  ( -- n )  sizeq Q ;
: PAR-SIZE  ( -- n )  ARG@ 6 AND ;
: RET-DEPTH  ( -- n )  RET@ 6 AND ;
: ARG-DEPTH  ( -- n )  0
   sizeq Q?  FOR  sizeq PULL DUP sizeq PUSH 6 AND +  NEXT ;
: #PAR  ( -- n )  paraq Q? ;
: NEXT-PAR  ( -- )  paraq PULL paraq PUSH  sizeq PULL sizeq PUSH ;
: #ARG-FLOATS  ( -- n )
   0  #PAR  FOR  ARG@ 5 =  1 AND +  NEXT-PAR  NEXT ;
: FLOATS?  ( -- n )  #ARG-FLOATS  RET@ 5 =  1 AND + ;

( ==== Output primitives ==== )
: AMONG  ( c \ start \ end -- )  >R  1 -  NUP >  SWAP R> 1 + <  AND ;
: C-CHAR?  ( c -- f )  DUP ` a ` z AMONG  OVER ` A ` Z AMONG OR
   OVER ` 0 ` 9 AMONG OR  SWAP ` _ = OR ;
: CEMIT  ( c -- )  BEGIN  DUP C-CHAR? 0=  WHILE  0x10 + 0x7F AND  REPEAT  EMIT ;
: CTYPE  ( a \ n -- )  FOR  COUNT CEMIT  NEXT  DROP ;
: .NAME  ( -- )  name @ COUNT CTYPE ;
: .CNAME  ( -- )  cname @ COUNT CTYPE ;
: .LAST  ( -- )  last @ COUNT CTYPE ; 
: .FIRST-BYTE  ( -- )  name @ C@  1 +  1 AND  0 .R ;
: LCOUNT  ( a -- a' \ n )  @+ SWAP ;
: .SPEC  ( a \ n -- )  FOR  @+ SWAP COUNT TYPE SPACE  NEXT  DROP ;
: .RET  ( -- )  ret-spec @ LCOUNT ?DUP  IF  .SPEC  ELSE  DROP ." void "  ENDIF ;
: .PAR-SPEC  ( -- )  paraq Q LCOUNT 1 - .SPEC ;
: .CAST  ( -- )  ." *(" paraq Q LCOUNT 1 - .SPEC ." *)&" ;
: .dsp  ( n -- )  ." dsp[" 2/ 0 .R  ." ]" ;  ( 2/ for 2 bytes per stack cell )
: .ARG  ( d \ u -- d' \ u' )  PAR-SIZE  ARG@ 2 >  IF  .CAST  ENDIF
   ARG@ 5 =  IF  SWAP >R  OVER .dsp  +  R>  ELSE  -  DUP .dsp  ENDIF   NEXT-PAR ;
: .ARGS  ( -- )  ." ("  #PAR
   IF  0  RET-DEPTH ARG-DEPTH MAX  .ARG
       #PAR 1 -  FOR  ." ," .ARG  NEXT  2DROP  ENDIF  ." )" ;
: .PAR  ( -- )  .PAR-SPEC  NEXT-PAR ;
: .PROTOTYPE  ( -- )  .RET .CNAME ." ("  #PAR
   ?DUP  IF  1 -  .PAR  FOR  ." , " .PAR NEXT  ELSE  ." void"  ENDIF  ." )" ;
: .LVALUE  ( -- )  RET-DEPTH  ?DUP
   IF  RET@  DUP 1 AND  SWAP 4 =  OR  IF  ." *(" .RET ." *)&"  ENDIF
       ARG-DEPTH SWAP -  0 MAX   .dsp  ." = "  ENDIF ;
: .GROW  ( -- )  RET-DEPTH ARG-DEPTH -  DUP 0 >
   IF  ."     dsp -= " 2/ 0 .R ." ;"  CR  ELSE  DROP  ENDIF ;
: .SHRINK  ( -- )  ARG-DEPTH RET-DEPTH -  DUP 0 >
   IF  ."     dsp += " 2/ 0 .R ." ;"  CR  ELSE  DROP  ENDIF ;

( ==== C output ==== )
  NO VARIABLE uc-case  \ YES for upper case conversion for names

: UC-EMIT  ( c -- )  uc-case @
   IF  DUP ` a ` z AMONG  IF  ` A ` a - +  ENDIF  ENDIF  EMIT ;
: UC-TYPE  ( a \ c -- )  FOR  COUNT UC-EMIT  NEXT  DROP ;
: .UC-NAME  ( -- )  fname @ COUNT UC-TYPE ;

: .COMMENT  ( -- )  CR ." /* head and body for " .NAME ."  */" CR ;
: .EXTERNF  ( -- )  ." extern " .PROTOTYPE  ." ;" CR ;
: .EXTERNV  ( -- )  ." extern " .RET .NAME  ." ;" CR ;
: .CALLC  ( -- )  CR  ." void call_" .NAME ." (void)" CR  ." {" CR  .GROW
   ."     "  RET@ IF .LVALUE ENDIF  .CNAME .ARGS ." ;" CR  .SHRINK  ." }" CR CR ;
: .CFUNCTION  ( -- )  ." Cfunction(" #PAR RET@ OR  IF  ." call_"  ENDIF
   .NAME  ." ," .NAME ." cfa);" CR ;
: .HEAD1  ( -- )
   ." Header(" fname @ C@ 2 + 0x1E AND 0 .R ." ," .NAME ." nfa)={" CR
   2 SPACES  fname @ C@ 1 + 1 AND  IF  ." 0, "  ENDIF
   ." 0x80|"  fname @ COUNT  DUP 0 .R
   FOR  ." ,'" COUNT UC-EMIT  ." '"  NEXT  DROP  ." |0x80, "
   ." &"  last @ ?DUP
   IF  .LAST  ." nfa.name["  names ADJUNCT @  C@ 1 + 1 AND 0 .R
   ELSE  " TASK" last !  ." tasknfa.name[0"  ENDIF
   ." ], &"  name @ last ! ;

: .HEAD2V  ( -- )  .NAME ." cfa" ;
: .HEAD2F  ( -- )  FLOATS?  IF  ." run_" .NAME  ELSE  .HEAD2V  ENDIF ;
: .HEAD3  ( -- )  ." [1]" CR  ." };" CR ;
: .HEADV  ( -- )  .HEAD1  .HEAD2V  .HEAD3 ;
: .HEADF  ( -- )  .HEAD1  .HEAD2F  .HEAD3 ;

\ Header and tailer for the header and glue code file.
: .TIMBRE  ( -- )  ." /* File generated by a Timbre Script */" CR ;

: #include  ( "file" --- )  \ file to include in header file
   ." #include "  BL WORD  HERE COUNT TYPE  CR ;

: .HEADER  ( -- )  " ..\Compiler\header.c" FILE> ;

: .TAILER  ( -- )  CR ." /* Final links to interactive kernel from C */"
   CR ." const Byte *lastnfa = &" .NAME ." nfa.name["
   name @ names ADJUNCT @ C@ 1 + 1 AND 0 .R ." ]; /* nfa of last word */" CR ;

\ glossary generators
\ stack picture generators
: .DEC  ( -- )  paraq Q LCOUNT 1 - CELLS + @ COUNT TYPE ;

: .PARAMETERS  ( -- )  NO  #PAR
   FOR  ARG@ 5 <
        IF  SPACE  DUP  IF  ." \ "  ENDIF  .DEC  YES OR  ENDIF  NEXT-PAR
   NEXT  DROP ;

: .RETURNS  ( -- )  RET@
   CASE 1 { ." c " } 2 { ." n " } 3 { ." a " } 4 { ." d " } ENDCASE ;

: .FPARAMETERS  ( -- )  NO ( none printed yet )  #PAR
   FOR  ARG@ 5 =
        IF  SPACE  DUP  IF  ." \ "  ENDIF  .DEC  YES OR ( some printed ) ENDIF
        NEXT-PAR
   NEXT  DROP ;

: .FRETURNS  ( -- )  SPACE  RET@ 5 =  IF  ." r"  ENDIF ;

: .STACKS  ( -- )  ."   ("  .PARAMETERS ."  -- " .RETURNS ." )"
   FLOATS?  IF  ."   (F:" .FPARAMETERS ."  --" .FRETURNS ." )"  ENDIF
   SPACE ;

\ glossary generators
  0 VARIABLE entries  \ link list of glossary entries

: ADD-TO-GLOSSARY  ( -- )  emitq Q?  DUP 1 + CELL +  ALLOCATE
   entries @  OVER entries !  SWAP  !+  NUP C!+
   SWAP  FOR  emitq PULL  SWAP C!+  NEXT  DROP ;

: .GLOSSARY  ( -- )  ." Glossary generated by a Timbre Script" CR CR
    DICTIONARY >R  entries @
    BEGIN  ?DUP  WHILE  @+ R INSERT   REPEAT
    R> SORT-DICT  FOR  @+ SWAP  COUNT TYPE  NEXT  CR  DROP ;

\ Comments that are captured in defining a function are included in the glossary 
CREATE comment-buffer 256 ALLOT  256 ALLOT ( for overflow )

: .EXPLANATION  ( -- )  comment-buffer COUNT TYPE ;

: FUNCTION+  ( -- )  FLUSH-EMITS  .UC-NAME .STACKS .EXPLANATION  CR  ADD-TO-GLOSSARY ;

: VARIABLE+  ( -- )  FLUSH-EMITS  .UC-NAME ."   ( -- a )  "  .RET  CR  ADD-TO-GLOSSARY ;

\ C outputs
   NO VARIABLE function-prototype  ( use prototypes to create headers )

: .FUNCTION  ( -- )  .COMMENT  .EXTERNF  #PAR RET@ OR  IF  .CALLC  ENDIF
   .CFUNCTION  .HEADF
   FUNCTION+  sizeq 0Q  paraq 0Q  specq 0Q ;

: .FUNCTION-PROTOTYPE  ( -- )  function-prototype @
   IF  .FUNCTION  ELSE    sizeq 0Q  paraq 0Q  specq 0Q  ENDIF ;

: .VARIABLE  ( -- )  .COMMENT  .EXTERNV
   ." Cvariable(&" .NAME ." ," .NAME ." cfa);" CR  .HEADV  VARIABLE+ ;

\ Macros for rules.

: TYPEDEF-TYPE  ( -- )  2 ADD-TYPE ;

: NEW-RULE  ( substitue \ method \ match \ rule set -- )
   >RULES  ADD-RULE  RULES> DROP ;

\ Additional rules for catching declarations.

typedef RULES
[ CPARSE ]
{ }[ inputq PULL  DUP NAME?  IF  NEW-NAME  ELSE  DROP  ENDIF ]
{ ; }[ 0  name @  2 CELLS ALLOCATE !+ !- ]{ add type definition }
 { add type definition }{ to arguments  to parsing  then return }
  { to arguments }[ DUP >R  0  ' TYPEDEF-TYPE  R>  paren  NEW-RULE ]
  { to parsing   }[     >R  0  ' TYPEDEF-TYPE  R>  c      NEW-RULE ]
  { then return  }[ CHANGE-RULES  paren .RULES  c .RULES ]

declaration RULES
{ }[ inputq PULL  DUP NAME?  IF  ANOTHER-NEW-NAME  ELSE  DROP  ENDIF ]
{ , }[ ( .EXTERNV ) sizeq 0Q  paraq 0Q  specq 0Q  ]
{ ; }[ ( .EXTERNV ) sizeq 0Q  paraq 0Q  specq 0Q  CHANGE-RULES ]
{ ) ( }[ RULES> parameters >RULES ]		\ pointer to function

comment RULES
{ }[ comment-buffer  inputq PULL COUNT  +$ ]

paren RULES
{ }[ inputq PULL DUP NAME?  IF  [CHECK]  NEW-PARAM  ELSE  DROP  ENDIF ]
{ void }{ const }[ 0 ADD-TYPE ]
{ char }{ short }{ int }{ signed }{ unsigned }[ 2 ADD-TYPE ]
{ enum }[ BL WORD ]{ int }
{ long }[ 4 ADD-TYPE ]
{ float }{ double }[ 5 ADD-TYPE ]  ( lsbit is float flag )
{ * }[ ADD-SPEC  3 spec-size ! ]
{ ) }[ 0 comment-buffer C! ]
| { |[ ?CR .PROTOTYPE ." ;"  sizeq 0Q  paraq 0Q  specq 0Q  CR  block CHANGE-RULES ]
{ ; }[ .FUNCTION-PROTOTYPE  CHANGE-RULES ]
{ Byte }{ unsigned char }
{ Forth }{ vector }
 { vector }[ 3 ADD-TYPE ]

c RULES
{ }[ inputq PULL  DUP NAME?  IF  NEW-NAME { declare a new word }  ELSE  DROP  ENDIF ]
{ void }{ const }[ 0 ADD-TYPE ]
{ char }{ short }{ int }{ signed }{ unsigned }[ 2 ADD-TYPE ]
{ long }[ 4 ADD-TYPE ]
{ float }{ double }[ 5 ADD-TYPE ]  ( lsbit is float flag )
{ extern }{ static }{ enum }{ struct }[ RULES> parameters >RULES ]

{ * }[ ADD-SPEC  3 spec-size ! ]
{ Byte }{ unsigned char }
{ Forth }{ vector }
 { vector }[ 3 ADD-TYPE ]
{ QUEUE }{ FILE }{ fpos_t }{ Cell }{ FInfo }[ RULES> parameters >RULES ]

{ debugon }[ YES input-echo !  YES rule-echo !  ." debuggin on" ]
{ debugoff }[ NO input-echo !   NO rule-echo !  ." debuggin off" ]

: TLD  ?CR CR  ." /* Function prototypes from "
   INPUT  BL WORD HERE COUNT TYPE  +IN  ."  */"  CR TLD ;