aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--README.md2
-rw-r--r--Sil/Compile.dcl1
-rw-r--r--Sil/Compile.icl74
-rw-r--r--Sil/Parse.dcl1
-rw-r--r--Sil/Parse.icl34
-rw-r--r--Sil/Syntax.dcl2
-rw-r--r--Sil/Syntax.icl2
-rw-r--r--Sil/Types.dcl2
-rw-r--r--Sil/Types.icl35
-rw-r--r--examples/issue-1.sil11
10 files changed, 127 insertions, 37 deletions
diff --git a/README.md b/README.md
index bb02905..f8dff10 100644
--- a/README.md
+++ b/README.md
@@ -31,7 +31,9 @@ or can be interpreted with the [ABCMachine][abc-github] project.
| <Name> '(' <Expression>-clist ')'
| <Op1> <Expression>
| <Expression> <Op2> <Expression>
+ | '(' <Expression>-clist ')'
| '(' <Expression> ')'
+ | <Expression> '.' <Name>
<Op1> ::= '~' | '!'
<Op2> ::= '+' | '-' | '*' | '/' | '%' | '==' | '||' | '&&'
diff --git a/Sil/Compile.dcl b/Sil/Compile.dcl
index 5eb35a2..7b0cf2f 100644
--- a/Sil/Compile.dcl
+++ b/Sil/Compile.dcl
@@ -12,6 +12,7 @@ from Sil.Types import :: Type, :: TypeError
:: CompileError
= UndefinedName Name
+ | UndefinedField Name
| VariableLabel
| FunctionOnStack
| TypeError TypeError Expression
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index cad8000..2a6ba54 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -1,5 +1,6 @@
implementation module Sil.Compile
+import StdBool
import StdEnum
from StdFunc import const, flip, o
import StdList
@@ -212,17 +213,17 @@ where
invert :: TypeSize -> TypeSize
invert ts = {zero & asize=0-ts.asize, bsize=0-ts.bsize}
-checkType :: Type Expression -> Gen ()
-checkType t e = getTypeResolver >>= \tr -> case type tr e of
+getType :: Expression -> Gen Type
+getType 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)
+ Just (Ok t) -> pure $ t
+
+checkType :: Type Expression -> Gen ()
+checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ TypeMisMatch t e)
checkTypeName :: Name Expression -> Gen Type
-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 $> t`
+checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t`
class gen a :: a -> Gen ()
@@ -254,8 +255,9 @@ where
tell [ 'ABC'.Annotation $ toOAnnot` [typeSize a.arg_type \\ a <- f.f_args]
, 'ABC'.Label $ toLabel f.f_name
] *>
- tell (repeatn retSize.asize 'ABC'.Create) *> growStack {retSize & bsize=0} *>
+ tell (repeatn retSize.asize 'ABC'.Create) *>
mapM_ reserveVar [(a.arg_name, a.arg_type) \\ a <- f.f_args] *>
+ growStack {retSize & bsize=0} *>
newReturn cleanup` *>
pushTypeResolver typeresolver *>
setReturnType f.f_type *>
@@ -448,16 +450,18 @@ where
] *>
growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes)
_ -> liftT $ Error $ UndefinedName n
- gen (BuiltinApp op arg) = genToBStack arg *> gen op
+ gen (BuiltinApp op arg) =
+ gen arg *>
+ gen op
gen (BuiltinApp2 e1 LogOr e2) =
checkType TBool e1 *>
checkType TBool e2 *>
fresh "or_true" >>= \true ->
fresh "or_end" >>= \end ->
storeStackOffsets *>
- genToBStack e1 *>
+ gen e1 *>
tell [ 'ABC'.JmpTrue true ] *>
- genToBStack e2 *>
+ gen e2 *>
tell [ 'ABC'.Jmp end ] *>
restoreStackOffsets *>
tell [ 'ABC'.Label true
@@ -470,24 +474,44 @@ where
fresh "and_false" >>= \false ->
fresh "and_end" >>= \end ->
storeStackOffsets *>
- genToBStack e1 *>
+ gen e1 *>
tell [ 'ABC'.JmpFalse false ] *>
- genToBStack e2 *>
+ gen e2 *>
tell [ 'ABC'.Jmp end ] *>
restoreStackOffsets *>
tell [ 'ABC'.Label false
, 'ABC'.PushB False ] *>
growStack {zero & bsize=1} *>
tell [ 'ABC'.Label end ]
- gen (BuiltinApp2 e1 op e2) = mapM genToBStack [e2,e1] *> gen op
+ gen (BuiltinApp2 e1 op e2) =
+ mapM gen [e2,e1] *>
+ gen op
+ gen (Tuple i es) =
+ comment "Building tuple" *>
+ tell [ 'ABC'.Create ] *>
+ growStack {zero & asize=1} *>
+ mapM genToAStack (reverse es) *>
+ tell [ 'ABC'.Raw $ "\tfillh\t_Tuple\t" <+ i <+ "\t" <+ i ] *>
+ shrinkStack {zero & asize=i}
+ gen e=:(Field f e`)
+ | isTuple =
+ getType e` >>= \(TTuple arity tes) ->
+ gen e` *>
+ tell [ 'ABC'.ReplArgs arity arity
+ , 'ABC'.Pop_a (tupleEl - 1)
+ , 'ABC'.Update_a 0 (arity - tupleEl)
+ , 'ABC'.Pop_a (arity - tupleEl)
+ ] *>
+ case typeSize $ tes!!(tupleEl - 1) of
+ {bsize=0} -> nop
+ {btypes} -> mapM (flip toBStack 1) btypes *> nop
+ | otherwise =
+ error $ UndefinedField f
+ where
+ f` = fromString f
-genToBStack :: Expression -> Gen ()
-genToBStack (Name n) = findVar n >>= getLoc
-where
- getLoc :: Address -> Gen ()
- getLoc (AAddr i) = tell ['ABC'.PushI_a $ i] *> growStack {zero & bsize=1}
- getLoc (BAddr i) = tell ['ABC'.Push_b $ i] *> growStack {zero & bsize=1}
-genToBStack e = gen e
+ isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`)
+ tupleEl = toInt $ toString $ tl f`
instance gen Op1
where
@@ -539,6 +563,14 @@ where
'ABC'.BT_Bool -> 'ABC'.FillB_b
'ABC'.BT_Int -> 'ABC'.FillI_b
+genToAStack :: Expression -> Gen ()
+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 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"
+
comment :: String -> Gen ()
comment s = tell ['ABC'.Comment s]
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 0db10e6..d5bf453 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -14,6 +14,7 @@ from Sil.Util.Parser import class name
| TBraceClose //* }
| TComma //* ,
| TSemicolon //* ;
+ | TField String //* . and field name
| TAssign //* :=
| TTilde //* ~
| TExclamation //* !
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index b5e0114..4fdc479 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -36,6 +36,7 @@ where
toString TBraceClose = "}"
toString TComma = ","
toString TSemicolon = ";"
+ toString (TField f) = "." +++ f
toString TAssign = ":="
toString TTilde = "~"
toString TPlus = "+"
@@ -74,6 +75,8 @@ where
skipUntilEndOfComment [] = []
skipUntilEndOfComment ['*':'/':r] = r
skipUntilEndOfComment [_:r] = skipUntilEndOfComment r
+ tks ['.':r=:[c:_]] t | isNameChar c = tks r` [TField $ toString f:t]
+ where (f,r`) = span isNameChar r
tks [':':'=':r] t = tks r [TAssign :t]
tks ['=':'=':r] t = tks r [TDoubleEquals :t]
tks ['|':'|':r] t = tks r [TDoubleBar :t]
@@ -109,7 +112,7 @@ where
(num,numrest) = span isDigit cs
isNameChar :: Char -> Bool
- isNameChar c = isAlpha c || isMember c ['_\'']
+ isNameChar c = isAlphanum c || isMember c ['_\'']
isNotNameChar = not o isNameChar
@@ -221,13 +224,20 @@ where
= liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
<|> op TTilde Neg
<|> op TExclamation Not
- <|> liftM Literal literal
- <|> liftM Name name
- <|> parenthised expression
+ <|> (simpleExpr >>= \e -> many field >>= \fs -> pure $ foldr Field e fs)
where
op :: Token Op1 -> Parser Token Expression
op token operator = liftM (BuiltinApp operator) (item token *> noInfix)
+ field :: Parser Token Name
+ field = satisfy (\t -> t =: TField _) >>= \(TField f) -> pure f
+
+ simpleExpr :: Parser Token Expression
+ simpleExpr = liftM Literal literal
+ <|> liftM Name name
+ <|> (parenthised (min2seplist TComma expression) >>= \es -> pure $ Tuple (length es) es)
+ <|> parenthised expression
+
name :: Parser Token Name
name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
where
@@ -240,12 +250,13 @@ arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
type :: Parser Token Type
type
- = type "Bool" TBool
- <|> type "Int" TInt
- <|> type "Void" TVoid
+ = simpletype "Bool" TBool
+ <|> simpletype "Int" TInt
+ <|> simpletype "Void" TVoid
+ <|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
<?> Expected "type"
where
- type s t = item (TName s) $> t
+ simpletype s t = item (TName s) $> t
literal :: Parser Token Literal
literal = satisfy isLit >>= \(TLit lit) -> pure lit
@@ -259,3 +270,10 @@ parenthised p = item TParenOpen *> p <* item TParenClose
braced :: (Parser Token a) -> Parser Token a
braced p = item TBraceOpen *> p <* item TBraceClose
+
+min2seplist :: a (Parser a b) -> Parser a [b] | ==, name a
+min2seplist sep val =
+ val >>= \v1 ->
+ item sep *>
+ seplist sep val >>= \vs ->
+ pure [v1:vs]
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 669f2f6..0f15930 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -47,6 +47,8 @@ from Sil.Types import :: Type
| App Name [Expression]
| BuiltinApp Op1 Expression
| BuiltinApp2 Expression Op2 Expression
+ | Tuple Int [Expression]
+ | Field Name Expression
:: Op1
= Neg //* ~
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index 43d27fc..cc5c3ba 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -31,6 +31,8 @@ where
toString (App n args) = n <+ "(" <+ printersperse ", " args <+ ")"
toString (BuiltinApp op e) = op <+ "(" <+ e <+ ")"
toString (BuiltinApp2 e1 op e2) = "(" <+ e1 <+ ") " <+ op <+ " (" <+ e2 <+ ")"
+ toString (Tuple _ es) = "(" <+ printersperse ", " es <+ ")"
+ toString (Field f e) = e <+ "." <+ f
instance toString Op1
where
diff --git a/Sil/Types.dcl b/Sil/Types.dcl
index d44a373..0821078 100644
--- a/Sil/Types.dcl
+++ b/Sil/Types.dcl
@@ -14,9 +14,11 @@ from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
| TInt
| TVoid
| (-->) infixr Type Type
+ | TTuple Int [Type]
:: TypeError
= IllegalApplication Type Type
+ | IllegalField Name Type
:: TypeSize =
{ asize :: Int
diff --git a/Sil/Types.icl b/Sil/Types.icl
index cd9b9a4..55e1cc0 100644
--- a/Sil/Types.icl
+++ b/Sil/Types.icl
@@ -1,6 +1,7 @@
implementation module Sil.Types
-from StdFunc import const
+import StdBool
+from StdFunc import const, o
import StdList
import StdMisc
import StdOverloaded
@@ -12,22 +13,25 @@ import Control.Applicative
import Control.Monad
import Data.Error
from Data.Func import $
+import Data.Functor
import Data.Maybe
from Text import <+
from ABC.Assembler import :: BasicType(..)
import Sil.Syntax
+import Sil.Util.Printer
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 <+ ")"
+ toString TBool = "Bool"
+ toString TInt = "Int"
+ toString TVoid = "Void"
+ toString (at --> rt) = "(" <+ at <+ " -> " <+ rt <+ ")"
+ toString (TTuple _ ts) = "(" <+ printersperse ", " ts <+ ")"
instance toString TypeError
where
@@ -36,9 +40,10 @@ where
instance zero TypeSize where zero = {asize=0, bsize=0, btypes=[]}
typeSize :: Type -> TypeSize
-typeSize TVoid = zero
-typeSize TBool = {zero & bsize=1, btypes=[BT_Bool]}
-typeSize TInt = {zero & bsize=1, btypes=[BT_Int]}
+typeSize TVoid = zero
+typeSize TBool = {zero & bsize=1, btypes=[BT_Bool]}
+typeSize TInt = {zero & bsize=1, btypes=[BT_Int]}
+typeSize (TTuple _ _) = {zero & asize=1}
(+~) infixl 6 :: TypeSize TypeSize -> TypeSize
(+~) a b =
@@ -83,6 +88,20 @@ where
( top >>= \top ->
te1 >>= \te1 ->
te2 >>= \te2 -> foldM tryApply top [te1,te2])
+ type res (Tuple n es) =
+ mapM (type res) es >>= \ats -> pure (sequence ats >>= pure o TTuple n)
+ type res (Field f e)
+ | isTuple = type res e >>= \te -> pure (te >>= \te -> case te of
+ TTuple arity es -> if (0 < tupleEl && tupleEl <= arity)
+ (Ok $ es!!(tupleEl - 1))
+ (Error $ IllegalField f te)
+ _ -> Error $ IllegalField f te)
+ | otherwise = type res e >>= \te -> pure (te >>= Error o IllegalField f)
+ where
+ f` = fromString f
+
+ isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`)
+ tupleEl = toInt $ toString $ tl f`
tryApply :: Type Type -> MaybeError TypeError Type
tryApply ft=:(at --> rt) et
diff --git a/examples/issue-1.sil b/examples/issue-1.sil
new file mode 100644
index 0000000..28c6958
--- /dev/null
+++ b/examples/issue-1.sil
@@ -0,0 +1,11 @@
+Int fst((Int, Int) tup) {
+ return tup._1;
+}
+
+(Int, Int) swap((Int, Int) tup) {
+ return (tup._2, tup._1);
+}
+
+Int main() {
+ return fst(swap((1,10)));
+}
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 15:42:03 +0000