blob: b2009dd76da3eccfb0768b0163fbb6358565f9bd (
plain) (
blame)
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
|
implementation module Sil.Types
import StdBool
from StdFunc import const, o
import StdList
import StdMisc
import StdOverloaded
import StdString
import GenEq
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 (TTuple _ ts) = "(" <+ printersperse ", " ts <+ ")"
instance toString TypeError
where
toString (IllegalApplication ft et) = "Cannot apply a " <+ et <+ " to a " <+ ft <+ "."
toString (IllegalField f t) = "Illegal field '" <+ f <+ "' on type " <+ t <+ "."
toString (TooHighTupleArity i) = "Too high tuple arity " <+ i <+ " (maximum is 32)."
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}
(+~) 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 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])
type res (Tuple n es)
| n > 32 = Just $ Error $ TooHighTupleArity n
| otherwise =
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
| 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
|
