デカルト言語 - 並列ロジック プログラミング言語

/*
 * let & rpn calculation H.Niwa copyright (C) 2009 - 2012
 */

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

 * This program 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 this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301, USA.
 */

#include "config.h"

#include <stdio.h>
#include <stdlib.h>
#include <errno.h>

#include <string>
#include <complex>

#include "syserr.h"

#include "bin_node.h"
#include "gc.h"
#include "var.h"
#include "pred.h"
#include "context.h"
#include "unify.h"
#include "builtin.h"
#include "sysmodule.h"
#include "expression.h"
#include "func.h"
#include "let.h"


int int_let(Context* cx, Node* n, List* module);
int int_compare(Context* cx, Node* n, List* module);
int int_rpn(Context* cx, Node* n, List* module);
int int_intp(Context* cx, Node* n1);
int int_push(Context* cx, Node* n1);
int int_pushnum(Context* cx, long long n);
int int_pop(Context* cx, Node* v);
int int_plus(Context* cx);
int int_minus(Context* cx);
int int_mult(Context* cx);
int int_div(Context* cx);
int int_mod(Context* cx);
int int_gt(Context* cx);
int int_ge(Context* cx);
int int_eq(Context* cx);
int int_noteq(Context* cx);
int int_lt(Context* cx);
int int_le(Context* cx);
int int_and(Context* cx);
int int_or(Context* cx);
int int_not(Context* cx);

int float_let(Context* cx, Node* n, List* module);
int float_compare(Context* cx, Node* n, List* module);
int float_rpn(Context* cx, Node* n, List* module);
int float_intp(Context* cx, Node* n1);
int float_push(Context* cx, Node* n1);
int float_pushnum(Context* cx, long double n);
int float_pop(Context* cx, Node* v);
int float_plus(Context* cx);
int float_minus(Context* cx);
int float_mult(Context* cx);
int float_div(Context* cx);
int float_mod(Context* cx);
int float_gt(Context* cx);
int float_ge(Context* cx);
int float_eq(Context* cx);
int float_noteq(Context* cx);
int float_lt(Context* cx);
int float_le(Context* cx);
int float_and(Context* cx);
int float_or(Context* cx);
int float_not(Context* cx);

int complex_let(Context* cx, Node* n, List* module);
int complex_compare(Context* cx, Node* n, List* module);
int complex_rpn(Context* cx, Node* n, List* module);
int complex_intp(Context* cx, Node* n1);
int complex_push(Context* cx, Node* n1);
int complex_pushnum(Context* cx, std::complex<long double> n);
int complex_pop(Context* cx, Node* v);
int complex_plus(Context* cx);
int complex_minus(Context* cx);
int complex_mult(Context* cx);
int complex_div(Context* cx);
int complex_mod(Context* cx);
int complex_gt(Context* cx);
int complex_ge(Context* cx);
int complex_eq(Context* cx);
int complex_noteq(Context* cx);
int complex_lt(Context* cx);
int complex_le(Context* cx);
int complex_and(Context* cx);
int complex_or(Context* cx);
int complex_not(Context* cx);



int int_let(Context* cx, Node* goalscar, List* module)
{
	Node*	nvar;
	Node*	n = goalscar->Val()->Cdr();
	Node*	n1;
	int	i1;
	int	r;
	int	rn;
	
	cx->int_stackp = 0;

	nvar = n->Car();

	n = n->Cdr();

	if (n->Car()->kind() == ATOM) {
		if (!((Atom*)n->Car())->EqStr("=")) {
			syslist(goalscar);
			syserr("'=' is missed\n");
			return 0;
		} else {
			n = n->Cdr()->Val();
		}
	} else {
		syserr("There is no left side.\n");
		return 0;
	}

	if (n == Nil) {
		syserr("There is no rigtht side.\n");
		return 0;
	}
	
	cxpush(cx, goalscar);
	cxpush(cx, n);

	if (!((rn=Expressioni(cx, n))>0)) {
		cxpop(cx);
		cxpop(cx);
		return rn;
	}
	cxpop(cx);
	cxpop(cx);

	if (n != Nil) {
		syslist(n);
		syserr("parse error\n");
		return 0;
	}

	
	if (nvar->Val()->kind() == UNDEF) {
		if (!int_pop(cx, nvar)) {
			syserr("Arithmetic operation error\n");
			return 0;
		}
		return 1;
	} else if (nvar->Val()->kind() != ATOM) {
			syserr("Arithmetic operation error\n");
		return 0;
	}
	long long nvar_val;
	((Atom*)(nvar->Val()))->toInt(nvar_val);
	return cx->int_stack[cx->int_stackp-1] == nvar_val;
}

int int_compare(Context* cx, Node* goalscar, List* module)
{
	Node*	n = goalscar->Val()->Cdr();
	
	cx->int_stackp = 0;
//printf("comparei a "); n->print(); printf("\n");
		
	cxpush(cx, n);
	if (Comparingi(cx, n) == 0 ) {
		cxpop(cx);
		return 0;
	}
	cxpop(cx);

//printf("comparei b %d : %d \n", cx->int_stackp, cx->int_stack[0]);
	if (cx->int_stackp < 1) {
		return 0;
	}
	if (cx->int_stack[cx->int_stackp-1] != 0) {
//printf("int_compare stack %d \n", cx->int_stack[cx->int_stackp-1]);
//printf("int_compare 1 \n");
		return 1;
	} else {
//printf("int_compare -1 \n");
		return -1;
	}
}

int int_rpn_list(Context* cx, Node* n)
{
	Node* n1;
	int	rn;
	for ( ; n != Nil; n=n->Cdr()) {
		n1 = n->Car();
		if (n1->kind() == LIST) {
			int_rpn_list(cx, n1);
		} else if (!((rn=int_intp(cx, n1))>0)) {
			return rn;
		}
	}
	return 1;
}

int int_rpn(Context* cx, Node* goalscar, List* module)
{
	Node*	nvar;
	Node*	n = goalscar->Val()->Cdr();
	int	rn;

	cx->int_stackp = 0;

	nvar = n->Car();
	if (nvar->Val()->kind() != UNDEF) {
		return 0;
	}

	n = n->Cdr();

	if (n == Nil) {
		return 0;
	}
	
	cxpush(cx, n);
	if ((rn=int_rpn_list(cx, n)) <= 0) {
		cxpop(cx);
		return rn;
	}
	cxpop(cx);

	if (!int_pop(cx, nvar)) {
		return 0;
	}

	return 1;
}


int int_intp(Context* cx, Node* n1)
{
	long long i1;
	long long r;
	std::string	s;
	int	rn;

	if (n1->Val()->kind() == PRED) {
		Node*	 n1p = n1->Val();
		Node*	 rval;
		Context* cx2 = new Context(cx->module, cx->modulename);
		cx2->selfname = cx->selfname;
		cx2->ioin = cx->ioin;
		cx2->ioout = cx->ioout;
		cx2->tokenflag = cx->tokenflag;
		cx2->token = cx->token;

		cx2->ode = cx->ode;
		cx2->integral = cx->integral;

		cxpush(cx, n1p);
//		if ((rn=Unify(cx2, n1p, cx->module))>0) {
		if ((rn=FuncPred(cx2, n1p, cx->module, rval))>0) {
			cxpop(cx);

			cx->Merge(cx2);
			delete cx2;
			cx2 = 0;
			
//printf("return value "); rval->print(); printf("\n");
			rval = rval->Val();
			if (rval->kind() != ATOM) {
				syslist(rval);
				syserr("not a return number");
				return 0;
			}

			if (((Atom*)rval)->toInt(r)) {
				int_pushnum(cx, r);
				return 1;
			} else {
				syslist(rval);
				syserr("not a number in expression");
				return 0;
			}

		} else {
			cxpop(cx);
			delete cx2;
			cx2 = 0;
			return rn;
		}
	}

	if (n1->Val()->kind() != ATOM) {
		syslist(n1);
		syserr("not a ATOM");
		return 0;
	}

	((Atom*)n1->Val())->toString(s);

	if (s == "+") {
		r = int_plus(cx);
	} else if (s == "-") {
		r = int_minus(cx);
	} else if (s == "*") {
		r = int_mult(cx);
	} else if (s == "/") {
		r = int_div(cx);
	} else if (s == "%") {
		r = int_mod(cx);
	} else if (((Atom*)(n1->Val()))->toInt(i1))  {
		int_pushnum(cx, i1);
		return 1;
	} else {
		syslist(n1);
		syserr("Value cannot be operated");
	}
	
	return r;
}

int int_push(Context* cx, Node* n1)
{
//printf("int_push \n");
	long long i1;
	
	if ((((Atom*)n1)->Val()->kind() != ATOM) 
	    || (!((Atom*)n1)->toInt(i1)))  {
		syslist(n1);
		syserr("value is not a number.");
	    	return 0;
	}

	cx->int_stack[cx->int_stackp] = i1;
	cx->int_stackp++;
	if (cx->int_stackp >= MAX_INT_STACK) {
		syslist(n1);
		syserr("stack overflow\n");
		return 0;
	}
	return 1;
}


int int_pushnum(Context* cx, long long n)
{
//printf("int_pushnum \n");
	cx->int_stack[cx->int_stackp] = n;
	cx->int_stackp++;
	if (cx->int_stackp >= MAX_INT_STACK) {
		syserr("stack overflow\n");
		return 0;
	}
	return 1;
}

int int_pop(Context* cx, Node* v)
{
//printf("int_pop \n");
	long long i1;
	
	if (v->Val()->kind() != UNDEF) {
		syslist(v);
		syserr("variable is not undefined.");
		return 0;
	}

	cx->int_stackp--;
	if (cx->int_stackp < 0) {
		syserr("stack underflow");
		return 0;
	}
	i1 = cx->int_stack[cx->int_stackp];

	Node* env = Nil->Cons(Nil);
	
	SetEnv(env, v->Val());
	((Undef*)(v->Val()))->Set(new Atom(i1));

	PushStack(cx, Nil, Nil, env);

	return 1;
}

int int_plus(Context* cx)
{
//printf("int_plus \n");
	long long i1;
	
	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		cx->int_stackp = 0;
		syserr("+ stack underflow: An argument is unfixed and '+' operation is not made.");
		return 0;
	}
	i1 = cx->int_stack[cx->int_stackp];

	cx->int_stack[cx->int_stackp-1] += i1;
	return 1;
}

int int_minus(Context* cx)
{
//printf("int_minus \n");
	long long i1;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		cx->int_stackp = 0;
		syserr("- stack underflow: An argument is unfixed and '-' operation is not made.");
		return 0;
	}
	i1 = cx->int_stack[cx->int_stackp];

	cx->int_stack[cx->int_stackp-1] -= i1;
	return 1;
}

int int_mult(Context* cx)
{
//printf("int_mult \n");
	long long i1;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		cx->int_stackp = 0;
		syserr("* stack underflow: An argument is unfixed and '*' operation is not made.");
		return 0;
	}
	i1 = cx->int_stack[cx->int_stackp];

	cx->int_stack[cx->int_stackp-1] *= i1;
	return 1;
}

int int_div(Context* cx)
{
//printf("int_div \n");
	long long i1;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		cx->int_stackp = 0;
		syserr("/ stack underflow: An argument is unfixed and '/' operation is not made.");
		return 0;
	}
	i1 = cx->int_stack[cx->int_stackp];
	if (i1 == 0) {
		syserr("Division by zero\n");
		return 0;
	}

	cx->int_stack[cx->int_stackp-1] /= i1;
	return 1;
}

int int_mod(Context* cx)
{
//printf("int_mod \n");
	long long i1;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		cx->int_stackp = 0;
		syserr("% stack underflow: An argument is unfixed and '%' operation is not made.");
		return 0;
	}
	i1 = cx->int_stack[cx->int_stackp];
	if (i1 == 0) {
		syserr("Floating point exception: division by zero");
		return 0;
	}

	cx->int_stack[cx->int_stackp-1] %= i1;
	return 1;
}


int int_gt(Context* cx)
{
//printf("int_gt \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr("> stack underflow: An argument is unfixed and '>' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = (i1 > i2);
	return 1;
}

int int_ge(Context* cx)
{
//printf("int_ge \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr(">= stack underflow: An argument is unfixed and '>=' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = (i1 >= i2);
	return 1;
}

int int_eq(Context* cx)
{
//printf("int_eq \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr("== stack underflow: An argument is unfixed and '==' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = (i1 == i2);
	return 1;
}

int int_noteq(Context* cx)
{
//printf("int_noteq \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr("!= stack underflow: An argument is unfixed and '!=' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = (i1 != i2);
	return 1;
}

int int_lt(Context* cx)
{
//printf("int_lt \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr("< stack underflow: An argument is unfixed and '<' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = (i1 < i2);
	return 1;
}

int int_le(Context* cx)
{
//printf("int_le \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr("<= stack underflow: An argument is unfixed and '<=' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = (i1 <= i2);
	return 1;
}

int int_and(Context* cx)
{
//printf("int_and \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr("'and'stack underflow: An argument is unfixed and 'and' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = ((i1 != 0) && (i2 != 0));
	return 1;
}

int int_or(Context* cx)
{
//printf("int_or \n");
	long long i1, i2;

	cx->int_stackp--;
	if (cx->int_stackp <= 0) {
		syserr("'or' stack underflow: An argument is unfixed and 'or' operation is not made.");
		return 0;
	}
	i2 = cx->int_stack[cx->int_stackp];

	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = ((i1 != 0) || (i2 != 0));
	return 1;
}

int int_not(Context* cx)
{
//printf("int_not \n");
	long long i1;

	if (cx->int_stackp <= 0) {
		syserr("'not' stack underflow: An argument is unfixed and 'not' operation is not made.");
		return 0;
	}
	i1 = cx->int_stack[cx->int_stackp-1];

	cx->int_stack[cx->int_stackp-1] = (i1 == 0);
	return 1;
}



int float_let(Context* cx, Node* goalscar, List* module)
{
	Node*	nvar;
	Node*	n = goalscar->Val()->Cdr();
	Node*	n1;
	long double	i1;
	int	rn;
	
//printf("float_let "); n->print(); printf("\n");
		
	cx->float_stackp = 0;

	nvar = n->Car();

	n = n->Cdr();
	
	if (n->Car()->kind() == ATOM) {
		if (!((Atom*)n->Car())->EqStr("=")) {
			syslist(goalscar);
			syserr("'=' is missed\n");
			return 0;
		} else {
			n = n->Cdr()->Val();
		}
	} else {
		syserr("There is no left side.\n");
		return 0;
	}

	if (n == Nil) {
		syserr("There is no rigtht side.\n");
		return 0;
	}

	cxpush(cx, n);

	if (!((rn=Expressionf(cx, n))>0)) {
		cxpop(cx);
		return rn;
	}
	cxpop(cx);
	if (n != Nil) {
		syslist(n);
		syserr("parse error\n");
		return 0;
	}
	if (nvar->Val()->kind() == UNDEF) {
		if (!float_pop(cx, nvar)) {
			syserr("Arithmetic operation error\n");
			return 0;
		}
		return 1;
	} else if (nvar->Val()->kind() != ATOM) {
		syserr("Arithmetic operation error\n");
		return 0;
	}
	long double nvar_val;
	((Atom*)(nvar->Val()))->toFloat(nvar_val);
	return cx->float_stack[cx->float_stackp-1] == nvar_val;
}

int float_compare(Context* cx, Node* goalscar, List* module)
{
	Node*	n = goalscar->Val()->Cdr();
	
	cx->float_stackp = 0;
//printf("compare a "); n->print(); //printf("\n");
		
	cxpush(cx, n);
	if (Comparingf(cx, n) == 0) {
		cxpop(cx);
		return 0;
	}
	cxpop(cx);

//printf("compare b %d : %g \n", cx->float_stackp, cx->float_stack[cx->float_stackp-1]);
	if (cx->float_stackp < 1) {
		return 0;
	}
	if (cx->float_stack[cx->float_stackp-1] != 0.0) {
//printf("float_compare stack %g \n", cx->float_stack[cx->float_stackp-1]);
//printf("float_compare 1 \n");
		return 1;
	} else {
//printf("float_compare -1 \n");
		return -1;
	}
}

int float_rpn_list(Context* cx, Node* n)
{
	Node*	n1;
	int	rn;
	
	for ( ; n != Nil; n=n->Cdr()) {
		n1 = n->Car();
		if (n1->kind() == LIST) {
			float_rpn_list(cx, n1);
		} else if (!((rn=float_intp(cx, n1))>0)) {
			return 0;
		}
	}
	return 1;
}

int float_rpn(Context* cx, Node* goalscar, List* module)
{
	Node*	nvar;
	Node*	n = goalscar->Val()->Cdr();
	int	rn;
	
	cx->float_stackp = 0;

	nvar = n->Car();
	if (nvar->Val()->kind() != UNDEF) {
		return 0;
	}

	n = n->Cdr();

	if (n == Nil) {
		return 0;
	}
	
	cxpush(cx, n);

	if ((rn=float_rpn_list(cx, n)) <= 0) {
		cxpop(cx);
		return rn;
	}
	cxpop(cx);

	if (!float_pop(cx, nvar)) {
		return 0;
	}

	return 1;
}


int float_intp(Context* cx, Node* n1)
{
	long double	r1;
	std::string	s;
	int	r;
	int	rn;
	
	if (n1->Val()->kind() == PRED) {
		Node* n1p = n1->Val();
		Node*	 rval;
		Context* cx2 = new Context(cx->module, cx->modulename);
		cx2->selfname = cx->selfname;
		cx2->ioin = cx->ioin;
		cx2->ioout = cx->ioout;
		cx2->tokenflag = cx->tokenflag;
		cx2->token = cx->token;

		cx2->ode = cx->ode;
		cx2->integral = cx->integral;

		cxpush(cx, n1p);
//		if ((rn=Unify(cx2, n1p, cx->module))>0) {
		if ((rn=FuncPred(cx2, n1p, cx->module, rval))>0) {
			cxpop(cx);

			cx->Merge(cx2);
			delete cx2;
			cx2 = 0;
			
//printf("return value "); rval->print(); //printf("\n");
			rval = rval->Val();
			if (rval->kind() != ATOM) {
				syslist(rval);
				syserr("not a return number");
				return 0;
			}

			if (((Atom*)rval)->toFloat(r1)) {
				float_pushnum(cx, r1);
				return 1;
			} else {
				syslist(rval);
				syserr("not a number in expression");
				return 0;
			}

		} else {
			cxpop(cx);
			delete cx2;
			cx2 = 0;
			return rn;
		}
	}

	if (n1->Val()->kind() != ATOM) {
		syslist(n1);
		syserr("not a ATOM");
		return 0;
	}

	((Atom*)n1->Val())->toString(s);

	if (s == "+") {
		r = float_plus(cx);
	} else if (s == "-") {
		r = float_minus(cx);
	} else if (s == "*") {
		r = float_mult(cx);
	} else if (s == "/") {
		r = float_div(cx);
	} else if (s == "%") {
		r = float_mod(cx);
	} else if (((Atom*)(n1->Val()))->toFloat(r1))  {
		float_pushnum(cx, r1);
		return 1;
	} else {
		syslist(n1);
		syserr("Value cannot be operated");
	}
	
	return r;
}

int float_push(Context* cx, Node* n1)
{
//printf("float_push \n");
	long double r1;
	
	if ((((Atom*)n1)->Val()->kind() != ATOM) 
	    || (!((Atom*)n1)->toFloat(r1)))  {
		syslist(n1);
		syserr("value is not a number.");
	    	return 0;
	}

	cx->float_stack[cx->float_stackp] = r1;
	cx->float_stackp++;
	if (cx->float_stackp >= MAX_FLOAT_STACK) {
		syslist(n1);
		syserr("stack overflow\n");
		return 0;
	}
	return 1;
}


int float_pushnum(Context* cx, long double n)
{
//printf("float_pushnum %g \n", n);
	cx->float_stack[cx->float_stackp] = n;
	cx->float_stackp++;
	if (cx->float_stackp >= MAX_FLOAT_STACK) {
		syserr("stack overflow\n");
		return 0;
	}
	return 1;
}

int float_pop(Context* cx, Node* v)
{
//printf("float_pop \n");
	long double r1;
	
	if (v->Val()->kind() != UNDEF) {
		syslist(v);
		syserr("variable is not undefined.");
		return 0;
	}

	cx->float_stackp--;
	if (cx->float_stackp < 0) {
		syserr("stack underflow");
		return 0;
	}
	r1 = cx->float_stack[cx->float_stackp];

	Node* env = Nil->Cons(Nil);
	
	SetEnv(env, v->Val());
	((Undef*)(v->Val()))->Set(new Atom(r1));

	PushStack(cx, Nil, Nil, env);
	return 1;
}

int float_plus(Context* cx)
{
//printf("float_plus \n");
	long double r1;
	
	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		cx->float_stackp = 0;
		syserr("+ stack underflow: An argument is unfixed and '+' operation is not made.");
		return 0;
	}
	r1 = cx->float_stack[cx->float_stackp];

	cx->float_stack[cx->float_stackp-1] += r1;
	return 1;
}

int float_minus(Context* cx)
{
//printf("float_minus \n");
	long double r1;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		cx->float_stackp = 0;
		syserr("- stack underflow: An argument is unfixed and '-' operation is not made.");
		return 0;
	}
	r1 = cx->float_stack[cx->float_stackp];

	cx->float_stack[cx->float_stackp-1] -= r1;
	return 1;
}

int float_mult(Context* cx)
{
//printf("float_mult \n");
	long double r1;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		cx->float_stackp = 0;
		syserr("* stack underflow: An argument is unfixed and '*' operation is not made.");
		return 0;
	}
	r1 = cx->float_stack[cx->float_stackp];

	cx->float_stack[cx->float_stackp-1] *= r1;
	return 1;
}

int float_div(Context* cx)
{
//printf("float_div \n");
	long double r1;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		cx->float_stackp = 0;
		syserr("/ stack underflow: An argument is unfixed and '/' operation is not made.");
		return 0;
	}
	r1 = cx->float_stack[cx->float_stackp];
	if (r1 == 0) {
		syserr("Floating point exception: division by zero");
		return 0;
	}

	cx->float_stack[cx->float_stackp-1] /= r1;
	return 1;
}

int float_mod(Context* cx)
{
//printf("float_mod \n");
	long double r1;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		cx->float_stackp = 0;
		syserr("% stack underflow: An argument is unfixed and '%' operation is not made.");
		return 0;
	}
	r1 = cx->float_stack[cx->float_stackp];
	if (r1 == 0) {
		syserr("Floating point exception: division by zero");
		return 0;
	}

	cx->float_stack[cx->float_stackp-1] 
		= (long double)((int)cx->float_stack[cx->float_stackp-1] % (int)r1);
	return 1;
}


int float_gt(Context* cx)
{
//printf("float_gt \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr("> stack underflow: An argument is unfixed and '>' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = (r1 > r2);
	return 1;
}

int float_ge(Context* cx)
{
//printf("float_ge \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr(">= stack underflow: An argument is unfixed and '>=' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = (r1 >= r2);
	return 1;
}

int float_eq(Context* cx)
{
//printf("float_eq \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr("== stack underflow: An argument is unfixed and '==' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = (r1 == r2);
	return 1;
}

int float_noteq(Context* cx)
{
//printf("float_noteq \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr("!= stack underflow: An argument is unfixed and '!=' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = (r1 != r2);
	return 1;
}

int float_lt(Context* cx)
{
//printf("float_lt \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr("< stack underflow: An argument is unfixed and '<' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = (r1 < r2);
	return 1;
}

int float_le(Context* cx)
{
//printf("float_le \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr("<= stack underflow: An argument is unfixed and '<=' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = (r1 <= r2);
	return 1;
}

int float_and(Context* cx)
{
//printf("float_and \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr("'and' stack underflow: An argument is unfixed and 'and' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = ((r1 != 0) && (r2 != 0));
	return 1;
}

int float_or(Context* cx)
{
//printf("float_or \n");
	long double r1, r2;

	cx->float_stackp--;
	if (cx->float_stackp <= 0) {
		syserr("'or' stack underflow: An argument is unfixed and 'or' operation is not made.");
		return 0;
	}
	r2 = cx->float_stack[cx->float_stackp];

	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = ((r1 != 0) || (r2 != 0));
	return 1;
}

int float_not(Context* cx)
{
//printf("float_not \n");
	long double r1;

	if (cx->float_stackp <= 0) {
		syserr("'not' stack underflow: An argument is unfixed and 'not' operation is not made.");
		return 0;
	}
	r1 = cx->float_stack[cx->float_stackp-1];

	cx->float_stack[cx->float_stackp-1] = (r1 == 0.0);
	return 1;
}



int complex_let(Context* cx, Node* goalscar, List* module)
{
	Node*	nvar;
	Node*	n = goalscar->Val()->Cdr();
	Node*	n1;
	long double	i1;
	int	rn;
	
//printf("complex_let "); n->print(); printf("\n");
		
	cx->complex_stackp = 0;

	nvar = n->Car();

	n = n->Cdr();
	
	if (n->Car()->kind() == ATOM) {
		if (!((Atom*)n->Car())->EqStr("=")) {
			syslist(goalscar);
			syserr("'=' is missed\n");
			return 0;
		} else {
			n = n->Cdr()->Val();
		}
	} else {
		syserr("There is no left side.\n");
		return 0;
	}

	if (n == Nil) {
		syserr("There is no rigtht side.\n");
		return 0;
	}

	cxpush(cx, n);

	if (!((rn=ExpressionC(cx, n))>0)) {
		cxpop(cx);
		return rn;
	}
	cxpop(cx);
	if (n != Nil) {
		syslist(n);
		syserr("parse error\n");
		return 0;
	}
	if (nvar->Val()->kind() == UNDEF) {
		if (!complex_pop(cx, nvar)) {
			syserr("Arithmetic operation error\n");
			return 0;
		}
		return 1;
	} else if (nvar->Val()->kind() != ATOM) {
		syserr("Arithmetic operation error\n");
		return 0;
	}
	long double nvar_val;
	((Atom*)(nvar->Val()))->toFloat(nvar_val);
	return cx->complex_stack[cx->complex_stackp-1] == nvar_val;
}

int complex_compare(Context* cx, Node* goalscar, List* module)
{
	Node*	n = goalscar->Val()->Cdr();
	
	cx->complex_stackp = 0;
//printf("compare a "); n->print(); //printf("\n");
		
	cxpush(cx, n);
	if (ComparingC(cx, n) == 0) {
		cxpop(cx);
		return 0;
	}
	cxpop(cx);

//printf("compare b %d : %g \n", cx->complex_stackp, cx->complex_stack[cx->complex_stackp-1]);
	if (cx->complex_stackp < 1) {
		return 0;
	}
	if (cx->complex_stack[cx->complex_stackp-1].real() != 0.0) {
//printf("complex_compare stack %g \n", cx->complex_stack[cx->complex_stackp-1]);
//printf("complex_compare 1 \n");
		return 1;
	} else {
//printf("complex_compare -1 \n");
		return -1;
	}
}

int complex_rpn_list(Context* cx, Node* n)
{
	Node*	n1;
	int	rn;
	
	for ( ; n != Nil; n=n->Cdr()) {
		n1 = n->Car();
		if (n1->kind() == LIST) {
			complex_rpn_list(cx, n1);
		} else if (!((rn=complex_intp(cx, n1))>0)) {
			return 0;
		}
	}
	return 1;
}

int complex_rpn(Context* cx, Node* goalscar, List* module)
{
	Node*	nvar;
	Node*	n = goalscar->Val()->Cdr();
	int	rn;
	
	cx->complex_stackp = 0;

	nvar = n->Car();
	if (nvar->Val()->kind() != UNDEF) {
		return 0;
	}

	n = n->Cdr();

	if (n == Nil) {
		return 0;
	}
	
	cxpush(cx, n);

	if ((rn=complex_rpn_list(cx, n)) <= 0) {
		cxpop(cx);
		return rn;
	}
	cxpop(cx);

	if (!complex_pop(cx, nvar)) {
		return 0;
	}

	return 1;
}


int complex_intp(Context* cx, Node* n1)
{
	std::complex<long double>	c1;
	std::string	s;
	int	r;
	int	rn;
	
	if (n1->Val()->kind() == PRED) {
		Node* n1p = n1->Val();
		Node*	 rval;
		Context* cx2 = new Context(cx->module, cx->modulename);
		cx2->selfname = cx->selfname;
		cx2->ioin = cx->ioin;
		cx2->ioout = cx->ioout;
		cx2->tokenflag = cx->tokenflag;
		cx2->token = cx->token;

		cx2->ode = cx->ode;
		cx2->integral = cx->integral;

		cxpush(cx, n1p);
//		if ((rn=Unify(cx2, n1p, cx->module))>0) {
		if ((rn=FuncPred(cx2, n1p, cx->module, rval))>0) {
			cxpop(cx);

			cx->Merge(cx2);
			delete cx2;
			cx2 = 0;
			
//printf("return value "); rval->print(); //printf("\n");
			rval = rval->Val();
			if (rval->kind() != ATOM) {
				syslist(rval);
				syserr("not a return number");
				return 0;
			}

			if (((Atom*)rval)->toComplex(c1)) {
				complex_pushnum(cx, c1);
				return 1;
			} else {
				syslist(rval);
				syserr("not a number in expression");
				return 0;
			}

		} else {
			cxpop(cx);
			delete cx2;
			cx2 = 0;
			return rn;
		}
	}

	if (n1->Val()->kind() != ATOM) {
		syslist(n1);
		syserr("not a ATOM");
		return 0;
	}

	((Atom*)n1->Val())->toString(s);

	if (s == "+") {
		r = complex_plus(cx);
	} else if (s == "-") {
		r = complex_minus(cx);
	} else if (s == "*") {
		r = complex_mult(cx);
	} else if (s == "/") {
		r = complex_div(cx);
#if 0
	} else if (s == "%") {
		r = complex_mod(cx);
#endif
	} else if (((Atom*)(n1->Val()))->toComplex(c1))  {
		complex_pushnum(cx, c1);
		return 1;
	} else {
		syslist(n1);
		syserr("Value cannot be operated");
	}
	
	return r;
}

int complex_push(Context* cx, Node* n1)
{
//printf("complex_push \n");
	std::complex<long double> c1;
	
	if ((((Atom*)n1)->Val()->kind() != ATOM) 
	    || (!((Atom*)n1)->toComplex(c1)))  {
		syslist(n1);
		syserr("value is not a number.");
	    	return 0;
	}

	cx->complex_stack[cx->complex_stackp] = c1;
	cx->complex_stackp++;
	if (cx->complex_stackp >= MAX_COMPLEX_STACK) {
		syslist(n1);
		syserr("stack overflow\n");
		return 0;
	}
	return 1;
}


int complex_pushnum(Context* cx, std::complex<long double> n)
{
//printf("complex_pushnum %g \n", n);
	cx->complex_stack[cx->complex_stackp] = n;
	cx->complex_stackp++;
	if (cx->complex_stackp >= MAX_COMPLEX_STACK) {
		syserr("stack overflow\n");
		return 0;
	}
	return 1;
}

int complex_pop(Context* cx, Node* v)
{
//printf("complex_pop \n");
	std::complex<long double> c1;
	
	if (v->Val()->kind() != UNDEF) {
		syslist(v);
		syserr("variable is not undefined.");
		return 0;
	}

	cx->complex_stackp--;
	if (cx->complex_stackp < 0) {
		syserr("stack underflow");
		return 0;
	}
	c1 = cx->complex_stack[cx->complex_stackp];

	Node* env = Nil->Cons(Nil);
	
	SetEnv(env, v->Val());
	((Undef*)(v->Val()))->Set(new Atom(c1));

	PushStack(cx, Nil, Nil, env);
	return 1;
}

int complex_plus(Context* cx)
{
//printf("complex_plus \n");
	std::complex<long double> c1;
	
	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		cx->complex_stackp = 0;
		syserr("+ stack underflow: An argument is unfixed and '+' operation is not made.");
		return 0;
	}
	c1 = cx->complex_stack[cx->complex_stackp];

	cx->complex_stack[cx->complex_stackp-1] += c1;
	return 1;
}

int complex_minus(Context* cx)
{
//printf("complex_minus \n");
	std::complex<long double> c1;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		cx->complex_stackp = 0;
		syserr("- stack underflow: An argument is unfixed and '-' operation is not made.");
		return 0;
	}
	c1 = cx->complex_stack[cx->complex_stackp];

	cx->complex_stack[cx->complex_stackp-1] -= c1;
	return 1;
}

int complex_mult(Context* cx)
{
//printf("complex_mult \n");
	std::complex<long double> c1;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		cx->complex_stackp = 0;
		syserr("* stack underflow: An argument is unfixed and '*' operation is not made.");
		return 0;
	}
	c1 = cx->complex_stack[cx->complex_stackp];

	cx->complex_stack[cx->complex_stackp-1] *= c1;
	return 1;
}

int complex_div(Context* cx)
{
//printf("complex_div \n");
	std::complex<long double> c1;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		cx->complex_stackp = 0;
		syserr("/ stack underflow: An argument is unfixed and '/' operation is not made.");
		return 0;
	}
	c1 = cx->complex_stack[cx->complex_stackp];
	if ((c1.real() == 0) && (c1.imag() == 0)) {
		syserr("Complex exception: division by zero");
		return 0;
	}

	cx->complex_stack[cx->complex_stackp-1] /= c1;
	return 1;
}

#if 0
int complex_mod(Context* cx)
{
//printf("complex_mod \n");
	std::complex<long double> c1;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		cx->complex_stackp = 0;
		syserr("% stack underflow: An argument is unfixed and '%' operation is not made.");
		return 0;
	}
	c1 = cx->complex_stack[cx->complex_stackp];
	if (c1.real() == 0) {
		syserr("Complex exception: division by zero");
		return 0;
	}

	cx->complex_stack[cx->complex_stackp-1] 
		= cx->complex_stack[cx->complex_stackp-1] % c1;
	return 1;
}


int complex_gt(Context* cx)
{
//printf("complex_gt \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr("> stack underflow: An argument is unfixed and '>' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] = (c1 > c2);
	return 1;
}

int complex_ge(Context* cx)
{
//printf("complex_ge \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr(">= stack underflow: An argument is unfixed and '>=' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] = (c1 >= c2);
	return 1;
}

#endif

int complex_eq(Context* cx)
{
//printf("complex_eq \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr("== stack underflow: An argument is unfixed and '==' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] = (c1 == c2);
	return 1;
}

int complex_noteq(Context* cx)
{
//printf("complex_noteq \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr("!= stack underflow: An argument is unfixed and '!=' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] = (c1 != c2);
	return 1;
}

#if 0

int complex_lt(Context* cx)
{
//printf("complex_lt \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr("< stack underflow: An argument is unfixed and '<' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] = (c1 < c2);
	return 1;
}

int complex_le(Context* cx)
{
//printf("complex_le \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr("<= stack underflow: An argument is unfixed and '<=' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] = (c1 <= c2);
	return 1;
}

#endif

int complex_and(Context* cx)
{
//printf("complex_and \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr("'and' stack underflow: An argument is unfixed and 'and' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] 
		= ((c1.real() != 0) && (c2.real() != 0));
	return 1;
}

int complex_or(Context* cx)
{
//printf("complex_or \n");
	std::complex<long double> c1, c2;

	cx->complex_stackp--;
	if (cx->complex_stackp <= 0) {
		syserr("'or' stack underflow: An argument is unfixed and 'or' operation is not made.");
		return 0;
	}
	c2 = cx->complex_stack[cx->complex_stackp];

	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] 
		= ((c1.real() != 0) || (c2.real() != 0));
	return 1;
}

int complex_not(Context* cx)
{
//printf("complex_not \n");
	std::complex<long double> c1;

	if (cx->complex_stackp <= 0) {
		syserr("'not' stack underflow: An argument is unfixed and 'not' operation is not made.");
		return 0;
	}
	c1 = cx->complex_stack[cx->complex_stackp-1];

	cx->complex_stack[cx->complex_stackp-1] 
			= (c1.real() == 0.0);
	return 1;
}