From cf879b4f037242eb535207f0ff3400fe89ab61b1 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 14 Dec 2006 23:44:16 +0000
Subject: [PATCH] Add external functions called during reduction

---
 src/domain.sml |  7 +++++--
 src/env.sig    |  3 +++
 src/env.sml    |  5 +++++
 src/reduce.sml | 19 ++++++++++++++++++-
 4 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/src/domain.sml b/src/domain.sml
index 85dcd67..8020ee4 100644
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -223,8 +223,11 @@ datatype master =
 	 ExternalMaster of string
        | InternalMaster of string
 
-val ip = fn (EApp ((EVar "ip_of_node", _), e), _) => Option.map nodeIp (Env.string e)
-	  | e => Env.string e
+val ip = Env.string
+
+val _ = Env.registerFunction ("ip_of_node",
+			      fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
+			       | _ => NONE)
 
 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
 	      | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
diff --git a/src/env.sig b/src/env.sig
index 31e6691..023813a 100644
--- a/src/env.sig
+++ b/src/env.sig
@@ -82,6 +82,9 @@ signature ENV = sig
 
     val containerV_one : string -> string * 'a arg -> (env_vars * 'a -> unit) * (unit -> unit) -> unit
 
+    val registerFunction : string * (Ast.exp list -> Ast.exp option) -> unit
+    val function : string -> (Ast.exp list -> Ast.exp option) option
+
     type env
     val empty : env
 
diff --git a/src/env.sml b/src/env.sml
index 1a93a38..f87278f 100644
--- a/src/env.sml
+++ b/src/env.sml
@@ -41,6 +41,11 @@ fun registerContainer (name, befor, after) =
     containers := SM.insert (!containers, name, (befor, after))
 fun container name = SM.find (!containers, name)
 
+val functions : (exp list -> exp option) SM.map ref = ref SM.empty
+fun registerFunction (name, f) =
+    functions := SM.insert (!functions, name, f)
+fun function name = SM.find (!functions, name)
+
 local
     val pr = ref (fn () => ())
 in
diff --git a/src/reduce.sml b/src/reduce.sml
index 37c2a35..ab6dafa 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -106,6 +106,15 @@ fun subst x e (bAll as (b, loc)) =
 	else
 	    (EALam (x', p, subst x e b'), loc)
 
+fun findPrim (e, _) =
+    case e of
+	EApp (f, x) =>
+	(case findPrim f of
+	     NONE => NONE
+	   | SOME (f, xs) => SOME (f, xs @ [x]))
+      | EVar x => SOME (x, [])
+      | _ => NONE
+
 fun reduceExp G (eAll as (e, loc)) =
     case e of
 	EInt _ => eAll
@@ -133,7 +142,15 @@ fun reduceExp G (eAll as (e, loc)) =
 	in
 	    case e1' of
 		(ELam (x, _, b), _) => reduceExp G (subst x e2' b)
-	      | _ => (EApp (e1', e2'), loc)
+	      | _ =>
+		case findPrim eAll of
+		    NONE => (EApp (e1', e2'), loc)
+		  | SOME (f, args) =>
+		    case function f of
+			NONE => (EApp (e1', e2'), loc)
+		      | SOME f => case f (map (reduceExp G) args) of
+				      NONE => (EApp (e1', e2'), loc)
+				    | SOME e' => reduceExp G e'
 	end
 
       | ESkip => eAll
-- 
2.20.1