+++ /dev/null
-#include "environment.hh"
-#include "errormsg.hh"
-#include "boxes.hh"
-#include "ppbox.hh"
-#include "names.hh"
-
-
-//-----------------------new environment management----------------------------
-//
-// The environement is made of layers. Each layer contains a set of definitions
-// stored as properties of the layer. Each definition can refers to other
-// definitions of the same layer or of subsequent layers. Recursive
-// definitions are not allowed. Multiple defintions of the same symbol
-// in a layer is allowed but generate a warning when the definition is
-// different
-//-----------------------------------------------------------------------------
-
-
-
-/**
- * Push a new (unique) empty layer (where multiple definitions can be stored)
- * on top of an existing environment.
- * @param lenv the old environment
- * @return the new environment
-*/
-static Tree pushNewLayer(Tree lenv)
-{
- return tree(unique("ENV_LAYER"), lenv);
-}
-
-
-
-/**
- * Push a new environment barrier on top of an existing environment so
- * that searchIdDef (used by the pattern matcher) will not look after
- * the barrier. This barrier will not any influence on regular environment
- * lookup.
- * @param lenv the old environment
- * @return the new environment
-*/
-Sym BARRIER = symbol ("BARRIER");
-
-Tree pushEnvBarrier(Tree lenv)
-{
- return tree(BARRIER, lenv);
-}
-
-
-/**
- * Test if the environment is a barrier (or nil) so
- * that searchIdDef will know where to stop when searching
- * an environment.
- * @param lenv the environment to test
- * @return true is barrier reached
-*/
-bool isEnvBarrier(Tree lenv)
-{
- return isNil(lenv) || (lenv->node() == Node(BARRIER));
-}
-
-
-/**
- * Add a definition (as a property) to the current top level layer. Check
- * and warn for multiple definitions.
- * @param id the symbol id to be defined
- * @param def the definition to be binded to the symbol id
- * @param lenv the environment where to add this new definition
-*/
-static void addLayerDef(Tree id, Tree def, Tree lenv)
-{
- // check for multiple definitions of a symbol in the same layer
- Tree olddef;
- if (getProperty(lenv, id, olddef)) {
- if (def == olddef) {
- evalwarning(getDefFileProp(id), getDefLineProp(id), "equivalent re-definitions of", id);
- } else {
- fprintf(stderr, "%s:%d: ERROR: redefinition of symbols are not allowed : ", getDefFileProp(id), getDefLineProp(id));
- print(id,stderr);
- fprintf(stderr, " is already defined in file \"%s\" line %d \n", getDefFileProp(id), getDefLineProp(id));
- gErrorCount++;
- }
- }
- setProperty(lenv, id, def);
-}
-
-
-/**
- * Push a new layer and add a single definition.
- * @param id the symbol id to be defined
- * @param def the definition to be binded to the symbol id
- * @param lenv the environment where to push the layer and add the definition
- * @return the new environment
- */
-Tree pushValueDef(Tree id, Tree def, Tree lenv)
-{
- Tree lenv2 = pushNewLayer(lenv);
- addLayerDef(id, def, lenv2);
- return lenv2;
-}
-
-
-/**
- * Push a new layer with multiple definitions creating the appropriate closures
- * @param ldefs list of pairs (symbol id x definition) to be binded to the symbol id
- * @param visited set of visited symbols (used for recursive definition detection)
- * @param lenv the environment where to push the layer and add all the definitions
- * @return the new environment
-*/
-Tree pushMultiClosureDefs(Tree ldefs, Tree visited, Tree lenv)
-{
- Tree lenv2 = pushNewLayer(lenv);
- while (!isNil(ldefs)) {
- Tree def = hd(ldefs);
- Tree id = hd(def);
- Tree rhs= tl(def);
- Tree cl = closure(tl(def),nil,visited,lenv2);
- stringstream s; s << boxpp(id);
- if (!isBoxCase(rhs)) setDefNameProperty(cl,s.str());
- addLayerDef( id, cl, lenv2 );
- ldefs = tl(ldefs);
- }
- return lenv2;
-}
-
-
-/**
- * Search the environment (until first barrier) for
- * the definition of a symbol ID and return it. Used by the
- * pattern matcher.
- * @param id the symbol ID to search
- * @param def where to store the definition if any
- * @param lenv the environment
- * @return true if a definition was found
- */
-bool searchIdDef(Tree id, Tree& def, Tree lenv)
-{
- // search the environment until a definition is found
- // or a barrier (or nil) is reached
-
- while (!isEnvBarrier(lenv) && !getProperty(lenv, id, def)) {
- lenv = lenv->branch(0);
- }
- return !isEnvBarrier(lenv);
-}
-
-/**
- * Replace closure that point to oldEnv with closure on newEnv
- */
-static void updateClosures(vector<Tree>& clos, Tree oldEnv, Tree newEnv)
-{
- for (unsigned int i=0; i < clos.size(); i++) {
- Tree exp, genv, visited, lenv;
- if (isClosure(clos[i], exp, genv, visited, lenv)) {
- if (lenv == oldEnv) {
- clos[i] = closure(exp, genv, visited, newEnv);
- }
- }
- }
-}
-
-/**
- * Create a new environment by copying an existing one and replacing some definitions
- * @param xenv existing environment we will copy
- * @param ldefs list of pairs (symbol id x definition) that will replace old definitions
- * @param visited set of visited symbols (used for recursive definition detection)
- * @param lenv the current environment to evaluate the definitions
- * @return the new environment
-*/
-Tree copyEnvReplaceDefs(Tree anEnv, Tree ldefs, Tree visited, Tree curEnv)
-{
- vector<Tree> ids, clos;
- Tree copyEnv;
-
- anEnv->exportProperties(ids, clos); // get the definitions of the environment
- copyEnv = pushNewLayer(anEnv->branch(0)); // create new environment with same stack
- updateClosures(clos, anEnv, copyEnv); // update the closures replacing oldEnv with newEnv
-
- for (unsigned int i=0; i < clos.size(); i++) { // transfers the updated definitions to the new environment
- setProperty(copyEnv, ids[i], clos[i]);
- }
-
- while (!isNil(ldefs)) { // replace the old definitions with the new ones
- Tree def = hd(ldefs);
- Tree id = hd(def);
- Tree rhs= tl(def);
- Tree cl = closure(rhs,nil,visited,curEnv);
- stringstream s; s << boxpp(id);
- if (!isBoxCase(rhs)) setDefNameProperty(cl,s.str());
- setProperty(copyEnv, id, cl);
- ldefs = tl(ldefs);
- }
- return copyEnv;
-}
-
-
projects / Faustine.git / blobdiff