1(* camlp5r *) 2(* $Id: translate.ml,v 5.9 2007-09-12 09:58:44 ddr Exp $ *) 3(* Copyright (c) 1998-2007 INRIA *) 4 5module Buff = Buff.Make (struct value buff = ref (Bytes.create 80); end); 6 7value skip_lang s = 8 loop where rec loop i = 9 if i = String.length s then None 10 else 11 match s.[i] with 12 [ 'a'..'z' | '-' -> loop (i + 1) 13 | _ -> Some i ] 14; 15 16value inline lang macro_char macro s = 17 let lang = lang ^ ":" in 18 let derived_lang = 19 try 20 let i = String.index lang '-' in 21 String.sub lang 0 i ^ ":" 22 with 23 [ Not_found -> "" ] 24 in 25 let rec loop alt_version bol i = 26 if i = String.length s then 27 match alt_version with 28 [ Some s -> (s, True) 29 | None -> ("..........", False) ] 30 else if bol then 31 match skip_lang s i with 32 [ Some j when s.[j] = ':' -> 33 let curr_lang = String.sub s i (j + 1 - i) in 34 if curr_lang = lang || curr_lang = derived_lang || 35 curr_lang = "en:" then 36 let (s, i) = 37 let j = if s.[j + 1] = ' ' then j + 1 else j in 38 let rec loop len j = 39 if j = String.length s then (Buff.get len, j) 40 else if s.[j] = '\n' then 41 if j + 1 < String.length s && s.[j + 1] = ' ' then 42 let j = 43 loop (j + 1) where rec loop j = 44 if j < String.length s && s.[j] = ' ' then 45 loop (j + 1) 46 else j 47 in 48 loop (Buff.store len '\n') j 49 else (Buff.get len, j) 50 else if s.[j] = macro_char then 51 loop (Buff.mstore len (macro s.[j + 1])) (j + 2) 52 else loop (Buff.store len s.[j]) (j + 1) 53 in 54 loop 0 (j + 1) 55 in 56 if curr_lang = lang then (s, False) 57 else 58 let alt_version = 59 if curr_lang = derived_lang then Some s 60 else if alt_version = None then Some s 61 else alt_version 62 in 63 loop alt_version True i 64 else loop alt_version (s.[i] = '\n') (i + 1) 65 | _ -> loop alt_version (s.[i] = '\n') (i + 1) ] 66 else loop alt_version (s.[i] = '\n') (i + 1) 67 in 68 loop None True 0 69; 70 71value language_name lang lang_def = 72 let str = lang_def in 73 let len = String.length lang in 74 let rec loop beg i = 75 if i = String.length str && i = beg then lang 76 else if i = String.length str || str.[i] = '/' then 77 if i > beg + len + 1 && str.[beg + len] = '=' && 78 String.sub str beg len = lang then 79 String.sub str (beg + len + 1) (i - beg - len - 1) 80 else if i = String.length str then lang 81 else loop (i + 1) (i + 1) 82 else loop beg (i + 1) 83 in 84 loop 0 0 85; 86 87(* eval *) 88 89value erase str i j = 90 String.sub str 0 i ^ String.sub str j (String.length str - j) 91; 92 93(* 94 * eval_set scans strings of the form @(x) where x is a list of characters 95 * meaning a predicate to set for each character. Fills [set], the set of 96 * predicates. Treats also the special case for @(&) = delete the next 97 * character if any. 98 *) 99 100value eval_set str = 101 loop [] str 0 where rec loop set str i = 102 if i + 3 < String.length str then 103 if str.[i] = '@' && str.[i + 1] = '(' && str.[i + 3] <> '?' && 104 str.[i + 3] <> '-' 105 then 106 if str.[i + 2] = '&' && str.[i + 3] = ')' && i + 4 < String.length str 107 then 108 loop set (erase str i (i + 5)) i 109 else 110 let (set, j) = 111 loop set (i + 2) where rec loop set i = 112 if i < String.length str then 113 if str.[i] <> ')' then loop [str.[i] :: set] (i + 1) 114 else (set, i + 1) 115 else (set, i) 116 in 117 loop set (erase str i j) i 118 else loop set str (i + 1) 119 else (set, str) 120; 121 122value rec apply_expr set str i = 123 if i + 1 < String.length str && str.[i + 1] = '?' then 124 if List.mem str.[i] set then 125 let str = erase str i (i + 2) in 126 let (str, i) = apply_expr set str i in 127 if i < String.length str && str.[i] = ':' then 128 let (str, j) = apply_expr set str (i + 1) in 129 (erase str i j, i) 130 else (str, i) 131 else 132 let (str, j) = apply_expr set str (i + 2) in 133 let str = erase str i j in 134 if i < String.length str && str.[i] = ':' then 135 let str = erase str i (i + 1) in 136 apply_expr set str i 137 else (str, i) 138 else if i < String.length str && (str.[i] = ':' || str.[i] = ')') then 139 (str, i) 140 else apply_expr set str (i + 1) 141; 142 143(* 144 * eval_app scans strings matching expressions between @( and ). 145 * an expression is: 146 * - a [character] followed by "?", an [expression] and possibly ":" and 147 * [another expression] 148 * - any [string] not holding ":" 149 * The [character] is a predicate. If defined, the first expression is 150 * evaluated, else it is the second one. The evaluation of a string is 151 * itself. 152 * 153 * ex: p?e:m?A?en:er:w?e:n?es 154 * In this example, if m and A are only defined predicates: 155 * p not being defined, it is m?A?en:er:w?e:n?es 156 * m being defined, it is A?en:er 157 * A being defined, it is en 158 * This example shows how to display adjectives in German, where 159 * m is for masculine, w for feminine and n for neuter 160 *) 161 162value eval_app set str = 163 loop str 0 where rec loop str i = 164 if i + 3 < String.length str then 165 if str.[i] = '@' && str.[i + 1] = '(' && str.[i + 3] <> '-' then 166 let str = erase str i (i + 2) in 167 let (str, i) = apply_expr set str i in 168 if i < String.length str then 169 if str.[i] = ')' then loop (erase str i (i + 1)) i else loop str i 170 else str 171 else loop str (i + 1) 172 else str 173; 174 175(* 176 * eval_shift scans strings matching: 177 * @(#-) shifting # words of the left after the next word. 178 * @(#--) shifting # words of the left to the end. 179 * ex: 180 * before: "Une avec un diamant@(3-) bague" 181 * after: "Une bague avec un diamant" 182 * before: "Sie haben geworfen@(1--) einen kurzen Bogen" 183 * after: "Sie haben einen kurzen Bogen geworfen" 184 *) 185 186value rec eval_shift s = 187 let t = String.make (String.length s) '#' in 188 let rec loop changed i j = 189 if i + 4 < String.length s && s.[i] = '@' && s.[i + 1] = '(' && 190 s.[i + 3] = '-' 191 then 192 let nleft = Char.code s.[i + 2] - Char.code '0' in 193 let to_the_end = s.[i + 4] = '-' in 194 let k = if to_the_end then i + 5 else i + 4 in 195 if k < String.length s && s.[k] = ')' then 196 let l = 197 loop nleft (i - 1) where rec loop nleft l = 198 if l > 0 then 199 if s.[l] = ' ' then 200 if nleft <= 1 then l + 1 else loop (nleft - 1) (l - 1) 201 else loop nleft (l - 1) 202 else 0 203 in 204 let len = i - l in 205 let j = j - len in 206 let k = k + 1 in 207 let i = if k < String.length s && s.[k] = ' ' then k + 1 else k in 208 let (i, j) = 209 if to_the_end then 210 let rec loop i j = 211 if i < String.length s then do { 212 Bytes.set t j s.[i]; loop (i + 1) (j + 1) 213 } 214 else do { 215 let j = 216 if j > 0 && t.[j - 1] <> ' ' then do { Bytes.set t j ' '; j + 1 } 217 else j 218 in 219 String.blit s l t j len; 220 (i, j + len) 221 } 222 in 223 loop i j 224 else 225 let rec loop i j = 226 if i < String.length s then 227 if s.[i] = ' ' then do { 228 Bytes.set t j ' '; 229 String.blit s l t (j + 1) len; 230 (i, j + 1 + len) 231 } 232 else do { Bytes.set t j s.[i]; loop (i + 1) (j + 1) } 233 else if k < String.length s && s.[k] = ' ' then do { 234 Bytes.set t j ' '; String.blit s l t (j + 1) len; (i, j + 1 + len) 235 } 236 else do { String.blit s l t j len; (i, j + len) } 237 in 238 loop i j 239 in 240 loop True i j 241 else do { Bytes.set t j s.[i]; loop changed (i + 1) (j + 1) } 242 else if i < String.length s then do { 243 Bytes.set t j s.[i]; loop changed (i + 1) (j + 1) 244 } 245 else if changed then eval_shift (String.sub t 0 j) 246 else String.sub t 0 j 247 in 248 loop False 0 0 249; 250 251value rec eval str = 252 if not (String.contains str '@') then (* optimisation *) str 253 else 254 let str = eval_rec str in 255 let (set, str) = eval_set str in 256 let str = eval_app set str in 257 eval_shift str 258and eval_rec str = 259 loop str 0 where rec loop str i = 260 if i = String.length str then str 261 else if i + 3 < String.length str && str.[i] = '@' && str.[i+1] = '(' && 262 str.[i+2] = '@' 263 then 264 let j = 265 loop (i + 2) where rec loop j = 266 if j < String.length str then 267 if str.[j] = '(' then 268 let j = loop (j + 1) in 269 loop (j + 1) 270 else if str.[j] = ')' then j 271 else loop (j + 1) 272 else j 273 in 274 if j = String.length str then str 275 else 276 let sstr = eval (String.sub str (i + 2) (j - i - 2)) in 277 let k = i + String.length sstr in 278 let str = 279 String.sub str 0 i ^ sstr ^ 280 String.sub str (j + 1) (String.length str - j - 1) 281 in 282 loop str k 283 else loop str (i + 1) 284; 285