interpretor/preprocessor/faust-0.9.47mr3/compiler/tlib/list.cpp

   1 /************************************************************************
   2  ************************************************************************
   3     FAUST compiler
   4         Copyright (C) 2003-2004 GRAME, Centre National de Creation Musicale
   5     ---------------------------------------------------------------------
   6     This program is free software; you can redistribute it and/or modify
   7     it under the terms of the GNU General Public License as published by
   8     the Free Software Foundation; either version 2 of the License, or
   9     (at your option) any later version.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14     GNU General Public License for more details.
  15
  16     You should have received a copy of the GNU General Public License
  17     along with this program; if not, write to the Free Software
  18     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19  ************************************************************************
  20  ************************************************************************/
  21
  22
  23
  24 /*****************************************************************************
  25 ******************************************************************************
  26                                                                 LIST
  27                                                 Y. Orlarey, (c) Grame 2002
  28 ------------------------------------------------------------------------------
  29 This file contains several extensions to the tree library :
  30         - lists : based on a operations like cons, hd , tl, ...
  31         - environments : list of associations (key value)
  32         - property list : used to annotate trees
  33
  34
  35  API:
  36  ----
  37
  38         List :
  39         -----
  40
  41         nil                                     = predefined empty list
  42         cons (x,l)                      = create a nex list of head x and tail l
  43         hd(cons(x,l))           = x,
  44         tl (cons(x,l))          = l
  45         nth(l,i)                        = ith element of l (or nil)
  46         replace(l,i,e)          = a copy of l where the ith element is e
  47         len(l)                          = number of elements of l
  48         isNil(nil)                      = true          (false otherwise)
  49         isList(cons(x,l))       = true          (false otherwise)
  50         list(a,b,..)            = cons(a, list(b,...))
  51
  52         lmap(f, cons(x,l))      = cons(f(x), lmap(f,l))
  53         reverse([a,b,..,z])     = [z,..,b,a]
  54         reverseall([a,b,..,z])  = [ra(z),..,ra(b),ra(a)] where ra is reverseall
  55
  56         Set :
  57         -----
  58         (Sets are implemented as ordered lists of elements without duplication)
  59
  60         isElement(e,s)                  = true if e is an element of set s, false otherwise
  61         addElement(e,s)                 = s U {e}
  62         remElement(e,s)                 = s - {e}
  63         singleton(e)                    = {e}
  64         list2set(l)                             = convert a list into a set
  65         setUnion(s1,s2)                 = s1 U s2
  66         setIntersection(s1,s2)  = s1 intersection s2
  67         setDifference(s1,s2)    = s1 - s2
  68
  69         Environment :
  70         -------------
  71
  72         An 'environment' is a stack of pairs (key x value) used to keep track of lexical bindings
  73
  74         pushEnv (key, val, env) -> env' create a new environment
  75         searchEnv (key,&v,env) -> bool  search for key in env and set v accordingly
  76
  77         search(k1,&v, push(k2,x,env))   = true and v is set to x if k1==k2
  78                                                                         = search(k1,&v,env) if k1 != k2
  79         Property list :
  80         ---------------
  81
  82         Every tree can be annotated with an 'attribut' field. This attribute field
  83         can be used to manage a property list (pl). A property list is a list of pairs
  84         key x value, with three basic operations :
  85
  86         setProperty (t, key, val) -> t          add the association (key x val) to the pl of t
  87         getProperty (t, key, &val) -> bool      search the pp of t for the value associated to key
  88         remProperty (t, key) -> t                       remove any association (key x ?) from the pl of t
  89
  90  Warning :
  91  ---------
  92  Since reference counters are used for garbage collecting, one must be careful not to
  93  create cycles in trees. The only possible source of cycles is by setting the attribut
  94  of a tree t to a tree t' that contains t as a subtree.
  95
  96  History :
  97  ---------
  98         2002-02-08 : First version
  99         2002-02-20 : New description of the API, non recursive lmap and reverse
 100         2002-03-29 : Added function remElement(e,set), corrected comment error
 101
 102 ******************************************************************************
 103 *****************************************************************************/
 104
 105 #include <stdlib.h>
 106 #include "list.hh"
 107 #include "compatibility.hh"
 108 #include <map>
 109 #include <cstdlib>
 110
 111 // predefined symbols CONS and NIL
 112 Sym CONS = symbol("cons");
 113 Sym NIL  = symbol("nil");
 114
 115 // predefined nil tree
 116 Tree nil = tree(NIL);
 117
 118
 119 //------------------------------------------------------------------------------
 120 // Printing of trees with special case for lists
 121 //------------------------------------------------------------------------------
 122
 123 static bool printlist (Tree l, FILE* out)
 124 {
 125         if (isList(l)) {
 126
 127                 char sep = '(';
 128
 129                 do {
 130                         fputc(sep, out); sep = ',';
 131                         print(hd(l));
 132                         l = tl(l);
 133                 } while (isList(l));
 134
 135                 if (! isNil(l)) {
 136                         fprintf(out, " . ");
 137                         print(l, out);
 138                 }
 139
 140                 fputc(')', out);
 141                 return true;
 142
 143         } else if (isNil(l)) {
 144
 145                 fprintf(out, "nil");
 146                 return true;
 147
 148         } else {
 149
 150                 return false;
 151         }
 152 }
 153
 154 void print (Tree t, FILE* out)
 155 {
 156         int i; double f; Sym s; void* p;
 157
 158         if (printlist(t, out))          return;
 159
 160         Node n = t->node();
 161                  if (isInt(n, &i))              fprintf (out, "%d", i);
 162         else if (isDouble(n, &f))       fprintf (out, "%f", f);
 163         else if (isSym(n, &s))          fprintf (out, "%s", name(s));
 164         else if (isPointer(n, &p))      fprintf (out, "#%p", p);
 165
 166         int k = t->arity();
 167         if (k > 0) {
 168                 char sep = '[';
 169                 for (int i=0; i<k; i++) {
 170                         fputc(sep, out); sep = ',';
 171                         print(t->branch(i), out);
 172                 }
 173                 fputc(']', out);
 174         }
 175 }
 176
 177
 178 //------------------------------------------------------------------------------
 179 // Elements of list
 180 //------------------------------------------------------------------------------
 181
 182 Tree nth (Tree l, int i)
 183 {
 184         while (isList(l)) {
 185                 if (i == 0)  return hd(l);
 186                 l = tl(l);
 187                 i--;
 188         }
 189         return nil;
 190 }
 191
 192 Tree replace(Tree l, int i, Tree e)
 193 {
 194         return (i==0) ? cons(e,tl(l)) : cons( hd(l), replace(tl(l),i-1,e) );
 195 }
 196
 197
 198 int len (Tree l)
 199 {
 200         int     n = 0;
 201         while (isList(l)) { l = tl(l); n++; }
 202         return n;
 203 }
 204
 205
 206 //------------------------------------------------------------------------------
 207 // Mapping and reversing
 208 //------------------------------------------------------------------------------
 209
 210 Tree rconcat (Tree l, Tree q)
 211 {
 212         while (isList(l)) { q = cons(hd(l),q); l = tl(l); }
 213         return q;
 214 }
 215
 216 Tree concat (Tree l, Tree q)
 217 {
 218         return rconcat(reverse(l), q);
 219 }
 220
 221 Tree lrange (Tree l, int i, int j)
 222 {
 223         Tree    r = nil;
 224         int     c = j;
 225         while (c>i) r = cons( nth(l,--c), r);
 226         return r;
 227 }
 228
 229 //------------------------------------------------------------------------------
 230 // Mapping and reversing
 231 //------------------------------------------------------------------------------
 232
 233 static Tree rmap (tfun f, Tree l)
 234 {
 235         Tree r = nil;
 236         while (isList(l)) { r = cons(f(hd(l)),r); l = tl(l); }
 237         return r;
 238 }
 239
 240 Tree reverse (Tree l)
 241 {
 242         Tree r = nil;
 243         while (isList(l)) { r = cons(hd(l),r); l = tl(l); }
 244         return r;
 245 }
 246
 247 Tree lmap (tfun f, Tree l)
 248 {
 249         return reverse(rmap(f,l));
 250 }
 251
 252 Tree reverseall (Tree l)
 253 {
 254         return isList(l) ? rmap(reverseall, l) : l;
 255 }
 256
 257
 258 //------------------------------------------------------------------------------
 259 // Sets : implemented as ordered list
 260 //------------------------------------------------------------------------------
 261
 262 bool isElement (Tree e, Tree l)
 263 {
 264         while (isList(l)) {
 265                 if (hd(l) == e) return true;
 266                 if (hd(l) > e) return false;
 267                 l = tl(l);
 268         }
 269         return false;
 270 }
 271
 272 Tree addElement(Tree e, Tree l)
 273 {
 274         if (isList(l)) {
 275                 if (e < hd(l)) {
 276                         return cons(e,l);
 277                 } else if (e == hd(l)) {
 278                         return l;
 279                 } else {
 280                         return cons(hd(l), addElement(e,tl(l)));
 281                 }
 282         } else {
 283                 return cons(e,nil);
 284         }
 285 }
 286
 287 Tree remElement(Tree e, Tree l)
 288 {
 289         if (isList(l)) {
 290                 if (e < hd(l)) {
 291                         return l;
 292                 } else if (e == hd(l)) {
 293                         return tl(l);
 294                 } else {
 295                         return cons(hd(l), remElement(e,tl(l)));
 296                 }
 297         } else {
 298                 return nil;
 299         }
 300 }
 301
 302 Tree singleton (Tree e)
 303 {
 304         return list1(e);
 305 }
 306
 307 Tree list2set (Tree l)
 308 {
 309         Tree s = nil;
 310         while (isList(l)) {
 311                 s = addElement(hd(l),s);
 312                 l = tl(l);
 313         }
 314         return s;
 315 }
 316
 317 Tree setUnion (Tree A, Tree B)
 318 {
 319         if (isNil(A))           return B;
 320         if (isNil(B))           return A;
 321
 322         if (hd(A) == hd(B)) return cons(hd(A), setUnion(tl(A),tl(B)));
 323         if (hd(A) < hd(B))      return cons(hd(A), setUnion(tl(A),B));
 324         /* hd(A) > hd(B) */     return cons(hd(B), setUnion(A,tl(B)));
 325 }
 326
 327 Tree setIntersection (Tree A, Tree B)
 328 {
 329         if (isNil(A))           return A;
 330         if (isNil(B))           return B;
 331         if (hd(A) == hd(B)) return cons(hd(A), setIntersection(tl(A),tl(B)));
 332         if (hd(A) < hd(B))      return setIntersection(tl(A),B);
 333         /* (hd(A) > hd(B)*/     return setIntersection(A,tl(B));
 334 }
 335
 336 Tree setDifference (Tree A, Tree B)
 337 {
 338         if (isNil(A))           return A;
 339         if (isNil(B))           return A;
 340         if (hd(A) == hd(B)) return setDifference(tl(A),tl(B));
 341         if (hd(A) < hd(B))      return cons(hd(A), setDifference(tl(A),B));
 342         /* (hd(A) > hd(B)*/     return setDifference(A,tl(B));
 343 }
 344
 345
 346
 347 //------------------------------------------------------------------------------
 348 // Environments
 349 //------------------------------------------------------------------------------
 350
 351 Tree pushEnv (Tree key, Tree val, Tree env)
 352 {
 353         return cons (cons(key,val), env);
 354 }
 355
 356 bool searchEnv (Tree key, Tree& v, Tree env)
 357 {
 358         while (isList(env)) {
 359                 if (hd(hd(env)) == key) {
 360                         v = tl(hd(env));
 361                         return true;
 362                 }
 363                 env = tl(env);
 364         }
 365         return false;
 366 }
 367
 368
 369 //------------------------------------------------------------------------------
 370 // Property list
 371 //------------------------------------------------------------------------------
 372
 373 static bool findKey (Tree pl, Tree key, Tree& val)
 374 {
 375         if (isNil(pl))                          return false;
 376         if (left(hd(pl)) == key)        { val= right(hd(pl)); return true; }
 377         /*  left(hd(pl)) != key */      return findKey (tl(pl), key, val);
 378 }
 379
 380 static Tree updateKey (Tree pl, Tree key, Tree val)
 381 {
 382         if (isNil(pl))                          return cons ( cons(key,val), nil );
 383         if (left(hd(pl)) == key)        return cons ( cons(key,val), tl(pl) );
 384         /*  left(hd(pl)) != key */      return cons ( hd(pl), updateKey( tl(pl), key, val ));
 385 }
 386
 387 static Tree removeKey (Tree pl, Tree key)
 388 {
 389         if (isNil(pl))                          return nil;
 390         if (left(hd(pl)) == key)        return tl(pl);
 391         /*  left(hd(pl)) != key */      return cons (hd(pl), removeKey(tl(pl), key));
 392 }
 393
 394
 395 #if 0
 396 void setProperty (Tree t, Tree key, Tree val)
 397 {
 398         CTree* pl = t->attribut();
 399         if (pl) t->attribut(updateKey(pl, key, val));
 400         else    t->attribut(updateKey(nil, key, val));
 401 }
 402
 403 void remProperty (Tree t, Tree key)
 404 {
 405         CTree* pl = t->attribut();
 406         if (pl) t->attribut(removeKey(pl, key));
 407 }
 408
 409 bool getProperty (Tree t, Tree key, Tree& val)
 410 {
 411         CTree* pl = t->attribut();
 412         if (pl) return findKey(pl, key, val);
 413         else    return false;
 414 }
 415
 416 #else
 417 // nouvelle implementation
 418 void setProperty (Tree t, Tree key, Tree val)
 419 {
 420         t->setProperty(key, val);
 421 }
 422
 423 bool getProperty (Tree t, Tree key, Tree& val)
 424 {
 425         CTree* pl = t->getProperty(key);
 426         if (pl) {
 427                 val = pl;
 428                 return true;
 429         } else {
 430                 return false;
 431         }
 432 }
 433
 434 void remProperty (Tree t, Tree key)
 435 {
 436         exit(1); // fonction not implemented
 437 }
 438 #endif
 439
 440
 441 //------------------------------------------------------------------------------
 442 // Bottom Up Tree Mapping
 443 //------------------------------------------------------------------------------
 444
 445 Tree tmap (Tree key, tfun f, Tree t)
 446 {
 447         //printf("start tmap\n");
 448         Tree p;
 449
 450         if (getProperty(t, key, p)) {
 451
 452                 return (isNil(p)) ? t : p;      // truc pour eviter les boucles
 453
 454         } else {
 455
 456                 Tree r1=nil;
 457                 switch (t->arity()) {
 458
 459                         case 0 :
 460                                 r1 = t;
 461                                 break;
 462                         case 1 :
 463                                 r1 = tree(t->node(), tmap(key,f,t->branch(0)));
 464                                 break;
 465                         case 2 :
 466                                 r1 = tree(t->node(), tmap(key,f,t->branch(0)), tmap(key,f,t->branch(1)));
 467                                 break;
 468                         case 3 :
 469                                 r1 = tree(t->node(), tmap(key,f,t->branch(0)), tmap(key,f,t->branch(1)),
 470                                                                                    tmap(key,f,t->branch(2)));
 471                                 break;
 472                         case 4 :
 473                                 r1 = tree(t->node(), tmap(key,f,t->branch(0)), tmap(key,f,t->branch(1)),
 474                                                                                    tmap(key,f,t->branch(2)), tmap(key,f,t->branch(3)));
 475                                 break;
 476                 }
 477                 Tree r2 = f(r1);
 478                 if (r2 == t) {
 479                         setProperty(t, key, nil);
 480                 } else {
 481                         setProperty(t, key, r2);
 482                 }
 483                 return r2;
 484         }
 485 }
 486
 487
 488
 489
 490
 491 //------------------------------------------------------------------------------
 492 // substitute :remplace toutes les occurences de 'id' par 'val' dans 't'
 493 //------------------------------------------------------------------------------
 494
 495 // genere une clef unique propre � cette substitution
 496 static Tree substkey(Tree t, Tree id, Tree val)
 497 {
 498         char    name[256];
 499         snprintf(name, 255, "SUBST<%p,%p,%p> : ", (CTree*)t, (CTree*)id, (CTree*)val);
 500         return tree(unique(name));
 501 }
 502
 503 // realise la substitution proprement dite tout en mettant � jour la propriete
 504 // pour ne pas avoir � la calculer deux fois
 505
 506 static Tree subst (Tree t, Tree propkey, Tree id, Tree val)
 507 {
 508         Tree p;
 509
 510         if (t==id) {
 511                 return val;
 512
 513         } else if (t->arity() == 0) {
 514                 return t;
 515         } else if (getProperty(t, propkey, p)) {
 516                 return (isNil(p)) ?  t : p;
 517         } else {
 518                 Tree r=nil;
 519                 switch (t->arity()) {
 520
 521                         case 1 :
 522                                 r = tree(t->node(),
 523                                                         subst(t->branch(0), propkey, id, val));
 524                                 break;
 525
 526                         case 2 :
 527                                 r = tree(t->node(),
 528                                                         subst(t->branch(0), propkey, id, val),
 529                                                         subst(t->branch(1), propkey, id, val));
 530                                 break;
 531
 532                         case 3 :
 533                                 r = tree(t->node(),
 534                                                         subst(t->branch(0), propkey, id, val),
 535                                                         subst(t->branch(1), propkey, id, val),
 536                                                         subst(t->branch(2), propkey, id, val));
 537                                 break;
 538
 539                         case 4 :
 540                                 r = tree(t->node(),
 541                                                         subst(t->branch(0), propkey, id, val),
 542                                                         subst(t->branch(1), propkey, id, val),
 543                                                         subst(t->branch(2), propkey, id, val),
 544                                                         subst(t->branch(3), propkey, id, val));
 545                                 break;
 546
 547                 }
 548                 if (r == t) {
 549                         setProperty(t, propkey, nil);
 550                 } else {
 551                         setProperty(t, propkey, r);
 552                 }
 553                 return r;
 554         }
 555
 556 }
 557
 558 // remplace toutes les occurences de 'id' par 'val' dans 't'
 559 Tree substitute (Tree t, Tree id, Tree val)
 560 {
 561         return subst (t, substkey(t,id,val), id, val);
 562 }
 563
 564
 565
 566
 567
 568
 569 //------------------------------------------------------------------------------
 570 // Fun : implementation of functions as set of pairs (key x value)
 571 // such that key are uniques : forall (k1,v1) and (k2,v2) in F, k1=k2 ==> v1=v2
 572 // Uses the order on key to speedup search
 573 //------------------------------------------------------------------------------
 574
 575 /**
 576   * Add a pair key x value to "function" l
 577   */
 578 Tree addFun(Tree k, Tree v, Tree l)
 579 {
 580     if (isList(l)) {
 581         Tree r = hd(hd(l));
 582         if (k < r) {
 583             return cons(cons(k,v),l);
 584         } else if (k == r) {
 585             return cons(cons(k,v),tl(l));
 586         } else {
 587             return cons(hd(l), addFun(k,v,tl(l)));
 588         }
 589     } else {
 590         return cons(cons(k,v),nil);
 591     }
 592 }
 593
 594 /**
 595   * Get value associated to key k in "function" l
 596   * returns true if a value was found.
 597   */
 598
 599 bool getFun(Tree k, Tree& v, Tree l)
 600 {
 601     if (isNil(l)) {
 602         return false;
 603     } else {
 604         assert (isList(l));
 605         Tree r = hd(hd(l));
 606         if (k < r) {
 607             return false;
 608         } else if (k == r) {
 609             v = tl(hd(l));
 610             return true;
 611         } else {
 612             return getFun(k,v,tl(l));
 613         }
 614     }
 615 }
 616
 617