1#use "topfind";; 2#require "unix";; 3#require "pcre";; 4 5type attribute_spec = { 6 function_name: string; 7 function_attrs: string list option; 8 parameter_attrs: (string * string list) list option; 9} 10 11(* These functions all require special handling beyond the more general rules 12 below. *) 13let manual_function_attributes = 14 [ 15 { 16 function_name = "c_plimage"; 17 function_attrs = None; 18 parameter_attrs = Some ["idata", ["in"; "size_is(nx, ny)"]]; 19 }; 20 { 21 function_name = "c_plstyl"; 22 function_attrs = None; 23 parameter_attrs = Some ["mark", ["size_is(nms)"]; "space", ["size_is(nms)"]]; 24 }; 25 { 26 function_name = "plMinMax2dGrid"; 27 function_attrs = None; 28 parameter_attrs = Some ["f", ["size_is(nx, ny)"]; "fmax", ["out"]; "fmin", ["out"]]; 29 }; 30 { 31 function_name = "c_plscmap1l"; 32 function_attrs = None; 33 parameter_attrs = Some ["alt_hue_path", ["in"; "size_is(npts)"; "unique"]]; 34 }; 35 { 36 function_name = "c_plscmap1la"; 37 function_attrs = None; 38 parameter_attrs = Some ["alt_hue_path", ["in"; "size_is(npts)"; "unique"]]; 39 }; 40 { 41 function_name = "c_plxormod"; 42 function_attrs = None; 43 parameter_attrs = Some ["status", ["out"]]; 44 }; 45 { 46 function_name = "c_plrgbhls"; 47 function_attrs = None; 48 parameter_attrs = Some ["p_h", ["out"]; "p_l", ["out"]; "p_s", ["out"]]; 49 }; 50 { 51 function_name = "c_plhlsrgb"; 52 function_attrs = None; 53 parameter_attrs = Some ["p_r", ["out"]; "p_g", ["out"]; "p_b", ["out"]]; 54 }; 55 { 56 function_name = "c_plmkstrm"; 57 function_attrs = None; 58 parameter_attrs = Some ["p_strm", ["out"]]; 59 }; 60 { 61 function_name = "c_plbin"; 62 function_attrs = None; 63 parameter_attrs = Some ["x", ["in"; "size_is(nbin)"]; 64 "y", ["in"; "size_is(nbin)"]]; 65 }; 66 { 67 function_name = "c_plpat"; 68 function_attrs = None; 69 parameter_attrs = Some ["inc", ["in"; "size_is(nlin)"]; 70 "del", ["in"; "size_is(nlin)"]]; 71 }; 72 { 73 function_name = "c_plctime"; 74 function_attrs = None; 75 parameter_attrs = Some ["ctime", ["out"]]; 76 }; 77 (* For now, this will be wrapped by hand... 78 { 79 function_name = "c_plcolorbar"; 80 function_attrs = None; 81 parameter_attrs = Some ["values", ["in"; "size_is(n_values)"]; 82 "p_colorbar_width", ["out"]; 83 "p_colorbar_height", ["out"]]; 84 }; 85 { 86 function_name = "c_plgriddata"; 87 function_attrs = None; 88 parameter_attrs = Some ["xg", ["in"; "size_is(nptsx)"]; "yg", ["in"; "size_is(nptsy)"]; "zg", ["out"; "size_is(nptsx,nptsy)"]]; 89 }; 90 *) 91 ] 92 93(* Length to allocate for output strings. *) 94let max_string_length = "1024" 95 96(* Functions to read in everything on STDOUT from a given command. *) 97(* Many thanks to Richard M. Jones for the following two functions! *) 98 99(** Read in all of the lines from an input source *) 100let rec input_all_lines chan = 101 try 102 let line = input_line chan in 103 line :: input_all_lines chan 104 with 105 End_of_file -> [] 106 107(** Read everything output on STDOUT from a given command-line *) 108let pget cmd = 109 let chan = Unix.open_process_in cmd in 110 let lines = input_all_lines chan in 111 let stat = Unix.close_process_in chan in 112 (match stat with 113 Unix.WEXITED 0 -> () 114 | Unix.WEXITED i -> 115 failwith ("command failed with code " ^ string_of_int i) 116 | Unix.WSIGNALED i -> 117 failwith ("command killed by signal " ^ string_of_int i) 118 | Unix.WSTOPPED i -> 119 failwith ("command stopped by signal " ^ string_of_int i)); 120 lines 121 122(** Read in a file, pre-processed with cpp, and return the output as a list of 123 lines. *) 124let read_file filename = 125 let preprocessed_text = pget ("cpp " ^ filename) in 126 let l = List.map (fun l -> l ^ "\n") preprocessed_text in 127 (* 128 let text_blob = 129 List.fold_left (^) "" l 130 in 131 print_endline text_blob; 132 text_blob 133 *) 134 l 135 136(** Utility functions *) 137let (|>) x f = f x 138let id x = x 139 140(** Clean up the text a bit, minimizing whitespace and cutting out leftover 141 cruft from the preprocessor. *) 142let cleanup_lines l = 143 (* Strip out #-started preprocessor lines, as well as lines with only 144 whitespace. *) 145 let blob = 146 let filtered = 147 List.filter ( 148 fun line -> 149 if Pcre.pmatch ~pat:"^#|^\\s+$" line then 150 false 151 else 152 true 153 ) l 154 in 155 List.fold_left (^) "" filtered 156 in 157 blob 158 (* Compress lengths of whitespace down to a single character *) 159 |> Pcre.replace ~pat:"\\s+" ~templ:" " 160 (* Put newlines back in after each ; *) 161 |> Pcre.replace ~pat:"; " ~templ:";\n" 162 163(** Given a list of attributes, return a camlidl-ready string representing those 164 attributes. *) 165let make_attribute_string attributes = 166 match attributes with 167 [] -> "" 168 | a -> 169 "[" ^ String.concat ", " a ^"]" 170 171(** Get rid of extraneous whitespace (leading, trailing, runs) *) 172let minimize_whitespace s = 173 s 174 |> Pcre.replace ~pat:"^\\s+" ~templ:"" 175 |> Pcre.replace ~pat:"\\s+$" ~templ:"" 176 |> Pcre.replace ~pat:"\\s+" ~templ:" " 177 178(** Generate attributes specific to a given function, based in its return type 179 and name. *) 180let function_attributes return_type name = 181 let check_re re = 182 if Pcre.pmatch ~pat:re name then 183 Pcre.extract ~pat:re ~full_match:false name 184 else 185 [||] 186 in 187 188 let name_checks = 189 [ 190 (* OCaml values can not begin with a capital letter. Translate a name 191 like FOObar to foo_bar for OCaml. *) 192 "^([A-Z]+)(.*)$", 193 ( 194 fun a -> ["mlname(" ^ ( 195 match Array.length a with 196 1 -> String.lowercase_ascii a.(0) 197 | 2 -> 198 String.lowercase_ascii a.(0) ^ "_" ^ a.(1) 199 | _ -> raise (Failure "Bad result in function caps check") 200 ) ^ ")"] 201 ); 202 (* Plplot names many of their functions c_* to avoid clashes with certain 203 language bindings. There's no need to carry this over to OCaml. 204 This turns c_foo in to foo. *) 205 "^c_(\\w+)$", (fun a -> ["mlname(" ^ a.(0) ^ ")"]); 206 ] 207 in 208 let type_checks = 209 [ 210 (* Treat strings properly *) 211 "char\\s*\\*", 212 ["string"; "length_is(" ^ max_string_length ^ ")"] 213 ] 214 in 215 216 (* Attributes based on the function name *) 217 let name_attrs = 218 List.map ( 219 fun (re,attrf) -> 220 let a = check_re re in if Array.length a > 0 then attrf a else [] 221 ) name_checks 222 |> List.flatten 223 in 224 (* Attributes based on the function type *) 225 let type_attrs = 226 List.map ( 227 fun (re,attrs) -> if Pcre.pmatch ~pat:re return_type then attrs else [] 228 ) type_checks 229 |> List.flatten 230 in 231 (* Any other attributes, specified manually *) 232 let manual_attrs = 233 try 234 let fa = 235 List.find (fun fa -> fa.function_name = name) manual_function_attributes 236 in 237 match fa.function_attrs with 238 | Some a -> a 239 | None -> [] 240 with 241 | Not_found -> [] 242 in 243 name_attrs @ type_attrs @ manual_attrs 244 245(** Generate attributes for function parameters *) 246let parameter_attributes function_name types names = 247 let pmatch re str = Pcre.pmatch ~pat:re str in 248 let non_get_functions = ["c_plgriddata"; "c_plgra"; "c_plgradient"] in 249 250 (* If all of the pieces are true, then the attribute(s) is(are) appropriate 251 for this parameter. This is basically a long list of special cases 252 which usually, but not always, apply to multiple functions. *) 253 let checks p_type p_name = 254 [ 255 (* Order goes: 256 function_name check 257 type check 258 attribute name check 259 misc. check (anything, as long as it's a bool) 260 attributes, if all of the above are true 261 *) 262 (* OCaml does not support unsigned integer values in its standard library 263 so use Int64.t values for unsigned ints to be safe. *) 264 true, 265 pmatch "unsigned int" p_type, 266 true, 267 true, 268 ["int64"]; 269 (* "get" functions *) 270 pmatch "^c_plg" function_name, 271 pmatch "\\*" p_type, 272 true, 273 not (List.mem function_name non_get_functions), 274 ["out"] @ 275 if pmatch "char" p_type then ["length_is(" ^ max_string_length ^ ")"] 276 else []; 277 (* Strings *) 278 true, 279 pmatch "(?:const )?char\\s*\\*$" p_type, 280 true, 281 true, 282 ["string"]; 283 (* Pointers to arrays of n elements *) 284 true, 285 pmatch "\\*" p_type && not (pmatch "const char" p_type), 286 true, 287 List.mem "n" names, 288 ["in"; "size_is(n)"]; 289 (* Pointers to arrays of npts elements *) 290 true, 291 pmatch "\\*" p_type, 292 not (pmatch "^[xyz]g$" p_name), 293 List.mem "npts" names, 294 ["in"; "size_is(npts)"]; 295 (* x and y dimensions *) 296 true, 297 pmatch "\\*" p_type, 298 p_name = "x" || p_name = "y", 299 List.mem ("n" ^ p_name) names, 300 ["size_is(n" ^ p_name ^ ")"; "in"]; 301 (* z dimensions *) 302 true, 303 pmatch "\\*\\*" p_type, 304 p_name = "z", 305 List.mem "nx" names && List.mem "ny" names, 306 ["size_is(nx, ny)"; "in"]; 307 (* Contouring levels *) 308 true, 309 true, 310 p_name = "clevel", 311 List.mem "nlevel" names, 312 ["size_is(nlevel)"; "in"]; 313 (* Color maps *) 314 true, 315 pmatch "\\*" p_type, 316 p_name = "r" || p_name = "g" || p_name = "b" || p_name = "alpha", 317 List.mem "ncol0" names, 318 ["size_is(ncol0)"; "in"]; 319 true, 320 pmatch "\\*" p_type, 321 p_name = "r" || p_name = "g" || p_name = "b" || p_name = "alpha", 322 List.mem "ncol1" names, 323 ["size_is(ncol1)"; "in"]; 324 (* Linear relationship color maps *) 325 pmatch "c_plscmap1l" function_name, 326 pmatch "\\*" p_type, 327 List.mem p_name ["intensity"; "coord1"; "coord2"; "coord3"; "alpha"], 328 true, 329 ["size_is(npts)"]; 330 (* Relative to world coordinates *) 331 function_name = "c_plcalc_world", 332 pmatch "\\*" p_type, 333 List.mem p_name ["wx"; "wy"; "window"], 334 true, 335 ["out"]; 336 (* Time conversion *) 337 function_name = "c_plbtime", 338 pmatch "\\*" p_type, 339 true, 340 true, 341 ["out"]; 342 (* Index limits *) 343 true, 344 pmatch "\\*" p_type, 345 List.mem p_name ["indexymin"; "indexymax"], 346 true, 347 ["size_is(indexxmax)"; "in"]; 348 ] 349 in 350 351 let attr_hash = Hashtbl.create 10 in 352 353 let perform_check param_type param_name = 354 (* Any other attributes, specified manually *) 355 let manual_attrs = 356 try 357 let fa = 358 List.find (fun fa -> fa.function_name = function_name) 359 manual_function_attributes 360 in 361 match fa.parameter_attrs with 362 | Some a -> List.assoc param_name a 363 | None -> [] 364 with 365 | Not_found -> [] 366 in 367 Hashtbl.add attr_hash param_name manual_attrs; 368 (* Check for attributes, filter the ones we don't want, then add the rest 369 to the attribute hash. *) 370 checks param_type param_name 371 |> List.filter ( 372 fun (function_check, type_check, name_check, other_check, _) -> 373 List.for_all id [function_check; type_check; name_check; other_check] 374 ) 375 |> List.iter (fun (_,_,_,_,attrs) -> Hashtbl.add attr_hash param_name attrs) 376 in 377 List.iter2 perform_check types names; 378 attr_hash 379 380(** Build a string from a list of attributes *) 381let build_attribute_list l = 382 List.map ( 383 fun (attrs, t, n) -> 384 String.concat " " [make_attribute_string attrs; t; n] 385 ) l 386 387(** Given a C function prototype, chop it up and find out what camlidl 388 attributes it should have. *) 389let process_prototype line = 390 (* This is an ugly, but for now effective, regexp to parse the PLplot function 391 prototypes. *) 392 let pieces = 393 line 394 |> Pcre.extract ~pat:"^((?:(?:const|unsigned|enum) )?\\w+ (?:\\*\\s*)?)(\\w+)\\s*\\(([\\w\\s\\*\\[\\],]*)\\)" ~full_match:false 395 |> Array.map minimize_whitespace 396 in 397 (* Get the return type, name and arg list separately *) 398 let return_type = pieces.(0) in 399 let function_name = pieces.(1) in 400 let params = 401 pieces.(2) 402 |> Pcre.split ~pat:"," 403 |> List.map minimize_whitespace 404 in 405 let param_types, param_names = 406 params 407 |> List.map ( 408 fun param -> 409 let p = Pcre.extract ~pat:"(.*)?\\b(\\w+)" ~full_match:false param in 410 minimize_whitespace p.(0), minimize_whitespace p.(1) 411 ) 412 |> List.split 413 in 414 let f_attrs = function_attributes return_type function_name in 415 let p_attrs = parameter_attributes function_name param_types param_names in 416 let params_with_attrs = 417 List.map2 418 (fun t n -> Hashtbl.find_all p_attrs n |> List.flatten, t, n) 419 param_types param_names 420 in 421 String.concat " " ( 422 [ 423 make_attribute_string f_attrs; 424 return_type; 425 function_name; "("; 426 ] 427 @ [String.concat ", " (build_attribute_list params_with_attrs)] 428 @ [");"] 429 ) 430 431(** Write a list of lines out to the given filename *) 432let write_file filename lines = 433 let fout = open_out filename in 434 List.iter (output_string fout) lines; 435 close_out fout; 436 () 437 438(** Given input and output filenames, process the contents of the input file 439 and write the results to the output file, which should be ready for 440 consumption by camlidl. *) 441let process_file () = 442 let infile, outfile = 443 if Array.length Sys.argv = 3 then 444 Sys.argv.(1), Sys.argv.(2) 445 else 446 "plplot_h", "plplot_h.inc" 447 in 448 read_file infile 449 |> cleanup_lines 450 |> Pcre.split ~pat:"\n" 451 |> List.map minimize_whitespace 452 |> List.map ( 453 fun l -> 454 try 455 process_prototype l 456 with 457 | Not_found -> 458 failwith ("Unhandled or malformed prototype: " ^ l) 459 ) 460 |> List.map minimize_whitespace 461 |> List.map (fun l -> l ^ "\n") 462 |> write_file outfile 463 464let () = 465 if !Sys.interactive then 466 () 467 else 468 process_file (); 469 () 470