aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Sil/Check.dcl18
-rw-r--r--Sil/Check.icl91
-rw-r--r--Sil/Compile.icl25
-rw-r--r--Sil/Error.dcl35
-rw-r--r--Sil/Error.icl47
-rw-r--r--Sil/Parse.dcl6
-rw-r--r--Sil/Parse.icl105
-rw-r--r--Sil/Syntax.dcl9
-rw-r--r--Sil/Syntax.icl9
-rw-r--r--Sil/Util/Parser.dcl23
-rw-r--r--Sil/Util/Parser.icl72
-rw-r--r--Sil/Util/Printer.dcl4
-rw-r--r--Sil/Util/Printer.icl4
-rw-r--r--sil.icl4
14 files changed, 261 insertions, 191 deletions
diff --git a/Sil/Check.dcl b/Sil/Check.dcl
index 9eff566..c2ba86f 100644
--- a/Sil/Check.dcl
+++ b/Sil/Check.dcl
@@ -4,19 +4,7 @@ from StdOverloaded import class toString
from Data.Maybe import :: Maybe
-from Sil.Syntax import :: Program, :: Name
-from Sil.Types import :: Type
+from Sil.Error import :: Error
+from Sil.Syntax import :: Program
-:: CheckError
- = NoMainFunction
- | MainFunctionInvalidType Type
- | DuplicateFunctionName Name
- | DuplicateLocalName Name Name
- | ReturnExpressionFromVoid Name
- | NoReturnFromNonVoid Name
- | LocalVoid Name Name
- | BasicGlobal Name
-
-instance toString CheckError
-
-checkProgram :: *(Maybe *File) Program -> *([CheckError], *Maybe *File)
+checkProgram :: *(Maybe *File) Program -> *([Error], *Maybe *File)
diff --git a/Sil/Check.icl b/Sil/Check.icl
index f9147bf..c9ccecb 100644
--- a/Sil/Check.icl
+++ b/Sil/Check.icl
@@ -15,31 +15,12 @@ import Data.Maybe
import Data.Tuple
from Text import <+
+import Sil.Error
import Sil.Syntax
import Sil.Types
+import Sil.Util.Parser
-instance toString CheckError
-where
- toString NoMainFunction
- = "Error: no main function."
- toString (MainFunctionInvalidType t)
- = "Error: function 'main' should not have arguments has type " <+ t <+ "."
- toString (DuplicateFunctionName n)
- = "Error: multiply defined: '" <+ n <+ "'."
- toString (DuplicateLocalName f arg)
- = "Error: multiply defined: '" <+ arg <+ "' in '" <+ f <+ "'."
- toString (ReturnExpressionFromVoid f)
- = "Type error: an expression was returned from void function '" <+ f <+ "'."
- toString (NoReturnFromNonVoid f)
- = "Type error: no return from non-void function '" <+ f <+ "'."
- toString (LocalVoid f l)
- = "Type error: local variable '" <+ l <+ "' in '" <+ f <+ "' cannot have type Void."
- toString (BasicGlobal g)
- = "Error: global variable '" <+ g <+ "' cannot have a basic type."
-
-instance <<< CheckError where <<< f e = f <<< toString e <<< "\r\n"
-
-checkProgram :: *(Maybe *File) Program -> *([CheckError], *Maybe *File)
+checkProgram :: *(Maybe *File) Program -> *([Error], *Maybe *File)
checkProgram err prog
= checkErrors
[ checkFunctionNames
@@ -48,24 +29,25 @@ checkProgram err prog
] prog
$ appFst flatten $ mapSt (flip checkFunction) prog.p_funs err
where
- checkMainFunction :: Program -> [CheckError]
- checkMainFunction p = case [f \\ f <- p.p_funs | f.f_name == "main"] of
- [] -> [NoMainFunction]
+ checkMainFunction :: Program -> [Error]
+ checkMainFunction p = case [f \\ f <- p.p_funs | f.pos_val.f_name == "main"] of
+ [] -> [Ck_NoMainFunction]
_ -> []
- checkFunctionNames :: Program -> [CheckError]
+ checkFunctionNames :: Program -> [Error]
checkFunctionNames p =
- [ DuplicateFunctionName $ hd fs
- \\ fs <- tails [f.f_name \\ f <- p.p_funs]
- | not (isEmpty fs) && isMember (hd fs) (tl fs)]
+ [ Ck_DuplicateFunctionName (errpos $ hd fs) (fromPositioned $ hd fs).f_name
+ \\ fs <- tails [f \\ f <- p.p_funs]
+ | let names = [f.pos_val.f_name \\ f <- fs]
+ in not (isEmpty names) && isMember (hd names) (tl names)]
- checkGlobals :: Program -> [CheckError]
+ checkGlobals :: Program -> [Error]
checkGlobals p =
- [ BasicGlobal g.init_name
+ [ Ck_BasicGlobal (errpos g) (fromPositioned g).init_name
\\ g <- p.p_globals
- | (typeSize g.init_type).bsize <> 0]
+ | (typeSize (fromPositioned g).init_type).bsize <> 0]
-checkFunction :: *(Maybe *File) Function -> *([CheckError], *Maybe *File)
+checkFunction :: *(Maybe *File) (Positioned Function) -> *([Error], *Maybe *File)
checkFunction err f = checkErrors
[ checkLocals
, checkReturnAndVoid
@@ -73,17 +55,17 @@ checkFunction err f = checkErrors
] f
$ noErrors err
where
- checkReturnAndVoid :: Function -> [CheckError]
- checkReturnAndVoid f = case f.f_type of
+ checkReturnAndVoid :: (Positioned Function) -> [Error]
+ checkReturnAndVoid p=:{pos_val=f} = case f.f_type of
TVoid -> case [st \\ st=:(Return (Just _)) <- allStatements f] of
[] -> []
- _ -> [ReturnExpressionFromVoid f.f_name]
- _ -> if (sureToReturn f.f_code) [] [NoReturnFromNonVoid f.f_name]
+ _ -> [Ck_ReturnExpressionFromVoid (errpos p) f.f_name]
+ _ -> if (sureToReturn f.f_code) [] [Ck_NoReturnFromNonVoid (errpos p) f.f_name]
where
sureToReturn :: CodeBlock -> Bool
sureToReturn cb = case cb.cb_content of
[] -> False
- sts -> case last sts of
+ sts -> case fromPositioned $ last sts of
Return _ -> True
While _ cb` -> sureToReturn cb`
If bs (Just e) -> all sureToReturn [e:map snd bs]
@@ -91,24 +73,27 @@ where
MachineStm _ -> True // Let's assume the user is not stupid
_ -> False
- checkMainFunctionType :: Function -> [CheckError]
- checkMainFunctionType f=:{f_name="main",f_args=[]} = []
- checkMainFunctionType f=:{f_name="main"} = [MainFunctionInvalidType $ fromOk $ fromJust $ type zero f]
- checkMainFunctionType _ = []
+ checkMainFunctionType :: (Positioned Function) -> [Error]
+ checkMainFunctionType {pos_val={f_name="main",f_args=[]}}
+ = []
+ checkMainFunctionType p=:{pos_val=f=:{f_name="main"}}
+ = [Ck_MainFunctionInvalidType (errpos p) $ fromOk $ fromJust $ type zero f]
+ checkMainFunctionType _
+ = []
- checkLocals :: Function -> [CheckError]
- checkLocals f =
+ checkLocals :: (Positioned Function) -> [Error]
+ checkLocals p=:{pos_val=f} =
checkDupName [a.arg_name \\ a <- f.f_args] f.f_code ++
concatMap checkVoid (allLocals f)
where
- checkDupName :: [Name] CodeBlock -> [CheckError]
+ checkDupName :: [Name] CodeBlock -> [Error]
checkDupName defined cb =
- [DuplicateLocalName f.f_name l \\ l <- defined | isMember l locals] ++
+ [Ck_DuplicateLocalName (errpos p) f.f_name l \\ l <- defined | isMember l locals] ++
concatMap (checkDupName (locals ++ defined)) (underlyingCBs cb)
- where locals = [i.init_name \\ i <- cb.cb_init]
+ where locals = [(fromPositioned i).init_name \\ i <- cb.cb_init]
underlyingCBs :: CodeBlock -> [CodeBlock]
- underlyingCBs cb = concatMap findCBs cb.cb_content
+ underlyingCBs cb = concatMap (findCBs o fromPositioned) cb.cb_content
where
findCBs (Declaration _ _) = []
findCBs (Application _) = []
@@ -118,17 +103,17 @@ where
findCBs (While _ cb) = [cb]
findCBs (MachineStm _) = []
- checkVoid :: (Type, Name) -> [CheckError]
- checkVoid (TVoid, n) = [LocalVoid f.f_name n]
+ checkVoid :: (Type, Name) -> [Error]
+ checkVoid (TVoid, n) = [Ck_LocalVoid f.f_name n]
checkVoid _ = []
-checkErrors :: [(a -> [CheckError])] a *([CheckError], Maybe *File) -> *([CheckError], *Maybe *File)
+checkErrors :: [(a -> [Error])] a *([Error], Maybe *File) -> *([Error], *Maybe *File)
checkErrors cks x st = seqSt error (concatMap (flip ($) x) cks) st
-error :: CheckError *([CheckError], *Maybe *File) -> *([CheckError], *Maybe *File)
+error :: Error *([Error], *Maybe *File) -> *([Error], *Maybe *File)
error e (es, err) = ([e:es], err <?< e)
-noErrors :: *(Maybe *File) -> *([CheckError], *Maybe *File)
+noErrors :: *(Maybe *File) -> *([Error], *Maybe *File)
noErrors f = ([], f)
(<?<) infixl :: !*(Maybe *File) !a -> *Maybe *File | <<< a
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index d20eff1..ced497e 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -26,6 +26,7 @@ import qualified ABC.Assembler as ABC
import Sil.Error
import Sil.Syntax
import Sil.Types
+import Sil.Util.Parser
import Sil.Util.Printer
error :: Error -> RWST r w s (MaybeError Error) a
@@ -263,6 +264,9 @@ where
class gen a :: a -> Gen ()
+instance gen (Positioned a) | gen a
+where gen p = gen $ fromPositioned p
+
instance gen Program
where
gen p =
@@ -276,24 +280,27 @@ where
, 'ABC'.Jmp "_driver"
, 'ABC'.Annotation $ 'ABC'.OAnnot 0 []
, 'ABC'.Label "_sil_boot2" ] *>
- let gsize = foldr (+~) zero [typeSize i.init_type \\ i <- p.p_globals] in
+ let gsize = foldr (+~) zero [typeSize i.init_type \\ i <- globs] in
modify (\cs -> {cs & globalsize=(gsize.asize, gsize.bsize)}) *>
shrinkStack gsize *>
- mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- p.p_globals] *>
+ mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- globs] *>
mapM_ gen p.p_globals *>
tell [ 'ABC'.Jmp (toLabel "main") ] *>
pushTypeResolver typeresolver *>
- mapM_ addFunction p.p_funs *>
+ mapM_ (addFunction o fromPositioned) p.p_funs *>
mapM_ gen p.p_funs *>
popTypeResolver
where
typeresolver :: Name -> Maybe (MaybeError Error Type)
- typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of
+ typeresolver n = case [f \\ f <- funs | f.f_name == n] of
[f:_] -> type typeresolver f
- [] -> case [g.init_type \\ g <- p.p_globals | g.init_name == n] of
+ [] -> case [g.init_type \\ g <- globs | g.init_name == n] of
[t:_] -> Just $ Ok t
[] -> Nothing
+ globs = map fromPositioned p.p_globals
+ funs = map fromPositioned p.p_funs
+
instance gen Function
where
gen f =
@@ -368,7 +375,7 @@ where
gen cb =
storeStackOffsets *>
gets stackoffsets >>= \so ->
- mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- cb.cb_init] *>
+ mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- init] *>
mapM_ gen cb.cb_init *>
addToReturn cleanup` *>
pushTypeResolver typeresolver *>
@@ -383,10 +390,12 @@ where
_ -> [ 'ABC'.Pop_a locals.asize
, 'ABC'.Pop_b locals.bsize
]
- locals = foldr (+~) zero [typeSize i.init_type \\ i <- cb.cb_init]
+ locals = foldr (+~) zero [typeSize i.init_type \\ i <- init]
typeresolver :: Name -> Maybe (MaybeError Error Type)
- typeresolver n = listToMaybe [Ok i.init_type \\ i <- cb.cb_init | i.init_name == n]
+ typeresolver n = listToMaybe [Ok i.init_type \\ i <- init | i.init_name == n]
+
+ init = map fromPositioned cb.cb_init
instance gen Initialisation
where
diff --git a/Sil/Error.dcl b/Sil/Error.dcl
index 7df1976..14427c8 100644
--- a/Sil/Error.dcl
+++ b/Sil/Error.dcl
@@ -5,26 +5,39 @@ from StdOverloaded import class toString
from Sil.Syntax import :: Expression
from Sil.Types import :: Type
+from Sil.Util.Parser import :: Positioned
+
+:: ErrorPosition
:: Error
// Parser errors
- = E.a: P_Invalid String a & toString a
- | P_Expected String
+ = E.a: P_Invalid String a & toString a
+ | P_Expected String
// Type errors
- | T_IllegalApplication Type Type
- | T_IllegalField String Type
- | T_TooHighTupleArity Int
+ | T_IllegalApplication Type Type
+ | T_IllegalField String Type
+ | T_TooHighTupleArity Int
+ // Check errors
+ | Ck_NoMainFunction
+ | Ck_MainFunctionInvalidType ErrorPosition Type
+ | Ck_DuplicateFunctionName ErrorPosition String
+ | Ck_DuplicateLocalName ErrorPosition String String
+ | Ck_ReturnExpressionFromVoid ErrorPosition String
+ | Ck_NoReturnFromNonVoid ErrorPosition String
+ | Ck_LocalVoid String String
+ | Ck_BasicGlobal ErrorPosition String
// Compile errors
- | C_UndefinedName String
- | C_UndefinedField String
+ | C_UndefinedName String
+ | C_UndefinedField String
| C_VariableLabel
| C_FunctionOnStack
- | C_TypeError Error Expression
- | C_CouldNotDeduceType Expression
- | C_TypeMisMatch Type Expression Type
- | C_BasicInitWithoutValue String
+ | C_CouldNotDeduceType Expression
+ | C_TypeMisMatch Type Expression Type
+ | C_BasicInitWithoutValue String
// Miscellaneous
| UnknownError String
instance toString Error
instance <<< Error
+
+errpos :: (Positioned a) -> ErrorPosition
diff --git a/Sil/Error.icl b/Sil/Error.icl
index 9c48ecc..ef3e4fa 100644
--- a/Sil/Error.icl
+++ b/Sil/Error.icl
@@ -7,22 +7,41 @@ import Text
import Sil.Syntax
import Sil.Types
+import Sil.Util.Parser
+
+:: ErrorPosition =
+ { ep_line :: Int
+ }
+
+instance toString ErrorPosition
+where
+ toString ep = ep.ep_line <+ ":\t"
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 t`) = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ t` <+ "."
- toString (C_BasicInitWithoutValue n) = "Basic value '" <+ n <+ "' must have an initial value."
- toString (UnknownError e) = "Unknown error: " <+ e <+ "."
+ toString (P_Invalid w tk) = "Invalid token '" <+ tk <+ "' while parsing a " <+ w <+ "."
+ 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 Ck_NoMainFunction = "Error: no main function."
+ toString (Ck_MainFunctionInvalidType p t) = p <+ "Error: function 'main' should not have arguments has type " <+ t <+ "."
+ toString (Ck_DuplicateFunctionName p n) = p <+ "Error: multiply defined: '" <+ n <+ "'."
+ toString (Ck_DuplicateLocalName p f arg) = p <+ "Error: multiply defined: '" <+ arg <+ "' in '" <+ f <+ "'."
+ toString (Ck_ReturnExpressionFromVoid p f) = p <+ "Type error: an expression was returned from void function '" <+ f <+ "'."
+ toString (Ck_NoReturnFromNonVoid p f) = p <+ "Type error: no return from non-void function '" <+ f <+ "'."
+ toString (Ck_LocalVoid f l) = "Type error: local variable '" <+ l <+ "' in '" <+ f <+ "' cannot have type Void."
+ toString (Ck_BasicGlobal p g) = p <+ "Error: global variable '" <+ g <+ "' cannot have a basic type."
+ 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_CouldNotDeduceType e) = "Could not deduce type of '" <+ e <+ "'."
+ toString (C_TypeMisMatch t e u) = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ u <+ "."
+ toString (C_BasicInitWithoutValue n) = "Basic value '" <+ n <+ "' must have an initial value."
+ toString (UnknownError e) = "Unknown error: " <+ e <+ "."
instance <<< Error where <<< f e = f <<< toString e <<< "\r\n"
+
+errpos :: (Positioned a) -> ErrorPosition
+errpos p = {ep_line=p.pos_line}
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 74a2ff2..cf27df2 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -6,7 +6,7 @@ from Data.Error import :: MaybeError
from Sil.Error import :: Error
from Sil.Syntax import :: Program, :: Literal
-from Sil.Util.Parser import class name
+from Sil.Util.Parser import class name, :: ParseInput
:: Token
= TParenOpen //* (
@@ -47,6 +47,6 @@ instance == Token
instance toString Token
instance name Token
-tokenise :: [Char] -> MaybeError Error [Token]
+tokenise :: [Char] -> MaybeError Error [ParseInput Token]
-parse :: ([Token] -> MaybeError Error Program)
+parse :: ([ParseInput Token] -> MaybeError Error Program)
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 16f3fca..be8079e 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -69,10 +69,10 @@ where
name (TMachineCode _) = "machine code"
name t = toString t
-tokenise :: [Char] -> MaybeError Error [Token]
+tokenise :: [Char] -> MaybeError Error [ParseInput Token]
tokenise cs = reverse <$> tks cs []
where
- tks :: [Char] [Token] -> MaybeError Error [Token]
+ tks :: [Char] [ParseInput Token] -> MaybeError Error [ParseInput Token]
tks [] t = pure t
tks ['/':'/':r] t = tks (dropWhile ((<>) '\n') r) t
tks ['/':'*':r] t = tks (skipUntilEndOfComment r) t
@@ -80,46 +80,47 @@ where
skipUntilEndOfComment [] = []
skipUntilEndOfComment ['*':'/':r] = r
skipUntilEndOfComment [_:r] = skipUntilEndOfComment r
- tks ['.':r=:[c:_]] t | isNameChar c = tks r` [TField $ toString f:t]
+ tks ['.':r=:[c:_]] t | isNameChar c = tks r` [PI_Token $ TField $ toString f:t]
where (f,r`) = span isNameChar r
- tks [':':'=':r] t = tks r [TAssign :t]
- tks ['=':'=':r] t = tks r [TEquals :t]
- tks ['<':'>':r] t = tks r [TUnequals :t]
- tks ['<':'=':r] t = tks r [TLe :t]
- tks ['>':'=':r] t = tks r [TGe :t]
- tks ['<' :r] t = tks r [TLt :t]
- tks ['>' :r] t = tks r [TGt :t]
- tks ['|':'|':r] t = tks r [TDoubleBar :t]
- tks ['&':'&':r] t = tks r [TDoubleAmpersand:t]
- tks ['(' :r] t = tks r [TParenOpen :t]
- tks [')' :r] t = tks r [TParenClose :t]
- tks ['[' :r] t = tks r [TBrackOpen :t]
- tks [']' :r] t = tks r [TBrackClose :t]
- tks ['{' :r] t = tks r [TBraceOpen :t]
- tks ['}' :r] t = tks r [TBraceClose :t]
- tks [',' :r] t = tks r [TComma :t]
- tks [':' :r] t = tks r [TColon :t]
- tks [';' :r] t = tks r [TSemicolon :t]
- tks ['!' :r] t = tks r [TExclamation :t]
- tks ['~' :r] t = tks r [TTilde :t]
- tks ['+' :r] t = tks r [TPlus :t]
- tks ['-' :r] t = tks r [TMinus :t]
- tks ['*' :r] t = tks r [TStar :t]
- tks ['/' :r] t = tks r [TSlash :t]
- tks ['%' :r] t = tks r [TPercent :t]
- tks ['i':'f' :r=:[n:_]] t | isNotNameChar n = tks r [TIf :t]
- tks ['e':'l':'s':'e' :r=:[n:_]] t | isNotNameChar n = tks r [TElse :t]
- tks ['w':'h':'i':'l':'e' :r=:[n:_]] t | isNotNameChar n = tks r [TWhile :t]
- tks ['r':'e':'t':'u':'r':'n':r=:[n:_]] t | isNotNameChar n = tks r [TReturn:t]
- tks ['T':'r':'u':'e' :r=:[n:_]] t | isNotNameChar n = tks r [TLit $ BLit True :t]
- tks ['F':'a':'l':'s':'e' :r=:[n:_]] t | isNotNameChar n = tks r [TLit $ BLit False:t]
- tks ['|':'~':r] t = tks r` [TMachineCode $ toString c:t]
+ tks [':':'=':r] t = tks r [PI_Token TAssign :t]
+ tks ['=':'=':r] t = tks r [PI_Token TEquals :t]
+ tks ['<':'>':r] t = tks r [PI_Token TUnequals :t]
+ tks ['<':'=':r] t = tks r [PI_Token TLe :t]
+ tks ['>':'=':r] t = tks r [PI_Token TGe :t]
+ tks ['<' :r] t = tks r [PI_Token TLt :t]
+ tks ['>' :r] t = tks r [PI_Token TGt :t]
+ tks ['|':'|':r] t = tks r [PI_Token TDoubleBar :t]
+ tks ['&':'&':r] t = tks r [PI_Token TDoubleAmpersand:t]
+ tks ['(' :r] t = tks r [PI_Token TParenOpen :t]
+ tks [')' :r] t = tks r [PI_Token TParenClose :t]
+ tks ['[' :r] t = tks r [PI_Token TBrackOpen :t]
+ tks [']' :r] t = tks r [PI_Token TBrackClose :t]
+ tks ['{' :r] t = tks r [PI_Token TBraceOpen :t]
+ tks ['}' :r] t = tks r [PI_Token TBraceClose :t]
+ tks [',' :r] t = tks r [PI_Token TComma :t]
+ tks [':' :r] t = tks r [PI_Token TColon :t]
+ tks [';' :r] t = tks r [PI_Token TSemicolon :t]
+ tks ['!' :r] t = tks r [PI_Token TExclamation :t]
+ tks ['~' :r] t = tks r [PI_Token TTilde :t]
+ tks ['+' :r] t = tks r [PI_Token TPlus :t]
+ tks ['-' :r] t = tks r [PI_Token TMinus :t]
+ tks ['*' :r] t = tks r [PI_Token TStar :t]
+ tks ['/' :r] t = tks r [PI_Token TSlash :t]
+ tks ['%' :r] t = tks r [PI_Token TPercent :t]
+ tks ['i':'f' :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TIf :t]
+ tks ['e':'l':'s':'e' :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TElse :t]
+ tks ['w':'h':'i':'l':'e' :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TWhile :t]
+ tks ['r':'e':'t':'u':'r':'n':r=:[n:_]] t | isNotNameChar n = tks r [PI_Token TReturn:t]
+ tks ['T':'r':'u':'e' :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token $ TLit $ BLit True :t]
+ tks ['F':'a':'l':'s':'e' :r=:[n:_]] t | isNotNameChar n = tks r [PI_Token $ TLit $ BLit False:t]
+ tks ['|':'~':r] t = tks r` [PI_Token $ TMachineCode $ toString c:t]
where (c,r`) = span (not o flip isMember ['\r\n']) r
- tks cs=:[h:_] t
+ tks cs=:[h:r] t
+ | h == '\n' = tks r [PI_NewLine:t]
| isSpace h = tks (dropWhile isSpace cs) t
- | isDigit h = tks numrest [TLit $ ILit $ toInt $ toString num:t]
+ | isDigit h = tks numrest [PI_Token $ TLit $ ILit $ toInt $ toString num:t]
| not (isNameChar h) = Error $ P_Invalid "name" h
- | otherwise = tks namerest [TName $ toString name:t]
+ | otherwise = tks namerest [PI_Token $ TName $ toString name:t]
where
(name,namerest) = span isNameChar cs
(num,numrest) = span isDigit cs
@@ -129,8 +130,8 @@ where
isNotNameChar = not o isNameChar
-parse :: ([Token] -> MaybeError Error Program)
-parse = fst o runParser program
+parse :: ([ParseInput Token] -> MaybeError Error Program)
+parse = fst o runParser program o makeParseState
program :: Parser Token Program
program =
@@ -139,16 +140,17 @@ program =
eof $>
{p_globals=flatten globss, p_funs=fs}
-function :: Parser Token Function
+function :: Parser Token (Positioned Function)
function =
type >>= \t ->
+ getPositioner >>= \pos ->
name >>= \n ->
item TParenOpen *>
seplist TComma arg >>= \args ->
item TParenClose *>
item TBraceOpen *>
codeblock >>= \cb ->
- item TBraceClose $>
+ item TBraceClose $> pos
{ f_type = t
, f_name = n
, f_args = args
@@ -160,25 +162,26 @@ codeblock = many initialisation >>= \is ->
many statement >>= \s ->
pure {cb_init=flatten is, cb_content=s}
-initialisation :: Parser Token [Initialisation]
+initialisation :: Parser Token [Positioned Initialisation]
initialisation =
- type >>= \t ->
- seplist TComma init >>= \nvs ->
- item TSemicolon $>
- [{init_type=t, init_name=n, init_value=v} \\ (n,v) <- nvs]
+ type >>= \t -> seplist TComma (init t) <* item TSemicolon
where
- init =
+ init t =
+ getPositioner >>= \pos ->
name >>= \n ->
optional (item TAssign *> expression) >>= \v ->
- pure (n,v)
+ pure $ pos $ {init_type=t, init_name=n, init_value=v}
-statement :: Parser Token Statement
-statement = declaration
+statement :: Parser Token (Positioned Statement)
+statement =
+ getPositioner >>= \pos ->
+ ( declaration
<|> liftM Application (expression <* item TSemicolon)
<|> return
<|> if`
<|> while
<|> machinecode
+ ) >>= pure o pos
where
declaration :: Parser Token Statement
declaration = liftM2 Declaration name (item TAssign *> expression <* item TSemicolon)
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 7c983eb..1273267 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -5,10 +5,11 @@ from StdOverloaded import class toString
from Data.Maybe import :: Maybe
from Sil.Types import :: Type
+from Sil.Util.Parser import :: Positioned
:: Program =
- { p_funs :: [Function]
- , p_globals :: [Initialisation]
+ { p_funs :: [Positioned Function]
+ , p_globals :: [Positioned Initialisation]
}
:: Function =
@@ -19,8 +20,8 @@ from Sil.Types import :: Type
}
:: CodeBlock =
- { cb_init :: [Initialisation]
- , cb_content :: [Statement]
+ { cb_init :: [Positioned Initialisation]
+ , cb_content :: [Positioned Statement]
}
:: Arg =
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index 65cb5c5..a8a0631 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -10,6 +10,7 @@ import Data.Maybe
import Text
import Sil.Types
+import Sil.Util.Parser
import Sil.Util.Printer
instance toString Statement
@@ -65,13 +66,13 @@ where
toString (ILit i) = toString i
instance allStatements Program
-where allStatements p = concatMap allStatements p.p_funs
+where allStatements p = concatMap (allStatements o fromPositioned) p.p_funs
instance allStatements Function
where allStatements f = allStatements f.f_code
instance allStatements CodeBlock
-where allStatements cb = concatMap allStatements cb.cb_content
+where allStatements cb = concatMap (allStatements o fromPositioned) cb.cb_content
instance allStatements Statement
where
@@ -86,7 +87,7 @@ where
instance allCodeBlocks Function where allCodeBlocks f = allCodeBlocks f.f_code
instance allCodeBlocks CodeBlock
-where allCodeBlocks cb = [cb:concatMap allCodeBlocks cb.cb_content]
+where allCodeBlocks cb = [cb:concatMap (allCodeBlocks o fromPositioned) cb.cb_content]
instance allCodeBlocks Statement
where
@@ -101,4 +102,4 @@ where
allLocals f.f_code
instance allLocals CodeBlock
-where allLocals cb = [(i.init_type, i.init_name) \\ i <- cb.cb_init]
+where allLocals cb = [(i.init_type, i.init_name) \\ i <- map fromPositioned cb.cb_init]
diff --git a/Sil/Util/Parser.dcl b/Sil/Util/Parser.dcl
index 65b050e..8474b78 100644
--- a/Sil/Util/Parser.dcl
+++ b/Sil/Util/Parser.dcl
@@ -6,10 +6,26 @@ from Control.Applicative import class Applicative, class Alternative
from Control.Monad import class Monad
from Data.Error import :: MaybeError
from Data.Functor import class Functor
+from Data.Maybe import :: Maybe
-from Sil.Parse import :: Error
+from Sil.Error import :: Error
-:: Parser a b = Parser ([a] -> (MaybeError Error b, [a]))
+:: Positioned a =
+ { pos_line :: Int
+ , pos_val :: a
+ }
+
+fromPositioned :: (Positioned a) -> a
+
+:: ParseState a
+
+:: ParseInput a
+ = PI_NewLine
+ | PI_Token a
+
+makeParseState :: [ParseInput a] -> ParseState a
+
+:: Parser a b = Parser ((ParseState a) -> (MaybeError Error b, ParseState a))
instance Functor (Parser a)
instance Applicative (Parser a)
@@ -19,7 +35,8 @@ instance Alternative (Parser a)
class name a :: a -> String
instance name String
-runParser :: (Parser a b) [a] -> (MaybeError Error b, [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
top :: Parser a a
diff --git a/Sil/Util/Parser.icl b/Sil/Util/Parser.icl
index d13bc09..34cf057 100644
--- a/Sil/Util/Parser.icl
+++ b/Sil/Util/Parser.icl
@@ -9,34 +9,62 @@ import Data.Error
from Data.Func import $
import Data.Functor
import Data.List
+import Data.Maybe
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]
+ }
+
+makeParseState :: [ParseInput a] -> ParseState a
+makeParseState i = {ps_line=1, ps_input=i, ps_read=[]}
+
+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}
+
+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}
+
instance Functor (Parser a) where
fmap f m = liftM f m
instance Applicative (Parser a) where
- pure a = Parser \i -> (Ok a, i)
+ pure a = Parser \st -> (Ok a, st)
(<*>) sf p = ap sf p
instance Monad (Parser a) where
- bind p f = Parser \i -> case runParser p i of
+ bind p f = Parser \st -> case runParser p st of
(Ok r, rest) -> runParser (f r) rest
- (Error e, _) -> (Error e, i)
+ (Error e, _) -> (Error e, st)
instance Alternative (Parser a) where
- empty = Parser \i -> (Error $ UnknownError "empty in Parser", i)
- (<|>) p1 p2 = Parser \i -> case runParser p1 i of
+ 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 i of
- (Error e2, rest) -> (Error e2, i)
+ (Error e1, rest) -> case runParser p2 st of
+ (Error e2, rest) -> (Error e2, st)
(Ok r, rest) -> (Ok r, rest)
instance name String where name s = s
-runParser :: (Parser a b) [a] -> (MaybeError Error b, [a])
+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)
+
(<?>) :: (Parser a b) Error -> Parser a b
(<?>) p e = Parser \i -> case runParser p i of
(Error _, rest) -> (Error e, rest)
@@ -46,14 +74,14 @@ fail :: Parser a b
fail = empty
top :: Parser a a
-top = Parser \i -> case i of
- [] = (Error $ UnknownError "top in Parser failed", [])
- [x:xs] = (Ok x, xs)
+top = Parser \st -> case nextToken st of
+ (Nothing, st) -> (Error $ UnknownError "top in Parser failed", st)
+ (Just x, st) -> (Ok x, st)
peek :: Parser a a
-peek = Parser \i -> case i of
- [] = (Error $ UnknownError "peek in Parser failed", [])
- [x:xs] = (Ok x, [x:xs])
+peek = Parser \st -> case nextToken st of
+ (Nothing, st) -> (Error $ UnknownError "peek in Parser failed", st)
+ (Just x, st) -> (Ok x, tokenBack st)
satisfy :: (a -> Bool) -> Parser a a
satisfy f = top >>= \r -> if (f r) (pure r) fail
@@ -65,15 +93,15 @@ 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 \i -> case runParser guard i of
+ until` p guard acc = Parser \st -> case runParser guard st of
(Ok _, rest) -> (Ok acc, rest)
- (Error _, _) -> case runParser p i of
+ (Error _, _) -> case runParser p st of
(Ok r, rest) -> runParser (until` p guard [r:acc]) rest
- (Error e, _) -> (Error e, i)
+ (Error e, _) -> (Error e, st)
try :: (Parser a b) -> Parser a b
- try p = Parser \i -> case runParser p i of
- (Error e, _) -> (Error e, i)
+ try p = Parser \st -> case runParser p st of
+ (Error e, _) -> (Error e, st)
(Ok r, rest) -> (Ok r, rest)
item :: a -> Parser a a | ==, name a
@@ -88,6 +116,6 @@ seplist sep p = liftM2 (\es e-> es ++ [e]) (some (p <* item sep)) p
<|> pure empty
eof :: Parser a ()
-eof = Parser \i -> case i of
- [] = (Ok (), [])
- _ = (Error $ P_Expected "eof", i)
+eof = Parser \st -> case nextToken st of
+ (Nothing, st) -> (Ok (), st)
+ (_, st) -> (Error $ P_Expected "eof", st)
diff --git a/Sil/Util/Printer.dcl b/Sil/Util/Printer.dcl
index 5535dc2..56ad103 100644
--- a/Sil/Util/Printer.dcl
+++ b/Sil/Util/Printer.dcl
@@ -3,7 +3,7 @@ definition module Sil.Util.Printer
from StdOverloaded import class toString, class zero
from Sil.Parse import :: Token
-from Sil.Syntax import :: Program, :: Function, :: CodeBlock,
+from Sil.Syntax import :: Positioned, :: Program, :: Function, :: CodeBlock,
:: Initialisation, :: Statement
:: PrintState
@@ -13,6 +13,8 @@ instance zero PrintState
class PrettyPrinter t where
print :: PrintState t -> String
+instance PrettyPrinter String
+instance PrettyPrinter (Positioned a) | PrettyPrinter a
instance PrettyPrinter [Token]
instance PrettyPrinter Program
instance PrettyPrinter Function
diff --git a/Sil/Util/Printer.icl b/Sil/Util/Printer.icl
index 979e478..2a028b6 100644
--- a/Sil/Util/Printer.icl
+++ b/Sil/Util/Printer.icl
@@ -16,6 +16,7 @@ import Text
import Sil.Parse
import Sil.Syntax
import Sil.Types
+import Sil.Util.Parser
:: PrintState =
{ indent :: Int
@@ -33,6 +34,9 @@ instance toString PrintState where toString st = {'\t' \\ _ <- [1..st.indent]}
instance PrettyPrinter String where print _ s = s
+instance PrettyPrinter (Positioned a) | PrettyPrinter a
+where print st p = print st $ fromPositioned p
+
instance PrettyPrinter [Token]
where
print st [] = ""
diff --git a/sil.icl b/sil.icl
index 9dd7674..0069fdb 100644
--- a/sil.icl
+++ b/sil.icl
@@ -21,7 +21,7 @@ import System.Process
import ABC.Assembler
-from Sil.Check import :: CheckError, checkProgram
+from Sil.Check import checkProgram
import qualified Sil.Compile as SC
import Sil.Error
import Sil.Parse
@@ -54,7 +54,7 @@ Start w
# (io,w) = stdio w
# err = stderr
# (cmd,w) = getCommandLine w
-# (args,_) = runParser (arg until eof) $ tl cmd
+# (args,_) = runParser (arg until eof) $ makeParseState $ map PI_Token $ tl cmd
| isError args
# err = err <<< toString (fromError args) <<< "\r\n"
= finish 1 io err w
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 20:07:45 +0000