Commit 8a494618 authored by Gerd Stolpmann's avatar Gerd Stolpmann

Fixing many warnings. Using -safe-string. Ported to OCaml-4.02

parent fd7f7e49
......@@ -7,8 +7,8 @@
# How to invoke compilers and tools:
# (May be moved to Makefile.conf if necessary)
OCAMLC = $(OCAMLFIND) ocamlc -g $(OCAMLC_OPTIONS) $(INCLUDES)
OCAMLOPT = $(OCAMLFIND) ocamlopt $(OCAMLOPT_OPTIONS) $(INCLUDES)
OCAMLC = $(OCAMLFIND) ocamlc -g -safe-string $(OCAMLC_OPTIONS) $(INCLUDES)
OCAMLOPT = $(OCAMLFIND) ocamlopt -safe-string $(OCAMLOPT_OPTIONS) $(INCLUDES)
OCAMLDEP = $(OCAMLFIND) ocamldep $(OCAMLDEP_OPTIONS)
OCAMLFIND = ocamlfind
OCAMLYACC = ocamlyacc
......
......@@ -21,7 +21,7 @@ set_defaults () {
}
set_defaults
version="2.1.5"
version="2.1.6"
exec_suffix=""
ehelp_findlib="Enable/disable installation as findlib package"
......
......@@ -78,6 +78,9 @@ Copyright holders are Joachim Schrod NPC GmbH and Gerd Stolpmann.</p>
<sect1>
<title>Version History</title>
<ul>
<li><p><em>Version 2.1.6:</em> ported to OCaml-4.02, and OCamlnet-4.1.
Using now -safe-string</p></li>
<li><p><em>Version 2.1.5:</em> tweaking _oasis</p></li>
<li><p><em>Version 2.1.4:</em>Port to OCamlnet-4. (This version
......
......@@ -10,16 +10,18 @@ let random_char () =
let make_session_id () =
let length = 128 + (Random.int 128) in
let id = String.create length in
let id = Bytes.create length in
for i=0 to length - 1
do
id.[i] <- random_char ()
Bytes.set id i (random_char ())
done;
id
Bytes.to_string id
let rec make_unique_session_id tbl =
let id = make_session_id () in
try ignore (Hashtbl.find tbl id);make_unique_session_id tbl;id
try ignore (Hashtbl.find tbl id);
ignore(make_unique_session_id tbl);
id
with Not_found -> id
let copy_dialog universe env dlg =
......
......@@ -16,12 +16,12 @@ let random_char () =
let make_session_id () =
let length = 128 + (Random.int 128) in
let id = String.create length in
let id = Bytes.create length in
for i=0 to length - 1
do
id.[i] <- random_char ()
Bytes.set id i (random_char ())
done;
id
Bytes.to_string id
let copy_dialog universe env dlg =
let new_dlg = universe#create env (dlg#name) in
......
......@@ -32,7 +32,10 @@ let ( *! ) = Netxdr.safe_mul
;;
let rec _to_ustring (x:Netxdr.xdr_value) : ustring =
( match x with | Netxdr.XV_string x -> x | _ -> raise Netxdr.Dest_failure )
and _of_ustring (x:ustring) : Netxdr.xdr_value = (Netxdr.XV_string x)
and _of_ustring (x:ustring) : Netxdr.xdr_value =
_xof_ustring Netxdr.default_ctx x
and _xof_ustring (ctx:Netxdr.ctx) (x:ustring) : Netxdr.xdr_value =
(Netxdr.XV_string (ctx.Netxdr.ctx_copy_string x))
and _to_st_get_result (x:Netxdr.xdr_value) : st_get_result =
( let f s =
{ result_code = (fun x -> ( match x with
......@@ -48,13 +51,18 @@ and _to_st_get_result (x:Netxdr.xdr_value) : st_get_result =
)
)
and _of_st_get_result (x:st_get_result) : Netxdr.xdr_value =
_xof_st_get_result Netxdr.default_ctx x
and _xof_st_get_result (ctx:Netxdr.ctx) (x:st_get_result) : Netxdr.xdr_value =
(Netxdr.XV_struct_fast
[|
(let x = x.result_code in (Netxdr.XV_int (Netnumber.int4_of_int32 x)));
(let x = x.serialized_data in (_of_ustring x));
(let x = x.serialized_data in (_xof_ustring ctx x));
|])
and _to_get_result (x:Netxdr.xdr_value) : get_result = (_to_st_get_result x)
and _of_get_result (x:get_result) : Netxdr.xdr_value = (_of_st_get_result x)
and _of_get_result (x:get_result) : Netxdr.xdr_value =
_xof_get_result Netxdr.default_ctx x
and _xof_get_result (ctx:Netxdr.ctx) (x:get_result) : Netxdr.xdr_value =
(_xof_st_get_result ctx x)
and _to_Wdstated'V1'put_session'arg (x:Netxdr.xdr_value) : t_Wdstated'V1'put_session'arg =
(let s = Netxdr.dest_xv_struct_fast x in
( (fun x -> (_to_ustring x)) s.(0),
......@@ -68,14 +76,16 @@ and _to_Wdstated'V1'put_session'arg (x:Netxdr.xdr_value) : t_Wdstated'V1'put_ses
(fun x -> (_to_ustring x)) s.(4)
))
and _of_Wdstated'V1'put_session'arg (x:t_Wdstated'V1'put_session'arg) : Netxdr.xdr_value =
_xof_Wdstated'V1'put_session'arg Netxdr.default_ctx x
and _xof_Wdstated'V1'put_session'arg ctx (x:t_Wdstated'V1'put_session'arg) : Netxdr.xdr_value =
(let (x0, x1, x2, x3, x4) = x in
Netxdr.XV_struct_fast
[|
((_of_ustring x0));
((_of_ustring x1));
((_xof_ustring ctx x0));
((_xof_ustring ctx x1));
((Netxdr.XV_int (Netnumber.int4_of_int32 x2)));
((_of_ustring x3));
((_of_ustring x4));
((_xof_ustring ctx x3));
((_xof_ustring ctx x4));
|]
)
and _to_Wdstated'V1'put_session'res (x:Netxdr.xdr_value) : t_Wdstated'V1'put_session'res =
......@@ -84,6 +94,8 @@ and _to_Wdstated'V1'put_session'res (x:Netxdr.xdr_value) : t_Wdstated'V1'put_ses
| _ -> raise Netxdr.Dest_failure
)
and _of_Wdstated'V1'put_session'res (x:t_Wdstated'V1'put_session'res) : Netxdr.xdr_value =
_xof_Wdstated'V1'put_session'res Netxdr.default_ctx x
and _xof_Wdstated'V1'put_session'res (ctx:Netxdr.ctx) (x:t_Wdstated'V1'put_session'res) : Netxdr.xdr_value =
(Netxdr.XV_int (Netnumber.int4_of_int32 x))
and _to_Wdstated'V1'replace_session'arg (x:Netxdr.xdr_value) : t_Wdstated'V1'replace_session'arg =
(let s = Netxdr.dest_xv_struct_fast x in
......@@ -98,14 +110,16 @@ and _to_Wdstated'V1'replace_session'arg (x:Netxdr.xdr_value) : t_Wdstated'V1'rep
(fun x -> (_to_ustring x)) s.(4)
))
and _of_Wdstated'V1'replace_session'arg (x:t_Wdstated'V1'replace_session'arg) : Netxdr.xdr_value =
_xof_Wdstated'V1'replace_session'arg Netxdr.default_ctx x
and _xof_Wdstated'V1'replace_session'arg ctx (x:t_Wdstated'V1'replace_session'arg) : Netxdr.xdr_value =
(let (x0, x1, x2, x3, x4) = x in
Netxdr.XV_struct_fast
[|
((_of_ustring x0));
((_of_ustring x1));
((_xof_ustring ctx x0));
((_xof_ustring ctx x1));
((Netxdr.XV_int (Netnumber.int4_of_int32 x2)));
((_of_ustring x3));
((_of_ustring x4));
((_xof_ustring ctx x3));
((_xof_ustring ctx x4));
|]
)
and _to_Wdstated'V1'replace_session'res (x:Netxdr.xdr_value) : t_Wdstated'V1'replace_session'res =
......@@ -114,6 +128,8 @@ and _to_Wdstated'V1'replace_session'res (x:Netxdr.xdr_value) : t_Wdstated'V1'rep
| _ -> raise Netxdr.Dest_failure
)
and _of_Wdstated'V1'replace_session'res (x:t_Wdstated'V1'replace_session'res) : Netxdr.xdr_value =
_xof_Wdstated'V1'replace_session'res Netxdr.default_ctx x
and _xof_Wdstated'V1'replace_session'res (ctx:Netxdr.ctx) (x:t_Wdstated'V1'replace_session'res) : Netxdr.xdr_value =
(Netxdr.XV_int (Netnumber.int4_of_int32 x))
and _to_Wdstated'V1'get_session'arg (x:Netxdr.xdr_value) : t_Wdstated'V1'get_session'arg =
(let s = Netxdr.dest_xv_struct_fast x in
......@@ -122,18 +138,22 @@ and _to_Wdstated'V1'get_session'arg (x:Netxdr.xdr_value) : t_Wdstated'V1'get_ses
(fun x -> (_to_ustring x)) s.(2)
))
and _of_Wdstated'V1'get_session'arg (x:t_Wdstated'V1'get_session'arg) : Netxdr.xdr_value =
_xof_Wdstated'V1'get_session'arg Netxdr.default_ctx x
and _xof_Wdstated'V1'get_session'arg ctx (x:t_Wdstated'V1'get_session'arg) : Netxdr.xdr_value =
(let (x0, x1, x2) = x in
Netxdr.XV_struct_fast
[|
((_of_ustring x0));
((_of_ustring x1));
((_of_ustring x2));
((_xof_ustring ctx x0));
((_xof_ustring ctx x1));
((_xof_ustring ctx x2));
|]
)
and _to_Wdstated'V1'get_session'res (x:Netxdr.xdr_value) : t_Wdstated'V1'get_session'res =
(_to_get_result x)
and _of_Wdstated'V1'get_session'res (x:t_Wdstated'V1'get_session'res) : Netxdr.xdr_value =
(_of_get_result x)
_xof_Wdstated'V1'get_session'res Netxdr.default_ctx x
and _xof_Wdstated'V1'get_session'res (ctx:Netxdr.ctx) (x:t_Wdstated'V1'get_session'res) : Netxdr.xdr_value =
(_xof_get_result ctx x)
;;
let xdrt_ustring = Netxdr.X_rec("ustring", Netxdr.x_string_max)
;;
......
......@@ -38,22 +38,31 @@ and t_Wdstated'V1'get_session'res =
val _to_ustring : Netxdr.xdr_value -> ustring;;
val _of_ustring : ustring -> Netxdr.xdr_value;;
val _xof_ustring : Netxdr.ctx -> ustring -> Netxdr.xdr_value;;
val _to_st_get_result : Netxdr.xdr_value -> st_get_result;;
val _of_st_get_result : st_get_result -> Netxdr.xdr_value;;
val _xof_st_get_result : Netxdr.ctx -> st_get_result -> Netxdr.xdr_value;;
val _to_get_result : Netxdr.xdr_value -> get_result;;
val _of_get_result : get_result -> Netxdr.xdr_value;;
val _xof_get_result : Netxdr.ctx -> get_result -> Netxdr.xdr_value;;
val _to_Wdstated'V1'put_session'arg : Netxdr.xdr_value -> t_Wdstated'V1'put_session'arg;;
val _of_Wdstated'V1'put_session'arg : t_Wdstated'V1'put_session'arg -> Netxdr.xdr_value;;
val _xof_Wdstated'V1'put_session'arg : Netxdr.ctx -> t_Wdstated'V1'put_session'arg -> Netxdr.xdr_value;;
val _to_Wdstated'V1'put_session'res : Netxdr.xdr_value -> t_Wdstated'V1'put_session'res;;
val _of_Wdstated'V1'put_session'res : t_Wdstated'V1'put_session'res -> Netxdr.xdr_value;;
val _xof_Wdstated'V1'put_session'res : Netxdr.ctx -> t_Wdstated'V1'put_session'res -> Netxdr.xdr_value;;
val _to_Wdstated'V1'replace_session'arg : Netxdr.xdr_value -> t_Wdstated'V1'replace_session'arg;;
val _of_Wdstated'V1'replace_session'arg : t_Wdstated'V1'replace_session'arg -> Netxdr.xdr_value;;
val _xof_Wdstated'V1'replace_session'arg : Netxdr.ctx -> t_Wdstated'V1'replace_session'arg -> Netxdr.xdr_value;;
val _to_Wdstated'V1'replace_session'res : Netxdr.xdr_value -> t_Wdstated'V1'replace_session'res;;
val _of_Wdstated'V1'replace_session'res : t_Wdstated'V1'replace_session'res -> Netxdr.xdr_value;;
val _xof_Wdstated'V1'replace_session'res : Netxdr.ctx -> t_Wdstated'V1'replace_session'res -> Netxdr.xdr_value;;
val _to_Wdstated'V1'get_session'arg : Netxdr.xdr_value -> t_Wdstated'V1'get_session'arg;;
val _of_Wdstated'V1'get_session'arg : t_Wdstated'V1'get_session'arg -> Netxdr.xdr_value;;
val _xof_Wdstated'V1'get_session'arg : Netxdr.ctx -> t_Wdstated'V1'get_session'arg -> Netxdr.xdr_value;;
val _to_Wdstated'V1'get_session'res : Netxdr.xdr_value -> t_Wdstated'V1'get_session'res;;
val _of_Wdstated'V1'get_session'res : t_Wdstated'V1'get_session'res -> Netxdr.xdr_value;;
val _xof_Wdstated'V1'get_session'res : Netxdr.ctx -> t_Wdstated'V1'get_session'res -> Netxdr.xdr_value;;
(* XDR definitions *)
......
......@@ -12,26 +12,26 @@ module Make'Wdstated(U'C:Rpc_client_pre.USE_CLIENT) = struct
type t = U'C.t
let put_session client arg =
_to_Wdstated'V1'put_session'res (U'C.unbound_sync_call client _program "put_session" (_of_Wdstated'V1'put_session'arg arg))
_to_Wdstated'V1'put_session'res (U'C.unbound_sync_call client _program "put_session" (_xof_Wdstated'V1'put_session'arg (U'C.xdr_ctx client) arg))
let put_session'async client arg pass_reply =
U'C.unbound_async_call client _program "put_session" (_of_Wdstated'V1'put_session'arg arg)
U'C.unbound_async_call client _program "put_session" (_xof_Wdstated'V1'put_session'arg (U'C.xdr_ctx client) arg)
(fun g -> pass_reply (fun () -> _to_Wdstated'V1'put_session'res (g())))
let replace_session client arg =
_to_Wdstated'V1'replace_session'res (U'C.unbound_sync_call client _program "replace_session" (_of_Wdstated'V1'replace_session'arg arg))
_to_Wdstated'V1'replace_session'res (U'C.unbound_sync_call client _program "replace_session" (_xof_Wdstated'V1'replace_session'arg (U'C.xdr_ctx client) arg))
let replace_session'async client arg pass_reply =
U'C.unbound_async_call client _program "replace_session" (_of_Wdstated'V1'replace_session'arg arg)
U'C.unbound_async_call client _program "replace_session" (_xof_Wdstated'V1'replace_session'arg (U'C.xdr_ctx client) arg)
(fun g -> pass_reply (fun () -> _to_Wdstated'V1'replace_session'res (g())))
let get_session client arg =
_to_Wdstated'V1'get_session'res (U'C.unbound_sync_call client _program "get_session" (_of_Wdstated'V1'get_session'arg arg))
_to_Wdstated'V1'get_session'res (U'C.unbound_sync_call client _program "get_session" (_xof_Wdstated'V1'get_session'arg (U'C.xdr_ctx client) arg))
let get_session'async client arg pass_reply =
U'C.unbound_async_call client _program "get_session" (_of_Wdstated'V1'get_session'arg arg)
U'C.unbound_async_call client _program "get_session" (_xof_Wdstated'V1'get_session'arg (U'C.xdr_ctx client) arg)
(fun g -> pass_reply (fun () -> _to_Wdstated'V1'get_session'res (g())))
......
......@@ -26,11 +26,11 @@ module Wdstated = struct
?program_number ?version_number esys connector protocol mode _program
[
(Rpc_server.Sync { Rpc_server.sync_name = "put_session";
Rpc_server.sync_proc = (fun x -> _of_Wdstated'V1'put_session'res (proc_put_session (_to_Wdstated'V1'put_session'arg x)))});
Rpc_server.sync_proc = (fun srv x -> _xof_Wdstated'V1'put_session'res (Rpc_server.xdr_ctx srv) (proc_put_session (_to_Wdstated'V1'put_session'arg x)))});
(Rpc_server.Sync { Rpc_server.sync_name = "replace_session";
Rpc_server.sync_proc = (fun x -> _of_Wdstated'V1'replace_session'res (proc_replace_session (_to_Wdstated'V1'replace_session'arg x)))});
Rpc_server.sync_proc = (fun srv x -> _xof_Wdstated'V1'replace_session'res (Rpc_server.xdr_ctx srv) (proc_replace_session (_to_Wdstated'V1'replace_session'arg x)))});
(Rpc_server.Sync { Rpc_server.sync_name = "get_session";
Rpc_server.sync_proc = (fun x -> _of_Wdstated'V1'get_session'res (proc_get_session (_to_Wdstated'V1'get_session'arg x)))});
Rpc_server.sync_proc = (fun srv x -> _xof_Wdstated'V1'get_session'res (Rpc_server.xdr_ctx srv) (proc_get_session (_to_Wdstated'V1'get_session'arg x)))});
]
limit
......@@ -50,11 +50,11 @@ module Wdstated = struct
?program_number ?version_number esys connector protocol mode _program
[
(Rpc_server.Async { Rpc_server.async_name = "put_session";
Rpc_server.async_invoke = (fun s x -> proc_put_session s (_to_Wdstated'V1'put_session'arg x) (fun y -> Rpc_server.reply s (_of_Wdstated'V1'put_session'res y)))});
Rpc_server.async_invoke = (fun srv s x -> proc_put_session s (_to_Wdstated'V1'put_session'arg x) (fun y -> Rpc_server.reply s (_xof_Wdstated'V1'put_session'res (Rpc_server.xdr_ctx srv) y)))});
(Rpc_server.Async { Rpc_server.async_name = "replace_session";
Rpc_server.async_invoke = (fun s x -> proc_replace_session s (_to_Wdstated'V1'replace_session'arg x) (fun y -> Rpc_server.reply s (_of_Wdstated'V1'replace_session'res y)))});
Rpc_server.async_invoke = (fun srv s x -> proc_replace_session s (_to_Wdstated'V1'replace_session'arg x) (fun y -> Rpc_server.reply s (_xof_Wdstated'V1'replace_session'res (Rpc_server.xdr_ctx srv) y)))});
(Rpc_server.Async { Rpc_server.async_name = "get_session";
Rpc_server.async_invoke = (fun s x -> proc_get_session s (_to_Wdstated'V1'get_session'arg x) (fun y -> Rpc_server.reply s (_of_Wdstated'V1'get_session'res y)))});
Rpc_server.async_invoke = (fun srv s x -> proc_get_session s (_to_Wdstated'V1'get_session'arg x) (fun y -> Rpc_server.reply s (_xof_Wdstated'V1'get_session'res (Rpc_server.xdr_ctx srv) y)))});
]
limit
......
......@@ -84,7 +84,7 @@ module L = Wd_brexpr_lex
let parse_expr ~enable_param enc s : expr_oe =
let enc = (enc : Pxp_types.rep_encoding :> Netconversion.encoding) in
let scan = Wd_brexpr_lex.scan in
let ulb = Netulex.ULB.from_string_inplace enc s in
let ulb = Netulex.ULB.from_string enc s in
let buf = Netulex.Ulexing.from_ulb_lexbuf ulb in
let raise_no_brace() =
......@@ -203,6 +203,7 @@ let parse_expr ~enable_param enc s : expr_oe =
| _ ->
raise_bad()
(*
and parse_formal_args () =
let tok = scan buf in
match tok with
......@@ -210,7 +211,7 @@ let parse_expr ~enable_param enc s : expr_oe =
[]
| _ ->
parse_formal_args_1 tok
*)
and parse_formal_args_1 tok =
match tok with
| L.Token name ->
......@@ -226,6 +227,7 @@ let parse_expr ~enable_param enc s : expr_oe =
| _ ->
raise_bad()
(*
and parse_binding rsym =
let tok = scan buf in
if tok = rsym then
......@@ -234,7 +236,7 @@ let parse_expr ~enable_param enc s : expr_oe =
let (b, tok') = parse_binding_1 tok in
if tok' <> rsym then raise_bad();
b
*)
and parse_binding_nonempty rsym =
let tok = scan buf in
let (b, tok') = parse_binding_1 tok in
......
......@@ -155,8 +155,8 @@ let update_variables_from_cgi cgi dlg=
let var_re = S.regexp "^var_\\(.*\\)$" in
let digits_re = S.regexp "^[0-9_]+$" in
let ia = dlg # interactors in
let dlg_name = dlg # name in
let dlg_decl = dlg # declaration in
let _dlg_name = dlg # name in
let _dlg_decl = dlg # declaration in
(* Iterate over all CGI parameters and recognize the parameters whose
* name match 'var_re'. These parameters contain the new variable
......@@ -434,9 +434,9 @@ let get_event_from_cgi cgi dlg =
let anchor_re = S.regexp "^anchor_\\(.*\\)$" in
let xanchor_re = S.regexp "^xanchor_\\(.*\\)$" in
let ibuttonx_re = S.regexp "^imagebutton_\\(.*\\)\\.x$" in
let ibuttony_re = S.regexp "^imagebutton_\\(.*\\)\\.y$" in
let _ibuttony_re = S.regexp "^imagebutton_\\(.*\\)\\.y$" in
let xibuttonx_re = S.regexp "^ximagebutton_\\(.*\\)\\.x$" in
let xibuttony_re = S.regexp "^ximagebutton_\\(.*\\)\\.y$" in
let _xibuttony_re = S.regexp "^ximagebutton_\\(.*\\)\\.y$" in
(* 'matchers': This is a list of functions which will be tried in turn
* in order to find the CGI parameter expressing the event. The functions
......@@ -655,7 +655,7 @@ let process_request
let t0 = Unix.gettimeofday() in
let ui_pipe_ch =
let _ui_pipe_ch =
(* If present, open pipe to uidebugger right at the beginning.
* Otherwise it may happen that the pipe is never closed, and the
* uidebugger hangs.
......@@ -859,8 +859,8 @@ let process_request
(fun dlg ->
(* ... because a different dialog might be in scope now! *)
let dlg_name = dlg # name in
let dlg_decl = dlg # declaration in
let _dlg_name = dlg # name in
let _dlg_decl = dlg # declaration in
(****************************** STAGE 3 *****************************)
......
......@@ -623,22 +623,22 @@ class virtual dialog
let assoc = var.var_associative in
begin match value with
String_value _ ->
if assoc & not inner_check then
if assoc && not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> String_type then
raise (Runtime_error ("Cannot put a string into variable"))
| Dialog_value _ ->
if assoc & not inner_check then
if assoc && not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> Dialog_type then
raise (Runtime_error ("Cannot put a dialog into variable"));
| Dyn_enum_value v ->
if assoc & not inner_check then
if assoc && not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> Dyn_enum_type then
raise (Runtime_error ("Cannot put a dynamic enumeration into variable"));
| Enum_value evals ->
if assoc & not inner_check then
if assoc && not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
begin match vt with
Enum_type e ->
......@@ -651,12 +651,12 @@ class virtual dialog
raise (Runtime_error ("Cannot put an enumeration into variable"));
end
| Matrix_value(head,matrix) ->
if assoc & not inner_check then
if assoc && not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> Matrix_type then
raise (Runtime_error ("Cannot put a matrix into variable"));
| Table_value t ->
if assoc & not inner_check then
if assoc && not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> Table_type then
raise (Runtime_error ("Cannot put a table into variable"));
......@@ -709,7 +709,7 @@ class virtual dialog
let arg = Wd_upload.get (Lazy.force upload_manager) name in
(* or raise Not_found *)
let fn = arg # filename in
if fn = None or fn = Some "" then
if fn = None || fn = Some "" then
None
else
Some arg
......
......@@ -40,23 +40,23 @@ let subst rex f s =
newlen := !newlen - (p1-p0) + String.length sb
)
matches;
let s' = String.create !newlen in
let s' = Bytes.create !newlen in
let k = ref 0 in (* position in s *)
let k' = ref 0 in (* position in s' *)
Array.iteri
(fun i m ->
let sb = substitutes.(i) in
let p0,p1 = Pcre.get_substring_ofs m 0 in
String.blit s !k s' !k' (p0 - !k);
Bytes.blit_string s !k s' !k' (p0 - !k);
k' := !k' + (p0 - !k);
String.blit sb 0 s' !k' (String.length sb);
Bytes.blit_string sb 0 s' !k' (String.length sb);
k' := !k' + (String.length sb);
k := p1;
)
matches;
String.blit s !k s' !k' (String.length s - !k);
assert(!k' + String.length s - !k = String.length s');
s'
Bytes.blit_string s !k s' !k' (String.length s - !k);
assert(!k' + String.length s - !k = Bytes.length s');
Bytes.to_string s'
;;
......@@ -79,11 +79,11 @@ let encode_as_html =
let repeat n s =
(* Repeat the string [s] [n] times *)
let l = String.length s in
let s' = String.create (l * n) in
let s' = Bytes.create (l * n) in
for k = 0 to n-1 do
String.blit s 0 s' (k*l) l
Bytes.blit_string s 0 s' (k*l) l
done;
s'
Bytes.to_string s'
;;
let encode_as_pre_re = Pcre.regexp "[ \r\n\t]";;
......@@ -181,25 +181,25 @@ let encode_as_js_longstring ~(enc : Pxp_types.rep_encoding) s =
let rec join s' pos =
function
Term t ->
String.blit t 0 s' !pos (String.length t);
Bytes.blit_string t 0 s' !pos (String.length t);
pos := !pos + (String.length t)
| Pair(p1,p2) ->
join s' pos p1;
s'.[ !pos ] <- '"';
s'.[ !pos+1 ] <- '+';
s'.[ !pos+2 ] <- '\n';
s'.[ !pos+3 ] <- '"';
Bytes.set s' !pos '"';
Bytes.set s' (!pos+1) '+';
Bytes.set s' (!pos+2) '\n';
Bytes.set s' (!pos+3) '"';
pos := !pos + 4;
join s' pos p2;
in
let expr = divide 0 (String.length s) in
let l = total_length expr in
let s' = String.create l in
let s' = Bytes.create l in
let pos = ref 0 in
join s' pos expr;
assert (!pos = l);
s'
Bytes.to_string s'
;;
......
......@@ -119,7 +119,7 @@ let iter f ia =
None ->
()
| Some (name_pos, index, value, id) ->
assert(name_pos >= 0 & name_pos < ia.n_names);
assert(name_pos >= 0 && name_pos < ia.n_names);
let _ = f id ia.names.(name_pos) index value in
dorec (i+1)
end
......@@ -136,7 +136,7 @@ let add ia name index opt_id value =
begin match opt_id with
None -> ()
| Some n ->
if n <> "" & n.[0] >= '0' & n.[0] <= '9' then
if n <> "" && n.[0] >= '0' && n.[0] <= '9' then
raise(Runtime_error("The name of the CGI parameter `" ^ n ^
"' is illegal (it begins with a digit)"));
end;
......@@ -149,7 +149,7 @@ let add ia name index opt_id value =
if ia.n_names >= l then begin
(* make space *)
let new_l = 2 * l in
let new_names = Array.create new_l "" in
let new_names = Array.make new_l "" in
Array.blit ia.names 0 new_names 0 l;
ia.names <- new_names;
end;
......@@ -173,7 +173,7 @@ let add ia name index opt_id value =
if ia.n_entries >= l then begin
(* make space *)
let new_l = 2 * l in
let new_entries = Array.create new_l None in
let new_entries = Array.make new_l None in
Array.blit ia.entries 0 new_entries 0 l;
ia.entries <- new_entries;
end;
......@@ -206,7 +206,7 @@ let exists ia name index =
for i = 0 to ia.n_entries - 1 do
match ia.entries.( i ) with
Some (p, ix, _, _) ->
if p = name_pos & ix = index then
if p = name_pos && ix = index then
raise (Result true)
| None -> ()
done;
......@@ -231,11 +231,11 @@ let lookup ia id =
failwith "Interactor.lookup: ID not found"
in
if position < 0 or position >= ia.n_entries then
if position < 0 || position >= ia.n_entries then
failwith "Interactor.lookup: ID not found";
match ia.entries.(position) with
Some (name_pos, index, value, _) ->
assert(name_pos >= 0 & name_pos < ia.n_names);
assert(name_pos >= 0 && name_pos < ia.n_names);
ia.names.(name_pos), index, value
| None ->
assert false
......
......@@ -418,7 +418,7 @@ and ds_glist buf ds_cell =
let tok = ds_scan_token buf in
match tok with
| L_tok (width, height) ->
let m = Array.create height [| |] in
let m = Array.make height [| |] in
for k = 0 to height - 1 do
let row = ref [] in
for j = 0 to width - 1 do
......
......@@ -107,8 +107,8 @@ let concat app sep l =
let to_string obj t =
let buffer = Buffer.create 1024 in
let outch = new Netchannels.output_buffer buffer in
let app_decl = obj#application in
let obj_decl = obj#declaration in
let _app_decl = obj#application in
let _obj_decl = obj#declaration in
let vars = { within_popup = false;
current_page = obj # page_name;
popup_env_initialized = false;
......
......@@ -330,7 +330,7 @@ let instantiate dlg r params container =
try
Wd_brexpr_eval.eval_expr_oe dlg (subst_expr_params ~subst expr)
with
| (Instantiation_error msg as e) -> (* From subst_expr_params *)
| Instantiation_error msg -> (* From subst_expr_params *)
raise_insterr_with_loc (entity,line,col) msg expr_str
| Eval_error_noloc msg -> (* From eval_expr *)
raise_insterr_with_loc (entity,line,col) msg expr_str
......
......@@ -628,7 +628,7 @@ class virtual page_tree =
raise(self # runtime_error("Variable `" ^ vname ^
"' is plain but used as associative variable (extra index attribute)"));
end;
is_associative & index = None, vname, index
is_associative && index = None, vname, index
method private allocate_variable dlg =
......@@ -1761,7 +1761,7 @@ class uicatalog =
let pc = Wd_catalog.parse_catalog events in
let () =
try
let cat = app # catalog obj#name in
let _cat = app # catalog obj#name in
if pc.Wd_catalog.pc_uplinks <> [] then
raise(Formal_user_error("ui:catalog: Uplinks can only be defined in the first catalog for the dialog"));
()
......@@ -2128,7 +2128,7 @@ object (self)
* and the page definition of the page:
*)
let page_name = self # node # required_string_attribute "page" in
let page =
let _page =
try
dlg # declaration # page page_name
with
......@@ -2895,7 +2895,7 @@ class ui_iterate_stuff =
let data_exempl = new data_impl (new data_node) in
let new_data s = data_exempl # create_data dtd s in
if values = [] & !iter_empty <> None then begin
if values = [] && !iter_empty <> None then begin
match !iter_empty with
Some n ->
to_any n#extension
......@@ -3915,13 +3915,14 @@ let restore_stdlib dtd =
| `Enc_utf8 -> Wd_stdlib.stdlib_utf8_1
| e -> failwith ("WDialog restriction: This encoding is not supported: " ^ Netconversion.string_of_encoding e)
in
let stdlib_bytes = Bytes.of_string stdlib_string in
let stdlib_pos = ref 0 in
try
let tree =
Pxp_marshal.subtree_from_cmd_sequence
(fun () ->
let p = !stdlib_pos in
stdlib_pos := !stdlib_pos + Marshal.total_size stdlib_string p;
stdlib_pos := !stdlib_pos + Marshal.total_size stdlib_bytes p;
Marshal.from_string stdlib_string p
)
dtd
......
......@@ -58,8 +58,8 @@ let size (dlg : dialog_type) args =
String_value (string_of_int (List.length d))
| Alist_value a ->
String_value (string_of_int (List.length a))
| Dialog_value _ ->
failwith "function `size': not defined for dialogs"
| _ ->
failwith "function 'size': argument has bad type"
)
| _ ->
failwith "function `size': expects exactly one argument"
......@@ -100,8 +100,8 @@ let card (dlg : dialog_type) args =
String_value (string_of_int (List.length d))
| Alist_value a ->
String_value (string_of_int (List.length a))
| Dialog_value _ ->
failwith "function `card': not defined for dialogs"
| _ ->
failwith "function `card': argument has bad type"
)
| _ ->
failwith "function `card': expects exactly one argument"
......@@ -121,8 +121,8 @@ let list_string_op name op dlg args =
List.map fst d
| Alist_value a ->
List.map fst a
| Dialog_value _ ->
failwith ("function `" ^ name ^ " ': not defined for dialogs")
| _ ->
failwith ("function `" ^ name ^ " ': argument has bad type")
in
let v2 =
match a2 with
......
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