1 files changed, 108 insertions, 0 deletions
diff --git a/src/boot/me/layer.ml b/src/boot/me/layer.ml
new file mode 100644
index 00000000..a5a33b0b
--- /dev/null
+++ b/src/boot/me/layer.ml
@@ -0,0 +1,108 @@
+open Semant;;
+open Common;;
+
+let log cx = Session.log "layer"
+  (should_log cx cx.ctxt_sess.Session.sess_log_layer)
+  cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+  if (should_log cx cx.ctxt_sess.Session.sess_log_layer)
+  then thunk ()
+  else ()
+;;
+
+
+let state_layer_checking_visitor
+    (cx:ctxt)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+  (* 
+   * This visitor enforces the following rules:
+   * 
+   * - A channel type carrying a state type is illegal.
+   * 
+   * - Writing to an immutable slot is illegal.
+   * 
+   * - Forming a mutable alias to an immutable slot is illegal.
+   * 
+   *)
+  let visit_ty_pre t =
+    match t with
+        Ast.TY_chan t' when type_has_state cx t' ->
+          err None "channel of state type: %a " Ast.sprintf_ty t'
+      | _ -> ()
+  in
+
+  let check_write s dst =
+    let is_init = Hashtbl.mem cx.ctxt_stmt_is_init s.id in
+    let dst_ty = lval_ty cx dst in
+    let is_mutable =
+      match dst_ty with
+          Ast.TY_mutable _ -> true
+        | _ -> false
+    in
+      iflog cx
+        (fun _ -> log cx "checking %swrite to %slval #%d = %a of type %a"
+           (if is_init then "initializing " else "")
+           (if is_mutable then "mutable " else "")
+           (int_of_node (lval_base_id dst))
+           Ast.sprintf_lval dst
+           Ast.sprintf_ty dst_ty);
+      if (is_mutable or is_init)
+      then ()
+      else err (Some s.id)
+        "writing to immutable type %a in statement %a"
+        Ast.sprintf_ty dst_ty Ast.sprintf_stmt s
+  in
+    (* FIXME (issue #75): enforce the no-write-alias-to-immutable-slot
+     * rule.
+     *)
+  let visit_stmt_pre s =
+    begin
+      match s.node with
+            Ast.STMT_copy (lv_dst, _)
+          | Ast.STMT_call (lv_dst, _, _)
+          | Ast.STMT_spawn (lv_dst, _, _, _, _)
+          | Ast.STMT_recv (lv_dst, _)
+          | Ast.STMT_bind (lv_dst, _, _)
+          | Ast.STMT_new_rec (lv_dst, _, _)
+          | Ast.STMT_new_tup (lv_dst, _)
+          | Ast.STMT_new_vec (lv_dst, _, _)
+          | Ast.STMT_new_str (lv_dst, _)
+          | Ast.STMT_new_port lv_dst
+          | Ast.STMT_new_chan (lv_dst, _)
+          | Ast.STMT_new_box (lv_dst, _, _) ->
+              check_write s lv_dst
+        | _ -> ()
+    end;
+    inner.Walk.visit_stmt_pre s
+  in
+
+    { inner with
+        Walk.visit_ty_pre = visit_ty_pre;
+        Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let process_crate
+    (cx:ctxt)
+    (crate:Ast.crate)
+    : unit =
+  let passes =
+    [|
+      (state_layer_checking_visitor cx
+         Walk.empty_visitor);
+    |]
+  in
+    run_passes cx "layer" passes
+      cx.ctxt_sess.Session.sess_log_layer log crate
+;;
+
+(*
+ * 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:
+ *)