11 extern FILE *fh, *fc, *fhs;
18 ** Generate to the .h file:
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));
40 ** Generate to the .hs file:
43 ** = U_constructor1 | U_constructor2 | ...
46 ** Generate to the .h file:
48 ** typedef struct { Ttypename tag; } *typename;
50 fprintf(fh, "typedef struct { T%s tag; } *%s;\n\n", gtid(t), gtid(t));
52 g_tagfun(gtid(t)); /* generate the tag-grabbing function */
54 /* Generate the struct definitions (to the .h file). */
55 gs_typlist(gtdeflist(t), gtid(t));
57 /* Generate a Haskell-equiv data type (to the .hs file) */
58 fprintf(fhs, "data U_%s = ", gtid(t));
59 hs_typlist(gtdeflist(t));
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));
74 ge_typlist(gdeflist(t));
75 fprintf(fh, ",\n\t%s", gdid(gdef(t)));
78 fprintf(fh, "\t%s", gdid(t));
81 fprintf(stderr,"ge_typlist: funny abstract syntax.\n");
93 gs_typlist(gdeflist(t), tid);
100 fprintf(stderr,"gs_typlist: funny abstract syntax.\n");
111 hs_typlist(gdeflist(t));
119 fprintf(stderr,"hs_typlist: funny abstract syntax.\n");
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");
139 fprintf(fhs, "U_%s ", gdid(t));
140 hs_itemlist(gditemlist(t));
151 gs_itemlist(gitemlist(t));
152 fprintf(fh, "\t%s X%s;\n",
153 gitemtypid(gitem(t)), gitemfunid(gitem(t)) );
156 fprintf(fh, "\t%s X%s;\n",
157 gitemtypid(t), gitemfunid(t));
160 fprintf(stderr,"gs_itemlist: funny abs. syntax: %d\n.", ttree(t));
173 hs_itemlist(gitemlist(t));
174 fprintf(fhs, "U_%s ", gitemtypid(gitem(t)));
177 fprintf(fhs, "U_%s ", gitemtypid(t));
180 fprintf(stderr,"hs_itemlist: funny abs. syntax: %d\n.", ttree(t));
189 fprintf(fh, "#ifdef __GNUC__\n");
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);
197 fprintf(fh, "#else /* ! __GNUC__ */\n");
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);
203 fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
205 /*******************************************************************/
214 g_consels(gdeflist(t), typid);
215 g_typconsel(gdef(t), typid);
218 g_typconsel(t, typid);
221 fprintf(stderr,"g_consel: funny abstract syntax.\n");
226 /***********************************************************************/
229 g_typconsel(t, typid)
233 fprintf(fc, "\n/************** %s ******************/\n\n", gdid(t));
235 gensels(typid, gdid(t), gditemlist(t));
242 tree t; /* of kind 'def'. */
244 tree itemlist = gditemlist(t);
246 fprintf(fh, "extern %s mk%s PROTO((", typid, gdid(t));
247 switch (ttree(itemlist)) {
248 case emitemlist: /* empty list */
252 genmkprotodekl(itemlist);
255 fprintf(fh, "));\n");
257 fprintf(fc, "%s mk%s(", typid, gdid(t));
258 switch (ttree(itemlist)) {
259 case emitemlist: /* empty list */
263 genmkparamlist(itemlist);
268 genmkparamdekl(itemlist);
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",
273 fprintf(fc, "\tpp -> tag = %s;\n", gdid(t));
274 genmkfillin(itemlist);
275 fprintf(fc, "\treturn((%s)pp);\n", typid);
287 genmkparamlist(gitemlist(t));
289 genmkparamlist(gitem(t));
292 fprintf(fc, "PP%s", gitemfunid(t));
295 fprintf(stderr,"genparamlist: funny abs syntax.\n");
302 tree t; /* of kind 'itemlist' or 'item' */
308 genmkparamdekl(gitemlist(t));
309 genmkparamdekl(gitem(t));
312 fprintf(fc, " %s PP%s;\n", gitemtypid(t), gitemfunid(t));
315 fprintf(stderr,"genmkparamdekl: funny abs syntax.\n");
322 tree t; /* of kind 'itemlist' or 'item' */
328 genmkprotodekl(gitemlist(t));
330 genmkprotodekl(gitem(t));
333 fprintf(fh, "%s", gitemtypid(t));
336 fprintf(stderr,"genmkprotodekl: funny abs syntax.\n");
349 genmkfillin(gitemlist(t));
350 genmkfillin(gitem(t));
353 fprintf(fc, "\tpp -> X%s = PP%s;\n",
354 gitemfunid(t), gitemfunid(t));
357 fprintf(stderr,"genmkfillin: funny abs syntax.\n");
363 gensels(typid, variantid, t)
372 gensels(typid, variantid, gitemlist(t));
373 gensels(typid, variantid, gitem(t));
376 fprintf(fh, "#ifdef __GNUC__\n");
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));
390 fprintf(fh, "#else /* ! __GNUC__ */\n");
393 "extern %s *R%s PROTO((struct S%s *));\n",
394 gitemtypid(t), gitemfunid(t), variantid);
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));
404 fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
407 "#define %s(xyzxyz) (*R%s((struct S%s *) (xyzxyz)))\n",
408 gitemfunid(t), gitemfunid(t), variantid);
411 fprintf(stderr,"gensels: funny abs syntax.\n");
417 /***********************************************************************/
420 gen_hs_reader(typid, deflist)
425 fprintf(fhs, "rdU_%s :: _Addr -> UgnM U_%s\n", typid, typid);
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);
435 gen_hs_rdalts(typid, t)
441 gen_hs_rdalts(typid, gdeflist(t));
442 fprintf(fhs, " else if ");
443 gen_hs_rdalt (typid, gdef(t));
446 gen_hs_rdalt(typid, t);
449 fprintf(stderr,"gen_hs_rdalts: funny abstract syntax.\n");
455 gen_hs_rdalt(typid, t)
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 */
467 gen_hs_rdcomponents(typid, variantid, t)
476 gen_hs_rdcomponents(typid, variantid, gitemlist(t));
477 gen_hs_rdcomponents(typid, variantid, gitem(t));
480 fprintf(fhs, "\tioToUgnM (_ccall_ %s t) `thenUgn` \\ x_%s ->\n",
481 gitemfunid(t), gitemfunid(t));
483 fprintf(fhs, "\trdU_%s x_%s `thenUgn` \\ y_%s ->\n",
484 gitemtypid(t), gitemfunid(t), gitemfunid(t));
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));
492 fprintf(stderr,"gen_hs_rdcomponents: funny abs syntax.\n");
498 gen_hs_retcomponents(typid, variantid, t)
507 gen_hs_retcomponents(typid, variantid, gitemlist(t));
509 gen_hs_retcomponents(typid, variantid, gitem(t));
512 fprintf(fhs, "y_%s", gitemfunid(t));
516 fprintf(stderr,"gen_hs_retcomponents: funny abs syntax.\n");