aboutsummaryrefslogtreecommitdiff
path: root/Sil
diff options
context:
space:
mode:
Diffstat (limited to 'Sil')
-rw-r--r--Sil/Parse.icl17
-rw-r--r--Sil/Util/Parser.dcl6
-rw-r--r--Sil/Util/Parser.icl95
3 files changed, 73 insertions, 45 deletions
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index be8079e..80bca2b 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -43,12 +43,14 @@ where
toString (TField f) = "." +++ f
toString TAssign = ":="
toString TTilde = "~"
+ toString TExclamation = "!"
toString TPlus = "+"
toString TMinus = "-"
toString TStar = "*"
toString TSlash = "/"
toString TPercent = "%"
toString TEquals = "=="
+ toString TUnequals = "<>"
toString TLe = "<="
toString TGe = ">="
toString TLt = "<"
@@ -57,13 +59,16 @@ where
toString TDoubleAmpersand = "&&"
toString (TLit l) = toString l
toString TIf = "if"
+ toString TElse = "else"
toString TWhile = "while"
toString TReturn = "return"
toString (TMachineCode s) = "|~ " +++ s
toString (TName s) = s
+ toString t = "???"
instance name Token
where
+ name (TField _) = "field"
name (TLit _) = "literal"
name (TName _) = "name"
name (TMachineCode _) = "machine code"
@@ -145,12 +150,9 @@ function =
type >>= \t ->
getPositioner >>= \pos ->
name >>= \n ->
- item TParenOpen *>
- seplist TComma arg >>= \args ->
- item TParenClose *>
- item TBraceOpen *>
- codeblock >>= \cb ->
- item TBraceClose $> pos
+ parenthised (seplist TComma arg) >>= \args ->
+ braced codeblock >>= \cb ->
+ pure $ pos
{ f_type = t
, f_name = n
, f_args = args
@@ -163,8 +165,7 @@ codeblock = many initialisation >>= \is ->
pure {cb_init=flatten is, cb_content=s}
initialisation :: Parser Token [Positioned Initialisation]
-initialisation =
- type >>= \t -> seplist TComma (init t) <* item TSemicolon
+initialisation = type >>= \t -> seplist TComma (init t) <* item TSemicolon
where
init t =
getPositioner >>= \pos ->
diff --git a/Sil/Util/Parser.dcl b/Sil/Util/Parser.dcl
index 8474b78..6f5929c 100644
--- a/Sil/Util/Parser.dcl
+++ b/Sil/Util/Parser.dcl
@@ -17,7 +17,7 @@ from Sil.Error import :: Error
fromPositioned :: (Positioned a) -> a
-:: ParseState a
+:: *ParseState a
:: ParseInput a
= PI_NewLine
@@ -25,7 +25,7 @@ fromPositioned :: (Positioned a) -> a
makeParseState :: [ParseInput a] -> ParseState a
-:: Parser a b = Parser ((ParseState a) -> (MaybeError Error b, ParseState a))
+:: Parser a b = Parser (*(ParseState a) -> *(MaybeError Error b, *ParseState a))
instance Functor (Parser a)
instance Applicative (Parser a)
@@ -35,7 +35,7 @@ instance Alternative (Parser a)
class name a :: a -> String
instance name String
-runParser :: (Parser a b) (ParseState a) -> (MaybeError Error b, ParseState a)
+runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a)
getPositioner :: Parser a (b -> Positioned b)
(<?>) :: (Parser a b) Error -> Parser a b
fail :: Parser a b
diff --git a/Sil/Util/Parser.icl b/Sil/Util/Parser.icl
index 34cf057..83da78c 100644
--- a/Sil/Util/Parser.icl
+++ b/Sil/Util/Parser.icl
@@ -1,5 +1,6 @@
implementation module Sil.Util.Parser
+from StdFunc import iter
import StdList
import StdOverloaded
@@ -16,26 +17,47 @@ import Sil.Error
fromPositioned :: (Positioned a) -> a
fromPositioned p = p.pos_val
-:: ParseState a =
- { ps_line :: Int
- , ps_input :: [ParseInput a]
- , ps_read :: [ParseInput a]
+:: *ParseState a =
+ { ps_line :: Int
+ , ps_input :: [ParseInput a]
+ , ps_read :: [ParseInput a]
+ , ps_pos :: Int
+ , ps_commits :: [Int]
}
makeParseState :: [ParseInput a] -> ParseState a
-makeParseState i = {ps_line=1, ps_input=i, ps_read=[]}
+makeParseState i =
+ { ps_line = 1
+ , ps_input = i
+ , ps_read = []
+ , ps_pos = 0
+ , ps_commits = []
+ }
nextToken :: (ParseState a) -> (Maybe a, ParseState a)
-nextToken ps = case ps.ps_input of
- [] -> (Nothing, ps)
- [PI_Token t:i] -> (Just t, {ps & ps_read=[PI_Token t:ps.ps_read], ps_input=i})
- [PI_NewLine:i] -> nextToken {ps & ps_line=ps.ps_line + 1, ps_read=[PI_NewLine:ps.ps_read], ps_input=i}
+nextToken ps=:{ps_input=[]} = (Nothing, ps)
+nextToken ps=:{ps_input=[i:is]} = case i of
+ PI_Token t -> (Just t, {advance & ps_pos=ps.ps_pos + 1})
+ PI_NewLine -> nextToken {advance & ps_line=ps.ps_line + 1}
+where
+ advance = {ps & ps_read=[i:ps.ps_read], ps_input=is}
tokenBack :: (ParseState a) -> ParseState a
-tokenBack ps = case ps.ps_read of
- [] -> ps
- [PI_Token t:r] -> {ps & ps_read=r, ps_input=[PI_Token t:ps.ps_input]}
- [PI_NewLine:r] -> tokenBack {ps & ps_read=r, ps_input=[PI_NewLine:ps.ps_input], ps_line=ps.ps_line-1}
+tokenBack ps=:{ps_read=[]} = ps
+tokenBack ps=:{ps_read=[r:rs]} = case r of
+ PI_Token t -> {rewind & ps_pos=ps.ps_pos - 1}
+ PI_NewLine -> tokenBack {rewind & ps_line=ps.ps_line-1}
+where
+ rewind = {ps & ps_read=rs, ps_input=[r:ps.ps_input]}
+
+commit :: (ParseState a) -> ParseState a
+commit ps = {ps & ps_commits=[ps.ps_pos:ps.ps_commits]}
+
+dropCommit :: (ParseState a) -> ParseState a
+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
fmap f m = liftM f m
@@ -45,30 +67,35 @@ instance Applicative (Parser a) where
(<*>) sf p = ap sf p
instance Monad (Parser a) where
- bind p f = Parser \st -> case runParser p st of
- (Ok r, rest) -> runParser (f r) rest
- (Error e, _) -> (Error e, st)
+ 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
empty = Parser \st -> (Error $ UnknownError "empty in Parser", st)
- (<|>) p1 p2 = Parser \st -> case runParser p1 st of
- (Ok r, rest) -> (Ok r, rest)
- (Error e1, rest) -> case runParser p2 st of
- (Error e2, rest) -> (Error e2, st)
- (Ok r, rest) -> (Ok r, rest)
+ (<|>) 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)
instance name String where name s = s
-runParser :: (Parser a b) (ParseState a) -> (MaybeError Error b, ParseState a)
+doPS :: ((ParseState a) -> ParseState a) -> Parser a ()
+doPS f = Parser \st -> (Ok (), f st)
+
+runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a)
runParser (Parser f) i = f i
getPositioner :: Parser a (b -> Positioned b)
-getPositioner = Parser \st -> (Ok \x -> {pos_line=st.ps_line, pos_val=x}, st)
+getPositioner = Parser \st=:{ps_line} -> (Ok \x -> {pos_line=ps_line, pos_val=x}, st)
(<?>) :: (Parser a b) Error -> Parser a b
(<?>) p e = Parser \i -> case runParser p i of
- (Error _, rest) -> (Error e, rest)
- o -> o
+ (Error _, st) -> (Error e, st)
+ o -> o
fail :: Parser a b
fail = empty
@@ -93,19 +120,19 @@ check f = peek >>= \r -> if (f r) (pure r) fail
(until) p guard = try $ until` p guard []
where
until` :: (Parser a b) (Parser a c) [b] -> Parser a [b]
- until` p guard acc = Parser \st -> case runParser guard st of
- (Ok _, rest) -> (Ok acc, rest)
- (Error _, _) -> case runParser p st of
- (Ok r, rest) -> runParser (until` p guard [r:acc]) rest
- (Error e, _) -> (Error e, st)
+ until` p guard acc = Parser \st -> case runParser guard (commit st) of
+ (Ok _, st) -> (Ok acc, dropCommit st)
+ (Error _, st) -> case runParser p (commit $ restoreCommit st) of
+ (Ok r, st) -> runParser (until` p guard [r:acc]) (dropCommit st)
+ (Error e, st) -> (Error e, restoreCommit st)
try :: (Parser a b) -> Parser a b
try p = Parser \st -> case runParser p st of
- (Error e, _) -> (Error e, st)
- (Ok r, rest) -> (Ok r, rest)
+ (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 = satisfy ((==) a) <?> P_Expected (name a)
list :: [a] -> Parser a [a] | ==, name a
list as = mapM item as
@@ -118,4 +145,4 @@ seplist sep p = liftM2 (\es e-> es ++ [e]) (some (p <* item sep)) p
eof :: Parser a ()
eof = Parser \st -> case nextToken st of
(Nothing, st) -> (Ok (), st)
- (_, st) -> (Error $ P_Expected "eof", st)
+ (t, st) -> (Error $ P_Expected "eof", st)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:01:25 +0000