projects / Faustine.git / blob
? search:


a0bdfe850b2cc5fd377ad5b45312f255788e7eba
[Faustine.git] / interpretor / 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
An OCaml-based interpreter for Faust and its vector extension