aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
m---------ABCMachine0
-rw-r--r--Sil/Check.icl1
-rw-r--r--Sil/Compile.dcl6
-rw-r--r--Sil/Compile.icl113
-rw-r--r--Sil/Parse.icl11
-rw-r--r--Sil/Syntax.dcl13
-rw-r--r--Sil/Syntax.icl12
-rw-r--r--Sil/Types.dcl36
-rw-r--r--Sil/Types.icl87
-rw-r--r--Sil/Util/Printer.icl1
-rw-r--r--examples/errors.sil1
-rw-r--r--sil.icl6
12 files changed, 240 insertions, 47 deletions
diff --git a/ABCMachine b/ABCMachine
-Subproject e896db3386454b9e079e9adfc19c1e5b4d8735f
+Subproject 628b8d6ec43d7f5e7e17e2cbd529336c2a10494
diff --git a/Sil/Check.icl b/Sil/Check.icl
index 37ee282..61f5ac7 100644
--- a/Sil/Check.icl
+++ b/Sil/Check.icl
@@ -15,6 +15,7 @@ import Data.Tuple
from Text import <+
import Sil.Syntax
+import Sil.Types
instance toString CheckError
where
diff --git a/Sil/Compile.dcl b/Sil/Compile.dcl
index 6407b67..4857ba9 100644
--- a/Sil/Compile.dcl
+++ b/Sil/Compile.dcl
@@ -7,12 +7,16 @@ from Data.Error import :: MaybeError
from ABC.Assembler import :: Assembler, :: Statement, instance <<< Assembler
-from Sil.Syntax import :: Program, :: Name
+from Sil.Syntax import :: Program, :: Name, :: Expression
+from Sil.Types import :: Type, :: TypeError
:: CompileError
= UndefinedName Name
| VariableLabel
| FunctionOnStack
+ | TypeError TypeError Expression
+ | CouldNotDeduceType Expression
+ | TypeMisMatch Type Expression
| UnknownError
instance toString CompileError
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index afdfe90..e930c44 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -1,7 +1,7 @@
implementation module Sil.Compile
import StdEnum
-from StdFunc import o
+from StdFunc import const, flip, o
import StdList
import StdString
@@ -11,6 +11,7 @@ import Control.Monad.RWST
import Control.Monad.Trans
import Data.Error
from Data.Func import $
+import Data.Functor
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
@@ -19,14 +20,24 @@ from Text import <+
import qualified ABC.Assembler as ABC
import Sil.Syntax
+import Sil.Types
import Sil.Util.Printer
instance toString CompileError
where
- toString (UndefinedName n) = "Undefined name '" <+ n <+ "'."
- toString VariableLabel = "Variable stored at label."
- toString FunctionOnStack = "Function stored on the stack."
- toString UnknownError = "Unknown error."
+ toString (UndefinedName n) = "Undefined name '" <+ n <+ "'."
+ 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 UnknownError = "Unknown error."
+
+error :: CompileError -> RWST r w s (MaybeError CompileError) 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 prog = case evalRWST (gen prog) () zero of
@@ -47,6 +58,7 @@ compile prog = case evalRWST (gen prog) () zero of
, returns :: ['ABC'.Assembler]
, stackoffset :: Int
, storedoffsets :: [Int]
+ , typeresolvers :: [TypeResolver]
}
instance zero CompileState
@@ -58,6 +70,7 @@ where
, returns = []
, stackoffset = 0
, storedoffsets = []
+ , typeresolvers = []
}
labels :: CompileState -> ['ABC'.Label]
@@ -94,15 +107,30 @@ restoreStackOffset :: CompileState -> CompileState
restoreStackOffset cs = {cs & stackoffset=so, storedoffsets=sos}
where [so:sos] = cs.storedoffsets
+typeresolvers :: CompileState -> [TypeResolver]
+typeresolvers cs = cs.typeresolvers
+
+pushTypeResolver :: TypeResolver CompileState -> CompileState
+pushTypeResolver tr cs = {cs & typeresolvers=[tr:cs.typeresolvers]}
+
+popTypeResolver :: CompileState -> CompileState
+popTypeResolver cs = {cs & typeresolvers=tl cs.typeresolvers}
+
:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
fresh :: a -> Gen 'ABC'.Label | toString a
fresh n = gets labels
>>= \labs -> modify (\cs -> {cs & labels=tl labs})
- *> pure (n <+ hd labs)
+ $> n <+ hd labs
+
+getTypeResolver :: Gen TypeResolver
+getTypeResolver = gets typeresolvers >>= \trs -> pure $ \n ->
+ case catMaybes $ map (flip ($) n) trs of
+ [t:_] -> Just t
+ [] -> Nothing
reserveVar :: Int Name -> Gen Int
-reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1)
+reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) $> (i+1)
addFunction :: Function -> Gen ()
addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols})
@@ -120,6 +148,18 @@ growStack n = modify (\cs -> {cs & stackoffset=cs.stackoffset + n})
shrinkStack :: (Int -> Gen ())
shrinkStack = growStack o ((-) 0)
+checkType :: Type Expression -> Gen ()
+checkType t e = getTypeResolver >>= \tr -> case type tr e of
+ Nothing -> error $ CouldNotDeduceType e
+ Just (Error err) -> error $ TypeError err e
+ Just (Ok t`) -> if (t == t`) nop (error $ TypeMisMatch t e)
+
+checkTypeName :: Name Expression -> Gen ()
+checkTypeName n e = getTypeResolver >>= \tr -> case type tr n of
+ Nothing -> error $ CouldNotDeduceType $ Name n
+ Just (Error err) -> error $ TypeError err $ Name n
+ Just (Ok t`) -> checkType t` e
+
class gen a :: a -> Gen ()
instance gen Program
@@ -134,8 +174,15 @@ where
, 'ABC'.Fill "_" 0 "main" 0
, 'ABC'.Jmp "_driver"
] *>
+ modify (pushTypeResolver typeresolver) *>
mapM_ addFunction p.p_funs *>
- mapM_ gen p.p_funs
+ mapM_ gen p.p_funs *>
+ modify popTypeResolver
+ where
+ typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+ typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of
+ [] -> Nothing
+ [f:_] -> type (const Nothing) f
instance gen Function
where
@@ -145,7 +192,9 @@ where
] *>
foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *>
modify (newReturn cleanup`) *>
+ modify (pushTypeResolver typeresolver) *>
gen f.f_code *>
+ modify popTypeResolver *>
cleanup *>
modify (\cs -> {cs & stackoffset=0}) *>
tell ['ABC'.Rtn] *>
@@ -163,6 +212,9 @@ where
args = length f.f_args
locals = length f.f_code.cb_init
+ typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+ typeresolver n = listToMaybe [Ok a.arg_type \\ a <- f.f_args | a.arg_name == n]
+
instance gen CodeBlock
where
gen cb =
@@ -170,7 +222,9 @@ where
foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
mapM_ gen cb.cb_init *>
modify (addToReturn cleanup`) *>
+ modify (pushTypeResolver typeresolver) *>
mapM_ gen cb.cb_content *>
+ modify popTypeResolver *>
tell cleanup` *>
modify (removeFromReturn $ length cleanup`) *>
modify restoreStackOffset
@@ -180,27 +234,49 @@ where
_ -> [ 'ABC'.Pop_a locals ]
locals = length cb.cb_init
+ typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+ typeresolver n = listToMaybe [Ok i.init_type \\ i <- cb.cb_init | i.init_name == n]
+
instance gen Initialisation
where
gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1
instance gen Statement
where
- gen st=:(Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
- Just i -> comment (toString st) *> gen app *>
- tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> shrinkStack 1
+ gen st=:(Declaration n e) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+ Just i -> checkTypeName n e *>
+ comment (toString st) *>
+ gen e *>
+ tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> // TODO should depend on size of return type
+ shrinkStack 1
_ -> liftT $ Error $ UndefinedName n
- gen (Application e) = comment "Application" *> gen e *> tell ['ABC'.Pop_a 1] *> shrinkStack 1
- gen (Return (Just e)) = comment "Return" *> gen e *> cleanup *> tell ['ABC'.Rtn]
- gen (Return Nothing) = comment "Return" *> cleanup *> tell ['ABC'.Rtn]
- gen (MachineStm s) = tell ['ABC'.Raw s]
- gen (If blocks else) =
+ gen (Application e) =
+ comment "Application" *>
+ gen e *>
+ getTypeResolver >>= \tr -> case fmap typeSize <$> type tr e of
+ Just (Ok 0) -> nop
+ Just (Ok sz) -> tell ['ABC'.Pop_a sz] *> shrinkStack sz
+ Just (Error err) -> error $ TypeError err e
+ Nothing -> error $ CouldNotDeduceType e
+ gen (Return (Just e)) =
+ comment "Return" *>
+ gen e *>
+ cleanup *>
+ tell ['ABC'.Rtn]
+ gen (Return Nothing) =
+ comment "Return" *>
+ cleanup *>
+ tell ['ABC'.Rtn]
+ gen (MachineStm s) =
+ tell ['ABC'.Raw s]
+ gen (If blocks else) =
fresh "ifend" >>= \end ->
mapM_ (genifblock end) blocks *>
genelse end else
where
genifblock :: 'ABC'.Label (Expression, CodeBlock) -> Gen ()
genifblock end (cond, cb) =
+ checkType TBool cond *>
fresh "ifelse" >>= \else ->
gen cond *>
toBStack 'ABC'.BT_Bool 1 *>
@@ -213,6 +289,7 @@ where
genelse end Nothing = tell ['ABC'.Label end]
genelse end (Just cb) = gen cb *> tell ['ABC'.Label end]
gen (While cond do) =
+ checkType TBool cond *>
fresh "while" >>= \loop -> fresh "whileend" >>= \end ->
tell [ 'ABC'.Label loop ] *>
gen cond *>
@@ -240,9 +317,9 @@ where
comment "Apply function" *>
tell [ 'ABC'.Annotation $ 'ABC'.DAnnot fs.fs_arity []
, 'ABC'.Jsr n
- , 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
+ , 'ABC'.Annotation $ 'ABC'.OAnnot (typeSize fs.fs_rettype) []
] *>
- shrinkStack (fs.fs_arity - 1)
+ shrinkStack (fs.fs_arity - typeSize fs.fs_rettype)
_ -> liftT $ Error $ UndefinedName n
gen (BuiltinApp op arg) = gen arg *> gen op
gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 806ac69..fb77def 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -21,6 +21,7 @@ from Text import <+, class Text, instance Text String
import GenEq
import Sil.Syntax
+import Sil.Types
import Sil.Util.Parser
import Sil.Util.Printer
@@ -119,7 +120,7 @@ function =
item TParenClose *>
item TBraceOpen *>
codeblock >>= \cb ->
- item TBraceClose *> pure
+ item TBraceClose $>
{ f_type = t
, f_name = n
, f_args = args
@@ -135,8 +136,8 @@ initialisation :: Parser Token [Initialisation]
initialisation =
type >>= \t ->
seplist TComma name >>= \ns ->
- item TSemicolon >>= \_ ->
- pure [{init_type=t, init_name=n} \\ n <- ns]
+ item TSemicolon $>
+ [{init_type=t, init_name=n} \\ n <- ns]
statement :: Parser Token Statement
statement = declaration
@@ -192,7 +193,7 @@ expression
$ noInfix
where
op :: Token Op2 -> Parser Token Op2
- op token operator = item token *> pure operator
+ op token operator = item token $> operator
rightAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
rightAssoc opp appp = appp >>= \e1 -> optional (opp >>= \op -> rightAssoc opp appp >>= \e -> pure (op,e))
@@ -231,7 +232,7 @@ type
<|> type "Void" TVoid
<?> Expected "type"
where
- type s t = item (TName s) *> pure t
+ type s t = item (TName s) $> t
literal :: Parser Token Literal
literal = satisfy isLit >>= \(TLit lit) -> pure lit
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 1aa0c8b..1b3b44a 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -4,6 +4,8 @@ from StdOverloaded import class toString
from Data.Maybe import :: Maybe
+from Sil.Types import :: Type
+
:: Program =
{ p_funs :: [Function]
}
@@ -59,11 +61,6 @@ from Data.Maybe import :: Maybe
| LogOr //* ||
| LogAnd //* &&
-:: Type
- = TBool
- | TInt
- | TVoid
-
:: Literal
= BLit Bool
| ILit Int
@@ -71,7 +68,6 @@ from Data.Maybe import :: Maybe
:: Name :== String
instance toString Statement
-instance toString Type
instance toString Arg
instance toString Expression
instance toString Op1
@@ -92,8 +88,3 @@ instance allCodeBlocks Statement
class allLocals a :: a -> [(Type, Name)]
instance allLocals Function
instance allLocals CodeBlock
-
-/**
- * Size of an expression on the stack
- */
-typeSize :: Type -> Int
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index 8083eba..43d27fc 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -9,6 +9,7 @@ import Data.List
import Data.Maybe
import Text
+import Sil.Types
import Sil.Util.Printer
instance toString Statement
@@ -21,12 +22,6 @@ where
toString (MachineStm s) = "|~" <+ s
toString _ = "<<unimplemented Statement>>"
-instance toString Type
-where
- toString TBool = "Bool"
- toString TInt = "Int"
- toString TVoid = "Void"
-
instance toString Arg where toString arg = arg.arg_type <+ " " <+ arg.arg_name
instance toString Expression
@@ -96,8 +91,3 @@ where
instance allLocals CodeBlock
where allLocals cb = [(i.init_type, i.init_name) \\ i <- cb.cb_init]
-
-typeSize :: Type -> Int
-typeSize TVoid = 0
-typeSize TBool = 1
-typeSize TInt = 1
diff --git a/Sil/Types.dcl b/Sil/Types.dcl
new file mode 100644
index 0000000..1659436
--- /dev/null
+++ b/Sil/Types.dcl
@@ -0,0 +1,36 @@
+definition module Sil.Types
+
+from StdOverloaded import class ==, class toString
+
+from Data.Error import :: MaybeError
+from Data.Maybe import :: Maybe
+
+from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
+
+:: Type
+ = TBool
+ | TInt
+ | TVoid
+ | (-->) infixr Type Type
+
+:: TypeError
+ = IllegalApplication Type Type
+
+instance == Type
+
+instance toString Type
+instance toString TypeError
+
+/**
+ * Size of an expression on the stack
+ */
+typeSize :: Type -> Int
+
+:: TypeResolver :== Name -> Maybe (MaybeError TypeError Type)
+
+class type a :: TypeResolver a -> Maybe (MaybeError TypeError Type)
+instance type Function
+instance type Expression
+instance type Name
+instance type Op1
+instance type Op2
diff --git a/Sil/Types.icl b/Sil/Types.icl
new file mode 100644
index 0000000..5f17956
--- /dev/null
+++ b/Sil/Types.icl
@@ -0,0 +1,87 @@
+implementation module Sil.Types
+
+import StdList
+import StdOverloaded
+import StdString
+
+import Control.Applicative
+import Control.Monad
+import Data.Error
+from Data.Func import $
+import Data.Maybe
+from Text import <+
+
+import GenEq
+
+import Sil.Syntax
+
+derive gEq Type
+instance == Type where == a b = gEq{|*|} a b
+
+instance toString Type
+where
+ toString TBool = "Bool"
+ toString TInt = "Int"
+ toString TVoid = "Void"
+ toString (at --> rt) = "(" <+ at <+ " -> " <+ rt <+ ")"
+
+instance toString TypeError
+where
+ toString (IllegalApplication ft et) = "Cannot apply a " <+ et <+ " to a " <+ ft <+ "."
+
+typeSize :: Type -> Int
+typeSize TVoid = 0
+typeSize TBool = 1
+typeSize TInt = 1
+
+instance type Function
+where
+ type res f = Just $ Ok $ foldr (-->) f.f_type [a.arg_type \\ a <- f.f_args]
+
+instance type Expression
+where
+ type res (Name n) = type res n
+ type res (Literal lit) = case lit of
+ BLit _ -> Just $ Ok TBool
+ ILit _ -> Just $ Ok TInt
+ type res (App n args) =
+ mapM (type res) args >>= \ats ->
+ res n >>= \ft -> pure
+ ( sequence ats >>= \ats ->
+ ft >>= \ft -> foldM tryApply ft ats)
+ type res (BuiltinApp op e) =
+ type res e >>= \te ->
+ type res op >>= \top -> pure
+ ( top >>= \top ->
+ te >>= \te -> tryApply top te)
+ type res (BuiltinApp2 e1 op e2) =
+ type res e1 >>= \te1 ->
+ type res e2 >>= \te2 ->
+ type res op >>= \top -> pure
+ ( top >>= \top ->
+ te1 >>= \te1 ->
+ te2 >>= \te2 -> foldM tryApply top [te1,te2])
+
+tryApply :: Type Type -> MaybeError TypeError Type
+tryApply ft=:(at --> rt) et
+| et == at = Ok rt
+| otherwise = Error $ IllegalApplication ft et
+tryApply ft et = Error $ IllegalApplication ft et
+
+instance type Name where type res n = res n
+
+instance type Op1
+where
+ type _ Neg = Just $ Ok $ TInt --> TInt
+ type _ Not = Just $ Ok $ TBool --> TBool
+
+instance type Op2
+where
+ type _ Add = Just $ Ok $ TInt --> TInt --> TInt
+ type _ Sub = Just $ Ok $ TInt --> TInt --> TInt
+ type _ Mul = Just $ Ok $ TInt --> TInt --> TInt
+ type _ Div = Just $ Ok $ TInt --> TInt --> TInt
+ type _ Rem = Just $ Ok $ TInt --> TInt --> TInt
+ type _ Equals = Just $ Ok $ TInt --> TInt --> TBool
+ type _ LogOr = Just $ Ok $ TBool --> TBool --> TBool
+ type _ LogAnd = Just $ Ok $ TBool --> TBool --> TBool
diff --git a/Sil/Util/Printer.icl b/Sil/Util/Printer.icl
index d35281b..ff9c3f2 100644
--- a/Sil/Util/Printer.icl
+++ b/Sil/Util/Printer.icl
@@ -15,6 +15,7 @@ import Text
import Sil.Parse
import Sil.Syntax
+import Sil.Types
:: PrintState =
{ indent :: Int
diff --git a/examples/errors.sil b/examples/errors.sil
index 8bad357..4e04514 100644
--- a/examples/errors.sil
+++ b/examples/errors.sil
@@ -19,4 +19,5 @@ Void duplicateLocals(Int a) {
Void localVoid(Void x) {
Void y;
+ y := duplicateLocals(True);
}
diff --git a/sil.icl b/sil.icl
index 5b1529a..32195e7 100644
--- a/sil.icl
+++ b/sil.icl
@@ -89,7 +89,11 @@ Start w
| not ok
# err = err <<< "Could not open 'sil_compiled.abc' for writing\r\n"
= finish 1 io err w
-# f = f <<< 'SC'.compile prog
+# prog = 'SC'.compile prog
+| isError prog
+ # err = err <<< fromError prog <<< "\r\n"
+ = finish 1 io err w
+# f = f <<< fromOk prog
# (_,w) = fclose f w
| not args.generate
= finish 0 io err w
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 19:59:41 +0000