Straight-line program interpreter

Chapter 1 of the Tiger book

type id = string
 
type binop = Plus | Minus | Times | Div
 
type stm = CompoundStm of stm * stm
	 | AssignStm of id * exp
	 | PrintStm of exp list
 
and exp = IdExp of id
	| NumExp of int
        | OpExp of exp * binop * exp
        | EseqExp of stm * exp
 
(* 
prog:
a = 5 + 3; 
b = (print [a, a-1]; 10 * a);
print b;
*)
let prog = 
 CompoundStm(
   AssignStm("a", 
             OpExp(NumExp 5, Plus, NumExp 3)),
   CompoundStm(
     AssignStm("b",
       EseqExp(PrintStm[IdExp "a"; OpExp(IdExp "a", Minus, NumExp 1)],
               OpExp(NumExp 10, Times, IdExp "a"))),
     PrintStm[IdExp "b"]))
 
 
(* 1: maxargs *)
let rec maxargs stm = 
  match stm with
    | CompoundStm (s1, s2) -> max (maxargs s1) (maxargs s2)
    | AssignStm (_, e) -> maxargs_exp e
    | PrintStm l -> let max_aux i e = max i (maxargs_exp e)
                    in let maxsub = List.fold_left max_aux  0 l
                    in max (List.length l) maxsub
and maxargs_exp exp =
  match exp with
    | IdExp _ -> 0
    | NumExp _ -> 0
    | OpExp (e1, _, e2) -> max (maxargs_exp e1) (maxargs_exp e2)
    | EseqExp (s, e) -> max (maxargs s) (maxargs_exp e)
 
 
(* 2: interpreter *)
type table = (id * int) list 
 
let rec lookup id env =
  match env with
    | [] -> raise Not_found
    | (x,v)::_ when x = id -> v
    | _::p -> lookup id p 
 
let set x v env = (x, v) :: env
 
let apply op v1 v2 = 
  match op with
    | Plus -> v1 + v2
    | Minus -> v1 - v2
    | Times -> v1 * v2
    | Div -> v1 / v2
 
let rec interp_stm expr env =
  match expr with 
    | CompoundStm (s1, s2) -> let env' = interp_stm s1 env
                              in interp_stm s2 env'
    | AssignStm (id, expr') -> let res, env' = interp_exp expr' env
                               in set id res env
    | PrintStm exprs -> 
      let print_exp env exp = 
        let v, env' = interp_exp exp env
        in print_string (string_of_int v ^ " "); env'   
      in let env' = List.fold_left print_exp env exprs
         in print_string "\n"; env'
 
and interp_exp expr env = 
  match expr with
    | IdExp id -> lookup id env, env 
    | NumExp n -> n, env
    | OpExp (e1, op , e2) -> let v1, env1 = interp_exp e1 env
                             in let v2, env2 = interp_exp e2 env1
                                in apply op v1 v2, env2
    | EseqExp (s, e) -> let env' = interp_stm s env 
                        in interp_exp e env'
 
let _ = 
  print_endline (string_of_int (maxargs prog)); (* => 2 *)
  interp_stm prog []                            (* => 8 7\n 80 *)

Set ADT in OCaml

In chapter 2 of Okasaki’s book, ML’s module system is used to implement an abstract polymorphic Set datatype. We parameterize our set implementation over a “comparable” interface that the set elements must implement.

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
(* "comparable" interface *)
module type Ord =
sig
  type t
  val lt : t -> t -> bool
  val lte : t -> t -> bool
  val eq : t -> t -> bool
end
 
(* implementation of Ord for integers *)
module IntOrd : Ord with type t = int =
struct
  type t = int
  let lt = (<)
  let lte = (<=)
  let eq = (=)
end
 
(* Set interface *)
module type Set =
sig
  (* abstract element and set type *)         
  type elem 
  type set  
  (* set operations *)
  val empty : set
  val insert : elem -> set -> set
  val member : elem -> set -> bool
end
 
(* implementation of a set paramterized over Ord *)
module UnbalSet(Elt : Ord) : Set with type elem = Elt.t =
struct
  type elem = Elt.t
  type 'a tree = 
      Leaf 
    | Node of 'a tree * 'a * 'a tree
  type set = elem tree 
 
  let empty = Leaf
  let rec insert x = function
      Leaf -> Node (Leaf, x, Leaf)
    | Node (a, y, b) as s -> 
        if Elt.lt x y then Node (insert x a, y, b)
        else if Elt.lt y x then Node (a, y, insert x b) 
        else s
 
  let rec member x = function
      Leaf -> false
    | Node (a, y, b) ->
        if Elt.lt x y then member x a               (* two comparisons *)
        else if Elt.lt y x then member x b
        else true
end
 
(* instanciation of a set of comparable integers *)
module IntSet = UnbalSet(IntOrd)

Exercise 2.1 asks to optimize the member operation, by assuming that equality is uncommon we can mostly get away with only one comparison, comparing for equality only when we reached the end of a branch (worst case is now d+1 instead of 2*d comparisons, where d is the depth of the tree):

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
module type Ord =
sig
  type t
  val lt : t -> t -> bool
  val lte : t -> t -> bool
  val eq : t -> t -> bool
end
 
module IntOrd : Ord with type t = int =
struct
  type t = int
  let lt = (<)
  let lte = (<=)
  let eq = (=)
end
 
module type Set =
sig
  type elem
  type set
  val empty : set
  val insert : elem -> set -> set
  val member : elem -> set -> bool
end
 
module UnbalSet(Elt : Ord) : Set with type elem = Elt.t =
struct
  type elem = Elt.t
  type 'a tree = 
      Leaf 
    | Node of 'a tree * 'a * 'a tree
  type set = elem tree 
 
  let empty = Leaf
  let rec insert x = function
      Leaf -> Node (Leaf, x, Leaf)
    | Node (a, y, b) as s -> 
        if Elt.lt x y then Node (insert x a, y, b)
        else if Elt.lt y x then Node (a, y, insert x b) 
        else s
 
  let member x s = 
    let rec member_aux x s z =
      match s with
          Leaf -> x = z  (* comparing for equality when reaching a leaf *)
        | Node(a, y, b) -> 
            if Elt.lt x y then member_aux x a z   (* only one comparison *)
            else member_aux x b y
    in
      match s with
          Leaf -> false
        | Node(_, y, _) -> member_aux x s y             
end
 
module IntSet = UnbalSet(IntOrd)