GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

Added gfcc2c to GF repo.

Browse Source
This commit is contained in:
bringert
2006-12-22 13:43:32 +00:00
parent 95d4af1f2d
commit da339b2686
20 changed files with 3000 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
doc/gf-history.html
View File

@@ -49,6 +49,20 @@ Use <tt>pg -printer=vxml</tt>.
generated from a multilingual GF grammar. Use <tt>pm -printer=js</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> <p>
20/11 (AR) Type error messages in concrete syntax are printed with a 20/11 (AR) Type error messages in concrete syntax are printed with a

19
lib/c/Makefile Normal file
View File

@@ -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

203
lib/c/gfcc-term.c Normal file
View File

@@ -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);
}
}

65
lib/c/gfcc-term.h Normal file
View File

@@ -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

61
lib/c/gfcc-tree.c Normal file
View File

@@ -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);
}

49
lib/c/gfcc-tree.h Normal file
View File

@@ -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

9
src/Makefile
View File

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

227
src/tools/c/GFCC/Abs.hs Normal file
View File

@@ -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

30
src/tools/c/GFCC/ComposOp.hs Normal file
View File

@@ -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 }

16
src/tools/c/GFCC/ErrM.hs Normal file
View File

@@ -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

340
src/tools/c/GFCC/Lex.hs Normal file
View File

File diff suppressed because one or more lines are too long

135
src/tools/c/GFCC/Lex.x Normal file
View File

@@ -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
}

1096
src/tools/c/GFCC/Par.hs Normal file
View File

File diff suppressed because it is too large Load Diff

204
src/tools/c/GFCC/Par.y Normal file
View File

@@ -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_ []
}

148
src/tools/c/GFCC/Print.hs Normal file
View File

@@ -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])

58
src/tools/c/GFCC/Test.hs Normal file
View File

@@ -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

25
src/tools/c/Makefile Normal file
View File

@@ -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/

47
src/tools/c/examples/bronzeage/Makefile Normal file
View File

@@ -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

31
src/tools/c/examples/bronzeage/bronzeage-test.c Normal file
View File

@@ -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;
}

223
src/tools/c/gfcc2c.hs Normal file
View File

@@ -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>"