Added gfcc2c to GF repo.

doc/gf-history.html

@@ -49,6 +49,20 @@ Use <tt>pg -printer=vxml</tt>.
 generated from a multilingual GF grammar. Use <tt>pm -printer=js</tt>.
 
 
+<p>
+
+5/12 (BB) A new tool for generating C linearization libraries
+from a GFCC file. <tt>make gfcc2c</tt> in <tt>src</tt>
+compiles the tool. The generated
+code includes header files in <tt>lib/c</tt> and should be linked
+against <tt>libgfcc.a</tt> in <tt>lib/c</tt>. For an example of
+using the generated code, see <tt>src/tools/c/examples/bronzeage</tt>.
+<tt>make</tt> in that directory generates a GFCC file, then generates
+C code from that, and then compiles a program <tt>bronzeage-test</tt>.
+The <tt>main</tt> function for that program is defined in
+<tt>bronzeage-test.c</tt>.
+
+
 <p>
 
 20/11 (AR) Type error messages in concrete syntax are printed with a

lib/c/Makefile

@@ -0,0 +1,19 @@
+CC = gcc
+CFLAGS += -O2 -W -Wall
+
+.PHONY: all clean
+
+all: libgfcc.a
+
+libgfcc.a: gfcc-tree.o gfcc-term.o 
+	ar r $@ $^
+
+gfcc-tree.o: gfcc-tree.c gfcc-tree.h
+	$(CC) $(CFLAGS) -c -o $@ $<
+
+gfcc-term.o: gfcc-term.c gfcc-term.h
+	$(CC) $(CFLAGS) -c -o $@ $<
+
+clean:
+	-rm -f libgfcc.a
+	-rm -f *.o

lib/c/gfcc-term.c

@@ -0,0 +1,203 @@
+#include "gfcc-term.h"
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+static void *buffer = NULL;
+static size_t current;
+
+extern void term_alloc_pool(size_t size) {
+	if (buffer == NULL) 
+		buffer = malloc(size);
+	current = 0;
+}
+
+extern void term_free_pool() {
+	if (buffer != NULL)
+		free(buffer);
+	buffer = NULL;
+}
+
+extern void *term_alloc(size_t size) {
+	void *off = buffer + current;
+	current += size;
+	return off;
+}
+
+static inline Term *create_term(TermType type, int n) {
+	Term *t = (Term*)term_alloc(sizeof(Term) + n * sizeof(Term *));
+	t->type = type;
+	t->value.size = n; /* FIXME: hack! */
+	return t;
+}
+
+extern Term *term_array(int n, ...) {
+	Term *t = create_term(TERM_ARRAY, n);
+	va_list ap;
+	int i;
+
+	va_start(ap, n);
+	for (i = 0; i < n; i++) {
+		term_set_child(t, i, va_arg(ap, Term *));
+	}
+	va_end(ap);
+
+	return t;
+}
+
+extern Term *term_seq(int n, ...) {
+	Term *t = create_term(TERM_SEQUENCE, n);
+	va_list ap;
+	int i;
+
+	va_start(ap, n);
+	for (i = 0; i < n; i++) {
+		term_set_child(t, i, va_arg(ap, Term *));
+	}
+	va_end(ap);
+
+	return t;
+}
+
+extern Term *term_variants(int n, ...) {
+	Term *t = create_term(TERM_VARIANTS, n);
+	va_list ap;
+	int i;
+
+	va_start(ap, n);
+	for (i = 0; i < n; i++) {
+		term_set_child(t, i, va_arg(ap, Term *));
+	}
+	va_end(ap);
+
+	return t;
+}
+
+extern Term *term_glue(int n, ...) {
+	Term *t = create_term(TERM_GLUE, n);
+	va_list ap;
+	int i;
+
+	va_start(ap, n);
+	for (i = 0; i < n; i++) {
+		term_set_child(t, i, va_arg(ap, Term *));
+	}
+	va_end(ap);
+
+	return t;
+}
+
+extern Term *term_rp(Term *t1, Term *t2) {
+	Term *t = create_term(TERM_RECORD_PARAM, 2);
+	term_set_child(t, 0, t1);
+	term_set_child(t, 1, t2);
+	return t;
+}
+
+extern Term *term_suffix(const char *pref, Term *suf) {
+	Term *t = create_term(TERM_SUFFIX_TABLE, 2);
+	term_set_child(t,0,term_str(pref));
+	term_set_child(t,1,suf);
+	return t;
+}
+
+extern Term *term_str(const char *s) {
+	Term *t = create_term(TERM_STRING, 0);
+	t->value.string_value = s;
+	return t;
+}
+
+extern Term *term_int(int i) {
+	Term *t = create_term(TERM_INTEGER,0);
+	t->value.integer_value = i;
+	return t;
+}
+
+extern Term *term_meta() {
+	return create_term(TERM_META, 0);
+}
+
+
+
+extern Term *term_sel_int(Term *t, int i) {
+	switch (t->type) {
+	case TERM_ARRAY:
+		return term_get_child(t,i);
+	case TERM_SUFFIX_TABLE:
+		return term_glue(2,
+				 term_get_child(t,0), 
+				 term_sel_int(term_get_child(t,1),i));
+	case TERM_META:
+		return t;
+	default: 
+		fprintf(stderr,"Error: term_sel_int %d %d\n", t->type, i);
+		exit(1);
+		return NULL;
+  }
+}
+
+extern Term *term_sel(Term *t1, Term *t2) {
+	switch (t2->type) {
+	case TERM_INTEGER:
+		return term_sel_int(t1, t2->value.integer_value);
+	case TERM_RECORD_PARAM:
+		return term_sel(t1,term_get_child(t2,0));
+	case TERM_META:
+		return term_sel_int(t1,0);
+	default: 
+		fprintf(stderr,"Error: term_sel %d %d\n", t1->type, t2->type);
+		exit(1);
+		return 0;
+	}
+}
+
+
+
+static void term_print_sep(FILE *stream, Term *t, const char *sep) {
+	int n = t->value.size;
+	int i;
+
+	for (i = 0; i < n; i++) {
+		term_print(stream, term_get_child(t,i));
+		if (i < n-1) {
+			fputs(sep, stream);
+		}
+	}
+}
+
+extern void term_print(FILE *stream, Term *t) {
+	switch (t->type) {
+	case TERM_ARRAY:
+		term_print(stream, term_get_child(t,0));
+		break;
+	case TERM_SEQUENCE:
+		term_print_sep(stream, t, " ");
+		break;
+	case TERM_VARIANTS:
+		term_print_sep(stream, t, "/");
+		break;
+	case TERM_GLUE:
+		term_print_sep(stream, t, "");
+		break;
+	case TERM_RECORD_PARAM:
+		term_print(stream, term_get_child(t,0));
+		break;
+	case TERM_SUFFIX_TABLE:
+		term_print(stream, term_get_child(t,0));
+		term_print(stream, term_get_child(t,1));
+		break;
+	case TERM_META:
+		fputs("?", stream);
+		break;
+	case TERM_STRING: 
+		fputs(t->value.string_value, stream);
+		break;
+	case TERM_INTEGER: 
+		fprintf(stream, "%d", t->value.integer_value);
+		break;
+	default:
+		fprintf(stderr,"Error: term_print %d\n", t->type);
+		exit(1);
+	}
+}

lib/c/gfcc-term.h

@@ -0,0 +1,65 @@
+#ifndef GFCC_TERM_H
+#define GFCC_TERM_H
+
+#include <stdio.h>
+
+typedef enum {
+	/* size = variable */
+	TERM_ARRAY,
+	TERM_SEQUENCE,
+	TERM_VARIANTS,
+	TERM_GLUE,
+	/* size = 2 */
+	TERM_RECORD_PARAM,
+	TERM_SUFFIX_TABLE,
+	/* size = 0 */
+	TERM_META,
+	TERM_STRING,
+	TERM_INTEGER
+} TermType;
+
+struct Term_ {
+	TermType type;
+	union {
+		const char *string_value;
+		int integer_value;
+		int size;
+	} value;
+	struct Term_ *args[0];
+};
+
+typedef struct Term_ Term;
+
+
+
+static inline Term *term_get_child(Term *t, int n) {
+	return t->args[n];
+}
+
+static inline void term_set_child(Term *t, int n, Term *c) {
+	t->args[n] = c;
+}
+
+extern void term_alloc_pool(size_t size);
+extern void term_free_pool();
+extern void *term_alloc(size_t size);
+
+
+extern Term *term_array(int n, ...);
+extern Term *term_seq(int n, ...);
+extern Term *term_variants(int n, ...);
+extern Term *term_glue(int n, ...);
+
+extern Term *term_rp(Term *t1, Term *t2);
+extern Term *term_suffix(const char *pref, Term *suf);
+extern Term *term_str(const char *s);
+extern Term *term_int(int i);
+extern Term *term_meta();
+
+extern Term *term_sel_int(Term *t, int i);
+extern Term *term_sel(Term *t1, Term *t2);
+
+
+extern void term_print(FILE *stream, Term *t);
+
+#endif

lib/c/gfcc-tree.c

@@ -0,0 +1,61 @@
+#include "gfcc-tree.h"
+
+#include <stdlib.h>
+
+
+extern int arity(Tree *t) {
+	switch (t->type) {
+	case ATOM_STRING: 
+	case ATOM_INTEGER:
+	case ATOM_DOUBLE:
+	case ATOM_META:
+		return 0;
+	default:
+		return t->value.size;
+	}
+}
+
+static Tree *create_tree(atom_type c, int n) {
+	Tree *t = (Tree *)malloc(sizeof(Tree) + n * sizeof(Tree *));
+	t->type = c;
+	return t;
+}
+
+extern Tree *tree_string(const char *s) {
+	Tree *t = create_tree(ATOM_STRING, 0);
+	t->value.string_value = s;
+	return t;
+}
+
+extern Tree *tree_integer(int i) {
+	Tree *t = create_tree(ATOM_INTEGER, 0);
+	t->value.integer_value = i;
+	return t;
+}
+
+extern Tree *tree_double(double d) {
+	Tree *t = create_tree(ATOM_DOUBLE, 0);
+	t->value.double_value = d;
+	return t;
+}
+
+extern Tree *tree_meta() {
+	return create_tree(ATOM_META, 0);
+}
+
+extern Tree *tree_fun(atom_type f, int n) {
+	Tree *t = create_tree(f, n);
+	t->value.size = n;
+	return t;
+}
+
+
+extern void tree_free(Tree *t) {
+	int n = arity(t);
+	int i;
+
+	for (i = 0; i < n; i++) {
+		tree_free(tree_get_child(t,i));
+	}
+	free(t);
+}

lib/c/gfcc-tree.h

@@ -0,0 +1,49 @@
+#ifndef GFCC_TREE_H
+#define GFCC_TREE_H
+
+typedef enum {
+	ATOM_STRING,
+	ATOM_INTEGER,
+	ATOM_DOUBLE,
+	ATOM_META,
+	ATOM_FIRST_FUN
+} atom_type;
+
+struct Tree_{
+	atom_type type;
+	union {
+		const char *string_value;
+		int integer_value;
+		double double_value;
+		int size;
+	} value;
+	struct Tree_ *args[0];
+};
+
+typedef struct Tree_ Tree;
+
+static inline Tree *tree_get_child(Tree *t, int n) {
+	return t->args[n];
+}
+
+static inline void tree_set_child(Tree *t, int n, Tree *a) {
+	t->args[n] = a;
+}
+
+extern int arity(Tree *t);
+
+
+extern Tree *tree_string(const char *s);
+
+extern Tree *tree_integer(int i);
+
+extern Tree *tree_double(double d);
+
+extern Tree *tree_meta();
+
+extern Tree *tree_fun(atom_type f, int n);
+
+
+extern void tree_free(Tree *t);
+
+#endif

src/Makefile

@@ -112,6 +112,9 @@ clean:
 	-rm -f $(GFEDITOR)/de/uka/ilkd/key/ocl/gf/*.class
 	-rm -f gf.wixobj
 	-rm -f ../bin/$(GF_EXE)
+	$(MAKE) -C tools/c clean
+	$(MAKE) -C ../lib/c clean
+	-rm -f ../bin/gfcc2c
 
 distclean: clean
 	-rm -f JavaGUI/gf-java.jar jgf
@@ -182,6 +185,12 @@ gfcc:
 	$(GHMAKE) $(GHCOPTFLAGS) -o gfcc GF/Canon/GFCC/RunGFCC.hs
 	strip gfcc
 	mv gfcc ../bin/
+
+gfcc2c:
+	$(MAKE) -C tools/c
+	$(MAKE) -C ../lib/c
+	mv tools/c/gfcc2c ../bin
+
 #
 # Distribution
 #

src/tools/c/GFCC/Abs.hs

@@ -0,0 +1,227 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module GFCC.Abs (Tree(..), Grammar, Header, Abstract, Concrete, AbsDef, CncDef, Type, Exp, Atom, Term, Tokn, Variant, CId, johnMajorEq, module GFCC.ComposOp) where
+
+import GFCC.ComposOp
+
+import Data.Monoid
+
+-- Haskell module generated by the BNF converter
+
+data Grammar_
+type Grammar = Tree Grammar_
+data Header_
+type Header = Tree Header_
+data Abstract_
+type Abstract = Tree Abstract_
+data Concrete_
+type Concrete = Tree Concrete_
+data AbsDef_
+type AbsDef = Tree AbsDef_
+data CncDef_
+type CncDef = Tree CncDef_
+data Type_
+type Type = Tree Type_
+data Exp_
+type Exp = Tree Exp_
+data Atom_
+type Atom = Tree Atom_
+data Term_
+type Term = Tree Term_
+data Tokn_
+type Tokn = Tree Tokn_
+data Variant_
+type Variant = Tree Variant_
+data CId_
+type CId = Tree CId_
+
+data Tree :: * -> * where
+    Grm :: Header -> Abstract -> [Concrete] -> Tree Grammar_
+    Hdr :: CId -> [CId] -> Tree Header_
+    Abs :: [AbsDef] -> Tree Abstract_
+    Cnc :: CId -> [CncDef] -> Tree Concrete_
+    Fun :: CId -> Type -> Exp -> Tree AbsDef_
+    Lin :: CId -> Term -> Tree CncDef_
+    Typ :: [CId] -> CId -> Tree Type_
+    Tr :: Atom -> [Exp] -> Tree Exp_
+    AC :: CId -> Tree Atom_
+    AS :: String -> Tree Atom_
+    AI :: Integer -> Tree Atom_
+    AF :: Double -> Tree Atom_
+    AM :: Tree Atom_
+    R :: [Term] -> Tree Term_
+    P :: Term -> Term -> Tree Term_
+    S :: [Term] -> Tree Term_
+    K :: Tokn -> Tree Term_
+    V :: Integer -> Tree Term_
+    C :: Integer -> Tree Term_
+    F :: CId -> Tree Term_
+    FV :: [Term] -> Tree Term_
+    W :: String -> Term -> Tree Term_
+    RP :: Term -> Term -> Tree Term_
+    TM :: Tree Term_
+    L :: CId -> Term -> Tree Term_
+    BV :: CId -> Tree Term_
+    KS :: String -> Tree Tokn_
+    KP :: [String] -> [Variant] -> Tree Tokn_
+    Var :: [String] -> [String] -> Tree Variant_
+    CId :: String -> Tree CId_
+
+instance Compos Tree where
+  compos r a f t = case t of
+      Grm header abstract concretes -> r Grm `a` f header `a` f abstract `a` foldr (a . a (r (:)) . f) (r []) concretes
+      Hdr cid cids -> r Hdr `a` f cid `a` foldr (a . a (r (:)) . f) (r []) cids
+      Abs absdefs -> r Abs `a` foldr (a . a (r (:)) . f) (r []) absdefs
+      Cnc cid cncdefs -> r Cnc `a` f cid `a` foldr (a . a (r (:)) . f) (r []) cncdefs
+      Fun cid type' exp -> r Fun `a` f cid `a` f type' `a` f exp
+      Lin cid term -> r Lin `a` f cid `a` f term
+      Typ cids cid -> r Typ `a` foldr (a . a (r (:)) . f) (r []) cids `a` f cid
+      Tr atom exps -> r Tr `a` f atom `a` foldr (a . a (r (:)) . f) (r []) exps
+      AC cid -> r AC `a` f cid
+      R terms -> r R `a` foldr (a . a (r (:)) . f) (r []) terms
+      P term0 term1 -> r P `a` f term0 `a` f term1
+      S terms -> r S `a` foldr (a . a (r (:)) . f) (r []) terms
+      K tokn -> r K `a` f tokn
+      F cid -> r F `a` f cid
+      FV terms -> r FV `a` foldr (a . a (r (:)) . f) (r []) terms
+      W str term -> r W `a` r str `a` f term
+      RP term0 term1 -> r RP `a` f term0 `a` f term1
+      L cid term -> r L `a` f cid `a` f term
+      BV cid -> r BV `a` f cid
+      KP strs variants -> r KP `a` r strs `a` foldr (a . a (r (:)) . f) (r []) variants
+      _ -> r t
+
+instance Show (Tree c) where
+  showsPrec n t = case t of
+    Grm header abstract concretes -> opar n . showString "Grm" . showChar ' ' . showsPrec 1 header . showChar ' ' . showsPrec 1 abstract . showChar ' ' . showsPrec 1 concretes . cpar n
+    Hdr cid cids -> opar n . showString "Hdr" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 cids . cpar n
+    Abs absdefs -> opar n . showString "Abs" . showChar ' ' . showsPrec 1 absdefs . cpar n
+    Cnc cid cncdefs -> opar n . showString "Cnc" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 cncdefs . cpar n
+    Fun cid type' exp -> opar n . showString "Fun" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 type' . showChar ' ' . showsPrec 1 exp . cpar n
+    Lin cid term -> opar n . showString "Lin" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 term . cpar n
+    Typ cids cid -> opar n . showString "Typ" . showChar ' ' . showsPrec 1 cids . showChar ' ' . showsPrec 1 cid . cpar n
+    Tr atom exps -> opar n . showString "Tr" . showChar ' ' . showsPrec 1 atom . showChar ' ' . showsPrec 1 exps . cpar n
+    AC cid -> opar n . showString "AC" . showChar ' ' . showsPrec 1 cid . cpar n
+    AS str -> opar n . showString "AS" . showChar ' ' . showsPrec 1 str . cpar n
+    AI n -> opar n . showString "AI" . showChar ' ' . showsPrec 1 n . cpar n
+    AF d -> opar n . showString "AF" . showChar ' ' . showsPrec 1 d . cpar n
+    AM -> showString "AM"
+    R terms -> opar n . showString "R" . showChar ' ' . showsPrec 1 terms . cpar n
+    P term0 term1 -> opar n . showString "P" . showChar ' ' . showsPrec 1 term0 . showChar ' ' . showsPrec 1 term1 . cpar n
+    S terms -> opar n . showString "S" . showChar ' ' . showsPrec 1 terms . cpar n
+    K tokn -> opar n . showString "K" . showChar ' ' . showsPrec 1 tokn . cpar n
+    V n -> opar n . showString "V" . showChar ' ' . showsPrec 1 n . cpar n
+    C n -> opar n . showString "C" . showChar ' ' . showsPrec 1 n . cpar n
+    F cid -> opar n . showString "F" . showChar ' ' . showsPrec 1 cid . cpar n
+    FV terms -> opar n . showString "FV" . showChar ' ' . showsPrec 1 terms . cpar n
+    W str term -> opar n . showString "W" . showChar ' ' . showsPrec 1 str . showChar ' ' . showsPrec 1 term . cpar n
+    RP term0 term1 -> opar n . showString "RP" . showChar ' ' . showsPrec 1 term0 . showChar ' ' . showsPrec 1 term1 . cpar n
+    TM -> showString "TM"
+    L cid term -> opar n . showString "L" . showChar ' ' . showsPrec 1 cid . showChar ' ' . showsPrec 1 term . cpar n
+    BV cid -> opar n . showString "BV" . showChar ' ' . showsPrec 1 cid . cpar n
+    KS str -> opar n . showString "KS" . showChar ' ' . showsPrec 1 str . cpar n
+    KP strs variants -> opar n . showString "KP" . showChar ' ' . showsPrec 1 strs . showChar ' ' . showsPrec 1 variants . cpar n
+    Var strs0 strs1 -> opar n . showString "Var" . showChar ' ' . showsPrec 1 strs0 . showChar ' ' . showsPrec 1 strs1 . cpar n
+    CId str -> opar n . showString "CId" . showChar ' ' . showsPrec 1 str . cpar n
+   where opar n = if n > 0 then showChar '(' else id
+         cpar n = if n > 0 then showChar ')' else id
+
+instance Eq (Tree c) where (==) = johnMajorEq
+
+johnMajorEq :: Tree a -> Tree b -> Bool
+johnMajorEq (Grm header abstract concretes) (Grm header_ abstract_ concretes_) = header == header_ && abstract == abstract_ && concretes == concretes_
+johnMajorEq (Hdr cid cids) (Hdr cid_ cids_) = cid == cid_ && cids == cids_
+johnMajorEq (Abs absdefs) (Abs absdefs_) = absdefs == absdefs_
+johnMajorEq (Cnc cid cncdefs) (Cnc cid_ cncdefs_) = cid == cid_ && cncdefs == cncdefs_
+johnMajorEq (Fun cid type' exp) (Fun cid_ type'_ exp_) = cid == cid_ && type' == type'_ && exp == exp_
+johnMajorEq (Lin cid term) (Lin cid_ term_) = cid == cid_ && term == term_
+johnMajorEq (Typ cids cid) (Typ cids_ cid_) = cids == cids_ && cid == cid_
+johnMajorEq (Tr atom exps) (Tr atom_ exps_) = atom == atom_ && exps == exps_
+johnMajorEq (AC cid) (AC cid_) = cid == cid_
+johnMajorEq (AS str) (AS str_) = str == str_
+johnMajorEq (AI n) (AI n_) = n == n_
+johnMajorEq (AF d) (AF d_) = d == d_
+johnMajorEq AM AM = True
+johnMajorEq (R terms) (R terms_) = terms == terms_
+johnMajorEq (P term0 term1) (P term0_ term1_) = term0 == term0_ && term1 == term1_
+johnMajorEq (S terms) (S terms_) = terms == terms_
+johnMajorEq (K tokn) (K tokn_) = tokn == tokn_
+johnMajorEq (V n) (V n_) = n == n_
+johnMajorEq (C n) (C n_) = n == n_
+johnMajorEq (F cid) (F cid_) = cid == cid_
+johnMajorEq (FV terms) (FV terms_) = terms == terms_
+johnMajorEq (W str term) (W str_ term_) = str == str_ && term == term_
+johnMajorEq (RP term0 term1) (RP term0_ term1_) = term0 == term0_ && term1 == term1_
+johnMajorEq TM TM = True
+johnMajorEq (L cid term) (L cid_ term_) = cid == cid_ && term == term_
+johnMajorEq (BV cid) (BV cid_) = cid == cid_
+johnMajorEq (KS str) (KS str_) = str == str_
+johnMajorEq (KP strs variants) (KP strs_ variants_) = strs == strs_ && variants == variants_
+johnMajorEq (Var strs0 strs1) (Var strs0_ strs1_) = strs0 == strs0_ && strs1 == strs1_
+johnMajorEq (CId str) (CId str_) = str == str_
+johnMajorEq _ _ = False
+
+instance Ord (Tree c) where
+  compare x y = compare (index x) (index y) `mappend` compareSame x y
+index :: Tree c -> Int
+index (Grm _ _ _) = 0
+index (Hdr _ _) = 1
+index (Abs _) = 2
+index (Cnc _ _) = 3
+index (Fun _ _ _) = 4
+index (Lin _ _) = 5
+index (Typ _ _) = 6
+index (Tr _ _) = 7
+index (AC _) = 8
+index (AS _) = 9
+index (AI _) = 10
+index (AF _) = 11
+index (AM ) = 12
+index (R _) = 13
+index (P _ _) = 14
+index (S _) = 15
+index (K _) = 16
+index (V _) = 17
+index (C _) = 18
+index (F _) = 19
+index (FV _) = 20
+index (W _ _) = 21
+index (RP _ _) = 22
+index (TM ) = 23
+index (L _ _) = 24
+index (BV _) = 25
+index (KS _) = 26
+index (KP _ _) = 27
+index (Var _ _) = 28
+index (CId _) = 29
+compareSame :: Tree c -> Tree c -> Ordering
+compareSame (Grm header abstract concretes) (Grm header_ abstract_ concretes_) = mappend (compare header header_) (mappend (compare abstract abstract_) (compare concretes concretes_))
+compareSame (Hdr cid cids) (Hdr cid_ cids_) = mappend (compare cid cid_) (compare cids cids_)
+compareSame (Abs absdefs) (Abs absdefs_) = compare absdefs absdefs_
+compareSame (Cnc cid cncdefs) (Cnc cid_ cncdefs_) = mappend (compare cid cid_) (compare cncdefs cncdefs_)
+compareSame (Fun cid type' exp) (Fun cid_ type'_ exp_) = mappend (compare cid cid_) (mappend (compare type' type'_) (compare exp exp_))
+compareSame (Lin cid term) (Lin cid_ term_) = mappend (compare cid cid_) (compare term term_)
+compareSame (Typ cids cid) (Typ cids_ cid_) = mappend (compare cids cids_) (compare cid cid_)
+compareSame (Tr atom exps) (Tr atom_ exps_) = mappend (compare atom atom_) (compare exps exps_)
+compareSame (AC cid) (AC cid_) = compare cid cid_
+compareSame (AS str) (AS str_) = compare str str_
+compareSame (AI n) (AI n_) = compare n n_
+compareSame (AF d) (AF d_) = compare d d_
+compareSame AM AM = EQ
+compareSame (R terms) (R terms_) = compare terms terms_
+compareSame (P term0 term1) (P term0_ term1_) = mappend (compare term0 term0_) (compare term1 term1_)
+compareSame (S terms) (S terms_) = compare terms terms_
+compareSame (K tokn) (K tokn_) = compare tokn tokn_
+compareSame (V n) (V n_) = compare n n_
+compareSame (C n) (C n_) = compare n n_
+compareSame (F cid) (F cid_) = compare cid cid_
+compareSame (FV terms) (FV terms_) = compare terms terms_
+compareSame (W str term) (W str_ term_) = mappend (compare str str_) (compare term term_)
+compareSame (RP term0 term1) (RP term0_ term1_) = mappend (compare term0 term0_) (compare term1 term1_)
+compareSame TM TM = EQ
+compareSame (L cid term) (L cid_ term_) = mappend (compare cid cid_) (compare term term_)
+compareSame (BV cid) (BV cid_) = compare cid cid_
+compareSame (KS str) (KS str_) = compare str str_
+compareSame (KP strs variants) (KP strs_ variants_) = mappend (compare strs strs_) (compare variants variants_)
+compareSame (Var strs0 strs1) (Var strs0_ strs1_) = mappend (compare strs0 strs0_) (compare strs1 strs1_)
+compareSame (CId str) (CId str_) = compare str str_
+compareSame x y = error "BNFC error:" compareSame

src/tools/c/GFCC/ComposOp.hs

@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module GFCC.ComposOp (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,
+                 composOpMPlus,composOpFold) where
+
+import Control.Monad.Identity
+import Data.Monoid
+
+class Compos t where
+  compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)
+         -> (forall a. t a -> m (t a)) -> t c -> m (t c)
+
+composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c
+composOp f = runIdentity . composOpM (Identity . f)
+
+composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)
+composOpM = compos return ap
+
+composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()
+composOpM_ = composOpFold (return ()) (>>)
+
+composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m
+composOpMonoid = composOpFold mempty mappend
+
+composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b
+composOpMPlus = composOpFold mzero mplus
+
+composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b
+composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
+
+newtype C b a = C { unC :: b }

src/tools/c/GFCC/ErrM.hs

@@ -0,0 +1,16 @@
+-- BNF Converter: Error Monad
+-- Copyright (C) 2004  Author:  Aarne Ranta
+
+-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
+module GFCC.ErrM where
+
+-- the Error monad: like Maybe type with error msgs
+
+data Err a = Ok a | Bad String
+  deriving (Read, Show, Eq)
+
+instance Monad Err where
+  return      = Ok
+  fail        = Bad
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s

src/tools/c/GFCC/Lex.x

@@ -0,0 +1,135 @@
+-- -*- haskell -*-
+-- This Alex file was machine-generated by the BNF converter
+{
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GFCC.Lex where
+
+
+}
+
+
+$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME
+$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME
+$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME
+$d = [0-9]                -- digit
+$i = [$l $d _ ']          -- identifier character
+$u = [\0-\255]          -- universal: any character
+
+@rsyms =    -- symbols and non-identifier-like reserved words
+   \; | \( | \) | \{ | \} | \: | \= | \- \> | \? | \[ | \] | \! | \$ | \[ \| | \| \] | \+ | \@ | \# | \/ | \,
+
+:-
+
+$white+ ;
+@rsyms { tok (\p s -> PT p (TS $ share s)) }
+(\_ | $l)($l | $d | \' | \_)* { tok (\p s -> PT p (eitherResIdent (T_CId . share) s)) }
+
+$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+
+$d+      { tok (\p s -> PT p (TI $ share s))    }
+$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
+
+{
+
+tok f p s = f p s
+
+share :: String -> String
+share = id
+
+data Tok =
+   TS !String     -- reserved words and symbols
+ | TL !String     -- string literals
+ | TI !String     -- integer literals
+ | TV !String     -- identifiers
+ | TD !String     -- double precision float literals
+ | TC !String     -- character literals
+ | T_CId !String
+
+ deriving (Eq,Show,Ord)
+
+data Token = 
+   PT  Posn Tok
+ | Err Posn
+  deriving (Eq,Show,Ord)
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+posLineCol (Pn _ l c) = (l,c)
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+
+prToken t = case t of
+  PT _ (TS s) -> s
+  PT _ (TI s) -> s
+  PT _ (TV s) -> s
+  PT _ (TD s) -> s
+  PT _ (TC s) -> s
+  PT _ (T_CId s) -> s
+
+  _ -> show t
+
+data BTree = N | B String Tok BTree BTree deriving (Show)
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = treeFind resWords
+  where
+  treeFind N = tv s
+  treeFind (B a t left right) | s < a  = treeFind left
+                              | s > a  = treeFind right
+                              | s == a = t
+
+resWords = b "grammar" (b "concrete" (b "abstract" N N) N) (b "pre" N N)
+   where b s = B s (TS s)
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+  unesc s = case s of
+    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+    '\\':'n':cs  -> '\n' : unesc cs
+    '\\':'t':cs  -> '\t' : unesc cs
+    '"':[]    -> []
+    c:cs      -> c : unesc cs
+    _         -> []
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn !Int !Int !Int
+      deriving (Eq, Show,Ord)
+
+alexStartPos :: Posn
+alexStartPos = Pn 0 1 1
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
+alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
+
+type AlexInput = (Posn, -- current position,
+		  Char,	-- previous char
+		  String)	-- current input string
+
+tokens :: String -> [Token]
+tokens str = go (alexStartPos, '\n', str)
+    where
+      go :: (Posn, Char, String) -> [Token]
+      go inp@(pos, _, str) =
+    	  case alexScan inp 0 of
+    	    AlexEOF                -> []
+    	    AlexError (pos, _, _)  -> [Err pos]
+    	    AlexSkip  inp' len     -> go inp'
+    	    AlexToken inp' len act -> act pos (take len str) : (go inp')
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (p, c, [])    = Nothing
+alexGetChar (p, _, (c:s)) =
+    let p' = alexMove p c
+     in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+}

src/tools/c/GFCC/Par.y

@@ -0,0 +1,204 @@
+-- This Happy file was machine-generated by the BNF converter
+{
+{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
+module GFCC.Par where
+import GFCC.Abs
+import GFCC.Lex
+import GFCC.ErrM
+}
+
+%name pGrammar Grammar
+%name pHeader Header
+%name pAbstract Abstract
+%name pConcrete Concrete
+%name pAbsDef AbsDef
+%name pCncDef CncDef
+%name pType Type
+%name pExp Exp
+%name pAtom Atom
+%name pTerm Term
+%name pTokn Tokn
+%name pVariant Variant
+%name pListConcrete ListConcrete
+%name pListAbsDef ListAbsDef
+%name pListCncDef ListCncDef
+%name pListCId ListCId
+%name pListTerm ListTerm
+%name pListExp ListExp
+%name pListString ListString
+%name pListVariant ListVariant
+
+-- no lexer declaration
+%monad { Err } { thenM } { returnM }
+%tokentype { Token }
+
+%token 
+ ';' { PT _ (TS ";") }
+ '(' { PT _ (TS "(") }
+ ')' { PT _ (TS ")") }
+ '{' { PT _ (TS "{") }
+ '}' { PT _ (TS "}") }
+ ':' { PT _ (TS ":") }
+ '=' { PT _ (TS "=") }
+ '->' { PT _ (TS "->") }
+ '?' { PT _ (TS "?") }
+ '[' { PT _ (TS "[") }
+ ']' { PT _ (TS "]") }
+ '!' { PT _ (TS "!") }
+ '$' { PT _ (TS "$") }
+ '[|' { PT _ (TS "[|") }
+ '|]' { PT _ (TS "|]") }
+ '+' { PT _ (TS "+") }
+ '@' { PT _ (TS "@") }
+ '#' { PT _ (TS "#") }
+ '/' { PT _ (TS "/") }
+ ',' { PT _ (TS ",") }
+ 'abstract' { PT _ (TS "abstract") }
+ 'concrete' { PT _ (TS "concrete") }
+ 'grammar' { PT _ (TS "grammar") }
+ 'pre' { PT _ (TS "pre") }
+
+L_quoted { PT _ (TL $$) }
+L_integ  { PT _ (TI $$) }
+L_doubl  { PT _ (TD $$) }
+L_CId { PT _ (T_CId $$) }
+L_err    { _ }
+
+
+%%
+
+String  :: { String }  : L_quoted { $1 }
+Integer :: { Integer } : L_integ  { (read $1) :: Integer }
+Double  :: { Double }  : L_doubl  { (read $1) :: Double }
+CId    :: { CId} : L_CId { CId ($1)}
+
+Grammar :: { Grammar }
+Grammar : Header ';' Abstract ';' ListConcrete { Grm $1 $3 (reverse $5) } 
+
+
+Header :: { Header }
+Header : 'grammar' CId '(' ListCId ')' { Hdr $2 $4 } 
+
+
+Abstract :: { Abstract }
+Abstract : 'abstract' '{' ListAbsDef '}' { Abs (reverse $3) } 
+
+
+Concrete :: { Concrete }
+Concrete : 'concrete' CId '{' ListCncDef '}' { Cnc $2 (reverse $4) } 
+
+
+AbsDef :: { AbsDef }
+AbsDef : CId ':' Type '=' Exp { Fun $1 $3 $5 } 
+
+
+CncDef :: { CncDef }
+CncDef : CId '=' Term { Lin $1 $3 } 
+
+
+Type :: { Type }
+Type : ListCId '->' CId { Typ $1 $3 } 
+
+
+Exp :: { Exp }
+Exp : '(' Atom ListExp ')' { Tr $2 (reverse $3) } 
+  | Atom { trA_ $1 }
+
+
+Atom :: { Atom }
+Atom : CId { AC $1 } 
+  | String { AS $1 }
+  | Integer { AI $1 }
+  | Double { AF $1 }
+  | '?' { AM }
+
+
+Term :: { Term }
+Term : '[' ListTerm ']' { R $2 } 
+  | '(' Term '!' Term ')' { P $2 $4 }
+  | '(' ListTerm ')' { S $2 }
+  | Tokn { K $1 }
+  | '$' Integer { V $2 }
+  | Integer { C $1 }
+  | CId { F $1 }
+  | '[|' ListTerm '|]' { FV $2 }
+  | '(' String '+' Term ')' { W $2 $4 }
+  | '(' Term '@' Term ')' { RP $2 $4 }
+  | '?' { TM }
+  | '(' CId '->' Term ')' { L $2 $4 }
+  | '#' CId { BV $2 }
+
+
+Tokn :: { Tokn }
+Tokn : String { KS $1 } 
+  | '[' 'pre' ListString '[' ListVariant ']' ']' { KP (reverse $3) $5 }
+
+
+Variant :: { Variant }
+Variant : ListString '/' ListString { Var (reverse $1) (reverse $3) } 
+
+
+ListConcrete :: { [Concrete] }
+ListConcrete : {- empty -} { [] } 
+  | ListConcrete Concrete ';' { flip (:) $1 $2 }
+
+
+ListAbsDef :: { [AbsDef] }
+ListAbsDef : {- empty -} { [] } 
+  | ListAbsDef AbsDef ';' { flip (:) $1 $2 }
+
+
+ListCncDef :: { [CncDef] }
+ListCncDef : {- empty -} { [] } 
+  | ListCncDef CncDef ';' { flip (:) $1 $2 }
+
+
+ListCId :: { [CId] }
+ListCId : {- empty -} { [] } 
+  | CId { (:[]) $1 }
+  | CId ',' ListCId { (:) $1 $3 }
+
+
+ListTerm :: { [Term] }
+ListTerm : {- empty -} { [] } 
+  | Term { (:[]) $1 }
+  | Term ',' ListTerm { (:) $1 $3 }
+
+
+ListExp :: { [Exp] }
+ListExp : {- empty -} { [] } 
+  | ListExp Exp { flip (:) $1 $2 }
+
+
+ListString :: { [String] }
+ListString : {- empty -} { [] } 
+  | ListString String { flip (:) $1 $2 }
+
+
+ListVariant :: { [Variant] }
+ListVariant : {- empty -} { [] } 
+  | Variant { (:[]) $1 }
+  | Variant ',' ListVariant { (:) $1 $3 }
+
+
+
+{
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+  Bad $ "syntax error at " ++ tokenPos ts ++ 
+  case ts of
+    [] -> []
+    [Err _] -> " due to lexer error"
+    _ -> " before " ++ unwords (map prToken (take 4 ts))
+
+myLexer = tokens
+trA_ a_ = Tr a_ []
+}
+

src/tools/c/GFCC/Print.hs

@@ -0,0 +1,148 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module GFCC.Print where
+
+-- pretty-printer generated by the BNF converter
+
+import GFCC.Abs
+import Data.Char
+import Data.List (intersperse)
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "["      :ts -> showChar '[' . rend i ts
+    "("      :ts -> showChar '(' . rend i ts
+    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+    "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
+    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+    ";"      :ts -> showChar ';' . new i . rend i ts
+    t  : "," :ts -> showString t . space "," . rend i ts
+    t  : ")" :ts -> showString t . showChar ')' . rend i ts
+    t  : "]" :ts -> showString t . showChar ']' . rend i ts
+    t        :ts -> space t . rend i ts
+    _            -> id
+  new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+  space t = showString t . (\s -> if null s then "" else (' ':s))
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+unwordsD :: [Doc] -> Doc
+unwordsD = concatD . intersperse (doc (showChar ' '))
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+
+instance Print String where
+  prt _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+  prt _ x = doc (shows x)
+
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
+instance Print (Tree c) where
+  prt _i e = case e of
+    Grm header abstract concretes -> prPrec _i 0 (concatD [prt 0 header , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
+    Hdr cid cids -> prPrec _i 0 (concatD [doc (showString "grammar") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")")])
+    Abs absdefs -> prPrec _i 0 (concatD [doc (showString "abstract") , doc (showString "{") , prt 0 absdefs , doc (showString "}")])
+    Cnc cid cncdefs -> prPrec _i 0 (concatD [doc (showString "concrete") , prt 0 cid , doc (showString "{") , prt 0 cncdefs , doc (showString "}")])
+    Fun cid type' exp -> prPrec _i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
+    Lin cid term -> prPrec _i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
+    Typ cids cid -> prPrec _i 0 (concatD [prt 0 cids , doc (showString "->") , prt 0 cid])
+    Tr atom exps -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 atom , prt 0 exps , doc (showString ")")])
+    AC cid -> prPrec _i 0 (concatD [prt 0 cid])
+    AS str -> prPrec _i 0 (concatD [prt 0 str])
+    AI n -> prPrec _i 0 (concatD [prt 0 n])
+    AF d -> prPrec _i 0 (concatD [prt 0 d])
+    AM  -> prPrec _i 0 (concatD [doc (showString "?")])
+    R terms -> prPrec _i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
+    P term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term1 , doc (showString ")")])
+    S terms -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
+    K tokn -> prPrec _i 0 (concatD [prt 0 tokn])
+    V n -> prPrec _i 0 (concatD [doc (showString "$") , prt 0 n])
+    C n -> prPrec _i 0 (concatD [prt 0 n])
+    F cid -> prPrec _i 0 (concatD [prt 0 cid])
+    FV terms -> prPrec _i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
+    W str term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
+    RP term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term1 , doc (showString ")")])
+    TM  -> prPrec _i 0 (concatD [doc (showString "?")])
+    L cid term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 cid , doc (showString "->") , prt 0 term , doc (showString ")")])
+    BV cid -> prPrec _i 0 (concatD [doc (showString "#") , prt 0 cid])
+    KS str -> prPrec _i 0 (concatD [prt 0 str])
+    KP strs variants -> prPrec _i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
+    Var strs0 strs1 -> prPrec _i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs1])
+    CId str -> prPrec _i 0 (doc (showString str))
+
+instance Print [Concrete] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+instance Print [AbsDef] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+instance Print [CncDef] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+instance Print [CId] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+instance Print [Term] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+instance Print [Exp] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+instance Print [String] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+instance Print [Variant] where
+  prt _ es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])

src/tools/c/GFCC/Test.hs

@@ -0,0 +1,58 @@
+-- automatically generated by BNF Converter
+module Main where
+
+
+import IO ( stdin, hGetContents )
+import System ( getArgs, getProgName )
+
+import GFCC.Lex
+import GFCC.Par
+import GFCC.Skel
+import GFCC.Print
+import GFCC.Abs
+
+
+
+
+import GFCC.ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+type Verbosity = Int
+
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+           Bad s    -> do putStrLn "\nParse              Failed...\n"
+                          putStrV v "Tokens:"
+                          putStrV v $ show ts
+                          putStrLn s
+           Ok  tree -> do putStrLn "\nParse Successful!"
+                          showTree v tree
+
+
+
+showTree :: (Show a, Print a) => Int -> a -> IO ()
+showTree v tree
+ = do
+      putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
+      putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+            [] -> hGetContents stdin >>= run 2 pGrammar
+            "-s":fs -> mapM_ (runFile 0 pGrammar) fs
+            fs -> mapM_ (runFile 2 pGrammar) fs
+
+
+
+
+

src/tools/c/Makefile

@@ -0,0 +1,25 @@
+GHC = ghc
+GHCFLAGS =
+
+.PHONY: all gfcc2c clean 
+
+all: gfcc2c
+
+gfcc2c: 
+	$(GHC) $(GHCFLAGS) --make -o $@ gfcc2c.hs
+
+bnfc:
+	bnfc -gadt -d ../../GF/Canon/GFCC/GFCC.cf
+	-rm -f GFCC/Doc.tex GFCC/Skel.hs
+	happy -gca GFCC/Par.y
+	alex -g GFCC/Lex.x
+
+clean:
+	-rm -f gfcc2c
+	-rm -f *.o *.hi
+	-rm -f GFCC/*.hi GFCC/*.o
+
+bnfcclean: clean
+	-rm -f GFCC/*.bak
+	-rm -f GFCC/Lex.* GFCC/Par.* GFCC/Layout.* GFCC/Skel.* GFCC/Print.* GFCC/Test.* GFCC/Abs.* GFCC/ComposOp.* GFCC/Test GFCC/ErrM.* GFCC/SharedString.*
+	-rmdir -p GFCC/

src/tools/c/examples/bronzeage/Makefile

@@ -0,0 +1,47 @@
+
+GFDIR=../../../../../
+
+LIBGFCC_INCLUDES = $(GFDIR)/lib/c
+LIBGFCC_LIBDIR = $(GFDIR)/lib/c
+
+GFCC2C = $(GFDIR)/bin/gfcc2c
+
+TEST_PROG = bronzeage-test
+
+GRAMMAR_DIR = $(GFDIR)/examples/bronzeage
+
+GRAMMAR_MODULES = Bronzeage BronzeageEng BronzeageSwe
+
+GRAMMAR_H_FILES = $(addsuffix .h, $(GRAMMAR_MODULES))
+GRAMMAR_C_FILES = $(addsuffix .c, $(GRAMMAR_MODULES))
+GRAMMAR_O_FILES = $(addsuffix .o, $(GRAMMAR_MODULES))
+
+CFLAGS += -O2
+CPPFLAGS += -I$(LIBGFCC_INCLUDES)
+
+.PHONY: clean
+
+all: bronzeage.gfcc $(TEST_PROG)
+
+$(TEST_PROG): $(GRAMMAR_O_FILES) $(TEST_PROG).o $(LIBGFCC_LIBDIR)/libgfcc.a	
+
+$(TEST_PROG).o: $(GRAMMAR_H_FILES) $(GRAMMAR_O_FILES) $(TEST_PROG).c
+
+$(GRAMMAR_H_FILES) $(GRAMMAR_C_FILES): $(GFCC2C) bronzeage.gfcc
+	$(GFCC2C) bronzeage.gfcc
+
+bronzeage.gfcc:
+	echo "i -optimize=all $(GRAMMAR_DIR)/BronzeageEng.gf" > mkBronzeage.gfs
+	echo "i -optimize=all $(GRAMMAR_DIR)/BronzeageSwe.gf" >> mkBronzeage.gfs
+	echo "s" >> mkBronzeage.gfs
+	echo "pm -printer=gfcc | wf bronzeage.gfcc" >> mkBronzeage.gfs
+	cat mkBronzeage.gfs | gf
+	rm -f mkBronzeage.gfs
+
+clean:
+	-rm -f $(TEST_PROG) *.o
+
+
+distclean: clean
+	-rm -f $(GRAMMAR_H_FILES) $(GRAMMAR_C_FILES)
+	-rm -f bronzeage.gfcc

src/tools/c/examples/bronzeage/bronzeage-test.c

@@ -0,0 +1,31 @@
+#include "Bronzeage.h"
+
+#include "BronzeageEng.h"
+
+#include <unistd.h>
+
+int main() {
+  Tree *tree = 
+	  mk_PhrPos(
+	    mk_SentV(
+	      mk_lie_V(),
+	      mk_NumCN(
+	        mk_two_Num(),
+	        mk_UseN(mk_wife_N())
+	      )
+            )
+	  );
+
+  int i;
+
+  for (i = 0; i < 1000; i++) {
+	  Term *term;
+	  term = BronzeageEng_lin(tree);
+	  term_print(stdout, term);
+	  fputs("\n", stdout);
+  }
+
+  tree_free(tree);
+
+  return 0;
+}

src/tools/c/gfcc2c.hs

@@ -0,0 +1,223 @@
+import GFCC.Abs
+import GFCC.ErrM
+import GFCC.Lex
+import GFCC.Par
+
+import Control.Monad
+import Data.Char
+import Data.List
+import Numeric
+import System.Environment
+import System.Exit
+import System.IO
+
+constrType :: Grammar -> String
+constrType g = unlines $ 
+    ["typedef enum { "]
+ ++ map (\x -> "  " ++ x ++ "," ) ds
+ ++ ["} Fun;"]
+  where fs = [id2c n | (n,_) <- constructors g ]
+        ds = case fs of
+                     [] -> []
+                     (x:xs) -> (x ++ " = ATOM_FIRST_FUN"):xs
+
+mkFunSigs :: Grammar -> String
+mkFunSigs g = unlines [mkFunSig n ats | (n,(ats,_)) <- constructors g]
+
+mkFunSig :: CId -> [CId] -> String
+mkFunSig n ats = 
+    "extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ");"
+  where 
+  adecls = map ("Tree *" ++) args
+  args = [ "x" ++ show x | x <- [0..c-1] ]
+  c = length ats
+
+mkFuns :: Grammar -> String
+mkFuns g = unlines [mkFun n ats | (n,(ats,_)) <- constructors g]
+
+mkFun :: CId -> [CId] -> String
+mkFun n ats = unlines $
+    ["extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ") {",
+     "  Tree *t = tree_fun(" ++ id2c n ++ "," ++ show c ++ ");"]
+ ++ ["  tree_set_child(" ++ commaSep ["t",show i, args!!i] ++ ");" | i <- [0..c-1]]
+ ++ ["  return t;",
+     "}"]
+  where 
+  adecls = map ("Tree *" ++) args
+  args = [ "x" ++ show x | x <- [0..c-1] ]
+  c = length ats
+
+doDie :: String -> [String] -> [String]
+doDie s args = ["fprintf(" ++ commaSep ("stderr":show s':args) ++ ");",
+                "exit(1);"]
+  where s' = "Error: " ++ s ++ "\n"
+
+mkLin :: Grammar -> CId -> String
+mkLin g l = unlines $
+    ["extern Term *" ++ langLinName_ l ++ "(Tree *t) {",
+     "  Term **cs = NULL;",
+     "  int n = arity(t);",
+     "  if (n > 0) {",
+     "    int i;",
+     "    cs = (Term**)term_alloc(n * sizeof(Term *));", -- FIXME: handle failure
+     "    for (i = 0; i < n; i++) {",
+     "      cs[i] = " ++ langLinName_ l ++ "(tree_get_child(t,i));",
+     "    }",
+     "  }",
+     "",
+     "  switch (t->type) {",
+     "  case ATOM_STRING:  return term_str(t->value.string_value);",
+--     "  case ATOM_INTEGER: return NULL;", -- FIXME!
+--     "  case ATOM_DOUBLE:  return NULL;", -- FIXME!
+     "  case ATOM_META:    return term_meta();"]
+ ++ ["  case " ++ id2c n ++ ": return " ++ linFunName n ++ "(cs);"  
+           | (n,_) <- constructors g]
+ ++ ["  default: "]
+ ++ map ("    " ++) (doDie (langLinName_ l ++ " %d") ["t->type"])
+ ++ ["    return NULL;",
+     "  }",
+     "}",
+     "",
+     "extern Term *" ++ langLinName l ++ "(Tree *t) {",
+     "  Term *r;",
+     "  term_alloc_pool(1000000);", -- FIXME: size?
+     "  r = " ++ langLinName_ l ++ "(t);",
+     "  /* term_free_pool(); */", -- FIXME: copy term?
+     "  return r;",
+     "}"]
+
+langLinName :: CId -> String
+langLinName n = id2c n ++ "_lin"
+
+langLinName_ :: CId -> String
+langLinName_ n = id2c n ++ "_lin_"
+
+linFunName :: CId -> String
+linFunName n = "lin_" ++ id2c n
+
+
+mkLinFuns :: [CncDef] -> String
+mkLinFuns cs = unlines $ map mkLinFunSig cs ++ [""] ++ map mkLinFun cs
+
+mkLinFunSig :: CncDef -> String
+mkLinFunSig (Lin n t) =
+  "static Term *" ++ linFunName n ++ "(Term **cs);"
+
+mkLinFun :: CncDef -> String
+mkLinFun (Lin (CId n) t) | "__" `isPrefixOf` n = ""
+mkLinFun (Lin n t) = unlines [
+  "static Term *" ++ linFunName n ++ "(Term **cs) {",
+  "  return " ++ term2c t ++ ";",
+  "}"
+                             ]
+
+term2c :: Tree a -> String
+term2c t = case t of
+  -- terms
+  R terms        -> fun "term_array" terms
+    -- an optimization of t!n where n is a constant int
+  P term0 (C n)  -> "term_sel_int("++ term2c term0 ++ "," ++ show n ++ ")"
+  P term0 term1  -> "term_sel(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
+  S terms        -> fun "term_seq" terms
+  K tokn         -> term2c tokn
+  V n            -> "cs[" ++ show n ++ "]"
+  C n            -> "term_int(" ++ show n ++ ")"
+  F cid          -> linFunName cid ++ "(cs)"
+  FV terms       -> fun "term_variants" terms
+  W str term     -> "term_suffix(" ++ string2c str ++ "," ++ term2c term ++ ")"
+  RP term0 term1 -> "term_rp(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
+  TM             -> "term_meta()"
+  -- tokens
+  KS s           -> "term_str(" ++ string2c s ++ ")"
+  KP strs vars   -> error $ show t -- FIXME: pre token
+  _              -> error $ show t 
+ where fun f ts = f ++ "(" ++ commaSep (show (length ts):map term2c ts) ++ ")"
+
+commaSep = concat . intersperse ","
+
+
+id2c :: CId -> String
+id2c (CId s) = s -- FIXME: convert ticks
+
+string2c :: String -> String
+string2c s = "\"" ++ concatEsc (map esc s) ++ "\""
+  where 
+    esc c | isAscii c && isPrint c = [c]
+    esc '\n' = "\\n"
+    esc c = "\\x" ++ map toUpper (showHex (ord c) "")
+    concatEsc [] = ""
+    concatEsc (x:xs) | length x <= 2 = x ++ concatEsc xs
+                     | otherwise = x ++ "\" \"" ++ concatEsc xs
+
+lang2file :: CId -> String -> String
+lang2file n ext = id2c n ++ "." ++ ext
+
+constructors :: Grammar -> [(CId, ([CId],CId))]
+constructors (Grm _ (Abs ads) _) = [(n,(ats,rt)) | Fun n (Typ ats rt) _ <- ads]
+
+absHFile :: Grammar -> FilePath
+absHFile (Grm (Hdr a _) _ _) = lang2file a "h"
+
+cncHFile :: Concrete -> FilePath
+cncHFile (Cnc l _) = lang2file l "h"
+
+mkAbsH :: Grammar -> String
+mkAbsH g = unlines ["#include \"gfcc-tree.h\"",
+                    "#include \"gfcc-term.h\"",
+                    constrType g,
+                    "",
+                    mkFunSigs g]
+
+mkAbsC :: Grammar -> String
+mkAbsC g = unlines [include (absHFile g),
+                    "",
+                    mkFuns g]
+
+mkCncH :: Grammar -> Concrete -> String
+mkCncH g (Cnc l _) = unlines
+    [include (absHFile g),
+     "",
+     "extern Term *" ++ langLinName l ++ "(Tree *);"]
+
+mkCncC :: Grammar -> Concrete -> String
+mkCncC g c@(Cnc l cds) = unlines $ 
+     ["#include <stdio.h>",
+      "#include <stdlib.h>",
+      include (cncHFile c),
+      ""]
+  ++ [mkLinFuns cds, mkLin g l]
+
+mkH :: FilePath -> String -> (FilePath, String)
+mkH f c = (f, c')
+  where c' = unlines ["#ifndef " ++ s, "#define " ++ s, "", c, "#endif"]
+        s = [if x=='.' then '_' else toUpper x | x <- f]
+
+include :: FilePath -> String
+include f = "#include " ++ show f
+
+-- returns list of file name, file contents
+gfcc2c :: Grammar -> [(FilePath, String)]
+gfcc2c g@(Grm (Hdr a _) _ cs) = 
+  [mkH (absHFile g) (mkAbsH g), (lang2file a "c", mkAbsC g)]
+  ++ concat [[mkH (cncHFile cnc) (mkCncH g cnc),(lang2file c "c", mkCncC g cnc)] | cnc@(Cnc c _) <- cs]
+
+parse :: String -> Err Grammar
+parse = pGrammar . myLexer
+
+die :: String -> IO ()
+die s = do hPutStrLn stderr "Usage: gfcc2c <gfcc file>"
+           exitFailure
+
+createFile :: FilePath -> String -> IO ()
+createFile f c = do hPutStrLn stderr $ "Writing " ++ f ++ "..."
+                    writeFile f c
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+            [file] -> do c <- readFile file 
+                         case parse c of
+                           Bad err -> die err
+                           Ok g    -> do let fs = gfcc2c g
+                                         mapM_ (uncurry createFile) fs
+            _      -> die "Usage: gfcc2c <gfcc file>"