aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Sil/Error.dcl11
-rw-r--r--Sil/Error.icl44
-rw-r--r--Sil/Parse.icl47
-rw-r--r--Sil/Util/Parser.dcl16
-rw-r--r--Sil/Util/Parser.icl49
5 files changed, 116 insertions, 51 deletions
diff --git a/Sil/Error.dcl b/Sil/Error.dcl
index c37e445..bdfa390 100644
--- a/Sil/Error.dcl
+++ b/Sil/Error.dcl
@@ -1,7 +1,9 @@
definition module Sil.Error
from StdFile import class <<<
-from StdOverloaded import class toString
+from StdOverloaded import class toString, class <
+
+from Data.Maybe import :: Maybe
from Sil.Syntax import :: Expression
from Sil.Types import :: Type
@@ -9,10 +11,12 @@ from Sil.Util.Parser import :: ParsePosition, class getPos
:: ErrorPosition
+instance < ErrorPosition
+
:: Error
// Parser errors
= E.a: P_Invalid String a & toString a
- | P_Expected String
+ | E.a: P_Expected ErrorPosition String a & toString a
// Type errors
| T_IllegalApplication Type Type
| T_IllegalField String Type
@@ -39,5 +43,8 @@ from Sil.Util.Parser import :: ParsePosition, class getPos
instance toString Error
instance <<< Error
+instance < Error // Based on position in file, to choose the furthest error in the parser
+
+getErrorPosition :: Error -> Maybe ErrorPosition
errpos :: a -> ErrorPosition | getPos a
diff --git a/Sil/Error.icl b/Sil/Error.icl
index 36a614b..fde96ee 100644
--- a/Sil/Error.icl
+++ b/Sil/Error.icl
@@ -1,8 +1,10 @@
implementation module Sil.Error
import StdFile
+import StdInt
import StdString
+import Data.Maybe
import Text
import Sil.Syntax
@@ -10,9 +12,12 @@ import Sil.Types
import Sil.Util.Parser
:: ErrorPosition =
- { ep_line :: Int
+ { ep_line :: Int
+ , ep_token :: Int
}
+instance < ErrorPosition where < p1 p2 = p1.ep_token < p2.ep_token
+
instance toString ErrorPosition
where
toString ep = ep.ep_line <+ ":\t"
@@ -20,7 +25,7 @@ where
instance toString Error
where
toString (P_Invalid w tk) = "\tInvalid token '" <+ tk <+ "' while parsing a " <+ w <+ "."
- toString (P_Expected s) = "\tExpected " <+ s <+ "."
+ toString (P_Expected p s h) = p <+ "Expected " <+ s <+ " near '" <+ h <+ "'."
toString (T_IllegalApplication ft et) = "\tCannot apply a " <+ et <+ " to a " <+ ft <+ "."
toString (T_IllegalField f t) = "\tIllegal field '" <+ f <+ "' on type " <+ t <+ "."
toString (T_TooHighTupleArity i) = "\tToo high tuple arity " <+ i <+ " (maximum is 32)."
@@ -43,5 +48,38 @@ where
instance <<< Error where <<< f e = f <<< toString e <<< "\r\n"
+instance < Error
+where
+ < _ (UnknownError _) = False
+ < (UnknownError _) _ = True
+ < e1 e2 = case (getErrorPosition e1, getErrorPosition e2) of
+ (Just p1, Just p2) -> p1 < p2
+ (_ , Nothing) -> False
+ (Nothing, _ ) -> True
+
+getErrorPosition :: Error -> Maybe ErrorPosition
+getErrorPosition (P_Invalid w tk) = Nothing
+getErrorPosition (P_Expected p s h) = Just p
+getErrorPosition (T_IllegalApplication ft et) = Nothing
+getErrorPosition (T_IllegalField f t) = Nothing
+getErrorPosition (T_TooHighTupleArity i) = Nothing
+getErrorPosition Ck_NoMainFunction = Nothing
+getErrorPosition (Ck_MainFunctionInvalidType p t) = Just p
+getErrorPosition (Ck_DuplicateFunctionName p n) = Just p
+getErrorPosition (Ck_DuplicateLocalName p f arg) = Just p
+getErrorPosition (Ck_ReturnExpressionFromVoid p f) = Just p
+getErrorPosition (Ck_NoReturnFromNonVoid p f) = Just p
+getErrorPosition (Ck_LocalVoid f l) = Nothing
+getErrorPosition (Ck_BasicGlobal p g) = Just p
+getErrorPosition (C_UndefinedName n) = Nothing
+getErrorPosition (C_UndefinedField f) = Nothing
+getErrorPosition C_VariableLabel = Nothing
+getErrorPosition C_FunctionOnStack = Nothing
+getErrorPosition (C_CouldNotDeduceType e) = Nothing
+getErrorPosition (C_TypeMisMatch t e u) = Nothing
+getErrorPosition (C_BasicInitWithoutValue n) = Nothing
+getErrorPosition (UnknownError e) = Nothing
+
errpos :: a -> ErrorPosition | getPos a
-errpos x = {ep_line=(getPos x).pp_line}
+errpos x = {ep_line=p.pp_line, ep_token=p.pp_token}
+where p = getPos x
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 6a3999d..2c8272d 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -141,17 +141,17 @@ parse = fst o runParser program o makeParseState
program :: Parser Token Program
program =
many initialisation >>= \globss ->
- some function >>= \fs ->
- eof $>
- {p_globals=flatten globss, p_funs=fs}
+ function until eof >>= \fs ->
+ pure {p_globals=flatten globss, p_funs=reverse fs}
function :: Parser Token Function
function =
type >>= \t ->
getPosition >>= \pos ->
name >>= \n ->
- parenthised (seplist TComma arg) >>= \args ->
- braced codeblock >>= \cb -> pure
+ item TParenOpen *>
+ seplistUntil TParenClose TComma arg >>= \args ->
+ codeblock >>= \cb -> pure
{ f_type = t
, f_name = n
, f_args = args
@@ -160,8 +160,10 @@ function =
}
codeblock :: Parser Token CodeBlock
-codeblock = many initialisation >>= \is ->
- many statement >>= \s ->
+codeblock =
+ item TBraceOpen *>
+ many initialisation >>= \is ->
+ statement until (item TBraceClose) >>= \s ->
pure {cb_init=flatten is, cb_content=s}
initialisation :: Parser Token [Initialisation]
@@ -182,7 +184,7 @@ statement =
<|> if` pos
<|> while pos
<|> machinecode pos
- )
+ ) <#> "statement"
where
declaration :: ParsePosition -> Parser Token Statement
declaration p = liftM2 (Declaration p) name (item TAssign *> expression <* item TSemicolon)
@@ -197,20 +199,20 @@ where
if` :: ParsePosition -> Parser Token Statement
if` p = item TIf *>
parenthised expression >>= \cond ->
- braced codeblock >>= \iftrue ->
+ codeblock >>= \iftrue ->
many elseif >>= \elseifs ->
- optional (item TElse *> braced codeblock) >>= \iffalse ->
+ optional (item TElse *> codeblock) >>= \iffalse ->
pure $ If p [(cond,iftrue):elseifs] iffalse
where
elseif = list [TElse, TIf] *>
parenthised expression >>= \cond ->
- braced codeblock >>= \block ->
+ codeblock >>= \block ->
pure (cond, block)
while :: ParsePosition -> Parser Token Statement
while p = item TWhile *>
parenthised expression >>= \cond ->
- braced codeblock >>= \do ->
+ codeblock >>= \do ->
pure $ While p cond do
expression :: Parser Token Expression
@@ -244,7 +246,7 @@ where
noInfix :: Parser Token Expression
noInfix
- = liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
+ = liftM2 App name (item TParenOpen *> seplistUntil TParenClose TComma expression)
<|> op TTilde Neg
<|> op TExclamation Not
<|> (simpleExpr >>= \e -> foldl (flip Field) e <$> many field)
@@ -258,29 +260,27 @@ where
simpleExpr :: Parser Token Expression
simpleExpr = liftM Literal literal
<|> liftM Name name
- <|> (parenthised (min2seplist TComma expression) >>= \es -> pure $ Tuple (length es) es)
<|> flip List [] o pure <$> bracked type
<|> List Nothing <$> bracked (seplist TComma expression)
- <|> parenthised expression
+ <|> (item TParenOpen *> seplistUntil TParenClose TComma expression >>= \es -> pure $ case es of [x] -> x; _ -> Tuple (length es) es)
name :: Parser Token Name
-name = liftM (\(TName s) -> s) $ satisfy isName <?> P_Expected "name"
+name = (\(TName n) -> n) <$> satisfy isName <#> "name"
where
isName (TName _) = True
isName _ = False
arg :: Parser Token Arg
-arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
- <?> P_Expected "argument"
+arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name}) <#> "argument"
type :: Parser Token Type
type
= simpletype "Bool" TBool
<|> simpletype "Int" TInt
<|> simpletype "Void" TVoid
- <|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
+ <|> (parenthised (min1seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
<|> TList <$> bracked type
- <?> P_Expected "type"
+ <#> "type"
where
simpletype s t = item (TName s) $> t
@@ -297,11 +297,8 @@ parenthised p = item TParenOpen *> p <* item TParenClose
bracked :: (Parser Token a) -> Parser Token a
bracked p = item TBrackOpen *> p <* item TBrackClose
-braced :: (Parser Token a) -> Parser Token a
-braced p = item TBraceOpen *> p <* item TBraceClose
-
-min2seplist :: a (Parser a b) -> Parser a [b] | ==, name a
-min2seplist sep val =
+min1seplist :: a (Parser a b) -> Parser a [b] | ==, name, toString a
+min1seplist sep val =
val >>= \v1 ->
item sep *>
seplist sep val >>= \vs ->
diff --git a/Sil/Util/Parser.dcl b/Sil/Util/Parser.dcl
index e5d1cce..14dc022 100644
--- a/Sil/Util/Parser.dcl
+++ b/Sil/Util/Parser.dcl
@@ -1,6 +1,6 @@
definition module Sil.Util.Parser
-from StdOverloaded import class ==
+from StdOverloaded import class ==, class toString
from Control.Applicative import class Applicative, class Alternative
from Control.Monad import class Monad
@@ -13,10 +13,12 @@ from Sil.Error import :: Error
:: *ParseState a
:: ParsePosition =
- { pp_line :: Int
+ { pp_line :: Int
+ , pp_token :: Int
}
class getPos a :: a -> ParsePosition
+instance getPos ParsePosition
:: ParseInput a
= PI_NewLine
@@ -37,13 +39,15 @@ instance name String
runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a)
getPosition :: Parser a ParsePosition
(<?>) :: (Parser a b) Error -> Parser a b
+(<#>) :: (Parser a b) String -> Parser a b | toString a
fail :: Parser a b
top :: Parser a a
peek :: Parser a a
satisfy :: (a -> Bool) -> Parser a a
check :: (a -> Bool) -> Parser a a
(until) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b]
-item :: a -> Parser a a | ==, name a
-list :: [a] -> Parser a [a] | ==, name a
-seplist :: a (Parser a b) -> Parser a [b] | ==, name a
-eof :: Parser a ()
+item :: a -> Parser a a | ==, name, toString a
+list :: [a] -> Parser a [a] | ==, name, toString a
+seplist :: a (Parser a b) -> Parser a [b] | ==, name, toString a
+seplistUntil :: a a (Parser a b) -> Parser a [b] | ==, name, toString a
+eof :: Parser a () | toString a
diff --git a/Sil/Util/Parser.icl b/Sil/Util/Parser.icl
index 92bc08f..e730313 100644
--- a/Sil/Util/Parser.icl
+++ b/Sil/Util/Parser.icl
@@ -14,6 +14,8 @@ import Data.Maybe
import Sil.Error
+instance getPos ParsePosition where getPos pp = pp
+
:: *ParseState a =
{ ps_line :: Int
, ps_input :: [ParseInput a]
@@ -56,27 +58,31 @@ dropCommit ps = {ps & ps_commits=tl ps.ps_commits}
restoreCommit :: (ParseState a) -> ParseState a
restoreCommit ps=:{ps_commits=[c:cs]} = iter (ps.ps_pos - c) tokenBack {ps & ps_commits=cs}
-instance Functor (Parser a) where
+instance Functor (Parser a)
+where
fmap f m = liftM f m
-instance Applicative (Parser a) where
+instance Applicative (Parser a)
+where
pure a = Parser \st -> (Ok a, st)
(<*>) sf p = ap sf p
-instance Monad (Parser a) where
+instance Monad (Parser a)
+where
bind p f = Parser \st -> case runParser p (commit st) of
(Error e, st) -> (Error e, restoreCommit st)
(Ok r, st) -> case runParser (f r) st of
(Ok r, st) -> (Ok r, dropCommit st)
(Error e, st) -> (Error e, restoreCommit st)
-instance Alternative (Parser a) where
+instance Alternative (Parser a)
+where
empty = Parser \st -> (Error $ UnknownError "empty in Parser", st)
(<|>) p1 p2 = Parser \st -> case runParser p1 (commit st) of
(Ok r, st) -> (Ok r, dropCommit st)
(Error e1, st) -> case runParser p2 (commit $ restoreCommit st) of
(Ok r, st) -> (Ok r, dropCommit st)
- (Error e2, st) -> (Error e2, restoreCommit st)
+ (Error e2, st) -> (Error $ max e1 e2, restoreCommit st)
instance name String where name s = s
@@ -87,13 +93,16 @@ runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a
runParser (Parser f) i = f i
getPosition :: Parser a ParsePosition
-getPosition = Parser \st=:{ps_line} -> (Ok {pp_line=ps_line}, st)
+getPosition = Parser \st=:{ps_line,ps_pos} -> (Ok {pp_line=ps_line,pp_token=ps_pos}, st)
(<?>) :: (Parser a b) Error -> Parser a b
(<?>) p e = Parser \i -> case runParser p i of
(Error _, st) -> (Error e, st)
o -> o
+(<#>) :: (Parser a b) String -> Parser a b | toString a
+(<#>) p what = p <|> (getPosition >>= \pos -> peek >>= \e -> Parser \st -> (Error $ P_Expected (errpos pos) what e, st))
+
fail :: Parser a b
fail = empty
@@ -128,18 +137,28 @@ where
(Error e, st) -> (Error e, st)
(Ok r, st) -> (Ok r, st)
-item :: a -> Parser a a | ==, name a
-item a = satisfy ((==) a) <?> P_Expected (name a)
+item :: a -> Parser a a | ==, name, toString a
+item a = satisfy ((==) a) <#> name a
-list :: [a] -> Parser a [a] | ==, name a
+list :: [a] -> Parser a [a] | ==, name, toString a
list as = mapM item as
-seplist :: a (Parser a b) -> Parser a [b] | ==, name a
-seplist sep p = liftM2 (\es e-> es ++ [e]) (some (p <* item sep)) p
- <|> liftM pure p
+seplist :: a (Parser a b) -> Parser a [b] | ==, name, toString a
+seplist sep p = liftM2 (\e es -> [e:es]) p (many (p <* item sep))
<|> pure empty
-eof :: Parser a ()
-eof = Parser \st -> case nextToken st of
+seplistUntil :: a a (Parser a b) -> Parser a [b] | ==, name, toString a
+seplistUntil end sep p =
+ liftM2 (\e es -> [e:es]) p ((item sep *> p) until` (item end))
+ <|> liftM pure (p <* item end)
+ <|> (pure empty <* item end)
+where
+ (until`) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b]
+ (until`) p1 guard = (p1 until guard) >>= \xs -> case xs of
+ [] -> fail
+ xs -> pure xs
+
+eof :: Parser a () | toString a
+eof = Parser \st=:{ps_line,ps_pos} -> case nextToken st of
(Nothing, st) -> (Ok (), st)
- (t, st) -> (Error $ P_Expected "eof", st)
+ (Just t, st) -> (Error $ P_Expected (errpos {pp_line=ps_line,pp_token=ps_pos}) "eof" t, st)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:35:28 +0000