Source file fsm_expr.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
(**********************************************************************)
(*                                                                    *)
(*                              LASCAr                                *)
(*                                                                    *)
(*  Copyright (c) 2017-present, Jocelyn SEROT.  All rights reserved.  *)
(*                                                                    *)
(*  This source code is licensed under the license found in the       *)
(*  LICENSE file in the root directory of this source tree.           *)
(*                                                                    *)
(**********************************************************************)

type ident = string 

type value = int 

type t = 
  EConst of value            (** Constants *)   
| EVar of ident              (** Input, output or local variable *)
| EBinop of string * t * t   (** Binary operation *)

type env = (ident * value option) list

exception Unknown of ident
exception Unbound of ident
exception Illegal_expr

let lookup env id = 
  try
    match List.assoc id env with
      Some v -> v
    | None -> raise (Unbound id)
  with 
    Not_found -> raise (Unknown id)

let binary_ops = [
    "+", ( + );
    "-", ( - );
    "*", ( * );
    "/", ( / );
  ]

let test_ops = [  (* TO FIX : should only be in [Fsm], not here, but this complicates the lexer defns *)
    "=", ( = );
    "!=", ( <> );
    "<", ( < );
    ">", ( > );
    "<=", ( <= );
    ">=", ( >= )
  ]

let binary_op op = 
  try List.assoc op binary_ops
  with Not_found -> raise (Unknown op)

let rec eval env exp = 
  match exp with
    EConst v -> v
  | EVar id -> lookup env id 
  | EBinop (op, exp1, exp2) -> binary_op op (eval env exp1) (eval env exp2)

(* let subst_vars vars exp =
 *   let rec subst e = match e with
 *       EConst _ -> e
 *     | EVar v -> if List.mem_assoc v vars then EConst (List.assoc v vars) else e
 *     | EBinop (op, exp1, exp2) -> EBinop (op, subst exp1, subst exp2) in
 *   subst exp *)

(* Parsing *)

(* BNF :
   <exp>  ::= INT
   | ID
   | <exp> <op> <exp>
   | '(' <exp> ')' <int>
   <op>    ::= '+' | '-' | '*' | '/'
 *)

let keywords = List.map fst binary_ops @ List.map fst test_ops @ [":="; "("; ")"; ";"]

let mk_binary_minus s = s |> String.split_on_char '-' |> String.concat " - "
                      
let lexer s = s |> mk_binary_minus |> Stream.of_string |> Genlex.make_lexer keywords 

open Genlex
   
let rec p_exp0 s =
  match Stream.next s with
    | Int n -> EConst n
    | Ident i -> EVar i
    | Kwd "(" ->
       let e = p_exp s in
       begin match Stream.peek s with
       | Some (Kwd ")") -> Stream.junk s; e
       | _ -> raise Stream.Failure
       end
    | _ -> raise Stream.Failure

and p_exp1 s =
  let e1 = p_exp0 s in
  p_exp2 e1 s
  
and p_exp2 e1 s =
  match Stream.peek s with
  | Some (Kwd "*") -> Stream.junk s; let e2 = p_exp1 s in EBinop("*", e1, e2)
  | Some (Kwd "/") -> Stream.junk s; let e2 = p_exp1 s in EBinop("/", e1, e2)
  | _ -> e1
  
and p_exp s =
  let e1 = p_exp1 s in p_exp3 e1 s
                     
and p_exp3 e1 s =
  match Stream.peek s with
  | Some (Kwd "+") -> Stream.junk s; let e2 = p_exp s in EBinop("+", e1, e2)
  | Some (Kwd "-") -> Stream.junk s; let e2 = p_exp s in EBinop("-", e1, e2)
  | _ -> e1

let parse = p_exp

let of_string s = s |> lexer |> p_exp

let rec to_string e = match e with
    EConst c -> string_of_int c
  | EVar n ->  n
  | EBinop (op,e1,e2) -> to_string e1 ^ op ^ to_string e2 (* TODO : add parens *)