Commit 0467e756 authored by gerd's avatar gerd

new release (1.8)


git-svn-id: https://godirepo.camlcity.org/svn/lib-xstrp4/trunk@35 56444827-45db-0310-81c6-95464f7ca4c4
parent 1dbc7d2c
......@@ -32,12 +32,6 @@ sample: sample.ml
view.sample: all
camlp4 $(ROPTIONS) pa_o.cmo ./xstrp4.cma pr_o.cmo sample.ml
xstrp4_here.ml: xstrp4_here.ml.$(CAMLP4_STYLE)
rm -f xstrp4_here.ml
ln -s xstrp4_here.ml.$(CAMLP4_STYLE) xstrp4_here.ml
#----------------------------------------------------------------------
# general rules:
......
......@@ -47,7 +47,7 @@ set_defaults () {
ocamlc=`get_path ocamlc`
set_defaults
version="1.7"
version="1.8"
exec_suffix=""
#######################################################################
......@@ -162,6 +162,7 @@ else
echo "not found"
echo "Make sure that ocamlfind is in your PATH, or download findlib"
echo "from www.ocaml-programming.de"
echo "ERROR"
exit 1
fi
......@@ -178,12 +179,15 @@ if camlp4; then
camlp4_opts="-package camlp4 -syntax camlp4o -ppopt pa_extend.cmo -ppopt q_MLast.cmo"
else
echo "3.09 style"
camlp4_style="309"
camlp4_opts="-package camlp4 -syntax camlp4o -ppopt pa_extend.cmo -ppopt q_MLast.cmo -ppopt -loc -ppopt loc"
echo "This is no longer supported. Upgrade to at least O'Caml 3.10"
echo "ERROR"
exit 1
fi
else
echo "not found"
echo "Make sure the camlp4 command is in your PATH"
echo "ERROR"
exit 1
fi
......
(* $Id$
* ----------------------------------------------------------------------
*
*)
open Xstrp4_here_types
open Pcaml
(* Note: Since O'Caml 3.09, the location variable is called "_loc" while
* in earlier versions it was called "loc". Fortunately, 3.09 allows it
* to set the name of the variable with the -loc option.
*)
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 ()
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 =
{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 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,loc) -> <:expr< $str:s$ >>
| Variable (sl,fmt,loc) ->
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] ->
<: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< [] >>
| x :: l' ->
let ast_l' = mk_list_ast l' in
<:expr< [ $x$ :: $ast_l'$ ] >>
in
let string_mod_ast = <:expr< $uid:"String"$ >> in
let concat_val_ast = <:expr< $lid:"concat"$ >> in
let string_concat_ast = <:expr< $string_mod_ast$ . $concat_val_ast$ >> in
let concat_ast = <:expr< $string_concat_ast$ $str:""$ >> in
let list_ast = mk_list_ast toklist_ast in
let result_ast = <:expr< $concat_ast$ $list_ast$ >> in
match toklist with
[] ->
<:expr< $str:""$ >>
| [Literal s] ->
List.hd toklist_ast (* = <:expr< $str:s$ >> *)
| _ ->
(* General case: *)
result_ast
;;
let here_expr s =
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! *)
;;
let interpolated_file filename =
let pathname =
if Filename.is_implicit filename then
Filename.concat (Filename.dirname !input_file) filename
else
filename
in
let f = open_in pathname in
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$ >>
;;
let included_file filename =
let pathname =
if Filename.is_implicit filename then
Filename.concat (Filename.dirname !input_file) 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;
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$ >>
;;
let here_pat s =
failwith "<<:here< >> documents not allowed in patterns"
;;
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"; expr = interpolation -> expr
| "include_file"; s = STRING -> included_file s
]];
END
;;
Quotation.add
"here"
(Quotation.ExAst(here_expr, here_pat))
;;
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