/***********************************************************
Copyright 1991 by Stichting Mathematisch Centrum, Amsterdam, The
Netherlands.

                        All Rights Reserved

Permission to use, copy, modify, and distribute this software and its 
documentation for any purpose and without fee is hereby granted, 
provided that the above copyright notice appear in all copies and that
both that copyright notice and this permission notice appear in 
supporting documentation, and that the names of Stichting Mathematisch
Centrum or CWI not be used in advertising or publicity pertaining to
distribution of the software without specific, written prior permission.

STICHTING MATHEMATISCH CENTRUM DISCLAIMS ALL WARRANTIES WITH REGARD TO
THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS, IN NO EVENT SHALL STICHTING MATHEMATISCH CENTRUM BE LIABLE
FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

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

/* Module support implementation */

#include "allobjects.h"
#include "modsupport.h"
#include "import.h"


object *
initmodule(name, methods)
	char *name;
	struct methodlist *methods;
{
	object *m, *d, *v;
	struct methodlist *ml;
	char namebuf[256];
	if ((m = add_module(name)) == NULL) {
		fprintf(stderr, "initializing module: %s\n", name);
		fatal("can't create a module");
	}
	d = getmoduledict(m);
	for (ml = methods; ml->ml_name != NULL; ml++) {
		sprintf(namebuf, "%s.%s", name, ml->ml_name);
		v = newmethodobject(strdup(namebuf), ml->ml_meth,
					(object *)NULL, ml->ml_varargs);
		/* XXX The strdup'ed memory is never freed */
		if (v == NULL || dictinsert(d, ml->ml_name, v) != 0) {
			fprintf(stderr, "initializing module: %s\n", name);
			fatal("can't initialize module");
		}
		DECREF(v);
	}
	return m;
}


/* Argument list handling tools.
   All return 1 for success, or call err_set*() and return 0 for failure */

int
getnoarg(v)
	object *v;
{
	if (v != NULL) {
		return err_badarg();
	}
	return 1;
}

int
getintarg(v, a)
	object *v;
	int *a;
{
	if (v == NULL || !is_intobject(v)) {
		return err_badarg();
	}
	*a = getintvalue(v);
	return 1;
}

int
getintintarg(v, a, b)
	object *v;
	int *a;
	int *b;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getintarg(gettupleitem(v, 0), a) &&
		getintarg(gettupleitem(v, 1), b);
}

int
getintintintarg(v, a, b, c)
	object *v;
	int *a;
	int *b;
	int *c;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
		return err_badarg();
	}
	return getintarg(gettupleitem(v, 0), a) &&
		getintarg(gettupleitem(v, 1), b) &&
		getintarg(gettupleitem(v, 2), c);
}

int
getlongarg(v, a)
	object *v;
	long *a;
{
	if (v == NULL || !is_intobject(v)) {
		return err_badarg();
	}
	*a = getintvalue(v);
	return 1;
}

int
getlonglongarg(v, a, b)
	object *v;
	long *a, *b;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getlongarg(gettupleitem(v, 0), a) &&
		getlongarg(gettupleitem(v, 1), b);
}

int
getlongobjectarg(v, a, b)
	object *v;
	long *a;
	object **b;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	if (getlongarg(gettupleitem(v, 0), a)) {
		*b = gettupleitem(v, 1);
		return 1;
	}
	else {
		return err_badarg();
	}
}

int
getlonglongobjectarg(v, a, b, c)
	object *v;
	long *a, *b;
	object **c;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
		return err_badarg();
	}
	if (getlongarg(gettupleitem(v, 0), a) &&
		getlongarg(gettupleitem(v, 1), b)) {
		*c = gettupleitem(v, 2);
		return 1;
	}
	else {
		return err_badarg();
	}
}

int
getstrarg(v, a)
	object *v;
	object **a;
{
	if (v == NULL || !is_stringobject(v)) {
		return err_badarg();
	}
	*a = v;
	return 1;
}

int
getstrstrarg(v, a, b)
	object *v;
	object **a;
	object **b;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getstrarg(gettupleitem(v, 0), a) &&
		getstrarg(gettupleitem(v, 1), b);
}

int
getstrstrintarg(v, a, b, c)
	object *v;
	object **a;
	object **b;
	int *c;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
		return err_badarg();
	}
	return getstrarg(gettupleitem(v, 0), a) &&
		getstrarg(gettupleitem(v, 1), b) &&
		getintarg(gettupleitem(v, 2), c);
}

int
getstrintarg(v, a, b)
	object *v;
	object **a;
	int *b;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getstrarg(gettupleitem(v, 0), a) &&
		getintarg(gettupleitem(v, 1), b);
}

int
getintstrarg(v, a, b)
	object *v;
	int *a;
	object **b;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getintarg(gettupleitem(v, 0), a) &&
		getstrarg(gettupleitem(v, 1), b);
}

int
getpointarg(v, a)
	object *v;
	int *a; /* [2] */
{
	return getintintarg(v, a, a+1);
}

int
get3pointarg(v, a)
	object *v;
	int *a; /* [6] */
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
		return err_badarg();
	}
	return getpointarg(gettupleitem(v, 0), a) &&
		getpointarg(gettupleitem(v, 1), a+2) &&
		getpointarg(gettupleitem(v, 2), a+4);
}

int
getrectarg(v, a)
	object *v;
	int *a; /* [2+2] */
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getpointarg(gettupleitem(v, 0), a) &&
		getpointarg(gettupleitem(v, 1), a+2);
}

int
getrectintarg(v, a)
	object *v;
	int *a; /* [4+1] */
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getrectarg(gettupleitem(v, 0), a) &&
		getintarg(gettupleitem(v, 1), a+4);
}

int
getpointintarg(v, a)
	object *v;
	int *a; /* [2+1] */
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getpointarg(gettupleitem(v, 0), a) &&
		getintarg(gettupleitem(v, 1), a+2);
}

int
getpointstrarg(v, a, b)
	object *v;
	int *a; /* [2] */
	object **b;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getpointarg(gettupleitem(v, 0), a) &&
		getstrarg(gettupleitem(v, 1), b);
}

int
getstrintintarg(v, a, b, c)
	object *v;
	object *a;
	int *b, *c;
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 3) {
		return err_badarg();
	}
	return getstrarg(gettupleitem(v, 0), a) &&
		getintarg(gettupleitem(v, 1), b) &&
		getintarg(gettupleitem(v, 2), c);
}

int
getrectpointarg(v, a)
	object *v;
	int *a; /* [4+2] */
{
	if (v == NULL || !is_tupleobject(v) || gettuplesize(v) != 2) {
		return err_badarg();
	}
	return getrectarg(gettupleitem(v, 0), a) &&
		getpointarg(gettupleitem(v, 1), a+4);
}

int
getlongtuplearg(args, a, n)
	object *args;
	long *a; /* [n] */
	int n;
{
	int i;
	if (!is_tupleobject(args) || gettuplesize(args) != n) {
		return err_badarg();
	}
	for (i = 0; i < n; i++) {
		object *v = gettupleitem(args, i);
		if (!is_intobject(v)) {
			return err_badarg();
		}
		a[i] = getintvalue(v);
	}
	return 1;
}

int
getshorttuplearg(args, a, n)
	object *args;
	short *a; /* [n] */
	int n;
{
	int i;
	if (!is_tupleobject(args) || gettuplesize(args) != n) {
		return err_badarg();
	}
	for (i = 0; i < n; i++) {
		object *v = gettupleitem(args, i);
		if (!is_intobject(v)) {
			return err_badarg();
		}
		a[i] = getintvalue(v);
	}
	return 1;
}

int
getlonglistarg(args, a, n)
	object *args;
	long *a; /* [n] */
	int n;
{
	int i;
	if (!is_listobject(args) || getlistsize(args) != n) {
		return err_badarg();
	}
	for (i = 0; i < n; i++) {
		object *v = getlistitem(args, i);
		if (!is_intobject(v)) {
			return err_badarg();
		}
		a[i] = getintvalue(v);
	}
	return 1;
}

int
getshortlistarg(args, a, n)
	object *args;
	short *a; /* [n] */
	int n;
{
	int i;
	if (!is_listobject(args) || getlistsize(args) != n) {
		return err_badarg();
	}
	for (i = 0; i < n; i++) {
		object *v = getlistitem(args, i);
		if (!is_intobject(v)) {
			return err_badarg();
		}
		a[i] = getintvalue(v);
	}
	return 1;
}

int
getdoublearg(args, px)
	register object *args;
	double *px;
{
	if (args == NULL)
		return err_badarg();
	if (is_floatobject(args)) {
		*px = getfloatvalue(args);
		return 1;
	}
	if (is_intobject(args)) {
		*px = getintvalue(args);
		return 1;
	}
	if (is_longobject(args)) {
		*px = dgetlongvalue(args);
		return 1;
	}
	return err_badarg();
}

int
get2doublearg(args, px, py)
	register object *args;
	double *px, *py;
{
	if (args == NULL || !is_tupleobject(args) || gettuplesize(args) != 2)
		return err_badarg();
	return getdoublearg(gettupleitem(args, 0), px) &&
		getdoublearg(gettupleitem(args, 1), py);
}