initial commit

.gitignore

@@ -0,0 +1 @@
+_build

dune-project

@@ -0,0 +1 @@
+(lang dune 3.21)

shell.nix

@@ -0,0 +1,11 @@
+let
+  pkgs = import <nixpkgs> {};
+in
+  pkgs.mkShell {
+    packages = with pkgs.ocamlPackages; [
+      ocaml
+      dune_3
+      findlib
+      ppx_deriving
+    ];
+  }

src/dune

@@ -0,0 +1,6 @@
+(executable
+ (name main)
+ (preprocess (pps ppx_deriving.show)))
+
+(ocamllex lexer)
+(ocamlyacc parser)

src/exec.ml

@@ -0,0 +1,49 @@
+open Types
+
+let update m x v = fun y -> if x=y then v else m y
+
+let rec builtin_iop f =
+  let iop1 m v =
+    match m "", v with
+    | VInt a, VInt b -> EInt (f a b)
+    | _, _ -> raise (Failure "iop: not int") in
+  VFn (builtin, "", EFnB iop1)
+and builtin_bop f =
+  let bop1 m v =
+    match m "", v with
+    | VBool a, VBool b -> EBool (f a b)
+    | _, _ -> raise (Failure "bop: not bool") in
+  VFn (builtin, "", EFnB bop1)
+and builtin = function
+  | "add" -> builtin_iop (+)
+  | "sub" -> builtin_iop (-)
+  | "mul" -> builtin_iop ( * )
+  | "div" -> builtin_iop (/)
+  | "and" -> builtin_bop (&&)
+  | "or" -> builtin_bop (||)
+  | _ -> raise (Failure "undefined var")
+
+let rec eval (m: mem) (e: exp) : value =
+  match e with
+  | EInt i -> VInt i
+  | EBool b -> VBool b
+  | EVar x -> m x
+  | EFn (x, e) -> VFn (m, x, e)
+  | EFnB f -> VFnB (m, f)
+  | EApp (e1, e2) ->
+      (match eval m e1, eval m e2 with
+      | VFn (m, x, body), v -> eval (update m x v) body
+      | VFnB (m, f), v -> eval m (f m v)
+      | v, _ -> raise (Failure ("not a func")))
+  | EIf (b, e1, e2) ->
+      (match eval m b with
+      | VBool b -> eval m (if b then e1 else e2)
+      | _ -> raise (Failure "not a bool"))
+  | EScope s -> fst (exec m s)
+and exec (m: mem) (s: stmt) =
+  match s with
+  | SExp e -> eval m e, m
+  | SAsgn (x, e) ->
+      let v = eval m e in
+      v, update m x v
+  | SSeq (s1, s2) -> exec (snd (exec m s1)) s2

src/lexer.mll

@@ -0,0 +1,28 @@
+{
+  open Parser
+}
+rule token = parse
+  [' ' '\t' '\n']
+    { token lexbuf }
+  | '(' { LPAREN }
+  | ')' { RPAREN }
+  (* | '{' { LBRACE } *)
+  (* | '}' { RBRACE } *)
+  | ';' { SEMICOLON }
+  | '=' { EQUAL }
+  | '+' { PLUS }
+  | '-' { MINUS }
+  | '*' { TIMES }
+  | '/' { DIVIDE }
+  | "&&" { AND }
+  | "||" { OR }
+  | "if" { IF }
+  | "then" { THEN }
+  | "else" { ELSE }
+  | "true" { TRUE }
+  | "false" { FALSE }
+  | "fn" { FN }
+  | ['0'-'9']+ { NUM (int_of_string (Lexing.lexeme lexbuf)) }
+  | ['A'-'Z' 'a'-'z' '_'] (['A'-'Z' 'a'-'z' '0'-'9' '_'])*
+        { VAR (Lexing.lexeme lexbuf) }
+  | eof { EOF }

src/main.ml

@@ -0,0 +1,6 @@
+let main () =
+  let s = Parser.parse_stmt Lexer.token
+    (Lexing.from_channel (open_in Sys.argv.(1))) in
+  print_endline (Types.show_stmt s);
+  print_endline (Types.show_value (fst (Exec.exec Exec.builtin s)));;
+main ();;

src/parser.mly

@@ -0,0 +1,59 @@
+%{
+  open Types
+  let app2 x a b = EApp (EApp (EVar x, a), b)
+%}
+%token LPAREN RPAREN SEMICOLON EQUAL OR AND PLUS MINUS TIMES DIVIDE EOF
+%token IF THEN ELSE TRUE FALSE FN
+%token<int> NUM
+%token<string> VAR
+
+%nonassoc EQUAL IF THEN ELSE
+%left OR
+%left AND
+%right NOT
+%nonassoc TRUE FALSE
+%left PLUS MINUS
+%left TIMES DIVIDE
+%nonassoc NUM VAR
+%right LPAREN RPAREN
+%nonassoc EOF
+
+%start parse_stmt
+%type<Types.stmt> parse_stmt
+
+%%
+
+parse_stmt:
+  | stmt { $1 }
+  | stmt SEMICOLON parse_stmt { SSeq ($1,$3) }
+
+stmt:
+  | parse_exp { SExp $1 }
+  | VAR EQUAL parse_exp { SAsgn ($1,$3) }
+
+parse_exp:
+  | exp { $1 }
+  | parse_exp exp { EApp ($1,$2) }
+  | IF parse_exp THEN parse_exp ELSE parse_exp
+      { EIf ($2,$4,$6) }
+  | parse_exp AND parse_exp
+      { app2 "and" $1 $3 }
+  | parse_exp OR parse_exp
+      { app2 "or" $1 $3 }
+  | parse_exp PLUS parse_exp
+      { app2 "add" $1 $3 }
+  | parse_exp MINUS parse_exp
+      { app2 "sub" $1 $3 }
+  | parse_exp TIMES parse_exp
+      { app2 "mul" $1 $3 }
+  | parse_exp DIVIDE parse_exp
+      { app2 "div" $1 $3 }
+  | FN VAR parse_exp
+      { EFn ($2,$3) }
+
+exp:
+  | NUM { EInt $1 }
+  | TRUE { EBool true }
+  | FALSE { EBool false }
+  | VAR { EVar $1 }
+  | LPAREN parse_exp RPAREN { $2 }

src/types.ml

@@ -0,0 +1,26 @@
+type var = string
+[@@deriving show]
+
+type exp =
+  | EInt of int
+  | EBool of bool
+  | EVar of var
+  | EFn of (var * exp)
+  | EFnB of fnb
+  | EApp of (exp * exp)
+  | EIf of (exp * exp * exp)
+  | EScope of stmt
+[@@deriving show]
+and stmt =
+  | SExp of exp
+  | SAsgn of (var * exp)
+  | SSeq of (stmt * stmt)
+[@@deriving show]
+and mem = var -> value
+and fnb = mem -> value -> exp
+and value =
+  | VInt of int
+  | VBool of bool
+  | VFn of (mem * var * exp)
+  | VFnB of (mem * fnb)
+[@@deriving show]