comparison lab3/tree.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 (* lab3/tree.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Dict
5 open Print
6
7 (* |name| -- type for applied occurrences with annotations *)
8 type name =
9 { x_name: ident; (* Name of the reference *)
10 x_line: int; (* Line number *)
11 mutable x_def: def option } (* Definition in scope *)
12
13 type expr =
14 Constant of int
15 | Variable of name
16 | Monop of Keiko.op * expr
17 | Binop of Keiko.op * expr * expr
18 | Call of name * expr list
19
20 type stmt =
21 Skip
22 | Seq of stmt list
23 | Assign of name * expr
24 | Return of expr
25 | IfStmt of expr * stmt * stmt
26 | WhileStmt of expr * stmt
27 | Print of expr
28 | Newline
29
30 type block = Block of ident list * proc list * stmt
31
32 and proc = Proc of name * ident list * block
33
34 type program = Program of block
35
36
37 let seq =
38 function
39 [] -> Skip
40 | [s] -> s
41 | ss -> Seq ss
42
43 let makeName x ln =
44 { x_name = x; x_line = ln; x_def = None }
45
46 let get_def x =
47 match x.x_def with
48 Some d -> d
49 | None -> failwith (sprintf "missing def on $" [fStr x.x_name])
50
51
52 (* Pretty printer *)
53
54 open Print
55
56 let fTail f xs =
57 let g prf = List.iter (fun x -> prf "; $" [f x]) xs in fExt g
58
59 let fList f =
60 function
61 [] -> fStr "[]"
62 | x::xs -> fMeta "[$$]" [f x; fTail(f) xs]
63
64 let fName x = fStr x.x_name
65
66 let rec fExpr =
67 function
68 Constant n ->
69 fMeta "Number_$" [fNum n]
70 | Variable x ->
71 fMeta "Variable_$" [fName x]
72 | Monop (w, e1) ->
73 fMeta "Monop_($, $)" [fStr (Keiko.op_name w); fExpr e1]
74 | Binop (w, e1, e2) ->
75 fMeta "Binop_($, $, $)" [fStr (Keiko.op_name w); fExpr e1; fExpr e2]
76 | Call (x, es) ->
77 fMeta "Call_($, $)" [fName x; fList(fExpr) es]
78
79 let rec fStmt =
80 function
81 Skip ->
82 fStr "Skip"
83 | Seq ss ->
84 fMeta "Seq_$" [fList(fStmt) ss]
85 | Assign (x, e) ->
86 fMeta "Assign_($, $)" [fName x; fExpr e]
87 | Return e ->
88 fMeta "Return_($)" [fExpr e]
89 | Print e ->
90 fMeta "Print_($)" [fExpr e]
91 | Newline ->
92 fStr "Newline"
93 | IfStmt (e, s1, s2) ->
94 fMeta "IfStmt_($, $, $)" [fExpr e; fStmt s1; fStmt s2]
95 | WhileStmt (e, s) ->
96 fMeta "WhileStmt_($, $)" [fExpr e; fStmt s]
97
98 let rec fBlock (Block (vs, ps, body)) =
99 fMeta "Block_($, $, $)" [fList(fStr) vs; fList(fProc) ps; fStmt body]
100
101 and fProc (Proc (x, fps, body)) =
102 fMeta "Proc_($, $, $)" [fName x; fList(fStr) fps; fBlock body]
103
104 let print_tree fp (Program b) =
105 fgrindf fp "" "Program_($)" [fBlock b]