23: # 2015 "./lpsrc/flx_types.ipk"
24: open Flx_util
25: open Flx_ast
26: open Flx_types
27: let src_of_bexe = function
28: | `BEXE_goto (sr,_)
29: | `BEXE_assert (sr,_)
30: | `BEXE_assert2 (sr,_,_,_)
31: | `BEXE_axiom_check (sr,_)
32: | `BEXE_halt (sr,_)
33: | `BEXE_ifgoto (sr,_,_)
34: | `BEXE_ifnotgoto (sr,_,_)
35: | `BEXE_label (sr,_)
36: | `BEXE_comment (sr,_)
37: | `BEXE_call (sr,_,_)
38: | `BEXE_call_direct (sr,_,_,_)
39: | `BEXE_call_method_direct (sr,_,_,_,_)
40: | `BEXE_call_method_stack (sr,_,_,_,_)
41: | `BEXE_jump_direct (sr,_,_,_)
42: | `BEXE_call_stack (sr,_,_,_)
43: | `BEXE_call_prim (sr,_,_,_)
44: | `BEXE_jump (sr,_,_)
45: | `BEXE_loop (sr,_,_)
46: | `BEXE_svc (sr,_)
47: | `BEXE_fun_return (sr,_)
48: | `BEXE_yield (sr,_)
49: | `BEXE_proc_return sr
50: | `BEXE_nop (sr,_)
51: | `BEXE_code (sr,_)
52: | `BEXE_nonreturn_code (sr,_)
53: | `BEXE_assign (sr,_,_)
54: | `BEXE_init (sr,_,_)
55: | `BEXE_apply_ctor (sr,_,_,_,_,_)
56: | `BEXE_apply_ctor_stack (sr,_,_,_,_,_)
57: -> sr
58:
59: | `BEXE_begin
60: | `BEXE_end -> dummy_sr
61:
62: let src_of_qualified_name (e : qualified_name_t) = match e with
63: | `AST_void s
64: | `AST_name (s,_,_)
65: | `AST_case_tag (s,_)
66: | `AST_typed_case (s,_,_)
67: | `AST_lookup (s,_)
68: | `AST_the (s,_)
69: | `AST_index (s,_,_)
70: | `AST_callback (s,_)
71: -> s
72:
73: let src_of_suffixed_name (e : suffixed_name_t) = match e with
74: | #qualified_name_t as x -> src_of_qualified_name x
75: | `AST_suffix (s,_)
76: -> s
77:
78: let src_of_expr (e : expr_t) = match e with
79: | #suffixed_name_t as x -> src_of_suffixed_name x
80: | `AST_interpolate (s,_)
81: | `AST_vsprintf (s,_)
82: | `AST_ellipsis (s)
83: | `AST_noexpand (s,_)
84: | `AST_product (s,_)
85: | `AST_sum (s,_)
86: | `AST_setunion (s,_)
87: | `AST_setintersection (s,_)
88: | `AST_orlist (s,_)
89: | `AST_andlist (s,_)
90: | `AST_arrow (s,_)
91: | `AST_longarrow (s,_)
92: | `AST_superscript (s,_)
93: | `AST_patvar (s,_)
94: | `AST_patany s
95:
96: | `AST_map (s,_,_)
97: | `AST_apply (s,_)
98: | `AST_deref (s,_)
99: | `AST_new (s,_)
100: | `AST_ref (s,_)
101: | `AST_lvalue (s,_)
102: | `AST_lift (s,_)
103: | `AST_literal (s,_)
104: | `AST_method_apply (s,_)
105: | `AST_tuple (s,_)
106: | `AST_record (s,_)
107: | `AST_variant (s,_)
108: | `AST_record_type (s,_)
109: | `AST_variant_type (s,_)
110: | `AST_arrayof (s,_)
111: | `AST_dot (s,_)
112: | `AST_lambda (s,_)
113: | `AST_match_ctor (s,_)
114: | `AST_match_case (s,_)
115: | `AST_ctor_arg (s,_)
116: | `AST_case_arg (s,_)
117: | `AST_case_index (s,_)
118: | `AST_get_n (s,_)
119: | `AST_get_named_variable (s,_)
120: | `AST_get_named_method (s,_)
121: | `AST_coercion (s,_)
122: | `AST_as (s,_)
123: | `AST_match (s, _)
124: | `AST_parse (s, _,_)
125: | `AST_sparse (s,_,_,_)
126: | `AST_type_match (s, _)
127: | `AST_regmatch (s, _)
128: | `AST_string_regmatch (s, _)
129: | `AST_reglex (s, _)
130: | `AST_cond (s,_)
131: | `AST_expr (s,_,_)
132: | `AST_letin (s,_)
133: | `AST_typeof (s,_)
134: | `AST_macro_ctor (s,_)
135: | `AST_macro_statements (s,_)
136: | `AST_case (s,_,_,_)
137: -> s
138:
139: let src_of_stmt e = match e with
140: (*
141: | `AST_public (s,_,_)
142: *)
143: | `AST_private (s,_)
144: | `AST_label (s,_)
145: | `AST_goto (s,_)
146: | `AST_assert (s,_)
147: | `AST_apply_ctor (s,_,_,_)
148: | `AST_init (s,_,_)
149: | `AST_function (s,_, _, _ , _, _, _)
150: | `AST_reduce (s,_, _, _ , _, _)
151: | `AST_axiom (s,_, _, _ , _)
152: | `AST_lemma (s,_, _, _ , _)
153: | `AST_curry (s,_, _, _ , _, _,_)
154: | `AST_object (s,_, _, _ , _)
155: | `AST_macro_name (s, _,_)
156: | `AST_macro_names (s, _,_)
157: | `AST_expr_macro (s,_, _,_)
158: | `AST_stmt_macro (s,_, _,_)
159: | `AST_macro_block (s,_)
160: | `AST_macro_val (s,_,_)
161: | `AST_macro_vals (s,_,_)
162: | `AST_macro_var (s, _,_)
163: | `AST_macro_assign (s,_,_)
164: | `AST_macro_forget (s,_)
165: | `AST_macro_label (s,_)
166: | `AST_macro_goto (s,_)
167: | `AST_macro_ifgoto (s,_,_)
168: | `AST_macro_proc_return s
169: | `AST_macro_ifor (s,_,_,_)
170: | `AST_macro_vfor (s,_,_,_)
171:
172: | `AST_val_decl (s,_,_,_,_)
173: | `AST_lazy_decl (s,_,_,_,_)
174: | `AST_var_decl (s,_,_,_,_)
175: | `AST_ref_decl (s,_,_,_,_)
176:
177:
178: | `AST_type_alias (s,_,_,_)
179: | `AST_inherit (s,_,_,_)
180: | `AST_inherit_fun (s,_,_,_)
181: | `AST_nop (s, _)
182:
183: | `AST_assign (s, _, _,_ )
184: | `AST_cassign (s, _,_ )
185: | `AST_call (s, _, _ )
186: | `AST_jump (s, _, _ )
187: | `AST_loop (s, _, _ )
188: | `AST_svc (s, _)
189: | `AST_fun_return (s, _)
190: | `AST_yield (s, _)
191: | `AST_proc_return s
192: | `AST_halt (s,_)
193: | `AST_ifgoto (s,_,_)
194: | `AST_ifreturn (s,_)
195: | `AST_ifdo (s,_,_,_)
196: (*
197: | `AST_whilst (s,_,_)
198: | `AST_until (s,_,_)
199: *)
200: | `AST_ifnotgoto (s,_,_)
201: | `AST_abs_decl (s,_,_, _,_,_)
202: | `AST_newtype (s,_,_,_)
203: | `AST_ctypes (s,_,_,_)
204: | `AST_const_decl (s,_,_,_,_,_)
205: | `AST_fun_decl (s,_,_,_,_,_,_,_ )
206: | `AST_callback_decl (s,_,_,_,_)
207: | `AST_insert (s,_,_,_,_,_)
208: | `AST_code (s, _)
209: | `AST_noreturn_code (s, _)
210: | `AST_union (s, _,_, _ )
211: | `AST_struct (s,_, _, _)
212: | `AST_cstruct (s,_, _, _)
213: | `AST_cclass (s,_, _, _)
214: | `AST_class (s,_, _, _)
215: | `AST_typeclass (s,_, _, _)
216: | `AST_instance (s,_, _,_)
217: | `AST_untyped_module (s,_,_,_)
218: | `AST_namespace (s,_,_,_)
219: | `AST_export_fun (s, _,_)
220: | `AST_export_type (s, _,_)
221: | `AST_type (s,_,_)
222: | `AST_open (s,_,_)
223: | `AST_inject_module (s,_)
224: | `AST_include (s,_)
225: | `AST_cparse (s,_)
226: | `AST_use (s,_,_)
227: | `AST_regdef (s,_,_)
228: | `AST_glr (s,_,_,_)
229: | `AST_seq (s,_)
230: | `AST_user_statement (s,_,_)
231: -> s
232: | `AST_comment _
233: -> ("Generated",0,0,0,0)
234:
235: let src_of_pat e = match e with
236: | `PAT_coercion (s,_,_)
237: | `PAT_nan s
238: | `PAT_none s
239: | `PAT_int (s,_,_)
240: | `PAT_string (s, _)
241: | `PAT_int_range (s,_,_,_,_)
242: | `PAT_string_range (s, _, _)
243: | `PAT_float_range (s, _,_)
244: | `PAT_name (s, _)
245: | `PAT_tuple (s, _)
246: | `PAT_any s
247: | `PAT_regexp (s, _, _ )
248: | `PAT_const_ctor (s, _)
249: | `PAT_nonconst_ctor (s, _, _)
250: | `PAT_as (s, _, _)
251: | `PAT_when (s, _, _)
252: | `PAT_record (s, _)
253: -> s
254:
255: (* get range from first and last expressions *)
256: let rsexpr a b = rsrange (src_of_expr a) (src_of_expr b)
257:
258: (* get source range of non-empty list of expressions *)
259: let rslist lst =
260: rsexpr (List.hd lst) (list_last lst)
261:
262:
263: let short_string_of_src (f,l1,c1,l2,c2) =
264: if l1 = l2
265: then
266: f ^ ": line " ^ si l1 ^
267: ", cols " ^ si c1 ^ " to " ^ si c2
268: else
269: f ^ ": line " ^ si l1 ^
270: " col " ^ si c1 ^ " to " ^
271: " line " ^ si l2 ^ " col " ^ si c2
272:
273: let get_lines f context l1' l2' c1 c2 = (* first line is line 1 *)
274: let l1 = max 1 (l1'-context) in
275: let l2 = l2' + context in
276: let n = String.length (si l2) in
277: let fmt i =
278: let s =" " ^ si i in
279: let m = String.length s in
280: String.sub s (m-n) n
281: in
282: try
283: let buf = Buffer.create ((l2-l1+4) * 80) in
284: let spc () = Buffer.add_char buf ' ' in
285: let star() = Buffer.add_char buf '*' in
286: let nl() = Buffer.add_char buf '\n' in
287: let f = open_in f in
288: for i = 1 to l1-1 do ignore(input_line f) done;
289: begin
290: try
291: for i = l1 to l2 do
292: Buffer.add_string buf (fmt i ^": ");
293: begin
294: try
295: Buffer.add_string buf (input_line f)
296: with _ ->
297: Buffer.add_string buf "<eof>\n";
298: raise Not_found
299: end
300: ;
301: nl();
302: if i = l1' && l1' = l2' then
303: begin
304: for i = 1 to n + 2 do spc() done;
305: for i = 1 to c1 - 1 do spc() done;
306: for i = c1 to c2 do star() done;
307: nl()
308: end
309: done
310: with Not_found -> ()
311: end
312: ;
313: close_in f;
314: Buffer.contents buf
315: with _ ->
316: "*** Can't read file " ^ f ^
317: " lines " ^ fmt l1 ^ " thru " ^ fmt l2 ^ "\n"
318:
319: let long_string_of_src (f,l1,c1,l2,c2) =
320: short_string_of_src (f,l1,c1,l2,c2) ^
321: "\n" ^
322: get_lines f 1 l1 l2 c1 c2
323: