├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── dune-project ├── examples └── libui │ ├── Makefile │ ├── controlgallery │ ├── controlgallery.ml │ └── dune │ ├── desc.ml │ ├── doc │ ├── gtk.png │ └── osx.png │ ├── dune │ ├── libui_box.c │ ├── libui_button.c │ ├── libui_checkbox.c │ ├── libui_color_button.c │ ├── libui_combobox.c │ ├── libui_control.c │ ├── libui_date_time_picker.c │ ├── libui_editable_combobox.c │ ├── libui_entry.c │ ├── libui_font_button.c │ ├── libui_form.c │ ├── libui_grid.c │ ├── libui_group.c │ ├── libui_label.c │ ├── libui_manual.c │ ├── libui_menu.c │ ├── libui_menu_item.c │ ├── libui_multiline_entry.c │ ├── libui_progressbar.c │ ├── libui_radio_buttons.c │ ├── libui_separator.c │ ├── libui_slider.c │ ├── libui_spinbox.c │ ├── libui_tab.c │ └── libui_window.c ├── gen ├── META ├── Makefile ├── c.ml ├── dune ├── id.ml ├── id.mli ├── ml.ml ├── model.ml └── model.mli └── lib ├── META ├── Makefile ├── dune ├── goo.ml ├── goo.mli ├── goo_ref.ml ├── goo_ref.mli ├── goo_system.c ├── goo_system.h ├── ml_goo.c └── ml_goo.h /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Frédéric Bour 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | 4 | clean: 5 | dune clean 6 | 7 | .PHONY: all clean 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Goo: Cross-runtime object interface generation 2 | 3 | _Goo is experimental_. 4 | 5 | Goo is a tool for writing high-level bindings. GUI toolkits are a natural use-case, but it is suitable for other libraries managing complex state and control flow, especially if they have an object-oriented interface. 6 | 7 | [Ctypes](https://github.com/ocamllabs/ocaml-ctypes) is effective for low-level FFI and fine grained manipulation of memory. However tracking objects lifetimes and relations is hard. 8 | 9 | Goo focus on this part of the problem: while losing some of the flexibility and efficiency of low-level bindings, it tracks and restrict the shape of the heap graph to offer cheap, type-safe and memory-safe bindings. 10 | 11 | ## Approach 12 | 13 | The core of Goo is an object model that is well suited for describing the structure of object graphs (e.g. relations of widgets in a window). It has a simple feature set that maps well to mainstream object languages. 14 | 15 | A binding starts with a description (see [libui](examples/libui/desc.ml) example) of an object graph. This graph is consumed by two code generators: one for the interface, one for the implementation. A C API is used as the "rendez-vous" point between both generators. 16 | 17 | Right now the interface generator produces OCaml code and the implementation generator a subset of C that encodes some more guarantees than usual C code, but it still compatible with a normal C compiler. 18 | 19 | # Examples 20 | 21 | For quick'n'dirty results, a Goo [description](examples/libui/desc.ml) of [libui](https://github.com/andlabs/libui) was written to illustrate the workflow: 22 | 23 | ![Libui bindings running on Gtk](examples/libui/doc/gtk.png?raw=true "OCaml/Goo/Libui/Gtk") 24 | ![Libui bindings running on OS X](examples/libui/doc/osx.png?raw=true "OCaml/Goo/Libui/OSX") 25 | 26 | # TODO 27 | 28 | - implement multiple return values 29 | - should exception management be part of event definitions ? (... yes) 30 | - ctypes integration 31 | 32 | # Future work 33 | 34 | There is nothing OCaml specific in Goo semantics. Adding backends for other languages should be a reasonable amount of work. 35 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | -------------------------------------------------------------------------------- /examples/libui/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | 4 | clean: 5 | dune clean 6 | 7 | .PHONY: all clean 8 | -------------------------------------------------------------------------------- /examples/libui/controlgallery/controlgallery.ml: -------------------------------------------------------------------------------- 1 | open Libui 2 | 3 | let make_basic_controls_page () = 4 | let hbox = 5 | let hbox = box_new_horizontal () in 6 | box_set_padded hbox true; 7 | box_append hbox (button_new "Button") false; 8 | box_append hbox (checkbox_new "Checkbox") false; 9 | box_append hbox (label_new "This is a label. Right now, labels can only span one line.") false; 10 | box_append hbox (separator_new_horizontal ()) false; 11 | hbox 12 | in 13 | let group = 14 | let group = group_new "Entries" in 15 | group_set_margined group true; 16 | let entry_form = form_new () in 17 | form_set_padded entry_form true; 18 | group_child_connect group entry_form; 19 | form_append entry_form "Entry" (entry_new ()) false; 20 | form_append entry_form "Password Entry" (entry_new_password ()) false; 21 | form_append entry_form "Search Entry" (entry_new_search ()) false; 22 | form_append entry_form "Multiline Entry" (multiline_entry_new true) true; 23 | form_append entry_form "Multiline Entry No Wrap" (multiline_entry_new false) true; 24 | group 25 | in 26 | let vbox = box_new_vertical() in 27 | box_set_padded vbox true; 28 | box_append vbox hbox false; 29 | box_append vbox group true; 30 | vbox 31 | 32 | let make_numbers_page () = 33 | let hbox = box_new_horizontal () in 34 | box_set_padded hbox true; 35 | let group = group_new "Numbers" in 36 | group_set_margined group true; 37 | box_append hbox group true; 38 | 39 | let vbox = box_new_vertical () in 40 | box_set_padded vbox true; 41 | group_child_connect group vbox; 42 | 43 | let spinbox = spinbox_new 0 100 in 44 | let slider = slider_new 0 100 in 45 | let pbar = progressbar_new () in 46 | Goo.set_event spinbox event_spinbox_changed (fun self -> 47 | slider_set_value slider (spinbox_value self); 48 | progressbar_set_value pbar (spinbox_value self) 49 | ); 50 | Goo.set_event slider event_slider_changed (fun self -> 51 | spinbox_set_value spinbox (slider_value self); 52 | progressbar_set_value pbar (slider_value self) 53 | ); 54 | box_append vbox spinbox false; 55 | box_append vbox slider false; 56 | box_append vbox pbar false; 57 | 58 | let ip = progressbar_new () in 59 | progressbar_set_value ip (-1); 60 | box_append vbox ip false; 61 | 62 | let group = group_new "Lists" in 63 | group_set_margined group true; 64 | box_append hbox group true; 65 | 66 | let vbox = box_new_vertical () in 67 | box_set_padded vbox true; 68 | group_child_connect group vbox; 69 | 70 | let cbox = combobox_new () in 71 | combobox_append cbox "Combobox Item 1"; 72 | combobox_append cbox "Combobox Item 2"; 73 | combobox_append cbox "Combobox Item 3"; 74 | box_append vbox cbox false; 75 | 76 | let ecbox = editable_combobox_new () in 77 | editable_combobox_append ecbox "Editable Item 1"; 78 | editable_combobox_append ecbox "Editable Item 2"; 79 | editable_combobox_append ecbox "Editable Item 3"; 80 | box_append vbox ecbox false; 81 | 82 | let rb = radio_buttons_new () in 83 | radio_buttons_append rb "Radio Button 1"; 84 | radio_buttons_append rb "Radio Button 2"; 85 | radio_buttons_append rb "Radio Button 3"; 86 | box_append vbox rb false; 87 | hbox 88 | 89 | (*static void onOpenFileClicked(uiButton *b, void *data) 90 | { 91 | uiEntry *entry = uiEntry(data); 92 | char *filename; 93 | 94 | filename = uiOpenFile(mainwin); 95 | if (filename == NULL) { 96 | uiEntrySetText(entry, "(cancelled)"); 97 | return; 98 | } 99 | uiEntrySetText(entry, filename); 100 | uiFreeText(filename); 101 | } 102 | 103 | static void onSaveFileClicked(uiButton *b, void *data) 104 | { 105 | uiEntry *entry = uiEntry(data); 106 | char *filename; 107 | 108 | filename = uiSaveFile(mainwin); 109 | if (filename == NULL) { 110 | uiEntrySetText(entry, "(cancelled)"); 111 | return; 112 | } 113 | uiEntrySetText(entry, filename); 114 | uiFreeText(filename); 115 | } 116 | 117 | static void onMsgBoxClicked(uiButton *b, void *data) 118 | { 119 | uiMsgBox(mainwin, 120 | "This is a normal message box.", 121 | "More detailed information can be shown here."); 122 | } 123 | 124 | static void onMsgBoxErrorClicked(uiButton *b, void *data) 125 | { 126 | uiMsgBoxError(mainwin, 127 | "This message box describes an error.", 128 | "More detailed information can be shown here."); 129 | }*) 130 | 131 | let make_data_choosers_page mainwin = 132 | let hbox = box_new_horizontal () in 133 | box_set_padded hbox true; 134 | let vbox = box_new_vertical () in 135 | box_set_padded vbox true; 136 | box_append hbox vbox false; 137 | box_append vbox (date_time_picker_new_date ()) false; 138 | box_append vbox (date_time_picker_new_time ()) false; 139 | box_append vbox (date_time_picker_new ()) false; 140 | box_append vbox (font_button_new ()) false; 141 | let cb = color_button_new () in 142 | box_append vbox cb false; 143 | Goo.set_event cb event_color_button_changed (fun self -> 144 | let r,g,b,a = color_button_get_color self in 145 | Printf.printf "picked color (%.00f%%,%.00f%%,%.00f%%,%.00f%%)\n%!" 146 | (r *. 100.0) (g *. 100.0) (b *. 100.0) (a *. 100.0) 147 | ); 148 | box_append hbox (separator_new_vertical ()) false; 149 | 150 | let vbox = box_new_vertical () in 151 | box_set_padded vbox true; 152 | box_append hbox vbox true; 153 | 154 | let grid = grid_new () in 155 | grid_set_padded grid true; 156 | box_append vbox grid false; 157 | 158 | let button = button_new "Open File" in 159 | let entry = entry_new () in 160 | entry_set_readonly entry true; 161 | Goo.set_event button event_button_clicked (fun _self -> 162 | let filename = open_file mainwin in 163 | entry_set_text entry (if filename = "" then "(cancelled)" else filename); 164 | raise Exit 165 | ); 166 | grid_append grid button 0 0 1 1 false `Fill false `Fill; 167 | grid_append grid entry 1 0 1 1 true `Fill false `Fill; 168 | 169 | let button = button_new "Save File" in 170 | let entry = entry_new () in 171 | entry_set_readonly entry true; 172 | Goo.set_event button event_button_clicked (fun _self -> 173 | let filename = save_file mainwin in 174 | entry_set_text entry (if filename = "" then "(cancelled)" else filename); 175 | failwith "lol" 176 | ); 177 | grid_append grid button 0 1 1 1 false `Fill false `Fill; 178 | grid_append grid entry 1 1 1 1 true `Fill false `Fill; 179 | 180 | let msggrid = grid_new () in 181 | grid_set_padded msggrid true; 182 | grid_append grid msggrid 0 2 2 1 false `Center false `Start; 183 | 184 | let button = button_new "Message Box" in 185 | Goo.set_event button event_button_clicked (fun _self -> 186 | msg_box mainwin 187 | "This is a normal message box." 188 | "More detailed information can be shown here."; 189 | "hoho" 190 | ); 191 | grid_append msggrid button 0 0 1 1 false `Fill false `Fill; 192 | let button = button_new "Error Box" in 193 | Goo.set_event button event_button_clicked (fun _self -> 194 | msg_box_error mainwin 195 | "This message box describes an error." 196 | "More detailed information can be shown here."; 197 | "hihi" 198 | ); 199 | grid_append msggrid button 1 0 1 1 false `Fill false `Fill; 200 | hbox 201 | ;; 202 | 203 | (*static int onShouldQuit(void *data) 204 | { 205 | uiWindow *mainwin = uiWindow(data); 206 | 207 | uiControlDestroy(uiControl(mainwin)); 208 | return 1; 209 | }*) 210 | 211 | let main () = 212 | begin match init () with 213 | | "" -> () 214 | | err -> failwith err 215 | end; 216 | let mainwin = window_new "OCaml goo/libui Control Gallery" 640 480 true in 217 | Goo.set_event mainwin event_window_closing (fun _self -> 218 | quit () 219 | ); 220 | (*uiOnShouldQuit(onShouldQuit, mainwin);*) 221 | 222 | let tab = tab_new () in 223 | window_child_connect mainwin tab; 224 | window_set_margined mainwin true; 225 | 226 | tab_append tab "Basic Controls" (make_basic_controls_page ()); 227 | tab_set_tab_margined tab 0 true; 228 | 229 | tab_append tab "Numbers and Lists" (make_numbers_page ()); 230 | tab_set_tab_margined tab 0 true; 231 | tab_set_tab_margined tab 1 true; 232 | 233 | tab_append tab "Data Choosers" (make_data_choosers_page mainwin); 234 | tab_set_tab_margined tab 2 true; 235 | 236 | control_show mainwin; 237 | main () 238 | 239 | let () = main () 240 | -------------------------------------------------------------------------------- /examples/libui/controlgallery/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name controlgallery) 3 | (libraries goo_libui)) 4 | -------------------------------------------------------------------------------- /examples/libui/desc.ml: -------------------------------------------------------------------------------- 1 | open Goo_gen 2 | open Model 3 | 4 | (* Some generic definitions to help binding libui *) 5 | 6 | (* A self_meth is a method that takes an instance of self as the first argument. *) 7 | let self_meth cl ret name args = 8 | meth cl ret name (arg "self" (objet cl) :: args) 9 | 10 | (* The `'` variant returns an abstract name that identifies the method: 11 | val self_meth : classe -> ... -> unit 12 | val self_meth' : classe -> ... -> func 13 | *) 14 | let self_meth' cl ret name args = 15 | meth' cl ret name (arg "self" (objet cl) :: args) 16 | 17 | (* A constructor is a method that returns an instance but doesn't take it as 18 | first argument. *) 19 | let constructor cl name args = 20 | C.set_concrete cl; 21 | meth cl [objet cl] name args 22 | 23 | (* A (boolean) property is a pair of methods: one to set, one to get. *) 24 | let prop cl name = 25 | self_meth cl [bool] ("is_" ^ name) []; 26 | self_meth cl [] ("set_" ^ name) [arg name bool] 27 | 28 | (* -- Declaration begins here. 29 | `val ui : package` will be the abstract name that identifies the libui package. 30 | *) 31 | let ui = package "libui" 32 | 33 | (* Some toplevel function definitions *) 34 | let () = 35 | (* The C compiler needs to know about the libui headers. 36 | However this is a specific knowledge that the ML interface generator 37 | doesn't need to know about. 38 | `Goo_model` is about declaring the shared parts. Entities of the model 39 | are given abstract name. Specific knowledge can then be added 40 | per-backend. *) 41 | C.package_declare ui ["#include \"ui.h\""]; 42 | (* A function declaration is read in the "C" order: 43 | func ; 44 | 45 | Multiple return types are allowed: 46 | - an empty list maps to "void" 47 | - a singleton maps to a normal C return-type 48 | - a tuple maps to a list of pointers that are expected to be filled by the 49 | C function. 50 | 51 | func math [float;float] "transpose" [arg "re" float; arg "im" float] 52 | 53 | maps to 54 | void math_transpose(double re, double im, double *ret0, double *ret1) 55 | val math_transpose : float -> float -> float * float 56 | *) 57 | func ui [string] "init" []; 58 | func ui [] "uninit" []; 59 | func ui [] "main" []; 60 | func ui [] "main_steps" []; 61 | func ui [int] "main_step" [arg "wait" int]; 62 | func ui [] "quit" [] 63 | 64 | (* The root of libui class hierarchy. *) 65 | let control = classe ui "control" 66 | 67 | let () = 68 | (* All classe inherits from "goo_object", which is part of the runtime 69 | support library. 70 | The only method declared by "goo_object" is destroy. This is a dynamic 71 | method (dispatched based on the actual class of its first argument) that 72 | can be given a more specific definition by sub-classes. 73 | But dynamicity and redefinition are implementation details and don't 74 | affect the interface. Hence, override only matters to C backend. 75 | *) 76 | C.override control goo_destroy; 77 | (* A control object is just a wrapper around uiControl: each instance 78 | contains a control field that points to the actual control. 79 | Like dynamic dispatch information, instance variables only matter to the 80 | implementation. They are not exposed in the interface. 81 | *) 82 | C.instance_variable control "control" (Custom "uiControl *"); 83 | (* uintptr_t uiControlHandle(uiControl * ); *) 84 | (* Other basic methods. *) 85 | self_meth control [bool] "is_toplevel" []; 86 | self_meth control [bool] "is_visible" []; 87 | self_meth control [] "show" []; 88 | self_meth control [] "hide" []; 89 | self_meth control [bool] "is_enabled" []; 90 | self_meth control [] "enable" []; 91 | self_meth control [] "disable" [] 92 | 93 | (* Relations. 94 | The structure of object graph is made explicit by the use of relations. 95 | There are three concepts of relations: port, slots and collections. 96 | 97 | A port is the endpoint of a relation. It can be empty (mapped to NULL / 98 | None) or connected to a slot or a collection. 99 | The declaration below reads "a control can have a single `parent` which is 100 | itself a control." 101 | A slot can connect to zero or one port. 102 | A collection can connect to zero or many ports. 103 | 104 | For instance, a window has a slot which is the root widget. A list layout 105 | has a collection, the sequence of all widgets that are listed. 106 | 107 | Symmetry is enforced: if button is the children of window, then window 108 | will be the parent of button. 109 | 110 | A last case of graph structure is captured: when one declares an 111 | instance_variable of type (Object ...), the GC will be notified. However 112 | this won't appear in the interface. 113 | 114 | Together, the "symmetric" port, slot and collection and the anonymous 115 | variable allow to capture all graph shapes, while ensuring safety and 116 | friendly programming style (wellformed-ness of the graph is ensured). 117 | The cost is that these relations must be declared upfront. 118 | *) 119 | let control_parent = port control "parent" control 120 | 121 | let window = classe ui "window" ~extend:control 122 | 123 | let () = 124 | self_meth window [string] "title" []; 125 | self_meth window [] "set_title" [arg "title" string]; 126 | (*self_meth window [int; int] "content_size" [];*) 127 | self_meth window [] "set_content_size" [arg "width" int; arg "height" int]; 128 | prop window "fullscreen"; 129 | prop window "borderless"; 130 | (* Events. 131 | Events allow control to call back to the interface language. 132 | Each event is an optional closure that can be set from ML. *) 133 | event window [] "content_size_changed" []; 134 | event window [] "closing" []; 135 | (* The C backend allows C-code to be notified when a slot is disconnected. 136 | The method "on_child_disconnect" will be invoked. The abstract names 137 | returned by slot' and self_meth' are used to connect both. 138 | *) 139 | C.on_slot_disconnect 140 | (slot' window "child" control_parent) 141 | (self_meth' window [] "on_child_disconnect" ["object", objet control]); 142 | self_meth window [] "child_connect" [arg "val" (objet control)]; 143 | prop window "margined"; 144 | constructor window "new" 145 | [arg "title" string; arg "width" int; arg "height" int; arg "has_menubar" bool] 146 | 147 | (* The rest of the file just builds on these concepts to bind the rest of the API. 148 | Jump to the last lines for the end of the introduction. *) 149 | 150 | let button = classe ui "button" ~extend:control 151 | 152 | let () = 153 | self_meth button [string] "text" []; 154 | self_meth button [] "set_text" [arg "text" string]; 155 | event button [string] "clicked" []; 156 | constructor button "new" [arg "text" string] 157 | 158 | let box = classe ui "box" ~extend:control 159 | 160 | let () = 161 | collection box "children" control_parent; 162 | self_meth box [] "append" [arg "child" (objet control); arg "stretchy" bool]; 163 | prop box "padded"; 164 | constructor box "new_horizontal" []; 165 | constructor box "new_vertical" [] 166 | 167 | let checkbox = classe ui "checkbox" ~extend:control 168 | 169 | let ()= 170 | self_meth checkbox [string] "text" []; 171 | self_meth checkbox [] "set_text" [arg "text" string]; 172 | event checkbox [] "toggled" []; 173 | prop checkbox "checked"; 174 | constructor checkbox "new" [arg "text" string] 175 | 176 | let entry = classe ui "entry" ~extend:control 177 | 178 | let () = 179 | self_meth entry [string] "text" []; 180 | self_meth entry [] "set_text" [arg "text" string]; 181 | event entry [] "changed" []; 182 | prop entry "readonly"; 183 | constructor entry "new" []; 184 | constructor entry "new_password" []; 185 | constructor entry "new_search" [] 186 | 187 | let label = classe ui "label" ~extend:control 188 | 189 | let () = 190 | self_meth label [string] "text" []; 191 | self_meth label [] "set_text" [arg "text" string]; 192 | constructor label "new" [arg "text" string] 193 | 194 | let tab = classe ui "tab" ~extend:control 195 | 196 | let () = 197 | self_meth tab [int] "num_pages" []; 198 | collection tab "tabs" control_parent; 199 | self_meth tab [] "append" [arg "name" string; arg "child" (objet control)]; 200 | self_meth tab [] "insert_at" [arg "name" string; arg "before" int; arg "child" (objet control)]; 201 | self_meth tab [bool] "is_tab_margined" [arg "page" int]; 202 | self_meth tab [] "set_tab_margined" [arg "page" int; arg "margined" bool]; 203 | constructor tab "new" [] 204 | 205 | let group = classe ui "group" ~extend:control 206 | 207 | let () = 208 | self_meth group [string] "title" []; 209 | self_meth group [] "set_title" [arg "title" string]; 210 | self_meth group [] "child_connect" [arg "val" (objet control)]; 211 | C.on_slot_disconnect 212 | (slot' group "child" control_parent) 213 | (self_meth' group [] "on_child_disconnect" ["object", objet control]); 214 | prop group "margined"; 215 | constructor group "new" [arg "title" string] 216 | 217 | let spinbox = classe ui "spinbox" ~extend:control 218 | 219 | let () = 220 | self_meth spinbox [int] "value" []; 221 | self_meth spinbox [] "set_value" [arg "value" int]; 222 | event spinbox [] "changed" []; 223 | constructor spinbox "new" [arg "min" int; arg "max" int] 224 | 225 | let slider = classe ui "slider" ~extend:control 226 | 227 | let () = 228 | self_meth slider [int] "value" []; 229 | self_meth slider [] "set_value" [arg "value" int]; 230 | event slider [] "changed" []; 231 | constructor slider "new" [arg "min" int; arg "max" int] 232 | 233 | let slider = classe ui "progressbar" ~extend:control 234 | 235 | let () = 236 | self_meth slider [int] "value" []; 237 | self_meth slider [] "set_value" [arg "value" int]; 238 | constructor slider "new" [] 239 | 240 | let separator = classe ui "separator" ~extend:control 241 | 242 | let () = 243 | constructor separator "new_horizontal" []; 244 | constructor separator "new_vertical" [] 245 | 246 | let combobox = classe ui "combobox" ~extend:control 247 | 248 | let () = 249 | self_meth combobox [] "append" [arg "text" string]; 250 | self_meth combobox [int] "selected" []; 251 | self_meth combobox [] "set_selected" [arg "selected" int]; 252 | event combobox [] "selected" []; 253 | constructor combobox "new" [] 254 | 255 | let editable_combobox = classe ui "editable_combobox" ~extend:control 256 | 257 | let () = 258 | self_meth editable_combobox [] "append" [arg "text" string]; 259 | self_meth editable_combobox [string] "text" []; 260 | self_meth editable_combobox [] "set_text" [arg "text" string]; 261 | event editable_combobox [] "changed" []; 262 | constructor editable_combobox "new" [] 263 | 264 | let radio_buttons = classe ui "radio_buttons" ~extend:control 265 | 266 | let () = 267 | self_meth radio_buttons [] "append" [arg "text" string]; 268 | self_meth radio_buttons [int] "selected" []; 269 | self_meth radio_buttons [] "set_selected" [arg "selected" int]; 270 | event radio_buttons [] "selected" []; 271 | constructor radio_buttons "new" [] 272 | 273 | let date_time_picker = classe ui "date_time_picker" ~extend:control 274 | 275 | let () = 276 | constructor date_time_picker "new" []; 277 | constructor date_time_picker "new_date" []; 278 | constructor date_time_picker "new_time" [] 279 | 280 | let multiline_entry = classe ui "multiline_entry" ~extend:control 281 | 282 | let () = 283 | self_meth multiline_entry [string] "text" []; 284 | self_meth multiline_entry [] "set_text" [arg "text" string]; 285 | self_meth multiline_entry [] "append" [arg "text" string]; 286 | event multiline_entry [] "changed" []; 287 | prop multiline_entry "readonly"; 288 | constructor multiline_entry "new" [arg "wrap" bool] 289 | 290 | let menu = classe ui "menu" 291 | 292 | let menu_item = classe ui "menu_item" 293 | 294 | let () = 295 | C.instance_variable menu_item "control" (Custom "uiMenuItem *"); 296 | self_meth menu_item [] "enable" []; 297 | self_meth menu_item [] "disable" []; 298 | event menu_item [] "clicked" []; 299 | prop menu_item "checked"; 300 | constructor menu_item "new" [arg "item" (Custom "uiMenuItem *")] 301 | 302 | let menu_item_parent = port menu_item "parent" menu 303 | 304 | let () = 305 | C.instance_variable menu "control" (Custom "uiMenu *"); 306 | collection menu "items" menu_item_parent; 307 | self_meth menu [objet menu_item] "append_item" [arg "name" string]; 308 | self_meth menu [objet menu_item] "append_check_item" [arg "name" string]; 309 | self_meth menu [objet menu_item] "append_quit_item" []; 310 | self_meth menu [objet menu_item] "append_preferences_item" []; 311 | self_meth menu [objet menu_item] "append_about_item" []; 312 | self_meth menu [] "append_separator" []; 313 | constructor menu "new" [arg "name" string] 314 | 315 | let () = 316 | func ui [string] "open_file" [arg "parent" (objet window)]; 317 | func ui [string] "save_file" [arg "parent" (objet window)]; 318 | func ui [] "msg_box" [arg "parent" (objet window); arg "title" string; arg "description" string]; 319 | func ui [] "msg_box_error" [arg "parent" (objet window); arg "title" string; arg "description" string] 320 | 321 | let font_button = classe ui "font_button" ~extend:control 322 | 323 | let () = 324 | (*_UI_EXTERN uiDrawTextFont *uiFontButtonFont(uiFontButton *b);*) 325 | event font_button [] "changed" []; 326 | constructor font_button "new" [] 327 | 328 | let color_button = classe ui "color_button" ~extend:control 329 | 330 | let () = 331 | self_meth color_button [float; float; float; float] "get_color" []; 332 | self_meth color_button [] "set_color" [arg "r" float; arg "g" float; arg "b" float; arg "a" float]; 333 | event color_button [] "changed" []; 334 | constructor color_button "new" [] 335 | 336 | let form = classe ui "form" ~extend:control 337 | 338 | let () = 339 | collection form "children" control_parent; 340 | self_meth form [] "append" [arg "name" string; arg "c" (objet control); arg "stretchy" bool]; 341 | self_meth form [] "delete" [arg "child" (objet control)]; 342 | prop form "padded"; 343 | constructor form "new" [] 344 | 345 | let align = enum ui "align" 346 | let () = List.iter (enum_member align) ["Fill"; "Start"; "Center"; "End"] 347 | 348 | let at = enum ui "at" 349 | let () = List.iter (enum_member at) ["Leading"; "Top"; "Trailing"; "Bottom"] 350 | 351 | let grid = classe ui "grid" ~extend:control 352 | 353 | let () = 354 | collection grid "children" control_parent; 355 | self_meth grid [] "append" [ 356 | arg "c" (objet control); 357 | arg "left" int; arg "top" int; 358 | arg "xspan" int; arg "yspan" int; 359 | arg "hexpand" bool; arg "halign" (flag align); 360 | arg "vexpand" bool; arg "valign" (flag align); 361 | ]; 362 | self_meth grid [] "insert_at" [ 363 | arg "c" (objet control); 364 | arg "existing" (objet control); arg "at" (flag at); 365 | arg "xspan" int; arg "yspan" int; 366 | arg "hexpand" bool; arg "halign" (flag align); 367 | arg "vexpand" bool; arg "valign" (flag align); 368 | ]; 369 | prop grid "padded"; 370 | constructor grid "new" [] 371 | 372 | (* The model and backends have now been fed with the description of library. 373 | We can tell the generators to start their work. *) 374 | let () = 375 | (* The C generator will produce 376 | - libui.h for shared definitions 377 | - for each class, a file libui_.h that contains private definitions. 378 | Template files libui_manual.c libui_.c are generated if they don't 379 | already exist with the skeleton of the implementation. In most cases this 380 | implementation should be filled manually. 381 | *) 382 | C.generate ui ~dir:"./"; 383 | (* The ML generator will produce libui_stubs.c and libui.ml that binds the 384 | model above to OCaml runtime. Nothing has to be written manually. *) 385 | Ml.generate ui ~dir:"./" 386 | ;; 387 | -------------------------------------------------------------------------------- /examples/libui/doc/gtk.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/goo/98a49bcf1dc511d77ffdfa0fdb9a834b29dc704d/examples/libui/doc/gtk.png -------------------------------------------------------------------------------- /examples/libui/doc/osx.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/let-def/goo/98a49bcf1dc511d77ffdfa0fdb9a834b29dc704d/examples/libui/doc/osx.png -------------------------------------------------------------------------------- /examples/libui/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name goo_libui) 3 | (modules libui) 4 | (libraries goo) 5 | (c_library_flags (-lui)) 6 | (wrapped false) 7 | (foreign_stubs 8 | (language c) 9 | (names libui_box 10 | libui_button 11 | libui_checkbox 12 | libui_color_button 13 | libui_combobox 14 | libui_control 15 | libui_date_time_picker 16 | libui_editable_combobox 17 | libui_entry 18 | libui_font_button 19 | libui_form 20 | libui_grid 21 | libui_group 22 | libui_label 23 | libui_manual 24 | libui_menu 25 | libui_menu_item 26 | libui_multiline_entry 27 | libui_progressbar 28 | libui_radio_buttons 29 | libui_separator 30 | libui_slider 31 | libui_spinbox 32 | libui_tab 33 | libui_window 34 | libui_stubs))) 35 | 36 | (executable 37 | (name desc) 38 | (modules desc) 39 | (libraries goo_gen)) 40 | 41 | (rule 42 | (deps desc.ml 43 | libui_box.c 44 | libui_button.c 45 | libui_checkbox.c 46 | libui_color_button.c 47 | libui_combobox.c 48 | libui_control.c 49 | libui_date_time_picker.c 50 | libui_editable_combobox.c 51 | libui_entry.c 52 | libui_font_button.c 53 | libui_form.c 54 | libui_grid.c 55 | libui_group.c 56 | libui_label.c 57 | libui_manual.c 58 | libui_menu.c 59 | libui_menu_item.c 60 | libui_multiline_entry.c 61 | libui_progressbar.c 62 | libui_radio_buttons.c 63 | libui_separator.c 64 | libui_slider.c 65 | libui_spinbox.c 66 | libui_tab.c 67 | libui_window.c) 68 | (targets libui.h 69 | libui.ml 70 | libui_box.h 71 | libui_button.h 72 | libui_checkbox.h 73 | libui_color_button.h 74 | libui_combobox.h 75 | libui_control.h 76 | libui_date_time_picker.h 77 | libui_editable_combobox.h 78 | libui_entry.h 79 | libui_font_button.h 80 | libui_form.h 81 | libui_grid.h 82 | libui_group.h 83 | libui_label.h 84 | libui_menu.h 85 | libui_menu_item.h 86 | libui_multiline_entry.h 87 | libui_progressbar.h 88 | libui_radio_buttons.h 89 | libui_separator.h 90 | libui_slider.h 91 | libui_spinbox.h 92 | libui_stubs.c 93 | libui_tab.h 94 | libui_window.h) 95 | (action (run ./desc.exe))) 96 | -------------------------------------------------------------------------------- /examples/libui/libui_box.c: -------------------------------------------------------------------------------- 1 | #include "libui_box.h" 2 | #define WIDGET uiBox($field(self, control)) 3 | 4 | static libui_box *init(uiBox *widget) 5 | { 6 | libui_box *self = $alloc(); 7 | $field(self, control) = uiControl(widget); 8 | return self; 9 | } 10 | 11 | $method libui_box *self_new_vertical(void) 12 | { 13 | return init(uiNewVerticalBox()); 14 | } 15 | 16 | $method libui_box *self_new_horizontal(void) 17 | { 18 | return init(uiNewHorizontalBox()); 19 | } 20 | 21 | $method goo_bool self_is_padded(libui_box *self) 22 | { 23 | return uiBoxPadded(WIDGET); 24 | } 25 | 26 | $method void self_set_padded(libui_box *self, goo_bool padded) 27 | { 28 | uiBoxSetPadded(WIDGET, padded); 29 | } 30 | 31 | $method void self_append(libui_box *self, libui_control *child, goo_bool stretchy) 32 | { 33 | $static(connect,children)(self, child, libui_box_children_last(self)); 34 | uiBoxAppend(WIDGET, $field(child, control), stretchy); 35 | } 36 | -------------------------------------------------------------------------------- /examples/libui/libui_button.c: -------------------------------------------------------------------------------- 1 | #include "libui_button.h" 2 | #define WIDGET uiButton($field(self, control)) 3 | 4 | static void on_clicked(uiButton *b, void *self) 5 | { 6 | goo_string result = null_string; 7 | if ($static(event, clicked)((libui_button*)self, &result)) 8 | puts(goo_string_data(result)); 9 | } 10 | 11 | $method libui_button* self_new(goo_string text) 12 | { 13 | libui_button *self = $alloc(); 14 | $field(self, control) = uiControl(uiNewButton(goo_string_data(text))); 15 | uiButtonOnClicked(WIDGET, on_clicked, self); 16 | return self; 17 | } 18 | 19 | $method void self_set_text(libui_button *self, goo_string text) 20 | { 21 | uiButtonSetText(WIDGET, goo_string_data(text)); 22 | } 23 | 24 | $method goo_string self_text(libui_button *self) 25 | { 26 | return goo_string_from_c(uiButtonText(WIDGET)); 27 | } 28 | -------------------------------------------------------------------------------- /examples/libui/libui_checkbox.c: -------------------------------------------------------------------------------- 1 | #include "libui_checkbox.h" 2 | #define WIDGET uiCheckbox($field(self, control)) 3 | 4 | static void on_toggled(uiCheckbox *b, void *self) 5 | { 6 | $static(event, toggled)((libui_checkbox*)self); 7 | } 8 | 9 | libui_checkbox *self_new(goo_string text) 10 | { 11 | libui_checkbox *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewCheckbox(goo_string_data(text))); 13 | uiCheckboxOnToggled(WIDGET, on_toggled, self); 14 | return self; 15 | } 16 | 17 | goo_bool self_is_checked(libui_checkbox *self) 18 | { 19 | return uiCheckboxChecked(WIDGET); 20 | } 21 | 22 | void self_set_checked(libui_checkbox *self, goo_bool checked) 23 | { 24 | uiCheckboxSetChecked(WIDGET, checked); 25 | } 26 | 27 | void self_set_text(libui_checkbox *self, goo_string text) 28 | { 29 | uiCheckboxSetText(WIDGET, goo_string_data(text)); 30 | } 31 | 32 | goo_string self_text(libui_checkbox *self) 33 | { 34 | return goo_string_from_c(uiCheckboxText(WIDGET)); 35 | } 36 | -------------------------------------------------------------------------------- /examples/libui/libui_color_button.c: -------------------------------------------------------------------------------- 1 | #include "libui_color_button.h" 2 | #define WIDGET uiColorButton($field(self, control)) 3 | 4 | static void on_changed(uiColorButton *b, void *self) 5 | { 6 | $static(event, changed)((libui_color_button*)self); 7 | } 8 | 9 | $method libui_color_button *self_new(void) 10 | { 11 | libui_color_button *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewColorButton()); 13 | uiColorButtonOnChanged(WIDGET, on_changed, self); 14 | return self; 15 | } 16 | 17 | $method void self_set_color(libui_color_button *self, double r, double g, double b, double a) 18 | { 19 | uiColorButtonSetColor(WIDGET, r, g, b, a); 20 | } 21 | 22 | $method void self_get_color(libui_color_button *self, double *ret0, double *ret1, double *ret2, double *ret3) 23 | { 24 | uiColorButtonColor(WIDGET, ret0, ret1, ret2, ret3); 25 | } 26 | -------------------------------------------------------------------------------- /examples/libui/libui_combobox.c: -------------------------------------------------------------------------------- 1 | #include "libui_combobox.h" 2 | #define WIDGET uiCombobox($field(self, control)) 3 | 4 | static void on_selected(uiCombobox *e, void *self) 5 | { 6 | $static(event, selected)((libui_combobox*)self); 7 | } 8 | 9 | $method libui_combobox *self_new(void) 10 | { 11 | libui_combobox *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewCombobox()); 13 | uiComboboxOnSelected(WIDGET, on_selected, self); 14 | return self; 15 | } 16 | 17 | $method void self_set_selected(libui_combobox *self, int selected) 18 | { 19 | uiComboboxSetSelected(WIDGET, selected); 20 | } 21 | 22 | $method int self_selected(libui_combobox *self) 23 | { 24 | return uiComboboxSelected(WIDGET); 25 | } 26 | 27 | $method void self_append(libui_combobox *self, goo_string text) 28 | { 29 | uiComboboxAppend(WIDGET, goo_string_data(text)); 30 | } 31 | -------------------------------------------------------------------------------- /examples/libui/libui_control.c: -------------------------------------------------------------------------------- 1 | #include "libui_control.h" 2 | #define WIDGET $field(self, control) 3 | 4 | $method void self_disable(libui_control *self) 5 | { 6 | uiControlDisable(WIDGET); 7 | } 8 | 9 | $method void self_enable(libui_control *self) 10 | { 11 | uiControlEnable(WIDGET); 12 | } 13 | 14 | $method goo_bool self_is_enabled(libui_control *self) 15 | { 16 | return uiControlEnabled(WIDGET); 17 | } 18 | 19 | $method void self_hide(libui_control *self) 20 | { 21 | uiControlHide(WIDGET); 22 | } 23 | 24 | $method void self_show(libui_control *self) 25 | { 26 | uiControlShow(WIDGET); 27 | } 28 | 29 | $method goo_bool self_is_visible(libui_control *self) 30 | { 31 | return uiControlVisible(WIDGET); 32 | } 33 | 34 | $method goo_bool self_is_toplevel(libui_control *self) 35 | { 36 | return uiControlToplevel(WIDGET); 37 | } 38 | 39 | $method void self_destroy(libui_control *self) 40 | { 41 | uiControlDestroy(WIDGET); 42 | $static(super, destroy)(self); 43 | } 44 | -------------------------------------------------------------------------------- /examples/libui/libui_date_time_picker.c: -------------------------------------------------------------------------------- 1 | #include "libui_date_time_picker.h" 2 | #define WIDGET uiDateTimePicker($field(self, control)) 3 | 4 | static libui_date_time_picker *init(uiDateTimePicker *control) 5 | { 6 | libui_date_time_picker *self = $alloc(); 7 | $field(self, control) = uiControl(control); 8 | return self; 9 | } 10 | 11 | $method libui_date_time_picker *self_new_time(void) 12 | { 13 | return init(uiNewTimePicker()); 14 | } 15 | 16 | $method libui_date_time_picker *self_new_date(void) 17 | { 18 | return init(uiNewDatePicker()); 19 | } 20 | 21 | $method libui_date_time_picker *self_new(void) 22 | { 23 | return init(uiNewDateTimePicker()); 24 | } 25 | -------------------------------------------------------------------------------- /examples/libui/libui_editable_combobox.c: -------------------------------------------------------------------------------- 1 | #include "libui_editable_combobox.h" 2 | #define WIDGET uiEditableCombobox($field(self, control)) 3 | 4 | static void on_changed(uiEditableCombobox *e, void *self) 5 | { 6 | $static(event, changed)((libui_editable_combobox*)self); 7 | } 8 | 9 | $method libui_editable_combobox *self_new(void) 10 | { 11 | libui_editable_combobox *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewEditableCombobox()); 13 | uiEditableComboboxOnChanged(WIDGET, on_changed, self); 14 | return self; 15 | } 16 | 17 | $method void self_set_text(libui_editable_combobox *self, goo_string text) 18 | { 19 | uiEditableComboboxSetText(WIDGET, goo_string_data(text)); 20 | } 21 | 22 | $method goo_string self_text(libui_editable_combobox *self) 23 | { 24 | return goo_string_from_c(uiEditableComboboxText(WIDGET)); 25 | } 26 | 27 | $method void self_append(libui_editable_combobox *self, goo_string text) 28 | { 29 | uiEditableComboboxAppend(WIDGET, goo_string_data(text)); 30 | } 31 | -------------------------------------------------------------------------------- /examples/libui/libui_entry.c: -------------------------------------------------------------------------------- 1 | #include "libui_entry.h" 2 | #define WIDGET uiEntry($field(self, control)) 3 | 4 | static void on_changed(uiEntry *e, void *self) 5 | { 6 | $static(event, changed)((libui_entry*)self); 7 | } 8 | 9 | static libui_entry *init(uiEntry *entry) 10 | { 11 | libui_entry *self = $alloc(); 12 | $field(self, control) = uiControl(entry); 13 | uiEntryOnChanged(WIDGET, on_changed, self); 14 | return self; 15 | } 16 | 17 | $method libui_entry *self_new_search(void) 18 | { 19 | return init(uiNewSearchEntry()); 20 | } 21 | 22 | $method libui_entry *self_new_password(void) 23 | { 24 | return init(uiNewPasswordEntry()); 25 | } 26 | 27 | $method libui_entry *self_new(void) 28 | { 29 | return init(uiNewEntry()); 30 | } 31 | 32 | $method goo_bool self_is_readonly(libui_entry *self) 33 | { 34 | return uiEntryReadOnly(WIDGET); 35 | } 36 | 37 | $method void self_set_readonly(libui_entry *self, goo_bool readonly) 38 | { 39 | uiEntrySetReadOnly(WIDGET, readonly); 40 | } 41 | 42 | $method void self_set_text(libui_entry *self, goo_string text) 43 | { 44 | uiEntrySetText(WIDGET, goo_string_data(text)); 45 | } 46 | 47 | $method goo_string self_text(libui_entry *self) 48 | { 49 | return goo_string_from_c(uiEntryText(WIDGET)); 50 | } 51 | -------------------------------------------------------------------------------- /examples/libui/libui_font_button.c: -------------------------------------------------------------------------------- 1 | #include "libui_font_button.h" 2 | #define WIDGET uiFontButton($field(self, control)) 3 | 4 | static void on_changed(uiFontButton *b, void *self) 5 | { 6 | $static(event, changed)((libui_font_button*)self); 7 | } 8 | 9 | $method libui_font_button *self_new(void) 10 | { 11 | libui_font_button *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewFontButton()); 13 | uiFontButtonOnChanged(WIDGET, on_changed, self); 14 | return self; 15 | } 16 | -------------------------------------------------------------------------------- /examples/libui/libui_form.c: -------------------------------------------------------------------------------- 1 | #include "libui_form.h" 2 | #define WIDGET uiForm($field(self, control)) 3 | 4 | $method libui_form *self_new(void) 5 | { 6 | libui_form *self = $alloc(); 7 | $field(self, control) = uiControl(uiNewForm()); 8 | return self; 9 | } 10 | 11 | $method goo_bool self_is_padded(libui_form *self) 12 | { 13 | return uiFormPadded(WIDGET); 14 | } 15 | 16 | $method void self_set_padded(libui_form *self, goo_bool padded) 17 | { 18 | return uiFormSetPadded(WIDGET, padded); 19 | } 20 | 21 | $method void self_delete(libui_form *self, libui_control *child) 22 | { 23 | int position = -1; 24 | for (libui_control *iter = child; iter; iter = libui_form_children_prev(iter)) 25 | position++; 26 | uiFormDelete(WIDGET, position); 27 | libui_control_parent_disconnect(child); 28 | } 29 | 30 | $method void self_append(libui_form *self, goo_string name, libui_control *c, goo_bool stretchy) 31 | { 32 | $static(connect,children)(self, c, libui_form_children_last(self)); 33 | uiFormAppend(WIDGET, goo_string_data(name), $field(c, control), stretchy); 34 | } 35 | -------------------------------------------------------------------------------- /examples/libui/libui_grid.c: -------------------------------------------------------------------------------- 1 | #include "libui_grid.h" 2 | #define WIDGET uiGrid($field(self, control)) 3 | 4 | $method libui_grid *self_new(void) 5 | { 6 | libui_grid *self = $alloc(); 7 | $field(self, control) = uiControl(uiNewGrid()); 8 | return self; 9 | } 10 | 11 | $method goo_bool self_is_padded(libui_grid *self) 12 | { 13 | return uiGridPadded(WIDGET); 14 | } 15 | 16 | $method void self_set_padded(libui_grid *self, goo_bool padded) 17 | { 18 | uiGridSetPadded(WIDGET, padded); 19 | } 20 | 21 | $method void self_insert_at(libui_grid *self, libui_control *c, libui_control *existing, libui_at at, int xspan, int yspan, 22 | goo_bool hexpand, libui_align halign, goo_bool vexpand, libui_align valign) 23 | { 24 | $static(connect,children)(self, c, NULL); 25 | uiGridInsertAt(WIDGET, $field(c, control), $field(existing, control), 26 | at, xspan, yspan, hexpand, halign, vexpand, valign); 27 | } 28 | 29 | $method void self_append(libui_grid *self, libui_control *c, int left, int top, int xspan, int yspan, 30 | goo_bool hexpand, libui_align halign, goo_bool vexpand, libui_align valign) 31 | { 32 | $static(connect,children)(self, c, NULL); 33 | uiGridAppend(WIDGET, $field(c, control), left, top, 34 | xspan, yspan, hexpand, halign, vexpand, valign); 35 | } 36 | -------------------------------------------------------------------------------- /examples/libui/libui_group.c: -------------------------------------------------------------------------------- 1 | #include "libui_group.h" 2 | #define WIDGET uiGroup($field(self, control)) 3 | 4 | $method libui_group *self_new(goo_string title) 5 | { 6 | libui_group *self = $alloc(); 7 | $field(self, control) = uiControl(uiNewGroup(goo_string_data(title))); 8 | return self; 9 | } 10 | 11 | $method goo_bool self_is_margined(libui_group *self) 12 | { 13 | return uiGroupMargined(WIDGET); 14 | } 15 | 16 | $method void self_set_margined(libui_group *self, goo_bool margined) 17 | { 18 | uiGroupSetMargined(WIDGET, margined); 19 | } 20 | 21 | $method void self_set_title(libui_group *self, goo_string title) 22 | { 23 | uiGroupSetTitle(WIDGET, goo_string_data(title)); 24 | } 25 | 26 | $method goo_string self_title(libui_group *self) 27 | { 28 | return goo_string_from_c(uiGroupTitle(WIDGET)); 29 | } 30 | 31 | $method void self_child_connect(libui_group *self, libui_control *child) 32 | { 33 | $static(connect, child)(self, child); 34 | uiGroupSetChild(WIDGET, $field($field(self, child), control)); 35 | } 36 | 37 | $method void self_on_child_disconnect(libui_group *self, libui_control *object) 38 | { 39 | uiGroupSetChild(WIDGET, NULL); 40 | } 41 | 42 | -------------------------------------------------------------------------------- /examples/libui/libui_label.c: -------------------------------------------------------------------------------- 1 | #include "libui_label.h" 2 | #define WIDGET uiLabel($field(self, control)) 3 | 4 | $method libui_label *self_new(goo_string text) 5 | { 6 | libui_label *self = $alloc(); 7 | $field(self, control) = uiControl(uiNewLabel(goo_string_data(text))); 8 | return self; 9 | } 10 | 11 | $method void self_set_text(libui_label *self, goo_string text) 12 | { 13 | uiLabelSetText(WIDGET, goo_string_data(text)); 14 | } 15 | 16 | $method goo_string self_text(libui_label *self) 17 | { 18 | return goo_string_from_c(uiLabelText(WIDGET)); 19 | } 20 | 21 | /*static libui_label* 22 | static_self_new(goo_string text); 23 | 24 | static void 25 | static_self_set_text(libui_label *self, goo_string text); 26 | 27 | static goo_string 28 | static_self_text(libui_label *self);*/ 29 | -------------------------------------------------------------------------------- /examples/libui/libui_manual.c: -------------------------------------------------------------------------------- 1 | #include "libui.h" 2 | 3 | goo_string libui_init(void) 4 | { 5 | uiInitOptions o; 6 | o.Size = sizeof(o); 7 | const char *result = uiInit(&o); 8 | if (result) 9 | { 10 | goo_string r = goo_string_from_c(result); 11 | uiFreeInitError(result); 12 | return r; 13 | } 14 | else 15 | return null_string; 16 | } 17 | 18 | void libui_uninit(void) 19 | { 20 | uiUninit(); 21 | } 22 | 23 | void libui_main(void) 24 | { 25 | uiMain(); 26 | } 27 | 28 | void libui_main_steps(void) 29 | { 30 | uiMainSteps(); 31 | } 32 | 33 | int libui_main_step(int wait) 34 | { 35 | return uiMainStep(wait); 36 | } 37 | 38 | void libui_quit(void) 39 | { 40 | uiQuit(); 41 | } 42 | 43 | goo_string libui_open_file(libui_window *parent) 44 | { 45 | char *fname = uiOpenFile(uiWindow($field(parent, control))); 46 | goo_string result = null_string; 47 | 48 | if (fname) 49 | { 50 | result = goo_string_from_c(fname); 51 | uiFreeText(fname); 52 | } 53 | return result; 54 | } 55 | 56 | goo_string libui_save_file(libui_window *parent) 57 | { 58 | char *fname = uiSaveFile(uiWindow($field(parent, control))); 59 | goo_string result = null_string; 60 | 61 | if (fname) 62 | { 63 | result = goo_string_from_c(fname); 64 | uiFreeText(fname); 65 | } 66 | return result; 67 | } 68 | 69 | void libui_msg_box(libui_window *parent, goo_string title, goo_string description) 70 | { 71 | uiMsgBox(uiWindow($field(parent, control)), goo_string_data(title), goo_string_data(description)); 72 | } 73 | 74 | void libui_msg_box_error(libui_window *parent, goo_string title, goo_string description) 75 | { 76 | uiMsgBoxError(uiWindow($field(parent, control)), goo_string_data(title), goo_string_data(description)); 77 | } 78 | -------------------------------------------------------------------------------- /examples/libui/libui_menu.c: -------------------------------------------------------------------------------- 1 | #include "libui_menu.h" 2 | #define WIDGET $field(self, control) 3 | 4 | $method libui_menu *self_new(goo_string name) 5 | { 6 | libui_menu *self = $alloc(); 7 | $field(self, control) = uiNewMenu(goo_string_data(name)); 8 | return self; 9 | } 10 | 11 | static libui_menu_item *append(libui_menu *self, uiMenuItem *item) 12 | { 13 | libui_menu_item *result = libui_menu_item_new(item); 14 | $static(connect,items)(self, result, libui_menu_items_last(self)); 15 | return result; 16 | } 17 | 18 | void self_append_separator(libui_menu *self) 19 | { 20 | uiMenuAppendSeparator(WIDGET); 21 | } 22 | 23 | $method libui_menu_item *self_append_about_item(libui_menu *self) 24 | { 25 | return append(self, uiMenuAppendAboutItem(WIDGET)); 26 | } 27 | 28 | $method libui_menu_item *self_append_preferences_item(libui_menu *self) 29 | { 30 | return append(self, uiMenuAppendPreferencesItem(WIDGET)); 31 | } 32 | 33 | $method libui_menu_item *self_append_quit_item(libui_menu *self) 34 | { 35 | return append(self, uiMenuAppendQuitItem(WIDGET)); 36 | } 37 | 38 | $method libui_menu_item *self_append_check_item(libui_menu *self, goo_string name) 39 | { 40 | return append(self, uiMenuAppendCheckItem(WIDGET, goo_string_data(name))); 41 | } 42 | 43 | $method libui_menu_item *self_append_item(libui_menu *self, goo_string name) 44 | { 45 | return append(self, uiMenuAppendItem(WIDGET, goo_string_data(name))); 46 | } 47 | -------------------------------------------------------------------------------- /examples/libui/libui_menu_item.c: -------------------------------------------------------------------------------- 1 | #include "libui_menu_item.h" 2 | #define WIDGET uiMenuItem($field(self, control)) 3 | 4 | static void on_clicked(uiMenuItem *sender, uiWindow *window, void *self) 5 | { 6 | $static(event, clicked)((libui_menu_item*)self); 7 | } 8 | 9 | $method libui_menu_item *self_new(uiMenuItem * item) 10 | { 11 | libui_menu_item *self = $alloc(); 12 | $field(self, control) = item; 13 | uiMenuItemOnClicked(WIDGET, on_clicked, self); 14 | return self; 15 | } 16 | 17 | $method goo_bool self_is_checked(libui_menu_item *self) 18 | { 19 | return uiMenuItemChecked(WIDGET); 20 | } 21 | 22 | $method void self_set_checked(libui_menu_item *self, goo_bool checked) 23 | { 24 | uiMenuItemSetChecked(WIDGET, checked); 25 | } 26 | 27 | $method void self_disable(libui_menu_item *self) 28 | { 29 | uiMenuItemDisable(WIDGET); 30 | } 31 | 32 | $method void self_enable(libui_menu_item *self) 33 | { 34 | uiMenuItemEnable(WIDGET); 35 | } 36 | -------------------------------------------------------------------------------- /examples/libui/libui_multiline_entry.c: -------------------------------------------------------------------------------- 1 | #include "libui_multiline_entry.h" 2 | #define WIDGET uiMultilineEntry($field(self, control)) 3 | 4 | static void on_changed(uiMultilineEntry *e, void *self) 5 | { 6 | $static(event, changed)((libui_multiline_entry*)self); 7 | } 8 | 9 | $method libui_multiline_entry *self_new(goo_bool wrap) 10 | { 11 | libui_multiline_entry *self = $alloc(); 12 | $field(self, control) = 13 | wrap 14 | ? uiControl(uiNewMultilineEntry()) 15 | : uiControl(uiNewNonWrappingMultilineEntry()); 16 | uiMultilineEntryOnChanged(WIDGET, on_changed, (void*)self); 17 | return self; 18 | } 19 | 20 | $method goo_bool self_is_readonly(libui_multiline_entry *self) 21 | { 22 | return uiMultilineEntryReadOnly(WIDGET); 23 | } 24 | 25 | $method void self_set_readonly(libui_multiline_entry *self, goo_bool readonly) 26 | { 27 | uiMultilineEntrySetReadOnly(WIDGET, readonly); 28 | } 29 | 30 | $method void self_append(libui_multiline_entry *self, goo_string text) 31 | { 32 | uiMultilineEntryAppend(WIDGET, goo_string_data(text)); 33 | } 34 | 35 | $method void self_set_text(libui_multiline_entry *self, goo_string text) 36 | { 37 | uiMultilineEntrySetText(WIDGET, goo_string_data(text)); 38 | } 39 | 40 | $method goo_string self_text(libui_multiline_entry *self) 41 | { 42 | return goo_string_from_c(uiMultilineEntryText(WIDGET)); 43 | } 44 | -------------------------------------------------------------------------------- /examples/libui/libui_progressbar.c: -------------------------------------------------------------------------------- 1 | #include "libui_progressbar.h" 2 | #define WIDGET uiProgressBar($field(self, control)) 3 | 4 | $method libui_progressbar *self_new(void) 5 | { 6 | libui_progressbar *self = $alloc(); 7 | $field(self, control) = uiControl(uiNewProgressBar()); 8 | return self; 9 | } 10 | 11 | $method void self_set_value(libui_progressbar *self, int value) 12 | { 13 | uiProgressBarSetValue(WIDGET, value); 14 | } 15 | 16 | $method int self_value(libui_progressbar *self) 17 | { 18 | return uiProgressBarValue(WIDGET); 19 | } 20 | -------------------------------------------------------------------------------- /examples/libui/libui_radio_buttons.c: -------------------------------------------------------------------------------- 1 | #include "libui_radio_buttons.h" 2 | #define WIDGET uiRadioButtons($field(self, control)) 3 | 4 | static void on_selected(uiRadioButtons *e, void *self) 5 | { 6 | $static(event, selected)((libui_radio_buttons*)self); 7 | } 8 | 9 | $method libui_radio_buttons *self_new(void) 10 | { 11 | libui_radio_buttons *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewRadioButtons()); 13 | uiRadioButtonsOnSelected(WIDGET, on_selected, self); 14 | return self; 15 | } 16 | 17 | $method void self_set_selected(libui_radio_buttons *self, int selected) 18 | { 19 | uiRadioButtonsSetSelected(WIDGET, selected); 20 | } 21 | 22 | $method int self_selected(libui_radio_buttons *self) 23 | { 24 | return uiRadioButtonsSelected(WIDGET); 25 | } 26 | 27 | $method void self_append(libui_radio_buttons *self, goo_string text) 28 | { 29 | uiRadioButtonsAppend(WIDGET, goo_string_data(text)); 30 | } 31 | -------------------------------------------------------------------------------- /examples/libui/libui_separator.c: -------------------------------------------------------------------------------- 1 | #include "libui_separator.h" 2 | #define WIDGET uiSeparator($field(self, control)) 3 | 4 | static libui_separator *init(uiSeparator *sep) 5 | { 6 | libui_separator *self = $alloc(); 7 | $field(self, control) = uiControl(sep); 8 | return self; 9 | } 10 | 11 | $method libui_separator *self_new_vertical(void) 12 | { 13 | return init(uiNewVerticalSeparator()); 14 | } 15 | 16 | $method libui_separator *self_new_horizontal(void) 17 | { 18 | return init(uiNewHorizontalSeparator()); 19 | } 20 | -------------------------------------------------------------------------------- /examples/libui/libui_slider.c: -------------------------------------------------------------------------------- 1 | #include "libui_slider.h" 2 | #define WIDGET uiSlider($field(self, control)) 3 | 4 | static void on_changed(uiSlider *e, void *self) 5 | { 6 | $static(event, changed)((libui_slider*)self); 7 | } 8 | 9 | $method libui_slider *self_new(int min, int max) 10 | { 11 | libui_slider *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewSlider(min, max)); 13 | uiSliderOnChanged(WIDGET, on_changed, self); 14 | return self; 15 | } 16 | 17 | $method void self_set_value(libui_slider *self, int value) 18 | { 19 | uiSliderSetValue(WIDGET, value); 20 | } 21 | 22 | $method int self_value(libui_slider *self) 23 | { 24 | return uiSliderValue(WIDGET); 25 | } 26 | -------------------------------------------------------------------------------- /examples/libui/libui_spinbox.c: -------------------------------------------------------------------------------- 1 | #include "libui_spinbox.h" 2 | #define WIDGET uiSpinbox($field(self, control)) 3 | 4 | static void on_changed(uiSpinbox *e, void *self) 5 | { 6 | $static(event, changed)((libui_spinbox*)self); 7 | } 8 | 9 | $method libui_spinbox *self_new(int min, int max) 10 | { 11 | libui_spinbox *self = $alloc(); 12 | $field(self, control) = uiControl(uiNewSpinbox(min, max)); 13 | uiSpinboxOnChanged(WIDGET, on_changed, self); 14 | return self; 15 | } 16 | 17 | $method void self_set_value(libui_spinbox *self, int value) 18 | { 19 | uiSpinboxSetValue(WIDGET, value); 20 | } 21 | 22 | $method int self_value(libui_spinbox *self) 23 | { 24 | return uiSpinboxValue(WIDGET); 25 | } 26 | -------------------------------------------------------------------------------- /examples/libui/libui_tab.c: -------------------------------------------------------------------------------- 1 | #include "libui_tab.h" 2 | #define WIDGET uiTab($field(self, control)) 3 | 4 | $method libui_tab *self_new(void) 5 | { 6 | libui_tab *self = $alloc(); 7 | $field(self, control) = uiControl(uiNewTab()); 8 | return self; 9 | } 10 | 11 | $method void self_set_tab_margined(libui_tab *self, int page, goo_bool margined) 12 | { 13 | uiTabSetMargined(WIDGET, page, margined); 14 | } 15 | 16 | $method goo_bool self_is_tab_margined(libui_tab *self, int page) 17 | { 18 | return uiTabMargined(WIDGET, page); 19 | } 20 | 21 | $method int self_num_pages(libui_tab *self) 22 | { 23 | return uiTabNumPages(WIDGET); 24 | } 25 | 26 | $method void self_insert_at(libui_tab *self, goo_string name, int before, libui_control *child) 27 | { 28 | libui_control *after = NULL; 29 | if (before > 0) 30 | { 31 | after = libui_tab_tabs_first(self); 32 | for (int i = 1; i < before && after; ++i) 33 | after = libui_tab_tabs_next(after); 34 | } 35 | $static(connect,tabs)(self, child, after); 36 | uiTabInsertAt(WIDGET, goo_string_data(name), before, $field(child, control)); 37 | } 38 | 39 | $method void self_append(libui_tab *self, goo_string name, libui_control *child) 40 | { 41 | $static(connect,tabs)(self, child, libui_tab_tabs_last(self)); 42 | uiTabAppend(WIDGET, goo_string_data(name), $field(child, control)); 43 | } 44 | -------------------------------------------------------------------------------- /examples/libui/libui_window.c: -------------------------------------------------------------------------------- 1 | #include "libui_window.h" 2 | #define WIDGET uiWindow($field(self, control)) 3 | 4 | static void on_content_size_changed(uiWindow *w, void *self) 5 | { 6 | $static(event, content_size_changed)((libui_window*)self); 7 | } 8 | 9 | static int on_closing(uiWindow *w, void *self) 10 | { 11 | return $static(event, closing)((libui_window*)self); 12 | } 13 | 14 | $method libui_window *self_new(goo_string title, int width, int height, goo_bool has_menubar) 15 | { 16 | libui_window *self = $alloc(); 17 | $field(self, control) = uiControl(uiNewWindow(goo_string_data(title), width, height, has_menubar)); 18 | uiWindowOnContentSizeChanged(WIDGET, on_content_size_changed, self); 19 | uiWindowOnClosing(WIDGET, on_closing, self); 20 | return self; 21 | } 22 | 23 | $method goo_bool self_is_margined(libui_window *self) 24 | { 25 | return uiWindowMargined(WIDGET); 26 | } 27 | 28 | $method void self_set_margined(libui_window *self, goo_bool margined) 29 | { 30 | uiWindowSetMargined(WIDGET, margined); 31 | } 32 | 33 | $method goo_bool self_is_borderless(libui_window *self) 34 | { 35 | return uiWindowBorderless(WIDGET); 36 | } 37 | 38 | $method void self_set_borderless(libui_window *self, goo_bool borderless) 39 | { 40 | uiWindowSetBorderless(WIDGET, borderless); 41 | } 42 | 43 | $method goo_bool self_is_fullscreen(libui_window *self) 44 | { 45 | return uiWindowFullscreen(WIDGET); 46 | } 47 | 48 | $method void self_set_fullscreen(libui_window *self, goo_bool fullscreen) 49 | { 50 | uiWindowSetFullscreen(WIDGET, fullscreen); 51 | } 52 | 53 | $method void self_set_content_size(libui_window *self, int width, int height) 54 | { 55 | uiWindowSetContentSize(WIDGET, width, height); 56 | } 57 | 58 | $method void self_content_size(libui_window *self, int *ret0, int *ret1) 59 | { 60 | uiWindowContentSize(WIDGET, ret0, ret1); 61 | } 62 | 63 | $method void self_set_title(libui_window *self, goo_string title) 64 | { 65 | uiWindowSetTitle(WIDGET, goo_string_data(title)); 66 | } 67 | 68 | $method goo_string self_title(libui_window *self) 69 | { 70 | return goo_string_from_c(uiWindowTitle(WIDGET)); 71 | } 72 | 73 | $method void self_child_connect(libui_window *self, libui_control *child) 74 | { 75 | $static(connect, child)(self, child); 76 | uiWindowSetChild(WIDGET, $field($field(self, child), control)); 77 | } 78 | 79 | $method void self_on_child_disconnect(libui_window *self, libui_control *object) 80 | { 81 | uiWindowSetChild(WIDGET, NULL); 82 | } 83 | 84 | -------------------------------------------------------------------------------- /gen/META: -------------------------------------------------------------------------------- 1 | name = "goo-gen" 2 | description = "Goo code generation library" 3 | version = "0.1" 4 | archive(byte) = "goo_gen.cma" 5 | archive(native) = "goo_gen.cmxa" 6 | requires = "unix" 7 | -------------------------------------------------------------------------------- /gen/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | 4 | clean: 5 | dune clean 6 | 7 | .PHONY: all clean 8 | -------------------------------------------------------------------------------- /gen/c.ml: -------------------------------------------------------------------------------- 1 | open Model 2 | module I = Introspect 3 | 4 | let class_name cl = I.(name_of (class_package cl) ^ "_" ^ name_of cl) 5 | let enum_name en = I.(name_of (enum_package en) ^ "_" ^ name_of en) 6 | 7 | let is_abstract, set_concrete = 8 | let table : (classe, unit) I.Table.table = I.Table.create () in 9 | (fun cl -> not (I.Table.mem table cl)), 10 | (fun cl -> I.Table.add table cl ()) 11 | 12 | let get_list table key = 13 | try I.Table.find table key with Not_found -> 14 | let l = ref [] in 15 | I.Table.add table key l; 16 | l 17 | 18 | let add_to_list l v = l := v :: !l 19 | 20 | let is_dynamic, set_dynamic = 21 | let table : (func, unit) I.Table.table = I.Table.create () in 22 | let assert_method func = match I.func_kind func with 23 | | I.Fn_class cl -> 24 | begin match I.func_args func with 25 | | ("self", Object cl') :: _ when cl = cl' -> () 26 | | _ -> 27 | Printf.ksprintf failwith 28 | "Goo_c.dynamic: for %s.%s to be a dynamic method, \ 29 | first argument should be a receiver 'self' of class %s" 30 | (class_name cl) (I.name_of func) (class_name cl) 31 | end 32 | | I.Fn_package pkg -> 33 | Printf.ksprintf failwith "Goo_c.dynamic: %s.%s is not a class method" 34 | (I.name_of pkg) (I.name_of func) 35 | in 36 | (fun func -> I.Table.mem table func), 37 | (fun func -> assert_method func; I.Table.add table func ()) 38 | 39 | type variable_desc = { v_type : ctype } 40 | type variable = variable_desc id 41 | 42 | let instance_variables, instance_variable = 43 | let table : (classe, variable list ref) I.Table.table = I.Table.create () in 44 | (fun cl -> List.rev !(get_list table cl)), 45 | (fun cl name v_type -> 46 | add_to_list (get_list table cl) (Id.inj name { v_type })) 47 | 48 | let add_method_body, method_bodies = 49 | let table : (classe * func, string list) Hashtbl.t = Hashtbl.create 7 in 50 | (fun cl func body -> match Hashtbl.find table (cl, func) with 51 | | _ -> 52 | Printf.ksprintf failwith 53 | "add_method_body: method %s.%s already has already been given a body" 54 | (class_name cl) (I.name_of func) 55 | | exception Not_found -> 56 | Hashtbl.add table (cl, func) body 57 | ), 58 | (fun cl func -> match Hashtbl.find table (cl,func) with 59 | | exception Not_found -> None 60 | | body -> Some body 61 | ) 62 | 63 | let override, overriden = 64 | let table : (classe, func list ref) I.Table.table = I.Table.create () in 65 | (fun cl ?body func -> 66 | add_to_list (get_list table cl) func; 67 | match body with 68 | | None -> () 69 | | Some body -> add_method_body cl func body 70 | ), 71 | (fun cl -> List.rev !(get_list table cl)) 72 | 73 | let get_disconnect_callback, add_disconnect_callback = 74 | let table : (I.class_relation, func) Hashtbl.t = Hashtbl.create 7 in 75 | let get rel = match Hashtbl.find table rel with 76 | | x -> Some x 77 | | exception Not_found -> None 78 | in 79 | let add rel func = 80 | if not (Hashtbl.mem table rel) then 81 | (Hashtbl.add table rel func; true) 82 | else 83 | false 84 | in 85 | get, add 86 | 87 | let on_port_disconnect pt cb = 88 | if not (add_disconnect_callback (I.Rel_port pt) cb) then 89 | Printf.ksprintf failwith 90 | "port %s already has a disconnect callback registered" 91 | (I.name_of pt) 92 | 93 | let on_slot_disconnect pt cb = 94 | if not (add_disconnect_callback (I.Rel_slot pt) cb) then 95 | Printf.ksprintf failwith 96 | "port %s already has a disconnect callback registered" 97 | (I.name_of pt) 98 | 99 | let on_collection_disconnect pt cb = 100 | if not (add_disconnect_callback (I.Rel_collection pt) cb) then 101 | Printf.ksprintf failwith 102 | "port %s already has a disconnect callback registered" 103 | (I.name_of pt) 104 | 105 | let rec lookup_override cl func = 106 | let parent = match I.class_extend cl with 107 | | Some cl -> lookup_override cl func 108 | | None -> 109 | match I.func_kind func with 110 | | I.Fn_class cl -> [cl] 111 | | _ -> assert false 112 | in 113 | if List.mem func (overriden cl) then 114 | cl :: parent 115 | else 116 | parent 117 | 118 | let () = set_dynamic Model.goo_destroy 119 | 120 | let package_declare, package_get_declarations = 121 | let table : (package, string list ref) I.Table.table = I.Table.create () in 122 | (fun pkg decls -> match I.Table.find table pkg with 123 | | lines -> lines := List.rev_append decls !lines 124 | | exception Not_found -> 125 | I.Table.add table pkg (ref (List.rev decls)) 126 | ), 127 | (fun pkg -> match I.Table.find table pkg with 128 | | lines -> List.rev !lines 129 | | exception Not_found -> []) 130 | 131 | let sprint = Printf.sprintf 132 | let print o fmt = Printf.ksprintf o fmt 133 | let on_ x y = "on_" ^ x ^ "_" ^ y 134 | 135 | let ctype ident = function 136 | | Bool -> sprint "goo_bool %s" ident 137 | | Int -> sprint "int %s" ident 138 | | Float -> sprint "double %s" ident 139 | | String -> sprint "goo_string %s" ident 140 | | Flag en -> sprint "%s %s" (enum_name en) ident 141 | | Object cl -> sprint "%s *%s" (class_name cl) ident 142 | | Object_option cl -> sprint "goo_option %s *%s" (class_name cl) ident 143 | | Custom s -> sprint "%s%s%s" s (if s.[String.length s - 1] <> ' ' then " " else "") ident 144 | 145 | let iter_ancestors ?(and_self=false) cl f = 146 | let rec aux = function 147 | | None -> () 148 | | Some cl -> aux (I.class_extend cl); f cl 149 | in 150 | aux (I.class_extend cl); 151 | if and_self then f cl 152 | 153 | let number_of_properties cl0 = 154 | let count = ref 0 in 155 | iter_ancestors ~and_self:true cl0 (fun cl -> 156 | List.iter (fun var -> 157 | match (Id.prj var ).v_type with 158 | | Object _ | Object_option _ -> incr count 159 | | _ -> ()) 160 | (instance_variables cl); 161 | List.iter (fun _event -> incr count) 162 | (I.class_events cl); 163 | List.iter (function 164 | | I.Rel_collection _ | I.Rel_slot _ -> incr count 165 | | I.Rel_port _ -> count := !count + 2) 166 | (I.class_relations cl); 167 | ); 168 | !count 169 | 170 | let property_index cl0 name = 171 | let count = ref 0 in 172 | match iter_ancestors ~and_self:true cl0 (fun cl -> 173 | List.iter (fun var -> 174 | match (Id.prj var).v_type with 175 | | Object _ | Object_option _ -> 176 | if I.name_of var = name then raise Exit; 177 | incr count 178 | | _ -> ()) 179 | (instance_variables cl); 180 | List.iter (fun event -> 181 | if I.name_of event = name then raise Exit 182 | else incr count) 183 | (I.class_events cl); 184 | List.iter (function 185 | | I.Rel_collection x when I.name_of x = name -> raise Exit 186 | | I.Rel_slot x when I.name_of x = name -> raise Exit 187 | | I.Rel_port x when I.name_of x = name -> raise Exit 188 | | I.Rel_collection _ | I.Rel_slot _ -> incr count 189 | | I.Rel_port _ -> count := !count + 2) 190 | (I.class_relations cl); 191 | ) 192 | with 193 | | () -> raise Not_found 194 | | exception Exit -> !count 195 | 196 | let func_symbol ?at_class func = 197 | let prefix = 198 | match at_class, I.func_kind func with 199 | | Some cl, _ | None, I.Fn_class cl -> class_name cl 200 | | None, I.Fn_package pkg -> I.name_of pkg 201 | in 202 | prefix ^ "_" ^ I.name_of func 203 | 204 | let params_str params = 205 | String.concat ", " (List.map (fun (n,ty) -> ctype n ty) params) 206 | 207 | let func_params ?at_class func = match I.func_args ?at_class func, I.func_ret func with 208 | | [], ([] | [_]) -> [] 209 | | params, ((_ :: ([] as ret)) | ret) -> 210 | params @ List.mapi (fun i ty -> ("*ret" ^ string_of_int i), ty) ret 211 | 212 | let func_params_str ?at_class func = match func_params ?at_class func with 213 | | [] -> "void" 214 | | params -> params_str params 215 | 216 | let func_ret func = match I.func_ret func with 217 | | [typ] -> Some typ 218 | | [] | (_ :: _ :: _) -> None 219 | 220 | let func_ret_str func = match func_ret func with 221 | | Some typ -> ctype "" typ 222 | | None -> "void " 223 | 224 | let func_args_str ?at_class func = 225 | let prepare_arg (k, _) = 226 | if k.[0] = '*' then String.sub k 1 (String.length k - 1) else k 227 | in 228 | String.concat ", " (List.map prepare_arg (func_params ?at_class func )) 229 | 230 | let event_symbol event = 231 | "event_" ^ class_name (I.event_classe event) ^ "_" ^ I.name_of event 232 | 233 | let event_ret event = 234 | List.mapi (fun i ty -> "ret" ^ string_of_int i, ty) (I.event_ret event) 235 | 236 | let event_params event = 237 | I.event_args ~with_self:true event @ 238 | List.map (fun (k,v) -> "*" ^ k, v) (event_ret event) 239 | 240 | let event_params_str event = 241 | params_str (event_params event) 242 | 243 | let event_args_str event = 244 | let prepare_arg (k, _) = 245 | if k.[0] = '*' then String.sub k 1 (String.length k - 1) else k 246 | in 247 | String.concat ", " (List.map prepare_arg (event_params event)) 248 | 249 | let print_proxy o name params = 250 | let remove_star k = 251 | if k.[0] = '*' then String.sub k 1 (String.length k - 1) else k 252 | in 253 | let prepare_formal (k, _) = remove_star k in 254 | let prepare_actual = function 255 | | (k, Object cl) when k.[0] <> '*' -> 256 | sprint "$as(%s, %s)" k (class_name cl) 257 | | (k, _) -> remove_star k 258 | in 259 | let formal = String.concat "," (List.map prepare_formal params) in 260 | let actual = String.concat "," (List.map prepare_actual params) in 261 | print o "#define $%s(%s) %s(%s)" name formal name actual 262 | 263 | let print_function o ?at_class func proxy body = 264 | print o "%s%s(%s)%s" 265 | (func_ret_str func) (func_symbol func) (func_params_str ?at_class func) 266 | (if body = None then ";" else ""); 267 | begin match body with 268 | | None -> () 269 | | Some xs -> 270 | o "{"; 271 | List.iter o xs; 272 | o "}"; 273 | end; 274 | if proxy then 275 | print_proxy o (func_symbol func) (func_params ?at_class func) 276 | 277 | let print_class_hierarchy o cl_main = 278 | let cname = class_name cl_main in 279 | print o "GOO_CLASS_HIERARCHY(%s)" cname; 280 | o "{"; 281 | print o " GOO_CLASS_HIERARCHY_INIT(%s);" cname; 282 | let rec print_inherit = function 283 | | None -> () 284 | | Some cl -> 285 | print o " GOO_CLASS_INHERIT(%s);" (class_name cl); 286 | print_inherit (I.class_extend cl) 287 | in 288 | print_inherit (I.class_extend cl_main); 289 | o "};"; 290 | o "" 291 | 292 | let print_class_methods o cl_main = 293 | let cname = class_name cl_main in 294 | print o "GOO_CLASS_METHODS(%s)" cname; 295 | o "{"; 296 | print o " GOO_CLASS_METHODS_INIT(%s);" cname; 297 | iter_ancestors ~and_self:true cl_main 298 | (fun cl -> 299 | List.iter (fun func -> 300 | if is_dynamic func then 301 | print o " %s( *const %s ) (%s);" 302 | (func_ret_str func) (I.name_of func) 303 | (func_params_str ~at_class:cl_main func) 304 | ) (I.class_funcs cl) 305 | ); 306 | o "};"; 307 | o "" 308 | 309 | let print_class_fields o cl_main = 310 | let cname = class_name cl_main in 311 | print o "GOO_CLASS_FIELDS(%s)" cname; 312 | o "{"; 313 | print o " GOO_CLASS_FIELDS_INIT(%s);" cname; 314 | iter_ancestors ~and_self:true cl_main 315 | (fun cl -> 316 | List.iter (fun var -> 317 | let name = I.name_of var and typ = (Id.prj var).v_type in 318 | let name = match typ with 319 | | Object _ | Object_option _ -> "const " ^ name 320 | | _ -> name 321 | in 322 | print o " %s;" (ctype name typ) 323 | ) (instance_variables cl); 324 | List.iter (function 325 | | I.Rel_collection col -> 326 | print o " goo_collection %s;" (I.name_of col) 327 | | I.Rel_slot sl -> 328 | let pt = I.slot_port sl in 329 | print o " %s;" (ctype ("const " ^ I.name_of sl) 330 | (Object_option (I.port_target pt))) 331 | | I.Rel_port pt -> 332 | print o " goo_port %s;" (I.name_of pt) 333 | ) (I.class_relations cl); 334 | ); 335 | o "};"; 336 | o "" 337 | 338 | let print_class_method_prototypes o cl = 339 | List.iter (fun func -> print_function o func true None) (I.class_funcs cl); 340 | List.iter (fun func -> 341 | if is_dynamic func then 342 | print o "%sstatic_%s(%s);" 343 | (func_ret_str func) (func_symbol ~at_class:cl func) (func_params_str ~at_class:cl func) 344 | else 345 | print o "#define static_%s %s" (func_symbol ~at_class:cl func) (func_symbol ~at_class:cl func) 346 | ) 347 | (overriden cl @ I.class_funcs cl) 348 | 349 | let print_package_h pkg o = 350 | o "#include \"goo_system.h\""; 351 | o ""; 352 | (* Forward declare classes. *) 353 | List.iter (fun c -> print o "GOO_CLASS_DECLARE(%s);" (class_name c)) 354 | (I.package_classes pkg); 355 | o ""; 356 | (* Declare enums *) 357 | List.iter (fun e -> 358 | o "typedef enum {"; 359 | List.iter (fun m -> print o " %s," (I.name_of m)) (I.enum_members e); 360 | print o "} %s;" (enum_name e); 361 | o ""; 362 | ) (I.package_enums pkg); 363 | o ""; 364 | List.iter o (package_get_declarations pkg); 365 | o ""; 366 | (* Declare functions *) 367 | List.iter 368 | (fun func -> print_function o func true None) 369 | (I.package_funcs pkg); 370 | (* Declare classes *) 371 | List.iter (fun cl -> 372 | o ""; 373 | print_class_methods o cl; 374 | print_class_fields o cl; 375 | print_class_hierarchy o cl; 376 | print_class_method_prototypes o cl 377 | ) (I.package_classes pkg); 378 | o ""; 379 | (* Declare relations *) 380 | List.iter (fun cl -> 381 | let cname = class_name cl in 382 | List.iter (function 383 | | I.Rel_collection col -> 384 | let pt = I.collection_port col in 385 | print o "GOO_COLLECTION(%s, %s, %s);" 386 | cname (I.name_of col) (class_name (I.port_target pt)) 387 | | I.Rel_slot sl -> 388 | let pt = I.slot_port sl in 389 | print o "GOO_SLOT(%s, %s, %s);" 390 | cname (I.name_of sl) (class_name (I.port_target pt)) 391 | | I.Rel_port pt -> 392 | print o "GOO_PORT(%s, %s, %s);" 393 | cname (I.name_of pt) (class_name (I.port_source pt)) 394 | ) (I.class_relations cl) 395 | ) (I.package_classes pkg) 396 | 397 | let print_class_impl_h cl o = 398 | print o "#include \"%s.h\"" (I.name_of (I.class_package cl)); 399 | o "#include \"ml_goo.h\""; 400 | o ""; 401 | o "/* Methods to implement */"; 402 | o ""; 403 | (* Overriden methods *) 404 | iter_ancestors cl (fun cl' -> 405 | List.iter 406 | (fun func -> 407 | match lookup_override cl func with 408 | | cl0 :: _ when cl0 = cl -> 409 | print o "$method %sself_%s(%s);" 410 | (func_ret_str func) (I.name_of func) (func_params_str ~at_class:cl func) 411 | | _ -> () 412 | ) 413 | (I.class_funcs cl') 414 | ); 415 | (* New methods *) 416 | List.iter 417 | (fun func -> 418 | print o "$method %sself_%s(%s);" 419 | (func_ret_str func) (I.name_of func) (func_params_str func)) 420 | (I.class_funcs cl); 421 | o ""; 422 | o "/* Internal definitions */"; 423 | o ""; 424 | iter_ancestors cl (fun cl' -> 425 | List.iter 426 | (fun func -> 427 | let overrides = lookup_override cl func in 428 | let next_cl, next_prefix = 429 | match overrides with 430 | | cl0 :: cl1 :: _ when cl0 = cl -> 431 | let sym = func_symbol ~at_class:cl func in 432 | let ret_type = func_ret_str func in 433 | let ret_call = if func_ret func = None then "" else "return " in 434 | let params = func_params_str ~at_class:cl func in 435 | let args = func_args_str ~at_class:cl func in 436 | print o "#define static_self_%s self_%s" (I.name_of func) (I.name_of func); 437 | print o "#define $static_self_%s $%s" (I.name_of func) sym; 438 | print o "%sstatic_%s(%s) { %sself_%s(%s); }" 439 | ret_type sym params ret_call (I.name_of func) args; 440 | cl1, "super" 441 | | cl0 :: _ -> cl0, "self" 442 | | [] -> assert false 443 | in 444 | let sym = func_symbol ~at_class:next_cl func in 445 | print o "#define static_%s_%s static_%s" 446 | next_prefix (I.name_of func) sym; 447 | print o "#define $static_%s_%s $%s" 448 | next_prefix (I.name_of func) sym 449 | ) 450 | (I.class_funcs cl') 451 | ); 452 | List.iter 453 | (fun func -> 454 | let ret_type = func_ret_str func in 455 | let ret_call = if func_ret func = None then "" else "return " in 456 | print o "#define static_self_%s self_%s" (I.name_of func) (I.name_of func); 457 | print o "#define $static_self_%s $%s" (I.name_of func) (func_symbol func); 458 | if is_dynamic func then 459 | print o "%s%s(%s) { %s$send(self, %s)(%s); }" 460 | ret_type (func_symbol func) (func_params_str func) 461 | ret_call (I.name_of func) (func_args_str func); 462 | print o "%sstatic_%s(%s) { %sself_%s(%s); }" 463 | ret_type (func_symbol func) (func_params_str func) 464 | ret_call (I.name_of func) (func_args_str func) 465 | ) 466 | (I.class_funcs cl); 467 | o ""; 468 | o "/* Relations */"; 469 | o ""; 470 | let rel_name_and_index cl id = 471 | (class_name cl, I.name_of id, property_index cl (I.name_of id)) in 472 | List.iter (fun rel -> 473 | let cb = get_disconnect_callback rel in 474 | match rel with 475 | | I.Rel_collection col -> 476 | let pt = I.collection_port col in 477 | let target = I.port_target pt in 478 | let src_cl, src_name, src_id = rel_name_and_index cl col in 479 | let dst_cl, dst_name, dst_id = rel_name_and_index target pt in 480 | print o "#define $port_%s_disconnect %s" src_name 481 | (match cb with 482 | | None -> sprint "(void(*)(%s *, %s *))NULL" src_cl dst_cl 483 | | Some func -> func_symbol func); 484 | print o "GOO_INTERNAL_COLLECTION(%s, %s, %d, %s, %s, %d);" 485 | src_cl src_name src_id 486 | dst_cl dst_name dst_id; 487 | print_proxy o ("static_connect_" ^ I.name_of col) 488 | ["self", Object cl; "that", Object target; "after_that", Object_option target] 489 | | I.Rel_slot sl -> 490 | let pt = I.slot_port sl in 491 | let target = I.port_target pt in 492 | let src_cl, src_name, src_id = rel_name_and_index cl sl in 493 | let dst_cl, dst_name, dst_id = rel_name_and_index target pt in 494 | print o "#define $port_%s_disconnect %s" src_name 495 | (match cb with 496 | | None -> sprint "(void(*)(%s *, %s *))NULL" src_cl dst_cl 497 | | Some func -> func_symbol func); 498 | print o "GOO_INTERNAL_SLOT(%s, %s, %d, %s, %s, %d);" 499 | src_cl src_name src_id 500 | dst_cl dst_name dst_id; 501 | print_proxy o ("static_connect_" ^ I.name_of sl) 502 | ["self", Object cl; "item", Object target] 503 | | I.Rel_port pt -> 504 | print o "#define $port_%s_disconnect(object) %s(object)" (I.name_of pt) 505 | (match cb with 506 | | None -> "(void)" 507 | | Some func -> func_symbol func); 508 | print o "GOO_INTERNAL_PORT(%s, %s, %s);" 509 | (class_name (I.port_target pt)) (I.name_of pt) 510 | (class_name (I.port_source pt)) 511 | ) (I.class_relations cl); 512 | o ""; 513 | o "/* Heap variable setters */"; 514 | o ""; 515 | List.iter (fun var -> 516 | let name = I.name_of var and typ = (Id.prj var).v_type in 517 | match typ with 518 | | Object arg | Object_option arg -> 519 | print o "static inline void static_set_%s(%s *self, %s *v)" name 520 | (class_name cl) (class_name arg); 521 | o "{"; 522 | print o " *(%s ** )(&$field(self, %s)) = val;" (class_name arg) name; 523 | print o " $ml_goo_set_property(self, %d, val);" (property_index cl name); 524 | o "}"; 525 | print_proxy o ("static_set_" ^ name) ["self", Object cl; "v", typ] 526 | | _ -> () 527 | ) (instance_variables cl); 528 | o ""; 529 | o "/* Events */"; 530 | o ""; 531 | iter_ancestors ~and_self:true cl 532 | (fun cl -> 533 | List.iter (fun event -> 534 | print o"goo_bool %s(%s);" 535 | (event_symbol event) (event_params_str event); 536 | print o "#define $static_event_%s %s" 537 | (I.name_of event) (event_symbol event); 538 | print_proxy o 539 | (sprint "event_%s_%s" (class_name cl) (I.name_of event)) (event_params event) 540 | ) (I.class_events cl) 541 | ); 542 | (*let print_field cl = function 543 | | Event (name, args) -> 544 | print o "#define self_on_%s %s" name (method_name cl ("on_" ^ name)); 545 | (*print_proxy o ("self_on_" ^ name) (add_self cl args);*) 546 | *) 547 | o ""; 548 | o "/* Class definition */"; 549 | o ""; 550 | if is_abstract cl then ( 551 | print o "GOO_INTERNAL_WITNESS(%s, %d);" 552 | (class_name cl) (I.class_depth cl); 553 | ) else ( 554 | print o "GOO_INTERNAL_DISPLAY(%s, %d)" 555 | (class_name cl) (I.class_depth cl); 556 | o "{"; 557 | print o " GOO_INTERNAL_DISPLAY_INIT(%s, %d, %d)" 558 | (class_name cl) (I.class_depth cl) (number_of_properties cl); 559 | let rec witnesses acc c = 560 | let name = "&goo_" ^ class_name c ^ "_witness" in 561 | match I.class_extend c with 562 | | None -> name :: acc 563 | | Some c -> witnesses (name :: acc) c 564 | in 565 | print o " {%s}" (String.concat ", " (witnesses [] cl)); 566 | o "};"; 567 | o ""; 568 | print o "GOO_INTERNAL_TABLE(%s)" (class_name cl); 569 | o "{"; 570 | print o " GOO_INTERNAL_TABLE_INIT(%s)," (class_name cl); 571 | iter_ancestors ~and_self:true cl 572 | (fun cl -> 573 | List.iter 574 | (fun func -> 575 | if is_dynamic func then 576 | print o " GOO_INTERNAL_TABLE_METHOD(%s)," (I.name_of func)) 577 | (I.class_funcs cl) 578 | ); 579 | o "};"; 580 | ); 581 | o ""; 582 | o "/* Method bodies */"; 583 | o ""; 584 | (* Overriden methods *) 585 | iter_ancestors cl (fun cl' -> 586 | List.iter 587 | (fun func -> 588 | match lookup_override cl func with 589 | | cl0 :: _ when cl0 = cl -> 590 | begin match method_bodies cl func with 591 | | Some body -> 592 | print o "$method %sself_%s(%s)" 593 | (func_ret_str func) (I.name_of func) (func_params_str ~at_class:cl func); 594 | o "{"; 595 | List.iter o body; 596 | o "}"; 597 | | None -> () 598 | end 599 | | _ -> () 600 | ) 601 | (I.class_funcs cl') 602 | ); 603 | (* New methods *) 604 | List.iter 605 | (fun func -> 606 | match method_bodies cl func with 607 | | Some body -> 608 | print o "$method %sself_%s(%s)" 609 | (func_ret_str func) (I.name_of func) (func_params_str func); 610 | o "{"; 611 | List.iter o body; 612 | o "}"; 613 | | None -> () 614 | ) (I.class_funcs cl) 615 | 616 | let print_class_impl_c cl o = 617 | print o "#include \"%s.h\"" (class_name cl); 618 | o "" 619 | 620 | let guard_header o n f = 621 | let n = String.uppercase_ascii n in 622 | print o "#ifndef __%s_H__" n; 623 | print o "#define __%s_H__" n; 624 | o ""; 625 | let result = f o in 626 | o ""; 627 | print o "#endif /* !__%s_H__ */" n; 628 | result 629 | 630 | let with_file ~force name f = 631 | let file_exists = Sys.file_exists name in 632 | if file_exists && not force then () else 633 | let name' = if file_exists then "." ^ name else name in 634 | let oc = open_out name' in 635 | let last_blank = ref true in 636 | let output_line line = 637 | let blank = line = "" in 638 | if not (!last_blank && blank) then ( 639 | output_string oc line; 640 | output_char oc '\n' 641 | ); 642 | last_blank := blank 643 | in 644 | let cleanup () = 645 | close_out_noerr oc; 646 | if file_exists then ( 647 | let hash = Digest.file name in 648 | let hash' = Digest.file name' in 649 | if Digest.equal hash hash' then 650 | Sys.remove name' 651 | else 652 | Sys.rename name' name 653 | ) 654 | in 655 | try 656 | let r = f output_line in 657 | cleanup (); 658 | r 659 | with exn -> 660 | cleanup (); 661 | raise exn 662 | 663 | let generate pkg ~dir = 664 | let rec mkdir path = 665 | if Sys.file_exists path then () else 666 | let dir, name = Filename.dirname path, Filename.basename path in 667 | if dir = path then () else mkdir dir; 668 | (try Unix.mkdir name 0o777 with _ -> ()) 669 | in 670 | mkdir dir; 671 | let filename base ext = Filename.concat dir (base ^ "." ^ ext) in 672 | with_file (filename (I.name_of pkg) "h") ~force:true (fun o -> 673 | guard_header o 674 | (String.uppercase_ascii (I.name_of pkg) ^ "_CLASSES") 675 | (print_package_h pkg)); 676 | List.iter 677 | (fun c -> with_file ~force:true (filename (class_name c) "h") (print_class_impl_h c)) 678 | (I.package_classes pkg); 679 | List.iter 680 | (fun c -> with_file ~force:false (filename (class_name c) "c") (print_class_impl_c c)) 681 | (I.package_classes pkg); 682 | () 683 | -------------------------------------------------------------------------------- /gen/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name goo_gen) 3 | ;(public_name goo.gen) 4 | (libraries unix)) 5 | -------------------------------------------------------------------------------- /gen/id.ml: -------------------------------------------------------------------------------- 1 | (* Some tools for making abstract names *) 2 | type name = string 3 | 4 | (* Abuse object ids to get well behaved physical identity (comparison, hashing, 5 | etc). *) 6 | external oo_id : unit -> int = "caml_fresh_oo_id" 7 | 8 | type 'a t = { value : 'a; id : int; name : name } 9 | 10 | let inj name value = 11 | let result : 'b = { value; id = oo_id (); name } in 12 | (Obj.obj (Obj.with_tag Obj.object_tag (Obj.repr result)) : 'b) 13 | 14 | let prj x = x.value 15 | 16 | let name x = x.name 17 | 18 | type void 19 | let forget : _ t -> void t = Obj.magic 20 | -------------------------------------------------------------------------------- /gen/id.mli: -------------------------------------------------------------------------------- 1 | (* Some tools for abstracting names *) 2 | type name = string 3 | 4 | type 'a t 5 | val inj : name -> 'a -> 'a t 6 | val prj : 'a t -> 'a 7 | val name : 'a t -> name 8 | 9 | type void 10 | val forget : _ t -> void t 11 | -------------------------------------------------------------------------------- /gen/ml.ml: -------------------------------------------------------------------------------- 1 | open Model 2 | module I = Introspect 3 | 4 | let sprint = Printf.sprintf 5 | let print o fmt = Printf.ksprintf o fmt 6 | 7 | let qualify_pkg (pkg : package) path_pkg path = 8 | if pkg = path_pkg then path else 9 | sprint "%s.%s" (String.capitalize_ascii (I.name_of path_pkg)) path 10 | 11 | let class_name pkg cl = 12 | let cl_pkg = I.class_package cl in 13 | if cl = goo_object then 14 | "goo_object" 15 | else 16 | qualify_pkg pkg cl_pkg (I.name_of cl) 17 | 18 | let enum_name pkg en = 19 | qualify_pkg pkg (I.enum_package en) (I.name_of en) 20 | 21 | let c_func_name func = C.func_symbol func 22 | 23 | exception Not_an_ml_type 24 | 25 | let mltype pkg = function 26 | | Bool -> "bool" 27 | | Int -> "int" 28 | | Float -> "float" 29 | | String -> "string" 30 | | Flag e -> enum_name pkg e 31 | | Object t -> sprint "[> %s] goo" (class_name pkg t) 32 | | Object_option t -> sprint "[> %s] goo option" (class_name pkg t) 33 | | Custom _ -> raise Not_an_ml_type 34 | 35 | let ml_function pkg ?(allow_caf=false) args ret = 36 | let mltype_ret = function 37 | | (Object t | Object_option t as x) -> 38 | let opt = match x with Object_option _ -> " option" | _ -> "" in 39 | sprint "%s goo%s" (class_name pkg t) opt 40 | | x -> mltype pkg x 41 | in 42 | let rec aux acc = function 43 | | [] -> 44 | List.rev 45 | ((if ret = [] then "unit" else String.concat " * " (List.map mltype_ret ret)) :: acc) 46 | | (_, typ) :: xs -> aux (mltype pkg typ :: acc) xs 47 | in 48 | let args = match aux [] args with 49 | | [ret] when not allow_caf -> ["unit"; ret] 50 | | args -> args 51 | in 52 | String.concat " -> " args 53 | 54 | let print_ml_stubs pkg o = 55 | o "open Goo"; 56 | o ""; 57 | List.iter (fun e -> 58 | print o "type %s = [" (enum_name pkg e); 59 | List.iter 60 | (fun x -> print o " | `%s" (I.name_of x)) 61 | (I.enum_members e); 62 | o "]"; 63 | ) (I.package_enums pkg); 64 | List.iter (fun c -> 65 | begin match I.class_extend c with 66 | | None -> print o "type %s = [`%s]" (I.name_of c) (class_name pkg c) 67 | | Some c' -> 68 | let cname = class_name pkg c in 69 | let c'name = class_name pkg c' in 70 | print o "type %s = [`%s | %s]" cname (C.class_name c) c'name; 71 | end; 72 | o "" 73 | ) (I.package_classes pkg); 74 | List.iter (fun func -> 75 | print o "external %s : %s = \"ml_%s\"" 76 | (I.name_of func) 77 | (ml_function pkg (I.func_args func) (I.func_ret func)) 78 | (c_func_name func) 79 | ) (I.package_funcs pkg); 80 | List.iter (fun cl -> 81 | o ""; 82 | let cname' = I.name_of cl in 83 | let cname = C.class_name cl in 84 | print o "external %s_witness : unit -> %s witness = \"ml_witness_%s\"" cname' cname' cname; 85 | let stub_name name arity = 86 | if arity > 5 then 87 | sprint "\"ml_bc_%s\" \"ml_%s\"" name name 88 | else 89 | sprint "\"ml_%s\"" name 90 | in 91 | List.iter (fun func -> 92 | try 93 | print o "external %s_%s : %s = %s" 94 | (I.name_of cl) (I.name_of func) 95 | (ml_function pkg (I.func_args func) (I.func_ret func)) 96 | (stub_name (C.func_symbol func) (List.length (I.func_args func))) 97 | with Not_an_ml_type -> ()) 98 | (I.class_funcs cl); 99 | List.iter (fun event -> 100 | print o "let event_%s_%s : ([> %s], %s) event = Obj.magic %d" 101 | (I.name_of cl) (I.name_of event) (I.name_of cl) 102 | (ml_function pkg ~allow_caf:true (I.event_args event) (I.event_ret event)) 103 | (C.property_index cl (I.name_of event)) 104 | ) (I.class_events cl); 105 | List.iter (function 106 | | I.Rel_collection col -> 107 | let name = I.name_of col in 108 | let prefix' = sprint "%s_%s" cname' name in 109 | let prefix = sprint "%s_%s" cname name in 110 | let target = class_name pkg (I.port_target (I.collection_port col)) in 111 | print o "external %s_prev : [> %s] goo -> %s goo option = \"ml_%s_prev\"" 112 | prefix' target target prefix; 113 | print o "external %s_next : [> %s] goo -> %s goo option = \"ml_%s_next\"" 114 | prefix' target target prefix; 115 | print o "external %s_first : [> %s] goo -> %s goo option = \"ml_%s_first\"" 116 | prefix' cname' target prefix; 117 | print o "external %s_last : [> %s] goo -> %s goo option = \"ml_%s_last\"" 118 | prefix' cname' target prefix; 119 | print o "external %s_parent : [> %s] goo -> %s goo option = \"ml_%s_parent\"" 120 | prefix' target cname' prefix; 121 | | I.Rel_slot sl -> 122 | let name = I.name_of sl in 123 | let prefix' = sprint "%s_%s" cname' name in 124 | let prefix = sprint "%s_%s" cname name in 125 | let target = class_name pkg (I.port_target (I.slot_port sl)) in 126 | print o "external %s_get : [> %s] goo -> %s goo option = \"ml_%s_get\"" 127 | prefix' cname' target prefix; 128 | | I.Rel_port pt -> 129 | let name = I.name_of pt in 130 | let prefix' = sprint "%s_%s" cname' name in 131 | let prefix = sprint "%s_%s" cname name in 132 | print o "external %s_get : [> %s] goo -> %s goo option = \"ml_%s_get\"" 133 | prefix' cname' (class_name pkg (I.port_source pt)) prefix; 134 | print o "external %s_detach : [> %s] goo -> unit = \"ml_%s_detach\"" 135 | prefix' cname' prefix; 136 | ) (I.class_relations cl) 137 | ) (I.package_classes pkg) 138 | 139 | let n_args n = 140 | let r = ref [] in 141 | for i = n - 1 downto 0 142 | do r := ("value arg" ^ string_of_int i) :: !r done; 143 | String.concat ", " !r 144 | 145 | let rec caml_xparam o i j = 146 | match j - i with 147 | | 0 -> () 148 | | 1 -> 149 | print o " CAMLxparam1(arg%d);" i 150 | | 2 -> 151 | print o " CAMLxparam2(arg%d, arg%d);" i (i + 1) 152 | | 3 -> 153 | print o " CAMLxparam3(arg%d, arg%d, arg%d);" i (i + 1) (i + 2) 154 | | 4 -> 155 | print o " CAMLxparam4(arg%d, arg%d, arg%d, arg%d);" 156 | i (i + 1) (i + 2) (i + 3) 157 | | _ -> 158 | print o " CAMLxparam5(arg%d, arg%d, arg%d, arg%d, arg%d);" 159 | i (i + 1) (i + 2) (i + 3) (i + 4); 160 | caml_xparam o (i + 5) j 161 | 162 | let caml_param o = function 163 | | 0 -> o " CAMLparam0();" 164 | | 1 -> o " CAMLparam1(arg0);" 165 | | 2 -> o " CAMLparam2(arg0, arg1);" 166 | | 3 -> o " CAMLparam3(arg0, arg1, arg2);" 167 | | 4 -> o " CAMLparam4(arg0, arg1, arg2, arg3);" 168 | | n -> 169 | o " CAMLparam5(arg0, arg1, arg2, arg3, arg4);"; 170 | caml_xparam o 5 n 171 | 172 | let rec caml_local o i j = 173 | match j - i with 174 | | 0 -> () 175 | | 1 -> 176 | print o " CAMLlocal1(var%d);" i 177 | | 2 -> 178 | print o " CAMLlocal2(var%d, var%d);" i (i + 1) 179 | | 3 -> 180 | print o " CAMLlocal3(var%d, var%d, var%d);" i (i + 1) (i + 2) 181 | | 4 -> 182 | print o " CAMLlocal4(var%d, var%d, var%d, var%d);" 183 | i (i + 1) (i + 2) (i + 3) 184 | | _ -> 185 | print o " CAMLlocal5(var%d, var%d, var%d, var%d, var%d);" 186 | i (i + 1) (i + 2) (i + 3) (i + 4); 187 | caml_local o (i + 5) j 188 | 189 | let caml_local o n = caml_local o 0 n 190 | 191 | let hash_variant s = 192 | let accu = ref 0 in 193 | for i = 0 to String.length s - 1 do 194 | accu := 223 * !accu + Char.code s.[i] 195 | done; 196 | (* reduce to 31 bits *) 197 | accu := !accu land (1 lsl 31 - 1); 198 | (* make it signed for 64 bits architectures *) 199 | if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu 200 | 201 | let bytecode_proxy o name argc = 202 | print o "value ml_bc_%s(value *argv, int argn)" name; 203 | o "{"; 204 | print o " goo_assert (argn = %d);" argc; 205 | let acc = ref [] in 206 | for i = argc - 1 downto 0 do 207 | acc := sprint "argv[%d]" i :: !acc 208 | done; 209 | print o " return ml_%s(%s);" name (String.concat "," !acc); 210 | o "}" 211 | 212 | let print_ml_c_stubs pkg o = 213 | o "#include "; 214 | o "#include "; 215 | o "#include "; 216 | o "#include \"ml_goo.h\""; 217 | print o "#include \"%s.h\"" (I.name_of pkg); 218 | o ""; 219 | List.iter (fun c -> 220 | print o "value ml_witness_%s(value unit) \ 221 | { return (((intnat)&goo_%s_witness)|1); }" 222 | (C.class_name c) (C.class_name c) 223 | ) (I.package_classes pkg); 224 | o ""; 225 | List.iter (fun e -> 226 | print o "value Val_%s(%s v)" (I.name_of e) (C.enum_name e); 227 | o "{"; 228 | o " switch (v)"; 229 | o " {"; 230 | List.iter (fun member -> 231 | let member = I.name_of member in 232 | print o " case %s: return Val_long(%d);" member (hash_variant member); 233 | ) (I.enum_members e); 234 | o " default:"; 235 | o " abort();"; 236 | o " }"; 237 | o "}"; 238 | o ""; 239 | print o "%s %s_val(value e)" (C.enum_name e) (I.name_of e); 240 | o "{"; 241 | o " switch (Long_val(e))"; 242 | o " {"; 243 | List.iter (fun member -> 244 | let member = I.name_of member in 245 | print o " case %d: return %s;" (hash_variant member) member; 246 | ) (I.enum_members e); 247 | o " default:"; 248 | o " abort();"; 249 | o " }"; 250 | o "}"; 251 | o ""; 252 | ) (I.package_enums pkg); 253 | let prj_typ typ var = match typ with 254 | | Bool -> sprint "Bool_val(%s)" var 255 | | Int -> sprint "Long_val(%s)" var 256 | | Float -> sprint "Double_val(%s)" var 257 | | String -> sprint "Goo_string_val(%s)" var 258 | | Flag e -> sprint "%s_val(%s)" (I.name_of e) var 259 | | Object cl -> sprint "$Goo_val(%s, %s)" var (C.class_name cl) 260 | | Object_option cl -> sprint "$Goo_val_option(%s, %s)" var (C.class_name cl) 261 | | Custom _ -> raise Not_an_ml_type 262 | in 263 | let inj_typ typ var = match typ with 264 | | Bool -> sprint "Val_bool(%s)" var 265 | | Int -> sprint "Val_long(%s)" var 266 | | Float -> sprint "caml_copy_double(%s)" var 267 | | String -> sprint "Val_goo_string(%s)" var 268 | | Flag e -> sprint "Val_%s(%s)" (I.name_of e) var 269 | | Object _ -> sprint "$Val_goo(%s)" var 270 | | Object_option _ -> sprint "$Val_goo_option(%s)" var 271 | | Custom _ -> raise Not_an_ml_type 272 | in 273 | let print_func func = 274 | let args = List.mapi (fun i (_, typ) -> prj_typ typ ("arg" ^ string_of_int i)) (I.func_args func) in 275 | if List.exists (function (Custom _) -> true | _ -> false) (I.func_ret func) then 276 | raise Not_an_ml_type; 277 | o ""; 278 | let argc = List.length args in 279 | print o "value ml_%s(%s)" (C.func_symbol func) (n_args argc); 280 | o "{"; 281 | caml_param o argc; 282 | o " GOO_ENTER_REGION;"; 283 | let call args = sprint "%s(%s)" (C.func_symbol func) (String.concat ", " args) in 284 | begin match I.func_ret func with 285 | | [] -> 286 | print o " %s;" (call args); 287 | o " GOO_LEAVE_REGION;"; 288 | o " CAMLreturn(Val_unit);" 289 | | [typ] -> 290 | print o " value goo_result = %s;" (inj_typ typ (call args)); 291 | o " GOO_LEAVE_REGION;"; 292 | o " CAMLreturn(goo_result);"; 293 | | typs -> 294 | let args' = List.mapi (fun i typ -> let name = "ret" ^ string_of_int i in print o " %s;" (C.ctype name typ); (name, typ)) typs in 295 | print o " %s;" (call (args @ List.map (fun (x,_) -> "&" ^ x) args')); 296 | o " value *tuple = goo_region_alloc();"; 297 | print o "*tuple = caml_alloc_tuple(%d);" (List.length typs); 298 | List.iteri (fun i (arg,typ) -> print o " Field(*tuple,%d) = %s;" i (inj_typ typ arg)) args'; 299 | o " value goo_result = *tuple;"; 300 | o " GOO_LEAVE_REGION;"; 301 | o " CAMLreturn(goo_result);"; 302 | end; 303 | o "}"; 304 | if (argc > 5) then bytecode_proxy o (C.func_symbol func) argc 305 | in 306 | List.iter (fun x -> try print_func x with Not_an_ml_type -> ()) (I.package_funcs pkg); 307 | List.iter (fun c -> 308 | let cname = C.class_name c in 309 | List.iter (fun x -> try print_func x with Not_an_ml_type -> ()) (I.class_funcs c); 310 | List.iter (fun event -> 311 | o ""; 312 | let index = C.property_index c (I.name_of event) in 313 | print o "goo_bool %s(%s)" 314 | (C.event_symbol event) (C.event_params_str event); 315 | o "{"; 316 | o " CAMLparam0();"; 317 | let cargs = I.event_args ~with_self:false event in 318 | print o " CAMLlocalN(var, %d);" (1 + List.length cargs); 319 | print o " var[0] = $Val_goo_handler_helper(self, %d);" index; 320 | o " if (var[0] == Val_unit)"; 321 | o " CAMLreturn(0);"; 322 | List.iteri (fun i (name, typ) -> 323 | let inj = match typ with 324 | | Bool -> "Val_bool" 325 | | Int -> "Val_long" 326 | | Float -> "caml_copy_double" 327 | | String -> "Val_goo_string" 328 | | Flag e -> sprint "Val_%s" (enum_name pkg e) 329 | | Object _ -> "$Val_goo" 330 | | Object_option _ -> "$Val_goo_option" 331 | | Custom _ -> assert false 332 | in 333 | print o " var[%d] = %s(%s);" (i + 1) inj name; 334 | ) cargs; 335 | print o " var[0] = caml_callbackN_exn(Field(var[0],%d+2),%d,&var[0]);" 336 | index (1 + List.length cargs); 337 | o " if (Is_exception_result(var[0])) {"; 338 | o " var[0] = Extract_exception(var[0]);"; 339 | print o " ml_goo_debug_aborted_event(%S, var[0]);" (C.event_symbol event); 340 | o " CAMLreturn(0);"; 341 | o " }"; 342 | begin match C.event_ret event with 343 | | [] -> () 344 | | [var, typ] -> 345 | print o " *%s = %s;" var (prj_typ typ "var[0]") 346 | | typs -> 347 | List.iteri (fun i (var, typ) -> print o " *%s = %s;" var (prj_typ typ (sprint "Field(var[0],%d)" i))) typs 348 | end; 349 | o " "; 350 | o " CAMLreturn(1);"; 351 | o "}"; 352 | ) (I.class_events c); 353 | List.iter (function 354 | | I.Rel_collection col -> 355 | let pt = I.collection_port col in 356 | print o "GOO_STUB_COLLECTION(%s, %s, %s, %s);" 357 | cname (I.name_of col) (C.class_name (I.port_target pt)) (I.name_of pt) 358 | | I.Rel_slot sl -> 359 | let pt = I.slot_port sl in 360 | print o "GOO_STUB_SLOT(%s, %s, %s, %s);" 361 | cname (I.name_of sl) (C.class_name (I.port_target pt)) (I.name_of pt) 362 | | I.Rel_port pt -> 363 | print o "GOO_STUB_PORT(%s, %s, %s);" 364 | cname (I.name_of pt) (C.class_name (I.port_source pt)); 365 | ) (I.class_relations c); 366 | ) (I.package_classes pkg) 367 | 368 | let generate pkg ~dir = 369 | let rec mkdir path = 370 | if Sys.file_exists path then () else 371 | let dir, name = Filename.dirname path, Filename.basename path in 372 | if dir = path then () else mkdir dir; 373 | (try Unix.mkdir name 0o777 with _ -> ()) 374 | in 375 | mkdir dir; 376 | let filename base ext = Filename.concat dir (base ^ "." ^ ext) in 377 | C.with_file (filename (I.name_of pkg) "ml") ~force:true (print_ml_stubs pkg); 378 | C.with_file (filename (I.name_of pkg ^ "_stubs") "c") ~force:true (print_ml_c_stubs pkg); 379 | () 380 | -------------------------------------------------------------------------------- /gen/model.ml: -------------------------------------------------------------------------------- 1 | (* An identifier name, must be a valid OCaml and C identifier *) 2 | type name = string 3 | 4 | let failwithf fmt = Printf.ksprintf failwith fmt 5 | 6 | module Sealed_list : sig 7 | type seal 8 | val seal: unit -> seal 9 | 10 | type 'a t 11 | val make : seal -> 'a t 12 | val append : 'a t -> 'a -> ('fmt, unit, string, unit) format4 -> 'fmt 13 | val read : 'a t -> 'a list 14 | (*val unsafe_rev_read : 'a t -> 'a list*) 15 | end = struct 16 | type seal = bool ref 17 | let seal () = ref false 18 | type 'a t = { mutable items: 'a list; mutable sealed: bool; seal : seal } 19 | let make seal = 20 | if !seal then invalid_arg "Sealed_list.make: seal is already broken"; 21 | { items = []; sealed = false; seal } 22 | 23 | let append xs x fmt = 24 | if !(xs.seal) then failwithf fmt 25 | else ( 26 | xs.items <- x :: xs.items; 27 | Printf.ifprintf () fmt 28 | ) 29 | 30 | let read xs = 31 | xs.seal := true; 32 | if not xs.sealed then ( 33 | xs.sealed <- true; 34 | xs.items <- List.rev xs.items; 35 | ); 36 | xs.items 37 | 38 | (*let unsafe_rev_read xs = xs.items*) 39 | end 40 | 41 | type 'a id = 'a Id.t 42 | let ignore_id : _ id -> unit = ignore 43 | 44 | type 'a sealed_list = 'a Sealed_list.t 45 | let seal = Sealed_list.seal 46 | let sealed_list = Sealed_list.make 47 | let append = Sealed_list.append 48 | 49 | (* Packages are the root of declarations. 50 | A package contains a list of classes, enums and functions. *) 51 | type package_desc = { 52 | pk_enums: enum sealed_list; 53 | pk_classes: classe sealed_list; 54 | pk_funcs: func sealed_list; 55 | } 56 | 57 | and classe_desc = { 58 | cl_package: package; 59 | cl_extend: classe option; 60 | cl_funcs: func sealed_list; 61 | cl_events : event sealed_list; 62 | cl_relations : classe_relation sealed_list; 63 | } 64 | 65 | and classe_relation = 66 | | Rel_port of port 67 | | Rel_slot of slot 68 | | Rel_collection of collection 69 | 70 | and func_desc = { 71 | fn_ret : ctype list; 72 | fn_args : arg list; 73 | fn_kind : func_kind; 74 | } 75 | 76 | and func_kind = 77 | | Fn_class of classe 78 | | Fn_package of package 79 | 80 | and event_desc = { 81 | ev_classe : classe; 82 | ev_args : arg list; 83 | ev_ret : ctype list; 84 | } 85 | 86 | and enum_desc = { 87 | en_package: package; 88 | en_members: enum_member sealed_list; 89 | } 90 | 91 | and enum_member_desc = { 92 | enm_enum : enum; 93 | } 94 | 95 | and port_desc = { 96 | pt_source : classe; 97 | pt_target : classe; 98 | } 99 | 100 | and collection_desc = { 101 | col_classe : classe; 102 | col_port : port; 103 | } 104 | 105 | and slot_desc = { 106 | sl_classe : classe; 107 | sl_port : port; 108 | } 109 | 110 | and enum = enum_desc id 111 | and enum_member = enum_member_desc id 112 | and event = event_desc id 113 | and func = func_desc id 114 | and classe = classe_desc id 115 | and package = package_desc id 116 | and port = port_desc id 117 | and collection = collection_desc id 118 | and slot = slot_desc id 119 | 120 | and arg = name * ctype 121 | 122 | and ctype = 123 | | Bool 124 | | Int 125 | | Float 126 | | String 127 | | Object of classe 128 | | Object_option of classe 129 | | Custom of string 130 | | Flag of enum 131 | 132 | let package name = 133 | let seal = Sealed_list.seal () in 134 | Id.inj name { 135 | pk_enums = sealed_list seal; 136 | pk_classes = sealed_list seal; 137 | pk_funcs = sealed_list seal; 138 | } 139 | 140 | let classe cl_package cl_extend name = 141 | let seal = seal () in 142 | let result = Id.inj name { 143 | cl_package; 144 | cl_extend; 145 | cl_funcs = sealed_list seal; 146 | cl_relations = sealed_list seal; 147 | cl_events = sealed_list seal; 148 | } in 149 | append (Id.prj cl_package).pk_classes result 150 | "adding class %s to package %s which is already sealed" 151 | name (Id.name cl_package); 152 | result 153 | 154 | let enum en_package name = 155 | let seal = seal () in 156 | let result = Id.inj name { en_package; en_members = sealed_list seal; } in 157 | append (Id.prj en_package).pk_enums result 158 | "adding enum %s to package %s which is already sealed" 159 | name (Id.name en_package); 160 | result 161 | 162 | let enum_member' enm_enum name = 163 | let result = Id.inj name { enm_enum } in 164 | append (Id.prj enm_enum).en_members result 165 | "adding member %s to enumeration %s which is already sealed" 166 | name (Id.name enm_enum); 167 | result 168 | 169 | let event' ev_classe ev_ret name ev_args = 170 | let ev = Id.inj name { ev_classe; ev_ret; ev_args; } in 171 | append (Id.prj ev_classe).cl_events ev 172 | "adding event %s to class %s which is already sealed" 173 | name (Id.name ev_classe); 174 | ev 175 | 176 | let enum_member enm_enum name = 177 | ignore_id (enum_member' enm_enum name) 178 | 179 | let event ev_classe ev_ret name ev_args = 180 | ignore_id (event' ev_classe ev_ret name ev_args) 181 | 182 | let int = Int 183 | let bool = Bool 184 | let float = Float 185 | let string = String 186 | let flag enum = Flag enum 187 | let arg name typ = (name, typ) 188 | let objet cl = Object cl 189 | let objet_opt cl = Object_option cl 190 | 191 | let raw_func fn_kind fn_ret name fn_args = 192 | Id.inj name { fn_args; fn_ret; fn_kind } 193 | 194 | let func' pkg ret name args = 195 | let func = raw_func (Fn_package pkg) ret name args in 196 | append (Id.prj pkg).pk_funcs func 197 | "adding function %s to package %s which is already sealed" 198 | name (Id.name pkg); 199 | func 200 | 201 | let meth' cl ret name args = 202 | let func = raw_func (Fn_class cl) ret name args in 203 | append (Id.prj cl).cl_funcs func 204 | "adding method %s to class %s which is already sealed" 205 | name (Id.name cl); 206 | func 207 | 208 | let compare_classe cl1 cl2 = 209 | let rec is_ancestor ancestor cl = 210 | match (Id.prj cl).cl_extend with 211 | | None -> false 212 | | Some cl' -> (cl' = ancestor || is_ancestor ancestor cl') 213 | in 214 | if cl1 = cl2 then `Eq else 215 | if is_ancestor cl1 cl2 then `Lt 216 | else if is_ancestor cl2 cl1 then `Gt 217 | else `Neq 218 | 219 | let func_args_at_class func classe = 220 | match (Id.prj func).fn_args with 221 | | ("self", Object cl) :: rest when compare_classe cl classe = `Lt -> 222 | ("self", Object classe) :: rest 223 | | args -> args 224 | 225 | let port pt_target name pt_source = 226 | let port = Id.inj name { pt_target; pt_source } in 227 | append (Id.prj pt_target).cl_relations (Rel_port port) 228 | "adding port %s to class %s which is already sealed" 229 | name (Id.name pt_target); 230 | port 231 | 232 | let slot' sl_classe name sl_port = 233 | let slot = Id.inj name { sl_classe; sl_port } in 234 | append (Id.prj sl_classe).cl_relations (Rel_slot slot) 235 | "adding slot %s to class %s which is already sealed" 236 | name (Id.name sl_classe); 237 | slot 238 | 239 | let collection' col_classe name col_port = 240 | let collection = Id.inj name { col_classe; col_port } in 241 | append (Id.prj col_classe).cl_relations (Rel_collection collection) 242 | "adding collection %s to class %s which is already sealed" 243 | name (Id.name col_classe); 244 | collection 245 | 246 | let func pkg ret name args = 247 | ignore_id (func' pkg ret name args) 248 | 249 | let meth cl ret name args = 250 | ignore_id (meth' cl ret name args) 251 | 252 | let slot sl_classe name sl_port = 253 | ignore_id (slot' sl_classe name sl_port) 254 | 255 | let collection col_classe name col_port = 256 | ignore_id (collection' col_classe name col_port) 257 | 258 | let seal_package pkg = 259 | ignore (Sealed_list.read (Id.prj pkg).pk_classes) 260 | 261 | let seal_classe cl = 262 | ignore (Sealed_list.read (Id.prj cl).cl_funcs) 263 | 264 | (* Runtime support package and root of object hierarchy *) 265 | let goo = package "goo" 266 | 267 | let goo_object = classe goo None "object" 268 | let goo_destroy = meth' goo_object [] "destroy" ["self", Object goo_object] 269 | 270 | let () = ( 271 | seal_package goo; 272 | seal_classe goo_object 273 | ) 274 | 275 | let classe package ?(extend=goo_object) name = 276 | classe package (Some extend) name 277 | 278 | module Introspect = struct 279 | module Table = struct 280 | type ('a, 'b) table = ('a, 'b) Hashtbl.t 281 | let create () = Hashtbl.create 7 282 | let add tbl k v = Hashtbl.add tbl k v 283 | let rem tbl k = Hashtbl.remove tbl k 284 | let mem tbl k = Hashtbl.mem tbl k 285 | let find tbl k = Hashtbl.find tbl k 286 | end 287 | 288 | let name_of = Id.name 289 | 290 | let read = Sealed_list.read 291 | 292 | let package_classes pkg = read (Id.prj pkg).pk_classes 293 | let package_enums pkg = read (Id.prj pkg).pk_enums 294 | let package_funcs pkg = read (Id.prj pkg).pk_funcs 295 | 296 | let class_package cl = (Id.prj cl).cl_package 297 | let class_extend cl = (Id.prj cl).cl_extend 298 | let class_depth cl = 299 | let rec aux n cl = match class_extend cl with 300 | | None -> n 301 | | Some cl' -> aux (n + 1) cl' 302 | in 303 | aux 0 cl 304 | let class_funcs cl = read (Id.prj cl).cl_funcs 305 | let class_events cl = read (Id.prj cl).cl_events 306 | 307 | type class_relation = classe_relation = 308 | | Rel_port of port 309 | | Rel_slot of slot 310 | | Rel_collection of collection 311 | 312 | let class_relations cl = read (Id.prj cl).cl_relations 313 | 314 | let enum_package en = (Id.prj en).en_package 315 | let enum_members en = read (Id.prj en).en_members 316 | let enum_member_enum enm = (Id.prj enm).enm_enum 317 | 318 | type nonrec func_kind = func_kind = 319 | | Fn_class of classe 320 | | Fn_package of package 321 | 322 | let func_kind fn = (Id.prj fn).fn_kind 323 | let func_ret fn = (Id.prj fn).fn_ret 324 | let func_args ?at_class fn = 325 | match at_class with 326 | | None -> (Id.prj fn).fn_args 327 | | Some cl -> func_args_at_class fn cl 328 | 329 | let port_source pt = (Id.prj pt).pt_source 330 | let port_target pt = (Id.prj pt).pt_target 331 | 332 | let slot_classe sl = (Id.prj sl).sl_classe 333 | let slot_port sl = (Id.prj sl).sl_port 334 | 335 | let collection_classe col = (Id.prj col).col_classe 336 | let collection_port col = (Id.prj col).col_port 337 | 338 | let event_classe ev = (Id.prj ev).ev_classe 339 | let event_args ?(with_self=false) ev = 340 | let result = (Id.prj ev).ev_args in 341 | if with_self 342 | then ("self", Object (event_classe ev)) :: result 343 | else result 344 | let event_ret ev = (Id.prj ev).ev_ret 345 | end 346 | -------------------------------------------------------------------------------- /gen/model.mli: -------------------------------------------------------------------------------- 1 | (* In Goo, one models a library to bind by describing the shape of the heap: 2 | - defining the objects (nodes of the heap graph), 3 | - the relations between objects (edges of the heap graph), 4 | - their methods (what can be done with an object). 5 | 6 | This module gives the definition of all entities. 7 | See [examples/libui/desc.ml] for a sample use of the entities. 8 | *) 9 | (* An identifier name, must be a valid OCaml and C identifier. 10 | An id is just a wrapper that gives a value a physical identity. 11 | *) 12 | type name = string 13 | type 'a id = 'a Id.t 14 | 15 | (* Abstract types for all entities manipulated in the model. *) 16 | type classe_desc 17 | type collection_desc 18 | type enum_desc 19 | type enum_member_desc 20 | type event_desc 21 | type func_desc 22 | type package_desc 23 | type port_desc 24 | type slot_desc 25 | 26 | (* Packages are the root of declarations. 27 | A package contains a list of classes, enums and functions. *) 28 | type package = package_desc id 29 | val package : name -> package 30 | 31 | (* Classes describe the shape of the nodes. 32 | A class can extend another one. An instance of a class B that extends class 33 | A is also an instance of A. *) 34 | type classe = classe_desc id 35 | val classe : package -> ?extend:classe -> name -> classe 36 | 37 | (* A C-like enumeration: a bunch of names that can be distinguished *) 38 | type enum = enum_desc id 39 | type enum_member = enum_member_desc id 40 | val enum : package -> name -> enum 41 | val enum_member' : enum -> name -> enum_member 42 | val enum_member : enum -> name -> unit 43 | 44 | (* Goo has a simple type system. 45 | Basic types represent simple values, the ones that don't appear in the heap 46 | graph. `Object' and `Object_option' are the two kind of values that affect 47 | the heap graph. 48 | `Flag' is a value taken from an enumeration. 49 | `Custom' is an arbitrary string that is given to the backend and may or may 50 | not make sense. (TODO: that's where Ctypes should be integrated). 51 | *) 52 | type ctype = 53 | | Bool 54 | | Int 55 | | Float 56 | | String 57 | | Object of classe 58 | | Object_option of classe 59 | | Custom of string 60 | | Flag of enum 61 | 62 | (* Some sugar for basic types. *) 63 | val int: ctype 64 | val bool: ctype 65 | val float: ctype 66 | val string: ctype 67 | val flag: enum -> ctype 68 | val objet: classe -> ctype 69 | val objet_opt: classe -> ctype 70 | 71 | (* Arguments of functions or methods are made from a name and type. 72 | Right now they are nothing more than a pair. *) 73 | type arg = name * ctype 74 | val arg: name -> ctype -> arg 75 | 76 | (* Functions for basic definitions come in two flavors: 77 | - the base one just register the definition 78 | - the one suffixed with `'` returns an opaque name that witnesses the 79 | definition. 80 | This name can be used to pass meta-data / specific knowledge to the backend. 81 | For instance, `Goo_c.set_dynamic a_method` informs the C backend that a 82 | method returned by `meth'` has dynamic dispatch. 83 | *) 84 | type func = func_desc id 85 | type event = event_desc id 86 | 87 | (* A function declaration is read in the "C" order: 88 | func ; 89 | 90 | Multiple return types are allowed: 91 | - an empty list maps to "void" 92 | - a singleton maps to a normal C return-type 93 | - a tuple maps to a list of pointers that are expected to be filled by the 94 | C function. 95 | 96 | func math [float;float] "transpose" [arg "re" float; arg "im" float] 97 | 98 | maps to 99 | void math_transpose(double re, double im, double *ret0, double *ret1) 100 | val math_transpose : float -> float -> float * float 101 | *) 102 | val func : package -> ctype list -> name -> arg list -> unit 103 | val func' : package -> ctype list -> name -> arg list -> func 104 | (* Method are nothing more than functions that belong to a class rather than 105 | belonging to a package. 106 | As far as the interface is concerned, this is just an informal difference 107 | that is used by code generator to generate names and put the function 108 | definition close to the class definition. 109 | To make it closer to a "usual" method, the first argument should be an 110 | object of the same class the method belongs too (e.g "meth_class *self"). 111 | *) 112 | val meth : classe -> ctype list -> name -> arg list -> unit 113 | val meth' : classe -> ctype list -> name -> arg list -> func 114 | (* Events. 115 | Events allow control to call back to the interface language. 116 | Each event is an optional closure that can be set from ML. 117 | Contrary to methods, events implicitly take an object of the class as first 118 | argument. Method can be "static" while events are always bound to an 119 | instance. 120 | *) 121 | val event' : classe -> ctype list -> name -> arg list -> event 122 | val event : classe -> ctype list -> name -> arg list -> unit 123 | 124 | (* Relations. 125 | The structure of object graph is made explicit by the use of relations. 126 | There are three concepts of relations: port, slots and collections. 127 | 128 | A port is the endpoint of a relation. It can be empty (mapped to NULL / 129 | None) or connected to a slot or a collection. 130 | The declaration below reads "a control can have a single `parent` which is 131 | itself a control." 132 | A slot can connect to zero or one port. 133 | A collection can connect to zero or many ports. 134 | 135 | For instance, a window has a slot which is the root widget. A list layout 136 | has a collection, the sequence of all widgets that are listed. 137 | 138 | Symmetry is enforced: if button is the children of window, then window 139 | will be the parent of button. 140 | *) 141 | type port = port_desc id 142 | type collection = collection_desc id 143 | type slot = slot_desc id 144 | val port : classe -> name -> classe -> port 145 | val slot : classe -> name -> port -> unit 146 | val slot' : classe -> name -> port -> slot 147 | val collection : classe -> name -> port -> unit 148 | val collection' : classe -> name -> port -> collection 149 | 150 | (* Runtime support package and root of object hierarchy *) 151 | val goo : package 152 | val goo_object : classe 153 | val goo_destroy : func 154 | 155 | (* That's all: the rest is functions used by backends to introspect 156 | definitions. *) 157 | module Introspect : sig 158 | module Table : sig 159 | type ('a, 'b) table 160 | val create : unit -> ('a id, 'b) table 161 | val add : ('a, 'b) table -> 'a -> 'b -> unit 162 | val rem : ('a, 'b) table -> 'a -> unit 163 | val mem : ('a, 'b) table -> 'a -> bool 164 | val find : ('a, 'b) table -> 'a -> 'b 165 | end 166 | 167 | val name_of : _ id -> name 168 | 169 | val package_classes : package -> classe list 170 | val package_enums : package -> enum list 171 | val package_funcs : package -> func list 172 | 173 | val class_package : classe -> package 174 | val class_extend : classe -> classe option 175 | val class_depth : classe -> int 176 | val class_funcs : classe -> func list 177 | val class_events : classe -> event list 178 | 179 | type class_relation = 180 | | Rel_port of port 181 | | Rel_slot of slot 182 | | Rel_collection of collection 183 | 184 | val class_relations : classe -> class_relation list 185 | 186 | val enum_package : enum -> package 187 | val enum_members : enum -> enum_member list 188 | val enum_member_enum : enum_member -> enum 189 | 190 | type func_kind = 191 | | Fn_class of classe 192 | | Fn_package of package 193 | 194 | val func_kind : func -> func_kind 195 | val func_ret : func -> ctype list 196 | val func_args : ?at_class:classe -> func -> arg list 197 | 198 | val port_source : port -> classe 199 | val port_target : port -> classe 200 | 201 | val slot_classe : slot -> classe 202 | val slot_port : slot -> port 203 | 204 | val collection_classe : collection -> classe 205 | val collection_port : collection -> port 206 | 207 | val event_classe : event -> classe 208 | val event_ret : event -> ctype list 209 | val event_args : ?with_self:bool -> event -> arg list 210 | end 211 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | name = "goo-lib" 2 | description = "Goo runtime support library" 3 | version = "0.1" 4 | archive(byte) = "goo_lib.cma" 5 | archive(native) = "goo_lib.cmxa" 6 | -------------------------------------------------------------------------------- /lib/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | 4 | clean: 5 | dune clean 6 | 7 | .PHONY: all clean 8 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name goo) 3 | (foreign_stubs 4 | (language c) 5 | (names ml_goo goo_system ml_goo))) 6 | -------------------------------------------------------------------------------- /lib/goo.ml: -------------------------------------------------------------------------------- 1 | (* Encode goo object hierarchy with polymorphic variants *) 2 | type -'a goo 3 | type goo_object = [`goo_object] 4 | 5 | type (+'self, 'a) event = int 6 | let set_event (obj : 'self goo) (event : ('self, 'a) event) (fn : 'self goo -> 'a) = 7 | Obj.set_field (Obj.repr obj) (event + 2) (Obj.repr fn) 8 | let unset_event (obj : 'self goo) (event : ('self, 'a) event) = 9 | Obj.set_field (Obj.repr obj) (event + 2) (Obj.repr ()) 10 | 11 | (* Weak table for referencing OCaml objects from C *) 12 | external set_handle : 'a goo -> int -> unit = "ml_goo_set_handle" [@@noalloc] 13 | 14 | let () = 15 | (* Dereferencing could be done more efficiently without leaving C-side, 16 | but that's ok for now. *) 17 | let table = Goo_ref.create ~compact:set_handle 64 in 18 | let alloc x = Goo_ref.wref table x in 19 | let deref x = Goo_ref.wderef table x in 20 | Callback.register "ml_goo_alloc" alloc; 21 | Callback.register "ml_goo_deref" deref; 22 | Callback.register "ml_goo_string" ""; 23 | Callback.register_exception "ml_goo_exit" Exit 24 | 25 | (* Primitive comparison, hashing and equality of Goo objects. 26 | 27 | TODO: maybe use object tag with the C-address as unique integer. 28 | It costs one more word, but it has one less indirection and behaves well 29 | with non-parametric polymorphic operators. *) 30 | external compare : _ goo -> _ goo -> int = "ml_goo_compare" [@@noalloc] 31 | external hash : _ goo -> int = "ml_goo_hash" [@@noalloc] 32 | let equal a b = compare a b = 0 33 | 34 | (* Root hashtables. 35 | 36 | Put object that must be indefinitely retained in the hashtable. 37 | For instance, windows of a GUI generally manage their lifetime themselves: 38 | the window should be kept alive as long as it is displayed. 39 | 40 | But being "displayed" is a notion foreign to the GC. When a C objects have 41 | custom lifetimes, it is useful to make them roots. 42 | (Otherwise it won't cause memory unsafety, but the window risk disappearing 43 | when the GC reclaims memory for application need.) 44 | *) 45 | module Tbl = Hashtbl.Make(struct 46 | type t = goo_object goo 47 | let equal = equal 48 | let hash = hash 49 | end) 50 | 51 | let roots = Tbl.create 7 52 | 53 | let retain (goo : _ goo) = 54 | let goo = (Obj.magic goo : goo_object goo) in 55 | Tbl.add roots goo () 56 | 57 | let release (goo : _ goo) = 58 | let goo = (Obj.magic goo : goo_object goo) in 59 | Tbl.remove roots goo 60 | 61 | (* Type casting. Welcome to OOP world! 62 | Goo object system can recover some type information at runtime. 63 | This casting routine won't break safety and runs in O(1). *) 64 | type 'a witness 65 | external cast : _ goo -> 'a witness -> 'a goo option = "ml_goo_cast" 66 | -------------------------------------------------------------------------------- /lib/goo.mli: -------------------------------------------------------------------------------- 1 | type -'a goo 2 | type goo_object = [`goo_object] 3 | 4 | type (+'self, 'a) event 5 | val set_event : 'self goo -> ('self, 'a) event -> ('self goo -> 'a) -> unit 6 | val unset_event : 'self goo -> ('self, 'a) event -> unit 7 | 8 | type 'a witness 9 | val cast : _ goo -> 'a witness -> 'a goo option 10 | 11 | val retain : _ goo -> unit 12 | val release : _ goo -> unit 13 | 14 | val compare : _ goo -> _ goo -> int 15 | val equal : _ goo -> _ goo -> bool 16 | val hash : _ goo -> int 17 | -------------------------------------------------------------------------------- /lib/goo_ref.ml: -------------------------------------------------------------------------------- 1 | (* {{{ COPYING *( 2 | 3 | Copyright (C) 2012 Frédéric Bour 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a 6 | copy of this software and associated documentation files (the "Software"), 7 | to deal in the Software without restriction, including without limitation the 8 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 9 | sell copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | The Software is provided "as is", without warranty of any kind, express or 16 | implied, including but not limited to the warranties of merchantability, 17 | fitness for a particular purpose and noninfringement. In no event shall 18 | the authors or copyright holders be liable for any claim, damages or other 19 | liability, whether in an action of contract, tort or otherwise, arising 20 | from, out of or in connection with the software or the use or other dealings 21 | in the Software. 22 | 23 | )* }}} *) 24 | 25 | type 'a t = 26 | { mutable weak : 'a Weak.t 27 | ; mutable first_free : int 28 | ; compact : ('a -> int -> unit) 29 | } 30 | 31 | let create ~compact n = 32 | let n = max n 1 in 33 | { weak = Weak.create n 34 | ; first_free = 0 35 | ; compact = compact 36 | } 37 | 38 | let resize t n = 39 | let n = max n 1 in 40 | let weak = Weak.create n in 41 | let count = min n (min t.first_free (Weak.length t.weak)) in 42 | Weak.blit t.weak 0 weak 0 count; 43 | t.weak <- weak 44 | 45 | let compact ({ weak; _ } as t) = 46 | let rec scan_left l r = 47 | if l > r then l 48 | else match Weak.get weak l with 49 | | Some _ -> scan_left (succ l) r 50 | | None -> scan_right l r 51 | 52 | and scan_right l r = 53 | (* - l is a free cell 54 | - we scan from r downto l hoping to find an allocated cell 55 | - if we find one : we relocate it to position l 56 | - if we don't find one (r reach l), we have finished and 57 | l is the first unallocated cell *) 58 | if l = r then l 59 | else match Weak.get weak r with 60 | | Some c as cell -> 61 | (* Relocate c from r to l *) 62 | t.compact c l; 63 | Weak.set weak l cell; 64 | Weak.set weak r None; 65 | scan_left (succ l) (pred r) 66 | | None -> 67 | scan_right l (pred r) 68 | in 69 | t.first_free <- scan_left 0 (Weak.length weak - 1) 70 | 71 | let realloc t = 72 | compact t; 73 | match Weak.length t.weak, t.first_free with 74 | (* Fill factor < 0.125, compact  *) 75 | | total, fill when fill <= total * 1 / 8 -> 76 | resize t (fill * 2) 77 | (* Fill factor too small : grow table *) 78 | | total, fill when fill >= total * 1 / 2 -> 79 | resize t (total * 2) 80 | (* Average fill factor, do nothing *) 81 | | _ -> () 82 | 83 | let wref t v = 84 | if t.first_free = Weak.length t.weak then realloc t; 85 | let index = t.first_free in 86 | Weak.set t.weak index (Some v); 87 | t.first_free <- succ index; 88 | index 89 | 90 | let wget t i = 91 | Weak.get t.weak i 92 | 93 | let wderef t i = match Weak.get t.weak i with 94 | | Some v -> v 95 | | None -> failwith "Invalid index, should not be reachable" 96 | -------------------------------------------------------------------------------- /lib/goo_ref.mli: -------------------------------------------------------------------------------- 1 | (* {{{ COPYING *( 2 | 3 | Copyright (C) 2012 Frédéric Bour 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a 6 | copy of this software and associated documentation files (the "Software"), 7 | to deal in the Software without restriction, including without limitation the 8 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 9 | sell copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | The Software is provided "as is", without warranty of any kind, express or 16 | implied, including but not limited to the warranties of merchantability, 17 | fitness for a particular purpose and noninfringement. In no event shall 18 | the authors or copyright holders be liable for any claim, damages or other 19 | liability, whether in an action of contract, tort or otherwise, arising 20 | from, out of or in connection with the software or the use or other dealings 21 | in the Software. 22 | 23 | )* }}} *) 24 | 25 | (** Table allowing to weakly reference values of type 'a with an integer index 26 | * (useful to simulate pointer to ocaml value in FFI). 27 | * Allocation/compaction behavior is done in an constant amortized time for 28 | * each item. *) 29 | type 'a t 30 | 31 | (** [create ~compact n] creates a new table with memory preallocated for n items 32 | * Size is doubled when needed. 33 | * compact function is called when relocating an item to a new position. 34 | *) 35 | val create : compact:('a -> int -> unit) -> int -> 'a t 36 | 37 | (** References an item in the table *) 38 | val wref : 'a t -> 'a -> int 39 | 40 | (** Safe getter *) 41 | val wget : 'a t -> int -> 'a option 42 | 43 | (** Quick getter. 44 | * Raise an exception if the references is invalid, however this case should 45 | * not happen if memory is managed safely. *) 46 | val wderef : 'a t -> int -> 'a 47 | -------------------------------------------------------------------------------- /lib/goo_system.c: -------------------------------------------------------------------------------- 1 | #include "goo_system.h" 2 | #include "ml_goo.h" 3 | 4 | GOO_INTERNAL_WITNESS(goo_object, 1); 5 | 6 | void *goo_dyncast_(goo_object *object, const goo_class_witness *witness) 7 | { 8 | if (object == NULL) 9 | return NULL; 10 | const goo_class_display *display = $send(object, display_); 11 | if (display->depth >= witness->depth && 12 | display->witnesses[witness->depth] == witness) 13 | return object; 14 | else 15 | return NULL; 16 | } 17 | 18 | void goo_object_destroy(goo_object *self) 19 | { 20 | $send(self, destroy)(self); 21 | } 22 | 23 | void static_goo_object_destroy(goo_object *self) 24 | { 25 | free(self); 26 | } 27 | -------------------------------------------------------------------------------- /lib/goo_system.h: -------------------------------------------------------------------------------- 1 | #ifndef __GOO_SYSTEM_H__ 2 | #define __GOO_SYSTEM_H__ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | /* Primitive types */ 9 | 10 | typedef int goo_bool; 11 | 12 | typedef struct { 13 | void *data; 14 | } goo_string; 15 | 16 | const char *goo_string_data(goo_string str); 17 | int goo_string_length(goo_string str); 18 | 19 | goo_string null_string; 20 | 21 | goo_string goo_string_from_c(const char *string); 22 | goo_string goo_string_from_mem(const char *string, size_t len); 23 | 24 | #define goo_option 25 | 26 | /* Basic definitions of object system. 27 | * 28 | * A witness is a runtime identifier of a given class. 29 | * A display is an array of witnesses, one for each class of a hierarchy. 30 | * 31 | * Together, they allow to test (in O(1)) that an object is an instance of a 32 | * class. 33 | * 34 | * Assuming `t` is an instance of class `c`, 35 | * then `t.display_.witnesses[c_witness.depth] == c_witness`. 36 | */ 37 | typedef struct { const int depth; const char *name; } goo_class_witness; 38 | typedef struct { const int depth; const int properties; const goo_class_witness * const (witnesses []); } goo_class_display; 39 | 40 | /* Class interface definition 41 | * ========================== 42 | * 43 | * A class definition is split in many parts. 44 | */ 45 | 46 | #define GOO_CLASS_DECLARE(name) \ 47 | typedef struct goo_##name##_class goo_##name##_class; \ 48 | typedef struct goo_##name##_inst goo_##name##_inst; \ 49 | typedef union goo_##name name; \ 50 | extern const goo_class_witness goo_##name##_witness; \ 51 | static inline name * \ 52 | goo_##name##_inst_(goo_##name##_inst *inst) \ 53 | { return (name *)inst; } 54 | 55 | /* Class methods 56 | * ------------- 57 | * 58 | * After declaring class inheritance hierarchy, one should declare the method 59 | * table of the class. 60 | * 61 | * The first item should be `GOO_CLASS_METHODS_INIT(my_class);`. Then all 62 | * methods from inherited classes and at last, all the new methods. 63 | * 64 | * GOO_CLASS_METHODS(b) 65 | * { 66 | * GOO_CLASS_METHODS_INIT(b); 67 | * // methods of object 68 | * // methods of a 69 | * int (*method_of_b)(b *self, int arg1); 70 | * } 71 | * 72 | */ 73 | 74 | #define GOO_CLASS_METHODS(name) struct goo_##name##_class 75 | 76 | #define GOO_CLASS_METHODS_INIT(name) const goo_class_display * const display_ 77 | 78 | /* Class hierarchy 79 | * --------------- 80 | * 81 | * Assuming: 82 | * - class object 83 | * - class a extends object 84 | * - class b extends object 85 | * 86 | * Encoding for class b will look like: 87 | * 88 | * GOO_CLASS_HIERARCHY(b) 89 | * { 90 | * GOO_CLASS_HIERARCHY_INIT(b); 91 | * GOO_CLASS_INHERIT(a); 92 | * GOO_CLASS_INHERIT(object); 93 | * } 94 | * 95 | * In practice, this boilerplate encodes the subtyping relation in C language: 96 | * - `GOO_CLASS_HIERARCHY_INIT(b)` 97 | * means that `(new b)` and is an instance of `b` and `self` 98 | * - `GOO_INHERIT(a)` means that `(new b)` is an instance of `a` 99 | */ 100 | 101 | #define GOO_CLASS_HIERARCHY(name) union goo_##name 102 | 103 | #define GOO_CLASS_HIERARCHY_INIT(name) goo_##name##_inst name, self 104 | 105 | #define GOO_CLASS_INHERIT(name) goo_##name##_inst name 106 | 107 | /* Class fields 108 | * ------------ 109 | * 110 | * The last part is the list of runtime variables stored in an instance of the 111 | * class. 112 | * The first item should be `GOO_CLASS_FIELDS_INIT(my_class);`. Then all 113 | * fields from inherited classes and at last, all the new fields. 114 | * 115 | * GOO_CLASS_FIELDS(b) 116 | * { 117 | * GOO_CLASS_FIELDS_INIT(b); 118 | * // fields from object 119 | * // fields from a 120 | * int field_of_b; 121 | * } 122 | */ 123 | 124 | #define GOO_CLASS_FIELDS(name) struct goo_##name##_inst 125 | 126 | #define GOO_CLASS_FIELDS_INIT(name) \ 127 | const goo_##name##_class * const class_; \ 128 | void * handle_ 129 | 130 | 131 | /* Class implementation 132 | * ==================== 133 | * 134 | * Class implementation defines the C values that will be used as witness, 135 | * display and method table of the instances. 136 | * 137 | * It also defines the function for allocating a new instance, with 138 | * uninitialized fields. 139 | * 140 | */ 141 | 142 | /* Instance witness 143 | * ---------------- 144 | * 145 | * This value defines the runtime "identity" of the class in an inheritance 146 | * hierarchy. 147 | * 148 | * Depth indicates how many ancestors the class has. 149 | * Name is just a string of the class name, accessible at runtime. 150 | * 151 | * GOO_INTERNAL_WITNESS(object, 0); 152 | * GOO_INTERNAL_WITNESS(a, 1); 153 | * GOO_INTERNAL_WITNESS(b, 2); 154 | */ 155 | 156 | #define GOO_INTERNAL_WITNESS(h_name, level) \ 157 | const goo_class_witness goo_##h_name##_witness = { \ 158 | .depth = level, \ 159 | .name = #h_name, \ 160 | } 161 | 162 | /* Instance diplay 163 | * --------------- 164 | * 165 | * This value defines the runtime "identity" of instances of this exact class 166 | * (subclasses have a different display). 167 | * 168 | * It contains the witnesse of all ancestors up to this class. 169 | * Subclasses extend the display with new witnesses. 170 | * 171 | * It must start with `GOO_INTERNAL_DISPLAY_INIT(my_object, depth)` followed 172 | * by a list of all witnesses. 173 | * 174 | * GOO_INTERNAL_DISPLAY(object, 0) 175 | * { 176 | * GOO_INTERNAL_DISPLAY_INIT(object, 0) 177 | * {&goo_object_witness} 178 | * } 179 | * 180 | * GOO_INTERNAL_DISPLAY(b, 2) 181 | * { 182 | * GOO_INTERNAL_DISPLAY_INIT(b, 2) 183 | * {&goo_object_witness, &goo_a_witness, &goo_b_witness} 184 | * }; 185 | * 186 | */ 187 | 188 | #define GOO_INTERNAL_DISPLAY(name, level) \ 189 | GOO_INTERNAL_WITNESS(name, level); \ 190 | static const goo_class_display goo_##name##_display = 191 | 192 | #define GOO_INTERNAL_DISPLAY_INIT(name, level, props) .depth = (level+1), .properties = (props), .witnesses = 193 | 194 | /* Instance table 195 | * --------------- 196 | * 197 | * This value defines the method table of instances of this exact class 198 | * (subclasses have a different table). 199 | * 200 | * It must starts with `GOO_INTERNAL_TABLE_INIT(my_class),` followed by 201 | * an occurrence of `GOO_INTERNAL_TABLE_METHOD(meth),` for each method. 202 | * 203 | * GOO_INTERNAL_TABLE(b) 204 | * { 205 | * GOO_INTERNAL_TABLE_INIT(b), 206 | * GOO_INTERNAL_TABLE_METHOD(...for each method of object...), 207 | * GOO_INTERNAL_TABLE_METHOD(...for each method of a...), 208 | * GOO_INTERNAL_TABLE_METHOD(method_of_b), 209 | * } 210 | */ 211 | 212 | #define GOO_INTERNAL_TABLE(name) \ 213 | static const goo_##name##_class goo_##name##_class_; \ 214 | GOO_INTERNAL_ALLOC(name); \ 215 | static const goo_##name##_class goo_##name##_class_ = 216 | 217 | #define GOO_INTERNAL_TABLE_INIT(name) .display_ = &goo_##name##_display 218 | #define GOO_INTERNAL_TABLE_METHOD(name) .name = (void*)static_self_##name 219 | 220 | #define GOO_INTERNAL_ALLOC(name) \ 221 | static name *goo_self_alloc(void) \ 222 | { \ 223 | name *self = malloc(sizeof(name)); \ 224 | memset(self, 0x00, sizeof(name)); \ 225 | *(const goo_##name##_class**)(&self->self.class_) = &goo_##name##_class_; \ 226 | self->self.handle_ = NULL; \ 227 | /*goo_self_init(self);*/ \ 228 | return self; \ 229 | } 230 | 231 | /* Definition of `goo_object` 232 | * ========================== 233 | * 234 | * `goo_object` is the root of class hierarchy. It is a valid object without 235 | * any method or field. 236 | */ 237 | 238 | GOO_CLASS_DECLARE(goo_object); 239 | 240 | GOO_CLASS_METHODS(goo_object) 241 | { 242 | GOO_CLASS_METHODS_INIT(goo_object); 243 | void (* const destroy)(goo_object *self); 244 | }; 245 | 246 | GOO_CLASS_FIELDS(goo_object) 247 | { 248 | GOO_CLASS_FIELDS_INIT(goo_object); 249 | }; 250 | 251 | GOO_CLASS_HIERARCHY(goo_object) 252 | { 253 | GOO_CLASS_HIERARCHY_INIT(goo_object); 254 | }; 255 | 256 | /* Object-oriented operations 257 | * ==================== 258 | * 259 | * $send(instance,name) does a dynamic dispatch of method `name` on `instance`. 260 | * 261 | * For instance: 262 | * int x = $send(instance_of_b, method_of_b)(instance_of_b, 42); 263 | * 264 | * $field(instance,name) resolves to the field `name` of an instance. 265 | * 266 | * For instance: 267 | * int x = $field(instance_of_b, field_of_b); 268 | * $field(instance_of_b, field_of_b) = 42; 269 | * 270 | * $static(class, name) does a static dispatch of method `name` to a known 271 | * class (either self or ancestor). 272 | * 273 | * For instance: 274 | * // call exactly the definition of method_of_b from b, not any override. 275 | * $static(b, method_of_b)(instance_of_subclass_of_b, 42); 276 | * 277 | * $alloc() 278 | * 279 | * Allocates a new instance of the class being defined. 280 | * All fields are uninitialized. 281 | * 282 | * This function is visible only in the scope of class implementation, so one 283 | * should define and export a constructor function making use of this. 284 | * 285 | */ 286 | 287 | #define __sub_EXPAND___(x) $ ## x 288 | #define __sub_EXPAND__(x) __sub_EXPAND___(x) 289 | //#define __sub_EXPAND__(x) x 290 | #define __sub_EXPAND_(x) __sub_EXPAND__(x) 291 | #define _X(x) x 292 | #define $send(obj,name) ((obj)->self.class_->name) 293 | #define $field(obj,name) ((obj)->self.name) 294 | //#define $static(obj,name) __sub_EXPAND_(static_##obj##_##name) 295 | #define $_static(name) _X($ ## name) 296 | #define $static(obj,name) $static_##obj##_##name 297 | #define $alloc() goo_self_alloc() 298 | #define $method static 299 | #define $number_of_properties(object) ($send(object, display_))->properties 300 | 301 | void *goo_dyncast_(goo_object *, const goo_class_witness * witness); 302 | 303 | void goo_object_init(goo_object *); 304 | #define $goo_object_init(self) goo_object_init($as(self,goo_object)) 305 | 306 | void goo_object_destroy(goo_object *); 307 | void static_goo_object_destroy(goo_object *); 308 | #define $goo_object_destroy(self) goo_object_destroy($as(self,goo_object)) 309 | #define $static_goo_object_destroy(self) static_goo_object_destroy($as(self,goo_object)) 310 | 311 | /* Safe casting operations 312 | * ============================ 313 | * 314 | * $as(object, class) is `object` upcasted to `class` if this is safe, or a 315 | * compilation error otherwise. (This is like C++ static_cast<...>). 316 | * 317 | * $cast(object, class) is `object` casted to `class` if it is an instance of 318 | * `class`, or NULL otherwise. (This is like C++ dynamic_cast<...>) 319 | * 320 | * $when(class, var, obj) { body } binds obj casted to `class` in body if this 321 | * is safe, or skip the body otherwise. 322 | * 323 | * $when(b, instance_of_b, my_object) 324 | * { 325 | * x += $send(instance_of_b, method_of_b)(instance_of_b, 42); 326 | * } 327 | */ 328 | 329 | #define $as(obj, type) (goo_##type##_inst_(&(obj)->type)) 330 | 331 | #define $cast(obj, type) \ 332 | ((type*)goo_dyncast_($as(obj, goo_object), &(goo_##type##_witness))) 333 | 334 | #define $when(type, var, obj) \ 335 | for (type *var = $cast(obj, type); var != NULL; var = NULL) 336 | 337 | /* Collections */ 338 | 339 | #define goo_assert(x) do { if (!(x)) { fprintf(stderr, "%s failed\n", #x); abort(); }; } while(0) 340 | 341 | typedef struct goo_port goo_port; 342 | 343 | struct goo_port { 344 | goo_object *parent; 345 | void (* disconnect)(goo_object *object); 346 | goo_object *prev, *next; 347 | }; 348 | 349 | typedef struct goo_collection goo_collection; 350 | 351 | struct goo_collection { 352 | goo_object *first; 353 | goo_object *last; 354 | }; 355 | 356 | #define GOO_PORT(target, target_field, source) \ 357 | source *target##_##target_field##_get(target *object); \ 358 | void target##_##target_field##_disconnect(target *object); 359 | 360 | #define GOO_INTERNAL_PORT(target, target_field, source) \ 361 | source *target##_##target_field##_get(target *object) \ 362 | { \ 363 | goo_assert (object != NULL); \ 364 | if (!$field(object, target_field).parent) return NULL; \ 365 | source *result = $cast($field(object, target_field).parent, source); \ 366 | goo_assert (result); \ 367 | return result; \ 368 | } \ 369 | \ 370 | void target##_##target_field##_disconnect(target *object) \ 371 | { \ 372 | if ($field(object, target_field).parent) \ 373 | { \ 374 | goo_assert ($field(object, target_field).disconnect); \ 375 | $field(object, target_field).disconnect($as(object, goo_object)); \ 376 | $port_##target_field##_disconnect(object); \ 377 | } \ 378 | goo_assert (!$field(object, target_field).parent); \ 379 | goo_assert (!$field(object, target_field).disconnect); \ 380 | goo_assert (!$field(object, target_field).prev); \ 381 | goo_assert (!$field(object, target_field).next); \ 382 | } 383 | 384 | #define GOO_COLLECTION_(name, source, target) \ 385 | target *name##prev(target *object); \ 386 | target *name##next(target *object); \ 387 | target *name##first(source *self); \ 388 | target *name##last(source *self); \ 389 | source *name##parent(target *self) 390 | 391 | #define GOO_COLLECTION(source, source_field, target) \ 392 | GOO_COLLECTION_(source##_##source_field##_, source, target) 393 | 394 | #define GOO_SLOT(source, source_field, target) \ 395 | target *source##_##source_field##_get(source *self) 396 | 397 | #define GOO_INTERNAL_COLLECTION_(name, source, source_field, source_prop, target, target_field, target_prop) \ 398 | static void name##_unlink(source *self, target *object) \ 399 | { \ 400 | if ($field(object, target_field).prev == NULL) \ 401 | $field(self, source_field).first = $field(object, target_field).next; \ 402 | else \ 403 | $field((target*)$field(object, target_field).prev, target_field).next = \ 404 | $field(object, target_field).next; \ 405 | \ 406 | if ($field(object, target_field).next == NULL) \ 407 | $field(self, source_field).last = $field(object, target_field).prev; \ 408 | else \ 409 | $field((target*)$field(object, target_field).next, target_field).prev = \ 410 | $field(object, target_field).prev; \ 411 | } \ 412 | \ 413 | static void name##_link(source *self, target *object, target *after_that) \ 414 | { \ 415 | $field(object, target_field).prev = (goo_object*)after_that; \ 416 | $field(object, target_field).next = \ 417 | after_that ? $field(after_that, target_field).next \ 418 | : $field(self, source_field).first; \ 419 | if ($field(object, target_field).prev == NULL) \ 420 | { \ 421 | goo_assert ($field(self, source_field).first == \ 422 | $field(object, target_field).next); \ 423 | $field(self, source_field).first = (goo_object*)object; \ 424 | } \ 425 | else \ 426 | { \ 427 | target *prev = $cast($field(object, target_field).prev, target); \ 428 | goo_assert (prev && $field(prev, target_field).next == \ 429 | $field(object, target_field).next); \ 430 | $field(prev, target_field).next = (goo_object*)object; \ 431 | } \ 432 | if ($field(object, target_field).next == NULL) \ 433 | { \ 434 | goo_assert ($field(self, source_field).last == \ 435 | $field(object, target_field).prev); \ 436 | $field(self, source_field).last = (goo_object*)object; \ 437 | } \ 438 | else \ 439 | { \ 440 | target *next = $cast($field(object, target_field).next, target); \ 441 | goo_assert (next && $field(next, target_field).prev == \ 442 | $field(object, target_field).prev); \ 443 | $field(next, target_field).prev = (goo_object*)object; \ 444 | } \ 445 | } \ 446 | \ 447 | static void _self_disconnect_##source_field(target *object) \ 448 | { \ 449 | source *self = $cast($field(object, target_field).parent, source); \ 450 | goo_assert (self); \ 451 | \ 452 | name##_unlink(self, object); \ 453 | \ 454 | $field(object, target_field).prev = NULL; \ 455 | $field(object, target_field).next = NULL; \ 456 | $field(object, target_field).parent = NULL; \ 457 | $field(object, target_field).disconnect = NULL; \ 458 | \ 459 | $ml_goo_port_disconnect(self, source_prop, object, target_prop, \ 460 | $port_##source_field##_disconnect); \ 461 | } \ 462 | \ 463 | target *name##prev(target *object) \ 464 | { \ 465 | if ($field(object, target_field).prev == NULL) return NULL; \ 466 | target *result = $cast($field(object, target_field).prev, target); \ 467 | goo_assert (result); \ 468 | if ($field(result, target_field).disconnect != (void*)_self_disconnect_##source_field) \ 469 | return NULL; \ 470 | return result; \ 471 | } \ 472 | \ 473 | target *name##next(target *object) \ 474 | { \ 475 | if ($field(object, target_field).next == NULL) return NULL; \ 476 | target *result = $cast($field(object, target_field).next, target); \ 477 | goo_assert (result); \ 478 | if ($field(result, target_field).disconnect != (void*)_self_disconnect_##source_field) \ 479 | return NULL; \ 480 | return result; \ 481 | } \ 482 | \ 483 | target *name##first(source *self) \ 484 | { \ 485 | if ($field(self, source_field).first == NULL) return NULL; \ 486 | target *result = $cast($field(self, source_field).first, target); \ 487 | goo_assert (result); \ 488 | return result; \ 489 | } \ 490 | \ 491 | target *name##last(source *self) \ 492 | { \ 493 | if ($field(self, source_field).last == NULL) return NULL; \ 494 | target *result = $cast($field(self, source_field).last, target); \ 495 | goo_assert (result); \ 496 | return result; \ 497 | } \ 498 | \ 499 | source *name##parent(target *self) \ 500 | { \ 501 | if ($field(self, target_field).disconnect != (void*)_self_disconnect_##source_field) \ 502 | return NULL; \ 503 | source *result = $cast($field(self, target_field).parent, source); \ 504 | goo_assert (result); \ 505 | return result; \ 506 | } \ 507 | \ 508 | static void static_connect_##source_field(source *self, target *that, target *after_that) \ 509 | { \ 510 | goo_assert (self != NULL && that != NULL); \ 511 | /* Incorrect use: put after a child belonging to another container. */ \ 512 | if (after_that) \ 513 | goo_assert($field(after_that, target_field).parent == (void*)self); \ 514 | if ($field(that, target_field).parent == (goo_object*)self && \ 515 | $field(that, target_field).disconnect == (void*)_self_disconnect_##source_field) \ 516 | { /* Reorder case */ \ 517 | target *prev = $cast($field(that, target_field).prev, target); \ 518 | goo_assert (prev == (void*)$field(that, target_field).prev); \ 519 | if (after_that == prev) return; \ 520 | name##_unlink(self, that); \ 521 | name##_link(self, that, after_that); \ 522 | } \ 523 | else \ 524 | { /* New connection / move to new collection case */ \ 525 | target##_##target_field##_disconnect(that); \ 526 | $ml_goo_port_connect(self, source_prop, that, target_prop); \ 527 | $field(that, target_field).parent = (goo_object*)self; \ 528 | $field(that, target_field).disconnect = (void*)_self_disconnect_##source_field; \ 529 | name##_link(self, that, after_that); \ 530 | } \ 531 | } 532 | 533 | #define GOO_INTERNAL_COLLECTION(source, source_field, source_prop, target, target_field, target_prop) \ 534 | GOO_INTERNAL_COLLECTION_(source##_##source_field##_, \ 535 | source, source_field, source_prop, target, target_field, target_prop) 536 | 537 | #define GOO_INTERNAL_SLOT(source, source_field, source_prop, target, target_field, target_prop) \ 538 | static void _self_disconnect_##source_field(target *object) \ 539 | { \ 540 | source *self = $cast($field(object, target_field).parent, source); \ 541 | goo_assert (self); \ 542 | \ 543 | goo_assert ($field(self, source_field) == object); \ 544 | *(void**)&$field(self, source_field) = NULL; \ 545 | $field(object, target_field).prev = NULL; \ 546 | $field(object, target_field).next = NULL; \ 547 | $field(object, target_field).parent = NULL; \ 548 | $field(object, target_field).disconnect = NULL; \ 549 | \ 550 | $ml_goo_port_disconnect(self, source_prop, object, target_prop, \ 551 | $port_##source_field##_disconnect); \ 552 | } \ 553 | \ 554 | target *source##_##source_field##_get(source *self) \ 555 | { \ 556 | target *result = $field(self, source_field); \ 557 | if (result == NULL) return NULL; \ 558 | goo_assert ($field(result, target_field).disconnect == \ 559 | (void*)_self_disconnect_##source_field); \ 560 | return result; \ 561 | } \ 562 | \ 563 | static void static_connect_##source_field(source *self, target *that) \ 564 | { \ 565 | goo_assert (self != NULL && that != NULL); \ 566 | \ 567 | if ($field(that, target_field).parent == (goo_object*)self && \ 568 | $field(that, target_field).disconnect == \ 569 | (void*)_self_disconnect_##source_field) \ 570 | return; \ 571 | \ 572 | if ($field(self, source_field)) \ 573 | target##_##target_field##_disconnect($field(self, source_field)); \ 574 | \ 575 | if ($field(that, target_field).parent) \ 576 | target##_##target_field##_disconnect(that); \ 577 | \ 578 | $ml_goo_port_connect(self, source_prop, that, target_prop); \ 579 | $field(that, target_field).parent = (goo_object*)self; \ 580 | $field(that, target_field).disconnect = \ 581 | (void*)_self_disconnect_##source_field; \ 582 | *(target**)&$field(self, source_field) = that; \ 583 | } 584 | 585 | #endif /* !__GOO_SYSTEM_H__ */ 586 | -------------------------------------------------------------------------------- /lib/ml_goo.c: -------------------------------------------------------------------------------- 1 | #include "ml_goo.h" 2 | #include 3 | 4 | #include "caml/alloc.h" 5 | #include "caml/memory.h" 6 | #include "caml/callback.h" 7 | #include "caml/custom.h" 8 | #include "caml/printexc.h" 9 | #include "goo_system.h" 10 | 11 | static value Val_some(value v) 12 | { 13 | CAMLparam1(v); 14 | CAMLlocal1(ret); 15 | ret = caml_alloc_small(1, 0); 16 | Field(ret, 0) = v; 17 | CAMLreturn(ret); 18 | } 19 | 20 | goo_object *Goo_val(value handle) 21 | { 22 | return *(goo_object**)(Data_custom_val(Field(handle,0))); 23 | } 24 | 25 | goo_object *Goo_val_option(value handle) 26 | { 27 | if (handle == Val_unit) 28 | return NULL; 29 | else 30 | return Goo_val(Field(handle,0)); 31 | } 32 | 33 | value ml_goo_set_handle(value handle, value index) 34 | { 35 | goo_assert ((index & 1) != 0); 36 | goo_object *obj = Goo_val(handle); 37 | $field(obj, handle_) = (void*)index; 38 | return Val_unit; 39 | } 40 | 41 | static void goo_finalize(value handle) 42 | { 43 | goo_object *obj = *(goo_object **)(Data_custom_val(handle)); 44 | const goo_class_display *display = $send(obj, display_); 45 | printf("collecting %s\n", display->witnesses[display->depth-1]->name); 46 | $goo_object_destroy(obj); 47 | } 48 | 49 | static int goo_compare(value v1, value v2) 50 | { 51 | goo_object *o1 = *(goo_object **)(Data_custom_val(v1)); 52 | goo_object *o2 = *(goo_object **)(Data_custom_val(v2)); 53 | 54 | if (o1 < o2) return -1; 55 | if (o1 > o2) return 1; 56 | return 0; 57 | } 58 | 59 | value ml_goo_compare(value v1, value v2) 60 | { 61 | return Val_long(goo_compare(Field(v1, 0), Field(v2, 0))); 62 | } 63 | 64 | static intnat goo_hash(value v) 65 | { 66 | goo_object *obj = *(goo_object **)(Data_custom_val(v)); 67 | return (intnat)obj; 68 | } 69 | 70 | value ml_goo_hash(value v1) 71 | { 72 | return Val_long(goo_hash(Field(v1, 0))); 73 | } 74 | 75 | static struct custom_operations goo_custom_ops = { 76 | identifier: "goo object", 77 | finalize: goo_finalize, 78 | compare: goo_compare, 79 | hash: goo_hash, 80 | serialize: custom_serialize_default, 81 | deserialize: custom_deserialize_default 82 | }; 83 | 84 | static value Val_goo_alloc(goo_object *goo) 85 | { 86 | value block, *root = goo_region_alloc(); 87 | 88 | *root = caml_alloc_custom(&goo_custom_ops, sizeof(goo_object *), 0, 1); 89 | *(goo_object**)(Data_custom_val(*root)) = goo; 90 | 91 | block = caml_alloc(2 + $number_of_properties(goo), Object_tag); 92 | Field(block, 0) = *root; 93 | Field(block, 1) = ((intnat)goo)|1; 94 | *root = block; 95 | 96 | static const value * alloc_id = NULL; 97 | if (alloc_id == NULL) 98 | alloc_id = caml_named_value("ml_goo_alloc"); 99 | 100 | value result = caml_callback_exn(*alloc_id, block); 101 | if (Is_exception_result(result)) abort(); 102 | 103 | printf("allocated id %ld\n", Long_val(result)); 104 | goo_assert((result & 1) != 0); 105 | $field(goo, handle_) = (void*)result; 106 | 107 | return block; 108 | } 109 | 110 | value Val_goo(goo_object *goo) 111 | { 112 | if ($field(goo, handle_) == NULL) 113 | return Val_goo_alloc(goo); 114 | 115 | static const value *deref = NULL; 116 | if (deref == NULL) 117 | deref = caml_named_value("ml_goo_deref"); 118 | 119 | printf("accessing id %ld\n", Long_val((value)$field(goo, handle_))); 120 | value result = caml_callback_exn(*deref, (value)$field(goo, handle_)); 121 | if (Is_exception_result(result)) abort(); 122 | 123 | return result; 124 | } 125 | 126 | value Val_goo_option(goo_object *goo) 127 | { 128 | if (goo == NULL) 129 | return Val_unit; 130 | else 131 | return Val_some(Val_goo(goo)); 132 | } 133 | 134 | value Val_goo_handler_helper(goo_object *goo, unsigned int prop_id) 135 | { 136 | if ($field(goo, handle_) == NULL) 137 | return Val_unit; 138 | value inst = Val_goo(goo); 139 | if (Field(inst, 2 + prop_id) == Val_unit) 140 | return Val_unit; 141 | return inst; 142 | } 143 | 144 | void ml_goo_set_property(goo_object *goo, unsigned int prop_id, goo_object *val) 145 | { 146 | CAMLparam0(); 147 | CAMLlocal2(vgoo, vval); 148 | 149 | vgoo = Val_goo(goo); 150 | vval = (val == NULL) ? Val_unit : Val_goo(val); 151 | 152 | if (prop_id + 2 >= Wosize_val(vgoo)) abort(); 153 | 154 | Store_field(vgoo, prop_id + 2, vval); 155 | 156 | CAMLreturn0; 157 | } 158 | 159 | const char *goo_string_data(goo_string str) 160 | { 161 | return String_val(*(value*)str.data); 162 | } 163 | 164 | int goo_string_length(goo_string str) 165 | { 166 | return caml_string_length(*(value*)str.data); 167 | } 168 | 169 | goo_string Goo_string_val(value str) 170 | { 171 | value *v = goo_region_alloc(); 172 | *v = str; 173 | return (goo_string){ .data = v }; 174 | } 175 | 176 | value Val_goo_string(goo_string str) 177 | { 178 | if (str.data) 179 | return *(value*)str.data; 180 | 181 | static const value *string_null = NULL; 182 | if (string_null == NULL) 183 | string_null = caml_named_value("ml_goo_string"); 184 | 185 | return *string_null; 186 | } 187 | 188 | goo_string null_string; 189 | 190 | goo_string goo_string_from_c(const char *string) 191 | { 192 | return Goo_string_val(caml_copy_string(string ? string : "")); 193 | } 194 | 195 | goo_string goo_string_from_mem(const char *string, size_t len) 196 | { 197 | value v = caml_alloc_string(len); 198 | memcpy(Bytes_val(v), string, len); 199 | return Goo_string_val(v); 200 | } 201 | 202 | value ml_goo_cast(value vobject, value vwitness) 203 | { 204 | goo_object *o = Goo_val(vobject); 205 | goo_class_witness *w = (void*)((intnat)(vwitness) & (~1)); 206 | return Val_goo_option(goo_dyncast_(o, w)); 207 | } 208 | 209 | void ml_goo_port_connect(goo_object *source, unsigned int table_prop, goo_object *target, unsigned int port_prop) 210 | { 211 | CAMLparam0(); 212 | CAMLlocal3(vsource, vtarget, vnext); 213 | vsource = Val_goo(source); 214 | vtarget = Val_goo(target); 215 | vnext = Field(vsource, table_prop + 2); 216 | 217 | goo_assert(Field(vtarget, port_prop + 2) == Val_unit); 218 | goo_assert(Field(vtarget, port_prop + 3) == Val_unit); 219 | 220 | Store_field(vsource, table_prop + 2, vtarget); 221 | Store_field(vtarget, port_prop + 2, vsource); 222 | Store_field(vtarget, port_prop + 3, vnext); 223 | 224 | if (vnext != Val_unit) 225 | Store_field(vnext, port_prop +2, vtarget); 226 | 227 | CAMLreturn0; 228 | } 229 | 230 | void ml_goo_port_disconnect(goo_object *source, unsigned int table_prop, goo_object *target, unsigned int port_prop, void (*callback)(goo_object *source, goo_object *target)) 231 | { 232 | CAMLparam0(); 233 | CAMLlocal4(vsource, vtarget, vprev, vnext); 234 | vsource = Val_goo(source); 235 | vtarget = Val_goo(target); 236 | vprev = Field(vtarget,port_prop+2); 237 | vnext = Field(vtarget,port_prop+3); 238 | 239 | if (Field(vsource, table_prop+2) == vtarget) 240 | { // First in source, update to next 241 | goo_assert(vprev == vsource); 242 | Store_field(vsource, table_prop+2, vnext); 243 | if (vnext != Val_unit) 244 | Store_field(vnext, port_prop+2, vsource); 245 | } 246 | else 247 | { 248 | goo_assert(vprev != Val_unit); 249 | Store_field(vprev, port_prop+3, vnext); 250 | if (vnext != Val_unit) 251 | Store_field(vnext, port_prop+2, vprev); 252 | } 253 | 254 | Store_field(vtarget, port_prop+2, Val_unit); 255 | Store_field(vtarget, port_prop+3, Val_unit); 256 | 257 | if (callback) callback(source, target); 258 | CAMLreturn0; 259 | } 260 | 261 | typedef struct { 262 | struct caml__roots_block desc; 263 | value values[1024]; 264 | } region_t; 265 | 266 | static struct caml__roots_block root_sentinel = { .nitems = 0, .ntables = 0, .next = NULL }; 267 | 268 | region_t *region_root, *spare_region; 269 | 270 | static region_t *region_alloc() 271 | { 272 | region_t *result; 273 | if (spare_region) 274 | { 275 | result = spare_region; 276 | spare_region = NULL; 277 | } 278 | else 279 | result = malloc(sizeof(region_t) + sizeof(value) * 1024); 280 | 281 | goo_assert (result); 282 | result->desc.next = NULL; 283 | result->desc.nitems = 0; 284 | result->desc.ntables = 1; 285 | result->desc.tables[0] = result->values; 286 | 287 | return result; 288 | } 289 | 290 | static void region_release(region_t *region) 291 | { 292 | if (spare_region) 293 | free(region); 294 | else 295 | spare_region = region; 296 | } 297 | 298 | goo_region_t goo_region_enter(void) 299 | { 300 | if (region_root == NULL) 301 | { 302 | region_root = region_alloc(); 303 | region_root->desc.next = caml_local_roots; 304 | 305 | root_sentinel.next = ®ion_root->desc; 306 | caml_local_roots = &root_sentinel; 307 | return (goo_region_t){ .block = region_root, .fill = -1 }; 308 | } 309 | else 310 | return (goo_region_t){ .block = region_root, .fill = region_root->desc.nitems }; 311 | } 312 | 313 | void goo_region_leave(goo_region_t region) 314 | { 315 | goo_assert (region_root); 316 | while (region.block != root_sentinel.next) 317 | { 318 | region_t *current = (region_t*)root_sentinel.next; 319 | root_sentinel.next = current->desc.next; 320 | region_release(current); 321 | } 322 | if (region.fill == -1) 323 | { 324 | goo_assert (caml_local_roots == &root_sentinel); 325 | caml_local_roots = region_root->desc.next; 326 | region_release(region_root); 327 | region_root = NULL; 328 | } 329 | else 330 | root_sentinel.next->nitems = region.fill; 331 | } 332 | 333 | value *goo_region_alloc(void) 334 | { 335 | goo_assert (region_root); 336 | 337 | if (root_sentinel.next->nitems < 1024) 338 | { 339 | int n = root_sentinel.next->nitems; 340 | root_sentinel.next->nitems += 1; 341 | return &((region_t*)root_sentinel.next)->values[n]; 342 | } 343 | 344 | region_t *region = region_alloc(); 345 | region->desc.next = root_sentinel.next; 346 | root_sentinel.next = ®ion->desc; 347 | region->desc.nitems = 1; 348 | region->values[0] = Val_unit; 349 | return ®ion->values[0]; 350 | } 351 | 352 | void ml_goo_debug_aborted_event(const char *event, value exn) 353 | { 354 | static const value *exit_exception = NULL; 355 | if (exit_exception == NULL) 356 | { 357 | exit_exception = caml_named_value("ml_goo_exit"); 358 | if (exit_exception == NULL) abort (); 359 | } 360 | if (exn == *exit_exception || Field(exn, 0) == Field(*exit_exception, 0)) 361 | return; 362 | const char *message = caml_format_exception(exn); 363 | printf("event %s aborted with exception: %s\n", event, message); 364 | free((void*)message); 365 | } 366 | -------------------------------------------------------------------------------- /lib/ml_goo.h: -------------------------------------------------------------------------------- 1 | #ifndef __ML_GOO_H__ 2 | #define __ML_GOO_H__ 3 | 4 | #include "caml/mlvalues.h" 5 | #include "goo_system.h" 6 | 7 | typedef struct { 8 | void *block; 9 | int fill; 10 | } goo_region_t; 11 | 12 | goo_region_t goo_region_enter(void); 13 | void goo_region_leave(goo_region_t region); 14 | value *goo_region_alloc(void); 15 | 16 | #define GOO_ENTER_REGION goo_region_t goo_region = goo_region_enter() 17 | #define GOO_LEAVE_REGION goo_region_leave(goo_region) 18 | 19 | goo_object *Goo_val(value v); 20 | #define $Goo_val(goo, typ) $cast(Goo_val(goo), typ) 21 | 22 | goo_object *Goo_val_option(value v); 23 | #define $Goo_val_option(goo, typ) $cast(Goo_val_option(goo), typ) 24 | 25 | value Val_goo(goo_object *goo); 26 | #define $Val_goo(goo) Val_goo($as(goo, goo_object)) 27 | 28 | value Val_goo_option(goo_object *goo); 29 | #define $Val_goo_option(goo) Val_goo_option($as(goo, goo_object)) 30 | 31 | value Val_goo_handler_helper(goo_object *goo, unsigned int prop_id); 32 | #define $Val_goo_handler_helper(goo, prop) Val_goo_handler_helper($as(goo, goo_object), prop) 33 | 34 | void ml_goo_set_property(goo_object *goo, unsigned int prop_id, goo_object *val); 35 | #define $ml_goo_set_property(goo, prop, val) \ 36 | ml_goo_set_property($as(goo, goo_object), prop, $as(val, goo_object)) 37 | 38 | goo_string Goo_string_val(value str); 39 | value Val_goo_string(goo_string str); 40 | 41 | value ml_goo_cast(value object, value witness); 42 | 43 | void ml_goo_debug_aborted_event(const char *event, value exn); 44 | 45 | void ml_goo_port_connect(goo_object *source, unsigned int collection_prop, goo_object *target, unsigned int target_prop); 46 | #define $ml_goo_port_connect(source, collection_prop, target, target_prop) \ 47 | ml_goo_port_connect($as(source, goo_object), collection_prop, $as(target, goo_object), target_prop) 48 | 49 | /* Goo disconnect is a bit trickier: 50 | * The target object has at least one reference up until that point. 51 | * But after execution of disconnect, it might be orphaned and at the risk of 52 | * being collected. 53 | * However, the reference is still needed for firing the on_disconnect event. 54 | * ml_goo_port_disconnect will invoke the callback and ensures that the target 55 | * is still reachable during the execution of the callback. 56 | */ 57 | void ml_goo_port_disconnect(goo_object *source, unsigned int collection_prop, goo_object *target, unsigned int target_prop, void (*callback)(goo_object *source, goo_object *target)); 58 | #define $ml_goo_port_disconnect(source, collection_prop, target, target_prop, callback) \ 59 | do { \ 60 | /* Don't call anything but ensure that the call typechecks */ \ 61 | if (0) (callback)(source, target); \ 62 | ml_goo_port_disconnect($as(source, goo_object), collection_prop, \ 63 | $as(target, goo_object), target_prop, \ 64 | (void*)(callback)); \ 65 | } while(0) 66 | 67 | #define GOO_STUB_PORT(target, target_field, source) \ 68 | value ml_##target##_##target_field##_get(value vtarget) \ 69 | { \ 70 | CAMLparam1(vtarget); \ 71 | target* atarget = $Goo_val(vtarget, target); \ 72 | goo_object *result = $field(atarget, target_field).parent; \ 73 | if (result) goo_assert ($cast(result, source)); \ 74 | CAMLreturn($Val_goo_option(result)); \ 75 | } \ 76 | \ 77 | value ml_##target##_##target_field##_detach(value vtarget) \ 78 | { \ 79 | CAMLparam1(vtarget); \ 80 | target* atarget = $Goo_val(vtarget, target); \ 81 | goo_assert (atarget); \ 82 | target##_##target_field##_disconnect(atarget); \ 83 | CAMLreturn(Val_unit); \ 84 | } 85 | 86 | #define GOO_STUB_SLOT(source, source_field, target, target_field) \ 87 | value ml_##source##_##source_field##_get(value vsource) \ 88 | { \ 89 | CAMLparam1(vsource); \ 90 | source *asource = $Goo_val(vsource, source); \ 91 | target *result = $field(asource, source_field); \ 92 | CAMLreturn($Val_goo_option(result)); \ 93 | } 94 | 95 | #define GOO_STUB_COLLECTION_(name, source, source_field, target, target_field) \ 96 | value ml_##name##prev(value vtarget); \ 97 | value ml_##name##next(value vtarget); \ 98 | value ml_##name##first(value vsource); \ 99 | value ml_##name##last(value vsource); \ 100 | value ml_##name##parent(value vtarget); \ 101 | \ 102 | value ml_##name##prev(value vtarget) \ 103 | { \ 104 | CAMLparam1(vtarget); \ 105 | target* atarget = $Goo_val(vtarget, target); \ 106 | goo_assert (atarget); \ 107 | target* result = name##prev(atarget); \ 108 | CAMLreturn($Val_goo_option(result)); \ 109 | } \ 110 | \ 111 | value ml_##name##next(value vtarget) \ 112 | { \ 113 | CAMLparam1(vtarget); \ 114 | target* atarget = $Goo_val(vtarget, target); \ 115 | goo_assert (atarget); \ 116 | target* result = name##next(atarget); \ 117 | CAMLreturn($Val_goo_option(result)); \ 118 | } \ 119 | \ 120 | value ml_##name##first(value vsource) \ 121 | { \ 122 | CAMLparam1(vsource); \ 123 | source* asource = $Goo_val(vsource, source); \ 124 | goo_object *result = $field(asource, source_field).first; \ 125 | if (result) goo_assert($cast(result, target)); \ 126 | CAMLreturn($Val_goo_option(result)); \ 127 | } \ 128 | \ 129 | value ml_##name##last(value vsource) \ 130 | { \ 131 | CAMLparam1(vsource); \ 132 | source* asource = $Goo_val(vsource, source); \ 133 | goo_object *result = $field(asource, source_field).last; \ 134 | if (result) goo_assert($cast(result, target)); \ 135 | CAMLreturn($Val_goo_option(result)); \ 136 | } \ 137 | \ 138 | value ml_##name##parent(value vtarget) \ 139 | { \ 140 | CAMLparam1(vtarget); \ 141 | CAMLreturn($Val_goo_option(name##parent($Goo_val(vtarget, target)))); \ 142 | } 143 | 144 | #define GOO_STUB_COLLECTION(source, source_field, target, target_field) \ 145 | GOO_STUB_COLLECTION_(source##_##source_field##_, source, source_field, target, target_field) 146 | 147 | #endif /* !__ML_GOO_H__ */ 148 | --------------------------------------------------------------------------------