diff --git a/ast.ml b/ast.ml index 7901781..13a1a38 100644 --- a/ast.ml +++ b/ast.ml @@ -2,37 +2,69 @@ module Type = struct type t = | Int | Float + | Function + | External | String let to_string = function | Int -> "int" | Float -> "float" | String -> "string" + | Function -> "fun" + | External -> "external" let supertype = function | Int -> Some Float | _ -> None end +(* simple, untyped AST. *) +type t = + | Value of value + | Var of string + | Let of string * t + | Unary of operator * t + | Binop of t * operator * t + | Apply of t * t list (* function application *) + | Set_binop_pre of operator * t + | Get_binop_pre of operator + | Set_binop_aso of operator * string + | Get_binop_aso of operator + +and value = + | Int of int + | Float of float + | String of string + | Function of string list * t + | External of string + | Nop (* return of system operations (will be deprecated) *) + +and operator = + | Add | Sub | Mul | Div (* arithmetics *) + | Mod (* modular operation *) + | Exp (* exponentation *) + | Negate + exception Invalid_type of Type.t module Value = struct - type t = - | Int of int - | Float of float - | String of string - | Nop (* return of system operations *) + type t = value let to_string = function | Int n -> string_of_int n | Float n -> string_of_float n | String s -> "\"" ^ s ^ "\"" + | Function (vars, _) -> + Printf.sprintf "function with %d arguments" @@ List.length vars + | External f -> "external " ^ f | Nop -> "nop" let typeof = function | Int _ -> Type.Int | Float _ -> Type.Float | String _ -> Type.String + | Function _ -> Type.Function + | External _ -> Type.External | Nop -> failwith "Value.typeof" let promote = function @@ -43,11 +75,7 @@ end (* operators *) module Operator = struct - type t = - | Add | Sub | Mul | Div (* arithmetics *) - | Mod (* modular operation *) - | Exp (* exponentation *) - | Negate + type t = operator exception Unavailable of t @@ -61,18 +89,16 @@ module Operator = struct | Negate -> "-" let negate = function - | Value.Int n -> Value.Int ~-n - | Float n -> Value.Float ~-.n + | Int n -> Int ~-n + | Float n -> Float ~-.n | _ -> failwith "Operator.negate" let vi f a b = - let open Value in match a, b with | Int a, Int b -> Int (f a b) | _ -> raise @@ Invalid_type Int let vf f a b = - let open Value in match a, b with | Float a, Float b -> Float (f a b) | _ -> raise @@ Invalid_type Float @@ -105,18 +131,6 @@ module Operator = struct |> List.assoc_opt typ end -type t = - | Value of Value.t - | Var of string - | Let of string * t - | Unary of Operator.t * t - | Binop of t * Operator.t * t - | Apply of t * t list - | Set_binop_pre of Operator.t * t - | Get_binop_pre of Operator.t - | Set_binop_aso of Operator.t * string - | Get_binop_aso of Operator.t - let value v = Value v let unary op t = @@ -135,11 +149,11 @@ let print ast = | Let (v, e) -> pr "(let %s " v; aux e; pr ")" | Unary (op, t) -> - let op = Operator.to_string op in - pr "(%s " op; aux t; pr ")" + let op = Operator.to_string op in + pr "(%s " op; aux t; pr ")" | Binop (left, op, right) -> - let op = Operator.to_string op in - pr "(%s " op; aux left; pr " "; aux right; pr ")" + let op = Operator.to_string op in + pr "(%s " op; aux left; pr " "; aux right; pr ")" | Apply (f, args) -> pr "("; List.iter aux @@ f::args; pr ")" diff --git a/env.ml b/env.ml index b86cfae..4bdedde 100644 --- a/env.ml +++ b/env.ml @@ -31,3 +31,6 @@ let get_opt e name = let set e name value = Hashtbl.replace e.vars name value + +let add_seq e seq = + Hashtbl.add_seq e.vars seq diff --git a/eval.ml b/eval.ml index db51bab..117a2dd 100644 --- a/eval.ml +++ b/eval.ml @@ -5,6 +5,17 @@ exception No_operation exception No_such_variable of string exception No_such_function of string +exception Too_many_arguments + +let assert_same_length vars args = + let vl = List.length vars + and al = List.length args in + if vl > al then + failwith "assert_same_length" + else if vl < al then + raise Too_many_arguments + else () + let resolve_type op tp = let optypes = Operator.get_types op in let q = Queue.create () in @@ -48,7 +59,7 @@ let floatfun f = function | Float n -> Float (f n) | v -> raise @@ Invalid_type (typeof v) -let apply f args = +let ex_apply f args = match f, args with | "sin", [n] -> floatfun Float.sin n | "cos", [n] -> floatfun Float.cos n @@ -57,7 +68,7 @@ let apply f args = | "rad", [n] -> floatfun rad n | _ -> raise @@ No_such_function f -let eval env ast = +let rec eval env ast = let rec aux = function | Value v -> v | Var v -> begin match Env.get_opt env v with @@ -73,15 +84,21 @@ let eval env ast = binop op l r | Let (var, e) -> let v = aux e in - Env.set env var v; - v + Env.set env var v; v | Apply (v, args) -> - let args = List.map aux args in - begin match v with - | Var id -> apply id args - | _ -> assert false + begin match aux v with + | Function (vars, e) -> + assert_same_length vars args; + let args = List.map aux args in + let nenv = Env.make env in + List.combine vars args + |> List.iter (fun (v, a) -> Env.set nenv v a); + eval nenv e + | External f -> + let args = List.map aux args in + ex_apply f args + | v -> raise @@ Invalid_type (typeof v) end - | Set_binop_pre (op, l) -> let l = match aux l with diff --git a/main.ml b/main.ml index 10f0498..7d2c860 100644 --- a/main.ml +++ b/main.ml @@ -11,6 +11,7 @@ let error_to_string e = | Ast.Invalid_type t -> sprintf "invalid type %s" (Ast.Type.to_string t) | Eval.No_such_variable v -> sprintf "no such variable %s" v | Eval.No_such_function f -> sprintf "no such function \"%s\"" f + | Eval.Too_many_arguments -> "applied too many arguments" | Failure f -> sprintf "error on %s" f | Division_by_zero -> "cannot divide by zero" | _ -> raise e @@ -18,7 +19,17 @@ let error_to_string e = let print_error e = printf "error: %s\n" @@ error_to_string e -let g = Env.init_global () +let stdlib = [ + "sin"; "cos"; "tan"; + "deg"; "rad"; +] + |> List.to_seq + |> Seq.map (fun v -> v, Ast.External v) + +let g = + let g = Env.init_global () in + Env.add_seq g stdlib; + g (* read-eval-print *) let rep env : unit = @@ -40,7 +51,7 @@ let rep env : unit = exception Reset_line (* used to indicate ^C is pressed *) let init_repl () = - Env.set g "ans" (Ast.Value.Int 0); + Env.set g "ans" (Ast.Int 0); (* treat Ctrl-C as to reset line *) let reset_line _ = raise Reset_line in Sys.(set_signal sigint (Signal_handle reset_line)) diff --git a/parser.ml b/parser.ml index f293b86..7a012bc 100644 --- a/parser.ml +++ b/parser.ml @@ -1,5 +1,4 @@ open Ast -open Ast.Operator module S = Set.Make(String) @@ -146,8 +145,10 @@ let rec expr pre seq = level; assoc; let_value; - (either unary value) @> binop pre; + lambda; + extern_value; apply; + (either unary value) @> binop pre; ] (* level := "level" {"get" | "set"} [op] *) @@ -184,11 +185,27 @@ and let_value seq = let e, seq = expr min_int seq in Let (id, e), seq -(* apply := ident [value]* *) +(* lambda := "fun" [ident]+ "->" expr *) +and lambda seq = + let _, seq = ident "fun" seq in + let v0, seq = any_ident seq in + let vars, seq = more any_ident seq in + let _, seq = token Right_arrow seq in + let e, seq = expr min_int seq in + Value (Function (v0::vars, e)), seq + +(* apply := value [value]+ *) and apply seq = - let id, seq = any_ident seq in + let v, seq = value seq in + let a0, seq = value seq in let args, seq = more value seq in - Apply (Var id, args), seq + Apply (v, a0::args), seq + +(* extern_value := external ident *) +and extern_value seq = + let _, seq = ident "external" seq in + let id, seq = any_ident seq in + Value (External id), seq (* unary := - value *) and unary seq = diff --git a/token.ml b/token.ml index 997f9db..ad33e6d 100644 --- a/token.ml +++ b/token.ml @@ -12,8 +12,10 @@ type t = | LParen | RParen | Equal + | Right_arrow let tokens = ref [ + "->", Right_arrow; "+", Plus; "-", Minus; "*", Asterisk;