Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Support for quoted strings. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13450 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-03-26 11:17:17 +00:00
parent 422b75d398
commit 6bfcb1da5b
21 changed files with 120 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
asmcomp/cmmgen.ml
View File

@ -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;

2
bytecomp/matching.ml
View File

@ -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)]))])])

2
bytecomp/printlambda.ml
View File

@ -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

4
bytecomp/symtable.ml
View File

@ -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

5
bytecomp/translcore.ml
View File

@ -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 *)

6
bytecomp/translmod.ml
View File

@ -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)

2
bytecomp/translobj.ml
View File

@ -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 =

4
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -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 []))))

4
camlp4/boot/Camlp4.ml
View File

@ -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))) ->

29
experimental/frisch/extension_points.txt
View File

@ -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

12
ocamldoc/.depend
View File

@ -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 \
odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
../parsing/syntaxerr.cmi ../driver/pparse.cmi ../parsing/parse.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 \
odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
../parsing/syntaxerr.cmx ../driver/pparse.cmx ../parsing/parse.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

2
parsing/ast_mapper.ml
View File

@ -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

2
parsing/asttypes.mli
View File

@ -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

46
parsing/lexer.mll
View File

@ -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 s = Lexing.lexeme lexbuf in
let store_string s =
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 }

10
parsing/parser.mly
View File

@ -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 primitive_declaration { $1 :: $2 }
STRING { [fst $1] }
| 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) }

3
parsing/pprintast.ml
View File

@ -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

4
parsing/printast.ml
View File

@ -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;

2
tools/dumpobj.ml
View File

@ -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

8
typing/parmatch.ml
View File

@ -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

4
typing/printtyped.ml
View File

@ -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;

2
typing/typecore.ml
View File

@ -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 = [];