git.kianting.info Git - uann/blob - ocaml_yacc/calc.ml

   1 exception Exc of string
   2
   3 (* File calc.ml *)
   4 let rec ast_to_string ast = match ast with
   5 | Ast.Leaf s -> s
   6 | Ast.Int i -> string_of_int i
   7 | Ast.Node ls -> "[" ^ String.concat " " (List.map ast_to_string ls) ^ "]"
   8 ;;
   9
  10 (**environment for the interpreter*)
  11 class environment =
  12     object (self)
  13       val mutable tbl : (string, int) Hashtbl.t = Hashtbl.create 10
  14       method add_val key data = Hashtbl.add tbl key data
  15       method get_val key = Hashtbl.find tbl key
  16           method get_tbl = tbl
  17     end;;
  18
  19
  20
  21
  22 (** interpreter for interp_int*)
  23 class interp_int =
  24     object (self)
  25       method interp (env : environment) code = match code with
  26                 | Ast.Int x -> x
  27                 | Ast.Node [Ast.Leaf "+"; lhs; rhs] ->
  28                         let x1 = self#interp env lhs in
  29                         let x2 = self#interp env rhs in
  30                         x1+x2
  31                 | Ast.Node [Ast.Leaf "-"; lhs; rhs] ->
  32                         let x1 = self#interp env lhs in
  33                         let x2 = self#interp env rhs in
  34                         x1-x2
  35                 | Ast.Node [Ast.Leaf "-"; x] ->
  36                         let x1 = self#interp env x in
  37                         0-x1
  38                 | Ast.Node [Ast.Leaf "%apply" ; Ast.Leaf "read"; Ast.Int 0] ->
  39                         let input = read_int_opt () in
  40                         match input with
  41                         | Some(y) -> y
  42                         | _ -> raise (Exc "input invalid number")
  43                 | _ -> raise (Exc "unsupported")
  44     end;;
  45
  46 (** interpreter for interp_var*)
  47 class interp_var =
  48         object (self)
  49       inherit interp_int as super
  50                 method interp (env : environment) code = match code with
  51                         | Ast.Leaf var -> env#get_val var
  52                         | Ast.Node [Ast.Leaf "%let"; Ast.Node[typ; Ast.Leaf var; data]; body] ->
  53                                 let new_val = self#interp env data in
  54                                 let _ = env#add_val var new_val in
  55                                 self#interp env body
  56
  57                         | _ -> super#interp env code
  58 end;;
  59
  60 let prime_op = ["+"; "-"];;
  61
  62 (** PASS1 : uniquify the variable*)
  63 let rec uniquify_var_pass ast (tbl : (string, int) Hashtbl.t) = match ast with
  64         | Ast.Int x -> ast
  65         | Ast.Leaf var -> Ast.Leaf (var ^ "." ^ (string_of_int(Hashtbl.find tbl var)))
  66         | Ast.Node [Ast.Leaf "-" ; x] ->  Ast.Node [Ast.Leaf "-"; uniquify_var_pass x tbl]
  67
  68
  69         | Ast.Node [Ast.Leaf "%let"; Ast.Node[typ; Ast.Leaf var; data]; body] ->
  70                 let _ = if not(Hashtbl.mem tbl var) then
  71                                 (Hashtbl.add tbl var 0) else
  72                                 Hashtbl.replace tbl var ((Hashtbl.find tbl var)+1) in
  73                 let new_var = Ast.Leaf (var ^ "." ^(string_of_int(Hashtbl.find tbl var))) in
  74                 let rhs = uniquify_var_pass data tbl in
  75                 Ast.Node [Ast.Leaf "%let"; Ast.Node[typ; new_var; rhs];
  76         uniquify_var_pass body tbl]
  77         | Ast.Node [Ast.Leaf op ; lhs; rhs] -> if List.mem op prime_op  then
  78                                                                                                         Ast.Node [Ast.Leaf op ;
  79                                                                                                         uniquify_var_pass lhs tbl;
  80                                                                                                         uniquify_var_pass rhs tbl] else
  81                                                                                                         Ast.Node [uniquify_var_pass (Ast.Leaf op) tbl;
  82                                                                                                         uniquify_var_pass lhs tbl;
  83                                                                                                         uniquify_var_pass rhs tbl]
  84         | _ -> ast
  85
  86
  87
  88 (**main body*)
  89         let _ =
  90           try
  91             let lexbuf = Lexing.from_channel stdin in
  92                         let env = new environment in
  93                         let interp = new interp_var in
  94             while true do
  95                           let hasht = (Hashtbl.create 10) in
  96               let result = Parser.main Lexer.token lexbuf in
  97                           let result2 = uniquify_var_pass result hasht in
  98                                 Printf.printf "%s\n" (ast_to_string result2);
  99                 Printf.printf "%d" (interp#interp env result2); print_newline(); flush stdout
 100             done
 101           with Lexer.Eof ->
 102             exit 0
 103
 104