src/generate_treefuncs.pl

   1 #!/usr/bin/perl -w
   2
   3 open (FILE, "treefuncs.def") || die ("Can't open treefuncs.def");
   4 open (OUTC, ">treefuncs.c") || die ("Can't open treefuncs.c");
   5 open (OUTH, ">treefuncs.h") || die ("Can't open treefuncs.h");
   6
   7 print OUTC  "/* Generated by generate_treefuncs.pl from treefuncs.def!\n";
   8 print OUTC " * Do not edit by hand! */\n\n";
   9 print OUTH "/* Generated by generate_treefuncs.pl from treefuncs.def!\n";
  10 print OUTH " * Do not edit by hand! */\n\n";
  11
  12 $typedefs = "typedef union _Node Node;\n";
  13 $typeenums = "enum {\n";
  14
  15 $typename = "";
  16 %typestruct = ();
  17 %freefunc = ();
  18 %freefunc_prot = ();
  19 %copyfunc = ();
  20 %copyfunc_prot = ();
  21 %setfunc = ();
  22 %setfunc_prot = ();
  23
  24 $quarks = "static gboolean quarks_set_up = FALSE;\n" .
  25         "static GHashTable *quark_ht;\n" .
  26         "enum {\n\tQUARK_0,\n";
  27 $setupquarks = "static void\nensure_quarks (void)\n{\n" .
  28                 "\tif (quarks_set_up)\n\t\treturn;\n" .
  29                 "\tquark_ht = g_hash_table_new (g_str_hash, g_str_equal);\n" .
  30                 "\tquarks_set_up = TRUE;\n";
  31 %got_quarks = ();
  32
  33 $var = "";
  34 $type = "";
  35 $copy = "";
  36 $free = "";
  37 $steal = 0;
  38
  39 $headercode = "";
  40
  41 $inheadercode = 0;
  42
  43 sub end_var {
  44         $typestruct{$typename} .= "\t$type $var;\n";
  45
  46         if ($copy ne "") {
  47                 $tmp = $copy;
  48                 $tmp =~ s/__VAL__/self->$var/g;
  49                 $tmp =~ s/__LVAL__/new->$var/g;
  50                 $copyfunc{$typename} .= "\t$tmp\n";
  51         } else {
  52                 $copyfunc{$typename} .= "\tnew->$var = self->$var;\n";
  53         }
  54         if ($free ne "") {
  55                 $tmp = $free;
  56                 $tmp =~ s/__VAL__/self->$var/g;
  57                 $freefunc{$typename} .= "\t$tmp\n";
  58         }
  59
  60         if ( ! $got_quarks{$var}) {
  61                 $quarks .= "\tQUARK_$var,\n";
  62                 $setupquarks .= "\tg_hash_table_insert (quark_ht, \"$var\", " .
  63                         "GINT_TO_POINTER (QUARK_$var));\n";
  64                 $got_quarks{$var} = 1;
  65         }
  66         if ($steal && ! $got_quarks{$var . ":steal"}) {
  67                 $quarks .= "\tQUARK_$var" . "_STEAL,\n";
  68                 $setupquarks .= "\tg_hash_table_insert (quark_ht, \"$var" .
  69                         ":steal\", " .
  70                         "GINT_TO_POINTER (QUARK_$var" . "_STEAL));\n";
  71                 $got_quarks{$var . ":steal"} = 1;
  72         }
  73
  74         $setfunc{$typename} .= "\t\tcase QUARK_$var: {\n";
  75         $setfunc{$typename} .= "\t\t\t$type $var = va_arg (__ap, $type);\n";
  76         if ($free ne "") {
  77                 $setfunc{$typename} .= "\t\t\t$type __old_value = self->$var;\n";
  78         }
  79
  80         if ($copy ne "") {
  81                 $tmp = $copy;
  82                 $tmp =~ s/__VAL__/$var/g;
  83                 $tmp =~ s/__LVAL__/self->$var/g;
  84                 $setfunc{$typename} .= "\t\t\t$tmp\n";
  85         } else {
  86                 $setfunc{$typename} .= "\t\t\tself->$var = $var;\n";
  87         }
  88         if ($free ne "") {
  89                 $tmp = $free;
  90                 $tmp =~ s/__VAL__/__old_value/g;
  91                 $setfunc{$typename} .= "\t\t\t$tmp\n";
  92         }
  93         $setfunc{$typename} .= "\t\t\tbreak;\n\t\t}\n";
  94
  95         if ($steal) {
  96                 $setfunc{$typename} .= "\t\tcase QUARK_$var" . "_STEAL: {\n";
  97                 $setfunc{$typename} .= "\t\t\t$type $var = va_arg (__ap, $type);\n";
  98                 $setfunc{$typename} .= "\t\t\tself->$var = $var;\n";
  99                 $setfunc{$typename} .= "\t\t\tbreak;\n\t\t}\n";
 100         }
 101 }
 102
 103 while (<FILE>) {
 104         if ($inheadercode) {
 105                 if (/^ENDHEADER$/) {
 106                         $inheadercode = 0;
 107                         next;
 108                 }
 109                 $headercode .= $_;
 110                 next;
 111         }
 112
 113         s/#.*$//;
 114
 115         if (/^[ \t]*HEADER[ \t]*$/) {
 116                 $inheadercode = 1;
 117                 next;
 118         }
 119
 120         if (/^[ \t]*CLASS[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 121                 $typename = $1;
 122                 $lct = lc $typename;
 123                 $uct = uc $typename;
 124
 125                 $typeenums .= "\t$uct"."_NODE,\n";
 126
 127                 $typedefs .= "typedef struct _$typename $typename;\n";
 128
 129                 $typestruct{$typename} = "struct _$typename {\n\tNodeType type;\n";
 130                 $copyfunc_prot{$typename} = "static $typename *\ncopy_$lct ($typename * self)";
 131                 $setfunc_prot{$typename} = "static void\nsetv_$lct ($typename * self, va_list __ap)";
 132                 $freefunc_prot{$typename} = "void\nfree_$lct ($typename * self)";
 133
 134                 $setfunc{$typename} = "{\n" .
 135                         "\tint quark;\n" .
 136                         "\tconst char *arg;\n" .
 137                         "\tensure_quarks ();\n" .
 138                         "\twhile ((arg = va_arg (__ap, char *)) != NULL) {\n" .
 139                         "\t\tquark = GPOINTER_TO_INT (g_hash_table_lookup (quark_ht, arg));\n" .
 140                         "\t\tswitch (quark) {\n";
 141                 $copyfunc{$typename} = "{\n" .
 142                                         "\t$typename * new;\n" .
 143                                         "\tg_return_val_if_fail (self != NULL, NULL);\n" .
 144                                         "\tg_return_val_if_fail (self->type == $uct"."_NODE, NULL);\n" .
 145                                         "\tnew = g_new0($typename, 1);\n" .
 146                                         "\tnew->type = $uct"."_NODE;\n";
 147                 $freefunc{$typename} = "{\n\tg_return_if_fail (self != NULL);\n" .
 148                                         "\tg_return_if_fail (self->type == $uct"."_NODE);\n";
 149
 150                 next;
 151         }
 152
 153         #ignore everything until we get some typename
 154         if ($typename eq "") {
 155                 next;
 156         }
 157
 158         #some predefined VARIABLE types
 159         if (/^[ \t]*INT[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 160                 $var = $1;
 161                 $type = "int";
 162                 $copy = "__LVAL__ = __VAL__;";
 163                 $free = "";
 164                 $steal = 0;
 165                 end_var;
 166                 next;
 167         } elsif (/^[ \t]*BOOL[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 168                 $var = $1;
 169                 $type = "gboolean";
 170                 $copy = "__LVAL__ = __VAL__;";
 171                 $free = "";
 172                 $steal = 0;
 173                 end_var;
 174                 next;
 175         } elsif (/^[ \t]*STRING[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 176                 $var = $1;
 177                 $type = "char *";
 178                 $copy = "__LVAL__ = g_strdup (__VAL__);";
 179                 $free = "g_free (__VAL__);";
 180                 $steal = 1;
 181                 end_var;
 182                 next;
 183         } elsif (/^[ \t]*STRINGLIST[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 184                 $var = $1;
 185                 $type = "GList *";
 186                 $copy = "__LVAL__ = g_list_copy (__VAL__); COPY_LIST_VALS(__LVAL__, g_strdup);";
 187                 $free = "g_list_foreach (__VAL__, (GFunc)g_free, NULL); g_list_free (__VAL__);";
 188                 $steal = 1;
 189                 end_var;
 190                 next;
 191         } elsif (/^[ \t]*NODELIST[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 192                 $var = $1;
 193                 $type = "GList *";
 194                 $copy = "__LVAL__ = node_list_copy (__VAL__);";
 195                 $free = "node_list_free (__VAL__);";
 196                 $steal = 1;
 197                 end_var;
 198                 next;
 199         #We assume one of the classes we are creating is named Type
 200         } elsif (/^[ \t]*TYPE[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 201                 $var = $1;
 202                 $type = "Type *";
 203                 $copy = "__LVAL__ = copy_type (__VAL__);";
 204                 $free = "free_type (__VAL__);";
 205                 $steal = 1;
 206                 end_var;
 207                 next;
 208         #generic variable type
 209         } elsif (/^[ \t]*VAR[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 210                 $var = $1;
 211                 $type = "int";
 212                 $copy = "__LVAL__ = __VAL__;";
 213                 $free = "";
 214                 $steal = 0;
 215                 next;
 216         } elsif (/^[ \t]*CTYPE[ \t]+(.+)[ \t]*$/) {
 217                 $type = $1;
 218                 next;
 219         } elsif (/^[ \t]*COPY[ \t]+(.+)$/) {
 220                 $copy = $1;
 221                 $steal = 1;
 222                 next;
 223         } elsif (/^[ \t]*FREE[ \t]+(.+)$/) {
 224                 $free = $1;
 225                 $steal = 1;
 226                 next;
 227         } elsif (/^[ \t]*ENDVAR[ \t]*$/) {
 228                 end_var;
 229                 next;
 230         } elsif (/^[ \t]*ENDCLASS[ \t]*$/) {
 231                 $typestruct{$typename} .= "};";
 232
 233                 $copyfunc{$typename} .= "\treturn new;\n}";
 234                 $freefunc{$typename} .= "\tg_free (self);\n}";
 235                 $setfunc{$typename} .= "\t\tdefault:\n" .
 236                         "\t\t\tg_warning (\"Argument named '" . $typename . "::\%s' does not exist\", arg);\n" .
 237                         "\t\t\tbreak;\n" .
 238                         "\t\t}\n" .
 239                         "\t}\n" .
 240                         "}";
 241                 $typename = "";
 242                 next;
 243         } else {
 244                 next;
 245         }
 246 }
 247
 248 $typeenums .= "\tLAST_NODE_TYPE\n};";
 249
 250 print OUTH "\n#ifndef TREEFUNCS_H\n";
 251 print OUTH "#define TREEFUNCS_H\n";
 252
 253 print OUTH "\n$headercode\n\n";
 254 print OUTH "typedef long NodeType;\n";
 255 print OUTH "$typeenums\n\n";
 256 print OUTH "$typedefs\n\n";
 257
 258 foreach $t (sort keys %typestruct) {
 259         print OUTH "$typestruct{$t}\n\n";
 260 }
 261
 262 print OUTH "union _Node {\n\tNodeType type;\n";
 263
 264 foreach $t (sort keys %typestruct) {
 265         $foo = lc $t;
 266         if ($foo eq "type") {
 267                 print OUTH "\t$t _type;\n";
 268         } else {
 269                 print OUTH "\t$t $foo;\n";
 270         }
 271 }
 272 print OUTH "};\n\n";
 273
 274 print OUTH "\n/* General copy/free functions */\n";
 275 print OUTH "Node * node_copy (Node *node);\n";
 276 print OUTH "void node_free (Node *node);\n\n";
 277 print OUTH "GList * node_list_copy (GList *nodes);\n";
 278 print OUTH "void node_list_free (GList *nodes);\n";
 279
 280 print OUTH "\n/* Node new/set functions */\n";
 281 print OUTH "Node * node_new (NodeType type, ...);\n";
 282 print OUTH "void node_set (Node *node, ...);\n\n";
 283
 284 print OUTH "\n#endif /* TREEFUNCS_H */\n";
 285
 286 close (OUTH);
 287
 288 print OUTC "#include <glib.h>\n";
 289 print OUTC "#include <stdarg.h>\n";
 290 print OUTC "#include \"treefuncs.h\"\n\n";
 291 print OUTC "#define COPY_LIST_VALS(list,func) " .
 292         "{ GList *li; for (li=(list);li;li=li->next) { li->data=func (li->data); } }\n\n";
 293
 294 foreach $t (sort keys %copyfunc_prot) {
 295         print OUTC "$copyfunc_prot{$t};\n";
 296 }
 297 print OUTC "\n";
 298
 299 foreach $t (sort keys %freefunc_prot) {
 300         print OUTC "$freefunc_prot{$t};\n";
 301 }
 302 print OUTC "\n";
 303
 304 foreach $t (sort keys %setfunc_prot) {
 305         print OUTC "$setfunc_prot{$t};\n";
 306 }
 307 print OUTC "\n";
 308
 309 print OUTC $quarks . "\tQUARK_LAST\n};\n\n";
 310 print OUTC $setupquarks . "}\n\n";
 311
 312 foreach $t (sort keys %copyfunc_prot) {
 313         print OUTC "$copyfunc_prot{$t}\n$copyfunc{$t}\n\n";
 314 }
 315
 316 foreach $t (sort keys %freefunc_prot) {
 317         print OUTC "$freefunc_prot{$t}\n$freefunc{$t}\n\n";
 318 }
 319
 320 foreach $t (sort keys %setfunc_prot) {
 321         print OUTC "$setfunc_prot{$t}\n$setfunc{$t}\n\n";
 322 }
 323
 324 print OUTC "Node *\nnode_copy (Node *node)\n" .
 325            "{\n" .
 326            "\tg_return_val_if_fail (node != NULL, NULL);\n" .
 327            "\tg_return_val_if_fail (node->type >= 0 && node->type < LAST_NODE_TYPE, NULL);\n" .
 328            "\tswitch (node->type) {\n";
 329 foreach $t (sort keys %typestruct) {
 330         print OUTC "\tcase " . uc ($t) . "_NODE: return (Node *)copy_" . lc ($t) . " (($t *)node);\n";
 331 }
 332 print OUTC "\tdefault: return NULL;\n\t}\n}\n\n";
 333
 334 print OUTC "static void\nnode_setv (Node *node, va_list __ap)\n" .
 335            "{\n" .
 336            "\tg_return_if_fail (node != NULL);\n" .
 337            "\tg_return_if_fail (node->type >= 0 && node->type < LAST_NODE_TYPE);\n" .
 338            "\tswitch (node->type) {\n";
 339 foreach $t (sort keys %typestruct) {
 340         print OUTC "\tcase " . uc ($t) . "_NODE: setv_" . lc ($t) . " (($t *)node, __ap); break;\n";
 341 }
 342 print OUTC "\tdefault: break;\n\t}\n}\n\n";
 343
 344 print OUTC "void\nnode_set (Node *node, ...)\n" .
 345            "{\n" .
 346            "\tva_list __ap;\n" .
 347            "\tva_start (__ap, node);\n" .
 348            "\tnode_setv (node, __ap);\n" .
 349            "\tva_end (__ap);\n" .
 350            "}\n\n";
 351
 352 print OUTC "Node *\nnode_new (NodeType type, ...)\n" .
 353            "{\n" .
 354            "\tva_list __ap;\n" .
 355            "\tNode *node = NULL;\n" .
 356            "\tva_start (__ap, type);\n" .
 357            "\tg_return_val_if_fail (type >= 0 && type < LAST_NODE_TYPE, NULL);\n" .
 358            "\tswitch (type) {\n";
 359 foreach $t (sort keys %typestruct) {
 360         print OUTC "\tcase " . uc ($t) . "_NODE:\n" .
 361                 "\t\tnode = (Node *)g_new0 ($t, 1);\n" .
 362                 "\t\tnode->type = type;\n" .
 363                 "\t\tsetv_" . lc ($t) . " (($t *)node, __ap);\n" .
 364                 "\t\tbreak;\n";
 365 }
 366 print OUTC "\tdefault: break;\n\t}\n" .
 367            "\tva_end (__ap);\n" .
 368            "\treturn node;\n" .
 369            "}\n\n";
 370
 371 print OUTC "void\nnode_free (Node *node)\n" .
 372            "{\n" .
 373            "\tg_return_if_fail (node != NULL);\n" .
 374            "\tg_return_if_fail (node->type >= 0 && node->type < LAST_NODE_TYPE);\n" .
 375            "\tswitch (node->type) {\n";
 376 foreach $t (sort keys %typestruct) {
 377         print OUTC "\tcase " . uc ($t) . "_NODE: free_" . lc ($t) . " (($t *)node); return;\n";
 378 }
 379 print OUTC "\tdefault: return;\n\t}\n}\n\n";
 380
 381 print OUTC "GList *\nnode_list_copy (GList *nodes)\n" .
 382            "{\n" .
 383            "\tGList *li;\n" .
 384            "\tnodes = g_list_copy (nodes);\n" .
 385            "\tfor (li = nodes; li != NULL; li = li->next) {\n" .
 386            "\t\tli->data = node_copy (li->data);\n" .
 387            "\t}\n" .
 388            "\treturn nodes;\n" .
 389            "}\n\n";
 390
 391 print OUTC "void\nnode_list_free (GList *nodes)\n" .
 392            "{\n" .
 393            "\tGList *li;\n" .
 394            "\tfor (li = nodes; li != NULL; li = li->next) {\n" .
 395            "\t\tnode_free (li->data);\n" .
 396            "\t}\n" .
 397            "\tg_list_free (nodes);\n" .
 398            "}\n\n";
 399
 400 close (OUTC);