--- /dev/null
+(******************************************************************************)
+(* SXSI : XPath evaluator *)
+(* Kim Nguyen (Kim.Nguyen@nicta.com.au) *)
+(* Copyright NICTA 2008 *)
+(* Distributed under the terms of the LGPL (see LICENCE) *)
+(******************************************************************************)
+open Camlp4.PreCast
+
+module Loc = struct
+ type t = int * int
+
+ let mk _ = (0,0)
+ let ghost = (-1,-1)
+
+ let of_lexing_position _ = assert false
+ let to_ocaml_location _ = assert false
+ let of_ocaml_location _ = assert false
+ let of_lexbuf _ = assert false
+ let of_tuple _ = assert false
+ let to_tuple _ = assert false
+
+ let merge (x1, x2) (y1, y2) = (min x1 y1, max x2 y2)
+ let join (x1, _) = (x1, x1)
+ let move _ _ _ = assert false
+ let shift _ _ = assert false
+ let move_line _ _ = assert false
+ let file_name _ = assert false
+ let start_line _ = assert false
+ let stop_line _ = assert false
+ let start_bol _ = assert false
+ let stop_bol _ = assert false
+ let start_off = fst
+ let stop_off = snd
+ let start_pos _ = assert false
+ let stop_pos _ = assert false
+ let is_ghost _ = assert false
+ let ghostify _ = assert false
+ let set_file_name _ = assert false
+ let strictly_before _ = assert false
+ let make_absolute _ = assert false
+ let print _ = assert false
+ let dump _ = assert false
+ let to_string _ = assert false
+ exception Exc_located of t * exn
+ let raise loc exn =
+ match exn with
+ | Exc_located _ -> raise exn
+ | _ -> raise (Exc_located (loc, exn))
+ let name = ref "_loc"
+end
+
+type token =
+ | TAG of string
+ | STRING of string
+ | INT of int
+ | KWD of string
+ | ATT of string
+ | EOI
+
+module Token = struct
+ open Format
+ module Loc = Loc
+ type t = token
+ type token = t
+
+ let sf = Printf.sprintf
+
+ let to_string =
+ function
+ | TAG s -> sf "TAG <%s>" s
+ | STRING s -> sf "STRING \"%s\"" s
+ | KWD s -> sf "KWD %s" s
+ | INT i -> sf "INT %i" i
+ | ATT s -> sf "ATT %s" s
+ | EOI -> sf "EOI"
+
+ let print ppf x = pp_print_string ppf (to_string x)
+
+ let match_keyword kwd =
+ function
+ | KWD kwd' when kwd = kwd' -> true
+ | _ -> false
+
+ let extract_string =
+ function
+ | KWD s | STRING s | TAG s | ATT s -> s
+ | INT i -> string_of_int i
+ | tok ->
+ invalid_arg ("Cannot extract a string from this token: "^
+ to_string tok)
+
+ module Error = struct
+ type t = string
+ exception E of string
+ let print = pp_print_string
+ let to_string x = x
+ end
+
+ module Filter = struct
+ type token_filter = (t, Loc.t) Camlp4.Sig.stream_filter
+
+ type t =
+ { is_kwd : string -> bool;
+ mutable filter : token_filter }
+
+ let mk is_kwd =
+ { is_kwd = is_kwd;
+ filter = (fun s -> s) }
+
+ let filter x =
+ let f tok loc =
+ let tok' = tok in
+ (tok', loc)
+ in
+ let rec filter =
+ parser
+ | [< '(tok, loc); s >] -> [< ' f tok loc; filter s >]
+ | [< >] -> [< >]
+ in
+ fun strm -> x.filter (filter strm)
+
+ let define_filter x f = x.filter <- f x.filter
+
+ let keyword_added _ _ _ = ()
+ let keyword_removed _ _ = ()
+ end
+
+end
+module Error = Camlp4.Struct.EmptyError
+
+module L = Ulexing
+
+exception Error of int * int * string
+
+let error i j s = raise (Error (i,j,s))
+
+(***********************************************************)
+(* Buffer for string literals *)
+
+let string_buff = Buffer.create 1024
+
+let store_lexeme lexbuf =
+ Buffer.add_string string_buff (Ulexing.utf8_lexeme lexbuf)
+let store_ascii = Buffer.add_char string_buff
+let store_code = Utf8.store string_buff
+let clear_buff () = Buffer.clear string_buff
+let get_stored_string () =
+ let s = Buffer.contents string_buff in
+ clear_buff ();
+ Buffer.clear string_buff;
+ s
+
+(***********************************************************)
+(* Lexer *)
+
+let illegal lexbuf =
+ error
+ (L.lexeme_start lexbuf)
+ (L.lexeme_end lexbuf)
+ "Illegal character"
+
+let return lexbuf tok = (tok, L.loc lexbuf)
+let return_loc i j tok = (tok, (i,j))
+
+let regexp ncname_char =
+ xml_letter | xml_digit | [ '-' '_' ] | xml_combining_char | xml_extender | "\\."
+
+let hexa_digit = function
+ | '0'..'9' as c -> (Char.code c) - (Char.code '0')
+ | 'a'..'f' as c -> (Char.code c) - (Char.code 'a') + 10
+ | 'A'..'F' as c -> (Char.code c) - (Char.code 'A') + 10
+ | _ -> -1
+
+let regexp ncname = ( xml_letter ncname_char* ) | ('_' ncname_char+)
+
+let parse_char lexbuf base i =
+ let s = L.latin1_sub_lexeme lexbuf i (L.lexeme_length lexbuf - i - 1) in
+ let r = ref 0 in
+ for i = 0 to String.length s - 1 do
+ let c = hexa_digit s.[i] in
+ if (c >= base) || (c < 0) then
+ error (L.lexeme_start lexbuf) (L.lexeme_end lexbuf) "invalid digit";
+ r := !r * base + c;
+ done;
+ !r
+
+let rec token = lexer
+ | [' ' '\t' '\n'] -> token lexbuf
+ | "and" | "not" | "or" | "text()" | "node()"
+ | "self" | "descendant" | "child" | "descendant-or-self"
+ | "attribute" | "following-sibling" | "preceding-sibling"
+ | "parent" | "ancestor" | "ancestor-or-self" | "preceding" | "following"
+ | "(" |")" | "," | "::" | "/" | "//" | "[" | "]" | "*" | "." | ".." | "@"
+ -> return lexbuf (KWD (L.utf8_lexeme lexbuf))
+ | ncname -> return lexbuf (TAG(L.utf8_lexeme lexbuf))
+ | '-'? ['0'-'9']+ -> let i = INT (int_of_string(L.utf8_lexeme lexbuf)) in return lexbuf i
+ | '"' | "'" ->
+ let start = L.lexeme_start lexbuf in
+ let double_quote = L.latin1_lexeme_char lexbuf 0 = '"' in
+ string (L.lexeme_start lexbuf) double_quote lexbuf;
+ let s = get_stored_string () in
+ return_loc start (L.lexeme_end lexbuf) (STRING s)
+
+ | eof -> return lexbuf EOI
+ | _ -> illegal lexbuf
+
+and string start double = lexer
+ | '"' | "'" ->
+ let d = L.latin1_lexeme_char lexbuf 0 = '"' in
+ if d != double then (store_lexeme lexbuf; string start double lexbuf)
+ | '\\' ['\\' '"' '\''] ->
+ store_ascii (L.latin1_lexeme_char lexbuf 1);
+ string start double lexbuf
+ | "\\n" ->
+ store_ascii '\n'; string start double lexbuf
+ | "\\t" ->
+ store_ascii '\t'; string start double lexbuf
+ | "\\r" ->
+ store_ascii '\r'; string start double lexbuf
+ | '\\' ['0'-'9']+ ';' ->
+ store_code (parse_char lexbuf 10 1);
+ string start double lexbuf
+ | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F']+ ';' ->
+ store_code (parse_char lexbuf 16 2);
+ string start double lexbuf
+ | '\\' ->
+ illegal lexbuf;
+ | eof ->
+ error start (start+1) "Unterminated string"
+ | _ ->
+ store_lexeme lexbuf;
+ string start double lexbuf
+
+
+
+(***********************************************************)
+
+let enc = ref L.Latin1
+let lexbuf = ref None
+let last_tok = ref (KWD "DUMMY")
+
+let raise_clean e =
+ clear_buff ();
+ raise e
+
+let mk () _loc cs =
+ let lb = L.from_var_enc_stream enc cs in
+ lexbuf := Some lb;
+ let next _ =
+ let tok, loc =
+ try token lb
+ with
+ | Ulexing.Error ->
+ raise_clean (Error (Ulexing.lexeme_end lb, Ulexing.lexeme_end lb,
+ "Unexpected character"))
+ | Ulexing.InvalidCodepoint i ->
+ raise_clean (Error (Ulexing.lexeme_end lb, Ulexing.lexeme_end lb,
+ "Code point invalid for the current encoding"))
+ | e -> raise_clean e
+ in
+ last_tok := tok;
+ Some (tok, loc)
+ in
+ Stream.from next
projects / tatoo.git / blobdiff