Add function and external value

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 =
+  type t = value
-    | Int of int
-    | Float of float
-    | String of string
-    | Nop (* return of system operations *)
 
   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 =
+  type t = operator
-    | Add | Sub | Mul | Div (* arithmetics *)
-    | Mod (* modular operation *)
-    | Exp (* exponentation *)
-    | Negate
 
   exception Unavailable of t
 
@@ -61,18 +89,16 @@ module Operator = struct
     | Negate -> "-"
 
   let negate = function
-    | Value.Int n -> Value.Int ~-n
+    | Int n -> Int ~-n
-    | Float n -> Value.Float ~-.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
+      let op = Operator.to_string op in
-        pr "(%s " op; aux t; pr ")"
+      pr "(%s " op; aux t; pr ")"
     | Binop (left, op, right) ->
-        let op = Operator.to_string op in
+      let op = Operator.to_string op in
-        pr "(%s " op; aux left; pr " "; aux right; pr ")"
+      pr "(%s " op; aux left; pr " "; aux right; pr ")"
     | Apply (f, args) ->
       pr "("; List.iter aux @@ f::args; pr ")"
 

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

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;
+      Env.set env var v; v
-      v
     | Apply (v, args) ->
-      let args = List.map aux args in
+      begin match aux v with
-      begin match v with
+        | Function (vars, e) ->
-        | Var id -> apply id args
+          assert_same_length vars args;
-        | _ -> assert false
+          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

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))

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 =

token.ml

@@ -12,8 +12,10 @@ type t =
   | LParen
   | RParen
   | Equal
+  | Right_arrow
 
 let tokens = ref [
+  "->", Right_arrow;
   "+", Plus;
   "-", Minus;
   "*", Asterisk;