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

Author: graydon

src/boot/driver/main.ml

@@ -24,6 +24,7 @@ let (sess:Session.sess) =
     Session.sess_out = None;
     Session.sess_library_mode = false;
     Session.sess_alt_backend = false;
+    Session.sess_use_pexps = false;
     (* FIXME (issue #69): need something fancier here for unix
      * sub-flavours.
      *)
@@ -214,6 +215,10 @@ let argspecs =
      "report dependencies of input, then exit");
     ("-version", Arg.Unit (fun _ -> print_version()),
      "print version information, then exit");
+
+    (flag (fun _ -> sess.Session.sess_use_pexps <- true)
+       "-pexp"         "use pexp portion of AST");
+
   ] @ (Glue.alt_argspecs sess)
 ;;
 

src/boot/driver/session.ml

@@ -13,6 +13,7 @@ type sess =
   mutable sess_out: filename option;
   mutable sess_library_mode: bool;
   mutable sess_alt_backend: bool;
+  mutable sess_use_pexps: bool;
   mutable sess_targ: target;
   mutable sess_log_lex: bool;
   mutable sess_log_parse: bool;

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

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)

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 =

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"
 ;;
 
 

src/boot/llvm/lltrans.ml

@@ -817,6 +817,8 @@ let trans_crate
           | Ast.ATOM_lval lval ->
               Llvm.build_load (fst (trans_lval lval)) (anon_llid "tmp")
                 llbuilder
+          | Ast.ATOM_pexp _ ->
+              bug () "Lltrans.trans_atom on ATOM_pexp"
       in
 
       let build_binop (op:Ast.binop) (lllhs:Llvm.llvalue) (llrhs:Llvm.llvalue)

src/boot/me/resolve.ml

@@ -495,6 +495,9 @@ let type_resolving_visitor
                 | Ast.COMP_atom (Ast.ATOM_literal _) -> ext
                 | Ast.COMP_atom (Ast.ATOM_lval lv) ->
                     Ast.COMP_atom (Ast.ATOM_lval (rebuild_lval lv))
+                | Ast.COMP_atom (Ast.ATOM_pexp _) ->
+                    bug () "Resolve.rebuild_lval' on ATOM_pexp"
+
                 | Ast.COMP_named (Ast.COMP_app (ident, params)) ->
                     Ast.COMP_named
                       (Ast.COMP_app (ident, Array.map resolve_ty params))

src/boot/me/semant.ml

@@ -1326,6 +1326,7 @@ let rec atom_type (cx:ctxt) (at:Ast.atom) : Ast.ty =
     | Ast.ATOM_literal {node=(Ast.LIT_nil); id=_} -> Ast.TY_nil
     | Ast.ATOM_literal {node=(Ast.LIT_mach_int (m,_)); id=_} -> Ast.TY_mach m
     | Ast.ATOM_lval lv -> lval_ty cx lv
+    | Ast.ATOM_pexp _ -> bug () "Semant.atom_type on ATOM_pexp"
 ;;
 
 let expr_type (cx:ctxt) (e:Ast.expr) : Ast.ty =

src/boot/me/trans.ml

@@ -1031,6 +1031,9 @@ let trans_visitor
       | Ast.ATOM_lval lv ->
           trans_const_lval lv
 
+      | Ast.ATOM_pexp _ ->
+          unimpl None "constant-folding pexp atom"
+
   and trans_const_expr
       (expr:Ast.expr)
       : (Ast.ty * const) =
@@ -1404,6 +1407,8 @@ let trans_visitor
             Il.Cell (fst (deref_ty DEREF_none false cell ty))
 
       | Ast.ATOM_literal lit -> trans_lit lit.node
+      | Ast.ATOM_pexp _ -> bug () "Trans.trans_atom on ATOM_pexp"
+
 
   and fixup_to_ptr_operand
       (imm_ok:bool)
@@ -3583,6 +3588,10 @@ let trans_visitor
                   dst_cell dst_ty
                   src_cell src_ty
 
+        | (_, Ast.EXPR_atom (Ast.ATOM_pexp _)) ->
+            bug () "Trans.trans_copy on ATOM_pexp"
+
+
   and trans_init_direct_fn
       (dst_cell:Il.cell)
       (flv:Ast.lval)

src/boot/me/type.ml

@@ -624,6 +624,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
     match atom with
         Ast.ATOM_lval lval -> check_lval ~deref:deref lval
       | Ast.ATOM_literal lit_id -> check_literal lit_id.Common.node
+      | Ast.ATOM_pexp _ -> Common.bug () "Type.check_atom on ATOM_pexp"
   in
 
   let infer_slot (ty:Ast.ty) (slot_id:Common.node_id) : unit =

src/boot/me/typestate.ml

@@ -258,6 +258,7 @@ and atom_slots (cx:ctxt) (a:Ast.atom) : node_id array =
   match a with
       Ast.ATOM_literal _ -> [| |]
     | Ast.ATOM_lval lv -> lval_slots cx lv
+    | Ast.ATOM_pexp _ -> bug () "Typestate.atom_slots on ATOM_pexp"
 ;;
 
 let lval_option_slots (cx:ctxt) (lv:Ast.lval option) : node_id array =

src/boot/me/walk.ml

@@ -557,6 +557,7 @@ and walk_atom
   match a with
       Ast.ATOM_literal ls -> walk_lit v ls.node
     | Ast.ATOM_lval lv -> walk_lval v lv
+    | Ast.ATOM_pexp _ -> bug () "Walk.walk_atom on ATOM_pexp"
 
 
 and walk_opt_atom

src/boot/util/fmt.ml

@@ -9,11 +9,12 @@ let fmt_str ff = fmt ff "%s"
 ;;
 
 let fmt_obox ff = Format.pp_open_box ff 4;;
-let fmt_obox_3 ff = Format.pp_open_box ff 3;;
+let fmt_obox_n ff n = Format.pp_open_box ff n;;
 let fmt_cbox ff = Format.pp_close_box ff ();;
 let fmt_obr ff = fmt ff "{";;
 let fmt_cbr ff = fmt ff "@\n}";;
 let fmt_cbb ff = (fmt_cbox ff; fmt_cbr ff);;
+let fmt_break ff = Format.pp_print_space ff ();;
 
 let fmt_bracketed
     (bra:string)
@@ -23,7 +24,9 @@ let fmt_bracketed
     (a:'a)
     : unit =
   fmt_str ff bra;
+  fmt_obox_n ff 0;
   inner ff a;
+  fmt_cbox ff;
   fmt_str ff ket
 ;;
 
@@ -37,7 +40,7 @@ let fmt_arr_sep
     begin
       fun i a ->
         if i <> 0
-        then fmt_str ff sep;
+        then (fmt_str ff sep; fmt_break ff);
         inner ff a
     end
     az