From 1edaaa067201474a246c30f6c34941d518f1042c Mon Sep 17 00:00:00 2001 From: Kakadu Date: Fri, 24 Jan 2025 00:02:47 +0300 Subject: [PATCH 1/2] Reproduce an issue Signed-off-by: Kakadu --- regression/dune.tests | 10 +++++ regression/test084.ml | 90 +++++++++++++++++++++++++++++++++++++++++++ regression/test084.t | 1 + 3 files changed, 101 insertions(+) create mode 100644 regression/test084.ml create mode 100644 regression/test084.t diff --git a/regression/dune.tests b/regression/dune.tests index 966c602e..d74c9572 100644 --- a/regression/dune.tests +++ b/regression/dune.tests @@ -400,6 +400,16 @@ (preprocess (action (run %{project_root}/camlp5/pp5+gt+plugins+dump.exe %{input-file}))) (preprocessor_deps (file %{project_root}/camlp5/pp5+gt+plugins+dump.exe))) +(cram + (applies_to test084) + (deps test084.exe)) +(executable + (name test084) + (modules test084) + (libraries GT) + (preprocess (action (run %{project_root}/camlp5/pp5+gt+plugins+dump.exe %{input-file}))) + (preprocessor_deps (file %{project_root}/camlp5/pp5+gt+plugins+dump.exe))) + (cram (applies_to test086) (deps test086std.exe)) diff --git a/regression/test084.ml b/regression/test084.ml new file mode 100644 index 00000000..3436350b --- /dev/null +++ b/regression/test084.ml @@ -0,0 +1,90 @@ +let id x = x + +module PV : sig + @type ('a, 'b) pv = [ `A of 'a | `B of 'b ] with show,gmap +end = struct + @type pv = [ `A | `B ] GT.list with show,gmap +end + +let _ = + let open PV in + Printf.printf "Original PV: %s\nMapped PV: %s\n" + (GT.show pv id id (`A "1")) + (GT.show pv (GT.show GT.int) id @@ + GT.gmap pv int_of_string id (`A "1")) + +module PVExt : sig + @type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a] with show,gmap +end = struct + @type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a] with show,gmap +end + +let _ = + let open PV in + let open PVExt in + Printf.printf "****************************\n%!"; + Printf.printf "Original pv: %s\n" @@ + GT.show pv id id (`A "1"); + Printf.printf "Mapped pv and showed as a pv_ext: %s\n" @@ + GT.show pv_ext (GT.show GT.int) id @@ + ((GT.gmap pv int_of_string id (`A "1")) :> (_,_) pv_ext); + Printf.printf "Original pv_ext: %s\n" @@ + GT.show pv_ext id id (`C "1"); + Printf.printf "Mapped PV_ext and showed as a pv_ext: %s\n" @@ + GT.show pv_ext (GT.show GT.int) id @@ + GT.gmap pv_ext int_of_string id (`C "1"); + +module PVExt2 : sig + @type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] with show,gmap +end = struct + @type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] with show,gmap +end + +let () = + let open PVExt in + let open PVExt2 in + + Printf.printf "****************************\n%!"; + Printf.printf "Original pv_ext: %s\n" @@ + GT.show pv_ext2 id id (`C "1"); + Printf.printf "Mapped pv_ext and showed as a pv_ext2: %s\n" @@ + GT.show pv_ext2 (GT.show GT.int) id @@ + ((GT.gmap pv_ext int_of_string id (`C "1")) :> (_,_) pv_ext2); + Printf.printf "Original pv_ext2: %s\n" @@ + GT.show pv_ext2 id (GT.show GT.int) (`D "1"); + Printf.printf "Mapped PV_ext2 and showed as a pv_ext2: %s\n" @@ + GT.show pv_ext2 (GT.show GT.int) id @@ + GT.gmap pv_ext2 int_of_string id (`D "1") + +module PVExt3 : sig + @type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] with show,gmap +end = struct + @type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] with show,gmap +end + +let () = + let open PVExt2 in + let open PVExt3 in + + (* let (_:int) = GT.show pv_ext3 in *) + Printf.printf "****************************\n%!"; + Printf.printf "Original pv_ext2: %s\n" @@ + GT.show pv_ext2 id id (`D "1"); + Printf.printf "Mapped pv_ext2 and showed as a pv_ext3: %s\n" @@ + GT.show pv_ext3 (GT.show GT.int) id id @@ + ((GT.gmap pv_ext2 (int_of_string) id (`D "1")) :> (_,_,_) pv_ext3); + Printf.printf "Original pv_ext3: %s\n" @@ + GT.show pv_ext3 id id id (`E "1"); + Printf.printf "Mapped PV_ext3 and showed as a pv_ext3: %s\n" @@ + GT.show pv_ext3 id id (GT.show GT.float) @@ + GT.gmap pv_ext3 id id float_of_string (`E "1.0"); + +module PVSum = struct + @type ('a,'b) s = [ ('a,'b) PV.pv | ('a,'b) PVExt.pv_ext ] with show,gmap +end +module XXX = struct + @type 'a xxx = [ `XXX of 'a ] with show,gmap +end +module YYY = struct + @type 'a yyy = [ 'a XXX.xxx | ('a,'a) PV.pv ] with show,gmap +end diff --git a/regression/test084.t b/regression/test084.t new file mode 100644 index 00000000..06f12efd --- /dev/null +++ b/regression/test084.t @@ -0,0 +1 @@ + $ ./test084.exe From bc3d73f35030deb07809182e12412cba442e185a Mon Sep 17 00:00:00 2001 From: Kakadu Date: Fri, 24 Jan 2025 17:51:22 +0300 Subject: [PATCH 2/2] Fix crash while injection of polyvariants (issue #32) Signed-off-by: Kakadu --- CHANGES | 5 ++- camlp5/Camlp5Helpers.ml | 16 +++++--- regression/dune.tests | 1 + regression/test084.ml | 86 ++--------------------------------------- regression/test084.t | 1 + 5 files changed, 19 insertions(+), 90 deletions(-) diff --git a/CHANGES b/CHANGES index c6ede7e7..39de33b6 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,8 @@ -# Ureleased +## Ureleased +## Changed + +* Fix issue 32: using polyvariants as type arguments crashed for Camlp5 ## 0.5.3 (2024-07-30) diff --git a/camlp5/Camlp5Helpers.ml b/camlp5/Camlp5Helpers.ml index 6075e901..938034f0 100644 --- a/camlp5/Camlp5Helpers.ml +++ b/camlp5/Camlp5Helpers.ml @@ -21,6 +21,7 @@ open GTCommon open Ploc open MLast +let failwiths = HelpersBase.failwiths module Located = struct type t = Ploc.t @@ -142,7 +143,7 @@ module Exp = struct | "[]" | "::" | _ when HelpersBase.Char.is_alpha s.[0] && capitalized s -> <:expr< $uid:s$ >> | _ -> <:expr< $lid:s$ >> - let attribute _ e = e + let attribute _ e = e let unit ~loc = <:expr< () >> let sprintf ~loc fmt = Printf.ksprintf (fun s -> <:expr< $lid:s$ >>) fmt @@ -312,7 +313,7 @@ module Typ = struct let init = List.hd r in List.fold_left (fun acc x -> arrow ~loc x acc) init (List.tl r) - let from_caml root_typ = + let rec from_caml root_typ = let rec helper typ = let loc = loc_from_caml typ.Ppxlib.ptyp_loc in match typ.ptyp_desc with @@ -321,13 +322,16 @@ module Typ = struct | Ptyp_arrow (lab, l, r) -> arrow ~loc (helper l) (helper r) | Ptyp_constr ({txt;_}, ts) -> constr ~loc txt (List.map helper ts) | Ptyp_tuple ts -> <:ctyp< ( $list:(List.map helper ts)$ ) >> - | Ptyp_variant (_,_,_) - | _ -> failwith "Not implemented: conversion from OCaml ast to Camlp5 Ast" + | Ptyp_variant (cs, flg, None) -> + variant ~loc ~is_open:(match flg with Closed -> false | Open -> true) cs + | Ptyp_variant (_,_,Some _ ) + | _ -> + failwiths "Not implemented: conversion from OCaml AST to Camlp5 AST (%s %d)" __FILE__ __LINE__ in helper root_typ (* this might need to be changed *) - let variant ~loc ?(is_open=false) fs = + and variant ~loc ?(is_open=false) fs = let vs = fs |> List.map (fun rf -> match rf.Ppxlib.prf_desc with | Ppxlib.Rinherit core_typ -> PvInh (loc, from_caml core_typ) | Rtag (lb, is_open, args) -> @@ -335,7 +339,7 @@ module Typ = struct ) in if is_open then <:ctyp< [ > $list:vs$ ] >> - else <:ctyp< [ < $list:vs$ ] >> + else <:ctyp< [ = $list:vs$ ] >> let variant_of_t ~loc typ = <:ctyp< [ > $list:[PvInh (loc, typ)]$ ] >> diff --git a/regression/dune.tests b/regression/dune.tests index d74c9572..af394343 100644 --- a/regression/dune.tests +++ b/regression/dune.tests @@ -406,6 +406,7 @@ (executable (name test084) (modules test084) + ;(flags (:standard -dsource)) (libraries GT) (preprocess (action (run %{project_root}/camlp5/pp5+gt+plugins+dump.exe %{input-file}))) (preprocessor_deps (file %{project_root}/camlp5/pp5+gt+plugins+dump.exe))) diff --git a/regression/test084.ml b/regression/test084.ml index 3436350b..491a7030 100644 --- a/regression/test084.ml +++ b/regression/test084.ml @@ -1,90 +1,10 @@ let id x = x module PV : sig - @type ('a, 'b) pv = [ `A of 'a | `B of 'b ] with show,gmap + @type ('a,'b) pv = [ `A of 'a | `B of 'b * GT.int ] GT.list with show end = struct - @type pv = [ `A | `B ] GT.list with show,gmap -end - -let _ = - let open PV in - Printf.printf "Original PV: %s\nMapped PV: %s\n" - (GT.show pv id id (`A "1")) - (GT.show pv (GT.show GT.int) id @@ - GT.gmap pv int_of_string id (`A "1")) - -module PVExt : sig - @type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a] with show,gmap -end = struct - @type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a] with show,gmap -end - -let _ = - let open PV in - let open PVExt in - Printf.printf "****************************\n%!"; - Printf.printf "Original pv: %s\n" @@ - GT.show pv id id (`A "1"); - Printf.printf "Mapped pv and showed as a pv_ext: %s\n" @@ - GT.show pv_ext (GT.show GT.int) id @@ - ((GT.gmap pv int_of_string id (`A "1")) :> (_,_) pv_ext); - Printf.printf "Original pv_ext: %s\n" @@ - GT.show pv_ext id id (`C "1"); - Printf.printf "Mapped PV_ext and showed as a pv_ext: %s\n" @@ - GT.show pv_ext (GT.show GT.int) id @@ - GT.gmap pv_ext int_of_string id (`C "1"); - -module PVExt2 : sig - @type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] with show,gmap -end = struct - @type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] with show,gmap + @type ('a,'b) pv = [ `A of 'a | `B of 'b * GT.int ] GT.list with show end let () = - let open PVExt in - let open PVExt2 in - - Printf.printf "****************************\n%!"; - Printf.printf "Original pv_ext: %s\n" @@ - GT.show pv_ext2 id id (`C "1"); - Printf.printf "Mapped pv_ext and showed as a pv_ext2: %s\n" @@ - GT.show pv_ext2 (GT.show GT.int) id @@ - ((GT.gmap pv_ext int_of_string id (`C "1")) :> (_,_) pv_ext2); - Printf.printf "Original pv_ext2: %s\n" @@ - GT.show pv_ext2 id (GT.show GT.int) (`D "1"); - Printf.printf "Mapped PV_ext2 and showed as a pv_ext2: %s\n" @@ - GT.show pv_ext2 (GT.show GT.int) id @@ - GT.gmap pv_ext2 int_of_string id (`D "1") - -module PVExt3 : sig - @type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] with show,gmap -end = struct - @type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] with show,gmap -end - -let () = - let open PVExt2 in - let open PVExt3 in - - (* let (_:int) = GT.show pv_ext3 in *) - Printf.printf "****************************\n%!"; - Printf.printf "Original pv_ext2: %s\n" @@ - GT.show pv_ext2 id id (`D "1"); - Printf.printf "Mapped pv_ext2 and showed as a pv_ext3: %s\n" @@ - GT.show pv_ext3 (GT.show GT.int) id id @@ - ((GT.gmap pv_ext2 (int_of_string) id (`D "1")) :> (_,_,_) pv_ext3); - Printf.printf "Original pv_ext3: %s\n" @@ - GT.show pv_ext3 id id id (`E "1"); - Printf.printf "Mapped PV_ext3 and showed as a pv_ext3: %s\n" @@ - GT.show pv_ext3 id id (GT.show GT.float) @@ - GT.gmap pv_ext3 id id float_of_string (`E "1.0"); - -module PVSum = struct - @type ('a,'b) s = [ ('a,'b) PV.pv | ('a,'b) PVExt.pv_ext ] with show,gmap -end -module XXX = struct - @type 'a xxx = [ `XXX of 'a ] with show,gmap -end -module YYY = struct - @type 'a yyy = [ 'a XXX.xxx | ('a,'a) PV.pv ] with show,gmap -end + print_endline @@ (GT.show PV.pv (GT.show GT.int) (GT.show GT.int)) [`A 5] \ No newline at end of file diff --git a/regression/test084.t b/regression/test084.t index 06f12efd..3acff221 100644 --- a/regression/test084.t +++ b/regression/test084.t @@ -1 +1,2 @@ $ ./test084.exe + [`A (5)]