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     fprintf(fh, "extern __inline__ T%s t%s(%s t)\n{\n\treturn(t -> tag);\n}\n",
 192                 typid, typid, typid);
 193
 194     fprintf(fh, "#else  /* ! __GNUC__ */\n");
 195
 196     fprintf(fh, "extern T%s t%s PROTO((%s));\n", typid, typid, typid);
 197     fprintf(fc, "\nT%s t%s(t)\n %s t;\n{\n\treturn(t -> tag);\n}\n\n",
 198                 typid, typid, typid);
 199
 200     fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
 201 }
 202 /*******************************************************************/
 203
 204 void
 205 g_consels(t, typid)
 206     tree t;
 207     id typid;
 208 {
 209         switch(ttree(t)) {
 210           case deflist:
 211                 g_consels(gdeflist(t), typid);
 212                 g_typconsel(gdef(t), typid);
 213                 break;
 214           case def:
 215                 g_typconsel(t, typid);
 216                 break;
 217           default:
 218                 fprintf(stderr,"g_consel: funny abstract syntax.\n");
 219                 break;
 220         }
 221 }
 222
 223 /***********************************************************************/
 224
 225 void
 226 g_typconsel(t, typid)
 227     tree t;
 228     id typid;
 229 {
 230         fprintf(fc, "\n/************** %s ******************/\n\n", gdid(t));
 231         gencons(typid, t);
 232         gensels(typid, gdid(t), gditemlist(t));
 233         fprintf(fh, "\n");
 234 }
 235
 236 void
 237 gencons(typid, t)
 238   id typid;
 239   tree t; /* of kind 'def'. */
 240 {
 241         fprintf(fh, "extern %s mk%s PROTO((", typid, gdid(t));
 242         genmkprotodekl(gditemlist(t));
 243         fprintf(fh, "));\n");
 244
 245         fprintf(fc, "%s mk%s(", typid, gdid(t));
 246         genmkparamlist(gditemlist(t));
 247         fprintf(fc, ")\n");
 248         genmkparamdekl(gditemlist(t));
 249         fprintf(fc, "{\n\tregister struct S%s *pp =\n", gdid(t));
 250         fprintf(fc, "\t\t(struct S%s *) malloc(sizeof(struct S%s));\n",
 251                     gdid(t), gdid(t));
 252         fprintf(fc, "\tpp -> tag = %s;\n", gdid(t));
 253         genmkfillin(gditemlist(t));
 254         fprintf(fc, "\treturn((%s)pp);\n", typid);
 255         fprintf(fc, "}\n");
 256 }
 257
 258 void
 259 genmkparamlist(t)
 260    tree t;
 261 {
 262         switch(ttree(t)) {
 263           case emitemlist:
 264                 break;
 265           case itemlist:
 266                 genmkparamlist(gitemlist(t));
 267                 fprintf(fc, ", ");
 268                 genmkparamlist(gitem(t));
 269                 break;
 270           case item:
 271                 fprintf(fc, "PP%s", gitemfunid(t));
 272                 break;
 273           default:
 274                 fprintf(stderr,"genparamlist: funny abs syntax.\n");
 275                 break;
 276         }
 277 }
 278
 279 void
 280 genmkparamdekl(t)
 281    tree t; /* of kind 'itemlist' or 'item' */
 282 {
 283         switch(ttree(t)) {
 284           case emitemlist:
 285                 break;
 286           case itemlist:
 287                 genmkparamdekl(gitemlist(t));
 288                 genmkparamdekl(gitem(t));
 289                 break;
 290           case item:
 291                 fprintf(fc, " %s PP%s;\n", gitemtypid(t), gitemfunid(t));
 292                 break;
 293           default:
 294                 fprintf(stderr,"genmkparamdekl: funny abs syntax.\n");
 295                 break;
 296         }
 297 }
 298
 299 void
 300 genmkprotodekl(t)
 301    tree t; /* of kind 'itemlist' or 'item' */
 302 {
 303         switch(ttree(t)) {
 304           case emitemlist:
 305                 break;
 306           case itemlist:
 307                 genmkprotodekl(gitemlist(t));
 308                 fprintf(fh, ", ");
 309                 genmkprotodekl(gitem(t));
 310                 break;
 311           case item:
 312                 fprintf(fh, "%s", gitemtypid(t));
 313                 break;
 314           default:
 315                 fprintf(stderr,"genmkprotodekl: funny abs syntax.\n");
 316                 break;
 317         }
 318 }
 319
 320 void
 321 genmkfillin(t)
 322     tree t;
 323 {
 324         switch(ttree(t)) {
 325           case emitemlist:
 326                 break;
 327           case itemlist:
 328                 genmkfillin(gitemlist(t));
 329                 genmkfillin(gitem(t));
 330                 break;
 331           case item:
 332                 fprintf(fc, "\tpp -> X%s = PP%s;\n",
 333                         gitemfunid(t), gitemfunid(t));
 334                 break;
 335           default:
 336                 fprintf(stderr,"genmkfillin: funny abs syntax.\n");
 337                 break;
 338         }
 339 }
 340
 341 void
 342 gensels(typid, variantid, t)
 343     id typid;
 344     id variantid;
 345     tree t;
 346 {
 347         switch(ttree(t)) {
 348           case emitemlist:
 349                 break;
 350           case itemlist:
 351                 gensels(typid, variantid, gitemlist(t));
 352                 gensels(typid, variantid, gitem(t));
 353                 break;
 354           case item:
 355                 fprintf(fh, "#ifdef __GNUC__\n");
 356
 357                 fprintf(fh, "\nextern __inline__ %s *R%s(struct S%s *t)\n{\n",
 358                              gitemtypid(t), gitemfunid(t), variantid);
 359                 fprintf(fh, "#ifdef UGEN_DEBUG\n");
 360                 fprintf(fh, "\tif(t -> tag != %s)\n", variantid);
 361                 fprintf(fh, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t));
 362                 fprintf(fh, "#endif /* UGEN_DEBUG */\n");
 363                 fprintf(fh, "\treturn(& t -> X%s);\n}\n", gitemfunid(t));
 364
 365                 fprintf(fh, "#else  /* ! __GNUC__ */\n");
 366
 367                 fprintf(fh,
 368                   "extern %s *R%s PROTO((struct S%s *));\n",
 369                   gitemtypid(t), gitemfunid(t), variantid);
 370
 371                 fprintf(fc, "\n%s *R%s(t)\n struct S%s *t;\n{\n",
 372                              gitemtypid(t), gitemfunid(t), variantid);
 373                 fprintf(fc, "#ifdef UGEN_DEBUG\n");
 374                 fprintf(fc, "\tif(t -> tag != %s)\n", variantid);
 375                 fprintf(fc, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t));
 376                 fprintf(fc, "#endif /* UGEN_DEBUG */\n");
 377                 fprintf(fc, "\treturn(& t -> X%s);\n}\n", gitemfunid(t));
 378
 379                 fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
 380
 381                 fprintf(fh,
 382                   "#define %s(xyzxyz) (*R%s((struct S%s *) (xyzxyz)))\n",
 383                   gitemfunid(t), gitemfunid(t), variantid);
 384                 break;
 385           default:
 386                 fprintf(stderr,"gensels: funny abs syntax.\n");
 387                 break;
 388         }
 389
 390 }
 391
 392 /***********************************************************************/
 393
 394 void
 395 gen_hs_reader(typid, deflist)
 396     id typid;
 397     tree deflist;
 398 {
 399         /* signature */
 400         fprintf(fhs, "rdU_%s :: _Addr -> UgnM U_%s\n", typid, typid);
 401
 402         /* defn */
 403         fprintf(fhs, "rdU_%s t\n  = ioToUgnM (_ccall_ t%s t) `thenUgn` \\ tag@(I# _) ->\n", typid, typid);
 404         fprintf(fhs, "    if ");
 405         gen_hs_rdalts(typid, deflist);
 406         fprintf(fhs, "    else\n\terror (\"rdU_%s: bad tag selection:\"++show tag++\"\\n\")\n", typid);
 407 }
 408
 409 void
 410 gen_hs_rdalts(typid, t)
 411     id   typid;
 412     tree t;
 413 {
 414         switch(ttree(t)) {
 415           case deflist:
 416                 gen_hs_rdalts(typid, gdeflist(t));
 417                 fprintf(fhs, "    else if ");
 418                 gen_hs_rdalt (typid, gdef(t));
 419                 break;
 420           case def:
 421                 gen_hs_rdalt(typid, t);
 422                 break;
 423           default:
 424                 fprintf(stderr,"gen_hs_rdalts: funny abstract syntax.\n");
 425                 break;
 426         }
 427 }
 428
 429 void
 430 gen_hs_rdalt(typid, t)
 431     id   typid;
 432     tree t;
 433 {
 434         fprintf(fhs, "tag == ``%s'' then\n", gdid(t));
 435         gen_hs_rdcomponents (typid, gdid(t), gditemlist(t));
 436         fprintf(fhs, "\treturnUgn (U_%s ", gdid(t));
 437         gen_hs_retcomponents(typid, gdid(t), gditemlist(t));
 438         fprintf(fhs, ")\n"); /* end of alt */
 439 }
 440
 441 void
 442 gen_hs_rdcomponents(typid, variantid, t)
 443     id   typid;
 444     id   variantid;
 445     tree t;
 446 {
 447         switch(ttree(t)) {
 448           case emitemlist:
 449                 break;
 450           case itemlist:
 451                 gen_hs_rdcomponents(typid, variantid, gitemlist(t));
 452                 gen_hs_rdcomponents(typid, variantid, gitem(t));
 453                 break;
 454           case item:
 455                 fprintf(fhs, "\tioToUgnM (_ccall_ %s t) `thenUgn` \\ x_%s ->\n",
 456                              gitemfunid(t), gitemfunid(t));
 457
 458                 fprintf(fhs, "\trdU_%s x_%s `thenUgn` \\ y_%s ->\n",
 459                              gitemtypid(t), gitemfunid(t), gitemfunid(t));
 460
 461 /*              fprintf(fhs, "\tif(t -> tag != %s)\n", variantid);
 462                 fprintf(fhs, "\t\tfprintf(stderr,\"%s: illegal selection; was %%d\\n\", t -> tag);\n", gitemfunid(t));
 463                 fprintf(fhs, "\treturn(& t -> X%s);\n}\n", gitemfunid(t));
 464 */              break;
 465
 466           default:
 467                 fprintf(stderr,"gen_hs_rdcomponents: funny abs syntax.\n");
 468                 break;
 469         }
 470 }
 471
 472 void
 473 gen_hs_retcomponents(typid, variantid, t)
 474     id   typid;
 475     id   variantid;
 476     tree t;
 477 {
 478         switch(ttree(t)) {
 479           case emitemlist:
 480                 break;
 481           case itemlist:
 482                 gen_hs_retcomponents(typid, variantid, gitemlist(t));
 483                 fprintf(fhs, " ");
 484                 gen_hs_retcomponents(typid, variantid, gitem(t));
 485                 break;
 486           case item:
 487                 fprintf(fhs, "y_%s", gitemfunid(t));
 488                 break;
 489
 490           default:
 491                 fprintf(stderr,"gen_hs_retcomponents: funny abs syntax.\n");
 492                 break;
 493         }
 494 }