(***********************************************************************************************************) (* Split a string into a list of substrings based on a delimiter character *) let split c str = let rec aux s acc = try let ind=String.index s c in aux (String.sub s (ind+1) ((String.length s) - ind -1 )) ((String.sub s 0 ind)::acc) with Not_found -> List.rev (s::acc) in aux str [];; (* Function to read a file into a string list, each line (excluding \n char) is an element of the list *) let readfile fname = let cin = open_in fname in let rec aux acc = try aux ((input_line cin)::acc) with End_of_file -> close_in cin; List.rev acc in aux [];; (* Flatten list of strings with separator *) let rec flatten l sep' = let sep = if (List.length l) = 1 then "" else sep' () in match l with | [] -> "" | h :: t -> h ^ (sep) ^ (flatten t sep');; (* Write string s to file f *) let write_file s f = let oc = open_out f in output_string oc s; close_out oc;; (* Trim a string *) let rec trim s = let l = String.length s in if l=0 then s else if s.[0]=' ' || s.[0]='\t' || s.[0]='\n' || s.[0]='\r' then trim (String.sub s 1 (l-1)) else if s.[l-1]=' ' || s.[l-1]='\t' || s.[l-1]='\n' || s.[l-1]='\r' then trim (String.sub s 0 (l-1)) else s let is_uppercase c = if c = Char.uppercase c then true else false;; let is_lowercase c = if c = Char.lowercase c then true else false;; (*************************************************************************************) exception NotAFunction of string exception ParameterError of string type glconst = { tname : string; tval : string } type glparam = { ptype: string; pconst: bool; parray: bool } type glfunc = { ftype : string; fname : string; fparams: glparam array } (* Is it a GL constant *) let is_gl_constant s' = let s = (trim s') in let l = (String.length s) in if (l < 4) then false else if ((String.sub s 0 3) = "GL_") then true else false (* Is it a line with a function *) let is_gl_function s' = let s = trim s' in if (s = "") then false else let l = (String.length s) - 1 in if s.[l] = ')' then true else false (* Get constants *) let get_gl_constant s' = let s = trim s' in let l = split ' ' s in let len = List.length l in if (len) = 1 then {tname = (List.hd l); tval = ""} else {tname = (List.hd l); tval = (List.nth l (len - 1))} (* from a string of format return-type function-name, get return-type*) let get_ftype s' = let s = trim s' in let l = split ' ' s in List.hd l (* from a string of format return-type function-name, get function-name*) let get_fname s' = let s = trim s' in let l = split ' ' s in let len = List.length l in (List.nth l (len - 1)) (* returns true if type is a pointer *) let is_ptr s' = let s = trim s' in let l = String.length s in if ((s.[l-1] = '*') || (s.[0] = '*')) then true else false (*Removes trailing '*' from a pointer*) let min_ptr s' = let s = trim s' in let l = String.length s in if not (s.[l-1] = '*') then s else String.sub s 0 ((String.length s) - 1) (* returns true if type is a C const *) let is_const s' = let s = trim s' in let len = String.length s in let lc = String.length "const " in if len <= lc then false else let c = String.sub s 0 lc in if c = "const " then true else false (* remove const*) let min_const s' = let s = trim s' in let len = String.length s in let lc = String.length "const " in if len <= lc then s else let c = String.sub s 0 lc in if c = "const " then (trim (String.sub s lc (len - lc))) else s (* get parameter type. If it is a pointer it may not be an input parameter *) let get_param s' = let s = trim s' in let l = split ' ' s in let h = if (((List.hd l) = "GLvoid") || ((List.hd l) = "void")) then "GLvoid" else if (List.length l = 2) then (List.hd l) else if (((List.length l) = 3) && ((trim (List.hd l)) = "const" )) then (List.nth l 1) else raise (ParameterError s) in let const = if ((trim (List.hd l)) = "const" ) then true else false in { ptype = h; pconst = const; parray = if ((is_ptr h) || (is_ptr (List.nth l ((List.length l) - 1)))) then true else false } (* Get an array of parameters*) let get_params s' = let s = trim s' in let l = split ',' s in let len = List.length l in let arr = Array.init len (fun i -> (get_param (List.nth l i))) in arr (* Get functions *) let get_gl_function s' = let s'' = trim s' in let s = String.sub s'' 0 ((String.length s'' )- 1) in let f1 = split '(' s in if not ((List.length f1) = 2) then raise (NotAFunction s) else { ftype = (get_ftype (List.hd f1)); fname = (get_fname (List.hd f1)); fparams = (get_params (List.nth f1 1)); } (************************************************************************************************************) (* Prologue and supporting functions *) let prologue_c = " /* * GLCaml - Objective Caml interface for OpenGL 1.1, 1.2, 1.3, 1.4, 1.5 and 2.0 * and the following extensions: * GL_ARB_imaging * GL_ARB_matrix_palette * GL_ARB_multitexture * GL_ARB_vertex_blend * GL_ATI_envmap_bumpmap * GL_ATI_map_object_buffer * GL_ATI_pn_triangles * GL_ATI_separate_stencil * GL_ATI_texture_compression_3dc * GL_ATI_vertex_streams * GL_ATIX_point_sprites * GL_ATIX_texture_env_combine3 * GL_ATIX_texture_env_route * GL_ATIX_vertex_shader_output_point_size * GL_EXT_Cg_shader * GL_EXT_depth_bounds_test * GL_EXT_draw_range_elements * GL_EXT_fog_coord * GL_EXT_pixel_buffer_object * GL_EXT_secondary_color * GL_EXT_texture_cube_map * GL_EXT_texture_edge_clamp * GL_EXT_texture_rectangle * GL_EXT_vertex_shader * GL_KTX_buffer_region * GL_NV_fragment_program2 * GL_NV_fragment_program_option * GL_NV_vertex_program2_option * GL_NV_vertex_program3 * * Copyright (C) 2006 Elliott OTI * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License version 2, as published by the Free Software Foundation. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * See the GNU Library General Public License version 2 for more details * (enclosed in the file LGPL). */ #include #include #include #include #include #include typedef unsigned int GLenum; typedef unsigned char GLboolean; typedef unsigned int GLbitfield; typedef void GLvoid; typedef char GLbyte; typedef short GLshort; typedef int GLint; typedef unsigned char GLubyte; typedef unsigned short GLushort; typedef unsigned int GLuint; typedef int GLsizei; typedef float GLfloat; typedef float GLclampf; typedef double GLdouble; typedef double GLclampd; typedef char GLchar; typedef ptrdiff_t GLsizeiptr; typedef ptrdiff_t GLintptr; typedef char* GLstring; #ifdef _WIN32 #include static HMODULE lib=NULL; static void init_lib() { if(lib == NULL) lib = LoadLibrary(\"opengl32.dll\"); if(lib == NULL) failwith(\"error loading opengl32.dll\"); } static void *get_proc_address(char *fname) { return GetProcAddress(lib, fname); } #endif #ifdef __linux__ #ifndef APIENTRY #define APIENTRY #endif #include #include static void* lib=NULL; static void init_lib() { if(lib == NULL) lib = dlopen(\"libGL.so.1\",RTLD_LAZY); if(lib == NULL) failwith(\"error loading gl dll\"); } static void *get_proc_address(char *fname) { return dlsym(lib, fname); } #endif static int fail_with_exception = 0; void FailWith(char *msg) { if(fail_with_exception)failwith(msg); } value glstub_set_failwith(value b) { CAMLparam1(b); int fw = Bool_val(b); fail_with_exception = 0; if(fw)fail_with_exception = 1; CAMLreturn (Val_unit); } value glstub_init_lib (value u) { CAMLparam1(u); init_lib (); CAMLreturn (Val_unit); } static GLenum get_glenum(int i); int get_glenum_list(value flag_list) { CAMLparam1(flag_list); GLenum flag = 0; value l = flag_list; while (Is_block(l)) { int fl = Int_val(Field(l,0)); flag |= get_glenum(fl); l = Field(l,1); } CAMLreturn (flag); } " (* One line comment containing the function name *) let make_c_comment t = Printf.sprintf "\n/* %s */" t.fname (* Make C declarations *) let make_c_decls t = let s = ref t.fparams.(0).ptype in for i = 1 to ((Array.length t.fparams) - 1) do s := !s ^ "," ^ t.fparams.(i).ptype; done; Printf.sprintf" typedef %s APIENTRY (*pstub_%s)(%s); static pstub_%s stub_%s = NULL; static int loaded_%s = 0; " t.ftype t.fname !s t.fname t.fname t.fname;; (* Make C function *) (* make the local c parameters *) let make_local_c_params cnt = let s = ref "lv0" in for i = 1 to (cnt - 1) do s := !s ^ Printf.sprintf ", lv%d" i; done; !s;; (* make the c parameters *) let make_c_params cnt = let s = ref "value v0" in for i = 1 to (cnt - 1) do s := !s ^ Printf.sprintf ", value v%d" i; done; !s;; (* Create the CAMLparam declarations*) let make_caml_params nparam = let s = ref "" in let j = ref 0 in let x = ref "" in let times = nparam / 5 and rest = nparam mod 5 in for i = 0 to (times - 1) do s := !s ^ (Printf.sprintf "\tCAML%sparam5(v%d, v%d, v%d, v%d, v%d);\n" !x !j (!j+1) (!j+2) (!j+3) (!j+4) ); j := !j + 5; x := "x"; done; if rest > 0 then begin s := !s ^ Printf.sprintf "\tCAML%sparam%d(" !x rest; for i = 0 to (rest - 1) do s := !s ^ (Printf.sprintf "v%d" !j); j := !j + 1; if i < (rest - 1) then s := !s ^ ","; done; s := !s ^ ");\n"; end; !s;; (* Create the local parameters *) (* Translate types *) let val_translate t = match t with | "GLboolean" -> "Val_bool" | "void" -> "Val_unit" | "GLvoid" -> "Val_unit" | "GLuint" -> "Val_int" | "GLint" -> "Val_int" | "GLintptr" -> "Val_int" | "GLenum" -> "Val_int" | "GLsizei" -> "Val_int" | "GLsizeiptr" -> "Val_int" | "GLfloat" -> "Val_double" | "GLdouble" -> "Val_double" | "GLchar" -> "Val_int" | "GLclampf" -> "Val_double" | "GLclampd" -> "Val_double" | "GLshort" -> "Val_int" | "GLubyte" -> "Val_int" | "GLbitfield" -> "Val_int" | "GLushort" -> "Val_int" | "GLbyte" -> "Val_int" | _ -> "unknown" let translate_val t = match t with | "GLboolean" -> "Bool_val" | "void" -> "" | "GLvoid" -> "" | "GLuint" -> "Int_val" | "GLint" -> "Int_val" | "GLintptr" -> "Int_val" | "GLenum" -> "get_glenum" | "GLsizei" -> "Int_val" | "GLsizeiptr" -> "Int_val" | "GLfloat" -> "Double_val" | "GLdouble" -> "Double_val" | "GLchar" -> "Int_val" | "GLclampf" -> "Double_val" | "GLclampd" -> "Double_val" | "GLshort" -> "Int_val" | "GLubyte" -> "Int_val" | "GLbitfield" -> "get_glenum_list" | "GLushort" -> "Int_val" | "GLbyte" -> "Int_val" | "GLstring" -> "caml_copy_string" | "void*" -> "(value)" | "GLvoid*" -> "(value)" | "GLvoid**" -> "(value)" | _ -> "unknown" let translate_ml t = match t with | "GLboolean" -> "bool" | "void" -> "unit" | "GLvoid" -> "unit" | "GLuint" -> "int" | "GLint" -> "int" | "GLintptr" -> "int" | "GLenum" -> "glenum" | "GLsizei" -> "int" | "GLsizeiptr" -> "int" | "GLfloat" -> "float" | "GLdouble" -> "float" | "GLchar" -> "int" | "GLclampf" -> "float" | "GLclampd" -> "float" | "GLshort" -> "int" | "GLubyte" -> "int" | "GLbitfield" -> "glenum list" | "GLushort" -> "int" | "GLbyte" -> "int" | "GLstring" -> "string" | "GLbyte*" -> "byte_array" | "GLubyte*" -> "ubyte_array" | "void*" -> "glpointer" | "GLvoid*" -> "glpointer" | "GLvoid**" -> "glpointer" | "GLuint*" -> "int_array" | "GLint*" -> "int_array" | "GLfloat*" -> "float_array" | "GLdouble*" -> "double_array" | "GLchar*" -> "byte_array" | "GLchar**" -> "byte_matrix" | "GLclampf*" -> "float_array" | "GLclampd*" -> "double_array" | "GLshort*" -> "short_array" | "GLushort*" -> "ushort_array" | "GLboolean*" -> "int_array" | "GLsizei*" -> "int_array" | "GLenum*" -> "int_array" | _ -> "unknown" (* Make the local declarations in stub code*) let make_local_param t i = let p = t.fparams.(i).ptype in let trans = if t.fparams.(i).parray then "Data_bigarray_val" else (translate_val p) in Printf.sprintf "\t%s lv%d = %s(v%d);\n" p i trans i let make_local_params t = let s = ref "" in for i = 0 to ((Array.length t.fparams) - 1) do s := !s ^ (make_local_param t i); done; !s;; (* Declare the return type *) let decl_ret t = if ((t.ftype = "void") || (t.ftype = "GLvoid")) then "" else (Printf.sprintf "\n\t%s ret;" t.ftype) (* Get the return type *) let get_ret t = if ((t.ftype = "void") || (t.ftype = "GLvoid")) then "" else (Printf.sprintf "ret = ") (* Pass the return type back to OCaml*) let make_ret t = if ((t.ftype = "void") || (t.ftype = "GLvoid")) then "\n\tresult = Val_unit;" else (Printf.sprintf "\n\tresult = %s(ret);" (translate_val t.ftype)) (* Is it a void function? *) let is_void t = if (((Array.length t.fparams) = 1) && (t.fparams.(0).ptype = "GLvoid") || (t.fparams.(0).ptype = "void")) then true else false;; (* Make the actual stub C code *) let make_c_func t = let cnt = (Array.length t.fparams) in Printf.sprintf " value glstub_%s(%s) { %s CAMLlocal1(result); %s%s if(stub_%s){%s(*stub_%s)(%s);} else { if(!loaded_%s) { init_lib(); stub_%s=(pstub_%s)get_proc_address(\"%s\"); if(stub_%s){%s(*stub_%s)(%s);} else { FailWith(\"Cannot load %s\"); } } else { FailWith(\"%s not available\"); } }%s CAMLreturn (result); } " t.fname (make_c_params cnt) (make_caml_params cnt) (if (is_void t) then "" else (make_local_params t) ) (decl_ret t) t.fname (get_ret t) t.fname (if (is_void t) then "" else (make_local_c_params cnt) ) t.fname t.fname t.fname t.fname t.fname (get_ret t) t.fname (if (is_void t) then "" else (make_local_c_params cnt) ) t.fname t.fname (make_ret t);; (* Makes a byte-code function *) let make_c_byte t = let nparams = (Array.length t.fparams) in let s = ref "" in if nparams > 5 then begin s := Printf.sprintf "\n\nvalue glstub_%s_byte(value * argv, int n)\n{\n\treturn glstub_%s(argv[0]" t.fname t.fname; for i = 1 to (nparams - 1) do s := !s ^ (Printf.sprintf ", argv[%d]" i); done; s := !s ^ ");\n}\n"; end; !s;; (* Transform a line into C code *) let make_c_stub_line s = if not (is_gl_function s) then "" else let t = get_gl_function s in let comment = make_c_comment t and cdecls = make_c_decls t and cfunc = make_c_func t and cbyte = make_c_byte t in (comment ^ cdecls ^ cfunc ^ cbyte) (* Create c stubs *) let rec make_c_stub s = match s with | [] -> "" | h :: tail -> (make_c_stub_line h) ^ (make_c_stub tail) ;; (* create c constants *) let get_c_constant s = if not (is_gl_constant s) then "" else let t = get_gl_constant s in Printf.sprintf "%s,\n" t.tname (* Make #defines*) let make_c_constant s = if not (is_gl_constant s) then "" else let t = get_gl_constant s in Printf.sprintf "#define %s %s\n" t.tname t.tval let rec make_define_list l = match l with | [] -> "" | h :: tail -> (make_c_constant h) ^ (make_define_list tail) let rec make_constant_array_contents l = match l with | [] -> "" | h :: tail -> (get_c_constant h) ^ (make_constant_array_contents tail) (* Make array of constants *) let make_constant_array l = let s = make_constant_array_contents l in let t = make_define_list l in Printf.sprintf " /* OPenGL #defines */ %s static int gl_constant_array[] = {\n%s\n}; static GLenum get_glenum(int i) { GLenum ret = 0; if(i >= 0 && i< sizeof(gl_constant_array)) { ret = gl_constant_array[i]; } else FailWith(\"Enumeration out of bounds\"); return ret; } value glstub_glenum_of_int(value v) { CAMLparam1(v); int lv = Int_val(v); int ret = -1; int i = 0; for(i=0; i< sizeof(gl_constant_array); i++ ) { if(gl_constant_array[i] == lv)ret = i; } if(ret == -1)failwith(\"Unknown glEnum\"); CAMLreturn (Val_int(ret)); } value glstub_int_of_glenum(value v) { CAMLparam1(v); int i = Int_val(v); GLenum ret = 0; if(i >= 0 && i< sizeof(gl_constant_array)) { ret = gl_constant_array[i]; } else FailWith(\"Enumeration out of bounds\"); CAMLreturn(Int_val(ret)); } " t s;; (*************************************************************************) (* ML prologue *) let prologue_ml = " (* * GLCaml - Objective Caml interface for OpenGL 1.1, 1.2, 1.3, 1.4, 1.5 and 2.0 * and the following extensions: * GL_ARB_imaging * GL_ARB_matrix_palette * GL_ARB_multitexture * GL_ARB_vertex_blend * GL_ATI_envmap_bumpmap * GL_ATI_map_object_buffer * GL_ATI_pn_triangles * GL_ATI_separate_stencil * GL_ATI_texture_compression_3dc * GL_ATI_vertex_streams * GL_ATIX_point_sprites * GL_ATIX_texture_env_combine3 * GL_ATIX_texture_env_route * GL_ATIX_vertex_shader_output_point_size * GL_EXT_Cg_shader * GL_EXT_depth_bounds_test * GL_EXT_draw_range_elements * GL_EXT_fog_coord * GL_EXT_pixel_buffer_object * GL_EXT_secondary_color * GL_EXT_texture_cube_map * GL_EXT_texture_edge_clamp * GL_EXT_texture_rectangle * GL_EXT_vertex_shader * GL_KTX_buffer_region * GL_NV_fragment_program2 * GL_NV_fragment_program_option * GL_NV_vertex_program2_option * GL_NV_vertex_program3 * * * Copyright (C) 2006 Elliott OTI * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License version 2, as published by the Free Software Foundation. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * See the GNU Library General Public License version 2 for more details * (enclosed in the file LGPL). *) type glpointer type byte_array = (int, Bigarray.int8_signed_elt, Bigarray.c_layout) Bigarray.Array1.t type ubyte_array = (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t type short_array = (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t type ushort_array = (int, Bigarray.int16_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t type int_array = (int, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t type float_array = (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t type double_array = (float, Bigarray.float64_elt, Bigarray.c_layout) Bigarray.Array1.t type byte_matrix = (int, Bigarray.int8_signed_elt, Bigarray.c_layout) Bigarray.Array2.t ";; let decl_extra = "external glenum_of_int : int -> glenum = \"glstub_glenum_of_int\" external set_failwith : bool -> unit = \"glstub_set_failwith\" external int_of_glenum : glenum -> int = \"glstub_int_of_glenum\" " (* Turn the glEnums into ML types*) let rec make_ml_constant l = match l with | [] -> "" | h :: tail -> let s = if (is_gl_constant h) then let c = (get_gl_constant h) in "\n| " ^ c.tname else "" in s ^ (make_ml_constant tail);; let make_ml_constants l = "type glenum = " ^ (make_ml_constant l) ^ "\n\n";; let make_ml_params l = let s = ref (translate_ml l.(0).ptype) in let len = (Array.length l) in for i = 1 to (len - 1) do s := !s ^ " -> " ^ (translate_ml l.(i).ptype); done; !s;; let make_ml_bytefunction t = if (Array.length t.fparams > 5) then (Printf.sprintf " \"glstub_%s_byte\"" t.fname) else "" let make_ml_function s = if not (is_gl_function s) then "" else let t = get_gl_function s in let mlname = t.fname and mltype = (translate_ml t.ftype) in Printf.sprintf "external %s : %s -> %s = \"glstub_%s\"%s\n" mlname (make_ml_params t.fparams) mltype mlname (make_ml_bytefunction t);; let rec make_ml_functions l = match l with | [] -> "" | h :: tail -> (make_ml_function h) ^ make_ml_functions tail;; (**************************** main ***************************************) let main () = let f = Sys.argv.(1) in let lines = readfile f in let c_stubs = (prologue_c ^ (make_constant_array lines) ^ (make_c_stub lines)) and ml_stubs = (prologue_ml ^ (make_ml_constants lines) ^ (decl_extra) ^ (make_ml_functions lines)) in write_file c_stubs (f ^ "_stub.c"); write_file ml_stubs (f ^ ".ml"); in main ()