-
Notifications
You must be signed in to change notification settings - Fork 3
/
SECD.ml
122 lines (95 loc) · 5.3 KB
/
SECD.ml
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
(* Expressions *)
type exp = Int of int | Bool of bool | Var of string | Abs of string * exp | App of exp * exp | Absolute of exp| Not of exp
| Add of exp*exp| Sub of exp*exp| Div of exp*exp| Mul of exp*exp| Mod of exp*exp| Exp of exp*exp
| And of exp*exp| Or of exp*exp| Imp of exp*exp
| Equ of exp*exp| GTEqu of exp*exp| LTEqu of exp*exp| Grt of exp*exp| Lst of exp*exp
| Tup of exp list| Proj of exp*exp | Ifthenelse of (exp*exp*exp);;
(* Opcode list generated by compiler *)
type opcode = INT of int | BOOL of bool | LOOKUP of string | CLOS of string*(opcode list) | CALL | RET | ABSOLUTE
| NOT| ADD| SUB| DIV| MUL| MOD| EXP| AND| OR| IMP | EQU| GTEQU| LTEQU| GRT| LST| TUP | PROJ| COND of (opcode list)*(opcode list);;
(* Interdependent types *)
type table = (string * answer) list
and answer = I of int | B of bool | Vclos of table*string*control | T of answer list
and stack = answer list
and environment = table
and control = opcode list
and dump = ( stack*environment*control )list;;
let _env = [("x", I 3); ("y", I 5); ("z", B true)];;
(* exceptions *)
exception InvalidOperation;;
exception Variable_not_intialized;;
exception ErrorInExecutionSECD;;
exception JoinError;;
exception StackError;;
(* useful functions*)
let rec join (s,n) = match (s,n) with (s,0) -> [] | (n1::s',n) -> (join (s',(n-1)))@[n1] | _-> raise JoinError;;
let rec stackleft (s',n1) = match (s',n1) with (s',0) -> s' | (n2::s',n1) -> (stackleft (s',(n1-1))) | _-> raise StackError;;
let nth l i = match (l,i) with (l,i) -> (Array.of_list(l)).(i);;
let rec power a b = match (a,b) with
(a,0) -> 1 |
(a,b) -> a*(power a (b-1));;
let imp a b = match(a,b) with (true,false) -> false| _-> true;;
let rec lookup x env = match env with
[] -> raise Variable_not_intialized
| (str,ans)::env' -> if str = x then ans else lookup x env';;
let rec map2 f l = match l with
[]->[]
| x::xs -> (f x)@(map2 f xs);;
(* compile function *)
let rec compile e = match e with
| Int(i) -> [INT(i)];
| Bool(i) -> [BOOL(i)]
| Var(x) -> [LOOKUP(x)]
| Abs(x, i2) -> [CLOS(x, (compile i2)@[RET])]
| App(i1, i2) -> (compile i1)@(compile i2)@[CALL]
| Absolute t -> (compile t)@[ABSOLUTE]
| Not t -> (compile t)@[NOT]
| Add(i1,i2) -> (compile i1)@(compile i2)@[ADD]
| Sub (e1,e2) -> (compile e1)@(compile e2)@[SUB]
| Mul (e1,e2) -> (compile e1)@(compile e2)@[MUL]
| Div (e1,e2) -> (compile e1)@(compile e2)@[DIV]
| Exp (e1,e2) -> (compile e1)@(compile e2)@[EXP]
| Mod (e1,e2) -> (compile e1)@(compile e2)@[MOD]
| And (e1,e2) -> (compile e1)@(compile e2)@[AND]
| Or (e1,e2) -> (compile e1)@(compile e2)@[OR]
| Imp (e1,e2) -> (compile e1)@(compile e2)@[IMP]
| Equ (e1,e2) -> (compile e1)@(compile e2)@[EQU]
| GTEqu (e1,e2) -> (compile e1)@(compile e2)@[GTEQU]
| LTEqu (e1,e2) -> (compile e1)@(compile e2)@[LTEQU]
| Grt (e1,e2) -> (compile e1)@(compile e2)@[GRT]
| Lst (e1,e2) -> (compile e1)@(compile e2)@[LST]
| Tup(e1) -> (map2 compile e1)@[INT(List.length e1);TUP]
| Proj (e1,e2) -> (compile e2)@(compile e1)@[PROJ]
| Ifthenelse (b,e1,e2) -> compile(b)@[COND(compile e1, compile e2)];;
(* secdmachine execution function *)
let rec secdmachine = function
| (x::s, _, [], _) -> x
| (s, e, INT(i)::c, d) -> secdmachine (I(i)::s, e, c, d)
| (s, e, BOOL(i)::c, d) -> secdmachine (B(i)::s, e, c, d)
| (s, e, LOOKUP(x)::c, d) -> secdmachine ((lookup x e)::s, e, c, d)
| (s, e, CLOS(x, c')::c, d) -> secdmachine (Vclos(e, x, c')::s, e, c, d)
| (x::Vclos(e', x', c')::s, e, CALL::c, d) -> secdmachine ([], (x', x)::e', c', (s, e, c)::d)
| (x::s, e, RET::c, (s', e', c')::d) -> secdmachine (x::s', e', c', d)
| (I(i1)::s, e, ABSOLUTE::c, d) -> secdmachine (I(if i1>0 then i1 else ((-1)*i1))::s, e, c, d)
| (B(i1)::s, e, NOT::c, d) -> secdmachine (B(not i1)::s, e, c, d)
| (I(i2)::I(i1)::s, e, ADD::c, d) -> secdmachine (I(i1+i2)::s, e, c, d)
| (I(i2)::I(i1)::s, e, SUB::c, d) -> secdmachine (I(i1-i2)::s, e, c, d)
| (I(i2)::I(i1)::s, e, MUL::c, d) -> secdmachine (I(i1*i2)::s, e, c, d)
| (I(i2)::I(i1)::s, e, DIV::c, d) -> secdmachine (I(i1/i2)::s, e, c, d)
| (I(i2)::I(i1)::s, e, EXP::c, d) -> secdmachine (I(power i1 i2)::s, e, c, d)
| (I(i2)::I(i1)::s, e, MOD::c, d) -> secdmachine (I(i1 mod i2)::s, e, c, d)
| (B(i2)::B(i1)::s, e, AND::c, d) -> secdmachine (B(i1 && i2)::s, e, c, d)
| (B(i2)::B(i1)::s, e, OR::c, d) -> secdmachine (B(i1 || i2)::s, e, c, d)
| (B(i2)::B(i1)::s, e, IMP::c, d) -> secdmachine (B(imp i1 i2)::s, e, c, d)
| (I(i2)::I(i1)::s, e, EQU::c, d) -> secdmachine (B(if i1==i2 then true else false)::s, e, c, d)
| (I(i2)::I(i1)::s, e, GTEQU::c, d) -> secdmachine (B(if i1>=i2 then true else false)::s, e, c, d)
| (I(i2)::I(i1)::s, e, LTEQU::c, d) -> secdmachine (B(if i1<=i2 then true else false)::s, e, c, d)
| (I(i2)::I(i1)::s, e, LST::c, d) -> secdmachine (B(if i1<i2 then true else false)::s, e, c, d)
| (I(i2)::I(i1)::s, e, GRT::c, d) -> secdmachine (B(if i1>i2 then true else false)::s, e, c, d)
| (I(n1)::s', e, TUP::c', d) -> (match (join (s',n1), stackleft (s',n1)) with (a,b) -> secdmachine (T(a)::b, e, c', d))
| (T(n1)::I(n2)::s', e, PROJ::c', d) -> secdmachine ((nth n1 n2)::s', e, c', d)
| (B(true)::s, e, COND(c', c'')::c, d) -> secdmachine (s, e, c'@c, d)
| (B(false)::s, e, COND(c', c'')::c, d) -> secdmachine (s, e, c''@c, d)
| _-> raise InvalidOperation;;
(* execute call *)
let execute oplist = secdmachine ([], _env, oplist, []);;