aboutsummaryrefslogtreecommitdiff
path: root/src/boot/fe
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/fe')
-rw-r--r--src/boot/fe/ast.ml41
-rw-r--r--src/boot/fe/cexp.ml45
-rw-r--r--src/boot/fe/item.ml24
-rw-r--r--src/boot/fe/lexer.mll87
-rw-r--r--src/boot/fe/parser.ml3
-rw-r--r--src/boot/fe/pexp.ml29
6 files changed, 166 insertions, 63 deletions
diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index 3f3d5145..79ff2c7c 100644
--- a/src/boot/fe/ast.ml
+++ b/src/boot/fe/ast.ml
@@ -199,7 +199,7 @@ and tup_input = (mutability * atom)
and stmt' =
(* lval-assigning stmts. *)
- STMT_spawn of (lval * domain * lval * (atom array))
+ STMT_spawn of (lval * domain * string * lval * (atom array))
| STMT_new_rec of (lval * (rec_input array) * lval option)
| STMT_new_tup of (lval * (tup_input array))
| STMT_new_vec of (lval * mutability * atom array)
@@ -259,7 +259,7 @@ and stmt_alt_type =
and stmt_alt_port =
{
- (* else lval is a timeout value. *)
+ (* else atom is a timeout value. *)
alt_port_arms: port_arm array;
alt_port_else: (atom * block) option;
}
@@ -328,7 +328,7 @@ and type_arm = type_arm' identified
and port_arm' = port_case * block
and port_arm = port_arm' identified
-and port_case =
+and port_case =
PORT_CASE_send of (lval * lval)
| PORT_CASE_recv of (lval * lval)
@@ -664,7 +664,7 @@ and fmt_constrained ff (ty, constrs) : unit =
fmt_constrs ff constrs;
fmt ff "@]";
fmt ff "@]";
-
+
and fmt_ty (ff:Format.formatter) (t:ty) : unit =
match t with
@@ -707,7 +707,7 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit =
| TY_tag ttag -> fmt_tag ff ttag
| TY_iso tiso -> fmt_iso ff tiso
| TY_idx idx -> fmt ff "<idx#%d>" idx
- | TY_constrained ctrd -> fmt_constrained ff ctrd
+ | TY_constrained ctrd -> fmt_constrained ff ctrd
| TY_obj (effect, fns) ->
fmt_obox ff;
@@ -942,10 +942,11 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt ff ";"
end
- | STMT_spawn (dst, domain, fn, args) ->
+ | STMT_spawn (dst, domain, name, fn, args) ->
fmt_lval ff dst;
fmt ff " = spawn ";
fmt_domain ff domain;
+ fmt_str ff ("\"" ^ name ^ "\"");
fmt_lval ff fn;
fmt_atoms ff args;
fmt ff ";";
@@ -1233,7 +1234,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
Array.iter (fmt_tag_arm ff) at.alt_tag_arms;
fmt_cbb ff;
- | STMT_alt_type at ->
+ | STMT_alt_type at ->
fmt_obox ff;
fmt ff "alt type (";
fmt_lval ff at.alt_type_lval;
@@ -1241,7 +1242,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_obr ff;
Array.iter (fmt_type_arm ff) at.alt_type_arms;
begin
- match at.alt_type_else with
+ match at.alt_type_else with
None -> ()
| Some block ->
fmt ff "@\n";
@@ -1252,7 +1253,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_cbb ff;
end;
fmt_cbb ff;
- | STMT_alt_port at ->
+ | STMT_alt_port at ->
fmt_obox ff;
fmt ff "alt ";
fmt_obr ff;
@@ -1271,13 +1272,13 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_cbb ff;
end;
fmt_cbb ff;
- | STMT_note at ->
+ | STMT_note at ->
begin
fmt ff "note ";
fmt_atom ff at;
fmt ff ";"
end
- | STMT_slice (dst, src, slice) ->
+ | STMT_slice (dst, src, slice) ->
fmt_lval ff dst;
fmt ff " = ";
fmt_lval ff src;
@@ -1285,11 +1286,11 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
fmt_slice ff slice;
fmt ff ";";
end
-
-and fmt_arm
- (ff:Format.formatter)
+
+and fmt_arm
+ (ff:Format.formatter)
(fmt_arm_case_expr : Format.formatter -> unit)
- (block : block)
+ (block : block)
: unit =
fmt ff "@\n";
fmt_obox ff;
@@ -1299,18 +1300,17 @@ and fmt_arm
fmt_obr ff;
fmt_stmts ff block.node;
fmt_cbb ff;
-
+
and fmt_tag_arm (ff:Format.formatter) (tag_arm:tag_arm) : unit =
let (pat, block) = tag_arm.node in
fmt_arm ff (fun ff -> fmt_pat ff pat) block;
-
+
and fmt_type_arm (ff:Format.formatter) (type_arm:type_arm) : unit =
let ((ident, slot), block) = type_arm.node in
let fmt_type_arm_case (ff:Format.formatter) =
fmt_slot ff slot; fmt ff " "; fmt_ident ff ident
in
fmt_arm ff fmt_type_arm_case block;
-
and fmt_port_arm (ff:Format.formatter) (port_arm:port_arm) : unit =
let (port_case, block) = port_arm.node in
fmt_arm ff (fun ff -> fmt_port_case ff port_case) block;
@@ -1320,7 +1320,6 @@ and fmt_port_case (ff:Format.formatter) (port_case:port_case) : unit =
PORT_CASE_send params -> STMT_send params
| PORT_CASE_recv params -> STMT_recv params in
fmt_stmt ff {node = stmt'; id = Node 0};
-
and fmt_pat (ff:Format.formatter) (pat:pat) : unit =
match pat with
@@ -1351,9 +1350,9 @@ and fmt_slice (ff:Format.formatter) (slice:slice) : unit =
fmt ff "@]";
end;
fmt ff "@])";
-
-
+
+
and fmt_decl_param (ff:Format.formatter) (param:ty_param) : unit =
let (ident, (i, e)) = param in
diff --git a/src/boot/fe/cexp.ml b/src/boot/fe/cexp.ml
index fc849b28..9c1b40e1 100644
--- a/src/boot/fe/cexp.ml
+++ b/src/boot/fe/cexp.ml
@@ -310,7 +310,7 @@ type cdir =
| CDIR_mod of (Ast.ident * Ast.mod_item)
| CDIR_auth of auth
-type env = { env_bindings: (Ast.ident * pval) list;
+type env = { env_bindings: ((Ast.ident * pval) list) ref;
env_prefix: filename list;
env_items: (filename, Ast.mod_items) Hashtbl.t;
env_files: (node_id,filename) Hashtbl.t;
@@ -357,10 +357,11 @@ and eval_cexp (env:env) (exp:cexp) : cdir array =
| CEXP_let {node=cl} ->
let ident = cl.let_ident in
let v = eval_pexp env cl.let_value in
- let env = { env with
- env_bindings = ((ident,v)::env.env_bindings ) }
- in
- eval_cexps env cl.let_body
+ let old_bindings = !(env.env_bindings) in
+ env.env_bindings := (ident,v)::old_bindings;
+ let res = eval_cexps env cl.let_body in
+ env.env_bindings := old_bindings;
+ res
| CEXP_src_mod {node=s; id=id} ->
let name = s.src_ident in
@@ -381,6 +382,7 @@ and eval_cexp (env:env) (exp:cexp) : cdir array =
ps.pstate_opaque_id
ps.pstate_sess
ps.pstate_get_mod
+ ps.pstate_get_cenv_tok
ps.pstate_infer_lib_name
env.env_required
env.env_required_syms
@@ -518,7 +520,7 @@ and eval_pexp (env:env) (exp:Pexp.pexp) : pval =
| Pexp.PEXP_lval (Pexp.PLVAL_ident ident) ->
begin
- match ltab_search env.env_bindings ident with
+ match ltab_search !(env.env_bindings) ident with
None -> raise (err (Printf.sprintf "no binding for '%s' found"
ident) env.env_ps)
| Some v -> v
@@ -622,11 +624,6 @@ let parse_crate_file
let oref = ref (Opaque 0) in
let required = Hashtbl.create 4 in
let required_syms = Hashtbl.create 4 in
- let ps =
- make_parser tref nref oref sess get_mod
- infer_lib_name required required_syms fname
- in
-
let files = Hashtbl.create 0 in
let items = Hashtbl.create 4 in
let target_bindings =
@@ -648,11 +645,23 @@ let parse_crate_file
("build_input", PVAL_str fname);
]
in
- let initial_bindings =
- target_bindings
- @ build_bindings
+ let bindings =
+ ref (target_bindings
+ @ build_bindings)
in
- let env = { env_bindings = initial_bindings;
+ let get_cenv_tok ps ident =
+ match ltab_search (!bindings) ident with
+ None -> raise (err (Printf.sprintf "no binding for '%s' found"
+ ident) ps)
+ | Some (PVAL_bool b) -> LIT_BOOL b
+ | Some (PVAL_str s) -> LIT_STR s
+ | Some (PVAL_num n) -> LIT_INT n
+ in
+ let ps =
+ make_parser tref nref oref sess get_mod get_cenv_tok
+ infer_lib_name required required_syms fname
+ in
+ let env = { env_bindings = bindings;
env_prefix = [Filename.dirname fname];
env_items = Hashtbl.create 0;
env_files = files;
@@ -720,8 +729,12 @@ let parse_src_file
let oref = ref (Opaque 0) in
let required = Hashtbl.create 0 in
let required_syms = Hashtbl.create 0 in
+ let get_cenv_tok ps ident =
+ raise (err (Printf.sprintf "no binding for '%s' found"
+ ident) ps)
+ in
let ps =
- make_parser tref nref oref sess get_mod
+ make_parser tref nref oref sess get_mod get_cenv_tok
infer_lib_name required required_syms fname
in
with_err_handling sess
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index 67a482a6..a47fca5a 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -556,7 +556,11 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
let stmts = expand_tags_to_stmts ps item in
spans ps stmts apos (Ast.STMT_decl decl)
- | _ ->
+ | token ->
+ if token = SPAWN then
+ prerr_endline ("warning: \"spawn\" with unused result spawns a " ^
+ "task that immediately dies");
+
let (lstmts, lval) = ctxt "stmt: lval" parse_lval ps in
let stmts =
match peek ps with
@@ -834,9 +838,17 @@ and parse_mod_item (ps:pstate) : (Ast.ident * Ast.mod_item) =
EQ ->
begin
bump ps;
- match peek ps with
- LIT_STR s -> (bump ps; s)
- | _ -> raise (unexpected ps)
+ let do_tok t =
+ bump ps;
+ match t with
+ LIT_STR s -> s
+ | _ -> raise (unexpected ps)
+ in
+ match peek ps with
+ IDENT i ->
+ do_tok (ps.pstate_get_cenv_tok ps i)
+ | t ->
+ do_tok t
end
| _ -> ps.pstate_infer_lib_name ident
in
@@ -888,14 +900,14 @@ and parse_mod_item (ps:pstate) : (Ast.ident * Ast.mod_item) =
| _ -> CONV_cdecl
in
expect ps MOD;
- let (ident, params) = parse_ident_and_params ps "native mod" in
+ let ident = Pexp.parse_ident ps in
let path = parse_lib_name ident in
let items = parse_mod_items_from_signature ps in
let bpos = lexpos ps in
let rlib = REQUIRED_LIB_c { required_libname = path;
required_prefix = ps.pstate_depth }
in
- let item = decl params (Ast.MOD_ITEM_mod items) in
+ let item = decl [||] (Ast.MOD_ITEM_mod items) in
let item = span ps apos bpos item in
note_required_mod ps {lo=apos; hi=bpos} conv rlib item;
(ident, item)
diff --git a/src/boot/fe/lexer.mll b/src/boot/fe/lexer.mll
index ed548b1e..af8eab6a 100644
--- a/src/boot/fe/lexer.mll
+++ b/src/boot/fe/lexer.mll
@@ -27,8 +27,12 @@
<- (bump_line lexbuf.Lexing.lex_curr_p)
;;
- let mach_suf_table = Hashtbl.create 0
+ let mach_suf_table = Hashtbl.create 10
;;
+
+ let reserved_suf_table = Hashtbl.create 10
+ ;;
+
let _ =
List.iter (fun (suf, ty) -> Common.htab_put mach_suf_table suf ty)
[ ("u8", Common.TY_u8);
@@ -43,8 +47,24 @@
("f64", Common.TY_f64); ]
;;
+ let _ =
+ List.iter (fun suf -> Common.htab_put reserved_suf_table suf ())
+ [ "f16"; (* IEEE 754-2008 'binary16' interchange format. *)
+ "f80"; (* IEEE 754-1985 'extended' *)
+ "f128"; (* IEEE 754-2008 'binary128' *)
+ "m32"; (* IEEE 754-2008 'decimal32' *)
+ "m64"; (* IEEE 754-2008 'decimal64' *)
+ "m128"; (* IEEE 754-2008 'decimal128' *)
+ "m"; (* One of m32, m64, m128. *)
+ ]
+ ;;
+
let keyword_table = Hashtbl.create 100
;;
+
+ let reserved_table = Hashtbl.create 10
+ ;;
+
let _ =
List.iter (fun (kwd, tok) -> Common.htab_put keyword_table kwd tok)
[ ("mod", MOD);
@@ -141,6 +161,19 @@
("f64", MACH TY_f64)
]
;;
+
+ let _ =
+ List.iter (fun kwd -> Common.htab_put reserved_table kwd ())
+ [ "f16"; (* IEEE 754-2008 'binary16' interchange format. *)
+ "f80"; (* IEEE 754-1985 'extended' *)
+ "f128"; (* IEEE 754-2008 'binary128' *)
+ "m32"; (* IEEE 754-2008 'decimal32' *)
+ "m64"; (* IEEE 754-2008 'decimal64' *)
+ "m128"; (* IEEE 754-2008 'decimal128' *)
+ "dec"; (* One of m32, m64, m128. *)
+ ];
+ ;;
+
}
let hexdig = ['0'-'9' 'a'-'f' 'A'-'F']
@@ -153,6 +186,7 @@ let flo = (dec '.' dec (exp?)) | (dec exp)
let mach_float_suf = "f32"|"f64"
let mach_int_suf = ['u''i']('8'|"16"|"32"|"64")
+let flo_suf = ['m''f']("16"|"32"|"64"|"80"|"128")
let ws = [ ' ' '\t' '\r' ]
@@ -218,26 +252,39 @@ rule token = parse
| ']' { RBRACKET }
| id as i
- { try
- Hashtbl.find keyword_table i
- with
- Not_found -> IDENT (i) }
+ {
+ match Common.htab_search keyword_table i with
+ Some tok -> tok
+ | None ->
+ if Hashtbl.mem reserved_table i
+ then fail lexbuf "reserved keyword"
+ else IDENT (i)
+ }
| (bin|hex|dec) as n { LIT_INT (Int64.of_string n) }
| ((bin|hex|dec) as n) 'u' { LIT_UINT (Int64.of_string n) }
| ((bin|hex|dec) as n)
- (mach_int_suf as s) { try
- let tm =
- Hashtbl.find mach_suf_table s
- in
- LIT_MACH_INT
- (tm, Int64.of_string n)
- with
- Not_found ->
- fail lexbuf
- "bad mach-int suffix" }
+ (mach_int_suf as s)
+ {
+ match Common.htab_search mach_suf_table s with
+ Some tm -> LIT_MACH_INT (tm, Int64.of_string n)
+ | None ->
+ if Hashtbl.mem reserved_suf_table s
+ then fail lexbuf "reserved mach-int suffix"
+ else fail lexbuf "bad mach-int suffix"
+ }
| flo as n { LIT_FLOAT (float_of_string n) }
+| flo 'm' { fail lexbuf "reseved mach-float suffix" }
+| (flo as n) (flo_suf as s)
+ {
+ match Common.htab_search mach_suf_table s with
+ Some tm -> LIT_MACH_FLOAT (tm, float_of_string n)
+ | None ->
+ if Hashtbl.mem reserved_suf_table s
+ then fail lexbuf "reserved mach-float suffix"
+ else fail lexbuf "bad mach-float suffix"
+ }
| '\'' { char lexbuf }
| '"' { let buf = Buffer.create 32 in
@@ -411,3 +458,13 @@ and comment depth = parse
comment depth lexbuf }
| _ { comment depth lexbuf }
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/fe/parser.ml b/src/boot/fe/parser.ml
index ab7ff56c..4add7b01 100644
--- a/src/boot/fe/parser.ml
+++ b/src/boot/fe/parser.ml
@@ -23,6 +23,7 @@ type pstate =
pstate_node_id : node_id ref;
pstate_opaque_id : opaque_id ref;
pstate_get_mod : get_mod_fn;
+ pstate_get_cenv_tok : pstate -> Ast.ident -> token;
pstate_infer_lib_name : (Ast.ident -> filename);
pstate_required : (node_id, (required_lib * nabi_conv)) Hashtbl.t;
pstate_required_syms : (node_id, string) Hashtbl.t; }
@@ -45,6 +46,7 @@ let make_parser
(oref:opaque_id ref)
(sess:Session.sess)
(get_mod:get_mod_fn)
+ (get_cenv_tok:pstate -> Ast.ident -> token)
(infer_lib_name:Ast.ident -> filename)
(required:(node_id, (required_lib * nabi_conv)) Hashtbl.t)
(required_syms:(node_id, string) Hashtbl.t)
@@ -68,6 +70,7 @@ let make_parser
pstate_node_id = nref;
pstate_opaque_id = oref;
pstate_get_mod = get_mod;
+ pstate_get_cenv_tok = get_cenv_tok;
pstate_infer_lib_name = infer_lib_name;
pstate_required = required;
pstate_required_syms = required_syms; }
diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml
index 3e17e0e4..75983c7f 100644
--- a/src/boot/fe/pexp.ml
+++ b/src/boot/fe/pexp.ml
@@ -18,7 +18,7 @@ open Parser;;
type pexp' =
PEXP_call of (pexp * pexp array)
- | PEXP_spawn of (Ast.domain * pexp)
+ | PEXP_spawn of (Ast.domain * string * pexp)
| PEXP_bind of (pexp * pexp option array)
| PEXP_rec of ((Ast.ident * Ast.mutability * pexp) array * pexp option)
| PEXP_tup of ((Ast.mutability * pexp) array)
@@ -558,9 +558,27 @@ and parse_bottom_pexp (ps:pstate) : pexp =
THREAD -> bump ps; Ast.DOMAIN_thread
| _ -> Ast.DOMAIN_local
in
- let pexp = ctxt "spawn [domain] pexp: init call" parse_pexp ps in
+ (* Spawns either have an explicit literal string for the spawned
+ task's name, or the task is named as the entry call
+ expression. *)
+ let explicit_name =
+ match peek ps with
+ LIT_STR s -> bump ps; Some s
+ | _ -> None
+ in
+ let pexp =
+ ctxt "spawn [domain] [name] pexp: init call" parse_pexp ps
+ in
let bpos = lexpos ps in
- span ps apos bpos (PEXP_spawn (domain, pexp))
+ let name =
+ match explicit_name with
+ Some s -> s
+ (* FIXME: string_of_span returns a string like
+ "./driver.rs:10:16 - 11:52", not the actual text at those
+ characters *)
+ | None -> Session.string_of_span { lo = apos; hi = bpos }
+ in
+ span ps apos bpos (PEXP_spawn (domain, name, pexp))
| BIND ->
let apos = lexpos ps in
@@ -1183,7 +1201,7 @@ and desugar_expr_init
let bind_stmt = ss (Ast.STMT_bind (dst_lval, fn_lval, arg_atoms)) in
ac [ fn_stmts; arg_stmts; [| bind_stmt |] ]
- | PEXP_spawn (domain, sub) ->
+ | PEXP_spawn (domain, name, sub) ->
begin
match sub.node with
PEXP_call (fn, args) ->
@@ -1191,7 +1209,8 @@ and desugar_expr_init
let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in
let fn_lval = atom_lval ps fn_atom in
let spawn_stmt =
- ss (Ast.STMT_spawn (dst_lval, domain, fn_lval, arg_atoms))
+ ss (Ast.STMT_spawn
+ (dst_lval, domain, name, fn_lval, arg_atoms))
in
ac [ fn_stmts; arg_stmts; [| spawn_stmt |] ]
| _ -> raise (err "non-call spawn" ps)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-29 14:31:14 +0000