5.10. Routines to extract source reference from terms

Source reference manipulators.
Start ocaml section to src/flx_srcref.mli[1 /1 ]
     1: # 1733 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: 
     5: val rstoken: srcref -> srcref -> range_srcref
     6: val rsrange: range_srcref -> range_srcref -> range_srcref
     7: val slift: srcref -> range_srcref
     8: 
     9: val rsexpr: expr_t -> expr_t -> range_srcref
    10: val rslist: expr_t list -> range_srcref
    11: 
    12: val src_of_bexe: bexe_t -> range_srcref
    13: val src_of_expr: expr_t -> range_srcref
    14: val src_of_stmt : statement_t -> range_srcref
    15: val src_of_pat : pattern_t -> range_srcref
    16: val src_of_qualified_name : qualified_name_t -> range_srcref
    17: val src_of_suffixed_name: suffixed_name_t -> range_srcref
    18: 
    19: val short_string_of_src: range_srcref -> string
    20: val long_string_of_src: range_srcref -> string
    21: 
    22: val dummy_sr: range_srcref
    23: # 1755 "./lpsrc/flx_types.ipk"
    24: 
End ocaml section to src/flx_srcref.mli[1]
Generic source reference manipulation. Note the special hack of forgetting the second filename when creating a range: the alternative would be to record a complete list of lines.
Start ocaml section to src/flx_srcref.ml[1 /2 ] Next Last
     1: # 1762 "./lpsrc/flx_types.ipk"
     2: 
     3: let dummy_sr = ("generated",0,0,0,0)
     4: 
     5: (** axiom: rstoken a b = rsrange (lift a) (lift b) *)
     6: 
     7: (** get source range from source references of first
     8:    and last tokens
     9: *)
    10: let rstoken (f1,l1,s1,e1) (f2,l2,s2,e2) = (f1,l1,s1,l2,e2)
    11: 
    12: (** get range from first and last ranges *)
    13: let rsrange (f1,sl1,sc1,el1,ec1) (f2,sl2,sc2,el2,ec2) =
    14:   (f1,sl1,sc1,el2,ec2)
    15: 
    16: (** lift token source to range for token without attribute*)
    17: let slift (f,l,s,e) = (f,l,s,l,e)
    18: 
    19: (** lift token source to range for tokens with attribute*)
    20: let sliftfst x = slift (fst x)
    21: 
    22: 
End ocaml section to src/flx_srcref.ml[1]
Type specific operations.
Start ocaml section to src/flx_srcref.ml[2 /2 ] Prev First
    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: 
End ocaml section to src/flx_srcref.ml[2]