diff options
Diffstat (limited to 'snug-clean/src/Snug')
| -rw-r--r-- | snug-clean/src/Snug/Compile.icl | 42 |
1 files changed, 22 insertions, 20 deletions
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl index de7078a..8c23134 100644 --- a/snug-clean/src/Snug/Compile.icl +++ b/snug-clean/src/Snug/Compile.icl @@ -5,12 +5,14 @@ import StdEnv import Control.Monad import Control.Monad.Fail import Control.Monad.State +import Control.Monad.Trans import Data.Error import Data.Func import Data.Functor import Data.List import qualified Data.Map from Data.Map import :: Map +from Text import concat4 import MIPS.MIPS32 import Snug.Compile.ABI @@ -69,11 +71,15 @@ gatherGlobals ns defs = ] } -lookupConstructor :: !Namespace !ConstructorIdent !Globals -> ?ConstructorDef -lookupConstructor ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.constructors +lookupConstructor :: !Namespace !ConstructorIdent !Globals -> MaybeError String ConstructorDef +lookupConstructor ns id globs = mb2error + (concat4 "Unknown constructor " ns "." id) + ('Data.Map'.get {ns=ns, id=id} globs.constructors) -lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo -lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions +lookupFunction :: !Namespace !SymbolIdent !Globals -> MaybeError String FunctionInfo +lookupFunction ns id globs = mb2error + (concat4 "Unknown symbol " ns "." id) + ('Data.Map'.get {ns=ns, id=id} globs.functions) compileDefinition :: !Namespace !Globals !Definition -> CompileM [Line] compileDefinition _ _ (TypeDef _ _) = pure @@ -138,30 +144,26 @@ simulator ns globals locals (Symbol id) = ?Just (FrontPtrArg i) -> stackSize >>= \n -> pushArg (n-1) i - ?None -> case lookupFunction ns id globals of - ?None -> fail ("unknown symbol: " +++ id) - ?Just info -> - case info.arity of - 0 -> - buildThunk (functionLabel ns NodeEntry id) 0 - _ -> - fail "symbol with arity > 0" // TODO implement + ?None -> + liftT (lookupFunction ns id globals) >>= \info -> case info.arity of + 0 -> + buildThunk (functionLabel ns NodeEntry id) 0 + _ -> + fail "symbol with arity > 0" // TODO implement simulator ns globals locals expr=:(ExpApp _ _) = case f of Symbol id -> // TODO include locals - case lookupFunction ns id globals of - ?None -> fail ("unknown symbol: " +++ id) - ?Just info | info.arity == length args -> + liftT (lookupFunction ns id globals) >>= \info + | info.arity == length args -> mapM_ (simulator ns globals locals) (reverse args) >>| buildThunk (functionLabel ns NodeEntry id) info.arity - _ -> fail "arity mismatch in application" // TODO implement + | otherwise -> fail "arity mismatch in application" // TODO implement Constructor id -> - case lookupConstructor ns id globals of - ?None -> fail ("unknown constructor: " +++ id) - ?Just (ConstructorDef _ arg_types) | length arg_types == length args -> + liftT (lookupConstructor ns id globals) >>= \(ConstructorDef _ arg_types) + | length arg_types == length args -> mapM_ (simulator ns globals locals) (reverse args) >>| buildCons (constructorLabel ns id) (length args) - _ -> fail ("arity mismatch in application of " +++ id) // TODO implement + | otherwise -> fail ("arity mismatch in application of " +++ id) // TODO implement _ -> // TODO fail "unexpected lhs of function application" where |