/* 
 * comp.c : odds and ends of the compiler
 * Revision History:
 *   3/92 : Changed all the vararg stuff to work with stdargs.
 */
 
/* Copyright 1990, 1991, 1992 Craig Durland
 *   Distributed under the terms of the GNU General Public License.
 *   Distributed "as is", without warranties of any kind, but comments,
 *     suggestions and bug reports are welcome.
 */

#include <stdio.h>
#include <os.h>
#include "mc.h"
#include "opcode.h"
#include "mm.h"

#ifdef __STDC__

#include <stdarg.h>
#define VA_START va_start

#else	/* __STDC__ */

#include <varargs.h>
#define VA_START(a,b) va_start(a)

#endif

extern address getpgm(), pgmaddr(), pcaddr();
extern char ebuf[], token[], temp[],
  *pgmname(), *savestr(), *spoof(), *strcpy(), *typename();
extern int btv, xtn, msize, omsize, moders;
extern unsigned int class, vtype(), vctype(), mmtype();
extern int32 atoN();
extern MMDatum *getconst();
extern MuttCmd muttcmds[], modifiers[];
extern oMuttCmd omuttcmds[], *olookup();
extern VBlob *proto_name();

int ddone_label = -1;		/* for defun */

/* ******************************************************************** */
/* *************** Type Checking ************************************** */
/* ******************************************************************** */

static void typerr(msg,type,ap) char *msg; unsigned int type; va_list ap;
{
  register unsigned int t;

  spoof(ebuf,"%sexpected %s",msg,typename(type));
  t = va_arg(ap,unsigned int);
  while (type = t)
  {
    t = va_arg(ap,unsigned int);
    strcat(ebuf, t ? ", " : " or ");
    strcat(ebuf,typename(type));
  }
  strcat(ebuf,".");
  moan(ebuf);
}

  /* Check to see if class matches any of a list of types.
   * Called:  cmp_types(type,...,0);
   * Returns: 0 (class is UNKNOWN), 1 (class matches), 2 (no match).
   */
static int cmp_types(type, ap) unsigned int type; va_list ap;
{
  if (class == UNKNOWN) return 0;

  for (; type; type = va_arg(ap,unsigned int))
  {
    if (class == type ||
        (mmtype(type) == NUMBER && mmtype(class) == NUMBER) ||
        ((class & POINTER) && (type & POINTER)))
	return 1;
  }
  return 2;
}

    /* Zero terminated list of ONE type (eg type_check(NUMBER,0)).
     * More than one type will mess things up.
     * Written in this strange way so I can call cmp_types().
     */
/*VARARGS1*/
#ifdef __STDC__
void type_check(unsigned int type, ...)
#else
void type_check(type, va_alist) unsigned int type; va_dcl
#endif
{
  int n;
  va_list ap;

  VA_START(ap,type);
  n = cmp_types(type, ap);

  switch(n)
  {
    case 0: gonum8(TYPECHECK,mmtype(type)); break;
    case 2: VA_START(ap,type); typerr("Type mismatch: ",type,ap); break;
  }

  va_end(ap);
  class = type;
}

/*VARARGS2*/
#ifdef __STDC__
void checkit(char *msg, unsigned int type, ...)
#else
void checkit(msg, type, va_alist)
  char *msg; unsigned int type; va_dcl	/* zero terminated list of types */
#endif
{
  char buf[90];
  va_list ap;

  VA_START(ap,type);
  if (cmp_types(type, ap) == 2)
  {
    VA_START(ap,type);
    typerr(spoof(buf,"%s: Invalid type: ",msg), type,ap);
  }
  va_end(ap);
}

	/* returns TRUE if conditions met */
/*VARARGS1*/
#ifdef __STDC__
gaze_ahead(unsigned int tipe, ...)
#else
gaze_ahead(tipe, va_alist)
  unsigned int tipe; va_dcl		/* zero terminated list of types */
#endif
{
  int t;
  unsigned int type;
  MMDatum *rv;
  va_list ap;
  VBlob *blob;

  lookahead();
  if (class == DELIMITER)
    if (*token == '(' || *token == '{') return TRUE;
    else return FALSE;

  VA_START(ap,tipe);
  if (class == TOKEN)	/* check for var or const */
  {
    for (type = tipe; type; type = va_arg(ap,unsigned int))
      if (type == TOKEN) goto ok;		/* class == type */
    if (blob = proto_name(token)) class = blob->type;	/* a prototype */
    else
      if ((t = getvar(token)) != -1)		/* local or global var */
		class = vctype(t);
      else
        if (rv = getconst(token)) class = rv->type;	/* constant */
  }

  VA_START(ap, tipe);
  if (cmp_types(tipe,ap) == 2)
    { VA_START(ap, tipe); typerr("Invalid type: ",tipe,ap); }

ok:
  va_end(ap);
  return TRUE;
}

/* ******************************************************************** */
/* ******************************************************************** */
/* ******************************************************************** */

    /* Generate the minimum code needed to push an arg of type class */
void pushpush()
{
  switch (class)
  {
    case EMPTY:
    case PUSHEDARGS:	return;		/* nothing to push */

    case STRING:
/*    case FCNPTR:	/* ??? am I sure about fcnptr?? */
    case UNKNOWN: genop(PUSHRV); break;

    default: genop(SHOVERV);
  }
}

void vargs()	/* compile args and push them */
{
  while (TRUE)
  {
    lookahead();
    if (class == DELIMITER)
      if (*token=='(' || *token=='{') { compile(); pushpush(); continue; }
      else
        if (*token == ')') break;
	else bitch("vargs is confused");
    switch (class)
    {
      case STRING:  gostr(RVSTR,token);  genop(SHOVERV); break;
      case NUMBER:  gonumx(atoN(token)); genop(SHOVERV); break;
      case BOOLEAN: gonum8(RVBOOL,btv);  genop(SHOVERV); break;
      case TOKEN:   genvar(token,FALSE); genop(SHOVERV); break;
      default: bitch(spoof(ebuf,"Invalid parameter: %s",token));
    }
    get_token();	/* suck up token we just compiled */
  }
}

void opmath(opcode)		/* stuff like (+ 1 2 3) */
{
  compile(); type_check(NUMBER,0);
  do { genop(SHOVERV); compile(); type_check(NUMBER,0); genop(opcode); }
  while (gaze_ahead(NUMBER,0));
  class = NUMBER;
}

void opeq(opcode)	/* stuff like (+= var 1 2 3) */
{
  int t, scope, offset = 0;
  unsigned int type = 0;

  get_token();
  if (class != TOKEN)
  {
    spoof(ebuf,"%s is not a var name.",token);
    if (class == DELIMITER) bitch(ebuf); else moan(ebuf);
  }
  else
    if ((t = getvar(token)) == -1)
      moan(spoof(ebuf,"Var %s not created yet.",token));
    else
    {
      if (vctype(t) != NUMBER)
	moan(spoof(ebuf,"Var %s needs to be numeric.",token));
      type = vtype(t); scope = vscope(t); offset = voffset(t);
    }

  go2num((scope == LOCAL ? GETLVAR : GETGVAR),type,offset); 

  do { genop(SHOVERV); compile(); type_check(NUMBER,0); genop(opcode); }
  while (gaze_ahead(NUMBER,0));

  go2num((scope == LOCAL ? SETLVAR : SETGVAR),type,offset);

  class = NUMBER;
}

extern int ntharg;	/* in vcomp.c */

    /* Define a function
     * Syntax:
     *   (defun pgm-name [(arg list)] [modifiers] pgm [another fcn])
     *     pgm-name: TOKEN or STRING: name of the function being defined
     *     arg-list:  a list of the function parameters.  Used to to a give
     *       name to (arg n).
     *       (type name ...)
     *       (array type name [dims] ...)
     *       (pointer type name ...)
     *       (name ...)		Unknown type: same as (arg n)
     *     modifiers:  stuff like HIDDEN, etc.
     *     pgm:  the actual function code.
     *     If another pgm-name follows the end of pgm, another function is
     *       defined.
     */
void defun()
{
  int t, pgm, dim[MAXDIM];
  unsigned int type;

  do
  {
		/* Get the name of the function */
    get_token();
    if (class != TOKEN && class != STRING)
	  bitch("Function names are tokens or strings.");
    pgm = addpgm(token);
/*strcpy(temp,token);	/* save pgm name */

	/* Parse arg-list */
    ntharg = 0; addproto("pgm-name");
    while (TRUE)
    {
      lookahead();
      if (class != DELIMITER || *token != '(') break;
      get_token(); lookahead(); t = -2;
      if (class == TOKEN)
	if ((t = lookup(token,muttcmds,msize)) != -1) get_token();
      switch (t)
      {
	default: moan(spoof(ebuf,"%s is not an arg type.",token));
	case -1: type = UNKNOWN; goto defvar; /* unknown token => untyped var */
	case 62:					/* bool */
	  type = BOOLEAN;
      defvar:
	  do
	  {
	    get_token();
	    if (class != TOKEN)
		bitch(spoof(ebuf,"%s is not a var name.",token));
	    moreproto(token,ntharg++,type,0,dim);
	    lookahead();
	  } while (class == TOKEN);
	  break;
	case 61: case 75: case 31:	/* byte, int, INT all are NUMBER */
		type = NUMBER; goto defvar;
	case 60: type = STRING; goto defvar;		/* string */
	case 27: type = LIST; goto defvar;		/* list */
	case 73: array(LOCAL,TRUE); break;		/* array */
	case 72:	/* (pointer { bool byte int INT defun } name ...) */
	  get_token(); t = -2;
	  if (class == TOKEN) t = lookup(token,muttcmds,msize);
	  switch (t)
	  {
	    default: moan(spoof(ebuf,"%s is not a pointer type.",token));
	    case -1: type = UNKNOWN; goto defvar;
	    case 62: type = POINTER | BOOLEAN;	goto defvar;	/* bool */
	    case 75: type = POINTER | INT8;	goto defvar;	/* byte */
	    case 61: type = POINTER | INT16;	goto defvar;	/* int */
	    case 31: type = POINTER | INT32;	goto defvar;	/* INT */
	    case 2:  type = FCNPTR;		goto defvar;	/* defun */
	  }
      }
      get_token();
      if (class != DELIMITER || *token!=')') bitch("Bad arg list.");
    }

			/* suck up function modifiers */
    while (lookahead(), class == TOKEN)
    {
      get_token();
      if ((t = lookup(token,modifiers,moders)) != -1) modpgm(pgm,t);
      else moan(spoof(ebuf,"%s is an invalid pgm modifer.",token));
    }

		/* Compile the code */
    if (class != DELIMITER || *token != '{') bitch("Pgms must start with a {");
    class = VAROK; compile();
    genop(DONE);

		/* Clean up and get ready for another defun */
    lookahead();
    reset_vars(); killproto(); reset_named_labels();
  } while (class == TOKEN || class == STRING);
}


    /* floc:  function location (address).
     * Syntax:
     *   (floc <STRING | TOKEN | string-var> [args])
     */
void floc()
{
  int t;
  oMuttCmd *ptr;

  lookahead();
  if (class == TOKEN)		/* (floc foo) */
  {
    if ((ptr = olookup(token,omuttcmds,omsize)))
	genfp(OPTOKEN, ptr->token, token);
    else
      if ((t = getpgm(token)) != NIL) genfa(t,token);
      else 
	if (-1 != (t = lookup_ext_token_by_name(token)))
		genfp(OPXTOKEN,t,token);
	else genfa((address)NIL, token);	/* resolve it later */
    get_token();
  }
  else				/* (floc "foo"), (floc (...)) */
    { compile(); type_check(STRING,0); genfp(OPNAME,0,""); }

/* !!!??? how come (string foo) (floc (foo)()) works but (floc foo()) don't?
 */
  lookahead();
  if (class == DELIMITER && *token == ')') class = FCNPTR;
  else		/* (floc name args) => gen fcn call */
  {
     genop(PUSHRV);	/* push will set op stack for fcn call */
     vargs();		/* compile fcn args */
     genop(DOOP);	/* call the fcn */
     class = UNKNOWN;
  }
}

    /* loc:  variable location (address)
     * Syntax:  (loc TOKEN) where token is the name of a variable.
     */
void loc()
{
  int t, scope, offset;

  lookahead();
  if (class == TOKEN)
  {
    get_token();
    if ((t = getvar(token)) != -1)	/* (loc var-name) */
    {
if (vtype(t) == STRING || vtype(t) == LIST)
moan(spoof(ebuf,"I need to think about (loc STRING) & (loc LIST): %s",token));
      scope = vscope(t); offset = voffset(t);
      gonum16((scope == LOCAL ? RVLBASE : RVGBASE),offset);
      class = POINTER | vtype(t);
    }
    else
    {
      moan("loc expects TOKEN.");
      compile(); class = POINTER | BOOLEAN;
    }
  }
}

other_Mutt_cmd(name) char *name;
{
  oMuttCmd *ptr;

  if ((ptr = olookup(name,omuttcmds,omsize)))
  {
    gonum16(PUSHTOKEN,ptr->token);
    vargs(); genop(DOOP);
    class = ptr->class;
    return TRUE;
  }
  return FALSE;
}

    /* Generate code to create the global objects and call all the MAIN
     *   functions.
     * Notes:
     *   If no MAINs and no global objects, this is a no-op but I need an
     *     entry point (by definition) so just put a (done) at the entry
     *     point.
     *   The init code is put after all other code.
     */
void finishup()
{
  extern address entrypt;		/* in code.c */

  int n;

  entrypt = pcaddr();			/* Address of init code */

  for (n = 0; (n = get_global_object(n)) != -1; n++)
	genobj(CREATE_OBJ, GLOBAL, vtype(n), voffset(n));

  for (n = 0; (n = get_main(n)) != -1; n++)
	{ goaddr(PUSHADDR, pgmaddr(n), pgmname(n)); genop(DOOP); }

  genop(DONE);				/* terminate init code */
}