/* 
*	The body prefix file of the voc(jet backend) runtime system, Version 1.0
*
*	Copyright (c) Software Templ, 1994, 1995
*
*	Module SYSTEM is subject to change any time without prior notification.
*	Software Templ disclaims all warranties with regard to module SYSTEM,
*	in particular shall Software Templ not be liable for any damage resulting
*	from inappropriate use or modification of module SYSTEM.
*
*	Version 1.1  jt, 24.11.95  fixes for correct pointer arithmetic on Cray computers
*	jt 31.1.2007  ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/

#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif

extern void *malloc(long size);
extern void exit(int status);

void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt;	/* x in HALT(x) */
LONGINT SYSTEM_assert;	/* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm;	/* adr of main proc stack frame, used for stack collection */

#define Lock	SYSTEM_lock++
#define Unlock	SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)


static void SYSTEM_InitHeap();
void *SYSTEM__init();

void SYSTEM_INIT(argc, argvadr)
	int argc; long argvadr;
{
	SYSTEM_mainfrm = argvadr;
	SYSTEM_argc = argc;
	SYSTEM_argv = *(long*)argvadr;
	SYSTEM_InitHeap();
	SYSTEM_halt = -128;
	SYSTEM__init();
}

void SYSTEM_FINI()
{
	SYSTEM_FINALL();
}

long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}

void SYSTEM_INHERIT(t, t0)
	long *t, *t0;
{
	t -= __TPROC0OFF;
	t0 -= __TPROC0OFF;
	while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}

void SYSTEM_ENUMP(adr, n, P)
	long *adr;
	long n;
	void (*P)();
{
	while (n > 0) {P(*adr); adr++; n--;}
}

void SYSTEM_ENUMR(adr, typ, size, n, P)
	char *adr;
	long *typ, size, n;
	void (*P)();
{
	long *t, off;
	typ++;
	while (n > 0) {
		t = typ;
		off = *t;
		while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
		adr += size; n--;
	}
}

long SYSTEM_DIV(x, y)
	unsigned long x, y;
{  if ((long) x >= 0) return (x / y);
	else return -((y - 1 - x) / y);
}

long SYSTEM_MOD(x, y)
	unsigned long x, y;
{ unsigned long m;
	if ((long) x >= 0) return (x % y);
	else { m = (-x) % y;
		if (m != 0) return (y - m); else return 0;
	}
}

long SYSTEM_ENTIER(x)
	double x;
{
	long y;
	if (x >= 0)
		return (long)x;
	else {
		y = (long)x;
		if (y <= x) return y; else return y - 1;
	}
}

void SYSTEM_HALT(n)
	int n;
{
	SYSTEM_halt = n;
	if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
	exit(n);
}

#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
	long *typ, elemsz;
	int elemalgn, nofdim, nofdyn;
	va_dcl
#endif
{
	long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
	va_list ap;
#ifdef __STDC__
	va_start(ap, nofdyn);
#else
	va_start(ap);
#endif
	nofelems = 1;
	while (nofdim > 0) {
		nofelems = nofelems * va_arg(ap, long); nofdim--;
		if (nofelems <= 0) __HALT(-20);
	}
	va_end(ap);
	dataoff = nofdyn * sizeof(long);
	if (elemalgn > sizeof(long)) {
		n = dataoff % elemalgn;
		if (n != 0) dataoff += elemalgn - n;
	}
	size = dataoff + nofelems * elemsz;
	Lock;
	if (typ == NIL) {
		/* element typ does not contain pointers */
		x = SYSTEM_NEWBLK(size);
	}
	else if (typ == POINTER__typ) {
		/* element type is a pointer */
		x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
		p = (long*)x[-1];
		p[-nofelems] = *p;	/* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
		p -= nofelems - 1; n = 1;	/* n =1 for skipping the size field */
		while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
		*p = - (nofelems + 1) * sizeof(long);	/* sentinel */
		x[-1] -= nofelems * sizeof(long);
	}
	else {
		/* element type is a record that contains pointers */
		ptab = typ + 1; nofptrs = 0;
		while (ptab[nofptrs] >= 0) {nofptrs++;}	/* number of pointers per element */
		nptr = nofelems * nofptrs;	/* total number of pointers */
		x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
		p = (long*)x[- 1];
		p[-nptr] = *p;	/* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
		p -= nptr - 1; n = 0; off = dataoff;
		while (n < nofelems) {i = 0;
			while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
			off += elemsz; n++;
		}
		*p = - (nptr + 1) * sizeof(long);	/* sentinel */
		x[-1] -= nptr * sizeof(long);
	}
	if (nofdyn != 0) {
		/* setup len vector for index checks */
#ifdef __STDC__
		va_start(ap, nofdyn);
#else
		va_start(ap);
#endif
		p = x;
		while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
		va_end(ap);
	}
	Unlock;
	return x;
}

/* ----------- end of SYSTEM.co ------------- */