aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/boot/driver/main.ml5
-rw-r--r--src/boot/driver/session.ml1
-rw-r--r--src/boot/fe/ast.ml10
-rw-r--r--src/boot/fe/item.ml31
-rw-r--r--src/boot/fe/parser.ml1
-rw-r--r--src/boot/fe/pexp.ml5
-rw-r--r--src/boot/llvm/lltrans.ml2
-rw-r--r--src/boot/me/resolve.ml3
-rw-r--r--src/boot/me/semant.ml1
-rw-r--r--src/boot/me/trans.ml9
-rw-r--r--src/boot/me/type.ml1
-rw-r--r--src/boot/me/typestate.ml1
-rw-r--r--src/boot/me/walk.ml1
-rw-r--r--src/boot/util/fmt.ml7
14 files changed, 66 insertions, 12 deletions
diff --git a/src/boot/driver/main.ml b/src/boot/driver/main.ml
index 1e4c28e8..8f686522 100644
--- a/src/boot/driver/main.ml
+++ b/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)
;;
diff --git a/src/boot/driver/session.ml b/src/boot/driver/session.ml
index ce5a18fb..f8e79fe2 100644
--- a/src/boot/driver/session.ml
+++ b/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;
diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index 8551c566..44c56d62 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 3bf61f8c..00eb8387 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 0c7a2f6f..883ee01d 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 f5704416..58a64474 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"
;;
diff --git a/src/boot/llvm/lltrans.ml b/src/boot/llvm/lltrans.ml
index d83ae2d0..c116cf05 100644
--- a/src/boot/llvm/lltrans.ml
+++ b/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)
diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
index d957e3b7..1be2e3b9 100644
--- a/src/boot/me/resolve.ml
+++ b/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))
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 09576219..42df903b 100644
--- a/src/boot/me/semant.ml
+++ b/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 =
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index 757b9ef7..8053c0f9 100644
--- a/src/boot/me/trans.ml
+++ b/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)
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index b576af86..4e737be2 100644
--- a/src/boot/me/type.ml
+++ b/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 =
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index 466e04fe..a88adcd2 100644
--- a/src/boot/me/typestate.ml
+++ b/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 =
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
index 7b89cbd8..552debdf 100644
--- a/src/boot/me/walk.ml
+++ b/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
diff --git a/src/boot/util/fmt.ml b/src/boot/util/fmt.ml
index 650224ba..8fa41695 100644
--- a/src/boot/util/fmt.ml
+++ b/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
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-11 16:07:32 +0000