Add Ast.ATOM_pexp and -pexp mode wherein pexps live beyond parsing, into later stages. Fixes to pexp pretty printer.

4 files changed, 37 insertions, 10 deletions

diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index 8551c5667d1..44c56d62341 100644
--- a/src/boot/fe/ast.ml
+++ b/src/boot/fe/ast.ml
@@ -318,6 +318,7 @@ and port_case =
 and atom =
     ATOM_literal of (lit identified)
   | ATOM_lval of lval
+  | ATOM_pexp of pexp
 
 and expr =
     EXPR_binary of (binop * atom * atom)
@@ -930,6 +931,7 @@ and fmt_pexp (ff:Format.formatter) (pexp:pexp) : unit =
           fmt_bracketed_arr_sep "(" ")" "," fmt_opt ff arg_opts
 
     | PEXP_rec (elts, base) ->
+        fmt_obox_n ff 0;
         fmt ff "rec(";
         let fmt_elt ff (ident, mut, pexp) =
           fmt_mutability ff mut;
@@ -945,6 +947,7 @@ and fmt_pexp (ff:Format.formatter) (pexp:pexp) : unit =
                   fmt ff " with ";
                   fmt_pexp ff b
           end;
+          fmt_cbox ff;
           fmt ff ")"
 
     | PEXP_tup elts ->
@@ -1014,11 +1017,11 @@ and fmt_pexp (ff:Format.formatter) (pexp:pexp) : unit =
     | PEXP_lit lit ->
         fmt_lit ff lit
 
-    | PEXP_str str -> fmt_str ff str
+    | PEXP_str str -> fmt_str ff  ("\"" ^ str ^ "\"")
 
     | PEXP_box (mut, pexp) ->
         fmt_mutability ff mut;
-        fmt ff "@";
+        fmt ff "@@";
         fmt_pexp ff pexp
 
     | PEXP_custom (name, args, txt) ->
@@ -1089,6 +1092,7 @@ and fmt_atom (ff:Format.formatter) (a:atom) : unit =
   match a with
       ATOM_literal lit -> fmt_lit ff lit.node
     | ATOM_lval lval -> fmt_lval ff lval
+    | ATOM_pexp pexp -> fmt_pexp ff pexp
 
 and fmt_atoms (ff:Format.formatter) (az:atom array) : unit =
   fmt ff "(";
@@ -1200,7 +1204,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
               | Some e ->
                   begin
                     fmt_cbb ff;
-                    fmt_obox_3 ff;
+                    fmt_obox_n ff 3;
                     fmt ff " else ";
                     fmt_obr ff;
                     fmt_stmts ff e.node
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index 3bf61f8c494..00eb8387adf 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -17,7 +17,9 @@ let empty_view = { Ast.view_imports = Hashtbl.create 0;
 
 let rec parse_expr (ps:pstate) : (Ast.stmt array * Ast.expr) =
   let pexp = ctxt "expr" Pexp.parse_pexp ps in
-    Pexp.desugar_expr ps pexp
+    if ps.pstate_sess.Session.sess_use_pexps
+    then ([||], Ast.EXPR_atom (Ast.ATOM_pexp pexp))
+    else Pexp.desugar_expr ps pexp
 
 and parse_prim_expr (ps:pstate) : Ast.expr =
   let pexp = ctxt "expr" Pexp.parse_pexp ps in
@@ -28,7 +30,9 @@ and parse_prim_expr (ps:pstate) : Ast.expr =
 
 and parse_expr_atom (ps:pstate) : (Ast.stmt array * Ast.atom) =
   let pexp = ctxt "expr" Pexp.parse_pexp ps in
-    Pexp.desugar_expr_atom ps pexp
+    if ps.pstate_sess.Session.sess_use_pexps
+    then ([||], Ast.ATOM_pexp pexp)
+    else Pexp.desugar_expr_atom ps pexp
 
 and parse_expr_atom_list
     (bra:token)
@@ -39,12 +43,29 @@ and parse_expr_atom_list
             (ctxt "expr-atom list" parse_expr_atom) ps)
 
 and parse_expr_init (lv:Ast.lval) (ps:pstate) : (Ast.stmt array) =
+  let apos = lexpos ps in
   let pexp = ctxt "expr" Pexp.parse_pexp ps in
-    Pexp.desugar_expr_init ps lv pexp
+  let bpos = lexpos ps in
+    if ps.pstate_sess.Session.sess_use_pexps
+    then [|
+      span ps apos bpos
+        (Ast.STMT_copy (lv, Ast.EXPR_atom (Ast.ATOM_pexp pexp)))
+    |]
+    else Pexp.desugar_expr_init ps lv pexp
 
 and parse_lval (ps:pstate) : (Ast.stmt array * Ast.lval) =
-  let pexp = Pexp.parse_pexp ps in
-    Pexp.desugar_lval ps pexp
+  let apos = lexpos ps in
+  let pexp = ctxt "lval" Pexp.parse_pexp ps in
+  let bpos = lexpos ps in
+    if ps.pstate_sess.Session.sess_use_pexps
+    then
+      let (_, tmp, decl_stmt) = build_tmp ps slot_auto apos bpos in
+      let copy_stmt =
+        span ps apos bpos
+          (Ast.STMT_copy (tmp, Ast.EXPR_atom (Ast.ATOM_pexp pexp)))
+      in
+        ([| decl_stmt; copy_stmt |], (clone_lval ps tmp))
+    else Pexp.desugar_lval ps pexp
 
 and parse_identified_slot_and_ident
     (aliases_ok:bool)
diff --git a/src/boot/fe/parser.ml b/src/boot/fe/parser.ml
index 0c7a2f6f543..883ee01d0ae 100644
--- a/src/boot/fe/parser.ml
+++ b/src/boot/fe/parser.ml
@@ -164,6 +164,7 @@ let clone_atom (ps:pstate) (atom:Ast.atom) : Ast.atom =
   match atom with
       Ast.ATOM_literal _ -> atom
     | Ast.ATOM_lval lv -> Ast.ATOM_lval (clone_lval ps lv)
+    | Ast.ATOM_pexp _ -> bug () "Parser.clone_atom on ATOM_pexp"
 ;;
 
 let ctxt (n:string) (f:pstate -> 'a) (ps:pstate) : 'a =
diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml
index f57044161fd..58a6447430d 100644
--- a/src/boot/fe/pexp.ml
+++ b/src/boot/fe/pexp.ml
@@ -1263,10 +1263,11 @@ and desugar_expr_init
             aa arg_stmts stmts
 
 
-and atom_lval (ps:pstate) (at:Ast.atom) : Ast.lval =
+and atom_lval (_:pstate) (at:Ast.atom) : Ast.lval =
   match at with
       Ast.ATOM_lval lv -> lv
-    | Ast.ATOM_literal _ -> raise (err "literal where lval expected" ps)
+    | Ast.ATOM_literal _
+    | Ast.ATOM_pexp _ -> bug () "Pexp.atom_lval on non-ATOM_lval"
 ;;