diff options
| -rw-r--r-- | bytecomp/translclass.ml | 11 | ||||
| -rw-r--r-- | stdlib/oo.ml | 50 | ||||
| -rw-r--r-- | stdlib/oo.mli | 7 |
3 files changed, 38 insertions, 30 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 01dc29c2c..501d1f30d 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -132,6 +132,14 @@ let transl_fields tbl public_methods meths fields cl_init = Meths.fold (bind_methods tbl public_methods) meths (List.fold_right (transl_field_cl tbl meths) fields cl_init) +let creator args = + let table = Ident.create "table" in + let params = + table :: List.map (fun pat -> name_pattern "param" [pat, ()]) args + in + Lfunction (Curried, params, + Lapply (oo_prim "create_object", + List.map (fun p -> Lvar p) params)) let transl_class cl_id cl = let public_methods = Lconst (transl_meth_list cl.cl_pub_meths) in @@ -158,7 +166,8 @@ let transl_class cl_id cl = [Lvar table; obj_init]))) cl.cl_field) in - Lapply (oo_prim "create_class", [Lvar cl_id; public_methods; cl_init]) + Lapply (oo_prim "create_class", + [Lvar cl_id; public_methods; creator cl.cl_args; cl_init]) let class_stub = Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit]) diff --git a/stdlib/oo.ml b/stdlib/oo.ml index f3260c5b0..93909d2e0 100644 --- a/stdlib/oo.ml +++ b/stdlib/oo.ml @@ -47,10 +47,6 @@ let first_bucket = 0 let bucket_size = 32 (* Must be 256 or less *) let initial_object_size = 2 -(**** Version ****) - -let version = ref 0 - (**** Index ****) type label = int @@ -78,25 +74,31 @@ let dummy_item = (magic () : item) type bucket = item array +let version = ref 0 + +let set_bucket_version (bucket : bucket) = + bucket.(bucket_size) <- (magic !version : item) + +let bucket_version bucket = + (magic bucket.(bucket_size) : int) + let bucket_list = ref [] let empty_bucket = [| |] let new_bucket () = let bucket = Array.create (bucket_size + 1) dummy_item in - bucket.(bucket_size) <- (magic !version : item); + set_bucket_version bucket; bucket_list := bucket :: !bucket_list; bucket let copy_bucket bucket = let bucket = Array.copy bucket in + set_bucket_version bucket; bucket.(bucket_size) <- (magic !version : item); bucket_list := bucket :: !bucket_list; bucket -let bucket_version bucket = - (magic bucket.(bucket_size) : int) - (**** Make a clean bucket ****) let new_filled_bucket pos methods = @@ -209,6 +211,10 @@ let new_method met = let new_anonymous_method = new_label +(**** Types ****) + +type object = t array + (**** Sparse array ****) module Vars = Map.Make(struct type t = string let compare = compare end) @@ -290,7 +296,7 @@ let put array label element = type t type class_info = - {mutable obj_init: t -> t; + {mutable obj_init: t; mutable class_init: table -> unit; mutable table: table} @@ -432,7 +438,7 @@ let new_object table = obj.(0) <- (magic table.buckets : t); obj -let create_class class_info public_methods class_init = +let create_class class_info public_methods creator class_init = let table = new_table () in List.iter (function met -> @@ -445,26 +451,16 @@ let create_class class_info public_methods class_init = inst_var_count := !inst_var_count + table.size - 1; class_info.class_init <- class_init; class_info.table <- table; - let buckets = table.buckets in - let initialization = Obj.magic (List.hd (List.hd table.init)) in - class_info.obj_init <- - (function x -> - let obj = Obj.new_block object_tag table.size in - Obj.set_field obj 0 (Obj.repr table.buckets); - Obj.set_field obj 1 (Obj.repr (new_id ())); - initialization obj x) + class_info.obj_init <- creator table (**** Objects ****) -type object = t array - -let inst_var obj lab = - let (buck, elem) = decode lab in - obj.((magic obj : int array array array).(0).(buck).(elem)) - -let set_inst_var obj lab value = - let (buck, elem) = decode lab in - obj.((magic obj : int array array array).(0).(buck).(elem)) <- value +let create_object table = + let obj = Obj.new_block object_tag table.size in + Obj.set_field obj 0 (Obj.repr table.buckets); + Obj.set_field obj 1 (Obj.repr (new_id ())); + let initialization = Obj.magic List.hd (List.hd table.init) in + initialization (Obj.obj obj) let send obj lab = let (buck, elem) = decode lab in diff --git a/stdlib/oo.mli b/stdlib/oo.mli index 07447097d..d5d5e0bf8 100644 --- a/stdlib/oo.mli +++ b/stdlib/oo.mli @@ -26,6 +26,7 @@ type label val new_method: string -> label (* Classes *) +type t type table type item type obj_init @@ -38,11 +39,13 @@ val get_method_label: table -> string -> label val get_variable: table -> string -> int val hide_variable: table -> string -> unit val get_private_variable: table -> string -> int -val create_class: class_info -> string list -> (table -> unit) -> unit +val create_class: + class_info -> string list -> (table -> t) -> + (table -> unit) -> unit (* Objects *) -type t type object +val create_object: table -> t val send: object -> label -> t (* Parameters *) |