Uh lol

Makefile

@@ -0,0 +1,5 @@
+all:
+	ocamlbuild test.byte
+
+clean:
+	ocamlbuild -clean

asttypes.mli

@@ -0,0 +1,45 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: asttypes.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
+
+(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
+
+type constant =
+    Const_int of int
+  | Const_char of char
+  | Const_string of string
+  | Const_float of string
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
+
+type rec_flag = Nonrecursive | Recursive | Default
+
+type direction_flag = Upto | Downto
+
+type private_flag = Private | Public
+
+type mutable_flag = Immutable | Mutable
+
+type virtual_flag = Virtual | Concrete
+
+type override_flag = Override | Fresh
+
+type closed_flag = Closed | Open
+
+type label = string
+
+type 'a loc = 'a Location.loc = {
+  txt : 'a;
+  loc : Location.t;
+}

history.ml

@@ -0,0 +1,74 @@
+type position = Lexing.position
+type 'a token = 'a * position * position
+
+type stat = { first : position ; last : position }
+
+type 'a t = { prev : 'a token list ; next : 'a token list ; stat : stat }
+
+let empty = { prev = [] ; next = [] ; stat = { first = Lexing.dummy_pos ; last = Lexing.dummy_pos } }
+
+let wrap r f buf =
+  match !r with
+    | { next = (t,s,c) :: ns } as history ->
+        buf.Lexing.lex_start_p <- s;
+        buf.Lexing.lex_curr_p <- c;
+        r := { history with next = ns };
+        t
+    | { prev ; stat } as history ->
+        (if stat.last <> Lexing.dummy_pos then
+            buf.Lexing.lex_curr_p <- stat.last);
+        let t = f buf in
+        let first =
+          if stat.first = Lexing.dummy_pos
+          then buf.Lexing.lex_start_p
+          else stat.first
+        in
+        r := { history with
+          prev = (t, buf.Lexing.lex_start_p, buf.Lexing.lex_curr_p) :: prev;
+          stat = { first ; last = buf.Lexing.lex_curr_p } };
+        t
+
+let compare_pos p1 p2 = compare p1.Lexing.pos_cnum p2.Lexing.pos_cnum
+
+let seek_forward f cnum =
+  let rec aux prev next =
+    match next with
+      | t :: next' when cnum > f t ->
+          aux (t :: prev) next'
+      | _ -> prev, next
+  in
+  aux
+
+let seek_backward f cnum =
+  let rec aux prev next =
+    match prev with
+      | t :: prev' when cnum < f t ->
+          aux prev' (t :: next)
+      | _ -> prev, next
+  in
+  aux
+
+let seek_pos f cnum ({ prev ; next } as history) =
+  let prev', next' =
+    match prev, next with
+      | (t :: prev'), next when cnum < f t ->
+          seek_backward f cnum prev' (t :: next)
+      | prev, (t :: next') when cnum > f t ->
+          seek_forward f cnum (t :: prev) next
+  in
+  { history with prev = prev' ; next = next' }
+
+let seek_start { Lexing.pos_cnum } = seek_pos (fun (_,p,_) -> p) pos_cnum
+let seek_curr  { Lexing.pos_cnum } = seek_pos (fun (_,_,p) -> p) pos_cnum
+
+let first_pos { stat = { first } } = first
+let last_pos { stat = { last } } = last
+let next_pos = function
+  | { next = (_,_,p) } -> p
+  | _ -> Lexing.dummy_pos
+
+let drop_next = function
+  | { prev = (_,_,last) :: _ ; next ; stat = { first } } ->
+      { prev ; next = [] ; stat = { first ; last } }, next
+  | { prev = [] ; next } ->
+      { prev = [] ; next = [] ; stat = empty.stat }, next

history.mli

@@ -0,0 +1,12 @@
+type position = Lexing.position
+type 'a t
+
+val empty : 'a t
+val wrap : 'a t ref -> (Lexing.lexbuf -> 'a) -> (Lexing.lexbuf -> 'a)
+
+val seek_start : position -> 'a t -> 'a t
+val seek_curr  : position -> 'a t -> 'a t
+
+val drop_next : 'a t -> 'a t * 'a list
+
+val fold : 

lexer.mli

@@ -0,0 +1,43 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: lexer.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
+
+(* The lexical analyzer *)
+
+val init : unit -> unit
+val token: Lexing.lexbuf -> Parser.token
+val skip_sharp_bang: Lexing.lexbuf -> unit
+
+type error =
+  | Illegal_character of char
+  | Illegal_escape of string
+  | Unterminated_comment of Location.t
+  | Unterminated_string
+  | Unterminated_string_in_comment of Location.t
+  | Keyword_as_label of string
+  | Literal_overflow of string
+;;
+
+exception Error of error * Location.t
+
+open Format
+
+val report_error: formatter -> error -> unit
+
+val in_comment : unit -> bool;;
+val in_string : unit -> bool;;
+
+
+val print_warnings : bool ref
+val comments : unit -> (string * Location.t) list
+val token_with_comments : Lexing.lexbuf -> Parser.token