X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/492c1cff68a2da969a559627725369c211470c92..270265f9d9f2d733a2e3c8cf843884570d940630:/src/reduce.sml

diff --git a/src/reduce.sml b/src/reduce.sml
index 17a8507..9e538d6 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -14,7 +14,7 @@
  * 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.
-*)
+ *)
 
 (* Evaluation of expressions until only externs are around *)
 
@@ -22,6 +22,8 @@ structure Reduce :> REDUCE = struct
 
 open Ast Print Env
 
+structure SM = StringMap
+
 fun freeIn x (b, _) =
     case b of
 	EInt _ => false
@@ -34,10 +36,13 @@ fun freeIn x (b, _) =
 
       | ESkip => false
       | ESet (_, e) => freeIn x e
-      | EGet (x', _, b') => x <> x' andalso freeIn x b'
+      | EGet (x', _, _, b') => x <> x' andalso freeIn x b'
       | ESeq es => List.exists (freeIn x) es
       | ELocal (e1, e2) => freeIn x e1 orelse freeIn x e2
       | EWith (e1, e2) => freeIn x e1 orelse freeIn x e2
+      | EALam (x', _, b') => x <> x' andalso freeIn x b'
+
+      | EIf (e1, e2, e3) => freeIn x e1 orelse freeIn x e2 orelse freeIn x e3
 
 local
     val freshCount = ref 0
@@ -77,20 +82,42 @@ fun subst x e (bAll as (b, loc)) =
 
       | ESkip => bAll
       | ESet (v, b) => (ESet (v, subst x e b), loc)
-      | EGet (x', v, b') =>
+      | EGet (x', topt, v, b') =>
 	if x = x' then
 	    bAll
 	else if freeIn x' e then
 	    let
 		val x'' = freshVar ()
 	    in
-		(EGet (x'', v, subst x e (subst x' (EVar x'', loc) b')), loc)
+		(EGet (x'', topt, v, subst x e (subst x' (EVar x'', loc) b')), loc)
 	    end
 	else
-	    (EGet (x', v, subst x e b'), loc)
+	    (EGet (x', topt, v, subst x e b'), loc)
       | ESeq es => (ESeq (map (subst x e) es), loc)
       | ELocal (b1, b2) => (ELocal (subst x e b1, subst x e b2), loc)
       | EWith (b1, b2) => (EWith (subst x e b1, subst x e b2), loc)
+      | EALam (x', p, b') =>
+	if x = x' then
+	    bAll
+	else if freeIn x' e then
+	    let
+		val x'' = freshVar ()
+	    in
+		(EALam (x'', p, subst x e (subst x' (EVar x'', loc) b')), loc)
+	    end
+	else
+	    (EALam (x', p, subst x e b'), loc)
+
+      | EIf (b1, b2, b3) => (EIf (subst x e b1, subst x e b2, subst x e b3), 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
@@ -110,7 +137,12 @@ fun reduceExp G (eAll as (e, loc)) =
 	end
       | EVar x =>
 	(case lookupEquation G x of
-	     NONE => eAll
+	     NONE =>
+	     (case function x of
+		  NONE => eAll
+		| SOME f => case f [] of
+				NONE => eAll
+			      | SOME e' => reduceExp G e')
 	   | SOME e => reduceExp G e)
       | EApp (e1, e2) =>
 	let
@@ -119,14 +151,48 @@ 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
       | ESet (v, b) => (ESet (v, reduceExp G b), loc)
-      | EGet (x, v, b) => (EGet (x, v, reduceExp G b), loc)
+      | EGet (x, topt, v, b) => (EGet (x, topt, v, reduceExp G b), loc)
       | ESeq es => (ESeq (map (reduceExp G) es), loc)
       | ELocal (e1, e2) => (ELocal (reduceExp G e1, reduceExp G e2), loc)
-      | EWith (e1, e2) => (EWith (reduceExp G e1, reduceExp G e2), loc)
+      | EWith (e1, e2) =>
+	let
+	    val e1' = reduceExp G e1
+	    val e2' = reduceExp G e2
+	in
+	    case e1' of
+		(EALam (x, _, b), _) => reduceExp G (subst x e2' b)
+	      | _ => (EWith (e1', e2'), loc)
+	end
+      | EALam (x, p, e) =>
+	let
+	    val G' = bindVal G (x, (TAction (p, SM.empty, SM.empty), loc), NONE)
+	in
+	    (EALam (x, p, reduceExp G' e), loc)
+	end
+
+      | EIf (e1, e2, e3) =>
+	let
+	    val e1' = reduceExp G e1
+	    fun e2' () = reduceExp G e2
+	    fun e3' () = reduceExp G e3
+	in
+	    case e1' of
+		(EVar "true", _) => e2' ()
+	      | (EVar "false", _) => e3' ()
+	      | _ => (EIf (e1', e2' (), e3' ()), loc)
+	end
 
 end