diff --git a/ast.ml b/ast.ml index 0cc220b..0f19d60 100644 --- a/ast.ml +++ b/ast.ml @@ -2,10 +2,12 @@ module Type = struct type t = | Int | Float + | String let to_string = function | Int -> "int" | Float -> "float" + | String -> "string" let merge a b = match a, b with @@ -22,16 +24,24 @@ module Value = struct type t = | Int of int | Float of float + | String of string | Nop (* return of system operations *) let to_string = function - | Int n -> Printf.sprintf "%d" n - | Float n -> Printf.sprintf "%f" n + | Int n -> string_of_int n + | Float n -> string_of_float n + | String s -> s | Nop -> "nop" + let of_token = function + | Token.Int n -> Int n + | Float n -> Float n + | _ -> invalid_arg "Value.of_token" + let typeof = function | Int _ -> Type.Int | Float _ -> Type.Float + | String _ -> Type.String | Nop -> failwith "Value.typeof" let promote = function @@ -92,6 +102,8 @@ type t = | Binop of t * Binop.t * t | Set_binop_pre of Binop.t * t | Get_binop_pre of Binop.t + | Set_binop_aso of Binop.t * string + | Get_binop_aso of Binop.t let value v = Value v @@ -115,5 +127,9 @@ let print ast = pr ")" | Get_binop_pre op -> pr "(get_pre %s)" (Binop.to_string op) + | Set_binop_aso (op, aso) -> + pr "(set_assoc %s %s)" (Binop.to_string op) aso + | Get_binop_aso op -> + pr "(get_pre %s)" (Binop.to_string op) in aux ast; pr "\n" diff --git a/eval.ml b/eval.ml index 21b8c1a..6f2bd25 100644 --- a/eval.ml +++ b/eval.ml @@ -41,5 +41,12 @@ let eval vars ast = Nop | Get_binop_pre op -> Int (Hashtbl.find Parser.precedence op) + | Set_binop_aso (op, a) -> + Hashtbl.replace Parser.oper_assoc op @@ Parser.assoc_of_string a; + Nop + | Get_binop_aso op -> + match Hashtbl.find_opt Parser.oper_assoc op with + | None -> String "left" + | Some a -> String (Parser.assoc_to_string a) in aux ast diff --git a/parser.ml b/parser.ml index 669c155..40d1246 100644 --- a/parser.ml +++ b/parser.ml @@ -33,6 +33,15 @@ type associativity = | Left_to_right | Right_to_left +let assoc_of_string = function + | "left" -> Left_to_right + | "right" -> Right_to_left + | _ -> invalid_arg "assoc_of_string" + +let assoc_to_string = function + | Left_to_right -> "left" + | Right_to_left -> "right" + let oper_assoc = [ Exp, Right_to_left; ] |> List.to_seq |> Hashtbl.of_seq @@ -62,6 +71,13 @@ let token_is_operator tok = (* common parsers *) +let token tok seq = + match seq () with + | Seq.Nil -> expected @@ Token.to_string tok + | Seq.Cons (x, seq) -> + if x = tok then x, seq + else expected @@ Token.to_string tok + let idents set seq = match seq () with | Seq.Nil -> @@ -85,23 +101,33 @@ let operator seq = (* parser combinators *) -let either f g seq = - try f seq with _ -> g seq +let oneof fs seq = + let rec aux = function + | [] -> assert false + | [f] -> f seq + | f::fs -> (try f seq with _ -> aux fs) + in + aux fs -let (@>) f g seq = +let (@>) f g = fun seq -> let a, seq = f seq in g a seq -(* expr := "level" level_inner +(* expr := level + * | assoc + * | let * | value binop_right *) -let rec expr seq = - seq |> either - (ident "level" @> level_inner) - (value @> binop ~-1) +let rec expr pre seq = + seq |> oneof [ + level; + assoc; + value @> binop pre; + ] -(* level_inner := "get" | "set" [op] *) -and level_inner _ seq = +(* level := "level" {"get" | "set"} [op] *) +and level seq = + let _, seq = ident "level" seq in let id, seq = idents (S.of_list ["get"; "set"]) seq in let op, seq = operator seq in if id = "get" then @@ -112,7 +138,20 @@ and level_inner _ seq = else failwith "Parser.level" -(* value := int | ( expr ) *) +(* assoc := "assoc" {"get" | "set"} [op] *) +and assoc seq = + let _, seq = ident "assoc" seq in + let id, seq = idents (S.of_list ["get"; "set"]) seq in + let op, seq = operator seq in + if id = "get" then + Get_binop_aso op, seq + else if id = "set" then + let a, seq = idents (S.of_list ["left"; "right"]) seq in + Set_binop_aso (op, a), seq + else + failwith "Parser.assoc" + +(* value := int | float | ( expr ) *) and value seq = match seq () with | Seq.Nil -> raise End_of_tokens @@ -120,7 +159,10 @@ and value seq = | Token.Int n -> Value (Int n), seq | Float n -> Value (Float n), seq | Ident id -> Var id, seq - | LParen -> expr seq + | LParen -> + let e, seq = expr min_int seq in + let _, seq = token RParen seq in + e, seq | _ -> unexpected_token x end @@ -131,20 +173,22 @@ and binop pre left seq = | Seq.Cons (x, seq) -> begin match x with | op when token_is_operator op -> let op = token_to_op op in - let o = precedence_of op in + let op_pre = precedence_of op in (* op has to be calculated first *) - if o > pre || (op_is_right_to_left op && o = pre) then - let v, seq = value seq in - let right, seq = binop o v seq in + if op_pre > pre + || (op_is_right_to_left op && op_pre = pre) + then + let right, seq = expr op_pre seq in binop pre (Ast.binop left op right) seq else left, Seq.cons x seq - | Token.RParen -> left, seq + + | Token.RParen -> left, Seq.cons x seq | _ -> unexpected_token x end (* parse tokens *) let parse ts = - let ast, rest = expr ts in + let ast, rest = expr min_int ts in if rest () <> Seq.Nil then failwith "Parser.parse"; ast