ocaml 3.13 ready

Ignore-this: 390ddd9264558fd4af5b1d437e817982

darcs-hash:20110803175530-c41ad-a1aeeb47c9c3294e7815a62dcb3d532276a235bf

_oasis

@@ -18,6 +18,12 @@ Description: Universal toplevel for OCaml
 # | The toplevel                                                      |
 # +-------------------------------------------------------------------+
 
+Library "optcomp"
+  Install: false
+  Path: syntax
+  Modules: Pa_optcomp
+  BuildDepends: camlp4.lib, camlp4.quotations.o
+
 Library utop
   Path: src
   Modules: UTop

_tags

@@ -1,6 +1,7 @@
 # -*- conf -*-
 
-<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax
+<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax, pa_optcomp
+<syntax/*.ml>: -pa_optcomp
 <src/*>: use_compiler_libs, pkg_lambda-term, pkg_findlib
 <**/*.top>: use_utop
 <**/uTop_emacs_top.top>: pkg_threads

myocamlbuild.ml

@@ -22,6 +22,12 @@ let () =
              (* Use -linkpkg for creating toplevels *)
              flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
 
+             (* Optcomp *)
+             flag ["ocaml"; "compile"; "pa_optcomp"] & S[A"-ppopt"; A "syntax/pa_optcomp.cmo"];
+             flag ["ocaml"; "ocamldep"; "pa_optcomp"] & S[A"-ppopt"; A "syntax/pa_optcomp.cmo"];
+             flag ["ocaml"; "doc"; "pa_optcomp"] & S[A"-ppopt"; A "syntax/pa_optcomp.cmo"];
+             dep ["ocaml"; "ocamldep"; "pa_optcomp"] ["syntax/pa_optcomp.cmo"];
+
              let env = BaseEnvLight.load () in
              let path = BaseEnvLight.var_get "compiler_libs" env in
              let stdlib = BaseEnvLight.var_get "standard_library" env in

src/uTop_complete.ml

@@ -344,7 +344,11 @@ let add_fields_of_type decl acc =
 let add_names_of_type decl acc =
   match decl.type_kind with
     | Type_variant constructors ->
+#if ocaml_version >= (3, 13)
+        List.fold_left (fun acc (name, _, _) -> add name acc) acc constructors
+#else
         List.fold_left (fun acc (name, _) -> add name acc) acc constructors
+#endif
     | Type_record(fields, _) ->
         List.fold_left (fun acc (name, _, _) -> add name acc) acc fields
     | Type_abstract ->

syntax/pa_optcomp.ml

@@ -0,0 +1,709 @@
+(*
+ * pa_optcomp.ml
+ * -------------
+ * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org>
+ * Licence   : BSD3
+ *
+ * This file is a part of optcomp.
+ *)
+
+open Camlp4.Sig
+open Camlp4.PreCast
+
+external filter : 'a Gram.not_filtered -> 'a = "%identity"
+external not_filtered : 'a -> 'a Gram.not_filtered = "%identity"
+
+(* Subset of supported caml types *)
+type typ =
+  | Tvar of string
+  | Tbool
+  | Tint
+  | Tchar
+  | Tstring
+  | Ttuple of typ list
+
+(* Subset of supported caml values *)
+type value =
+  | Bool of bool
+  | Int of int
+  | Char of char
+  | String of string
+  | Tuple of value list
+
+type ident = string
+    (* An identifier. It is either a lower or a upper identifier. *)
+
+module Env = Map.Make(struct type t = ident let compare = compare end)
+
+type env = value Env.t
+
+type directive =
+  | Dir_let of ident * Ast.expr
+  | Dir_default of ident * Ast.expr
+  | Dir_if of Ast.expr
+  | Dir_else
+  | Dir_elif of Ast.expr
+  | Dir_endif
+  | Dir_include of Ast.expr
+  | Dir_error of Ast.expr
+  | Dir_warning of Ast.expr
+  | Dir_directory of Ast.expr
+
+  (* This one is not part of optcomp but this is one of the directives
+     handled by camlp4 we probably want to use. *)
+  | Dir_default_quotation of Ast.expr
+
+(* Quotations are evaluated by the token filters, but are expansed
+   after. Evaluated quotations are kept in this table, which quotation
+   id to to values: *)
+let quotations : (int, value) Hashtbl.t = Hashtbl.create 42
+
+let next_quotation_id =
+  let r = ref 0 in
+  fun _ -> incr r; !r
+
+(* +-------------+
+   | Environment |
+   +-------------+ *)
+
+let env = ref Env.empty
+let define id value = env := Env.add id value !env
+
+let _ =
+  define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> Tuple [Int major; Int minor]))
+
+let dirs = ref []
+let add_include_dir dir = dirs := dir :: !dirs
+
+(* +--------------+
+   | Dependencies |
+   +--------------+ *)
+
+module String_set = Set.Make(String)
+
+(* All depencies of the file being parsed *)
+let dependencies = ref String_set.empty
+
+(* Where to write dependencies *)
+let dependency_filename = ref None
+
+(* The file being parsed. This is set when the first (token, location)
+   pair is fetched. *)
+let source_filename = ref None
+
+let write_depencies () =
+  match !dependency_filename, !source_filename with
+    | None, _
+    | _, None ->
+        ()
+
+    | Some dependency_filename, Some source_filename ->
+        let oc = open_out dependency_filename in
+        if not (String_set.is_empty !dependencies) then begin
+          output_string oc "# automatically generated by optcomp\n";
+          output_string oc source_filename;
+          output_string oc ": ";
+          output_string oc (String.concat " " (String_set.elements !dependencies));
+          output_char oc '\n'
+        end;
+        close_out oc
+
+(* +----------------------------------------+
+   | Value to expression/pattern conversion |
+   +----------------------------------------+ *)
+
+let rec expr_of_value _loc = function
+  | Bool true -> <:expr< true >>
+  | Bool false -> <:expr< false >>
+  | Int x -> <:expr< $int:string_of_int x$ >>
+  | Char x -> <:expr< $chr:Char.escaped x$ >>
+  | String x -> <:expr< $str:String.escaped x$ >>
+  | Tuple [] -> <:expr< () >>
+  | Tuple [x] -> expr_of_value _loc x
+  | Tuple l -> <:expr< $tup:Ast.exCom_of_list (List.map (expr_of_value _loc) l)$ >>
+
+let rec patt_of_value _loc = function
+  | Bool true -> <:patt< true >>
+  | Bool false -> <:patt< false >>
+  | Int x -> <:patt< $int:string_of_int x$ >>
+  | Char x -> <:patt< $chr:Char.escaped x$ >>
+  | String x -> <:patt< $str:String.escaped x$ >>
+  | Tuple [] -> <:patt< () >>
+  | Tuple [x] -> patt_of_value _loc x
+  | Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >>
+
+(* +-----------------------+
+   | Expression evaluation |
+   +-----------------------+ *)
+
+let rec type_of_value = function
+  | Bool _ -> Tbool
+  | Int _ -> Tint
+  | Char _ -> Tchar
+  | String _ -> Tstring
+  | Tuple l -> Ttuple (List.map type_of_value l)
+
+let rec string_of_type = function
+  | Tvar v -> "'" ^ v
+  | Tbool -> "bool"
+  | Tint -> "int"
+  | Tchar -> "char"
+  | Tstring -> "string"
+  | Ttuple l -> "(" ^ String.concat " * " (List.map string_of_type l) ^ ")"
+
+let invalid_type loc expected real =
+  Loc.raise loc (Failure
+                   (Printf.sprintf "this expression has type %s but is used with type %s"
+                      (string_of_type real) (string_of_type expected)))
+
+let type_of_patt patt =
+  let rec aux (a, n) = function
+    | <:patt< $tup:x$ >> ->
+      let l, x = List.fold_left
+        (fun (l, x) patt -> let t, x = aux x patt in (t :: l, x))
+        ([], (a, n)) (Ast.list_of_patt x []) in
+      (Ttuple(List.rev l), x)
+    | _ ->
+        (Tvar(Printf.sprintf "%c%s"
+                (char_of_int (Char.code 'a' + a))
+                (if n = 0 then "" else string_of_int n)),
+         if a = 25 then (0, n + 1) else (a + 1, n))
+  in
+  fst (aux (0, 0) patt)
+
+let rec eval env = function
+
+  (* Literals *)
+  | <:expr< true >> -> Bool true
+  | <:expr< false >> -> Bool false
+  | <:expr< $int:x$ >> -> Int(int_of_string x)
+  | <:expr< $chr:x$ >> -> Char(Camlp4.Struct.Token.Eval.char x)
+  | <:expr< $str:x$ >> -> String(Camlp4.Struct.Token.Eval.string ~strict:() x)
+
+  (* Tuples *)
+  | <:expr< $tup:x$ >> -> Tuple(List.map (eval env) (Ast.list_of_expr x []))
+
+  (* Variables *)
+  | <:expr@loc< $lid:x$ >>
+  | <:expr@loc< $uid:x$ >> ->
+    begin try
+      Env.find x env
+    with
+        Not_found ->
+          Loc.raise loc (Failure (Printf.sprintf "unbound value %s" x))
+    end
+
+  (* Value comparing *)
+  | <:expr< $x$ = $y$ >> -> let x, y = eval_same env x y in Bool(x = y)
+  | <:expr< $x$ < $y$ >> -> let x, y = eval_same env x y in Bool(x < y)
+  | <:expr< $x$ > $y$ >> -> let x, y = eval_same env x y in Bool(x > y)
+  | <:expr< $x$ <= $y$ >> -> let x, y = eval_same env x y in Bool(x <= y)
+  | <:expr< $x$ >= $y$ >> -> let x, y = eval_same env x y in Bool(x >= y)
+  | <:expr< $x$ <> $y$ >> -> let x, y = eval_same env x y in Bool(x <> y)
+
+  (* min and max *)
+  | <:expr< min $x$ $y$ >> -> let x, y = eval_same env x y in min x y
+  | <:expr< max $x$ $y$ >> -> let x, y = eval_same env x y in max x y
+
+  (* Arithmetic *)
+  | <:expr< $x$ + $y$ >> -> Int(eval_int env x + eval_int env y)
+  | <:expr< $x$ - $y$ >> -> Int(eval_int env x - eval_int env y)
+  | <:expr< $x$ * $y$ >> -> Int(eval_int env x * eval_int env y)
+  | <:expr< $x$ / $y$ >> -> Int(eval_int env x / eval_int env y)
+  | <:expr< $x$ mod $y$ >> -> Int(eval_int env x mod eval_int env y)
+
+  (* Boolean operations *)
+  | <:expr< not $x$ >> -> Bool(not (eval_bool env x))
+  | <:expr< $x$ or $y$ >> -> Bool(eval_bool env x or eval_bool env y)
+  | <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y)
+  | <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y)
+
+  (* String operations *)
+  | <:expr< $x$ ^ $y$ >> -> String(eval_string env x ^ eval_string env y)
+
+  (* Pair operations *)
+  | <:expr< fst $x$ >> -> fst (eval_pair env x)
+  | <:expr< snd $x$ >> -> snd (eval_pair env x)
+
+  (* Let-binding *)
+  | <:expr< let $p$ = $x$ in $y$ >> ->
+    let vx = eval env x in
+    let env =
+      try
+        bind env p vx
+      with
+          Exit -> invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx)
+    in
+    eval env y
+
+  | e -> Loc.raise (Ast.loc_of_expr e) (Stream.Error "expression not supported")
+
+and bind env patt value = match patt with
+  | <:patt< $lid:id$ >> ->
+    Env.add id value env
+
+  | <:patt< $tup:patts$ >> ->
+    let patts = Ast.list_of_patt patts [] in
+    begin match value with
+      | Tuple values when List.length values = List.length patts ->
+          List.fold_left2 bind env patts values
+      | _ ->
+          raise Exit
+    end
+
+  | _ ->
+      Loc.raise (Ast.loc_of_patt patt) (Stream.Error "pattern not supported")
+
+and eval_same env ex ey =
+  let vx = eval env ex and vy = eval env ey in
+  let tx = type_of_value vx and ty = type_of_value vy in
+  if tx = ty then
+    (vx, vy)
+  else
+    invalid_type (Ast.loc_of_expr ey) tx ty
+
+and eval_int env e = match eval env e with
+  | Int x -> x
+  | v -> invalid_type (Ast.loc_of_expr e) Tint (type_of_value v)
+
+and eval_bool env e = match eval env e with
+  | Bool x -> x
+  | v -> invalid_type (Ast.loc_of_expr e) Tbool (type_of_value v)
+
+and eval_string env e = match eval env e with
+  | String x -> x
+  | v -> invalid_type (Ast.loc_of_expr e) Tstring (type_of_value v)
+
+and eval_pair env e = match eval env e with
+  | Tuple [x; y] -> (x, y)
+  | v -> invalid_type (Ast.loc_of_expr e) (Ttuple [Tvar "a"; Tvar "b"]) (type_of_value v)
+
+(* +-----------------------+
+   | Parsing of directives |
+   +-----------------------+ *)
+
+let rec skip_space stream = match Stream.peek stream with
+  | Some((BLANKS _ | COMMENT _), _) ->
+      Stream.junk stream;
+      skip_space stream
+  | _ ->
+      ()
+
+let parse_equal stream =
+  skip_space stream;
+  match Stream.next stream with
+    | KEYWORD "=", _ -> ()
+    | _, loc -> Loc.raise loc (Stream.Error "'=' expected")
+
+let rec parse_eol stream =
+  let tok, loc = Stream.next stream in
+  match tok with
+    | BLANKS _ | COMMENT _ ->
+        parse_eol stream
+    | NEWLINE | EOI ->
+        ()
+    | _ ->
+        Loc.raise loc (Stream.Error "end of line expected")
+
+(* Return wether a keyword can be interpreted as an identifier *)
+let keyword_is_id str =
+  let rec aux i =
+    if i = String.length str then
+      true
+    else
+      match str.[i] with
+        | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' ->
+            aux (i + 1)
+        | _ ->
+            false
+  in
+  aux 0
+
+let parse_ident stream =
+  skip_space stream;
+  let tok, loc = Stream.next stream in
+  begin match tok with
+    | LIDENT id | UIDENT id ->
+        id
+    | KEYWORD kwd when keyword_is_id kwd ->
+        kwd
+    | _ ->
+        Loc.raise loc (Stream.Error "identifier expected")
+  end
+
+let parse_expr stream =
+  (* Lists of opened brackets *)
+  let opened_brackets = ref [] in
+
+  (* Return the next token of [stream] until all opened parentheses
+     have been closed and a newline is reached *)
+  let rec next_token _ =
+    Some(match Stream.next stream, !opened_brackets with
+           | (NEWLINE, loc), [] ->
+               EOI, loc
+
+           | (KEYWORD("(" | "[" | "{" as b), _) as x, l ->
+               opened_brackets := b :: l;
+               x
+
+           | (KEYWORD ")", loc) as x, "(" :: l ->
+               opened_brackets := l;
+               x
+
+           | (KEYWORD "]", loc) as x, "[" :: l ->
+               opened_brackets := l;
+               x
+
+           | (KEYWORD "}", loc) as x, "{" :: l ->
+               opened_brackets := l;
+               x
+
+           | x, _ ->
+               x)
+  in
+
+  Gram.parse_tokens_before_filter Syntax.expr_eoi
+    (not_filtered (Stream.from next_token))
+
+let parse_directive stream = match Stream.peek stream with
+  | Some(KEYWORD "#", loc) ->
+      Stream.junk stream;
+
+      (* Move the location to the beginning of the line *)
+      let (file_name,
+           start_line, start_bol, start_off,
+           stop_line,  stop_bol,  stop_off,
+           ghost) = Loc.to_tuple loc in
+      let loc = Loc.of_tuple (file_name,
+                              start_line, start_bol, start_bol,
+                              start_line, start_bol, start_bol,
+                              ghost) in
+
+      begin match parse_ident stream with
+
+        | "let" ->
+            let id = parse_ident stream in
+            parse_equal stream;
+            let expr = parse_expr stream in
+            Some(Dir_let(id, expr), loc)
+
+        | "let_default" ->
+            let id = parse_ident stream in
+            parse_equal stream;
+            let expr = parse_expr stream in
+            Some(Dir_default(id, expr), loc)
+
+        (* For compatibility *)
+        | "define" ->
+            let id = parse_ident stream in
+            let expr = parse_expr stream in
+            Some(Dir_let(id, expr), loc)
+
+        (* For compatibility *)
+        | "default" ->
+            let id = parse_ident stream in
+            let expr = parse_expr stream in
+            Some(Dir_default(id, expr), loc)
+
+        | "if" ->
+            Some(Dir_if(parse_expr stream), loc)
+
+        | "else" ->
+            parse_eol stream;
+            Some(Dir_else, loc)
+
+        | "elif" ->
+            Some(Dir_elif(parse_expr stream), loc)
+
+        | "endif" ->
+            parse_eol stream;
+            Some(Dir_endif, loc)
+
+        | "include" ->
+            Some(Dir_include(parse_expr stream), loc)
+
+        | "directory" ->
+            Some(Dir_directory(parse_expr stream), loc)
+
+        | "error" ->
+            Some(Dir_error(parse_expr stream), loc)
+
+        | "warning" ->
+            Some(Dir_warning(parse_expr stream), loc)
+
+        | "default_quotation" ->
+            Some(Dir_default_quotation(parse_expr stream), loc)
+
+        | dir ->
+            Loc.raise loc (Stream.Error (Printf.sprintf "bad directive ``%s''" dir))
+      end
+
+  | _ ->
+      None
+
+let parse_command_line_define str =
+  match Gram.parse_string Syntax.expr (Loc.mk "<command line>") str with
+    | <:expr< $lid:id$ = $e$ >>
+    | <:expr< $uid:id$ = $e$ >> -> define id (eval !env e)
+    | _ -> invalid_arg str
+
+(* +----------------+
+   | BLock skipping |
+   +----------------+ *)
+
+let rec skip_line stream =
+  match Stream.next stream with
+    | NEWLINE, _ -> ()
+    | EOI, loc -> Loc.raise loc (Stream.Error "#endif missing")
+    | _ -> skip_line stream
+
+let rec next_directive stream = match parse_directive stream with
+  | Some dir -> dir
+  | None -> skip_line stream; next_directive stream
+
+let rec next_endif stream =
+  let dir, loc = next_directive stream in
+  match dir with
+    | Dir_if _ -> skip_if stream; next_endif stream
+    | Dir_else
+    | Dir_elif _
+    | Dir_endif -> dir
+    | _ -> next_endif stream
+
+and skip_if stream =
+  let dir, loc = next_directive stream in
+  match dir with
+    | Dir_if _ ->
+        skip_if stream;
+        skip_if stream
+
+    | Dir_else ->
+        skip_else stream
+
+    | Dir_elif _ ->
+        skip_if stream
+
+    | Dir_endif ->
+        ()
+
+    | _ -> skip_if stream
+
+and skip_else stream =
+  let dir, loc = next_directive stream in
+  match dir with
+    | Dir_if _ ->
+        skip_if stream;
+        skip_else stream
+
+    | Dir_else ->
+        Loc.raise loc (Stream.Error "#else without #if")
+
+    | Dir_elif _ ->
+        Loc.raise loc (Stream.Error "#elif without #if")
+
+    | Dir_endif ->
+        ()
+
+    | _ ->
+        skip_else stream
+
+(* +-----------------+
+   | Token filtering |
+   +-----------------+ *)
+
+type context = Ctx_if | Ctx_else
+
+(* State of the token filter *)
+type state = {
+  stream : (Gram.Token.t * Loc.t) Stream.t;
+  (* Input stream *)
+
+  mutable bol : bool;
+  (* Wether we are at the beginning of a line *)
+
+  mutable stack : context list;
+  (* Nested contexts *)
+
+  on_eoi : Gram.Token.t * Loc.t -> Gram.Token.t * Loc.t;
+  (* Eoi handler, it is used to restore the previous sate on #include
+     directives *)
+}
+
+(* Read and return one token *)
+let really_read state =
+  let tok, loc = Stream.next state.stream in
+  state.bol <- tok = NEWLINE;
+  match tok with
+    | QUOTATION ({ q_name = "optcomp" } as quot) ->
+        let id = next_quotation_id () in
+        Hashtbl.add quotations id (eval !env (Gram.parse_string
+                                                Syntax.expr_eoi
+                                                (Loc.move `start quot.q_shift loc)
+                                                quot.q_contents));
+
+        (* Replace the quotation by its id *)
+        (QUOTATION { quot with q_contents = string_of_int id }, loc)
+
+    | EOI ->
+        (* If end of input is reached, we call the eoi handler. It may
+           continue if we were parsing an included file *)
+        if state.stack <> [] then
+          Loc.raise loc (Stream.Error "#endif missing");
+        state.on_eoi (tok, loc)
+
+    | _ ->
+        (tok, loc)
+
+(* Return the next token from a stream, interpreting directives. *)
+let rec next_token state_ref =
+  let state = !state_ref in
+  if state.bol then
+    match parse_directive state.stream, state.stack with
+      | Some(Dir_if e, _), _ ->
+          let rec aux e =
+            if eval_bool !env e then begin
+              state.stack <- Ctx_if :: state.stack;
+              next_token state_ref
+            end else
+              match next_endif state.stream with
+                | Dir_else ->
+                    state.stack <- Ctx_else :: state.stack;
+                    next_token state_ref
+
+                | Dir_elif e ->
+                    aux e
+
+                | Dir_endif ->
+                    next_token state_ref
+
+                | _ ->
+                    assert false
+          in
+          aux e
+
+      | Some(Dir_else, loc), ([] | Ctx_else :: _) ->
+          Loc.raise loc (Stream.Error "#else without #if")
+
+      | Some(Dir_elif _, loc), ([] | Ctx_else :: _) ->
+          Loc.raise loc (Stream.Error "#elif without #if")
+
+      | Some(Dir_endif, loc), [] ->
+          Loc.raise loc (Stream.Error "#endif without #if")
+
+      | Some(Dir_else, loc), Ctx_if :: l ->
+          skip_else state.stream;
+          state.stack <- l;
+          next_token state_ref
+
+      | Some(Dir_elif _, loc), Ctx_if :: l ->
+          skip_if state.stream;
+          state.stack <- l;
+          next_token state_ref
+
+      | Some(Dir_endif, loc), _ :: l ->
+          state.stack <- l;
+          next_token state_ref
+
+      | Some(Dir_let(id, e), _), _ ->
+          define id (eval !env e);
+          next_token state_ref
+
+      | Some(Dir_default(id, e), _), _ ->
+          if not (Env.mem id !env) then
+            define id (eval !env e);
+          next_token state_ref
+
+      | Some(Dir_include e, _), _ ->
+          let fname = eval_string !env e in
+          (* Try to looks up in all include directories *)
+          let fname =
+            try
+              List.find (fun dir -> Sys.file_exists (Filename.concat dir fname)) !dirs
+            with
+                (* Just try in the current directory *)
+                Not_found -> fname
+          in
+          dependencies := String_set.add fname !dependencies;
+          let ic = open_in fname in
+          let nested_state = {
+            stream = Gram.Token.Filter.filter (Gram.get_filter ()) (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic)));
+            bol = true;
+            stack = [];
+            on_eoi = (fun _ ->
+                        (* Restore previous state and close channel on
+                           eoi *)
+                        state_ref := state;
+                        close_in ic;
+                        next_token state_ref)
+          } in
+          (* Replace current state with the new one *)
+          state_ref := nested_state;
+          next_token state_ref
+
+      | Some(Dir_directory e, loc), _ ->
+          let dir = eval_string !env e in
+          add_include_dir dir;
+          next_token state_ref
+
+      | Some(Dir_error e, loc), _ ->
+          Loc.raise loc (Failure (eval_string !env e))
+
+      | Some(Dir_warning e, loc), _ ->
+          Syntax.print_warning loc (eval_string !env e);
+          next_token state_ref
+
+      | Some(Dir_default_quotation e, loc), _ ->
+          Syntax.Quotation.default := eval_string !env e;
+          next_token state_ref
+
+      | None, _ ->
+          really_read state
+
+  else
+    really_read state
+
+let stream_filter filter stream =
+  (* Set the source filename *)
+  begin match !source_filename with
+    | Some _ ->
+        ()
+    | None ->
+        match Stream.peek stream with
+          | None ->
+              ()
+          | Some(tok, loc) ->
+              source_filename := Some(Loc.file_name loc)
+  end;
+  let state_ref = ref { stream = stream;
+                        bol = true;
+                        stack = [];
+                        on_eoi = (fun x -> x) } in
+  filter (Stream.from (fun _ -> Some(next_token state_ref)))
+
+(* +----------------------+
+   | Quotations expansion |
+   +----------------------+ *)
+
+let expand f loc _ contents =
+  try
+    f loc (Hashtbl.find quotations (int_of_string contents))
+  with
+      exn -> Loc.raise loc (Failure "fatal error in optcomp!")
+
+(* +--------------+
+   | Registration |
+   +--------------+ *)
+
+let _ =
+  Camlp4.Options.add "-let" (Arg.String parse_command_line_define)
+    "<string> Binding for a #let directive.";
+  Camlp4.Options.add "-depend"
+    (Arg.String (fun filename -> dependency_filename := Some filename))
+    "<file> Write dependencies to <file>.";
+
+  Pervasives.at_exit write_depencies;
+
+  Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.expr_tag (expand expr_of_value);
+  Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.patt_tag (expand patt_of_value);
+
+  Gram.Token.Filter.define_filter (Gram.get_filter ()) stream_filter