mfl.hs is attatched.
ghc -c mfl.hs -Wall
mfl.hs:8: Warning: Defined but not used: INil, IString
mfl.hs:12: Warning: Definition but no type signature for `isOp'
mfl.hs:27: Warning: Definition but no type signature for `parse'
mfl.hs:68: Warning: Definition but no type signature for `da'
mfl.hs:73: Warning: Definition but no type signature for `main'
ghc-5.00: panic! (the `impossible' happened, GHC version 5.00):
<<loop>>
Please report it as a compiler bug to [EMAIL PROTECTED],
or http://sourceforge.net/projects/ghc/.
make: *** [mfl.o] Error 1
--
--------------------------------------------------------------
John Meacham http://www.ugcs.caltech.edu/~john/
California Institute of Technology, Alum. [EMAIL PROTECTED]
--------------------------------------------------------------
import Char
import Maybe(fromJust)
data Code = CodeItem Item | CodeSymbol String | CodeAssign String |
CodeQuote String | CodePrimitive (RunState -> RunState)
deriving(Show)
data Item = IString String | IInt Int | IClosure [Code] | INil
deriving(Show)
isOp c = c `elem` ops where
ops = "+-*/"
spanName :: String -> (String,String)
spanName (c:cs) | isOp c = (c:[],cs)
spanName (c:cs) | isAlpha c = span isAlpha (c:cs)
spanName _ = error "Invalid name"
spanClosure :: String -> (String, String)
spanClosure (']':cs) = ([],cs)
spanClosure ('[':cs) = let (c,r) = spanClosure cs in
let (a,b) = spanClosure r in ("[" ++ c ++ "]" ++ a,b)
spanClosure (c:cs) = let (a,b) = spanClosure cs in (c:a, b)
spanClosure [] = error "unterminated closure"
parse (c:cs) | isSpace c = parse (dropWhile isSpace cs)
parse (c:cs) | isDigit c = let (n,r) = span isDigit (c:cs) in (CodeItem $ IInt $ read
n):parse r
parse ('\\':cs) = let (n,r) = spanName cs in (CodeAssign n):parse r
parse ('`':cs) = let (n,r) = spanName cs in (CodeQuote n):parse r
parse ('[':cs) = let (c,r) = spanClosure cs in (CodeItem $ IClosure $ parse c):parse r
parse (c:cs) = let (n,r) = spanName (c:cs) in (CodeSymbol n):parse r
parse [] = []
type Stack = [Item]
type State = ([Code],RunState)
type RunState = (Stack, [(String, Item)])
evalItem :: Item -> RunState -> RunState
evalItem (IClosure code) rs = rs' where
(_, rs') = evalall (code, rs)
eval :: State -> State
eval (CodeItem i:rc, (s, a)) = (rc,(i:s,a))
eval (CodeAssign n:rc, ((s:ss), a)) = (rc, (ss, (n,s):a))
eval (CodeSymbol n:rc, (s, a)) = (rc, (s', a')) where
(s',a') = evalItem (fromJust $ lookup n a) (s, a)
eval (CodePrimitive cp:rc, rs) = (rc, cp rs)
evalall :: State -> State
evalall ([], rs)= ([],rs)
evalall s = evalall (eval s)
{-
eval :: State -> State
eval (c:cs,s) | isSpace c = (dropWhile isSpace cs,s)
eval (c:cs,s) | isDigit c = let (n,r) = span isDigit (c:cs) in (r,(IInt $ read n):s)
eval (c:cs,s) |
evalall :: State -> State
evalall ("", s)= ("",s)
evalall s = evalall (eval s)
-}
da = [("foo", IInt 3)]
initstate :: [Code] -> State
initstate c = (c, ([],da))
main = do
c <- getContents
let s = evalall (initstate (parse c))
print s
