annotate lab4/dict.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
rev   line source
0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
1 (* lab4/dict.ml *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
2 (* Copyright (c) 2017 J. M. Spivey *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
3
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
4 open Print
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
5 open Optree
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
6 open Mach
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
7
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
8 (* Identifiers are represented by integers, with a hash table that maps
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
9 strings to the corresponding integer, and a vector that maps the
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
10 other way. *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
11
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
12 type ident = int
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
13
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
14 let nids = ref 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
15 let idhash = Hashtbl.create 100
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
16 let idvec = Growvect.create 100
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
17
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
18 let intern s =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
19 try Hashtbl.find idhash s with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
20 Not_found ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
21 let x = !nids in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
22 incr nids;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
23 Hashtbl.add idhash s x;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
24 Growvect.append idvec s;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
25 x
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
26
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
27 let spelling x = Growvect.get idvec x
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
28
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
29 let fId x = fStr (spelling x)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
30
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
31 (* |location| -- runtime locations *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
32 type location =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
33 Local of int (* Local (offset) *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
34 | Global of symbol (* Global (label) *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
35 | Register of int (* Register *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
36 | Nowhere (* Compile-time only *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
37
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
38 let fLoc =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
39 function
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
40 Local n -> fMeta "local $" [fNum n]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
41 | Global g -> fMeta "global $" [fStr g]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
42 | Register i -> fMeta "register $" [fNum i]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
43 | Nowhere -> fStr "*nowhere*"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
44
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
45 (* |libid| -- type of picoPascal library procedures *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
46 type libid = ChrFun | OrdFun | PrintNum | PrintChar | PrintString
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
47 | NewLine | ReadChar | ExitProc | NewProc | ArgcFun | ArgvProc
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
48 | OpenIn | CloseIn | Operator of Optree.op
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
49
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
50 (* |lib_name| -- name of a library procedure *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
51 let lib_name x =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
52 match x with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
53 PrintNum -> "print_num" | PrintChar -> "print_char"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
54 | PrintString -> "print_string" | NewLine -> "newline"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
55 | ReadChar -> "read_char" | ChrFun -> "chr" | OrdFun -> "ord"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
56 | ExitProc -> "exit" | NewProc -> "new"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
57 | ArgcFun -> "argc" | ArgvProc -> "argv"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
58 | OpenIn -> "open_in" | CloseIn -> "close_in"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
59 | Operator op -> sprintf "$" [Optree.fOp op]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
60
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
61 let fLibId l = fStr (lib_name l)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
62
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
63
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
64 (*
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
65 Environments are represented using CAML Light's library module that
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
66 implements mappings using balanced binary trees.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
67
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
68 The top block is also kept separately as a list, to check for multiple
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
69 declarations, and so that it can be returned by the top_block function.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
70 This is used for formal parameter lists and lists of fields in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
71 record types. The list is kept in reverse order internally, so that
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
72 an element can be added in constant time.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
73 *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
74
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
75 (* |def_kind| -- kinds of definition *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
76 type def_kind =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
77 ConstDef of int (* Constant (value) *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
78 | StringDef (* String *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
79 | TypeDef (* Type *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
80 | VarDef (* Variable *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
81 | CParamDef (* Value parameter *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
82 | VParamDef (* Var parameter *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
83 | FieldDef (* Field of record *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
84 | ProcDef (* Procedure *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
85 | PParamDef (* Proc parameter *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
86 | LibDef of libproc (* Lib proc (data) *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
87 | HoleDef of ptype ref (* Pending type *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
88 | DummyDef (* Dummy *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
89
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
90 (* |def| -- definitions in environment *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
91 and def =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
92 { d_tag: ident; (* Name *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
93 d_kind: def_kind; (* Kind of object *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
94 d_type: ptype; (* Type *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
95 d_level: int; (* Static level *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
96 mutable d_mem: bool; (* Whether addressible *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
97 mutable d_addr: location } (* Run-time location *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
98
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
99 and basic_type = VoidType | IntType | CharType | BoolType | AddrType
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
100
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
101 (* |ptype| -- picoPascal types *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
102 and ptype =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
103 { t_id: int; (* Unique identifier *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
104 t_guts: type_guts; (* Shape of the type *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
105 t_rep: Mach.metrics }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
106
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
107 and type_guts =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
108 BasicType of basic_type
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
109 | ArrayType of int * ptype
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
110 | RecordType of def list
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
111 | ProcType of proc_data
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
112 | PointerType of ptype ref
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
113
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
114 (* |proc_data| -- data about a procedure type *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
115 and proc_data =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
116 { p_fparams: def list;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
117 p_pcount: int;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
118 p_result: ptype }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
119
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
120 (* |libproc| -- data about a library procedure *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
121 and libproc =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
122 { q_id: libid;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
123 q_nargs: int;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
124 q_argtypes: ptype list }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
125
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
126 module IdMap =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
127 Map.Make(struct
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
128 type t = ident
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
129 let compare = compare
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
130 end)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
131
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
132 type environment = Env of (def list * def IdMap.t)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
133
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
134 let add_def d m = IdMap.add d.d_tag d m
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
135
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
136 let add_block b (Env (b0, m)) =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
137 Env (List.rev b, Util.accum add_def b m)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
138
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
139 let top_block (Env (b, m)) = List.rev b
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
140
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
141 let new_block (Env (b0, m)) = Env ([], m)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
142
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
143 let find_def x ds =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
144 let rec search =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
145 function
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
146 [] -> raise Not_found
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
147 | d::ds ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
148 if x = d.d_tag then d else search ds in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
149 search ds
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
150
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
151 let can f x = try f x; true with Not_found -> false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
152
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
153 let define d (Env (b, m)) =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
154 if can (find_def d.d_tag) b then raise Exit;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
155 Env (d::b, add_def d m)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
156
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
157 let replace d (Env (b, m)) =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
158 let rec repl =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
159 function
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
160 [] -> failwith "replace"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
161 | d'::ds ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
162 if d.d_tag = d'.d_tag then d::ds else d' :: repl ds in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
163 Env (repl b, add_def d m)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
164
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
165 let lookup x (Env (b, m)) = IdMap.find x m
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
166
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
167 let empty = Env ([], IdMap.empty)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
168
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
169 let n_types = ref 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
170
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
171 let mk_type t r =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
172 incr n_types;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
173 { t_id = !n_types; t_guts = t; t_rep = r }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
174
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
175 let voidtype = mk_type (BasicType VoidType) void_rep
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
176 let integer = mk_type (BasicType IntType) int_rep
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
177 let character = mk_type (BasicType CharType) char_rep
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
178 let boolean = mk_type (BasicType BoolType) bool_rep
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
179 let addrtype = mk_type (BasicType AddrType) addr_rep
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
180
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
181 let row n t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
182 let r = t.t_rep in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
183 mk_type (ArrayType (n, t)) { r_size = n * r.r_size; r_align = r.r_align }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
184
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
185 let discrete t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
186 match t.t_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
187 BasicType (IntType | CharType | BoolType) -> true
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
188 | _ -> false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
189
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
190 let scalar t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
191 match t.t_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
192 BasicType (IntType | CharType | BoolType) -> true
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
193 | PointerType _ -> true
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
194 | _ -> false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
195
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
196 let is_pointer t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
197 match t.t_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
198 PointerType t1 -> true
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
199 | _ -> false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
200
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
201 let bound t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
202 match t.t_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
203 ArrayType (n, t1) -> n
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
204 | _ -> failwith "bound"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
205
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
206 let base_type t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
207 match t.t_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
208 PointerType t1 -> !t1
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
209 | ArrayType (n, t1) -> t1
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
210 | _ -> failwith "base_type"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
211
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
212 let get_proc t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
213 match t.t_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
214 ProcType p -> p
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
215 | _ -> failwith "get_proc"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
216
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
217 let rec same_type t1 t2 =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
218 match (t1.t_guts, t2.t_guts) with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
219 (ProcType p1, ProcType p2) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
220 match_args p1.p_fparams p2.p_fparams
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
221 && same_type p1.p_result p2.p_result
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
222 | (ArrayType (n1, u1), ArrayType(n2, u2)) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
223 n1 = n2 && same_type u1 u2
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
224 | (PointerType _, BasicType x) -> x = AddrType
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
225 | (BasicType x, PointerType _) -> x = AddrType
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
226 | (_, _) -> t1.t_id = t2.t_id
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
227
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
228 and match_args fp1 fp2 =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
229 match (fp1, fp2) with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
230 ([], []) -> true
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
231 | (f1::fp1', f2::fp2') ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
232 f1.d_kind = f2.d_kind && same_type f1.d_type f2.d_type
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
233 && match_args fp1' fp2'
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
234 | _ -> false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
235
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
236 let is_string t =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
237 match t.t_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
238 ArrayType (n, t1) -> same_type t1 character
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
239 | _ -> false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
240
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
241 let offset_of d =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
242 match d.d_addr with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
243 Local o -> o
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
244 | _ -> failwith "offset_of"