X-Git-Url: https://scm.cri.ensmp.fr/git/Faustine.git/blobdiff_plain/1059e1cc0c2ecfa237406949aa26155b6a5b9154..66f23d4fabf89ad09adbd4dfc15ac6b5b2b7da83:/interpretor/preprocessor/faust-0.9.47mr3/compiler/tlib/list.cpp diff --git a/interpretor/preprocessor/faust-0.9.47mr3/compiler/tlib/list.cpp b/interpretor/preprocessor/faust-0.9.47mr3/compiler/tlib/list.cpp deleted file mode 100644 index a0bdfe8..0000000 --- a/interpretor/preprocessor/faust-0.9.47mr3/compiler/tlib/list.cpp +++ /dev/null @@ -1,617 +0,0 @@ -/************************************************************************ - ************************************************************************ - 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 -#include "list.hh" -#include "compatibility.hh" -#include -#include - -// 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; ibranch(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)); - } - } -} - -