gtest.flx

// GRAMMAR TREE SYNTAX using polymorphic variants
SCHEME """(define  (mklist es)`(ast_apply ,_sr (,(nos "list") (ast_tuple ,_sr ,es))))""";

syntax grammar {
x[let_pri]:= "grammar" xproduction* "endgrammar" =># 
  """`(ast_variant ("grammar" ,(mklist _2)))"""
;

xproduction := sname ":=" (xnonterminal | xterminal)* "=>#" sstring ";" =># 
  """
    (let*
      (
        (cast (lambda (sym)`(ast_coercion ,_sr (,sym ,(nos "sym_t")))))
        (mapcast (map cast _3))
      )
       `(ast_variant ("production" (ast_tuple ,_sr (,(stringof _1) ,(mklist  mapcast) ,(stringof _5)))))
    )
  """
;

xnonterminal := sname =>#
  """`(ast_variant ("nonterminal" ,(stringof _1)))"""
;

xterminal := sstring =># // a string, to be interpreted as a regexp
  """`(ast_variant ("terminal" ,(stringof _1))))""";
}
//----------------------------------------------------------
// TREE TYPES
typedef gram_t = (
  | `grammar of list[prod_t]
);
typedef prod_t = ( 
  | `production of string * list[sym_t] * string
);
typedef sym_t = (
  | `terminal of string 
  | `nonterminal of string 
);

//----------------------------------------------------------
// TREE PRETTY PRINTS
instance Str[sym_t] {
  fun str(x:sym_t):string => 
    match x with
    | `terminal s => s.repr
    | `nonterminal s => s
    endmatch
  ;
}
instance Str[prod_t] {
  fun str(x:prod_t):string => 
    match x with
    | `production (name, symbols, action) => 
      "  " + name + " := " + List::cat "," (List::map (str of sym_t) symbols) +" =># " +  action.repr + ";"
    endmatch
  ;
}
instance Str[gram_t] {
  fun str(x:gram_t):string => 
    match x with
    | `grammar ls => "grammar\n" + List::cat "\n" (List::map (str of prod_t) ls) +"\nendgrammar\n"
    endmatch
  ;
}


//----------------------------------------------------------
// ARRAY FORMAT
typedef aprod_t = (
  | `aproduction of string * varray[sym_t] * string
);
typedef agram_t = (
  | `agrammar of varray[aprod_t]
);

fun make_aprod: prod_t -> aprod_t =
  | `production (name,symbols,action) => 
    let new_symbols = varray symbols in 
    `aproduction(name,new_symbols,action) 
;

fun make_agram: gram_t -> agram_t =
  | `grammar productions  => 
    let new_productions = varray(List::map make_aprod productions) in 
    `agrammar new_productions
;

instance Str[aprod_t] {
  fun str(p:aprod_t) =>
    match p with
    | `aproduction (name, symbols, action) => 
      "  " + name + " := " + List::cat "," (List::map (str of sym_t) symbols.as_list) +" =># " +  action.repr + ";"
    endmatch
  ;  
}
instance Str[agram_t] {
  fun str(x:agram_t):string => 
    match x with
    | `agrammar productions => "grammar\n" + List::cat "\n" (List::map (str of aprod_t) productions.as_list) +"\nendgrammar\n"
    endmatch
  ;
}

//----------------------------------------------------------
// MAP SYMBOLS
//
// Map the string name of a non-terminal to a list of productions for that symbol
typedef ntdefs_t = strdict[list[size]];
fun ntmap (g:agram_t) : ntdefs_t {
  var ntdefs = strdict[list[size]]();
  match g with
  | `agrammar productions =>
    for index in 0uz ..< productions.len do
      var key = match (get(productions,index)) with | `aproduction (name,_,_) => name endmatch;
      var dflt = Empty[size];
      var data = ntdefs.get_dflt (key, dflt);
      var new_data = Snoc (data, index); 
      ntdefs.add key new_data;
    done
  endmatch;
  return ntdefs; 
}

//----------------------------------------------------------
// Produce an array of non-terminal string names
// and a reverse map from string names to the assigned indices

typedef ntindices_t = varray[string] * strdict[size];
fun get_ntindices  (ntmap : ntdefs_t) : ntindices_t {
  var nnts = 0uz;
  for data in ntmap perform ++nnts; // hacky!
  var ntnames = varray[string] nnts;
  var ntindices = strdict[size]();
  for data in ntmap do
    var name = data.0;
    ntindices.add name ntnames.len;
    push_back (ntnames, data.0);
  done
  return ntnames, ntindices;
}

// Map the string name of a terminal to a list of locations for that symbol
// A location is a pair, the production index and the location in the production.
 
typedef tdefs_t = strdict[list[size * size]];
fun tmap (g:agram_t) : tdefs_t {
  var tdefs = strdict[list[size * size]]();
  match g with
  | `agrammar productions =>
    for pindex in 0uz ..< productions.len do
      var symbols = match (get(productions,pindex)) with | `aproduction (_,symbols,_) => symbols endmatch;
      for sindex in 0uz ..< symbols.len do
        match symbols.sindex with
        | `terminal name => 
          var dflt = Empty[size * size];
          var data = tdefs.get_dflt (name, dflt);
          var new_data = Snoc (data, (pindex,sindex)); 
          tdefs.add name new_data;
       | _ => ;
       endmatch;
     done
    done
  endmatch;
  return tdefs; 
}

//----------------------------------------------------------
// Produce an array of terminal string names
// and a reverse map from string names to the assigned indices

typedef tindices_t = varray[string] * strdict[size];
fun get_tindices  (tmap : tdefs_t) : tindices_t {
  var nts = 0uz;
  for data in tmap perform ++nts; // hacky!
  var tnames = varray[string] nts;
  var tindices = strdict[size]();
  for data in tmap do
    var name = data.0;
    tindices.add name tnames.len;
    push_back (tnames, data.0);
  done
  return tnames, tindices;
}

//----------------------------------------------------------
// Rebuild the grammar using indices for the symbols
// Terminals indices are negated instead of using a constructor,
//   so as to make the representation compact
typedef bsym_t = int;
struct bprod_t { nt: int; syms: varray[bsym_t]; act: string; }
typedef bgram_t = varray[bprod_t];
instance Str[bprod_t] { fun str (x:bprod_t) => "\n  " + x.nt.str + " := " + x.syms.str + " =># " + x.act.repr + ";"; }

fun make_bgram (a: agram_t, nts: strdict[size], ts: strdict[size]) : bgram_t {
  match a with 
  | `agrammar ps =>
    var g = varray[bprod_t] ps.len;
    for p in ps do
      match p with
      | `aproduction (name, syms, act) =>
        var s = varray[bsym_t] syms.len;
        var ntindex = match nts.get name with | Some x=> x.int | None => 0 endmatch;
        for sym in syms do
          var six = 
            match sym with
            | `terminal x => -1-match (ts.get x) with | Some x=> x.int | None => 0 endmatch
            | `nonterminal x => match (nts.get x) with | Some x => x.int | None => 0 endmatch
            endmatch
          ;
          push_back (s, six); 
        done
        var new_prod = bprod_t(ntindex,s,act); 
        push_back(g,new_prod);
      endmatch;
    done
    return g;
  endmatch;
}

//----------------------------------------------------------
// TEST CASE
 
open syntax grammar;
println$ "Grammar test";
var s = grammar
  start := x y =># "act1";
  x := "Jello" =># "act2";
  x := "Jello2" =># "act2a";
  y := "world" =># "act3";
  z := "Jello" "world" =># "act4"; 
endgrammar;
println$ "Grammar spec parsed";

var a = make_agram s;

println$ "tree format\n" + s.str;
println$ "array format\n" + a.str;

var nts = ntmap a;
println$ "ntdefs\n" + nts.str;

var ts = tmap a;
instance Repr[size * size] { fun repr(x:size,y:size) => "(" + x.str + ", " + y.str + ")"; }
println$ "tdefs\n" + ts.str;


var ntnames, ntindices = get_ntindices nts;
println$ "ntnames\n" + ntnames.str;
println$ "ntindices\n" + ntindices.str;
var tnames, tindices = get_tindices ts;
println$ "tnames\n" + tnames.str;
println$ "tindices\n" + tindices.str;

var bgram = make_bgram (a, ntindices, tindices);
println$ bgram.str;