/*
 * mc.c : the Mutt compiler
 *  Craig Durland 6/87, modified in late '91 for Mutt2
 */

/* 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.
 */

static char what[] = "@(#)Mutt2 compiler v2.1 2/2/92";
#define WHAT (&what[4])

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

extern address entrypt;		/* in code.c */
extern char *malloc(), *strcpy(), *new_ext(), *spoof(), *savestr();
extern int xtn, msize, omsize;
extern int32 atoN();
extern MuttCmd muttcmds[];
extern unsigned int codesize();
extern void doc(), dumpcode(), pilefile();

char ebuf[MAXSTRLEN+5], *muttfile = "", *include_list[10];
FILE *lstfile = NULL, *srcfile;
int errors = 0, warnings = 0, srcline = 0;

main(argc,argv) char *argv[];
{
  extern char *optarg, optltr;		/* in argh.c */
  extern int no_warn, no_gripe;		/* in supp.c */

  char buf[90], *ptr = NULL, *tfname = NULL;
  int j = 0, list = FALSE, x, stats = FALSE, quiet = FALSE;

  while ( (x = argh(argc,argv,"I:lst:vq:")) )
    switch (x)
    {
      case 2: ptr = optarg; break;
      case 1:
	switch (optltr)
	{
	  case 'I': include_list[j++] = optarg; break;
	  case 'l': list = TRUE;	break;
	  case 's': stats = TRUE;	break;
	  case 't': tfname = optarg;	break;
	  case 'v':
	    printf("%s copyright 1987-92 Craig Durland\n",WHAT);
	    exit(0);
	  case 'q':			/* quiet */
	    x = atoi(optarg);
	    quiet    = x & 1;
	    no_gripe = x & 2;
	    no_warn  = x & 4;
	    break;
	}
    }
  include_list[j] = NULL;

  if (!quiet) printf("%s\n",WHAT);

  if (ptr == NULL) { doc(); exit(1); }

  if (list)
  {
    new_ext(buf,ptr,".lst");
    if ((lstfile = fopen(buf,"w")) == NULL) bitch("Can't open list file.");
  }

  if (tfname) load_ext_token_table(tfname);	/* external token file */

  init_code_generater();

  new_ext(buf,ptr,".mut");
  pilefile(buf,FALSE); finishup();

  if (errors == 0) dumpcode(ptr);
  spoof(ebuf,"%d Errors.  %d Warnings. %u bytes of code.",
	errors,warnings,codesize());

  if (stats) dump_stats(stdout);
  if (!quiet) puts(ebuf);

  if (lstfile) { fprintf(lstfile,"\n%s\n",ebuf); fclose(lstfile); }
  exit(errors);
}

void doc()
{
  dump_doc(
  "MC2 [options] sourcefile[.MUT]",
  "options: ",
  " -I dir: An alternate directory for include files.  One dir per -I",
  " -l : Assembler output with source comments.  Put into sourcefile.LST",
  " -q <bits> : quiet some messages",
  " -s : Obscure compiler stats",
  " -t tokenfile : tokenfile.TOK contains X-tokens",
  " -v : Display the version of the compiler",
  "Compiled code is put into sourcefile.MCO",
  (char *)NULL);
}

extern char *catstrs();

	/* open a file, search path_list if necessary */
FILE *flopen(name,path_list,mode) char *name, *path_list[], *mode;
{
  char buf[300];
  FILE *fptr;
  int j;

  if ((fptr = fopen(name,mode))) return fptr;
  for (j = 0; path_list[j]; j++)
    if ((fptr = fopen(catstrs(buf,path_list[j],"/",name,(char *)NULL),mode)))
      return fptr;
  return NULL;
}

void pilefile(fname,search) char *fname;
{
  char fn[100], *ptr = muttfile;
  FILE *sf = srcfile;
  int sline = srcline;

  srcfile = search ? flopen(fname,include_list,"r") : fopen(fname,"r");
  if (srcfile == NULL) bitch(spoof(ebuf,"Can't open %s.",fname));
  muttfile = strcpy(fn,fname); srcline = 0;
  getsrc();	/* prime scan() */
  while (compile()) ;
  muttfile = ptr; srcline = sline;
  fclose(srcfile); srcfile = sf;
}

/* ******************************************************************** */
/* ********************* the compiler ********************************* */
/* ******************************************************************** */

extern address getpgm(), pcaddr();
extern int ddone_label, btv;
extern MMDatum *getconst();

char token[257], temp[257];
int breaklabel = -1, contlabel = -1;
unsigned int class = VOID;
MMDatum rv, *vtr;

compile()
{
  static int clevel = -1, indefun = FALSE;

  int l1, ldone, t,z;
  unsigned int lastclass;

  clevel++;
  lastclass = class; get_token();
  switch(class)
  {
    case SEOF:    clevel--; return FALSE;	/* hit EOF */
    case STRING:  gostr(RVSTR,token);	break;
    case NUMBER:  gonumx(atoN(token));	break;
    case BOOLEAN: gonum8(RVBOOL,btv);	break;
    case TOKEN:   genvar(token,FALSE);	break;
    case DELIMITER:
      switch (*token)
      {
	case '{':						 /* { ... } */
	  while (TRUE)
	  {
	    lookahead();
	    if (class == DELIMITER)
	      if (*token == '}') break;
	      else if (*token == '{') bitch("Can't nest pgms.");
	    class = lastclass; compile(); lastclass = class;
	  }
	  get_token();		/* suck up } */
	  class = lastclass; 
	  break;
	case '(':						 /* ( ... ) */
	  lookahead();
	  if (class == DELIMITER && *token == ')')	/* () */
		{ class = EMPTY; goto endexp; }
/*class = lastclass;*/
	  get_token();
	  switch (class)
	  {
	    case STRING:  gostr(RVSTR,token);  goto endexp;
	    case NUMBER:  gonumx(atoN(token)); goto endexp;
	    case BOOLEAN: gonum8(RVBOOL,btv);  goto endexp;
	    case TOKEN:	  break;
	    default:
	      bitch(spoof(ebuf,
		"Wanted token, string, number or boolean, got %s.",token));
	  }
	  if ((t = lookup(token,muttcmds,msize)) != -1)
	  {
	    class = lastclass;
	    switch (t)
	    {
	      case 64:					  /* (include file) */
		get_token();
		if (class != TOKEN && class != STRING)
		  bitch("include requires token or string.");
		clevel--; class = include(token); clevel++;
		goto done;	/* end of this line !!! sleaze */
	      case 23: class = comp_if(lastclass); break;	/* (if ...) */
	      case 5:  class = comp_while();  break;	     /* (while ...) */
	      case 76: class = comp_for();    break;	       /* (for ...) */
      	      case 1:  class = comp_cond();   break;	      /* (cond ...) */
	      case 4:  class = comp_switch(); break;	    /* (switch ...) */
	      case 2:					/* (defun name pgm) */
		if (clevel != 0) moan("Can't nest defuns.");
		indefun = TRUE;
		defun();
		indefun = FALSE; class = VOID;
		break;
	      case 8: case 6:		 /* (label label-name) (goto label) */
		get_token();
		if (class != TOKEN && class != STRING)
		  bitch("Label must be token or string.");
		if (!indefun)
		  moan("Labels and gotos can only be used inside defuns.");
		if ((z = get_named_label(token)) == -1)
			z = gen_named_label(token);
		if (t == 6) { gojmp(JMP,z); class = VOID; }	    /* goto */
		else						   /* label */
		{
		  stufflabel(z);
		  class = UNKNOWN;	/* can get here from anywhere */
		}
		break;
	      case 7:						 /* (break) */
		if (breaklabel == -1)
			{ moan("break not allowed here."); break; }
		gojmp(JMP,breaklabel); class = VOID;
		break;
	      case 71:					      /* (continue) */
		if (contlabel == -1)
			{ moan("continue not allowed here."); break; }
		gojmp(JMP,contlabel); class = VOID;
		break;
	      case  9:						  /* (done) */
		if (ddone_label == -1) genop(DONE); 
		else		       gojmp(JMP,ddone_label);
		class = VOID;
		break;
	      case 16: genop(HALT);   class = VOID;   break;	  /* (halt) */
	      case 29: genop(RVVOID); class = VOID;   break;   /* (novalue) */
	      case 42: genop(NARGS);  class = NUMBER; break;	 /* (nargs) */
	      case 43:						 /* (arg n) */
		compile(); type_check(NUMBER,0); genop(ARG); class = UNKNOWN;
	        break;
	      case 15:					   /* (push-args n) */
		compile(); type_check(NUMBER,0); genop(PUSHARGS);
		class = PUSHEDARGS;
	        break;
	      case 17:					  /* (push-arg exp) */
		compile(); genop(SHOVERV); class = PUSHEDARGS;
	        break;
	      case 0:					    /* (!= val val) */
		compile(); z = class;
		checkit("!=",STRING,BOOLEAN,NUMBER,0);
		pushpush(); compile();
		if (z != UNKNOWN) type_check(z,0);		/* yukk!!! */
		genop(CMP); genop(NOT); class = BOOLEAN;
		break;
	      case 12:				       /* (== val val ... ) */
		compile(); z = class;
		checkit("==",STRING,BOOLEAN,NUMBER,0);
		pushpush(); compile();
		if (z != UNKNOWN) type_check(z,0);	/* yukk!!! */
		if (!gaze_ahead(STRING,BOOLEAN,NUMBER,0))   /* (== val val) */
			genop(CMP);
		else			/* (== val val val [...]) */
		{
		  l1 = genlabel();
		  do
		  {
		    genop(DUP); genop(CMP);
		    if (!gaze_ahead(STRING,BOOLEAN,NUMBER,0)) break;
		    gojmp(JMPFALSE,l1); compile();
		    if (z != UNKNOWN) type_check(z,0);	/* yukk!!! */
		  } while (TRUE);
		  stufflabel(l1); genop(POP);
		}
		class = BOOLEAN;
		break;
	      case 21:			    /* (remove-elements object n z) */
		gonum16(PUSHTOKEN,REMOVE_ELS);
		compile(); checkit("remove-elements", LIST,STRING,0); /* !!!ick */
			/* !!!??? can't be a string constant! */
		  genop(SHOVERV);
		compile(); type_check(NUMBER,0); genop(SHOVERV);
		compile(); type_check(NUMBER,0); genop(SHOVERV);
		genop(DOOP); class = VOID;
		break;
	      case 18:		 /* (insert-object object n new-object ...) */
		gonum16(PUSHTOKEN,INSERT_OBJ);
		compile(); checkit("insert-object", LIST,STRING,0); /* !!!ick */
		  genop(SHOVERV);
		compile(); type_check(NUMBER,0); genop(SHOVERV);
		while (gaze_ahead(LIST,STRING,NUMBER,0))
			{ compile(); genop(SHOVERV); } 
		
		genop(DOOP);
		class = UNKNOWN;    /* !!!Not really - its STRING or LIST */
		break;
	      case 24:			      /* (extract-element object n) */
		gonum16(PUSHTOKEN,EXTRACT_EL);
		compile();
		checkit("extract-element", LIST,STRING,0); /* !!!ick */
			/* !!!??? can't be a string constant! */
		  genop(SHOVERV);
		compile(); type_check(NUMBER,0); genop(SHOVERV);
		genop(DOOP); class = UNKNOWN;
		break;
	      case 25:			   /* (extract-elements object n z) */
		gonum16(PUSHTOKEN,EXTRACT_ELS);
		compile();
		checkit("extract-elements", LIST,STRING,0); /* !!!ick */
			/* !!!??? can't be a string constant! */
		  genop(SHOVERV);
		compile(); type_check(NUMBER,0); genop(SHOVERV);
		compile(); type_check(NUMBER,0); genop(SHOVERV);
		genop(DOOP);
		class = UNKNOWN;    /* !!!Not really - its STRING or LIST */
		break;
	      case 19:				      /* (length-of object) */
	        compile();	/* get object - can be anything */
		genop(LEN_OF);
		class = NUMBER;
		break;
	      case 20:				/* (convert-to type object) */
		compile(); type_check(NUMBER,0); genop(SHOVERV);  /* type */
	        compile();	/* get object - can be anything */
		genop(CONVERT_TO);
		class = UNKNOWN; /* !!!I can (sometimes) figure out the type */
			/* !!! do some more checking here */
		break;
	      case 28:						   /* (not) */
		compile(); type_check(BOOLEAN,0); genop(NOT); class = BOOLEAN;
		break;
	      case 3:  opmath(ADD); break;		 /* (+ num num ...) */
	      case 67: opmath(SUB); break;		 /* (- num num ...) */
	      case 65: opmath(MUL); break;		 /* (* num num ...) */
	      case 69: opmath(DIV); break;		 /* (/ num num ...) */
	      case 63: opeq(ADD);   break;	  /* (+= var num [num ...]) */
	      case 68: opeq(SUB);   break;	  /* (-= var num [num ...]) */
	      case 66: opeq(MUL);   break;	  /* (*= var num [num ...]) */
	      case 70: opeq(DIV);   break;	  /* (/= var num [num ...]) */
	      case 11: case 14:		       /* (< num num), (>= num num) */
		compile(); z = class;
		checkit("< or >=",NUMBER,0); pushpush();
		compile();
		if (z != UNKNOWN) type_check(z,0);	/* yukk!!! */
		genop(LT);
		if (t == 14) genop(NOT);	/* (x >= y) == !(x < y) */
		class = BOOLEAN;
		break;
	      case 10: case 13:		       /* (<= num num), (> num num) */
		compile(); z = class;
		checkit("<= or >",NUMBER,0); pushpush();
		compile();
		if (z != UNKNOWN) type_check(z,0);	/* yukk!!! */
		genop(LTE);
		if (t == 13) genop(NOT);	/* (x > y) == !(x <= y) */
		class = BOOLEAN;
		break;
	      case 81:					   /* (or bool ...) */
		z = JMPTRUE;
	      andor:
		ldone = genlabel();
		while (TRUE)
		{
		  compile(); type_check(BOOLEAN,0);
		  lookahead(); if (class == DELIMITER && *token == ')') break;
		  gojmp(z,ldone);
		}
		stufflabel(ldone);
		class = BOOLEAN;
		break;
	      case 80: z = JMPFALSE; goto andor;     /* (and bool bool ...) */
	      case 26: genop(ASKUSER); break;		      /* (ask-user) */
	      case 78: floc(); break;			 /* (floc fcn-name) */
	      case 79: loc();  break;			  /* (loc var-name) */
	      case 72:					   /* (pointer var) */
		isvarok(clevel,class); pointer(indefun); class = lastclass;
		break;
	      case 73:				  /* (array type name subs) */
		isvarok(clevel,class);
		array(indefun ? LOCAL : GLOBAL,FALSE); class = lastclass;
		break;
	      case 62:				    /* (bool var [var ...]) */
		t = BOOLEAN;
	    defvar:
	        isvarok(clevel,class); vdeclare(t,indefun); class = lastclass;
		break;
	      case 75: t = INT8;  goto defvar;	    /* (byte var [var ...]) */
	      case 61: t = INT16; goto defvar; /* (small-int var [var ...]) */
	      case 31: t = INT32; goto defvar;	     /* (int var [var ...]) */
	      case 60:				/* (string name [name ...]) */
		t = STRING; goto defobject;
	      case 27:				  /* (list name [name ...]) */
		t = LIST;
	      defobject:
		isvarok(clevel,class); 
		do
		{
		  get_token();
		  if (class != TOKEN)
			bitch(spoof(ebuf,"%s is not a var name.",token));
		  z = addvar(token, t, 0, (indefun ? LOCAL : GLOBAL));
		  if (indefun) genobj(CREATE_OBJ, LOCAL, t, voffset(z));
		  lookahead();
		} while (class == TOKEN);

		class = lastclass;
		break;
	      case 77:			   /* (const name val name val ...) */
		do
		{
		  get_token();
		  if (class != TOKEN)
			bitch(spoof(ebuf,"%s is not a const name.",token));
		  strcpy(temp,token);
		  get_token(); rv.type = class;
		  switch (class)
		  {
		    case NUMBER:  rv.val.num = atoN(token); break;
		    case BOOLEAN: rv.val.num = btv; break;
		    case STRING:  rv.val.str = savestr(token); break;
		    case TOKEN:
		      if (vtr = getconst(token)) { rv = *vtr; break; }
		      /* else fall though and error */
		    default:
		      moan(spoof(ebuf,"Invalid const type: %s",token));
		      rv.type = BOOLEAN;
		  }
		  add_const(temp,&rv);
		  lookahead();
		} while (class == TOKEN);
		class = lastclass;
		break;
	      default: moan(spoof(ebuf,"Compiler is confused by %s.",token));
	    }
	    goto endexp;
	  }
	  if (other_Mutt_cmd(token)) goto endexp;
	  if (varcompile(TRUE)) goto endexp;
	  if ((t = getpgm(token)) != NIL) goaddr(PUSHADDR,t,token);
	  else 
	    if (-1 != (t = lookup_ext_token_by_name(token))) gonum16(PUSHXT,t);
	    else gostr(PUSHNAME,token);
	  vargs(); genop(DOOP); class = UNKNOWN;
  endexp:
	  lastclass = class; get_token();
	  if (class != DELIMITER || *token != ')')
		bitch(spoof(ebuf,"Wanted ) got %s.",token));
	  class = lastclass;
	  break;
	default:
	  bitch(spoof(ebuf,"Invalid delimiter: %s  ?not enough args?",token));
      }
      break;
    default: bitch(spoof(ebuf,"I don't reconize %s!",token));
  }
done:
  clevel--;
  return TRUE;
}