+++ /dev/null
-(******************************************************)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 14/05/2000 *)
-(******************************************************)
-
-(* Surrogate Pairs are not accepted in XML files (is it true???) *)
-exception SurrogatePairs;;
-
-(* Interval (n,m) where n >m m *)
-exception InvalidInterval of int * int;;
-
-(* Given an ucs2 character code, returns it in utf8 *)
-(* (as a concatenation of characters) *)
-let char_ucs2_to_utf8 =
- function
- n when n >= 0xD800 && n <= 0xDFFF -> raise SurrogatePairs
- | n when n <= 0x007F -> Types.Char n
- | n when n <= 0x07FF ->
- Types.Concat
- [[Types.Char (n lsr 6 land 0b00011111 lor 0b11000000)] ;
- [Types.Char (n land 0b00111111 lor 0b10000000)]]
- | n ->
- Types.Concat
- [[Types.Char (n lsr 12 land 0b00001111 lor 0b11100000)] ;
- [Types.Char (n lsr 6 land 0b00111111 lor 0b10000000)] ;
- [Types.Char (n land 0b00111111 lor 0b10000000)]]
-;;
-
-(*CSC: Two functions for debugging pourposes only
-
-let char_ucs2_to_utf8 =
- function
- n when n >= 0xD800 && n <= 0xDFFF -> assert false
- | n when n <= 0x007F -> [[n]]
- | n when n <= 0x07FF ->
- [[(n lsr 6 land 0b00011111 lor 0b11000000)] ;
- [(n land 0b00111111 lor 0b10000000)]]
- | n ->
- [[(n lsr 12 land 0b00001111 lor 0b11100000)] ;
- [(n lsr 6 land 0b00111111 lor 0b10000000)] ;
- [(n land 0b00111111 lor 0b10000000)]]
-;;
-
-let rec bprint =
- function
- 0 -> ""
- | n -> bprint (n / 2) ^ string_of_int (n mod 2)
-;;
-*)
-
-(* A few useful functions *)
-let rec mklist e =
- function
- 0 -> []
- | n -> e::(mklist e (n - 1))
-;;
-
-let sup =
- let t = Types.Char 0b10111111 in
- function
- 1 -> t
- | n -> Types.Concat (mklist [t] n)
-;;
-
-let rec inf =
- let b = Types.Char 0b10000000 in
- function
- 1 -> [[b]]
- | n -> mklist [b] n
-;;
-
-let mysucc =
- function
- [Types.Char n] -> n + 1
- | _ -> assert false
-;;
-
-let mypred =
- function
- [Types.Char n] -> n - 1
- | _ -> assert false
-;;
-
-(* Given two utf8-encoded extremes of an interval character code *)
-(* whose 'length' is the same, it returns the utf8 regular expression *)
-(* matching all the characters in the interval *)
-let rec same_length_ucs2_to_utf8 =
- let module T = Types in
- function
- (T.Char n, T.Char m) when n = m -> [T.Char n]
- | (T.Char n, T.Char m) -> [T.Interval (n,m)]
- | (T.Concat [hen ; [tln]], T.Concat [hem ; [tlm]]) when hen = hem ->
- [T.Concat [hen ; same_length_ucs2_to_utf8 (tln,tlm)]]
- | (T.Concat [hen ; [tln]], T.Concat ([hem ; [tlm]] as e2)) ->
- (T.Concat [hen ; same_length_ucs2_to_utf8 (tln,sup 1)]) ::
- (let shen = mysucc hen
- and phem = mypred hem in
- let succhen = [T.Char shen] in
- if succhen = hem then
- same_length_ucs2_to_utf8 (T.Concat (succhen::(inf 1)), T.Concat e2)
- else
- (T.Concat [[T.Interval (shen, phem)] ;
- [T.Interval (0b10000000,0b10111111)]])::
- same_length_ucs2_to_utf8 (T.Concat (hem::(inf 1)), T.Concat e2)
- )
- (*same_length_ucs2_to_utf8 (T.Concat ((mysucc hen)::(inf 1)), T.Concat e2)*)
- | (T.Concat (hen::tln), T.Concat (hem::tlm)) when hen = hem ->
- [T.Concat [hen ; same_length_ucs2_to_utf8 (T.Concat tln, T.Concat tlm)]]
- | (T.Concat (hen::tln), T.Concat ((hem::tlm) as e2)) ->
- let n = List.length tln in
- (T.Concat
- [hen ; same_length_ucs2_to_utf8 (T.Concat tln,sup n)]) ::
- (let shen = mysucc hen
- and phem = mypred hem in
- let succhen = [T.Char shen] in
- if succhen = hem then
- same_length_ucs2_to_utf8 (T.Concat (succhen::(inf n)), T.Concat e2)
- else
- (T.Concat [[T.Interval (shen, phem)] ;
- [T.Interval (0b10000000,0b10111111)] ;
- [T.Interval (0b10000000,0b10111111)]]
- )::
- same_length_ucs2_to_utf8 (T.Concat (hem::(inf n)), T.Concat e2)
- )
- (*same_length_ucs2_to_utf8 (T.Concat ((mysucc hen)::(inf n)),T.Concat e2)*)
- | _ -> assert false
-;;
-
-(* Given an interval of ucs2 characters, splits *)
-(* the list in subintervals whose extremes has *)
-(* the same utf8 encoding length and, for each *)
-(* extreme, calls same_length_ucs2_to_utf8 *)
-let rec seq_ucs2_to_utf8 =
- function
- (n,_) when n >= 0xD800 && n <= 0xDFFF -> raise SurrogatePairs
- | (_,n) when n >= 0xD800 && n <= 0xDFFF -> raise SurrogatePairs
- | (n,m) when n > m -> raise (InvalidInterval (n,m))
- | (n,m) when n = m -> [char_ucs2_to_utf8 n]
- | (n,m) when n <= 0x07F && m > 0x07F ->
- (seq_ucs2_to_utf8 (n,0x07F)) @ (seq_ucs2_to_utf8 (0x080,m))
- | (n,m) when n <= 0x07FF && m > 0x07FF ->
- (seq_ucs2_to_utf8 (n,0x07FF)) @ (seq_ucs2_to_utf8 (0x0800,m))
- | (n,m) ->
- let utf8n = char_ucs2_to_utf8 n
- and utf8m = char_ucs2_to_utf8 m in
- same_length_ucs2_to_utf8 (utf8n,utf8m)
-;;
-
-(* Given an ucs2 regual expression, returns *)
-(* the corresponding utf8 regular expression *)
-let ucs2_to_utf8 { Types.id = id ; Types.rel = rel } =
- let rec aux re l2 =
- match re with
- Types.Char i -> char_ucs2_to_utf8 i :: l2
- | Types.Interval (l,u) -> seq_ucs2_to_utf8 (l,u) @ l2
- | Types.Identifier _ as i -> i :: l2
- | Types.Concat rell ->
- let foo rel = List.fold_right aux rel [] in
- Types.Concat (List.map foo rell) :: l2
- in
- { Types.id = id ; Types.rel = List.fold_right aux rel [] }
-;;
-
-(* The function actually used to produce the output *)
-let output = print_string ;;
-
-(* padded_string_of_int i returns the string representing the *)
-(* integer i (i < 256) using exactly 3 digits (example: 13 -> "013") *)
-let padded_string_of_int i =
- if i < 10 then
- "00" ^ string_of_int i
- else if i < 100 then
- "0" ^ string_of_int i
- else
- string_of_int i
-;;
-
-(* Two functions useful to print a definition *)
-let rec print_disjunction ?(first = true) =
- function
- [] -> ()
- | he::tl ->
- if not first then output " | " ;
- print_re he ;
- print_disjunction ~first:false tl
-and print_re =
- function
- Types.Char i -> output ("'\\" ^ padded_string_of_int i ^ "'")
- | Types.Interval (l,u) ->
- output ("['\\" ^ padded_string_of_int l ^ "'-'\\" ^
- padded_string_of_int u ^ "']")
- | Types.Identifier i -> output i
- | Types.Concat rell ->
- let foo rel =
- if List.length rel > 1 then
- (output "(" ; print_disjunction rel ; output ")")
- else
- print_disjunction rel
- in
- List.iter foo rell
-;;
-
-(* print_definition prints a definition in the format expected by ocamllex *)
-let print_definition { Types.id = id ; Types.rel = rel } =
- output ("let " ^ id ^ " =\n ") ;
- print_disjunction rel ;
- output "\n\n"
-;;
-
-(* main *)
-let _ =
- let lexbuf = Lexing.from_channel stdin in
- let ucs2_result = Parser.main Lexer.token lexbuf in
- List.iter print_definition (List.map ucs2_to_utf8 ucs2_result)
-;;
projects / helm.git / blobdiff