aboutsummaryrefslogtreecommitdiff
path: root/Sil/Compile.icl
diff options
context:
space:
mode:
Diffstat (limited to 'Sil/Compile.icl')
-rw-r--r--Sil/Compile.icl56
1 files changed, 28 insertions, 28 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index 6efee77..6475da7 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -198,12 +198,12 @@ where
{asize,bsize=0} -> ((aso + asize, bso), AAddr $ aso + asize)
{asize=0,bsize} -> ((aso, bso + bsize), BAddr $ bso + bsize)
-findVar :: Name -> Gen Address
-findVar n = gets stackoffsets >>= \(aso, bso) ->
+findVar :: ParsePosition Name -> Gen Address
+findVar p n = gets stackoffsets >>= \(aso, bso) ->
gets addresses >>= \addr -> case 'M'.get n addr of
Just (AAddr i) -> comment (n <+ " is on AStack at " <+ i <+ ", with aso " <+ aso <+ " so " <+ (aso-i)) $> AAddr (aso - i)
Just (BAddr i) -> comment (n <+ " is on BStack at " <+ i <+ ", with bso " <+ bso <+ " so " <+ (bso-i)) $> BAddr (bso - i)
- Nothing -> error $ C_UndefinedName n
+ Nothing -> error $ C_UndefinedName (errpos p) n
addFunction :: Function -> Gen ()
addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols})
@@ -239,8 +239,8 @@ getType e = getTypeResolver >>= \tr -> case type tr e of
checkType :: Type Expression -> Gen ()
checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e t`)
-checkTypeName :: Name Expression -> Gen Type
-checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t`
+checkTypeName :: ParsePosition Name Expression -> Gen Type
+checkTypeName pp n e = getType (Name pp n) >>= \t` -> checkType t` e $> t`
tellAbort :: String -> Gen ()
tellAbort s = tell
@@ -396,16 +396,16 @@ where
Nothing -> tell $ repeatn s.asize 'ABC'.Create
Just v -> shrinkStack s *> gen v
s=:{asize=0} -> case init.init_value of
- Nothing -> error $ C_BasicInitWithoutValue init.init_name
+ Nothing -> error $ C_BasicInitWithoutValue (errpos init) init.init_name
Just v -> checkType init.init_type v *> shrinkStack s *> gen v
instance gen Statement
where
- gen st=:(Declaration _ n e) =
- checkTypeName n e >>= \t ->
+ gen st=:(Declaration pp n e) =
+ checkTypeName pp n e >>= \t ->
comment (toString st) *>
gen e *>
- findVar n >>=
+ findVar pp n >>=
updateLoc t
where
updateLoc :: Type Address -> Gen ()
@@ -477,18 +477,18 @@ where
instance gen Expression
where
- gen (Name n) = findVar n >>= getLoc
+ gen (Name p n) = findVar p n >>= getLoc
where
getLoc :: Address -> Gen ()
getLoc (AAddr i) = tell ['ABC'.Push_a $ i] *> growStack {zero & asize=1}
getLoc (BAddr i) = tell ['ABC'.Push_b $ i] *> growStack {zero & bsize=1,btypes=['ABC'.BT_Int]} //TODO check type
- gen (Literal (BLit b)) =
+ gen (Literal _ (BLit b)) =
tell ['ABC'.PushB b] *>
growStack {zero & bsize=1,btypes=['ABC'.BT_Bool]}
- gen (Literal (ILit i)) =
+ gen (Literal _ (ILit i)) =
tell ['ABC'.PushI i] *>
growStack {zero & bsize=1,btypes=['ABC'.BT_Int]}
- gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+ 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 ->
@@ -500,11 +500,11 @@ where
, 'ABC'.Annotation $ toOAnnot $ typeSize fs.fs_rettype
] *>
growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes)
- _ -> error $ C_UndefinedName n
- gen (BuiltinApp op arg) =
+ _ -> error $ C_UndefinedName (errpos p) n
+ gen (BuiltinApp _ op arg) =
gen arg *>
gen op
- gen (BuiltinApp2 e1 LogOr e2) =
+ gen (BuiltinApp2 _ e1 LogOr e2) =
checkType TBool e1 *>
checkType TBool e2 *>
fresh "or_true" >>= \true ->
@@ -520,7 +520,7 @@ where
, 'ABC'.PushB True ] *>
growStack {zero & bsize=1} *>
tell [ 'ABC'.Label end ]
- gen (BuiltinApp2 e1 LogAnd e2) =
+ gen (BuiltinApp2 _ e1 LogAnd e2) =
checkType TBool e1 *>
checkType TBool e2 *>
fresh "and_false" >>= \false ->
@@ -536,24 +536,24 @@ where
, 'ABC'.PushB False ] *>
growStack {zero & bsize=1} *>
tell [ 'ABC'.Label end ]
- gen (BuiltinApp2 e1 Cons e2) =
+ gen (BuiltinApp2 _ e1 Cons e2) =
genToAStack e2 *>
genToAStack e1 *>
tell [ 'ABC'.Raw "\tbuildh\t_Cons\t2" ] *>
shrinkStack {zero & asize=1}
- gen (BuiltinApp2 e1 op e2) =
+ gen (BuiltinApp2 _ e1 op e2) =
mapM gen [e2,e1] *>
gen op
- gen (Tuple i es) =
+ gen (Tuple _ i es) =
comment "Building tuple" *>
mapM genToAStack (reverse es) *>
tell [ 'ABC'.Raw $ "\tbuildh\t_Tuple\t" <+ i ] *>
shrinkStack {zero & asize=i-1}
- gen (List _ []) = tell ['ABC'.Raw "\tbuildh\t_Nil\t0"] *> growStack {zero & asize=1}
- gen (List t [e:es]) =
+ gen (List _ _ []) = tell ['ABC'.Raw "\tbuildh\t_Nil\t0"] *> growStack {zero & asize=1}
+ gen (List pp t [e:es]) =
getType e >>= \te ->
- gen (BuiltinApp2 e Cons (List (t <|> pure te) es))
- gen e=:(Field f e`)
+ gen (BuiltinApp2 pp e Cons (List pp (t <|> pure te) es))
+ gen e=:(Field _ f e`)
| isTuple =
getType e` >>= \t=:(TTuple arity tes) ->
gen e` *>
@@ -561,7 +561,7 @@ where
, 'ABC'.Pop_a (tupleEl - 1)
, 'ABC'.Update_a 0 (arity - tupleEl)
, 'ABC'.Pop_a (arity - tupleEl) ] *>
- if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField f t) nop *>
+ if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField (errpos e) f t) nop *>
case typeSize $ tes!!(tupleEl - 1) of
{bsize=0} -> nop
{btypes} -> mapM (flip toBStack 1) btypes *> nop
@@ -594,7 +594,7 @@ where
, 'ABC'.Pop_a 1 ] *>
growStack {asize=(-1), bsize=1, btypes=['ABC'.BT_Bool]}
| otherwise =
- error $ C_UndefinedField f
+ error $ C_UndefinedField (errpos e) f
where
f` = fromString f
@@ -655,9 +655,9 @@ where
'ABC'.BT_Int -> 'ABC'.FillI_b
genToAStack :: Expression -> Gen ()
-genToAStack (Literal (BLit b)) = tell [ 'ABC'.Raw $ "\tbuildB\t" <+ toABCBool b ] *> growStack {zero & asize=1}
+genToAStack (Literal _ (BLit b)) = tell [ 'ABC'.Raw $ "\tbuildB\t" <+ toABCBool b ] *> growStack {zero & asize=1}
where toABCBool = toString o map toUpper o fromString o toString
-genToAStack (Literal (ILit i)) = tell [ 'ABC'.Raw $ "\tbuildI\t" <+ i ] *> growStack {zero & asize=1}
+genToAStack (Literal _ (ILit i)) = tell [ 'ABC'.Raw $ "\tbuildI\t" <+ i ] *> growStack {zero & asize=1}
genToAStack e = getType e >>= \t -> case typeSize t of
{bsize=0} -> gen e
{btypes} -> gen e <* comment "To A-stack" <* mapM BtoAStack btypes <* comment "Done to A-stack"
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:31:32 +0000