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