5.10. Routines to extract source reference from terms

Source reference manipulators.
Start ocaml section to src/flx_srcref.mli[1 /1 ]
     1: # 1962 "./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: # 1984 "./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: # 1991 "./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: # 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: 
End ocaml section to src/flx_srcref.ml[2]