aboutsummaryrefslogtreecommitdiff
path: root/Sil
diff options
context:
space:
mode:
Diffstat (limited to 'Sil')
-rw-r--r--Sil/Check.icl30
-rw-r--r--Sil/Compile.icl14
-rw-r--r--Sil/Error.icl30
-rw-r--r--Sil/Parse.icl38
-rw-r--r--Sil/Syntax.dcl13
-rw-r--r--Sil/Syntax.icl45
-rw-r--r--Sil/Util/Printer.icl4
7 files changed, 92 insertions, 82 deletions
diff --git a/Sil/Check.icl b/Sil/Check.icl
index 6179a66..b06824b 100644
--- a/Sil/Check.icl
+++ b/Sil/Check.icl
@@ -57,21 +57,19 @@ checkFunction err f = checkErrors
where
checkReturnAndVoid :: Function -> [Error]
checkReturnAndVoid f = case f.f_type of
- TVoid -> case [st \\ st=:(Return (Just _)) <- allStatements f] of
- [] -> []
- _ -> [Ck_ReturnExpressionFromVoid (errpos f) f.f_name]
+ TVoid -> [Ck_ReturnExpressionFromVoid (errpos st) f.f_name \\ st=:(Return _ (Just _)) <- allStatements f]
_ -> if (sureToReturn f.f_code) [] [Ck_NoReturnFromNonVoid (errpos f) f.f_name]
where
sureToReturn :: CodeBlock -> Bool
sureToReturn cb = case cb.cb_content of
[] -> False
sts -> case last sts of
- Return _ -> True
- While _ cb` -> sureToReturn cb`
- If bs (Just e) -> all sureToReturn [e:map snd bs]
- If bs Nothing -> all (sureToReturn o snd) bs
- MachineStm _ -> True // Let's assume the user is not stupid
- _ -> False
+ Return _ _ -> True
+ While _ _ cb` -> sureToReturn cb`
+ If _ bs (Just e) -> all sureToReturn [e:map snd bs]
+ If _ bs Nothing -> all (sureToReturn o snd) bs
+ MachineStm _ _ -> True // Let's assume the user is not stupid
+ _ -> False
checkMainFunctionType :: Function -> [Error]
checkMainFunctionType {f_name="main",f_args=[]}
@@ -95,13 +93,13 @@ where
underlyingCBs :: CodeBlock -> [CodeBlock]
underlyingCBs cb = concatMap findCBs cb.cb_content
where
- findCBs (Declaration _ _) = []
- findCBs (Application _) = []
- findCBs (Return _) = []
- findCBs (If bs (Just e)) = [e:map snd bs]
- findCBs (If bs Nothing) = map snd bs
- findCBs (While _ cb) = [cb]
- findCBs (MachineStm _) = []
+ findCBs (Declaration _ _ _) = []
+ findCBs (Application _ _) = []
+ findCBs (Return _ _) = []
+ findCBs (If _ bs (Just e)) = [e:map snd bs]
+ findCBs (If _ bs Nothing) = map snd bs
+ findCBs (While _ _ cb) = [cb]
+ findCBs (MachineStm _ _) = []
checkVoid :: (Type, Name) -> [Error]
checkVoid (TVoid, n) = [Ck_LocalVoid f.f_name n]
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index 6569dd1..6efee77 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -401,7 +401,7 @@ where
instance gen Statement
where
- gen st=:(Declaration n e) =
+ gen st=:(Declaration _ n e) =
checkTypeName n e >>= \t ->
comment (toString st) *>
gen e *>
@@ -415,14 +415,14 @@ where
({asize=0}, TBool) -> tell ['ABC'.FillB_b 0 i, 'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1}
_ -> tell ['ABC'.Update_a 0 i, 'ABC'.Pop_a 1] *> shrinkStack {zero & asize=1}
updateLoc _ (BAddr i) = tell ['ABC'.Update_b 0 i, 'ABC'.Pop_b 1] *> shrinkStack {zero & bsize=1}
- gen (Application e) =
+ gen (Application _ e) =
comment "Application" *>
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 err
Nothing -> error $ C_CouldNotDeduceType e
- gen (Return (Just e)) =
+ gen (Return _ (Just e)) =
comment "Return" *>
gen e *>
gets returnType >>= \rettype ->
@@ -438,13 +438,13 @@ where
updateReturnFrame {asize=0,bsize=0} _ = nop
updateReturnFrame {bsize=0} (aso, _) = tell ['ABC'.Update_a 0 (aso-1), 'ABC'.Pop_a 1] // TODO should depend on return type
updateReturnFrame _ (_, bso) = tell ['ABC'.Update_b 0 (bso-1)] // TODO should depend on return type
- gen (Return Nothing) =
+ gen (Return _ Nothing) =
comment "Return" *>
cleanup *>
tell ['ABC'.Rtn]
- gen (MachineStm s) =
+ gen (MachineStm _ s) =
tell ['ABC'.Raw s]
- gen (If blocks else) =
+ gen (If _ blocks else) =
fresh "ifend" >>= \end ->
mapM_ (genifblock end) blocks *>
genelse end else
@@ -464,7 +464,7 @@ where
genelse :: 'ABC'.Label (Maybe CodeBlock) -> Gen ()
genelse end Nothing = tell ['ABC'.Label end]
genelse end (Just cb) = gen cb *> tell ['ABC'.Label end]
- gen (While cond do) =
+ gen (While _ cond do) =
checkType TBool cond *>
fresh "while" >>= \loop -> fresh "whileend" >>= \end ->
tell [ 'ABC'.Label loop ] *>
diff --git a/Sil/Error.icl b/Sil/Error.icl
index 9253673..36a614b 100644
--- a/Sil/Error.icl
+++ b/Sil/Error.icl
@@ -19,27 +19,27 @@ where
instance toString Error
where
- 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 (P_Invalid w tk) = "\tInvalid token '" <+ tk <+ "' while parsing a " <+ w <+ "."
+ toString (P_Expected s) = "\tExpected " <+ s <+ "."
+ 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)."
+ toString Ck_NoMainFunction = "\tError: 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_LocalVoid f l) = "\tType 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 <+ "."
+ toString (C_UndefinedName n) = "\tUndefined name '" <+ n <+ "'."
+ toString (C_UndefinedField f) = "\tUndefined field '" <+ f <+ "'."
+ toString C_VariableLabel = "\tVariable stored at label."
+ toString C_FunctionOnStack = "\tFunction stored on the stack."
+ toString (C_CouldNotDeduceType e) = "\tCould not deduce type of '" <+ e <+ "'."
+ toString (C_TypeMisMatch t e u) = "\tType mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ u <+ "."
+ toString (C_BasicInitWithoutValue n) = "\tBasic value '" <+ n <+ "' must have an initial value."
+ toString (UnknownError e) = "\tUnknown error: " <+ e <+ "."
instance <<< Error where <<< f e = f <<< toString e <<< "\r\n"
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 4a345fe..6a3999d 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -175,41 +175,43 @@ where
statement :: Parser Token Statement
statement =
- declaration
- <|> liftM Application (expression <* item TSemicolon)
- <|> return
- <|> if`
- <|> while
- <|> machinecode
+ getPosition >>= \pos ->
+ ( declaration pos
+ <|> liftM (Application pos) (expression <* item TSemicolon)
+ <|> return pos
+ <|> if` pos
+ <|> while pos
+ <|> machinecode pos
+ )
where
- declaration :: Parser Token Statement
- declaration = liftM2 Declaration name (item TAssign *> expression <* item TSemicolon)
+ declaration :: ParsePosition -> Parser Token Statement
+ declaration p = liftM2 (Declaration p) name (item TAssign *> expression <* item TSemicolon)
- return :: Parser Token Statement
- return = liftM Return (item TReturn *> optional expression <* item TSemicolon)
+ return :: ParsePosition -> Parser Token Statement
+ return p = liftM (Return p) (item TReturn *> optional expression <* item TSemicolon)
- machinecode :: Parser Token Statement
- machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
+ machinecode :: ParsePosition -> Parser Token Statement
+ machinecode p = (\(TMachineCode s) -> MachineStm p s) <$> satisfy isMachineCode
where isMachineCode (TMachineCode _) = True; isMachineCode _ = False
- if` :: Parser Token Statement
- if` = item TIf *>
+ if` :: ParsePosition -> Parser Token Statement
+ if` p = item TIf *>
parenthised expression >>= \cond ->
braced codeblock >>= \iftrue ->
many elseif >>= \elseifs ->
optional (item TElse *> braced codeblock) >>= \iffalse ->
- pure $ If [(cond,iftrue):elseifs] iffalse
+ pure $ If p [(cond,iftrue):elseifs] iffalse
where
elseif = list [TElse, TIf] *>
parenthised expression >>= \cond ->
braced codeblock >>= \block ->
pure (cond, block)
- while :: Parser Token Statement
- while = item TWhile *>
+ while :: ParsePosition -> Parser Token Statement
+ while p = item TWhile *>
parenthised expression >>= \cond ->
braced codeblock >>= \do ->
- pure $ While cond do
+ pure $ While p cond do
expression :: Parser Token Expression
expression
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index b298c19..4f0ddf9 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -38,12 +38,12 @@ from Sil.Util.Parser import :: ParsePosition, class getPos
}
:: Statement
- = Declaration Name Expression
- | Application Expression
- | Return (Maybe Expression)
- | If [(Expression, CodeBlock)] (Maybe CodeBlock)
- | While Expression CodeBlock
- | MachineStm String
+ = Declaration ParsePosition Name Expression
+ | Application ParsePosition Expression
+ | Return ParsePosition (Maybe Expression)
+ | If ParsePosition [(Expression, CodeBlock)] (Maybe CodeBlock)
+ | While ParsePosition Expression CodeBlock
+ | MachineStm ParsePosition String
:: Expression
= Name Name
@@ -90,6 +90,7 @@ instance toString Literal
instance getPos Function
instance getPos Initialisation
+instance getPos Statement
class allStatements a :: a -> [Statement]
instance allStatements Program
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index 0749dde..e28d616 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -15,13 +15,13 @@ import Sil.Util.Printer
instance toString Statement
where
- toString (Declaration n a) = n <+ " := " <+ a <+ ";"
- toString (Application e) = toString e <+ ";"
- toString (Return Nothing) = "return;"
- toString (Return (Just a)) = "return " <+ a <+ ";"
- toString (If bs e) = "if ..."
- toString (MachineStm s) = "|~" <+ s
- toString _ = "<<unimplemented Statement>>"
+ toString (Declaration _ n a) = n <+ " := " <+ a <+ ";"
+ toString (Application _ e) = toString e <+ ";"
+ toString (Return _ Nothing) = "return;"
+ toString (Return _ (Just a)) = "return " <+ a <+ ";"
+ toString (If _ bs e) = "if ..."
+ toString (MachineStm _ s) = "|~" <+ s
+ toString _ = "<<unimplemented Statement>>"
instance toString Arg where toString arg = arg.arg_type <+ " " <+ arg.arg_name
@@ -68,6 +68,15 @@ where
instance getPos Function where getPos f = f.f_pos
instance getPos Initialisation where getPos i = i.init_pos
+instance getPos Statement
+where
+ getPos (Declaration p _ _) = p
+ getPos (Application p _) = p
+ getPos (Return p _) = p
+ getPos (If p _ _) = p
+ getPos (While p _ _) = p
+ getPos (MachineStm p _) = p
+
instance allStatements Program
where allStatements p = concatMap allStatements p.p_funs
@@ -79,13 +88,13 @@ where allStatements cb = concatMap allStatements cb.cb_content
instance allStatements Statement
where
- allStatements st=:(Declaration _ _) = [st]
- allStatements st=:(Application _) = [st]
- allStatements st=:(Return _) = [st]
- allStatements st=:(If bs Nothing) = [st:concatMap (allStatements o snd) bs]
- allStatements st=:(If bs (Just e)) = [st:allStatements e ++ concatMap (allStatements o snd) bs]
- allStatements st=:(While _ cb) = [st:allStatements cb]
- allStatements st=:(MachineStm _) = [st]
+ allStatements st=:(Declaration _ _ _) = [st]
+ allStatements st=:(Application _ _) = [st]
+ allStatements st=:(Return _ _) = [st]
+ allStatements st=:(If _ bs Nothing) = [st:concatMap (allStatements o snd) bs]
+ allStatements st=:(If _ bs (Just e)) = [st:allStatements e ++ concatMap (allStatements o snd) bs]
+ allStatements st=:(While _ _ cb) = [st:allStatements cb]
+ allStatements st=:(MachineStm _ _) = [st]
instance allCodeBlocks Function where allCodeBlocks f = allCodeBlocks f.f_code
@@ -94,10 +103,10 @@ where allCodeBlocks cb = [cb:concatMap allCodeBlocks cb.cb_content]
instance allCodeBlocks Statement
where
- allCodeBlocks (If bs Nothing) = concatMap (allCodeBlocks o snd) bs
- allCodeBlocks (If bs (Just e)) = [e:concatMap (allCodeBlocks o snd) bs]
- allCodeBlocks (While _ cb) = [cb]
- allCodeBlocks _ = []
+ allCodeBlocks (If _ bs Nothing) = concatMap (allCodeBlocks o snd) bs
+ allCodeBlocks (If _ bs (Just e)) = [e:concatMap (allCodeBlocks o snd) bs]
+ allCodeBlocks (While _ _ cb) = [cb]
+ allCodeBlocks _ = []
instance allLocals Function
where
diff --git a/Sil/Util/Printer.icl b/Sil/Util/Printer.icl
index bcb3c84..283709d 100644
--- a/Sil/Util/Printer.icl
+++ b/Sil/Util/Printer.icl
@@ -101,14 +101,14 @@ where
instance PrettyPrinter Statement
where
- print st (If bs else) = st <+ printersperse " else " (map oneblock bs) <+ else`
+ print st (If _ bs else) = st <+ printersperse " else " (map oneblock bs) <+ else`
where
st` = incIndent st
oneblock (c,b) = "if (" <+ c <+ ") {\r\n" <+ print st` b <+ "\r\n" <+ st <+ "}"
else` = case else of
Nothing -> ""
Just e -> " else {\r\n" <+ print st` e <+ "\r\n" <+ st <+ "}"
- print st (While c do) = st <+ "while (" <+ c <+ ") {\r\n" <+
+ print st (While _ c do) = st <+ "while (" <+ c <+ ") {\r\n" <+
print (incIndent st) do <+ "\r\n" <+ st <+ "}"
print st stm = st <+ stm
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 15:33:42 +0000