comparison lab4/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 (* lab4/tree.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Dict
5 open Print
6
7 (* |name| -- type for applied occurrences, with mutable 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 (* abstract syntax *)
14 type program = Prog of block * def list ref
15
16 and block = Block of decl list * stmt * int ref * int ref
17
18 and decl =
19 ConstDecl of ident * expr
20 | VarDecl of def_kind * ident list * typexpr
21 | TypeDecl of (ident * typexpr) list
22 | ProcDecl of proc_heading * block
23 | PParamDecl of proc_heading
24
25 and proc_heading = Heading of name * decl list * typexpr option
26
27 and stmt =
28 { s_guts: stmt_guts;
29 s_line: int }
30
31 and stmt_guts =
32 Skip
33 | Seq of stmt list
34 | Assign of expr * expr
35 | ProcCall of name * expr list
36 | Return of expr option
37 | IfStmt of expr * stmt * stmt
38 | WhileStmt of expr * stmt
39 | RepeatStmt of stmt * expr
40 | ForStmt of expr * expr * expr * stmt * def option ref
41 | CaseStmt of expr * (expr * stmt) list * stmt
42
43 and expr =
44 { e_guts: expr_guts;
45 mutable e_type: ptype;
46 mutable e_value: int option }
47
48 and expr_guts =
49 Constant of int * ptype
50 | Variable of name
51 | Sub of expr * expr
52 | Select of expr * name
53 | Deref of expr
54 | String of Optree.symbol * int
55 | Nil
56 | FuncCall of name * expr list
57 | Monop of Optree.op * expr
58 | Binop of Optree.op * expr * expr
59
60 and typexpr =
61 TypeName of name
62 | Array of expr * typexpr
63 | Record of decl list
64 | Pointer of typexpr
65
66 (* |makeExpr| -- construct an expression node with dummy annotations *)
67 let makeExpr e =
68 { e_guts = e; e_type = voidtype; e_value = None }
69
70 (* |makeStmt| -- construct a stmt node *)
71 let makeStmt (s, n) = { s_guts = s; s_line = n }
72
73 (* |makeName| -- contruct a name node with dummy annotations *)
74 let makeName (x, n) = { x_name = x; x_line = n; x_def = None }
75
76 let get_def x =
77 match x.x_def with
78 Some d -> d
79 | None -> failwith (sprintf "missing def of $" [fId x.x_name])
80
81 (* |MakeBlock| -- construct a block node with dummy annotations *)
82 let makeBlock (decls, stmts) = Block (decls, stmts, ref 0, ref 0)
83
84
85 (* Grinder *)
86
87 let fTail f xs =
88 let g prf = List.iter (fun x -> prf " $" [f x]) xs in fExt g
89
90 let fList f =
91 function
92 [] -> fStr "()"
93 | x::xs -> fMeta "($$)" [f x; fTail(f) xs]
94
95 let fName x = fId x.x_name
96
97 let rec fBlock (Block (decls, stmts, _, _)) =
98 match decls with
99 [] -> fMeta "(BLOCK $)" [fStmt stmts]
100 | _ -> fMeta "(BLOCK (DECLS$) $)" [fTail(fDecl) decls; fStmt stmts]
101
102 and fDecl =
103 function
104 ConstDecl (x, e) ->
105 fMeta "(CONST $ $)" [fId x; fExpr e]
106 | VarDecl (kind, xs, te) ->
107 fMeta "($ $ $)" [fKind kind; fList(fId) xs; fType te]
108 | TypeDecl tds ->
109 let f (x, te) = fMeta "($ $)" [fId x; fType te] in
110 fMeta "(TYPE$)" [fTail(f) tds]
111 | ProcDecl (heading, body) ->
112 fMeta "(PROC $ $)" [fHeading heading; fBlock body]
113 | PParamDecl heading ->
114 fMeta "(PROC $)" [fHeading heading]
115
116 and fKind =
117 function
118 VarDef -> fStr "VAR"
119 | CParamDef -> fStr "PARAM"
120 | VParamDef -> fStr "VPARAM"
121 | FieldDef -> fStr "FIELD"
122 | _ -> fStr "???"
123
124 and fHeading (Heading (p, fps, te)) =
125 let res = match te with Some t -> fType t | None -> fStr "VOID" in
126 fMeta "($ $ $)" [fName p; fList(fDecl) fps; res]
127
128 and fStmt s =
129 match s.s_guts with
130 Skip -> fStr "(SKIP)"
131 | Seq stmts -> fMeta "(SEQ$)" [fTail(fStmt) stmts]
132 | Assign (e1, e2) -> fMeta "(ASSIGN $ $)" [fExpr e1; fExpr e2]
133 | ProcCall (p, aps) -> fMeta "(CALL $$)" [fName p; fTail(fExpr) aps]
134 | Return (Some e) -> fMeta "(RETURN $)" [fExpr e]
135 | Return None -> fStr "(RETURN)"
136 | IfStmt (test, thenpt, elsept) ->
137 fMeta "(IF $ $ $)" [fExpr test; fStmt thenpt; fStmt elsept]
138 | WhileStmt (test, body) ->
139 fMeta "(WHILE $ $)" [fExpr test; fStmt body]
140 | RepeatStmt (body, test) ->
141 fMeta "(REPEAT $ $)" [fStmt body; fExpr test]
142 | ForStmt (var, lo, hi, body, _) ->
143 fMeta "(FOR $ $ $ $)" [fExpr var; fExpr lo; fExpr hi; fStmt body]
144 | CaseStmt (sel, arms, deflt) ->
145 let fArm (lab, body) = fMeta "($ $)" [fExpr lab; fStmt body] in
146 fMeta "(CASE $ $ $)" [fExpr sel; fList(fArm) arms; fStmt deflt]
147
148 and fExpr e =
149 match e.e_guts with
150 Constant (n, t) -> fMeta "(CONST $)" [fNum n]
151 | Variable x -> fName x
152 | Sub (e1, e2) -> fMeta "(SUB $ $)" [fExpr e1; fExpr e2]
153 | Select (e1, x) -> fMeta "(SELECT $ $)" [fExpr e1; fName x]
154 | Deref e1 -> fMeta "(DEREF $)" [fExpr e1]
155 | String (s, _) -> fMeta "(STRING $)" [fStr s]
156 | Nil -> fStr "(NIL)"
157 | FuncCall (p, aps) ->
158 fMeta "(CALL $$)" [fName p; fTail(fExpr) aps]
159 | Monop (w, e1) ->
160 fMeta "($ $)" [Optree.fOp w; fExpr e1]
161 | Binop (w, e1, e2) ->
162 fMeta "($ $ $)" [Optree.fOp w; fExpr e1; fExpr e2]
163
164 and fType =
165 function
166 TypeName x -> fName x
167 | Array (e, t1) -> fMeta "(ARRAY $ $)" [fExpr e; fType t1]
168 | Record fields -> fMeta "(RECORD$)" [fTail(fDecl) fields]
169 | Pointer t1 -> fMeta "(POINTER $)" [fType t1]
170
171 let print_tree fp pfx (Prog (body, _)) =
172 fgrindf fp pfx "(PROGRAM $)" [fBlock body]