1.1emThis is ocamlweb, a literate programming tool for Objective Caml. This document has been automatically produced using ocamlweb itself, applied to his own code, in some kind of ‘bootstrap’.

This code is split is several Caml modules, organized as follows:

Interface for module Output

2.1emIn that module, we concentrate all the printing functions. Thus, it will be easy to add another kind of output, HTML for instance, by adapting the code of that module, and nothing else. Default output is to standard output, but it can be redirected to a file with set_output_to_file. close_output closes the output, if it is a file.
val set_output_to_file : string → unit
val close_output : unit → unit
3.1emThese mutable flags controls the output. If quiet, no extra output is done on standard output, default is false. If use_greek_letters is true, greek letters are used to display (some of) the single-letter type variables, default is true.
val quiet : bool ref
val use_greek_letters : bool ref
val short : bool ref
4.1emThen we introduce some low level output functions, for characters and strings. (output_file f) copies the contents of file f on the output. (output_verbatim s) outputs the string s ‘as is’.
val output_char : char → unit
val output_string : string → unit
val output_file : string → unit
val output_verbatim : string → unit
5.1emThe following functions are mainly useful for a L^AT_EX output, but will work correctly in other cases. A call to set_no_preamble suppresses the output of the header and trailer. (end_line ()) ends a line, (indentation n) introduces an indentation of size n at the beggining of a line. latex_header takes as argument the options of the L^AT_EX package ocamlweb.sty.
val class_options : string ref
val set_no_preamble : bool → unit
val push_in_preamble : string → unit
val fullpage_headings : bool ref
val latex_header : string → unit
val latex_trailer : unit → unit

val indentation : int → unit
val end_line : unit → unit
val end_line_string : unit → unit

val enter_math : unit → unit
val leave_math : unit → unit
6.1emThe following functions are used to pretty-print the code. is_keyword identifies the keywords of Objective Caml. output_ident outputs an identifier, in different faces for keywords and other identifiers, escaping the characters that need it, like _ for instance in L^AT_EX. output_escaped_char pretty-prints the reserved char of L^AT_EX, like & or $. output_symbol pretty-prints the Caml symbols, like → for ->. output_type_variable s pretty-prints type variables, in particular one-letter type variables are output as greek letters. output_ascii_char n outputs the character of ASCII code n.

type char_type = Upper ∣ Lower ∣ Symbol
val what_is_first_char : string → char_type

val is_keyword : string → bool
val output_ident : string → unit
val output_escaped_char : char → unit
val output_symbol : string → unit
val output_type_variable : string → unit
val output_ascii_char : int → unit

output_lex_ident (resp. output_yacc_ident) outputs an identifier as above but taking into account CAMLLEX keywords (resp. CAMLYACC keywords)
val output_lex_ident : string → unit
val output_yacc_ident : string → unit
7.1emConstants are typeset by the following functions.
val output_integer : string → unit
val output_float : string → unit
8.1emComments inside code are opened and closed respectively by output_bc and output_ec. The function output_hfill is called before output_bc to justify a comment. output_byc and output_eyc are the same for CAMLYACC comments, that is /*…*/.
val output_bc : unit → unit
val output_ec : unit → unit
val output_byc : unit → unit
val output_eyc : unit → unit
val output_hfill : unit → unit
9.1emStrings inside code are opened and close respectively by  output_bs and output_es. A space character in a string is output as a visible space, with output_vspace.
val output_bs : unit → unit
val output_es : unit → unit
val output_vspace : unit → unit
10.1emThe following functions deal with sectioning. The highest level is the one of modules and interfaces. The next level is the one of section. The last level is the one of paragraphs, which are atomic pieces of documentation or code.
val output_module : string → unit
val output_interface : string → unit
val output_lexmodule : string → unit
val output_yaccmodule : string → unit

val begin_section : unit → unit

val begin_code : unit → unit
val end_code : unit → unit
val begin_dcode : unit → unit
val end_dcode : unit → unit

val begin_code_paragraph : unit → unit
val end_code_paragraph : bool → unit
val begin_doc_paragraph : bool → int → unit
val end_doc_paragraph : unit → unit
11.1emIndex functions. (output_index_entry id t def use) outputs an entry line for identifier id, with type t, where def is the list of sections where f is introduced and use the list of sections where f is used. If the type of the entry is "", then it is omitted.
type α elem = Single of α ∣ Interval of α × α

val begin_index : unit → unit
val output_index_entry : 
   string → string → string elem list → string elem list → unit
val output_raw_index_entry : 
   string → string → string list → string list → unit
val end_index : unit → unit

val output_label : string → unit
12.1emThe parameters of the output engine are reset to their initial values with reset_output.
val reset_output : unit → unit

Module Output

13.1emLow level output. out_channel is a reference on the current output channel. It is initialized to the standard output and can be redirect to a file by the function set_output_to_file. The function close_output closes the output channel if it is a file. output_char, output_string and output_file are self-explainable.

let out_channel = ref stdout
let output_is_file = ref false

let set_output_to_file f = 
   out_channel := open_out f;
   output_is_file := true

let close_output () =
   if !output_is_file then close_out !out_channel

let quiet = ref false

let short = ref false

let output_char c = Pervasives.output_char !out_channel c

let output_string s = Pervasives.output_string !out_channel s

let output_file f =
   let ch = open_in f in
   try
     while true do
       Pervasives.output_char !out_channel (input_char ch)
     done
   with End_of_file → close_in ch
14.1emHigh level output. In this section and the following, we introduce functions which are L^AT_EX dependent.
15.1emoutput_verbatim outputs a string in verbatim mode. A valid delimiter is given by the function char_out_of_string. It assumes that one of the four characters of fresh_chars is not used (which is the case in practice, since output_verbatim is only used to print quote-delimited characters).
let fresh_chars = [ '!'; '|'; '"'; '+' ]

let char_out_of_string s = 
   let rec search = function
     ∣ [ ] → assert false
     ∣ c :: r → if String.contains s c then search r else c
   in
   search fresh_chars

let output_verbatim s =
   let c = char_out_of_string s in
   output_string (sprintf "\\verb%c%s%c" c s c)

let no_preamble = ref false

let set_no_preamble b = no_preamble := b

let (preamble : string Queue.t) = Queue.create ()

let push_in_preamble s = Queue.add s preamble

let class_options = ref "12pt"

let fullpage_headings = ref true

let latex_header opt =
   if ¬ !no_preamble then begin
     output_string (sprintf "\\documentclass[%s]{article}\n" !class_options);
     output_string "\\usepackage[latin1]{inputenc}\n";
         if !fullpage_headings then
       output_string "\\usepackage[headings]{fullpage}\n"
     else
       output_string "\\usepackage{fullpage}\n";
     output_string "\\usepackage";
     if opt ≠ "" then output_string (sprintf "[%s]" opt);
     output_string "{ocamlweb}\n";
     output_string "\\pagestyle{headings}\n";
     Queue.iter (fun s → output_string s; output_string "\n") preamble;
     output_string "\\begin{document}\n"
   end;
   output_string 
     "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n";
   output_string 
     "%% This file has been automatically generated with the command\n";
   output_string "%% ";
   Array.iter (fun s → output_string s; output_string " ") Sys.argv;
   output_string "\n";
   output_string 
     "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n"

let latex_trailer () =
   if ¬ !no_preamble then begin
     output_string "\\end{document}\n"
   end
16.1emMath mode. We keep a boolean, math_mode, to know if we are currently already in T_EX math mode. The functions enter_math and leave_math inserts $ if necessary, and switch that boolean.

let math_mode = ref false

let enter_math () =
   if ¬ !math_mode then begin
     output_string "$";
     math_mode := true
   end

let leave_math () =
   if !math_mode then begin
     output_string "$";
     math_mode := false
   end
17.1emIndentation. An indentation at the beginning of a line of n spaces is produced by (indentation n) (used for code only).
let indentation n =
   let space = 0.5 *. (float n) in
   output_string (sprintf "\\ocwindent{%2.2fem}\n" space)
18.1emEnd of lines. (end_line ()) ends a line. (used for code only).
let end_line () =
   leave_math ();
   output_string "\\ocweol\n"

let end_line_string () =
   output_string "\\endgraf\n"
19.1emKeywords. Caml keywords and base type are stored in two hash tables, and the two functions is_caml_keyword and is_base_type make the corresponding tests. The function output_keyword prints a keyword, with different macros for base types and keywords.

let build_table l = 
   let h = Hashtbl.create 101 in
   List.iter (fun key → Hashtbl.add h key ()) l;
   Hashtbl.mem h

let is_caml_keyword = 
   build_table
     [ "and"; "as"; "assert"; "begin"; "class";
       "constraint"; "do"; "done"; "downto"; "else"; "end"; "exception";
       "external"; "false"; "for"; "fun"; "function"; "functor"; "if";
       "in"; "include"; "inherit"; "initializer"; "lazy"; "let"; "match";
       "method"; "module"; "mutable"; "new"; "object"; "of"; "open";
       "or"; "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to";
       "true"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with";
       "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"
     ]

let is_base_type = 
   build_table
     [ "string"; "int"; "array"; "unit"; "bool"; "char"; "list"; "option";
       "float"; "ref" ]

let is_lex_keyword = 
   build_table
     [ "rule"; "let"; "and"; "parse"; "eof" ]

let is_yacc_keyword =
   build_table
     [ "%token"; "%left"; "%right"; "%type"; "%start"; "%nonassoc"; "%prec"; 
       "error" ]

let is_keyword s = is_base_type s ∨ is_caml_keyword s

let output_keyword s =
   if is_base_type s then 
     output_string "\\ocwbt{" 
   else 
     output_string "\\ocwkw{";
   output_string s;
   output_string "}"

let output_lex_keyword s =
   output_string "\\ocwlexkw{";
   output_string s;
   output_string "}"

let output_yacc_keyword s =
   output_string "\\ocwyacckw{";
   if String.get s 0 = '%' then output_string "\\";
   output_string s;
   output_string "}"
20.1emIdentifiers. The function output_raw_ident prints an identifier, escaping the T_EX reserved characters with output_escaped_char. The function output_ident prints an identifier, calling output_keyword if necessary.

let output_escaped_char c = 
   if c = '^' ∨ c = '~' then leave_math();
   match c with
     ∣ '\\' → 
         output_string "\\symbol{92}"
     ∣ '$' ∣ '#' ∣ '%' ∣ '&' ∣ '{' ∣ '}' ∣ '_' → 
         output_char '\\'; output_char c
     ∣ '^' ∣ '~' → 
         output_char '\\'; output_char c; output_string "{}"
     ∣ '<' ∣ '>' →
         output_string "\\ensuremath{"; output_char c; output_string "}"
     ∣ _ → 
         output_char c

let output_latex_id s =
   for i = 0 to String.length s − 1 do
     output_escaped_char s.[i]
   done

type char_type = Upper ∣ Lower ∣ Symbol

let what_char = function
   ∣ 'A'..'Z' ∣ '\192'..'\214' ∣ '\216'..'\222' → Upper
   ∣ 'a'..'z' ∣'\223'..'\246' ∣ '\248'..'\255' ∣ '_' → Lower
   ∣ _ → Symbol

let what_is_first_char s =
   if String.length s > 0 then what_char s.[0] else Lower

let output_raw_ident_in_index s =
   begin match what_is_first_char s with
     ∣ Upper → output_string "\\ocwupperid{"
     ∣ Lower → output_string "\\ocwlowerid{"
     ∣ Symbol → output_string "\\ocwsymbolid{"
   end;
   output_latex_id s;
   output_string "}"

let output_raw_ident s =
   begin match what_is_first_char s with
     ∣ Upper → output_string "\\ocwupperid{"
     ∣ Lower → output_string "\\ocwlowerid{"
     ∣ Symbol → output_string "\\ocwsymbolid{"
   end;
   try
     let qualification = Filename.chop_extension s in 
     (∗ We extract the qualified name. ∗)
     let qualified_name =
       String.sub s (String.length qualification + 1)
         (String.length s − String.length qualification − 1)
     in 
     (∗ We check now whether the qualified term is a lower id or not. ∗)
     match qualified_name.[0] with
       ∣ 'A'..'Z' → 
       (∗ The qualified term is a module or a constructor: nothing to change. ∗)
           output_latex_id (s);
           output_string "}"
       ∣ _ → 
       (∗ The qualified term is a value or a type: \\ocwlowerid used instead. ∗)
           output_latex_id (qualification ^ ".");
           output_string "}";
           output_string "\\ocwlowerid{";
           output_latex_id qualified_name;
           output_string "}" 
   with Invalid_argument _ →
     (∗ The string s is a module name or a constructor: nothing to do. ∗)
     output_latex_id s;
     output_string "}"

let output_ident s =
   if is_keyword s then begin
     leave_math (); output_keyword s
   end else begin
     enter_math (); output_raw_ident s
   end

let output_lex_ident s =
   if is_lex_keyword s then begin
     leave_math (); output_lex_keyword s
   end else begin
     enter_math ();
     output_string "\\ocwlexident{"; 
     output_latex_id s;
     output_string "}";
   end

let output_yacc_ident s =
   if is_yacc_keyword s then begin
     leave_math (); output_yacc_keyword s
   end else begin
     enter_math ();
     output_string "\\ocwyaccident{"; 
     output_latex_id s;
     output_string "}";
   end
21.1emSymbols. Some mathematical symbols are printed in a nice way, in order to get a more readable code. The type variables from 'a to 'd are printed as Greek letters for the same reason.

let output_symbol = function
   ∣ "*" → enter_math (); output_string "\\times{}"
   ∣ "**" → enter_math (); output_string "*\\!*"
   ∣ "->" → enter_math (); output_string "\\rightarrow{}"
   ∣ "<-" → enter_math (); output_string "\\leftarrow{}"
   ∣ "<=" → enter_math (); output_string "\\le{}"
   ∣ ">=" → enter_math (); output_string "\\ge{}"
   ∣ "<>" → enter_math (); output_string "\\not="
   ∣ "==" → enter_math (); output_string "\\equiv"
   ∣ "!=" → enter_math (); output_string "\\not\\equiv"
   ∣ "~-" → enter_math (); output_string "-"
   ∣ "[<" → enter_math (); output_string "[\\langle{}"
   ∣ ">]" → enter_math (); output_string "\\rangle{}]"
   ∣ "<" ∣ ">" ∣ "(" ∣ ")" ∣ "[" ∣ "]" ∣ "[|" ∣ "|]" as s → 
             enter_math (); output_string s
   ∣ "&" ∣ "&&" →
             enter_math (); output_string "\\land{}"
   ∣ "or" ∣ "||" →
             enter_math (); output_string "\\lor{}"
   ∣ "not" → enter_math (); output_string "\\lnot{}"
   ∣ "[]" → enter_math (); output_string "[\\,]"
   ∣ "|" → enter_math (); output_string "\\mid{}"
   ∣ s → output_latex_id s

let use_greek_letters = ref true

let output_tv id = 
   output_string "\\ocwtv{"; output_latex_id id; output_char '}'

let output_greek l =
   enter_math (); output_char '\\'; output_string l; output_string "{}"

let output_type_variable id = 
   if ¬ !use_greek_letters then 
     output_tv id
   else
     match id with 
       ∣ "a" → output_greek "alpha"
       ∣ "b" → output_greek "beta"
       ∣ "c" → output_greek "gamma"
       ∣ "d" → output_greek "delta"
       ∣ "e" → output_greek "varepsilon"
       ∣ "i" → output_greek "iota"
       ∣ "k" → output_greek "kappa"
       ∣ "l" → output_greek "lambda"
       ∣ "m" → output_greek "mu"
       ∣ "n" → output_greek "nu"
       ∣ "r" → output_greek "rho"
       ∣ "s" → output_greek "sigma"
       ∣ "t" → output_greek "tau"
       ∣ _ → output_tv id

let output_ascii_char n =
   output_string (sprintf "\\symbol{%d}" n)
22.1emConstants.
let output_integer s =
   let n = String.length s in
   let base b = 
     let v = String.sub s 2 (n − 2) in
     output_string (sprintf "\\ocw%sconst{%s}" b v)
   in
   if n > 1 then
     match s.[1] with
       ∣ 'x' ∣ 'X' → base "hex" 
       ∣ 'o' ∣ 'O' → base "oct"
       ∣ 'b' ∣ 'B' → base "bin"
       ∣ _ → output_string s
   else
     output_string s

let output_float s =
   try
     let i = try String.index s 'e' with Not_found → String.index s 'E' in
     let m = String.sub s 0 i in
     let e = String.sub s (succ i) (String.length s − i − 1) in
     if m = "1" then
       output_string (sprintf "\\ocwfloatconstexp{%s}" e)
     else
       output_string (sprintf "\\ocwfloatconst{%s}{%s}" m e)
   with Not_found →
     output_string s
23.1emComments.
let output_bc () = leave_math (); output_string "\\ocwbc{}"

let output_ec () = leave_math (); output_string "\\ocwec{}"

let output_hfill () = leave_math (); output_string "\\hfill "

let output_byc () = leave_math (); output_string "\\ocwbyc{}"

let output_eyc () = leave_math (); output_string "\\ocweyc{}"
24.1emStrings.
let output_bs () = leave_math (); output_string "\\ocwstring{\""

let output_es () = output_string "\"}"

let output_vspace () = output_string "\\ocwvspace{}"
25.1emReset of the output machine.
let reset_output () =
   math_mode := false
26.1emSectioning commands.
let begin_section () =
   output_string "\\allowbreak\\ocwsection\n"

let output_typeout_command filename =
   output_string "\\typeout{OcamlWeb file ";
   output_string filename;
   output_string "}\n"

let output_module module_name =
   if ¬ !short then begin
     output_typeout_command (module_name^".ml");
     output_string "\\ocwmodule{";
     output_latex_id module_name;
     output_string "}\n"
   end

let output_interface module_name =
   if ¬ !short then begin
     output_typeout_command (module_name^".mli");
     output_string "\\ocwinterface{";
     output_latex_id module_name;
     output_string "}\n"
   end

let output_lexmodule module_name =
   if ¬ !short then begin
     output_typeout_command (module_name^".mll");
     output_string "\\ocwlexmodule{";
     output_latex_id module_name;
     output_string "}\n"
   end

let output_yaccmodule module_name =
   if ¬ !short then begin
     output_typeout_command (module_name^".mly");
     output_string "\\ocwyaccmodule{";
     output_latex_id module_name;
     output_string "}\n"
   end

let in_code = ref false

let begin_code () =
   if ¬ !in_code then output_string "\\ocwbegincode{}";
   in_code := true
let end_code () =
   if !in_code then output_string "\\ocwendcode{}";
   in_code := false

let begin_dcode () =
   output_string "\\ocwbegindcode{}"
let end_dcode () =
   output_string "\\ocwenddcode{}"

let last_is_code = ref false

let begin_code_paragraph () =
   if ¬ !last_is_code then output_string "\\medskip\n";
   last_is_code := true

let end_code_paragraph is_last_paragraph =
   if is_last_paragraph then end_line() else output_string "\\medskip\n\n"

let begin_doc_paragraph is_first_paragraph n =
   if ¬ is_first_paragraph then indentation n;
   last_is_code := false

let end_doc_paragraph () =
   output_string "\n"
27.1emIndex. It is opened and closed with the two macros ocwbeginindex and ocwendindex. The auxiliary function print_list is a generic function to print a list with a given printing function and a given separator.

let begin_index () =
   output_string "\n\n\\ocwbeginindex{}\n"

let end_index () =
   output_string "\n\n\\ocwendindex{}\n"

let print_list print sep l = 
   let rec print_rec = function
     ∣ [ ] → ()
     ∣ [x] → print x
     ∣ x::r → print x; sep(); print_rec r
   in
   print_rec l
28.1emIndex in WEB style. The function output_index_entry prints one entry line, given the name of the entry, and two lists of pre-formatted sections labels, like 1–4,7,10–17, of type string elem list. The first list if printed in bold face (places where the identifier is defined) and the second one in roman (places where it is used).

type α elem = Single of α ∣ Interval of α × α

let output_ref r = output_string (sprintf "\\ref{%s}" r)

let output_elem = function
   ∣ Single r → 
       output_ref r
   ∣ Interval (r1,r2) → 
       output_ref r1;
       output_string "--";
       output_ref r2

let output_bf_elem n = 
   output_string "\\textbf{"; output_elem n; output_string "}"

let output_index_entry s t def use =
   let sep () = output_string ", " in
   output_string "\\ocwwebindexentry{";
   enter_math ();
   output_raw_ident_in_index s;
   leave_math ();
   if t ≠ "" then output_string (" " ^ t);
   output_string "}{";
   print_list output_bf_elem sep def;
   output_string "}{";
   if def ≠ [ ] ∧ use ≠ [ ] then output_string ", ";
   print_list output_elem sep use;
   output_string "}\n"
29.1emIndex in L^AT_EX style. When we are not in WEB style, the index in left to L^AT_EX, and all the work is done by the macro \ocwrefindexentry, which takes three arguments: the name of the entry and the two lists of labels where it is defined and used, respectively.

let output_raw_index_entry s t def use =
   let sep () = output_string "," 
   and sep′ () = output_string ", " in
   output_string "\\ocwrefindexentry{";
   enter_math ();
   output_raw_ident_in_index s;
   leave_math ();
   if t ≠ "" then output_string (" " ^ t);
   output_string "}{";
   print_list output_string sep def;
   output_string "}{";
   print_list output_string sep use;
   output_string "}{";
   print_list output_ref sep′ def;
   output_string "}{";
   print_list output_ref sep′ use;
   output_string "}\n"

let output_label l =
   output_string "\\label{"; output_string l; output_string "}%\n"

Module Yacc_parser (Yacc)

30.1emIn actions, we reuse the location type for lex files.

   open Lex_syntax
   open Yacc_syntax

   let dummy_loc =
     { start_pos = Lexing.dummy_pos;
       end_pos = Lexing.dummy_pos;
       start_line = 0 ;
       start_col = 0 }

31.1emYacc tokens.
%token Ttoken Tstart Ttype Tleft Tright Tnonassoc Tprec Terror
%token < Yacc_syntax.ident > Tident
%token < Yacc_syntax.location > Taction Ttypedecl
%token Tor Tsemicolon Tcolon Tmark
%token EOF

%start yacc_definitions 
%type < Yacc_syntax.yacc_definitions > yacc_definitions

32.1emStart symbol for yacc description files
yacc_definitions::= 
   ∣ header tokendecls Tmark rules header EOF 
       {   { header = $1 ; 
           decls = $2;
           rules = $4;
           trailer = $5 }  }

header ::=
   ∣ Taction 
       {   $1  }
   ∣ /∗ ε ∗/ 
     {   dummy_loc  }

33.1emToken declarations.
tokendecls ::=
   ∣ tokendecl tokendecls 
     {   $1::$2  }
   ∣ /∗epsilon∗/
     {   [ ]  }

tokendecl ::=
   ∣ Ttoken Ttypedecl idlist
       {   Typed_tokens($2,$3)  }
   ∣ Ttoken idlist
       {   Untyped_tokens($2)  }
   ∣ Ttype Ttypedecl idlist
       {   Non_terminals_type($2,$3)  }
   ∣ Tstart idlist
       {   Start_symbols($2)  }
   ∣ Tleft idlist
       {   Tokens_assoc($2)  }
   ∣ Tnonassoc idlist
       {   Tokens_assoc($2)  }
   ∣ Tright idlist
       {   Tokens_assoc($2)  }

idlist::=
   ∣ Tident
     {   [$1]  }
   ∣ Tident idlist
     {   $1 :: $2  }

34.1emParsing of rules.
rules::=
   ∣ /∗ ε ∗/
     {   [ ]  }
   ∣ general_rule rules 
     {   $1 :: $2  }

Ocamlyacc manual asks for a semicolon at end of each rules. But ocamlyacc accepts if they are missing. We issue a warning for non conformity to ocamlyacc documentation.

general_rule::=
   ∣ rule Tsemicolon
       {   $1  }
   ∣ rule
       {   Yacc_syntax.issue_warning "ocamlyacc documentation recommends adding a semicolon at end of each grammar rules";
       $1  }

rule ::=
   ∣ Tident Tcolon right_part 
     {   ($1,$3)  }
   ∣ Tident Tcolon Tor right_part 
     {   ($1,$4)  }

right_part ::=
   ∣ word Taction
     {   [($1,$2)]  }
   ∣ word Taction Tor right_part
     {   ($1,$2) :: $4  }

word ::=
   ∣ /∗ ε ∗/
     {   [ ]  }
   ∣ Tident word
     {   $1 :: $2  }
   ∣ Tprec Tident word
     {   $2 :: $3  }
   ∣ Terror word
     {   $2  }

Module Yacc_lexer (Lex)

35.1em {

   open Lex_syntax
   open Yacc_syntax
   open Yacc_parser

Auxiliaries for the lexical analyzer
let brace_depth = ref 0
and comment_depth = ref 0
and mark_count = ref 0

exception Lexical_error of string × int × int

let handle_lexical_error fn lexbuf =
   let line = !current_line_num
   and column = Lexing.lexeme_start lexbuf − !current_line_start_pos in
   try
     fn lexbuf
   with Lexical_error(msg, _, _) →
     raise(Lexical_error(msg, line, column))
36.1emyacc keywords
let keyword_table = Hashtbl.create 17
let _ =
   List.iter (fun (kwd, tok) → Hashtbl.add keyword_table kwd tok)
     [ "token", Ttoken;
       "start", Tstart; 
       "type", Ttype;
       "left", Tleft;
       "right", Tright;
       "nonassoc", Tnonassoc;
       "prec", Tprec ]

let keyword_token lexbuf =
   try
     Hashtbl.find keyword_table (Lexing.lexeme lexbuf)
   with
       Not_found →
         raise(Lexical_error
               ("unknown keyword " ^ String.escaped(Lexing.lexeme lexbuf),
               !current_line_num, Lexing.lexeme_start lexbuf − !current_line_start_pos))

let cur_loc lexbuf = 
   { start_pos = Lexing.lexeme_start_p lexbuf; 
     end_pos = Lexing.lexeme_end_p lexbuf; 
     start_line = !current_line_num; 
     start_col = Lexing.lexeme_start lexbuf − !current_line_start_pos }

let reset_lexer f lexbuf =
   current_file_name := f;
   mark_count := 0;
   current_line_num := 1;
   current_line_start_pos := 0;
   current_lexbuf := lexbuf

}
37.1emmain rule for tokens in yacc files
rule main = parse

   ∣ [' ' '\013' '\009' '\012' ]  ⁺ 
     {   main lexbuf  }

Although few grammar files include commas anywhere commas are skipped in yacc. The original yacc code is used for ocaml. See yacc/reader.c:nextc(),read_grammar() from the ocaml 3.04 distribution.

We issue a warning for non conformity to ocamlyacc documentation.

   ∣ ','
     {   issue_warning 
         "use of commas in mly files is allowed but not conform to ocamlyacc documentation";
         main lexbuf  }

   ∣ '\010'
     {   current_line_start_pos := Lexing.lexeme_end lexbuf;
       incr current_line_num;
       main lexbuf  }
   ∣ "/*" 
     {   handle_lexical_error yacc_comment lexbuf;
       main lexbuf  }
   ∣ ['A'–'Z' 'a'–'z'] ['A'–'Z' 'a'–'z' '\'' '_' '0'–'9'] ^⋆
     {   match Lexing.lexeme lexbuf with
           "error" → Terror
         ∣ s → let l = cur_loc lexbuf in
                   Tident (s,l)  }
   ∣ '{' 
     {   let n1 = Lexing.lexeme_end_p lexbuf
       and l1 = !current_line_num
       and s1 = !current_line_start_pos in
       brace_depth := 1;
       let n2 = handle_lexical_error action lexbuf in
       Taction({start_pos = n1; end_pos = n2;
                 start_line = l1; start_col = n1.Lexing.pos_cnum − s1})  }
   ∣ '|' 
       {   Tor  }
   ∣ ';' 
       {   Tsemicolon  }
   ∣ ':' 
       {   Tcolon  }
   ∣ '%' 
       {   yacc_keyword lexbuf  }
   ∣ '<'
       {   let n1 = Lexing.lexeme_end_p lexbuf
         and l1 = !current_line_num
         and s1 = !current_line_start_pos in
         let n2 = handle_lexical_error typedecl lexbuf in
         Ttypedecl({start_pos = n1; end_pos = n2;
                     start_line = l1; start_col = n1.Lexing.pos_cnum − s1})  }
   ∣ eof 
       {   EOF  }
   ∣ _ 
     {   raise(Lexical_error
               ("illegal character " ^ String.escaped(Lexing.lexeme lexbuf),
               !current_line_num, Lexing.lexeme_start lexbuf − !current_line_start_pos))  }

and yacc_keyword = parse
   ∣ '%' 
       {   incr mark_count;
         if !mark_count = 1 then Tmark else 
           let n1 = Lexing.lexeme_end_p lexbuf
           and l1 = !current_line_num
           and s1 = !current_line_start_pos in
           brace_depth := 0;
           let n2 = handle_lexical_error action lexbuf in
           Taction({start_pos = n1; end_pos = n2;
                     start_line = l1; start_col = n1.Lexing.pos_cnum − s1})  }
   ∣ '{' 
       {   let n1 = Lexing.lexeme_end_p lexbuf
         and l1 = !current_line_num
         and s1 = !current_line_start_pos in
         brace_depth := 1;
         let n2 = handle_lexical_error action lexbuf in
         Taction({start_pos = n1; end_pos = n2;
                   start_line = l1; start_col = n1.Lexing.pos_cnum − s1})  }
   ∣ ['a'–'z'] ⁺
       {   keyword_token lexbuf  }
   ∣ _  
       {   raise(Lexical_error
               ("illegal character " ^ String.escaped(Lexing.lexeme lexbuf),
               !current_line_num, Lexing.lexeme_start lexbuf − !current_line_start_pos))  }
38.1emrecognizes a CAML action
and action = parse
   ∣ '{' 
     {   incr brace_depth;
       action lexbuf  }
   ∣ '}' 
     {   decr brace_depth;
       if !brace_depth = 0 
       then Lexing.lexeme_start_p lexbuf else action lexbuf  }
   ∣ "%}" 
     {   decr brace_depth;
       if !brace_depth = 0 then Lexing.lexeme_start_p lexbuf else 
         raise(Lexical_error
                 ("ill-balanced brace ",
                   !current_line_num, Lexing.lexeme_start lexbuf − !current_line_start_pos))  }
   ∣ '"' 
     {   string lexbuf;
       action lexbuf  }
   ∣ "’" [^ '\\'] "’" 
     {   action lexbuf  }
   ∣ "’" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "’" 
     {   action lexbuf  }
   ∣ "’" '\\' ['0'–'9'] ['0'–'9'] ['0'–'9'] "’" 
     {   action lexbuf  }
   ∣ "(*" 
     {   comment_depth := 1;
       comment lexbuf;
       action lexbuf  }
   ∣ eof 
     {   if !brace_depth = 0 then Lexing.lexeme_start_p lexbuf else
         raise (Lexical_error("unterminated action", 0, 0))  }
   ∣ '\010'
     {   current_line_start_pos := Lexing.lexeme_end lexbuf;
       incr current_line_num;
       action lexbuf  }
   ∣ _  
     {   action lexbuf  }
39.1emrecognizes a CAML type between < and >
and typedecl = parse
   ∣ '>' 
     {   Lexing.lexeme_start_p lexbuf  }
   ∣ eof 
     {   raise (Lexical_error("unterminated type declaration", 0, 0))  }
   ∣ '\010'
     {   current_line_start_pos := Lexing.lexeme_end lexbuf;
       incr current_line_num;
       typedecl lexbuf  }
   ∣ "->" 
     {   typedecl lexbuf  }
   ∣ _  
     {   typedecl lexbuf  }

and string = parse
     '"' 
     {   ()  }
   ∣ '\\' [' ' '\013' '\009' '\012'] ^⋆ '\010' [' ' '\013' '\009' '\012'] ^⋆
     {   current_line_start_pos := Lexing.lexeme_end lexbuf;
       incr current_line_num;
       string lexbuf  }
   ∣ '\\' ['\\' '"' 'n' 't' 'b' 'r'] 
     {   string lexbuf  }
   ∣ '\\' ['0'–'9'] ['0'–'9'] ['0'–'9'] 
     {   string lexbuf  }
   ∣ eof 
     {   raise(Lexical_error("unterminated string", 0, 0))  }
   ∣ '\010'
     {   current_line_start_pos := Lexing.lexeme_end lexbuf;
       incr current_line_num;
       string lexbuf  }
   ∣ _  
     {   string lexbuf  }

and comment = parse
     "(*" 
     {   incr comment_depth; comment lexbuf  }
   ∣ "*)" 
     {   decr comment_depth;
       if !comment_depth = 0 then () else comment lexbuf  }
   ∣ '"' 
     {   string lexbuf;
       comment lexbuf  }
   ∣ "’’"
       {   comment lexbuf  }
   ∣ "’" [^ '\\' '\''] "’"
       {   comment lexbuf  }
   ∣ "’\\" ['\\' '\'' 'n' 't' 'b' 'r'] "’"
       {   comment lexbuf  }
   ∣ "’\\" ['0'–'9'] ['0'–'9'] ['0'–'9'] "’"
       {   comment lexbuf  }
   ∣ eof 
     {   raise(Lexical_error("unterminated comment", 0, 0))  }
   ∣ '\010'
     {   current_line_start_pos := Lexing.lexeme_end lexbuf;
       incr current_line_num;
       comment lexbuf  }
   ∣ _  
     {   comment lexbuf  }

and yacc_comment = parse
   ∣ "*/" 
     {   ()  }
   ∣ eof 
     {   raise(Lexical_error("unterminated yacc comment", 0, 0))  }
   ∣ '\010'
     {   current_line_start_pos := Lexing.lexeme_end lexbuf;
       incr current_line_num;
       yacc_comment lexbuf  }
   ∣ _  
     {   yacc_comment lexbuf  }

Interface for module Cross

40.1emThat module exports to global tables used and defined, indexed by identifiers (strings) and containing respectively the sets of locations where they are defined and used. Those locations are of type where, which contain the name of the file and the absolute position in the source.

type where = { w_filename : string; w_loc : int }

type entry_type = 
   ∣ Value
   ∣ Constructor
   ∣ Field
   ∣ Label
   ∣ Type
   ∣ Exception
   ∣ Module
   ∣ ModuleType
   ∣ Class
   ∣ Method
   ∣ LexParseRule (∗ CAMLLEX entry points ∗)
   ∣ RegExpr (∗ CAMLLEX regular expressions ∗)
   ∣ YaccNonTerminal (∗ CAMLYACC non-terminal symbols ∗)
   ∣ YaccTerminal (∗ CAMLYACC terminal symbols, i.e. tokens ∗)

type index_entry = { e_name : string; e_type : entry_type }

module Idmap : Map.S with type key = index_entry

module Stringset : Set.S with type elt = string

module Whereset : Set.S with type elt = where

val used : Whereset.t Idmap.t ref
val defined : Whereset.t Idmap.t ref
41.1emThe two following functions fill the above tables for a given file.
val cross_implem : string → string → unit
val cross_interf : string → string → unit

cross-referencing lex and yacc description files
val cross_lex : string → string → unit
val cross_yacc : string → string → unit

Module Cross

42.1emCross references inside Caml files are kept in the following two global tables, which keep the places where things are defined and used, to produce the final indexes.
type where = { w_filename : string; w_loc : int }

module Whereset = Set.Make(struct type t = where let compare = compare end)

type entry_type = 
   ∣ Value
   ∣ Constructor
   ∣ Field
   ∣ Label
   ∣ Type
   ∣ Exception
   ∣ Module
   ∣ ModuleType
   ∣ Class
   ∣ Method
   ∣ LexParseRule (∗ CAMLLEX entry points ∗)
   ∣ RegExpr (∗ CAMLLEX regular expressions ∗)
   ∣ YaccNonTerminal (∗ CAMLYACC non-terminal symbols ∗)
   ∣ YaccTerminal (∗ CAMLYACC terminal symbols, i.e. tokens ∗)

type index_entry = { e_name : string; e_type : entry_type }

module Idmap = Map.Make(struct type t = index_entry let compare = compare end)

let defined = ref Idmap.empty
let used = ref Idmap.empty
43.1emThe function add_global is a generic function to add an entry in one table. add_def is used to add the definition of an identifier (so in the table defined).
let add_global table k i =
   try
     let s = Idmap.find k !table in
     table := Idmap.add k (Whereset.add i s) !table
   with Not_found →
     table := Idmap.add k (Whereset.singleton i) !table

let current_file = ref ""

let current_offset = ref 0

let current_location loc = 
   { w_filename = !current_file; 
     w_loc = !current_offset + loc.loc_start.pos_cnum }

let add_def loc t s =
   if String.length s > 0 then
     let e = { e_name = s; e_type = t } in
     add_global defined e (current_location loc)
44.1emAnother table, locals, keeps the bound variables, in order to distinguish them from global identifiers. Then the function add_uses registers that an identifier is used (in the table used), taking care of the fact that it is not a bound variable (in the table locals). add_uses_q iters add_uses on a qualified identifier.
module Stringset = Set.Make(struct type t = string let compare = compare end)

let locals = ref Stringset.empty

let reset_cross f offs =
   assert (Stringset.cardinal !locals = 0);
   locals := Stringset.empty;
   current_file := f;
   current_offset := offs

let add_local s =
   locals := Stringset.add s !locals

let is_uppercase = function 'A'..'Z' → true ∣ _ → false

let add_uses loc t s =
   if String.length s > 0 ∧
       ¬ (is_keyword s) ∧ ¬ (Stringset.mem s !locals) 
   then
     let e = { e_name = s; e_type = t } in
     add_global used e (current_location loc)

let add_uses_q loc t q =
   let rec addmod = function
     ∣ Lident s → add_uses loc Module s
     ∣ Ldot (q,s) → addmod q; add_uses loc Module s
     ∣ Lapply (q1,q2) → addmod q1; addmod q2 
   in
   match q with
     ∣ Lident s → add_uses loc t s
     ∣ Ldot (q,s) → addmod q; add_uses loc t s
     ∣ Lapply (q1,q2) → addmod q1; addmod q2
45.1emSome useful functions.
let iter_fst f = List.iter (fun x → f (fst x))

let iter_snd f = List.iter (fun x → f (snd x))

let option_iter f = function None → () ∣ Some x → f x
46.1emWhen traversing a pattern, we must collect all its identifiers, in order to declare them as bound variables (or definitions behind a let construction). That is the job of the function ids_of_a_pattern. Then pattern_for_def declares all the identifiers of a pattern as new definitions.
let ids_of_a_pattern p =
   let r = ref [ ] in
   let add id = r := id :: !r in
   let rec pattern_d = function
     ∣ Ppat_any → ()
     ∣ Ppat_var id → add id
     ∣ Ppat_alias (p,id) → add id; pattern p
     ∣ Ppat_constant _ → ()
     ∣ Ppat_tuple pl → List.iter pattern pl
     ∣ Ppat_construct (_,po,_) → option_iter pattern po
     ∣ Ppat_record l → iter_snd pattern l
     ∣ Ppat_array pl → List.iter pattern pl
     ∣ Ppat_or (p1,p2) → pattern p1; pattern p2
     ∣ Ppat_constraint (p,_) → pattern p
     ∣ Ppat_variant (_,po) → option_iter pattern po
     ∣ Ppat_type _ → ()
   and pattern p = 
     pattern_d p.ppat_desc
   in
   pattern p; !r

let pattern_for_def p =
   let loc = p.ppat_loc in
   let ids = ids_of_a_pattern p in
   List.iter (add_def loc Value) ids
47.1emThe following function locally adds some given variables to the set of bound variables, during the time of the application of a given function on a given argument.
let bind_variables ids f x =
   let save = !locals in
   List.iter add_local ids;
   f x;
   locals := save
48.1emTraversing of Caml abstract syntax trees. Each type t in those abstract syntax trees is associated to a function tr_t which traverses it, declaring the identifiers used and defined. Those types are defined in the Caml module interface Paresetree.mli contained in the Caml source distribution.

The following code is quite code, but systematic and easy to understand.

49.1emCore types.
let rec tr_core_type t =
   tr_core_type_desc t.ptyp_loc t.ptyp_desc

and tr_core_type_desc loc = function
   ∣ Ptyp_any ∣ Ptyp_var _ → 
       ()
   ∣ Ptyp_arrow (l,t1,t2) →
       add_def loc Label l; tr_core_type t1; tr_core_type t2
   ∣ Ptyp_tuple tl →
       List.iter tr_core_type tl
   ∣ Ptyp_constr (q,tl) →
       add_uses_q loc Type q; List.iter tr_core_type tl
   ∣ Ptyp_object l →
       List.iter tr_core_field_type l
   ∣ Ptyp_class (id,l,ll) →
       add_uses_q loc Class id;
       List.iter (add_def loc Label) ll;
       List.iter tr_core_type l
   ∣ Ptyp_alias (ct,_) → 
       tr_core_type ct
   ∣ Ptyp_variant (l,_,_) →
       List.iter tr_row_field l
   ∣ Ptyp_poly (_,t) →
       tr_core_type t

and tr_row_field = function
   ∣ Rtag (_,_,ctl) → List.iter tr_core_type ctl
   ∣ Rinherit t → tr_core_type t

and tr_core_field_type ft =
   tr_core_field_desc ft.pfield_loc ft.pfield_desc

and tr_core_field_desc loc = function
   ∣ Pfield (id,ct) →
       add_uses loc Method id;
       tr_core_type ct
   ∣ Pfield_var → ()
50.1emType expressions for the class language.
let tr_class_infos f p =
   add_def p.pci_loc Class p.pci_name;
   f p.pci_expr
51.1emValue expressions for the core language.
let bind_pattern f (p,e) =
   bind_variables (ids_of_a_pattern p) f e

let bind_patterns f pl e =
   let ids = List.flatten (List.map ids_of_a_pattern pl) in
   bind_variables ids f e

let rec tr_expression e = 
   tr_expression_desc e.pexp_loc e.pexp_desc

and tr_expression_desc loc = function
   ∣ Pexp_ident q → 
       add_uses_q loc Value q
   ∣ Pexp_apply (e,lel) →
       tr_expression e; 
       List.iter (fun (l,e) → add_uses loc Label l; tr_expression e) lel
   ∣ Pexp_ifthenelse (e1,e2,e3) → 
       tr_expression e1; tr_expression e2; option_iter tr_expression e3
   ∣ Pexp_sequence (e1,e2) →
       tr_expression e1; tr_expression e2
   ∣ Pexp_while (e1,e2) →
       tr_expression e1; tr_expression e2
   ∣ Pexp_tuple el →
       List.iter tr_expression el
   ∣ Pexp_construct (q,e,_) → 
       add_uses_q loc Constructor q;
       option_iter tr_expression e
   ∣ Pexp_function (l,eo,pel) → 
       add_def loc Label l;
       option_iter tr_expression eo;
       List.iter (bind_pattern tr_expression) pel
   ∣ Pexp_match (e,pel) → 
       tr_expression e; List.iter (bind_pattern tr_expression) pel
   ∣ Pexp_try (e,pel) → 
       tr_expression e; List.iter (bind_pattern tr_expression) pel
   ∣ Pexp_let (recf,pel,e) → 
       let pl = List.map fst pel in
       if recf = Recursive then 
         iter_snd (bind_patterns tr_expression pl) pel
       else
         iter_snd tr_expression pel; 
       bind_patterns tr_expression pl e
   ∣ Pexp_record (l,e) →
       iter_fst (add_uses_q loc Field) l; iter_snd tr_expression l; 
       option_iter tr_expression e
   ∣ Pexp_field (e,q) →
       tr_expression e; add_uses_q loc Field q
   ∣ Pexp_setfield (e1,q,e2) →
       tr_expression e1; add_uses_q loc Field q; tr_expression e2
   ∣ Pexp_array el →
       List.iter tr_expression el
   ∣ Pexp_for (i,e1,e2,_,e) →
       tr_expression e1; tr_expression e2; bind_variables [i] tr_expression e
   ∣ Pexp_constraint (e,t1,t2) →
       tr_expression e; option_iter tr_core_type t1; option_iter tr_core_type t2
   ∣ Pexp_when (e1,e2) →
       tr_expression e1; tr_expression e2
   ∣ Pexp_letmodule (x,m,e) →
       tr_module_expr m; bind_variables [x] tr_expression e
   ∣ Pexp_constant _ → 
       ()
   ∣ Pexp_send (e,id) →
       add_uses loc Method id; tr_expression e
   ∣ Pexp_new id →
       add_uses_q loc Class id
   ∣ Pexp_setinstvar (id,e) →
       add_uses loc Value id; tr_expression e
   ∣ Pexp_override l →
       iter_fst (add_uses loc Method) l; iter_snd tr_expression l
   ∣ Pexp_variant (_,eo) →
       option_iter tr_expression eo
   ∣ Pexp_assert e →
       tr_expression e
   ∣ Pexp_assertfalse →
       ()
   ∣ Pexp_lazy e →
       tr_expression e
   ∣ Pexp_poly (e, t) →
       tr_expression e; option_iter tr_core_type t
   ∣ Pexp_object cs →
       tr_class_structure cs
52.1emValue descriptions.
and tr_value_description vd =
   tr_core_type vd.pval_type
53.1emType declarations.
and tr_type_declaration td =
   tr_type_kind td.ptype_loc td.ptype_kind;
   option_iter tr_core_type td.ptype_manifest

and tr_type_kind loc = function
   ∣ Ptype_abstract → ()
   ∣ Ptype_variant (cl,_) →
       iter_fst (add_def loc Constructor) cl;
       iter_snd (List.iter tr_core_type) cl
   ∣ Ptype_record (fl,_) →
       List.iter (fun (f,_,t) → add_def loc Field f; tr_core_type t) fl

and tr_exception_declaration ed =
   List.iter tr_core_type ed
54.1emType expressions for the class language.
and tr_class_type c =
   tr_class_type_desc c.pcty_loc c.pcty_desc

and tr_class_type_desc loc = function
   ∣ Pcty_constr (id,l) →
       add_uses_q loc Class id;
       List.iter tr_core_type l
   ∣ Pcty_signature cs →
       tr_class_signature cs
   ∣ Pcty_fun (l,co,cl) →
       add_def loc Label l;
       tr_core_type co;
       tr_class_type cl

and tr_class_signature (ct,l) = 
   tr_core_type ct;
   List.iter tr_class_type_field l

and tr_class_type_field = function
   ∣ Pctf_inher ct → 
       tr_class_type ct
   ∣ Pctf_val (id,_,ct,loc) →
       add_def loc Value id;
       option_iter tr_core_type ct
   ∣ Pctf_virt (id,_,ct,loc) →
       add_def loc Method id;
       tr_core_type ct
   ∣ Pctf_meth (id,_,ct,loc) →
       add_def loc Method id;
       tr_core_type ct
   ∣ Pctf_cstr (ct1,ct2,_) →
       tr_core_type ct1;
       tr_core_type ct2

and tr_class_description x = tr_class_infos tr_class_type x

and tr_class_type_declaration x = tr_class_infos tr_class_type x
55.1emValue expressions for the class language.
and tr_class_expr ce = tr_class_expr_desc ce.pcl_loc ce.pcl_desc

and tr_class_expr_desc loc = function
   ∣ Pcl_constr (id,l) →
       add_uses_q loc Class id;
       List.iter tr_core_type l
   ∣ Pcl_structure cs → 
       tr_class_structure cs
   ∣ Pcl_fun (l,eo,p,ce) →
       add_def loc Label l;
       option_iter tr_expression eo;
       bind_variables (ids_of_a_pattern p) tr_class_expr ce
   ∣ Pcl_apply (ce,l) →
       tr_class_expr ce;
       List.iter (fun (l,e) → add_uses loc Label l; tr_expression e) l
   ∣ Pcl_let (recf,pel,ce) → 
       let pl = List.map fst pel in
       if recf = Recursive then 
         iter_snd (bind_patterns tr_expression pl) pel
       else
         iter_snd tr_expression pel; 
       bind_patterns tr_class_expr pl ce
   ∣ Pcl_constraint (ce,ct) →
       tr_class_expr ce;
       tr_class_type ct