Commit 1a2faa50 authored by Pietro Abate's avatar Pietro Abate

[r2002-10-29 18:49:26 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-29 18:49:26+00:00
parent 13f74890
DEBUG = -g
OCAMLC = ocamlc
DEBUG =
# -g
PACKAGES = pxp-engine,pxp-lex-iso88591,camlp4,num
OCAMLC = ocamlfind ocamlc -package $(PACKAGES)
OCAMLOPT = ocamlfind ocamlopt -package $(PACKAGES)
PARSER = parser/lexer.cmo parser/location.cmo parser/ast.cmo parser/parser.cmo
......@@ -29,39 +32,38 @@ INCLUDES = -I +camlp4 -I parser -I types -I runtime -I typing
SYNTAX_PARSER = -pp 'camlp4o pa_extend.cmo'
all.cma: $(OBJECTS)
$(OCAMLC) $(DEBUG) -o all.cma -I +camlp4 gramlib.cma nums.cma -a $(OBJECTS)
$(OCAMLC) $(DEBUG) -o all.cma -linkpkg gramlib.cma -a $(OBJECTS)
all.cmxa: $(XOBJECTS)
ocamlopt -a -o all.cmxa $(XOBJECTS)
$(OCAMLOPT) -a -o all.cmxa $(XOBJECTS)
cduce: all.cma $(DRIVER)
$(OCAMLC) $(DEBUG) -o cduce all.cma $(DRIVER)
cduce: $(OBJECTS) $(DRIVER)
$(OCAMLC) $(DEBUG) -linkpkg -o cduce gramlib.cma $(OBJECTS) $(DRIVER)
cduce.opt: all.cmxa $(XDRIVER)
ocamlopt -o cduce.opt -I +camlp4 gramlib.cmxa nums.cmxa all.cmxa $(XDRIVER)
$(OCAMLOPT) -linkpkg -o cduce.opt gramlib.cmxa $(XOBJECTS) $(XDRIVER)
compute_depend:
@echo "Computing dependencies ..."
ocamldep $(INCLUDES) $(SYNTAX_PARSER) $(DEPEND) > depend
run_top: all.cma
ledit ocaml $(INCLUDES) all.cma
ledit ocaml $(INCLUDES) `ocamlfind use pxp` all.cma
clean:
(cd parser; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
(cd types; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
(cd typing; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
(cd driver; rm -f *.cmi *.cmo *.cma *.cmx *.o *~)
rm -f *.cmi *.cmo *.cma *.cmx *.o *~
rm -f cduce
for i in $(DIRS); do \
(cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *~); \
done
rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~
rm -f cduce cduce.opt
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.ml.cmo:
$(OCAMLC) $(DEBUG) -c $(SYNTAX_PARSER) $(INCLUDES) $<
.ml.cmx:
ocamlopt -c $(SYNTAX_PARSER) $(INCLUDES) $<
$(OCAMLOPT) -c $(SYNTAX_PARSER) $(INCLUDES) $<
.mli.cmi:
$(OCAMLC) $(DEBUG) -c $(INCLUDES) $<
......
......@@ -61,7 +61,12 @@ types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
types/sortedMap.cmi
runtime/value.cmi: types/patterns.cmi typing/typed.cmo
runtime/value.cmi: types/chars.cmi types/patterns.cmi types/sortedMap.cmi \
typing/typed.cmo types/types.cmi
runtime/load_xml.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
types/types.cmi runtime/value.cmi
runtime/load_xml.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
types/types.cmx runtime/value.cmx
runtime/value.cmo: types/chars.cmi types/patterns.cmi types/sequence.cmi \
types/sortedMap.cmi typing/typed.cmo types/types.cmi runtime/value.cmi
runtime/value.cmx: types/chars.cmx types/patterns.cmx types/sequence.cmx \
......
......@@ -82,6 +82,7 @@ EXTEND
|
[ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
| LIDENT "load_xml"; e = expr -> mk loc (Op ("load_xml",[e]))
| e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
]
......
......@@ -7,7 +7,6 @@ type t =
| Atom of Types.atom
| Integer of Big_int.big_int
| Char of Chars.Unichar.t
| String of int * string * t (* position in string *)
| Fun of abstr
and env = t Env.t
and abstr = {
......@@ -41,7 +40,6 @@ let rec print ppf v =
| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Char c -> Chars.Unichar.print ppf c
| Fun c -> Format.fprintf ppf "<fun>"
| String (i,s,y) -> Format.fprintf ppf "<str:%S;%i>%a" s i print y
and print_quoted_str ppf = function
| Pair (Char c, y) ->
Chars.Unichar.print_in_string ppf c;
......@@ -76,6 +74,91 @@ and print_field ppf (l,v) =
Format.fprintf ppf "%s=%a" (Types.label_name l) print v
(* Loading XML documents *)
(*TODO: close the file ! *)
module Load_xml =
struct
open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
let run s =
let config = { default_config with
store_element_positions = false;
drop_ignorable_whitespace = true
}
in
let mgr = create_entity_manager config (from_file s) in
let next_event =
create_pull_parser config (`Entry_document[]) mgr in
let curr = ref E_end_of_stream in
let get () =
match next_event () with
| Some x -> curr := x
| None -> () in
let string s q =
let rec check_ws i = (i < 0) ||
(match s.[i] with
| ' ' | '\t' | '\n' | '\r' -> check_ws (i - 1)
| _ -> false) in
if check_ws (String.length s - 1) then q
else
let rec aux i accu =
if i < 0 then accu
else aux (i - 1) (Pair
(Char (Chars.Unichar.from_char s.[i]),
accu))
in
aux (String.length s - 1) q in
let nil = Atom Sequence.nil_atom in
let rec parse_elt name att =
let att = List.map (fun (l,v) -> Types.label l, string v nil) att in
let att = SortedMap.from_list (fun _ _ -> assert false) att in
let child = parse_seq () in
let elt = Pair
(Atom (Types.mk_atom name),
Pair (Record att, child)
) in
(match !curr with
| E_end_tag (_,_) -> get ()
| _ -> failwith "Expect end_tag");
elt
and parse_seq () =
match !curr with
| E_start_tag (name,att,_) ->
get ();
let e1 = parse_elt name att in
let rest = parse_seq () in
Pair (e1, rest)
| E_char_data data ->
get ();
let rest = parse_seq () in
string data rest
| E_end_tag (_,_) ->
nil
| _ -> failwith "Expect start_tag, char_data, or end_tag"
and parse_doc () =
match !curr with
| E_start_tag (name,att,_) -> get (); parse_elt name att
| _ -> get (); parse_doc ()
in
get ();
parse_doc ()
end
(* Running dispatchers *)
let const = function
......@@ -141,8 +224,6 @@ and run_disp_kind actions v = match v with
| Fun f ->
run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t)
actions.Patterns.Compile.basic
| String (i,s,y) ->
failwith "Dispatch on string not yet implemented"
and run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
......@@ -219,6 +300,7 @@ let rec eval env e0 =
| Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
| Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
| Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
| Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.DebugTyper t -> failwith "Evaluating a ! expression"
| _ -> failwith "Unknown expression"
......@@ -240,7 +322,6 @@ and eval_branches env brs arg =
and eval_map env brs = function
| Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
| String (i,s,y) -> failwith "map on string not implemented"
| q -> q
and eval_flatten = function
......@@ -249,7 +330,6 @@ and eval_flatten = function
and eval_concat l1 l2 = match l1 with
| Pair (x,y) -> Pair (x, eval_concat y l2)
| String (i,s,y) -> String(i,s, eval_concat y l2)
| q -> l2
and eval_dot l = function
......@@ -272,3 +352,14 @@ and eval_div x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
| _ -> assert false
and eval_load_xml e =
Load_xml.run (get_string e)
and get_string e =
let rec compute_len accu = function
| Pair (_,y) -> compute_len (accu + 1) y
| _ -> accu in
let rec fill pos s = function
| Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
| _ -> s in
fill 0 (String.create (compute_len 0 e)) e
type t
type env
type t =
| Pair of t * t
| Record of (Types.label,t) SortedMap.t
| Atom of Types.atom
| Integer of Big_int.big_int
| Char of Chars.Unichar.t
| Fun of abstr
and abstr
and env
val empty_env : env
val print: Format.formatter -> t -> unit
......
......@@ -13,6 +13,10 @@ module Unichar = struct
let to_int c = c
let to_char c =
if (c > 255) then failwith "to_char: code-point > 255";
Char.chr c
let print ppf c =
if (c < 128)
then Format.fprintf ppf "%C" (Char.chr c)
......
......@@ -3,6 +3,7 @@ module Unichar : sig
val from_int: int -> t
val from_char: char -> t
val to_int: t -> int
val to_char: t -> char
val print : Format.formatter -> t -> unit
val print_in_string : Format.formatter -> t -> unit
......
......@@ -46,7 +46,7 @@ let any = Types.descr any_node
let seqseq = Types.descr (star_node any_node)
let star t = Types.descr (star_node (Types.cons t))
let string = star (Types.Char.any)
let approx t =
let memo = H.create 13 in
......
......@@ -2,6 +2,7 @@ val nil_type: Types.descr
val nil_atom: Types.atom
val any: Types.descr
val seqseq: Types.descr
val string: Types.descr
val concat: Types.descr -> Types.descr -> Types.descr
val flatten: Types.descr -> Types.descr
......
......@@ -833,6 +833,7 @@ end
module Char = struct
let has_char d c = Chars.contains c d.chars
let any = { empty with chars = Chars.any }
end
(*
......
......@@ -157,6 +157,7 @@ end
module Char : sig
val has_char : descr -> Chars.Unichar.t -> bool
val any : descr
end
val normalize : descr -> descr
......
......@@ -630,6 +630,10 @@ and type_op loc op args =
check loc1 t1 Sequence.seqseq
"The argument of flatten must be a sequence of sequences";
Sequence.flatten t1
| "load_xml", [loc1,t1] ->
check loc1 t1 Sequence.string
"The argument of load_xml must be a string (filename)";
Types.any
| _ -> assert false
and type_int_binop f loc1 t1 loc2 t2 =
......
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