ghc/utils/ugen/gen.c

   1 #ifdef __STDC__
   2 #define PROTO(x)        x
   3 #else
   4 #define PROTO(x)        ()
   5 #endif
   6
   7 #include <stdio.h>
   8 #include "id.h"
   9 #include "tree.h"
  10 #include "funs.h"
  11 extern FILE *fh, *fc, *fhs;
  12
  13 void
  14 ge_typdef(t)
  15     tree t;
  16 {
  17         /*
  18         ** Generate to the .h file:
  19         **
  20         **      typdef enum {
  21         **              constructor1,
  22         **              constructor2,
  23         **              ...
  24         **      } *Ttypename;
  25         */
  26         fprintf(fh, "#ifndef %s_defined\n", gtid(t));
  27         fprintf(fh, "#define %s_defined\n", gtid(t));
  28         fprintf(fh, "\n#include <stdio.h>\n"); /* for stderr */
  29         fprintf(fh, "\n#ifndef PROTO\n");
  30         fprintf(fh, "#ifdef __STDC__\n");
  31         fprintf(fh, "#define PROTO(x) x\n");
  32         fprintf(fh, "#else\n");
  33         fprintf(fh, "#define PROTO(x) /**/\n");
  34         fprintf(fh, "#endif\n");
  35         fprintf(fh, "#endif\n\n");
  36         fprintf(fh, "#ifdef UGEN_DEBUG\n");
  37         fprintf(fh, "int\tfprintf PROTO((FILE *, const char *, ...));\n");
  38         fprintf(fh, "#endif /* UGEN_DEBUG */\n\n");
  39         fprintf(fh, "typedef enum {\n");
  40         ge_typlist(gtdeflist(t));
  41         fprintf(fh, "\n} T%s;\n\n", gtid(t));
  42         /*
  43         ** Generate to the .hs file:
  44         **
  45         **      data U_typename
  46         **        = U_constructor1 | U_constructor2 | ...
  47         */
  48         /*
  49         ** Generate to the .h file:
  50         **
  51         **      typedef struct { Ttypename tag; } *typename;
  52         */
  53         fprintf(fh, "typedef struct { T%s tag; } *%s;\n\n", gtid(t), gtid(t));
  54
  55         g_tagfun(gtid(t)); /* generate the tag-grabbing function */
  56
  57         /* Generate the struct definitions (to the .h file). */
  58         gs_typlist(gtdeflist(t), gtid(t));
  59
  60         /* Generate a Haskell-equiv data type (to the .hs file) */
  61         fprintf(fhs, "data U_%s = ", gtid(t));
  62         hs_typlist(gtdeflist(t));
  63         fprintf(fhs, "\n\n");
  64         /* And a type with which to talk about the C-land parse tree */
  65 /*      fprintf(fhs, "data U__%s = U__%s Addr#\n", gtid(t), gtid(t));
  66         fprintf(fhs, "instance _CCallable U__%s\n", gtid(t));
  67         fprintf(fhs, "instance _CReturnable U__%s\n\n", gtid(t));
  68 */
  69 }
  70
  71 void
  72 ge_typlist(t)
  73     tree t;
  74 {
  75         switch(ttree(t)) {
  76           case deflist:
  77                 ge_typlist(gdeflist(t));
  78                 fprintf(fh, ",\n\t%s", gdid(gdef(t)));
  79                 break;
  80           case def:
  81                 fprintf(fh, "\t%s", gdid(t));
  82                 break;
  83           default:
  84                 fprintf(stderr,"ge_typlist: funny abstract syntax.\n");
  85                 break;
  86         }
  87 }
  88
  89 void
  90 gs_typlist(t, tid)
  91     tree t;
  92     id tid;
  93 {
  94         switch(ttree(t)) {
  95           case deflist:
  96                 gs_typlist(gdeflist(t), tid);
  97                 gs_def(gdef(t), tid);
  98                 break;
  99           case def:
 100                 gs_def(t, tid);
 101                 break;
 102           default:
 103                 fprintf(stderr,"gs_typlist: funny abstract syntax.\n");
 104                 break;
 105         }
 106 }
 107
 108 void
 109 hs_typlist(t)
 110     tree t;
 111 {
 112         switch(ttree(t)) {
 113           case deflist:
 114                 hs_typlist(gdeflist(t));
 115                 fprintf(fhs, "| ");
 116                 hs_def(gdef(t));
 117                 break;
 118           case def:
 119                 hs_def(t);
 120                 break;
 121           default:
 122                 fprintf(stderr,"hs_typlist: funny abstract syntax.\n");
 123                 break;
 124         }
 125 }
 126
 127 void
 128 gs_def(t, tid)
 129    tree t;
 130    id tid;
 131 {
 132         fprintf(fh, "struct S%s {\n", gdid(t));
 133         fprintf(fh, "\tT%s tag;\n", tid);
 134         gs_itemlist(gditemlist(t));
 135         fprintf(fh, "};\n\n");
 136 }
 137
 138 void
 139 hs_def(t)
 140    tree t;
 141 {
 142         fprintf(fhs, "U_%s ", gdid(t));
 143         hs_itemlist(gditemlist(t));
 144 }
 145
 146 void
 147 gs_itemlist(t)
 148     tree t;
 149 {
 150         switch(ttree(t)) {
 151           case emitemlist:
 152                 break;
 153           case itemlist:
 154                 gs_itemlist(gitemlist(t));
 155                 fprintf(fh, "\t%s X%s;\n",
 156                         gitemtypid(gitem(t)), gitemfunid(gitem(t)) );
 157                 break;
 158           case item:
 159                 fprintf(fh, "\t%s X%s;\n",
 160                         gitemtypid(t), gitemfunid(t));
 161                 break;
 162           default:
 163                 fprintf(stderr,"gs_itemlist: funny abs. syntax: %d\n.", ttree(t));
 164                 break;
 165         }
 166 }
 167
 168 void
 169 hs_itemlist(t)
 170     tree t;
 171 {
 172         switch(ttree(t)) {
 173           case emitemlist:
 174                 break;
 175           case itemlist:
 176                 hs_itemlist(gitemlist(t));
 177                 fprintf(fhs, "U_%s ", gitemtypid(gitem(t)));
 178                 break;
 179           case item:
 180                 fprintf(fhs, "U_%s ", gitemtypid(t));
 181                 break;
 182           default:
 183                 fprintf(stderr,"hs_itemlist: funny abs. syntax: %d\n.", ttree(t));
 184                 break;
 185         }
 186 }
 187
 188 void
 189 g_tagfun(typid)
 190     id typid;
 191 {
 192     fprintf(fh, "#ifdef __GNUC__\n");
 193
 194     /* to satisfy GCC when in really-picky mode: */
 195     fprintf(fh, "T%s t%s(%s t);\n", typid, typid, typid);
 196     /* the real thing: */
 197     fprintf(fh, "extern __inline__ T%s t%s(%s t)\n{\n\treturn(t -> tag);\n}\n",
 198                 typid, typid, typid);
 199
 200     fprintf(fh, "#else  /* ! __GNUC__ */\n");
 201
 202     fprintf(fh, "extern T%s t%s PROTO((%s));\n", typid, typid, typid);
 203     fprintf(fc, "\nT%s t%s(t)\n %s t;\n{\n\treturn(t -> tag);\n}\n\n",
 204                 typid, typid, typid);
 205
 206     fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
 207 }
 208 /*******************************************************************/
 209
 210 void
 211 g_consels(t, typid)
 212     tree t;
 213     id typid;
 214 {
 215         switch(ttree(t)) {
 216           case deflist:
 217                 g_consels(gdeflist(t), typid);
 218                 g_typconsel(gdef(t), typid);
 219                 break;
 220           case def:
 221                 g_typconsel(t, typid);
 222                 break;
 223           default:
 224                 fprintf(stderr,"g_consel: funny abstract syntax.\n");
 225                 break;
 226         }
 227 }
 228
 229 /***********************************************************************/
 230
 231 void
 232 g_typconsel(t, typid)
 233     tree t;
 234     id typid;
 235 {
 236         fprintf(fc, "\n/************** %s ******************/\n\n", gdid(t));
 237         gencons(typid, t);
 238         gensels(typid, gdid(t), gditemlist(t));
 239         fprintf(fh, "\n");
 240 }
 241
 242 void
 243 gencons(typid, t)
 244   id typid;
 245   tree t; /* of kind 'def'. */
 246 {
 247         tree itemlist = gditemlist(t);
 248
 249         fprintf(fh, "extern %s mk%s PROTO((", typid, gdid(t));
 250         switch (ttree(itemlist)) {
 251           case emitemlist: /* empty list */
 252             fprintf(fh, "void");
 253             break;
 254           default:
 255             genmkprotodekl(itemlist);
 256             break;
 257         }
 258         fprintf(fh, "));\n");
 259
 260         fprintf(fc, "%s mk%s(", typid, gdid(t));
 261         switch (ttree(itemlist)) {
 262           case emitemlist: /* empty list */
 263             fprintf(fc, "void");
 264             break;
 265           default:
 266             genmkparamlist(itemlist);
 267             break;
 268         }
 269         fprintf(fc, ")\n");
 270
 271         genmkparamdekl(itemlist);
 272
 273         fprintf(fc, "{\n\tregister struct S%s *pp =\n", gdid(t));
 274         fprintf(fc, "\t\t(struct S%s *) malloc(sizeof(struct S%s));\n",
 275                     gdid(t), gdid(t));
 276         fprintf(fc, "\tpp -> tag = %s;\n", gdid(t));
 277         genmkfillin(itemlist);
 278         fprintf(fc, "\treturn((%s)pp);\n", typid);
 279         fprintf(fc, "}\n");
 280 }
 281
 282 void
 283 genmkparamlist(t)
 284    tree t;
 285 {
 286         switch(ttree(t)) {
 287           case emitemlist:
 288                 break;
 289           case itemlist:
 290                 genmkparamlist(gitemlist(t));
 291                 fprintf(fc, ", ");
 292                 genmkparamlist(gitem(t));
 293                 break;
 294           case item:
 295                 fprintf(fc, "PP%s", gitemfunid(t));
 296                 break;
 297           default:
 298                 fprintf(stderr,"genparamlist: funny abs syntax.\n");
 299                 break;
 300         }
 301 }
 302
 303 void
 304 genmkparamdekl(t)
 305    tree t; /* of kind 'itemlist' or 'item' */
 306 {
 307         switch(ttree(t)) {
 308           case emitemlist:
 309                 break;
 310           case itemlist:
 311                 genmkparamdekl(gitemlist(t));
 312                 genmkparamdekl(gitem(t));
 313                 break;
 314           case item:
 315                 fprintf(fc, " %s PP%s;\n", gitemtypid(t), gitemfunid(t));
 316                 break;
 317           default:
 318                 fprintf(stderr,"genmkparamdekl: funny abs syntax.\n");
 319                 break;
 320         }
 321 }
 322
 323 void
 324 genmkprotodekl(t)
 325    tree t; /* of kind 'itemlist' or 'item' */
 326 {
 327         switch(ttree(t)) {
 328           case emitemlist:
 329                 break;
 330           case itemlist:
 331                 genmkprotodekl(gitemlist(t));
 332                 fprintf(fh, ", ");
 333                 genmkprotodekl(gitem(t));
 334                 break;
 335           case item:
 336                 fprintf(fh, "%s", gitemtypid(t));
 337                 break;
 338           default:
 339                 fprintf(stderr,"genmkprotodekl: funny abs syntax.\n");
 340                 break;
 341         }
 342 }
 343
 344 void
 345 genmkfillin(t)
 346     tree t;
 347 {
 348         switch(ttree(t)) {
 349           case emitemlist:
 350                 break;
 351           case itemlist:
 352                 genmkfillin(gitemlist(t));
 353                 genmkfillin(gitem(t));
 354                 break;
 355           case item:
 356                 fprintf(fc, "\tpp -> X%s = PP%s;\n",
 357                         gitemfunid(t), gitemfunid(t));
 358                 break;
 359           default:
 360                 fprintf(stderr,"genmkfillin: funny abs syntax.\n");
 361                 break;
 362         }
 363 }
 364
 365 void
 366 gensels(typid, variantid, t)
 367     id typid;
 368     id variantid;
 369     tree t;
 370 {
 371         switch(ttree(t)) {
 372           case emitemlist:
 373                 break;
 374           case itemlist:
 375                 gensels(typid, variantid, gitemlist(t));
 376                 gensels(typid, variantid, gitem(t));
 377                 break;
 378           case item:
 379                 fprintf(fh, "#ifdef __GNUC__\n");
 380
 381                 /* to satisfy GCC when in extremely-picky mode: */
 382                 fprintf(fh, "\n%s *R%s PROTO((struct S%s *));\n",
 383                              gitemtypid(t), gitemfunid(t), variantid);
 384                 /* the real thing: */
 385                 fprintf(fh, "\nextern __inline__ %s *R%s(struct S%s *t)\n{\n",
 386                              gitemtypid(t), gitemfunid(t), variantid);
 387                 fprintf(fh, "#ifdef UGEN_DEBUG\n");
 388                 fprintf(fh, "\tif(t -> tag != %s)\n", variantid);
 389                 fprintf(fh, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t));
 390                 fprintf(fh, "#endif /* UGEN_DEBUG */\n");
 391                 fprintf(fh, "\treturn(& t -> X%s);\n}\n", gitemfunid(t));
 392
 393                 fprintf(fh, "#else  /* ! __GNUC__ */\n");
 394
 395                 fprintf(fh,
 396                   "extern %s *R%s PROTO((struct S%s *));\n",
 397                   gitemtypid(t), gitemfunid(t), variantid);
 398
 399                 fprintf(fc, "\n%s *R%s(t)\n struct S%s *t;\n{\n",
 400                              gitemtypid(t), gitemfunid(t), variantid);
 401                 fprintf(fc, "#ifdef UGEN_DEBUG\n");
 402                 fprintf(fc, "\tif(t -> tag != %s)\n", variantid);
 403                 fprintf(fc, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t));
 404                 fprintf(fc, "#endif /* UGEN_DEBUG */\n");
 405                 fprintf(fc, "\treturn(& t -> X%s);\n}\n", gitemfunid(t));
 406
 407                 fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
 408
 409                 fprintf(fh,
 410                   "#define %s(xyzxyz) (*R%s((struct S%s *) (xyzxyz)))\n",
 411                   gitemfunid(t), gitemfunid(t), variantid);
 412                 break;
 413           default:
 414                 fprintf(stderr,"gensels: funny abs syntax.\n");
 415                 break;
 416         }
 417
 418 }
 419
 420 /***********************************************************************/
 421
 422 void
 423 gen_hs_reader(typid, deflist)
 424     id typid;
 425     tree deflist;
 426 {
 427         /* signature */
 428         fprintf(fhs, "rdU_%s :: _Addr -> UgnM U_%s\n", typid, typid);
 429
 430         /* defn */
 431         fprintf(fhs, "rdU_%s t\n  = ioToUgnM (_ccall_ t%s t) `thenUgn` \\ tag@(I# _) ->\n", typid, typid);
 432         fprintf(fhs, "    if ");
 433         gen_hs_rdalts(typid, deflist);
 434         fprintf(fhs, "    else\n\terror (\"rdU_%s: bad tag selection:\"++show tag++\"\\n\")\n", typid);
 435 }
 436
 437 void
 438 gen_hs_rdalts(typid, t)
 439     id   typid;
 440     tree t;
 441 {
 442         switch(ttree(t)) {
 443           case deflist:
 444                 gen_hs_rdalts(typid, gdeflist(t));
 445                 fprintf(fhs, "    else if ");
 446                 gen_hs_rdalt (typid, gdef(t));
 447                 break;
 448           case def:
 449                 gen_hs_rdalt(typid, t);
 450                 break;
 451           default:
 452                 fprintf(stderr,"gen_hs_rdalts: funny abstract syntax.\n");
 453                 break;
 454         }
 455 }
 456
 457 void
 458 gen_hs_rdalt(typid, t)
 459     id   typid;
 460     tree t;
 461 {
 462         fprintf(fhs, "tag == ``%s'' then\n", gdid(t));
 463         gen_hs_rdcomponents (typid, gdid(t), gditemlist(t));
 464         fprintf(fhs, "\treturnUgn (U_%s ", gdid(t));
 465         gen_hs_retcomponents(typid, gdid(t), gditemlist(t));
 466         fprintf(fhs, ")\n"); /* end of alt */
 467 }
 468
 469 void
 470 gen_hs_rdcomponents(typid, variantid, t)
 471     id   typid;
 472     id   variantid;
 473     tree t;
 474 {
 475         switch(ttree(t)) {
 476           case emitemlist:
 477                 break;
 478           case itemlist:
 479                 gen_hs_rdcomponents(typid, variantid, gitemlist(t));
 480                 gen_hs_rdcomponents(typid, variantid, gitem(t));
 481                 break;
 482           case item:
 483                 fprintf(fhs, "\tioToUgnM (_ccall_ %s t) `thenUgn` \\ x_%s ->\n",
 484                              gitemfunid(t), gitemfunid(t));
 485
 486                 fprintf(fhs, "\trdU_%s x_%s `thenUgn` \\ y_%s ->\n",
 487                              gitemtypid(t), gitemfunid(t), gitemfunid(t));
 488
 489 /*              fprintf(fhs, "\tif(t -> tag != %s)\n", variantid);
 490                 fprintf(fhs, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t));
 491                 fprintf(fhs, "\treturn(& t -> X%s);\n}\n", gitemfunid(t));
 492 */              break;
 493
 494           default:
 495                 fprintf(stderr,"gen_hs_rdcomponents: funny abs syntax.\n");
 496                 break;
 497         }
 498 }
 499
 500 void
 501 gen_hs_retcomponents(typid, variantid, t)
 502     id   typid;
 503     id   variantid;
 504     tree t;
 505 {
 506         switch(ttree(t)) {
 507           case emitemlist:
 508                 break;
 509           case itemlist:
 510                 gen_hs_retcomponents(typid, variantid, gitemlist(t));
 511                 fprintf(fhs, " ");
 512                 gen_hs_retcomponents(typid, variantid, gitem(t));
 513                 break;
 514           case item:
 515                 fprintf(fhs, "y_%s", gitemfunid(t));
 516                 break;
 517
 518           default:
 519                 fprintf(stderr,"gen_hs_retcomponents: funny abs syntax.\n");
 520                 break;
 521         }
 522 }