/* forfunc.c zilla 19aug91 - foreign function interface for elk
 *
 * this file creates 
 *      (foreign-prototype <forfunc>)
 *      (foreign-trace! #t/#f)
 * and provides 'foreign
 *
    Portions of this file are Copyright (C) 1991 John Lewis,
    adapted from Elk2.0 by Oliver Laumann.

    This file is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation.

    This program 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 General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****NOTE THE ELK COPYING GC: ALL Object REFERENCES MUST BE GC_LINKED
 ****ACROSS CALLS WHICH MAY ALLOCATE STORAGE.  ALL C VARIABLES WHICH 
 ****ARE ASSIGNED FROM THE ADDRESS OF AN OBJECT MUST BE REASSIGNED
 ****AFTER A GC.
 *
 * foreign functions are defined in an Init_(), using
 * Define_Foreign(char *name,c_entry_point,char *argspec);
 * argspec is a string containing
 *  B boolean
 *  I integer
 *  F float
 *  R returns
 *  S string
 *  P port
 *  A farray
 * currently ports may be passed (C should expect a FILE) but not returned.
 * returned strings are allocated on the lisp heap, so the c function
 * should return a pointer to a static rather than a malloced string
 * (or else there will be a memory leak)
 *
 * modified
 * 12nov
 * 6sep         sparc flush register windows on ff call. needed?
 * 11may        gc checked. probably ok.
 * 17apr        sgi port, cleanups
 * 15oct91      added ZLforudeftab
 * 18sep91      error checking in foreign-prototype
 *
 * naming
 * ZLfordef
 * ZLforcall
 * ZLforproto   return readable form of the prototype
 *
 * Sparc architecture notes%%%%%%%%%%%%%%%%
32 registers. 8 globals %g0..7, same in every window.  24 window-specific:
%0..31		absolute names for registers
%g0..7		global.  same as %0..7
%o0-7		"out" regs, become "in" for subroutine, same as %8..15
%i0..5		"in registers", are outs of caller. same as %24..31
%i0..5			6th..1st c-program reg var
%l0..7		local	same as %16..23
%f0-31		float regs.  fstod leaves result in 0,1.
%sp=%o6
%fp=%i6
i7=return address
[reg+off]	contents of (*reg)
save,restore create, delete a new register window; syntax is like add
function return values in %o0, %f0,1 for doubles.
call .ptr_call calls routine whos address is in %g1
first 6 args are passed in %o0..%o5, remainder passed on stack.
number of args in registers (<= 6) passed as second arg to call:
call	.ptr_call,6

It appears that doubles do not need to be 8-byte aligned when on the stack.

stack:
		previous frame
	fp	locals
		alloca
		out parameters beyond 6th		sp+x5c
		6 words - register args for callee	sp+x44..58
		hidden struct return addr word
		16 words save stuff
	sp	;grows down
	;;(16+6+1)*4 = 92

register layout:
		return addr
		frame pointer
		#in #5..0
		locals
		out:temp	
		stack pointer		becomes callees frame pointer
		out #5..0		become callee's in#5..0 

save instruction swaps register windows.  out0..7 become in0..7;
caller's sp becomes callee's fp.
restore instruction undoes this.

%i0..5  incoming arguments
sp+x44..58 where caller stores args 0..5 on stack, mirrored in registers o0..5
fp+44 	is where first passed argument gets stored if needed, grow up.
	i.e., callee moves i0 into fp+44, i1 int fp+48 if needed.
sp+x5c	Caller stores args beyond 6th here
fp-4 	is first local variable, grow down.

sp+0x5c should be??? the address of the first out parameter which does
	not fit in a register (arg 7 typically?).
	this becomes fp+0x5c for the callee.
%%%%%%%%%%%%%%%%*/

#include <theusual.h>
#include <assert.h>
#include <scheme.h>
#include <zelk.h>

/* I integer
   F float
   R returns
   S string
   P port
   A farray
 */

/* map 'R' returns indicator onto this dummy type id */
#define T_Returns    254
#define T_End        255



/* primitive (foreign-trace #t/#f) */
static bool ForeignTracep = FALSE;

Object P_foreigntrace(o)
  Object o;
{
  Error_Tag = "foreign-trace!";
  if (o == True) ForeignTracep = TRUE;
  else if (o == False) ForeignTracep = FALSE;
  else Primitive_Error("#t or #f");
  return Null;
}



/* primitive define-foreign.  
 * must create a static copy of the argspec, lookup the function symbol,
 * then call Define_Foreign.
 * Should create a separate non-lisp string heap for strings
 * allocated here, and in the foreign function call itself.
 */

void P_Define_Foreign (name, fun, args)
  Object name,fun,args;
{
  /* UNFINISHED */
}



/* Define_Foreign - define a foreign function.
 * args may be (char *)0 if function has/returns no arguments.
 * alternate name? ZLfordef()
 */
void Define_Foreign (name, fun, args)
  char *name;
  void (*fun)();
  char *args;
{
    Object prim, sym, frame;
    GC_Node2;
    int len;
    Ztrace(("Define_Foreign %s %s\n",name,args));
    Error_Tag = "define-foreign";

    prim = Make_Primitive ( (Object (*)())fun, name, 0, MANY, FOREIGN);
    sym = Null;
    GC_Link2 (prim, sym);

    if (args != (char *)0) {
      unsigned char *s;

      s = PRIM(prim)->forfunargs = (unsigned char *)Zsalloc(args);

      /* WARNING: done in place */
      /* translate from character codes into elk T_ ids */
      while( *s ) {
        switch(*s) {
        case 'B':       *s = (unsigned char)T_Boolean; break;
        case 'I':       *s = (unsigned char)T_Fixnum; break;
        case 'f':       *s = (unsigned char)T_Flonum; break;
# ifdef T_Double
        case 'F':       *s = (unsigned char)T_Double; break;
        case 'D':       *s = (unsigned char)T_Double; break;
# else
        case 'F':       *s = (unsigned char)T_Flonum; break;
        case 'D':       *s = (unsigned char)T_Flonum; break;
# endif
        case 'S':       *s = (unsigned char)T_String; break;
        case 'P':       *s = (unsigned char)T_Port; break;
        case 'A':       *s = (unsigned char)T_Farray; break;
        case 'R':       *s = (unsigned char)T_Returns; break;
        default:
          Ztrace(("(%s) ",PRIM(prim)->forfunargs));
          Primitive_Error("unrecognized argspec");
          break;
        }
        s++;
      } /*while*/
      *s = T_End;
    } /*args!=0*/
    else 
      PRIM(prim)->forfunargs = (unsigned char *)0;

    sym = Intern (name);
    frame = Add_Binding (Car (The_Environment), sym, prim);
    SYMBOL(sym)->value = prim;
    Car (The_Environment) = frame;
    GC_Unlink;
} /*Define_Foreign*/


/* old name of Define_Fortab */
void ZLfordeftab(tab)
  struct fordef *tab;
{
  Define_Fortab(tab);
}


/* define a table of foreign functions */
void Define_Fortab(tab)
  struct fordef *tab;
{
  struct fordef *f;
  for( f = tab; f->name != (char *)0; f++ ) {
    Ztrace(("fordeftab %s %s\n",f->name,f->args));
    Define_Foreign(f->name,f->ffunc,f->args);
  }
}


/* define a table of foreign functions with doc strings*/
/* currently (oct-0) the doc string is ignored */
void ZLforudeftab(tab)
  struct fordef_usage *tab;
{
  struct fordef_usage *f;
  for( f = tab; f->name != (char *)0; f++ ) {
    Ztrace(("fordeftab %s %s\n",f->name,f->args));
    Define_Foreign(f->name,f->ffunc,f->args);
  }
}


/* define primitives via table
   table needs name entry-point minargs maxargs discipline
   NOT DONE YET
   primarily for package-style things.
 */
void ZLdeftab(tab)
  struct fordef *tab;
{
  Panic("ZLdeftab: not implemented");
}


/* return readable string version of foreign prototype */
char *
ZLforproto(args)
  unsigned char *args;
{
  unsigned char *arg;
  static char cargs[128];
  char *c = cargs;
  Error_Tag = "foreign prototype";

  arg = args;
  while( *arg != T_End ) {
    if (*arg == T_Farray)       /* T_Farray is not a constant, wont go */
                                /* in switch */
      *c++ = 'A';
    else
    switch(*arg) {
    case T_Boolean:     *c++ = 'B'; break;
    case T_Fixnum:      *c++ = 'I'; break;
# ifdef T_Double
    case T_Flonum:      *c++ = 'f'; break;
    case T_Double:      *c++ = 'F'; break;
# else
    case T_Flonum:      *c++ = 'F'; break;
# endif
    case T_Port:        *c++ = 'P'; break;
    case T_String:      *c++ = 'S'; break;
    case T_Returns:     *c++ = 'R'; break;
    default: Primitive_Error("bad id in foreign prototype");
    } /*switch*/
    arg++;
  }
  *c = (char)0;

  return cargs;
} /*forproto*/



/* primitive foreign-prototype - rtn argspec string for a foreign func */

Object Pforeignprototype(fun)
  Object fun;
{
  struct S_Primitive *prim;
  char *proto;

  Error_Tag = "foreign-prototype";
  Check_Type(fun,T_Primitive);

  prim = PRIM(fun);
  if (prim->disc != FOREIGN) 
    Primitive_Error("not a foreign function");
  proto = ZLforproto(prim->forfunargs);

  return Make_String(proto,str_len(proto));
} /*P_foreignprototype*/



/* Zforfuncall() - call a foreign function!
 * sparc version 
 */
#if Esparc
Object ZLforcall(name,func,proto,ac,av)
  char *name;
  function *func;
  unsigned char *proto;
  int ac;
  Object *av;
{
  register long *_REG1; /* data stacking pointer (must be in r1=%i5) */
  long _LOCAL1,_LOCAL2;	/* first,second local (fp) vars */

  int i;                /*fp-x0c now?*/
  Object arg;           /* -x10*/
  char *ptr;            /* -x14?*/
  bool err;             /* -x18?*/
  int4 tmp;             /* -x1c?*/
  double dtmp;		/* double tmp var @fp-0x20? */
  char *cs,*ds;
  int j;

# define formaxargs 20
  int intargs[formaxargs];

# define strheapsize 1024  
  char strheap[strheapsize];
  char *strptr = strheap;

  int padding[512];	      /* superstitous? make sure enough stack space */

  Error_Tag = "foreign function";

#if 0
  __asm__("ta 3"); /* from scm, flush register windows onto the stack.
                      is this necessary or helpful?? */
#endif

  if (ForeignTracep)
    printf("%s(%s) #args=%d\n",name,ZLforproto(proto),ac);
  else
    Ztrace(("Zforfuncall %s(%s) ac=%d\n",name,ZLforproto(proto),ac));

  if (ac > formaxargs) Primitive_Error("max of 20 args");

    /* loop: check argument types, convert int<->flt, stack args.
     * DO NOT DECLARE LOCAL VARIABLES IN BLOCKS BELOW
     * ALSO DO NOT CALL ANY SUBROUTINES
     * variables could occupy the same stack space where
     * the callees frame is being setup (this happened during debugging,
     * see the NONO comment below.
     * ALSO, cannot call any subroutines in this loop, because they
     * may well write over the sp+x44 outparameter assembly area.
     * OR, if calling a subroutine, save this area, and restore it
     * afterwards!
     * NOTE this code depends on T_Returns < T_Ends!!
     */

  /* because elk accesses an integer through a subroutine,
   * call this subroutine first before entering the argstacking routine.
   * For elk only.
   */

  for( i=0; i < ac; i++ ) {
    arg = av[i];        /* get supplied argument */
    if ((TYPE(arg) == T_Fixnum) || (TYPE(arg) == T_Bignum))
      intargs[i] = Get_Integer(arg);
  }

  err = FALSE;

  /* move data stacking pointer (future frame pointer) into _REG1 */
  __asm__("	add %sp,0x44,%i5");	/* i5 == REG1 */

  for( i=0; i < ac; i++ ) {

    if (!proto || (*proto >= T_Returns)) /* too many arguments given */
      { err = TRUE; break; }

    arg = av[i];        /* get supplied argument */

    if ((TYPE(arg)==*proto) || ((TYPE(arg)==T_Bignum) && (*proto==T_Fixnum)))
    {

      /* T_Farray is not a constant, so it is not part of switch below */
      if (*proto == T_Farray)
        *_REG1++ = (long)(FARRAY(arg)->data);

      else switch(*proto) {

      case T_Flonum:
        /****NO****[double d;]****NO****/
        dtmp = (double)FLONUM(arg)->val;
/*	if ((long)_REG1&0x7) _REG1++; align on 8.doesnt work-why not?*/
        *_REG1++ = *((long *)(&dtmp));
        *_REG1++ = *((long *)(&dtmp)+1);
        break;

      case T_Fixnum:
        tmp = intargs[i];
        *_REG1++ = *((long *)&(tmp));
        break;

      case T_Boolean:
        *_REG1++ = (arg == True) ? 1 : 0;
        break;

      case T_String:
        /* elk does not null-terminate strings on its heap,
         * so we must create a null-terminated copy, without
         * calling any subroutines.
         */
        if ((strptr + STRING(arg)->size) >= (strheap+strheapsize))
          Primitive_Error("string heap is full");
        for( cs=STRING(arg)->data,ds=strptr,j=STRING(arg)->size; j; j-- )
          *ds++ = *cs++;
        *ds = (char)0;
        *_REG1++ = (long)strptr;
        strptr += (STRING(arg)->size + 1);
        break;

      case T_Port:
        *_REG1++ = (long)PORT(arg)->file;
        break;

      default:
        Primitive_Error("bad type");
        break;

      } /*switch*/
    } /* TYPE(arg)==*proto */

 /* int<->flt type conversion */
    else {
      if ((*proto == T_Flonum)
          && ((TYPE(arg)==T_Fixnum) || (TYPE(arg)==T_Bignum)))
      {
        dtmp = (float)intargs[i];
        *_REG1++ = *((long *)&dtmp);
        *_REG1++ = *((long *)(&dtmp)+1);
      }
      else if ((*proto == T_Fixnum) && (TYPE(arg)==T_Flonum)) {
        tmp = (int)(double)FLONUM(arg)->val;
        *_REG1++ = *((long *)&(tmp));
      }
      else {
        err = TRUE; break;
      }
    } /*convert type*/

    proto++;
  } /*argstackloop*/


  if (err || (proto && (*proto < T_Returns))) {
    printf("(...%s): ",ZLforproto(proto)); /*&HERE*/
    Primitive_Error("incorrect arguments");
  }

    /* setup for calling.  this must appear before asms below */
    _REG1 = (long *)(int4) func;

    /* copy first 6 args from stack into registers
     * note could not think of any way to store directly into registers-
     * need a register-indirect(into register) move or store, which
     * doesnt exist.
     */
    __asm__("	ld [%sp+0x44],%o0	");
    __asm__("	ld [%sp+0x48],%o1	");
    __asm__("	ld [%sp+0x4c],%o2	");
    __asm__("	ld [%sp+0x50],%o3	");
    __asm__("	ld [%sp+0x54],%o4	");
    __asm__("	ld [%sp+0x58],%o5	");

    /* now do nothing in C until function is called */

    /* Invoke the function with the argument list.
     * appears that %g1 always holds the function ptr.
     */
    __asm__("	mov %i5,%g1	");
    __asm__("	call	.ptr_call,6	");
    __asm__("	nop	");  /* do not delete! */

    /* copy result into _LOCAL1 (immediately after call)
     * float result in %f0 on sparc, can leave it there.
     */
    __asm__("	st	%o0,[%fp+-0x4]    ");

    if (*proto++ == T_Returns) {

      if (*proto == T_Boolean)
        return( _LOCAL1 ? True : False );

      else if (*proto == T_Fixnum)
        return(Make_Integer(_LOCAL1));

      else if (*proto == T_String) {
        if (_LOCAL1 == 0) return(Null);
        /* note elk does not null-terminate strings on its heap */
        return(Make_String((char *)_LOCAL1, str_len((char *)_LOCAL1)));
      }

      else if (*proto == T_Flonum) {
        __asm__("	fdtos	%f0,%f0		");
        __asm__("	st	%f0,[%fp+-0x4]	");
        return Make_Reduced_Flonum( (double)*((float *)(&_LOCAL1)) );
      }

      else if (*proto == T_Port) {
        FILE *f = (FILE *)_LOCAL1;
        return Make_Port( (f->_flag&_IOREAD) ? P_INPUT : 0,
                         f, Make_String("foreign-port",12));
      }

      else Primitive_Error("bad return spec.");
    } /*get return value*/

  return Null;
} /*forfuncall*/

#else /*!sparc*/

# if Emips
#  include "FORMIPS.c"
# else
   :error 
#endif

#endif /*!Esparc*/


Object Pprargs(ac,av)
  int ac;
  Object av[];
{
  int i,type;
  Printf(Standard_Output_Port,"prargs: ");

  for( i=0; i < ac; i++ ) {
    type = TYPE(av[i]); 
    printf("type:%d ",type);
  } printf("\n");

  for( i=0; i < ac; i++ ) {
    Format(Standard_Output_Port,"~s ",3,1,av);
    av++;
  }
  Printf(Standard_Output_Port,"\n");
  return Null;
}

Object Pgetstr(ac,av)
  int ac;
  Object *av;
{
  char *s;
  Object str;

  if (ac != 1) Primitive_Error("Pgetstr #args");
  Check_Type(*av,T_String);
  str = *av;
  s = STRING(str)->data;
  printf("%s len=%d strlen=%d\n",s,STRING(str)->size,strlen(s));
  return Null;
}



/*%%%%%%%%%%%%%%%% init %%%%%%%%%%%%%%%%*/

void Init_foreign()
{
  Ztrace(("Init_foreign--\n"));
  if (T_Farray == 0) Panic("Init_Farray before Z");

  /* prelinked functions to test */
  Init_forfunctest();

  Define_Primitive(Pgetstr,"Zgetstr",0,MANY,VARARGS);
  Define_Primitive(Pprargs,"Zprargs",0,MANY,VARARGS);

/*not useful yet
  Define_Primitive(Zforfuncall,"foreign-call",0,MANY,VARARGS);
 */

  Define_Primitive(Pforeignprototype,"foreign-prototype",1,1,EVAL);
  Define_Primitive(P_foreigntrace,"foreign-trace!",1,1,EVAL);

  P_Provide(Intern("foreign"));

} /*Init_foreign*/
