diff --git a/ast.ml b/ast.ml index 6a6388e..f7020a0 100644 --- a/ast.ml +++ b/ast.ml @@ -1,27 +1,24 @@ -type _ typ = - | Int : int -> int typ - | Unit : unit typ +type typ = + | Int of int + | Unit -let typ_to_string : type a. a typ -> string = function +let typ_to_string = function | Int n -> Printf.sprintf "%d" n | Unit -> "()" -type (_, _) binop = - | Add : (int, int) binop - | Sub : (int, int) binop - | Mul : (int, int) binop - | Div : (int, int) binop +type binop = + | Add | Sub | Mul | Div -let binop_to_string : type a b. (a, b) binop -> string = function +let binop_to_string = function | Add -> "+" | Sub -> "-" | Mul -> "*" | Div -> "/" -type _ t = - | Value : 'a typ -> 'a t - | Binop : 'a t * ('a, 'b) binop * 'a t -> 'b t - | Set_binop_pre : ('a, 'b) binop * int t -> unit t +type t = + | Value of typ + | Binop of t * binop * t + | Set_binop_pre of binop * t let value v = Value v @@ -35,7 +32,7 @@ let set_binop_pre op pre = let print ast = let pr = Printf.printf in let pv v = pr "%s" @@ typ_to_string v in - let rec aux : type a. a t -> unit = function + let rec aux = function | Value n -> pv n | Binop (left, op, right) -> begin pr "(%s " @@ binop_to_string op; diff --git a/eval.ml b/eval.ml index 228f156..2f8d5a3 100644 --- a/eval.ml +++ b/eval.ml @@ -1,18 +1,22 @@ open Ast -let binop_to_func : type a b. (a, b) Ast.binop -> (a -> a -> b) = function - | Add -> Int.add - | Sub -> Int.sub - | Mul -> Int.mul - | Div -> Int.div - | Eq -> (=) +let intop f a b = + match a, b with + | Int a, Int b -> Int (f a b) + | _ -> failwith "typecheck failed" -let rec eval : type a. a Ast.t -> a = function - | Value (Int t) -> t - | Value Unit -> () +let binop_to_func = function + | Add -> intop Int.add + | Sub -> intop Int.sub + | Mul -> intop Int.mul + | Div -> intop Int.div + +let rec eval = function + | Value v -> v | Binop (l, op, r) -> let f = binop_to_func op in f (eval l) (eval r) | Set_binop_pre (op, l) -> - Hashtbl.replace Parser.precedence - (Ast.binop_to_string op) (eval l) + let l = match eval l with Int n -> n | _ -> failwith "not int" in + Hashtbl.replace Parser.precedence (Ast.binop_to_string op) l; + Unit diff --git a/lex.ml b/lex.ml index 47506b9..3ecf1ab 100644 --- a/lex.ml +++ b/lex.ml @@ -15,7 +15,7 @@ let is_whitespace = function | _ -> false let is_alpha c = - 'A' <= c && c <= 'Z' && 'a' <= c && c <= 'z' + ('A' <= c && c <= 'Z') || ('a' <= c && c <= 'z') let is_ident_start = either is_alpha ((=) '_') @@ -48,9 +48,11 @@ let tokenize (str : string) : tokens = let n = String.of_seq @@ Seq.cons x n in Seq.cons (of_string n) (aux s) else if is_ident_start x then - let id, s = partition_while is_ident s in - let id = String.of_seq @@ Seq.cons x id in - Seq.cons (Ident id) (aux s) + begin + let id, s = partition_while is_ident s in + let id = String.of_seq @@ Seq.cons x id in + Seq.cons (Ident id) (aux s) + end else Seq.cons (of_char x) (aux s) in diff --git a/main.ml b/main.ml index a65f1e5..7580f02 100644 --- a/main.ml +++ b/main.ml @@ -7,7 +7,8 @@ let rec repl () : unit = |> Lex.tokenize |> Parser.parse |> Eval.eval - |> Printf.printf "%d\n"; + |> Ast.typ_to_string + |> Printf.printf "%s\n"; repl () end diff --git a/parser.ml b/parser.ml index a55d7f4..21cd61b 100644 --- a/parser.ml +++ b/parser.ml @@ -9,6 +9,10 @@ let expected t = let unexpected_token t = raise @@ Unexpected_token (Token.to_string t) +(* precedence table. + * my first thought was using some sort of partially-ordered graph for + * precedency, but infering precedence relation from the graph is hard + * and the graph can be made to have loops, I just used plain table. *) let precedence = [ "+", 10; "-", 10; @@ -19,6 +23,9 @@ let precedence = [ let precedence_of op = Hashtbl.find precedence (Ast.binop_to_string op) +let is_left_to_right = function + | Add | Sub | Mul | Div -> true + let token_to_op = function | Token.Plus -> Add | Minus -> Sub @@ -26,7 +33,7 @@ let token_to_op = function | Slash -> Div | _ -> failwith "Parser.token_to_op" -let parse : type a. Token.t Seq.t -> a Ast.t = fun ts -> +let parse ts = (* value := int | ( expr ) *) let rec value seq = match seq () with @@ -75,7 +82,7 @@ let parse : type a. Token.t Seq.t -> a Ast.t = fun ts -> and expr seq = match seq () with - | Seq.Nil -> Value Unit (* nop *) + | Seq.Nil -> Value Unit, Seq.empty (* nop *) | Seq.Cons (x, s) -> begin match x with | Ident "set" -> set_conf s | _ -> @@ -83,8 +90,6 @@ let parse : type a. Token.t Seq.t -> a Ast.t = fun ts -> binop ~-1 left seq end in - let ast, _ = expr ts in - (* + let ast, rest = expr ts in if rest () <> Seq.Nil then failwith "Parser.parse"; - *) ast