## ml-grinder.pkg
#
# The core of the ML-Grinder library
### Never tell the truth to people who are not worthy of it.
###
### -- Mark Twain,
### Notebook, 1902
local
Author = "Allen Leung"
Email = "leunga@cs.nyu.edu, leunga@dorsai.org"
Version = "1.2.4"
basisForTheMatchCompiler =
string::cat
[ "enum List X = NIL | . of X * List(X)\n",
"enum Null_Or X = NULL | THE of X\n",
"enum order = LESS | EQUAL | GREATER\n"
]
in
package ml_grinder :> Ml_Grinder {
package pp = pp
package re = reg_exp_lib
package err = adl_error
package raw = adl_raw_syntax
package raw_util = adl_raw_syntax_junk
package raw_pp = adl_raw_syntax_unparser
package map_raw_syntax = adl_rewrite_raw_syntax_parsetree
package raw_trans = adl_raw_syntax_translation
package raw_consts = adl_raw_syntax_constants
package parser
=
architecture_description_language_parser_g (
#
package rsu = raw_pp # "rsu" == "raw_syntax_unparser"
adl_mode = FALSE extra_cells = []
)
package match_generic
=
match_gen_g ( # See src/lib/compiler/back/low/tools/match-compiler/match-gen-g.pkg package rsu = raw_pp # "rsu" == "raw_syntax_unparser"
package rsj = raw_util # "rsj" == "raw_syntax_junk"
package map_raw_syntax = map_raw_syntax
)
# package html_g = html_g
package r = map_raw_syntax
package u = raw_util
package m = match_generic
package p = parser
package tr = raw_trans
i2s = int::to_string
my ++ = pp.++
infix ++
type labeled X = raw::id * X
line_width = REF 160
nolocations = raw_trans::stripMarks
fakeId = "__fake_id__"
# Pretty print as code
fun asML prog
=
pp::lit (pp::setmode "code" ++ pp::text_width *line_width ++ prog)
# Error handling stuff
exception MLGrinderErrorMsg of String
error = err::error
warning = err::warning
fun bug (fn, msg)
=
{ msg = "ml_grinder error: " + fn + ": " + msg;
error msg;
raise exception MLGrinderErrorMsg msg;
}
fun fail msg
=
{ error msg;
raise exception MLGrinderErrorMsg msg;
}
silent = REF FALSE
fun comment text
=
A.@@@("" . "/* " . map (\\ c => " * " + c) text @ [" */", ""])
package map {
enum rule = E of raw::exp -> raw::exp
| SE of raw::structexp -> raw::structexp
| D of raw::decl -> raw::decl
| T of raw::ty -> raw::ty
| P of raw::pat -> raw::pat
};
package rewrite {
enum rule = E of (raw::exp -> raw::exp) -> raw::exp -> raw::exp
| SE of (raw::structexp -> raw::structexp) ->
raw::structexp -> raw::structexp
| D of (raw::decl -> raw::decl) -> raw::decl -> raw::decl
| T of (raw::ty -> raw::ty) -> raw::ty -> raw::ty
| P of (raw::pat -> raw::pat) -> raw::pat -> raw::pat
};
package fold {
enum rule X = E of raw::exp * X -> X
| SE of raw::structexp * X -> X
| D of raw::decl * X -> X
| T of raw::ty * X -> X
| P of raw::pat * X -> X
};
package app {
enum rule = E of raw::exp -> Void
| SE of raw::structexp -> Void
| D of raw::decl -> Void
| T of raw::ty -> Void
| P of raw::pat -> Void
};
package subst {
enum rule = E of String -> Null_Or( raw::exp )
| SE of String -> Null_Or( raw::structexp )
| D of String -> Null_Or( raw::decl )
| T of String -> Null_Or( raw::ty )
| P of String -> Null_Or( raw::pat )
};
nothing = r::noRewrite
# Trace the current line
fun markLines { exp, decl, ty, pat, sexp }
=
{ fun exp' f (e as raw::MARKexp (l, _)) = { err::setLoc l; exp f e; }
| exp' f e = exp f e;
fun decl' f (d as raw::MARKDECL (l, _)) = { err::setLoc l; decl f d; }
| decl' f d = decl f d;
{ exp=exp', decl=decl', ty, pat, sexp };
}
fun mapper rules
=
{ use Map;
fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
| f (E exp . rules, _, d, t, p, se) = f (rules, \\ _ => exp, d, t, p, se)
| f (D decl . rules, e, _, t, p, se) = f (rules, e, \\ _ => decl, t, p, se)
| f (T ty . rules, e, d, _, p, se) = f (rules, e, d, \\ _ => ty, p, se)
| f (P pat . rules, e, d, t, _, se) = f (rules, e, d, t, \\ _ => pat, se)
| f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, \\ _ => sexp);
rules = f (rules, nothing, nothing, nothing, nothing, nothing);
r::rewrite rules;
}
fun rewriter rules
=
{ use Rewrite;
fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
| f (E exp . rules, _, d, t, p, se) = f (rules, exp, d, t, p, se)
| f (D decl . rules, e, _, t, p, se) = f (rules, e, decl, t, p, se)
| f (T ty . rules, e, d, _, p, se) = f (rules, e, d, ty, p, se)
| f (P pat . rules, e, d, t, _, se) = f (rules, e, d, t, pat, se)
| f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, sexp);
rules = f (rules, nothing, nothing, nothing, nothing, nothing);
r::rewrite rules;
}
fun subster rules
=
{ use Subst;
fun g1 f _ (e as raw::ID_IN_EXPRESSION (raw::IDENT([], x))) =
(case f x of THE e => e | NULL => e)
| g1 f _ e = e;
fun g2 f _ (e as raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, raw::LITERAL_IN_EXPRESSION (raw::STRING_LIT x))]) =
(case f x of THE e => e | NULL => e)
| g2 f _ e = e;
fun g3 f _ (e as raw::IDTY (raw::IDENT([], x))) =
(case f x of THE e => e | NULL => e)
| g3 f _ e = e;
fun g4 f _ (e as raw::IDPAT x) =
(case f x of THE e => e | NULL => e)
| g4 f _ e = e;
fun g5 f _ (e as raw::IDSEXP (raw::IDENT([], x))) =
(case f x of THE e => e | NULL => e)
| g5 f _ e = e;
fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
| f (E exp . rules, _, d, t, p, se) = f (rules, g1 exp, d, t, p, se)
| f (D decl . rules, e, _, t, p, se) = f (rules, e, g2 decl, t, p, se)
| f (T ty . rules, e, d, _, p, se) = f (rules, e, d, g3 ty, p, se)
| f (P pat . rules, e, d, t, _, se) = f (rules, e, d, t, g4 pat, se)
| f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, g5 sexp);
rules = f (rules, nothing, nothing, nothing, nothing, nothing);
r::rewrite rules;
}
fun folder rules x
=
{ use Fold;
x = REF x;
fun g f _ y
=
{ x := f (y,*x);
y;
};
fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
| f (E exp . rules, _, d, t, p, se) = f (rules, g exp, d, t, p, se)
| f (D decl . rules, e, _, t, p, se) = f (rules, e, g decl, t, p, se)
| f (T ty . rules, e, d, _, p, se) = f (rules, e, d, g ty, p, se)
| f (P pat . rules, e, d, t, _, se) = f (rules, e, d, t, g pat, se)
| f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, g sexp);
rules = f (rules, nothing, nothing, nothing, nothing, nothing);
my { exp, decl, ty, pat, sexp }
=
r::rewrite rules;
fun h f y
=
{ f y;
*x;
};
{ exp = h exp, decl= h decl, ty=h ty, pat=h pat, sexp=h sexp };
}
fun apper rules
=
{ use App;
fun g f _ x
=
{ f x;
x;
};
fun f ([], e, d, t, p, se) = markLines { exp=e, decl=d, ty=t, pat=p, sexp=se }
| f (E exp . rules, _, d, t, p, se) = f (rules, g exp, d, t, p, se)
| f (D decl . rules, e, _, t, p, se) = f (rules, e, g decl, t, p, se)
| f (T ty . rules, e, d, _, p, se) = f (rules, e, d, g ty, p, se)
| f (P pat . rules, e, d, t, _, se) = f (rules, e, d, t, g pat, se)
| f (SE sexp . rules, e, d, t, p, _) = f (rules, e, d, t, p, g sexp);
rules = f (rules, nothing, nothing, nothing, nothing, nothing);
my { exp, decl, ty, pat, sexp }
=
r::rewrite rules;
fun h f x
=
{ f x;
();
};
{ exp = h exp, decl= h decl, ty=h ty, pat=h pat, sexp=h sexp };
}
fun noSimplify x
=
x
# Make a new type
generic package Type (type t) {
type t = t
type pp = pp::pp
type ar = App::rule
type fr X = Fold::rule X
type mr = Map::rule
type rr = Rewrite::rule
type sr = Subst::rule
};
# Map a list out of it
generic package List (type t
my pp: t -> pp::pp
my apply: List( App::rule ) -> t -> Void
my fold: List( Fold::rule(X) ) -> X -> t -> X
my map: List( Map::rule ) -> t -> t
my rewrite: List( Rewrite::rule ) -> t -> t
my subst: List( Subst::rule ) -> t -> t
my simplify: t -> t
my nolocations: t -> t
)
{
package t = Type (type t = List (t) ) use t
list = pp::seq (pp::nop, pp.!! ", ", pp::nop)
pp = \\ x => list (list::map pp x)
show = asML o pp
apply = \\ r => list::apply (apply r)
fold = \\ r => { f = fold r; fold_forward (\\ (e, x) => f x e); }
map = \\ r => list::map (map r)
subst = \\ r => list::map (subst r)
rewrite = \\ r => list::map (rewrite r)
simplify = list::map simplify
nolocations = list::map nolocations
};
# Make a labeled something out of it
generic package Labeled (type t
my pp: labeled( t ) -> pp::pp
my apply: List( App::rule ) -> t -> Void
my fold: List( Fold::rule(X) ) -> X -> t -> X
my map: List( Map::rule ) -> t -> t
my rewrite: List( Rewrite::rule ) -> t -> t
my subst: List( Subst::rule ) -> t -> t
my simplify: t -> t
my nolocations: t -> t
)
{
package t = Type (type t = labeled (t) ) use t
pp = pp
show = asML o pp
apply = \\ r => \\ (l, x) => apply r x
fold = \\ r => \\ u => \\ (l, x) => fold r u x
map = \\ r => \\ (l, x) => (l, map r x)
rewrite = \\ r => \\ (l, x) => (l, rewrite r x)
subst = \\ r => \\ (l, x) => (l, subst r x)
simplify = \\ (l, x) => (l, simplify x)
nolocations = \\ (l, x) => (l, nolocations x)
};
# Declaration
package decl {
package t = Type (type t = raw::decl) use t
fun parse s
=
case p::parseString' *silent s of
[raw::MARKDECL(_, d)] => d | ds => raw::SEQ_DECL ds
pp = raw_pp::decl
show = asML o pp
simplify = tr::simplify_declaration
map = .decl o mapper
rewrite = .decl o rewriter
apply = .decl o apper
subst = .decl o subster
fun fold r x = .decl (folder r x)
nolocations = nolocations
};
# Make iterators for types without convenient ones
generic package Iterators (type t
my ===> : t -> raw::decl
my <== : String * raw::decl -> t
)
{
fun simplify x = <==("simplify", decl::simplify(===> x))
fun map r x = <==("map", decl::map r (===> x))
fun rewrite r x = <==("rewrite", decl::rewrite r (===> x))
fun subst r x = <==("subst", decl::subst r (===> x))
fun apply r x = decl::apply r (===> x)
fun fold r u x = decl::fold r u (===> x)
fun nolocations x = <==("nolocations", decl::nolocations(===> x))
}
# Expression
package exp {
package t = Type (type t = raw::exp) use t
fun parse s =
case decl::parse("my _ =\n" + s) of
raw::VAL_DECL[raw::NAMED_VALUE(_, e)] => e | _ => raise exception p::PARSE_ERROR
pp = raw_pp::exp
show = asML o pp
simplify = tr::simplifyExp
map = .exp o mapper
rewrite = .exp o rewriter
apply = .exp o apper
subst = .exp o subster
fun fold r x = .exp (folder r x)
fun nolocations e =
case decl::nolocations (raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, e)]) of
raw::VAL_DECL[raw::NAMED_VALUE(_, e)] => e
| _ => bug("Exp", "locations")
}
# Expressions
package exps {
fun parse s =
case decl::parse("my _ =\n(" + s + ")") of
raw::VAL_DECL[raw::NAMED_VALUE(_, raw::TUPLE_IN_EXPRESSION e)] => e
| raw::VAL_DECL[raw::NAMED_VALUE(_, e)] => [e]
| _ => raise exception p::PARSE_ERROR
package x = List (Exp) use x
}
package label_expression {
fun parse s =
case decl::parse("{\n" + s + "}") of
raw::VAL_DECL[raw::NAMED_VALUE(_, raw::RECORDexp[e])] => e
| _ => raise exception p::PARSE_ERROR
package x = Labeled (struct use Exp pp = raw_pp::label_expression end) use x
}
# Labeled Expressions:
#
package label_expressions {
fun parse s =
case decl::parse("{\n" + s + "}") of
raw::VAL_DECL[raw::NAMED_VALUE(_, raw::RECORDexp e)] => e
| _ => raise exception p::PARSE_ERROR
package x = List (Label_Expression) use x
}
# Package Expression:
#
package sexp {
package t = Type (type t = raw::structexp) use t
fun parse s =
case decl::parse("package __fake_id__ =\n" + s) of
raw::PACKAGE_DECL(_, _, _, e) => e | _ => raise exception p::PARSE_ERROR
pp = raw_pp::sexp
show = asML o pp
map = .sexp o mapper
rewrite = .sexp o rewriter
apply = .sexp o apper
subst = .sexp o subster
fun fold r x = .sexp (folder r x)
simplify = tr::simplifySexp
fun nolocations x =
case decl::nolocations (raw::PACKAGE_DECL (fakeId,[], NULL, x)) of
raw::PACKAGE_DECL(_, _, _, x) => x
| _ => bug("Sexp", "locations")
}
# API Expression:
#
package api_expression {
package t = Type (type t = raw::api_expression) use t
fun parse s =
case decl::parse("api f =\n" + s) of
raw::API_DECL(_, e) => e | _ => raise exception p::PARSE_ERROR
pp = raw_pp::api_expression
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::API_DECL (fakeId, x)
fun <== (name, raw::API_DECL(_, x)) = x
| <== (name, _) = bug("Api_Exp", name)
) use i
}
# Clauses: <clause> | ... | <clause>
package clauses {
package t = Type (type t = List (raw::clause)) use t
fun parse s =
case exp::parse("\\\n" + s) of
raw::LAMBDA_EXPRESSION c => c | _ => raise exception p::PARSE_ERROR
pp = raw_pp::clauses
show = asML o pp
isComplex = m::isComplex
package i = Iterators
(type t = t
fun ===> x = raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, raw::LAMBDA_EXPRESSION x)]
fun <== (name, raw::VAL_DECL[raw::NAMED_VALUE(_, raw::LAMBDA_EXPRESSION x)]) = x
| <== (name, _) = bug("Clauses", name)
) use i
}
# Clause: <pat> => <exp>
# or <pat> where <exp> => <exp> (ml_grinder extension)
package clause {
package t = Type (type t = raw::clause) use t
fun parse s = case Clauses::parse s of [c] => c | _ => raise exception p::PARSE_ERROR
pp = raw_pp::clause show = asML o pp
fun isComplex c= m::isComplex[c]
package i = Iterators
(type t = t
fun ===> x = raw::VAL_DECL[raw::NAMED_VALUE (raw::WILDCARD_PATTERN, raw::LAMBDA_EXPRESSION [x])]
fun <== (name, raw::VAL_DECL[raw::NAMED_VALUE(_, raw::LAMBDA_EXPRESSION [x])]) = x
| <== (name, _) = bug("Clause", name)
) use i
}
# Funclauses: <funclause> | ... | <funclause>
package fun_clauses {
use Clauses
fun parse s =
case decl::parse("fun \n" + s) of
raw::FUN_DECL [raw::FUN (f, cs)] => (f, cs)
| _ => raise exception p::PARSE_ERROR
fun nolocations (f, c) = (f, Clauses::nolocations c)
}
/* FunClause: f <pat> ... <pat> = <exp>
* or f <pat> ....<pat> where (<exp>) => <exp> (ml_grinder extension)
*/
package fun_clause {
use Clause
fun parse s =
case FunClauses::parse s of
(f,[c]) => (f, c)
| _ => raise exception p::PARSE_ERROR
fun nolocations (f, c) = (f, Clause::nolocations c)
}
# Function_Defs: <function_def> and ... and <function_def>
package function_defs {
package t = Type (type t = List (raw::function_def)) use t
fun parse s =
case decl::parse("fun .\n" + s)
of raw::FUN_DECL b => b
| _ => raise exception p::PARSE_ERROR
pp = raw_pp::function_defs
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::FUN_DECL x
fun <== (name, raw::FUN_DECL x) = x
| <== (name, _) = bug("Function_Defs", name)
) use i
}
# Fun: f <funclause>
package function_def {
package t = Type (type t = raw::function_def) use t
fun parse s =
case Function_Defs::parse s of [b] => b | _ => raise exception p::PARSE_ERROR
pp = raw_pp::function_def
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::FUN_DECL [x]
fun <== (name, raw::FUN_DECL [x]) = x
| <== (name, _) = bug("Fun", name)
) use i
}
# Named_Values: <named_value> and ... and <named_value>
package named_values {
package t = Type (type t = List (raw::NAMED_VALUE) ) use t
fun parse s =
case decl::parse("my\n" + s)
of raw::VAL_DECL b => b
| _ => raise exception p::PARSE_ERROR
pp = raw_pp::named_values
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::VAL_DECL x
fun <== (name, raw::VAL_DECL x) = x
| <== (name, _) = bug("Named_Values", name)
) use i
}
# Named_Value: <pat> = <exp>
package named_value {
package t = Type (type t = raw::NAMED_VALUE) use t
fun parse s =
case Named_Values::parse s of [b] => b | _ => raise exception p::PARSE_ERROR
pp = raw_pp::named_value
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::VAL_DECL [x]
fun <== (name, raw::VAL_DECL [x]) = x
| <== (name, _) = bug("Named_Value", name)
) use i
}
package consbinds {
package t = Type (type t = List( raw::consbind )) use t
fun parse s =
case decl::parse("enum f=\n" + s) of
raw::DATATYPE_DECL ([raw::DATATYPE { cbs=c, ... } ], _) => c
| _ => raise exception p::PARSE_ERROR
pp = raw_pp::consbinds
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::DATATYPE_DECL(
[raw::DATATYPE { name=fakeId, tyvars=[], mc=NULL,
asm=FALSE, field=NULL, cbs=x } ],
[])
fun <== (name, raw::DATATYPE_DECL(
[raw::DATATYPE { cbs, ... } ], _)) = cbs
| <== (name, _) = bug("Consbinds", name)
) use i
}
package consbind {
package t = Type (type t = raw::consbind) use t
fun parse s = case Consbinds::parse s of [c] => c | _ => raise exception p::PARSE_ERROR
pp = raw_pp::consbind
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::DATATYPE_DECL(
[raw::DATATYPE { name=fakeId, tyvars=[], mc=NULL,
asm=FALSE, field=NULL, cbs=[x] } ],
[])
fun <== (name, raw::DATATYPE_DECL(
[raw::DATATYPE { cbs=[x], ... } ], _)) = x
| <== (name, _) = bug("Constructor_Def", name)
) use i
}
package datatypes {
package t = Type (type t = List( raw::sumtype )) use t
fun parse s =
case decl::parse("enum " + s)
of raw::DATATYPE_DECL (db,[]) => db
| _ => raise exception p::PARSE_ERROR
pp = raw_pp::datatypes
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::DATATYPE_DECL (x,[])
fun <== (name, raw::DATATYPE_DECL (x, _)) = x
| <== (name, _) = bug("Datatypes", name)
) use i
}
package sumtype {
package t = Type (type t = raw::sumtype) use t
fun parse s =
case Datatypes::parse s of [d] => d | _ => raise exception p::PARSE_ERROR
pp = raw_pp::sumtype
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::DATATYPE_DECL([x],[])
fun <== (name, raw::DATATYPE_DECL([x], _)) = x
| <== (name, _) = bug("Datatype", name)
) use i
}
package typebinds {
package t = Type (type t = List( raw::typebind )) use t
fun parse s =
case decl::parse("type " + s)
of raw::DATATYPE_DECL([], tb) => tb
| _ => raise exception p::PARSE_ERROR
pp = raw_pp::typebinds
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::DATATYPE_DECL([], x)
fun <== (name, raw::DATATYPE_DECL(_, x)) = x
| <== (name, _) = bug("Typebinds", name)
) use i
}
package typebind {
package t = Type (type t = raw::typebind) use t
fun parse s =
case Typebinds::parse s of [d] => d | _ => raise exception p::PARSE_ERROR
pp = raw_pp::typebind
show = asML o pp
package i = Iterators
(type t = t
fun ===> x = raw::DATATYPE_DECL([],[x])
fun <== (name, raw::DATATYPE_DECL(_,[x])) = x
| <== (name, _) = bug("Typebind", name)
) use i
}
package ty {
package t = Type (type t = raw::ty) use t
fun parse s =
case decl::parse("type __fake_id__=\n" + s) of
raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, t)]) => t
| _ => raise exception p::PARSE_ERROR
pp = raw_pp::ty show = asML o pp
map = .ty o mapper
rewrite = .ty o rewriter
apply = .ty o apper
subst = .ty o subster
fun fold r x = .ty (folder r x)
simplify = tr::simplifyTy
fun nolocations t =
case decl::nolocations (raw::DATATYPE_DECL([],[raw::TYPEBIND (fakeId,[], t)])) of
raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, t)]) => t
| _ => bug("Ty", "locations")
}
package tys {
fun parse s =
case decl::parse("type t=\n(" + s + ")") of
raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, raw::TUPLETY ts)]) => ts
| raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, t)]) => [t]
| _ => raise exception p::PARSE_ERROR
package x = List (Ty) use x
}
package labty {
fun parse s =
case decl::parse("type t= {\n" + s + "}") of
raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, raw::RECORDTY[t])]) => t
| _ => raise exception p::PARSE_ERROR
package x = Labeled (struct use Ty pp = raw_pp::labty end) use x
}
package labtys {
fun parse s =
case decl::parse("type t= {\n" + s + "}") of
raw::DATATYPE_DECL(_,[raw::TYPEBIND(_, _, raw::RECORDTY ts)]) => ts
| _ => raise exception p::PARSE_ERROR
package x = List (Labty) use x
}
package pat {
package t = Type (type t = raw::pat) use t
type t = raw::pat
fun parse s =
case decl::parse("my\n" + s + " = ()") of
raw::VAL_DECL[raw::NAMED_VALUE (p, _)] => p | _ => raise exception p::PARSE_ERROR
pp = raw_pp::pat show = asML o pp
map = .pat o mapper
rewrite = .pat o rewriter
apply = .pat o apper
subst = .pat o subster
fun fold r x = .pat (folder r x)
simplify = tr::simplifyPat
fun nolocations p =
case decl::nolocations (raw::VAL_DECL[raw::NAMED_VALUE (p, raw::TUPLE_IN_EXPRESSION [])]) of
raw::VAL_DECL[raw::NAMED_VALUE (p, _)] => p
| _ => bug("Pat", "locations")
}
package pats {
fun parse s =
case decl::parse("my(\n" + s + ")=()") of
raw::VAL_DECL[raw::NAMED_VALUE (raw::TUPLEPAT p, _)] => p
| raw::VAL_DECL[raw::NAMED_VALUE (p, _)] => [p]
| _ => raise exception p::PARSE_ERROR
package x = List (Pat) use x
}
package labpat {
fun parse s =
case decl::parse("my {\n" + s + "} =()") of
raw::VAL_DECL[raw::NAMED_VALUE (raw::RECORD_PATTERN([p], _), _)] => p
| _ => raise exception p::PARSE_ERROR
package x = Labeled (pkg use Pat pp = raw_pp::labpat end) use x
{
package labpats {
fun parse s =
case decl::parse("my {\n" + s + "} =()") of
raw::VAL_DECL[raw::NAMED_VALUE (raw::RECORD_PATTERN (ps, _), _)] => ps
| _ => raise exception p::PARSE_ERROR
package x = List (Labpat) use x
}
package constants {
fun constants ()
=
{ t = raw_consts::newConstTable();
defineConst = raw_consts::const t;
fun declareConsts decl
=
case raw_consts::genConsts t of
[] => decl
| ds => raw::LOCAL_DECL (ds,[decl])
{ defineConst, declareConsts };
}
}
# Input/Output
package io {
type filename = String
fun read_string filename =
let s = file::open_for_read filename
in file::read_all s then file::close_input s
end
fun read_lines filename
=
{ s = file::open_for_read filename;
fun read (text)
=
case file::read_line s of
"" => reverse text
| t => read (t . text)
read [] then file::close_input s;
}
fun stripNL "" = ""
| stripNL s
=
{ i = size s - 1;
if string::get_byte_as_char (s, i) == '\n'
then string::substring (s, 0, i)
else s;
}
fun read_lines' filename
=
map stripNL (read_lines filename);
fun read_verbatim filename
=
A.@@@(read_lines' filename);
fun read_file filename
=
case parser::load filename of
[d] => d
| ds => raw::SEQ_DECL ds;
enum writeOpt =
INFILE of filename
| OUTFILE of filename
| EXT of String
| AUTHOR of String
| VERSION of String
| PROGRAM of String
| EMAIL of String
| COMMENT of List( String )
# Don't write the file if nothing has changed
fun changed (outfile, text)
=
{ ch
=
{ s = file::open_for_read outfile;
t = file::read_all s;
t != text then file::close_input s;
}
except _ => TRUE;
if ch then err::log("[Writing " + outfile + "]")
else err::log("[No change to " + outfile + "]");
ch;
}
fun write_string (filename, text)
=
if changed (filename, text)
then
{ s = file::open filename;
file::write (s, text)
then
file::close s;
}
else ()
fun write_lines (filename, text)
=
write_string (filename, string::cat text)
fun writeFile (opts, generatedProgram)
=
{ infile = REF NULL;
outfile = REF NULL;
extension = REF "pkg";
author = REF NULL;
version = REF NULL;
program = REF NULL;
email = REF NULL;
comment = REF [];
apply (\\ INFILE s => infile := THE s;
| OUTFILE s => outfile := THE s;
| EXT s => extension := s;
| AUTHOR s => author := THE s;
| VERSION s => version := THE s;
| PROGRAM s => program := THE s;
| EMAIL s => email := THE s;
| COMMENT s => comment := s @ *comment) opts;
# Find out what output file to use
outfile
=
case *outfile of
THE f => f
| NULL => # Determine outfile name from infile/suffix
case *infile of
NULL => bug("writeFile", "no output filename given")
| THE infile
=>
{ my { base, ext }
=
winix__premicrothread::path::split_base_ext infile;
outfile = winix__premicrothread::path::join_base_ext
{ base, ext=THE *extension };
if infile == outfile
then
bug("writeFile",
"input and output file have the same name: " +
infile)
else outfile;
};
# Create a comment message on top
from = case *infile of
THE f => [" * from \"" + f + "\""]
| NULL => [];
auth = case *author of THE a => a + " + s " | NULL => "";
prog = case *program of THE p => p + " " | NULL => "";
ver = case *version of THE v => "(version " + v + ")" | NULL => "";
by = case auth + prog + ver of "" => [] | s => [" * by " + s];
other = map (\\ s => " * " + s) (*comment);
email = case *email of THE e =>
[" * Please send comments and suggestions to " + e]
| NULL => [] ;
prog' = case *program of THE p => p + " is " | NULL => "";
comment
=
A.@@@("/*" .
" * This file has been automatically generated" .
from @
by @
email @
[" * [" + prog' +
"built with the ml_grinder library (version " + Version + ")]"] @
other @
[ " */",
""
]
);
# Prettyprint and generate the program
text = decl::show (raw::SEQ_DECL[comment, generatedProgram]);
write_string (outfile, text);
}
}
# The match compiler
package match_compiler {
fakeBasis = decl::parse basisForTheMatchCompiler
fun compileTypes datatypes
=
m::compileTypes (fakeBasis . datatypes)
exception MATCH_COMPILER = m::mc::MATCH_COMPILER
fun compile_case_pattern { datatypes, prog }
=
{ literals = REF m::LitMap::empty;
info = compileTypes datatypes;
# Compile a case statement
fun compileCase (exp, rules)
=
{ dfa = m::compile info rules
m::report { warning=err::warning,
error=err::error,
log=err::log,
dfa,
rules };
m::coder { root=exp, dfa,
fail=\\ () => raw::RAISEexp (u::ID "MATCH"),
literals };
};
# Compile a function
fun fbind (fb as raw::FUN (f, cs as c . _))
=
if Clauses::isComplex cs
then # expand function
{ my raw::CLAUSE (args, _, _)
=
c;
arity = length args;
vars = list::from_fn (arity, \\ i => "p_" + i2s i);
root = raw::TUPLE_IN_EXPRESSION (map u::ID vars);
cs' = map (\\ raw::CLAUSE (ps, g, e) =>
raw::CLAUSE([raw::TUPLEPAT ps], g, e)) cs;
body = compileCase (root, cs');
raw::FUN (f, [raw::CLAUSE (map raw::IDPAT vars, NULL, body)]);
}
else fb
| fbind fb = fb
# Find all occurances of conditional patterns and transform them
prog = decl::map
[Map::D (\\ raw::FUN_DECL fbs => raw::FUN_DECL (map fbind fbs)
| d => d
),
Map::E (\\ e as raw::CASEexp (r, cs) =>
if Clauses::isComplex cs then compileCase (r, cs)
else e
| e => e)
] prog;
litDecls =
m::LitMap::keyed_fold_backward
(\\ (l, v, d) =>
raw::NAMED_VALUE (raw::IDPAT v, raw::LITERAL_IN_EXPRESSION l) . d) [] (*literals);
litDecls = case litDecls of
[] => []
| _ => [raw::VAL_DECL litDecls];
{ prog, literals=litDecls };
}
} # match_compiler
# The lexer generator
package lexer_generator {
exception LEXER_GENERATOR of String
package p = perl_syntax
package lg = lexer_generator_g (perl_syntax::R)
fun compile re = the (number_string::scan_string p::scan re)
fun lexerGenerate prog
=
{ exception WrongForm;
fun exp (origExp as
raw::CASEexp (raw::APPLY_EXPRESSION (raw::ID_IN_EXPRESSION (raw::IDENT(["Lexer"], "lexer")), head),
clauses))
=
( { rules = map (\\ raw::CLAUSE([raw::TUPLEPAT [raw::LITPAT (raw::STRING_LIT re), p]], g, action)
=>
(re, p, g, action)
| _ => raise exception WrongForm
)
clauses;
regexps = map (\\ (re, _, _, _) => compile re) rules;
lexer = lg::compile regexps;
clauses = map (\\ (_, p, g, action) => raw::CLAUSE([p], g, action))
rules;
raw::CASEexp
(raw::APPLY_EXPRESSION (raw::ID_IN_EXPRESSION (raw::IDENT(["Lexer"], "match")), head),
clauses);
}
except
WrongForm => origExp
)
| exp e = e;
prog = decl::map[Map::E exp] prog;
literals = [];
{ prog, literals };
};
} # lexer_generator
}; # ml_grinder
end; # local