1
2#include <string.h>
3#include "tcl.h"
4#include <t.h>
5#include <util.h>
6
7/* .................................................. */
8
9static int t_walkdfspre	 (Tcl_Interp* interp, TN* tdn, t_walk_function f,
10			  Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
11			  Tcl_Obj* action);
12static int t_walkdfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f,
13			  Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
14			  Tcl_Obj* action);
15static int t_walkdfsin	 (Tcl_Interp* interp, TN* tdn, t_walk_function f,
16			  Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
17			  Tcl_Obj* action);
18static int t_walkdfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f,
19			  Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
20			  Tcl_Obj* enter, Tcl_Obj* leave);
21static int t_walkbfspre	 (Tcl_Interp* interp, TN* tdn, t_walk_function f,
22			  Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
23			  Tcl_Obj* action);
24static int t_walkbfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f,
25			  Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
26			  Tcl_Obj* action);
27static int t_walkbfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f,
28			  Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
29			  Tcl_Obj* enter, Tcl_Obj* leave);
30
31/* .................................................. */
32
33int
34t_walkoptions (Tcl_Interp* interp, int n,
35	       int objc, Tcl_Obj* CONST* objv,
36	       int* type, int* order, int* remainder,
37	       char* usage)
38{
39    int i;
40    Tcl_Obj* otype  = NULL;
41    Tcl_Obj* oorder = NULL;
42
43    static CONST char* wtypes [] = {
44	"bfs", "dfs", NULL
45    };
46    static CONST char* worders [] = {
47	"both", "in", "pre", "post", NULL
48    };
49
50    for (i = 3; i < objc; ) {
51	ASSERT_BOUNDS (i, objc);
52	if (0 == strcmp ("-type", Tcl_GetString (objv [i]))) {
53	    if (objc == (i+1)) {
54		Tcl_AppendResult (interp,
55				  "value for \"-type\" missing",
56				  NULL);
57		return TCL_ERROR;
58	    }
59
60	    ASSERT_BOUNDS (i+1, objc);
61	    otype = objv [i+1];
62	    i += 2;
63
64	} else if (0 == strcmp ("-order", Tcl_GetString (objv [i]))) {
65	    if (objc == (i+1)) {
66		Tcl_AppendResult (interp,
67				  "value for \"-order\" missing",
68				  NULL);
69		return TCL_ERROR;
70	    }
71
72	    ASSERT_BOUNDS (i+1, objc);
73	    oorder = objv [i+1];
74	    i += 2;
75
76	} else if (0 == strcmp ("--", Tcl_GetString (objv [i]))) {
77	    i++;
78	    break;
79	} else {
80	    break;
81	}
82    }
83
84    if (i == objc) {
85	Tcl_WrongNumArgs (interp, 2, objv, usage);
86	return TCL_ERROR;
87    }
88
89    if ((objc - i) > n) {
90	Tcl_AppendResult (interp, "unknown option \"", NULL);
91	Tcl_AppendResult (interp, Tcl_GetString (objv [i]), NULL);
92	Tcl_AppendResult (interp, "\"", NULL);
93	return TCL_ERROR;
94    }
95
96    if (!otype) {
97	*type = WT_DFS;
98    } else if (Tcl_GetIndexFromObj (interp, otype, wtypes, "search type",
99				    0, type) != TCL_OK) {
100	return TCL_ERROR;
101    }
102
103    if (!oorder) {
104	*order = WO_PRE;
105    } else if (Tcl_GetIndexFromObj (interp, oorder, worders, "search order",
106				    0, order) != TCL_OK) {
107	return TCL_ERROR;
108    }
109
110    if ((*order == WO_IN) && (*type == WT_BFS)) {
111	Tcl_AppendResult (interp,
112			  "unable to do a in-order breadth first walk",
113			  NULL);
114	return TCL_ERROR;
115    }
116
117    *remainder = i;
118    return TCL_OK;
119}
120
121/* .................................................. */
122
123int
124t_walk (Tcl_Interp* interp, TN* tdn, int type, int order,
125	t_walk_function f, Tcl_Obj* cs,
126	Tcl_Obj* avn, Tcl_Obj* nvn)
127{
128    int	     res;
129    Tcl_Obj* la = NULL;
130    Tcl_Obj* lb = NULL;
131
132    switch (type)
133	{
134	case WT_DFS:
135	    switch (order)
136		{
137		case WO_BOTH:
138		    la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
139		    lb = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (lb);
140
141		    res = t_walkdfsboth (interp, tdn, f, cs, avn, nvn, la, lb);
142
143		    Tcl_DecrRefCount (la);
144		    Tcl_DecrRefCount (lb);
145		    break;
146
147		case WO_IN:
148		    la = Tcl_NewStringObj ("visit",-1); Tcl_IncrRefCount (la);
149
150		    res = t_walkdfsin	(interp, tdn, f, cs, avn, nvn, la);
151
152		    Tcl_DecrRefCount (la);
153		    break;
154
155		case WO_PRE:
156		    la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
157
158		    res = t_walkdfspre	(interp, tdn, f, cs, avn, nvn, la);
159
160		    Tcl_DecrRefCount (la);
161		    break;
162
163		case WO_POST:
164		    la = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (la);
165
166		    res = t_walkdfspost (interp, tdn, f, cs, avn, nvn, la);
167
168		    Tcl_DecrRefCount (la);
169		    break;
170		}
171	    break;
172
173	case WT_BFS:
174	    switch (order)
175		{
176		case WO_BOTH:
177		    la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
178		    lb = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (lb);
179
180		    res = t_walkbfsboth (interp, tdn, f, cs, avn, nvn, la, lb);
181
182		    Tcl_DecrRefCount (la);
183		    Tcl_DecrRefCount (lb);
184		    break;
185
186		case WO_PRE:
187		    la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la);
188
189		    res = t_walkbfspre	(interp, tdn, f, cs, avn, nvn, la);
190
191		    Tcl_DecrRefCount (la);
192		    break;
193
194		case WO_POST:
195		    la = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (la);
196
197		    res = t_walkbfspost (interp, tdn, f, cs, avn, nvn, la);
198
199		    Tcl_DecrRefCount (la);
200		    break;
201		}
202	    break;
203	}
204
205    /* Error and Return are passed unchanged. Everything else is ok */
206
207    if (res == TCL_ERROR)  {return res;}
208    if (res == TCL_RETURN) {return res;}
209    return TCL_OK;
210}
211
212
213/* .................................................. */
214
215int
216t_walk_invokescript (Tcl_Interp* interp, TN* n, Tcl_Obj* cs,
217		     Tcl_Obj* avn, Tcl_Obj* nvn,
218		     Tcl_Obj* action)
219{
220    int res;
221
222    /* Note: Array elements, like 'a(x)', are not possible as iterator variables */
223
224    if (avn) {
225	Tcl_ObjSetVar2 (interp, avn, NULL, action, 0);
226    }
227    Tcl_ObjSetVar2 (interp, nvn, NULL, n->name, 0);
228
229    res = Tcl_EvalObj(interp, cs);
230
231    return res;
232}
233
234int
235t_walk_invokecmd (Tcl_Interp* interp, TN* n, Tcl_Obj* dummy0,
236		  Tcl_Obj* dummy1, Tcl_Obj* dummy2,
237		  Tcl_Obj* action)
238{
239    int	      res;
240    int	      cc = (int)       dummy0;
241    Tcl_Obj** ev = (Tcl_Obj**) dummy1; /* cc+3 elements */
242
243    ev [cc]   = dummy2;	   /* Tree */
244    ev [cc+1] = n->name;   /* Node */
245    ev [cc+2] = action;	   /* Action */
246
247    Tcl_IncrRefCount (ev [cc]);
248    Tcl_IncrRefCount (ev [cc+1]);
249    Tcl_IncrRefCount (ev [cc+2]);
250
251    res = Tcl_EvalObjv (interp, cc+3, ev, 0);
252
253    Tcl_DecrRefCount (ev [cc]);
254    Tcl_DecrRefCount (ev [cc+1]);
255    Tcl_DecrRefCount (ev [cc+2]);
256
257    return res;
258}
259
260/* .................................................. */
261
262static int
263t_walkdfspre (Tcl_Interp* interp, TN* tdn, t_walk_function f,
264	      Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
265	      Tcl_Obj* action)
266{
267    /* ok	- next node
268     * error	- abort walking
269     * break	- abort walking
270     * continue - next node
271     * return	- abort walking
272     * prune /5 - skip children, otherwise ok.
273     */
274
275    int res;
276
277    /* Parent before children, action is 'enter'. */
278
279    res = (*f) (interp, tdn, cs, avn, nvn, action);
280
281    if (res == 5) {
282	return TCL_OK;
283    } else if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
284	return res;
285    }
286
287    if (tdn->nchildren) {
288	/* We make a copy of the child array. This emulates the behaviour of
289	 * the Tcl implementation, which will walk to a child of this node,
290	 * even if the loop body/procedure moved it to a different node before
291	 * it was reached by the loop here. If the node it the child is moved
292	 * to was already visited nothing else will happen. Ortherwise the
293	 * child will be visited multiple times.
294	 */
295
296	int i;
297	int  nc = tdn->nchildren;
298	TN** nv = NALLOC (nc,TN*);
299	memcpy (nv, tdn->child, nc*sizeof(TN*));
300
301	for (i = 0; i < nc; i++) {
302	    res = t_walkdfspre (interp, nv [i], f, cs, avn, nvn, action);
303
304	    /* prune, continue cannot occur, were transformed into ok
305	     * by the child.
306	     */
307
308	    if (res != TCL_OK) {
309		ckfree ((char*) nv);
310		return res;
311	    }
312	}
313
314	ckfree ((char*) nv);
315    }
316
317    return TCL_OK;
318}
319
320static int
321t_walkdfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f,
322	       Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
323	       Tcl_Obj* action)
324{
325    int res;
326
327    /* Parent after children, action is 'leave'. */
328
329    if (tdn->nchildren) {
330	/* We make a copy of the child array. This emulates the behaviour of
331	 * the Tcl implementation, which will walk to a child of this node,
332	 * even if the loop body/procedure moved it to a different node before
333	 * it was reached by the loop here. If the node it the child is moved
334	 * to was already visited nothing else will happen. Ortherwise the
335	 * child will be visited multiple times.
336	 */
337
338	int i;
339
340	int  nc = tdn->nchildren;
341	TN** nv = NALLOC (nc,TN*);
342	memcpy (nv, tdn->child, nc*sizeof(TN*));
343
344	for (i = 0; i < nc; i++) {
345	    res = t_walkdfspost (interp, nv [i], f, cs, avn, nvn, action);
346
347	    if ((res == TCL_ERROR) ||
348		(res == TCL_BREAK) ||
349		(res == TCL_RETURN)) {
350		ckfree ((char*) nv);
351		return res;
352	    }
353	}
354
355	ckfree ((char*) nv);
356    }
357
358    res = (*f) (interp, tdn, cs, avn, nvn, action);
359
360    if ((res == TCL_ERROR) ||
361	(res == TCL_BREAK) ||
362	(res == TCL_RETURN)) {
363	return res;
364    } else if (res == 5) {
365	/* Illegal pruning */
366
367	Tcl_ResetResult (interp);
368	Tcl_AppendResult (interp,
369			  "Illegal attempt to prune post-order walking", NULL);
370	return TCL_ERROR;
371    }
372
373    return TCL_OK;
374}
375
376static int
377t_walkdfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f,
378	       Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
379	       Tcl_Obj* enter, Tcl_Obj* leave)
380{
381    /* ok	- next node
382     * error	- abort walking
383     * break	- abort walking
384     * continue - next node
385     * return	- abort walking
386     * prune /5 - skip children, otherwise ok.
387     */
388
389    int res;
390
391    /* Parent before and after Children, action is 'enter' & 'leave'. */
392
393    res = (*f) (interp, tdn, cs, avn, nvn, enter);
394
395    if (res != 5) {
396	if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
397	    return res;
398	}
399
400	if (tdn->nchildren) {
401	    int i;
402	    int  nc = tdn->nchildren;
403	    TN** nv = NALLOC (nc,TN*);
404	    memcpy (nv, tdn->child, nc*sizeof(TN*));
405
406	    for (i = 0; i < nc; i++) {
407		res = t_walkdfsboth (interp, nv [i], f, cs, avn, nvn, enter, leave);
408
409		/* prune, continue cannot occur, were transformed into ok
410		 * by the child.
411		 */
412
413		if (res != TCL_OK) {
414		    ckfree ((char*) nv);
415		    return res;
416		}
417	    }
418
419	    ckfree ((char*) nv);
420	}
421    }
422
423    res = (*f) (interp, tdn, cs, avn, nvn, leave);
424
425    if (res == 5) {
426	return TCL_OK;
427    } else if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
428	return res;
429    }
430
431    return TCL_OK;
432}
433
434static int
435t_walkdfsin (Tcl_Interp* interp, TN* tdn, t_walk_function f,
436	     Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
437	     Tcl_Obj* action)
438{
439    int res;
440
441    /* First child visited first, then parent, then */
442    /* the remaining children. Action is 'visit'.   */
443    /* This is the correct thing for binary trees.  */
444    /* For #children <= 1 the parent is visited */
445    /* before the child */
446
447    if (tdn->nchildren == 0) {
448	res = (*f) (interp, tdn, cs, avn, nvn, action);
449
450	if ((res == TCL_ERROR) ||
451	    (res == TCL_BREAK) ||
452	    (res == TCL_RETURN)) {
453	    return res;
454	} else if (res == 5) {
455	    /* Illegal pruning */
456
457	    Tcl_ResetResult (interp);
458	    Tcl_AppendResult (interp,
459			      "Illegal attempt to prune in-order walking", NULL);
460	    return TCL_ERROR;
461	}
462
463    } else if (tdn->nchildren == 1) {
464	res = (*f) (interp, tdn, cs, avn, nvn, action);
465
466	if ((res == TCL_ERROR) ||
467	    (res == TCL_BREAK) ||
468	    (res == TCL_RETURN)) {
469	    return res;
470	} else if (res == 5) {
471	    /* Illegal pruning */
472
473	    Tcl_ResetResult (interp);
474	    Tcl_AppendResult (interp,
475			      "Illegal attempt to prune in-order walking", NULL);
476	    return TCL_ERROR;
477	}
478
479	return t_walkdfsin (interp, tdn->child [0], f, cs, avn, nvn, action);
480
481    } else {
482	int i;
483	int  nc = tdn->nchildren;
484	TN** nv = NALLOC (nc,TN*);
485	memcpy (nv, tdn->child, nc*sizeof(TN*));
486
487	res = t_walkdfsin (interp, tdn->child [0], f, cs, avn, nvn, action);
488
489	if ((res == TCL_ERROR) ||
490	    (res == TCL_BREAK) ||
491	    (res == TCL_RETURN)) {
492	    ckfree ((char*) nv);
493	    return res;
494	}
495
496	res = (*f) (interp, tdn, cs, avn, nvn, action);
497
498	if ((res == TCL_ERROR) ||
499	    (res == TCL_BREAK) ||
500	    (res == TCL_RETURN)) {
501	    ckfree ((char*) nv);
502	    return res;
503	} else if (res == 5) {
504	    /* Illegal pruning */
505	    ckfree ((char*) nv);
506
507	    Tcl_ResetResult (interp);
508	    Tcl_AppendResult (interp,
509			      "Illegal attempt to prune in-order walking", NULL);
510	    return TCL_ERROR;
511	}
512
513	for (i = 1; i < nc; i++) {
514	    res = t_walkdfsin (interp, nv [i], f, cs, avn, nvn, action);
515
516	    if ((res == TCL_ERROR) ||
517		(res == TCL_BREAK) ||
518		(res == TCL_RETURN)) {
519		ckfree ((char*) nv);
520		return res;
521	    }
522	}
523
524	ckfree ((char*) nv);
525    }
526
527    return TCL_OK;
528}
529
530static int
531t_walkbfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f,
532	       Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
533	       Tcl_Obj* enter, Tcl_Obj* leave)
534{
535    /* ok	- next node
536     * error	- abort walking
537     * break	- pre: abort walking, skip to post, post: abort walking
538     * continue - next node
539     * return	- abort walking
540     * prune /5 - skip children, otherwise ok.
541   */
542
543    int res;
544    TN* n;
545    NLQ q;
546    NLQ qb;
547
548    nlq_init (&q);
549    nlq_init (&qb);
550
551    nlq_append (&q,  tdn);
552    nlq_push   (&qb, tdn);
553
554    while (1) {
555	n = nlq_pop (&q);
556	if (!n) break;
557
558	res = (*f) (interp, n, cs, avn, nvn, enter);
559
560	if (res == 5) {
561	    continue;
562	} else if (res == TCL_ERROR) {
563	    nlq_clear (&q);
564	    nlq_clear (&qb);
565	    return res;
566	} else if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
567	    nlq_clear (&q);
568
569	    /* We abort the collection of more nodes, but still run the
570	     * backward iteration (post-order phase).
571	     */
572	    break;
573	}
574
575	if (n->nchildren) {
576	    int i;
577	    for (i = 0; i < n->nchildren; i++) {
578		nlq_append (&q,	 n->child [i]);
579		nlq_push   (&qb, n->child [i]);
580	    }
581	}
582    }
583
584    /* Backward visit to leave */
585
586    while (1) {
587	n = nlq_pop (&qb);
588	if (!n) break;
589
590	res = (*f) (interp, n, cs, avn, nvn, leave);
591
592	if (res == 5) {
593	    continue;
594	} else if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
595	    nlq_clear (&qb);
596	    return res;
597	}
598    }
599
600    return TCL_OK;
601}
602
603static int
604t_walkbfspre (Tcl_Interp* interp, TN* tdn, t_walk_function f,
605	      Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
606	      Tcl_Obj* action)
607{
608    /* ok	- next node
609     * error	- abort walking
610     * break	- abort walking
611     * continue - next node
612     * return	- abort walking
613     * prune /5 - skip children, otherwise ok.
614   */
615
616    int res;
617    TN* n;
618    NLQ q;
619
620    nlq_init   (&q);
621    nlq_append (&q, tdn);
622
623    while (1) {
624	n = nlq_pop (&q);
625	if (!n) break;
626
627	res = (*f) (interp, n, cs, avn, nvn, action);
628
629	if (res == 5) {
630	    continue;
631	} else if ((res != TCL_OK) && (res != TCL_CONTINUE)) {
632	    nlq_clear (&q);
633	    return res;
634	}
635
636	if (n->nchildren) {
637	    int i;
638	    for (i = 0; i < n->nchildren; i++) {
639		nlq_append (&q, n->child [i]);
640	    }
641	}
642    }
643
644    return TCL_OK;
645}
646
647static int
648t_walkbfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f,
649	       Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn,
650	       Tcl_Obj* action)
651{
652    int res;
653    TN* n;
654    NLQ q;
655    NLQ qb;
656
657    nlq_init (&q);
658    nlq_init (&qb);
659
660    nlq_append (&q,  tdn);
661    nlq_push   (&qb, tdn);
662
663    while (1) {
664	n = nlq_pop (&q);
665	if (!n) break;
666
667	if (n->nchildren) {
668	    int i;
669	    for (i = 0; i < n->nchildren; i++) {
670		nlq_append (&q,	 n->child [i]);
671		nlq_push   (&qb, n->child [i]);
672	    }
673	}
674    }
675
676    /* Backward visit to leave */
677
678    while (1) {
679	n = nlq_pop (&qb);
680	if (!n) break;
681
682	res = (*f) (interp, n, cs, avn, nvn, action);
683
684	if ((res == TCL_ERROR) ||
685	    (res == TCL_BREAK) ||
686	    (res == TCL_RETURN)) {
687	    nlq_clear (&qb);
688	    return res;
689	} else if (res == 5) {
690	    /* Illegal pruning */
691
692	    nlq_clear (&qb);
693	    Tcl_ResetResult (interp);
694	    Tcl_AppendResult (interp,
695			      "Illegal attempt to prune post-order walking", NULL);
696	    return TCL_ERROR;
697	}
698    }
699
700    return TCL_OK;
701}
702
703/*
704 * Local Variables:
705 * mode: c
706 * c-basic-offset: 4
707 * fill-column: 78
708 * End:
709 */
710