Commit 228c5134 authored by gerd's avatar gerd

Initial revision.


git-svn-id: https://godirepo.camlcity.org/svn/lib-xstrp4/trunk@1 56444827-45db-0310-81c6-95464f7ca4c4
parents
version = "0.1"
requires = ""
archive(camlp4) = "xstrp4.cma"
# make all: make bytecode archive
# make install: install bytecode archive
# make uninstall: uninstall package
# make clean: remove intermediate files
# make distclean: remove any superflous files
# make release: cleanup, create archive, tag CVS module
# (for developers)
#----------------------------------------------------------------------
# specific rules for this package:
OBJECTS = xstrp4_here_types.cmo xstrp4_here_lexer.cmo xstrp4_here.cmo
ARCHIVE = xstrp4.cma
NAME = xstrp4
REQUIRES = camlp4
all: $(ARCHIVE)
$(ARCHIVE): $(OBJECTS)
$(OCAMLC) -a -o $(ARCHIVE) $(OBJECTS)
sample: sample.ml xstrp4.cma sample.file
ocamlc \
-pp 'camlp4 $(ROPTIONS) pa_o.cmo ./xstrp4.cma pr_dump.cmo' \
sample.ml \
-o sample
view.sample:
camlp4 $(ROPTIONS) pa_o.cmo ./xstrp4.cma pr_o.cmo sample.ml
#----------------------------------------------------------------------
# general rules:
OPTIONS =
CAMLP4 = camlp4 $(ROPTIONS) pa_o.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo
OCAMLC = ocamlc $(OPTIONS) $(ROPTIONS) -pp '$(CAMLP4)'
OCAMLOPT = ocamlopt $(OPTIONS) $(ROPTIONS)
OCAMLDEP = ocamldep $(OPTIONS)
OCAMLFIND = ocamlfind
#depend: *.ml *.mli
# $(OCAMLDEP) *.ml *.mli >depend
*.mli:
depend.pkg: Makefile
$(OCAMLFIND) use -p ROPTIONS= $(REQUIRES) >depend.pkg
.PHONY: install
install: all
$(OCAMLFIND) install $(NAME) *.cmi *.cma META
.PHONY: uninstall
uninstall:
$(OCAMLFIND) remove $(NAME)
.PHONY: clean
clean:
rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa
.PHONY: distclean
distclean: clean
rm -f *~ depend depend.pkg
RELEASE: META
awk '/version/ { print substr($$3,2,length($$3)-2) }' META >RELEASE
.PHONY: dist
dist: RELEASE
r=`head -1 RELEASE`; cd ..; gtar czf $(NAME)-$$r.tar.gz --exclude='*/CVS*' --exclude="*/depend.pkg" --exclude="*/depend" $(NAME)
.PHONY: tag-release
tag-release: RELEASE
r=`head -1 RELEASE | sed -e s/\\\./-/g`; cd ..; cvs tag -F $(NAME)-$$r $(NAME)
.PHONY: release
release: distclean
$(MAKE) tag-release
$(MAKE) dist
.SUFFIXES: .cmo .cmi .cmx .ml .mli .mll
.ml.cmx:
$(OCAMLOPT) -c $<
.ml.cmo:
$(OCAMLC) -c $<
.mli.cmi:
$(OCAMLC) -c $<
.mll.ml:
ocamllex $<
xstrp4_here_lexer.cmo: xstrp4_here_types.cmo xstrp4_here_types.cmi
xstrp4_here_lexer.cmi: xstrp4_here_types.cmi
xstrp4_here.cmo: xstrp4_here_lexer.cmo xstrp4_here_lexer.cmi
xstrp4_here.cmi: xstrp4_here_lexer.cmi
#include depend
include depend.pkg
(* This is an example how to use the new syntactic elements: *)
(**********************************************************************)
(* interpolate *)
(**********************************************************************)
(* interpolate "string":
* In the string literal brace expansion is performed. The following
* notations are allowed:
* $name expands to the value of the string variable 'name'
* $Module.name expands to the value of the string variable 'name'
* of 'Module'
* ${name} same as $name
* ${Module.name} same as $Module.name
* ${name,%format} expands to the value of the variable 'name' which
* has been converted to a string using "%format".
* The format string may be anything allowed in printf.
* ${Module.name,%format} works,too
* \$ A dollar character
* \<newline> Expands to the empty string
* All backslash sequences of normal string constants are allowed, too.
*
* NOTE: For non-string variables a format specification is required;
* otherwise type checking is impossible.
*)
let s = "The number" in
let f = 3.14 in
let i = 42 in
print_string interpolate "$s ${f,%f} is not ${i,%d}\n";;
(**********************************************************************)
(* interpolate file *)
(**********************************************************************)
(* interpolate file "filename":
* expands to the contents of the file; brace expansion is performed
* (see above).
* 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.
*)
let s = "The number" in
let f = 3.14 in
let i = 42 in
print_string interpolate file "sample.file";;
(**********************************************************************)
(* <:here< quotations>> *)
(**********************************************************************)
(* It is also possible to use the 'here' quotation which does brace
* expansion on its argument. This is sometimes easier to write because
* the double quotes need no escaping. Of course, $ and \ characters
* must still be escaped.
* Only \$, \<newline>, \>, and \\ are allowed as backslash sequences.
*)
let s = "The number" in
let f = 3.14 in
let i = 42 in
print_string <:here<\
The interpolation example was:
print_string interpolate "\$s \${f,%f} is not \${i,%d}\n";;
-- where s was replaced by "$s", f by "${f,%f}", and i by "${i,%d}".
>>
(* $Id: xstrp4_here.ml,v 1.1 1999/07/18 16:42:38 gerd Exp $
* ----------------------------------------------------------------------
*
*)
open Xstrp4_here_types
open Pcaml
let interpolated_expr s =
let rec parse_here_expr lexbuf =
let tok = Xstrp4_here_lexer.token lexbuf in
match tok with
Textend -> []
| x -> x :: parse_here_expr lexbuf
in
let loc = (0, String.length s) in
let buf = Lexing.from_string s in
let toklist = parse_here_expr buf in
let toklist_ast =
List.map
(function
Literal s -> <:expr< $str:s$ >>
| Variable (sl,fmt,pos1,pos2) ->
let rec translate_id sl =
let loc = (pos1,pos2) in
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
result_ast
;;
let here_expr s =
let result_ast = interpolated_expr s in
let loc = (0, String.length s) in
<:expr< $anti:result_ast$ >>
;;
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 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 here_pat s =
failwith "<<:here< >> documents not allowed in patterns"
;;
EXTEND
expr: AFTER "simple"
[[ "interpolate"; "file"; s = STRING -> interpolated_file s
| "interpolate"; s = STRING -> interpolated_expr s ]];
END
;;
Quotation.add
"here"
(Quotation.ExAst(here_expr, here_pat))
;;
(* ======================================================================
* History:
*
* $Log: xstrp4_here.ml,v $
* Revision 1.1 1999/07/18 16:42:38 gerd
* Initial revision.
*
*
*)
(* $Id: xstrp4_here_lexer.mll,v 1.1 1999/07/18 16:42:39 gerd Exp $
* ----------------------------------------------------------------------
*
*)
{
open Xstrp4_here_types
type val_id = LC of string | UC of string | End_of_id
let rec parse_val_id f buf =
let id = f buf in
match id with
UC s -> s :: parse_val_id f buf
| LC s -> [s]
| End_of_id -> []
}
let ucletter = [ 'A' - 'Z' ]
let lcletter = [ 'a' - 'z' '_' ]
let acletter = ucletter | lcletter
let format = '%'
[ '0' '-' ' ' ]* (* no more modifiers are supported by Ocaml *)
['0'-'9']*
( '.' ['0'-'9']* )?
[ 'd' 'i' 'u' 'x' 'X' 's' 'c' 'f' 'e' 'E' 'g' 'G' 'b' 'a' 't' ]
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
Variable (parse_val_id value_identifier buf,
"%s",
Lexing.lexeme_start lexbuf+1,
Lexing.lexeme_end lexbuf)
}
| '$' '{' ( ucletter acletter* '.' )* lcletter acletter*
( ',' format )?
'}'
{ let s = Lexing.lexeme lexbuf in
let k_close = String.index s '}' in
let k_percent = try String.index s '%' with Not_found -> (-1) in
let buf = Lexing.from_string (String.sub s 2 (k_close - 1)) in
let fmt =
if k_percent >= 0 then
String.sub s k_percent (String.length s - k_percent - 1)
else
"%s"
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))
}
| '$'
{ failwith "Bad $ expander" }
| '\\' '\n'
{ Literal "" }
| '\\' '$'
{ Literal "$" }
| '\\' _
{ Literal (Lexing.lexeme lexbuf) }
| [^ '$' '\\']+
{ Literal (Lexing.lexeme lexbuf) }
| eof
{ Textend }
| _
{ Literal (Lexing.lexeme lexbuf) }
and value_identifier = parse
ucletter acletter* '.'
{ let s = Lexing.lexeme lexbuf in
UC (String.sub s 0 (String.length s - 1))
}
| lcletter acletter*
{ LC(Lexing.lexeme lexbuf) }
| eof
{ End_of_id }
(* ======================================================================
* History:
*
* $Log: xstrp4_here_lexer.mll,v $
* Revision 1.1 1999/07/18 16:42:39 gerd
* Initial revision.
*
*
*)
(* $Id: xstrp4_here_types.ml,v 1.1 1999/07/18 16:42:39 gerd Exp $
* ----------------------------------------------------------------------
*
*)
type here_clause =
Literal of string
| Variable of (string list * string * int * int)
(* [ M1; M2; ...; value ],f,pos1,pos2
* <==> M1.M2. ... .value with format f from position pos1 to pos2
*)
| Textend
;;
(* ======================================================================
* History:
*
* $Log: xstrp4_here_types.ml,v $
* Revision 1.1 1999/07/18 16:42:39 gerd
* Initial revision.
*
*
*)
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