Source file compact_position.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
module Position = struct
  (* We encode the position in three, 21 bit fields: [cnum][lnum][bol] *)
  type t = int

  let field_size = 21
  let field_mask = (1 lsl field_size) - 1
  let shift_bol = 0
  let shift_lnum = field_size
  let shift_cnum = 2 * field_size

  let small_enough =
    let max_size = 1 lsl field_size in
    let test int = int <= max_size in
    fun [@inline] { Lexing.pos_bol; pos_cnum; pos_lnum; pos_fname = _ } ->
      test pos_bol && test pos_cnum && test pos_lnum
  ;;

  let[@inline] of_position { Lexing.pos_bol; pos_cnum; pos_lnum; pos_fname = _ } =
    ((pos_bol land field_mask) lsl shift_bol)
    lor ((pos_lnum land field_mask) lsl shift_lnum)
    lor ((pos_cnum land field_mask) lsl shift_cnum)
  ;;

  let[@inline] bol t = (t lsr shift_bol) land field_mask
  let[@inline] lnum t = (t lsr shift_lnum) land field_mask
  let[@inline] cnum t = (t lsr shift_cnum) land field_mask

  let to_position t ~fname:pos_fname =
    let pos_bol = bol t in
    let pos_cnum = cnum t in
    let pos_lnum = lnum t in
    { Lexing.pos_bol; pos_cnum; pos_lnum; pos_fname }
  ;;
end

module Same_line_loc = struct
  (* we encode the location in four, 15 bit chunks
     [bol][lnum][start_cnum][stop_cnum]

     Note that this leaves us with 3 spare bits. We should probably use them to
     expand [bol] and [lnum] a little.

     CR-someday jtov: Instead of [stop_cnum], we can store [stop_cnum -
     start_cnum]. This should be smaller than [stop_cnum] and release more
     bits for other fields.
  *)
  type t = int

  let field_size = 15
  let field_mask = (1 lsl field_size) - 1
  let shift_bol = 0
  let shift_lnum = field_size
  let shift_start_cnum = 2 * field_size
  let shift_stop_cnum = 3 * field_size

  let create ~bol ~lnum ~start_cnum ~stop_cnum =
    ((bol land field_mask) lsl shift_bol)
    lor ((lnum land field_mask) lsl shift_lnum)
    lor ((start_cnum land field_mask) lsl shift_start_cnum)
    lor ((stop_cnum land field_mask) lsl shift_stop_cnum)
  ;;

  let[@inline] bol t = (t lsr shift_bol) land field_mask
  let[@inline] lnum t = (t lsr shift_lnum) land field_mask
  let[@inline] start_cnum t = (t lsr shift_start_cnum) land field_mask
  let[@inline] stop_cnum t = (t lsr shift_stop_cnum) land field_mask

  let set_start_to_stop t =
    let bol = bol t in
    let lnum = lnum t in
    let stop_cnum = stop_cnum t in
    (* this can be optimized more if necessary *)
    create ~bol ~lnum ~start_cnum:stop_cnum ~stop_cnum
  ;;

  let small_enough =
    let max_size = 1 lsl field_size in
    fun [@inline] int -> int <= max_size
  ;;

  let[@inline] to_loc t ~fname:pos_fname =
    let pos_lnum = lnum t in
    let pos_bol = bol t in
    let start = { Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum = start_cnum t } in
    let stop = { start with pos_cnum = stop_cnum t } in
    { Lexbuf.Loc.start; stop }
  ;;

  let[@inline] start t ~fname:pos_fname =
    let pos_lnum = lnum t in
    let pos_bol = bol t in
    { Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum = start_cnum t }
  ;;

  let[@inline] stop t ~fname:pos_fname =
    let pos_lnum = lnum t in
    let pos_bol = bol t in
    { Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum = stop_cnum t }
  ;;
end

include Position

type of_loc =
  | Same_line of Same_line_loc.t
  | Loc of
      { start : t
      ; stop : t
      }
  | Loc_does_not_fit

let[@inline] try_loc { Lexbuf.Loc.start; stop } =
  if Position.small_enough start && Position.small_enough stop
  then (
    let start = Position.of_position start in
    let stop = Position.of_position stop in
    Loc { start; stop })
  else Loc_does_not_fit
;;

let[@inline] of_loc ({ Lexbuf.Loc.start; stop } as loc) =
  if start.pos_fname <> stop.pos_fname
  then Loc_does_not_fit
  else if start.pos_bol = stop.pos_bol && start.pos_lnum = stop.pos_lnum
  then (
    let bol = start.pos_bol in
    let lnum = start.pos_lnum in
    let start_cnum = start.pos_cnum in
    let stop_cnum = stop.pos_cnum in
    let test = Same_line_loc.small_enough in
    if test bol && test lnum && test start_cnum && test stop_cnum
    then Same_line (Same_line_loc.create ~bol ~lnum ~start_cnum ~stop_cnum)
    else try_loc loc)
  else try_loc loc
;;

let of_loc = if Sys.int_size = 63 then of_loc else fun _ -> Loc_does_not_fit

module For_tests = struct
  let small_enough = small_enough
end