1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
implementation module Sil.Types
import StdBool
from StdFunc import const, o
import StdList
import StdMisc
import StdOverloaded
import StdString
import Control.Applicative
import Control.Monad
import Data.Error
from Data.Func import $
import Data.Functor
import Data.GenEq
import Data.Maybe
from Text import <+
from ABC.Assembler import :: BasicType(..)
import Sil.Error
import Sil.Syntax
import Sil.Util.Parser
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 (TTuple _ ts) = "(" <+ printersperse ", " ts <+ ")"
toString (TList t) = "[" <+ t <+ "]"
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 (TTuple _ _) = {zero & asize=1}
typeSize (TList _) = {zero & asize=1}
(+~) infixl 6 :: TypeSize TypeSize -> TypeSize
(+~) a b =
{ asize = a.asize + b.asize
, bsize = a.bsize + b.bsize
, btypes = a.btypes ++ b.btypes
}
(-~) infixl 6 :: TypeSize TypeSize -> TypeSize
(-~) a b =
{ asize = a.asize - b.asize
, bsize = a.bsize - b.bsize
, btypes = abort "btypes after -~\r\n"
}
instance zero TypeResolver where zero = const Nothing
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 p n args) =
mapM (type res) args >>= \ats ->
res n >>= \ft -> pure
( sequence ats >>= \ats ->
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 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 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 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
[(e`,t`):_] -> Error $ C_TypeMisMatch t e` t`
[] -> Ok $ TList t)
type res (List _ Nothing []) = Nothing
type res e=:(List _ Nothing es) =
mapM (type res) es >>= \tes -> pure
(sequence tes >>= \tes -> case removeDup tes of
[t] -> Ok $ TList t
[_:_] -> Error $ C_CouldNotDeduceType e)
type res e=:(Tuple _ n es)
| n > 32 = Just $ Error $ T_TooHighTupleArity (errpos e) n
| otherwise =
mapM (type res) es >>= \ats -> pure (sequence ats >>= pure o TTuple n)
type res fe=:(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 $ T_IllegalField (errpos fe) f te)
_ -> Error $ T_IllegalField (errpos fe) f te)
| f == "hd" = type res e >>= \te -> pure (te >>= \te -> case te of
TList t -> Ok t
_ -> Error $ T_IllegalField (errpos fe) f te)
| f == "tl" = type res e >>= \te -> pure (te >>= \te -> case te of
t=:(TList _) -> Ok t
_ -> Error $ T_IllegalField (errpos fe) f te)
| f == "nil" = type res e >>= \te -> pure (te >>= \te -> case te of
(TList _) -> Ok TBool
_ -> Error $ T_IllegalField (errpos fe) f te)
| otherwise = type res e >>= \te -> pure (te >>= Error o T_IllegalField (errpos fe) f)
where
f` = fromString f
isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`)
tupleEl = toInt $ toString $ tl f`
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
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 _ Unequals = Just $ Ok $ TInt --> TInt --> TBool
type _ CmpLe = Just $ Ok $ TInt --> TInt --> TBool
type _ CmpGe = Just $ Ok $ TInt --> TInt --> TBool
type _ CmpLt = Just $ Ok $ TInt --> TInt --> TBool
type _ CmpGt = Just $ Ok $ TInt --> TInt --> TBool
type _ LogOr = Just $ Ok $ TBool --> TBool --> TBool
type _ LogAnd = Just $ Ok $ TBool --> TBool --> TBool
|
