diff --git a/ast.ml b/ast.ml index bdc631a..cf67336 100644 --- a/ast.ml +++ b/ast.ml @@ -2,6 +2,7 @@ type t = | Nint of int | Nfloat of float + | Nbool of bool | Nstring of string | Nsymbol of string | Nfunction of string list * t @@ -10,6 +11,7 @@ type t = | Let of string * t | Unary of operator * t | Binop of t * operator * t + | If of t * t * t (* cond then else *) | Apply of t * t list (* function application *) (* these will be seperated into (toplevel) directives. *) | Set_binop_pre of operator * t @@ -44,12 +46,13 @@ let print ast = let rec aux = function | Nint n -> pr "%d" n | Nfloat n -> pr "%f" n + | Nbool b -> pr "%b" b | Nstring s -> pr "\"%s\"" s | Nsymbol s -> pr "#%s" s | Nfunction (args, e) -> - pr "lambda (%s" @@ List.hd args; + pr "(lambda (%s" @@ List.hd args; List.iter (pr " %s") @@ List.tl args; - pr ") ("; aux e; pr")" + pr ") "; aux e; pr ")" | Nexternal e -> pr "(extern %s)" e | Var v -> pr "%s" v | Let (v, e) -> @@ -60,8 +63,11 @@ let print ast = | Binop (left, op, right) -> let op = op_to_string op in pr "(%s " op; aux left; pr " "; aux right; pr ")" + | If (co, th, el) -> + let f e = pr " "; aux e in + pr "(if"; f co; f th; f el; pr ")" | Apply (f, args) -> - pr "("; List.iter aux @@ f::args; pr ")" + pr "("; aux f; List.iter (fun a -> pr " "; aux a) args; pr ")" | Set_binop_pre (op, pre) -> pr "(set_pre %s " (op_to_string op); diff --git a/eval.ml b/eval.ml index 6db9364..242f287 100644 --- a/eval.ml +++ b/eval.ml @@ -1,8 +1,10 @@ open Ast +(* resulting value of eval *) type value = | Int of int | Float of float + | Bool of bool | String of string | Symbol of string | Function of string list * expr @@ -11,6 +13,7 @@ type value = and expr = Ast.t +(* environment for eval *) and env = { vars : (string, value) Hashtbl.t; parent : env option; @@ -23,6 +26,7 @@ module Type = struct type t = | Int | Float + | Bool | String | Symbol | Function @@ -33,6 +37,7 @@ module Type = struct let to_string = function | Int -> "int" | Float -> "float" + | Bool -> "bool" | String -> "string" | Symbol -> "symbol" | Function -> "fun" @@ -49,6 +54,7 @@ module Value = struct let to_string = function | Int n -> string_of_int n | Float n -> string_of_float n + | Bool b -> string_of_bool b | String s -> "\"" ^ s ^ "\"" | Symbol s -> "symbol " ^ s | Function (vars, _) -> @@ -59,6 +65,7 @@ module Value = struct let typeof = function | Int _ -> Type.Int | Float _ -> Type.Float + | Bool _ -> Type.Bool | String _ -> Type.String | Symbol _ -> Type.Symbol | Function _ -> Type.Function @@ -217,6 +224,7 @@ let rec eval env ast : string * value = let rec aux = function | Nint n -> Int n | Nfloat n -> Float n + | Nbool b -> Bool b | Nstring s -> String s | Nsymbol s -> Symbol s | Nfunction (args, e) -> Function (args, e) @@ -232,6 +240,12 @@ let rec eval env ast : string * value = | Binop (l, op, r) -> let l = aux l and r = aux r in binop op l r + | If (co, th, el) -> + begin match aux co with + | Bool true -> aux th + | Bool false -> aux el + | v -> raise @@ Type.Invalid (Value.typeof v) + end | Apply (v, args) -> begin match aux v with | Function (vars, e) -> diff --git a/main.ml b/main.ml index ddc96dc..56e36a8 100644 --- a/main.ml +++ b/main.ml @@ -2,6 +2,7 @@ open Printf open Eval let version = "%%VERSION%%" +let debug = ref false let error_to_string e = try raise e with @@ -36,12 +37,9 @@ let rep env : unit = printf "> "; let line = read_line () in if line = "quit" then raise Exit; - let var, v = - line - |> Lex.tokenize - |> Parser.parse - |> Eval.eval env - in + let ast = line |> Lex.tokenize |> Parser.parse in + if !debug then Ast.print ast; + let var, v = Eval.eval env ast in match v with | Nop -> () | _ -> diff --git a/parser.ml b/parser.ml index 5c97420..1e709ea 100644 --- a/parser.ml +++ b/parser.ml @@ -148,6 +148,14 @@ let rec decl seq = expr min_int; ] +(* let_value := "let" ident "=" expr *) +and let_value seq = + let _, seq = ident "let" seq in + let id, seq = any_ident seq in + let _, seq = token Token.Equal seq in + let e, seq = expr min_int seq in + Let (id, e), seq + (* expr := level * | assoc * | apply @@ -155,12 +163,13 @@ let rec decl seq = *) and expr pre seq = seq |> oneof [ + (either unary value) @> binop pre; + ifexpr; level; assoc; lambda; extern_value; apply; - (either unary value) @> binop pre; ] (* level := "level" {"get" | "set"} [op] *) @@ -189,14 +198,6 @@ and assoc seq = else failwith "Parser.assoc" -(* let_value := "let" ident "=" expr *) -and let_value seq = - let _, seq = ident "let" seq in - let id, seq = any_ident seq in - let _, seq = token Token.Equal seq in - let e, seq = expr min_int seq in - Let (id, e), seq - (* lambda := "fun" [ident]+ "->" expr *) and lambda seq = let _, seq = ident "fun" seq in @@ -206,6 +207,16 @@ and lambda seq = let e, seq = expr min_int seq in Nfunction (v0::vars, e), seq +(* ifexpr := "if" expr "then" expr "else" expr *) +and ifexpr seq = + let _, seq = ident "if" seq in + let co, seq = expr min_int seq in + let _, seq = ident "then" seq in + let th, seq = expr min_int seq in + let _, seq = ident "else" seq in + let el, seq = expr min_int seq in + If (co, th, el), seq + (* apply := value [value]+ *) and apply seq = let v, seq = value seq in @@ -237,7 +248,9 @@ and value seq = match seq () with | Seq.Nil -> raise End_of_tokens | Seq.Cons (x, seq) -> begin match x with - | Token.Ident id -> Var id, seq + | Ident "true" -> Nbool true, seq + | Ident "false" -> Nbool false, seq + | Ident id -> Var id, seq | Int x -> Nint x, seq | Float x -> Nfloat x, seq | String x -> Nstring x, seq @@ -268,7 +281,8 @@ and binop pre left seq = else left, Seq.cons x seq - | Token.RParen -> left, Seq.cons x seq + | RParen | Ident "then" | Ident "else" -> + left, Seq.cons x seq | _ -> unexpected_token x end