1scheme COMPILER =
2class
3  type
4    Prog == mk_Prog(stmt : Stmt),
5
6    Stmt ==
7      mk_Asgn(ide : Identifier,  expr : Expr) |
8      mk_If(cond : Expr,  s1 : Stmt, s2 : Stmt) |
9      mk_Seq(head : Stmt,  last : Stmt),
10
11    Expr ==
12      mk_Const(const : Int) |
13      mk_Plus(fst : Expr,  snd : Expr) |
14      mk_Id(ide : Identifier),
15    Identifier = Text
16
17type /* storage for program variables */
18  `Sigma = Identifier -m-> Int
19
20value
21  m : Prog -> `Sigma -> `Sigma
22  m(p)(`sigma)  is  m(stmt(p))(`sigma),
23
24  m : Stmt -> `Sigma -> `Sigma
25  m(s)(`sigma)  is
26    case s of
27      mk_Asgn(i, e) -> `sigma !! [i +> m(e)(`sigma)],
28      mk_Seq(s1, s2) -> m(s2)(m(s1)(`sigma)),
29      mk_If(c, s1, s2) ->
30        if m(c)(`sigma) ~= 0 then m(s1)(`sigma) else m(s2)(`sigma) end
31    end,
32
33  m : Expr -> `Sigma -> Int
34  m(e)(`sigma)  is
35    case e of
36      mk_Const(n) -> n,
37      mk_Plus(e1, e2) -> m(e1)(`sigma) + m(e2)(`sigma),
38      mk_Id(id) -> if id isin  dom `sigma then `sigma(id) else 0 end
39    end
40
41type
42  MProg = Inst-list,
43  Inst ==
44     mk_Push(ide1 : Identifier) |
45     mk_Pop(Unit) |
46     mk_Add(Unit) |
47     mk_Cnst(val : Int) |
48     mk_Store(ide2 : Identifier) |
49     mk_Jumpfalse(off1 : Int) |
50     mk_Jump(off2 : Int)
51
52
53/* An interpreter for SMALL instructions */
54
55type  Stack = Int-list
56value
57  I : MProg >< Int >< Stack -> (`Sigma ->`Sigma)
58  I(mp, pc, s)(`sigma) is
59    if pc <= 0 \/ pc > len mp then `sigma else
60      case  mp(pc) of
61        mk_Push(x) -> if x isin dom `sigma
62          then I(mp, pc + 1, <.`sigma(x).> ^ s)(`sigma)
63          else  I(mp, pc + 1, <.0.> ^ s)(`sigma) end,
64        mk_Pop(()) -> if len s = 0 then `sigma
65          else I(mp, pc + 1, tl s)(`sigma) end,
66        mk_Cnst(n)  -> I(mp, pc + 1, <.n.> ^  s)(`sigma),
67        mk_Add(()) -> if len s < 2 then `sigma
68          else  I(mp, pc + 1,<.s(1) + s(2).> ^ tl tl s)(`sigma) end,
69        mk_Store(x) -> if len s = 0 then `sigma
70          else I(mp, pc + 1, s)(`sigma !! [x +> s(1)]) end,
71        mk_Jumpfalse(n) -> if len s = 0 then `sigma
72          elsif  hd s ~= 0  then I(mp, pc + 1, s)(`sigma)
73          else I(mp, pc + n, s)(`sigma) end,
74        mk_Jump(n) -> I(mp, pc + n, s)(`sigma)
75      end
76    end
77
78value
79  comp_Prog : Prog -> MProg
80  comp_Prog(p) is comp_Stmt(stmt(p)),
81
82  comp_Stmt : Stmt -> MProg
83  comp_Stmt(s) is
84    case s of
85      mk_Asgn(id, e) -> comp_Expr(e) ^ <. mk_Store(id), mk_Pop() .>,
86      mk_Seq(s1, s2) -> comp_Stmt(s1) ^ comp_Stmt(s2),
87      mk_If(e, s1, s2) ->
88       let
89         ce = comp_Expr(e),
90         cs1 = comp_Stmt(s1), cs2 = comp_Stmt(s2)
91       in
92           ce ^
93           <. mk_Jumpfalse(len cs1 + 3) .> ^
94           <. mk_Pop() .> ^
95           cs1 ^
96           <. mk_Jump(len cs2 + 2) .> ^
97           <. mk_Pop() .> ^
98           cs2
99       end
100    end,
101
102  comp_Expr : Expr -> MProg
103  comp_Expr(e) is
104    case e of
105      mk_Const(n) -> <. mk_Cnst(n) .>,
106      mk_Plus(e1, e2) ->
107        comp_Expr(e1) ^ comp_Expr(e2) ^ <. mk_Add() .>,
108      mk_Id(id) -> <. mk_Push(id) .>
109    end
110
111end
112