aboutsummaryrefslogtreecommitdiff
path: root/Sil
diff options
context:
space:
mode:
Diffstat (limited to 'Sil')
-rw-r--r--Sil/Compile.dcl19
-rw-r--r--Sil/Compile.icl47
-rw-r--r--Sil/Error.dcl28
-rw-r--r--Sil/Error.icl25
-rw-r--r--Sil/Parse.dcl12
-rw-r--r--Sil/Parse.icl21
-rw-r--r--Sil/Types.dcl11
-rw-r--r--Sil/Types.icl21
-rw-r--r--Sil/Util/Parser.dcl8
-rw-r--r--Sil/Util/Parser.icl16
10 files changed, 108 insertions, 100 deletions
diff --git a/Sil/Compile.dcl b/Sil/Compile.dcl
index 7b0cf2f..61ee1b5 100644
--- a/Sil/Compile.dcl
+++ b/Sil/Compile.dcl
@@ -7,20 +7,7 @@ from Data.Error import :: MaybeError
from ABC.Assembler import :: Assembler, :: Statement, instance <<< Assembler
-from Sil.Syntax import :: Program, :: Name, :: Expression
-from Sil.Types import :: Type, :: TypeError
+from Sil.Error import :: Error
+from Sil.Syntax import :: Program
-:: CompileError
- = UndefinedName Name
- | UndefinedField Name
- | VariableLabel
- | FunctionOnStack
- | TypeError TypeError Expression
- | CouldNotDeduceType Expression
- | TypeMisMatch Type Expression
- | BasicInitWithoutValue Name
- | UnknownError
-
-instance toString CompileError
-
-compile :: Program -> MaybeError CompileError Assembler
+compile :: Program -> MaybeError Error Assembler
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
diff --git a/Sil/Error.dcl b/Sil/Error.dcl
new file mode 100644
index 0000000..b953f60
--- /dev/null
+++ b/Sil/Error.dcl
@@ -0,0 +1,28 @@
+definition module Sil.Error
+
+from StdOverloaded import class toString
+
+from Sil.Syntax import :: Expression
+from Sil.Types import :: Type
+
+:: Error
+ // Parser errors
+ = E.a: P_Invalid String a & toString a
+ | P_Expected String
+ // Type errors
+ | T_IllegalApplication Type Type
+ | T_IllegalField String Type
+ | T_TooHighTupleArity Int
+ // Compile errors
+ | C_UndefinedName String
+ | C_UndefinedField String
+ | C_VariableLabel
+ | C_FunctionOnStack
+ | C_TypeError Error Expression
+ | C_CouldNotDeduceType Expression
+ | C_TypeMisMatch Type Expression
+ | C_BasicInitWithoutValue String
+ // Miscellaneous
+ | UnknownError String
+
+instance toString Error
diff --git a/Sil/Error.icl b/Sil/Error.icl
new file mode 100644
index 0000000..b5d5941
--- /dev/null
+++ b/Sil/Error.icl
@@ -0,0 +1,25 @@
+implementation module Sil.Error
+
+import StdString
+
+import Text
+
+import Sil.Syntax
+import Sil.Types
+
+instance toString Error
+where
+ toString (P_Invalid loc sym) = "Invalid token '" <+ sym <+ "' while parsing a " <+ loc <+ "."
+ toString (P_Expected s) = "Expected " <+ s <+ "."
+ toString (T_IllegalApplication ft et) = "Cannot apply a " <+ et <+ " to a " <+ ft <+ "."
+ toString (T_IllegalField f t) = "Illegal field '" <+ f <+ "' on type " <+ t <+ "."
+ toString (T_TooHighTupleArity i) = "Too high tuple arity " <+ i <+ " (maximum is 32)."
+ toString (C_UndefinedName n) = "Undefined name '" <+ n <+ "'."
+ toString (C_UndefinedField f) = "Undefined field '" <+ f <+ "'."
+ toString C_VariableLabel = "Variable stored at label."
+ toString C_FunctionOnStack = "Function stored on the stack."
+ toString (C_TypeError err e) = "Type error in '" <+ e <+ "': " <+ err
+ toString (C_CouldNotDeduceType e) = "Could not deduce type of '" <+ e <+ "'."
+ toString (C_TypeMisMatch t e) = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'."
+ toString (C_BasicInitWithoutValue n) = "Basic value '" <+ n <+ "' must have an initial value."
+ toString (UnknownError e) = "Unknown error: " <+ e <+ "."
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index d5bf453..441bf9e 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -4,6 +4,7 @@ from StdOverloaded import class ==, class toString
from Data.Error import :: MaybeError
+from Sil.Error import :: Error
from Sil.Syntax import :: Program, :: Literal
from Sil.Util.Parser import class name
@@ -38,13 +39,6 @@ instance == Token
instance toString Token
instance name Token
-:: ParseError
- = E.a: Invalid String a & toString a
- | Expected String
- | UnknownError
+tokenise :: [Char] -> MaybeError Error [Token]
-instance toString ParseError
-
-tokenise :: [Char] -> MaybeError ParseError [Token]
-
-parse :: ([Token] -> MaybeError ParseError Program)
+parse :: ([Token] -> MaybeError Error Program)
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 4fdc479..c9521bf 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -20,6 +20,7 @@ from Text import <+, class Text, instance Text String
import GenEq
+import Sil.Error
import Sil.Syntax
import Sil.Types
import Sil.Util.Parser
@@ -58,16 +59,10 @@ where
name (TMachineCode _) = "machine code"
name t = toString t
-instance toString ParseError
-where
- toString (Invalid loc sym) = "Invalid token '" <+ sym <+ "' while parsing a " <+ loc <+ "."
- toString (Expected s) = "Expected " <+ s <+ "."
- toString UnknownError = "Unknown error."
-
-tokenise :: [Char] -> MaybeError ParseError [Token]
+tokenise :: [Char] -> MaybeError Error [Token]
tokenise cs = reverse <$> tks cs []
where
- tks :: [Char] [Token] -> MaybeError ParseError [Token]
+ tks :: [Char] [Token] -> MaybeError Error [Token]
tks [] t = pure t
tks ['/':'/':r] t = tks (dropWhile ((<>) '\n') r) t
tks ['/':'*':r] t = tks (skipUntilEndOfComment r) t
@@ -105,7 +100,7 @@ where
tks cs=:[h:_] t
| isSpace h = tks (dropWhile isSpace cs) t
| isDigit h = tks numrest [TLit $ ILit $ toInt $ toString num:t]
- | not (isNameChar h) = Error $ Invalid "name" h
+ | not (isNameChar h) = Error $ P_Invalid "name" h
| otherwise = tks namerest [TName $ toString name:t]
where
(name,namerest) = span isNameChar cs
@@ -116,7 +111,7 @@ where
isNotNameChar = not o isNameChar
-parse :: ([Token] -> MaybeError ParseError Program)
+parse :: ([Token] -> MaybeError Error Program)
parse = fst o runParser program
program :: Parser Token Program
@@ -239,14 +234,14 @@ where
<|> parenthised expression
name :: Parser Token Name
-name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
+name = liftM (\(TName s) -> s) $ satisfy isName <?> P_Expected "name"
where
isName (TName _) = True
isName _ = False
arg :: Parser Token Arg
arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
- <?> Expected "argument"
+ <?> P_Expected "argument"
type :: Parser Token Type
type
@@ -254,7 +249,7 @@ type
<|> simpletype "Int" TInt
<|> simpletype "Void" TVoid
<|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
- <?> Expected "type"
+ <?> P_Expected "type"
where
simpletype s t = item (TName s) $> t
diff --git a/Sil/Types.dcl b/Sil/Types.dcl
index 013f064..51d4229 100644
--- a/Sil/Types.dcl
+++ b/Sil/Types.dcl
@@ -7,6 +7,7 @@ from Data.Maybe import :: Maybe
from ABC.Assembler import :: BasicType
+from Sil.Error import :: Error
from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
:: Type
@@ -16,11 +17,6 @@ from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
| (-->) infixr Type Type
| TTuple Int [Type]
-:: TypeError
- = IllegalApplication Type Type
- | IllegalField Name Type
- | TooHighTupleArity Int
-
:: TypeSize =
{ asize :: Int
, bsize :: Int
@@ -30,7 +26,6 @@ from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
instance == Type
instance toString Type
-instance toString TypeError
instance zero TypeSize
@@ -42,11 +37,11 @@ typeSize :: Type -> TypeSize
(+~) infixl 6 :: TypeSize TypeSize -> TypeSize
(-~) infixl 6 :: TypeSize TypeSize -> TypeSize
-:: TypeResolver :== Name -> Maybe (MaybeError TypeError Type)
+:: TypeResolver :== Name -> Maybe (MaybeError Error Type)
instance zero TypeResolver
-class type a :: TypeResolver a -> Maybe (MaybeError TypeError Type)
+class type a :: TypeResolver a -> Maybe (MaybeError Error Type)
instance type Function
instance type Expression
instance type Name
diff --git a/Sil/Types.icl b/Sil/Types.icl
index b2009dd..e314342 100644
--- a/Sil/Types.icl
+++ b/Sil/Types.icl
@@ -19,6 +19,7 @@ from Text import <+
from ABC.Assembler import :: BasicType(..)
+import Sil.Error
import Sil.Syntax
import Sil.Util.Printer
@@ -33,12 +34,6 @@ where
toString (at --> rt) = "(" <+ at <+ " -> " <+ rt <+ ")"
toString (TTuple _ ts) = "(" <+ printersperse ", " ts <+ ")"
-instance toString TypeError
-where
- toString (IllegalApplication ft et) = "Cannot apply a " <+ et <+ " to a " <+ ft <+ "."
- toString (IllegalField f t) = "Illegal field '" <+ f <+ "' on type " <+ t <+ "."
- toString (TooHighTupleArity i) = "Too high tuple arity " <+ i <+ " (maximum is 32)."
-
instance zero TypeSize where zero = {asize=0, bsize=0, btypes=[]}
typeSize :: Type -> TypeSize
@@ -91,27 +86,27 @@ where
te1 >>= \te1 ->
te2 >>= \te2 -> foldM tryApply top [te1,te2])
type res (Tuple n es)
- | n > 32 = Just $ Error $ TooHighTupleArity n
+ | n > 32 = Just $ Error $ T_TooHighTupleArity n
| otherwise =
mapM (type res) es >>= \ats -> pure (sequence ats >>= pure o TTuple n)
type res (Field f e)
| isTuple = type res e >>= \te -> pure (te >>= \te -> case te of
TTuple arity es -> if (0 < tupleEl && tupleEl <= arity)
(Ok $ es!!(tupleEl - 1))
- (Error $ IllegalField f te)
- _ -> Error $ IllegalField f te)
- | otherwise = type res e >>= \te -> pure (te >>= Error o IllegalField f)
+ (Error $ T_IllegalField f te)
+ _ -> Error $ T_IllegalField f te)
+ | otherwise = type res e >>= \te -> pure (te >>= Error o T_IllegalField f)
where
f` = fromString f
isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`)
tupleEl = toInt $ toString $ tl f`
-tryApply :: Type Type -> MaybeError TypeError Type
+tryApply :: Type Type -> MaybeError Error Type
tryApply ft=:(at --> rt) et
| et == at = Ok rt
-| otherwise = Error $ IllegalApplication ft et
-tryApply ft et = Error $ IllegalApplication ft et
+| otherwise = Error $ T_IllegalApplication ft et
+tryApply ft et = Error $ T_IllegalApplication ft et
instance type Name where type res n = res n
diff --git a/Sil/Util/Parser.dcl b/Sil/Util/Parser.dcl
index 361fa83..65b050e 100644
--- a/Sil/Util/Parser.dcl
+++ b/Sil/Util/Parser.dcl
@@ -7,9 +7,9 @@ from Control.Monad import class Monad
from Data.Error import :: MaybeError
from Data.Functor import class Functor
-from Sil.Parse import :: ParseError
+from Sil.Parse import :: Error
-:: Parser a b = Parser ([a] -> (MaybeError ParseError b, [a]))
+:: Parser a b = Parser ([a] -> (MaybeError Error b, [a]))
instance Functor (Parser a)
instance Applicative (Parser a)
@@ -19,8 +19,8 @@ instance Alternative (Parser a)
class name a :: a -> String
instance name String
-runParser :: (Parser a b) [a] -> (MaybeError ParseError b, [a])
-(<?>) :: (Parser a b) ParseError -> Parser a b
+runParser :: (Parser a b) [a] -> (MaybeError Error b, [a])
+(<?>) :: (Parser a b) Error -> Parser a b
fail :: Parser a b
top :: Parser a a
peek :: Parser a a
diff --git a/Sil/Util/Parser.icl b/Sil/Util/Parser.icl
index f0895fe..d13bc09 100644
--- a/Sil/Util/Parser.icl
+++ b/Sil/Util/Parser.icl
@@ -10,7 +10,7 @@ from Data.Func import $
import Data.Functor
import Data.List
-import Sil.Parse
+import Sil.Error
instance Functor (Parser a) where
fmap f m = liftM f m
@@ -25,7 +25,7 @@ instance Monad (Parser a) where
(Error e, _) -> (Error e, i)
instance Alternative (Parser a) where
- empty = Parser \i -> (Error UnknownError, i)
+ empty = Parser \i -> (Error $ UnknownError "empty in Parser", i)
(<|>) p1 p2 = Parser \i -> case runParser p1 i of
(Ok r, rest) -> (Ok r, rest)
(Error e1, rest) -> case runParser p2 i of
@@ -34,10 +34,10 @@ instance Alternative (Parser a) where
instance name String where name s = s
-runParser :: (Parser a b) [a] -> (MaybeError ParseError b, [a])
+runParser :: (Parser a b) [a] -> (MaybeError Error b, [a])
runParser (Parser f) i = f i
-(<?>) :: (Parser a b) ParseError -> Parser a b
+(<?>) :: (Parser a b) Error -> Parser a b
(<?>) p e = Parser \i -> case runParser p i of
(Error _, rest) -> (Error e, rest)
o -> o
@@ -47,12 +47,12 @@ fail = empty
top :: Parser a a
top = Parser \i -> case i of
- [] = (Error UnknownError, [])
+ [] = (Error $ UnknownError "top in Parser failed", [])
[x:xs] = (Ok x, xs)
peek :: Parser a a
peek = Parser \i -> case i of
- [] = (Error UnknownError, [])
+ [] = (Error $ UnknownError "peek in Parser failed", [])
[x:xs] = (Ok x, [x:xs])
satisfy :: (a -> Bool) -> Parser a a
@@ -77,7 +77,7 @@ where
(Ok r, rest) -> (Ok r, rest)
item :: a -> Parser a a | ==, name a
-item a = satisfy ((==) a) <?> Expected (name a)
+item a = satisfy ((==) a) <?> P_Expected (name a)
list :: [a] -> Parser a [a] | ==, name a
list as = mapM item as
@@ -90,4 +90,4 @@ seplist sep p = liftM2 (\es e-> es ++ [e]) (some (p <* item sep)) p
eof :: Parser a ()
eof = Parser \i -> case i of
[] = (Ok (), [])
- _ = (Error $ Expected "eof", i)
+ _ = (Error $ P_Expected "eof", i)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:19:39 +0000