--- /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