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