git-svn-id: https://slps.svn.sourceforge.net/svnroot/slps@1064 ab42f6…

…e0-554d-0410-b580-99e487e6eeb2

topics/partialevaluation/simplepe/Evaluator.hs

@@ -0,0 +1,31 @@
+import Syntax
+import Data.Maybe
+
+type VEnv = [(String,Int)]
+
+eval :: Prog -> Int
+eval (fe,m) = eval' m []
+ where
+  eval' :: Expr -> VEnv -> Int
+  eval' (Const i) ve = i
+  eval' (Var x) ve = fromJust (lookup x ve)
+  eval' (Binary op e1 e2) ve = f v1 v2
+   where
+    f  = op2f op
+    v1 = eval' e1 ve
+    v2 = eval' e2 ve
+  eval' (IfZero e1 e2 e3) ve = if (v1==0) then v2 else v3
+   where
+    v1 = eval' e1 ve
+    v2 = eval' e2 ve
+    v3 = eval' e3 ve
+  eval' (Apply n es) ve = eval' e ve'
+   where
+    (ns,e) = fromJust (lookup n fe)
+    vs = map (\e -> eval' e ve) es
+    ve' = zip ns vs
+
+main
+ = do
+      print $ eval (lib, Apply "fac" [Const 5])
+      print $ eval (lib, Apply "exp" [Const 2, Const 3])

topics/partialevaluation/simplepe/PartialEvaluator.hs

@@ -0,0 +1,41 @@
+import Syntax
+import Data.Maybe
+
+type VEnv = [(String,Expr)]
+
+peval :: Prog -> Expr
+peval (fe,m) = peval' m []
+ where
+  peval' :: Expr -> VEnv -> Expr
+  peval' (Const i) ve = Const i
+  peval' (Var x) ve
+   = case lookup x ve of
+      Just r -> r
+      Nothing -> Var x
+  peval' (Binary op e1 e2) ve
+   = case (r1, r2) of 
+      (Const v1, Const v2) -> Const (f v1 v2)
+      _ -> Binary op r1 r2
+   where
+    f  = op2f op
+    r1 = peval' e1 ve
+    r2 = peval' e2 ve
+  peval' (IfZero e1 e2 e3) ve
+   = case r1 of
+      (Const v1) -> if (v1==0) then r2 else r3
+      _ -> IfZero r1 r2 r3
+   where
+    r1 = peval' e1 ve
+    r2 = peval' e2 ve
+    r3 = peval' e3 ve
+  peval' (Apply n es) ve = peval' e ve'
+   where
+    (ns,e) = fromJust (lookup n fe)
+    rs = map (\e -> peval' e ve) es
+    ve' = zip ns rs
+
+main
+ = do
+      print $ peval (lib, Apply "fac" [Const 5])
+      print $ peval (lib, Apply "exp" [Const 2, Const 3])
+      print $ peval (lib, Apply "exp" [Var "x", Const 3])

topics/partialevaluation/simplepe/Syntax.hs

@@ -0,0 +1,45 @@
+module Syntax where
+
+-- Syntax of programs and expressions
+
+type Prog = (FEnv,Expr)
+type FEnv = [(String,([String],Expr))]
+
+data Expr
+ = Const Int
+ | Var String
+ | Binary Op Expr Expr
+ | IfZero Expr Expr Expr
+ | Apply String [Expr]
+ deriving (Show)
+
+data Op = Plus | Times
+ deriving (Show)
+
+op2f :: Op -> (Int -> Int -> Int)
+op2f Plus = (+) 
+op2f Times = (*)
+
+
+-- Sample functions collected in one "library"
+
+lib :: FEnv
+lib
+ = [ ("fac",
+       ( ["x"]
+       , IfZero (Var "x")
+           (Const 1)
+           (Binary Times
+                   (Var "x")
+                   (Apply "fac" [(Binary Plus
+                                         (Var "x")
+                                         (Const (-1)))])))),
+     ("exp",
+       ( ["x","n"]
+       , IfZero (Var "n")
+           (Const 1)
+           (Binary Times
+                   (Var "x")
+                   (Apply "exp" [Var "x",(Binary Plus
+                                                 (Var "n")
+                                                 (Const (-1)))])))) ]