diff --git a/src/core/CCAtomic.ml b/src/core/CCAtomic.ml new file mode 100644 index 00000000..3cbe1206 --- /dev/null +++ b/src/core/CCAtomic.ml @@ -0,0 +1,35 @@ + +[%IFGE 4.12] + +include Atomic + + +[%ELSE] + +open CCShims_.Stdlib (* for == *) + +type 'a t = {mutable x: 'a} +let[@inline] make x = {x} +let[@inline] get {x} = x +let[@inline] set r x = r.x <- x +let[@inline] exchange r x = + let y = r.x in + r.x <- x; + y + +let[@inline] compare_and_set r seen v = + if r.x == seen then ( + r.x <- v; + true + ) else false + +let[@inline] fetch_and_add r x = + let v = r.x in + r.x <- x + r.x; + v + +let[@inline] incr r = r.x <- 1 + r.x +let[@inline] decr r = r.x <- r.x - 1 + + +[%ENDIF] diff --git a/src/core/CCFun.ml b/src/core/CCFun.ml index ea7c3322..7bfab01e 100644 --- a/src/core/CCFun.ml +++ b/src/core/CCFun.ml @@ -9,7 +9,27 @@ let opaque_identity x = x include Sys include CCShims_.Stdlib -include CCShimsFun_ + +[%IFGE 4.8] + +include Fun + +[%ELSE] + +external id : 'a -> 'a = "%identity" +let[@inline] flip f x y = f y x +let[@inline] const x _ = x +let[@inline] negate f x = not (f x) +let[@inline] protect ~finally f = + try + let x= f() in + finally(); + x + with e -> + finally(); + raise e + +[%ENDIF] let compose f g x = g (f x) diff --git a/src/core/CCFun.mli b/src/core/CCFun.mli index 83b98328..8bda13b7 100644 --- a/src/core/CCFun.mli +++ b/src/core/CCFun.mli @@ -3,9 +3,22 @@ (** Basic operations on Functions *) -include module type of CCShimsFun_ +[%IFGE 4.8] +include module type of Fun (** @inline *) +[%ELSE] +(** This is an API imitating the new standard Fun module *) +external id : 'a -> 'a = "%identity" +val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c +val const : 'a -> _ -> 'a +val negate : ('a -> bool) -> 'a -> bool + +val protect : finally:(unit -> unit) -> (unit -> 'a) -> 'a +(* this doesn't have the exact same semantics as the stdlib's finally. + It will not attempt to catch exceptions raised from [finally] at all. *) +[%ENDIF] + val compose : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c (** [compose f g x] is [g (f x)]. Composition. *) diff --git a/src/core/cpp/cpp.ml b/src/core/cpp/cpp.ml index 58cd3425..0066c17d 100644 --- a/src/core/cpp/cpp.ml +++ b/src/core/cpp/cpp.ml @@ -32,9 +32,10 @@ let eval ~major ~minor op i j = | Le -> (major,minor) <= (i,j) | Ge -> (major,minor) >= (i,j) -let preproc_lines ~major ~minor (ic:in_channel) : unit = +let preproc_lines ~file ~major ~minor (ic:in_channel) : unit = let pos = ref 0 in let fail msg = failwith (Printf.sprintf "at line %d: %s" !pos msg) in + let pp_pos () = Printf.printf "#%d %S\n" !pos file in let parse_line () : line = match input_line ic with @@ -49,6 +50,7 @@ let preproc_lines ~major ~minor (ic:in_channel) : unit = Scanf.sscanf line "[%%ELIFLE %d.%d]" (fun x y -> Elseif(Le,x,y)) else if prefix line ~pre:"[%ELIFGE" then Scanf.sscanf line "[%%ELIFGE %d.%d]" (fun x y -> Elseif(Ge,x,y)) + else if line="[%ELSE]" then Else else if line="[%ENDIF]" then Endif else Raw line in @@ -58,8 +60,10 @@ let preproc_lines ~major ~minor (ic:in_channel) : unit = match parse_line () with | Eof -> () | If (op,i,j) -> - if eval ~major ~minor op i j - then cat_block () else skip_block ~elseok:true () + if eval ~major ~minor op i j then ( + pp_pos(); + cat_block () + ) else skip_block ~elseok:true () | Raw s -> print_endline s; top() | Elseif _ | Else | Endif -> fail "unexpected elseif|else|endif" @@ -82,20 +86,23 @@ let preproc_lines ~major ~minor (ic:in_channel) : unit = | Raw _ -> skip_block ~elseok () | Endif -> top() | Elseif (op,i,j) -> - if elseok && eval ~major ~minor op i j - then cat_block () - else skip_block ~elseok () + if elseok && eval ~major ~minor op i j then ( + pp_pos(); + cat_block () + ) else skip_block ~elseok () | Else -> - if elseok then cat_block() else skip_block ~elseok () + if elseok then ( + pp_pos(); + cat_block() + ) else skip_block ~elseok () in top() let () = let file = Sys.argv.(1) in - C.main ~name:"cpp" (fun c -> - let version = C.ocaml_config_var_exn c "version" in - let major, minor = Scanf.sscanf version "%u.%u" (fun maj min -> maj, min) in + let c = C.create "main" in + let version = C.ocaml_config_var_exn c "version" in + let major, minor = Scanf.sscanf version "%u.%u" (fun maj min -> maj, min) in - let ic = open_in_bin file in - preproc_lines ~major ~minor ic - ) + let ic = open_in_bin file in + preproc_lines ~file ~major ~minor ic diff --git a/src/core/dune b/src/core/dune index fd2dd653..8389303d 100644 --- a/src/core/dune +++ b/src/core/dune @@ -5,9 +5,9 @@ (libraries dune.configurator)) (rule - (targets CCShims_.ml CCShimsList_.ml CCShimsFun_.ml CCShimsFun_.mli + (targets CCShims_.ml CCShimsList_.ml CCShimsArray_.ml CCShimsFormat_.ml CCShimsMkLet_.ml CCShimsMkLetList_.ml - CCShimsArrayLabels_.ml CCShimsInt_.ml CCAtomic.ml CCUnit.ml) + CCShimsArrayLabels_.ml CCShimsInt_.ml CCUnit.ml) (deps ./mkshims.exe) (action (run ./mkshims.exe))) diff --git a/src/core/mkshims.ml b/src/core/mkshims.ml index 8cb652b3..bcd8f075 100644 --- a/src/core/mkshims.ml +++ b/src/core/mkshims.ml @@ -53,20 +53,6 @@ let shims_fun_pre_408 = " raise e " -let shims_fun_mli_pre_408 = " - (** This is an API imitating the new standard Fun module *) - external id : 'a -> 'a = \"%identity\" - val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c - val const : 'a -> _ -> 'a - val negate : ('a -> bool) -> 'a -> bool - - val protect : finally:(unit -> unit) -> (unit -> 'a) -> 'a - (* this doesn't have the exact same semantics as the stdlib's finally. - It will not attempt to catch exceptions raised from [finally] at all. *) -" - -let shims_fun_post_408 = "include Fun" -let shims_fun_mli_post_408 = "include module type of Fun" let shims_list_pre_408 = " include List @@ -213,35 +199,6 @@ let to_string () = "()" let shims_unit_after_408 = "include Unit" -let shims_atomic_before_412 = {| - open CCShims_.Stdlib (* for == *) - - type 'a t = {mutable x: 'a} - let[@inline] make x = {x} - let[@inline] get {x} = x - let[@inline] set r x = r.x <- x - let[@inline] exchange r x = - let y = r.x in - r.x <- x; - y - - let[@inline] compare_and_set r seen v = - if r.x == seen then ( - r.x <- v; - true - ) else false - - let[@inline] fetch_and_add r x = - let v = r.x in - r.x <- x + r.x; - v - - let[@inline] incr r = r.x <- 1 + r.x - let[@inline] decr r = r.x <- r.x - 1 - |} - -let shims_atomic_after_412 = {|include Atomic|} - let () = C.main ~name:"mkshims" (fun c -> let version = C.ocaml_config_var_exn c "version" in @@ -257,14 +214,10 @@ let () = else if (major, minor) >= (4,6) then shims_array_label_406_408 else shims_array_label_pre_406); write_file "CCShimsFormat_.ml" (if (major, minor) >= (4,8) then shims_fmt_post_408 else shims_fmt_pre_408); - write_file "CCShimsFun_.ml" (if (major, minor) >= (4,8) then shims_fun_post_408 else shims_fun_pre_408); - write_file "CCShimsFun_.mli" (if (major, minor) >= (4,8) then shims_fun_mli_post_408 else shims_fun_mli_pre_408); write_file "CCShimsMkLet_.ml" (if (major, minor) >= (4,8) then shims_let_op_post_408 else shims_let_op_pre_408); write_file "CCShimsMkLetList_.ml" (if (major, minor) >= (4,8) then shims_let_op_list_post_408 else shims_let_op_list_pre_408); write_file "CCShimsInt_.ml" (if (major, minor) >= (4,8) then shims_int_post_408 else shims_int_pre_408); - write_file "CCAtomic.ml" - (if (major, minor) >= (4,12) then shims_atomic_after_412 else shims_atomic_before_412); write_file "CCUnit.ml" (if (major, minor) >= (4,8) then shims_unit_after_408 else shims_unit_before_408); )