Commit be3903fe authored by gerd's avatar gerd

Port to camlp4 3.10


git-svn-id: https://godirepo.camlcity.org/svn/lib-xstrp4/trunk@29 56444827-45db-0310-81c6-95464f7ca4c4
parent 0e86c43d
......@@ -175,7 +175,7 @@ if camlp4; then
if camlp4 -loaded-modules >/dev/null 2>/dev/null; then
echo "3.10 style"
camlp4_style="310"
camlp4_opts="-package camlp4 -syntax camlp4o -ppopt pa_extend.cmo -ppopt q_MLast.cmo -ppopt -loc -ppopt loc"
camlp4_opts="-package camlp4 -syntax camlp4o -ppopt pa_extend.cmo -ppopt q_MLast.cmo"
else
echo "3.09 style"
camlp4_style="309"
......
(* $Id$
* ----------------------------------------------------------------------
*
*)
open Xstrp4_here_types
open Camlp4.PreCast
open Syntax
let camlp4loc (loc1,loc2) =
Loc.merge
(Loc.of_lexing_position loc1)
(Loc.of_lexing_position loc2)
let interpolated_expr lexbuf _loc =
(* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
*)
(*
Printf.eprintf "All at line %d bol %d off %d\n%!"
(Loc.start_line _loc) (Loc.start_bol _loc) (Loc.start_off _loc);
*)
let rec parse_here_expr() =
let tok = Xstrp4_here_lexer.token lexbuf in
match tok with
Textend -> []
| x -> x :: parse_here_expr ()
in
let rec normalize_literals =
(* - Concat adjacent literals
* - Remove empty literals
*)
function
[] ->
[]
| Literal("",_) :: tl ->
normalize_literals tl
| Literal(s1,(p1,_)) :: (Literal(s2,(_,p2))) :: tl ->
normalize_literals((Literal(s1^s2,(p1,p2)))::tl)
| hd :: tl ->
hd :: (normalize_literals tl)
in
let fix_position p =
{ Lexing.pos_fname = Loc.file_name _loc;
Lexing.pos_lnum = p.Lexing.pos_lnum + Loc.start_line _loc - 1;
Lexing.pos_cnum = p.Lexing.pos_cnum + Loc.start_off _loc;
Lexing.pos_bol = p.Lexing.pos_bol + Loc.start_bol _loc;
}
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 _loc = camlp4loc loc in
*)
let toklist_ast =
List.map
(function
Literal(s,lexloc) ->
let _loc = camlp4loc lexloc in
<:expr< $str:s$ >>
| Variable (sl,fmt,lexloc) ->
let _loc = camlp4loc lexloc in
let rec translate_id sl =
match sl with
s :: ((s' :: _) as sl') ->
let moduleid_ast = <:expr< $uid:s$ >> in
let valueid_ast = translate_id sl' in
<:expr< $moduleid_ast$ . $valueid_ast$ >>
| [s] ->
(*
Printf.eprintf "Var at line %d bol %d off %d\n%!"
(Loc.start_line _loc) (Loc.start_bol _loc) (Loc.start_off _loc);
*)
<:expr< $lid:s$ >>
| _ ->
failwith "Xstrp4.here_expr"
in
let node = match fmt with
"%s" -> translate_id sl
| ("%d"|"%i") ->
let id = translate_id sl in
<:expr< $lid:"string_of_int"$ $id$ >>
| _ ->
let id = translate_id sl in
<:expr< ( ( $uid:"Printf"$ . $lid:"sprintf"$ )
$str:fmt$
)
$id$ >>
in
node
| Textend -> failwith "Xstrp4.here_expr")
toklist
in
let rec mk_list_ast l =
match l with
[] -> <:expr@here< [] >>
| x :: l' ->
let ast_l' = mk_list_ast l' in
<:expr@here< [ $x$ :: $ast_l'$ ] >>
in
let string_mod_ast = <:expr@here< $uid:"String"$ >> in
let concat_val_ast = <:expr@here< $lid:"concat"$ >> in
let string_concat_ast = <:expr@here< $string_mod_ast$ . $concat_val_ast$ >> in
let concat_ast = <:expr@here< $string_concat_ast$ $str:""$ >> in
let list_ast = mk_list_ast toklist_ast in
let result_ast = <:expr@here< $concat_ast$ $list_ast$ >> in
match toklist with
[] ->
<:expr@here< $str:""$ >>
| [Literal s] ->
List.hd toklist_ast (* = <:expr< $str:s$ >> *)
| _ ->
(* General case: *)
result_ast
;;
let here_expr _loc _loc_name s =
let lexbuf = Lexing.from_string s in
interpolated_expr lexbuf _loc
;;
let interpolated_file filename _loc =
let pathname =
if Filename.is_implicit filename then
Filename.concat (Filename.dirname (Loc.file_name _loc)) filename
else
filename
in
let f = open_in pathname in
let lexbuf = Lexing.from_channel f in
let _loc =
Loc.of_tuple
(pathname, 1, 0, 0, 1, 0, 0, false) in
interpolated_expr lexbuf _loc
;;
let included_file filename _loc =
let pathname =
if Filename.is_implicit filename then
Filename.concat (Filename.dirname (Loc.file_name _loc)) filename
else
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;
<:expr< $str:s$ >>
;;
let interpolation = Gram.Entry.mk "interpolation";;
EXTEND Gram
interpolation:
[[ s = STRING ->
let lexbuf = Lexing.from_string s in
interpolated_expr lexbuf _loc
]];
expr: AFTER "simple"
[[ "interpolate"; "file"; s = STRING -> interpolated_file s _loc
| "interpolate"; expr = interpolation -> expr
| "include_file"; s = STRING -> included_file s _loc
]];
END
;;
Quotation.add
"here"
Syntax.Quotation.DynAst.expr_tag
here_expr
;;
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