Implement a way to hide (unsafe) builtin primitives from the user.

One can pass the undocumented --allow-cduce-unsafe-ns to the compiler
to use these primitive directly.

Makefile.distrib

@@ -454,7 +454,7 @@ stdlib: $(STDLIB_CDO)
 
 %.cdo: %.cd cduce
 	@echo "Build $@"
-	$(HIDE) ./cduce --compile --depends -I stdlib $<
+	$(HIDE) ./cduce --compile --allow-cduce-unsafe-ns --depends -I stdlib $<
 
 # Documentation
 

compile/compile.ml

@@ -173,12 +173,12 @@ and compile_aux env te = function
 	 | None -> failwith "Cannot compile externals in the toplevel")
   | Typed.External (t,`Builtin s) -> 
       Var (Builtin s)
-  | Typed.Op (op,_,args) -> 
+  | Typed.Op ((ns, op),_,args) -> 
       let rec aux = function
 	| [arg] -> [ compile env arg ]
 	| arg::l -> (compile env arg) :: (aux l)
 	| [] -> [] in
-      Op (op, aux args)
+      Op ((U.to_string (Ns.Uri.value ns)) ^ (U.to_string op) , aux args)
   | Typed.NsTable (ns,e) ->
       NsTable (ns, compile_aux env te e)
 

compile/operators.ml

 open Cduce_loc
 type type_fun = Types.t -> bool -> Types.t
 
-let register op arity typ eval =
-  Typer.register_op op arity typ;
-  Eval.register_op op eval
+let register ?(ns=Ns.empty) op arity typ eval =
+  Typer.register_op ~ns:ns op arity typ;
+  let full_op = Ident.U.to_string (Ns.Uri.value ns) ^ op in
+  Eval.register_op full_op eval
 
-let register_unary op typ eval =
-  register op 1
+let register_unary ?(ns=Ns.empty) op typ eval =
+  register ~ns op 1
     (function
        | [ tf ] -> 
 	   typ tf
@@ -19,8 +20,8 @@ let register_unary op typ eval =
        | _ -> assert false
     )
 
-let register_binary op typ eval =
-  register op 2
+let register_binary ?(ns=Ns.empty) op typ eval =
+  register ~ns op 2
     (function
        | [ tf1; tf2 ] -> 
 	   typ tf1 tf2
@@ -33,8 +34,8 @@ let register_binary op typ eval =
        | _ -> assert false
     )
 
-let register_cst op t v =
-  register op 0
+let register_cst ?(ns=Ns.empty) op t v =
+  register ~ns op 0
     (function
        | [ ] -> fun _ _  -> t
        | _ -> assert false)
@@ -43,26 +44,26 @@ let register_cst op t v =
        | _ -> assert false
     )
 
-let register_fun op dom codom eval =
-  register_cst op
+let register_fun ?(ns=Ns.empty) op dom codom eval =
+  register_cst ~ns op
     (Types.arrow (Types.cons dom) (Types.cons codom))
     (Value.Abstraction (Some [(dom,codom)],eval, Value.Identity))
 
-let register_fun2 op dom1 dom2 codom eval =
+let register_fun2 ?(ns=Ns.empty) op dom1 dom2 codom eval =
   let t2 = Types.arrow (Types.cons dom2) (Types.cons codom) in
   let iface2 = Some [(dom2,codom)] in
-  register_cst op
+  register_cst ~ns op
     (Types.arrow (Types.cons dom1) (Types.cons t2))
     (Value.Abstraction (Some [(dom1,t2)],(fun v1 ->
 					    Value.Abstraction (iface2,
 							       eval v1, Value.Identity)), Value.Identity))
 
-let register_fun3 op dom1 dom2 dom3 codom eval =
+let register_fun3 ?(ns=Ns.empty) op dom1 dom2 dom3 codom eval =
   let t3 = Types.arrow (Types.cons dom3) (Types.cons codom) in
   let t2 = Types.arrow (Types.cons dom2) (Types.cons t3) in
   let iface3 = Some [(dom3,codom)] in
   let iface2 = Some [(dom2,t3)] in
-  register_cst op
+  register_cst ~ns op
     (Types.arrow (Types.cons dom1) (Types.cons t2))
     (Value.Abstraction (Some [(dom1,t2)], (fun v1 ->
                                              Value.Abstraction (iface2, (fun v2 ->
@@ -70,12 +71,12 @@ let register_fun3 op dom1 dom2 dom3 codom eval =
   
 
 
-let register_op op ?(expect=Types.any) typ eval =
-  register_unary op 
+let register_op ?(ns=Ns.empty) op ?(expect=Types.any) typ eval =
+  register_unary ~ns op 
     (fun tf _ _ -> let t = tf expect true in typ t)
     eval
 
-let register_op2 op t1 t2 s eval =
-  register_binary op
+let register_op2 ?(ns=Ns.empty) op t1 t2 s eval =
+  register_binary ~ns op
     (fun tf1 tf2 _ _ -> ignore (tf1 t1 false); ignore (tf2 t2 false); s)
     eval

compile/operators.mli

 open Cduce_loc
 type type_fun = Types.t -> bool -> Types.t
 
-val register: 
+val register: ?ns:Ns.Uri.t ->
   string -> int -> (type_fun list -> type_fun) -> (Value.t list -> Value.t) -> unit
 
-val register_unary: 
+val register_unary: ?ns:Ns.Uri.t ->
   string -> (type_fun -> type_fun) -> (Value.t -> Value.t) -> unit
-val register_binary: 
+val register_binary: ?ns:Ns.Uri.t ->
   string -> (type_fun -> type_fun -> type_fun) -> (Value.t -> Value.t -> Value.t) -> unit
 
-val register_fun: string -> Types.t -> Types.t -> (Value.t -> Value.t) -> unit
-val register_fun2: string -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t) -> unit
-val register_fun3: string -> Types.t -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t -> Value.t) -> unit
+val register_fun: ?ns:Ns.Uri.t -> string -> Types.t -> Types.t -> (Value.t -> Value.t) -> unit
+val register_fun2: ?ns:Ns.Uri.t -> string -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t) -> unit
+val register_fun3: ?ns:Ns.Uri.t -> string -> Types.t -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t -> Value.t) -> unit
 
-val register_cst: string -> Types.t -> Value.t -> unit
-val register_op: 
+val register_cst: ?ns:Ns.Uri.t -> string -> Types.t -> Value.t -> unit
+val register_op: ?ns:Ns.Uri.t ->
   string -> ?expect:Types.t -> (Types.t -> Types.t) -> (Value.t -> Value.t) -> unit
 
-val register_op2: 
+val register_op2: ?ns:Ns.Uri.t ->
   string -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t) -> unit

driver/run.ml

@@ -16,6 +16,11 @@ let version () =
   Printf.eprintf "Supported features: \n";
   List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Cduce_config.descrs ());
   exit 0
+let spec_ref = ref []
+let usage_msg =
+  "Usage:\n" ^ Sys.argv.(0) ^ " [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:"
+
+let show_help () = Arg.usage !spec_ref usage_msg; exit 0
 
 let specs = Arg.align
   [ "--compile", Arg.Set compile,
@@ -55,7 +60,14 @@ let specs = Arg.align
     " produce stub ML code from a compiled unit";
     "--topstub", Arg.Set topstub,
     " produce stub ML code for a toplevel from a primitive file";
- ]
+    "--help", Arg.Unit show_help, " display this list of options";
+    "-help", Arg.Unit show_help, " display this list of options";
+  ]
+
+let () = spec_ref := specs
+let undoc_options = [
+    "--allow-cduce-unsafe-ns", Arg.Set Ns.allow_unsafe, ""
+  ]
 
 let ppf = Format.std_formatter
 let ppf_err = Format.err_formatter
@@ -65,8 +77,7 @@ let err s =
   exit 1
 
 let mode () =
-  Arg.parse (specs @ !Cduce.extra_specs) (fun s -> src := s :: !src)
-    "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
+  Arg.parse (specs @ !Cduce.extra_specs @ undoc_options) (fun s -> src := s :: !src) usage_msg;
   if (!mlstub) then (
     match !src with [x] -> `Mlstub x | _ ->
       err "Please specify one .cdo file"

misc/ns.ml

@@ -30,6 +30,9 @@ let xml_ns_str = "http://www.w3.org/XML/1998/namespace"
 let xml_ns = Uri.mk (U.mk xml_ns_str)
 let xsd_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema")
 let xsi_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema-instance")
+let cduce_ns = Uri.mk (U.mk "http://www.cduce.org/")
+let cduce_unsafe_ns = Uri.mk (U.mk "http://www.cduce.org/#UNSAFE")
+let allow_unsafe = ref false
 
 module H = Hashtbl.Make(Uri)
 
@@ -39,7 +42,7 @@ type table = Uri.t Table.t
 
 let mktbl = List.fold_left (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
 let empty_table = mktbl Table.empty ["", empty; "xml", xml_ns]
-let def_table = mktbl empty_table ["xsd", xsd_ns; "xsi", xsi_ns]
+let def_table = mktbl empty_table ["xsd", xsd_ns; "xsi", xsi_ns; "cduce", cduce_ns; ]
 
 let mk_table =
   List.fold_left (fun table (pr,ns) -> Table.add pr ns table) empty_table
@@ -225,8 +228,11 @@ module Label = struct
     U.mk ns, local
 *)
 end
-
+exception UnsafeCDuceNs
 let add_prefix pr ns table =
+  if not !allow_unsafe &&
+       Uri.equal ns cduce_unsafe_ns
+  then raise UnsafeCDuceNs;
   if (U.get_str pr <> "") then Hashtbl.add global_hints ns pr;
   Table.add pr ns table
 

misc/ns.mli

@@ -38,13 +38,16 @@ module Label : sig
 end
 
 exception UnknownPrefix of Utf8.t
-
+exception UnsafeCDuceNs
 val empty : Uri.t
 val xml_ns: Uri.t
+val cduce_ns: Uri.t
+val cduce_unsafe_ns: Uri.t
+val allow_unsafe : bool ref
 
 type table  (* prefix => namespace *)
 val empty_table: table  (* Contains only xml *)
-val def_table: table (* Contains xml,xsd,xsi *)
+val def_table: table (* Contains xml,xsd,xsi,cduce *)
 val add_prefix: Utf8.t -> Uri.t -> table -> table
 val merge_tables: table -> table -> table
 val dump_table: Format.formatter -> table -> unit

misc/upool.ml

@@ -38,13 +38,13 @@ module Make(X : Custom.T) = struct
   let mk v =
     let h = X.hash v in
     if (h == dummy) then raise (Not_unique (v,v));
-    (try 
-       let v' = HInt.find pool h in 
+    (try
+       let v' = HInt.find pool h in
        if not (X.equal v v') then raise (Not_unique (v,v'));
      with Not_found -> HInt.add pool h v);
     h
 
-(*  let value h = 
+(*  let value h =
     assert (h != dummy);
     try HInt.find pool h
     with Not_found -> assert false *)

stdlib/Fmt.cd

@@ -114,10 +114,10 @@ let flush_buff (o : Out_channel) (buff : String) : String =
   []
 
 let printf (fmt : t) : [] =
-  let _ = print_gen flush_buff Io.output_string [] stdout fmt in []
+  let _ = print_gen flush_buff Io.output_string [] Io.stdout fmt in []
 
 let eprintf (fmt : t) : [] =
-  let _ = print_gen flush_buff Io.output_string [] stderr fmt in []
+  let _ = print_gen flush_buff Io.output_string [] Io.stderr fmt in []
 
 let fprintf (o : Out_channel) (fmt : t) : [] =
   let _ = print_gen flush_buff Io.output_string [] o fmt in []

stdlib/Io.cd

-let open_in = cduce_open_in
-let open_out = cduce_open_out
+namespace cduce_ = "http://www.cduce.org/#UNSAFE"
 
-let output_string = cduce_output_string
+let open_in = cduce_:open_in
+let open_out = cduce_:open_out
 
-let flush = cduce_flush
+let output_string = cduce_:output_string
+
+let flush = cduce_:flush
+let stdin = cduce_:stdin
+let stdout = cduce_:stdout
+let stderr = cduce_:stderr

types/builtin.ml

@@ -246,7 +246,7 @@ register_fun "dump_xml_utf8"
      Print_xml.dump_xml ~utf8:true !Eval.ns_table v);;
 
 
-register_fun2 "replace_inner"
+register_fun2 ~ns:Ns.cduce_unsafe_ns "replace_inner"
   string_latin1 string_latin1 nil
   (fun id str ->
     !Print_xml.replace_inner
@@ -508,18 +508,18 @@ register_fun "cdata_of" string string
 
 (* i/o *)
 
-register_fun "cduce_open_in" string in_channel
+register_fun ~ns:Ns.cduce_unsafe_ns "open_in" string in_channel
   (fun v ->
-  Cduce_loc.protect_op "cduce_open_in";
+  Cduce_loc.protect_op "cduce_:open_in";
   let (s,_) = Value.get_string_utf8 v in
   try Value.in_channel (open_in (U.get_str s))
   with exn -> raise_gen exn)
 
 ;;
 
-  register_fun "cduce_open_out" string out_channel
-  (fun v ->
-   Cduce_loc.protect_op "cduce_open_out";
+register_fun ~ns:Ns.cduce_unsafe_ns "open_out" string out_channel
+ (fun v ->
+   Cduce_loc.protect_op "cduce_:open_out";
    let (s,_) = Value.get_string_utf8 v in
    try Value.out_channel (open_out (U.get_str s))
    with exn -> raise_gen exn)
@@ -531,27 +531,27 @@ let get_out_channel (v : Value.t) : out_channel =
    | _ -> assert false
 ;;
 
-register_fun2 "cduce_output_string" out_channel string nil
+register_fun2 ~ns:Ns.cduce_unsafe_ns "output_string" out_channel string nil
 (fun v1 v2 ->
- Cduce_loc.protect_op "cduce_output_string";
+ Cduce_loc.protect_op "cduce_:output_string";
  let (s, _) = Value.get_string_utf8 v2 in
  output_string (get_out_channel v1) (U.get_str s);
  Value.nil
 )
 ;;
 
-  register_cst "stdin" in_channel (Value.in_channel stdin)
+  register_cst ~ns:Ns.cduce_unsafe_ns "stdin" in_channel (Value.in_channel stdin)
 ;;
 
-  register_cst "stdout" out_channel (Value.out_channel stdout)
+  register_cst ~ns:Ns.cduce_unsafe_ns "stdout" out_channel (Value.out_channel stdout)
 ;;
 
-  register_cst "stderr" out_channel (Value.out_channel stderr)
+  register_cst ~ns:Ns.cduce_unsafe_ns "stderr" out_channel (Value.out_channel stderr)
 ;;
 
-  register_fun "cduce_flush" out_channel nil
+  register_fun ~ns:Ns.cduce_unsafe_ns "flush" out_channel nil
 (fun v ->
- Cduce_loc.protect_op "cduce_flush";
+ Cduce_loc.protect_op "cduce_:flush";
  flush (get_out_channel v); Value.nil)
 
 ;;

typing/typed.ml

@@ -58,7 +58,7 @@ and  texpr' =
 
   | Ref of texpr * ttyp
   | External of Types.t * [ `Builtin of string | `Ext of int ]
-  | Op of string * int * texpr list
+  | Op of id * int * texpr list
   | NsTable of Ns.table * texpr'
 
 and abstr = {
@@ -174,7 +174,7 @@ module Print = struct
       | Match(e, b) ->
           Format.fprintf ppf "Match(%a,%a)" pp e pp_branches b
       | Op(s, i, l) ->
-          Format.fprintf ppf "(%s, %d, %a)" s i (Utils.pp_list pp) l
+          Format.fprintf ppf "(%a, %d, %a)" Ident.print s i (Utils.pp_list pp) l
       | _ -> assert false
 
   and pp_abst ppf abstr =

typing/typer.ml

@@ -262,7 +262,10 @@ let type_ns env loc p ns =
   (* TODO: check that p has no prefix *)
   let ns = eval_ns env loc ns in
   { env with
-    ns = Ns.add_prefix p ns env.ns;
+    ns = (try
+	     Ns.add_prefix p ns env.ns
+	   with Ns.UnsafeCDuceNs ->
+	     error loc ("Cannot use reserved namespace '" ^ (U.to_string (Ns.Uri.value ns)) ^ "'"));
     ids = Env.add (Ns.empty,p) (ENamespace ns) env.ids }
 
 let find_global_type env loc ids =
@@ -733,9 +736,12 @@ let pat_false =
   Patterns.define n (Patterns.constr Builtin_defs.false_type);
   n
 
-let ops = Hashtbl.create 13
-let register_op op arity f = Hashtbl.add ops op (arity,f)
-let typ_op op = snd (Hashtbl.find ops op)
+
+module OpsTable = Hashtbl.Make (Ns.QName)
+
+let ops = OpsTable.create 13
+let register_op ?(ns=Ns.empty) op arity f = OpsTable.add ops (ns,Ident.U.mk op) (arity,f)
+let typ_op op = snd (OpsTable.find ops op)
 
 let fun_name env a =
   match a.fun_name with
@@ -750,11 +756,12 @@ let fresh_arg_name () =
 let is_op env s =
   if (Env.mem s env.ids) then None
   else
-    let (ns,s) = s in
-    if Ns.Uri.equal ns Ns.empty then
-      let s = U.get_str s in
+    let (ns, _) = s in
+    if Ns.Uri.equal ns Ns.empty ||
+	 Ns.Uri.equal ns Ns.cduce_ns ||
+	 Ns.Uri.equal ns Ns.cduce_unsafe_ns then
       try
-	let o = Hashtbl.find ops s in
+	let o = OpsTable.find ops s in
 	Some (s, fst o)
       with Not_found -> None
     else None
@@ -905,13 +912,13 @@ and extern loc env s args =
 and var env loc s =
   let id = ident env loc s in
   match is_op env id with
-  | Some (s,arity) ->
-    let e = match s with
-      | "print_xml" | "print_xml_utf8" ->
-	Typed.NsTable (env.ns,Typed.Op (s, arity, []))
-      | "load_xml" when env.keep_ns ->
-	Typed.Op ("!load_xml",arity,[])
-      | _ -> Typed.Op (s, arity, [])
+  | Some ((ns,s) as opname ,arity) ->
+    let e = match U.to_string s with
+      | "print_xml" | "print_xml_utf8" when Ns.Uri.equal ns Ns.empty ->
+	Typed.NsTable (env.ns,Typed.Op (opname, arity, []))
+      | "load_xml" when env.keep_ns && Ns.Uri.equal ns Ns.empty ->
+	Typed.Op ((Ns.empty, U.mk "!load_xml"),arity,[])
+      | _ -> Typed.Op (opname, arity, [])
     in
     exp loc Fv.empty e
   | None ->

typing/typer.mli

@@ -53,7 +53,7 @@ val type_let_funs: t -> Ast.pexpr list ->
 
 type type_fun = Types.t -> bool -> Types.t
 
-val register_op: string -> int -> (type_fun list -> type_fun) -> unit
+val register_op: ?ns:Ns.Uri.t -> string -> int -> (type_fun list -> type_fun) -> unit
 val flatten: type_fun -> type_fun
 
 (* Forward definitions *)