epic (empty) → 0.1.2
raw patch · 18 files changed
+3613/−0 lines, 18 filesdep +Cabaldep +arraydep +basesetup-changedbinary-added
Dependencies added: Cabal, array, base, directory, haskell98, mtl
Files
- Epic/Bytecode.lhs +225/−0
- Epic/CodegenC.lhs +230/−0
- Epic/Compiler.lhs +151/−0
- Epic/Language.lhs +165/−0
- Epic/Lexer.lhs +267/−0
- Epic/OTTLang.lhs +20/−0
- Epic/Parser.y +218/−0
- Epic/Scopecheck.lhs +101/−0
- LICENSE +32/−0
- Setup.hs +26/−0
- dist/build/Epic/Parser.hs +1178/−0
- epic.cabal +27/−0
- evm/Makefile +22/−0
- evm/closure.c +698/−0
- evm/closure.h +162/−0
- evm/libevm.a binary
- evm/mainprog.c +17/−0
- evm/stdfuns.h +74/−0
+ Epic/Bytecode.lhs view
@@ -0,0 +1,225 @@+> module Epic.Bytecode where++> import Control.Monad.State+> import List++> import Epic.Language++> type Local = Int+> type TmpVar = Int++Register based - most operations do an action, then put the result in a+'TmpVar' which is basically a numbered register. There are infinite registers+at this stage.++> data ByteOp = CALL TmpVar Name [TmpVar]+> | TAILCALL TmpVar Name [TmpVar]+> | THUNK TmpVar Int Name [TmpVar]+> | ADDARGS TmpVar TmpVar [TmpVar]+> | FOREIGN Type TmpVar String [(TmpVar, Type)]+> | VAR TmpVar Local+> | ASSIGN Local TmpVar+> | CON TmpVar Tag [TmpVar]+> | UNIT TmpVar+> | INT TmpVar Int+> | BIGINT TmpVar Integer+> | FLOAT TmpVar Float+> | BIGFLOAT TmpVar Double+> | STRING TmpVar String+> | PROJ TmpVar TmpVar Int -- project into a register+> | PROJVAR Local TmpVar Int -- project into a local variable+> -- each case branch records which tag it's code for+> | CASE TmpVar [(Int, Bytecode)] (Maybe Bytecode)+> | IF TmpVar Bytecode Bytecode+> | OP TmpVar Op TmpVar TmpVar+> | LOCALS Int -- allocate space for locals+> | TMPS Int -- declare temporary variables+> | EVAL TmpVar+> -- | LET TmpVar Local TmpVar+> | RETURN TmpVar+> | DRETURN -- return dummy value+> | ERROR String -- Fatal error, exit+> | TRACE String [TmpVar]+> deriving Show++> type Bytecode = [ByteOp]++> data FunCode = Code [Type] Bytecode+> deriving Show++> data CompileState = CS { arg_types :: [Type],+> num_locals :: Int,+> next_tmp :: Int }++> compile :: Context -> Name -> Func -> FunCode+> compile ctxt fname fn@(Bind args locals def) = +> let cs = (CS (map snd args) (length args) 1)+> code = evalState (scompile ctxt fname fn) cs in+> Code (map snd args) code++> data TailCall = Tail | Middle++> scompile :: Context -> Name -> Func -> State CompileState Bytecode+> scompile ctxt fname (Bind args locals def) = +> do -- put (CS args (length args) 1)+> code <- ecomp Tail def 0 (length args)+> cs <- get+> return $ (LOCALS (num_locals cs)):+> (TRACE (show fname) [0..(length args)-1]):+> (TMPS (next_tmp cs)):code ++[EVAL 0, RETURN 0]++> where++> new_tmp :: State CompileState Int+> new_tmp = do cs <- get+> let reg' = next_tmp cs+> put (cs { next_tmp = reg'+1 } )+> return reg'++Add some locals, return de Bruijn level of first new one.++> new_locals :: Int -> State CompileState Int+> new_locals args = +> do cs <- get+> let loc = num_locals cs+> put (cs { num_locals = loc+args } )+> return loc++Take an expression and the register (TmpVar) to put the result into;+compile code to do just that.++Also carry the number of real variables currently in scope so that, in +particular, when we project from a data structure we store it in the right+place.++> ecomp :: TailCall -> Expr -> TmpVar -> Int -> +> State CompileState Bytecode+> ecomp tcall (V v) reg vs = +> do return [VAR reg v]+> ecomp tcall (R x) reg vs = acomp tcall False (R x) [] reg vs+> ecomp tcall (App f as) reg vs = acomp tcall False f as reg vs+> ecomp tcall (LazyApp f as) reg vs = acomp tcall True f as reg vs+> ecomp tcall (Con t as) reg vs = +> do (argcode, argregs) <- ecomps as vs+> return $ argcode ++ [CON reg t argregs]+> ecomp tcall (Proj con i) reg vs =+> do reg' <- new_tmp+> concode <- ecomp Middle con reg' vs+> return [PROJ reg reg' i]+> ecomp tcall (Const c) reg vs = ccomp c reg+> ecomp tcall (Case scrutinee alts) reg vs =+> do screg <- new_tmp+> sccode <- ecomp Middle scrutinee screg vs+> (altcode, def) <- altcomps tcall (order alts) screg reg vs+> return $ sccode ++ [EVAL screg, CASE screg altcode def]+> ecomp tcall (If a t e) reg vs =+> do areg <- new_tmp+> acode <- ecomp Middle a areg vs+> tcode <- ecomp tcall t reg vs+> ecode <- ecomp tcall e reg vs+> return $ acode ++ [EVAL areg, IF areg tcode ecode]+> ecomp tcall (Op op l r) reg vs =+> do lreg <- new_tmp+> rreg <- new_tmp+> lcode <- ecomp Middle l lreg vs+> rcode <- ecomp Middle r rreg vs+> return $ lcode ++ [EVAL lreg] ++ +> rcode ++ [EVAL rreg, OP reg op lreg rreg]+> ecomp tcall (Let nm ty val scope) reg vs =+> do loc <- new_locals 1+> reg' <- new_tmp+> valcode <- ecomp Middle val reg' vs+> scopecode <- ecomp tcall scope reg (vs+1)+> return $ valcode ++ (EVAL reg'):(ASSIGN vs reg'):scopecode+> ecomp tcall (Error str) reg vs = return [ERROR str]+> ecomp tcall Impossible reg vs = return [ERROR "The impossible happened."]+> ecomp tcall (ForeignCall ty fn argtypes) reg vs = do+> let (args,types) = unzip argtypes+> (argcode, argregs) <- ecomps args vs+> let evalcode = map EVAL argregs+> return $ argcode ++ evalcode ++ [FOREIGN ty reg fn (zip argregs types)]++> ecomps :: [Expr] -> Int -> State CompileState (Bytecode, [TmpVar])+> ecomps e vs = ecomps' [] [] e vs+> ecomps' code tmps [] vs = return (code, tmps)+> ecomps' code tmps (e:es) vs =+> do reg <- new_tmp+> ecode <- ecomp Middle e reg vs+> ecomps' (code++ecode) (tmps++[reg]) es vs++Compile case alternatives.++> order :: [CaseAlt] -> [CaseAlt]+> order xs = sort xs -- insertError 0 (sort xs)++We don't do this any more, now that we have default cases.++> insertError t [] = []+> insertError t (a@(Alt tn _ _):xs)+> = {- (errors t tn) ++ -} a:(insertError (tn+1) xs)+> insertError t rest@((DefaultCase _):xs)+> = rest -- End at defaul case++> errors x end | x == end = []+> | otherwise = (Alt x [] Impossible):(errors (x+1) end)++> altcomps :: TailCall -> [CaseAlt] -> TmpVar -> TmpVar -> Int ->+> State CompileState ([(Int, Bytecode)], Maybe Bytecode)+> altcomps tc [] _ _ vs = return ([], Nothing)+> altcomps tc (a:as) scrutinee reg vs = +> do (t,acode) <- altcomp tc a scrutinee reg vs+> (ascode, def) <- altcomps tc as scrutinee reg vs+> if (t<0) then return (ascode, Just acode)+> else return ((t,acode):ascode, def)++Assume that all the tags are in order, and unused constructors have +a default inserted (i.e., tag can be ignored).++Return the tag and the code - tag is -1 for default case.++> altcomp :: TailCall -> CaseAlt -> TmpVar -> TmpVar -> Int ->+> State CompileState (Int, Bytecode)+> altcomp tc (Alt tag nmargs expr) scrutinee reg vs =+> do let args = map snd nmargs+> local <- new_locals (length args)+> projcode <- project args scrutinee vs 0+> exprcode <- ecomp tc expr reg (vs+(length args))+> return (tag, projcode++exprcode)+> altcomp tc (DefaultCase expr) scrutinee reg vs =+> do exprcode <- ecomp tc expr reg vs+> return (-1,exprcode)++> project [] _ _ _ = return []+> project (_:as) scr loc arg = +> do let acode = PROJVAR loc scr arg+> ascode <- project as scr (loc+1) (arg+1)+> return (acode:ascode)++Compile an application of a function to arguments++> acomp :: TailCall -> Bool -> Expr -> [Expr] -> TmpVar -> Int ->+> State CompileState Bytecode+> acomp tc lazy (R x) args reg vs+> | lazy == False && arity x ctxt == length args =+> do (argcode, argregs) <- ecomps args vs+> return $ argcode {- ++ map EVAL argregs -} ++ [(tcall tc) reg x argregs]+> | otherwise =+> do (argcode, argregs) <- ecomps args vs+> return $ argcode ++ [THUNK reg (arity x ctxt) x argregs]+> where tcall Tail = TAILCALL+> tcall Middle = CALL+> acomp _ _ f args reg vs+> = do (argcode, argregs) <- ecomps args vs+> reg' <- new_tmp+> fcode <- ecomp Middle f reg' vs+> return $ fcode ++ argcode ++ [ADDARGS reg reg' argregs]++> ccomp (MkInt i) reg = return [INT reg i]+> ccomp (MkBigInt i) reg = return [BIGINT reg i]+> ccomp (MkChar c) reg = return [INT reg (fromEnum c)]+> ccomp (MkFloat f) reg = return [FLOAT reg f]+> ccomp (MkBigFloat f) reg = return [BIGFLOAT reg f]+> ccomp (MkBool b) reg = return [INT reg (if b then 1 else 0)]+> ccomp (MkString s) reg = return [STRING reg s]+> ccomp (MkUnit) reg = return [UNIT reg]+
+ Epic/CodegenC.lhs view
@@ -0,0 +1,230 @@+> module Epic.CodegenC where++> import Control.Monad.State++> import Epic.Language+> import Epic.Bytecode+> import Debug.Trace++> codegenC :: Context -> [Decl] -> String+> codegenC ctxt decs =+> fileHeader +++> headers decs ++ "\n" +++> wrappers decs +++> workers ctxt decs+> -- ++ mainDriver++> writeIFace :: [Decl] -> String+> writeIFace [] = ""+> writeIFace ((Decl name ret (Bind args _ _)):xs) =+> "extern " ++ showC name ++ " ("++ showextargs (args) ++ ")" +++> " -> " ++ show ret ++ "\n" ++ writeIFace xs+> writeIFace (_:xs) = writeIFace xs++> showextargs [] = ""+> showextargs [(n,ty)] = showC n ++ ":" ++ show ty+> showextargs ((n,ty):xs) = showC n ++ ":" ++ show ty ++ ", " ++ +> showextargs xs++> fileHeader = "#include \"closure.h\"\n" ++ +> "#include \"stdfuns.h\"\n" ++ +> "#include <assert.h>\n\n"++> mainDriver = "int main(int argc, char*[] argv) {\nGC_init();\ninit_evm();\n_do__U_main(); return 0; }\n"++> showarg _ i = "void* " ++ loc i++> showargs [] i= ""+> showargs [x] i = showarg x i+> showargs (x:xs) i = showarg x i ++ ", " ++ showargs xs (i+1)++> headers [] = ""+> headers ((Decl fname ret (Bind args _ _)):xs) =+> "void* " ++ thunk fname ++ "(void** block);\n" +++> "void* " ++ quickcall fname ++ "(" ++ showargs args 0 ++ ");\n" +++> headers xs+> headers ((Extern fname ret tys):xs) =+> "void* " ++ thunk fname ++ "(void** block);\n" +++> "void* " ++ quickcall fname ++ "(" ++ showargs (zip (names 0) tys) 0 ++ ");\n" +++> headers xs+> where names i = (MN "arg" i):(names (i+1))+> headers ((Include h):xs) = "#include <"++h++">\n" ++ headers xs+> headers (_:xs) = headers xs++> wrappers [] = ""+> wrappers ((Decl fname ret (Bind args _ _)):xs) =+> "void* " ++ thunk fname ++ "(void** block) {\n return " ++ +> quickcall fname ++ "(" +++> wrapperArgs (length args) ++ ");\n}\n\n" +++> wrappers xs+> wrappers (_:xs) = wrappers xs++> wrapperArgs 0 = ""+> wrapperArgs 1 = "block[0]"+> wrapperArgs x = wrapperArgs (x-1) ++ ", block[" ++ show (x-1) ++ "]"++> workers _ [] = ""+> workers ctxt ((Decl fname ret func@(Bind args locals defn)):xs) =+> -- trace (show fname ++ ": " ++ show defn) $+> "void* " ++ quickcall fname ++ "(" ++ showargs args 0 ++ ") {\n" +++> compileBody (compile ctxt fname func) ++ "\n}\n\n" +++> workers ctxt xs+> workers ctxt (_:xs) = workers ctxt xs++> tmp v = "tmp" ++ show v+> loc v = "var" ++ show v++> quickcall fn = "_do_" ++ showC fn+> thunk fn = "_wrap_" ++ showC fn++> compileBody :: FunCode -> String+> compileBody (Code args bytecode) = +> let (code, b) = runState (cgs bytecode) 0 in+> if (b>0) then "void** block;\n" ++ code else code -- = EMALLOC("++show b++"*sizeof(void*));\n"++code else code+> where+> sizeneeded x = do+> max <- get+> if (x>max) then put x else return ()++> cgs [] = return ""+> cgs (x:xs) = do xc <- cg x+> xsc <- cgs xs+> return $ xc ++ "\n" ++ xsc++> cg (CALL t fn args) = return $ tmp t ++ " = " ++ quickcall fn ++ +> targs "(" args ++ ");"+> cg (TAILCALL t fn args) = return $ "return " ++ quickcall fn ++ +> targs "(" args ++ ");"+> cg (THUNK t ar fn []) = do+> return $ tmp t ++ +> " = (void*)CLOSURE(" ++ thunk fn ++ ", " ++ +> show ar ++ ", 0, 0);"+> cg (THUNK t ar fn args) = do+> sizeneeded (length args)+> return $ argblock "block" args ++ tmp t ++ +> " = (void*)CLOSURE(" ++ thunk fn ++ ", " ++ +> show ar ++ "," ++ show (length args) ++ +> ", block);"+> cg (ADDARGS t th args) = do sizeneeded (length args)+> return $ closureApply t th args+> cg (FOREIGN ty t fn args) = return $ +> castFrom t ty +> (fn ++ "(" ++ foreignArgs args ++ ")")+> ++ ";"+> cg (VAR t l) = return $ tmp t ++ " = " ++ loc l ++ ";"+> cg (ASSIGN l t) = return $ loc l ++ " = " ++ tmp t ++ ";"+> cg (CON t tag args) = do sizeneeded (length args)+> return $ constructor t tag args+> cg (UNIT t) = return $ tmp t ++ " = MKUNIT;"+> cg (INT t i) = return $ "ASSIGNINT("++tmp t ++ ", " ++show i++");"+> cg (BIGINT t i) = return $ tmp t ++ " = NEWBIGINT(\"" ++show i++"\");"+> cg (FLOAT t i) = return $ tmp t ++ " = MKFLOAT("++show i++");"+> cg (BIGFLOAT t i) = return $ tmp t ++ " = NEWBIGFLOAT(\""++show i++"\");"+> cg (STRING t s) = return $ tmp t ++ " = MKSTR("++show s++");"+> cg (PROJ t1 t2 i) = return $ tmp t1 ++ " = PROJECT((Closure*)"++tmp t2++", "++show i++");"+> cg (PROJVAR l t i) = return $ loc l ++ " = PROJECT((Closure*)"++tmp t++", "++show i++");"+> cg (OP t op l r) = return $ doOp t op l r +> cg (LOCALS n) = return $ declare "void* " loc (length args) n+> cg (TMPS n) = return $ declare "void* " tmp 0 n+> cg (CASE v alts def) = do+> altscode <- cgalts alts def 0+> return $ "assert(ISCON("++tmp v++"));\n" +++> "switch(TAG(" ++ tmp v ++")) {\n" +++> altscode+> ++ "}"+> cg (IF v t e) = do+> tcode <- cgs t+> ecode <- cgs e+> return $ "assert(ISINT("++tmp v++"));\n" +++> "if (GETINT("++tmp v++")) {\n" ++ tcode ++ "} else {\n" +++> ecode ++ "}"+> cg (EVAL v) = return $ tmp v ++ "=(void*)EVAL((VAL)"++tmp v++");"+> cg (RETURN t) = return $ "return "++tmp t++";"+> cg DRETURN = return $ "return NULL;"+> cg (ERROR s) = return $ "ERROR("++show s++");"+> cg (TRACE s args) = return $ "TRACE {\n\tprintf(\"%s\\n\", " ++ show s ++ ");\n" +++> concat (map dumpClosure args) ++ " }"+> where dumpClosure i +> = "\tdumpClosure(" ++ loc i ++ "); printf(\"--\\n\");\n"+> -- cg x = return $ "NOP; // not done " ++ show x++> cgalts [] def _ = +> case def of +> Nothing -> return $ ""+> (Just bc) -> do bcode <- cgs bc+> return $ "default:\n" ++ bcode ++ "break;\n"+> cgalts ((t,bc):alts) def tag+> = do bcode <- cgs bc+> altscode <- cgalts alts def (tag+1)+> return $ "case "++ show t ++":\n" +++> bcode ++ "break;\n" ++ altscode++> targs st [] = st+> targs st [x] = st ++ tmp x+> targs st (x:xs) = st ++ tmp x ++ targs ", " xs++> argblock name [] = name ++ " = 0;\n"+> argblock name args = name ++ " = EMALLOC(sizeof(void*)*" ++ show (length args) ++ ");\n" ++ +> ab name args 0+> ab nm [] i = ""+> ab nm (x:xs) i = nm ++ "[" ++ show i ++ "] = " ++ tmp x ++";\n" ++ +> ab nm xs (i+1)++> constructor t tag []+> = tmp t ++ " = CONSTRUCTOR(" +++> show tag ++ ", 0, 0);"+> constructor t tag args +> | length args < 3 && length args > 0+> = tmp t ++ " = CONSTRUCTOR" ++ show (length args) ++ "(" +++> show tag ++ targs ", " args ++ ");"+> constructor t tag args = argblock "block" args ++ tmp t +++> " = (void*)CONSTRUCTOR(" ++ +> show tag ++ ", " ++ +> show (length args) +++> ", block);"++> closureApply t th []+> = tmp t ++ " = CLOSURE_APPLY((VAL)" +++> tmp th ++ ", 0, 0);"+> closureApply t th args +> | length args < 3 && length args > 0+> = tmp t ++ " = CLOSURE_APPLY" ++ show (length args) ++ "((VAL)" +++> tmp th ++ targs ", " args ++ ");"+> closureApply t th args = argblock "block" args ++ tmp t ++ +> " = CLOSURE_APPLY((VAL)" ++ +> tmp th ++ ", " ++ +> show (length args) ++ +> ", block);"++> declare decl fn start end +> | start == end = ""+> | otherwise = decl ++ fn start ++";\n" +++> declare decl fn (start+1) end++> foreignArgs [] = ""+> foreignArgs [x] = foreignArg x+> foreignArgs (x:xs) = foreignArg x ++ ", " ++ foreignArgs xs++> castFrom t TyUnit x = tmp t ++ " = NULL; " ++ x+> castFrom t TyString rest = tmp t ++ " = MKSTR((char*)(" ++ rest ++ "))"+> castFrom t TyPtr rest = tmp t ++ " = MKPTR(" ++ rest ++ ")"+> castFrom t TyInt rest = tmp t ++ " = MKINT((int)(" ++ rest ++ "))"+> castFrom t TyBigInt rest = tmp t ++ " = MKBIGINT((mpz_t*)(" ++ rest ++ "))"+> castFrom t _ rest = tmp t ++ " = (void*)(" ++ rest ++ ")"++> foreignArg (t, TyInt) = "GETINT("++ tmp t ++")"+> foreignArg (t, TyBigInt) = "*(GETBIGINT("++ tmp t ++"))"+> foreignArg (t, TyString) = "GETSTR("++ tmp t ++")"+> foreignArg (t, TyPtr) = "GETPTR("++ tmp t ++")"+> foreignArg (t, _) = tmp t++> doOp t Plus l r = tmp t ++ " = INTOP(+,"++tmp l ++ ", "++tmp r++");"+> doOp t Minus l r = tmp t ++ " = INTOP(-,"++tmp l ++ ", "++tmp r++");"+> doOp t Times l r = tmp t ++ " = INTOP(*,"++tmp l ++ ", "++tmp r++");"+> doOp t Divide l r = tmp t ++ " = INTOP(/,"++tmp l ++ ", "++tmp r++");"+> doOp t OpEQ l r = tmp t ++ " = INTOP(==,"++tmp l ++ ", "++tmp r++");"+> doOp t OpGT l r = tmp t ++ " = INTOP(>,"++tmp l ++ ", "++tmp r++");"+> doOp t OpLT l r = tmp t ++ " = INTOP(<,"++tmp l ++ ", "++tmp r++");"+> doOp t OpGE l r = tmp t ++ " = INTOP(>=,"++tmp l ++ ", "++tmp r++");"+> doOp t OpLE l r = tmp t ++ " = INTOP(<=,"++tmp l ++ ", "++tmp r++");"+
+ Epic/Compiler.lhs view
@@ -0,0 +1,151 @@+> -- | +> -- Module : EMachine.Compiler+> -- Copyright : Edwin Brady+> -- Licence : BSD-style (see LICENSE in the distribution)+> --+> -- Maintainer : eb@dcs.st-and.ac.uk+> -- Stability : experimental+> -- Portability : portable+> -- +> -- Public interface for Epigram Supercombinator Compiler++> module Epic.Compiler(CompileOptions(..),+> compile, +> compileOpts, +> link) where++Brings everything together; parsing, checking, code generation++> import System+> import System.IO+> import System.Directory+> import System.Environment++> import Epic.Language+> import Epic.Parser+> import Epic.Scopecheck+> import Epic.CodegenC++> import Paths_epic++> -- | (Debugging) options to give to compiler+> data CompileOptions = KeepC -- ^ Keep intermediate C file+> | Trace -- ^ Generate trace at run-time (debug)+> | ShowBytecode -- ^ Show generated code+> | ShowParseTree -- ^ Show parse tree+> | GCCOpt String -- ^ Extra GCC option+> deriving Eq++> addGCC :: [CompileOptions] -> String+> addGCC [] = ""+> addGCC ((GCCOpt s):xs) = s ++ " " ++ addGCC xs+> addGCC (_:xs) = addGCC xs++> doTrace opts | elem Trace opts = " -DTRACEON"+> | otherwise = ""++> -- |Compile a source file in supercombinator language to a .o+> compile :: FilePath -- ^ Input file name+> -> FilePath -- ^ Output file name+> -> Maybe FilePath -- ^ Interface (.ei) file name, if desired+> -> IO ()+> compile fn outf iface+> = compileOpts fn outf iface []++Chop off everything after the last / - get the directory a file is in++> trimLast f = case span (\x -> x /= '/') (reverse f) of+> (eman, htap) -> reverse htap++> compileOpts :: FilePath -- ^ Input file name+> -> FilePath -- ^ Output file name+> -> Maybe FilePath -- ^ Interface (.ei) file name, if desired+> -> [CompileOptions] -- Keep the C file+> -> IO ()+> compileOpts fn outf iface opts+> = do input <- readFile fn+> -- prelude <- readFile (libdir ++ "/Prelude.e")+> let s = parse input fn+> case s of+> Failure err _ _ -> fail err+> Success ds -> do+> (tmpn,tmph) <- tempfile+> checked <- compileDecls (checkAll ds) tmph+> fp <- getDataFileName "evm/closure.h"+> let libdir = trimLast fp+> let cmd = "gcc -c -O2 -foptimize-sibling-calls -x c " ++ tmpn ++ " -I" ++ libdir ++ " -o " ++ outf ++ " " ++ addGCC opts ++ doTrace opts+> -- putStrLn $ cmd+> -- putStrLn $ fp+> exit <- system cmd+> if (elem KeepC opts)+> then do system $ "cp " ++ tmpn ++ " " ++ +> (getRoot fn) ++ ".c"+> return ()+> else return ()+> -- removeFile tmpn+> if (exit /= ExitSuccess) +> then fail $ "gcc failed"+> else return ()+> case iface of+> Nothing -> return ()+> (Just fn) -> do writeFile fn (writeIFace checked)++> getRoot fn = case span (/='.') fn of+> (stem,_) -> stem+++> compileDecls (Success (ctxt, decls)) outh+> = do hPutStr outh $ codegenC ctxt decls+> hFlush outh+> hClose outh+> return decls+> compileDecls (Failure err _ _) _ = fail err++> -- |Link a collection of .o files into an executable+> link :: [FilePath] -- ^ Object files+> -> [FilePath] -- ^ Extra include files for main program+> -> FilePath -- ^ Executable filename+> -> IO ()+> link infs extraIncs outf = do+> mainprog <- mkMain extraIncs +> fp <- getDataFileName "evm/closure.h"+> let libdir = trimLast fp+> let cmd = "gcc -x c -O2 -foptimize-sibling-calls " ++ mainprog ++ " -x none -L" +++> libdir++" -I"++libdir ++ " " +++> (concat (map (++" ") infs)) ++ +> " -levm -lgc -lpthread -lgmp -o "++outf+> -- putStrLn $ cmd+> exit <- system cmd+> if (exit /= ExitSuccess)+> then fail $ "Linking failed"+> else return ()++Output the main progam, adding any extra includes needed. +(Some libraries need the extra includes, notably SDL, to compile correctly.+Grr.)++> mkMain :: [FilePath] -> IO FilePath+> mkMain extra = +> do mppath <- getDataFileName "evm/mainprog.c"+> mp <- readFile mppath+> (tmp, tmpH) <- tempfile+> hPutStr tmpH (concat (map (\x -> "#include <" ++ x ++ ">\n") extra))+> hPutStr tmpH mp+> hClose tmpH+> return tmp++ -- |Get the path where the required C libraries and include files are stored+ libdir :: FilePath+ libdir = libprefix ++ "/lib/evm"++> tempfile :: IO (FilePath, Handle)+> tempfile = do env <- environment "TMPDIR"+> let dir = case env of+> Nothing -> "/tmp"+> (Just d) -> d+> openTempFile dir "esc"++> environment :: String -> IO (Maybe String)+> environment x = catch (do e <- getEnv x+> return (Just e))+> (\_ -> return Nothing)
+ Epic/Language.lhs view
@@ -0,0 +1,165 @@+> module Epic.Language where++> import Control.Monad++Raw data types. Int, Char, Bool are unboxed.++> data Type = TyInt+> | TyChar+> | TyBool+> | TyFloat+> | TyBigInt+> | TyBigFloat+> | TyString+> | TyPtr+> | TyUnit+> | TyAny -- unchecked, polymorphic+> | TyData -- generic data type+> | TyFun -- any function+> deriving Eq++> instance Show Type where+> show TyInt = "Int"+> show TyChar = "Char"+> show TyBool = "Bool"+> show TyFloat = "Float"+> show TyBigInt = "BigInt"+> show TyBigFloat = "BigFloat"+> show TyString = "String"+> show TyPtr = "Ptr"+> show TyUnit = "Unit"+> show TyAny = "Any"+> show TyData = "Data"+> show TyFun = "Fun"++> data Const = MkInt Int+> | MkBigInt Integer+> | MkChar Char+> | MkFloat Float+> | MkBigFloat Double+> | MkString String+> | MkBool Bool+> | MkUnit+> deriving (Show, Eq)++> data Name = UN String -- user name+> | MN String Int -- machine generated name+> deriving Eq++> instance Show Name where+> show (UN str) = "_U_"++str+> show (MN str i) = "_M_"++show i++"_"++str++> showuser (UN str) = str+> showuser (MN str i) = "["++str++"_"++show i++"]"++> quotename [] = ""+> quotename ('_':cs) = "__"++quotename cs+> quotename ('\'':cs) = "_PR_"++quotename cs+> quotename ('?':cs) = "_QU_"++quotename cs+> quotename ('$':cs) = "_DO_"++quotename cs+> quotename ('#':cs) = "_HA_"++quotename cs+> quotename ('@':cs) = "_AT_"++quotename cs+> quotename (c:cs) = c:(quotename cs)++> showC n = quotename (show n)++> type Context = [(Name,([Type],Type))] -- Name, arg types, return type++Get the arity of a definition in the context++> arity x ctxt = case lookup x ctxt of+> Nothing -> error $ "No such function " ++ show x+> (Just (args,ret)) -> length args++> type Tag = Int++> data Expr = V Int -- Locally bound name+> | R Name -- Global reference+> | App Expr [Expr] -- Function application+> | LazyApp Expr [Expr] -- Lazy function application+> | Con Tag [Expr] -- Constructor, tags, arguments (fully applied)+> | Const Const -- a constant+> | Proj Expr Int -- Project argument+> | Case Expr [CaseAlt]+> | If Expr Expr Expr+> | Op Op Expr Expr -- Infix operator+> | Let Name Type Expr Expr -- Let binding+> | Error String -- Exit with error message+> | Impossible -- Claimed impossible to reach code+> | ForeignCall Type String [(Expr, Type)] -- Foreign function call+> deriving (Show, Eq)++> data CaseAlt = Alt { alt_tag :: Tag,+> alt_args :: [(Name, Type)], -- bound arguments+> alt_expr :: Expr -- what to do+> }+> | DefaultCase { alt_expr :: Expr }+> deriving (Show, Eq)++> instance Ord CaseAlt where -- only the tag matters+> compare (Alt t1 _ _) (Alt t2 _ _) = compare t1 t2+> compare (Alt _ _ _) (DefaultCase _) = LT+> compare (DefaultCase _) (Alt _ _ _) = GT+> compare _ _ = EQ++> data Op = Plus | Minus | Times | Divide | OpEQ | OpLT | OpLE | OpGT | OpGE+> deriving (Show, Eq)++Supercombinator definitions++> data Func = Bind { fun_args :: [(Name, Type)],+> locals :: Int, -- total number of locals+> defn :: Expr }+> deriving Show++Programs++> data Decl = Decl { fname :: Name,+> frettype :: Type,+> fdef :: Func }+> | Extern { fname :: Name, +> frettype :: Type,+> fargs :: [Type] }+> | Include String+> | Link String+> deriving Show++> data Result r = Success r+> | Failure String String Int+> deriving (Show, Eq)+> +> instance Monad Result where+> (Success r) >>= k = k r+> (Failure err fn line) >>= k = Failure err fn line+> return = Success+> fail s = Failure s "(no file)" 0+> +> instance MonadPlus Result where+> mzero = Failure "Error" "(no file)" 0+> mplus (Success x) _ = (Success x)+> mplus (Failure _ _ _) y = y+> ++++Some tests+++foo x = let y = case x of+ c1 a b -> a b+ c2 c -> bar (c+2)+ in y+3+++++ testctxt = [((UN "foo"),([TyData], TyInt)),+ ((UN "bar"),([TyInt], TyInt))]++ testprog = Bind [TyData] 3 $+ Let (UN "y") TyInt (Case (V 0)+ [Alt 0 [TyFun,TyInt] (App (V 1) [V 2]),+ Alt 1 [TyInt] (App (R (UN "bar")) [Op Plus (V 1) (Const (MkInt 2))])])+ (Op Plus (V 1) (Const (MkInt 3)))+
+ Epic/Lexer.lhs view
@@ -0,0 +1,267 @@+> module Epic.Lexer where++> import Char++> import Epic.Language++> type LineNumber = Int+> type P a = String -> String -> LineNumber -> Result a+ +> getLineNo :: P LineNumber+> getLineNo = \s fn l -> Success l+ +> getFileName :: P String+> getFileName = \s fn l -> Success fn+ +> getContent :: P String+> getContent = \s fn l -> Success s+ +> thenP :: P a -> (a -> P b) -> P b+> m `thenP` k = \s fn l ->+> case m s fn l of+> Success a -> k a s fn l+> Failure e f ln -> Failure e f ln+ +> returnP :: a -> P a+> returnP a = \s fn l -> Success a+> +> failP :: String -> P a+> failP err = \s fn l -> Failure err fn l+ +> catchP :: P a -> (String -> P a) -> P a+> catchP m k = \s fn l ->+> case m s fn l of+> Success a -> Success a+> Failure e f ln -> k e s fn l+ +> happyError :: P a+> happyError = reportError "Parse error"+ +> reportError :: String -> P a+> reportError err = getFileName `thenP` \fn ->+> getLineNo `thenP` \line ->+> getContent `thenP` \content ->+> failP (fn ++ ":" ++ show line ++ ":" ++ err ++ " at " ++ take 40 content ++ " ...")+ +> data Token +> = TokenName Name+> | TokenString String+> | TokenInt Int+> | TokenFloat Float+> | TokenBigInt Integer+> | TokenBigFloat Double+> | TokenChar Char+> | TokenBool Bool+> | TokenIntType+> | TokenBigIntType+> | TokenCharType+> | TokenBoolType+> | TokenFloatType+> | TokenBigFloatType+> | TokenStringType+> | TokenPtrType+> | TokenUnitType+> | TokenAnyType+> | TokenDataType+> | TokenFunType+> | TokenForeign+> | TokenCInclude+> | TokenLink+> | TokenOB+> | TokenCB+> | TokenOCB+> | TokenCCB+> | TokenPlus+> | TokenMinus+> | TokenTimes+> | TokenDivide+> | TokenEquals+> | TokenEQ+> | TokenGE+> | TokenLE+> | TokenGT+> | TokenLT+> | TokenArrow+> | TokenColon+> | TokenUnit+> | TokenCon+> | TokenDefault+> | TokenLet+> | TokenCase+> | TokenOf+> | TokenIf+> | TokenThen+> | TokenElse+> | TokenIn+> | TokenLazy+> | TokenError+> | TokenImpossible+> | TokenProj+> | TokenSemi+> | TokenComma+> | TokenBar+> | TokenExtern+> | TokenInclude+> | TokenEOF+> deriving (Show, Eq)+> +> +> lexer :: (Token -> P a) -> P a+> lexer cont [] = cont TokenEOF []+> lexer cont ('\n':cs) = \fn line -> lexer cont cs fn (line+1)+> lexer cont (c:cs)+> | isSpace c = \fn line -> lexer cont cs fn line+> | isAlpha c = lexVar cont (c:cs)+> | isDigit c = lexNum cont (c:cs)+> | c == '_' = lexVar cont (c:cs)+> lexer cont ('"':cs) = lexString cont cs+> lexer cont ('\'':cs) = lexChar cont cs+> lexer cont ('{':'-':cs) = lexerEatComment 0 cont cs+> lexer cont ('-':'-':cs) = lexerEatToNewline cont cs+> lexer cont ('-':'>':cs) = cont TokenArrow cs+> lexer cont ('(':cs) = cont TokenOB cs+> lexer cont (')':cs) = cont TokenCB cs+> lexer cont ('{':cs) = cont TokenOCB cs+> lexer cont ('}':cs) = cont TokenCCB cs+> lexer cont ('+':cs) = cont TokenPlus cs+> lexer cont ('-':cs) = cont TokenMinus cs+> lexer cont ('*':cs) = cont TokenTimes cs+> lexer cont ('/':cs) = cont TokenDivide cs+> lexer cont ('=':'=':cs) = cont TokenEQ cs+> lexer cont ('>':'=':cs) = cont TokenGE cs+> lexer cont ('<':'=':cs) = cont TokenLE cs+> lexer cont ('>':cs) = cont TokenGT cs+> lexer cont ('<':cs) = cont TokenLT cs+> lexer cont ('=':cs) = cont TokenEquals cs+> lexer cont (':':cs) = cont TokenColon cs+> lexer cont ('!':cs) = cont TokenProj cs+> lexer cont (';':cs) = cont TokenSemi cs+> lexer cont (',':cs) = cont TokenComma cs+> lexer cont ('|':cs) = cont TokenBar cs+> lexer cont ('%':cs) = lexSpecial cont cs+> lexer cont (c:cs) = lexError c cs+ +> lexError c s l = failP (show l ++ ": Unrecognised token '" ++ [c] ++ "'\n") s l++> lexerEatComment nls cont ('-':'}':cs)+> = \fn line -> lexer cont cs fn (line+nls)+> lexerEatComment nls cont ('\n':cs) = lexerEatComment (nls+1) cont cs+> lexerEatComment nls cont (c:cs) = lexerEatComment nls cont cs+> +> lexerEatToNewline cont ('\n':cs)+> = \fn line -> lexer cont cs fn (line+1)+> lexerEatToNewline cont (c:cs) = lexerEatToNewline cont cs++> lexNum cont cs = case readNum cs of+> (num,'L':rest,isreal) ->+> cont (tok True num isreal) rest+> (num,rest,isreal) ->+> cont (tok False num isreal) rest+> where tok False num isreal | isreal = TokenFloat (read num)+> | otherwise = TokenInt (read num)+> tok True num isreal | isreal = TokenBigFloat (read num)+> | otherwise = TokenBigInt (read num)++> readNum :: String -> (String,String,Bool)+> readNum x = rn' False "" x+> where rn' dot acc [] = (acc,[],dot)+> rn' False acc ('.':xs) | head xs /= '.' = rn' True (acc++".") xs+> rn' dot acc (x:xs) | isDigit x = rn' dot (acc++[x]) xs+> rn' dot acc ('e':'+':xs) = rn' True (acc++"e+") xs+> rn' dot acc ('e':'-':xs) = rn' True (acc++"e-") xs+> rn' dot acc ('e':xs) = rn' True (acc++"e") xs+> rn' dot acc xs = (acc,xs,dot)++> lexString cont cs =+> \fn line ->+> case getstr cs of+> Just (str,rest,nls) -> cont (TokenString str) rest fn (nls+line)+> Nothing -> failP (fn++":"++show line++":Unterminated string contant")+> cs fn line++> lexChar cont cs =+> \fn line ->+> case getchar cs of+> Just (str,rest) -> cont (TokenChar str) rest fn line+> Nothing -> +> failP (fn++":"++show line++":Unterminated character constant")+> cs fn line++> isAllowed c = isAlpha c || isDigit c || c `elem` "_\'?#"++> lexVar cont cs =+> case span isAllowed cs of+> -- Keywords+> ("Default",rest) -> cont TokenDefault rest+> -- Types+> ("Int",rest) -> cont TokenIntType rest+> ("Char",rest) -> cont TokenCharType rest+> ("Bool",rest) -> cont TokenBoolType rest+> ("Float",rest) -> cont TokenFloatType rest+> ("BigInt",rest) -> cont TokenBigIntType rest+> ("BigFloat",rest) -> cont TokenBigFloatType rest+> ("String",rest) -> cont TokenStringType rest+> ("Ptr",rest) -> cont TokenPtrType rest+> ("Unit",rest) -> cont TokenUnitType rest+> ("Data",rest) -> cont TokenDataType rest+> ("Fun",rest) -> cont TokenFunType rest+> ("Any",rest) -> cont TokenAnyType rest+> -- values+> ("unit",rest) -> cont TokenUnit rest+> ("Con",rest) -> cont TokenCon rest+> ("true",rest) -> cont (TokenBool True) rest+> ("false",rest) -> cont (TokenBool False) rest+> -- expressions+> ("let",rest) -> cont TokenLet rest+> ("case",rest) -> cont TokenCase rest+> ("of",rest) -> cont TokenOf rest+> ("if",rest) -> cont TokenIf rest+> ("then",rest) -> cont TokenThen rest+> ("else",rest) -> cont TokenElse rest+> ("in",rest) -> cont TokenIn rest+> ("lazy",rest) -> cont TokenLazy rest+> ("error",rest) -> cont TokenError rest+> ("impossible",rest) -> cont TokenImpossible rest+> ("foreign",rest) -> cont TokenForeign rest+> -- declarations+> ("extern",rest) -> cont TokenExtern rest+> ("include",rest) -> cont TokenInclude rest+> (var,rest) -> cont (mkname var) rest+ +> lexSpecial cont cs =+> case span isAllowed cs of+> ("include",rest) -> cont TokenCInclude rest+> ("link",rest) -> cont TokenLink rest+> (thing,rest) -> lexError '%' rest+ +> mkname :: String -> Token+> mkname c = TokenName (UN c)++> getstr :: String -> Maybe (String,String,Int)+> getstr cs = case getstr' "" cs 0 of+> Just (str,rest,nls) -> Just (reverse str,rest,nls)+> _ -> Nothing+> getstr' acc ('\"':xs) = \nl -> Just (acc,xs,nl)+> getstr' acc ('\\':'n':xs) = getstr' ('\n':acc) xs -- Newline+> getstr' acc ('\\':'r':xs) = getstr' ('\r':acc) xs -- CR+> getstr' acc ('\\':'t':xs) = getstr' ('\t':acc) xs -- Tab+> getstr' acc ('\\':'b':xs) = getstr' ('\b':acc) xs -- Backspace+> getstr' acc ('\\':'a':xs) = getstr' ('\a':acc) xs -- Alert+> getstr' acc ('\\':'f':xs) = getstr' ('\f':acc) xs -- Formfeed+> getstr' acc ('\\':'0':xs) = getstr' ('\0':acc) xs -- null+> getstr' acc ('\\':x:xs) = getstr' (x:acc) xs -- Literal+> getstr' acc ('\n':xs) = \nl ->getstr' ('\n':acc) xs (nl+1) -- Count the newline+> getstr' acc (x:xs) = getstr' (x:acc) xs+> getstr' _ _ = \nl -> Nothing+ +> getchar :: String -> Maybe (Char,String)+> getchar ('\\':'n':'\'':xs) = Just ('\n',xs) -- Newline+> getchar ('\\':'r':'\'':xs) = Just ('\r',xs) -- CR+> getchar ('\\':'t':'\'':xs) = Just ('\t',xs) -- Tab+> getchar ('\\':'b':'\'':xs) = Just ('\b',xs) -- Backspace+> getchar ('\\':'a':'\'':xs) = Just ('\a',xs) -- Alert+> getchar ('\\':'f':'\'':xs) = Just ('\f',xs) -- Formfeed+> getchar ('\\':'0':'\'':xs) = Just ('\0',xs) -- null+> getchar ('\\':x:'\'':xs) = Just (x,xs) -- Literal+> getchar (x:'\'':xs) = Just (x,xs)+> getchar _ = Nothing
+ Epic/OTTLang.lhs view
@@ -0,0 +1,20 @@+> module Epic.OTTLang where++> import Epic.Language++Terms++t = x | lam x. t | t t+ | i t | hd(t) | tl(t) | + | switch(t) [t]+ | TY++> data OTTerm = OTRef Name -- Global or unresolved name+> | OTV Int -- Locally bound name+> | OTLam Name+> | OTApp OTTerm OTTerm+> | OTRec Tag OTTerm+> | OTHd OTTerm+> | OTTl OTTerm+> | OTSwitch OTTerm [OTTerm]+> | OTTY -- can't look at types, so dump them all here
+ Epic/Parser.y view
@@ -0,0 +1,218 @@+{ -- -*-Haskell-*-+{-# OPTIONS_GHC -fglasgow-exts #-}++module Epic.Parser where++import Char+import System.IO.Unsafe++import Epic.Language+import Epic.Lexer++}++%name mkparse Program++%tokentype { Token }+%monad { P } { thenP } { returnP }+%lexer { lexer } { TokenEOF }+++%token + name { TokenName $$ }+ string { TokenString $$ }+ int { TokenInt $$ }+ bigint { TokenBigInt $$ }+ bool { TokenBool $$ }+ float { TokenFloat $$ }+ bigfloat { TokenBigFloat $$ }+ char { TokenChar $$ }+ inttype { TokenIntType }+ biginttype { TokenBigIntType }+ chartype { TokenCharType }+ booltype { TokenBoolType }+ floattype { TokenFloatType }+ bigfloattype { TokenBigFloatType }+ stringtype { TokenStringType }+ ptrtype { TokenPtrType }+ unittype { TokenUnitType }+ funtype { TokenFunType }+ datatype { TokenDataType }+ anytype { TokenAnyType }+ unit { TokenUnit }+ con { TokenCon }+ default { TokenDefault }+ let { TokenLet }+ case { TokenCase }+ of { TokenOf }+ if { TokenIf }+ then { TokenThen }+ else { TokenElse }+ in { TokenIn }+ lazy { TokenLazy }+ foreign { TokenForeign }+ errorcode { TokenError }+ impossible { TokenImpossible }+ '(' { TokenOB }+ ')' { TokenCB }+ '{' { TokenOCB }+ '}' { TokenCCB }+ '+' { TokenPlus }+ '-' { TokenMinus }+ '*' { TokenTimes }+ '/' { TokenDivide }+ '=' { TokenEquals }+ eq { TokenEQ }+ le { TokenLE }+ ge { TokenGE }+ '<' { TokenLT }+ '>' { TokenGT }+ ':' { TokenColon }+ '!' { TokenProj }+ ';' { TokenSemi }+ ',' { TokenComma }+ '|' { TokenBar }+ arrow { TokenArrow }+ cinclude { TokenCInclude }+ extern { TokenExtern }+ include { TokenInclude }++%nonassoc NONE+%nonassoc lazy+%left LET+%left IF+%left eq+%left ';'+%left '<' '>' le ge+%left '+' '-'+%left '*' '/'+%nonassoc '!'+%nonassoc '('+++%%++Program :: { [Decl] }+Program: Declaration { [$1] }+ | Declaration Program { $1:$2 }+ | include string Program File {%+ let rest = $3 in+ let pt = unsafePerformIO (readFile $2) in+ case (parse pt $4) of+ Success x -> returnP (x ++ rest)+ Failure err file ln -> failP err+ }++Type :: { Type }+Type : inttype { TyInt }+ | biginttype { TyBigInt }+ | chartype { TyChar }+ | booltype { TyBool }+ | floattype { TyFloat }+ | bigfloattype { TyBigFloat }+ | stringtype { TyString }+ | ptrtype { TyPtr }+ | unittype { TyUnit }+ | anytype { TyAny }+ | datatype { TyData }+ | funtype { TyFun }++Declaration :: { Decl }+Declaration: name '(' TypeList ')' arrow Type '=' Expr+ { mkBind $1 (map snd $3) $6 (map fst $3) $8 }+ | extern name '(' TypeList ')' arrow Type+ { mkExtern $2 (map snd $4) $7 (map fst $4) }+ | cinclude string { Include $2 }+++TypeList :: { [(Name,Type)] }+TypeList : { [] }+ | name ':' Type { [($1,$3)] }+ | name ':' Type ',' TypeList { ($1,$3):$5 }++Expr :: { Expr }+Expr : name { R $1 }+ | '(' Expr ')' { $2 }+ | Expr '(' ExprList ')' { App $1 $3 }+ | lazy '(' Expr '(' ExprList ')' ')' { LazyApp $3 $5 }+ | lazy '(' name ')' { LazyApp (R $3) [] }+ | con int '(' ExprList ')' { Con $2 $4 }+ | Const { Const $1 }+ | Expr '!' int { Proj $1 $3 }+ | let name ':' Type '=' Expr in Expr %prec LET { Let $2 $4 $6 $8 }+ | Expr ';' Expr { Let (MN "unused" 0) TyUnit $1 $3 }+ | if Expr then Expr else Expr %prec IF { If $2 $4 $6 }+ | CaseExpr { $1 }+ | MathExpr { $1 }+ | errorcode string { Error $2 }+ | impossible { Impossible }+ | foreign Type string '(' ExprTypeList ')' + { ForeignCall $2 $3 $5 }++CaseExpr :: { Expr }+CaseExpr : case Expr of '{' Alts '}' { Case $2 $5 }++Alts :: { [CaseAlt] }+Alts : { [] }+ | Alt { [$1] }+ | Alt '|' Alts { $1:$3 }++Alt :: { CaseAlt }+Alt : con int '(' TypeList ')' arrow Expr + { Alt $2 $4 $7 }+ | default arrow Expr { DefaultCase $3 }++MathExpr :: { Expr }+MathExpr : Expr '+' Expr { Op Plus $1 $3 }+ | Expr '-' Expr { Op Minus $1 $3 }+ | Expr '*' Expr { Op Times $1 $3 }+ | Expr '/' Expr { Op Divide $1 $3 }+ | Expr '<' Expr { Op OpLT $1 $3 }+ | Expr '>' Expr { Op OpGT $1 $3 }+ | Expr le Expr { Op OpLE $1 $3 }+ | Expr ge Expr { Op OpGE $1 $3 }+ | Expr eq Expr { Op OpEQ $1 $3 }++ExprList :: { [Expr] }+ExprList : { [] }+ | Expr { [$1] }+ | Expr ',' ExprList { $1:$3 }++ExprTypeList :: { [(Expr,Type)] }+ExprTypeList : { [] }+ | Expr ':' Type { [($1,$3)] }+ | Expr ':' Type ',' ExprTypeList { ($1,$3):$5 }++Const :: { Const }+Const : int { MkInt $1 }+ | bigint { MkBigInt $1 }+ | char { MkChar $1 }+ | bool { MkBool $1 }+ | float { MkFloat $1 }+ | bigfloat { MkBigFloat $1 }+ | string { MkString $1 }+ | unit { MkUnit }++Line :: { LineNumber }+ : {- empty -} {% getLineNo }++File :: { String } + : {- empty -} %prec NONE {% getFileName }++{++mkBind :: Name -> [Type] -> Type -> [Name] -> Expr -> Decl+mkBind n tys ret ns expr = Decl n ret (Bind (zip ns tys) 0 expr)++mkExtern :: Name -> [Type] -> Type -> [Name] -> Decl+mkExtern n tys ret ns = Extern n ret tys++parse :: String -> FilePath -> Result [Decl]+parse s fn = mkparse s fn 1++parseFile :: FilePath -> IO (Result [Decl])+parseFile fn = do s <- readFile fn+ let x = parse s fn+ return x++}
+ Epic/Scopecheck.lhs view
@@ -0,0 +1,101 @@+> module Epic.Scopecheck where++Check that an expression has all its names in scope. This is the only+checking we do (for now).++> import Control.Monad.State++> import Epic.Language+> import Epic.Parser++> checkAll :: Monad m => [Decl] -> m (Context, [Decl])+> checkAll xs = do let ctxt = mkContext xs+> ds <- ca (mkContext xs) xs+> return (ctxt,ds)+> where ca ctxt [] = return []+> ca ctxt ((Decl nm rt fn):xs) = +> do fn' <- scopecheck ctxt fn+> xs' <- ca ctxt xs+> return $ (Decl nm rt fn'):xs'+> ca ctxt (x:xs) =+> do xs' <- ca ctxt xs+> return (x:xs')++> mkContext [] = []+> mkContext ((Decl nm rt (Bind args _ _)):xs) =+> (nm,(map snd args, rt)):(mkContext xs)+> mkContext ((Extern nm rt args):xs) =+> (nm,(args, rt)):(mkContext xs)+> mkContext (_:xs) = mkContext xs++> scopecheck :: Monad m => Context -> Func -> m Func+> scopecheck ctxt (Bind args locs exp) = do+> (exp', locs') <- runStateT (tc (v_ise args 0) exp) (length args)+> return $ Bind args locs' exp'+> where+> tc env (R n) = case lookup n env of+> Nothing -> case lookup n ctxt of+> Nothing -> return $ Const (MkInt 1234567890)+> -- lift $ fail $ +> -- "Unknown name " ++ showuser n+> (Just _) -> return $ R n+> (Just i) -> return $ V i+> tc env (Let n ty v sc) = do+> v' <- tc env v+> sc' <- tc ((n,length env):env) sc+> maxlen <- get+> put (if (length env + 1)>maxlen +> then (length env + 1) +> else maxlen)+> return $ Let n ty v' sc'+> tc env (Case v alts) = do+> v' <- tc env v+> alts' <- tcalts env alts+> return $ Case v' alts'+> tc env (If a t e) = do+> a' <- tc env a+> t' <- tc env t+> e' <- tc env e+> return $ If a' t' e'+> tc env (App f as) = do+> f' <- tc env f+> as' <- mapM (tc env) as+> return $ App f' as'+> tc env (LazyApp f as) = do+> f' <- tc env f+> as' <- mapM (tc env) as+> return $ LazyApp f' as'+> tc env (Con t as) = do+> as' <- mapM (tc env) as+> return $ Con t as'+> tc env (Proj e i) = do+> e' <- tc env e+> return $ Proj e' i+> tc env (Op op l r) = do+> l' <- tc env l+> r' <- tc env r+> return $ Op op l' r'+> tc env (ForeignCall ty fn args) = do+> argexps' <- mapM (tc env) (map fst args)+> return $ ForeignCall ty fn (zip argexps' (map snd args))+> tc env x = return x++> tcalts env [] = return []+> tcalts env ((Alt tag args expr):alts) = do+> let env' = (v_ise args (length env))++env+> expr' <- tc env' expr+> maxlen <- get+> put (if (length env')>maxlen +> then (length env')+> else maxlen)+> alts' <- tcalts env alts+> return $ (Alt tag args expr'):alts'+> tcalts env ((DefaultCase expr):alts) = do+> expr' <- tc env expr+> alts' <- tcalts env alts+> return $ (DefaultCase expr'):alts'++Turn the argument list into a mapping from names to argument position++> v_ise [] _ = []+> v_ise ((n,ty):args) i = (n,i):(v_ise args (i+1))
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2006 Edwin Brady+ School of Computer Science, University of St Andrews+All rights reserved.++This code is derived from software written by Edwin Brady+(eb@dcs.st-and.ac.uk).++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. None of the names of the copyright holders may be used to endorse+ or promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++*** End of disclaimer. ***
+ Setup.hs view
@@ -0,0 +1,26 @@+import Distribution.Simple+import Distribution.PackageDescription++import System++-- After Epic is built, we need a run time system.++-- FIXME: This is probably all done the wrong way, I don't really understand+-- Cabal properly...++buildLib args flags desc local + = do exit <- system "make -C evm"+ return ()++-- This is a hack. I don't know how to tell cabal that a data file needs+-- installing but shouldn't be in the distribution. And it won't make the+-- distribution if it's not there, so instead I just delete+-- the file after configure.++postConfLib args flags desc local+ = do exit <- system "make -C evm clean"+ return ()++main = defaultMainWithHooks (simpleUserHooks { postBuild = buildLib,+ postConf = postConfLib})+
+ dist/build/Epic/Parser.hs view
@@ -0,0 +1,1178 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+-- -*-Haskell-*-+{-# OPTIONS_GHC -fglasgow-exts #-}++module Epic.Parser where++import Char+import System.IO.Unsafe++import Epic.Language+import Epic.Lexer+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+#else+import Array+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif++-- parser produced by Happy Version 1.16++newtype HappyAbsSyn = HappyAbsSyn (() -> ())+happyIn4 :: ([Decl]) -> (HappyAbsSyn )+happyIn4 x = unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn ) -> ([Decl])+happyOut4 x = unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: (Type) -> (HappyAbsSyn )+happyIn5 x = unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn ) -> (Type)+happyOut5 x = unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: (Decl) -> (HappyAbsSyn )+happyIn6 x = unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn ) -> (Decl)+happyOut6 x = unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: ([(Name,Type)]) -> (HappyAbsSyn )+happyIn7 x = unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn ) -> ([(Name,Type)])+happyOut7 x = unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: (Expr) -> (HappyAbsSyn )+happyIn8 x = unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn ) -> (Expr)+happyOut8 x = unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: (Expr) -> (HappyAbsSyn )+happyIn9 x = unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn ) -> (Expr)+happyOut9 x = unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyIn10 :: ([CaseAlt]) -> (HappyAbsSyn )+happyIn10 x = unsafeCoerce# x+{-# INLINE happyIn10 #-}+happyOut10 :: (HappyAbsSyn ) -> ([CaseAlt])+happyOut10 x = unsafeCoerce# x+{-# INLINE happyOut10 #-}+happyIn11 :: (CaseAlt) -> (HappyAbsSyn )+happyIn11 x = unsafeCoerce# x+{-# INLINE happyIn11 #-}+happyOut11 :: (HappyAbsSyn ) -> (CaseAlt)+happyOut11 x = unsafeCoerce# x+{-# INLINE happyOut11 #-}+happyIn12 :: (Expr) -> (HappyAbsSyn )+happyIn12 x = unsafeCoerce# x+{-# INLINE happyIn12 #-}+happyOut12 :: (HappyAbsSyn ) -> (Expr)+happyOut12 x = unsafeCoerce# x+{-# INLINE happyOut12 #-}+happyIn13 :: ([Expr]) -> (HappyAbsSyn )+happyIn13 x = unsafeCoerce# x+{-# INLINE happyIn13 #-}+happyOut13 :: (HappyAbsSyn ) -> ([Expr])+happyOut13 x = unsafeCoerce# x+{-# INLINE happyOut13 #-}+happyIn14 :: ([(Expr,Type)]) -> (HappyAbsSyn )+happyIn14 x = unsafeCoerce# x+{-# INLINE happyIn14 #-}+happyOut14 :: (HappyAbsSyn ) -> ([(Expr,Type)])+happyOut14 x = unsafeCoerce# x+{-# INLINE happyOut14 #-}+happyIn15 :: (Const) -> (HappyAbsSyn )+happyIn15 x = unsafeCoerce# x+{-# INLINE happyIn15 #-}+happyOut15 :: (HappyAbsSyn ) -> (Const)+happyOut15 x = unsafeCoerce# x+{-# INLINE happyOut15 #-}+happyIn16 :: (LineNumber) -> (HappyAbsSyn )+happyIn16 x = unsafeCoerce# x+{-# INLINE happyIn16 #-}+happyOut16 :: (HappyAbsSyn ) -> (LineNumber)+happyOut16 x = unsafeCoerce# x+{-# INLINE happyOut16 #-}+happyIn17 :: (String) -> (HappyAbsSyn )+happyIn17 x = unsafeCoerce# x+{-# INLINE happyIn17 #-}+happyOut17 :: (HappyAbsSyn ) -> (String)+happyOut17 x = unsafeCoerce# x+{-# INLINE happyOut17 #-}+happyInTok :: Token -> (HappyAbsSyn )+happyInTok x = unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn ) -> Token+happyOutTok x = unsafeCoerce# x+{-# INLINE happyOutTok #-}++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x01\x00\x04\x00\x00\x00\x04\x01\x1f\x01\x21\x01\xe2\x00\x01\x00\x12\x01\x01\x00\x00\x00\xf0\x00\x00\x00\x0d\x01\xe1\x00\xc6\x00\xff\x00\x00\x00\x00\x00\xce\x00\x20\x01\xae\x00\x20\x01\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x20\x01\xd5\x00\xaa\x00\x4b\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xbb\x00\x4b\x00\x4b\x00\x94\x00\x20\x01\xac\x00\x00\x00\x4b\x00\xb0\x00\x00\x00\xa7\x00\x28\x00\x62\x00\x4d\x00\x77\x00\x84\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\xa2\x00\x05\x00\xf6\x00\x00\x00\xed\xff\xed\xff\xed\xff\xed\xff\xe8\x00\xe1\xff\xe1\xff\xef\xff\xef\xff\x91\x00\x80\x00\x05\x00\x20\x01\x76\x00\x05\x00\xcc\x00\x72\x00\x65\x00\x00\x00\x05\x00\x00\x00\x05\x00\x70\x00\x2e\x00\x59\x00\x5f\x00\x00\x00\x05\x00\x00\x00\x00\x00\x05\x00\x61\x00\x51\x00\x75\x00\x3c\x00\x05\x00\x5e\x00\x9f\x00\x5d\x00\x00\x00\x20\x01\x4f\x00\xbe\x00\x05\x00\x4e\x00\x2e\x00\x00\x00\x83\x00\x05\x00\x00\x00\x6e\x00\xbe\x00\x00\x00\x35\x00\x05\x00\x44\x00\xbe\x00\x26\x00\x00\x00\x05\x00\xbe\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x32\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x54\x00\x49\x00\x00\x00\x00\x00\x45\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x34\x00\x00\x00\xaf\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x01\xa5\x01\x00\x00\x1b\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x00\x00\x00\x00\x9b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x01\x93\x01\x91\x01\x89\x01\x87\x01\x7f\x01\x7d\x01\x75\x01\x73\x01\x6b\x01\x00\x00\x69\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x01\x0d\x00\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x01\x00\x00\x39\x01\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x57\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x55\x01\x00\x00\x1c\x00\x00\x00\x00\x00\x4d\x01\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\xfd\xff\x00\x00\xed\xff\xec\xff\x00\x00\x00\x00\xec\xff\xbb\xff\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xfb\xff\xfa\xff\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf5\xff\xf4\xff\xf3\xff\xf0\xff\xf1\xff\xf2\xff\x00\x00\x00\x00\xec\xff\x00\x00\x00\x00\xea\xff\xee\xff\xef\xff\xde\xff\xdd\xff\xe3\xff\xe9\xff\xbe\xff\xc4\xff\xc3\xff\xc1\xff\xc0\xff\xbf\xff\xc2\xff\xbd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\x00\x00\xdc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xe2\xff\xce\xff\xcf\xff\xcc\xff\xcd\xff\xcb\xff\xd0\xff\xd1\xff\xd2\xff\xd3\xff\xc9\xff\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe9\xff\x00\x00\xe8\xff\xc7\xff\xe5\xff\xca\xff\x00\x00\xd8\xff\x00\x00\x00\x00\xe7\xff\xca\xff\xc8\xff\xe4\xff\x00\x00\x00\x00\xd7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\xff\x00\x00\xe7\xff\xdf\xff\x00\x00\x00\x00\xd8\xff\xd9\xff\x00\x00\x00\x00\xd6\xff\xec\xff\xd4\xff\xe6\xff\xc6\xff\xc7\xff\x00\x00\xe1\xff\x00\x00\xc5\xff\x00\x00\xd5\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x01\x00\x23\x00\x01\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x01\x00\x00\x00\x23\x00\x02\x00\x23\x00\x32\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x29\x00\x2a\x00\x15\x00\x16\x00\x01\x00\x18\x00\x19\x00\x32\x00\x1b\x00\x32\x00\x06\x00\x07\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x02\x00\x02\x00\x06\x00\x07\x00\x03\x00\x37\x00\x38\x00\x39\x00\x37\x00\x38\x00\x15\x00\x16\x00\x01\x00\x18\x00\x19\x00\x01\x00\x1b\x00\x16\x00\x17\x00\x01\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x04\x00\x05\x00\x0d\x00\x03\x00\x08\x00\x03\x00\x0a\x00\x0b\x00\x36\x00\x02\x00\x04\x00\x05\x00\x15\x00\x16\x00\x08\x00\x18\x00\x19\x00\x0b\x00\x1b\x00\x1a\x00\x24\x00\x34\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\x23\x00\x23\x00\x36\x00\x24\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x03\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x1c\x00\x32\x00\x33\x00\x24\x00\x24\x00\x24\x00\x2b\x00\x23\x00\x35\x00\x26\x00\x23\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x24\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x25\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x1e\x00\x32\x00\x33\x00\x24\x00\x03\x00\x23\x00\x23\x00\x31\x00\x02\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x02\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x23\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x01\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x34\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x03\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x23\x00\x24\x00\x2b\x00\x01\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x36\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x36\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x34\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x24\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x31\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x01\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x24\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x01\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x23\x00\x02\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x3a\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x02\x00\x01\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x04\x00\x05\x00\xff\xff\xff\xff\x08\x00\x09\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\x09\x00\x08\x00\x0b\x00\x0a\x00\x0b\x00\x04\x00\x05\x00\xff\xff\xff\xff\x08\x00\x09\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\x09\x00\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x8e\x00\x04\x00\x8c\x00\x4a\x00\x04\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x6f\x00\x11\x00\x4a\x00\x07\x00\x4a\x00\x54\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4d\x00\x4e\x00\x38\x00\x39\x00\x43\x00\x3a\x00\x3b\x00\x54\x00\x3c\x00\x54\x00\x88\x00\x77\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x68\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0a\x00\x06\x00\x07\x00\x07\x00\x76\x00\x77\x00\x29\x00\x05\x00\x06\x00\x09\x00\x05\x00\x06\x00\x38\x00\x39\x00\x2a\x00\x3a\x00\x3b\x00\x27\x00\x3c\x00\x79\x00\x7a\x00\x17\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x7c\x00\x2c\x00\x12\x00\x13\x00\x2d\x00\x0e\x00\x91\x00\x2e\x00\x93\x00\x02\x00\x93\x00\x2c\x00\x38\x00\x39\x00\x2d\x00\x3a\x00\x3b\x00\x2e\x00\x3c\x00\x65\x00\x91\x00\x8e\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x10\x00\x4a\x00\x8a\x00\x83\x00\x8c\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x84\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x66\x00\x54\x00\x55\x00\x7f\x00\x81\x00\x75\x00\x76\x00\x4a\x00\x85\x00\x86\x00\x6b\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x7b\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x6c\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x6f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x88\x00\x54\x00\x55\x00\x72\x00\x57\x00\x4a\x00\x63\x00\x64\x00\x69\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x43\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x45\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x48\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x73\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x49\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x80\x00\x54\x00\x55\x00\x4a\x00\x6a\x00\x29\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x26\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x17\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x27\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x6d\x00\x54\x00\x55\x00\x25\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x15\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x16\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x11\x00\x0a\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\xff\xff\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x0d\x00\x0c\x00\x50\x00\x51\x00\x52\x00\x53\x00\x0e\x00\x54\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x60\x00\x2c\x00\x00\x00\x00\x00\x2d\x00\x73\x00\x00\x00\x2e\x00\x60\x00\x2c\x00\x7c\x00\x2c\x00\x2d\x00\x7b\x00\x2d\x00\x2e\x00\x7d\x00\x2e\x00\x60\x00\x2c\x00\x00\x00\x00\x00\x2d\x00\x70\x00\x00\x00\x2e\x00\x60\x00\x2c\x00\x8f\x00\x2c\x00\x2d\x00\x61\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x8a\x00\x2c\x00\x81\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x86\x00\x2c\x00\x6d\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x55\x00\x2c\x00\x57\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x58\x00\x2c\x00\x59\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x5a\x00\x2c\x00\x5b\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x5c\x00\x2c\x00\x5d\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x5e\x00\x2c\x00\x5f\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x66\x00\x2c\x00\x41\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x45\x00\x2c\x00\x46\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = array (1, 68) [+ (1 , happyReduce_1),+ (2 , happyReduce_2),+ (3 , happyReduce_3),+ (4 , happyReduce_4),+ (5 , happyReduce_5),+ (6 , happyReduce_6),+ (7 , happyReduce_7),+ (8 , happyReduce_8),+ (9 , happyReduce_9),+ (10 , happyReduce_10),+ (11 , happyReduce_11),+ (12 , happyReduce_12),+ (13 , happyReduce_13),+ (14 , happyReduce_14),+ (15 , happyReduce_15),+ (16 , happyReduce_16),+ (17 , happyReduce_17),+ (18 , happyReduce_18),+ (19 , happyReduce_19),+ (20 , happyReduce_20),+ (21 , happyReduce_21),+ (22 , happyReduce_22),+ (23 , happyReduce_23),+ (24 , happyReduce_24),+ (25 , happyReduce_25),+ (26 , happyReduce_26),+ (27 , happyReduce_27),+ (28 , happyReduce_28),+ (29 , happyReduce_29),+ (30 , happyReduce_30),+ (31 , happyReduce_31),+ (32 , happyReduce_32),+ (33 , happyReduce_33),+ (34 , happyReduce_34),+ (35 , happyReduce_35),+ (36 , happyReduce_36),+ (37 , happyReduce_37),+ (38 , happyReduce_38),+ (39 , happyReduce_39),+ (40 , happyReduce_40),+ (41 , happyReduce_41),+ (42 , happyReduce_42),+ (43 , happyReduce_43),+ (44 , happyReduce_44),+ (45 , happyReduce_45),+ (46 , happyReduce_46),+ (47 , happyReduce_47),+ (48 , happyReduce_48),+ (49 , happyReduce_49),+ (50 , happyReduce_50),+ (51 , happyReduce_51),+ (52 , happyReduce_52),+ (53 , happyReduce_53),+ (54 , happyReduce_54),+ (55 , happyReduce_55),+ (56 , happyReduce_56),+ (57 , happyReduce_57),+ (58 , happyReduce_58),+ (59 , happyReduce_59),+ (60 , happyReduce_60),+ (61 , happyReduce_61),+ (62 , happyReduce_62),+ (63 , happyReduce_63),+ (64 , happyReduce_64),+ (65 , happyReduce_65),+ (66 , happyReduce_66),+ (67 , happyReduce_67),+ (68 , happyReduce_68)+ ]++happy_n_terms = 59 :: Int+happy_n_nonterms = 14 :: Int++happyReduce_1 = happySpecReduce_1 0# happyReduction_1+happyReduction_1 happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn4+ ([happy_var_1]+ )}++happyReduce_2 = happySpecReduce_2 0# happyReduction_2+happyReduction_2 happy_x_2+ happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4+ (happy_var_1:happy_var_2+ )}}++happyReduce_3 = happyMonadReduce 4# 0# happyReduction_3+happyReduction_3 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen (case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> + case happyOut4 happy_x_3 of { happy_var_3 -> + case happyOut17 happy_x_4 of { happy_var_4 -> + (+ let rest = happy_var_3 in+ let pt = unsafePerformIO (readFile happy_var_2) in+ case (parse pt happy_var_4) of+ Success x -> returnP (x ++ rest)+ Failure err file ln -> failP err)}}}+ ) (\r -> happyReturn (happyIn4 r))++happyReduce_4 = happySpecReduce_1 1# happyReduction_4+happyReduction_4 happy_x_1+ = happyIn5+ (TyInt+ )++happyReduce_5 = happySpecReduce_1 1# happyReduction_5+happyReduction_5 happy_x_1+ = happyIn5+ (TyBigInt+ )++happyReduce_6 = happySpecReduce_1 1# happyReduction_6+happyReduction_6 happy_x_1+ = happyIn5+ (TyChar+ )++happyReduce_7 = happySpecReduce_1 1# happyReduction_7+happyReduction_7 happy_x_1+ = happyIn5+ (TyBool+ )++happyReduce_8 = happySpecReduce_1 1# happyReduction_8+happyReduction_8 happy_x_1+ = happyIn5+ (TyFloat+ )++happyReduce_9 = happySpecReduce_1 1# happyReduction_9+happyReduction_9 happy_x_1+ = happyIn5+ (TyBigFloat+ )++happyReduce_10 = happySpecReduce_1 1# happyReduction_10+happyReduction_10 happy_x_1+ = happyIn5+ (TyString+ )++happyReduce_11 = happySpecReduce_1 1# happyReduction_11+happyReduction_11 happy_x_1+ = happyIn5+ (TyPtr+ )++happyReduce_12 = happySpecReduce_1 1# happyReduction_12+happyReduction_12 happy_x_1+ = happyIn5+ (TyUnit+ )++happyReduce_13 = happySpecReduce_1 1# happyReduction_13+happyReduction_13 happy_x_1+ = happyIn5+ (TyAny+ )++happyReduce_14 = happySpecReduce_1 1# happyReduction_14+happyReduction_14 happy_x_1+ = happyIn5+ (TyData+ )++happyReduce_15 = happySpecReduce_1 1# happyReduction_15+happyReduction_15 happy_x_1+ = happyIn5+ (TyFun+ )++happyReduce_16 = happyReduce 8# 2# happyReduction_16+happyReduction_16 (happy_x_8 `HappyStk`+ happy_x_7 `HappyStk`+ happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + case happyOut7 happy_x_3 of { happy_var_3 -> + case happyOut5 happy_x_6 of { happy_var_6 -> + case happyOut8 happy_x_8 of { happy_var_8 -> + happyIn6+ (mkBind happy_var_1 (map snd happy_var_3) happy_var_6 (map fst happy_var_3) happy_var_8+ ) `HappyStk` happyRest}}}}++happyReduce_17 = happyReduce 7# 2# happyReduction_17+happyReduction_17 (happy_x_7 `HappyStk`+ happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_2 of { (TokenName happy_var_2) -> + case happyOut7 happy_x_4 of { happy_var_4 -> + case happyOut5 happy_x_7 of { happy_var_7 -> + happyIn6+ (mkExtern happy_var_2 (map snd happy_var_4) happy_var_7 (map fst happy_var_4)+ ) `HappyStk` happyRest}}}++happyReduce_18 = happySpecReduce_2 2# happyReduction_18+happyReduction_18 happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> + happyIn6+ (Include happy_var_2+ )}++happyReduce_19 = happySpecReduce_0 3# happyReduction_19+happyReduction_19 = happyIn7+ ([]+ )++happyReduce_20 = happySpecReduce_3 3# happyReduction_20+happyReduction_20 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn7+ ([(happy_var_1,happy_var_3)]+ )}}++happyReduce_21 = happyReduce 5# 3# happyReduction_21+happyReduction_21 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + case happyOut5 happy_x_3 of { happy_var_3 -> + case happyOut7 happy_x_5 of { happy_var_5 -> + happyIn7+ ((happy_var_1,happy_var_3):happy_var_5+ ) `HappyStk` happyRest}}}++happyReduce_22 = happySpecReduce_1 4# happyReduction_22+happyReduction_22 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + happyIn8+ (R happy_var_1+ )}++happyReduce_23 = happySpecReduce_3 4# happyReduction_23+happyReduction_23 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8+ (happy_var_2+ )}++happyReduce_24 = happyReduce 4# 4# happyReduction_24+happyReduction_24 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn8+ (App happy_var_1 happy_var_3+ ) `HappyStk` happyRest}}++happyReduce_25 = happyReduce 7# 4# happyReduction_25+happyReduction_25 (happy_x_7 `HappyStk`+ happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut8 happy_x_3 of { happy_var_3 -> + case happyOut13 happy_x_5 of { happy_var_5 -> + happyIn8+ (LazyApp happy_var_3 happy_var_5+ ) `HappyStk` happyRest}}++happyReduce_26 = happyReduce 4# 4# happyReduction_26+happyReduction_26 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_3 of { (TokenName happy_var_3) -> + happyIn8+ (LazyApp (R happy_var_3) []+ ) `HappyStk` happyRest}++happyReduce_27 = happyReduce 5# 4# happyReduction_27+happyReduction_27 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> + case happyOut13 happy_x_4 of { happy_var_4 -> + happyIn8+ (Con happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_28 = happySpecReduce_1 4# happyReduction_28+happyReduction_28 happy_x_1+ = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn8+ (Const happy_var_1+ )}++happyReduce_29 = happySpecReduce_3 4# happyReduction_29+happyReduction_29 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (TokenInt happy_var_3) -> + happyIn8+ (Proj happy_var_1 happy_var_3+ )}}++happyReduce_30 = happyReduce 8# 4# happyReduction_30+happyReduction_30 (happy_x_8 `HappyStk`+ happy_x_7 `HappyStk`+ happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_2 of { (TokenName happy_var_2) -> + case happyOut5 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_6 of { happy_var_6 -> + case happyOut8 happy_x_8 of { happy_var_8 -> + happyIn8+ (Let happy_var_2 happy_var_4 happy_var_6 happy_var_8+ ) `HappyStk` happyRest}}}}++happyReduce_31 = happySpecReduce_3 4# happyReduction_31+happyReduction_31 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn8+ (Let (MN "unused" 0) TyUnit happy_var_1 happy_var_3+ )}}++happyReduce_32 = happyReduce 6# 4# happyReduction_32+happyReduction_32 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOut8 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_6 of { happy_var_6 -> + happyIn8+ (If happy_var_2 happy_var_4 happy_var_6+ ) `HappyStk` happyRest}}}++happyReduce_33 = happySpecReduce_1 4# happyReduction_33+happyReduction_33 happy_x_1+ = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8+ (happy_var_1+ )}++happyReduce_34 = happySpecReduce_1 4# happyReduction_34+happyReduction_34 happy_x_1+ = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn8+ (happy_var_1+ )}++happyReduce_35 = happySpecReduce_2 4# happyReduction_35+happyReduction_35 happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> + happyIn8+ (Error happy_var_2+ )}++happyReduce_36 = happySpecReduce_1 4# happyReduction_36+happyReduction_36 happy_x_1+ = happyIn8+ (Impossible+ )++happyReduce_37 = happyReduce 6# 4# happyReduction_37+happyReduction_37 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokenString happy_var_3) -> + case happyOut14 happy_x_5 of { happy_var_5 -> + happyIn8+ (ForeignCall happy_var_2 happy_var_3 happy_var_5+ ) `HappyStk` happyRest}}}++happyReduce_38 = happyReduce 6# 5# happyReduction_38+happyReduction_38 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_5 of { happy_var_5 -> + happyIn9+ (Case happy_var_2 happy_var_5+ ) `HappyStk` happyRest}}++happyReduce_39 = happySpecReduce_0 6# happyReduction_39+happyReduction_39 = happyIn10+ ([]+ )++happyReduce_40 = happySpecReduce_1 6# happyReduction_40+happyReduction_40 happy_x_1+ = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn10+ ([happy_var_1]+ )}++happyReduce_41 = happySpecReduce_3 6# happyReduction_41+happyReduction_41 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn10+ (happy_var_1:happy_var_3+ )}}++happyReduce_42 = happyReduce 7# 7# happyReduction_42+happyReduction_42 (happy_x_7 `HappyStk`+ happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> + case happyOut7 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_7 of { happy_var_7 -> + happyIn11+ (Alt happy_var_2 happy_var_4 happy_var_7+ ) `HappyStk` happyRest}}}++happyReduce_43 = happySpecReduce_3 7# happyReduction_43+happyReduction_43 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn11+ (DefaultCase happy_var_3+ )}++happyReduce_44 = happySpecReduce_3 8# happyReduction_44+happyReduction_44 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op Plus happy_var_1 happy_var_3+ )}}++happyReduce_45 = happySpecReduce_3 8# happyReduction_45+happyReduction_45 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op Minus happy_var_1 happy_var_3+ )}}++happyReduce_46 = happySpecReduce_3 8# happyReduction_46+happyReduction_46 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op Times happy_var_1 happy_var_3+ )}}++happyReduce_47 = happySpecReduce_3 8# happyReduction_47+happyReduction_47 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op Divide happy_var_1 happy_var_3+ )}}++happyReduce_48 = happySpecReduce_3 8# happyReduction_48+happyReduction_48 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op OpLT happy_var_1 happy_var_3+ )}}++happyReduce_49 = happySpecReduce_3 8# happyReduction_49+happyReduction_49 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op OpGT happy_var_1 happy_var_3+ )}}++happyReduce_50 = happySpecReduce_3 8# happyReduction_50+happyReduction_50 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op OpLE happy_var_1 happy_var_3+ )}}++happyReduce_51 = happySpecReduce_3 8# happyReduction_51+happyReduction_51 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op OpGE happy_var_1 happy_var_3+ )}}++happyReduce_52 = happySpecReduce_3 8# happyReduction_52+happyReduction_52 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12+ (Op OpEQ happy_var_1 happy_var_3+ )}}++happyReduce_53 = happySpecReduce_0 9# happyReduction_53+happyReduction_53 = happyIn13+ ([]+ )++happyReduce_54 = happySpecReduce_1 9# happyReduction_54+happyReduction_54 happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn13+ ([happy_var_1]+ )}++happyReduce_55 = happySpecReduce_3 9# happyReduction_55+happyReduction_55 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn13+ (happy_var_1:happy_var_3+ )}}++happyReduce_56 = happySpecReduce_0 10# happyReduction_56+happyReduction_56 = happyIn14+ ([]+ )++happyReduce_57 = happySpecReduce_3 10# happyReduction_57+happyReduction_57 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn14+ ([(happy_var_1,happy_var_3)]+ )}}++happyReduce_58 = happyReduce 5# 10# happyReduction_58+happyReduction_58 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + case happyOut14 happy_x_5 of { happy_var_5 -> + happyIn14+ ((happy_var_1,happy_var_3):happy_var_5+ ) `HappyStk` happyRest}}}++happyReduce_59 = happySpecReduce_1 11# happyReduction_59+happyReduction_59 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenInt happy_var_1) -> + happyIn15+ (MkInt happy_var_1+ )}++happyReduce_60 = happySpecReduce_1 11# happyReduction_60+happyReduction_60 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenBigInt happy_var_1) -> + happyIn15+ (MkBigInt happy_var_1+ )}++happyReduce_61 = happySpecReduce_1 11# happyReduction_61+happyReduction_61 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenChar happy_var_1) -> + happyIn15+ (MkChar happy_var_1+ )}++happyReduce_62 = happySpecReduce_1 11# happyReduction_62+happyReduction_62 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenBool happy_var_1) -> + happyIn15+ (MkBool happy_var_1+ )}++happyReduce_63 = happySpecReduce_1 11# happyReduction_63+happyReduction_63 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenFloat happy_var_1) -> + happyIn15+ (MkFloat happy_var_1+ )}++happyReduce_64 = happySpecReduce_1 11# happyReduction_64+happyReduction_64 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenBigFloat happy_var_1) -> + happyIn15+ (MkBigFloat happy_var_1+ )}++happyReduce_65 = happySpecReduce_1 11# happyReduction_65+happyReduction_65 happy_x_1+ = case happyOutTok happy_x_1 of { (TokenString happy_var_1) -> + happyIn15+ (MkString happy_var_1+ )}++happyReduce_66 = happySpecReduce_1 11# happyReduction_66+happyReduction_66 happy_x_1+ = happyIn15+ (MkUnit+ )++happyReduce_67 = happyMonadReduce 0# 12# happyReduction_67+happyReduction_67 (happyRest) tk+ = happyThen (( getLineNo)+ ) (\r -> happyReturn (happyIn16 r))++happyReduce_68 = happyMonadReduce 0# 13# happyReduction_68+happyReduction_68 (happyRest) tk+ = happyThen (( getFileName)+ ) (\r -> happyReturn (happyIn17 r))++happyNewToken action sts stk+ = lexer(\tk -> + let cont i = happyDoAction i tk action sts stk in+ case tk of {+ TokenEOF -> happyDoAction 58# tk action sts stk;+ TokenName happy_dollar_dollar -> cont 1#;+ TokenString happy_dollar_dollar -> cont 2#;+ TokenInt happy_dollar_dollar -> cont 3#;+ TokenBigInt happy_dollar_dollar -> cont 4#;+ TokenBool happy_dollar_dollar -> cont 5#;+ TokenFloat happy_dollar_dollar -> cont 6#;+ TokenBigFloat happy_dollar_dollar -> cont 7#;+ TokenChar happy_dollar_dollar -> cont 8#;+ TokenIntType -> cont 9#;+ TokenBigIntType -> cont 10#;+ TokenCharType -> cont 11#;+ TokenBoolType -> cont 12#;+ TokenFloatType -> cont 13#;+ TokenBigFloatType -> cont 14#;+ TokenStringType -> cont 15#;+ TokenPtrType -> cont 16#;+ TokenUnitType -> cont 17#;+ TokenFunType -> cont 18#;+ TokenDataType -> cont 19#;+ TokenAnyType -> cont 20#;+ TokenUnit -> cont 21#;+ TokenCon -> cont 22#;+ TokenDefault -> cont 23#;+ TokenLet -> cont 24#;+ TokenCase -> cont 25#;+ TokenOf -> cont 26#;+ TokenIf -> cont 27#;+ TokenThen -> cont 28#;+ TokenElse -> cont 29#;+ TokenIn -> cont 30#;+ TokenLazy -> cont 31#;+ TokenForeign -> cont 32#;+ TokenError -> cont 33#;+ TokenImpossible -> cont 34#;+ TokenOB -> cont 35#;+ TokenCB -> cont 36#;+ TokenOCB -> cont 37#;+ TokenCCB -> cont 38#;+ TokenPlus -> cont 39#;+ TokenMinus -> cont 40#;+ TokenTimes -> cont 41#;+ TokenDivide -> cont 42#;+ TokenEquals -> cont 43#;+ TokenEQ -> cont 44#;+ TokenLE -> cont 45#;+ TokenGE -> cont 46#;+ TokenLT -> cont 47#;+ TokenGT -> cont 48#;+ TokenColon -> cont 49#;+ TokenProj -> cont 50#;+ TokenSemi -> cont 51#;+ TokenComma -> cont 52#;+ TokenBar -> cont 53#;+ TokenArrow -> cont 54#;+ TokenCInclude -> cont 55#;+ TokenExtern -> cont 56#;+ TokenInclude -> cont 57#;+ _ -> happyError' tk+ })++happyError_ tk = happyError' tk++happyThen :: () => P a -> (a -> P b) -> P b+happyThen = (thenP)+happyReturn :: () => a -> P a+happyReturn = (returnP)+happyThen1 = happyThen+happyReturn1 :: () => a -> P a+happyReturn1 = happyReturn+happyError' :: () => Token -> P a+happyError' tk = (\token -> happyError) tk++mkparse = happySomeParser where+ happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++mkBind :: Name -> [Type] -> Type -> [Name] -> Expr -> Decl+mkBind n tys ret ns expr = Decl n ret (Bind (zip ns tys) 0 expr)++mkExtern :: Name -> [Type] -> Type -> [Name] -> Decl+mkExtern n tys ret ns = Extern n ret tys++parse :: String -> FilePath -> Result [Decl]+parse s fn = mkparse s fn 1++parseFile :: FilePath -> IO (Result [Decl])+parseFile fn = do s <- readFile fn+ let x = parse s fn+ return x+{-# LINE 1 "GenericTemplate.hs" #-}+{-# LINE 1 "GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# LINE 1 "GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 28 "GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Int# Happy_IntList++++++{-# LINE 49 "GenericTemplate.hs" #-}++{-# LINE 59 "GenericTemplate.hs" #-}++{-# LINE 68 "GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser). We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+ happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+ = {- nothing -}+++ case action of+ 0# -> {- nothing -}+ happyFail i tk st+ -1# -> {- nothing -}+ happyAccept i tk st+ n | (n <# (0# :: Int#)) -> {- nothing -}++ (happyReduceArr ! rule) i tk st+ where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))+ n -> {- nothing -}+++ happyShift new_state i tk st+ where new_state = (n -# (1# :: Int#))+ where off = indexShortOffAddr happyActOffsets st+ off_i = (off +# i)+ check = if (off_i >=# (0# :: Int#))+ then (indexShortOffAddr happyCheck off_i ==# i)+ else False+ action | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st++{-# LINE 127 "GenericTemplate.hs" #-}+++indexShortOffAddr (HappyA# arr) off =+#if __GLASGOW_HASKELL__ > 500+ narrow16Int# i+#elif __GLASGOW_HASKELL__ == 500+ intToInt16# i+#else+ (i `iShiftL#` 16#) `iShiftRA#` 16#+#endif+ where+#if __GLASGOW_HASKELL__ >= 503+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+#else+ i = word2Int# ((high `shiftL#` 8#) `or#` low)+#endif+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#++++++data HappyAddr = HappyA# Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 170 "GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+ let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in+-- trace "shifting the error token" $+ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+ happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+ = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+ = let r = fn v1 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+ = let r = fn v1 v2 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+ = let r = fn v1 v2 v3 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+ = case happyDrop (k -# (1# :: Int#)) sts of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let r = fn stk in -- it doesn't hurt to always seq here...+ happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))+ where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++happyMonad2Reduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))+ where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++ off = indexShortOffAddr happyGotoOffsets st1+ off_i = (off +# nt)+ new_state = indexShortOffAddr happyTable off_i+++++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = + {- nothing -}+ happyDoAction j tk new_state+ where off = indexShortOffAddr happyGotoOffsets st+ off_i = (off +# nt)+ new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk =+-- trace "failing" $ + happyError_ tk++{- We don't need state discarding for our restricted implementation of+ "error". In fact, it can cause some bogus parses, so I've disabled it+ for now --SDM++-- discard a state+happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) =+-- trace ("discarding state, depth " ++ show (length stk)) $+ happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+-- save the old token and carry on.+happyFail i tk (action) sts stk =+-- trace "entering error recovery" $+ happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq+-- otherwise it emits+-- happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template. GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ epic.cabal view
@@ -0,0 +1,27 @@+Name: epic+Version: 0.1.2+Author: Edwin Brady+License: BSD3+License-file: LICENSE+Maintainer: eb@dcs.st-and.ac.uk+Homepage: http://www.dcs.st-and.ac.uk/~eb/epic.php+Stability: experimental+Category: Compilers/Interpreters+Synopsis: Compiler for a supercombinator language+Description: Epic is a simple functional language which compiles to+ reasonably efficient C code, using the Boehm-Demers-Weiser + garbage collector. It is currently used as a back end for + the Idris dependently typed programming language. It is invoked+ as a library, as it is intended as a compiler back end.++Build-depends: base, haskell98, mtl, Cabal, array, directory+Build-type: Simple++Extensions: MultiParamTypeClasses, FunctionalDependencies,+ ExistentialQuantification, OverlappingInstances+Exposed-modules: Epic.Compiler+Other-modules: Epic.Bytecode Epic.Parser Epic.Scopecheck+ Epic.Language Epic.Lexer Epic.CodegenC+ Epic.OTTLang Paths_epic+Data-files: evm/libevm.a evm/closure.h evm/stdfuns.h evm/mainprog.c+Extra-source-files: evm/closure.c evm/closure.h evm/stdfuns.h evm/mainprog.c evm/Makefile
+ evm/Makefile view
@@ -0,0 +1,22 @@+CC = gcc+CFLAGS = -g -Wall # -O2+OBJS = closure.o stdfuns.o+INSTALLDIR = ${PREFIX}/lib/evm++TARGET = libevm.a+INSTALLHDRS = closure.h stdfuns.h mainprog.c++${TARGET} : ${OBJS}+ ar r ${TARGET} ${OBJS}+ ranlib ${TARGET}++install:+ mkdir -p ${INSTALLDIR}+ install libevm.a ${INSTALLHDRS} ${INSTALLDIR}+ ranlib ${INSTALLDIR}/libevm.a++clean:+ rm -f ${OBJS} ${TARGET}++closure.o : closure.h+stdfuns.o : stdfuns.h closure.h
+ evm/closure.c view
@@ -0,0 +1,698 @@+#include "closure.h"+#include <assert.h>+#include <string.h>+#include <stdio.h>+#include <stdlib.h>+#include <gmp.h>++VAL one;++void dumpCon(con* c) {+ printf("%d", c->tag);+}++void dumpClosure(Closure* c) {+ switch(GETTY(c)) {+ case FUN:+ printf("FUN[");+ break;+ case THUNK:+ printf("THUNK[");+ break;+ case CON:+ printf("CON[");+ dumpCon((con*)c->info);+ break;+ case INT:+ printf("INT[%d", ((int)c)>>1);+ break;+ case BIGINT:+ printf("BIGINT[");+ break;+ case FLOAT:+ printf("FLOAT[");+ break;+ case BIGFLOAT:+ printf("BIGFLOAT[");+ break;+ case STRING:+ printf("STRING[");+ break;+ case UNIT:+ printf("UNIT[");+ break;+ case PTR:+ printf("PTR[");+ break;+ case FREEVAR:+ printf("FREEVAR[");+ break;+ default:+ printf("[%d,%d", GETTY(c), (int)c->info);+ }+ printf("]\n");+}+++inline VAL CLOSURE(func x, int arity, int args, void** block)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(fun)); // MKCLOSURE;+ fun* fn = (fun*)(c+1);+ fn->fn = x;+ fn->arity = arity;+ if (args==0) {+ fn->args = 0;+ fn->arg_end = 0;+ } else {+ fn->args = MKARGS(args);+ fn->arg_end=fn->args+args;+ memcpy((void*)(fn->args), (void*)block, args*sizeof(VAL));+ }++ SETTY(c, FUN);+ c->info = (void*)fn;+ return c;+}++inline VAL CONSTRUCTOR(int tag, int arity, void** block)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE;+ con* cn = (con*)(c+1);+ cn->tag = tag;+ if (arity==0) {+ cn->args = 0;+ } else {+ cn->args = MKARGS(arity);+ memcpy((void*)(cn->args), (void*)block, arity*sizeof(VAL));+ }+ SETTY(c, CON);+ c->info = (void*)cn;+ return c;+}++inline VAL CONSTRUCTOR1(int tag, VAL a1)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE;+ con* cn = (con*)(c+1);+ cn->tag = tag;+ cn->args = MKARGS(1);+ cn->args[0] = a1;+ SETTY(c,CON);+ c->info = (void*)cn;+ return c;+}++inline VAL CONSTRUCTOR2(int tag, VAL a1, VAL a2)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE;+ con* cn = (con*)(c+1);+ cn->tag = tag;+ cn->args = MKARGS(2);+ cn->args[0] = a1;+ cn->args[1] = a2;+ SETTY(c,CON);+ c->info = (void*)cn;+ return c;+}++inline VAL CONSTRUCTOR3(int tag, VAL a1, VAL a2, VAL a3)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE;+ con* cn = (con*)(c+1);+ cn->tag = tag;+ cn->args = MKARGS(3);+ cn->args[0] = a1;+ cn->args[1] = a2;+ cn->args[2] = a3;+ SETTY(c,CON);+ c->info = (void*)cn;+ return c;+}++inline VAL CONSTRUCTOR4(int tag, VAL a1, VAL a2, VAL a3, VAL a4)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE;+ con* cn = (con*)(c+1);+ cn->tag = tag;+ cn->args = MKARGS(2);+ cn->args[0] = a1;+ cn->args[1] = a2;+ cn->args[2] = a3;+ cn->args[3] = a4;+ SETTY(c,CON);+ c->info = (void*)cn;+ return c;+}++inline VAL CONSTRUCTOR5(int tag, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE;+ con* cn = (con*)(c+1);+ cn->tag = tag;+ cn->args = MKARGS(5);+ cn->args[0] = a1;+ cn->args[1] = a2;+ cn->args[2] = a3;+ cn->args[3] = a4;+ cn->args[4] = a5;+ SETTY(c,CON);+ c->info = (void*)cn;+ return c;+}++// This needs to make a copy+inline VAL CLOSURE_ADDN(VAL xin, int args, void** block)+{+ assert(GETTY(xin) == FUN);++ fun* finf = (fun*)xin->info;++ VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args);++ fun* fn = (fun*)(x->info);+ int diff = fn->arg_end - fn->args;++ fn->args = MOREARGS(fn->args, args + diff);+ fn->arg_end = fn->args + diff;++ memcpy((void*)(fn->arg_end), (void*)block, args*sizeof(VAL));+ fn->arg_end += args;+ return x;+}++/*+VAL CLOSURE_ADDN(VAL xin, int args, void** block)+{+ switch(args) {+ case 1: return CLOSURE_ADD1(xin,block[0]);+ case 2: return CLOSURE_ADD2(xin,block[0],block[1]);+ case 3: return CLOSURE_ADD3(xin,block[0],block[1],block[2]);+ case 4: return CLOSURE_ADD4(xin,block[0],block[1],block[2],block[3]);+ case 5: return CLOSURE_ADD5(xin,block[0],block[1],block[2],block[3],block[4]);+ default: return aux_CLOSURE_ADDN(xin,args,block);+ }+}+*/++inline VAL CLOSURE_ADD1(VAL xin, VAL a1)+{+ assert(GETTY(xin)==FUN);++ fun* finf = (fun*)xin->info;++ VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args);++ fun* fn = (fun*)(x->info);+ int diff = fn->arg_end - fn->args;++ fn->args = MOREARGS(fn->args, diff + 1);+ fn->arg_end = fn->args + diff;+ fn->arg_end[0] = a1;+ fn->arg_end+=1;++ return x;+}++inline VAL CLOSURE_ADD2(VAL xin, VAL a1, VAL a2)+{+ assert(GETTY(xin)==FUN);++ fun* finf = (fun*)xin->info;++ VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args);++ fun* fn = (fun*)(x->info);+ int diff = fn->arg_end - fn->args;++ fn->args = MOREARGS(fn->args, diff + 2);+ fn->arg_end = fn->args + diff;+ fn->arg_end[0] = a1;+ fn->arg_end[1] = a2;+ fn->arg_end+=2;++ return x;+}++inline VAL CLOSURE_ADD3(VAL xin, VAL a1, VAL a2, VAL a3)+{+ assert(GETTY(xin)==FUN);++ fun* finf = (fun*)xin->info;++ VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args);++ fun* fn = (fun*)(x->info);+ int diff = fn->arg_end - fn->args;++ fn->args = MOREARGS(fn->args, diff + 3);+ fn->arg_end = fn->args + diff;+ fn->arg_end[0] = a1;+ fn->arg_end[1] = a2;+ fn->arg_end[2] = a3;+ fn->arg_end+=3;++ return x;+}++inline VAL CLOSURE_ADD4(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4)+{+ assert(GETTY(xin)==FUN);++ fun* finf = (fun*)xin->info;++ VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args);++ fun* fn = (fun*)(x->info);+ int diff = fn->arg_end - fn->args;++ fn->args = MOREARGS(fn->args, diff + 4);+ fn->arg_end = fn->args + diff;+ fn->arg_end[0] = a1;+ fn->arg_end[1] = a2;+ fn->arg_end[2] = a3;+ fn->arg_end[3] = a4;+ fn->arg_end+=4;++ return x;+}++inline VAL CLOSURE_ADD5(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5)+{+ assert(GETTY(xin)==FUN);++ fun* finf = (fun*)xin->info;++ VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args);++ fun* fn = (fun*)(x->info);+ int diff = fn->arg_end - fn->args;++ fn->args = MOREARGS(fn->args, diff + 5);+ fn->arg_end = fn->args + diff;+ fn->arg_end[0] = a1;+ fn->arg_end[1] = a2;+ fn->arg_end[2] = a3;+ fn->arg_end[3] = a4;+ fn->arg_end[4] = a5;+ fn->arg_end+=2;++ return x;+}++inline VAL CLOSURE_APPLY(VAL f, int args, void** block)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE;+ thunk* fn = (thunk*)(c+1);++ if (ISFUN(f)) {+ return CLOSURE_ADDN(f,args,block);+ }++ fn->fn = (void*)f;+ fn->numargs = args;+ if (args==0) {+ fn->args = 0;+ } else {+ fn->args = MKARGS(args);+ memcpy((void*)(fn->args), (void*)block, args*sizeof(VAL));+ }++ SETTY(c,THUNK);+ c->info = (void*)fn;+ return c;+}++inline VAL aux_CLOSURE_APPLY1(VAL f, VAL a1)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE;+ thunk* fn = (thunk*)(c+1);++ if (ISFUN(f)) {+ return CLOSURE_ADD1(f,a1);+ }++ fn->fn = (void*)f;+ fn->numargs = 1;+ fn->args = MKARGS(1);+ fn->args[0] = a1;++ SETTY(c,THUNK);+ c->info = (void*)fn;+ return c;+}++inline VAL aux_CLOSURE_APPLY2(VAL f, VAL a1, VAL a2)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE;+ thunk* fn = (thunk*)(c+1);++ if (ISFUN(f)) {+ return CLOSURE_ADD2(f,a1,a2);+ }++ fn->fn = (void*)f;+ fn->numargs = 2;+ fn->args = MKARGS(2);+ fn->args[0] = a1;+ fn->args[1] = a2;++ SETTY(c,THUNK);+ c->info = (void*)fn;+ return c;+}++inline VAL aux_CLOSURE_APPLY3(VAL f, VAL a1, VAL a2, VAL a3)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE;+ thunk* fn = (thunk*)(c+1);++ if (ISFUN(f)) {+ return CLOSURE_ADD3(f,a1,a2,a3);+ }++ fn->fn = (void*)f;+ fn->numargs = 2;+ fn->args = MKARGS(3);+ fn->args[0] = a1;+ fn->args[1] = a2;+ fn->args[2] = a3;++ SETTY(c,THUNK);+ c->info = (void*)fn;+ return c;+}++inline VAL aux_CLOSURE_APPLY4(VAL f, VAL a1, VAL a2, VAL a3, VAL a4)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE;+ thunk* fn = (thunk*)(c+1);++ if (ISFUN(f)) {+ return CLOSURE_ADD4(f,a1,a2,a3,a4);+ }++ fn->fn = (void*)f;+ fn->numargs = 2;+ fn->args = MKARGS(4);+ fn->args[0] = a1;+ fn->args[1] = a2;+ fn->args[2] = a3;+ fn->args[3] = a4;++ SETTY(c,THUNK);+ c->info = (void*)fn;+ return c;+}++inline VAL aux_CLOSURE_APPLY5(VAL f, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5)+{+ VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE;+ thunk* fn = (thunk*)(c+1);++ if (ISFUN(f)) {+ return CLOSURE_ADD5(f,a1,a2,a3,a4,a5);+ }++ fn->fn = (void*)f;+ fn->numargs = 2;+ fn->args = MKARGS(5);+ fn->args[0] = a1;+ fn->args[1] = a2;+ fn->args[2] = a3;+ fn->args[3] = a4;+ fn->args[4] = a5;++ SETTY(c,THUNK);+ c->info = (void*)fn;+ return c;+}++inline VAL CLOSURE_APPLY1(VAL f, VAL a1)+{+ if (ISFUN(f)) {+ fun* finf = (fun*)(f->info);+ int got = finf->arg_end-finf->args;+ if (finf->arity == (got+1)) {+ void* block[got+1];+ memcpy(block, finf->args, got*sizeof(VAL));+ block[got] = a1;+ return (VAL)(finf->fn(block));+ }+ else return CLOSURE_ADD1(f,a1);+ }+ else return aux_CLOSURE_APPLY1(f,a1);+}++inline VAL CLOSURE_APPLY2(VAL f, VAL a1, VAL a2)+{+ if (ISFUN(f)) {+ fun* finf = (fun*)(f->info);+ int got = finf->arg_end-finf->args;+ if (finf->arity == (got+2)) {+ void* block[got+2];+ memcpy(block, finf->args, got*sizeof(VAL));+ block[got] = a1;+ block[got+1] = a2;+ return (VAL)(finf->fn(block));+ }+ else return CLOSURE_ADD2(f,a1,a2);+ }+ else return aux_CLOSURE_APPLY2(f,a1,a2);+}++inline VAL CLOSURE_APPLY3(VAL f, VAL a1, VAL a2, VAL a3)+{+ if (ISFUN(f)) {+ fun* finf = (fun*)(f->info);+ int got = finf->arg_end-finf->args;+ if (finf->arity == (got+3)) {+ void* block[got+3];+ memcpy(block, finf->args, got*sizeof(VAL));+ block[got] = a1;+ block[got+1] = a2;+ block[got+2] = a3;+ return (VAL)(finf->fn(block));+ }+ else return CLOSURE_ADD3(f,a1,a2,a3);+ }+ else return aux_CLOSURE_APPLY3(f,a1,a2,a3);+}++inline VAL CLOSURE_APPLY4(VAL f, VAL a1, VAL a2, VAL a3, VAL a4)+{+ if (ISFUN(f)) {+ fun* finf = (fun*)(f->info);+ int got = finf->arg_end-finf->args;+ if (finf->arity == (got+4)) {+ void* block[got+4];+ memcpy(block, finf->args, got*sizeof(VAL));+ block[got] = a1;+ block[got+1] = a2;+ block[got+2] = a3;+ block[got+3] = a4;+ return (VAL)(finf->fn(block));+ }+ else return CLOSURE_ADD4(f,a1,a2,a3,a4);+ }+ else return aux_CLOSURE_APPLY4(f,a1,a2,a3,a4);+}++inline VAL CLOSURE_APPLY5(VAL f, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5)+{+ if (ISFUN(f)) {+ fun* finf = (fun*)(f->info);+ int got = finf->arg_end-finf->args;+ if (finf->arity == (got+5)) {+ void* block[got+5];+ memcpy(block, finf->args, got*sizeof(VAL));+ block[got] = a1;+ block[got+1] = a2;+ block[got+2] = a3;+ block[got+3] = a4;+ block[got+4] = a5;+ return (VAL)(finf->fn(block));+ }+ else return CLOSURE_ADD5(f,a1,a2,a3,a4,a5);+ }+ else return aux_CLOSURE_APPLY5(f,a1,a2,a3,a4,a5);+}++VAL DO_EVAL(VAL x) {+// dummy value we'll never inspect, leave it alone.+ if (x==NULL) return x; ++ VAL result;+// VAL x = (VAL)(*xin);+ fun* fn;+ thunk* th;+ int excess;++// dumpClosure(x);++ switch(GETTY(x)) {+ case CON:+ case INT:+ case FLOAT:+ case STRING:+ case PTR:+ case UNIT:+ return x; // Already evaluated+ case FUN:+ // If the number of arguments is right, run it.+ fn = (fun*)(x->info);+ excess = (fn->arg_end - fn->args) - fn->arity;+ if (excess == 0) {+ result = fn->fn(fn->args);+ // If the result is still a function, better eval again to make+ // more progress.+ // It could reasonably be null though, so be careful. It's null+ // if it was a foreign/io call in particular.+ if (result) {+ if (GETTY(result)==FUN || GETTY(result)==THUNK) {+ result=DO_EVAL(result);+ }+/* if (ISINT(result)) {+ printf("Updating with %d\n", x);+ } else {+ printf("Updating %d %d with %d\n", x, GETTY(x), result);+ }*/+ UPDATE(x,result);+ }+ else {+ SETTY(x, INT); x->info=(void*)42;+ }+ }+ // If there are too many arguments, run it with the right number+ // then apply the remaining arguments to the resulting closure+ else if (excess > 0) {+ result = fn->fn(fn->args);+ result = CLOSURE_APPLY(result, excess, fn->args + fn->arity);+ result = DO_EVAL(result);+ UPDATE(x,result);+ return x;+ }+ break;+ case THUNK:+ th = (thunk*)(x->info);+ // Evaluate inner thunk, which should give us a function+ th->fn = DO_EVAL((VAL)(th->fn));+ // Apply this thunk's arguments to it+ CLOSURE_APPLY((VAL)th->fn, th->numargs, th->args);+ // And off we go again...+ th->fn = DO_EVAL((VAL)(th->fn));+ UPDATE(x,((VAL)(th->fn)));+ return x;+ break;+ default:+ assert(0); // Can't happen+ }+ return x;+}++/*+void* DO_PROJECT(VAL x, int arg)+{+ assert(x->ty == CON);+ con* cn = (con*)x->info;+ return cn->args[arg];+}+*/++void* MKINT(int x)+{+ return (void*)((x<<1)+1);+// VAL c = MKCLOSURE;+// SETTY(c, INT);+// c->info = (void*)x;+// return c;+}++void* NEWBIGINT(char* intstr)+{+ mpz_t* bigint;+ VAL c = EMALLOC(sizeof(Closure)+sizeof(mpz_t));+ bigint = (mpz_t*)(c+1);+ mpz_init(*bigint);+ mpz_set_str(*bigint, intstr, 10);++ SETTY(c, BIGINT);+ c->info = (void*)bigint;+ return c;+}++void* MKBIGINT(mpz_t* big)+{+ mpz_t* bigint;+ VAL c = EMALLOC(sizeof(Closure)+sizeof(mpz_t));+ bigint = (mpz_t*)(c+1);+ mpz_init(*bigint);+ mpz_set(*bigint, *big);++ SETTY(c, BIGINT);+ c->info = (void*)bigint;+ return c;+}++int GETINT(void* x)+{+ return ((int)x)>>1;+}++mpz_t* GETBIGINT(void* x)+{+ return ((mpz_t*)(((VAL)x)->info));+}+++void* MKSTR(char* x)+{+ VAL c = MKCLOSURE;+ SETTY(c, STRING);+ c->info = (void*)(EMALLOC(strlen(x)*sizeof(char)+1));+ strcpy(c->info,x);+ return c;+}++void* MKPTR(void* x)+{+ VAL c = MKCLOSURE;+ SETTY(c, PTR);+ c->info = x;+ return c;+}++char* GETSTR(void* x)+{+ return (char*)(((VAL)x)->info);+}++void* GETPTR(void* x)+{+ return (void*)(((VAL)x)->info);+}++void ERROR(char* msg)+{+ printf("*** error : %s ***\n",msg);+ assert(0);+ exit(1);+}++void* MKFREE(int x)+{+ VAL c = MKCLOSURE;+ SETTY(c, FREEVAR);+ c->info = (void*)x;+ return c;+}++void init_evm()+{+ one = MKINT(1);+}
+ evm/closure.h view
@@ -0,0 +1,162 @@+#ifndef _CLOSURE_H+#define _CLOSURE_H++# ifndef WIN32+# include <pthread.h>+# define GC_THREADS+# else+# define GC_WIN32_THREADS+# endif++#include <gc/gc.h>+#include <gmp.h>+#include <stdio.h>+#include <stdlib.h>++#define EMALLOC GC_MALLOC+#define EREALLOC GC_REALLOC+#define EFREE GC_FREE++#define MKCON (con*)EMALLOC(sizeof(con))+#define MKFUN (fun*)EMALLOC(sizeof(fun))+#define MKTHUNK (thunk*)EMALLOC(sizeof(thunk))+#define MKCLOSURE (Closure*)EMALLOC(sizeof(Closure))+#define MKUNIT (void*)0++#define INTOP(op,x,y) MKINT((((int)x)>>1) op (((int)y)>>1))+#define CHECKEVALUATED(x) if(ISFUN(x) || ISTHUNK(x) \+ || ISFV(x)) return 0;++#define MKARGS(x) (void**)EMALLOC(sizeof(VAL)*(x));+#define MOREARGS(args,x) (void**)EREALLOC(args,sizeof(VAL)*(x));++typedef enum { + FUN, + THUNK, + CON, + INT, + BIGINT,+ FLOAT,+ BIGFLOAT,+ STRING, + UNIT, + PTR,+ FREEVAR +} ClosureType;++typedef struct {+ int ty;+ void* info;+} Closure;++void dumpClosure(Closure* c);++typedef Closure* VAL;++#define GETTY(x) (ISINT(x) ? INT : ((ClosureType)(((x)->ty) >> 24)))+#define QGETTY(x) ((ClosureType)(((x)->ty) >> 24))+#define SETTY(x,t) (x)->ty = (((int)t) << 24)++#define REF(x) x+#define DEREF(x) ++typedef void*(*func)(void**);++typedef struct {+ func fn;+ void** args;+ void** arg_end;+ int arity;+} fun;++typedef struct {+ void* fn;+ void** args;+ int numargs;+} thunk;++typedef struct {+ int tag;+ void** args;+} con;++#define UPDATE(x,res) if (ISINT(res)) { x = MKINT(GETINT(res)); } else { \+ SETTY(x, GETTY(res)); x->info=res->info; }+#define TAG(x) ((con*)((Closure*)x)->info)->tag++#define ISCON(x) GETTY(((Closure*)(x)))==CON+#define ISINT(x) ((((int)x)&1) == 1)+#define ISTHUNK(x) GETTY(((Closure*)(x)))==THUNK+#define ISFUN(x) GETTY(((Closure*)(x)))==FUN+#define ISFV(x) GETTY(((Closure*)(x)))==FREEVAR++#ifdef TRACEON+#define TRACE if(1)+#else+#define TRACE if(0)+#endif++// Evaluate x to head normal form+VAL DO_EVAL(VAL x);++//#define EVAL(x) DO_EVAL(x)+#define EVAL(x) ((x && (ISTHUNK(x) || ISFUN(x))) ? DO_EVAL(x) : x)++// Return a new constructor+VAL CONSTRUCTOR(int tag, int arity, void** block);+VAL CONSTRUCTOR1(int tag, VAL a1);+VAL CONSTRUCTOR2(int tag, VAL a1, VAL a2);+VAL CONSTRUCTOR3(int tag, VAL a1, VAL a2, VAL a3);+VAL CONSTRUCTOR4(int tag, VAL a1, VAL a2, VAL a3, VAL a4);+VAL CONSTRUCTOR5(int tag, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5);++// Return a new function node+VAL CLOSURE(func x, int arity, int args, void** block);++// Add arguments to an already existing thunk+VAL CLOSURE_ADDN(VAL x, int args, void** block);+VAL CLOSURE_ADD1(VAL xin, VAL a1);+VAL CLOSURE_ADD2(VAL xin, VAL a1, VAL a2);+VAL CLOSURE_ADD3(VAL xin, VAL a1, VAL a2, VAL a3);+VAL CLOSURE_ADD4(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4);+VAL CLOSURE_ADD5(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5);++// Apply a closure to some arguments+VAL CLOSURE_APPLY(VAL x, int args, void** block);+VAL CLOSURE_APPLY1(VAL x, VAL a1);+VAL CLOSURE_APPLY2(VAL x, VAL a1, VAL a2);+VAL CLOSURE_APPLY3(VAL x, VAL a1, VAL a2, VAL a3);+VAL CLOSURE_APPLY4(VAL x, VAL a1, VAL a2, VAL a3, VAL a4);+VAL CLOSURE_APPLY5(VAL x, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5);++// Project an argument from a constructor+#define PROJECT(x,arg) (((con*)((x)->info))->args[arg])+//void* DO_PROJECT(VAL x, int arg);++#define ASSIGNINT(t, x) t=MKINT(x);++//extern VAL one; ++void* MKINT(int x);+void* NEWBIGINT(char* bigint);+void* MKBIGINT(mpz_t* bigint);++void* MKSTR(char* str);+void* MKPTR(void* ptr);++// Get values from a closure+int GETINT(void* x);+mpz_t* GETBIGINT(void* x);+char* GETSTR(void* x);+void* GETPTR(void* x);++void* MKFREE(int x);++// Exit with fatal error+void ERROR(char* msg);++// Initialise everything+void init_evm();+++#endif
+ evm/libevm.a view
binary file changed (absent → 42420 bytes)
+ evm/mainprog.c view
@@ -0,0 +1,17 @@+# ifndef WIN32+# include <pthread.h>+# define GC_THREADS+# else+# define GC_WIN32_THREADS+# endif++#include "closure.h"++void* _do__U_main();++int main(int argc, char* argv[]) {+ GC_init();+ init_evm();+ _do___U__main();+ return 0; +}
+ evm/stdfuns.h view
@@ -0,0 +1,74 @@+#ifndef _STDFUNS_H+#define _STDFUNS_H++# ifndef WIN32+# include <pthread.h>+# define GC_THREADS+# else+# define GC_WIN32_THREADS+# endif++#include <gc/gc.h>+#include <gmp.h>+#include <stdio.h>+#include "closure.h"++// Some basic communication with the outside world++void putStr(char* str);+void printInt(int x);+void printBigInt(mpz_t x);++// dump memory usage (from libgc)+void epicMemInfo();++int readInt();+char* readStr();++void* fileOpen(char* name, char* mode);+void fileClose(void* h);+char* freadStr(void* h);+void fputStr(void* h, char* str);++int isNull(void* ptr);++// IORefs+int newRef();+void* readRef(int r);+void writeRef(int r, void* val);++// Locks+int newLock(int sem);+void doLock(int lock);+void doUnlock(int lock);+void doFork(void* proc);++int strToInt(char* str);+char* intToStr(int x);++mpz_t* strToBigInt(char* str);+char* bigIntToStr(mpz_t x);++// get a native representation of a value+void* getNative(void * fn);++// String operations++int strIndex(char* str, int i);+char* append(char* x, char* y);++// Big integer arithmetic++mpz_t* addBigInt(mpz_t x, mpz_t y);+mpz_t* subBigInt(mpz_t x, mpz_t y);+mpz_t* mulBigInt(mpz_t x, mpz_t y);+mpz_t* divBigInt(mpz_t x, mpz_t y);++int eqBigInt(mpz_t x, mpz_t y);+int ltBigInt(mpz_t x, mpz_t y);+int gtBigInt(mpz_t x, mpz_t y);+int leBigInt(mpz_t x, mpz_t y);+int geBigInt(mpz_t x, mpz_t y);++#endif+