blob: 55e1cc050deadf376a9e4ca353fe79523e9e5e28 (
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
|
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 <+ "."
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) =
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
|
