home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / location.mlp < prev    next >
Encoding:
Text File  |  1993-09-24  |  4.6 KB  |  162 lines  |  [TEXT/MPS ]
  1. (* Printing a location in the source program *)
  2.  
  3. (**) #open "config";;
  4. (**) #open "lexing";;
  5. (**) #open "parsing";;
  6. (**) #open "misc";;
  7.  
  8. let input_name = ref ""                 (* Input file name. *)
  9. and input_chan = ref std_in             (* The channel opened on the input. *)
  10. and input_lexbuf = ref (obj__magic 0 : lexbuf)
  11.                                         (* The lexer buffer on the input. *)
  12. ;;
  13.  
  14. let no_location =
  15.   Loc(0,0)
  16. ;;
  17.  
  18. let get_current_location () =
  19.   Loc(symbol_start(), symbol_end())
  20. ;;
  21.  
  22. #ifdef macintosh
  23. let prerr_lines char1 char2 charline1 line1 line2 =
  24.   prerr_string "; Line \165!"; prerr_int char1;
  25.   prerr_string ":\165!"; prerr_int char2
  26. ;;
  27. #else
  28. let prerr_lines char1 char2 charline1 line1 line2 =
  29.   prerr_string ", line "; prerr_int line1;
  30.   if line2 != line1 then begin prerr_string "-"; prerr_int line2 end;
  31.   prerr_string ", characters ";
  32.   prerr_int (char1-charline1); prerr_string "-"; prerr_int (char2-charline1);
  33.   prerr_string ":"
  34. ;;
  35. #endif
  36.  
  37. let prerr_loc input seek line_flag (Loc(pos1, pos2)) =
  38.   let prerr_chars n c =
  39.     for i = 1 to n do prerr_char c done
  40.   and skip_line () =
  41.     try
  42.       while input() != `\n` do () done
  43.     with End_of_file -> ()
  44.   and copy_line () =
  45.     let c = ref ` ` in
  46.       begin
  47.         try while c := input(); !c != `\n` do prerr_char !c done
  48.         with End_of_file -> prerr_string "<EOF>"
  49.       end;
  50.       prerr_endline ""
  51.   and tr_line first len ch =
  52.     let c = ref ` `
  53.     and f = ref first
  54.     and l = ref len
  55.     in begin
  56.          try while c := input (); !c != `\n`
  57.          do if !f > 0
  58.             then (f := !f - 1;
  59.               if !c == `\t` then prerr_char !c else prerr_char ` `)
  60.         else if !l > 0
  61.         then (l := !l - 1;
  62.               if !c == `\t` then prerr_char !c else prerr_char ch)
  63.         else ()
  64.          done
  65.      with End_of_file -> prerr_string (make_string 5 ch)
  66.        end
  67.   in
  68.       let pos = ref 0
  69.       and line1 = ref 1
  70.       and line1_pos = ref 0
  71.       and line2 = ref 1
  72.       and line2_pos = ref 0 in
  73.         seek 0;
  74.         begin try
  75.           while !pos < pos1 do
  76.             incr pos;
  77.             if input() == `\n` then
  78.               begin incr line1; line1_pos := !pos; () end
  79.           done
  80.         with End_of_file -> ()
  81.         end;
  82.         line2 := !line1;
  83.         line2_pos := !line1_pos;
  84.         begin try
  85.           while !pos < pos2 do
  86.             incr pos;
  87.             if input() == `\n` then
  88.               begin incr line2; line2_pos := !pos; () end
  89.           done
  90.         with End_of_file -> ()
  91.         end;
  92.         if line_flag then prerr_lines pos1 pos2 !line1_pos !line1 !line2;
  93.         prerr_endline "";
  94.         if !line1 == !line2 then begin
  95.           seek !line1_pos;
  96.           prerr_begline ""; copy_line ();
  97.       seek !line1_pos;
  98.       prerr_begline ""; tr_line (pos1 - !line1_pos) (pos2 - pos1) `^`;
  99.       prerr_endline ""
  100.         end else begin
  101.       seek !line1_pos;
  102.           prerr_begline ""; tr_line 0 (pos1 - !line1_pos) `.`;
  103.           seek pos1;
  104.           copy_line();
  105.           if !line2 - !line1 <= 8 then
  106.             for i = !line1 + 1 to !line2 - 1 do
  107.           prerr_begline ""; copy_line()
  108.             done
  109.           else
  110.             begin
  111.               for i = !line1 + 1 to !line1 + 3 do prerr_begline ""; copy_line() done;
  112.               prerr_begline ".........."; prerr_endline "";
  113.               for i = !line1 + 4 to !line2 - 4 do skip_line() done;
  114.               for i = !line2 - 3 to !line2 - 1 do prerr_begline ""; copy_line() done
  115.             end;
  116.       prerr_begline "";
  117.           begin try
  118.             for i = !line2_pos to pos2 - 1 do
  119.               prerr_char(input())
  120.             done;
  121.             tr_line 0 100 `.`
  122.           with End_of_file -> prerr_string "<EOF>"
  123.           end;
  124.           prerr_endline ""
  125.         end
  126. ;;
  127.  
  128. let prerr_location loc =
  129.   if string_length !input_name > 0 then begin
  130.     let p = pos_in !input_chan in
  131.     prerr_string "File \""; prerr_string !input_name; prerr_string "\"";
  132.     prerr_loc (fun () -> input_char !input_chan) (seek_in !input_chan)
  133.               true loc;
  134.     seek_in !input_chan p
  135.   end else begin
  136.     prerr_begline " Toplevel input:";
  137.     let curr_pos = ref 0 in
  138.     let input () =
  139.       let c =
  140.         if !curr_pos >= 2048 then
  141.           raise End_of_file
  142.         else if !curr_pos >= 0 then
  143.           nth_char !input_lexbuf.lex_buffer !curr_pos
  144.         else
  145.           `.`
  146.       in
  147.         incr curr_pos; c
  148.     and seek pos =
  149.       curr_pos := pos - !input_lexbuf.lex_abs_pos
  150.     in
  151.       prerr_loc input seek false loc
  152.   end
  153. ;;
  154.  
  155. let prerr_input_name () =
  156. #ifdef macintosh
  157.   prerr_string "File \""; prerr_string !input_name; prerr_endline "\""
  158. #else
  159.   prerr_string "File \""; prerr_string !input_name; prerr_endline "\", line 1:"
  160. #endif
  161. ;;
  162.