compilation/cours/cours-01/marthe.ml

(*

    Ce module implémente une boucle interactive pour le langage
    "Marthe", un langage d'expressions arithmétiques avec un
    opérateurs de sommation.

    Pour le compiler, utilisez par exemple la commande :

    ocamlopt -o marthe unix.cmxa marthe.ml

    Vous pouvez aussi l'évaluer pas à pas dans une boucle interactive
    ocaml, liée au module standard Unix. Pour cela, dans le mode
    Tuareg d'emacs, lancez la fonction "Run Caml Toplevel" du menu
    Tuareg avec la commande :

    ocaml unix.cma

*)

(*

   Le langage Marthe est un langage minimaliste dont voici quelques
   exemples de programmes corrects syntaxiquement:

   - "73"
   - "6 * 7"
   - "1 + (2 * 3)"
   - "1 + 2 * 3"
   - "sum (x, 1, 10, x * x)"
   - "sum (x, 1, 10, sum (y, 1, 10, x + y))"
   - "1
      + 2 *         3"
   - "sum (x, 1, 10 * 10, y)"

   Nous allons écrire une boucle interactive incluant un interpréteur
   de Marthe ainsi qu'un compilateur de Marthe vers une machine
   abstraite minimaliste à pile.

*)

(* Cette fonction implémente une boucle interactive à
  l'aide de trois fonctions:
  - [read ()] demande une chaîne [s] à l'utilisateur ;
  - [eval s] évalue le programme Marthe ;
  - [print r] affiche la valeur résultat de l'évaluation de [s]. *)
let loop read eval print =
  let rec aux () =
    try
      let p = read () in
      let v = eval p in
      print v;
      aux ()
    with
    | End_of_file ->
       (* Si le flux entrant se termine, on arrête la boucle interactive après
          avoir affiché une nouvelle ligne. *)
       print_newline ()
    | exn ->
      (* On utilise le module de la bibliothèque standard de Caml
         pour afficher l'exception. L'échappement ANSI "\033[31m"
         permet d'afficher en rouge l'erreur dans un terminal.
         http://tldp.org/HOWTO/Bash-Prompt-HOWTO/x329.html
      *)
      Printf.printf "\027[31mError:%s\n\027[0m" (Printexc.to_string exn);
      aux ()
  in
  aux ()

(*

   Pour définir la syntaxe d'un langage, on utilise une *grammaire*.

   Une grammaire définit deux choses:
   - un ensemble de mots (les programmes syntaxiquement corrects) ;
   - la structure de ces mots.

   Ainsi, le premier problème à résoudre est de transformer une chaîne
   de caractères (qui est une donnée toute plate, sans structure) en
   un *arbre de syntaxe abstraite* (qui met en avant la structure des
   programmes). Avoir une structure d'arbre permet d'*interpréter* les
   programmes récursivement. Typiquement, on veut évaluer un expression
   de la forme "e₁ + e₂" en évaluant e₁ en un entier n₁ puis e₂ en
   un entier n₂ puis en faisant la somme de n₁ et n₂.

   Voici des exemples de programmes Marthe pour illustrent ces idées:

   * Exemple 1:
   On veut traduire "1 + 2" en "EPlus (EInt 1, EInt 2)".
   La sous-chaîne "1" a été reconnue comme "EInt 1".
   La sous-chaîne "2" a été reconnue comme "EInt 2".
   La sous-chaîne "1 + 2" a été reconnue en "EPlus (EInt 1, EInt 2)".

   * Exemple 2:
   On veut traduire "1 +    2   * 3" en "EPlus (EInt 1, EMul (EInt 2, EInt 3))".
   Le nombre d'espaces n'a pas de signification dans la grammaire du langage
   Marthe. Il y a donc des caractères importants et des caractères à ignorer.
   Nous allons voir que la phase d'analyse lexicale sert à se concentrer sur
   les symboles importants.

   * Exemple 3:
   On veut transformer "1 + 2 * 3" en "EPlus (EInt 1, EMul (EInt 2, EInt 3))".
   Attention, ici, il serait incorrect de traduire "1 + 2 * 3" en
   "EMul (EPlus (EInt 1, EInt 2), EInt 3)" parce que l'on donnerait
   alors la priorité à l'addition devant la multiplication !

   Ces exemples nous apprennent plusieurs choses:

   1. Le type de la fonction "read" doit être quelque chose comme:

                            string → expression

   où "expression" est un type de données arborescent.

   2. L'analyse syntaxique peut être précédée d'une première phase qui
      élimine les caractères non significatifs.

   3. L'analyse syntaxique doit prendre en charge la reconnaissance des
      priorités des opérateurs.

*)

(* [read] transforme une chaîne de caractères d'entrées en un arbre
    de syntaxe abstraite en composant l'analyse lexicale et l'analyse
    syntaxique. *)
let read lexer parse =
  Printf.printf "marthe> %!";
  let s = input_line stdin in
  let tokens = lexer s in
  parse tokens

(* Les lexèmes, aussi appelés "terminaux", sur lesquels
    la grammaire du langage est définie. *)
type token =
  | Int of int   (* Ex: "42", "0", "231", ...  *)
  | Id of string (* Ex: "x", "abc", "foo"      *)
  | Sum          (* "sum"                      *)
  | Plus         (* "+"                        *)
  | Star         (* "*"                        *)
  | Lparen       (* "("                        *)
  | Rparen       (* ")"                        *)
  | Comma        (* ","                        *)
  | EOF          (* La fin de l'entrée.        *)

let string_of_token = function
  | Int x   -> "Int(" ^ string_of_int x ^ ")"
  | Id x    -> "Id(" ^ x ^ ")"
  | Sum     -> "Sum"
  | Plus    -> "Plus"
  | Star    -> "Star"
  | Lparen  -> "Lparen"
  | Rparen  -> "Rparen"
  | Comma   -> "Comma"
  | EOF     -> "EOF"

exception LexingError of string

(* L'analyse lexixale produit une liste de lexèmes à partir de la
   chaîne de caractères d'entrée. Il s'agit essentiellement d'un
   automate fini implémentée à la main. *)
let lexer : string -> token list =
  fun s ->
    let at_the_end i = i >= String.length s in

    (* Itère sur la chaîne en partant de l'indice [start],
       et avance tant que le caractère [c] est tel que
       [char_class c = true]. *)
    let word char_class =
      let rec aux start i =
        let return stop = (String.sub s start (i - start), stop) in
        if at_the_end i then
          return (i + 1)
        else if char_class s.[i] then
          aux start (i + 1)
        else
          return i
      in
      fun start -> aux start start
    in

    (* Les classes de caractères. *)
    let is_digit  c = c >= '0' && c <= '9' in
    let is_letter c = c >= 'a' && c <= 'z' in
    (* Les mots sur ces classes de caractères. *)
    let number      = word is_digit in
    let identifier  = word is_letter in

    (* La fonction récursive suivante itère sur la chaîne
       à partir de [i] et tente de reconnaître un lexème. *)
    let rec aux i =
      (* Par défaut, pour continuer sur le caractère suivant, on augmente
         l'indice et on fait un appel récursif. Dans certains cas,
         l'indice [where] est fourni. *)
      let continue ?(where=(i + 1)) () = aux where in

      (* Pour retourner un lexème reconnu, on le met en tête
         de la liste des tokens produite par les appels récursifs. *)
      let produce_and_continue ?where token = token :: (continue ?where ()) in

      if at_the_end i then
        (* Le lexème EOF marque la fin de l'entrée. *)
        [EOF]
      else
        (* Sinon, on peut décider quel lexème essayer de reconnaître
           à l'aide du premier caractère croisé. *)
        match s.[i] with
        (* On saute les espaces. *)
        | ' ' -> continue ()

        (* Les symboles. *)
        | '*' -> produce_and_continue Star
        | '+' -> produce_and_continue Plus
        | '(' -> produce_and_continue Lparen
        | ')' -> produce_and_continue Rparen
        | ',' -> produce_and_continue Comma

        (* Les nombres. *)
        | c when is_digit c ->
          let (n, eo_num) = number i in
          (* [i] est l'indice du dernier caractère du nombre
              reconnu. *)
          produce_and_continue ~where:eo_num (Int (int_of_string n))

        (* Les identificateurs. *)
        | c when is_letter c ->
          let (s, eo_id) = identifier i in
          (* [i] est l'indice du dernier caractère de
              l'identificateur reconnu. *)
          produce_and_continue ~where:eo_id (if s = "sum" then Sum else Id s)

        (* Sinon, le caractère n'est pas accepté par le lexeur. *)
        | _ ->
          raise (LexingError "Invalid character")
    in
    aux 0

(* Tests de l'analyseur lexical. *)
let test_title s =
  let max_test_title_len = 30 in
  let s = String.escaped s in
  if String.length s > max_test_title_len then
    String.sub s 0 max_test_title_len ^ "..."
  else
    s

let ok s = Printf.printf "\027[1;32m[OK] `%s'\027[0m\n" (test_title s)
let ko s = Printf.printf "\027[1;31m[KO] `%s'\027[0m\n" (test_title s)
let ( --> ) input output = (input, output)
let do_test positivity display test (input, expected) =
  try
    if positivity (test input = expected) then
      ok (display input)
    else
      ko (display input)
  with _ -> if positivity true then ko (display input) else ok (display input)

let valid   x = x
let invalid x = not x

let test_lexer () =
  Printf.printf "-*- Lexer -*-\n";
  (* Tests positifs. *)
  List.iter (do_test valid (fun s -> s) lexer) [
    "1"    --> [Int 1; EOF];
    "42"   --> [Int 42; EOF];
    "231"  --> [Int 231; EOF];
    "+"    --> [Plus; EOF];
    "*"    --> [Star; EOF];
    "("    --> [Lparen; EOF];
    ")"    --> [Rparen; EOF];
    ","    --> [Comma; EOF];
    "sum"  --> [Sum; EOF];
    "a"    --> [Id "a"; EOF];
    "sumx" --> [Id "sumx"; EOF];
    "(  )" --> [Lparen; Rparen; EOF];
    "()"   --> [Lparen; Rparen; EOF];
    "42,"  --> [Int 42; Comma; EOF];
    ""     --> [EOF]
  ];

  (* Tests négatifs. *)
  List.iter (do_test invalid (fun s -> s) lexer) [
    "#"    --> [];
    "!"    --> [];
    "\n"   --> [];
  ]

(* Exercices de programmation:

   Étendre l'analyse lexicale, pour
   1. ignorer les tabulations ;
   2. rajouter la gestion des symboles '-' et '/' ;
   3. ignorer des commentaires écrits entre '(*' et '*)'.

*)

(* Les arbres de syntaxe abstraite du langage Marthe.

   Sont donnés ici en exemple des chaînes de caractères produisant
   un arbre dont la racine est le constructeur de données de la
   même ligne. *)
type e =
  | EInt  of int                 (* Ex: "42", "31"              *)
  | EVar  of string              (* Ex: "x", "y", "foo"         *)
  | EPlus of e * e               (* Ex: "1 + 2", "2 * 3 + 4"    *)
  | EMult of e * e               (* Ex: "1 * 2", "(1 + 2) * 3"  *)
  | ESum  of string * e * e * e  (* Ex: "sum (x, 1, 10, x * x)" *)

exception ParseError of string * token

(* On se donne la grammaire suivante pour les arbres de syntaxe
   de Marthe:

   phrase ::= expression EOF

   expression ::=
     term PLUS expression
   | term

   term ::=
     factor STAR term
   | factor

   factor ::=
     INT(x)
   | VAR(x)
   | SUM LPAREN VAR COMMA expression COMMA expression COMMA expression RPAREN
   | LPAREN expression RPAREN

   La fonction [parse] transforme une liste de lexèmes en un arbre du type [e]
   via l'analyse induite par la grammaire.
*)

let parse : token list -> e = fun tokens ->
  (* On utilise trois fonctions pour se construire une abstraction
     au-dessus de la liste des lexèmes restant à traiter. À l'aide
     des trois fonctions suivantes, on lit cette liste de gauche
     à droite au fur et à mesure de l'analyse, qui accepte ou non
     ces lexèmes comme étant à une position valide vis-à-vis de
     la grammaire. *)
  let (accept, current, next) =

    (* En utilisant une référence locale, on s'assure que seules
       les trois fonctions suivantes peuvent modifier la variable
       [token_stream]. *)
    let token_stream = ref tokens in

    (* La fonction [next] supprime le lexème en tête de la liste
       des lexèmes à traiter. *)
    let next () =
      match !token_stream with
        | [] -> raise (ParseError ("No more tokens", EOF))
        | _ :: tokens ->
          token_stream := tokens
    in

    (* La fonction [current] renvoie le lexème courant. *)
    let current () =
      match !token_stream with
        | [] -> assert false
        | tok :: _ ->
          tok
    in

    (* [accept t] vérifie que le lexème courante est [t] et
        passe alors au lexème suivant. *)
    let accept token =
      if (current () <> token) then
        raise (ParseError ("Unexpected token", token));
      next ()
    in
    (accept, current, next)
  in

  (* L'analyseur syntaxique suit un algorithme récursif et
     descendant.

     Il est défini par 4 fonctions mutuellement récursives
     correspondant à chaque cas de la grammaire définie plus
     haut.
  *)

  (* Une phrase est une expression suivie obligatoirement
     par la fin de l'entrée. *)
  let rec phrase () =
    let e = expression () in
    accept EOF;
    e

  (* Pour analyser une expression, ... *)
  and expression () =
    (* ... on commence par analyser un terme. *)
    let e = term () in
    match current () with
      (* Si ce terme est suivi par un "Plus", on
         est dans la seconde règle de la grammaire,
         on doit donc accepter ce "Plus" et passer à
         la suite pour reconnaître une expression. *)
      | Plus ->
        next ();
        EPlus (e, expression ())

      (* Dans les autres cas, nous étions dans
         la première règle et nous avons reconnu
         une expression [e]. Le travail est terminé. *)
      | _ ->
        e

  (* Pour analyser un terme, on suit le même schéma que pour
     les expressions. *)
  and term () =
    let t = factor () in
    match current () with
      | Star ->
        next ();
        EMult (t, term ())

      | _ -> t

  (* Pour décider dans quelle règle on se trouve, ... *)
  and factor () =
    (* on commence par observer le lexème courant. *)
    match current () with
      (* C'est une parenthèse ouvrante ? C'est la règle 4. *)
      | Lparen ->
        next ();
        (* On doit reconnaître une expression ... *)
        let e = expression () in
        (* ... suivie d'une parenthèse fermante. *)
        accept Rparen;
        e

      (* C'est le mot-clé "sum" ? C'est la règle 3. *)
      | Sum ->
        next ();
        (* On attend une parenthèse ouvrante. *)
        accept Lparen;
        (* Puis, un identificateur. *)
        let id =
          match current () with
            | Id s -> next (); s
            | token -> raise (ParseError ("Expecting an identifier", token))
        in
        (* Une virgule. *)
        accept Comma;
        (* L'expression correspondante à l'initialisation de la variable
           de sommation. *)
        let start = expression () in
        (* Une virgule. *)
        accept Comma;
        (* L'expression correspondante à la valeur finale de la variable
           de sommation. *)
        let stop = expression () in
        (* Une virgule. *)
        accept Comma;
        (* L'expression correspondante au corps de la sommation. *)
        let body = expression () in
        (* Et enfin, une parenthèse fermante. *)
        accept Rparen;
        ESum (id, start, stop, body)

      (* C'est un identificateur ? C'est la règle 2. *)
      | Id x ->
        next ();
        EVar x

      (* C'est un entier ? C'est la règle 1. *)
      | Int x ->
        next ();
        EInt x

      (* Les autres cas sont des cas d'erreur. *)
      | token ->
        raise (ParseError ("Unexpected token", token))

  in
  phrase ()

let test_parser () =
  Printf.printf "-*- Parser -*-\n";
  let display_tokens t = String.concat " " (List.map string_of_token t) in
  (* Tests positifs. *)
  List.iter (do_test valid display_tokens parse) [
    [Int 1; EOF]               --> EInt 1;
    [Int 1; Plus; Int 41; EOF] --> EPlus (EInt 1, EInt 41);
    [Int 1; Star; Int 41; EOF] --> EMult (EInt 1, EInt 41);
    (lexer "1 + 2 * 3")        --> EPlus (EInt 1, EMult (EInt 2, EInt 3));
    (lexer "1 * 2 + 3")        --> EPlus (EMult (EInt 1, EInt 2), EInt 3);
    (lexer "sum (x, 1, 2, x * x)")
     --> ESum ("x", EInt 1, EInt 2, EMult (EVar "x", EVar "x"))
  ];

  (* Tests négatifs. *)

  (* Une valeur bidon de type [e]. *)
  let fail = EInt (-42) in

  List.iter (do_test invalid display_tokens parse) [
    [EOF]                         --> fail;
    (lexer "1 + 2 *")             --> fail;
    (lexer "1 * (2)) + 3")        --> fail;
    (lexer "sum (x, 1, 2, x * x") --> fail
  ]

(* Exercices de programmation

   Étendre l'analyse syntaxique pour intégrer
   la division et la soustraction. Comment reconnaissez-vous
   2 - 3 - 4 ? Comme "(2 - 3) - 4", ce qui est correct ou
   plutôt comme "2 - (3 - 4)", ce qui est incorrect ?
*)

(* Un interprète produit récursivement la valeur entière correspondante à
   l'évaluation d'un arbre de syntaxe. *)
let interpret : e -> int =
  (* Le paramètre [env] est une liste associative
     contenant la valeur associée aux indices de
     sommation.

     La fonction d'évaluation est définie par
     cas sur la forme de l'arbre. *)
  let rec aux env = function
    (* Pour évaluer une expression de la forme "e1 + e2",
       on évalue [e1] en un entier, on évalue [e2] en
       un autre entier, puis on fait la somme des deux
       entiers. *)
    | EPlus (e1, e2) -> aux env e1 + aux env e2

    (* Même raisonnement pour la multiplication. *)
    | EMult (e1, e2) -> aux env e1 * aux env e2

    (* Une expression qui est un entier s'évalue en cet entier. *)
    | EInt x -> x

    (* Pour évaluer une expression de la forme
        "sum (x, start, stop, body)". *)
    | ESum (x, start, stop, body) ->
       (* On évalue [start]. *)
       let vstart = aux env start
       (* On évalue [stop]. *)
       and vstop = aux env stop
       in
       (* On itère sur toutes les valeurs [i] de
          [start] à [stop] et on accumule les sommes
          intermédiaires dans la variable [accu]. *)
       let rec iter i accu =
         if i > vstop then
           accu
         else
           (* L'évaluation de [body] se fait dans un
              environnement où l'indice [x] est associé
              à la valeur [i]. *)
           iter (i + 1) (accu + aux ((x, i) :: env) body)
       in
       iter vstart 0

    (* Une expression qui est variable s'évalue en la valeur
       associée à cette variable dans l'environnement. *)
    | EVar x ->
       List.assoc x env
  in
  aux []

(* En rejoignant toutes les composantes, on obtient une boucle interactive qui
   utilise notre interprète pour évaluer le programme Marthe. *)
let interactive_loop () =
  loop
    (fun () -> read lexer parse)
    interpret
    (fun x -> Printf.printf ":- %d\n" x)

let eval s = interpret (parse (lexer s))

(* Test de l'interprète. *)
let test_interpreter () =
  Printf.printf "-*- Interpreter -*-\n";

  (* Tests positifs. *)
  List.iter (do_test valid (fun x -> x) eval) [
    "1"                         --> 1;
    "1 + 1"             --> 2;
    "6 * 7"             --> 42;
    "1 + 2 * 3"         --> 7;
    "sum (i, 1, 10, i)" --> 55;
    "sum (i, 1, 10, sum (j, 1, i, i * j))"
    --> 1705
  ];

  (* Tests négatifs. *)
  let fail = 42 in

  List.iter (do_test invalid (fun x -> x) eval) [
    "i"                  --> fail;
    "sum (i, 1, 10, j)"  --> fail
  ]


(* Exercice de programmation

   Étendre l'interprète pour traiter la division et la soustraction.
*)

(* Nous allons maintenant définir une compilation des programmes
   marthe vers la machine suivante : *)
type machine = {
  (* Le pointeur de code courant. *)
  mutable pc    : int;
  (* Le code est une liste d'instructions. *)
  code          : instruction array;
  (* Des emplacements mémoires pour un nombre borné de variables. *)
  variables     : int array;
  (* Des accumulateurs pour sommer en itérant sur ces variables. *)
  accumulators  : int array;
  (* Une pile d'entiers pour stocker les valeurs intermédiaires. *)
  mutable sp    : int;
  stack         : int array;
}

and instruction =
  (* Pousse une valeur entière sur la pile. *)
  | Push of int
  (* Dépile la valeur au sommet de la pile. *)
  | Pop
  (* Dépile deux valeurs et empile leur somme. *)
  | Add
  (* Dépile deux valeurs et empile leur produit. *)
  | Mul
  (* Met l'accumulateur numéro x à zéro. *)
  | ResetAccu of int
  (* Pousse l'accumulateur numéro x au sommet de la pile. *)
  | PushAccu of int
  (* Augmente l'accumulateur numéro x de la valeur sur la pile. *)
  | AddAccu of int
  (* Pousse la valeur de la variable x sur pile. *)
  | GetVar of int
  (* Affecte la valeur au sommet de la pile à la variable numéro x. *)
  | SetVar of int
  (* Incrémente à la variable x. *)
  | IncVar of int
  (* L'instruction [JumpLe (x, a)] déplace le pointeur de code en a si la valeur
     de la variable x est inférieure ou égale à celle présente au sommet de la
     pile. *)
  | JumpLe of int * int
  (* Arrête la machine et renvoie l'entier au sommet de la pile. *)
  | Halt

(* Initialisation d'une machine abstraite. *)
let vm_init stack_size nb_variables code : machine = {
  pc                   = 0;
  sp                   = -1;
  code                 = code;
  variables            = Array.make nb_variables 0;
  accumulators         = Array.make nb_variables 0;
  stack                = Array.make stack_size 0;
}

(* Cette exception sera lancée pour interrompre le
    calcul. *)
exception Exit of int

(* Interprète le code d'une machine en un entier
    (si le code est correct et ne dépasse pas les capacités
    de la machine, en termes de nombre de variables et de
    profondeur de pile). *)
let vm_interpret : machine -> int =
  fun vm ->
    (* Les opérations standards sur les piles. *)
    let top () = vm.stack.(vm.sp) in
    let pop () = let x = top () in vm.sp <- vm.sp - 1; x in
    let push x = vm.sp <- vm.sp + 1; vm.stack.(vm.sp) <- x in

    let interpret_instruction = function
      | Push x ->
        push x
      | Pop ->
        vm.sp <- vm.sp - 1
      | Add ->
        (* Notez l'optimisation: on travaille en place sur la pile. *)
        vm.stack.(vm.sp - 1) <- vm.stack.(vm.sp - 1) + vm.stack.(vm.sp);
        vm.sp <- vm.sp - 1
      | Mul ->
        vm.stack.(vm.sp - 1) <- vm.stack.(vm.sp - 1) * vm.stack.(vm.sp);
        vm.sp <- vm.sp - 1
      | ResetAccu x ->
        vm.accumulators.(x) <- 0
      | PushAccu x ->
        push vm.accumulators.(x)
      | AddAccu x ->
        vm.accumulators.(x) <- vm.accumulators.(x) + pop ()
      | IncVar x ->
        vm.variables.(x) <- vm.variables.(x) + 1
      | SetVar x ->
        vm.variables.(x) <- pop ()
      | GetVar x ->
        push vm.variables.(x)
      | JumpLe (x, a) ->
        if vm.variables.(x) <= top () then vm.pc <- a - 1
      | Halt ->
        raise (Exit (pop ()))
    in
    try
      while true do
        interpret_instruction (vm.code.(vm.pc));
        vm.pc <- vm.pc + 1
      done;
      (* On peut sortir de la boucle précédente uniquement
         si son corps lance une exception. On ne peut donc
         pas atteindre le point de code suivant. Cette branche
         est du code mort. *)
      assert false
    with Exit x -> x

(* Voici une fonction de compilation des arbres de syntaxe
   abstraite vers un code pour la machine précédente. *)
let compile : e -> instruction array =
  fun e ->
  (* [nb_idx] est le dernier indice utilisé pour nommer les variables de
     sommation.

     [variable_idx] est une liste associative des noms de variable du code
     source vers leurs indices associés.

     [pos] est la position courante dans le code machine produit.

     La fonction de compilation fait un parcours en profondeur de l'arbre de
     syntaxe abstraite et pour chaque sous-arbre A produit un code machine C tel
     que l'évaluation de C place le résultat de l'évaluation du sous-arbre A au
     sommet de la pile de la machine, sans modifier celle-ci autrement.

    *)
    let rec aux nb_idx variable_idx pos = function
      | EInt x ->
        (pos + 1, [ Push x ])

      | EPlus (e1, e2) ->
        let (pos, instrs_e1) = aux nb_idx variable_idx pos e1 in
        let (pos, instrs_e2) = aux nb_idx variable_idx pos e2 in
        (pos + 1, instrs_e1 @ instrs_e2 @ [ Add ])

      | EMult (e1, e2) ->
        let (pos, instrs_e1) = aux nb_idx variable_idx pos e1 in
        let (pos, instrs_e2) = aux nb_idx variable_idx pos e2 in
        (pos + 1, instrs_e1 @ instrs_e2 @ [ Mul ])

      | ESum (x, start, stop, body) ->
        let variable_idx'       = (x, nb_idx + 1) :: variable_idx in
        let nb_idx'             = nb_idx + 1 in
        let (pos, instrs_start) = aux nb_idx variable_idx pos start in
        let (pos, set_x)        = (pos + 1, [ SetVar nb_idx' ]) in
        let (pos, instrs_stop)  = aux nb_idx variable_idx pos stop in
        let (pos, init_accu)    = (pos + 1, [ ResetAccu nb_idx' ]) in
        let pos_body            = pos in
        let (pos, instrs_body)  = aux nb_idx' variable_idx' pos body in
        (pos + 5,
         instrs_start
         @ set_x
         @ instrs_stop
         @ init_accu
         @ instrs_body
         @ [ AddAccu nb_idx' ]
         @ [ IncVar nb_idx';
             JumpLe (nb_idx', pos_body);
             Pop;
             PushAccu nb_idx' ])

      | EVar x ->
         (pos + 1, [ GetVar (List.assoc x variable_idx) ])
    in
    let (_, code) = aux 0 [] 0 e in
    Array.of_list (code @ [ Halt ])

let lot_of_variables = 128
let stack_size       = 1024

let vm_eval s =
  let vm = vm_init stack_size lot_of_variables (compile (parse (lexer s))) in
  vm_interpret vm

(* Tests du compilateur. *)

let test_compiler () =
  Printf.printf "-*- Compiler -*-\n";

  (* Tests positifs. *)
  let check s = s --> eval s in

  List.iter (do_test valid (fun x -> x) vm_eval) [
    check "1";
    check "1 + 2";
    check "1 + 2 * 3";
    check "sum (x, 1, 10, x + x)";
    check "1 + sum (x, 10 * 10, 10 * 10 * 10, x * sum (i, x, 2 * x, i + x))"
  ]

(* Exercice de programmation

   Étendre la machine et la fonction de compilation pour traiter la division et
   la soustraction.
*)

let benchmark_interactive_loop () =
  let time f =
    let start = Unix.gettimeofday () in
    let y = f () in
    let stop = Unix.gettimeofday () in
    (stop -. start, y)
  in
  let eval e =
    let (interpreted_time, x) = time (fun () -> interpret e) in
    let vm = vm_init stack_size lot_of_variables (compile e) in
    let (compiled_time, y) = time (fun () -> vm_interpret vm) in
    (interpreted_time, compiled_time, x, y)
  in
  let print (interpreted_time, compiled_time, x, y) =
    Printf.printf "(Interpreted: %f, Compiled: %f) :- %d\n"
      interpreted_time compiled_time x;
    if x <> y then Printf.printf "Warning: VM found %d\n" y
  in
  loop (fun () -> read lexer parse) eval print

let test_suite () =
  test_lexer  ();
  test_parser ();
  test_interpreter ();
  test_compiler ()

let batch () =
  Printf.printf "%d\n" (interpret (read lexer parse))

let batch_mode = ref false

let _ =
  Arg.parse (Arg.align [
    "-bench", Arg.Unit benchmark_interactive_loop,
    " Launch a toplevel that uses several evaluation strategies.";
    "--", Arg.Set batch_mode, " Only interpret stdin.";
    "-test", Arg.Unit test_suite,
    " Launch the test suite of the program."
  ]) ignore ("marthe [options]");
  if !batch_mode then
    batch ()
  else
    interactive_loop ()