src/generate_treefuncs.pl

   1 #!/usr/bin/perl -w
   2
   3 my $srcfile = $ARGV[0] || "treefuncs.def";
   4
   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");
   8
   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";
  13
  14 $typedefs = "typedef union _Node Node;\n";
  15 $typeenums = "enum {\n";
  16
  17 $typename = "";
  18 %typestruct = ();
  19 %freefunc = ();
  20 %freefunc_prot = ();
  21 %copyfunc = ();
  22 %copyfunc_prot = ();
  23 %setfunc = ();
  24 %setfunc_prot = ();
  25
  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";
  33 %got_quarks = ();
  34
  35 $var = "";
  36 $type = "";
  37 $copy = "";
  38 $free = "";
  39 $steal = 0;
  40
  41 $headercode = "";
  42
  43 $inheadercode = 0;
  44
  45 sub end_var {
  46         $typestruct{$typename} .= "\t$type $var;\n";
  47
  48         if ($copy ne "") {
  49                 $tmp = $copy;
  50                 $tmp =~ s/__VAL__/self->$var/g;
  51                 $tmp =~ s/__LVAL__/new->$var/g;
  52                 $copyfunc{$typename} .= "\t$tmp\n";
  53         } else {
  54                 $copyfunc{$typename} .= "\tnew->$var = self->$var;\n";
  55         }
  56         if ($free ne "") {
  57                 $tmp = $free;
  58                 $tmp =~ s/__VAL__/self->$var/g;
  59                 $freefunc{$typename} .= "\t$tmp\n";
  60         }
  61
  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;
  67         }
  68         if ($steal && ! $got_quarks{$var . ":steal"}) {
  69                 $quarks .= "\tQUARK_$var" . "_STEAL,\n";
  70                 $setupquarks .= "\tg_hash_table_insert (quark_ht, \"$var" .
  71                         ":steal\", " .
  72                         "GINT_TO_POINTER (QUARK_$var" . "_STEAL));\n";
  73                 $got_quarks{$var . ":steal"} = 1;
  74         }
  75
  76         $setfunc{$typename} .= "\t\tcase QUARK_$var: {\n";
  77         $setfunc{$typename} .= "\t\t\t$type $var = va_arg (__ap, $type);\n";
  78         if ($free ne "") {
  79                 $setfunc{$typename} .= "\t\t\t$type __old_value = self->$var;\n";
  80         }
  81
  82         if ($copy ne "") {
  83                 $tmp = $copy;
  84                 $tmp =~ s/__VAL__/$var/g;
  85                 $tmp =~ s/__LVAL__/self->$var/g;
  86                 $setfunc{$typename} .= "\t\t\t$tmp\n";
  87         } else {
  88                 $setfunc{$typename} .= "\t\t\tself->$var = $var;\n";
  89         }
  90         if ($free ne "") {
  91                 $tmp = $free;
  92                 $tmp =~ s/__VAL__/__old_value/g;
  93                 $setfunc{$typename} .= "\t\t\t$tmp\n";
  94         }
  95         $setfunc{$typename} .= "\t\t\tbreak;\n\t\t}\n";
  96
  97         if ($steal) {
  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";
 102         }
 103 }
 104
 105 while (<FILE>) {
 106         if ($inheadercode) {
 107                 if (/^ENDHEADER$/) {
 108                         $inheadercode = 0;
 109                         next;
 110                 }
 111                 $headercode .= $_;
 112                 next;
 113         }
 114
 115         s/#.*$//;
 116
 117         if (/^[ \t]*HEADER[ \t]*$/) {
 118                 $inheadercode = 1;
 119                 next;
 120         }
 121
 122         if (/^[ \t]*CLASS[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 123                 $typename = $1;
 124                 $lct = lc $typename;
 125                 $uct = uc $typename;
 126
 127                 $typeenums .= "\t$uct"."_NODE,\n";
 128
 129                 $typedefs .= "typedef struct _$typename $typename;\n";
 130
 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)";
 135
 136                 $setfunc{$typename} = "{\n" .
 137                         "\tint quark;\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";
 151
 152                 next;
 153         }
 154
 155         #ignore everything until we get some typename
 156         if ($typename eq "") {
 157                 next;
 158         }
 159
 160         #some predefined VARIABLE types
 161         if (/^[ \t]*INT[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 162                 $var = $1;
 163                 $type = "int";
 164                 $copy = "__LVAL__ = __VAL__;";
 165                 $free = "";
 166                 $steal = 0;
 167                 end_var;
 168                 next;
 169         } elsif (/^[ \t]*BOOL[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 170                 $var = $1;
 171                 $type = "gboolean";
 172                 $copy = "__LVAL__ = __VAL__;";
 173                 $free = "";
 174                 $steal = 0;
 175                 end_var;
 176                 next;
 177         } elsif (/^[ \t]*STRING[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 178                 $var = $1;
 179                 $type = "char *";
 180                 $copy = "__LVAL__ = g_strdup (__VAL__);";
 181                 $free = "g_free (__VAL__);";
 182                 $steal = 1;
 183                 end_var;
 184                 next;
 185         } elsif (/^[ \t]*STRINGLIST[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 186                 $var = $1;
 187                 $type = "GList *";
 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__);";
 190                 $steal = 1;
 191                 end_var;
 192                 next;
 193         } elsif (/^[ \t]*NODELIST[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 194                 $var = $1;
 195                 $type = "GList *";
 196                 $copy = "__LVAL__ = node_list_copy (__VAL__);";
 197                 $free = "node_list_free (__VAL__);";
 198                 $steal = 1;
 199                 end_var;
 200                 next;
 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]*$/) {
 203                 $var = $1;
 204                 $type = "Type *";
 205                 $copy = "__LVAL__ = copy_type (__VAL__);";
 206                 $free = "free_type (__VAL__);";
 207                 $steal = 1;
 208                 end_var;
 209                 next;
 210         #generic variable type
 211         } elsif (/^[ \t]*VAR[ \t]+([_A-Za-z][A-Za-z_0-9]+)[ \t]*$/) {
 212                 $var = $1;
 213                 $type = "int";
 214                 $copy = "__LVAL__ = __VAL__;";
 215                 $free = "";
 216                 $steal = 0;
 217                 next;
 218         } elsif (/^[ \t]*CTYPE[ \t]+(.+)[ \t]*$/) {
 219                 $type = $1;
 220                 next;
 221         } elsif (/^[ \t]*COPY[ \t]+(.+)$/) {
 222                 $copy = $1;
 223                 $steal = 1;
 224                 next;
 225         } elsif (/^[ \t]*FREE[ \t]+(.+)$/) {
 226                 $free = $1;
 227                 $steal = 1;
 228                 next;
 229         } elsif (/^[ \t]*ENDVAR[ \t]*$/) {
 230                 end_var;
 231                 next;
 232         } elsif (/^[ \t]*ENDCLASS[ \t]*$/) {
 233                 $typestruct{$typename} .= "};";
 234
 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" .
 239                         "\t\t\tbreak;\n" .
 240                         "\t\t}\n" .
 241                         "\t}\n" .
 242                         "}";
 243                 $typename = "";
 244                 next;
 245         } else {
 246                 next;
 247         }
 248 }
 249
 250 $typeenums .= "\tLAST_NODE_TYPE\n};";
 251
 252 print OUTH "\n#ifndef TREEFUNCS_H\n";
 253 print OUTH "#define TREEFUNCS_H\n";
 254
 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";
 259
 260 foreach $t (sort keys %typestruct) {
 261         print OUTH "$typestruct{$t}\n\n";
 262 }
 263
 264 print OUTH "union _Node {\n\tNodeType type;\n";
 265
 266 foreach $t (sort keys %typestruct) {
 267         $foo = lc $t;
 268         if ($foo eq "type") {
 269                 print OUTH "\t$t _type;\n";
 270         } else {
 271                 print OUTH "\t$t $foo;\n";
 272         }
 273 }
 274 print OUTH "};\n\n";
 275
 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";
 281
 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";
 285
 286 print OUTH "\n#endif /* TREEFUNCS_H */\n";
 287
 288 close (OUTH);
 289
 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";
 295
 296 foreach $t (sort keys %copyfunc_prot) {
 297         print OUTC "$copyfunc_prot{$t};\n";
 298 }
 299 print OUTC "\n";
 300
 301 foreach $t (sort keys %freefunc_prot) {
 302         print OUTC "$freefunc_prot{$t};\n";
 303 }
 304 print OUTC "\n";
 305
 306 foreach $t (sort keys %setfunc_prot) {
 307         print OUTC "$setfunc_prot{$t};\n";
 308 }
 309 print OUTC "\n";
 310
 311 print OUTC $quarks . "\tQUARK_LAST\n};\n\n";
 312 print OUTC $setupquarks . "}\n\n";
 313
 314 foreach $t (sort keys %copyfunc_prot) {
 315         print OUTC "$copyfunc_prot{$t}\n$copyfunc{$t}\n\n";
 316 }
 317
 318 foreach $t (sort keys %freefunc_prot) {
 319         print OUTC "$freefunc_prot{$t}\n$freefunc{$t}\n\n";
 320 }
 321
 322 foreach $t (sort keys %setfunc_prot) {
 323         print OUTC "$setfunc_prot{$t}\n$setfunc{$t}\n\n";
 324 }
 325
 326 print OUTC "Node *\nnode_copy (Node *node)\n" .
 327            "{\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";
 333 }
 334 print OUTC "\tdefault: return NULL;\n\t}\n}\n\n";
 335
 336 print OUTC "static void\nnode_setv (Node *node, va_list __ap)\n" .
 337            "{\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";
 343 }
 344 print OUTC "\tdefault: break;\n\t}\n}\n\n";
 345
 346 print OUTC "void\nnode_set (Node *node, ...)\n" .
 347            "{\n" .
 348            "\tva_list __ap;\n" .
 349            "\tva_start (__ap, node);\n" .
 350            "\tnode_setv (node, __ap);\n" .
 351            "\tva_end (__ap);\n" .
 352            "}\n\n";
 353
 354 print OUTC "Node *\nnode_new (NodeType type, ...)\n" .
 355            "{\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" .
 366                 "\t\tbreak;\n";
 367 }
 368 print OUTC "\tdefault: break;\n\t}\n" .
 369            "\tva_end (__ap);\n" .
 370            "\treturn node;\n" .
 371            "}\n\n";
 372
 373 print OUTC "void\nnode_free (Node *node)\n" .
 374            "{\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";
 380 }
 381 print OUTC "\tdefault: return;\n\t}\n}\n\n";
 382
 383 print OUTC "GList *\nnode_list_copy (GList *nodes)\n" .
 384            "{\n" .
 385            "\tGList *li;\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" .
 389            "\t}\n" .
 390            "\treturn nodes;\n" .
 391            "}\n\n";
 392
 393 print OUTC "void\nnode_list_free (GList *nodes)\n" .
 394            "{\n" .
 395            "\tGList *li;\n" .
 396            "\tfor (li = nodes; li != NULL; li = li->next) {\n" .
 397            "\t\tnode_free (li->data);\n" .
 398            "\t}\n" .
 399            "\tg_list_free (nodes);\n" .
 400            "}\n\n";
 401
 402 close (OUTC);