+++ /dev/null
-/************************************************************************
- ************************************************************************
- FAUST compiler
- Copyright (C) 2003-2004 GRAME, Centre National de Creation Musicale
- ---------------------------------------------------------------------
- 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 of the License, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
- ************************************************************************
- ************************************************************************/
-
-
-
-/*****************************************************************************
-******************************************************************************
- LIST
- Y. Orlarey, (c) Grame 2002
-------------------------------------------------------------------------------
-This file contains several extensions to the tree library :
- - lists : based on a operations like cons, hd , tl, ...
- - environments : list of associations (key value)
- - property list : used to annotate trees
-
-
- API:
- ----
-
- List :
- -----
-
- nil = predefined empty list
- cons (x,l) = create a nex list of head x and tail l
- hd(cons(x,l)) = x,
- tl (cons(x,l)) = l
- nth(l,i) = ith element of l (or nil)
- replace(l,i,e) = a copy of l where the ith element is e
- len(l) = number of elements of l
- isNil(nil) = true (false otherwise)
- isList(cons(x,l)) = true (false otherwise)
- list(a,b,..) = cons(a, list(b,...))
-
- lmap(f, cons(x,l)) = cons(f(x), lmap(f,l))
- reverse([a,b,..,z]) = [z,..,b,a]
- reverseall([a,b,..,z]) = [ra(z),..,ra(b),ra(a)] where ra is reverseall
-
- Set :
- -----
- (Sets are implemented as ordered lists of elements without duplication)
-
- isElement(e,s) = true if e is an element of set s, false otherwise
- addElement(e,s) = s U {e}
- remElement(e,s) = s - {e}
- singleton(e) = {e}
- list2set(l) = convert a list into a set
- setUnion(s1,s2) = s1 U s2
- setIntersection(s1,s2) = s1 intersection s2
- setDifference(s1,s2) = s1 - s2
-
- Environment :
- -------------
-
- An 'environment' is a stack of pairs (key x value) used to keep track of lexical bindings
-
- pushEnv (key, val, env) -> env' create a new environment
- searchEnv (key,&v,env) -> bool search for key in env and set v accordingly
-
- search(k1,&v, push(k2,x,env)) = true and v is set to x if k1==k2
- = search(k1,&v,env) if k1 != k2
- Property list :
- ---------------
-
- Every tree can be annotated with an 'attribut' field. This attribute field
- can be used to manage a property list (pl). A property list is a list of pairs
- key x value, with three basic operations :
-
- setProperty (t, key, val) -> t add the association (key x val) to the pl of t
- getProperty (t, key, &val) -> bool search the pp of t for the value associated to key
- remProperty (t, key) -> t remove any association (key x ?) from the pl of t
-
- Warning :
- ---------
- Since reference counters are used for garbage collecting, one must be careful not to
- create cycles in trees. The only possible source of cycles is by setting the attribut
- of a tree t to a tree t' that contains t as a subtree.
-
- History :
- ---------
- 2002-02-08 : First version
- 2002-02-20 : New description of the API, non recursive lmap and reverse
- 2002-03-29 : Added function remElement(e,set), corrected comment error
-
-******************************************************************************
-*****************************************************************************/
-
-#include <stdlib.h>
-#include "list.hh"
-#include "compatibility.hh"
-#include <map>
-#include <cstdlib>
-
-// predefined symbols CONS and NIL
-Sym CONS = symbol("cons");
-Sym NIL = symbol("nil");
-
-// predefined nil tree
-Tree nil = tree(NIL);
-
-
-//------------------------------------------------------------------------------
-// Printing of trees with special case for lists
-//------------------------------------------------------------------------------
-
-static bool printlist (Tree l, FILE* out)
-{
- if (isList(l)) {
-
- char sep = '(';
-
- do {
- fputc(sep, out); sep = ',';
- print(hd(l));
- l = tl(l);
- } while (isList(l));
-
- if (! isNil(l)) {
- fprintf(out, " . ");
- print(l, out);
- }
-
- fputc(')', out);
- return true;
-
- } else if (isNil(l)) {
-
- fprintf(out, "nil");
- return true;
-
- } else {
-
- return false;
- }
-}
-
-void print (Tree t, FILE* out)
-{
- int i; double f; Sym s; void* p;
-
- if (printlist(t, out)) return;
-
- Node n = t->node();
- if (isInt(n, &i)) fprintf (out, "%d", i);
- else if (isDouble(n, &f)) fprintf (out, "%f", f);
- else if (isSym(n, &s)) fprintf (out, "%s", name(s));
- else if (isPointer(n, &p)) fprintf (out, "#%p", p);
-
- int k = t->arity();
- if (k > 0) {
- char sep = '[';
- for (int i=0; i<k; i++) {
- fputc(sep, out); sep = ',';
- print(t->branch(i), out);
- }
- fputc(']', out);
- }
-}
-
-
-//------------------------------------------------------------------------------
-// Elements of list
-//------------------------------------------------------------------------------
-
-Tree nth (Tree l, int i)
-{
- while (isList(l)) {
- if (i == 0) return hd(l);
- l = tl(l);
- i--;
- }
- return nil;
-}
-
-Tree replace(Tree l, int i, Tree e)
-{
- return (i==0) ? cons(e,tl(l)) : cons( hd(l), replace(tl(l),i-1,e) );
-}
-
-
-int len (Tree l)
-{
- int n = 0;
- while (isList(l)) { l = tl(l); n++; }
- return n;
-}
-
-
-//------------------------------------------------------------------------------
-// Mapping and reversing
-//------------------------------------------------------------------------------
-
-Tree rconcat (Tree l, Tree q)
-{
- while (isList(l)) { q = cons(hd(l),q); l = tl(l); }
- return q;
-}
-
-Tree concat (Tree l, Tree q)
-{
- return rconcat(reverse(l), q);
-}
-
-Tree lrange (Tree l, int i, int j)
-{
- Tree r = nil;
- int c = j;
- while (c>i) r = cons( nth(l,--c), r);
- return r;
-}
-
-//------------------------------------------------------------------------------
-// Mapping and reversing
-//------------------------------------------------------------------------------
-
-static Tree rmap (tfun f, Tree l)
-{
- Tree r = nil;
- while (isList(l)) { r = cons(f(hd(l)),r); l = tl(l); }
- return r;
-}
-
-Tree reverse (Tree l)
-{
- Tree r = nil;
- while (isList(l)) { r = cons(hd(l),r); l = tl(l); }
- return r;
-}
-
-Tree lmap (tfun f, Tree l)
-{
- return reverse(rmap(f,l));
-}
-
-Tree reverseall (Tree l)
-{
- return isList(l) ? rmap(reverseall, l) : l;
-}
-
-
-//------------------------------------------------------------------------------
-// Sets : implemented as ordered list
-//------------------------------------------------------------------------------
-
-bool isElement (Tree e, Tree l)
-{
- while (isList(l)) {
- if (hd(l) == e) return true;
- if (hd(l) > e) return false;
- l = tl(l);
- }
- return false;
-}
-
-Tree addElement(Tree e, Tree l)
-{
- if (isList(l)) {
- if (e < hd(l)) {
- return cons(e,l);
- } else if (e == hd(l)) {
- return l;
- } else {
- return cons(hd(l), addElement(e,tl(l)));
- }
- } else {
- return cons(e,nil);
- }
-}
-
-Tree remElement(Tree e, Tree l)
-{
- if (isList(l)) {
- if (e < hd(l)) {
- return l;
- } else if (e == hd(l)) {
- return tl(l);
- } else {
- return cons(hd(l), remElement(e,tl(l)));
- }
- } else {
- return nil;
- }
-}
-
-Tree singleton (Tree e)
-{
- return list1(e);
-}
-
-Tree list2set (Tree l)
-{
- Tree s = nil;
- while (isList(l)) {
- s = addElement(hd(l),s);
- l = tl(l);
- }
- return s;
-}
-
-Tree setUnion (Tree A, Tree B)
-{
- if (isNil(A)) return B;
- if (isNil(B)) return A;
-
- if (hd(A) == hd(B)) return cons(hd(A), setUnion(tl(A),tl(B)));
- if (hd(A) < hd(B)) return cons(hd(A), setUnion(tl(A),B));
- /* hd(A) > hd(B) */ return cons(hd(B), setUnion(A,tl(B)));
-}
-
-Tree setIntersection (Tree A, Tree B)
-{
- if (isNil(A)) return A;
- if (isNil(B)) return B;
- if (hd(A) == hd(B)) return cons(hd(A), setIntersection(tl(A),tl(B)));
- if (hd(A) < hd(B)) return setIntersection(tl(A),B);
- /* (hd(A) > hd(B)*/ return setIntersection(A,tl(B));
-}
-
-Tree setDifference (Tree A, Tree B)
-{
- if (isNil(A)) return A;
- if (isNil(B)) return A;
- if (hd(A) == hd(B)) return setDifference(tl(A),tl(B));
- if (hd(A) < hd(B)) return cons(hd(A), setDifference(tl(A),B));
- /* (hd(A) > hd(B)*/ return setDifference(A,tl(B));
-}
-
-
-
-//------------------------------------------------------------------------------
-// Environments
-//------------------------------------------------------------------------------
-
-Tree pushEnv (Tree key, Tree val, Tree env)
-{
- return cons (cons(key,val), env);
-}
-
-bool searchEnv (Tree key, Tree& v, Tree env)
-{
- while (isList(env)) {
- if (hd(hd(env)) == key) {
- v = tl(hd(env));
- return true;
- }
- env = tl(env);
- }
- return false;
-}
-
-
-//------------------------------------------------------------------------------
-// Property list
-//------------------------------------------------------------------------------
-
-static bool findKey (Tree pl, Tree key, Tree& val)
-{
- if (isNil(pl)) return false;
- if (left(hd(pl)) == key) { val= right(hd(pl)); return true; }
- /* left(hd(pl)) != key */ return findKey (tl(pl), key, val);
-}
-
-static Tree updateKey (Tree pl, Tree key, Tree val)
-{
- if (isNil(pl)) return cons ( cons(key,val), nil );
- if (left(hd(pl)) == key) return cons ( cons(key,val), tl(pl) );
- /* left(hd(pl)) != key */ return cons ( hd(pl), updateKey( tl(pl), key, val ));
-}
-
-static Tree removeKey (Tree pl, Tree key)
-{
- if (isNil(pl)) return nil;
- if (left(hd(pl)) == key) return tl(pl);
- /* left(hd(pl)) != key */ return cons (hd(pl), removeKey(tl(pl), key));
-}
-
-
-#if 0
-void setProperty (Tree t, Tree key, Tree val)
-{
- CTree* pl = t->attribut();
- if (pl) t->attribut(updateKey(pl, key, val));
- else t->attribut(updateKey(nil, key, val));
-}
-
-void remProperty (Tree t, Tree key)
-{
- CTree* pl = t->attribut();
- if (pl) t->attribut(removeKey(pl, key));
-}
-
-bool getProperty (Tree t, Tree key, Tree& val)
-{
- CTree* pl = t->attribut();
- if (pl) return findKey(pl, key, val);
- else return false;
-}
-
-#else
-// nouvelle implementation
-void setProperty (Tree t, Tree key, Tree val)
-{
- t->setProperty(key, val);
-}
-
-bool getProperty (Tree t, Tree key, Tree& val)
-{
- CTree* pl = t->getProperty(key);
- if (pl) {
- val = pl;
- return true;
- } else {
- return false;
- }
-}
-
-void remProperty (Tree t, Tree key)
-{
- exit(1); // fonction not implemented
-}
-#endif
-
-
-//------------------------------------------------------------------------------
-// Bottom Up Tree Mapping
-//------------------------------------------------------------------------------
-
-Tree tmap (Tree key, tfun f, Tree t)
-{
- //printf("start tmap\n");
- Tree p;
-
- if (getProperty(t, key, p)) {
-
- return (isNil(p)) ? t : p; // truc pour eviter les boucles
-
- } else {
-
- Tree r1=nil;
- switch (t->arity()) {
-
- case 0 :
- r1 = t;
- break;
- case 1 :
- r1 = tree(t->node(), tmap(key,f,t->branch(0)));
- break;
- case 2 :
- r1 = tree(t->node(), tmap(key,f,t->branch(0)), tmap(key,f,t->branch(1)));
- break;
- case 3 :
- r1 = tree(t->node(), tmap(key,f,t->branch(0)), tmap(key,f,t->branch(1)),
- tmap(key,f,t->branch(2)));
- break;
- case 4 :
- r1 = tree(t->node(), tmap(key,f,t->branch(0)), tmap(key,f,t->branch(1)),
- tmap(key,f,t->branch(2)), tmap(key,f,t->branch(3)));
- break;
- }
- Tree r2 = f(r1);
- if (r2 == t) {
- setProperty(t, key, nil);
- } else {
- setProperty(t, key, r2);
- }
- return r2;
- }
-}
-
-
-
-
-
-//------------------------------------------------------------------------------
-// substitute :remplace toutes les occurences de 'id' par 'val' dans 't'
-//------------------------------------------------------------------------------
-
-// genere une clef unique propre � cette substitution
-static Tree substkey(Tree t, Tree id, Tree val)
-{
- char name[256];
- snprintf(name, 255, "SUBST<%p,%p,%p> : ", (CTree*)t, (CTree*)id, (CTree*)val);
- return tree(unique(name));
-}
-
-// realise la substitution proprement dite tout en mettant � jour la propriete
-// pour ne pas avoir � la calculer deux fois
-
-static Tree subst (Tree t, Tree propkey, Tree id, Tree val)
-{
- Tree p;
-
- if (t==id) {
- return val;
-
- } else if (t->arity() == 0) {
- return t;
- } else if (getProperty(t, propkey, p)) {
- return (isNil(p)) ? t : p;
- } else {
- Tree r=nil;
- switch (t->arity()) {
-
- case 1 :
- r = tree(t->node(),
- subst(t->branch(0), propkey, id, val));
- break;
-
- case 2 :
- r = tree(t->node(),
- subst(t->branch(0), propkey, id, val),
- subst(t->branch(1), propkey, id, val));
- break;
-
- case 3 :
- r = tree(t->node(),
- subst(t->branch(0), propkey, id, val),
- subst(t->branch(1), propkey, id, val),
- subst(t->branch(2), propkey, id, val));
- break;
-
- case 4 :
- r = tree(t->node(),
- subst(t->branch(0), propkey, id, val),
- subst(t->branch(1), propkey, id, val),
- subst(t->branch(2), propkey, id, val),
- subst(t->branch(3), propkey, id, val));
- break;
-
- }
- if (r == t) {
- setProperty(t, propkey, nil);
- } else {
- setProperty(t, propkey, r);
- }
- return r;
- }
-
-}
-
-// remplace toutes les occurences de 'id' par 'val' dans 't'
-Tree substitute (Tree t, Tree id, Tree val)
-{
- return subst (t, substkey(t,id,val), id, val);
-}
-
-
-
-
-
-
-//------------------------------------------------------------------------------
-// Fun : implementation of functions as set of pairs (key x value)
-// such that key are uniques : forall (k1,v1) and (k2,v2) in F, k1=k2 ==> v1=v2
-// Uses the order on key to speedup search
-//------------------------------------------------------------------------------
-
-/**
- * Add a pair key x value to "function" l
- */
-Tree addFun(Tree k, Tree v, Tree l)
-{
- if (isList(l)) {
- Tree r = hd(hd(l));
- if (k < r) {
- return cons(cons(k,v),l);
- } else if (k == r) {
- return cons(cons(k,v),tl(l));
- } else {
- return cons(hd(l), addFun(k,v,tl(l)));
- }
- } else {
- return cons(cons(k,v),nil);
- }
-}
-
-/**
- * Get value associated to key k in "function" l
- * returns true if a value was found.
- */
-
-bool getFun(Tree k, Tree& v, Tree l)
-{
- if (isNil(l)) {
- return false;
- } else {
- assert (isList(l));
- Tree r = hd(hd(l));
- if (k < r) {
- return false;
- } else if (k == r) {
- v = tl(hd(l));
- return true;
- } else {
- return getFun(k,v,tl(l));
- }
- }
-}
-
-
projects / Faustine.git / blobdiff