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, "#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));
43 ** Generate to the .hs file:
46 ** = U_constructor1 | U_constructor2 | ...
49 ** Generate to the .h file:
51 ** typedef struct { Ttypename tag; } *typename;
53 fprintf(fh, "typedef struct { T%s tag; } *%s;\n\n", gtid(t), gtid(t));
55 g_tagfun(gtid(t)); /* generate the tag-grabbing function */
57 /* Generate the struct definitions (to the .h file). */
58 gs_typlist(gtdeflist(t), gtid(t));
60 /* Generate a Haskell-equiv data type (to the .hs file) */
61 fprintf(fhs, "data U_%s = ", gtid(t));
62 hs_typlist(gtdeflist(t));
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));
77 ge_typlist(gdeflist(t));
78 fprintf(fh, ",\n\t%s", gdid(gdef(t)));
81 fprintf(fh, "\t%s", gdid(t));
84 fprintf(stderr,"ge_typlist: funny abstract syntax.\n");
96 gs_typlist(gdeflist(t), tid);
103 fprintf(stderr,"gs_typlist: funny abstract syntax.\n");
114 hs_typlist(gdeflist(t));
122 fprintf(stderr,"hs_typlist: funny abstract syntax.\n");
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");
142 fprintf(fhs, "U_%s ", gdid(t));
143 hs_itemlist(gditemlist(t));
154 gs_itemlist(gitemlist(t));
155 fprintf(fh, "\t%s X%s;\n",
156 gitemtypid(gitem(t)), gitemfunid(gitem(t)) );
159 fprintf(fh, "\t%s X%s;\n",
160 gitemtypid(t), gitemfunid(t));
163 fprintf(stderr,"gs_itemlist: funny abs. syntax: %d\n.", ttree(t));
176 hs_itemlist(gitemlist(t));
177 fprintf(fhs, "U_%s ", gitemtypid(gitem(t)));
180 fprintf(fhs, "U_%s ", gitemtypid(t));
183 fprintf(stderr,"hs_itemlist: funny abs. syntax: %d\n.", ttree(t));
192 fprintf(fh, "#ifdef __GNUC__\n");
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);
200 fprintf(fh, "#else /* ! __GNUC__ */\n");
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);
206 fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
208 /*******************************************************************/
217 g_consels(gdeflist(t), typid);
218 g_typconsel(gdef(t), typid);
221 g_typconsel(t, typid);
224 fprintf(stderr,"g_consel: funny abstract syntax.\n");
229 /***********************************************************************/
232 g_typconsel(t, typid)
236 fprintf(fc, "\n/************** %s ******************/\n\n", gdid(t));
238 gensels(typid, gdid(t), gditemlist(t));
245 tree t; /* of kind 'def'. */
247 tree itemlist = gditemlist(t);
249 fprintf(fh, "extern %s mk%s PROTO((", typid, gdid(t));
250 switch (ttree(itemlist)) {
251 case emitemlist: /* empty list */
255 genmkprotodekl(itemlist);
258 fprintf(fh, "));\n");
260 fprintf(fc, "%s mk%s(", typid, gdid(t));
261 switch (ttree(itemlist)) {
262 case emitemlist: /* empty list */
266 genmkparamlist(itemlist);
271 genmkparamdekl(itemlist);
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",
276 fprintf(fc, "\tpp -> tag = %s;\n", gdid(t));
277 genmkfillin(itemlist);
278 fprintf(fc, "\treturn((%s)pp);\n", typid);
290 genmkparamlist(gitemlist(t));
292 genmkparamlist(gitem(t));
295 fprintf(fc, "PP%s", gitemfunid(t));
298 fprintf(stderr,"genparamlist: funny abs syntax.\n");
305 tree t; /* of kind 'itemlist' or 'item' */
311 genmkparamdekl(gitemlist(t));
312 genmkparamdekl(gitem(t));
315 fprintf(fc, " %s PP%s;\n", gitemtypid(t), gitemfunid(t));
318 fprintf(stderr,"genmkparamdekl: funny abs syntax.\n");
325 tree t; /* of kind 'itemlist' or 'item' */
331 genmkprotodekl(gitemlist(t));
333 genmkprotodekl(gitem(t));
336 fprintf(fh, "%s", gitemtypid(t));
339 fprintf(stderr,"genmkprotodekl: funny abs syntax.\n");
352 genmkfillin(gitemlist(t));
353 genmkfillin(gitem(t));
356 fprintf(fc, "\tpp -> X%s = PP%s;\n",
357 gitemfunid(t), gitemfunid(t));
360 fprintf(stderr,"genmkfillin: funny abs syntax.\n");
366 gensels(typid, variantid, t)
375 gensels(typid, variantid, gitemlist(t));
376 gensels(typid, variantid, gitem(t));
379 fprintf(fh, "#ifdef __GNUC__\n");
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));
393 fprintf(fh, "#else /* ! __GNUC__ */\n");
396 "extern %s *R%s PROTO((struct S%s *));\n",
397 gitemtypid(t), gitemfunid(t), variantid);
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));
407 fprintf(fh, "#endif /* ! __GNUC__ */\n\n");
410 "#define %s(xyzxyz) (*R%s((struct S%s *) (xyzxyz)))\n",
411 gitemfunid(t), gitemfunid(t), variantid);
414 fprintf(stderr,"gensels: funny abs syntax.\n");
420 /***********************************************************************/
423 gen_hs_reader(typid, deflist)
428 fprintf(fhs, "rdU_%s :: _Addr -> UgnM U_%s\n", typid, typid);
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);
438 gen_hs_rdalts(typid, t)
444 gen_hs_rdalts(typid, gdeflist(t));
445 fprintf(fhs, " else if ");
446 gen_hs_rdalt (typid, gdef(t));
449 gen_hs_rdalt(typid, t);
452 fprintf(stderr,"gen_hs_rdalts: funny abstract syntax.\n");
458 gen_hs_rdalt(typid, t)
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 */
470 gen_hs_rdcomponents(typid, variantid, t)
479 gen_hs_rdcomponents(typid, variantid, gitemlist(t));
480 gen_hs_rdcomponents(typid, variantid, gitem(t));
483 fprintf(fhs, "\tioToUgnM (_ccall_ %s t) `thenUgn` \\ x_%s ->\n",
484 gitemfunid(t), gitemfunid(t));
486 fprintf(fhs, "\trdU_%s x_%s `thenUgn` \\ y_%s ->\n",
487 gitemtypid(t), gitemfunid(t), gitemfunid(t));
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));
495 fprintf(stderr,"gen_hs_rdcomponents: funny abs syntax.\n");
501 gen_hs_retcomponents(typid, variantid, t)
510 gen_hs_retcomponents(typid, variantid, gitemlist(t));
512 gen_hs_retcomponents(typid, variantid, gitem(t));
515 fprintf(fhs, "y_%s", gitemfunid(t));
519 fprintf(stderr,"gen_hs_retcomponents: funny abs syntax.\n");