diff options
Diffstat (limited to 'discocaml/ast.ml')
| -rw-r--r-- | discocaml/ast.ml | 31 |
1 files changed, 21 insertions, 10 deletions
diff --git a/discocaml/ast.ml b/discocaml/ast.ml index d1652d8..b5ebba3 100644 --- a/discocaml/ast.ml +++ b/discocaml/ast.ml @@ -13,7 +13,7 @@ type 'a index = { index : int } [@@deriving show { with_path = false }] let get (arr : 'a Arraylist.t) (i : 'a index) : 'a = Arraylist.get arr i.index -type prim = [ `Add ] [@@deriving show { with_path = false }] +type prim = [ `Add | `Mul | `Sub ] [@@deriving show { with_path = false }] type expr = | App of expr index * expr index @@ -37,12 +37,29 @@ let add_expr_to_ast (ast : 'a ast) : Parsetree.expression -> expr index = Arraylist.push ast.subexprs expr; { index } in + let binop (prim : prim) : expr index = + add + (Lam + ( "$0", + add + (Lam ("$1", add (Prim (prim, [| add (Var "$0"); add (Var "$1") |])))) + )) + in + let rec loop (expr : Parsetree.expression) : expr index = match expr.pexp_desc with | Pexp_apply ( { pexp_desc = Pexp_ident { txt = Lident "+"; _ }; _ }, [ (Nolabel, l); (Nolabel, r) ] ) -> add (Prim (`Add, [| loop l; loop r |])) + | Pexp_apply + ( { pexp_desc = Pexp_ident { txt = Lident "-"; _ }; _ }, + [ (Nolabel, l); (Nolabel, r) ] ) -> + add (Prim (`Sub, [| loop l; loop r |])) + | Pexp_apply + ( { pexp_desc = Pexp_ident { txt = Lident "*"; _ }; _ }, + [ (Nolabel, l); (Nolabel, r) ] ) -> + add (Prim (`Mul, [| loop l; loop r |])) | Pexp_apply (f, xs) -> List.fold_left (fun f -> function @@ -54,15 +71,9 @@ let add_expr_to_ast (ast : 'a ast) : Parsetree.expression -> expr index = match arg_pat.ppat_desc with | Ppat_var { txt = name; _ } -> add (Lam (name, loop body)) | _ -> raise_unsupported_expr expr) - | Pexp_ident { txt = Lident "+"; _ } -> - add - (Lam - ( "$0", - add - (Lam - ( "$1", - add (Prim (`Add, [| add (Var "$0"); add (Var "$1") |])) )) - )) + | Pexp_ident { txt = Lident "+"; _ } -> binop `Add + | Pexp_ident { txt = Lident "-"; _ } -> binop `Sub + | Pexp_ident { txt = Lident "*"; _ } -> binop `Mul | Pexp_ident { txt = Lident name; _ } -> add (Var name) | _ -> raise_unsupported_expr expr in |