Support for quoted strings.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13450 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

asmcomp/cmmgen.ml

@@ -1924,7 +1924,7 @@ let rec emit_constant symb cst cont =
   match cst with
     Const_base(Const_float s) ->
       Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont
-  | Const_base(Const_string s) | Const_immstring s ->
+  | Const_base(Const_string (s, _)) | Const_immstring s ->
       Cint(string_header (String.length s)) ::
       Cdefine_symbol symb ::
       emit_string_constant s cont
@@ -1967,7 +1967,7 @@ and emit_constant_field field cont =
       let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont)
-  | Const_base(Const_string s) ->
+  | Const_base(Const_string (s, _)) ->
       let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(string_header (String.length s)) :: Cdefine_label lbl ::
@@ -2443,7 +2443,7 @@ let reference_symbols namelist =
 let global_data name v =
   Cdata(Cglobal_symbol name ::
           emit_constant name
-          (Const_base (Const_string (Marshal.to_string v []))) [])
+          (Const_base (Const_string (Marshal.to_string v [], None))) [])
 
 let globals_map v = global_data "caml_globals_map" v
 
@@ -2482,7 +2482,8 @@ let predef_exception name =
   let bucketname = "caml_bucket_" ^ name in
   let symname = "caml_exn_" ^ name in
   Cdata(Cglobal_symbol symname ::
-        emit_constant symname (Const_block(0,[Const_base(Const_string name)]))
+        emit_constant symname
+          (Const_block(0,[Const_base(Const_string (name, None))]))
         [ Cglobal_symbol bucketname;
           Cint(block_header 0 1);
           Cdefine_symbol bucketname;

bytecomp/matching.ml

@@ -2541,7 +2541,7 @@ let partial_function loc () =
   Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_match_failure;
            Lconst(Const_block(0,
-              [Const_base(Const_string fname);
+              [Const_base(Const_string (fname, None));
                Const_base(Const_int line);
                Const_base(Const_int char)]))])])
 

bytecomp/printlambda.ml

@@ -20,7 +20,7 @@ open Lambda
 let rec struct_const ppf = function
   | Const_base(Const_int n) -> fprintf ppf "%i" n
   | Const_base(Const_char c) -> fprintf ppf "%C" c
-  | Const_base(Const_string s) -> fprintf ppf "%S" s
+  | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s
   | Const_immstring s -> fprintf ppf "#%S" s
   | Const_base(Const_float f) -> fprintf ppf "%s" f
   | Const_base(Const_int32 n) -> fprintf ppf "%lil" n

bytecomp/symtable.ml

@@ -140,7 +140,7 @@ let init () =
         try List.assoc name Predef.builtin_values
         with Not_found -> fatal_error "Symtable.init" in
       let c = slot_for_setglobal id in
-      let cst = Const_block(0, [Const_base(Const_string name)]) in
+      let cst = Const_block(0, [Const_base(Const_string (name, None))]) in
       literal_table := (c, cst) :: !literal_table)
     Runtimedef.builtin_exceptions;
   (* Initialize the known C primitives *)
@@ -199,7 +199,7 @@ let patch_object buff patchlist =
 let rec transl_const = function
     Const_base(Const_int i) -> Obj.repr i
   | Const_base(Const_char c) -> Obj.repr c
-  | Const_base(Const_string s) -> Obj.repr s
+  | Const_base(Const_string (s, _)) -> Obj.repr s
   | Const_base(Const_float f) -> Obj.repr (float_of_string f)
   | Const_base(Const_int32 i) -> Obj.repr i
   | Const_base(Const_int64 i) -> Obj.repr i

bytecomp/translcore.ml

@@ -583,7 +583,7 @@ let assert_failed exp =
     (Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_assert_failure;
            Lconst(Const_block(0,
-              [Const_base(Const_string fname);
+              [Const_base(Const_string (fname, None));
                Const_base(Const_int line);
                Const_base(Const_int char)]))]))])
 ;;
@@ -1076,7 +1076,8 @@ let transl_exception path decl =
     match path with
       None -> Ident.name decl.cd_id
     | Some p -> Path.name p in
-  Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))])
+  Lprim(Pmakeblock(0, Immutable),
+        [Lconst(Const_base(Const_string (name,None)))])
 
 (* Error report *)
 

bytecomp/translmod.ml

@@ -108,7 +108,7 @@ let mod_prim name =
 let undefined_location loc =
   let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
   Lconst(Const_block(0,
-                     [Const_base(Const_string fname);
+                     [Const_base(Const_string (fname, None));
                       Const_base(Const_int line);
                       Const_base(Const_int char)]))
 
@@ -653,13 +653,13 @@ let toplevel_name id =
 let toploop_getvalue id =
   Lapply(Lprim(Pfield toploop_getvalue_pos,
                  [Lprim(Pgetglobal toploop_ident, [])]),
-         [Lconst(Const_base(Const_string (toplevel_name id)))],
+         [Lconst(Const_base(Const_string (toplevel_name id, None)))],
          Location.none)
 
 let toploop_setvalue id lam =
   Lapply(Lprim(Pfield toploop_setvalue_pos,
                  [Lprim(Pgetglobal toploop_ident, [])]),
-         [Lconst(Const_base(Const_string (toplevel_name id))); lam],
+         [Lconst(Const_base(Const_string (toplevel_name id, None))); lam],
          Location.none)
 
 let toploop_setvalue_id id = toploop_setvalue id (Lvar id)

bytecomp/translobj.ml

@@ -86,7 +86,7 @@ let reset_labels () =
 
 (* Insert labels *)
 
-let string s = Lconst (Const_base (Const_string s))
+let string s = Lconst (Const_base (Const_string (s, None)))
 let int n = Lconst (Const_base (Const_int n))
 
 let prim_makearray =

camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml

@@ -582,7 +582,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
         let is_closed = if wildcards = [] then Closed else Open in
         mkpat loc (Ppat_record (List.map mklabpat ps, is_closed))
     | PaStr loc s ->
-        mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s)))
+        mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s) None))
     | <:patt@loc< ($p1$, $p2$) >> ->
          mkpat loc (Ppat_tuple
            (List.map patt (list_of_patt p1 (list_of_patt p2 []))))
@@ -861,7 +861,7 @@ value varify_constructors var_names =
           (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get")))
             [("", expr e1); ("", expr e2)])
     | ExStr loc s ->
-        mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s)))
+        mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s) None))
     | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a []))
     | <:expr@loc< ($e1$, $e2$) >> ->
          mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 []))))

camlp4/boot/Camlp4.ml

@@ -14810,7 +14810,7 @@ module Struct =
               | PaStr (loc, s) ->
                   mkpat loc
                     (Ppat_constant
-                       (Const_string (string_of_string_token loc s)))
+                       (Const_string (string_of_string_token loc s, None)))
               | Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) ->
                   mkpat loc
                     (Ppat_tuple
@@ -15152,7 +15152,7 @@ module Struct =
               | ExStr (loc, s) ->
                   mkexp loc
                     (Pexp_constant
-                       (Const_string (string_of_string_token loc s)))
+                       (Const_string (string_of_string_token loc s, None)))
               | ExTry (loc, e, a) ->
                   mkexp loc (Pexp_try ((expr e), (match_case a [])))
               | Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) ->

experimental/frisch/extension_points.txt

@@ -134,6 +134,35 @@ begin[@foo] ... end        ====   (begin ... end)[@foo]
 match%foo e with ...       ====   [%foo match e with ...]
 
 
+=== Quoted strings
+
+Quoted strings gives a different syntax to write string literals in
+OCaml code.  This will typically be used to support embedding pieces
+of foreign syntax fragments (to be interpret by a -ppx filter or just
+a library) in OCaml code.
+
+The opening delimiter has the form {id| where id is a (possibly empty)
+sequence of lowercase letters.  The corresponding closing delimiter is
+|id} (the same identifier).  Contrary to regular OCaml string
+literals, quoted strings don't interpret any character in a special
+way.
+
+Example:
+
+String.length {|\"|}   (* returns 2 *)
+String.length {foo|\"|foo}   (* returns 2 *)
+
+
+The fact that a string literal comes from a quoted string is kept in
+the Parsetree representation.  The Astypes.Const_string constructor is
+now defined as:
+
+  | Const_string of string * string option
+
+where the "string option" represents the delimiter (None for a string
+literal with the regular syntax).
+
+
 === Representation of attributes in the Parsetree
 
 Attributes as standalone signature/structure items are represented

ocamldoc/.depend

@@ -10,26 +10,26 @@ odoc_analyse.cmo : ../utils/warnings.cmi ../typing/typetexp.cmi \
     ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \
     ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \
     ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \
-    ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \
+    ../parsing/syntaxerr.cmi ../driver/pparse.cmi ../parsing/parse.cmi \
-    odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
+    odoc_types.cmi odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
     odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \
     odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \
     ../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
     ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \
     ../utils/config.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \
-    ../utils/ccomp.cmi odoc_analyse.cmi
+    odoc_analyse.cmi
 odoc_analyse.cmx : ../utils/warnings.cmx ../typing/typetexp.cmx \
     ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \
     ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \
     ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \
-    ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \
+    ../parsing/syntaxerr.cmx ../driver/pparse.cmx ../parsing/parse.cmx \
-    odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
+    odoc_types.cmx odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
     odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \
     odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \
     ../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
     ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \
     ../utils/config.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \
-    ../utils/ccomp.cmx odoc_analyse.cmi
+    odoc_analyse.cmi
 odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \
     odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \
     odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi

parsing/ast_mapper.ml

@@ -193,7 +193,7 @@ module E = struct
 
   let lid ?(loc = Location.none) ?attrs lid = Exp.ident ~loc ?attrs (mkloc (Longident.parse lid) loc)
   let apply_nolabs ?loc ?attrs f el = Exp.apply ?loc ?attrs f (List.map (fun e -> ("", e)) el)
-  let strconst ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_string x)
+  let strconst ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_string (x, None))
 
   let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
     let open Exp in

parsing/asttypes.mli

@@ -15,7 +15,7 @@
 type constant =
     Const_int of int
   | Const_char of char
-  | Const_string of string
+  | Const_string of string * string option
   | Const_float of string
   | Const_int32 of int32
   | Const_int64 of int64

parsing/lexer.mll

@@ -111,12 +111,14 @@ let store_string_char c =
   String.unsafe_set (!string_buff) (!string_index) c;
   incr string_index
 
-let store_lexeme lexbuf =
+let store_string s =
-  let s = Lexing.lexeme lexbuf in
   for i = 0 to String.length s - 1 do
     store_string_char s.[i];
   done
 
+let store_lexeme lexbuf =
+  store_string (Lexing.lexeme lexbuf)
+
 let get_stored_string () =
   let s = String.sub (!string_buff) 0 (!string_index) in
   string_buff := initial_string_buffer;
@@ -311,7 +313,18 @@ rule token = parse
         string lexbuf;
         is_in_string := false;
         lexbuf.lex_start_p <- string_start;
-        STRING (get_stored_string()) }
+        STRING (get_stored_string(), None) }
+  | "{" lowercase* "|"
+      { reset_string_buffer();
+        let delim = Lexing.lexeme lexbuf in
+        let delim = String.sub delim 1 (String.length delim - 2) in
+        is_in_string := true;
+        let string_start = lexbuf.lex_start_p in
+        string_start_loc := Location.curr lexbuf;
+        quoted_string delim lexbuf;
+        is_in_string := false;
+        lexbuf.lex_start_p <- string_start;
+        STRING (get_stored_string(), Some delim) }
   | "'" newline "'"
       { update_loc lexbuf None 1 false 1;
         CHAR (Lexing.lexeme_char lexbuf 1) }
@@ -536,6 +549,33 @@ and string = parse
       { store_string_char(Lexing.lexeme_char lexbuf 0);
         string lexbuf }
 
+and quoted_string delim = parse
+  | newline
+      { update_loc lexbuf None 1 false 0;
+        store_lexeme lexbuf;
+        quoted_string delim lexbuf
+      }
+  | eof
+      { is_in_string := false;
+        raise (Error (Unterminated_string, !string_start_loc)) }
+  | "|" lowercase* "}"
+      {
+        let edelim = Lexing.lexeme lexbuf in
+        let edelim = String.sub edelim 1 (String.length edelim - 2) in
+        if delim = edelim then ()
+        else begin
+          lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1;
+          let curpos = lexbuf.lex_curr_p in
+          lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
+          store_string_char '|';
+          store_string edelim;
+          quoted_string delim lexbuf
+        end
+      }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        quoted_string delim lexbuf }
+
 and skip_sharp_bang = parse
   | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
        { update_loc lexbuf None 3 false 0 }

parsing/parser.mly

@@ -404,7 +404,7 @@ let mkexp_attrs d attrs =
 %token SHARP
 %token SIG
 %token STAR
-%token <string> STRING
+%token <string * string option> STRING
 %token STRUCT
 %token THEN
 %token TILDE
@@ -1408,8 +1408,8 @@ lbl_pattern:
 /* Primitive declarations */
 
 primitive_declaration:
-    STRING                                      { [$1] }
+    STRING                                      { [fst $1] }
-  | STRING primitive_declaration                { $1 :: $2 }
+  | STRING primitive_declaration                { fst $1 :: $2 }
 ;
 
 /* Type declarations */
@@ -1737,7 +1737,7 @@ label:
 constant:
     INT                                         { Const_int $1 }
   | CHAR                                        { Const_char $1 }
-  | STRING                                      { Const_string $1 }
+  | STRING                                      { let (s, d) = $1 in Const_string (s, d) }
   | FLOAT                                       { Const_float $1 }
   | INT32                                       { Const_int32 $1 }
   | INT64                                       { Const_int64 $1 }
@@ -1856,7 +1856,7 @@ any_longident:
 
 toplevel_directive:
     SHARP ident                 { Ptop_dir($2, Pdir_none) }
-  | SHARP ident STRING          { Ptop_dir($2, Pdir_string $3) }
+  | SHARP ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
   | SHARP ident INT             { Ptop_dir($2, Pdir_int $3) }
   | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
   | SHARP ident FALSE           { Ptop_dir($2, Pdir_bool false) }

parsing/pprintast.ml

@@ -169,7 +169,8 @@ class printer  ()= object(self:'self)
   method longident_loc f x = pp f "%a" self#longident x.txt
   method constant f  = function
     | Const_char i -> pp f "%C"  i 
-    | Const_string i -> pp f "%S" i
+    | Const_string (i, None) -> pp f "%S" i
+    | Const_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
     | Const_int i -> self#paren (i<0) (fun f -> pp f "%d") f i
     | Const_float  i -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i 
     | Const_int32 i -> self#paren (i<0l) (fun f -> pp f "%ldl") f i

parsing/printast.ml

@@ -53,7 +53,9 @@ let fmt_constant f x =
   match x with
   | Const_int (i) -> fprintf f "Const_int %d" i;
   | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
-  | Const_string (s) -> fprintf f "Const_string %S" s;
+  | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
+  | Const_string (s, Some delim) ->
+      fprintf f "Const_string (%S,Some %S)" s delim;
   | Const_float (s) -> fprintf f "Const_float %s" s;
   | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
   | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;

tools/dumpobj.ml

@@ -82,7 +82,7 @@ let print_float f =
 let rec print_struct_const = function
     Const_base(Const_int i) -> printf "%d" i
   | Const_base(Const_float f) -> print_float f
-  | Const_base(Const_string s) -> printf "%S" s
+  | Const_base(Const_string (s, _)) -> printf "%S" s
   | Const_immstring s -> printf "%S" s
   | Const_base(Const_char c) -> printf "%C" c
   | Const_base(Const_int32 i) -> printf "%ldl" i

typing/parmatch.ml

@@ -57,6 +57,8 @@ let const_compare x y =
   match x,y with
   | Const_float f1, Const_float f2 ->
       Pervasives.compare (float_of_string f1) (float_of_string f2)
+  | Const_string (s1, _), Const_string (s2, _) ->
+      Pervasives.compare s1 s2
   | _, _ -> Pervasives.compare x y
 
 let records_args l1 l2 =
@@ -175,7 +177,7 @@ let is_cons tag v  = match get_constr_name tag v.pat_type v.pat_env with
 let pretty_const c = match c with
 | Const_int i -> Printf.sprintf "%d" i
 | Const_char c -> Printf.sprintf "%C" c
-| Const_string s -> Printf.sprintf "%S" s
+| Const_string (s, _) -> Printf.sprintf "%S" s
 | Const_float f -> Printf.sprintf "%s" f
 | Const_int32 i -> Printf.sprintf "%ldl" i
 | Const_int64 i -> Printf.sprintf "%LdL" i
@@ -904,9 +906,9 @@ let build_other ext env =  match env with
       0n Nativeint.succ p env
 | ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
     build_other_constant
-      (function Tpat_constant(Const_string s) -> String.length s
+      (function Tpat_constant(Const_string (s, _)) -> String.length s
               | _ -> assert false)
-      (function i -> Tpat_constant(Const_string(String.make i '*')))
+      (function i -> Tpat_constant(Const_string(String.make i '*', None)))
       0 succ p env
 | ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
     build_other_constant

typing/printtyped.ml

@@ -56,7 +56,9 @@ let fmt_constant f x =
   match x with
   | Const_int (i) -> fprintf f "Const_int %d" i;
   | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
-  | Const_string (s) -> fprintf f "Const_string %S" s;
+  | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
+  | Const_string (s, Some delim) ->
+      fprintf f "Const_string (%S,Some %S)" s delim;
   | Const_float (s) -> fprintf f "Const_float %s" s;
   | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
   | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;

typing/typecore.ml

@@ -1856,7 +1856,7 @@ and type_expect_ ?in_function env sexp ty_expected =
           exp_attributes = sexp.pexp_attributes;
           exp_env = env }
       end
-  | Pexp_constant(Const_string s as cst) ->
+  | Pexp_constant(Const_string (s, _) as cst) ->
       rue {
         exp_desc = Texp_constant cst;
         exp_loc = loc; exp_extra = [];