diff options
| -rw-r--r-- | camlp4/camlp4/ast2pt.ml | 37 | ||||
| -rw-r--r-- | camlp4/etc/pa_o.ml | 3 | ||||
| -rw-r--r-- | camlp4/ocaml_src/camlp4/ast2pt.ml | 31 |
3 files changed, 47 insertions, 24 deletions
diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml index ce8603f55..21011a8ab 100644 --- a/camlp4/camlp4/ast2pt.ml +++ b/camlp4/camlp4/ast2pt.ml @@ -142,22 +142,35 @@ value rec ctyp_fa al = | f -> (f, al) ] ; -value rec ctyp_long_id = - fun +value rec ctyp_long_id_prefix t = + match t with [ TyAcc _ m (TyLid _ s) -> - let (is_cls, li) = ctyp_long_id m in - (is_cls, ldot li s) + error (loc_of_ctyp t) "invalid path element in type name" | TyAcc _ m (TyUid _ s) -> - let (is_cls, li) = ctyp_long_id m in + let (is_cls, li) = ctyp_long_id_prefix m in (is_cls, ldot li s) | TyApp _ m1 m2 -> - let (is_cls, li1) = ctyp_long_id m1 in - let (_, li2) = ctyp_long_id m2 in - (is_cls, Lapply li1 li2) + error (loc_of_ctyp t) "invalid path element in type name" | TyUid _ s -> (False, lident s) + | TyLid _ s -> + error (loc_of_ctyp t) "invalid path element in type name" + | t -> error (loc_of_ctyp t) "invalid type" ] +; + +value ctyp_long_id t = + match t with + [ TyAcc _ m (TyLid _ s) -> + let (is_cls, li) = ctyp_long_id_prefix m in + (is_cls, ldot li s) + | TyAcc _ m (TyUid _ s as t) -> + error (loc_of_ctyp t) "type names cannot be capitalized" + | TyApp _ m1 m2 -> + error (loc_of_ctyp t) "expecting a type name" + | TyUid _ s -> + error (loc_of_ctyp t) "type names cannot be capitalized" | TyLid _ s -> (False, lident s) | TyCls loc sl -> (True, long_id_of_string_list loc sl) - | t -> error (loc_of_ctyp t) "incorrect type" ] + | t -> error (loc_of_ctyp t) "invalid type" ] ; value rec ctyp = @@ -171,7 +184,7 @@ value rec ctyp = match (t1, t2) with [ (t, TyQuo _ s) -> (t, s) | (TyQuo _ s, t) -> (t, s) - | _ -> error loc "incorrect alias type" ] + | _ -> error loc "invalid alias type" ] in mktyp loc (Ptyp_alias (ctyp t) i) | TyAny loc -> mktyp loc Ptyp_any @@ -198,7 +211,7 @@ value rec ctyp = | TyRec loc _ _ -> error loc "record type not allowed here" | TySum loc _ _ -> error loc "sum type not allowed here" | TyTup loc tl -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid loc s -> mktyp loc (Ptyp_constr (lident s) []) + | TyUid loc s as t -> error (loc_of_ctyp t) "invalid type" | TyVrn loc catl ool -> let catl = List.map @@ -402,7 +415,7 @@ value rec patt = match (p1, p2) with [ (p, PaLid _ s) -> (p, s) | (PaLid _ s, p) -> (p, s) - | _ -> error loc "incorrect alias pattern" ] + | _ -> error loc "invalid alias pattern" ] in mkpat loc (Ppat_alias (patt p) i) | PaAnt _ p -> patt p diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml index 2da98a5bc..b80f4eb7b 100644 --- a/camlp4/etc/pa_o.ml +++ b/camlp4/etc/pa_o.ml @@ -926,8 +926,7 @@ EXTEND | "ctyp1" [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] | "ctyp2" - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> - | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] + [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> ] | "simple" [ "'"; i = ident -> <:ctyp< '$i$ >> | "_" -> <:ctyp< _ >> diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml index d3eb318e8..6866b5bde 100644 --- a/camlp4/ocaml_src/camlp4/ast2pt.ml +++ b/camlp4/ocaml_src/camlp4/ast2pt.ml @@ -131,19 +131,30 @@ let rec ctyp_fa al = | f -> f, al ;; -let rec ctyp_long_id = - function +let rec ctyp_long_id_prefix t = + match t with TyAcc (_, m, TyLid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s + error (loc_of_ctyp t) "invalid path element in type name" | TyAcc (_, m, TyUid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s + let (is_cls, li) = ctyp_long_id_prefix m in is_cls, ldot li s | TyApp (_, m1, m2) -> - let (is_cls, li1) = ctyp_long_id m1 in - let (_, li2) = ctyp_long_id m2 in is_cls, Lapply (li1, li2) + error (loc_of_ctyp t) "invalid path element in type name" | TyUid (_, s) -> false, lident s + | TyLid (_, s) -> error (loc_of_ctyp t) "invalid path element in type name" + | t -> error (loc_of_ctyp t) "invalid type" +;; + +let ctyp_long_id t = + match t with + TyAcc (_, m, TyLid (_, s)) -> + let (is_cls, li) = ctyp_long_id_prefix m in is_cls, ldot li s + | TyAcc (_, m, (TyUid (_, s) as t)) -> + error (loc_of_ctyp t) "type names cannot be capitalized" + | TyApp (_, m1, m2) -> error (loc_of_ctyp t) "expecting a type name" + | TyUid (_, s) -> error (loc_of_ctyp t) "type names cannot be capitalized" | TyLid (_, s) -> false, lident s | TyCls (loc, sl) -> true, long_id_of_string_list loc sl - | t -> error (loc_of_ctyp t) "incorrect type" + | t -> error (loc_of_ctyp t) "invalid type" ;; let rec ctyp = @@ -157,7 +168,7 @@ let rec ctyp = match t1, t2 with t, TyQuo (_, s) -> t, s | TyQuo (_, s), t -> t, s - | _ -> error loc "incorrect alias type" + | _ -> error loc "invalid alias type" in mktyp loc (Ptyp_alias (ctyp t, i)) | TyAny loc -> mktyp loc Ptyp_any @@ -184,7 +195,7 @@ let rec ctyp = | TyRec (loc, _, _) -> error loc "record type not allowed here" | TySum (loc, _, _) -> error loc "sum type not allowed here" | TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) + | TyUid (loc, s) as t -> error (loc_of_ctyp t) "invalid type" | TyVrn (loc, catl, ool) -> let catl = List.map @@ -397,7 +408,7 @@ let rec patt = match p1, p2 with p, PaLid (_, s) -> p, s | PaLid (_, s), p -> p, s - | _ -> error loc "incorrect alias pattern" + | _ -> error loc "invalid alias pattern" in mkpat loc (Ppat_alias (patt p, i)) | PaAnt (_, p) -> patt p |