Commit b9d9fd15 authored by gerd's avatar gerd

Update for O'Caml 3.08


git-svn-id: https://godirepo.camlcity.org/svn/lib-xstrp4/trunk@23 56444827-45db-0310-81c6-95464f7ca4c4
parent 346c2cf2
This is a camlp4 extension that expands brace expansions like a shell
does. See sample.ml for examples.
You need camlp4 to build the extension.
This version works only for O'Caml 3.08.
You need findlib to 'make install'; AT LEAST VERSION 0.4 OF FINDLIB!
......@@ -25,6 +25,11 @@ See sample.ml for explanations. See the Makefile how to compile sample.ml.
CHANGES:
Changed in version 1.5:
Fixes for O'Caml 3.08. There is still a known problem:
Locations in error messages may be wrong for <:here< ... >>.
This seems to be a bug in camlp4.
Changed in version 1.4:
Better code is generated. (Suggested by Mike Potanin.)
......
......@@ -49,20 +49,24 @@ let i = 42 in
print_string interpolate file "sample.file";;
(**********************************************************************)
(* include file *)
(* include_file *)
(**********************************************************************)
(* include file "filename":
(* include_file "filename":
* expands to the contents of the file but _no_ brace expansion is performed.
* If "filename" is written without "/", it is always searched in the
* same directory as the source file being compiled. Otherwise "filename"
* is interpreted as relative or absolute path name.
*
* IMPORTANT NOTE: Of course, the file is only read during compile time.
*
* Note: Up to xstrp4-1.4, this construction used the notation
* "include file". In xstrp4-1.5, it was changed to "include_file"
* to avoid ambiguities with O'Caml's built-in "include" directive.
*)
print_string "sample.file: ";
print_string include file "sample.file";;
print_string include_file "sample.file";;
(**********************************************************************)
(* <:here< quotations>> *)
......
......@@ -7,12 +7,19 @@ open Xstrp4_here_types
open Pcaml
let interpolated_expr s =
let rec parse_here_expr lexbuf =
let interpolated_expr ?(fname="")
?(lnum_offset=0) ?(cnum_offset=0) ?(bol_offset=0)
lexbuf =
(* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
* The locations in this tree are relative to [s]! Before inserting the tree
* into the surrounding tree an antiquotation node should be created.
*)
let rec parse_here_expr() =
let tok = Xstrp4_here_lexer.token lexbuf in
match tok with
Textend -> []
| x -> x :: parse_here_expr lexbuf
| x -> x :: parse_here_expr ()
in
let rec normalize_literals =
......@@ -22,26 +29,57 @@ let interpolated_expr s =
function
[] ->
[]
| (Literal "") :: tl ->
| Literal("",_) :: tl ->
normalize_literals tl
| (Literal s1) :: (Literal s2) :: tl ->
normalize_literals((Literal(s1^s2))::tl)
| Literal(s1,(p1,_)) :: (Literal(s2,(_,p2))) :: tl ->
normalize_literals((Literal(s1^s2,(p1,p2)))::tl)
| hd :: tl ->
hd :: (normalize_literals tl)
in
let loc = (0, String.length s) in
let fix_position p =
{p with
Lexing.pos_fname = fname;
Lexing.pos_lnum = p.Lexing.pos_lnum + lnum_offset;
Lexing.pos_cnum = p.Lexing.pos_cnum + cnum_offset + 1;
Lexing.pos_bol = p.Lexing.pos_bol + bol_offset;
}
in
let buf = Lexing.from_string s in
let toklist = normalize_literals (parse_here_expr buf) in
let fix_positions =
function
Literal(s, (p1, p2)) ->
Literal(s, (fix_position p1, fix_position p2))
| Variable(sl, fmt, (p1, p2)) ->
Variable(sl, fmt, (fix_position p1, fix_position p2))
| other ->
other
in
let toklist =
List.map fix_positions (normalize_literals (parse_here_expr ())) in
let loc =
let start_pos =
match toklist with
Literal(_,(l1,_)) :: _ -> l1
| Variable(_,_,(l1,_)) :: _ -> l1
| _ -> Lexing.dummy_pos
in
let end_pos =
match List.rev toklist with
Literal(_,(_,l2)) :: _ -> l2
| Variable(_,_,(_,l2)) :: _ -> l2
| _ -> Lexing.dummy_pos
in
(start_pos, end_pos)
in
let toklist_ast =
List.map
(function
Literal s -> <:expr< $str:s$ >>
| Variable (sl,fmt,pos1,pos2) ->
Literal(s,loc) -> <:expr< $str:s$ >>
| Variable (sl,fmt,loc) ->
let rec translate_id sl =
let loc = (pos1,pos2) in
match sl with
s :: ((s' :: _) as sl') ->
let moduleid_ast = <:expr< $uid:s$ >> in
......@@ -96,9 +134,11 @@ let interpolated_expr s =
let here_expr s =
let result_ast = interpolated_expr s in
let loc = (0, String.length s) in
<:expr< $anti:result_ast$ >>
let lexbuf = Lexing.from_string s in
let result_ast = interpolated_expr ~lnum_offset:(-1) lexbuf in
let loc = (Lexing.dummy_pos, Lexing.dummy_pos) in
(* <:expr< $anti:result_ast$ >> *)
result_ast (* For O'Caml 3.08, this creates better error positions! *)
;;
......@@ -110,11 +150,11 @@ let interpolated_file filename =
filename
in
let f = open_in pathname in
let n = in_channel_length f in
let s = String.create n in
really_input f s 0 n;
close_in f;
here_expr s
let lexbuf = Lexing.from_channel f in
let result_ast = interpolated_expr ~fname:pathname lexbuf in
let loc = (Lexing.dummy_pos, Lexing.dummy_pos) in
(* Will be replaced anyway by camlp4 *)
<:expr< $anti:result_ast$ >>
;;
......@@ -130,7 +170,15 @@ let included_file filename =
let s = String.create n in
really_input f s 0 n;
close_in f;
let loc = (0, String.length s) in
let start_p = { Lexing.pos_fname = pathname;
pos_lnum = 1;
pos_bol = 0;
pos_cnum = 0 } in
let end_p = { Lexing.pos_fname = pathname;
pos_lnum = 1;
pos_bol = 0;
pos_cnum = n } in
let loc = (start_p, end_p) in
<:expr< $str:s$ >>
;;
......@@ -140,12 +188,26 @@ let here_pat s =
;;
let interpolation = Grammar.Entry.create Pcaml.gram "interpolation";;
EXTEND
interpolation:
[[ s = STRING ->
let (start_p,_) = loc in
let lexbuf = Lexing.from_string s in
interpolated_expr
~lnum_offset:(start_p.Lexing.pos_lnum - 1)
~cnum_offset:(start_p.Lexing.pos_cnum)
~bol_offset:(start_p.Lexing.pos_bol)
lexbuf
]];
expr: AFTER "simple"
[[ "interpolate"; "file"; s = STRING -> interpolated_file s
| "interpolate"; s = STRING -> interpolated_expr s
| "include"; "file"; s = STRING -> included_file s
| "interpolate"; expr = interpolation -> expr
| "include_file"; s = STRING -> included_file s
]];
END
;;
......
......@@ -32,10 +32,12 @@ rule token = parse
'$' ( ucletter acletter* '.' )* lcletter acletter*
{ let s = Lexing.lexeme lexbuf in
let buf = Lexing.from_string (String.sub s 1 (String.length s - 1)) in
let start_p = Lexing.lexeme_start_p lexbuf in
let end_p = Lexing.lexeme_end_p lexbuf in
Variable (parse_val_id value_identifier buf,
"%s",
Lexing.lexeme_start lexbuf+1,
Lexing.lexeme_end lexbuf)
({ start_p with Lexing.pos_cnum = start_p.Lexing.pos_cnum (* + 1 *) },
end_p))
}
| '$' '{' ( ucletter acletter* '.' )* lcletter acletter*
( ',' format )?
......@@ -50,23 +52,27 @@ rule token = parse
else
"%s"
in
let start_p = Lexing.lexeme_start_p lexbuf in
let end_p = Lexing.lexeme_end_p lexbuf in
let start = Lexing.lexeme_start lexbuf in
Variable (parse_val_id value_identifier buf,
fmt,
start+2,
start+(if k_percent >= 0 then k_percent-1 else k_close))
({ start_p with Lexing.pos_cnum = start_p.Lexing.pos_cnum (* + 2 *) },
{ end_p with Lexing.pos_cnum = end_p.Lexing.pos_cnum (* +
(if k_percent >= 0 then k_percent-1 else k_close) *) })
)
}
| '$'
{ failwith "Bad $ expander" }
| '\\' '\n'
{ Literal "" }
{ Literal("", (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf)) }
| '\\' '$'
{ Literal "$" }
{ Literal("$", (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf)) }
| '\\' [ '0'-'9' ] [ '0'-'9' ] [ '0'-'9' ]
{ Literal (let s = Lexing.lexeme lexbuf in
let n = int_of_string(String.sub s 1 3) in
Printf.sprintf "%c" (Char.chr n)
)
{ let s = Lexing.lexeme lexbuf in
let n = int_of_string(String.sub s 1 3) in
let lit = Printf.sprintf "%c" (Char.chr n) in
Literal(lit, (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf))
}
(*
| '\\' 'o' [ '0'-'7' ] [ '0'-'7' ] [ '0'-'7' ]
......@@ -77,20 +83,26 @@ rule token = parse
}
*)
| '\\' 'x' [ '0'-'9' 'a'-'f' 'A'-'F' ] [ '0'-'9' 'a'-'f' 'A'-'F' ]
{ Literal (let s = Lexing.lexeme lexbuf in
let n = int_of_string("0" ^ String.sub s 1 3) in
Printf.sprintf "%c" (Char.chr n)
)
{ let s = Lexing.lexeme lexbuf in
let n = int_of_string("0" ^ String.sub s 1 3) in
let lit = Printf.sprintf "%c" (Char.chr n) in
Literal(lit, (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf))
}
| '\\' _
{ Literal (Lexing.lexeme lexbuf) }
{ let lit = Lexing.lexeme lexbuf in
Literal(lit, (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf))
}
| [^ '$' '\\']+
{ Literal (Lexing.lexeme lexbuf) }
{ let lit = Lexing.lexeme lexbuf in
Literal(lit, (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf))
}
| eof
{ Textend }
| _
{ Literal (Lexing.lexeme lexbuf) }
{ let lit = Lexing.lexeme lexbuf in
Literal(lit, (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf))
}
and value_identifier = parse
ucletter acletter* '.'
......
......@@ -4,8 +4,8 @@
*)
type here_clause =
Literal of string
| Variable of (string list * string * int * int)
Literal of (string * (Lexing.position * Lexing.position))
| Variable of (string list * string * (Lexing.position * Lexing.position))
(* [ M1; M2; ...; value ],f,pos1,pos2
* <==> M1.M2. ... .value with format f from position pos1 to pos2
*)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment