let s = "(1+23*456+78)*9"

(** Analyse lexicale *)
type token =
    | NUM of int
    | PLUS
    | STAR
    | LPAR
    | RPAR


let tokenize (s: string): token list =
  let rec lex i =
    if i >= String.length s then
      []
    else
      match s.[i] with
      | '+' -> PLUS :: (lex (i+1))
      | '*' -> STAR :: (lex (i+1))
      | '(' -> LPAR :: (lex (i+1))
      | ')' -> RPAR :: (lex (i+1))
      | ' ' -> lex (i+1)
      | '0'..'9' -> let n, i' = num 0 i in
                    NUM n :: lex i'
      | c -> failwith (Printf.sprintf "unknown character : %c" c)
  and num n i =
    if i >= String.length s then
      n, i
    else match s.[i] with
      | '0'..'9' as d -> 
        num (10*n + Char.code d - Char.code '0') (i+1)
      | _ -> n, i
  in
  lex 0

let lt = tokenize s

(** Arbre de syntaxe abstraite *)
type expr =
    | Cst of int
    | Add of expr * expr
    | Mul of expr * expr

let e = Add(Cst 1, Mul(Cst 2, Cst 3))

let rec nb_cst = function
    | Cst _ -> 1
    | Add(e1, e2) -> nb_cst e1 + nb_cst e2
    | Mul(e1, e2) -> nb_cst e1 + nb_cst e2

let rec nb_op = function
    | Cst _ -> 0
    | Add(e1, e2) -> 1 + nb_op e1 + nb_op e2
    | Mul(e1, e2) -> 1 + nb_op e1 + nb_op e2

let rec (eval : expr -> int) = function
    | Cst n       -> n
    | Add(e1, e2) -> eval e1 + eval e2
    | Mul(e1, e2) -> eval e1 * eval e2

(* Analyse grammaticale *)
let parse (s: string): expr =
 let rec sy (t: token list * token list * expr list) : expr = 
  match t with
   | ([], [], [e]) -> e

   | (NUM n :: input,  ops        ,  exprs               ) -> 
   sy(input         ,  ops        ,  Cst n :: exprs      )

   | (LPAR  :: input,  ops        ,  exprs               ) -> 
   sy(input         ,  LPAR :: ops,  exprs               )

   | (input         ,  STAR :: ops,  e2 :: e1 :: exprs   ) -> 
   sy(input         ,  ops        ,  Mul(e1, e2) :: exprs)

   | (STAR  :: input,  ops        ,  exprs               ) -> 
   sy(input         ,  STAR :: ops,  exprs               )

   | (input         ,  PLUS :: ops,  e2 :: e1 :: exprs   ) -> 
   sy(input         ,  ops        ,  Add(e1, e2) :: exprs)

   | (PLUS  :: input,  ops        ,  exprs               ) -> 
   sy(input         ,  PLUS :: ops,  exprs               )

   | (RPAR  :: input,  LPAR :: ops,  exprs               ) -> 
   sy(input         ,  ops        ,  exprs               )

   | _ -> failwith "syntax error"
 in
 sy (tokenize s, [], [])
                      
let e1 = parse s

let s' = "1 2 +"
let e2 = parse s'

let rec parse_expr (l:token list) : expr * token list =
  parse_m_expr l |> expand_sum
and expand_sum = function
  | e1, PLUS :: l -> let e2, l' = parse_m_expr l in 
                     expand_sum (Add(e1, e2), l')
  | r -> r
and parse_m_expr (l:token list) : expr * token list = 
  parse_atom l |> expand_prod
and expand_prod = function
  | e1, STAR :: l -> let e2, l' = parse_atom l in 
                     expand_prod (Mul(e1, e2), l')
  | r -> r
and parse_atom = function
  | NUM n :: l -> Cst n, l
  | LPAR :: l -> (match parse_expr l with
      | e, RPAR :: l' -> e, l'
      | _ -> failwith "syntax error")
  | _ -> failwith "syntax error"
           
let e2 = parse_expr lt

let _ = assert (e1 = fst e2)

(* 1.5 analyse grammaticale structurée *)

let rec parse_expr (l:token list) : expr * token list =
  parse_m_expr l |> expand_sum
and expand_sum = function
  | e1, PLUS :: l -> let e2, l' = parse_m_expr l in 
    expand_sum (Add(e1, e2), l')
  | r -> r
and parse_m_expr (l:token list) : expr * token list =
  parse_atom l |> expand_prod
and expand_prod = function
  | e1, STAR :: l -> let e2, l' = parse_atom l in 
    expand_prod (Mul(e1, e2), l')
  | r -> r
and parse_atom = function
  | NUM n :: l -> Cst n, l
  | LPAR :: l -> (match parse_expr l with
      | e, RPAR :: l' -> e, l'
      | _ -> failwith "syntax error")
  | _ -> failwith "syntax error"

let e3 = parse_expr lt

let _ = assert (e2 = e3)

let parse (input: string): expr =
  match tokenize input |> parse_expr with
  | e, [] -> e
  | _ -> failwith "syntax error"

(* 1.6 compilation *)

type instr =
  | ICst of int (* place une constante au sommet de la pile *)
  | IAdd        (* additionne deux valeurs au sommet de la pile *)
  | IMul        (* multiplie deux valeurs au sommet de la pile *)

let exec (code : instr list) : int  =
  let rec ex (p: instr list * int list) : int = match p with
    | ([], v :: stack) -> assert (stack = []); v

    | (ICst n :: code, stack            ) -> 
      ex(code          , n :: stack       )

    | (IAdd :: code  , v2 :: v1 :: stack) ->
      ex(code          , v1+v2 :: stack   )

    | (IMul :: code  , v2 :: v1 :: stack) -> 
      ex(code          , v1*v2 :: stack   )

    | _ -> failwith "empty stack"
  in
  ex(code, [])

let rec codegen : expr -> instr list = function
  | Cst n       -> [ICst n]
  | Add(e1, e2) -> codegen e1 @ codegen e2 @ [IAdd]
  | Mul(e1, e2) -> codegen e1 @ codegen e2 @ [IMul]

let code1  = (codegen e1)
let vc1 = exec code1
let vi1 = eval e1
    

(* 1.7 utilisation d'effets de bord *)

let counter = ref (-1)     (* référence locale *)
let plus1 () = counter := !counter +1  

let next : unit -> int =
  let counter = ref (-1) in         (* variable locale *)
  fun () -> incr counter; !counter  (* fonction associée à next *)

let (n1,n2,n3) =  (next(),next(),next())
let n1=next() in let n2 = next() in let n3=next() in (n1,n2,n3)

(* version incorrecte, nouvelle référence crée à chaque appel *)
let next : unit -> int =
  fun () -> let counter = ref (-1) in         (* variable locale *)
            incr counter; !counter  (* fonction associée à next *)
let (n1,n2,n3) =  (next(),next(),next())
    
(* Le code est ajouté au fur et à mesure dans la référence code *)
                  
let codegen e =
  let code = ref [] in
  let add_instr i = code := i :: !code in

  let rec gen: expr -> unit = function
    | Cst n       -> add_instr (ICst n)
    | Add(e1, e2) -> gen e1; gen e2; add_instr IAdd
    | Mul(e1, e2) -> gen e1; gen e2; add_instr IMul
  in
  gen e;
  List.rev !code

let code2 = codegen e1
let _ = assert (code1=code2)

type token =
  | NUM of int
  | PLUS
  | STAR
  | LPAR
  | RPAR
  | EOI

let tokenizer (s: string): unit -> token =
  let i = ref 0 in
  let rec next_token () =
    if !i >= String.length s then
      EOI
    else
      match s.[!i] with
      | '+' -> incr i; PLUS
      | '*' -> incr i; STAR
      | '(' -> incr i; LPAR
      | ')' -> incr i; RPAR
      | ' ' -> incr i; next_token()
      | '0'..'9' -> NUM (next_num 0)
      | c -> failwith (Printf.sprintf "unknown character : %c" c)
  and next_num n =
    if !i >= String.length s then
      n
    else match s.[!i] with
      | '0'..'9' as d -> 
        incr i; next_num (10*n + Char.code d - Char.code '0')
      | _ -> n
  in
  next_token

let nts = tokenizer s
let t1 =  nts ()
let t2 = nts ()
let t3 = nts ()

let parse (s: string) : expr =
  let next_token = tokenizer s in
  let current_token = ref (next_token()) in
  let next() = current_token := next_token() in

  let rec parse_expr() = parse_m_expr() |> expand_sum
  and expand_sum e = match !current_token with
    | PLUS -> next(); Add(e, parse_m_expr()) |> expand_sum
    | _ -> e
  and parse_m_expr() = parse_atom() |> expand_prod
  and expand_prod e = match !current_token with
    | STAR -> next(); Mul(e, parse_atom()) |> expand_prod
    | _ -> e
  and parse_atom() = match !current_token with
    | NUM n -> next(); Cst n
    | LPAR  -> next(); let e = parse_expr() in
      (match !current_token with
       | RPAR -> next(); e
       | _ -> failwith "syntax error")
    | _ -> failwith "syntax error"
  in
  let e = parse_expr() in
  if !current_token <> EOI then failwith "syntax error";
  e

let e3 = parse s
let _ = assert (e1=e3)

(* exécution du code en cachant la pile *)
let exec code =
  let stack = Stack.create() in

  let open Stack in
  List.iter (function
      | ICst n -> push n stack
      | IAdd   -> let v1, v2 = pop stack, pop stack in 
        push (v1+v2) stack
      | IMul   -> let v1, v2 = pop stack, pop stack in
        push (v1*v2) stack
    ) code;
  let v = pop stack in
  assert (is_empty stack);
  v

let vc2 = exec code1
let _ = assert (vc1 = vc2)

let exec code =
  let stack = Stack.create() in
  List.fold_left (fun v -> function
      | ICst n -> Stack.push v stack; n
      | IAdd   -> Stack.pop stack + v
      | IMul   -> Stack.pop stack * v
    ) 0 code

let vc3 = exec code1
let _ = assert (vc1 = vc2)