diff options
Diffstat (limited to 'Sil/Compile.icl')
| -rw-r--r-- | Sil/Compile.icl | 47 |
1 files changed, 18 insertions, 29 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl index 7ef48e4..fdc2bf5 100644 --- a/Sil/Compile.icl +++ b/Sil/Compile.icl @@ -23,29 +23,18 @@ from Text import <+ import qualified ABC.Assembler as ABC +import Sil.Error import Sil.Syntax import Sil.Types import Sil.Util.Printer -instance toString CompileError -where - toString (UndefinedName n) = "Undefined name '" <+ n <+ "'." - toString (UndefinedField f) = "Undefined field '" <+ f <+ "'." - toString VariableLabel = "Variable stored at label." - toString FunctionOnStack = "Function stored on the stack." - toString (TypeError err e) = "Type error in '" <+ e <+ "': " <+ err - toString (CouldNotDeduceType e) = "Could not deduce type of '" <+ e <+ "'." - toString (TypeMisMatch t e) = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'." - toString (BasicInitWithoutValue n) = "Basic value '" <+ n <+ "' must have an initial value." - toString UnknownError = "Unknown error." - -error :: CompileError -> RWST r w s (MaybeError CompileError) a +error :: Error -> RWST r w s (MaybeError Error) a error e = RWST \_ _ -> Error e nop :: RWST r w s m () | Monoid w & Monad m nop = RWST \_ s -> pure ((), s, mempty) -compile :: Program -> MaybeError CompileError 'ABC'.Assembler +compile :: Program -> MaybeError Error 'ABC'.Assembler compile prog = case evalRWST (censor censor` $ gen prog) () zero of Error e -> Error e Ok (_,p) -> Ok p @@ -129,7 +118,7 @@ stackoffsets cs = cs.stackoffsets typeresolvers :: CompileState -> [TypeResolver] typeresolvers cs = cs.typeresolvers -:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a +:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError Error) a fresh :: a -> Gen 'ABC'.Label | toString a fresh n = gets labels @@ -187,7 +176,7 @@ findVar n = gets stackoffsets >>= \(aso, bso) -> gets addresses >>= \addr -> case 'M'.get n addr of Just (AAddr i) -> comment (n <+ " is on AStack at " <+ i <+ ", with aso " <+ aso <+ " so " <+ (aso-i)) $> AAddr (aso - i) Just (BAddr i) -> comment (n <+ " is on BStack at " <+ i <+ ", with bso " <+ bso <+ " so " <+ (bso-i)) $> BAddr (bso - i) - Nothing -> error $ UndefinedName n + Nothing -> error $ C_UndefinedName n addFunction :: Function -> Gen () addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols}) @@ -216,12 +205,12 @@ where getType :: Expression -> Gen Type getType e = getTypeResolver >>= \tr -> case type tr e of - Nothing -> error $ CouldNotDeduceType e - Just (Error err) -> error $ TypeError err e + Nothing -> error $ C_CouldNotDeduceType e + Just (Error err) -> error err Just (Ok t) -> pure $ t checkType :: Type Expression -> Gen () -checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ TypeMisMatch t e) +checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e) checkTypeName :: Name Expression -> Gen Type checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t` @@ -245,7 +234,7 @@ where mapM_ gen p.p_funs *> popTypeResolver where - typeresolver :: Name -> Maybe (MaybeError TypeError Type) + typeresolver :: Name -> Maybe (MaybeError Error Type) typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of [] -> Nothing [f:_] -> type zero f @@ -278,7 +267,7 @@ where ] retSize = typeSize f.f_type - typeresolver :: Name -> Maybe (MaybeError TypeError Type) + typeresolver :: Name -> Maybe (MaybeError Error Type) typeresolver n = listToMaybe [Ok a.arg_type \\ a <- f.f_args | a.arg_name == n] mainBootstrap :: Gen () @@ -339,7 +328,7 @@ where ] locals = foldr (+~) zero [typeSize i.init_type \\ i <- cb.cb_init] - typeresolver :: Name -> Maybe (MaybeError TypeError Type) + typeresolver :: Name -> Maybe (MaybeError Error Type) typeresolver n = listToMaybe [Ok i.init_type \\ i <- cb.cb_init | i.init_name == n] instance gen Initialisation @@ -347,7 +336,7 @@ where gen init = case typeSize init.init_type of s=:{bsize=0} -> tell $ repeatn s.asize 'ABC'.Create s=:{asize=0} -> case init.init_value of - Nothing -> error $ BasicInitWithoutValue init.init_name + Nothing -> error $ C_BasicInitWithoutValue init.init_name Just v -> checkType init.init_type v *> gen v *> shrinkStack s instance gen Statement @@ -371,8 +360,8 @@ where gen e *> getTypeResolver >>= \tr -> case fmap typeSize <$> type tr e of Just (Ok sz) -> tell ['ABC'.Pop_a sz.asize, 'ABC'.Pop_b sz.bsize] *> shrinkStack sz - Just (Error err) -> error $ TypeError err e - Nothing -> error $ CouldNotDeduceType e + Just (Error err) -> error err + Nothing -> error $ C_CouldNotDeduceType e gen (Return (Just e)) = comment "Return" *> gen e *> @@ -440,7 +429,7 @@ where tell ['ABC'.PushI i] *> growStack {zero & bsize=1,btypes=['ABC'.BT_Int]} gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of - Just i -> liftT $ Error FunctionOnStack + Just i -> error C_FunctionOnStack _ -> gets symbols >>= \syms -> case 'M'.get n syms of Just fs -> comment "Retrieve arguments" *> @@ -451,7 +440,7 @@ where , 'ABC'.Annotation $ toOAnnot $ typeSize fs.fs_rettype ] *> growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes) - _ -> liftT $ Error $ UndefinedName n + _ -> error $ C_UndefinedName n gen (BuiltinApp op arg) = gen arg *> gen op @@ -504,12 +493,12 @@ where , 'ABC'.Update_a 0 (arity - tupleEl) , 'ABC'.Pop_a (arity - tupleEl) ] *> - if (0 >= tupleEl || tupleEl > arity) (error $ TypeError (IllegalField f t) e) nop *> + if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField f t) nop *> case typeSize $ tes!!(tupleEl - 1) of {bsize=0} -> nop {btypes} -> mapM (flip toBStack 1) btypes *> nop | otherwise = - error $ UndefinedField f + error $ C_UndefinedField f where f` = fromString f |