/*
 *  -*- c -*-
 * Copyright (C) 1991-1999 Erik Schoenfelder (schoenfr@web.de)
 *
 * This file is part of NASE A60.
 * 
 * NASE A60 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; either version 2, or (at your option)
 * any later version.
 *
 * NASE A60 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 NASE A60; see the file COPYING.  If not, write to the Free
 * Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * a60-mkc.inc:						oct '90
 *
 * Header for use in automagically generated c-code from NASE A60.
 * Especially here are the routines about output formatting are
 * declared. (Field width, etc.)
 */

#ifndef NOT_FOR_MKC_C
/*
 * the large following part is for use in mkc output.
 */
#include <stdio.h>
#include <math.h>

#ifdef __STDC__
#include <stdarg.h>
#else /* ! __STDC__ */
#include <varargs.h>
#endif /* ! __STDC__ */

/*
 * substitution for the output routines:
 */

#define B_OUTSTR(i,str)	b_outstr ((long) i, (char *) str)
#define B_OUTREAL(i,x)	b_outreal ((long) i, (double) x)
#define B_OUTINT(i,j)	b_outint ((long) i, (long) j)
#define B_OUTSYMB(ii,s,j) b_outsym ((long) ii, (char *) s, (long) j)
#define B_INSYMB(ii,s,j) (j = b_insym ((long) ii, (char *) s))
#define B_INREAL(ii,x) (x = b_inreal ((long) ii))
#define B_ININTEGER(ii,x) (x = b_ininteger ((long) ii))
#define B_PRINT(xx,f1,f2) b_print ((double) xx, (long) f1, (long) f2)
#define B_LENGTH(S)	b_length ((char *) S)
#define B_VPRINT	printf
#define B_SIGN		b_sign
#define B_ABS		b_abs
#define B_RAND		b_rand

#define LONG_MIN	(-LONG_MAX-1)
#define LONG_MAX	2147483647L

#define RVALTRUNC(x)	(((x) > (double) LONG_MAX) \
	 ? LONG_MAX : ((x) < (double) LONG_MIN) \
	 ? LONG_MIN : (long) (x))

#define B_ENTIER(x) (b_entier ((double) x))


/*
 * Memory allocation:
 */

#define NTALLOC(T,N) \
	((T *) malloc ((unsigned) (N * sizeof(T))))

extern char *malloc ();


/*
 * array description:
 */

#define MAXBOUND	16

typedef struct {
    long bnd [MAXBOUND][3];
    long siz, dim;
    union { double *d; long *l; } data;
} arrdesc;

#define DUP_DATA(D, SIZ, T) \
	{ char * new = (char *) NTALLOC (T, SIZ); \
	  int i; for (i=0; i<sizeof(T)*(SIZ); i++) \
		  new[i] = ((char *) (D))[i]; \
	  D = (T *) new; }

/*
 * access to the array elements:
 */

/* VARARGS */
static int
#ifdef __STDC__
gidx (arrdesc *ad, ...)
#else
gidx (ad, va_alist)
arrdesc *ad;
va_dcl
#endif
{
	va_list pvar;
	int i, idx = 0;
	long val;
	
#ifdef __STDC__
	va_start (pvar, ad);
#else
	va_start (pvar);
#endif

	for (i=0; i<ad->dim; i++) {

		val = va_arg(pvar, long);
		idx += (val - ad->bnd [i][0]) * ad->bnd [i][2];
	}

#ifdef __STDC__
	va_start (pvar, ad);
#else
	va_end (pvar);
#endif

	return idx;
}

#else

#endif /* NOT_FOR_MKC_C */


/* hmm: maybe not avail - fix me: */
#ifdef HAVE_ERRNO_H
#include <errno.h>
#else
/* uhhh - this must not work... - fix me */
static int errno = -9999;
#endif

/*
 * this is for both mkc and the interpreter:
 */

#ifndef M_E
#define	M_E	((double) 2.718281828459045235)
#endif

#ifndef M_PI
#define	M_PI	((double) 3.141592653589793238)
#endif

#define B_PI()	M_PI

/*
 * runtime error:
 *
 * print runtime error message and exit with exit code 2.
 */
static char err_msg [256];			/* message buffer */

static void
runtime_error (char *msg)
{
  fprintf (stderr, "\nRUNTIME Error: ");
  fprintf (stderr, "%s\n", msg);
  fflush (stderr);

  exit (2);
}


/*
 * the input/output channels are stored here:
 *
 * channels are mapped to FILE *in or FILE *out:
 */
#define MAXIOFILES	16
static FILE *iofiles [MAXIOFILES];
static int io_flag_out [MAXIOFILES];

/*
 * channel helper:
 */
static FILE *get_chan (long chan, int flag_out)
{
  int i;
  char* fname;
  char fname_env [8];			/* buffer for ``FILE_%2d'' */

  if (! io_flag_out [1]) {

    /* initialize known directions: */
    io_flag_out [1] = io_flag_out [2] = 1;     /* stdout and stderr */
    
    for (i = 3; i < MAXIOFILES; i++) {
      /* initialize unknown directions: */
      io_flag_out [i] = -1;
    }
  }

  if (chan < 0 || chan >= MAXIOFILES) {
    snprintf (err_msg, sizeof(err_msg), 
	      "invalid channel value (channel=%ld)", chan);
    runtime_error (err_msg);
    /* not reached */
  } 

  if (io_flag_out [chan] >= 0) {
    /*
     * check read / write mode of an already opened channel:
     */
    if (io_flag_out [chan] != flag_out) {
      snprintf (err_msg, sizeof(err_msg), 
		"invalid %s attempt to %s opened channel (channel=%ld)",
		flag_out ? "write" : "read",
		flag_out ? "read" : "write", chan);
      runtime_error (err_msg);
      /* not reached */
    }
  } 

  /*
   * predefined channels:
   */
  if (chan == 0) {
    return stdin;
  } else if (chan == 1) {
    return stdout;
  } else if (chan == 2) {
    return stderr;
  }

  /*
   * via environment or statically named channels (FILE_n):
   */
  if (iofiles [chan]) {
    return iofiles [chan];
  }

  /*
   * get the FILE_n filename from environment, or use the string itself:
   */
  snprintf (fname_env, 8, "FILE_%ld", chan);
  
  if (! (fname = getenv (fname_env))) {
    fname = fname_env;
  }
  
  if (! (iofiles [chan] = fopen (fname, flag_out ? "w" : "r"))) {
    snprintf (err_msg, sizeof(err_msg), 
	      "cannot open file ``%s'' for %s: errno %d\n",
	      fname, flag_out ? "writing" : "reading", errno);
    runtime_error (err_msg);
    /* not reached */
  }

  io_flag_out [chan] = flag_out;

  return iofiles [chan];
}



/*
 * general defines and functions:
 */

#define sign(x) ((x) > 0 ? 1 : (x) < 0 ? (-1) : 0)

#ifndef NOT_FOR_MKC_C
static double
b_abs (x)
double x;
{
	return (x < 0) ? -x : x ;
}
#endif /* ! NOT_FOR_MKC_C */


static double
b_sign (x)
double x;
{
	return (x < 0) ? -1 : (x > 0) ? 1 : 0 ;
}

static long
b_entier (x)
double x;
{
	long val;

	if (x < 0) {
		val = - (RVALTRUNC(-x));
		if ((double) val != x)
			val -= 1;
	}
	else
		val = RVALTRUNC(x);

	return val;
}


/*
 * create a random number between 0 and 1;
 * ugly ? don't care. only doit.
 */

static double
b_rand ()
{
	static int first_time = 1;
	static double rnum;
#ifndef NO_TIME_FUNC
	extern long time ();
#endif

	if (first_time) {
		first_time = 0;
#ifdef NO_TIME_FUNC
		/* sorry folks */
		rnum = 1.0;
#else
		rnum = time ((long) 0) & 0xffffffl;
#endif
	}

	/* use anywhat ... (change and truncate) */

	rnum = rnum * M_PI + M_E;
	rnum -= (long) rnum;

#ifdef NOT_FOR_MKC_C
	if (rnum >= 1.0)
		xabort ("INTERNAL: r_rand: rand >= 1.0 !");
#endif

	return rnum;
}

static void
b_outreal (chan, val)
long chan;
double val;
{
	char tmp[80];
	int rc;
	FILE *out;

	/* choose what format ??? */
#ifdef AMIGA
	/* bad exactness (sp?) of double arithmetic */
	sprintf (tmp, " %.8g ", val);
#else

	/* 
	 * printf ("%g",  - 0.0) gives: -0
	 * (at least for sunos and linux...)
	 * i like to prevent this:
	 */

	if (val == 0.0)
	  strcpy (tmp, " 0 ");
	else
	  sprintf (tmp, " %.12g ", val);
#endif
	
	if (! (out = get_chan (chan, 1))) {
	  /* return on error: */
	  return;
	}
	
	rc = fprintf (out, "%s", tmp);
	fflush (out);

	if (rc < 0) {
	  snprintf (err_msg, sizeof(err_msg), 
		    "error writing to channel %ld: errno %d\n",
		    chan, errno);
	  runtime_error (err_msg);
	  /* not reached */
	}
}

static void
b_outint (chan, val)
long chan, val;
{
	char tmp[80];
	int rc;
	FILE *out;

	/*
	 * format the integer (check about 0 helps to aviod 
	 * output of -0): 
	 */	
	if (! val)
	  strcpy (tmp, " 0 ");
	else
	  sprintf (tmp, " %ld ", val);

	if (! (out = get_chan (chan, 1))) {
	  /* return on error: */
	  return;
	}
	
	rc = fprintf (out, "%s", tmp);
	fflush (out);

	if (rc <= 0) {
	  snprintf (err_msg, sizeof(err_msg), 
		    "error writing ``%s'' to channel %ld: errno %d\n",
		    tmp, chan, errno);
	  runtime_error (err_msg);
	  /* not reached */
	}
}

static void
b_outstr (chan, val)
long chan;
char *val;
{
	int rc;
	FILE *out;

	if (! (out = get_chan (chan, 1))) {
	  /* return on error: */
	  return;
	}

	rc = fprintf (out, "%s", val ? val : "");
	fflush (out);

	if (rc < 0) {
	  snprintf (err_msg, sizeof(err_msg), 
		    "error writing ``%s'' to channel %ld: errno %d\n",
		    val ? val : "", chan, errno);
	  runtime_error (err_msg);
	  /* not reached */
	}
}

static void
b_outsym (chan, val, idx)
long chan;
char *val;
long idx;
{
	char ctmp[2];
	int rc;
	FILE *out;

	if (! val)
		val = "";
	
	if (idx < 0) {
		ctmp[0] = -idx;
	}
	else {
		if (idx < strlen (val))
			ctmp[0] = val[idx];
		else
			ctmp[0] = 0;
	}
	ctmp[1] = 0;

	val = ctmp;

	if (! (out = get_chan (chan, 1))) {
	  /* return on error: */
	  return;
	}

	rc = fprintf (out, "%s", val);
	fflush (out);

	if (rc < 0) {
	  snprintf (err_msg, sizeof(err_msg), 
		    "error writing ``%s'' to channel %ld: errno %d\n",
		    val, chan, errno);
	  runtime_error (err_msg);
	  /* not reached */
	}
}


static long
b_insym (chan, str)
long chan;
char *str;
{
	long idx, val;
	FILE *in;

	if (! (in = get_chan (chan, 0))) {
	  /* return 0 on error: */
	  return (long) 0;
	}

	val = fgetc (in);

	if (val == EOF) {
	  snprintf (err_msg, sizeof(err_msg), 
		    "error reading symbol from channel %ld: errno %d\n",
		    chan, errno);
	  runtime_error (err_msg);
	  /* not reached */
	}

	for (idx = 0; str && *str && *str != val; str++, idx++);

	if (! str || ! *str)
		return -val;
	else
		return idx;
}


static double
b_inreal (chan)
long chan;
{
	double val;
	char *fmt;
	int rc;
	FILE *in;

#ifdef pyr
	/* don't know why... */
        fmt = "%lf";
#else
	fmt = "%le";
#endif

	if (! (in = get_chan (chan, 0))) {
	  /* return 0 on error: */
	  return (double) 0;
	}

	rc = fscanf (in, fmt, &val);

	if (rc != 1) {
	  snprintf (err_msg, sizeof(err_msg), 
		    "error reading real value from channel %ld: errno %d\n",
		    chan, errno);
	  runtime_error (err_msg);
	  /* not reached */
	}
	
	return val;
}


static long
b_ininteger (chan)
long chan;
{
	long val;
	char *fmt;
	int rc;
	FILE *in;

	fmt = "%ld";

	if (! (in = get_chan (chan, 0))) {
	  /* return 0 on error: */
	  return (long) 0;
	}

	if ((rc = fscanf (in, fmt, &val)) != 1) {
	  snprintf (err_msg, sizeof(err_msg), 
		    "error reading integer value from channel %ld: errno %d\n",
		    chan, errno);
	  runtime_error (err_msg);
	  /* not reached */
	}

	return val;
}


/*
 * print the real value, using the format given by f1 and f2. here the
 * c-printf format is used...
 * the real number is followd by two spaces.
 */

static void
b_print (val, f1, f2)
double val;
long f1, f2;
{
	char fmt [20];

	if (f1 <= 0 && f2 <= 0)
		sprintf (fmt, "%%g");
	else {
		sprintf (fmt, "%%");
		if (f1 > 0)
			sprintf (fmt+strlen(fmt), "%ld", f1);
		sprintf (fmt+strlen(fmt), ".");
		if (f2 > 0)
			sprintf (fmt+strlen(fmt), "%ld", f2);
		sprintf (fmt+strlen(fmt), "g  ");
	}
	
	fprintf (stdout, fmt, val);
	fflush (stdout);
}


/*
 * return the length of the given string.
 */

static long
b_length (s)
char *s;
{
	return (s) ? strlen (s) : 0;
}

/* end of a60-mkc.inc */
