3 my $srcfile = $ARGV[0] || "treefuncs.def";
5 open (FILE, "$srcfile") || die ("Can't open $srcfile");
6 open (OUTC, ">treefuncs.c") || die ("Can't open treefuncs.c");
7 open (OUTH, ">treefuncs.h") || die ("Can't open treefuncs.h");
9 print OUTC "/* Generated by generate_treefuncs.pl from treefuncs.def!\n";
10 print OUTC " * Do not edit by hand! */\n\n";
11 print OUTH "/* Generated by generate_treefuncs.pl from treefuncs.def!\n";
12 print OUTH " * Do not edit by hand! */\n\n";
14 $typedefs = "typedef union _Node Node;\n";
15 $typeenums = "enum {\n";
26 $quarks = "static gboolean quarks_set_up = FALSE;\n" .
27 "static GHashTable *quark_ht;\n" .
28 "enum {\n\tQUARK_0,\n";
29 $setupquarks = "static void\nensure_quarks (void)\n{\n" .
30 "\tif (quarks_set_up)\n\t\treturn;\n" .
31 "\tquark_ht = g_hash_table_new (g_str_hash, g_str_equal);\n" .
32 "\tquarks_set_up = TRUE;\n";
46 $typestruct{$typename} .= "\t$type $var;\n";
50 $tmp =~ s/__VAL__/self->$var/g;
51 $tmp =~ s/__LVAL__/new->$var/g;
52 $copyfunc{$typename} .= "\t$tmp\n";
54 $copyfunc{$typename} .= "\tnew->$var = self->$var;\n";
58 $tmp =~ s/__VAL__/self->$var/g;
59 $freefunc{$typename} .= "\t$tmp\n";
62 if ( ! $got_quarks{$var}) {
63 $quarks .= "\tQUARK_$var,\n";
64 $setupquarks .= "\tg_hash_table_insert (quark_ht, \"$var\", " .
65 "GINT_TO_POINTER (QUARK_$var));\n";
66 $got_quarks{$var} = 1;
68 if ($steal && ! $got_quarks{$var . ":steal"}) {
69 $quarks .= "\tQUARK_$var" . "_STEAL,\n";
70 $setupquarks .= "\tg_hash_table_insert (quark_ht, \"$var" .
72 "GINT_TO_POINTER (QUARK_$var" . "_STEAL));\n";
73 $got_quarks{$var . ":steal"} = 1;
76 $setfunc{$typename} .= "\t\tcase QUARK_$var: {\n";
77 $setfunc{$typename} .= "\t\t\t$type $var = va_arg (__ap, $type);\n";
79 $setfunc{$typename} .= "\t\t\t$type __old_value = self->$var;\n";
84 $tmp =~ s/__VAL__/$var/g;
85 $tmp =~ s/__LVAL__/self->$var/g;
86 $setfunc{$typename} .= "\t\t\t$tmp\n";
88 $setfunc{$typename} .= "\t\t\tself->$var = $var;\n";
92 $tmp =~ s/__VAL__/__old_value/g;
93 $setfunc{$typename} .= "\t\t\t$tmp\n";
95 $setfunc{$typename} .= "\t\t\tbreak;\n\t\t}\n";
98 $setfunc{$typename} .= "\t\tcase QUARK_$var" . "_STEAL: {\n";
99 $setfunc{$typename} .= "\t\t\t$type $var = va_arg (__ap, $type);\n";
100 $setfunc{$typename} .= "\t\t\tself->$var = $var;\n";
101 $setfunc{$typename} .= "\t\t\tbreak;\n\t\t}\n";
117 if (/^[ \t]*HEADER[ \t]*$/) {
122 if (/^[ \t]*CLASS[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
127 $typeenums .= "\t$uct"."_NODE,\n";
129 $typedefs .= "typedef struct _$typename $typename;\n";
131 $typestruct{$typename} = "struct _$typename {\n\tNodeType type;\n";
132 $copyfunc_prot{$typename} = "static $typename *\ncopy_$lct ($typename * self)";
133 $setfunc_prot{$typename} = "static void\nsetv_$lct ($typename * self, va_list __ap)";
134 $freefunc_prot{$typename} = "void\nfree_$lct ($typename * self)";
136 $setfunc{$typename} = "{\n" .
138 "\tconst char *arg;\n" .
139 "\tensure_quarks ();\n" .
140 "\twhile ((arg = va_arg (__ap, char *)) != NULL) {\n" .
141 "\t\tquark = GPOINTER_TO_INT (g_hash_table_lookup (quark_ht, arg));\n" .
142 "\t\tswitch (quark) {\n";
143 $copyfunc{$typename} = "{\n" .
144 "\t$typename * new;\n" .
145 "\tg_return_val_if_fail (self != NULL, NULL);\n" .
146 "\tg_return_val_if_fail (self->type == $uct"."_NODE, NULL);\n" .
147 "\tnew = g_new0($typename, 1);\n" .
148 "\tnew->type = $uct"."_NODE;\n";
149 $freefunc{$typename} = "{\n\tg_return_if_fail (self != NULL);\n" .
150 "\tg_return_if_fail (self->type == $uct"."_NODE);\n";
155 #ignore everything until we get some typename
156 if ($typename eq "") {
160 #some predefined VARIABLE types
161 if (/^[ \t]*INT[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
164 $copy = "__LVAL__ = __VAL__;";
169 } elsif (/^[ \t]*BOOL[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
172 $copy = "__LVAL__ = __VAL__;";
177 } elsif (/^[ \t]*STRING[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
180 $copy = "__LVAL__ = g_strdup (__VAL__);";
181 $free = "g_free (__VAL__);";
185 } elsif (/^[ \t]*STRINGLIST[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
188 $copy = "__LVAL__ = g_list_copy (__VAL__); COPY_LIST_VALS(__LVAL__, g_strdup);";
189 $free = "g_list_foreach (__VAL__, (GFunc)g_free, NULL); g_list_free (__VAL__);";
193 } elsif (/^[ \t]*NODELIST[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
196 $copy = "__LVAL__ = node_list_copy (__VAL__);";
197 $free = "node_list_free (__VAL__);";
201 #We assume one of the classes we are creating is named Type
202 } elsif (/^[ \t]*TYPE[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
205 $copy = "__LVAL__ = copy_type (__VAL__);";
206 $free = "free_type (__VAL__);";
210 #generic variable type
211 } elsif (/^[ \t]*VAR[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
214 $copy = "__LVAL__ = __VAL__;";
218 } elsif (/^[ \t]*CTYPE[ \t]+(.+)[ \t]*$/) {
221 } elsif (/^[ \t]*COPY[ \t]+(.+)$/) {
225 } elsif (/^[ \t]*FREE[ \t]+(.+)$/) {
229 } elsif (/^[ \t]*ENDVAR[ \t]*$/) {
232 } elsif (/^[ \t]*ENDCLASS[ \t]*$/) {
233 $typestruct{$typename} .= "};";
235 $copyfunc{$typename} .= "\treturn new;\n}";
236 $freefunc{$typename} .= "\tg_free (self);\n}";
237 $setfunc{$typename} .= "\t\tdefault:\n" .
238 "\t\t\tg_warning (\"Argument named '" . $typename . "::\%s' does not exist\", arg);\n" .
250 $typeenums .= "\tLAST_NODE_TYPE\n};";
252 print OUTH "\n#ifndef TREEFUNCS_H\n";
253 print OUTH "#define TREEFUNCS_H\n";
255 print OUTH "\n$headercode\n\n";
256 print OUTH "typedef long NodeType;\n";
257 print OUTH "$typeenums\n\n";
258 print OUTH "$typedefs\n\n";
260 foreach $t (sort keys %typestruct) {
261 print OUTH "$typestruct{$t}\n\n";
264 print OUTH "union _Node {\n\tNodeType type;\n";
266 foreach $t (sort keys %typestruct) {
268 if ($foo eq "type") {
269 print OUTH "\t$t _type;\n";
271 print OUTH "\t$t $foo;\n";
276 print OUTH "\n/* General copy/free functions */\n";
277 print OUTH "Node * node_copy (Node *node);\n";
278 print OUTH "void node_free (Node *node);\n\n";
279 print OUTH "GList * node_list_copy (GList *nodes);\n";
280 print OUTH "void node_list_free (GList *nodes);\n";
282 print OUTH "\n/* Node new/set functions */\n";
283 print OUTH "Node * node_new (NodeType type, ...);\n";
284 print OUTH "void node_set (Node *node, ...);\n\n";
286 print OUTH "\n#endif /* TREEFUNCS_H */\n";
290 print OUTC "#include <glib.h>\n";
291 print OUTC "#include <stdarg.h>\n";
292 print OUTC "#include \"treefuncs.h\"\n\n";
293 print OUTC "#define COPY_LIST_VALS(list,func) " .
294 "{ GList *li; for (li=(list);li;li=li->next) { li->data=func (li->data); } }\n\n";
296 foreach $t (sort keys %copyfunc_prot) {
297 print OUTC "$copyfunc_prot{$t};\n";
301 foreach $t (sort keys %freefunc_prot) {
302 print OUTC "$freefunc_prot{$t};\n";
306 foreach $t (sort keys %setfunc_prot) {
307 print OUTC "$setfunc_prot{$t};\n";
311 print OUTC $quarks . "\tQUARK_LAST\n};\n\n";
312 print OUTC $setupquarks . "}\n\n";
314 foreach $t (sort keys %copyfunc_prot) {
315 print OUTC "$copyfunc_prot{$t}\n$copyfunc{$t}\n\n";
318 foreach $t (sort keys %freefunc_prot) {
319 print OUTC "$freefunc_prot{$t}\n$freefunc{$t}\n\n";
322 foreach $t (sort keys %setfunc_prot) {
323 print OUTC "$setfunc_prot{$t}\n$setfunc{$t}\n\n";
326 print OUTC "Node *\nnode_copy (Node *node)\n" .
328 "\tg_return_val_if_fail (node != NULL, NULL);\n" .
329 "\tg_return_val_if_fail (node->type >= 0 && node->type < LAST_NODE_TYPE, NULL);\n" .
330 "\tswitch (node->type) {\n";
331 foreach $t (sort keys %typestruct) {
332 print OUTC "\tcase " . uc ($t) . "_NODE: return (Node *)copy_" . lc ($t) . " (($t *)node);\n";
334 print OUTC "\tdefault: return NULL;\n\t}\n}\n\n";
336 print OUTC "static void\nnode_setv (Node *node, va_list __ap)\n" .
338 "\tg_return_if_fail (node != NULL);\n" .
339 "\tg_return_if_fail (node->type >= 0 && node->type < LAST_NODE_TYPE);\n" .
340 "\tswitch (node->type) {\n";
341 foreach $t (sort keys %typestruct) {
342 print OUTC "\tcase " . uc ($t) . "_NODE: setv_" . lc ($t) . " (($t *)node, __ap); break;\n";
344 print OUTC "\tdefault: break;\n\t}\n}\n\n";
346 print OUTC "void\nnode_set (Node *node, ...)\n" .
348 "\tva_list __ap;\n" .
349 "\tva_start (__ap, node);\n" .
350 "\tnode_setv (node, __ap);\n" .
351 "\tva_end (__ap);\n" .
354 print OUTC "Node *\nnode_new (NodeType type, ...)\n" .
356 "\tva_list __ap;\n" .
357 "\tNode *node = NULL;\n" .
358 "\tva_start (__ap, type);\n" .
359 "\tg_return_val_if_fail (type >= 0 && type < LAST_NODE_TYPE, NULL);\n" .
360 "\tswitch (type) {\n";
361 foreach $t (sort keys %typestruct) {
362 print OUTC "\tcase " . uc ($t) . "_NODE:\n" .
363 "\t\tnode = (Node *)g_new0 ($t, 1);\n" .
364 "\t\tnode->type = type;\n" .
365 "\t\tsetv_" . lc ($t) . " (($t *)node, __ap);\n" .
368 print OUTC "\tdefault: break;\n\t}\n" .
369 "\tva_end (__ap);\n" .
373 print OUTC "void\nnode_free (Node *node)\n" .
375 "\tg_return_if_fail (node != NULL);\n" .
376 "\tg_return_if_fail (node->type >= 0 && node->type < LAST_NODE_TYPE);\n" .
377 "\tswitch (node->type) {\n";
378 foreach $t (sort keys %typestruct) {
379 print OUTC "\tcase " . uc ($t) . "_NODE: free_" . lc ($t) . " (($t *)node); return;\n";
381 print OUTC "\tdefault: return;\n\t}\n}\n\n";
383 print OUTC "GList *\nnode_list_copy (GList *nodes)\n" .
386 "\tnodes = g_list_copy (nodes);\n" .
387 "\tfor (li = nodes; li != NULL; li = li->next) {\n" .
388 "\t\tli->data = node_copy (li->data);\n" .
390 "\treturn nodes;\n" .
393 print OUTC "void\nnode_list_free (GList *nodes)\n" .
396 "\tfor (li = nodes; li != NULL; li = li->next) {\n" .
397 "\t\tnode_free (li->data);\n" .
399 "\tg_list_free (nodes);\n" .