diff options
| -rw-r--r-- | Sil/Compile.icl | 24 | ||||
| -rw-r--r-- | Sil/Error.dcl | 4 | ||||
| -rw-r--r-- | Sil/Error.icl | 8 | ||||
| -rw-r--r-- | Sil/Types.icl | 27 |
4 files changed, 28 insertions, 35 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl index 6475da7..e16cdd9 100644 --- a/Sil/Compile.icl +++ b/Sil/Compile.icl @@ -488,19 +488,17 @@ where gen (Literal _ (ILit i)) = tell ['ABC'.PushI i] *> growStack {zero & bsize=1,btypes=['ABC'.BT_Int]} - gen (App p n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of - Just i -> error C_FunctionOnStack - _ -> gets symbols >>= \syms -> case 'M'.get n syms of - Just fs -> - comment "Retrieve arguments" *> - mapM gen args *> - comment "Apply function" *> - tell [ 'ABC'.Annotation $ toDAnnot` $ map typeSize fs.fs_argtypes - , 'ABC'.Jsr $ toLabel n - , 'ABC'.Annotation $ toOAnnot $ typeSize fs.fs_rettype - ] *> - growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes) - _ -> error $ C_UndefinedName (errpos p) n + gen (App p n args) = gets symbols >>= \syms -> case 'M'.get n syms of + Just fs -> + comment "Retrieve arguments" *> + mapM gen args *> + comment "Apply function" *> + tell [ 'ABC'.Annotation $ toDAnnot` $ map typeSize fs.fs_argtypes + , 'ABC'.Jsr $ toLabel n + , 'ABC'.Annotation $ toOAnnot $ typeSize fs.fs_rettype + ] *> + growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes) + _ -> error $ C_UndefinedName (errpos p) n gen (BuiltinApp _ op arg) = gen arg *> gen op diff --git a/Sil/Error.dcl b/Sil/Error.dcl index 42341ed..947ba9a 100644 --- a/Sil/Error.dcl +++ b/Sil/Error.dcl @@ -18,7 +18,7 @@ instance < ErrorPosition = E.a: P_Invalid String a & toString a | E.a: P_Expected ErrorPosition String a & toString a // Type errors - | T_IllegalApplication Type Type + | T_IllegalApplication ErrorPosition Type Type | T_IllegalField ErrorPosition String Type | T_TooHighTupleArity ErrorPosition Int // Check errors @@ -33,8 +33,6 @@ instance < ErrorPosition // Compile errors | C_UndefinedName ErrorPosition String | C_UndefinedField ErrorPosition String - | C_VariableLabel - | C_FunctionOnStack | C_CouldNotDeduceType Expression | C_TypeMisMatch Type Expression Type | C_BasicInitWithoutValue ErrorPosition String diff --git a/Sil/Error.icl b/Sil/Error.icl index e548e33..66fb338 100644 --- a/Sil/Error.icl +++ b/Sil/Error.icl @@ -26,7 +26,7 @@ instance toString Error where toString (P_Invalid w tk) = "\tInvalid token '" <+ tk <+ "' while parsing a " <+ w <+ "." 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_IllegalApplication p ft et) = p <+ "Cannot apply a " <+ et <+ " to a " <+ ft <+ "." toString (T_IllegalField p f t) = p <+ "Illegal field '" <+ f <+ "' on type " <+ t <+ "." toString (T_TooHighTupleArity p i) = p <+ "Too high tuple arity " <+ i <+ " (maximum is 32)." toString Ck_NoMainFunction = "\tError: no main function." @@ -39,8 +39,6 @@ where toString (Ck_BasicGlobal p g) = p <+ "Error: global variable '" <+ g <+ "' cannot have a basic type." toString (C_UndefinedName p n) = p <+ "Undefined name '" <+ n <+ "'." toString (C_UndefinedField p f) = p <+ "Undefined field '" <+ f <+ "'." - toString C_VariableLabel = "\tVariable stored at label." - toString C_FunctionOnStack = "\tFunction stored on the stack." toString (C_CouldNotDeduceType e) = errpos e <+ "Could not deduce type of '" <+ e <+ "'." toString (C_TypeMisMatch t e u) = errpos e <+ "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ u <+ "." toString (C_BasicInitWithoutValue p n) = p <+ "Basic value '" <+ n <+ "' must have an initial value." @@ -60,7 +58,7 @@ where 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_IllegalApplication p ft et) = Just p getErrorPosition (T_IllegalField p f t) = Just p getErrorPosition (T_TooHighTupleArity p i) = Just p getErrorPosition Ck_NoMainFunction = Nothing @@ -73,8 +71,6 @@ getErrorPosition (Ck_LocalVoid p l) = Just p getErrorPosition (Ck_BasicGlobal p g) = Just p getErrorPosition (C_UndefinedName p n) = Just p getErrorPosition (C_UndefinedField p f) = Just p -getErrorPosition C_VariableLabel = Nothing -getErrorPosition C_FunctionOnStack = Nothing getErrorPosition (C_CouldNotDeduceType e) = Just (errpos e) getErrorPosition (C_TypeMisMatch t e u) = Just (errpos e) getErrorPosition (C_BasicInitWithoutValue p n) = Just p diff --git a/Sil/Types.icl b/Sil/Types.icl index a68a7b8..2fdd666 100644 --- a/Sil/Types.icl +++ b/Sil/Types.icl @@ -21,6 +21,7 @@ from ABC.Assembler import :: BasicType(..) import Sil.Error import Sil.Syntax +import Sil.Util.Parser import Sil.Util.Printer derive gEq Type @@ -70,30 +71,30 @@ where type res (Literal _ lit) = case lit of BLit _ -> Just $ Ok TBool ILit _ -> Just $ Ok TInt - type res (App _ n args) = + type res (App p 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) = + ft >>= \ft -> foldM (tryApply p) ft ats) + type res (BuiltinApp p op e) = type res e >>= \te -> type res op >>= \top -> pure ( top >>= \top -> - te >>= \te -> tryApply top te) - type res (BuiltinApp2 _ e1 Cons e2) = + te >>= \te -> tryApply p top te) + type res (BuiltinApp2 p e1 Cons e2) = type res e1 >>= \te1 -> type res e2 >>= \te2 -> pure ( te1 >>= \te1 -> te2 >>= \te2 -> let top = te1 --> TList te1 --> TList te1 in - foldM tryApply top [te1,te2]) - type res (BuiltinApp2 _ e1 op e2) = + foldM (tryApply p) top [te1,te2]) + type res (BuiltinApp2 p 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]) + te2 >>= \te2 -> foldM (tryApply p) top [te1,te2]) type res e=:(List _ (Just t) es) = mapM (type res) es >>= \tes -> pure (sequence tes >>= \tes -> case [(e,t`) \\ e <- es & t` <- tes | t <> t`] of @@ -131,11 +132,11 @@ where isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`) tupleEl = toInt $ toString $ tl f` -tryApply :: Type Type -> MaybeError Error Type -tryApply ft=:(at --> rt) et -| et == at = Ok rt -| otherwise = Error $ T_IllegalApplication ft et -tryApply ft et = Error $ T_IllegalApplication ft et +tryApply :: ParsePosition Type Type -> MaybeError Error Type +tryApply p ft=:(at --> rt) et +| et == at = Ok rt +| otherwise = Error $ T_IllegalApplication (errpos p) ft et +tryApply p ft et = Error $ T_IllegalApplication (errpos p) ft et instance type Name where type res n = res n |