Commit 913ed99b authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

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.
parent b195317d
......@@ -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
......
......@@ -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)
......
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
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
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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 *)
......
......@@ -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 []
......
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
......@@ -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)
;;
......@@ -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 =
......
......@@ -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 ->
......
......@@ -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 *)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment