Add unit type, remove Nop

ast.ml

@@ -1,12 +1,13 @@
 (* simple, untyped AST. *)
 type t =
   | Nothing
+  | Nunit
   | Nint of int
   | Nfloat of float
   | Nbool of bool
   | Nstring of string
   | Nsymbol of string
-  | Nfunction of string * t
+  | Nfunction of string list * t
   | Nexternal of string
   | Var of string
   | Let of string * t
@@ -16,27 +17,7 @@ type t =
   | If of t * t * t (* cond then else *)
   | Apply of t * t list (* function application *)
 
-and operator =
+and operator = string
-  | Add | Sub | Mul | Div (* arithmetics *)
-  | Mod (* modular operation *)
-  | Exp (* exponentation *)
-  | Eq | Neq | GE | LE | GT | LT
-  | Negate
-
-let op_to_string = function
-  | Add -> "+"
-  | Sub -> "-"
-  | Mul -> "*"
-  | Div -> "/"
-  | Mod -> "%"
-  | Exp -> "^"
-  | Eq -> "="
-  | Neq -> "<>"
-  | GE -> ">="
-  | LE -> "<="
-  | GT -> ">"
-  | LT -> "<"
-  | Negate -> "-"
 
 let unary op t =
   Unary (op, t)
@@ -46,43 +27,39 @@ let binop left op right =
 
 (* print ast LISP style. *)
 let print ast =
-  let rec cascade = function
-    | Nfunction (arg, e) ->
-      let args, e = cascade e in
-      arg :: args, e
-    | e -> [], e
-  in
-
   let pr = Printf.printf in
   let rec aux = function
     | Nothing -> pr ""
+    | Nunit -> pr "()"
     | 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 (arg, e) ->
+    | Nfunction (arg::args, e) ->
-      let args, e = cascade e in
       pr "(lambda (%s" arg;
       List.iter (pr " %s") args;
       pr ") "; aux e; pr ")"
     | Nexternal e -> pr "(extern %s)" e
 
     | Var v -> pr "%s" v
+    | Let (v, Nfunction (args, e)) ->
+      pr "(define (%s" v;
+      List.iter (pr " %s") args;
+      pr ") "; aux e; pr ")"
     | Let (v, e) ->
       pr "(define %s " v; aux e; pr ")"
     | Letin (v, e, f) ->
       pr "(let ((%s " v; aux e; pr ")) "; aux f; pr ")"
     | Unary (op, t) ->
-      let op = op_to_string op in
       pr "(%s " op; aux t; pr ")"
     | 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 "("; aux f; List.iter (fun a -> pr " "; aux a) args; pr ")"
+    | _ -> invalid_arg "Ast.print"
   in
   aux ast; pr "\n"

eval.ml

@@ -2,27 +2,25 @@ open Ast
 
 (* resulting value of eval *)
 type value =
+  | Unit
   | Int of int
   | Float of float
   | Bool of bool
   | String of string
   | Symbol of string
-  (* (name), arg, expression, name *)
+  (* (name), bound variables, expression, environment *)
-  | Function of string option * string * expr * env
+  | Function of string option * string list * expr * env
   | External of string
-  | Nop (* return of system operations (will be deprecated) *)
 
 and expr = Ast.t
 
 (* environment for eval *)
-and env = (string * value) list
+and env = Env of (string * value) list
-
-exception No_operation
-exception Too_many_arguments
 
 (* TODO: add proper type system *)
 module Type = struct
   type t =
+    | Unit
     | Int
     | Float
     | Bool
@@ -30,11 +28,13 @@ module Type = struct
     | Symbol
     | Function
     | External
+    | Any
 
   exception Invalid of t
   exception Expected of t
 
   let to_string = function
+    | Unit -> "unit"
     | Int -> "int"
     | Float -> "float"
     | Bool -> "bool"
@@ -42,34 +42,39 @@ module Type = struct
     | Symbol -> "symbol"
     | Function -> "fun"
     | External -> "external"
+    | Any -> "any"
 
   let supertype = function
     | Int -> Some Float
     | _ -> None
+
+  let matches : t -> t -> bool = function
+    | Any -> Fun.const true
+    | t -> fun o -> o = t || o = Any
 end
 
 module Value = struct
   type t = value
 
   let to_string = function
+    | Unit -> "()"
     | 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
+    | Symbol s -> "#" ^ s
     | Function _ -> "<fun>"
     | External f -> "external " ^ f
-    | Nop -> "nop"
 
   let typeof = function
-    | Int _ -> Type.Int
+    | Unit -> Type.Unit
-    | Float _ -> Type.Float
+    | Int _ -> Int
-    | Bool _ -> Type.Bool
+    | Float _ -> Float
-    | String _ -> Type.String
+    | Bool _ -> Bool
-    | Symbol _ -> Type.Symbol
+    | String _ -> String
-    | Function _ -> Type.Function
+    | Symbol _ -> Symbol
-    | External _ -> Type.External
+    | Function _ -> Function
-    | Nop -> failwith "Value.typeof"
+    | External _ -> External
 
   let promote = function
     | Int n -> Float (float n)
@@ -79,26 +84,20 @@ end
 module Env = struct
   type t = env
 
-  let empty = []
+  let empty = Env []
 
-  let get_opt e name =
+  let get_opt (Env e) name =
     List.assoc_opt name e
 
-  let bind v e =
+  let bind v (Env e) =
-    v::e
+    Env (v::e)
 
-  let bind_seq seq e =
+  let bind_seq seq (Env e) =
-    List.of_seq seq @ e
+    Env (List.of_seq seq @ e)
 end
 
-(* operators *)
+(* primitive methods *)
-module Operator = struct
+module Primitive = struct
-  type t = Ast.operator
-
-  exception Unavailable of t
-
-  let to_string = Ast.op_to_string
-
   let negate = function
     | [Int n] -> Int ~-n
     | [Float n] -> Float ~-.n
@@ -127,45 +126,16 @@ module Operator = struct
   let gt vs = Bool (compare vs > 0)
   let lt vs = Bool (compare vs < 0)
 
-  (* operator table *)
-  let operators =
-    let open Type in
-    let ip = [Int; Int] and fp = [Float; Float] in
-    let any f = [ip, f; fp, f] in
-    [
-      Add, [ip, vi Int.add; fp, vf Float.add];
-      Sub, [ip, vi Int.sub; fp, vf Float.sub];
-      Mul, [ip, vi Int.mul; fp, vf Float.mul];
-      Div, [ip, vi Int.div; fp, vf Float.div];
-      Mod, [ip, vi Int.rem; fp, vf Float.rem];
-      Exp, [fp, vf Float.pow];
-      Eq,  any eq;
-      Neq, any neq;
-      GE, any ge;
-      LE, any le;
-      GT, any gt;
-      LT, any lt;
-      Negate, [[Int], negate; [Float], negate];
-    ]
-    |> List.to_seq
-    |> Hashtbl.of_seq
-
-  let get op =
-    Hashtbl.find operators op
-end
-
-module External = struct
-  exception Invalid of string
-
   let rad r =
     r *. 180. /. Float.pi
 
   let deg d =
     d /. 180. *. Float.pi
 
-  let floatfun f = function
+  let floatfun f =
+    [Type.Float],
+    function
     | [Float n] -> Float (f n)
-    | [v] -> raise @@ Type.Invalid (Value.typeof v)
     | _ -> invalid_arg "External.floatfun"
 
   let symbol_to_op op =
@@ -180,7 +150,7 @@ module External = struct
     | [Symbol op; Int l] ->
       let op = symbol_to_op op in
       Hashtbl.replace Parser.precedence op l;
-      Nop
+      Unit
     | _ -> failwith "set_op_pre"
 
   let get_op_pre = function
@@ -193,7 +163,7 @@ module External = struct
     | [Symbol op; String a] ->
       let op = symbol_to_op op in
       Hashtbl.replace Parser.oper_assoc op @@ Parser.assoc_of_string a;
-      Nop
+      Unit
     | _ -> failwith "set_op_assoc"
 
   let get_op_assoc = function
@@ -204,65 +174,129 @@ module External = struct
       |> (fun a -> String (Parser.assoc_to_string a))
     | _ -> failwith "get_op_assoc"
 
-  let apply f args =
+  let print args =
-    let f = match f with
+    let to_string = function
-      | "sin" -> floatfun Float.sin
+      | Int n -> string_of_int n
-      | "cos" -> floatfun Float.cos
+      | Float n -> string_of_float n
-      | "tan" -> floatfun Float.tan
+      | Bool b -> string_of_bool b
-      | "deg" -> floatfun deg
+      | String s -> s
-      | "rad" -> floatfun rad
+      | Symbol s -> s
-      | "set_op_pre" -> set_op_pre
+      | _ -> failwith "print"
-      | "get_op_pre" -> get_op_pre
-      | "set_op_assoc" -> set_op_assoc
-      | "get_op_assoc" -> get_op_assoc
-      | _ -> raise @@ Invalid f
     in
-    f args
+    List.map to_string args
+    |> List.iter (Printf.printf "%s");
+    Unit
+
+  let println args =
+    ignore @@ print args;
+    Printf.printf "\n";
+    Unit
+
+
+  let methods =
+    let open Type in
+    let ip = [Int; Int] and fp = [Float; Float] in
+    let number f = [ip, f; fp, f] in
+    [
+      "+", [ip, vi Int.add; fp, vf Float.add];
+      "-", [ip, vi Int.sub; fp, vf Float.sub;
+            [Int], negate; [Float], negate];
+      "*", [ip, vi Int.mul; fp, vf Float.mul];
+      "/", [ip, vi Int.div; fp, vf Float.div];
+      "%", [ip, vi Int.rem; fp, vf Float.rem];
+      "^", [fp, vf Float.pow];
+      "=", number eq;
+      "<>", number neq;
+      ">=", number ge;
+      "<=", number le;
+      ">", number gt;
+      "<", number lt;
+
+      "sin", [floatfun Float.sin];
+      "cos", [floatfun Float.cos];
+      "tan", [floatfun Float.tan];
+      "deg", [floatfun deg];
+      "rad", [floatfun rad];
+      "set_op_pre", [[Symbol; Int], set_op_pre];
+      "get_op_pre", [[Symbol], get_op_pre];
+      "set_op_assoc", [[Symbol; String], set_op_assoc];
+      "get_op_assoc", [[Symbol], get_op_assoc];
+      "print", [[Any], print];
+      "println", [[Any], println];
+    ]
+    |> List.to_seq
+    |> Hashtbl.of_seq
+
+  let get op =
+    Hashtbl.find methods op
 end
 
-let find_operator op ts =
+(* find_method returns a method and (corresponding) type list that
-  let filter t =
+ * satisfies ts. *)
-    List.filter (fun (ts, _) ->
+let find_method m ts =
-        match ts with [] -> false | x::_ -> t=x)
+  let open List in
+  let filter_type t i =
+    filter (fun (ts, _) ->
+        nth_opt ts i
+        |> Option.map (Type.matches t)
+        |> Option.value ~default: false)
   in
-  let rec aux ops = function
+  let rec aux ms i = function
-    | [] -> List.nth_opt ops 0
+    | [] -> nth_opt ms 0
     | t::ts ->
-      (match aux (filter t ops) ts with
+      (match aux (filter_type t i ms) (i+1) ts with
-      | None -> Option.bind (Type.supertype t) (fun t -> aux ops (t::ts))
+       | None -> Option.bind (Type.supertype t)
+                   (fun t -> aux ms i (t::ts))
        | Some _ as x -> x)
   in
-  aux (Operator.get op) ts
+  let ms =
+    let len = length ts in
+    Primitive.get m
+    |> filter (fun (ts, _) -> length ts = len)
+  in
+  aux ms 0 ts
 
 let promote_values =
   let rec promote_until t v =
-    if Value.typeof v = t
+    if Type.matches t @@ Value.typeof v
     then v
     else promote_until t @@ Value.promote v
   in
   List.map2 promote_until
 
+exception No_such_method of string * Type.t
+let no_such m v = raise @@ No_such_method (m, Value.typeof v)
+
 let unary op v =
-  match find_operator op [Value.typeof v] with
+  match find_method op [Value.typeof v] with
-  | None -> raise No_operation
+  | None -> no_such op v
   | Some (ts, f) ->
     let vs = promote_values ts [v] in
     f vs
 
 let binop op l r =
   let open Value in
-  match find_operator op [typeof l; typeof r] with
+  match find_method op [typeof l; typeof r] with
-  | None -> raise No_operation
+  | None -> no_such op l
   | Some (ts, f) ->
     let vs = promote_values ts [l; r] in
     f vs
 
-exception Unbound of string
+let extern f args =
+  match find_method f (List.map Value.typeof args) with
+  | None -> no_such f (List.hd args)
+  | Some (ts, f) ->
+    let vs = promote_values ts args in
+    f vs
 
-let rec eval env ast =
+exception Unbound of string
-  let aux = eval env in (* eval with current env *)
+exception Noop
+
+let rec eval global env ast =
+  let aux = eval global env in (* eval with current env *)
   match ast with
-    | Nothing -> Nop
+    | Nothing -> raise Noop
+    | Nunit -> Unit
     | Nint n -> Int n
     | Nfloat n -> Float n
     | Nbool b -> Bool b
@@ -272,12 +306,13 @@ let rec eval env ast =
     | Nexternal f -> External f
 
     | Var v -> begin match Env.get_opt env v with
-        | None -> raise @@ Unbound v
+        | None -> (try Hashtbl.find global v
+                   with Not_found -> raise @@ Unbound v)
         | Some v -> v
       end
     | Letin (v, e, f) ->
       let env = Env.bind (v, aux e) env in
-      eval env f
+      eval global env f
 
     | Unary (op, v) -> unary op (aux v)
     | Binop (l, op, r) -> binop op (aux l) (aux r)
@@ -288,41 +323,53 @@ let rec eval env ast =
         | Bool false -> aux el
         | v -> raise @@ Type.Invalid (Value.typeof v)
       end
-    | Apply (v, args) -> apply v args env
+    | Apply (v, args) ->
+      let args = List.map (eval global env) args in
+      apply global env v args
 
     | _ -> failwith "Eval.eval"
 
 (* apply args to result of expr *)
-and apply expr args env =
+and apply global env expr args =
-  match eval env expr with
+  match eval global env expr with
-  | Function (itself, var, e, env) as f ->
+  | Function (itself, vars, body, local_env) as f ->
     begin match args with
       | [] -> f
-      | a::args ->
+      | args ->
-        let value = eval env a in
+        (* bind arguments to variables *)
+        let rec aux e = function
+          | [], [] -> [], [], e
+          | vars, [] -> vars, [], e
+          | [], args -> [], args, e
+          | v::vars, a::args ->
+            let e = Env.bind (v, a) e in
+            aux e (vars, args)
+        in
+        let vars, args, env = aux local_env (vars, args) in
         let env = (* binding itself into env for recursion *)
-          itself
+          itself |> Option.fold
-          |> Option.fold
             ~none: env
             ~some: (fun n -> Env.bind (n, f) env)
-          |> Env.bind (var, value)
         in
-        eval env @@ Apply (e, args)
+        if vars <> [] then (* partially-applied function *)
+          Function (None, vars, body, env)
+        else if args <> [] then (* reapply *)
+          apply global env body args
+        else (* eval (vars = [], args = []) *)
+          eval global env body
     end
-  | External f ->
+  | External f -> extern f args
-    let args = List.map (eval env) args in
-    External.apply f args
   | v ->
     if args = [] then v
     else raise @@ Type.Invalid (Value.typeof v)
 
 (* toplevel for global let *)
-let eval_top env_ref ast =
+let eval_top global ast =
   let var, v = match ast with
     | Let (var, Nfunction (arg, e)) -> (* named function *)
-      var, Function (Some var, arg, e, !env_ref)
+      var, Function (Some var, arg, e, Env.empty)
-    | Let (var, e) -> var, eval !env_ref e
+    | Let (var, e) -> var, eval global Env.empty e
-    | ast -> "-", eval !env_ref ast
+    | ast -> "-", eval global Env.empty ast
   in
-  if var <> "-" then env_ref := Env.bind (var, v) !env_ref;
+  if var <> "-" then Hashtbl.replace global var v;
   var, v

lex.ml

@@ -9,6 +9,8 @@ let expected col c = raise @@ Expected (col, c)
 let either f g c =
   f c || g c
 
+(* test functions *)
+
 let is_digit c =
   '0' <= c && c <= '9'
 
@@ -30,10 +32,11 @@ let is_ident_start =
 let is_ident =
   either is_ident_start is_digit
 
+(* expect_char expects c at col of seq. If not, raise Expected. *)
 let expect_char col c seq =
   match seq () with
   | Seq.Nil -> expected col c
-  | Seq.Cons ((_, x), seq) ->
+  | Seq.Cons ((col, x), seq) ->
     if x = c then seq else expected col c
 
 let expect_token str tok seq =

main.ml

@@ -16,7 +16,8 @@ let error_to_string e =
     sprintf "unexpected token \"%s\" at col %d" t col
   | Type.Invalid t -> sprintf "invalid type %s" (Type.to_string t)
   | Eval.Unbound v -> sprintf "unbound value %s" v
-  | Eval.Too_many_arguments -> "applied too many arguments"
+  | Eval.No_such_method (m, t) ->
+    sprintf "no such method %s matching type %s" m (Type.to_string t)
   | Failure f -> sprintf "error on %s" f
   | Division_by_zero -> "cannot divide by zero"
   | _ -> raise e
@@ -29,43 +30,43 @@ let stdlib = [
   "deg"; "rad";
   "get_op_pre"; "set_op_pre";
   "get_op_assoc"; "set_op_assoc";
+  "print"; "println";
 ]
   |> List.to_seq
   |> Seq.map (fun v -> v, External v)
 
 (* global environment *)
 let g =
-  ref @@ Env.bind_seq stdlib Env.empty
+  let g = Hashtbl.create 100 in
+  Hashtbl.add_seq g stdlib;
+  g
 
 (* read-eval-print *) 
-let rep env : unit =
+let rep () : unit =
   printf "> ";
   let line = read_line () in
   if line = "quit" then raise Exit;
   let ast = line |> Lex.tokenize |> Parser.parse in
   if !debug then Ast.print ast;
-  let var, v = Eval.eval_top env ast in
+  let var, v = Eval.eval_top g ast in
-  match v with
+  Hashtbl.replace g "ans" v;
-  | Nop -> ()
-  | _ ->
-    g := Env.bind ("ans", v) !g;
   printf "%s: %s = %s\n"
     var (Type.to_string @@ Value.typeof v) (Value.to_string v)
 
 exception Reset_line (* used to indicate ^C is pressed *)
 
 let init_repl () =
-  g := Env.bind ("ans", Int 0) !g;
   (* treat Ctrl-C as to reset line *)
   let reset_line _ = raise Reset_line in
   Sys.(set_signal sigint (Signal_handle reset_line))
 
 (* simple REPL with error handling *)
-let rec repl env : unit =
+let rec repl () : unit =
-  try rep env; repl env with
+  try rep (); repl () with
   | Exit | End_of_file (* Ctrl-D *) -> ()
-  | Reset_line -> printf "\n"; repl env
+  | Noop -> repl ()
-  | e -> print_error e; repl env
+  | Reset_line -> printf "\n"; repl ()
+  | e -> print_error e; repl ()
 
 let speclist = [
   "--debug", Arg.Set debug, "print debug infos";
@@ -75,4 +76,4 @@ let () =
   Arg.parse speclist (fun _ -> ()) "";
   init_repl ();
   printf "Configurable Evaluator %s\n" version; (* banner *)
-  repl g
+  repl ()

parser.ml

@@ -19,18 +19,18 @@ let unexpected_token col t =
  * 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 = [
-  Eq, 1;
+  "=", 1;
-  Neq, 1;
+  "<>", 1;
-  GE, 1;
+  ">=", 1;
-  LE, 1;
+  "<=", 1;
-  GT, 1;
+  ">", 1;
-  LT, 1;
+  "<", 1;
-  Add, 10;
+  "+", 10;
-  Sub, 10;
+  "-", 10;
-  Mul, 20;
+  "*", 20;
-  Div, 20;
+  "/", 20;
-  Mod, 30;
+  "%", 30;
-  Exp, 30;
+  "^", 30;
 ] |> List.to_seq |> Hashtbl.of_seq
 
 let precedence_of op =
@@ -50,7 +50,7 @@ let assoc_to_string = function
   | Right_to_left -> "right"
 
 let oper_assoc = [
-  Exp, Right_to_left;
+  "^", Right_to_left;
 ] |> List.to_seq |> Hashtbl.of_seq
 
 let op_is_right_to_left op =
@@ -61,26 +61,25 @@ let op_is_right_to_left op =
   a = Right_to_left
 
 let operators = [
-  Token.Plus, Add;
+  Token.Plus;
-  Minus, Sub;
+  Minus;
-  Asterisk, Mul;
+  Asterisk;
-  Slash, Div;
+  Slash;
-  Carret, Exp;
+  Carret;
-  Percent, Mod;
+  Percent;
-  Equal, Eq;
+  Equal;
-  Not_equal, Neq;
+  Not_equal;
-  Greater_equal, GE;
+  Greater_equal;
-  Less_equal, LE;
+  Less_equal;
-  Greater, GT;
+  Greater;
-  Less, LT;
+  Less;
-] |> List.to_seq |> Hashtbl.of_seq
+]
 
 let token_to_op tok =
-  try Hashtbl.find operators tok
+  Token.to_string tok
-  with _ -> failwith "Parser.token_to_op"
 
 let token_is_operator tok =
-  Hashtbl.mem operators tok
+  List.mem tok operators
 
 let is_keyword = function
   | "if" | "then" | "else" | "let" | "in" -> true
@@ -177,9 +176,13 @@ and nothing seq =
 and let_global seq =
   let _, seq = ident "let" seq in
   let id, seq = any_ident seq in
+  let args, seq = more any_ident seq in
   let _, seq = token Token.Equal seq in
   let e, seq = expr min_int seq in
-  Let (id, e), seq
+  (if args = []
+   then Let (id, e)
+   else Let (id, Nfunction (args, e))),
+  seq
 
 (* expr := level
  *       | let_value
@@ -215,8 +218,7 @@ and lambda seq =
       let vars, seq = more any_ident seq in
       let _, seq = token Right_arrow seq in
       let e, seq = expr min_int seq in
-      List.fold_right (fun v f -> Nfunction (v, f)) (v0::vars) e,
+      Nfunction (v0::vars, e), seq)
-      seq)
 
 (* ifexpr := "if" expr "then" expr "else" expr *)
 and ifexpr seq =
@@ -247,7 +249,7 @@ and unary seq =
   let op, seq =
     let col, x, seq = any seq in
     if x = Minus
-    then Negate, seq
+    then "-", seq
     else expected col "minus (-)"
   in
   let v, seq = mustbe value seq in
@@ -269,9 +271,14 @@ and value seq =
         let _, t, seq = any seq in
         Nsymbol (Token.to_string t), seq
       | LParen ->
+        seq |> either
+          (fun seq ->
+             let _, seq = token RParen seq in
+             Nunit, seq)
+          (fun seq ->
              let e, seq = mustbe (expr min_int) seq in
              let _, seq = mustbe (token RParen) seq in
-        e, seq
+             e, seq)
       | _ -> unexpected_token col x
     end
 

todo.md

@@ -0,0 +1,5 @@
+# Todo
+
+- macro
+- implementing custom operator
+- abstract stack machine & compiler