| /* node.cc */ |
| /* |
| Copyright (C) 2003 Unique Software Designs |
| |
| This file is part of the program "lambda". |
| |
| The program "lambda" 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 of the License, or |
| (at your option) any later version. |
| |
| The program "lambda" 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 "lambda"; if not, write to the Free Software |
| Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
| |
| A copy of the GNU General Public License may also be found at: |
| http://www.gnu.org/copyleft/gpl.html |
| */ |
| #if HAVE_CONFIG_H |
| # include "config.h" |
| #endif |
| #include <string.h> |
| #include <stdio.h> |
| #include <stdlib.h> |
| #include <config.h> |
| #include "node.h" |
| |
| #define REDUCE_VARS |
| //#undef REDUCE_VARS |
| #define USE_UNDER_SCORE_PREFIX_FOR_GENERATED_NAMES |
| #undef USE_UNDER_SCORE_PREFIX_FOR_GENERATED_NAMES |
| |
| //const int MAX_RECURSE=200; |
| const int MAX_RECURSE=4000; |
| |
| const arglst_node* definition_env = 0; |
| |
| static int name_sequence = 1; |
| static int lambda_reduce_recurse_level = 0; |
| static int app_reduce_recurse_level = 0; |
| static int var_reduce_recurse_level = 0; |
| |
| static char* newname(const char* oldname) |
| { |
| char* nm = 0; |
| char buf[128]; |
| if( !oldname ) oldname = "~"; |
| |
| #ifdef USE_UNDER_SCORE_PREFIX_FOR_GENERATED_NAMES |
| sprintf( buf, "_%s_%d", oldname, name_sequence ); |
| #else |
| sprintf( buf, "%s#%d", oldname, name_sequence ); |
| #endif |
| name_sequence += 1; |
| |
| nm = new char[strlen(buf)+1]; |
| strcpy(nm,buf); |
| return nm; |
| } |
| |
| char* newstring(const char*os) |
| { |
| char* ns; |
| if(os) { |
| ns = new char[strlen(os)+1]; |
| strcpy(ns,os); |
| }else ns = 0; |
| return ns; |
| }; |
| |
| ////////////////////////////////////////////////////////////////////// |
| void node:: |
| reset() |
| { |
| name_sequence = 1; |
| lambda_reduce_recurse_level = 0; |
| app_reduce_recurse_level = 0; |
| var_reduce_recurse_level = 0; |
| } |
| |
| void node:: |
| print(const alst_node*env,int inp) const |
| { |
| printf("(%p:node)",this); |
| } |
| |
| ////////////////////////////////////////////////////////////////////// |
| // arg_node |
| arg_node:: |
| arg_node(const char* nm, const exp_node* ex, Boolean import) |
| { |
| this->name_v = newstring(nm); |
| if( import ){ |
| if( ex ) value_v = (exp_node*)ex; |
| else value_v = 0; |
| }else{ |
| if( ex ) value_v = (exp_node*)ex->clone(); |
| else value_v = 0; |
| if( value_v ) value_v->set_parent(this); |
| } |
| } |
| |
| arg_node:: |
| arg_node(const arg_node& from) |
| { |
| //*this = from; |
| if( from.name_v ) { |
| name_v = new char [strlen(from.name_v)+1]; |
| strcpy(name_v, from.name_v); |
| }else name_v = 0; |
| if( from.value_v ) |
| value_v = |
| (exp_node*)from.value_v->clone(); |
| else value_v = 0; |
| if( value_v ) value_v->set_parent(this); |
| parent_v = from.parent_v; |
| } |
| |
| node* arg_node:: |
| clone() const |
| { |
| return (node*)new arg_node(*this); |
| } |
| |
| arg_node:: |
| ~arg_node() |
| { |
| if( name_v ) delete [] name_v; |
| if( value_v ) delete value_v; |
| } |
| |
| arg_node& arg_node:: |
| operator =(const arg_node& from) |
| { |
| if( this != &from ){ |
| this->~arg_node(); |
| if( from.name_v ) { |
| name_v = new char [strlen(from.name_v)+1]; |
| strcpy(name_v, from.name_v); |
| }else name_v = 0; |
| if( from.value_v ) |
| value_v = |
| (exp_node*)from.value_v->clone(); |
| else value_v = 0; |
| if( value_v ) value_v->set_parent(this); |
| parent_v = from.parent_v; |
| } |
| return *this; |
| } |
| |
| //Boolean arg_node:: |
| //free_in(exp_node* exp) |
| //{ |
| // Boolean in = False; |
| // in = exp->has_free(this); |
| // return in; |
| //} |
| |
| void arg_node:: |
| print(const alst_node*env, int inp)const |
| { |
| printf("%s", name_v ? name_v : "(null)" ); |
| if( value_v ) { |
| printf(" = "); |
| value_v->print(env,inp); |
| } |
| } |
| |
| void arg_node:: |
| import_value(exp_node** val) |
| { |
| if( value_v ) delete value_v; |
| if( val ){ |
| value_v = *val; |
| *val = 0; |
| }else value_v = 0; |
| if( value_v ) value_v->set_parent(this); |
| } |
| |
| int arg_node:: |
| operator == (const arg_node& cmp) const |
| { |
| Boolean b1 = |
| !name_v && !cmp.name_v || |
| name_v && cmp.name_v && 0==strcmp(name_v, cmp.name_v); |
| return b1; |
| } |
| |
| int arg_node:: |
| operator == (const char* cmp) const |
| { |
| Boolean b1 = |
| !name_v && !cmp || |
| name_v && cmp && 0==strcmp(name_v, cmp); |
| return b1; |
| } |
| |
| ///////////////////////////////////////////////////////////////////// |
| // exp_node's |
| const alst_node* exp_node:: |
| match(const alst_node* env ) const |
| { |
| const alst_node* match = 0; |
| for(const alst_node* en=env; en; en = en->next() ) |
| { |
| if( en->arg() && en->arg()->value() ){ |
| if( *this==*(en->arg()->value()) ) |
| { |
| match = en; |
| break; |
| } |
| } |
| } |
| return match; |
| } |
| |
| void exp_node:: |
| symbolic_print(const alst_node*env,int inp)const |
| { |
| if( inp&node::DO_PRINT_SYM ){ |
| exp_node* exp = (exp_node*)this->clone(); |
| if( exp ){ |
| exp_node* pexp = exp->extract_defs(env); |
| if( pexp ){ |
| pexp->print(env,inp); |
| if( pexp != exp ) delete pexp; |
| }else{ |
| exp->print(env,inp); |
| } |
| delete exp; |
| }else{ |
| this->print(env,inp); |
| } |
| }else{ |
| this->print(env,inp); |
| } |
| } |
| |
| ///////////////////////////////////////////////////////////////////// |
| // var_node |
| var_node:: |
| var_node(const char* nm) |
| { |
| if( nm ){ |
| name_v = new char[strlen(nm)+1]; |
| strcpy(name_v,nm); |
| }else nm = 0; |
| } |
| |
| var_node:: |
| var_node(const var_node& from) |
| { |
| //*this = from; |
| if( from.name_v ) { |
| name_v = new char [strlen(from.name_v)+1]; |
| strcpy(name_v, from.name_v); |
| }else name_v = 0; |
| parent_v = 0;//from.parent_v; |
| } |
| |
| Boolean var_node:: |
| has_free(const arg_node* argr, const alst_node* env) const |
| { |
| // const exp_node* exp=this; |
| #ifndef REDUCE_VARS |
| exp = reduce_value(env); |
| //if( exp != this ) |
| if( VAR!=exp->op() ) |
| return exp->has_free(argr, env); |
| #endif |
| #undef MATCH_NAME |
| #ifdef MATCH_NAME |
| //if( argr ) return argr->operator==(name_v); |
| if( argr ) return *argr==(exp->name()); |
| #else |
| if( argr ){ |
| const alst_node* bd = this->bind(env); |
| if( bd && (bd->arg()==argr)) |
| { |
| return True; |
| } |
| } |
| #endif |
| return False; |
| } |
| |
| arglst_node* var_node:: |
| bind(const alst_node* env) const |
| { |
| //arg_node* arg = 0; |
| //if( !this->name() ) return arg; |
| //if( ref_arg_v ) return; |
| if( !this->name() ) return 0; |
| #if 0 |
| for( node* par = parent_v; par; par = par->parent() ) |
| { |
| if( LAM==par->op() && par->arg() && par->arg()->name() ){ |
| if( 0==strcmp(par->arg()->name(), |
| this->name())) |
| { |
| arg = par->arg(); |
| break; |
| } |
| } |
| // if( arg ) break; |
| } |
| #endif |
| //if( !arg ) { |
| alst_node* lst; |
| for( lst=(arglst_node*)env; |
| lst; lst=(arglst_node*)lst->next() ) |
| { |
| if( lst->arg() && lst->arg()->name() ){ |
| if( 0==strcmp(lst->arg()->name(), |
| this->name())) |
| { |
| //arg = lst->arg(); |
| break; |
| } |
| } |
| } |
| //} |
| ////if( arg ){ref_arg_v = arg;if( def_arg_v ) delete def_arg_v;def_arg_v = 0;} |
| return (arglst_node*)lst; |
| } |
| |
| void var_node:: |
| print(const alst_node*env,int inp) const |
| { |
| printf("%s", name() ? name() : "(null-var)" ); |
| } |
| |
| var_node& var_node:: |
| operator =(const var_node& from) |
| { |
| if( name_v ) delete [] name_v; |
| if( from.name_v ) { |
| name_v = new char [strlen(from.name_v)+1]; |
| strcpy(name_v, from.name_v); |
| }else name_v = 0; |
| if( this != &from ){ |
| parent_v = from.parent_v; |
| } |
| return *this; |
| } |
| |
| void var_node:: |
| set_name(const char* nm) |
| { |
| if( name_v == nm ) return; |
| if( name_v ) delete [] name_v; |
| name_v = nm?new char[strlen(nm)+1]:0; |
| if( name_v && nm ) strcpy(name_v,nm); |
| } |
| |
| exp_node* var_node:: |
| reduce_value(const alst_node* env, int inp, int* outp, |
| const alst_node** pnenv) |
| { |
| exp_node* exp = this; |
| exp_node* val; |
| |
| val = exp; |
| int reduced = 0; |
| int cnt = 0; |
| int max_loops = (inp & DO_REDUCE_FULLY) ? 2 : 0; |
| do { |
| do { |
| env = val->bind(env); |
| if( !val ) goto end; |
| arg_node* barg = env ? env->arg() : 0; |
| exp_node* nval = barg ? barg->value() : 0; |
| if( !nval ) break; |
| if( val == nval ) goto end; |
| if( val == nval ) break; |
| val = nval; |
| reduced = 1; |
| } while (env && val && VAR==val->op() && val!=this ); |
| env = definition_env; |
| cnt++; |
| } while (reduced && cnt < max_loops); |
| end: |
| if( val ) exp = val; |
| if( pnenv ){ |
| //if( env ) env = env->next(); |
| //*pnenv = (alst_node*)env; |
| *pnenv = definition_env; |
| } |
| return exp; |
| } |
| |
| exp_node* var_node:: |
| reduce_number() |
| { |
| exp_node* exp = 0; |
| if( name() ) |
| { |
| int is_number = 1; |
| for(const char*pc = name();*pc!='\0';pc++) |
| { |
| int ch = *pc; |
| if( ch < '0' || ch > '9' ) |
| { |
| is_number = 0; |
| break; |
| } |
| } |
| if( is_number ) |
| { |
| arg_node* arg1 = new arg_node("m",0); |
| arg_node* arg2 = new arg_node("n",0); |
| exp_node *bdy = new var_node("n"); |
| int number = atoi((const char*)name()); |
| for( ; number > 0; number -= 1 ) |
| { |
| var_node* lft = new var_node("m"); |
| bdy = new app_node(lft,bdy,True); |
| } |
| lam_node* lam2 = new lam_node(arg2,bdy,True); |
| lam_node* lam1 = new lam_node(arg1,lam2,True); |
| exp = lam1; |
| } |
| } |
| return exp; |
| } |
| |
| exp_node* var_node:: |
| reduce(const alst_node* env, int inp,int* outp) |
| { |
| var_reduce_recurse_level++; |
| if( var_reduce_recurse_level > MAX_RECURSE ){ |
| printf("\nvar_reduce_recurse_level %d [", |
| var_reduce_recurse_level); |
| this->print(); |
| printf ("]\n"); |
| var_reduce_recurse_level--; |
| if( outp ) *outp |= node::RECURSE_LVL; |
| return this; |
| } |
| const alst_node* nenv = 0; |
| exp_node* exp = this->reduce_value(env, inp, outp, &nenv); |
| if( exp != this ) |
| { |
| exp = (exp_node*)exp->clone(); |
| if( nenv && (APP==exp->op() || LAM==exp->op()) |
| && (inp&DO_REDUCE_FULLY)!=0 ) |
| { |
| exp_node* nexp = exp->reduce_vars(nenv,inp,outp); |
| if( nexp && nexp != exp ) |
| { |
| delete exp; |
| exp = nexp; |
| } |
| } |
| } |
| exp_node* num = reduce_number(); |
| if( num ) |
| { |
| if( exp != this ){ |
| delete exp; |
| exp = num; |
| }else{ |
| exp = num; |
| } |
| } |
| var_reduce_recurse_level--; |
| return exp; |
| } |
| |
| void var_node:: |
| rename(arg_node* arg, const char* newname, alst_node* env) |
| { |
| arglst_node* lst = this->bind(env); |
| arg_node* barg = lst ? lst->arg() : 0; |
| if( barg && barg==arg ) this->set_name(newname); |
| } |
| |
| int var_node:: |
| operator == (const exp_node& cmp) const |
| { |
| Boolean b1 = False; |
| if( VAR!=cmp.op() ) return b1; |
| b1 = !name() && !cmp.name() || |
| name() && cmp.name() && 0==strcmp(name(), cmp.name()); |
| return b1; |
| } |
| |
| exp_node* var_node:: |
| extract(const char* nm, int inp) const |
| { |
| if( name() && nm && 0==strcmp(nm,name()) ) |
| { |
| return (exp_node*)new var_node("I"); |
| }else |
| if( nm ) |
| { |
| exp_node* lft = new var_node("K"); |
| exp_node* rgt = new var_node(name()); |
| return (exp_node*)new app_node(lft,rgt,True); |
| }else{ |
| return (exp_node*)new var_node(name()); |
| } |
| } |
| |
| |
| ////////////////////////////////////////////////////////////////////// |
| // lam_node |
| lam_node:: |
| lam_node(arg_node* arg, exp_node* bdy, Boolean import) |
| { |
| arg_v = 0; |
| body_v = 0; |
| set_arg(arg,import); |
| set_body(bdy,import); |
| } |
| |
| lam_node:: |
| lam_node(const lam_node& from) |
| { |
| //*this = from; |
| if( from.arg_v ) |
| arg_v = (arg_node*)from.arg_v->clone(); |
| else arg_v = 0; |
| if( arg_v ) arg_v->set_parent(this); |
| if( from.body_v ) |
| body_v = (exp_node*)from.body_v->clone(); |
| else body_v = 0; |
| if( body_v ) body_v->set_parent(this); |
| parent_v = 0;//from.parent_v; |
| } |
| |
| lam_node:: |
| ~lam_node() |
| { |
| if( arg_v ) delete arg_v; |
| if( body_v ) delete body_v; |
| } |
| |
| Boolean lam_node:: |
| has_free(const arg_node* argr, const alst_node* env) const |
| { |
| stack_frame nenv(arg_v,env); |
| if( arg_v && arg_v->operator ==(*argr) ) return False; |
| if( body_v ) return body_v->has_free(argr, (alst_node*)&nenv); |
| return False; |
| } |
| |
| void lam_node:: |
| print(const alst_node*env, int inp) const |
| { |
| int printed = 0; |
| if( (inp&DO_PRINT_SYM) ) |
| { |
| if( env ) |
| { |
| const alst_node* alst = this->match(env); |
| if( alst ){ |
| printf("%s", alst->arg()->name()); |
| printed = 1; |
| } |
| } |
| if( !printed ) |
| { |
| int value = 0; |
| if( LAM==body()->op() |
| && arg() |
| && arg()->name() |
| && body() |
| && body()->arg() |
| && body()->arg()->name() |
| && body()->body()) |
| { |
| const char* name1 = arg()->name(); |
| const char* name2 = body()->arg()->name(); |
| for( exp_node* numbody = body()->body(); |
| numbody; numbody = numbody->right() ) |
| { |
| if( APP==numbody->op() |
| && numbody->left() |
| && VAR==numbody->left()->op() |
| && numbody->left()->name() |
| && 0==strcmp(name1,numbody->left()->name()) |
| ){ |
| value += 1; |
| }else |
| if( VAR==numbody->op() |
| && numbody->name() |
| && 0==strcmp(name2,numbody->name()) |
| ){ |
| break; |
| }else{ |
| value = -1; |
| break; |
| } |
| } |
| if( value >= 0 ) |
| { |
| printf( "%d",value); |
| printed = 1; |
| } |
| }else |
| if( arg() |
| && arg()->name() |
| && body() |
| && VAR==body()->op() |
| && 0==strcmp(arg()->name(), body()->name()) ) |
| { |
| printf( "I"); |
| printed = 1; |
| } |
| } |
| } |
| if( !printed ) |
| { |
| printf("^"); |
| //if( arg() ) arg()->print(env,inp); |
| if( arg() && arg()->name() ) printf("%s",arg()->name()); |
| else printf("(null-arg)"); |
| if( arg() && arg()->value() ){ |
| printf("["); |
| arg()->value()->print(env,inp); |
| printf("]"); |
| } |
| printf("."); |
| if( body() ) body()->print(env,inp); |
| else printf("(null-body)"); |
| } |
| } |
| |
| lam_node& lam_node:: |
| operator =(const lam_node& from) |
| { |
| if( this!=&from ){ |
| this->~lam_node(); |
| if( from.arg_v ) |
| arg_v = (arg_node*)from.arg_v->clone(); |
| else arg_v = 0; |
| if( arg_v ) arg_v->set_parent(this); |
| if( from.body_v ) |
| body_v = (exp_node*)from.body_v->clone(); |
| else body_v = 0; |
| if( body_v ) body_v->set_parent(this); |
| parent_v = 0;//from.parent_v; |
| } |
| return *this; |
| } |
| |
| exp_node* lam_node:: |
| reduce(const alst_node* env, int inp, int* outp) |
| { |
| exp_node* exp = this; |
| stack_frame nenv(this->arg_v, (arglst_node*)env ); |
| if(inp&DO_TRACE){ |
| for(int idx=0;idx<lambda_reduce_recurse_level;idx++)printf("."); |
| printf("L: "); |
| symbolic_print(env, inp); |
| printf("\n"); |
| exp_node* par; |
| for(par=this;par->parent();par=(exp_node*)par->parent() ); |
| par->symbolic_print(env,inp); |
| printf("\n"); |
| } |
| lambda_reduce_recurse_level++; |
| if( lambda_reduce_recurse_level > MAX_RECURSE ){ |
| printf("\nlambda_reduce_recurse_level %d\n", |
| lambda_reduce_recurse_level); |
| lambda_reduce_recurse_level--; |
| if( outp ) *outp |= node::RECURSE_LVL; |
| return this; |
| } |
| body_v->set_parent(this); |
| if( arg_v && arg_v->name() && '&'==arg_v->name()[0] ) |
| { |
| inp &= ~DO_STEP; |
| inp &= ~DO_REDUCE_BODY; |
| } |
| if( arg_v && arg_v->value() && body_v ){ |
| body_v->resolve_name_clash(arg_v,&nenv); |
| //old delet -- body_v->bind(nenv); |
| // |
| if( arg_v->name() && '$'==arg_v->name()[0] ) |
| { |
| inp &= ~DO_STEP; |
| inp |= DO_REDUCE_BODY; |
| } |
| if( !(inp&DO_STEP) ){ |
| int toutp = outp ? *outp : 0; |
| exp = body_v; |
| exp = body_v->reduce_vars((alst_node*)&nenv,inp,outp); |
| if( exp!=body_v ) set_body(0,True); |
| arg_v->import_value((exp_node*)0); |
| int cnt = 0; |
| do { |
| exp_node* nexp = 0; |
| nexp = exp->reduce((alst_node*)&nenv,inp,&toutp); |
| if( nexp && exp != nexp ){ |
| if( exp==body_v ) body_v = 0; |
| delete exp; |
| exp = nexp; |
| } |
| if( toutp && toutp&node::RECURSE_LVL ) break; |
| if( toutp & node::BETA_ETA_DONE){ |
| toutp &= ~node::BETA_ETA_DONE; |
| }else break; |
| cnt++; |
| } while( exp ); |
| if( outp ) *outp = toutp; |
| if( cnt > 1 ) |
| { |
| printf("[%d.%d]",cnt,lambda_reduce_recurse_level); |
| } |
| }else{ |
| exp = body_v->reduce_vars((alst_node*)&nenv,inp,outp); |
| } |
| if( body_v && body_v!=exp ) delete body_v; |
| this->body_v = 0; |
| if( exp ) exp->set_parent(parent_v); |
| //if( parent() ) delete this; |
| }else if( body_v ){ |
| exp_node* nexp = eta_reduce( &nenv,inp,outp); |
| if( exp!=nexp ){ |
| if( exp != this ) delete exp; |
| exp = nexp; |
| }else{ |
| int toutp = outp ? *outp : 0; |
| if( inp&DO_REDUCE_BODY ){ |
| exp_node* nd = |
| body_v->reduce((alst_node*)&nenv,inp,&toutp); |
| if( nd ) set_body(nd,True); |
| }else{ |
| exp_node* nd = |
| body_v->reduce_vars((alst_node*)&nenv,inp,outp); |
| if( nd ) set_body(nd,True); |
| } |
| if( !(inp&DO_STEP) || !(toutp&node::BETA_ETA_DONE) ){ |
| nexp = eta_reduce( &nenv,inp, &toutp); |
| if( exp!=nexp ){ |
| if( exp != this ) delete exp; |
| exp = nexp; |
| } |
| } |
| if( outp ) *outp = toutp; |
| } |
| } |
| lambda_reduce_recurse_level--; |
| if(0 && inp&DO_TRACE ){ |
| for(int idx=0;idx<lambda_reduce_recurse_level;idx++)printf("."); |
| printf("L> "); |
| //exp->print(env, inp); |
| exp->set_parent(this->parent()); |
| exp_node* par; |
| for(par=exp;par->parent();par=(exp_node*)par->parent() ); |
| par->symbolic_print(env,inp); |
| printf("\n"); |
| } |
| return exp; |
| } |
| |
| exp_node* lam_node:: |
| eta_reduce(const alst_node* env,int inp,int* outp) |
| { |
| // assume stack frame already set> |
| exp_node* exp = this; |
| if( !body_v ) return exp; |
| if( !(inp&DO_STEP) || !outp || !(*outp&node::BETA_ETA_DONE)) |
| { |
| if(APP==body_v->op() && !(inp&DO_APP_ORDER) ){ |
| // check for eta reduction |
| if( body()->left() ) |
| { |
| #ifdef REDUCE_VARS |
| exp_node* nd = body_v->left()->reduce_vars(env,inp,outp); |
| if( nd ) ((app_node*)body())->set_left(nd,True); |
| #endif |
| if( body_v->right() && arg_v |
| && *arg_v == body_v->right()->name() |
| && !body_v->left()->has_free(arg_v, env) ) |
| { |
| // do eta reduction |
| exp = this->body_v->export_left(); |
| //this->body_v = 0; // right_v memory leak? |
| set_body(0,true); |
| if( outp ) *outp |= |
| (node::BETA_ETA_DONE | node::ETA_DONE); |
| if( !(inp&DO_STEP ) ){ |
| exp_node* nexp = exp->reduce(env,inp,outp); |
| if( nexp && exp != nexp ){ |
| if( exp ) delete exp; |
| exp = nexp; |
| } |
| } |
| } |
| } |
| } |
| } |
| return exp; |
| } |
| |
| exp_node* lam_node:: |
| reduce_vars(const alst_node* env,int inp,int* outp) |
| { |
| stack_frame nenv(this->arg_v, (arglst_node*)env ); |
| |
| exp_node* nd = body_v->reduce_vars((alst_node*)&nenv,inp,outp); |
| if( nd ) set_body(nd,True); |
| |
| return this; |
| } |
| |
| void lam_node:: |
| rename(arg_node* arg, const char* newname, alst_node* env) |
| { |
| stack_frame nenv(this->arg_v, (arglst_node*)env ); |
| if( body_v ) body_v->rename(arg,newname,&nenv); |
| } |
| |
| void lam_node:: |
| resolve_name_clash( arg_node* outer_arg,alst_node* env) |
| { |
| stack_frame nenv(this->arg_v, (arglst_node*)env ); |
| if( outer_arg->value() ){ |
| arg_node* inner_arg = this->arg(); |
| exp_node* inner_body = this->body(); |
| if( inner_arg && inner_body |
| && !(inner_arg==outer_arg)) |
| { |
| Boolean b1 = outer_arg->value() |
| ->has_free(inner_arg, (alst_node*)&nenv); |
| Boolean b2 = |
| inner_body->has_free(outer_arg, (alst_node*)&nenv); |
| if( b1 && b2 ) |
| { |
| char* nm = newname(inner_arg->name()); |
| body_v->rename(inner_arg,nm,(alst_node*)&nenv); |
| inner_arg->set_name(nm); |
| delete [] nm; |
| } |
| } |
| if( body_v && body_v->has_free(outer_arg, &nenv) ) |
| body_v->resolve_name_clash(outer_arg, &nenv); |
| } |
| } |
| |
| void lam_node:: |
| set_arg(arg_node* nd, Boolean import) |
| { |
| if( arg_v == nd ) return; |
| if( arg_v ) delete arg_v; |
| if( import ) arg_v = nd; |
| else if( nd ) arg_v = (arg_node*)nd->clone(); |
| else arg_v = 0; |
| if( arg_v ) arg_v->set_parent(this); |
| } |
| |
| void lam_node:: |
| set_body(exp_node* nd, Boolean import) |
| { |
| if( body_v == nd ) return; |
| if( body_v ) delete body_v; |
| if( import ) body_v = nd; |
| else if( nd ) body_v = (exp_node*)nd->clone(); |
| else body_v = 0; |
| if( body_v ) body_v->set_parent(this); |
| } |
| |
| int lam_node:: |
| operator == (const exp_node& cmp) const |
| { |
| Boolean b1 = False; |
| if( LAM!=cmp.op() ) return b1; |
| if( !arg() || !cmp.arg() ) return b1; |
| if( !body() || !cmp.body() ) return b1; |
| b1 = *arg() == *(cmp.arg()) |
| && *body() == *(cmp.body()); |
| return b1; |
| } |
| |
| exp_node* lam_node:: |
| extract_defs(const alst_node* env) |
| { |
| exp_node* exp = this; |
| const alst_node* alst = this->match(env); |
| if( !alst ){ |
| if( body() ) { |
| exp_node* nb = body()->extract_defs(env); |
| if( nb ) |
| set_body(nb,True); |
| alst = this->match(env); |
| if( alst ) |
| exp = new var_node(alst->arg()->name()); |
| } |
| }else{ |
| exp = new var_node(alst->arg()->name()); |
| } |
| return exp; |
| } |
| |
| exp_node* lam_node:: |
| extract(const char* nm, int inp) const |
| { |
| exp_node* exp = 0; |
| if( body() && arg() ) |
| { |
| exp_node* bdy = body()->extract(arg()->name(),inp); |
| if( bdy && nm ) |
| { |
| exp = bdy->extract(nm,inp); |
| delete bdy; |
| } else { |
| exp = bdy; |
| } |
| } |
| return exp; |
| } |
| |
| ////////////////////////////////////////////////////////////////////// |
| // app_node |
| app_node:: |
| app_node(exp_node* lft, |
| exp_node* rgt, |
| Boolean import) |
| { |
| left_v = 0; |
| right_v = 0; |
| set_left(lft,import); |
| set_right(rgt,import); |
| } |
| |
| app_node:: |
| app_node(const app_node& from) |
| { |
| //*this = from; |
| if( from.left_v ) |
| left_v = (exp_node*)from.left_v->clone(); |
| else left_v = 0; |
| if( left_v ) left_v->set_parent(this); |
| if( from.right_v ) |
| right_v = |
| (exp_node*)from.right_v->clone(); |
| else right_v = 0; |
| if( right_v) set_parent(this); |
| parent_v = from.parent_v; |
| } |
| |
| app_node:: |
| ~app_node() |
| { |
| if( left_v ) delete left_v; |
| if( right_v ) delete right_v; |
| } |
| |
| Boolean app_node:: |
| has_free(const arg_node* argr, const alst_node* env) const |
| { |
| Boolean has = False; |
| if( left_v ) has = has || left_v->has_free(argr,env); |
| if( right_v ) has = has || right_v->has_free(argr,env); |
| return has; |
| } |
| |
| void app_node:: |
| print(const alst_node*env,int inp) const |
| { |
| if( inp&DO_PRINT_BRIEF ){ |
| int left_paren = 1; |
| int right_paren = 1; |
| int left_right_paren = 0; |
| int left_match = 0; |
| int right_match = 0; |
| int left_right_match = 0; |
| if( left() ){ |
| if( inp&DO_PRINT_SYM ) |
| left_match = left()->match(env) ? 1 : 0; |
| if( VAR==left()->op() || APP==left()->op() || left_match ) |
| { |
| left_paren = 0; |
| } |
| if( APP==left()->op() && left()->right() ) |
| { |
| if( inp&DO_PRINT_SYM ) |
| left_right_match = |
| left()->right()->match(env) ? 1 : 0; |
| if( VAR!=left()->right()->op() && !left_right_match ) |
| left_right_paren = 1; |
| } |
| if( left_paren ) printf("("); |
| if( left() ) left()->print(env,inp); |
| else printf("(null-right)"); |
| if( left_paren ) printf(")"); |
| }else printf("()"); |
| if( right() ){ |
| if( inp&DO_PRINT_SYM ) |
| right_match = right()->match(env) ? 1 : 0; |
| if( VAR==right()->op() || right_match ) right_paren = 0; |
| if( right_paren ) printf("("); |
| else if( !left_paren && !left_right_paren ) |
| printf(" "); |
| if( right() ) right()->print(env,inp); |
| else printf("(null-right)"); |
| if( right_paren ) printf(")"); |
| }else printf("()"); |
| }else{ |
| if( left() ){ |
| if( VAR!=left()->op()||left()->value() ) printf("("); |
| if( left() ) left()->print(env,inp); |
| else printf("(null-right)"); |
| if( VAR!=left()->op()||left()->value() ) printf(")"); |
| }else printf("()"); |
| if( right() ){ |
| if( VAR!=right()->op()||right()->value() ) printf("("); |
| else printf(" "); |
| if( right() ) right()->print(env,inp); |
| else printf("(null-right)"); |
| if( VAR!=right()->op()||right()->value() ) printf(")"); |
| }else printf("()"); |
| } |
| } |
| |
| app_node& app_node:: |
| operator =(const app_node& from) |
| { |
| if( this!=&from ){ |
| this->~app_node(); |
| if( from.left_v ) |
| left_v = (exp_node*)from.left_v->clone(); |
| else left_v = 0; |
| if( left_v ) left_v->set_parent(this); |
| if( from.right_v ) |
| right_v = (exp_node*)from.right_v->clone(); |
| else right_v = 0; |
| if( right_v ) right_v->set_parent(this); |
| parent_v = from.parent_v; |
| } |
| return *this; |
| } |
| |
| void app_node:: |
| rename(arg_node* arg, const char* newname, alst_node* env) |
| { |
| if( left_v ) left_v->rename(arg,newname,env); |
| if( right_v ) right_v->rename(arg,newname,env); |
| } |
| |
| void app_node:: |
| resolve_name_clash( arg_node* outer_arg,alst_node* env) |
| { |
| if( left_v ) left_v->resolve_name_clash(outer_arg,env); |
| if( right_v ) right_v->resolve_name_clash(outer_arg,env); |
| } |
| |
| exp_node* app_node:: |
| reduce(const alst_node* env, int inp,int* outp) |
| { |
| exp_node* exp = this; |
| app_reduce_recurse_level += 1; |
| if( app_reduce_recurse_level > MAX_RECURSE ){ |
| printf("\napp_reduce_recurse_level %d\n", |
| app_reduce_recurse_level); |
| app_reduce_recurse_level--; |
| if( outp ) *outp |= node::RECURSE_LVL; |
| return this; |
| } |
| |
| if( left_v ){ |
| int ninp = inp & ~DO_REDUCE_BODY; |
| left_v->set_parent(this); |
| exp_node* nd = left_v->reduce(env,ninp,outp); |
| set_left(nd,True); |
| if( outp && *outp&node::RECURSE_LVL ){ |
| app_reduce_recurse_level--; |
| return exp; |
| } |
| if( inp&node::DO_STEP && outp && (*outp&node::BETA_ETA_DONE) ) |
| { |
| app_reduce_recurse_level--; |
| return exp; |
| } |
| } |
| if( left_v && APP==left_v->op() ){ |
| exp_node* nd = 0; |
| int ninp = inp & ~DO_REDUCE_BODY; |
| left_v->set_parent(this); |
| if( left_v ) nd = left_v->reduce(env,ninp,outp); |
| set_left(nd, True); |
| if( outp && *outp&node::RECURSE_LVL ) |
| { |
| app_reduce_recurse_level--; |
| return exp; |
| } |
| if( inp&node::DO_STEP && outp && (*outp&node::BETA_ETA_DONE) ) |
| { |
| app_reduce_recurse_level--; |
| return exp; |
| } |
| if( right_v ){ |
| nd = 0; |
| right_v->set_parent(this); |
| #ifdef REDUCE_VARS |
| nd = right_v->reduce_vars(env,inp,outp); |
| set_right(nd,True); |
| #endif |
| } |
| } |
| if( left_v && LAM==left_v->op() ) |
| { |
| int app_inp = inp; |
| if( left_v->arg() |
| && left_v->arg() |
| && left_v->arg()->name() ) |
| { |
| if('@'==left_v->arg()->name()[0] ) |
| { |
| app_inp |= DO_APP_ORDER; |
| }else |
| if( '#'==left_v->arg()->name()[0] ) |
| { |
| app_inp &= ~DO_APP_ORDER; |
| } |
| } |
| if( right_v ) |
| { |
| Boolean has = False; |
| right_v->set_parent(this); |
| if( app_inp&DO_APP_ORDER ){ |
| arg_node* an = left_v->arg(); |
| exp_node* bd = left_v->body(); |
| stack_frame nenv(an, (arglst_node*)env ); |
| has = bd && an && bd->has_free(an, &nenv); |
| } |
| if( (app_inp&DO_APP_ORDER) && has ){ |
| int ninp = inp & ~DO_REDUCE_BODY; |
| set_right(right_v->reduce(env, ninp, outp),True); |
| if( outp && (*outp&node::RECURSE_LVL) ) |
| { |
| app_reduce_recurse_level--; |
| return exp; |
| } |
| if( (inp&node::DO_STEP) |
| && outp && (*outp&node::BETA_ETA_DONE) ) |
| { |
| app_reduce_recurse_level--; |
| return exp; |
| } |
| }else{ |
| #ifdef REDUCE_VARS |
| set_right(right_v->reduce_vars(env,inp,outp),True); |
| if( outp && (*outp&node::RECURSE_LVL) ) |
| { |
| app_reduce_recurse_level--; |
| return exp; |
| } |
| #endif |
| } |
| } |
| left_v->arg()->import_value(&right_v); |
| right_v = 0; |
| left_v->set_parent(this); |
| exp = left_v->reduce(env,inp,outp); |
| if( left_v && left_v!=exp ) delete left_v; |
| left_v = 0; |
| if( exp ) exp->set_parent(this); |
| if( outp ) *outp |= node::BETA_ETA_DONE; |
| }else{ |
| if( right_v ){ |
| right_v->set_parent(this); |
| #ifdef REDUCE_VARS |
| set_right(right_v->reduce_vars(env,inp,outp),True); |
| #endif |
| set_right(right_v->reduce(env,inp,outp),True); |
| |
| #if 0 |
| if( right_v && APP==right_v->op() |
| && right_v->left() |
| && LAM==right_v->left()->op() |
| ){ |
| set_right(right_v->reduce(env,inp,outp),True);//OLD |
| } |
| #endif |
| } |
| } |
| app_reduce_recurse_level -= 1; |
| return exp; |
| } |
| |
| exp_node* app_node:: |
| reduce_vars(const alst_node* env,int inp,int* outp) |
| { |
| if( left_v ){ |
| left_v->set_parent(this); |
| exp_node* exp = left_v->reduce_vars(env,inp,outp); |
| set_left(exp,True); |
| if( outp && (*outp&node::RECURSE_LVL) ) |
| { |
| if( right_v ) right_v->set_parent(this); |
| return this; |
| } |
| } |
| if( right_v ){ |
| right_v->set_parent(this); |
| exp_node* exp = right_v->reduce_vars(env,inp,outp); |
| set_right(exp,True); |
| } |
| return this; |
| } |
| |
| void app_node:: |
| set_left(exp_node* nd, Boolean import) |
| { |
| if( left_v == nd ) return; |
| if( left_v ) delete left_v; |
| if( import ) left_v = nd; |
| else if( nd ) left_v = (exp_node*)nd->clone(); |
| else left_v = 0; |
| if( left_v ) left_v->set_parent(this); |
| } |
| |
| void app_node:: |
| set_right(exp_node* nd, Boolean import) |
| { |
| if( right_v==nd ) return; |
| if( right_v ) delete right_v; |
| if( import ) right_v = nd; |
| else if( nd ) right_v = (exp_node*)nd->clone(); |
| else right_v = 0; |
| if( right_v ) right_v->set_parent(this); |
| } |
| |
| int app_node:: |
| operator == (const exp_node& cmp) const |
| { |
| Boolean b1 = False; |
| if( APP!=cmp.op() ) return b1; |
| if( !left() || !cmp.left() ) return b1; |
| if( !right() || !cmp.right() ) return b1; |
| b1 = *left() == *(cmp.left()) |
| && *right() == *(cmp.right()); |
| return b1; |
| } |
| |
| exp_node* app_node:: |
| extract_defs(const alst_node* env) |
| { |
| exp_node* exp = this; |
| const alst_node* alst = match(env); |
| if( !alst ){ |
| if( left() ){ |
| exp_node* nl = left()->extract_defs(env); |
| if( nl ) |
| set_left( nl, True); |
| } |
| if( right() ){ |
| exp_node* nr = right()->extract_defs(env); |
| if( nr ) |
| set_right( nr, True); |
| } |
| alst = match(env); |
| if( alst ) |
| exp = new var_node(alst->arg()->name()); |
| }else{ |
| exp = new var_node(alst->arg()->name()); |
| } |
| return exp; |
| } |
| |
| exp_node* app_node:: |
| extract(const char* nm,int inp) const |
| { |
| exp_node* exp = 0; |
| exp_node* lft = 0; |
| exp_node* rgt = 0; |
| exp_node* exp1 = 0; |
| //if( left() && right() && nm && (inp&DO_EXTRACT_ETA) ) |
| if( left() && right() && nm ) |
| { |
| arg_node* argr = new arg_node(nm,0); |
| arglst_node env(argr,0, True); |
| if( !this->has_free(argr, &env) ) |
| { |
| if( inp&DO_EXTRACT_APP ) |
| { |
| if( left() ) lft = left()->extract(nm,inp); |
| if( right() ) rgt = right()->extract(nm,inp); |
| exp1 = (exp_node*)new app_node( |
| new var_node("S"),lft,True); |
| exp = (exp_node*)new app_node(exp1,rgt,True); |
| }else{ |
| //exp = (exp_node*)new app_node(new var_node("K"), |
| // (exp_node*)this->clone(),True); |
| exp1 = this->extract(0,inp); |
| exp = (exp_node*)new app_node( |
| new var_node("K"), exp1, True); |
| } |
| }else |
| if( !left()->has_free(argr, &env) |
| && VAR==right()->op() |
| && right()->name() |
| && (inp&DO_EXTRACT_ETA) |
| && 0==strcmp( nm, right()->name()) ) |
| { |
| exp = (exp_node*)left()->clone(); |
| } |
| } |
| if( !exp ) |
| { |
| if( left() ) lft = left()->extract(nm,inp); |
| if( right() ) rgt = right()->extract(nm,inp); |
| if( nm ) |
| { |
| exp1 = (exp_node*)new app_node( |
| new var_node("S"),lft,True); |
| exp = (exp_node*)new app_node(exp1,rgt,True); |
| }else{ |
| exp = (exp_node*)new app_node(lft,rgt,True); |
| } |
| } |
| return exp; |
| } |
| |
| ////////////////////////////////////////////////////////////////////// |
| // alst_node's |
| arglst_node:: |
| arglst_node( arg_node* arg,arglst_node* next, Boolean import) |
| { |
| if( import) arg_v=arg; |
| else if( arg ) arg_v = (arg_node*)arg->clone(); |
| else arg_v = 0; |
| if( import ) next_v=next; |
| else if( next ) next_v = (arglst_node*)next->clone(); |
| else next_v = 0; |
| } |
| |
| arglst_node:: |
| arglst_node(const arglst_node& from) { |
| if( from.arg_v ) |
| arg_v = (arg_node*)from.arg_v->clone(); |
| else arg_v = 0; |
| if( from.next_v ) |
| next_v = (arglst_node*)from.next_v->clone(); |
| else arg_v = 0; |
| } |
| |
| |
| arglst_node:: |
| ~arglst_node() |
| { |
| if( arg_v ) delete arg_v; |
| if( next_v ) delete next_v; |
| } |
| alst_node* arglst_node:: |
| add(arg_node* anode,Boolean import) |
| { |
| arglst_node* retval = this; |
| arglst_node* where = 0; |
| if( !anode ) return where; |
| |
| for( arglst_node* lst=this; |
| lst; lst=(arglst_node*)lst->next() ) |
| { |
| if( lst->arg() && lst->arg()->name() ){ |
| if( 0==strcmp(anode->name(), |
| lst->arg_v->name())) |
| { |
| where = lst; |
| where->set_arg(anode, import); |
| break; |
| } |
| } |
| } |
| |
| if( !where){ |
| where = new arglst_node(anode,0,import); |
| where->next_v = this; |
| retval = where; |
| } |
| |
| return (alst_node*)retval; |
| } |
| |
| arg_node* arglst_node:: |
| find(arg_node* anode) |
| { |
| arglst_node* where = 0; |
| if( !anode ) return 0; |
| arglst_node* last = 0; |
| arg_node* arg = 0; |
| |
| for( arglst_node* lst=this; |
| lst; last = lst, lst=(arglst_node*)lst->next() ) |
| { |
| if( lst->arg() && lst->arg()->name() ){ |
| if( 0==strcmp(anode->name(), |
| lst->arg_v->name())) |
| { |
| where = lst; |
| break; |
| } |
| } |
| } |
| if( where ) arg = where->arg_v; |
| return arg; |
| } |
| |
| void arglst_node:: |
| set_arg(arg_node* nd, Boolean import) |
| { |
| if( arg_v == nd ) return; |
| if( arg_v ) delete arg_v; |
| if( import ) arg_v = nd; |
| else if( nd ) arg_v = (arg_node*)nd->clone(); |
| else arg_v = 0; |
| if( arg_v ) arg_v->set_parent(this); |
| } |
| |
| void arglst_node:: |
| list() |
| { |
| for(alst_node* pnode=(alst_node*)this;pnode; pnode=pnode->next() ) |
| { |
| if( pnode->arg() ) pnode->arg()->print(); |
| printf("\n"); |
| } |
| } |