\ To allow C routines to call Forth routines

requires case.f

create cregs 16 /l * allot
create fregs  td 16 /l* allot

code init-fregs
   th 4800 #  fregs l#) movem   \ UP and RP
   next c;
init-fregs

\ We have to save UP and RP whenever we enter C code,
\ because if the C program calls Forth again, we must establish
\ the correct task and return stack
: make-c-entry ( ip-value #args -- )
[ assembler ]
   normal
   th fffe #  sp -)  movem
   fregs l#)  th 4800 #  movem   \ Restore rp and up
   ( ip #args )
   dup ( ip #args #args )
   0
   ?do   ( ip #args )
      dup /l* td 15 /l* +  ( offset of C arguments - 15 is # registers saved)
             sp d)  sp -) lmove
   loop
   drop  ( ip )

   l# ip lmove
   next
;
\ We have to save UP and RP whenever we enter C code,
\ because if the C program calls Forth again, we must establish
\ the correct task and return stack

code 0vals
   th 4800 #  fregs l#) movem   \ UP and RP
   sp )+  th 7fff #  movem
   rts
end-code

code 1val
   th 4800 #  fregs l#) movem   \ UP and RP
   sp )+ sp ) lmove
   sp )+  th 7fff #  movem
   rts
end-code

\ Put down 2 tokens:   cfa , 0/1val ,

: makebody ( #returns cfa -- ip )
  here -rot ( ip #returns cfa )
  token,    ( ip #returns )
  case
    0 of  compile 0vals endof
    1 of  compile 1val  endof
       abort" Can't return more than 1 value"
  endcase ( ip )
;
: centry:  ( #args #returns cfa -- )  ( Input Stream:  Name )
  makebody
  ( #args ip )
  create  
  swap make-c-entry
;

40 constant #centries
create centry-table #centries /l* allot
variable next-centry next-centry off

: centries next-centry off ;

: table-centry ( #args #returns cfa -- )
  makebody   ( #args ip )
  here -rot  ( entry-point #args ip )
  swap make-c-entry ( entry-point )
  centry-table next-centry @  la+  !
  1 next-centry +!
;
\
\ make-entry writes on the output stream an assembler entry of the form:
\ .text
\ . = addr
\ .global _name
\ _name:
\
\ This may be assembled by /bin/as to produce an object file.  The object
\ file will have the names defined as text symbols with the given addresses
: make-entry ( addr name -- )
  base @ >r hex
  ." .text" cr
  swap ." . = 0x" u. cr
  ." .globl _"   dup count type cr
  ." _" count type ." :" cr
  r> base !
;
create cname 32 allot
: centry ( #args #returns -- ) ( Input stream: name )
  bl word  ( #args #returns str )
  dup cname "copy ( #args #returns str )
  find 0= if interpret-do-undefined then  ( #args #returns cfa )
  makebody   ( #args ip )
  here -rot  ( entry-point #args ip )
  swap make-c-entry ( entry-point )
  cname make-entry
;
hex