From a3698041b3521c3cb17b3546ecdc08ba101c788a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 30 Jul 2006 15:03:38 +0000 Subject: [PATCH] Add primitive action handlers --- src/domain.sig | 28 ++++++++++++ src/domain.sml | 51 +++++++++++++++++++++ src/domtool.cm | 6 +++ src/env.sig | 15 ++++++- src/env.sml | 16 ++++++- src/eval.sig | 25 +++++++++++ src/eval.sml | 111 ++++++++++++++++++++++++++++++++++++++++++++++ src/main.sig | 2 + src/main.sml | 33 ++++++++++++++ tests/domain2.dtl | 5 +++ 10 files changed, 289 insertions(+), 3 deletions(-) create mode 100644 src/domain.sig create mode 100644 src/domain.sml create mode 100644 src/eval.sig create mode 100644 src/eval.sml create mode 100644 tests/domain2.dtl diff --git a/src/domain.sig b/src/domain.sig new file mode 100644 index 0000000..0d74a54 --- /dev/null +++ b/src/domain.sig @@ -0,0 +1,28 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +*) + +(* Domain-related primitive actions *) + +signature DOMAIN = sig + + val registerBefore : (string -> unit) -> unit + val registerAfter : (string -> unit) -> unit + (* Register handlers to run just before and after entering a domain + * block. *) + +end diff --git a/src/domain.sml b/src/domain.sml new file mode 100644 index 0000000..e38ea4a --- /dev/null +++ b/src/domain.sml @@ -0,0 +1,51 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +*) + +(* Domain-related primitive actions *) + +structure Domain :> DOMAIN = struct + +open Ast + +val befores = ref (fn (_ : string) => ()) +val afters = ref (fn (_ : string) => ()) + +fun registerBefore f = + let + val old = !befores + in + befores := (fn x => (old x; f x)) + end + +fun registerAfter f = + let + val old = !afters + in + afters := (fn x => (old x; f x)) + end + +val current = ref "" + +val _ = Env.registerContainer ("domain", + fn (_, [(EString dom, _)]) => (current := dom; + !befores dom; + StringMap.empty) + | _ => Env.badArgs "domain", + fn () => !afters (!current)) + +end diff --git a/src/domtool.cm b/src/domtool.cm index 4771582..df4938b 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -30,8 +30,14 @@ tycheck.sml reduce.sig reduce.sml +eval.sig +eval.sml + baseTypes.sig baseTypes.sml +domain.sig +domain.sml + main.sig main.sml diff --git a/src/env.sig b/src/env.sig index 795129a..f965ee2 100644 --- a/src/env.sig +++ b/src/env.sig @@ -20,8 +20,19 @@ signature ENV = sig - val registerType : string * (Ast.exp -> bool) -> unit - val typeRule : string -> (Ast.exp -> bool) option + type typeRule = Ast.exp -> bool + val registerType : string * typeRule -> unit + val typeRule : string -> typeRule option + + type env_vars = Ast.exp Ast.StringMap.map + type action = env_vars * Ast.exp list -> env_vars + val registerAction : string * action -> unit + val action : string -> action option + + val registerContainer : string * action * (unit -> unit) -> unit + val container : string -> (action * (unit -> unit)) option + + val badArgs : string -> 'a type env val empty : env diff --git a/src/env.sml b/src/env.sml index d18a5a9..47003cb 100644 --- a/src/env.sml +++ b/src/env.sml @@ -25,10 +25,24 @@ open Ast structure SS = StringSet structure SM = StringMap -val typeRules : (exp -> bool) SM.map ref = ref SM.empty +type typeRule = exp -> bool +val typeRules : typeRule SM.map ref = ref SM.empty fun registerType (name, rule) = typeRules := SM.insert (!typeRules, name, rule) fun typeRule name = SM.find (!typeRules, name) +type env_vars = exp SM.map +type action = env_vars * Ast.exp list -> env_vars +val actions : action SM.map ref = ref SM.empty +fun registerAction (name, action) = actions := SM.insert (!actions, name, action) +fun action name = SM.find (!actions, name) + +val containers : (action * (unit -> unit)) SM.map ref = ref SM.empty +fun registerContainer (name, befor, after) = + containers := SM.insert (!containers, name, (befor, after)) +fun container name = SM.find (!containers, name) + +fun badArgs name = raise Fail ("Invalid arguments to " ^ name) + type env = SS.set * (typ * exp option) SM.map val empty : env = (SS.add (SS.singleton "int", "string"), SM.empty) diff --git a/src/eval.sig b/src/eval.sig new file mode 100644 index 0000000..9b98e67 --- /dev/null +++ b/src/eval.sig @@ -0,0 +1,25 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +*) + +(* Execution of Domtool programs reduced to primitive actions *) + +signature EVAL = sig + + val exec : Env.env_vars -> Ast.exp -> unit + +end diff --git a/src/eval.sml b/src/eval.sml new file mode 100644 index 0000000..c05d781 --- /dev/null +++ b/src/eval.sml @@ -0,0 +1,111 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +*) + +(* Execution of Domtool programs reduced to primitive actions *) + +structure Eval :> EVAL = struct + +open Ast + +structure SM = StringMap + +fun lookup (evs, ev) = + case SM.find (evs, ev) of + NONE => raise Fail ("Couldn't find an environment variable " + ^ ev ^ " that type-checking has guaranteed") + | SOME v => v + +val conjoin : Env.env_vars * Env.env_vars -> Env.env_vars = + SM.unionWith #2 + +fun findPrimitive e = + let + fun findPrim (e, _) = + case e of + EVar name => (name, []) + | EApp (e1, e2) => + let + val (name, args) = findPrim e1 + in + (name, e2 :: args) + end + | _ => raise Fail "Non-primitive action left after reduction" + + val (name, args) = findPrim e + in + (name, rev args) + end + +fun exec evs e = + let + fun exec' evs (eAll as (e, _)) = + case e of + ESkip => SM.empty + | ESet (ev, e) => SM.insert (SM.empty, ev, e) + | EGet (x, ev, e) => exec' evs (Reduce.subst x (lookup (evs, ev)) e) + | ESeq es => + let + val (new, _) = + foldl (fn (e, (new, keep)) => + let + val new' = exec' keep e + in + (conjoin (new, new'), + conjoin (keep, new')) + end) (SM.empty, evs) es + in + new + end + | ELocal (e1, e2) => + let + val evs' = exec' evs e1 + val evs'' = exec' (conjoin (evs, evs')) e2 + in + conjoin (evs, evs'') + end + | EWith (e1, e2) => + let + val (prim, args) = findPrimitive e1 + in + case Env.container prim of + NONE => raise Fail "Unbound primitive container" + | SOME (action, cleanup) => + let + val evs' = action (evs, args) + val evs'' = exec' evs e2 + in + cleanup (); + conjoin (conjoin (evs, evs'), evs'') + end + end + + | _ => + let + val (prim, args) = findPrimitive eAll + in + case Env.action prim of + NONE => raise Fail "Unbound primitive action" + | SOME action => action (evs, args) + end + + val evs' = exec' evs e + in + () + end + +end diff --git a/src/main.sig b/src/main.sig index a7c3b2d..f36fb65 100644 --- a/src/main.sig +++ b/src/main.sig @@ -23,5 +23,7 @@ signature MAIN = sig val tInit : Ast.typ val check : string -> unit + val reduce : string -> unit + val eval : string -> unit end diff --git a/src/main.sml b/src/main.sml index 7f7d2c0..7bc4599 100644 --- a/src/main.sml +++ b/src/main.sml @@ -30,6 +30,20 @@ val tInit = (TAction ((CRoot, dmy), dmy) fun check fname = + let + val prog = Parse.parse fname + in + if !ErrorMsg.anyErrors then + () + else + let + val G' = Tycheck.checkFile Env.empty tInit prog + in + () + end + end + +fun reduce fname = let val prog = Parse.parse fname in @@ -56,4 +70,23 @@ fun check fname = end end +fun eval fname = + let + val prog = Parse.parse fname + in + if !ErrorMsg.anyErrors then + () + else + let + val G' = Tycheck.checkFile Env.empty tInit prog + in + if !ErrorMsg.anyErrors then + () + else + case prog of + (_, SOME body) => Eval.exec StringMap.empty body + | _ => () + end + end + end diff --git a/tests/domain2.dtl b/tests/domain2.dtl new file mode 100644 index 0000000..248f4a8 --- /dev/null +++ b/tests/domain2.dtl @@ -0,0 +1,5 @@ +extern val domain : string -> Domain => [Root]; + +domain "hcoop.net" with + +end -- 2.20.1