Rev. | 1278 |
---|---|
Size | 8,805 bytes |
Time | 2011-01-01 15:56:05 |
Author | hniwa |
Log Message | The copyright display is made to correspond to 2011.
|
/*
* module program H.Niwa copyright (C) 2009 - 2011
*/
/*
* 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 "checkreserved.h"
#include "bin_node.h"
#include "gc.h"
#include "var.h"
#include "pred.h"
#include "context.h"
#include "builtin.h"
#include "sysmodule.h"
#include "module.h"
#include "unify.h"
void PPmoduleHead(int tabs, Node* nd, FILE* fd);
void PPmoduleBody(int tabs, Node* nd, FILE* fd);
void PPmoduleBody(int tabs, Node* nd, int tabsflag, FILE* fd);
void PPmodule(Node* module, FILE* fd);
void PPmodule(int tabs, Node* module, FILE* fd);
inline int ModuleCompare(Node* l1, Node* l2)
{
int r;
if ((l1->kind() == ATOM) && (l2->kind() == ATOM)) {
std::string s1, s2;
((Atom*)l1)->toString(s1);
((Atom*)l2)->toString(s2);
if (s1 == s2) {
return 0;
} else if (s1 > s2) {
return 1;
} else {
return -1;
}
} else if ((l1->kind() == PRED) && (l2->kind() == PRED)) {
r = ModuleCompare(l1->Car(), l2->Car());
if (r != 0) {
return r;
}
return ModuleCompare(l1->Cdr(), l2->Cdr());
} else if ((l1->kind() == LIST) && (l2->kind() == LIST)) {
r = ModuleCompare(l1->Car(), l2->Car());
if (r != 0) {
return r;
}
return ModuleCompare(l1->Cdr(), l2->Cdr());
} else if ((l1->kind() == LIST) && (l2->kind() == ATOM)) {
return -1;
} else if ((l1->kind() == ATOM) && (l2->kind() == LIST)) {
return 1;
}
return -1;
}
void ModuleSort(List* module)
{
Node* l1;
Node* l2;
for (l1 = module->Car(); l1->Cdr() != Nil; l1=l1->Cdr()) {
for (l2 = l1->Cdr(); l2 != Nil; l2=l2->Cdr()){
if (ModuleCompare(l1->Car()->Car()->Car(),
l2->Car()->Car()->Car()) > 0) {
Node* tmp = l1->Car();
((List*)l1)->SetCar(l2->Car());
((List*)l2)->SetCar(tmp);
}
}
}
}
int Assert(List* module, Node* nd)
{
if (nd->kind() != LIST) {
return 0;
}
if (nd->Car()->kind() != PRED) {
return 0;
}
if (nd->Car()->Car()->kind() == ATOM) {
std::string s;
((Atom*)nd->Car()->Car())->toString(s);
if (CheckReserved(s.c_str())) {
return 0;
}
}
module->SetCar(Append(module->Car(),Cons(nd, Nil)));
// ModuleSort(module);
return 1;
}
int Asserta(List* module, Node* nd)
{
if (nd->kind() != LIST) {
return 0;
}
if (nd->Car()->kind() != PRED) {
return 0;
}
if (nd->Car()->Car()->kind() == ATOM) {
std::string s;
((Atom*)nd->Car()->Car())->toString(s);
if (CheckReserved(s.c_str())) {
return 0;
}
}
module->SetCar(Cons(nd, module->Car()));
// ModuleSort(module);
return 1;
}
void PPmoduleOld(Node* module, FILE* fd)
{
Node *nd;
Node *ndpred;
for (nd = module->Car(); nd != Nil; nd = nd->Cdr()) {
nd->Car()->Car()->print(fd);
if (nd->Car()->Cdr() == Nil) {
fprintf(fd, ";\n");
} else {
fprintf(fd, "\n");
}
for (ndpred = nd->Car()->Cdr(); ndpred != Nil;
ndpred = ndpred->Cdr()) {
fprintf(fd, "\t");
ndpred->Car()->print(fd);
if (ndpred->Cdr() != Nil) {
fprintf(fd, "\n");
} else {
fprintf(fd, ";\n");
}
}
}
}
static void ptabs(int n, FILE* fd)
{
for (int i=0; i < n; i++) {
fprintf(fd, "\t");
}
}
static int checkmodule(Node* ndh)
{
if (ndh->kind() != PRED) {
//printf("checkmodule trace 0\n");
return 0;
}
if (ndh->Car()->kind() != PRED) {
//printf("checkmodule trace 0.5\n");
return 0;
}
if (ndh->Cdr()->Car()->kind() != LIST) {
//printf("checkmodule trace 1\n");
return 0;
}
#if 0
if (ndh->Cdr()->Car()->Car()->kind() != PRED) {
//printf("checkmodule trace 2\n");
return 0;
}
if (ndh->Cdr()->Cdr()->Car()->kind() != LIST) {
//printf("checkmodule trace 3\n");
return 0;
}
if (ndh->Cdr()->Cdr()->Car()->Car()->kind() != PRED) {
//printf("checkmodule trace 4\n");
return 0;
}
#endif
return 1;
}
/* Prety Print Head module */
void PPmoduleHead(int tabs, Node* ndh, FILE* fd=stdout)
{
Node* n;
ptabs(tabs, fd);
if (checkmodule(ndh)) {
fprintf(fd, "::<");
ndh->Car()->Car()->print(fd);
fprintf(fd, "\n");
PPmodule(tabs+1, MkList(ndh->Cdr()), fd);
ptabs(tabs, fd);
fprintf(fd, ">");
} else {
ndh->print(fd);
}
}
void PPmodulePred(int tabs, Node* ndpred, int tabsflag, FILE* fd=stdout)
{
//PrintNode("PPmodulePred 0 ", ndpred);
if (tabsflag) {
ptabs(tabs, fd);
}
if (ndpred->Car()->Eq(mka("obj")) ||
ndpred->Car()->Eq(mka("unify"))) {
fprintf(fd, "::");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, " ");
PPmodulePred(tabs, ndpred->Cdr()->Cdr()->Car(), 0, fd);
} else if (ndpred->Car()->Eq(mka("loop"))) {
fprintf(fd, "{\n");
ptabs(tabs, fd);
PPmoduleBody(tabs, ndpred->Cdr(), 0, fd);
ptabs(tabs, fd);
fprintf(fd, "}\n");
} else if (ndpred->Car()->Eq(mka("alt"))) {
fprintf(fd, "[\n");
ptabs(tabs, fd);
PPmoduleBody(tabs, ndpred->Cdr(), 0, fd);
ptabs(tabs, fd);
fprintf(fd, "]\n");
} else if (ndpred->Car()->Eq(mka("or"))) {
PPmoduleBody(tabs, ndpred->Cdr()->Car(), 0, fd);
for (Node* np=ndpred->Cdr()->Cdr();
np->kind() != ATOM;
np=np->Cdr()) {
ptabs(tabs, fd);
fprintf(fd, " |\n");
PPmoduleBody(tabs, np->Car(), fd);
}
} else if (ndpred->Car()->Eq(mka("for"))) {
fprintf(fd, "<for ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else if (ndpred->Car()->Eq(mka("firstfor"))) {
fprintf(fd, "<firstfor ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else if ((ndpred->Car()->Eq(mka("foreach"))) ||
(ndpred->Car()->Eq(mka("map")))) {
fprintf(fd, "<foreach ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else if ((ndpred->Car()->Eq(mka("firstforeach")))) {
fprintf(fd, "<firstforeach ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else if (ndpred->Car()->Eq(mka("newproc"))) {
fprintf(fd, "<newproc ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else if (ndpred->Car()->Eq(mka("firstnewproc"))) {
fprintf(fd, "<firstnewproc ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else if ((ndpred->Car()->Eq(mka("eachproc")))) {
fprintf(fd, "<eachproc ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else if ((ndpred->Car()->Eq(mka("firsteachproc")))) {
fprintf(fd, "<firsteachproc ");
ndpred->Cdr()->Car()->print(fd);
fprintf(fd, "\n");
PPmoduleBody(tabs+1, ndpred->Cdr()->Cdr(), fd);
ptabs(tabs, fd);
fprintf(fd, ">\n");
} else {
ndpred->print(fd);
fprintf(fd, "\n");
}
}
void PPmoduleBody(int tabs, Node* nd, FILE* fd)
{
PPmoduleBody(tabs, nd, 1, fd);
}
/* Prety Print Body module */
void PPmoduleBody(int tabs, Node* nd, int tabsflag, FILE* fd=stdout)
{
Node *ndpred;
//PrintNode("PPmoduleBody ", nd);
if (nd->kind() == PRED) {
PPmodulePred(tabs, nd, tabsflag, fd);
return;
}
for ( ; nd->kind() != ATOM; nd = nd->Cdr()) {
ndpred = nd->Car();
if (ndpred == Nil) {
continue;
}
PPmodulePred(tabs, ndpred, tabsflag, fd);
tabsflag = 1;
}
}
/* Prety Print module for test */
void PPmodule(Node* module, FILE* fd)
{
PPmodule(0, module, fd);
}
void PPmodule(int tabs, Node* module, FILE* fd)
{
Node *nd;
for (nd = module->Car(); nd->kind() != ATOM; nd = nd->Cdr()) {
PPmoduleHead(tabs, nd->Car()->Car(), fd);
if (nd->Car()->Cdr() == Nil) {
fprintf(fd, "\n"); ptabs(tabs+1, fd); fprintf(fd, ";\n");
continue;
} else {
fprintf(fd, "\n");
}
PPmoduleBody(tabs+1, nd->Car()->Cdr(), fd);
ptabs(tabs, fd); fprintf(fd, "\t;\n");
}
}