Author: Christian.Queinnec@lip6.fr

## Exercises

### Creation of a Toplevel and Standalone Executable

Consider again the Basic interpreter. Modify it to make a new toplevel.

1. Split the Basic application into 4 files, each with the extension `.ml`. The files will be organized like this: abstract syntax (`syntax.ml`), printing (`pprint.ml`), parsing (`alexsynt.ml`) and evaluation of instructions (`eval.ml`). The head of each file should contain the open statements to load the modules required for compilation.
   `syntax.ml` :

       type op_unr = OPPOSE | NON  ;;

       type op_bin = PLUS | MINUS | MULT | DIV | MOD
                   | EQUAL | INF | INFEQ | SUP | SUPEQ | DIFF
                   | AND | OR  ;;

       type expression =
           ExpInt of int
         | ExpVar of string
         | ExpStr of string
         | ExpUnr of op_unr * expression
         | ExpBin of expression * op_bin * expression  ;;

       type instruction =
           Rem of string
         | Goto of int
         | Print of expression
         | Input of string
         | If of expression * int
         | Let of string * expression  ;;

       type line = { num : int ; inst : instruction }  ;;

       type program = line list  ;;

       type phrase =  Line of line | List | Run | End  ;;

       let priority_ou = function NON -> 1 | OPPOSE -> 7
       let priority_ob = function
           MULT | DIV  -> 6
         | PLUS | MINUS -> 5
         | MOD -> 4
         | EQUAL | INF | INFEQ | SUP | SUPEQ | DIFF -> 3
         | AND | OR -> 2 ;;

       let pp_opbin = function
           PLUS -> "+" | MULT -> "*" | MOD   -> "%" | MINUS -> "-"
         | DIV -> "/"  | EQUAL -> " = " | INF -> " < "
         | INFEQ -> " <= "   | SUP   -> " > "
         | SUPEQ -> " >= "   | DIFF  -> " <> " | AND -> " & " | OR -> " | "
       let pp_opunr = function OPPOSE -> "-"  | NON -> "!"  ;;

   `pprint.ml` :

       open Syntax;;

       let parenthesis x = "(" ^ x ^ ")";;

       let pp_expression =
        let rec ppg pr = function
             ExpInt n -> (string_of_int n)
           | ExpVar v -> v
           | ExpStr s -> "\"" ^ s ^ "\""
           | ExpUnr (op,e) ->
               let res = (pp_opunr op)^(ppg (priority_ou op) e)
               in if pr=0 then res else parenthesis res
           | ExpBin (e1,op,e2) ->
               let pr2 = priority_ob op
               in let res = (ppg pr2 e1)^(pp_opbin op)^(ppd pr2 e2)
               (* parenthesis if the priority is not higher *)
               in if pr2 >= pr then res else parenthesis res
         and ppd pr exp = match exp with

           (*  the sub-trees could only be different *)
           (*  in their binary operators             *)
             ExpBin (e1,op,e2) ->
               let pr2 = priority_ob op
               in let res = (ppg pr2 e1)^(pp_opbin op)^(ppd pr2 e2)
               in if pr2 > pr then res else parenthesis res
           | _ -> ppg pr exp
         in ppg 0 ;;

       let pp_instruction = function
           Rem s     ->  "REM " ^ s
         | Goto n    ->  "GOTO " ^ (string_of_int n)
         | Print e   ->  "PRINT " ^ (pp_expression e)
         | Input v   ->  "INPUT " ^ v
         | If (e,n)  ->  "IF "^(pp_expression e)^" THEN "^(string_of_int n)
         | Let (v,e) ->  "LET " ^ v ^ " = " ^ (pp_expression e)  ;;

       let pp_line l = (string_of_int l.num) ^ "  " ^ (pp_instruction l.inst)  ;;

   `alexsynt.ml` :

       open Syntax;;

       type lexeme = Lint of int
                   | Lident of string
                   | Lsymbol of string
                   | Lstring of string
                   | Lfin ;;

       type str_lexer = {str:string; mutable position:int; size:int } ;;

       let init_lex s = { str=s; position=0 ; size=String.length s } ;;

       let advance cl = cl.position <- cl.position+1  ;;

       let advance_n cl n = cl.position <- cl.position+n ;;

       let extract pred cl =
         let st = cl.str and ct = cl.position in
         let rec ext n = if n<cl.size && (pred st.[n]) then ext (n+1) else n in
         let res = ext ct
         in cl.position <- res ; String.sub cl.str ct (res-ct)  ;;

       let extract_int =
          let is_integer = function '0'..'9' -> true | _ -> false
          in function cl -> int_of_string (extract is_integer cl)
       let extract_ident =
          let is_alpha_num = function
            'a'..'z' | 'A'..'Z' | '0' .. '9' | '_' -> true
          | _ -> false
          in extract is_alpha_num ;;

       exception LexerError ;;

       let  rec lexer cl =
         let lexer_char c = match c with
             ' '
           | '\t'     -> advance cl ; lexer cl
           | 'a'..'z'
           | 'A'..'Z' -> Lident (extract_ident cl)
           | '0'..'9' -> Lint (extract_int cl)
           | '"'      -> advance cl ;
                         let res = Lstring (extract ((<>) '"') cl)
                         in advance cl ; res
           | '+' | '-' | '*' | '/' | '%' | '&' | '|' | '!' | '=' | '(' | ')'  ->
                         advance cl; Lsymbol (String.make 1 c)
           | '<'
           | '>'      -> advance cl;
                         if cl.position >= cl.size then Lsymbol (String.make 1 c)
                         else  let cs = cl.str.[cl.position]
                               in ( match (c,cs) with
                                      ('<','=') -> advance cl; Lsymbol "<="
                                          | ('>','=') -> advance cl; Lsymbol ">="
                                    | ('<','>') -> advance cl; Lsymbol "<>"
                                    |     _     -> Lsymbol (String.make 1 c) )
           | _ -> raise LexerError
         in
            if cl.position >= cl.size then Lfin
            else lexer_char cl.str.[cl.position] ;;

       type exp_elem =
           Texp of expression   (* expression         *)
         | Tbin of op_bin       (* binary operator    *)
         | Tunr of op_unr       (* unary operator     *)
         | Tpg                  (* right parenthesis  *) ;;

       exception ParseError ;;

       let symb_unr = function
         "!" -> NON | "-" -> OPPOSE | _ -> raise ParseError
       let symb_bin = function
           "+" -> PLUS | "-" -> MINUS | "*" -> MULT | "/" -> DIV | "%" -> MOD
         | "=" -> EQUAL | "<" -> INF | "<=" -> INFEQ | ">" -> SUP
         | ">=" -> SUPEQ | "<>" -> DIFF | "&" -> AND | "|" -> OR
         | _ -> raise ParseError
       let tsymb s = try Tbin (symb_bin s) with ParseError -> Tunr (symb_unr s) ;;

       let reduce pr = function
           (Texp e)::(Tunr op)::st  when  (priority_ou op) >= pr
              -> (Texp (ExpUnr (op,e)))::st
         | (Texp e1)::(Tbin op)::(Texp e2)::st  when  (priority_ob op) >= pr
              -> (Texp (ExpBin (e2,op,e1)))::st
         | _ -> raise ParseError ;;

       let rec pile_or_reduce lex stack = match lex , stack with
           Lint n ,  _      ->  (Texp (ExpInt n))::stack
         | Lident v ,  _    ->  (Texp (ExpVar v))::stack
         | Lstring s , _    ->  (Texp (ExpStr s))::stack
         | Lsymbol "(" , _  ->  Tpg::stack
         | Lsymbol ")" , (Texp e)::Tpg::st  ->  (Texp e)::st
         | Lsymbol ")" , _ -> pile_or_reduce lex (reduce 0 stack)
         | Lsymbol s , _
              -> let symbole =
                   if s<>"-" then tsymb s
                   (* resolve the ambiguity of the symbol ``-''   *)
                   (* follow the stack (i.e last exp_elem pile)  *)
                   else match stack
                        with (Texp _)::_  ->  Tbin MINUS
                                      | _ ->  Tunr OPPOSE
                 in ( match symbole with
                        Tunr op  ->  (Tunr op)::stack
                      | Tbin op  ->
                          ( try pile_or_reduce lex (reduce (priority_ob op)
                                                     stack )
                            with ParseError -> (Tbin op)::stack )
                      | _ -> raise ParseError )
         | _ , _ -> raise ParseError ;;

       let rec reduce_all = function
         | [] -> raise ParseError
         | [Texp x] -> x
         | st -> reduce_all (reduce 0 st) ;;

       let parse_exp fin cl =
         let p = ref 0
         in let rec parse_un stack  =
              let l = ( p:=cl.position ; lexer cl)
               in if not (fin l) then parse_un (pile_or_reduce l stack)
                  else ( cl.position <- !p ; reduce_all stack )
         in parse_un []  ;;

       let parse_inst cl = match lexer cl with
           Lident s -> ( match s with
               "REM" -> Rem (extract (fun _ -> true) cl)
             | "GOTO" -> Goto (match lexer cl with
                                 Lint p -> p
                               | _ -> raise ParseError)
             | "INPUT" -> Input (match lexer cl with
                                   Lident v -> v
                                 | _ -> raise ParseError)
             | "PRINT" -> Print (parse_exp ((=) Lfin) cl)
             | "LET" ->
                 let l2 = lexer cl and l3 = lexer cl
                 in ( match l2 ,l3 with
                          (Lident v,Lsymbol "=") -> Let (v,parse_exp ((=) Lfin) cl)
                        | _ -> raise ParseError )
             | "IF" ->
                 let test = parse_exp ((=) (Lident "THEN")) cl
                 in ( match ignore (lexer cl) ; lexer cl with
                         Lint n  ->  If (test,n)
                       | _ -> raise ParseError )
             | _ -> raise ParseError )
         | _ -> raise ParseError  ;;

       let parse str =
         let cl = init_lex str
         in match lexer cl with
             Lint n -> Line { num=n ; inst=parse_inst cl }
           | Lident "LIST" -> List
           | Lident "RUN" -> Run
           | Lident "END" -> End
           | _ -> raise ParseError  ;;

   `eval.ml` :

       open Syntax;;
       open Pprint;;
       open Alexsynt;;

       type vl = Vint of int | Vstr of string | Vbool of bool  ;;

       type environment = (string * vl) list ;;

       type state = { line:int ; prog:program ; env:environment } ;;

       exception RunError of int
       let runerr n = raise (RunError n) ;;

       let rec eval_exp n envt expr = match expr with
           ExpInt p  ->  Vint p
         | ExpVar v  -> ( try List.assoc v envt with Not_found -> runerr n )
         | ExpUnr (OPPOSE,e) ->
             ( match eval_exp n envt e with
                 Vint p -> Vint (-p)
               | _ -> runerr n )
         | ExpUnr (NON,e) ->
             ( match eval_exp n envt e with
                 Vbool p -> Vbool (not p)
               | _ -> runerr n )
         | ExpStr s -> Vstr s
         | ExpBin (e1,op,e2)
             -> match eval_exp n envt e1 , op , eval_exp n envt e2 with
                     Vint v1 , PLUS  , Vint v2  ->  Vint (v1 + v2)
                   | Vint v1 , MINUS , Vint v2  ->  Vint (v1 - v2)
                   | Vint v1 , MULT  , Vint v2  ->  Vint (v1 * v2)
                   | Vint v1 ,  DIV  , Vint v2  when v2<>0 ->  Vint (v1 / v2)
                   | Vint v1 ,  MOD  , Vint v2  when v2<>0 ->  Vint (v1 mod v2)

                   | Vint v1 , EQUAL  , Vint v2  ->  Vbool (v1 = v2)
                   | Vint v1 , DIFF  , Vint v2  ->  Vbool (v1 <> v2)
                   | Vint v1 ,  INF  , Vint v2  ->  Vbool (v1 < v2)
                   | Vint v1 ,  SUP  , Vint v2  ->  Vbool (v1 > v2)
                   | Vint v1 , INFEQ , Vint v2  ->  Vbool (v1 <= v2)
                   | Vint v1 , SUPEQ , Vint v2  ->  Vbool (v1 >= v2)

                   | Vbool v1 , AND , Vbool v2  ->  Vbool (v1 && v2)
                   | Vbool v1 , OR , Vbool v2  ->  Vbool (v1 || v2)

                   | Vstr v1 , PLUS , Vstr v2 -> Vstr (v1 ^ v2)
                   | _ , _ , _  -> runerr n  ;;

       let rec add v e env = match env with
           [] -> [v,e]
         | (w,f)::l -> if w=v then (v,e)::l else (w,f)::(add v e l) ;;

       let rec goto_line n prog = match prog with
           [] -> runerr n
         | l::ll -> if l.num = n then prog
                    else if l.num<n then goto_line n ll
                    else runerr n ;;

       let print_vl v = match v with
           Vint n -> print_int n
         | Vbool true -> print_string "true"
         | Vbool false -> print_string "false"
         | Vstr s -> print_string s ;;

       let eval_inst state =
         let lc, ns =
           match goto_line state.line state.prog with
             [] -> failwith "empty program"
           | lc::[] -> lc,-1
           | lc::ls::_ -> lc,ls.num
         in
           match lc.inst with
             Rem _    ->  { state with line=ns }
           | Print e  ->  print_vl (eval_exp lc.num state.env e) ;
                          print_newline () ;
                          { state with line=ns }
           | Let(v,e) ->  let ev = eval_exp lc.num state.env e
                          in { state with line=ns; env=add v ev state.env }
           | Goto n   ->  { state with line=n }
           | Input v  ->  let x = try read_int ()
                                  with Failure "int_of_string" -> 0
                          in { state with line=ns ; env=add v (Vint x) state.env }
           | If (t,n) ->  match eval_exp lc.num state.env t with
                            Vbool true  -> { state with line=n }
                          | Vbool false -> { state with line=ns }
                          | _ -> runerr n  ;;

       let rec run state =
        if state.line = -1 then state else run (eval_inst state) ;;

       let rec insert line p = match p with
           [] -> [line]
         | l::prog ->
             if l.num < line.num then l::(insert line prog)
             else if l.num=line.num then line::prog
             else line::l::prog ;;

       let print_prog state =
         let print_line x = print_string (pp_line x) ; print_newline ()
         in print_newline () ;
            List.iter print_line state.prog ;
            print_newline () ;;

       let premiere_line = function [] -> 0 | i::_ -> i.num  ;;

       exception Fin
       let one_command state =
         print_string "> " ; flush stdout ;
         try
           match parse (input_line stdin) with
              Line l -> { state with prog=insert l state.prog }
            | List  -> (print_prog state ; state )
            | Run -> run {state with line = premiere_line state.prog}
            | End -> raise Fin
         with
             LexerError -> print_string "Illegal character\n"; state
           | ParseError -> print_string "syntax error\n"; state
           | RunError n ->
               print_string "runtime error at line ";
               print_int n ;
               print_string "\n";
               state ;;

       let go () =
       try
         print_string "Mini-BASIC version 0.1\n\n";
         let rec loop state = loop (one_command state)  in
           loop { line=0; prog=[]; env=[] }
       with Fin -> print_string "A bientôt...\n";;

2. Compile all files separately.

       $ ocamlc -c syntax.ml
       $ ocamlc -c pprint.ml
       $ ocamlc -c alexsynt.ml
       $ ocamlc -c eval.ml

3. Add a file `mainbasic.ml` which contains only the statement for calling the main function.
   `mainbasic.ml` :

       open Eval;;

       go ();;

4. Create a new toplevel with the name `topbasic`, which starts the Basic interpreter.
   création du toplevel :

       $ ocamlmktop -o topbasic syntax.cmo pprint.cmo alexsynt.cmo eval.cmo mainbasic.ml

   test du toplevel :

       $ topbasic
       Mini-BASIC version 0.1

       > 10 PRINT "DONNER UN NOMBRE"
       > 20 INPUT X
       > 30 PRINT X
       > LIST

       10  PRINT "DONNER UN NOMBRE"
       20  INPUT X
       30  PRINT X

       > RUN
       DONNER UN NOMBRE
       44
       44
       > END
       A bientôt...
               Objective Caml version 2.04

       #

5. Create a standalone executable which runs the Basic interpreter.
   compilation et édition de liens :

       $ ocamlc -custom -o basic.exe syntax.cmo pprint.cmo alexsynt.cmo eval.cmo mainbasic.ml

   test de l'exécutable autonome :

       $ basic.exe
       Mini-BASIC version 0.1

       > 10 PRINT "BONJOUR"
       > LIST

       10  PRINT "BONJOUR"

       > RUN
       BONJOUR
       > END
       A bientôt...
       $

### Comparison of Performance

Try to compare the performance of code produced by the bytecode compiler and by the native compiler. For this purpose, write an application for sorting lists and arrays.

1. Write a polymorphic function for sorting lists. The order relation should be passed as an argument to the sort function. The sort algorithm can be selected by the reader. For example: bubble sort, or quick sort. Write this function as `sort.ml`.
   On utilise les fichiers `sort.mli` et `sort.ml` de la distribution qui définissent les fonctions `list` et `array` de tri d'une liste et d'un tableau.
   `sort.mli` :

       (***********************************************************************)
       (*                                                                     *)
       (*                           Objective Caml                            *)
       (*                                                                     *)
       (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
       (*                                                                     *)
       (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
       (*  Automatique.  Distributed only by permission.                      *)
       (*                                                                     *)
       (***********************************************************************)

       (* $Id: sort.mli,v 1.1.1.1 2000/06/26 14:37:50 xleroy Exp $ *)

       (* Module [Sort]: sorting and merging lists *)

       val list : ('a -> 'a -> bool) -> 'a list -> 'a list
               (* Sort a list in increasing order according to an ordering predicate.
                  The predicate should return [true] if its first argument is
                  less than or equal to its second argument. *)

       val array : ('a -> 'a -> bool) -> 'a array -> unit
               (* Sort an array in increasing order according to an
                  ordering predicate.
                  The predicate should return [true] if its first argument is
                  less than or equal to its second argument.
                  The array is sorted in place. *)

       val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
               (* Merge two lists according to the given predicate.
                  Assuming the two argument lists are sorted according to the
                  predicate, [merge] returns a sorted list containing the elements
                  from the two lists. The behavior is undefined if the two
                  argument lists were not sorted. *)

   `sort.ml`

       (***********************************************************************)
       (*                                                                     *)
       (*                           Objective Caml                            *)
       (*                                                                     *)
       (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
       (*                                                                     *)
       (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
       (*  Automatique.  Distributed only by permission.                      *)
       (*                                                                     *)
       (***********************************************************************)

       (* $Id: sort.ml,v 1.1.1.1 2000/06/26 14:37:50 xleroy Exp $ *)

       (* Merging and sorting *)

       open Array

       let rec merge order l1 l2 =
         match l1 with
           [] -> l2
         | h1 :: t1 ->
             match l2 with
               [] -> l1
             | h2 :: t2 ->
                 if order h1 h2
                 then h1 :: merge order t1 l2
                 else h2 :: merge order l1 t2

       let list order l =
         let rec initlist = function
             [] -> []
           | [e] -> [[e]]
           | e1::e2::rest ->
               (if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in
         let rec merge2 = function
             l1::l2::rest -> merge order l1 l2 :: merge2 rest
           | x -> x in
         let rec mergeall = function
             [] -> []
           | [l] -> l
           | llist -> mergeall (merge2 llist) in
         mergeall(initlist l)

       let swap arr i j =
         let tmp = unsafe_get arr i in
         unsafe_set arr i (unsafe_get arr j);
         unsafe_set arr j tmp

       let array order arr =
         let rec qsort lo hi =
           if hi <= lo then ()
           else if hi - lo < 5 then begin
             (* Use insertion sort *)
             for i = lo + 1 to hi do
               let val_i = unsafe_get arr i in
               if order val_i (unsafe_get arr (i - 1)) then begin
                 unsafe_set arr i (unsafe_get arr (i - 1));
                 let j = ref (i - 1) in
                 while !j >= 1 && order val_i (unsafe_get arr (!j - 1)) do
                   unsafe_set arr !j (unsafe_get arr (!j - 1));
                   decr j
                 done;
                 unsafe_set arr !j val_i
               end
             done
           end else begin
             let mid = (lo + hi) lsr 1 in
             (* Select median value from among LO, MID, and HI *)
             let pivotpos =
               let vlo = unsafe_get arr lo
               and vhi = unsafe_get arr hi
               and vmid = unsafe_get arr mid in
               if order vlo vmid then
                 if order vmid vhi then mid
                 else if order vlo vhi then hi else lo
               else
                 if order vhi vmid then mid
                 else if order vhi vlo then hi else lo in
             swap arr pivotpos hi;
             let pivot = unsafe_get arr hi in
             let i = ref lo and j = ref hi in
             while !i < !j do
               while !i < hi && order (unsafe_get arr !i) pivot do incr i done;
               while !j > lo && order pivot (unsafe_get arr !j) do decr j done;
               if !i < !j then swap arr !i !j
             done;
             swap arr !i hi;
             (* Recurse on larger half first *)
             if (!i - 1) - lo >= hi - (!i + 1) then begin
               qsort lo (!i - 1); qsort (!i + 1) hi
             end else begin
               qsort (!i + 1) hi; qsort lo (!i - 1)
             end
           end in
         qsort 0 (Array.length arr - 1)

2. Create the main function in the file `trilist.ml`, which uses the previous function and applies it to a list of integers by sorting it in increasing order, then in decreasing order.
   `interval.ml` :

       let interval order next a b =
         let rec aux a =
           if not (order a b) then [a] else  a :: aux  (next a)
         in aux a;;

   `trilist.ml` :

       let main () =
         let il = Interval.interval (>) (fun x -> x -1) 50000 20
         and il2 = Interval.interval (<) (fun x -> x + 1) 20 50000  in
           Sort.list (<) il, Sort.list (>) il2;;

       main();;

3. Create two standalone executables - one with the bytecode compiler, and another with the native compiler. Measure the execution time of these two programs. Choose lists of sufficient size to get a good idea of the time differences.
   1. code-octet (Unix) : trilbyte.exe

          ocamlc -custom -o trilbyte.exe sort.mli sort.ml interval.ml trilist.ml

   2. natif (Unix) : trilopt.exe

          ocamlopt -o trilopt.exe sort.mli sort.ml interval.ml trilist.ml

   Performances :

   trilbyte.exe | trilopt.exe
   2,55 secondes (user) | 1,67 secondes (user)

   Le rapport trilopt.exe / trilbyte.exe est de 2/3.
4. Rewrite the sort program for arrays. Continue using an order function as argument. Perform the test on arrays filled in the same manner as for the lists.
   `triarray.ml` :

       let main () =
         let il = Array.of_list(Interval.interval (>) (fun x -> x -1) 50000 20)
         and il2 = Array.of_list(Interval.interval (<) (fun x -> x + 1) 20 50000)  in
           Sort.array (<) il, Sort.array (>) il2;;

       main();;

   1. code-octet (Unix) : triabyte.exe

          ocamlc -custom -o triabyte.exe sort.mli sort.ml interval.ml triarray.ml

   2. natif (Unix) : triaopt.exe

          ocamlopt -o triaoptu.exe sort.mli sort.ml interval.ml triarray.ml

   Performances :

   triabyte.exe | triaopt.exe
   515 s | 106 s

   Le rapport triaopt.exe / triabyte.exe est de 1/5.
5. What can we say about the results of these tests?
   Le compilateur natif apporte un gain de temps d'exécution variable ( facteur 2/3 pour les liste et 1/5 pour les tableaux).