real: enable linear
[nofib.git] / real / rx / src / Semantik.hs
1 -- C-like imperative semantics:
2
3 -- expressions have values and side effects (that modify the environment)
4 -- and they may do output
5
6 module Semantik
7
8 ( Env
9
10 , FIO, unFIO, forceFIO
11
12 , oops
13 , moops
14
15 , Fun, mkFun, mkfunction
16
17 , vargs
18
19 , comp
20 , docomp
21
22 )
23
24 where
25
26 import Maybes
27
28 import Options
29
30 import FiniteMap -- syslib ghc
31
32 import Syntax
33 import Ids
34
35 import FAcon
36
37
38 -- identifiers are bound to functions from Exp^* -> a
39 -- that is they see the literal form of their arguments
40 -- they need to evaluate them if they want
41 -- this is like lisp and allows for (setq foo bar)
42
43 newtype FIO s = FIO (Either String s); unFIO (FIO n) = n
44
45 instance Functor FIO where
46 fmap f (FIO (Left l)) = FIO (Left l)
47 fmap f (FIO (Right r)) = FIO (Right (f r))
48
49 instance Monad FIO where
50 return x = FIO (Right x)
51 FIO (Left l) >>= f = FIO (Left l)
52 FIO (Right r) >>= f = f r
53
54 -- instance MonadPlus FIO where
55 -- mzero = FIO (Left "some error")
56
57 oops :: String -> FIO a
58 oops cs = FIO (Left cs)
59
60 moops :: Bool -> String -> FIO ()
61 moops p cs = if p then oops cs else return ()
62
63 forceFIO :: FIO a -> a
64 forceFIO (FIO (Left l)) = error ("error (FIO): " ++ l)
65 forceFIO (FIO (Right r)) = r
66
67
68 -- only look at the result
69 docomp opts env arg =
70 forceFIO (do { (x, env') <- comp opts env arg; return x } )
71
72
73
74 -------------------------------------------------------------------
75
76 type Env e a = FiniteMap String (Fun e a)
77
78 data Fun e a = Fun (Opts -> Env e a -> [Exp] -> FIO (a, Env e a))
79 mkFun f = Fun f; unFun (Fun f) = f
80
81
82 --------------------------------------------------------------------
83
84 -- a plain function that evaluates its arguments
85
86 -- mkfunction :: String -> ([a] -> a) -> Fun e a
87 mkfunction name f = Fun (\ opts env args ->
88
89 do { troff opts ("\nentered: " ++ name) (return ())
90 ; (vals, env1) <- vargs opts env args
91 ; return (f opts vals, env1) -- todo: really env1 here?
92 } )
93
94
95 ----------------------------------------------------------------------
96
97 -- evaluate a list of expressions from left to right
98 -- return list of results
99 -- thread state through
100
101 -- vargs :: Opts -> Env e a -> [Exp] -> FIO ([a], Env e a)
102 vargs opts env [] = return ([], env)
103 vargs opts env (x : xs) =
104 do { (y, env1) <- comp opts env x
105 ; (ys, env2) <- vargs opts env1 xs
106 ; return (y : ys, env2)
107 }
108
109
110 -- a computation
111 -- has a result
112 -- maybe changes the environment
113 -- maybe does some FIO
114 -- sequential composition ";" and assignment "=" are wired in
115
116 -- comp :: Opts -> Env e a -> Exp -> FIO (a, Env e a)
117
118 comp opts env (App id args) | idname id == ";" =
119 do { (xs, env1) <- vargs opts env args
120 ; return (last xs, env1)
121 }
122
123 comp opts env x @ (App id args) | idname id == "=" =
124 do { moops (length args /= 2)
125 ( "(=) needs exactly two arguments: " ++ show x )
126 ; let [lhs, rhs] = args
127
128 ; case lhs of
129 App id locs -> compbind opts env x (idname id) locs rhs
130 _ -> oops ( "lhs of (=) must be application of function or operator: " ++ show x )
131 }
132
133 comp opts env x @ (App id args) =
134
135 troff opts ("\ncomp: " ++ show x ) $
136
137 let name = idname id in case lookupFM env name of
138 Just f -> unFun f opts env args
139 Nothing -> -- oops ("identifier " ++ name ++ " not bound")
140 -- NO, rather: unbound ids are treated as constructors
141
142 -- todo: this breaks the abstraction
143 do { (vs, env1) <- vargs opts env args
144 ; return (conTNFA opts id vs, env1)
145 }
146
147
148 compbind opts env x name locs rhs =
149 do { moops (exists (lookupFM env name))
150 ( "identifier already bound: " ++ show x )
151
152 ; if null locs
153 then define_value opts env name rhs -- see below
154 else define_function opts env x name locs rhs -- see below
155 }
156
157 -------------------------------------------------------------------
158
159 mkconst :: a -> Fun e a
160 mkconst x = Fun ( \ opts env args -> do
161 { moops (not (null args))
162 ("a constant cannot have args: " ++ show args)
163 ; return (x, env)
164 } )
165
166 -- a value (function with 0 args) is evaluated right now
167 define_value opts env name rhs =
168 do { (v, env1) <- comp opts env rhs -- env1 is ignored
169 ; let val = mkconst v
170 ; let env2 = addToFM env name val
171 ; return (v, env2)
172 }
173
174 -- a `real' function (with > 0 args) is stored as closure
175 define_function opts env x name lhsargs rhs =
176 do { moops (any (not . isAppId) lhsargs)
177 ( "local args must be ids: " ++ show x )
178 ; let locs = map (idname . unAppId) lhsargs
179
180 -- here's the semantics of a function call
181 ; let val = Fun (\ opts env1 args1 -> do
182 -- evaluate args in caller's environment
183 { (vs, env2) <- vargs opts env1 args1
184 ; moops (length vs /= length locs)
185 ( "wrong number of args: " ++ show args1
186 ++ ", should be " ++ show (length locs) )
187 -- local bindings over callee's environment
188 ; let bnds = listToFM (zip locs (map mkconst vs))
189 ; let env3 = env1 `plusFM` bnds
190 ; (v, env4) <- comp opts env3 rhs
191 -- return caller's environment
192 ; return (v, env2)
193 } )
194
195 ; let env1 = addToFM env name val
196
197 -- ; return (undefined, env1) -- todo: what to return here?
198 ; return (conTNFA opts (usercon 0 "defined") [], env1)
199
200 }
201
202