add parser

dune-project

@@ -1,3 +1,4 @@
 (lang dune 3.0)
 
+(using menhir 2.1)
 (using mdx 0.2)

src/a.flambda1

@@ -0,0 +1,35 @@
+let a = const 42 in
+let b = const 28 in
+
+let set =
+  make_closures
+  | cl_f { x } env ->
+    let aa = project_var v_a from env in
+    let cond = x == aa in
+    if cond then
+      let res = project_var v_a from env in res
+    else
+      let g = move_within_closures env cl_g in
+      g x
+    end
+  | cl_g { x } env ->
+    let f = move_within_closures env cl_f in
+    let one = const 1 in
+    let x = x - one in
+    f x
+  with vars
+  | v_a -> a
+  end
+in
+
+let f =
+  project_closure cl_f from set
+in
+
+let g =
+  project_closure cl_g from set
+in
+
+let arg = f b in
+
+print_int arg

src/dune

@@ -37,6 +37,16 @@
  (action
    (run texfot xelatex -halt-on-error -shell-escape main.tex)))
 
+(executable
+  (name main)
+  (modules main)
+  (libraries wasocaml_core))
+
 (library
   (name wasocaml_core)
-  (modules flambda_core_ast interpret))
+  (modules flambda_core_ast interpret menhir_parser parse  lexer)
+  (private_modules menhir_parser lexer)
+  (libraries menhirLib sedlex)
+  (preprocess (pps sedlex.ppx)))
+
+(menhir (modules menhir_parser))

src/flambda_core_ast.ml

@@ -15,6 +15,7 @@ and named =
   | Const of int
   | Sub of id * id
   | Physical_eq of id * id
+  | Print_int of id
   | Get_field of int * id
   | Make_block of int * id list
   | Make_closures of closure list * (id * id) list
@@ -70,6 +71,7 @@ and pp_named fmt = function
   | Const n -> pp fmt "const %d" n
   | Sub (id, id') -> pp fmt "%a - %a" pp_id id pp_id id'
   | Physical_eq (id, id') -> pp fmt "%a == %a" pp_id id pp_id id'
+  | Print_int id -> pp fmt "print_int %a" pp_id id
   | Get_field (n, id) -> pp fmt "get_field %d %a" n pp_id id
   | Make_block (n, ids) -> pp fmt "make_block %d %a" n pp_ids ids
   | Make_closures (closures, env) ->

src/interpret.ml

@@ -1,8 +1,79 @@
 open Flambda_core_ast
 
-type value =
-  | Scalar of int
-  | Func of (int -> int)
+module Value : sig
+  type t
+
+  type block
+
+  val unit : t
+
+  val bool : bool -> t
+
+  val scalar : int -> t
+
+  val block : int -> t array -> t
+
+  val func : (int -> int) -> t
+
+  val to_bool : t -> bool
+
+  val to_scalar : t -> int
+
+  val to_func : t -> int -> int
+
+  val to_block : t -> block
+
+  val is_scalar : t -> bool
+
+  val is_block : t -> bool
+
+  val get_block_tag : block -> int
+
+  val get_block_field : block -> int -> t
+
+  val print : t -> unit
+end = struct
+  type block =
+    { tag : int
+    ; data : t array
+    }
+
+  and t =
+    | Scalar of int
+    | Func of (int -> int)
+    | Block of block
+
+  let unit = Scalar 0
+
+  let bool b = if b then Scalar 1 else Scalar 0
+
+  let scalar n = Scalar n
+
+  let block tag data = Block { tag; data }
+
+  let func f = Func f
+
+  let to_bool = function Scalar n -> n <> 0 | Func _ | Block _ -> assert false
+
+  let to_scalar = function Scalar n -> n | Func _ | Block _ -> assert false
+
+  let to_func = function Func f -> f | Scalar _ | Block _ -> assert false
+
+  let to_block = function Block b -> b | Scalar _ | Func _ -> assert false
+
+  let is_scalar = function Scalar _n -> true | Func _ | Block _ -> false
+
+  let is_block = function Block _ -> true | Scalar _ | Func _ -> false
+
+  let get_block_tag { tag; data = _ } = tag
+
+  let get_block_field { tag = _; data } n = data.(n)
+
+  let print = function
+    | Block _ -> Format.printf "block@\n"
+    | Scalar n -> Format.printf "scalar %d@\n" n
+    | Func _ -> Format.printf "func@\n"
+end
 
 module Id_map = struct
   include Map.Make (struct
@@ -15,36 +86,23 @@ end
 module Env : sig
   type t
 
-  val find_id : t -> Id_map.key -> value
+  val empty : t
 
-  val find_id_as_scalar : t -> Id_map.key -> int
+  val find_id : t -> Id_map.key -> Value.t
 
-  val find_id_as_func : t -> Id_map.key -> int -> int
-
-  val add_id : t -> Id_map.key -> value -> t
+  val add_id : t -> Id_map.key -> Value.t -> t
 end = struct
-  type t = { id_map : value Id_map.t }
-
-  let find_id env id = Id_map.find id env.id_map
+  type t = { id_map : Value.t Id_map.t }
 
-  let find_id_as_scalar env id =
-    match find_id env id with Scalar n -> n | Func _f -> assert false
+  let empty = { id_map = Id_map.empty }
 
-  let find_id_as_func env id =
-    match find_id env id with Scalar _n -> assert false | Func f -> f
+  let find_id env id = Id_map.find id env.id_map
 
   let add_id env id v =
     let id_map = Id_map.add id v env.id_map in
     { id_map }
 end
 
-let unit = Scalar 0
-
-let to_bool = function
-  | Scalar 0 -> false
-  | Scalar _n -> true
-  | Func _ -> assert false
-
 exception Static_raise of id * id list
 
 let rec eval_term env = function
@@ -56,21 +114,22 @@ let rec eval_term env = function
   | Mutate (id, id') ->
     let v = Env.find_id env id' in
     let env = Env.add_id env id v in
-    (env, unit)
+    (env, Value.unit)
   | Apply (f, v) ->
-    let f = Env.find_id_as_func env f in
-    let v = Env.find_id_as_scalar env v in
-    (env, Scalar (f v))
-  | If_then_else (cond, e1, e2) ->
-    let cond = to_bool @@ Env.find_id env cond in
-    let term = if cond then e1 else e2 in
+    let f = Value.to_func @@ Env.find_id env f in
+    let v = Value.to_scalar @@ Env.find_id env v in
+    let v = f v in
+    (env, Value.scalar v)
+  | If_then_else (cond, t1, t2) ->
+    let cond = Value.to_bool @@ Env.find_id env cond in
+    let term = if cond then t1 else t2 in
     eval_term env term
   | While (cond, t) ->
     let env, v = eval_term env cond in
-    if to_bool v then
+    if Value.to_bool v then
       let env, _v = eval_term env t in
       eval_term env (While (cond, t))
-    else (env, unit)
+    else (env, Value.unit)
   | Raise (id, ids) -> raise (Static_raise (id, ids))
   | Try_catch (t, id, _ids, t') -> begin
     (* TODO: _ids ? *)
@@ -79,6 +138,43 @@ let rec eval_term env = function
       (* TODO: ids' ? *)
       if id <> id' then raise (Static_raise (id', ids')) else eval_term env t'
   end
-  | _ -> assert false
+  | Switch (id, scalar_cases, block_cases) ->
+    let v = Env.find_id env id in
+    let tag, cases =
+      if Value.is_scalar v then
+        let n = Value.to_scalar v in
+        (n, scalar_cases)
+      else
+        let b = Value.to_block v in
+        let tag = Value.get_block_tag b in
+        (tag, block_cases)
+    in
+    let _tag, term = List.find (fun (tag', _term) -> tag = tag') cases in
+    eval_term env term
 
-and eval_named env = function Const n -> (env, Scalar n) | _ -> assert false
+and eval_named env = function
+  | Const n ->
+    let v = Value.scalar n in
+    (env, v)
+  | Sub (id, id') ->
+    let n = Value.to_scalar @@ Env.find_id env id in
+    let n' = Value.to_scalar @@ Env.find_id env id' in
+    let v = Value.scalar (n - n') in
+    (env, v)
+  | Physical_eq (id, id') ->
+    let v = Env.find_id env id in
+    let v' = Env.find_id env id' in
+    (* TODO: ? *)
+    let eq = Value.bool (v == v') in
+    (env, eq)
+  | Get_field (n, id) ->
+    let block = Value.to_block @@ Env.find_id env id in
+    let field = Value.get_block_field block n in
+    (env, field)
+  | Make_block (tag, ids) ->
+    let data = Array.of_list @@ List.map (Env.find_id env) ids in
+    let block = Value.block tag data in
+    (env, block)
+  | _ ->
+    let _foo = Value.func succ in
+    assert false

src/lexer.ml

@@ -0,0 +1,105 @@
+open Sedlexing
+open Menhir_parser
+
+exception Error of Lexing.position * string
+
+let blank = [%sedlex.regexp? ' ' | '\t']
+
+let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"]
+
+let any_blank = [%sedlex.regexp? blank | newline]
+
+let sign = [%sedlex.regexp? '+' | '-']
+
+let digit = [%sedlex.regexp? '0' .. '9']
+
+let hexdigit = [%sedlex.regexp? digit | 'a' .. 'f' | 'A' .. 'F']
+
+let num = [%sedlex.regexp? digit, Star (Opt '_', digit)]
+
+let hexnum = [%sedlex.regexp? hexdigit, Star (Opt '_', hexdigit)]
+
+let nat = [%sedlex.regexp? num | "0x", hexnum]
+
+let int = [%sedlex.regexp? sign, nat]
+
+let num = [%sedlex.regexp? int | nat]
+
+let id_char = [%sedlex.regexp? 'a' .. 'z' | '_']
+
+let id = [%sedlex.regexp? Plus id_char]
+
+let err buf msg =
+  let position = fst @@ lexing_positions buf in
+  let tok = Utf8.lexeme buf in
+  raise @@ Error (position, Printf.sprintf "%s %S" msg tok)
+
+let rec token buf =
+  match%sedlex buf with
+  | Plus any_blank -> token buf
+  | num -> NUM (Utf8.lexeme buf)
+  | "|" -> BAR
+  | "==" -> DOUBLE_EQUAL
+  | "=" -> EQUAL
+  | "-" -> HYPHEN
+  | "<-" -> LEFT_ARROW
+  | "{" -> LEFT_BRACKET
+  | "->" -> RIGHT_ARROW
+  | "}" -> RIGHT_BRACKET
+  | ";" -> SEMI_COLON
+  | "catch" -> CATCH
+  | "const" -> CONST
+  | "do" -> DO
+  | "if" -> IF
+  | "in" -> IN
+  | "int" -> INT
+  | "else" -> ELSE
+  | "end" -> END
+  | "from" -> FROM
+  | "get_field" -> GET_FIELD
+  | "let" -> LET
+  | "make_block" -> MAKE_BLOCK
+  | "make_closures" -> MAKE_CLOSURES
+  | "move_within_closures" -> MOVE_WITHIN_CLOSURES
+  | "print_int" -> PRINT_INT
+  | "project_closure" -> PROJECT_CLOSURE
+  | "project_var" -> PROJECT_VAR
+  | "raise" -> RAISE
+  | "switch" -> SWITCH
+  | "tag" -> TAG
+  | "then" -> THEN
+  | "try" -> TRY
+  | "vars" -> VARS
+  | "while" -> WHILE
+  | "with" -> WITH
+  | "(*" ->
+    comment buf;
+    token buf
+  (* other *)
+  | id ->
+    let id = Utf8.lexeme buf in
+    ID id
+  | eof -> EOF
+  | _ ->
+    let position = fst @@ lexing_positions buf in
+    let tok = Utf8.lexeme buf in
+    raise @@ Error (position, Printf.sprintf "unexpected character `%S`" tok)
+
+and comment buf =
+  match%sedlex buf with
+  | "*)" -> ()
+  | "(*" ->
+    comment buf;
+    comment buf
+  | eof -> Format.ksprintf failwith "eof in comment"
+  | any -> comment buf
+  | _ -> assert false
+
+and single_comment buf =
+  match%sedlex buf with
+  | newline -> ()
+  | eof -> Format.ksprintf failwith "eof in single line comment"
+  | any -> single_comment buf
+  | _ -> assert false
+
+let lexer buf = Sedlexing.with_tokenizer token buf

src/main.ml

@@ -0,0 +1,22 @@
+let () =
+  if Array.length Sys.argv <> 2 then
+    Format.ksprintf failwith "usage: %s <file>" Sys.argv.(0)
+
+let filename = Sys.argv.(1)
+
+let () =
+  if not @@ Sys.file_exists filename then
+    Format.ksprintf failwith "file %s doesn't exist" filename
+
+open Wasocaml_core
+
+let ast =
+  match Parse.from_file ~filename with
+  | Error msg -> failwith msg
+  | Ok ast -> ast
+
+let env = Interpret.Env.empty
+
+let _env, value = Interpret.eval_term env ast
+
+let () = Interpret.Value.print value

src/menhir_parser.mly

@@ -0,0 +1,68 @@
+%token <String.t> NUM
+%token <String.t> ID
+%token BAR DOUBLE_EQUAL EOF EQUAL HYPHEN LEFT_ARROW LEFT_BRACKET RIGHT_ARROW RIGHT_BRACKET SEMI_COLON
+%token CATCH CONST DO IF IN INT ELSE END FROM GET_FIELD LET MAKE_BLOCK MAKE_CLOSURES MOVE_WITHIN_CLOSURES PRINT_INT PROJECT_CLOSURE PROJECT_VAR RAISE SWITCH TAG THEN TRY VARS WHILE WITH
+
+%{
+  open Flambda_core_ast
+%}
+
+%start <Flambda_core_ast.term> file
+
+%%
+
+(* Helpers *)
+
+(*
+let par(X) ==
+  | LPAR; ~ = X; RPAR; <>
+*)
+
+(* Types *)
+
+let id ==
+  | ~ = ID; <>
+
+let num ==
+  | n = NUM; { int_of_string n }
+
+let int_case ==
+  | BAR; INT; ~ = num; RIGHT_ARROW; ~ = term; <>
+
+let tag_case ==
+  | BAR; TAG; ~ = num; RIGHT_ARROW; ~ = term; <>
+
+let term :=
+  | ~ = id; <Variable>
+  | LET; ~ = id; EQUAL; ~ = named; IN; ~ = term; <Let>
+  | i1 = id; LEFT_ARROW; i2 = id; <Mutate>
+  | i1 = id; i2 = id; <Apply>
+  | IF; ~ = id; THEN; t1 = term; ELSE; t2 = term; END; <If_then_else>
+  | SWITCH; ~ = id; WITH; ~ = list(int_case); ~ = list(tag_case); END; <Switch>
+  | RAISE; ~ = id; ~ = list(id); SEMI_COLON; <Raise>
+  | TRY; t1 = term; CATCH; ~ = id; ~ = list(id); RIGHT_ARROW; t2 = term; END; <Try_catch>
+  | WHILE; t1 = term; DO; t2 = term; END; <While>
+
+let named ==
+  | CONST; ~ = num; <Const>
+  | PRINT_INT; ~ = id; <Print_int>
+  | i1 = id; HYPHEN; i2 = id; <Sub>
+  | i1 = id; DOUBLE_EQUAL; i2 = id; <Physical_eq>
+  | GET_FIELD; ~ = num; ~ = id; <Get_field>
+  | MAKE_BLOCK; ~ = num; ~ = list(id); <Make_block>
+  | MAKE_CLOSURES;
+    (* TODO: can this be empty ? *)
+    ~ = list(closures);
+    WITH; VARS; ~ = list(vars); END; <Make_closures>
+  | PROJECT_CLOSURE; i1 = id; FROM; i2 = id; <Project_closure>
+  | PROJECT_VAR; i1 = id; FROM; i2 = id; <Project_var>
+  | MOVE_WITHIN_CLOSURES; i1 = id; i2 = id; <Move_within_closure>
+
+let closures ==
+  | BAR; i1 = id; LEFT_BRACKET; i2 = id; RIGHT_BRACKET; i3 = id; RIGHT_ARROW; ~ = term; <>
+
+let vars ==
+  | BAR; i1 = id; RIGHT_ARROW; i2 = id; <>
+
+let file :=
+  | ~ = term; EOF; <>

src/parse.ml

@@ -0,0 +1,46 @@
+let from_lexbuf =
+  let parser =
+    MenhirLib.Convert.Simplified.traditional2revised Menhir_parser.file
+  in
+  fun buf ->
+    let provider () =
+      let tok = Lexer.token buf in
+      let start, stop = Sedlexing.lexing_positions buf in
+      (tok, start, stop)
+    in
+    try Ok (parser provider) with
+    | Menhir_parser.Error ->
+      let start, _stop = Sedlexing.lexing_positions buf in
+      Format.ksprintf failwith "File %s, line %i, character %i: parse error"
+        start.pos_fname start.pos_lnum
+        (start.pos_cnum - start.pos_bol)
+    | Lexer.Error (pos, msg) ->
+      let file_line =
+        let cpos = pos.pos_cnum - pos.pos_bol in
+        Printf.sprintf "File \"%s\", line %i, character %i:" pos.pos_fname
+          pos.pos_lnum cpos
+      in
+      let msg = Printf.sprintf "Error: Lexing error %s" msg in
+      Format.ksprintf failwith "%s\n%s\n" file_line msg
+    | Failure msg ->
+      let msg = Printf.sprintf "Error: Lexing error %s" msg in
+      Format.ksprintf failwith "%s\n" msg
+
+(** Parse a script from a string. *)
+let from_string s = from_lexbuf (Sedlexing.Utf8.from_string s)
+
+(** Parse a script from a channel. *)
+let from_channel c = from_lexbuf (Sedlexing.Utf8.from_channel c)
+
+(** Parse a script from a file. *)
+let from_file ~filename =
+  let chan = open_in filename in
+  let result =
+    Fun.protect
+      ~finally:(fun () -> close_in chan)
+      (fun () ->
+        let lb = Sedlexing.Utf8.from_channel chan in
+        Sedlexing.set_filename lb filename;
+        from_lexbuf lb )
+  in
+  result