Teach front-end about simple, first-cut version of const items.

7 files changed, 39 insertions, 0 deletions

diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index 6e6483e3b3d..b3a13df87d6 100644
--- a/src/boot/fe/ast.ml
+++ b/src/boot/fe/ast.ml
@@ -415,6 +415,7 @@ and mod_item' =
   | MOD_ITEM_mod of (mod_view * mod_items)
   | MOD_ITEM_fn of fn
   | MOD_ITEM_obj of obj
+  | MOD_ITEM_const of (ty * expr option)
 
 and mod_item_decl =
     {
@@ -1438,6 +1439,18 @@ and fmt_mod_item (ff:Format.formatter) (id:ident) (item:mod_item) : unit =
 
         | MOD_ITEM_obj obj ->
             fmt_obj ff id params obj
+
+        | MOD_ITEM_const (ty,e) ->
+            fmt ff "const ";
+            fmt_ty ff ty;
+            begin
+              match e with
+                  None -> ()
+                | Some e ->
+                    fmt ff " = ";
+                    fmt_expr ff e
+            end;
+            fmt ff ";"
     end
 
 and fmt_import (ff:Format.formatter) (ident:ident) (name:name) : unit =
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index a74952cc8a0..3bf61f8c494 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -19,6 +19,13 @@ 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
 
+and parse_prim_expr (ps:pstate) : Ast.expr =
+  let pexp = ctxt "expr" Pexp.parse_pexp ps in
+  let (stmts, expr) = Pexp.desugar_expr ps pexp in
+    if Array.length stmts = 0
+    then expr
+    else raise (Parse_err (ps, "expected primitive expression"))
+
 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
@@ -944,6 +951,17 @@ and parse_mod_item (ps:pstate)
                               (decl params (Ast.MOD_ITEM_fn fn))) |]
             end
 
+      | CONST ->
+          bump ps;
+          let ty = Pexp.parse_ty ps in
+          let ident = Pexp.parse_ident ps in
+            expect ps EQ;
+            let expr = parse_prim_expr ps in
+              expect ps SEMI;
+              let bpos = lexpos ps in
+                [| (ident, span ps apos bpos
+                      (decl [||] (Ast.MOD_ITEM_const (ty, Some expr)))) |]
+
       | MOD ->
           bump ps;
           let (ident, params) = parse_ident_and_params ps "mod" in
diff --git a/src/boot/fe/lexer.mll b/src/boot/fe/lexer.mll
index af8eab6a7c6..58b27ec1a4c 100644
--- a/src/boot/fe/lexer.mll
+++ b/src/boot/fe/lexer.mll
@@ -110,6 +110,7 @@
                 ("export", EXPORT);
 
                 ("let", LET);
+                ("const", CONST);
 
                 ("log", LOG);
                 ("spawn", SPAWN);
diff --git a/src/boot/fe/token.ml b/src/boot/fe/token.ml
index 64aef2a421c..e6f8cd4bbc3 100644
--- a/src/boot/fe/token.ml
+++ b/src/boot/fe/token.ml
@@ -93,6 +93,7 @@ type token =
 
   (* Value / stmt declarators *)
   | LET
+  | CONST
 
   (* Magic runtime services *)
   | LOG
@@ -246,6 +247,7 @@ let rec string_of_tok t =
 
     (* Value / stmt declarators. *)
     | LET        -> "let"
+    | CONST      -> "const"
 
     (* Magic runtime services *)
     | LOG        -> "log"
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 9521df94e0d..463acadb17b 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -1366,6 +1366,7 @@ let ty_of_mod_item (item:Ast.mod_item) : Ast.ty =
       Ast.MOD_ITEM_type _ -> Ast.TY_type
     | Ast.MOD_ITEM_fn f -> (Ast.TY_fn (ty_fn_of_fn f))
     | Ast.MOD_ITEM_mod _ -> bug () "Semant.ty_of_mod_item on mod"
+    | Ast.MOD_ITEM_const (ty, _) -> ty
     | Ast.MOD_ITEM_obj ob ->
         let taux = { Ast.fn_effect = Ast.PURE;
                      Ast.fn_is_iter = false }
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index ccf5c5340dd..b576af867d8 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -295,6 +295,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
             LTYPE_mono ty
           else
             LTYPE_poly ((Array.map (fun p -> p.Common.node) params), ty)
+      | Ast.MOD_ITEM_const (ty, _) -> LTYPE_mono ty
       | Ast.MOD_ITEM_type _ ->
           Common.err None "Type-item used in non-type context"
   in
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
index 09cde99926a..7b89cbd8eee 100644
--- a/src/boot/me/walk.ml
+++ b/src/boot/me/walk.ml
@@ -173,6 +173,9 @@ and walk_mod_item
   let children _ =
     match item.node.Ast.decl_item with
         Ast.MOD_ITEM_type (_, ty) -> walk_ty v ty
+      | Ast.MOD_ITEM_const (ty, e) ->
+          walk_ty v ty;
+          walk_option (walk_expr v) e
       | Ast.MOD_ITEM_fn f -> walk_fn v f item.id
       | Ast.MOD_ITEM_tag (hdr, _, _) ->
           walk_header_slots v hdr