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