[*BIGBANG* zillions of API changes. barista@x9c.fr**20110408092513 Ignore-this: 4b542ebeb7ecd7c15636340b4a604f33 Should have been in multiple patches... ] { rmdir ./javadoc/dev rmdir ./javadoc/public hunk ./javadoc/overview.html 1 - -Barista is implemented using the -Objective Caml language. Nevertheless, -when compiled using Cafesterol, a Java -binary version is produced that can be used via the API presented in these Java -doc files. - rmfile ./javadoc/overview.html rmdir ./javadoc hunk ./src/analysis/code.ml 29 - Stack.iter (fun y -> if ControlFlow.equal_vertex x y then raise Already_present) cont; + Stack.iter + (fun y -> + if ControlFlow.equal_vertex x y then + raise Already_present) + cont; hunk ./src/analysis/code.ml 42 - Queue.iter (fun y -> if ControlFlow.equal_vertex x y then raise Already_present) cont; + Queue.iter + (fun y -> + if ControlFlow.equal_vertex x y then + raise Already_present) + cont; hunk ./src/analysis/code.ml 70 - let edge = try Some (snd (ControlFlow.edge_of_vertex g vertex)) with Not_found -> None in + let edge = + try + let edge = ControlFlow.edge_of_vertex g vertex in + Some (snd edge) + with Not_found -> None in hunk ./src/analysis/code.ml 88 - ~visit_node:(fun pending_add _ edge handlers-> + ~visit_node:(fun pending_add _ edge handlers -> hunk ./src/analysis/code.ml 131 - | ControlFlow.Unconditional_edge dst-> + | ControlFlow.Unconditional_edge dst -> hunk ./src/analysis/code.ml 147 - | ControlFlow.Unconditional_edge dst-> + | ControlFlow.Unconditional_edge dst -> hunk ./src/analysis/code.ml 196 -let flatten_graph g = +let flatten_graph_with_goto_size wide g = + let goto_size = if wide then 5 else 3 in hunk ./src/analysis/code.ml 207 - ~visit_node:(fun pending_add _ edge handlers-> + ~visit_node:(fun pending_add _ edge handlers -> hunk ./src/analysis/code.ml 252 - if lbl.in_line then 0 else 3 + if lbl.in_line then 0 else goto_size hunk ./src/analysis/code.ml 254 - 3 + (if lbl.in_line then 0 else 3) + (if wide then 3 + 5 else 3) + (if lbl.in_line then 0 else goto_size) hunk ./src/analysis/code.ml 261 - | None -> 0 in + | None -> 0 in hunk ./src/analysis/code.ml 280 - invalid_arg "Code.flatten_graph" in + invalid_arg "BaristaLibrary.Code.flatten_graph" in hunk ./src/analysis/code.ml 286 + else if wide then + instrs @ [ Instruction.GOTO_W (s4 (ofs_of_vertex32 dst)) ] hunk ./src/analysis/code.ml 291 - let ofs = s2 (ofs_of_vertex ifso) in - instrs - @ (match jk with - | ControlFlow.References_equal -> [ Instruction.IF_ACMPEQ ofs ] - | ControlFlow.References_not_equal -> [ Instruction.IF_ACMPNE ofs ] - | ControlFlow.Integers_equal -> [ Instruction.IF_ICMPEQ ofs ] - | ControlFlow.Integers_greater_or_equal -> [ Instruction.IF_ICMPGE ofs ] - | ControlFlow.Integers_greater -> [ Instruction.IF_ICMPGT ofs ] - | ControlFlow.Integers_lower_or_equal -> [ Instruction.IF_ICMPLE ofs ] - | ControlFlow.Integers_lower -> [ Instruction.IF_ICMPLT ofs ] - | ControlFlow.Integers_not_equal -> [ Instruction.IF_ICMPNE ofs ] - | ControlFlow.Integer_equal_zero -> [ Instruction.IFEQ ofs ] - | ControlFlow.Integer_greater_or_equal_zero -> [ Instruction.IFGE ofs ] - | ControlFlow.Integer_greater_zero -> [ Instruction.IFGT ofs ] - | ControlFlow.Integer_lower_or_equal_zero -> [ Instruction.IFLE ofs ] - | ControlFlow.Integer_lower_zero -> [ Instruction.IFLT ofs ] - | ControlFlow.Integer_not_equal_zero -> [ Instruction.IFNE ofs ] - | ControlFlow.Reference_null -> [ Instruction.IFNULL ofs ] - | ControlFlow.Reference_not_null -> [ Instruction.IFNONNULL ofs ]) - @ (if lbl.in_line then - [] - else - [ Instruction.GOTO (s2 ((ofs_of_vertex ifno) - 3)) ]) + if wide then begin + let next = s2 (3 + goto_size) in + instrs + @ (match ControlFlow.opposite_jump_kind jk with + | ControlFlow.References_equal -> [ Instruction.IF_ACMPEQ next ] + | ControlFlow.References_not_equal -> [ Instruction.IF_ACMPNE next ] + | ControlFlow.Integers_equal -> [ Instruction.IF_ICMPEQ next ] + | ControlFlow.Integers_greater_or_equal -> [ Instruction.IF_ICMPGE next ] + | ControlFlow.Integers_greater -> [ Instruction.IF_ICMPGT next ] + | ControlFlow.Integers_lower_or_equal -> [ Instruction.IF_ICMPLE next ] + | ControlFlow.Integers_lower -> [ Instruction.IF_ICMPLT next ] + | ControlFlow.Integers_not_equal -> [ Instruction.IF_ICMPNE next ] + | ControlFlow.Integer_equal_zero -> [ Instruction.IFEQ next ] + | ControlFlow.Integer_greater_or_equal_zero -> [ Instruction.IFGE next ] + | ControlFlow.Integer_greater_zero -> [ Instruction.IFGT next ] + | ControlFlow.Integer_lower_or_equal_zero -> [ Instruction.IFLE next ] + | ControlFlow.Integer_lower_zero -> [ Instruction.IFLT next ] + | ControlFlow.Integer_not_equal_zero -> [ Instruction.IFNE next ] + | ControlFlow.Reference_null -> [ Instruction.IFNULL next ] + | ControlFlow.Reference_not_null -> [ Instruction.IFNONNULL next ]) + @ ([Instruction.GOTO_W (s4 (ofs_of_vertex32 ifso))]) + @ (if lbl.in_line then + [] + else + let dest = Int32.sub (ofs_of_vertex32 ifno) (Int32.of_int goto_size) in + [ Instruction.GOTO_W (s4 dest) ]) + end else begin + let ofs = s2 (ofs_of_vertex ifso) in + instrs + @ (match jk with + | ControlFlow.References_equal -> [ Instruction.IF_ACMPEQ ofs ] + | ControlFlow.References_not_equal -> [ Instruction.IF_ACMPNE ofs ] + | ControlFlow.Integers_equal -> [ Instruction.IF_ICMPEQ ofs ] + | ControlFlow.Integers_greater_or_equal -> [ Instruction.IF_ICMPGE ofs ] + | ControlFlow.Integers_greater -> [ Instruction.IF_ICMPGT ofs ] + | ControlFlow.Integers_lower_or_equal -> [ Instruction.IF_ICMPLE ofs ] + | ControlFlow.Integers_lower -> [ Instruction.IF_ICMPLT ofs ] + | ControlFlow.Integers_not_equal -> [ Instruction.IF_ICMPNE ofs ] + | ControlFlow.Integer_equal_zero -> [ Instruction.IFEQ ofs ] + | ControlFlow.Integer_greater_or_equal_zero -> [ Instruction.IFGE ofs ] + | ControlFlow.Integer_greater_zero -> [ Instruction.IFGT ofs ] + | ControlFlow.Integer_lower_or_equal_zero -> [ Instruction.IFLE ofs ] + | ControlFlow.Integer_lower_zero -> [ Instruction.IFLT ofs ] + | ControlFlow.Integer_not_equal_zero -> [ Instruction.IFNE ofs ] + | ControlFlow.Reference_null -> [ Instruction.IFNULL ofs ] + | ControlFlow.Reference_not_null -> [ Instruction.IFNONNULL ofs ]) + @ (if lbl.in_line then + [] + else + [ Instruction.GOTO (s2 ((ofs_of_vertex ifno) - goto_size)) ]) + end hunk ./src/analysis/code.ml 362 - let l1 = List.length instrs in - let l2 = List.length lbl.lines in - if l1 <> l2 then begin - Printf.printf "#instrs=%d\t#lines=%d\n" l1 l2; - exit 0 - end; hunk ./src/analysis/code.ml 399 - | (Some n1), (Some n2) -> - Utils.UTF8.equal (Name.internal_utf8_for_class n1) (Name.internal_utf8_for_class n2) + | (Some n1), (Some n2) -> Name.equal_for_class n1 n2 hunk ./src/analysis/code.ml 411 + let table = + List.map + (fun (ofs_start, ofs_end, ofs_dest, cn) -> + { Attribute.try_start = ofs_start; + Attribute.try_end = ofs_end; + Attribute.catch = ofs_dest; + Attribute.caught = cn; }) + table in hunk ./src/analysis/code.ml 424 +let flatten_graph g = + try + flatten_graph_with_goto_size false g + with _ -> + flatten_graph_with_goto_size true g + hunk ./src/analysis/code.ml 481 - ~visit_node:(fun pending_add vertex edge handlers-> + ~visit_node:(fun pending_add vertex edge handlers -> hunk ./src/analysis/code.mli 19 -(** This module provides utility functions for code manipulation. *) +(** Utility functions for code manipulation, and optimization. *) hunk ./src/analysis/code.mli 27 -(** [optimize_jumps g] returns [g] except that empty nodes have been - short-circuited (but not removed, possibly producing dead code), - and trivial conditional jumps have been replaced. *) +(** [optimize_jumps g] returns [g] except that empty nodes ({i i. e.} + with no instruction) have been short-circuited (but not removed, + possibly producing dead code). *) hunk ./src/analysis/code.mli 31 -val flatten_graph : ('a * (Utils.u2 list), 'b) ControlFlow.graph -> Instruction.t list * (Utils.u2 * Utils.u2) list * (Utils.u2 * Utils.u2 * Utils.u2 * Name.for_class option) list * (int32 * 'a, 'b) ControlFlow.graph -(** [flatten_graph g] returns a [l, t, e, g'] triple where [g'] is [g] labeled with code offsets - corresponding to the instruction list [l]. [t] is the data for the {i LineNumberTable} - attribute, and [e] is the exception table for [l]. *) +val flatten_graph : ('a * (Utils.u2 list), 'b) ControlFlow.graph -> Instruction.t list * (Utils.u2 * Utils.u2) list * Attribute.exception_table_element list * (int32 * 'a, 'b) ControlFlow.graph +(** [flatten_graph g] returns a [l, t, e, g'] triple where [g'] is [g] + labeled with code offsets corresponding to the instruction list [l]. + [t] is the data for the {i LineNumberTable} attribute, and [e] is the + exception table for [l]. *) hunk ./src/analysis/code.mli 41 -val compute_stack_infos : [ `Array_type of Descriptor.array_type | `Class_or_interface of Name.for_class ] StackState.unifier -> (int32 * 'a, 'b) ControlFlow.graph -> StackState.t -> Utils.u2 * Utils.u2 * Attribute.stack_map_frame list +val compute_stack_infos : StackState.instance StackState.unifier -> (int32 * 'a, 'b) ControlFlow.graph -> StackState.t -> Utils.u2 * Utils.u2 * Attribute.stack_map_frame list hunk ./src/analysis/code.mli 43 - for the method whose control flow graph [g] and initial stack state [s] are passed. - The [int32] values labelling the vertices are the offsets of the related instructions - blocks. The function [u] is used to unify stack states. + for the method whose control flow graph [g] and initial stack state + [s] are passed. The [int32] values labelling the vertices are the + offsets of the related instructions blocks. The function [u] is used + to unify stack states. hunk ./src/analysis/code.mli 48 - Raises [StackState.Exception] if the passed instruction lists associated with - the graph vertices are incoherent. *) + Raises [StackState.Exception] if the passed instruction lists + associated with the graph vertices are incoherent. *) hunk ./src/analysis/controlFlow.ml 86 +let opposite_jump_kind = function + | References_equal -> References_not_equal + | References_not_equal -> References_equal + | Integers_equal -> Integers_not_equal + | Integers_greater_or_equal -> Integers_lower + | Integers_greater -> Integers_lower_or_equal + | Integers_lower_or_equal -> Integers_greater + | Integers_lower -> Integers_greater_or_equal + | Integers_not_equal -> Integers_equal + | Integer_equal_zero -> Integer_not_equal_zero + | Integer_greater_or_equal_zero -> Integer_lower_zero + | Integer_greater_zero -> Integer_lower_or_equal_zero + | Integer_lower_or_equal_zero -> Integer_greater_zero + | Integer_lower_zero -> Integer_greater_or_equal_zero + | Integer_not_equal_zero -> Integer_equal_zero + | Reference_null -> Reference_not_null + | Reference_not_null -> Reference_null + hunk ./src/analysis/controlFlow.ml 131 - | Unsupported_instruction x -> "unsupported instruction: " ^ x + | Unsupported_instruction x -> + Printf.sprintf "unsupported instruction: %S" x hunk ./src/analysis/controlFlow.ml 406 - fail Invalid_switch_edge + fail Invalid_switch_edge hunk ./src/analysis/controlFlow.ml 455 - let graph = { graph_vertices = vertices; graph_root = id; graph_edges = IdMap.empty; graph_handlers = IdMap.empty; } in + let graph = { graph_vertices = vertices; + graph_root = id; + graph_edges = IdMap.empty; + graph_handlers = IdMap.empty; } in hunk ./src/analysis/controlFlow.ml 485 - | (Some n1), (Some n2) -> - UTF8.equal (Name.internal_utf8_for_class n1) (Name.internal_utf8_for_class n2) + | (Some n1), (Some n2) -> Name.equal_for_class n1 n2 hunk ./src/analysis/controlFlow.ml 704 +let identity g = + map_graph + (fun x y -> x, y) + (fun x _ -> x) + (fun x _ _ -> x) + g + hunk ./src/analysis/controlFlow.ml 717 + | '&' -> Buffer.add_string buf "&" + | '\'' -> Buffer.add_string buf "'" + | '\"' -> Buffer.add_string buf """ hunk ./src/analysis/controlFlow.ml 729 - let b = Buffer.create 64 in + let b = Buffer.create 128 in hunk ./src/analysis/controlFlow.ml 733 - let add_type t = Buffer.add_string b (UTF8.to_string (Source.utf8_of_java_type t)) in + let add_type t = Buffer.add_string b (UTF8.to_string (Descriptor.external_utf8_of_java_type t)) in hunk ./src/analysis/controlFlow.ml 756 - | Instruction.String_constant x -> Buffer.add_string b (escape_xml (UTF8.to_string (UTF8.escape x))) + | Instruction.String_constant x -> Buffer.add_string b (UTF8.to_string (UTF8.escape x)) hunk ./src/analysis/controlFlow.ml 766 - let buf = Buffer.create 512 in + let buf = Buffer.create 1024 in hunk ./src/analysis/controlFlow.ml 853 -let graph_of_instructions ?(line_mapper=dummy_mapper) instrs exception_table = +let graph_of_instructions ?(line_mapper = dummy_mapper) instrs exception_table = hunk ./src/analysis/controlFlow.ml 856 - (* step 1: label instructions with offset, compute cut offsets from instructions *) + (* step 1: label instructions with offsets, compute cut offsets from instructions *) hunk ./src/analysis/controlFlow.ml 886 - (fun acc (ofs_start, ofs_end, ofs_handler, _) -> - let acc = Int32Set.add (Int32.of_int (ofs_start : u2 :> int)) acc in - let acc = Int32Set.add (Int32.of_int (ofs_end : u2 :> int)) acc in - Int32Set.add (Int32.of_int (ofs_handler : u2 :> int)) acc) + (fun acc elem -> + let acc = Int32Set.add (Int32.of_int (elem.Attribute.try_start : u2 :> int)) acc in + let acc = Int32Set.add (Int32.of_int (elem.Attribute.try_end : u2 :> int)) acc in + Int32Set.add (Int32.of_int (elem.Attribute.catch : u2 :> int)) acc) hunk ./src/analysis/controlFlow.ml 962 - let start1, end1, _, _ = x in - let start2, end2, _, _ = y in + let start1 = x.Attribute.try_start in + let end1 = x.Attribute.try_end in + let start2 = y.Attribute.try_start in + let end2 = y.Attribute.try_end in hunk ./src/analysis/controlFlow.ml 975 - (fun g (ofs_start, ofs_end, ofs_handler, class_name) -> - let handler = get_vertex (Int32.of_int (ofs_handler : u2 :> int)) in + (fun g elem -> + let handler = get_vertex (Int32.of_int (elem.Attribute.catch : u2 :> int)) in hunk ./src/analysis/controlFlow.ml 979 - if (ofs >= (Int32.of_int (ofs_start : u2 :> int))) - && (ofs < (Int32.of_int (ofs_end : u2 :> int))) then - add_handler acc v class_name handler () + if (ofs >= (Int32.of_int (elem.Attribute.try_start : u2 :> int))) + && (ofs < (Int32.of_int (elem.Attribute.try_end : u2 :> int))) then + add_handler acc v elem.Attribute.caught handler () hunk ./src/analysis/controlFlow.mli 20 -(** This module provides types and functions related to control flow information. *) +(** Types and functions related to control flow information. + + {b Warning:} although graphs expose a functional interface, their + current implementation is based on identifiers for the vertices. + While this is not observable for most programs, this may lead to + inconsistent behaviour when graphs are marshalled and then + unmarshalled. To ensure that an unmarshalled graph can be used + with no risk of identifier collision, one should call [identity] + on any unmarshlled graph. *) hunk ./src/analysis/controlFlow.mli 54 - | Integer_lower_or_equal_zero (** Indicates that the jump will be performed if the integer is lower than of equal to zero. *) + | Integer_lower_or_equal_zero (** Indicates that the jump will be performed if the integer is lower than or equal to zero. *) hunk ./src/analysis/controlFlow.mli 64 +val opposite_jump_kind : jump_kind -> jump_kind +(** Returns the jump kind that is the opposite ({i i. e.} negation) of + the passed one. *) + hunk ./src/analysis/controlFlow.mli 107 - Raises [Exception] if the instruction is unsupported ({i jsr}, {i jsr_w}, - {i ret}, or {i wide ret}). *) + Raises [Exception] if the instruction is unsupported ({i jsr}, + {i jsr_w}, {i ret}, or {i wide ret}). *) hunk ./src/analysis/controlFlow.mli 116 -(** The type of graph vertices, each being labeled with an instruction list - and a value of type ['a]. *) +(** The type of graph vertices, each being labeled with an instruction + list and a value of type ['a]. *) hunk ./src/analysis/controlFlow.mli 126 -(** The type of control flow graphs for methods, ['a] and ['b] being respectively - the types of vertex and edge labels. Graphs are applicative data structures. +(** The type of control flow graphs for methods (actually + {i hypergraphs}), ['a] and ['b] being respectively the types of + vertex and edge labels. Graphs are applicative data structures. hunk ./src/analysis/controlFlow.mli 132 - - a designated vertex: the {i root} (representing the method entry point); + - a designated vertex: the {i root} (representing the method entry + point); hunk ./src/analysis/controlFlow.mli 135 - - a set of handlers, that are special edges from protected vertices to associated handlers. + - a set of handlers, that are special edges from protected vertices + to associated exception handlers. hunk ./src/analysis/controlFlow.mli 139 - - there is at most one outgoing edge for each vertex; - - there is at most one outgoing edge for each (vertex, caught exception) couple. *) + - there is at most one {i standard} outgoing edge for each vertex; + - there is at most one {i special} outgoing edge for each (vertex, caught exception) couple. *) hunk ./src/analysis/controlFlow.mli 150 -(** {7 Graph construction and accessors} *) +(** {7 Graph constructor and accessors} *) hunk ./src/analysis/controlFlow.mli 153 -(** [make_graph instrs lbl] returns both a graph reduced to its root and the - aforementioned root. Instructions [instrs] and label [lbl] are associated - with the root. *) +(** [make_graph instrs lbl] returns both a graph reduced to its root and + the aforementioned root. Instructions [instrs] and label [lbl] are + associated with the root. *) hunk ./src/analysis/controlFlow.mli 161 -(** [add_vertex g instrs lbl] returns a couple [g', v] where [g'] is [g] augmented - with a new vertex [v] labeled with [instrs] and [lbl]. *) +(** [add_vertex g instrs lbl] returns a couple [g', v] where [g'] is [g] + augmented with a new vertex [v] labeled with [instrs] and [lbl]. *) hunk ./src/analysis/controlFlow.mli 165 -(** [add_edge g v e l] returns a graph that is [g] augmented with a new edge [e] from [v] - labeled with [l]. Raises [Exception] if either [v] or any vertex of [e] is not in [g], - or if the edge is an invalid switch edge. *) +(** [add_edge g v e l] returns a graph that is [g] augmented with a new + edge [e] from [v] labeled with [l]. Raises [Exception] if either [v] + or any vertex of [e] is not in [g], or if the edge is an invalid + switch edge. *) hunk ./src/analysis/controlFlow.mli 171 -(** [add_handler g src cn dst lbl] returns a graph that is [g] augmented with a handler - from [src] to [dst] for exception [cn] labeled with [lbl]. +(** [add_handler g src cn dst lbl] returns a graph that is [g] augmented + with a handler from [src] to [dst] for exception [cn] labeled with + [lbl]. hunk ./src/analysis/controlFlow.mli 181 -(** [remove_vertex g v] returns a graph that is [g] without [v] and associated edge and handlers. +(** [remove_vertex g v] returns a graph that is [g] without [v] and + associated edge and handlers. hunk ./src/analysis/controlFlow.mli 186 -(** [remove_vertices g l] returns a graph that is [g] without the vertices [l] - and associated edges and handlers. +(** [remove_vertices g l] returns a graph that is [g] without the + vertices [l] and associated edges and handlers. Equivalent to + [remove_vertex] over all elements from [l], except that performances + are much better. hunk ./src/analysis/controlFlow.mli 193 -(** [remove_edge g v] returns a graph that is [g] without the edge going out of [v]. +(** [remove_edge g v] returns a graph that is [g] without the edge going + out of [v]. hunk ./src/analysis/controlFlow.mli 198 -(** [remove_handler g src cn dst] returns a graph that is [g] without the handler from - [src] to [dst] for exception [cn]. +(** [remove_handler g src cn dst] returns a graph that is [g] without the + handler from [src] to [dst] for exception [cn]. hunk ./src/analysis/controlFlow.mli 212 -(** Returns the edge for the passed vertex in the passed graph, as well as the. - label associated with this edge. +(** Returns the edge for the passed vertex in the passed graph, as well + as the label associated with this edge. hunk ./src/analysis/controlFlow.mli 218 -(** Returns the list of vertices that have the passed vertex as a destination. +(** Returns the list of vertices that have the passed vertex as a + destination. hunk ./src/analysis/controlFlow.mli 223 -(** Returns the list of handlers for the passed vertex in the passed graph. +(** Returns the list of handlers for the passed vertex in the passed + graph. hunk ./src/analysis/controlFlow.mli 239 -(** [fold_vertices f g z] is [f v1 (f v2 (... (f vn z) ...))] where the [vi] are the vertices of [g]. *) +(** [fold_vertices f g z] is [f v1 (f v2 (... (f vn z) ...))] where the + [vi] are the vertices of [g]. *) hunk ./src/analysis/controlFlow.mli 243 -(** [fold_edges f g z] is [f s1 l1 e1 (f s2 l2 e2 (... (f sn ln en z) ...))] where - the [si, li, ei] are the edges of [g] (components being source, label and destination). *) +(** [fold_edges f g z] is [f s1 l1 e1 (f s2 l2 e2 (... (f sn ln en z) ...))] + where the [si, li, ei] are the edges of [g] (components being source, + label and destination). *) hunk ./src/analysis/controlFlow.mli 249 - where the [si, li, ci, hi] are the handlers of [g] (components being source, label, - caught exception, and handler). *) + where the [si, li, ci, hi] are the handlers of [g] (components being + source, label, caught exception, and handler). *) hunk ./src/analysis/controlFlow.mli 253 -(** [map_graph f1 f2 f3 g] maps [g] into a new graph structurally identical, using: +(** [map_graph f1 f2 f3 g] maps [g] into a new graph structurally + identical, using: hunk ./src/analysis/controlFlow.mli 257 - - [f2] to map handler information. *) + - [f3] to map handler information. *) + +val identity : ('a, 'b) graph -> ('a, 'b) graph +(** [identity g] maps [g] into a new graph structurally identical, but + with new identifiers for vertices. + + Useful to guarantee that an unmarshalled graph has correct vertex + identifiers. *) hunk ./src/analysis/controlFlow.mli 269 -(** [dot_of_graph f1 f2 g] converts [g] into its dot representation using [f1] to - convert vertex labels into strings, and [f2] to convert edge labels into strings. *) +(** [dot_of_graph f1 f2 g] converts [g] into its dot representation + using [f1] to convert vertex labels into strings, and [f2] to convert + edge labels into strings. *) hunk ./src/analysis/controlFlow.mli 276 -(** The type of functions mapping code offsets to associated line numbers. *) +(** The type of functions mapping code offsets to associated source line + numbers. *) hunk ./src/analysis/controlFlow.mli 286 -val graph_of_instructions : ?line_mapper:line_mapper -> Instruction.t list -> (Utils.u2 * Utils.u2 * Utils.u2 * Name.for_class option) list -> (int32 * (Utils.u2 list), unit) graph -(** [graph_of_instructions instrs exn_table] constructs the graph for the method whose - instructions are [instrs] and exception table is [exn_table] (components being - respectively start and end offsets of protected block, offset of handler, and class - name of the exception to be caught). The vertices of the returned graph are labeled - with the offset of the first instruction of the list associated with the vertex, - and a list number lines (one number by instruction). +val graph_of_instructions : ?line_mapper:line_mapper -> Instruction.t list -> Attribute.exception_table_element list -> (int32 * (Utils.u2 list), unit) graph +(** [graph_of_instructions instrs exn_table] constructs the graph for the + method whose instructions are [instrs] and exception table is + [exn_table]. The vertices of the returned graph are labeled with the + offset of the first instruction associated with the vertex, and a + list number lines (one number by instruction). hunk ./src/analysis/controlFlow.mli 293 - Raises [Exception] if [instrs] contains an instruction that is not supported by - [for_instruction], or if the resulting graph would be empty. *) + Raises [Exception] if [instrs] contains an instruction that is not + supported by [for_instruction], or if the resulting graph would be + empty. *) hunk ./src/analysis/peephole.ml 25 -type rewriting_rules = (Utils.u2 * Instruction.t) list -> (Utils.u2 * Instruction.t) list +type rewriting_rules = (u2 * Instruction.t) list -> (u2 * Instruction.t) list + +let s1_zero = s1 0 + +let s2_zero = s2 0 hunk ./src/analysis/peephole.ml 41 -let is_commutative_float_operation = function - | Instruction.FADD | Instruction.FMUL -> true - | _ -> false - -let is_commutative_double_operation = function - | Instruction.DADD | Instruction.DMUL -> true - | _ -> false - hunk ./src/analysis/peephole.ml 51 -let same_class_name c1 c2 = - Utils.UTF8.equal (Name.internal_utf8_for_class c1) (Name.internal_utf8_for_class c2) - -let same_method_name m1 m2 = - Utils.UTF8.equal (Name.utf8_for_method m1) (Name.utf8_for_method m2) - -let same_field_name f1 f2 = - Utils.UTF8.equal (Name.utf8_for_field f1) (Name.utf8_for_field f2) - -let rec eq_desc x y = - match (x, y) with - | (`Class c1), (`Class c2) -> same_class_name c1 c2 - | (`Array a1), (`Array a2) -> - eq_desc (a1 :> Descriptor.java_type) (a2 :> Descriptor.java_type) - | _ -> x = y - -let rec eq_meth_desc (l1, t1) (l2, t2) = - ((List.length l1) = (List.length l2)) && (List.for_all2 eq_desc (l1 :> Descriptor.java_type list) (l2 :> Descriptor.java_type list)) && (eq_desc t1 t2) - hunk ./src/analysis/peephole.ml 52 - (same_class_name c1 c2) && (same_field_name f1 f2) && (eq_desc (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type)) + (Name.equal_for_class c1 c2) + && (Name.equal_for_field f1 f2) + && (Descriptor.equal_java_type (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type)) hunk ./src/analysis/peephole.ml 57 - (same_method_name m1 m2) && (eq_meth_desc d1 d2) + (Name.equal_for_method m1 m2) + && (Descriptor.equal_for_method d1 d2) hunk ./src/analysis/peephole.ml 61 - (same_class_name c1 c2) && (same_method_name m1 m2) && (eq_meth_desc d1 d2) + (Name.equal_for_class c1 c2) + && (Name.equal_for_method m1 m2) + && (Descriptor.equal_for_method d1 d2) + +let same_cast c1 c2 = + match (c1, c2) with + | `Array_type at1, `Array_type at2 -> + Descriptor.equal_java_type + (at1 :> Descriptor.java_type) + (at2 :> Descriptor.java_type) + | `Class_or_interface cn1, `Class_or_interface cn2 -> + Name.equal_for_class cn1 cn2 + | _ -> false hunk ./src/analysis/peephole.ml 118 - | _ -> invalid_arg "Peephole.extract_iload_index" + | _ -> invalid_arg "BaristaLibrary.Peephole.extract_iload_index" + +let extract_iload_index_u1 x = + u1 (extract_iload_index x) + +let extract_iload_index_u2 x = + u2 (extract_iload_index x) hunk ./src/analysis/peephole.ml 133 - | _ -> invalid_arg "Peephole.extract_istore_index" + | _ -> invalid_arg "BaristaLibrary.Peephole.extract_istore_index" hunk ./src/analysis/peephole.ml 136 - try (extract_iload_index instr1) = (extract_istore_index instr2) with _ -> false + try + (extract_iload_index instr1) = (extract_istore_index instr2) + with _ -> false hunk ./src/analysis/peephole.ml 142 -(* hunk ./src/analysis/peephole.ml 155 - | (line, (Instruction.BIPUSH 0)) :: tl -> rewrite ((line, Instruction.ICONST_0) :: acc) tl - | (line, (Instruction.BIPUSH 1)) :: tl -> rewrite ((line, Instruction.ICONST_1) :: acc) tl - | (line, (Instruction.BIPUSH 2)) :: tl -> rewrite ((line, Instruction.ICONST_2) :: acc) tl - | (line, (Instruction.BIPUSH 3)) :: tl -> rewrite ((line, Instruction.ICONST_3) :: acc) tl - | (line, (Instruction.BIPUSH 4)) :: tl -> rewrite ((line, Instruction.ICONST_4) :: acc) tl - | (line, (Instruction.BIPUSH 5)) :: tl -> rewrite ((line, Instruction.ICONST_5) :: acc) tl - | (line, (Instruction.BIPUSH (-1))) :: tl -> rewrite ((line, Instruction.ICONST_M1) :: acc) tl - | (line, (Instruction.SIPUSH 0)) :: tl -> rewrite ((line, Instruction.ICONST_0) :: acc) tl - | (line, (Instruction.SIPUSH 1)) :: tl -> rewrite ((line, Instruction.ICONST_1) :: acc) tl - | (line, (Instruction.SIPUSH 2)) :: tl -> rewrite ((line, Instruction.ICONST_2) :: acc) tl - | (line, (Instruction.SIPUSH 3)) :: tl -> rewrite ((line, Instruction.ICONST_3) :: acc) tl - | (line, (Instruction.SIPUSH 4)) :: tl -> rewrite ((line, Instruction.ICONST_4) :: acc) tl - | (line, (Instruction.SIPUSH 5)) :: tl -> rewrite ((line, Instruction.ICONST_5) :: acc) tl - | (line, (Instruction.SIPUSH (-1))) :: tl -> rewrite ((line, Instruction.ICONST_M1) :: acc) tl - | (line, (Instruction.LDC (`Int x))) :: tl when (x >= -128l) && (x <= 127l) -> rewrite ((line, (Instruction.BIPUSH (Int32.to_int x))) :: acc) tl - | (line, (Instruction.LDC (`Int x))) :: tl when (x >= -32768l) && (x <= 32767l) -> rewrite ((line, (Instruction.SIPUSH (Int32.to_int x))) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ICONST_0) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ICONST_1) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ICONST_2) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ICONST_3) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: tl when (x :> int) = 4 -> rewrite ((line, Instruction.ICONST_4) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: tl when (x :> int) = 5 -> rewrite ((line, Instruction.ICONST_5) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: tl when (x :> int) = -1 -> rewrite ((line, Instruction.ICONST_M1) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ICONST_0) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ICONST_1) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ICONST_2) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ICONST_3) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: tl when (x :> int) = 4 -> rewrite ((line, Instruction.ICONST_4) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: tl when (x :> int) = 5 -> rewrite ((line, Instruction.ICONST_5) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: tl when (x :> int) = -1 -> rewrite ((line, Instruction.ICONST_M1) :: acc) tl + | (line, (Instruction.LDC (`Int x))) :: tl when (x >= -128l) && (x <= 127l) -> rewrite ((line, (Instruction.BIPUSH (s1 (Int32.to_int x)))) :: acc) tl + | (line, (Instruction.LDC (`Int x))) :: tl when (x >= -32768l) && (x <= 32767l) -> rewrite ((line, (Instruction.SIPUSH (s2 (Int32.to_int x)))) :: acc) tl hunk ./src/analysis/peephole.ml 178 - | (line, (Instruction.LDC_W (`Int x))) :: tl when (x >= -128l) && (x <= 127l) -> rewrite ((line, (Instruction.BIPUSH (Int32.to_int x))) :: acc) tl - | (line, (Instruction.LDC_W (`Int x))) :: tl when (x >= -32768l) && (x <= 32767l) -> rewrite ((line, (Instruction.SIPUSH (Int32.to_int x))) :: acc) tl + | (line, (Instruction.LDC_W (`Int x))) :: tl when (x >= -128l) && (x <= 127l) -> rewrite ((line, (Instruction.BIPUSH (s1 (Int32.to_int x)))) :: acc) tl + | (line, (Instruction.LDC_W (`Int x))) :: tl when (x >= -32768l) && (x <= 32767l) -> rewrite ((line, (Instruction.SIPUSH (s2 (Int32.to_int x)))) :: acc) tl hunk ./src/analysis/peephole.ml 182 -*) hunk ./src/analysis/peephole.ml 188 -(* - | (line, (Instruction.WIDE_ALOAD 0)) :: tl -> rewrite ((line, Instruction.ALOAD_0) :: acc) tl - | (line, (Instruction.WIDE_ALOAD 1)) :: tl -> rewrite ((line, Instruction.ALOAD_1) :: acc) tl - | (line, (Instruction.WIDE_ALOAD 2)) :: tl -> rewrite ((line, Instruction.ALOAD_2) :: acc) tl - | (line, (Instruction.WIDE_ALOAD 3)) :: tl -> rewrite ((line, Instruction.ALOAD_3) :: acc) tl - | (line, (Instruction.WIDE_ALOAD i)) :: tl when i < 256 -> rewrite ((line, (Instruction.ALOAD i)) :: acc) tl - | (line, (Instruction.ALOAD 0)) :: tl -> rewrite ((line, Instruction.ALOAD_0) :: acc) tl - | (line, (Instruction.ALOAD 1)) :: tl -> rewrite ((line, Instruction.ALOAD_1) :: acc) tl - | (line, (Instruction.ALOAD 2)) :: tl -> rewrite ((line, Instruction.ALOAD_2) :: acc) tl - | (line, (Instruction.ALOAD 3)) :: tl -> rewrite ((line, Instruction.ALOAD_3) :: acc) tl - | (line, (Instruction.WIDE_ASTORE 0)) :: tl -> rewrite ((line, Instruction.ASTORE_0) :: acc) tl - | (line, (Instruction.WIDE_ASTORE 1)) :: tl -> rewrite ((line, Instruction.ASTORE_1) :: acc) tl - | (line, (Instruction.WIDE_ASTORE 2)) :: tl -> rewrite ((line, Instruction.ASTORE_2) :: acc) tl - | (line, (Instruction.WIDE_ASTORE 3)) :: tl -> rewrite ((line, Instruction.ASTORE_3) :: acc) tl - | (line, (Instruction.WIDE_ASTORE i)) :: tl when i < 256 -> rewrite ((line, (Instruction.ASTORE i)) :: acc) tl - | (line, (Instruction.ASTORE 0)) :: tl -> rewrite ((line, Instruction.ASTORE_0) :: acc) tl - | (line, (Instruction.ASTORE 1)) :: tl -> rewrite ((line, Instruction.ASTORE_1) :: acc) tl - | (line, (Instruction.ASTORE 2)) :: tl -> rewrite ((line, Instruction.ASTORE_2) :: acc) tl - | (line, (Instruction.ASTORE 3)) :: tl -> rewrite ((line, Instruction.ASTORE_3) :: acc) tl - | (line, (Instruction.WIDE_DLOAD 0)) :: tl -> rewrite ((line, Instruction.DLOAD_0) :: acc) tl - | (line, (Instruction.WIDE_DLOAD 1)) :: tl -> rewrite ((line, Instruction.DLOAD_1) :: acc) tl - | (line, (Instruction.WIDE_DLOAD 2)) :: tl -> rewrite ((line, Instruction.DLOAD_2) :: acc) tl - | (line, (Instruction.WIDE_DLOAD 3)) :: tl -> rewrite ((line, Instruction.DLOAD_3) :: acc) tl - | (line, (Instruction.WIDE_DLOAD i)) :: tl when i < 256 -> rewrite ((line, (Instruction.DLOAD i)) :: acc) tl - | (line, (Instruction.DLOAD 0)) :: tl -> rewrite ((line, Instruction.DLOAD_0) :: acc) tl - | (line, (Instruction.DLOAD 1)) :: tl -> rewrite ((line, Instruction.DLOAD_1) :: acc) tl - | (line, (Instruction.DLOAD 2)) :: tl -> rewrite ((line, Instruction.DLOAD_2) :: acc) tl - | (line, (Instruction.DLOAD 3)) :: tl -> rewrite ((line, Instruction.DLOAD_3) :: acc) tl - | (line, (Instruction.WIDE_DSTORE 0)) :: tl -> rewrite ((line, Instruction.DSTORE_0) :: acc) tl - | (line, (Instruction.WIDE_DSTORE 1)) :: tl -> rewrite ((line, Instruction.DSTORE_1) :: acc) tl - | (line, (Instruction.WIDE_DSTORE 2)) :: tl -> rewrite ((line, Instruction.DSTORE_2) :: acc) tl - | (line, (Instruction.WIDE_DSTORE 3)) :: tl -> rewrite ((line, Instruction.DSTORE_3) :: acc) tl - | (line, (Instruction.WIDE_DSTORE i)) :: tl when i < 256 -> rewrite ((line, (Instruction.DSTORE i)) :: acc) tl - | (line, (Instruction.DSTORE 0)) :: tl -> rewrite ((line, Instruction.DSTORE_0) :: acc) tl - | (line, (Instruction.DSTORE 1)) :: tl -> rewrite ((line, Instruction.DSTORE_1) :: acc) tl - | (line, (Instruction.DSTORE 2)) :: tl -> rewrite ((line, Instruction.DSTORE_2) :: acc) tl - | (line, (Instruction.DSTORE 3)) :: tl -> rewrite ((line, Instruction.DSTORE_3) :: acc) tl - | (line, (Instruction.WIDE_FLOAD 0)) :: tl -> rewrite ((line, Instruction.FLOAD_0) :: acc) tl - | (line, (Instruction.WIDE_FLOAD 1)) :: tl -> rewrite ((line, Instruction.FLOAD_1) :: acc) tl - | (line, (Instruction.WIDE_FLOAD 2)) :: tl -> rewrite ((line, Instruction.FLOAD_2) :: acc) tl - | (line, (Instruction.WIDE_FLOAD 3)) :: tl -> rewrite ((line, Instruction.FLOAD_3) :: acc) tl - | (line, (Instruction.WIDE_FLOAD i)) :: tl when i < 256 -> rewrite ((line, (Instruction.FLOAD i)) :: acc) tl - | (line, (Instruction.FLOAD 0)) :: tl -> rewrite ((line, Instruction.FLOAD_0) :: acc) tl - | (line, (Instruction.FLOAD 1)) :: tl -> rewrite ((line, Instruction.FLOAD_1) :: acc) tl - | (line, (Instruction.FLOAD 2)) :: tl -> rewrite ((line, Instruction.FLOAD_2) :: acc) tl - | (line, (Instruction.FLOAD 3)) :: tl -> rewrite ((line, Instruction.FLOAD_3) :: acc) tl - | (line, (Instruction.WIDE_FSTORE 0)) :: tl -> rewrite ((line, Instruction.FSTORE_0) :: acc) tl - | (line, (Instruction.WIDE_FSTORE 1)) :: tl -> rewrite ((line, Instruction.FSTORE_1) :: acc) tl - | (line, (Instruction.WIDE_FSTORE 2)) :: tl -> rewrite ((line, Instruction.FSTORE_2) :: acc) tl - | (line, (Instruction.WIDE_FSTORE 3)) :: tl -> rewrite ((line, Instruction.FSTORE_3) :: acc) tl - | (line, (Instruction.WIDE_FSTORE i)) :: tl when i < 256 -> rewrite ((line, (Instruction.FSTORE i)) :: acc) tl - | (line, (Instruction.FSTORE 0)) :: tl -> rewrite ((line, Instruction.FSTORE_0) :: acc) tl - | (line, (Instruction.FSTORE 1)) :: tl -> rewrite ((line, Instruction.FSTORE_1) :: acc) tl - | (line, (Instruction.FSTORE 2)) :: tl -> rewrite ((line, Instruction.FSTORE_2) :: acc) tl - | (line, (Instruction.FSTORE 3)) :: tl -> rewrite ((line, Instruction.FSTORE_3) :: acc) tl - | (line, (Instruction.WIDE_ILOAD 0)) :: tl -> rewrite ((line, Instruction.ILOAD_0) :: acc) tl - | (line, (Instruction.WIDE_ILOAD 1)) :: tl -> rewrite ((line, Instruction.ILOAD_1) :: acc) tl - | (line, (Instruction.WIDE_ILOAD 2)) :: tl -> rewrite ((line, Instruction.ILOAD_2) :: acc) tl - | (line, (Instruction.WIDE_ILOAD 3)) :: tl -> rewrite ((line, Instruction.ILOAD_3) :: acc) tl - | (line, (Instruction.WIDE_ILOAD i)) :: tl when i < 256 -> rewrite ((line, (Instruction.ILOAD i)) :: acc) tl - | (line, (Instruction.ILOAD 0)) :: tl -> rewrite ((line, Instruction.ILOAD_0) :: acc) tl - | (line, (Instruction.ILOAD 1)) :: tl -> rewrite ((line, Instruction.ILOAD_1) :: acc) tl - | (line, (Instruction.ILOAD 2)) :: tl -> rewrite ((line, Instruction.ILOAD_2) :: acc) tl - | (line, (Instruction.ILOAD 3)) :: tl -> rewrite ((line, Instruction.ILOAD_3) :: acc) tl - | (line, (Instruction.WIDE_ISTORE 0)) :: tl -> rewrite ((line, Instruction.ISTORE_0) :: acc) tl - | (line, (Instruction.WIDE_ISTORE 1)) :: tl -> rewrite ((line, Instruction.ISTORE_1) :: acc) tl - | (line, (Instruction.WIDE_ISTORE 2)) :: tl -> rewrite ((line, Instruction.ISTORE_2) :: acc) tl - | (line, (Instruction.WIDE_ISTORE 3)) :: tl -> rewrite ((line, Instruction.ISTORE_3) :: acc) tl - | (line, (Instruction.WIDE_ISTORE i)) :: tl when i < 256 -> rewrite ((line, (Instruction.ISTORE i)) :: acc) tl - | (line, (Instruction.ISTORE 0)) :: tl -> rewrite ((line, Instruction.ISTORE_0) :: acc) tl - | (line, (Instruction.ISTORE 1)) :: tl -> rewrite ((line, Instruction.ISTORE_1) :: acc) tl - | (line, (Instruction.ISTORE 2)) :: tl -> rewrite ((line, Instruction.ISTORE_2) :: acc) tl - | (line, (Instruction.ISTORE 3)) :: tl -> rewrite ((line, Instruction.ISTORE_3) :: acc) tl - | (line, (Instruction.WIDE_LLOAD 0)) :: tl -> rewrite ((line, Instruction.LLOAD_0) :: acc) tl - | (line, (Instruction.WIDE_LLOAD 1)) :: tl -> rewrite ((line, Instruction.LLOAD_1) :: acc) tl - | (line, (Instruction.WIDE_LLOAD 2)) :: tl -> rewrite ((line, Instruction.LLOAD_2) :: acc) tl - | (line, (Instruction.WIDE_LLOAD 3)) :: tl -> rewrite ((line, Instruction.LLOAD_3) :: acc) tl - | (line, (Instruction.WIDE_LLOAD i)) :: tl when i < 256 -> rewrite ((line, (Instruction.LLOAD i)) :: acc) tl - | (line, (Instruction.LLOAD 0)) :: tl -> rewrite ((line, Instruction.LLOAD_0) :: acc) tl - | (line, (Instruction.LLOAD 1)) :: tl -> rewrite ((line, Instruction.LLOAD_1) :: acc) tl - | (line, (Instruction.LLOAD 2)) :: tl -> rewrite ((line, Instruction.LLOAD_2) :: acc) tl - | (line, (Instruction.LLOAD 3)) :: tl -> rewrite ((line, Instruction.LLOAD_3) :: acc) tl - | (line, (Instruction.WIDE_LSTORE 0)) :: tl -> rewrite ((line, Instruction.LSTORE_0) :: acc) tl - | (line, (Instruction.WIDE_LSTORE 1)) :: tl -> rewrite ((line, Instruction.LSTORE_1) :: acc) tl - | (line, (Instruction.WIDE_LSTORE 2)) :: tl -> rewrite ((line, Instruction.LSTORE_2) :: acc) tl - | (line, (Instruction.WIDE_LSTORE 3)) :: tl -> rewrite ((line, Instruction.LSTORE_3) :: acc) tl - | (line, (Instruction.WIDE_LSTORE i)) :: tl when i < 256 -> rewrite ((line, (Instruction.LSTORE i)) :: acc) tl - | (line, (Instruction.LSTORE 0)) :: tl -> rewrite ((line, Instruction.LSTORE_0) :: acc) tl - | (line, (Instruction.LSTORE 1)) :: tl -> rewrite ((line, Instruction.LSTORE_1) :: acc) tl - | (line, (Instruction.LSTORE 2)) :: tl -> rewrite ((line, Instruction.LSTORE_2) :: acc) tl - | (line, (Instruction.LSTORE 3)) :: tl -> rewrite ((line, Instruction.LSTORE_3) :: acc) tl -*) + | (line, (Instruction.WIDE_ALOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ALOAD_0) :: acc) tl + | (line, (Instruction.WIDE_ALOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ALOAD_1) :: acc) tl + | (line, (Instruction.WIDE_ALOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ALOAD_2) :: acc) tl + | (line, (Instruction.WIDE_ALOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ALOAD_3) :: acc) tl + | (line, (Instruction.WIDE_ALOAD x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.ALOAD (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.ALOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ALOAD_0) :: acc) tl + | (line, (Instruction.ALOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ALOAD_1) :: acc) tl + | (line, (Instruction.ALOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ALOAD_2) :: acc) tl + | (line, (Instruction.ALOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ALOAD_3) :: acc) tl + | (line, (Instruction.WIDE_ASTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ASTORE_0) :: acc) tl + | (line, (Instruction.WIDE_ASTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ASTORE_1) :: acc) tl + | (line, (Instruction.WIDE_ASTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ASTORE_2) :: acc) tl + | (line, (Instruction.WIDE_ASTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ASTORE_3) :: acc) tl + | (line, (Instruction.WIDE_ASTORE x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.ASTORE (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.ASTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ASTORE_0) :: acc) tl + | (line, (Instruction.ASTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ASTORE_1) :: acc) tl + | (line, (Instruction.ASTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ASTORE_2) :: acc) tl + | (line, (Instruction.ASTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ASTORE_3) :: acc) tl + | (line, (Instruction.WIDE_DLOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.DLOAD_0) :: acc) tl + | (line, (Instruction.WIDE_DLOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.DLOAD_1) :: acc) tl + | (line, (Instruction.WIDE_DLOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.DLOAD_2) :: acc) tl + | (line, (Instruction.WIDE_DLOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.DLOAD_3) :: acc) tl + | (line, (Instruction.WIDE_DLOAD x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.DLOAD (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.DLOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.DLOAD_0) :: acc) tl + | (line, (Instruction.DLOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.DLOAD_1) :: acc) tl + | (line, (Instruction.DLOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.DLOAD_2) :: acc) tl + | (line, (Instruction.DLOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.DLOAD_3) :: acc) tl + | (line, (Instruction.WIDE_DSTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.DSTORE_0) :: acc) tl + | (line, (Instruction.WIDE_DSTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.DSTORE_1) :: acc) tl + | (line, (Instruction.WIDE_DSTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.DSTORE_2) :: acc) tl + | (line, (Instruction.WIDE_DSTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.DSTORE_3) :: acc) tl + | (line, (Instruction.WIDE_DSTORE x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.DSTORE (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.DSTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.DSTORE_0) :: acc) tl + | (line, (Instruction.DSTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.DSTORE_1) :: acc) tl + | (line, (Instruction.DSTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.DSTORE_2) :: acc) tl + | (line, (Instruction.DSTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.DSTORE_3) :: acc) tl + | (line, (Instruction.WIDE_FLOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.FLOAD_0) :: acc) tl + | (line, (Instruction.WIDE_FLOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.FLOAD_1) :: acc) tl + | (line, (Instruction.WIDE_FLOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.FLOAD_2) :: acc) tl + | (line, (Instruction.WIDE_FLOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.FLOAD_3) :: acc) tl + | (line, (Instruction.WIDE_FLOAD x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.FLOAD (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.FLOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.FLOAD_0) :: acc) tl + | (line, (Instruction.FLOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.FLOAD_1) :: acc) tl + | (line, (Instruction.FLOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.FLOAD_2) :: acc) tl + | (line, (Instruction.FLOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.FLOAD_3) :: acc) tl + | (line, (Instruction.WIDE_FSTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.FSTORE_0) :: acc) tl + | (line, (Instruction.WIDE_FSTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.FSTORE_1) :: acc) tl + | (line, (Instruction.WIDE_FSTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.FSTORE_2) :: acc) tl + | (line, (Instruction.WIDE_FSTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.FSTORE_3) :: acc) tl + | (line, (Instruction.WIDE_FSTORE x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.FSTORE (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.FSTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.FSTORE_0) :: acc) tl + | (line, (Instruction.FSTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.FSTORE_1) :: acc) tl + | (line, (Instruction.FSTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.FSTORE_2) :: acc) tl + | (line, (Instruction.FSTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.FSTORE_3) :: acc) tl + | (line, (Instruction.WIDE_ILOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ILOAD_0) :: acc) tl + | (line, (Instruction.WIDE_ILOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ILOAD_1) :: acc) tl + | (line, (Instruction.WIDE_ILOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ILOAD_2) :: acc) tl + | (line, (Instruction.WIDE_ILOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ILOAD_3) :: acc) tl + | (line, (Instruction.WIDE_ILOAD x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.ILOAD (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.ILOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ILOAD_0) :: acc) tl + | (line, (Instruction.ILOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ILOAD_1) :: acc) tl + | (line, (Instruction.ILOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ILOAD_2) :: acc) tl + | (line, (Instruction.ILOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ILOAD_3) :: acc) tl + | (line, (Instruction.WIDE_ISTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ISTORE_0) :: acc) tl + | (line, (Instruction.WIDE_ISTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ISTORE_1) :: acc) tl + | (line, (Instruction.WIDE_ISTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ISTORE_2) :: acc) tl + | (line, (Instruction.WIDE_ISTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ISTORE_3) :: acc) tl + | (line, (Instruction.WIDE_ISTORE x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.ISTORE (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.ISTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.ISTORE_0) :: acc) tl + | (line, (Instruction.ISTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.ISTORE_1) :: acc) tl + | (line, (Instruction.ISTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.ISTORE_2) :: acc) tl + | (line, (Instruction.ISTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.ISTORE_3) :: acc) tl + | (line, (Instruction.WIDE_LLOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.LLOAD_0) :: acc) tl + | (line, (Instruction.WIDE_LLOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.LLOAD_1) :: acc) tl + | (line, (Instruction.WIDE_LLOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.LLOAD_2) :: acc) tl + | (line, (Instruction.WIDE_LLOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.LLOAD_3) :: acc) tl + | (line, (Instruction.WIDE_LLOAD x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.LLOAD (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.LLOAD x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.LLOAD_0) :: acc) tl + | (line, (Instruction.LLOAD x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.LLOAD_1) :: acc) tl + | (line, (Instruction.LLOAD x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.LLOAD_2) :: acc) tl + | (line, (Instruction.LLOAD x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.LLOAD_3) :: acc) tl + | (line, (Instruction.WIDE_LSTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.LSTORE_0) :: acc) tl + | (line, (Instruction.WIDE_LSTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.LSTORE_1) :: acc) tl + | (line, (Instruction.WIDE_LSTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.LSTORE_2) :: acc) tl + | (line, (Instruction.WIDE_LSTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.LSTORE_3) :: acc) tl + | (line, (Instruction.WIDE_LSTORE x)) :: tl when (x :> int) < 256 -> rewrite ((line, (Instruction.LSTORE (u1 (x :> int)))) :: acc) tl + | (line, (Instruction.LSTORE x)) :: tl when (x :> int) = 0 -> rewrite ((line, Instruction.LSTORE_0) :: acc) tl + | (line, (Instruction.LSTORE x)) :: tl when (x :> int) = 1 -> rewrite ((line, Instruction.LSTORE_1) :: acc) tl + | (line, (Instruction.LSTORE x)) :: tl when (x :> int) = 2 -> rewrite ((line, Instruction.LSTORE_2) :: acc) tl + | (line, (Instruction.LSTORE x)) :: tl when (x :> int) = 3 -> rewrite ((line, Instruction.LSTORE_3) :: acc) tl hunk ./src/analysis/peephole.ml 284 -(* hunk ./src/analysis/peephole.ml 333 -*) hunk ./src/analysis/peephole.ml 339 -(* - | (line, iload) :: (_, Instruction.ICONST_M1) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), 1))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_1) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), -1))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_2) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), -2))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_3) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), -3))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_4) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), -4))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_5) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), -5))) :: acc) tl - | (line, iload) :: (_, (Instruction.BIPUSH n)) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), ~-n))) :: acc) tl - | (line, iload) :: (_, (Instruction.SIPUSH n)) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.WIDE_IINC ((extract_iload_index iload), ~-n))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_M1) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), -1))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_1) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), 1))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_2) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), 2))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_3) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), 3))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_4) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), 4))) :: acc) tl - | (line, iload) :: (_, Instruction.ICONST_5) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), 5))) :: acc) tl - | (line, iload) :: (_, (Instruction.BIPUSH n)) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index iload), n))) :: acc) tl - | (line, iload) :: (_, (Instruction.SIPUSH n)) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.WIDE_IINC ((extract_iload_index iload), n))) :: acc) tl -*) + | (line, iload) :: (_, Instruction.ICONST_M1) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 1))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_1) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 (-1)))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_2) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 (-2)))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_3) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 (-3)))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_4) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 (-4)))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_5) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 (-5)))) :: acc) tl + | (line, iload) :: (_, (Instruction.BIPUSH n)) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1_neg n))) :: acc) tl + | (line, iload) :: (_, (Instruction.SIPUSH n)) :: (_, Instruction.ISUB) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.WIDE_IINC ((extract_iload_index_u2 iload), s2_neg n))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_M1) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 (-1)))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_1) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 1))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_2) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 2))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_3) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 3))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_4) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 4))) :: acc) tl + | (line, iload) :: (_, Instruction.ICONST_5) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), s1 5))) :: acc) tl + | (line, iload) :: (_, (Instruction.BIPUSH n)) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.IINC ((extract_iload_index_u1 iload), n))) :: acc) tl + | (line, iload) :: (_, (Instruction.SIPUSH n)) :: (_, Instruction.IADD) :: (_, istore) :: tl when (load_store_same_index iload istore) -> rewrite ((line, (Instruction.WIDE_IINC ((extract_iload_index_u2 iload), n))) :: acc) tl hunk ./src/analysis/peephole.ml 361 -(* hunk ./src/analysis/peephole.ml 391 -*) hunk ./src/analysis/peephole.ml 397 -(* hunk ./src/analysis/peephole.ml 409 -*) hunk ./src/analysis/peephole.ml 415 -(* hunk ./src/analysis/peephole.ml 447 -*) hunk ./src/analysis/peephole.ml 453 -(* hunk ./src/analysis/peephole.ml 485 -*) hunk ./src/analysis/peephole.ml 491 -(* - | (line, Instruction.DCONST_0) :: (_, dload) :: (_, op) :: tl when (is_dload dload) && (is_commutative_double_operation op) -> rewrite ((line, op) :: (line, Instruction.DCONST_0) :: (line, dload) :: acc) tl - | (line, Instruction.DCONST_1) :: (_, dload) :: (_, op) :: tl when (is_dload dload) && (is_commutative_double_operation op) -> rewrite ((line, op) :: (line, Instruction.DCONST_1) :: (line, dload) :: acc) tl - | (line, (Instruction.LDC2_W (`Double c))) :: (_, dload) :: (_, op) :: tl when (is_dload dload) && (is_commutative_double_operation op) -> rewrite ((line, op) :: (line, (Instruction.LDC2_W (`Double c))) :: (line, dload) :: acc) tl - | (line, Instruction.FCONST_0) :: (_, fload) :: (_, op) :: tl when (is_fload fload) && (is_commutative_float_operation op) -> rewrite ((line, op) :: (line, Instruction.FCONST_0) :: (line, fload) :: acc) tl - | (line, Instruction.FCONST_1) :: (_, fload) :: (_, op) :: tl when (is_fload fload) && (is_commutative_float_operation op) -> rewrite ((line, op) :: (line, Instruction.FCONST_1) :: (line, fload) :: acc) tl - | (line, Instruction.FCONST_2) :: (_, fload) :: (_, op) :: tl when (is_fload fload) && (is_commutative_float_operation op) -> rewrite ((line, op) :: (line, Instruction.FCONST_1) :: (line, fload) :: acc) tl - | (line, (Instruction.LDC (`Float c))) :: (_, fload) :: (_, op) :: tl when (is_fload fload) && (is_commutative_float_operation op) -> rewrite ((line, op) :: (line, (Instruction.LDC (`Float c))) :: (line, fload) :: acc) tl - | (line, (Instruction.LDC_W (`Float c))) :: (_, fload) :: (_, op) :: tl when (is_fload fload) && (is_commutative_float_operation op) -> rewrite ((line, op) :: (line, (Instruction.LDC_W (`Float c))) :: (line, fload) :: acc) tl hunk ./src/analysis/peephole.ml 505 -*) hunk ./src/analysis/peephole.ml 511 -(* - | (_, Instruction.DCONST_0) :: (_, Instruction.DADD) :: tl - | (_, Instruction.FCONST_0) :: (_, Instruction.FADD) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.IADD) :: tl - | (_, Instruction.LCONST_0) :: (_, Instruction.LADD) :: tl - | (_, Instruction.DCONST_0) :: (_, Instruction.DSUB) :: tl - | (_, Instruction.FCONST_0) :: (_, Instruction.FSUB) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.ISUB) :: tl - | (_, Instruction.LCONST_0) :: (_, Instruction.LSUB) :: tl - | (_, Instruction.DCONST_1) :: (_, Instruction.DMUL) :: tl - | (_, Instruction.FCONST_1) :: (_, Instruction.FMUL) :: tl - | (_, Instruction.ICONST_1) :: (_, Instruction.IMUL) :: tl - | (_, Instruction.LCONST_1) :: (_, Instruction.LMUL) :: tl - | (_, Instruction.DCONST_1) :: (_, Instruction.DDIV) :: tl - | (_, Instruction.FCONST_1) :: (_, Instruction.FDIV) :: tl - | (_, Instruction.ICONST_1) :: (_, Instruction.IDIV) :: tl - | (_, Instruction.LCONST_1) :: (_, Instruction.LDIV) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.IOR) :: tl - | (_, Instruction.LCONST_0) :: (_, Instruction.LOR) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.IXOR) :: tl - | (_, Instruction.LCONST_0) :: (_, Instruction.LXOR) :: tl - | (_, Instruction.ICONST_M1) :: (_, Instruction.IAND) :: tl - | (_, (Instruction.LDC2_W (`Long 1L))) :: (_, Instruction.LAND) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.ISHL) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.LSHL) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.ISHR) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.LSHR) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.IUSHR) :: tl - | (_, Instruction.ICONST_0) :: (_, Instruction.LUSHR) :: tl - | (_, (Instruction.IINC (_, 0))) :: tl - | (_, (Instruction.WIDE_IINC (_, 0))) :: tl -> rewrite acc tl -*) + | (_, Instruction.ICONST_0) :: (_, Instruction.IADD) :: tl -> rewrite acc tl + | (_, Instruction.LCONST_0) :: (_, Instruction.LADD) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.ISUB) :: tl -> rewrite acc tl + | (_, Instruction.LCONST_0) :: (_, Instruction.LSUB) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_1) :: (_, Instruction.IMUL) :: tl -> rewrite acc tl + | (_, Instruction.LCONST_1) :: (_, Instruction.LMUL) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_1) :: (_, Instruction.IDIV) :: tl -> rewrite acc tl + | (_, Instruction.LCONST_1) :: (_, Instruction.LDIV) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.IOR) :: tl -> rewrite acc tl + | (_, Instruction.LCONST_0) :: (_, Instruction.LOR) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.IXOR) :: tl -> rewrite acc tl + | (_, Instruction.LCONST_0) :: (_, Instruction.LXOR) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_M1) :: (_, Instruction.IAND) :: tl -> rewrite acc tl + | (_, (Instruction.LDC2_W (`Long (-1L)))) :: (_, Instruction.LAND) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.ISHL) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.LSHL) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.ISHR) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.LSHR) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.IUSHR) :: tl -> rewrite acc tl + | (_, Instruction.ICONST_0) :: (_, Instruction.LUSHR) :: tl -> rewrite acc tl + | (_, (Instruction.IINC (_, z))) :: tl when z = s1_zero -> rewrite acc tl + | (_, (Instruction.WIDE_IINC (_, z))) :: tl when z = s2_zero -> rewrite acc tl hunk ./src/analysis/peephole.ml 539 -(* hunk ./src/analysis/peephole.ml 541 - | (line, Instruction.ICONST_1) :: (_, Instruction.IREM) :: tl -> rewrite ((line, Instruction.ICONST_0) :: (line, Instruction.POP) :: acc) tl - | (line, Instruction.LCONST_1) :: (_, Instruction.LREM) :: tl -> rewrite ((line, Instruction.LCONST_0) :: (line, Instruction.POP2) :: acc) tl hunk ./src/analysis/peephole.ml 545 -*) hunk ./src/analysis/peephole.ml 551 -(* - | (line, (Instruction.LDC2_W (`Double (-1.0)))) :: (_, Instruction.DMUL) :: tl -> rewrite ((line, Instruction.DNEG) :: acc) tl - | (line, (Instruction.LDC (`Float (-1.0)))) :: (_, Instruction.FMUL) :: tl -> rewrite ((line, Instruction.FNEG) :: acc) tl - | (line, (Instruction.LDC_W (`Float (-1.0)))) :: (_, Instruction.FMUL) :: tl -> rewrite ((line, Instruction.FNEG) :: acc) tl hunk ./src/analysis/peephole.ml 553 - | (line, (Instruction.LDC2_W (`Double (-1.0)))) :: (_, Instruction.DDIV) :: tl -> rewrite ((line, Instruction.DNEG) :: acc) tl - | (line, (Instruction.LDC (`Float (-1.0)))) :: (_, Instruction.FDIV) :: tl -> rewrite ((line, Instruction.FNEG) :: acc) tl - | (line, (Instruction.LDC_W (`Float (-1.0)))) :: (_, Instruction.FDIV) :: tl -> rewrite ((line, Instruction.FNEG) :: acc) tl hunk ./src/analysis/peephole.ml 557 - | (line, (Instruction.BIPUSH 8)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, Instruction.ICONST_3) :: acc) tl - | (line, (Instruction.BIPUSH 16)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, Instruction.ICONST_4) :: acc) tl - | (line, (Instruction.BIPUSH 32)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, Instruction.ICONST_5) :: acc) tl - | (line, (Instruction.BIPUSH 64)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 6)) :: acc) tl - | (line, (Instruction.SIPUSH 128)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 7)) :: acc) tl - | (line, (Instruction.SIPUSH 256)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 8)) :: acc) tl - | (line, (Instruction.SIPUSH 512)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 9)) :: acc) tl - | (line, (Instruction.SIPUSH 1024)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 10)) :: acc) tl - | (line, (Instruction.SIPUSH 2048)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 11)) :: acc) tl - | (line, (Instruction.SIPUSH 4096)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 12)) :: acc) tl - | (line, (Instruction.SIPUSH 8192)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 13)) :: acc) tl - | (line, (Instruction.SIPUSH 16384)) :: (_, Instruction.IMUL) :: tl -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH 14)) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 8 -> rewrite ((line, Instruction.ISHL) :: (line, Instruction.ICONST_3) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 16 -> rewrite ((line, Instruction.ISHL) :: (line, Instruction.ICONST_4) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 32 -> rewrite ((line, Instruction.ISHL) :: (line, Instruction.ICONST_5) :: acc) tl + | (line, (Instruction.BIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 64 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 6))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 128 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 7))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 256 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 8))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 512 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 9))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 1024 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 10))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 2048 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 11))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 4096 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 12))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 8192 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 13))) :: acc) tl + | (line, (Instruction.SIPUSH x)) :: (_, Instruction.IMUL) :: tl when (x :> int) = 16384 -> rewrite ((line, Instruction.ISHL) :: (line, (Instruction.BIPUSH (s1 14))) :: acc) tl hunk ./src/analysis/peephole.ml 574 - | (line, (Instruction.LDC2_W (`Long 64L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 6)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 128L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 7)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 256L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 8)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 512L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 9)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 1024L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 10)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 2048L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 11)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 4096L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 12)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 8192L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 13)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 16384L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 14)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 32768L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 15)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 65536L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 16)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 16777216L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 24)) :: acc) tl - | (line, (Instruction.LDC2_W (`Long 4294967296L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH 32)) :: acc) tl -*) + | (line, (Instruction.LDC2_W (`Long 64L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 6))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 128L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 7))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 256L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 8))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 512L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 9))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 1024L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 10))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 2048L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 11))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 4096L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 12))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 8192L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 13))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 16384L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 14))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 32768L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 15))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 65536L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 16))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 16777216L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 24))) :: acc) tl + | (line, (Instruction.LDC2_W (`Long 4294967296L))) :: (_, Instruction.LMUL) :: tl -> rewrite ((line, Instruction.LSHL) :: (line, (Instruction.BIPUSH (s1 32))) :: acc) tl hunk ./src/analysis/peephole.ml 593 -(* - | (_, Instruction.DNEG) :: (_, Instruction.DNEG) :: tl -> rewrite acc tl - | (_, Instruction.FNEG) :: (_, Instruction.FNEG) :: tl -> rewrite acc tl hunk ./src/analysis/peephole.ml 595 - | (line, Instruction.DNEG) :: (_, Instruction.DADD) :: tl -> rewrite ((line, Instruction.DSUB) :: acc) tl - | (line, Instruction.FNEG) :: (_, Instruction.FADD) :: tl -> rewrite ((line, Instruction.FSUB) :: acc) tl hunk ./src/analysis/peephole.ml 606 - | (line, (Instruction.CHECKCAST c1)) :: (_, (Instruction.CHECKCAST c2)) :: tl when c1 = c2 -> rewrite ((line, (Instruction.CHECKCAST c1)) :: acc) tl -*) + | (line, (Instruction.CHECKCAST c1)) :: (_, (Instruction.CHECKCAST c2)) :: tl when same_cast c1 c2 -> rewrite ((line, (Instruction.CHECKCAST c1)) :: acc) tl hunk ./src/analysis/peephole.ml 647 - | (`Class_or_interface c1), (`Class_or_interface c2) -> same_class_name c1 c2 - | (`Array_type d1), (`Array_type d2) -> eq_desc (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type) + | (`Class_or_interface c1), (`Class_or_interface c2) -> Name.equal_for_class c1 c2 + | (`Array_type d1), (`Array_type d2) -> Descriptor.equal_java_type (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type) hunk ./src/analysis/peephole.ml 655 - | (`Class_or_interface c1), (`Class_or_interface c2) -> same_class_name c1 c2 - | (`Array_type d1), (`Array_type d2) -> eq_desc (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type) + | (`Class_or_interface c1), (`Class_or_interface c2) -> Name.equal_for_class c1 c2 + | (`Array_type d1), (`Array_type d2) -> Descriptor.equal_java_type (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type) hunk ./src/analysis/peephole.ml 673 - | (Instruction.INVOKEVIRTUAL (coi1, m1, d1)), (Instruction.INVOKEVIRTUAL (coi2, m2, d2)) -> (eq_coi coi1 coi2) && (same_method_name m1 m2) && (eq_meth_desc d1 d2) + | (Instruction.INVOKEVIRTUAL (coi1, m1, d1)), (Instruction.INVOKEVIRTUAL (coi2, m2, d2)) -> (eq_coi coi1 coi2) && (Name.equal_for_method m1 m2) && (Descriptor.equal_for_method d1 d2) hunk ./src/analysis/peephole.ml 678 - | (Instruction.NEW c1), (Instruction.NEW c2) -> same_class_name c1 c2 - | (Instruction.NEWARRAY d1), (Instruction.NEWARRAY d2) -> eq_desc (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type) + | (Instruction.NEW c1), (Instruction.NEW c2) -> Name.equal_for_class c1 c2 + | (Instruction.NEWARRAY d1), (Instruction.NEWARRAY d2) -> Descriptor.equal_java_type (d1 :> Descriptor.java_type) (d2 :> Descriptor.java_type) hunk ./src/analysis/peephole.mli 19 -(** This module provides functions for peephole optimization. *) +(** Peephole optimizations over jump-less instruction lists. *) hunk ./src/analysis/peephole.mli 93 - Raises [Not_found] if [p] references rewriting rules not present in the list. *) + Raises [Not_found] if [p] references rewriting rules not present in + the list. *) hunk ./src/analysis/peephole.mli 100 -(** [optimize_graph ~rules:l g] returns a graph similar to [g], except that every - instruction list has been optimized, [l] being the list of rewriting rules - to apply to instruction lists (until a fixpoint is reached). *) +(** [optimize_graph ~rules:l g] returns a graph similar to [g], except + that every instruction list has been optimized, [l] being the list of + rewriting rules to apply to instruction lists (until a fixpoint is + reached). *) hunk ./src/analysis/stackState.ml 39 - | Invalid_local_index + | Invalid_local_index of Utils.u2 * int hunk ./src/analysis/stackState.ml 46 - | Different_stack_sizes + | Different_stack_sizes of int * int hunk ./src/analysis/stackState.ml 49 - | Different_frames + | Different_frames of Utils.u2 hunk ./src/analysis/stackState.ml 55 -let string_of_verification_type_info = function - | Attribute.Top_variable_info -> "top" - | Attribute.Integer_variable_info -> "int" - | Attribute.Float_variable_info -> "float" - | Attribute.Long_variable_info -> "long" - | Attribute.Double_variable_info -> "double" - | Attribute.Null_variable_info -> "null" - | Attribute.Uninitialized_this_variable_info -> "uninit this" - | Attribute.Object_variable_info (`Class_or_interface cn) -> UTF8.to_string (Name.external_utf8_for_class cn) - | Attribute.Object_variable_info (`Array_type (`Array a)) -> - let rec conv = function - | `Boolean -> "boolean" - | `Byte -> "byte" - | `Char -> "char" - | `Double -> "double" - | `Float -> "float" - | `Int -> "int" - | `Long -> "long" - | `Short -> "short" - | `Class cn -> UTF8.to_string (Name.external_utf8_for_class cn) - | `Array a -> (conv a) ^ "[]" in - (conv a) ^ "[]" - | Attribute.Uninitialized_variable_info ofs -> "uninit " ^ (string_of_int (ofs :> int)) - hunk ./src/analysis/stackState.ml 56 - | Unsupported_instruction x -> "unsupported instruction: " ^ x + | Unsupported_instruction x -> + Printf.sprintf "unsupported instruction: %S" x hunk ./src/analysis/stackState.ml 59 - | Invalid_local_index -> "invalid local index" + | Invalid_local_index (i, l) -> + Printf.sprintf "invalid local index (%d, length %d)" (i :> int) l hunk ./src/analysis/stackState.ml 62 - "invalid stack top: '" ^ (string_of_verification_type_info w) - ^ "' waited but '" ^ (string_of_verification_type_info f) ^ "' found" + Printf.sprintf "invalid stack top: %S waited but %S found" + (Attribute.string_of_verification_type_info w) + (Attribute.string_of_verification_type_info f) hunk ./src/analysis/stackState.ml 66 - "invalid local contents at index " ^ (string_of_int (i :> int)) ^ ": '" ^ (string_of_verification_type_info w) - ^ "' waited but '" ^ (string_of_verification_type_info f) ^ "' found" - | Reference_waited f -> "reference waited but '" ^ (string_of_verification_type_info f) ^ "' found" + Printf.sprintf "invalid local contents at index %d: %S waited but %S found" + (i :> int) + (Attribute.string_of_verification_type_info w) + (Attribute.string_of_verification_type_info f) + | Reference_waited f -> + Printf.sprintf "reference waited but %S found" + (Attribute.string_of_verification_type_info f) hunk ./src/analysis/stackState.ml 76 - | Different_stack_sizes -> "different stack sizes" + | Different_stack_sizes (sz1, sz2) -> + Printf.sprintf "different stack sizes (%d and %d)" sz1 sz2 hunk ./src/analysis/stackState.ml 80 - | Different_frames -> "different frames" + | Different_frames ofs -> + Printf.sprintf "different frames (at offset %d)" (ofs :> int) hunk ./src/analysis/stackState.ml 95 -let verification_type_info_of_parameter_descriptor = function - | `Boolean -> Attribute.Integer_variable_info - | `Byte -> Attribute.Integer_variable_info - | `Char -> Attribute.Integer_variable_info - | `Double -> Attribute.Double_variable_info - | `Float -> Attribute.Float_variable_info - | `Int -> Attribute.Integer_variable_info - | `Long -> Attribute.Long_variable_info - | `Short -> Attribute.Integer_variable_info - | `Class cn -> Attribute.Object_variable_info (`Class_or_interface cn) - | `Array e -> Attribute.Object_variable_info (`Array_type (`Array e)) - hunk ./src/analysis/stackState.ml 99 -let java_dyn_MethodHandle = Name.make_for_class_from_external (UTF8.of_string "java.dyn.MethodHandle") +let java_lang_invoke_MethodHandle = Name.make_for_class_from_external (UTF8.of_string "java.lang.invoke.MethodHandle") hunk ./src/analysis/stackState.ml 109 - | `Interface_method _ -> Attribute.Object_variable_info (`Class_or_interface java_dyn_MethodHandle) - | `Method _ -> Attribute.Object_variable_info (`Class_or_interface java_dyn_MethodHandle) + | `Interface_method _ -> Attribute.Object_variable_info (`Class_or_interface java_lang_invoke_MethodHandle) + | `Method _ -> Attribute.Object_variable_info (`Class_or_interface java_lang_invoke_MethodHandle) hunk ./src/analysis/stackState.ml 126 - let l' = List.map verification_type_info_of_parameter_descriptor l in - let l'' = match c with - | Some (_, true) -> Attribute.Uninitialized_this_variable_info :: l' - | Some (cn, false) -> (Attribute.Object_variable_info (`Class_or_interface cn)) :: l' - | None -> l' in - { locals = of_list l''; stack = []; } + let l = List.map Attribute.verification_type_info_of_parameter_descriptor l in + let l = match c with + | Some (_, true) -> Attribute.Uninitialized_this_variable_info :: l + | Some (cn, false) -> (Attribute.Object_variable_info (`Class_or_interface cn)) :: l + | None -> l in + { locals = of_list l; stack = []; } hunk ./src/analysis/stackState.ml 134 - | Method.Regular (flags, _, (l, _), _) -> - let l' = List.map verification_type_info_of_parameter_descriptor l in - let l'' = + | Method.Regular { Method.flags; descriptor; _ } -> + let l = fst descriptor in + let l = List.map Attribute.verification_type_info_of_parameter_descriptor l in + let l = hunk ./src/analysis/stackState.ml 139 - l' + l hunk ./src/analysis/stackState.ml 141 - (Attribute.Object_variable_info (`Class_or_interface cn)) :: l' in - { locals = of_list l''; stack = [] } - | Method.Constructor (_, l, _) -> - let l' = List.map verification_type_info_of_parameter_descriptor l in - let l'' = Attribute.Uninitialized_this_variable_info :: l' in - { locals = of_list l''; stack = [] } + (Attribute.Object_variable_info (`Class_or_interface cn)) :: l in + { locals = of_list l; stack = [] } + | Method.Constructor { Method.cstr_descriptor = l ; _ } -> + let l = List.map Attribute.verification_type_info_of_parameter_descriptor l in + let l = Attribute.Uninitialized_this_variable_info :: l in + { locals = of_list l; stack = [] } hunk ./src/analysis/stackState.ml 156 -let rec eq_desc x y = - match (x, y) with - | (`Class cn1), (`Class cn2) -> - Name.eq_for_class cn1 cn2 - | (`Array a1), (`Array a2) -> - eq_desc (a1 :> Descriptor.java_type) (a2 :> Descriptor.java_type) - | _ -> x = y - -let eq_type_info x y = - match (x, y) with - | (Attribute.Object_variable_info (`Class_or_interface cn1)), - (Attribute.Object_variable_info (`Class_or_interface cn2)) -> - Name.eq_for_class cn1 cn2 - | (Attribute.Object_variable_info (`Array_type at1)), - (Attribute.Object_variable_info (`Array_type at2)) -> - eq_desc (at1 :> Descriptor.java_type) (at2 :> Descriptor.java_type) - | (Attribute.Object_variable_info _), - (Attribute.Object_variable_info _) -> false - | (Attribute.Uninitialized_variable_info uvi1), - (Attribute.Uninitialized_variable_info uvi2) -> uvi1 = uvi2 - | _ -> x = y - hunk ./src/analysis/stackState.ml 160 - List.fold_left (fun acc x -> acc + match x with Attribute.Double_variable_info | Attribute.Long_variable_info -> 2 | _ -> 1) 0 st.stack + List.fold_left + (fun acc x -> + acc + + (match x with + | Attribute.Double_variable_info + | Attribute.Long_variable_info -> 2 + | _ -> 1)) + 0 + st.stack hunk ./src/analysis/stackState.ml 170 -let array_for_all2 ?(n=max_int) p a1 a2 = +let array_for_all2 ?(n = max_int) p a1 a2 = hunk ./src/analysis/stackState.ml 179 - && (array_for_all2 eq_type_info st1.locals st2.locals) + && (array_for_all2 Attribute.equal_verification_type_info st1.locals st2.locals) hunk ./src/analysis/stackState.ml 183 - && (List.for_all2 eq_type_info st1.stack st2.stack) + && (List.for_all2 Attribute.equal_verification_type_info st1.stack st2.stack) hunk ./src/analysis/stackState.ml 195 - push (verification_type_info_of_parameter_descriptor y) s + push (Attribute.verification_type_info_of_parameter_descriptor y) s hunk ./src/analysis/stackState.ml 207 - if (match v with Attribute.Object_variable_info _ -> true | _ -> eq_type_info v v') then + let popable = match v with + | Attribute.Object_variable_info _ -> true + | _ -> Attribute.equal_verification_type_info v v' in + if popable then hunk ./src/analysis/stackState.ml 226 -let pop_if_cat1 = function +let pop_if_category1 = function hunk ./src/analysis/stackState.ml 241 - let i = (i : u2 :> int) in - if i >= 0 && i < Array.length l then - l.(i) + let j = (i : u2 :> int) in + let len = Array.length l in + if j >= 0 && j < len then + l.(j) hunk ./src/analysis/stackState.ml 246 - fail Invalid_local_index + fail (Invalid_local_index (i, len)) hunk ./src/analysis/stackState.ml 250 - if not (eq_type_info v v') then + if not (Attribute.equal_verification_type_info v v') then hunk ./src/analysis/stackState.ml 317 - | Attribute.Object_variable_info (`Array_type (`Array t)) -> push (verification_type_info_of_parameter_descriptor t) stack + | Attribute.Object_variable_info (`Array_type (`Array t)) -> push (Attribute.verification_type_info_of_parameter_descriptor t) stack hunk ./src/analysis/stackState.ml 431 - let stack = push (verification_type_info_of_parameter_descriptor (match parameter with `Array_type at -> (at :> Descriptor.for_parameter) | `Class_or_interface cn -> `Class cn)) stack in + let stack = push (Attribute.verification_type_info_of_parameter_descriptor (match parameter with `Array_type at -> (at :> Descriptor.for_parameter) | `Class_or_interface cn -> `Class cn)) stack in hunk ./src/analysis/stackState.ml 544 - let v, stack = pop_if_cat1 stack in + let v, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 553 - let v2, stack = pop_if_cat1 stack in + let v2, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 566 - let v2, stack = pop_if_cat1 stack in - let v3, stack = pop_if_cat1 stack in + let v2, stack = pop_if_category1 stack in + let v3, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 575 - let v2, stack = pop_if_cat1 stack in + let v2, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 585 - let v2, stack = pop_if_cat1 stack in + let v2, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 610 - let v3, stack = pop_if_cat1 stack in + let v3, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 624 - let v1, stack = pop_if_cat1 stack in - let v2, stack = pop_if_cat1 stack in + let v1, stack = pop_if_category1 stack in + let v2, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 631 - let v1, stack = pop_if_cat1 stack in + let v1, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 635 - let v2, stack = pop_if_cat1 stack in - let v3, stack = pop_if_cat1 stack in + let v2, stack = pop_if_category1 stack in + let v3, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 764 - let stack = push (verification_type_info_of_parameter_descriptor desc) stack in + let stack = push (Attribute.verification_type_info_of_parameter_descriptor desc) stack in hunk ./src/analysis/stackState.ml 767 - let stack = push (verification_type_info_of_parameter_descriptor desc) stack in + let stack = push (Attribute.verification_type_info_of_parameter_descriptor desc) stack in hunk ./src/analysis/stackState.ml 937 - let infos = List.rev_map verification_type_info_of_parameter_descriptor params in + let infos = List.rev_map Attribute.verification_type_info_of_parameter_descriptor params in hunk ./src/analysis/stackState.ml 945 - let infos = List.rev_map verification_type_info_of_parameter_descriptor params in + let infos = List.rev_map Attribute.verification_type_info_of_parameter_descriptor params in hunk ./src/analysis/stackState.ml 953 - let infos = List.rev_map verification_type_info_of_parameter_descriptor params in + let infos = List.rev_map Attribute.verification_type_info_of_parameter_descriptor params in hunk ./src/analysis/stackState.ml 973 - let infos = List.rev_map verification_type_info_of_parameter_descriptor params in + let infos = List.rev_map Attribute.verification_type_info_of_parameter_descriptor params in hunk ./src/analysis/stackState.ml 978 - let infos = List.rev_map verification_type_info_of_parameter_descriptor params in + let infos = List.rev_map Attribute.verification_type_info_of_parameter_descriptor params in hunk ./src/analysis/stackState.ml 1221 - let _, stack = pop_if_cat1 stack in + let _, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 1227 - snd (pop_if_cat1 (snd (pop_if_cat1 stack))) + snd (pop_if_category1 (snd (pop_if_category1 stack))) hunk ./src/analysis/stackState.ml 1232 - let stack = pop_if (verification_type_info_of_parameter_descriptor desc) stack in + let stack = pop_if (Attribute.verification_type_info_of_parameter_descriptor desc) stack in hunk ./src/analysis/stackState.ml 1238 - let stack = pop_if (verification_type_info_of_parameter_descriptor desc) stack in + let stack = pop_if (Attribute.verification_type_info_of_parameter_descriptor desc) stack in hunk ./src/analysis/stackState.ml 1258 - let v1, stack = pop_if_cat1 stack in - let v2, stack = pop_if_cat1 stack in + let v1, stack = pop_if_category1 stack in + let v2, stack = pop_if_category1 stack in hunk ./src/analysis/stackState.ml 1318 +type instance = + [ `Array_type of Descriptor.array_type + | `Class_or_interface of Name.for_class ] + hunk ./src/analysis/stackState.ml 1356 - if Name.eq_for_class x y then + if Name.equal_for_class x y then hunk ./src/analysis/stackState.ml 1366 - let c, p = List.find (fun (x, _) -> Name.eq_for_class cn x) l in + let c, p = List.find (fun (x, _) -> Name.equal_for_class cn x) l in hunk ./src/analysis/stackState.ml 1389 - let c, p = List.find (fun (x, _) -> Name.eq_for_class cn x) l in + let c, p = List.find (fun (x, _) -> Name.equal_for_class cn x) l in hunk ./src/analysis/stackState.ml 1415 - if (List.length st1.stack) = (List.length st2.stack) then begin + let sz1 = List.length st1.stack in + let sz2 = List.length st2.stack in + if sz1 = sz2 then begin hunk ./src/analysis/stackState.ml 1432 - fail Different_stack_sizes + fail (Different_stack_sizes (sz1, sz2)) hunk ./src/analysis/stackState.ml 1434 -let encode l = +let encode ?(optimize = true) l = hunk ./src/analysis/stackState.ml 1443 -(* - if same_locals prev curr then + if optimize && same_locals prev curr then hunk ./src/analysis/stackState.ml 1452 - | -3 when array_for_all2 ~n:curr_size eq_type_info prev.locals curr.locals -> + | -3 when array_for_all2 ~n:curr_size Attribute.equal_verification_type_info prev.locals curr.locals -> hunk ./src/analysis/stackState.ml 1454 - | -2 when array_for_all2 ~n:curr_size eq_type_info prev.locals curr.locals -> + | -2 when array_for_all2 ~n:curr_size Attribute.equal_verification_type_info prev.locals curr.locals -> hunk ./src/analysis/stackState.ml 1456 - | -1 when array_for_all2 ~n:curr_size eq_type_info prev.locals curr.locals -> + | -1 when array_for_all2 ~n:curr_size Attribute.equal_verification_type_info prev.locals curr.locals -> hunk ./src/analysis/stackState.ml 1458 - | 1 when array_for_all2 ~n:prev_size eq_type_info prev.locals curr.locals -> + | 1 when array_for_all2 ~n:prev_size Attribute.equal_verification_type_info prev.locals curr.locals -> hunk ./src/analysis/stackState.ml 1460 - | 2 when array_for_all2 ~n:prev_size eq_type_info prev.locals curr.locals -> + | 2 when array_for_all2 ~n:prev_size Attribute.equal_verification_type_info prev.locals curr.locals -> hunk ./src/analysis/stackState.ml 1464 - | 3 when array_for_all2 ~n:prev_size eq_type_info prev.locals curr.locals -> + | 3 when array_for_all2 ~n:prev_size Attribute.equal_verification_type_info prev.locals curr.locals -> hunk ./src/analysis/stackState.ml 1472 -*)ignore prev; hunk ./src/analysis/stackState.ml 1483 - fail Different_frames) + fail (Different_frames ofs)) hunk ./src/analysis/stackState.mli 20 -(** This module provides definition and utility functions for stack state manipulation. *) +(** Definition and utility functions for stack state manipulation. *) hunk ./src/analysis/stackState.mli 26 -(** The type of locals: integer-index type information. *) +(** The type of locals: integer-index type information. + Elements are of [Attribute.verification_type_info] type. *) hunk ./src/analysis/stackState.mli 30 -(** The type of {i operand} stacks. *) +(** The type of {i operand} stacks. + Elements are of [Attribute.verification_type_info] type. *) hunk ./src/analysis/stackState.mli 34 - locals : locals; - stack : stack; + locals : locals; (** type information for the locals. *) + stack : stack; (** type information for the {i operand} stack. *) hunk ./src/analysis/stackState.mli 37 -(** The type of stack states, composed of two essential components: - - type information for the locals; - - type information for the {i operand} stack. *) +(** The type of stack states. *) hunk ./src/analysis/stackState.mli 45 - | Invalid_local_index + | Invalid_local_index of Utils.u2 * int hunk ./src/analysis/stackState.mli 52 - | Different_stack_sizes + | Different_stack_sizes of int * int hunk ./src/analysis/stackState.mli 55 - | Different_frames + | Different_frames of Utils.u2 hunk ./src/analysis/stackState.mli 70 -(** [make_of_parameters cn p] returns the state describing the stack at the - beginning of a method. [cn] is the enclosing class for the method if it - an instance method (the boolean indicating whether the method is a - constructor), [None] being used for static methods. [p] is the list - of parameters of the method. *) +(** [make_of_parameters cn p] returns the state describing the stack at + the beginning of a method. [cn] is the enclosing class for the method + if it is an instance method (the boolean indicating whether the + method is a constructor), [None] being used for static methods. [p] + is the list of parameters of the method. *) hunk ./src/analysis/stackState.mli 77 -(** [make_of_method cn m] returns the state describing the stack at the beginning - for the method [m] in the class [cn]. *) +(** [make_of_method cn m] returns the state describing the stack at the + beginning for the method [m] in the class [cn]. *) hunk ./src/analysis/stackState.mli 90 -(** Returns [true] iff the passed states are equal. *) +(** Equality over stack states. *) hunk ./src/analysis/stackState.mli 93 -(** [push v s] returns a stack similar to [s] with [v] pushed on its top. *) +(** [push v s] returns a stack similar to [s] with [v] pushed on its + top. *) hunk ./src/analysis/stackState.mli 109 -val pop_if_cat1 : stack -> Attribute.verification_type_info * stack -(** [pop_if_cat1 s] returns a couple with the top element, and [s] without - its top element. Raises [Exception] if [s] is empty, or if its top - element is not a {i category 1} element. *) +val pop_if_category1 : stack -> Attribute.verification_type_info * stack +(** [pop_if_category1 s] returns a couple with the top element, and [s] + without its top element. Raises [Exception] if [s] is empty, or if + its top element is not a {i category 1} element. *) hunk ./src/analysis/stackState.mli 131 - [i]th element is equal to [v]. The size of [l] is augmented as necessary. *) + [i]th element is equal to [v]. The size of [l] is augmented as + necessary. *) hunk ./src/analysis/stackState.mli 141 - instruction, or if the instruction is unsupported ({i jsr}, {i jsr_w}, - {i ret}, or {i wide ret}). *) + instruction, or if the instruction is unsupported ({i jsr}, + {i jsr_w}, {i ret}, or {i wide ret}). *) hunk ./src/analysis/stackState.mli 145 -(** The type of unifier, that is functions that return an element that - generalizes the passed elements. *) +(** The type of unifiers, that is functions that return an element that + generalizes the passed ones. *) hunk ./src/analysis/stackState.mli 148 -val make_array_unifier : Name.for_class unifier -> Descriptor.array_type -> Descriptor.array_type -> [ `Array_type of Descriptor.array_type | `Class_or_interface of Name.for_class ] -(** Builds an array unifier from a class unifier that is used to unify array elements. *) +type instance = + [ `Array_type of Descriptor.array_type + | `Class_or_interface of Name.for_class ] +(** Type abbreviation, used to represent any Java instance. *) hunk ./src/analysis/stackState.mli 153 -val make_unifier : Name.for_class unifier -> [ `Array_type of Descriptor.array_type | `Class_or_interface of Name.for_class ] unifier +val make_array_unifier : Name.for_class unifier -> Descriptor.array_type -> Descriptor.array_type -> instance +(** Builds an array unifier from a class unifier that is used to unify + array elements. *) + +val make_unifier : Name.for_class unifier -> instance unifier hunk ./src/analysis/stackState.mli 160 -val unify_to_java_lang_Object : [ `Array_type of Descriptor.array_type | `Class_or_interface of Name.for_class ] unifier -(** A unifier that returns {i java.lang.Object} when passed classes are different. *) +val unify_to_java_lang_Object : instance unifier +(** A unifier that returns {i java.lang.Object} when passed classes are + different. *) hunk ./src/analysis/stackState.mli 164 -val unify_to_closest_common_parent : ClassLoader.t -> (Name.for_class * Name.for_class option) list -> [ `Array_type of Descriptor.array_type | `Class_or_interface of Name.for_class ] unifier -(** A unifier that returns the closest common parent of the passed classes. - The class loader is used to load the parents of the passed classes. - The passed list is a (class, parent) association list overriding the class loader. *) +val unify_to_closest_common_parent : ClassLoader.t -> (Name.for_class * Name.for_class option) list -> instance unifier +(** A unifier that returns the closest common parent of the passed + classes. The class loader is used to load the parents of the passed + classes. The passed list is a (class, parent) association list + overriding the class loader. *) hunk ./src/analysis/stackState.mli 170 -val unify_to_parent_list : (Name.for_class * Name.for_class option) list -> [ `Array_type of Descriptor.array_type | `Class_or_interface of Name.for_class ] unifier -(** A unifier that returns the closest common parent of the passed classes, - using the passed list as a (class, parent) association list. *) +val unify_to_parent_list : (Name.for_class * Name.for_class option) list -> instance unifier +(** A unifier that returns the closest common parent of the passed + classes, using the passed list as a (class, parent) association + list. *) hunk ./src/analysis/stackState.mli 175 -val unify : [ `Array_type of Descriptor.array_type | `Class_or_interface of Name.for_class ] unifier -> t -> t -> t -(** [unify st1 st2] returns a state that generalizes [st1] and [st2]. *) +val unify : instance unifier -> t -> t -> t +(** [unify u st1 st2] returns a state that generalizes [st1] and [st2]. *) hunk ./src/analysis/stackState.mli 178 -val encode : (Utils.u2 * t) list -> Attribute.stack_map_frame list -(** Encodes the passed list of (offset, state) couples into attribute values. - Raises [Exception] if the passed list is empty, or contains different frames at the same offset. *) +val encode : ?optimize : bool -> (Utils.u2 * t) list -> Attribute.stack_map_frame list +(** Encodes the passed list of (offset, state) couples into attribute + values. + Raises [Exception] if the passed list is empty, or contains different + frames at the same offset. *) hunk ./src/analysis/traversal.ml 25 - method class_field : AccessFlag.for_field list -> Name.for_field -> Descriptor.for_field -> Attribute.for_field list -> Field.t + method class_field : Field.t -> Field.t hunk ./src/analysis/traversal.ml 28 - method field_flags : AccessFlag.for_field list -> AccessFlag.for_field list - method field_name : Name.for_field -> Name.for_field - method field_descriptor : Descriptor.for_field -> Descriptor.for_field - method field_attribute : Attribute.for_field -> Attribute.for_field - method regular_method : AccessFlag.for_method list -> Name.for_method -> Descriptor.for_method -> Attribute.for_method list -> (AccessFlag.for_method list * Name.for_method * Descriptor.for_method * Attribute.for_method list) - method regular_method_flags : AccessFlag.for_method list -> AccessFlag.for_method list - method regular_method_name : Name.for_method -> Name.for_method - method regular_method_descriptor : Descriptor.for_method -> Descriptor.for_method - method regular_method_attribute : Attribute.for_method -> Attribute.for_method - method constructor_method : AccessFlag.for_constructor list -> Descriptor.for_parameter list -> Attribute.for_method list -> (AccessFlag.for_constructor list * Descriptor.for_parameter list * Attribute.for_method list) - method constructor_method_flags : AccessFlag.for_constructor list -> AccessFlag.for_constructor list - method constructor_method_descriptor : Descriptor.for_parameter list -> Descriptor.for_parameter list - method constructor_method_attribute : Attribute.for_method -> Attribute.for_method - method initializer_method : bool -> Attribute.for_method list -> (bool * Attribute.for_method list) - method initializer_method_strictfp : bool -> bool - method initializer_method_attribute : Attribute.for_method -> Attribute.for_method + method regular_method : Method.regular -> Method.regular + method constructor_method : Method.constructor -> Method.constructor + method initializer_method : Method.class_initializer -> Method.class_initializer hunk ./src/analysis/traversal.ml 33 -let copy_code_value cv = - let copy = function - | `Unknown (x, y) -> `Unknown (x, String.copy y) - | x -> x in - { cv with Attribute.attributes = List.map copy cv.Attribute.attributes } - hunk ./src/analysis/traversal.ml 39 - let fields' = List.map (fun (x, y, z, t) -> self#class_field x y z t) fields in + let fields' = List.map self#class_field fields in hunk ./src/analysis/traversal.ml 52 - method class_field flags name descriptor attributes = - let flags' = self#field_flags flags in - let name' = self#field_name name in - let descriptor' = self#field_descriptor descriptor in - let attributes' = List.map self#field_attribute attributes in - (flags', name', descriptor', attributes') + method class_field x = x hunk ./src/analysis/traversal.ml 55 - | Method.Regular (flags, name, descriptor, attributes) -> - let x, y, z, t = self#regular_method flags name descriptor attributes in - Method.Regular (x, y, z, t) - | Method.Constructor (flags, descriptor, attributes) -> - let x, y, z = self#constructor_method flags descriptor attributes in - Method.Constructor (x, y, z) - | Method.Initializer (strictfp, attributes) -> - let x, y = self#initializer_method strictfp attributes in - Method.Initializer (x, y) - - method class_attribute = function - | `Unknown (x, y) -> `Unknown (x, String.copy y) - | x -> x - - method field_flags x = x - - method field_name x = x - - method field_descriptor x = x - - method field_attribute = function - | `Unknown (x, y) -> `Unknown (x, String.copy y) - | x -> x - - method regular_method flags name descriptor attributes = - let flags' = self#regular_method_flags flags in - let name' = self#regular_method_name name in - let descriptor' = self#regular_method_descriptor descriptor in - let attributes' = List.map self#regular_method_attribute attributes in - (flags', name', descriptor', attributes') - - method regular_method_flags x = x - - method regular_method_name x = x - - method regular_method_descriptor x = x - - method regular_method_attribute = function - | `Code cv -> `Code (copy_code_value cv) - | `Unknown (x, y) -> `Unknown (x, String.copy y) - | x -> x - - method constructor_method flags descriptor attributes = - let flags' = self#constructor_method_flags flags in - let descriptor' = self#constructor_method_descriptor descriptor in - let attributes' = List.map self#constructor_method_attribute attributes in - (flags', descriptor', attributes') - - method constructor_method_flags x = x + | Method.Regular mr -> Method.Regular (self#regular_method mr) + | Method.Constructor mc -> Method.Constructor (self#constructor_method mc) + | Method.Initializer mi -> Method.Initializer (self#initializer_method mi) hunk ./src/analysis/traversal.ml 59 - method constructor_method_descriptor x = x + method class_attribute x = x hunk ./src/analysis/traversal.ml 61 - method constructor_method_attribute = function - | `Code cv -> `Code (copy_code_value cv) - | `Unknown (x, y) -> `Unknown (x, String.copy y) - | x -> x + method regular_method x = x hunk ./src/analysis/traversal.ml 63 - method initializer_method strictfp attributes = - let strictfp' = self#initializer_method_strictfp strictfp in - let attributes' = List.map self#initializer_method_attribute attributes in - (strictfp', attributes') + method constructor_method x = x hunk ./src/analysis/traversal.ml 65 - method initializer_method_strictfp x = x + method initializer_method x = x hunk ./src/analysis/traversal.ml 67 - method initializer_method_attribute = function - | `Code cv -> `Code (copy_code_value cv) - | `Unknown (x, y) -> `Unknown (x, String.copy y) - | x -> x hunk ./src/analysis/traversal.ml 75 - method class_field : AccessFlag.for_field list -> Name.for_field -> Descriptor.for_field -> Attribute.for_field list -> unit + method class_field : Field.t -> unit hunk ./src/analysis/traversal.ml 78 - method field_flags : AccessFlag.for_field list -> unit - method field_name : Name.for_field -> unit - method field_descriptor : Descriptor.for_field -> unit - method field_attribute : Attribute.for_field -> unit - method regular_method : AccessFlag.for_method list -> Name.for_method -> Descriptor.for_method -> Attribute.for_method list -> unit - method regular_method_flags : AccessFlag.for_method list -> unit - method regular_method_name : Name.for_method -> unit - method regular_method_descriptor : Descriptor.for_method -> unit - method regular_method_attribute : Attribute.for_method -> unit - method constructor_method : AccessFlag.for_constructor list -> Descriptor.for_parameter list -> Attribute.for_method list -> unit - method constructor_method_flags : AccessFlag.for_constructor list -> unit - method constructor_method_descriptor : Descriptor.for_parameter list -> unit - method constructor_method_attribute : Attribute.for_method -> unit - method initializer_method : bool -> Attribute.for_method list -> unit - method initializer_method_strictfp : bool -> unit - method initializer_method_attribute : Attribute.for_method -> unit + method regular_method : Method.regular -> unit + method constructor_method : Method.constructor -> unit + method initializer_method : Method.class_initializer -> unit hunk ./src/analysis/traversal.ml 89 - List.iter (fun (x, y, z, t) -> self#class_field x y z t) fields; + List.iter self#class_field fields; hunk ./src/analysis/traversal.ml 101 - method class_field flags name descriptor attributes = - self#field_flags flags; - self#field_name name; - self#field_descriptor descriptor; - List.iter self#field_attribute attributes + method class_field _ = () hunk ./src/analysis/traversal.ml 104 - | Method.Regular (flags, name, descriptor, attributes) -> - self#regular_method flags name descriptor attributes - | Method.Constructor (flags, descriptor, attributes) -> - self#constructor_method flags descriptor attributes - | Method.Initializer (strictfp, attributes) -> - self#initializer_method strictfp attributes + | Method.Regular x -> self#regular_method x + | Method.Constructor x -> self#constructor_method x + | Method.Initializer x -> self#initializer_method x hunk ./src/analysis/traversal.ml 110 - method field_flags _ = () - - method field_name _ = () - - method field_descriptor _ = () - - method field_attribute _ = () - - method regular_method flags name descriptor attributes = - self#regular_method_flags flags; - self#regular_method_name name; - self#regular_method_descriptor descriptor; - List.iter self#regular_method_attribute attributes - - method regular_method_flags _ = () - - method regular_method_name _ = () - - method regular_method_descriptor _ = () - - method regular_method_attribute _ = () - - method constructor_method flags descriptor attributes = - self#constructor_method_flags flags; - self#constructor_method_descriptor descriptor; - List.iter self#constructor_method_attribute attributes - - method constructor_method_flags _ = () - - method constructor_method_descriptor _ = () - - method constructor_method_attribute _ = () + method regular_method _ = () hunk ./src/analysis/traversal.ml 112 - method initializer_method strictfp attributes = - self#initializer_method_strictfp strictfp; - List.iter self#initializer_method_attribute attributes + method constructor_method _ = () hunk ./src/analysis/traversal.ml 114 - method initializer_method_strictfp _ = () + method initializer_method _ = () hunk ./src/analysis/traversal.ml 116 - method initializer_method_attribute _ = () hunk ./src/analysis/traversal.mli 19 -(** This module provides class types and default implementations for - "mapper" and "iterator" over class definition. +(** Class types and default implementations for "mapper" and "iterator" + over class definitions. hunk ./src/analysis/traversal.mli 22 - of "mappper" and "iterator". *) + of "mapppers" and "iterators". *) hunk ./src/analysis/traversal.mli 30 - method class_field : AccessFlag.for_field list -> Name.for_field -> Descriptor.for_field -> Attribute.for_field list -> Field.t + method class_field : Field.t -> Field.t hunk ./src/analysis/traversal.mli 33 - method field_flags : AccessFlag.for_field list -> AccessFlag.for_field list - method field_name : Name.for_field -> Name.for_field - method field_descriptor : Descriptor.for_field -> Descriptor.for_field - method field_attribute : Attribute.for_field -> Attribute.for_field - method regular_method : AccessFlag.for_method list -> Name.for_method -> Descriptor.for_method -> Attribute.for_method list -> (AccessFlag.for_method list * Name.for_method * Descriptor.for_method * Attribute.for_method list) - method regular_method_flags : AccessFlag.for_method list -> AccessFlag.for_method list - method regular_method_name : Name.for_method -> Name.for_method - method regular_method_descriptor : Descriptor.for_method -> Descriptor.for_method - method regular_method_attribute : Attribute.for_method -> Attribute.for_method - method constructor_method : AccessFlag.for_constructor list -> Descriptor.for_parameter list -> Attribute.for_method list -> (AccessFlag.for_constructor list * Descriptor.for_parameter list * Attribute.for_method list) - method constructor_method_flags : AccessFlag.for_constructor list -> AccessFlag.for_constructor list - method constructor_method_descriptor : Descriptor.for_parameter list -> Descriptor.for_parameter list - method constructor_method_attribute : Attribute.for_method -> Attribute.for_method - method initializer_method : bool -> Attribute.for_method list -> (bool * Attribute.for_method list) - method initializer_method_strictfp : bool -> bool - method initializer_method_attribute : Attribute.for_method -> Attribute.for_method + method regular_method : Method.regular -> Method.regular + method constructor_method : Method.constructor -> Method.constructor + method initializer_method : Method.class_initializer -> Method.class_initializer hunk ./src/analysis/traversal.mli 37 -(** This class type defines a "mapper", instances being used as "functions" to - transform class definitions. The "function" is defined by parts through the - various methods of the object. Any method is responsible for the calling of - its embedded elements; this means that the method [class_definition] should - call methods to map fields, attributes, etc. *) +(** This class type defines a "mapper", instances being used as + "functions" to transform class definitions. The "function" is defined + {i by parts} through the various methods of the object. Any method is + responsible for the calling of its embedded elements; this means that + the method [class_definition] should call methods to map fields, + attributes, etc. *) hunk ./src/analysis/traversal.mli 45 -(** The default "mapper", that encodes the identity over class definitions. - When inheriting from this class, one should not forget to call the parent - methods in order to ensure that the whole structure is mapped. *) +(** The default "mapper", that encodes the identity over class + definitions. When inheriting from this class, one should not forget + to call the parent methods in order to ensure that the whole + structure is mapped. *) hunk ./src/analysis/traversal.mli 56 - method class_field : AccessFlag.for_field list -> Name.for_field -> Descriptor.for_field -> Attribute.for_field list -> unit + method class_field : Field.t -> unit hunk ./src/analysis/traversal.mli 59 - method field_flags : AccessFlag.for_field list -> unit - method field_name : Name.for_field -> unit - method field_descriptor : Descriptor.for_field -> unit - method field_attribute : Attribute.for_field -> unit - method regular_method : AccessFlag.for_method list -> Name.for_method -> Descriptor.for_method -> Attribute.for_method list -> unit - method regular_method_flags : AccessFlag.for_method list -> unit - method regular_method_name : Name.for_method -> unit - method regular_method_descriptor : Descriptor.for_method -> unit - method regular_method_attribute : Attribute.for_method -> unit - method constructor_method : AccessFlag.for_constructor list -> Descriptor.for_parameter list -> Attribute.for_method list -> unit - method constructor_method_flags : AccessFlag.for_constructor list -> unit - method constructor_method_descriptor : Descriptor.for_parameter list -> unit - method constructor_method_attribute : Attribute.for_method -> unit - method initializer_method : bool -> Attribute.for_method list -> unit - method initializer_method_strictfp : bool -> unit - method initializer_method_attribute : Attribute.for_method -> unit + method regular_method : Method.regular -> unit + method constructor_method : Method.constructor -> unit + method initializer_method : Method.class_initializer -> unit hunk ./src/analysis/traversal.mli 63 -(** This class type defines an "iterator", instances being used as "functions" to - iterate over the different components of a class definitions. The "function" - is defined by parts through the various methods of the object. Any method is - responsible for the calling of its embedded elements; this means that the - method [class_definition] should call methods to map fields, attributes, etc. *) +(** This class type defines an "iterator", instances being used as + "functions" to iterate over the different components of a class + definitions. The "function" is defined by parts through the various + methods of the object. Any method is responsible for the calling of + its embedded elements; this means that the method [class_definition] + should call methods to map fields, attributes, etc. *) hunk ./src/analysis/traversal.mli 71 -(** The default "iterator", that iterates over the whole structure by doing - nothing. When inheriting from this class, one should not forget to call - the parent methods in order to ensure that the whole structure is traversed. *) +(** The default "iterator", that iterates over the whole structure by + doing nothing. When inheriting from this class, one should not forget + to call the parent methods in order to ensure that the whole + structure is traversed. *) hunk ./src/classfile/accessFlag.ml 21 +open Consts hunk ./src/classfile/accessFlag.ml 46 +let to_string = function + | `Public -> "public" + | `Private -> "private" + | `Protected -> "protected" + | `Static -> "static" + | `Final -> "final" + | `Super -> "super" + | `Synchronized -> "synchronized" + | `Bridge -> "bridge" + | `Volatile -> "volatile" + | `Transient -> "transient" + | `Varargs -> "varargs" + | `Native -> "native" + | `Interface -> "interface" + | `Abstract -> "abstract" + | `Strict -> "strict" + | `Synthetic -> "synthetic" + | `Annotation -> "annotation" + | `Enum -> "enum" + | `Module -> "module" + hunk ./src/classfile/accessFlag.ml 128 +type for_initializer = + [ `Static + | `Strict ] + hunk ./src/classfile/accessFlag.ml 146 - | Invalid_class_flags - | Invalid_inner_class_flags - | Invalid_field_flags - | Invalid_method_flags - | Invalid_constructor_flags - | Invalid_package_flags - | Invalid_module_flags + | Invalid_class_flags of t option + | Invalid_inner_class_flags of t option + | Invalid_field_flags of t option + | Invalid_method_flags of t option + | Invalid_constructor_flags of t option + | Invalid_initializer_flags of t option + | Invalid_package_flags of t option + | Invalid_module_flags of t option + | Several_visibility_flags + | Unknown_flag of string hunk ./src/classfile/accessFlag.ml 161 -let string_of_error = function - | Invalid_class_flags -> "invalid flags for class" - | Invalid_inner_class_flags -> "invalid flags for inner class" - | Invalid_field_flags -> "invalid flags for field" - | Invalid_method_flags -> "invalid flags for method" - | Invalid_constructor_flags -> "invalid flags for constructor" - | Invalid_package_flags -> "invalid flags for package" - | Invalid_module_flags -> "invalid flags for module" +let string_of_error e = + let soe kind = function + | Some x -> + Printf.sprintf "invalid flags for %s (%S)" kind (to_string x) + | None -> + Printf.sprintf "invalid flags for %s (invalid list)" kind in + match e with + | Invalid_class_flags f -> soe "class" f + | Invalid_inner_class_flags f -> soe "inner class" f + | Invalid_field_flags f -> soe "field" f + | Invalid_method_flags f -> soe "method" f + | Invalid_constructor_flags f -> soe "constructor" f + | Invalid_initializer_flags f -> soe "initializer" f + | Invalid_package_flags f -> soe "package" f + | Invalid_module_flags f -> soe "module" f + | Several_visibility_flags -> "several visibility flags" + | Unknown_flag f -> Printf.sprintf "unknown flag %S" f hunk ./src/classfile/accessFlag.ml 251 - let res = ref 0 in - let rec iter = function - | hd :: tl -> res := !res + (to_int hd); iter tl - | [] -> () in - iter l; - u2 !res + let res = + List.fold_left + (fun acc elem -> + acc + (to_int elem)) + 0 + l in + u2 res hunk ./src/classfile/accessFlag.ml 266 -let check_visibility is_class fl = - let incr_if x = if !x = 0 then incr x in - let pub = ref 0 in - let pro = ref 0 in - let pri = ref 0 in - let mdl = ref 0 in - let iter = function - | `Public -> incr_if pub - | `Protected -> incr_if pro - | `Private -> incr_if pri - | `Module -> incr_if mdl - | _ -> () in - List.iter iter fl; - let at_most_one = (!pub + !pro + !pri + !mdl) <= 1 in - if is_class then - at_most_one && !pro = 0 && !pri = 0 +let of_string = function + | "public" -> `Public + | "private" -> `Private + | "protected" -> `Protected + | "static" -> `Static + | "final" -> `Final + | "super" -> `Super + | "synchonized" -> `Synchronized + | "bridge" -> `Bridge + | "volatile" -> `Volatile + | "transient" -> `Transient + | "varargs" -> `Varargs + | "native" -> `Native + | "interface" -> `Interface + | "abstract" -> `Abstract + | "strictfp" -> `Strict + | "synthetic" -> `Synthetic + | "annotation" -> `Annotation + | "enum" -> `Enum + | "module" -> `Module + | f -> fail (Unknown_flag f) + +let to_utf8 f = + UTF8.of_string (to_string f) + +let of_utf8 f = + of_string (UTF8.to_string_noerr f) + +let check_visibility is_non_inner_class fl = + let succ_if_zero x = if x = 0 then succ x else x in + let pub, pro, pri, mdl = + List.fold_left + (fun ((pub, pro, pri, mdl) as acc) flag -> + match flag with + | `Public -> (succ_if_zero pub, pro, pri, mdl) + | `Protected -> (pub, succ_if_zero pro, pri, mdl) + | `Private -> (pub, pro, succ_if_zero pri, mdl) + | `Module -> (pub, pro, pri, succ_if_zero mdl) + | _ -> acc) + (0, 0, 0, 0) + fl in + let at_most_one = (pub + pro + pri + mdl) <= 1 in + if is_non_inner_class then + (if not (at_most_one && pro = 0 && pri = 0) then fail Several_visibility_flags) hunk ./src/classfile/accessFlag.ml 311 - at_most_one + (if not at_most_one then fail Several_visibility_flags) hunk ./src/classfile/accessFlag.ml 322 - if (check_visibility true fl) - && (`Interface ==> `Abstract) + check_visibility true fl; + if (`Interface ==> `Abstract) hunk ./src/classfile/accessFlag.ml 329 - && (`Abstract =/> `Final) - then List.map (function #for_class as x -> x | _ -> fail Invalid_class_flags) fl - else fail Invalid_class_flags + && (`Abstract =/> `Final) then + List.map + (function + | #for_class as x -> x + | y -> fail (Invalid_class_flags (Some y))) + fl + else + fail (Invalid_class_flags None) hunk ./src/classfile/accessFlag.ml 341 - if (check_visibility false fl) - && (`Interface ==> `Abstract) + check_visibility false fl; + if (`Interface ==> `Abstract) hunk ./src/classfile/accessFlag.ml 348 - && (`Abstract =/> `Final) - then List.map (function #for_inner_class as x -> x | _ -> fail Invalid_inner_class_flags) fl - else fail Invalid_inner_class_flags + && (`Abstract =/> `Final) then + List.map + (function + | #for_inner_class as x -> x + | y -> fail (Invalid_inner_class_flags (Some y))) + fl + else + fail (Invalid_inner_class_flags None) hunk ./src/classfile/accessFlag.ml 359 - if (check_visibility false fl) - && (`Final =/> `Volatile) + check_visibility false fl; + if (`Final =/> `Volatile) hunk ./src/classfile/accessFlag.ml 370 - `Synthetic]) fl))) - then List.map (function #for_field as x -> x | _ -> fail Invalid_field_flags) fl - else fail Invalid_field_flags + `Synthetic]) fl))) then + List.map + (function + | #for_field as x -> x + | y -> fail (Invalid_field_flags (Some y))) + fl + else + fail (Invalid_field_flags None) hunk ./src/classfile/accessFlag.ml 381 - if (check_visibility false fl) - && ((not interface) + check_visibility false fl; + if ((not interface) hunk ./src/classfile/accessFlag.ml 397 - && (`Abstract =/> `Synchronized))) - then List.map (function #for_method as x -> x | _ -> fail Invalid_method_flags) fl - else fail Invalid_method_flags + && (`Abstract =/> `Synchronized))) then + List.map + (function + | #for_method as x -> x + | y -> fail (Invalid_method_flags (Some y))) + fl + else + fail (Invalid_method_flags None) hunk ./src/classfile/accessFlag.ml 407 - if (check_visibility false fl) - then List.map (function #for_constructor as x -> x | _ -> fail Invalid_constructor_flags) fl - else fail Invalid_constructor_flags + check_visibility false fl; + List.map + (function + | #for_constructor as x -> x + | y -> fail (Invalid_constructor_flags (Some y))) + fl + +let check_initializer_flags fl = + List.map + (function + | #for_initializer as x -> x + | y -> fail (Invalid_initializer_flags (Some y))) + fl hunk ./src/classfile/accessFlag.ml 422 - List.map (function #for_package as x -> x | _ -> fail Invalid_package_flags) fl + List.map + (function + | #for_package as x -> x + | y -> fail (Invalid_package_flags (Some y))) + fl hunk ./src/classfile/accessFlag.ml 429 - List.map (function #for_module as x -> x | _ -> fail Invalid_module_flags) fl + List.map + (function + | #for_module as x -> x + | y -> fail (Invalid_module_flags (Some y))) + fl + +let compare x y = + let rank = function + | `Public + | `Private + | `Protected + | `Module -> 1 + | `Static -> 2 + | `Final -> 3 + | `Synchronized -> 4 + | `Volatile -> 4 + | `Transient -> 4 + | `Native -> 4 + | `Abstract -> 2 + | `Strict -> 4 + | `Super + | `Bridge + | `Varargs + | `Interface + | `Synthetic + | `Annotation + | `Enum -> 5 in + let cmp = compare (rank x) (rank y) in + if cmp = 0 then compare x y else cmp + +let list_compare l1 l2 = + let s1 = List.mem `Static l1 in + let s2 = List.mem `Static l2 in + let pub1 = List.mem `Public l1 in + let pub2 = List.mem `Public l2 in + let pro1 = List.mem `Protected l1 in + let pro2 = List.mem `Protected l2 in + let pri1 = List.mem `Private l1 in + let pri2 = List.mem `Private l2 in + Pervasives.compare (pub2, pro2, pri2, s2, l2) (pub1, pro1, pri1, s1, l1) hunk ./src/classfile/accessFlag.ml 508 - Version.make_bounds "module flag" Version.Java_1_7 None + Version.make_bounds "'module' flag" Version.Java_1_8 None + +let list_to_utf8 = function + | (_ :: _) as l -> + let space = UTF8.of_char ' ' in + (UTF8.concat_sep + space + (List.map to_utf8 (List.sort compare l))) + ++ space + | [] -> empty_utf8 hunk ./src/classfile/accessFlag.mli 19 -(** This module defines access flags for various Java elements. *) +(** Access flags for the various Java elements. *) hunk ./src/classfile/accessFlag.mli 112 +type for_initializer = + [ `Static + | `Strict ] +(** Possible flags for an initializer. *) + hunk ./src/classfile/accessFlag.mli 133 - | Invalid_class_flags - | Invalid_inner_class_flags - | Invalid_field_flags - | Invalid_method_flags - | Invalid_constructor_flags - | Invalid_package_flags - | Invalid_module_flags + | Invalid_class_flags of t option + | Invalid_inner_class_flags of t option + | Invalid_field_flags of t option + | Invalid_method_flags of t option + | Invalid_constructor_flags of t option + | Invalid_initializer_flags of t option + | Invalid_package_flags of t option + | Invalid_module_flags of t option + | Several_visibility_flags + | Unknown_flag of string hunk ./src/classfile/accessFlag.mli 145 -(** Exception to be raised if a flag is incorrect. *) +(** Exception to be raised when a function of this module fails. *) hunk ./src/classfile/accessFlag.mli 162 -(** [from_u2 meth mask] converts mask into flag list, [meth] indicating whether - the considered Java element is a method (including constructors). *) +(** [from_u2 meth mask] converts mask into flag list, [meth] indicating + whether the considered Java element is a method (including + constructors). *) + +val to_string : t -> string +(** Converts the passed flag into a string. *) + +val of_string : string -> t +(** Converts the passed string into a flag. + Raises [Exception] if the passed string is not a valid flag. *) + +val to_utf8 : t -> Utils.UTF8.t +(** Converts the passed flag into a UTF8 string. *) + +val of_utf8 : Utils.UTF8.t -> t +(** Converts the passed UTF8 string into a flag. + Raises [Exception] if the passed string is not a valid flag. *) + +val list_to_utf8 : t list -> Utils.UTF8.t +(** Converts the passed flag list to its corresponding UTF8 string. + Flags are separated by a single space, and a single space is also + added at the end of the returned string. *) hunk ./src/classfile/accessFlag.mli 186 -(** Acts as the identity function if the passed flags form a valid flag set - for a class, raises [Exception] otherwise. *) +(** Acts as the identity function if the passed flags form a valid flag + set for a class, raises [Exception] otherwise. *) hunk ./src/classfile/accessFlag.mli 190 -(** Acts as the identity function if the passed flags form a valid flag set - for an inner class, raises [Exception] otherwise. *) +(** Acts as the identity function if the passed flags form a valid flag + set for an inner class, raises [Exception] otherwise. *) hunk ./src/classfile/accessFlag.mli 194 -(** Acts as the identity function if the passed flags form a valid flag set - for a field, raises [Exception] otherwise. - The passed boolean indicates whether the checked field belongs to an - interface. *) +(** Acts as the identity function if the passed flags form a valid flag + set for a field, raises [Exception] otherwise. + The passed boolean indicates whether the checked field belongs to an + interface. *) hunk ./src/classfile/accessFlag.mli 200 -(** Acts as the identity function if the passed flags form a valid flag set - for a method, raises [Exception] otherwise. - The passed boolean indicates whether the checked method belongs to an - interface. *) +(** Acts as the identity function if the passed flags form a valid flag + set for a method, raises [Exception] otherwise. + The passed boolean indicates whether the checked method belongs to + an interface. *) hunk ./src/classfile/accessFlag.mli 206 -(** Acts as the identity function if the passed flags form a valid flag set - for a constructor, raises [Exception] otherwise. *) +(** Acts as the identity function if the passed flags form a valid flag + set for a constructor, raises [Exception] otherwise. *) + +val check_initializer_flags : t list -> for_initializer list +(** Acts as the identity function if the passed flags form a valid flag + set for an initializer, raises [Exception] otherwise. *) hunk ./src/classfile/accessFlag.mli 214 -(** Acts as the identity function if the passed flags form a valid flag set - for a package, raises [Exception] otherwise. *) +(** Acts as the identity function if the passed flags form a valid flag + set for a package, raises [Exception] otherwise. *) hunk ./src/classfile/accessFlag.mli 218 -(** Acts as the identity function if the passed flags form a valid flag set - for a module, raises [Exception] otherwise. *) +(** Acts as the identity function if the passed flags form a valid flag + set for a module, raises [Exception] otherwise. *) + +val compare : t -> t -> int +(** Comparison over flags. + The order is the one defined by {i java.lang.reflect.Modifier}. *) + +val list_compare : t list -> t list -> int +(** Comparison over flag list. *) hunk ./src/classfile/annotation.ml 63 +type primitive_type = + [ `Boolean + | `Byte + | `Char + | `Double + | `Float + | `Int + | `Long + | `Short] + hunk ./src/classfile/annotation.ml 74 - | Primitive of [ `Boolean | `Byte | `Char | `Double | `Float | `Int | `Long | `Short] * u2 + | Primitive of primitive_type * u2 hunk ./src/classfile/annotation.ml 96 - | Invalid_tag + | Invalid_tag of UChar.t hunk ./src/classfile/annotation.ml 98 - | Invalid_string_value - | Invalid_enum_value - | Invalid_class_value - | Invalid_annotation_type_value - | Invalid_element_name - | Invalid_list_length - | Invalid_target + | Invalid_string_value of u2 + | Invalid_enum_value of u2 * u2 + | Invalid_class_value of u2 + | Invalid_annotation_type_value of u2 + | Invalid_element_name of u2 + | Invalid_list_length of int + | Invalid_target of int hunk ./src/classfile/annotation.ml 111 - | Invalid_tag -> "invalid tag" - | Inconsistent_primitive_value -> "inconsistent primitive value" - | Invalid_string_value -> "invalid string value" - | Invalid_enum_value -> "invalid enum value" - | Invalid_class_value -> "invalid class value" - | Invalid_annotation_type_value -> "invalid annotation type value" - | Invalid_element_name -> "invalid element name" - | Invalid_list_length -> "invalid list length" - | Invalid_target -> "invalid target" + | Invalid_tag x -> + Printf.sprintf "invalid tag (%C)" (UChar.to_char_noerr x) + | Inconsistent_primitive_value -> + "inconsistent primitive value" + | Invalid_string_value x -> + Printf.sprintf "invalid string value (index %d)" (x :> int) + | Invalid_enum_value (x, y) -> + Printf.sprintf "invalid enum value (indexes %d and %d)" (x :> int) (y :> int) + | Invalid_class_value x -> + Printf.sprintf "invalid class value (index %d)" (x :> int) + | Invalid_annotation_type_value x -> + Printf.sprintf "invalid annotation type value (index %d)" (x :> int) + | Invalid_element_name x -> + Printf.sprintf "invalid element name (index %d)" (x :> int) + | Invalid_list_length x -> + Printf.sprintf "invalid list length (%d)" x + | Invalid_target x -> + Printf.sprintf "invalid target (0x%02x)" x hunk ./src/classfile/annotation.ml 143 - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let start = InputStream.read_u2 st in - let length = InputStream.read_u2 st in - let index = InputStream.read_u2 st in - res := (start, length, index) :: !res - done; - List.rev !res in + InputStream.read_elements + st + (fun st -> + let start = InputStream.read_u2 st in + let length = InputStream.read_u2 st in + let index = InputStream.read_u2 st in + start, length, index) in hunk ./src/classfile/annotation.ml 151 - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let x = InputStream.read_u1 st in - res := x :: !res; - done; - List.rev !res in - let unsupported () = fail Invalid_target in + InputStream.read_elements + st + (fun st -> + InputStream.read_u1 st) in + let unsupported x = fail (Invalid_target x) in hunk ./src/classfile/annotation.ml 173 - | 0x07 -> unsupported () + | 0x07 -> unsupported 0x07 hunk ./src/classfile/annotation.ml 212 - | 0x17 -> unsupported () + | 0x17 -> unsupported 0x17 hunk ./src/classfile/annotation.ml 242 - | 0x21 -> unsupported () + | 0x21 -> unsupported 0x21 hunk ./src/classfile/annotation.ml 244 - | 0x23 -> unsupported () - | _ -> fail Invalid_target + | 0x23 -> unsupported 0x23 + | x -> fail (Invalid_target x) + +let checked_length l = + let res = List.length l in + if res <= max_u2 then + u2 res + else + fail (Invalid_list_length res) hunk ./src/classfile/annotation.ml 255 - let checked_length l = - let res = List.length l in - if res < 65536 then - res - else - fail Invalid_list_length in hunk ./src/classfile/annotation.ml 260 - let len = checked_length l in - OutputStream.write_u2 st (u2 len); - List.iter - (fun (x, y, z) -> + OutputStream.write_elements + checked_length + st + (fun st (x, y, z) -> hunk ./src/classfile/annotation.ml 269 - let len = checked_length l in - OutputStream.write_u2 st (u2 len); - List.iter - (fun x -> OutputStream.write_u1 st x) + OutputStream.write_elements + checked_length + st + (fun st x -> + OutputStream.write_u1 st x) hunk ./src/classfile/annotation.ml 311 - if UChar.equal tag capital_b then - let index = InputStream.read_u2 st in - Primitive (`Byte, index) - else if UChar.equal tag capital_c then - let index = InputStream.read_u2 st in - Primitive (`Char, index) - else if UChar.equal tag capital_d then - let index = InputStream.read_u2 st in - Primitive (`Double, index) - else if UChar.equal tag capital_f then - let index = InputStream.read_u2 st in - Primitive (`Float, index) - else if UChar.equal tag capital_i then - let index = InputStream.read_u2 st in - Primitive (`Int, index) - else if UChar.equal tag capital_j then - let index = InputStream.read_u2 st in - Primitive (`Long, index) - else if UChar.equal tag capital_s then + let primitive p _ = hunk ./src/classfile/annotation.ml 313 - Primitive (`Short, index) - else if UChar.equal tag capital_z then - let index = InputStream.read_u2 st in - Primitive (`Boolean, index) - else if UChar.equal tag small_s then - let index = InputStream.read_u2 st in - String index - else if UChar.equal tag small_e then - let type_name_index = InputStream.read_u2 st in - let const_name_index = InputStream.read_u2 st in - Enum (type_name_index, const_name_index) - else if UChar.equal tag small_c then - let class_info_index = InputStream.read_u2 st in - Class class_info_index - else if UChar.equal tag at_character then - let annot = read_info st in - Annotation annot - else if UChar.equal tag opening_square_bracket then - let num_values = InputStream.read_u2 st in - let values = Array.init (num_values :> int) (fun _ -> read_info_element_value st) in - Array (num_values, values) - else - fail Invalid_tag + Primitive (p, index) in + switch UChar.equal + [ capital_b, primitive `Byte; + capital_c, primitive `Char; + capital_d, primitive `Double; + capital_f, primitive `Float; + capital_i, primitive `Int; + capital_j, primitive `Long; + capital_s, primitive `Short; + capital_z, primitive `Boolean; + small_s, + (fun _ -> + let index = InputStream.read_u2 st in + String index); + small_e, + (fun _ -> + let type_name_index = InputStream.read_u2 st in + let const_name_index = InputStream.read_u2 st in + Enum (type_name_index, const_name_index)); + small_c, + (fun _ -> + let class_info_index = InputStream.read_u2 st in + Class class_info_index); + at_character, + (fun _ -> + let annot = read_info st in + Annotation annot); + opening_square_bracket, + (fun _ -> + let num_values = InputStream.read_u2 st in + let values = Array.init (num_values :> int) (fun _ -> read_info_element_value st) in + Array (num_values, values)) ] + (fun tag -> fail (Invalid_tag tag)) + tag hunk ./src/classfile/annotation.ml 410 - Array.iter (fun (idx, iev) -> - OutputStream.write_u2 st idx; - write_info_element_value st iev) + Array.iter + (fun (idx, iev) -> + OutputStream.write_u2 st idx; + write_info_element_value st iev) hunk ./src/classfile/annotation.ml 418 - Array.iter (fun (idx, iev) -> - OutputStream.write_u2 st idx; - write_info_element_value st iev) + Array.iter + (fun (idx, iev) -> + OutputStream.write_u2 st idx; + write_info_element_value st iev) hunk ./src/classfile/annotation.ml 478 - | _ -> fail Invalid_string_value) + | _ -> fail (Invalid_string_value idx)) hunk ./src/classfile/annotation.ml 486 - | _ -> fail Invalid_enum_value) - | _ -> fail Invalid_enum_value) + | _ -> fail (Invalid_enum_value (name_idx, value_idx))) + | _ -> fail (Invalid_enum_value (name_idx, value_idx))) hunk ./src/classfile/annotation.ml 491 - (match Descriptor.java_type_of_utf8 n with + (match Descriptor.java_type_of_internal_utf8 n with hunk ./src/classfile/annotation.ml 493 - | _ -> fail Invalid_class_value) - | _ -> fail Invalid_class_value) + | _ -> fail (Invalid_class_value idx)) + | _ -> fail (Invalid_class_value idx)) hunk ./src/classfile/annotation.ml 502 - (match Descriptor.java_type_of_utf8 n with + (match Descriptor.java_type_of_internal_utf8 n with hunk ./src/classfile/annotation.ml 504 - | _ -> fail Invalid_annotation_type_value) - | _ -> fail Invalid_annotation_type_value in + | _ -> fail (Invalid_annotation_type_value i.type_index)) + | _ -> fail (Invalid_annotation_type_value i.type_index) in hunk ./src/classfile/annotation.ml 509 - | _ -> fail Invalid_element_name in + | _ -> fail (Invalid_element_name idx) in hunk ./src/classfile/annotation.ml 515 - let x, y = decode pool { type_index = i.ext_type_index; - num_element_value_pairs = i.ext_num_element_value_pairs; - element_value_pairs = i.ext_element_value_pairs; } in + let x, y = + decode + pool + { type_index = i.ext_type_index; + num_element_value_pairs = i.ext_num_element_value_pairs; + element_value_pairs = i.ext_element_value_pairs; } in hunk ./src/classfile/annotation.ml 558 - let desc = Descriptor.utf8_of_java_type (`Class n) in + let desc = Descriptor.internal_utf8_of_java_type (`Class n) in hunk ./src/classfile/annotation.ml 567 - let checked_length l = - let res = List.length l in - if res < 65536 then - res - else - fail Invalid_list_length in hunk ./src/classfile/annotation.ml 574 - num_element_value_pairs = u2 (checked_length pairs); + num_element_value_pairs = checked_length pairs; hunk ./src/classfile/annotation.mli 19 -(** This module defines annotations in both low- and high-level forms. - It also provides conversion functions between levels as well as i/o - functions for low-level. *) +(** Annotations in both low- and high-level forms. + + It also provides conversion functions between levels as well as i/o + functions for low-level. *) hunk ./src/classfile/annotation.mli 28 -(** Location, that is list of interval used to disambiguate an annotation target. *) +(** Location, that is list of indexes used to disambiguate an annotation target. *) hunk ./src/classfile/annotation.mli 32 - - start is the begin of the interval in the code; - - length is the size of the interval; - - index is the position of the local variable. *) + - start is the begin of the interval in the code; + - length is the size of the interval; + - index is the position of the local variable. *) hunk ./src/classfile/annotation.mli 69 -(** Represents the target, that is the element actually annotated by an extended annotation. *) +(** Represents the target, that is the element actually annotated by an + extended annotation. *) + +type primitive_type = + [ `Boolean + | `Byte + | `Char + | `Double + | `Float + | `Int + | `Long + | `Short ] +(** Represents the primitives types that can be used inside an annotation. *) hunk ./src/classfile/annotation.mli 84 - | Primitive of [ `Boolean | `Byte | `Char | `Double | `Float | `Int | `Long | `Short] * Utils.u2 (** primitive value (given by type and index of value in constant pool) *) + | Primitive of primitive_type * Utils.u2 (** primitive value (given by type and index of value in constant pool) *) hunk ./src/classfile/annotation.mli 95 -(** Represents an annotation as defined in the class file format specification. *) +(** Represents an annotation as defined in the class file format + specification. *) hunk ./src/classfile/annotation.mli 103 -(** Represents an extended annotation as defined in the class file format specification. *) +(** Represents an extended annotation as defined in the class file + format specification. *) hunk ./src/classfile/annotation.mli 110 - | Invalid_tag + | Invalid_tag of Utils.UChar.t hunk ./src/classfile/annotation.mli 112 - | Invalid_string_value - | Invalid_enum_value - | Invalid_class_value - | Invalid_annotation_type_value - | Invalid_element_name - | Invalid_list_length - | Invalid_target + | Invalid_string_value of Utils.u2 + | Invalid_enum_value of Utils.u2 * Utils.u2 + | Invalid_class_value of Utils.u2 + | Invalid_annotation_type_value of Utils.u2 + | Invalid_element_name of Utils.u2 + | Invalid_list_length of int + | Invalid_target of int hunk ./src/classfile/annotation.mli 131 - Raises [Exception] if [st] does not contain a valid element target. - Raises [InputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [st] does not contain a valid element target. + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 136 - Raises [Exception] if [e] is not a valid element target. - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [e] is not a valid element target. + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 141 - Raises [Exception] if [st] does not contain a valid element value. - Raises [InputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [st] does not contain a valid element value. + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 146 - Raises [Exception] if [e] is not a valid element value. - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [e] is not a valid element value. + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 151 - Raises [Exception] if [st] does not contain a valid annotation. - Raises [InputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [st] does not contain a valid annotation. + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 156 - Raises [Exception] if [a] is not a valid annotation. - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [a] is not a valid annotation. + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 161 - Raises [Exception] if [st] does not contain a valid extended annotation. - Raises [InputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [st] does not contain a valid extended + annotation. + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 167 - Raises [Exception] if [a] is not a valid extended annotation. - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [Exception] if [a] is not a valid extended annotation. + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/annotation.mli 196 -(** Converts from a low-level into a high-level form according to passed pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a low-level into a high-level form according to + passed pool. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/annotation.mli 201 -(** Converts from a low-level into a high-level form according to passed pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a low-level into a high-level form according to + passed pool. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/annotation.mli 206 -(** Converts from a low-level into a high-level form according to passed pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a low-level into a high-level form according to + passed pool. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/annotation.mli 211 -(** Converts from a high-level into a low-level form, using passed extendable - pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a high-level into a low-level form, using passed + extendable pool. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/annotation.mli 216 -(** Converts from a high-level into a low-level form, using passed extendable - pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a high-level into a low-level form, using passed + extendable pool. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/annotation.mli 221 -(** Converts from a high-level into a low-level form, using passed extendable - pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a high-level into a low-level form, using passed + extendable pool. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/attribute.ml 65 +let fail_if b a x = + if !b then + fail (Defined_twice a) + else begin + b := true; + x + end + hunk ./src/classfile/attribute.ml 170 - | `InnerClasses of ((Name.for_class option) * (Name.for_class option) * (UTF8.t option) * (AccessFlag.for_inner_class list)) list - | `EnclosingMethod of Name.for_class * ((Name.for_method * Descriptor.for_method) option) + | `InnerClasses of inner_class_element list + | `EnclosingMethod of enclosing_method_value hunk ./src/classfile/attribute.ml 177 - | `LocalVariableTable of (u2 * u2 * UTF8.t * Descriptor.for_field * u2) list - | `LocalVariableTypeTable of (u2 * u2 * UTF8.t * Signature.field_type_signature * u2) list + | `LocalVariableTable of local_variable_table_element list + | `LocalVariableTypeTable of local_variable_type_table_element list hunk ./src/classfile/attribute.ml 184 - | `RuntimeVisibleTypeAnnotations of Annotation.extended list (** extended annotations *) - | `RuntimeInvisibleTypeAnnotations of Annotation.extended list (** extended annotations *) + | `RuntimeVisibleTypeAnnotations of Annotation.extended list + | `RuntimeInvisibleTypeAnnotations of Annotation.extended list hunk ./src/classfile/attribute.ml 188 - | `Module of Utils.UTF8.t * Utils.UTF8.t - | `ModuleRequires of (Utils.UTF8.t * Utils.UTF8.t * dependency_kind) list - | `ModulePermits of (Utils.UTF8.t * Utils.UTF8.t) list - | `ModuleProvides of (Utils.UTF8.t * Utils.UTF8.t) list + | `Module of UTF8.t * UTF8.t + | `ModuleRequires of (UTF8.t * UTF8.t * dependency_kind) list + | `ModulePermits of (UTF8.t * UTF8.t) list + | `ModuleProvides of (UTF8.t * UTF8.t) list hunk ./src/classfile/attribute.ml 198 - | `LineNumberTable of (Utils.u2 * Utils.u2) list - | `LocalVariableTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Descriptor.for_field * Utils.u2) list - | `LocalVariableTypeTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Signature.field_type_signature * Utils.u2) list + | `LineNumberTable of (u2 * u2) list + | `LocalVariableTable of local_variable_table_element list + | `LocalVariableTypeTable of local_variable_type_table_element list hunk ./src/classfile/attribute.ml 202 - | `Unknown of Utils.UTF8.t * string ] + | `Unknown of UTF8.t * string ] hunk ./src/classfile/attribute.ml 207 - exception_table : (u2 * u2 * u2 * (Name.for_class option)) list; + exception_table : exception_table_element list; hunk ./src/classfile/attribute.ml 210 +and exception_table_element = { + try_start : u2; + try_end : u2; + catch : u2; + caught : Name.for_class option; + } +and inner_class_element = { + inner_class : Name.for_class option; + outer_class : Name.for_class option; + inner_name : UTF8.t option; + inner_flags : AccessFlag.for_inner_class list; + } +and enclosing_method_value = { + innermost_class : Name.for_class; + enclosing_method : (Name.for_method * Descriptor.for_method) option; + } +and local_variable_table_element = { + local_start : u2; + local_length : u2; + local_name : UTF8.t; + local_descriptor : Descriptor.for_field; + local_index : u2; + } +and local_variable_type_table_element = { + local_type_start : u2; + local_type_length : u2; + local_type_name : UTF8.t; + local_type_signature : Signature.field_type_signature; + local_type_index : u2; + } hunk ./src/classfile/attribute.ml 248 - | `RuntimeVisibleTypeAnnotations of Annotation.extended list (** extended annotations *) - | `RuntimeInvisibleTypeAnnotations of Annotation.extended list (** extended annotations *) + | `RuntimeVisibleTypeAnnotations of Annotation.extended list + | `RuntimeInvisibleTypeAnnotations of Annotation.extended list hunk ./src/classfile/attribute.ml 262 - | `RuntimeVisibleTypeAnnotations of Annotation.extended list (** extended annotations *) - | `RuntimeInvisibleTypeAnnotations of Annotation.extended list (** extended annotations *) + | `RuntimeVisibleTypeAnnotations of Annotation.extended list + | `RuntimeInvisibleTypeAnnotations of Annotation.extended list hunk ./src/classfile/attribute.ml 268 - [ `InnerClasses of ((Name.for_class option) * (Name.for_class option) * (UTF8.t option) * (AccessFlag.for_inner_class list)) list - | `EnclosingMethod of Name.for_class * ((Name.for_method * Descriptor.for_method) option) + [ `InnerClasses of inner_class_element list + | `EnclosingMethod of enclosing_method_value hunk ./src/classfile/attribute.ml 277 - | `RuntimeVisibleTypeAnnotations of Annotation.extended list (** extended annotations *) - | `RuntimeInvisibleTypeAnnotations of Annotation.extended list (** extended annotations *) - | `Module of Utils.UTF8.t * Utils.UTF8.t (** module name and version *) + | `RuntimeVisibleTypeAnnotations of Annotation.extended list + | `RuntimeInvisibleTypeAnnotations of Annotation.extended list + | `Module of UTF8.t * UTF8.t hunk ./src/classfile/attribute.ml 283 - [ `Module of Utils.UTF8.t * Utils.UTF8.t - | `SourceFile of Utils.UTF8.t + [ `Module of UTF8.t * UTF8.t + | `SourceFile of UTF8.t hunk ./src/classfile/attribute.ml 290 - [ `Module of Utils.UTF8.t * Utils.UTF8.t - | `SourceFile of Utils.UTF8.t - | `ModuleRequires of (Utils.UTF8.t * Utils.UTF8.t * dependency_kind) list - | `ModulePermits of (Utils.UTF8.t * Utils.UTF8.t) list - | `ModuleProvides of (Utils.UTF8.t * Utils.UTF8.t) list + [ `Module of UTF8.t * UTF8.t + | `SourceFile of UTF8.t + | `ModuleRequires of (UTF8.t * UTF8.t * dependency_kind) list + | `ModulePermits of (UTF8.t * UTF8.t) list + | `ModuleProvides of (UTF8.t * UTF8.t) list hunk ./src/classfile/attribute.ml 321 +let string_of_verification_type_info = function + | Top_variable_info -> "top" + | Integer_variable_info -> "int" + | Float_variable_info -> "float" + | Long_variable_info -> "long" + | Double_variable_info -> "double" + | Null_variable_info -> "null" + | Uninitialized_this_variable_info -> "uninit this" + | Object_variable_info (`Class_or_interface cn) -> + UTF8.to_string_noerr (Name.external_utf8_for_class cn) + | Object_variable_info (`Array_type ((`Array _) as a)) -> + let res = Descriptor.external_utf8_of_java_type (a :> Descriptor.java_type) in + (UTF8.to_string_noerr res) + | Uninitialized_variable_info ofs -> + Printf.sprintf "uninit %d" (ofs :> int) + +let verification_type_info_of_parameter_descriptor = function + | `Boolean -> Integer_variable_info + | `Byte -> Integer_variable_info + | `Char -> Integer_variable_info + | `Double -> Double_variable_info + | `Float -> Float_variable_info + | `Int -> Integer_variable_info + | `Long -> Long_variable_info + | `Short -> Integer_variable_info + | `Class cn -> Object_variable_info (`Class_or_interface cn) + | `Array e -> Object_variable_info (`Array_type (`Array e)) + +let equal_verification_type_info x y = + match (x, y) with + | (Object_variable_info (`Class_or_interface cn1)), + (Object_variable_info (`Class_or_interface cn2)) -> + Name.equal_for_class cn1 cn2 + | (Object_variable_info (`Array_type at1)), + (Object_variable_info (`Array_type at2)) -> + Descriptor.equal_java_type + (at1 :> Descriptor.java_type) + (at2 :> Descriptor.java_type) + | (Object_variable_info _), + (Object_variable_info _) -> false + | (Uninitialized_variable_info uvi1), + (Uninitialized_variable_info uvi2) -> uvi1 = uvi2 + | _ -> x = y + hunk ./src/classfile/attribute.ml 382 - let t = Descriptor.java_type_of_utf8 v in `Array_type (Descriptor.filter_array Descriptor.Invalid_array_element_type t) + let t = Descriptor.java_type_of_internal_utf8 v in `Array_type (Descriptor.filter_non_array Descriptor.Invalid_array_element_type t) hunk ./src/classfile/attribute.ml 453 - let nb_locals = InputStream.read_u2 st in - let locals = ref [] in - for i = 1 to (nb_locals :> int) do - let l = read_verification_type_info st pool in - locals := l :: !locals - done; - let nb_stack_items = InputStream.read_u2 st in - let stack_items = ref [] in - for i = 1 to (nb_stack_items :> int) do - let si = read_verification_type_info st pool in - stack_items := si :: !stack_items - done; - (Full_frame (ofs, (List.rev !locals), (List.rev !stack_items))), ofs + let locals = InputStream.read_elements st (fun x -> read_verification_type_info x pool) in + let stack_items = InputStream.read_elements st (fun x -> read_verification_type_info x pool) in + (Full_frame (ofs, locals, stack_items)), ofs hunk ./src/classfile/attribute.ml 529 - if (len_locals <= 65535) && (len_stack_items <= 65535) then + if (len_locals <= max_u2) && (len_stack_items <= max_u2) then hunk ./src/classfile/attribute.ml 563 - let fail_if b a x = if !b then fail (Defined_twice a) else b := true; x in hunk ./src/classfile/attribute.ml 585 - let fail_if b a x = if !b then fail (Defined_twice a) else b := true; x in hunk ./src/classfile/attribute.ml 615 - let fail_if b a x = if !b then fail (Defined_twice a) else b := true; x in hunk ./src/classfile/attribute.ml 645 - let fail_if b a x = if !b then fail (Defined_twice a) else b := true; x in hunk ./src/classfile/attribute.ml 668 - let fail_if b a x = if !b then fail (Defined_twice a) else b := true; x in hunk ./src/classfile/attribute.ml 684 - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let a = Annotation.read_info st in - res := (Annotation.decode pool a) :: !res - done; - List.rev !res in + InputStream.read_elements + st + (fun st -> + let a = Annotation.read_info st in + Annotation.decode pool a) in hunk ./src/classfile/attribute.ml 690 - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let a = Annotation.read_extended_info st in - res := (Annotation.decode_extended pool a) :: !res - done; - List.rev !res in + InputStream.read_elements + st + (fun st -> + let a = Annotation.read_extended_info st in + Annotation.decode_extended pool a) in hunk ./src/classfile/attribute.ml 699 - let nb' = InputStream.read_u2 st in - let local = ref [] in - for j = 1 to (nb' :> int) do - let a = Annotation.read_info st in - local := (Annotation.decode pool a) :: !local - done; - res := (List.rev !local) :: !res + let local = + InputStream.read_elements + st + (fun st -> + let a = Annotation.read_info st in + Annotation.decode pool a) in + res := local :: !res hunk ./src/classfile/attribute.ml 718 - if UTF8.equal attr_name attr_constant_value then - let const_index = InputStream.read_u2 st in - match ConstantPool.get_entry pool const_index with - | ConstantPool.Long (hi, lo) -> - let v = Int64.logor (Int64.shift_left (Int64.of_int32 hi) 32) (Int64.of_int32 lo) in - `ConstantValue (Long_value v) - | ConstantPool.Float v -> - `ConstantValue (Float_value (Int32.float_of_bits v)) - | ConstantPool.Double (hi, lo) -> - let v = Int64.logor (Int64.shift_left (Int64.of_int32 hi) 32) (Int64.of_int32 lo) in - `ConstantValue (Double_value (Int64.float_of_bits v)) - | ConstantPool.Integer v -> - `ConstantValue (Integer_value v) - | ConstantPool.String idx -> - `ConstantValue (String_value (get_utf8 pool idx Invalid_constant_value)) - | _ -> fail Invalid_constant_value - else if UTF8.equal attr_name attr_code then - let mx_stack = InputStream.read_u2 st in - let mx_locals = InputStream.read_u2 st in - let code_len' = InputStream.read_u4 st in - let code_len = - if (code_len' :> int64) < 65536L then - Int64.to_int (code_len' :> int64) - else - fail Invalid_code_length in - let code_content = InputStream.read_bytes st code_len in - let exceptions_len = InputStream.read_u2 st in - let exceptions = ref [] in - for i = 1 to (exceptions_len :> int) do - let start_pc = InputStream.read_u2 st in - let end_pc = InputStream.read_u2 st in - let handler_pc = InputStream.read_u2 st in - let catch_index = InputStream.read_u2 st in - let catch_type = - if (catch_index :> int) <> 0 then - Some (get_class_name pool catch_index Invalid_exception_name) + switch UTF8.equal + [ attr_constant_value, + (fun _ -> + let const_index = InputStream.read_u2 st in + match ConstantPool.get_entry pool const_index with + | ConstantPool.Long (hi, lo) -> + let v = Int64.logor (Int64.shift_left (Int64.of_int32 hi) 32) (Int64.of_int32 lo) in + `ConstantValue (Long_value v) + | ConstantPool.Float v -> + `ConstantValue (Float_value (Int32.float_of_bits v)) + | ConstantPool.Double (hi, lo) -> + let v = Int64.logor (Int64.shift_left (Int64.of_int32 hi) 32) (Int64.of_int32 lo) in + `ConstantValue (Double_value (Int64.float_of_bits v)) + | ConstantPool.Integer v -> + `ConstantValue (Integer_value v) + | ConstantPool.String idx -> + `ConstantValue (String_value (get_utf8 pool idx Invalid_constant_value)) + | _ -> fail Invalid_constant_value); + attr_code, + (fun _ -> + let mx_stack = InputStream.read_u2 st in + let mx_locals = InputStream.read_u2 st in + let code_len' = InputStream.read_u4 st in + let code_len = + if (code_len' :> int64) < 65536L then + Int64.to_int (code_len' :> int64) + else + fail Invalid_code_length in + let code_content = InputStream.read_bytes st code_len in + let exceptions = + InputStream.read_elements + st + (fun st -> + let start_pc = InputStream.read_u2 st in + let end_pc = InputStream.read_u2 st in + let handler_pc = InputStream.read_u2 st in + let catch_index = InputStream.read_u2 st in + let catch_type = + if (catch_index :> int) <> 0 then + Some (get_class_name pool catch_index Invalid_exception_name) + else + None in + { try_start = start_pc; + try_end = end_pc; + catch = handler_pc; + caught = catch_type; }) in + let attrs = + InputStream.read_elements + st + (fun st -> + let a = read_info st in + decode element pool a) in + let code_stream = InputStream.make_of_string code_content in + `Code { max_stack = mx_stack; + max_locals = mx_locals; + code = List.map (fun i -> Instruction.decode pool i) (ByteCode.read code_stream 0); + exception_table = exceptions; + attributes = check_code_attributes attrs; }); + attr_exceptions, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let idx = InputStream.read_u2 st in + get_class_name pool idx Invalid_exception) in + `Exceptions res); + attr_inner_classes, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let inner_info_index = InputStream.read_u2 st in + let outer_info_index = InputStream.read_u2 st in + let inner_name_index = InputStream.read_u2 st in + let inner_class_access_flag = InputStream.read_u2 st in + let inner_class = + if (inner_info_index :> int) = 0 then + None + else + Some (get_class_name pool inner_info_index Invalid_inner_class) in + let outer_class = + if (outer_info_index :> int) = 0 then + None + else + Some (get_class_name pool outer_info_index Invalid_outer_class) in + let inner_name = + if (inner_name_index :> int) = 0 then + None + else + Some (get_utf8 pool inner_name_index Invalid_inner_class) in + let inner_flags = AccessFlag.from_u2 false inner_class_access_flag in + let inner_flags = AccessFlag.check_inner_class_flags inner_flags in + { inner_class; outer_class; inner_name; inner_flags }) in + `InnerClasses res); + attr_enclosing_method, + (fun _ -> + let class_index = InputStream.read_u2 st in + let method_index = InputStream.read_u2 st in + let class_name = get_class_name pool class_index Invalid_enclosing_method in + let method_desc = if (method_index :> int) <> 0 then + try + match ConstantPool.get_entry pool method_index with + | ConstantPool.NameAndType (name, desc) -> + Some ((Name.make_for_method (get_utf8 pool name Invalid_enclosing_method)), + (Descriptor.method_of_utf8 (get_utf8 pool desc Invalid_enclosing_method))) + | _ -> fail Invalid_enclosing_method + with _ -> fail Invalid_enclosing_method hunk ./src/classfile/attribute.ml 829 - exceptions := (start_pc, end_pc, handler_pc, catch_type) :: !exceptions - done; - let attrib_count = InputStream.read_u2 st in - let attrs = ref [] in - for i = 1 to (attrib_count :> int) do - let a = read_info st in - attrs := (decode element pool a) :: !attrs - done; - let code_stream = InputStream.make_of_string code_content in - `Code { max_stack = mx_stack; - max_locals = mx_locals; - code = List.map (fun i -> Instruction.decode pool i) (ByteCode.read code_stream 0); - exception_table = List.rev !exceptions; - attributes = List.rev (check_code_attributes !attrs); } - else if UTF8.equal attr_name attr_exceptions then - let exceptions_nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (exceptions_nb :> int) do - let idx = InputStream.read_u2 st in - let name = get_class_name pool idx Invalid_exception in - res := name :: !res - done; - `Exceptions (List.rev !res) - else if UTF8.equal attr_name attr_inner_classes then - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let inner_info_index = InputStream.read_u2 st in - let outer_info_index = InputStream.read_u2 st in - let inner_name_index = InputStream.read_u2 st in - let inner_class_access_flag = InputStream.read_u2 st in - let inner_class = - if (inner_info_index :> int) = 0 then - None - else - Some (get_class_name pool inner_info_index Invalid_inner_class) in - let outer_class = - if (outer_info_index :> int) = 0 then - None - else - Some (get_class_name pool outer_info_index Invalid_outer_class) in - let inner_name = - if (inner_name_index :> int) = 0 then - None - else - Some (get_utf8 pool inner_name_index Invalid_inner_class) in - let flags = AccessFlag.from_u2 false inner_class_access_flag in - res := (inner_class, outer_class, inner_name, (AccessFlag.check_inner_class_flags flags)) :: !res - done; - `InnerClasses (List.rev !res) - else if UTF8.equal attr_name attr_enclosing_method then - let class_index = InputStream.read_u2 st in - let method_index = InputStream.read_u2 st in - let class_name = get_class_name pool class_index Invalid_enclosing_method in - let method_desc = if (method_index :> int) <> 0 then - try - match pool.((method_index :> int)) with - | ConstantPool.NameAndType (name, desc) -> - Some ((Name.make_for_method (get_utf8 pool name Invalid_enclosing_method)), - (Descriptor.method_of_utf8 (get_utf8 pool desc Invalid_enclosing_method))) - | _ -> fail Invalid_enclosing_method - with _ -> fail Invalid_enclosing_method - else - None in - `EnclosingMethod (class_name, method_desc) - else if UTF8.equal attr_name attr_synthetic then - `Synthetic - else if UTF8.equal attr_name attr_signature then - let signature_index = InputStream.read_u2 st in - let s = get_utf8 pool signature_index Invalid_signature in - let s' = (match element with - | Class -> `Class (Signature.class_signature_of_utf8 s) - | Method -> `Method (Signature.method_signature_of_utf8 s) - | Field -> `Field (Signature.field_type_signature_of_utf8 s) - | Package -> fail Invalid_package_attribute - | Module -> fail Invalid_module_attribute) in - `Signature s' - else if UTF8.equal attr_name attr_source_file then - let sourcefile_index = InputStream.read_u2 st in - `SourceFile (get_utf8 pool sourcefile_index Invalid_source_file) - else if UTF8.equal attr_name attr_source_debug_extension then - let extension = UTF8.of_modified (UTF8.modified_of_bytes i.data) in - `SourceDebugExtension extension - else if UTF8.equal attr_name attr_line_number_table then - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let start_pc = InputStream.read_u2 st in - let line_number = InputStream.read_u2 st in - res := (start_pc, line_number) :: !res - done; - `LineNumberTable (List.rev !res) - else if UTF8.equal attr_name attr_local_variable_table then - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let start_pc = InputStream.read_u2 st in - let length = InputStream.read_u2 st in - let name_index = InputStream.read_u2 st in - let desc_index = InputStream.read_u2 st in - let index = InputStream.read_u2 st in - let name = get_utf8 pool name_index Invalid_local_variable_table in - let desc = get_utf8 pool desc_index Invalid_local_variable_table in - let field_desc = Descriptor.field_of_utf8 desc in - if Name.is_valid_unqualified name then - res := (start_pc, length, name, field_desc, index) :: !res - else - fail Invalid_local_variable_table - done; - `LocalVariableTable (List.rev !res) - else if UTF8.equal attr_name attr_local_variable_type_table then - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let start_pc = InputStream.read_u2 st in - let length = InputStream.read_u2 st in - let name_index = InputStream.read_u2 st in - let sign_index = InputStream.read_u2 st in - let index = InputStream.read_u2 st in - let name = get_utf8 pool name_index Invalid_local_variable_type_table in - let s = get_utf8 pool sign_index Invalid_local_variable_type_table in - let sign = Signature.field_type_signature_of_utf8 s in - if Name.is_valid_unqualified name then - res := (start_pc, length, name, sign, index) :: !res - else - fail Invalid_local_variable_type_table - done; - `LocalVariableTypeTable (List.rev !res) - else if UTF8.equal attr_name attr_deprecated then - `Deprecated - else if UTF8.equal attr_name attr_runtime_visible_annotations then - `RuntimeVisibleAnnotations (read_annotations ()) - else if UTF8.equal attr_name attr_runtime_invisible_annotations then - `RuntimeInvisibleAnnotations (read_annotations ()) - else if UTF8.equal attr_name attr_runtime_visible_parameter_annotations then - `RuntimeVisibleParameterAnnotations (read_annotations_list ()) - else if UTF8.equal attr_name attr_runtime_invisible_parameter_annotations then - `RuntimeInvisibleParameterAnnotations (read_annotations_list ()) - else if UTF8.equal attr_name attr_runtime_visible_type_annotations then - `RuntimeVisibleTypeAnnotations (read_extended_annotations ()) - else if UTF8.equal attr_name attr_runtime_invisible_type_annotations then - `RuntimeInvisibleTypeAnnotations (read_extended_annotations ()) - else if UTF8.equal attr_name attr_annotation_default then - let eiv = Annotation.read_info_element_value st in - `AnnotationDefault (Annotation.decode_element_value pool eiv) - else if UTF8.equal attr_name attr_stack_map_table then - let nb = InputStream.read_u2 st in - let res = ref [] in - let ofs = ref (-1) in - for i = 1 to (nb :> int) do - let e, o = read_stack_map_frame st pool !ofs in - res := e :: !res; - ofs := (o :> int) - done; - `StackMapTable (List.rev !res) - else if UTF8.equal attr_name attr_module then - let name, version = read_module_info () in - `Module (name, version) - else if UTF8.equal attr_name attr_module_requires then - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let n, v = read_module_info () in - let k = dependency_kind_of_u1 (InputStream.read_u1 st) in - res := (n, v, k) :: !res - done; - `ModuleRequires (List.rev !res) - else if UTF8.equal attr_name attr_module_permits then - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let n, v = read_module_info () in - res := (n, v) :: !res - done; - `ModulePermits (List.rev !res) - else if UTF8.equal attr_name attr_module_provides then - let nb = InputStream.read_u2 st in - let res = ref [] in - for i = 1 to (nb :> int) do - let n, v = read_module_info () in - res := (n, v) :: !res - done; - `ModuleProvides (List.rev !res) - else - `Unknown (attr_name, i.data) + `EnclosingMethod { innermost_class = class_name; + enclosing_method = method_desc }); + attr_synthetic, + (fun _ -> + `Synthetic); + attr_signature, + (fun _ -> + let signature_index = InputStream.read_u2 st in + let s = get_utf8 pool signature_index Invalid_signature in + let s' = (match element with + | Class -> `Class (Signature.class_signature_of_utf8 s) + | Method -> `Method (Signature.method_signature_of_utf8 s) + | Field -> `Field (Signature.field_type_signature_of_utf8 s) + | Package -> fail Invalid_package_attribute + | Module -> fail Invalid_module_attribute) in + `Signature s'); + attr_source_file, + (fun _ -> + let sourcefile_index = InputStream.read_u2 st in + `SourceFile (get_utf8 pool sourcefile_index Invalid_source_file)); + attr_source_debug_extension, + (fun _ -> + let extension = UTF8.of_modified (UTF8.modified_of_bytes i.data) in + `SourceDebugExtension extension); + attr_line_number_table, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let start_pc = InputStream.read_u2 st in + let line_number = InputStream.read_u2 st in + (start_pc, line_number)) in + `LineNumberTable res); + attr_local_variable_table, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let start_pc = InputStream.read_u2 st in + let length = InputStream.read_u2 st in + let name_index = InputStream.read_u2 st in + let desc_index = InputStream.read_u2 st in + let index = InputStream.read_u2 st in + let name = get_utf8 pool name_index Invalid_local_variable_table in + let desc = get_utf8 pool desc_index Invalid_local_variable_table in + let field_desc = Descriptor.field_of_utf8 desc in + if Name.is_valid_unqualified name then + { local_start = start_pc; + local_length = length; + local_name = name; + local_descriptor = field_desc; + local_index = index } + else + fail Invalid_local_variable_table) in + `LocalVariableTable res); + attr_local_variable_type_table, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let start_pc = InputStream.read_u2 st in + let length = InputStream.read_u2 st in + let name_index = InputStream.read_u2 st in + let sign_index = InputStream.read_u2 st in + let index = InputStream.read_u2 st in + let name = get_utf8 pool name_index Invalid_local_variable_type_table in + let s = get_utf8 pool sign_index Invalid_local_variable_type_table in + let sign = Signature.field_type_signature_of_utf8 s in + if Name.is_valid_unqualified name then + { local_type_start = start_pc; + local_type_length = length; + local_type_name = name; + local_type_signature = sign; + local_type_index = index } + else + fail Invalid_local_variable_type_table) in + `LocalVariableTypeTable res); + attr_deprecated, + (fun _ -> + `Deprecated); + attr_runtime_visible_annotations, + (fun _ -> + `RuntimeVisibleAnnotations (read_annotations ())); + attr_runtime_invisible_annotations, + (fun _ -> + `RuntimeInvisibleAnnotations (read_annotations ())); + attr_runtime_visible_parameter_annotations, + (fun _ -> + `RuntimeVisibleParameterAnnotations (read_annotations_list ())); + attr_runtime_invisible_parameter_annotations, + (fun _ -> + `RuntimeInvisibleParameterAnnotations (read_annotations_list ())); + attr_runtime_visible_type_annotations, + (fun _ -> + `RuntimeVisibleTypeAnnotations (read_extended_annotations ())); + attr_runtime_invisible_type_annotations, + (fun _ -> + `RuntimeInvisibleTypeAnnotations (read_extended_annotations ())); + attr_annotation_default, + (fun _ -> + let eiv = Annotation.read_info_element_value st in + `AnnotationDefault (Annotation.decode_element_value pool eiv)); + attr_stack_map_table, + (fun _ -> + let nb = InputStream.read_u2 st in + let res = ref [] in + let ofs = ref (-1) in + for i = 1 to (nb :> int) do + let e, o = read_stack_map_frame st pool !ofs in + res := e :: !res; + ofs := (o :> int) + done; + `StackMapTable (List.rev !res)); + attr_module, + (fun _ -> + let name, version = read_module_info () in + `Module (name, version)); + attr_module_requires, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let n, v = read_module_info () in + let k = dependency_kind_of_u1 (InputStream.read_u1 st) in + (n, v, k)) in + `ModuleRequires res); + attr_module_permits, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let n, v = read_module_info () in + (n, v)) in + `ModulePermits res); + attr_module_provides, + (fun _ -> + let res = + InputStream.read_elements + st + (fun st -> + let n, v = read_module_info () in + (n, v)) in + `ModuleProvides res) ] + (fun attr_name -> `Unknown (attr_name, i.data)) + attr_name hunk ./src/classfile/attribute.ml 983 - if res < 65536 then + if res <= max_u2 then hunk ./src/classfile/attribute.ml 990 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter (fun a -> - let a' = Annotation.encode pool a in - Annotation.write_info st a') l in + OutputStream.write_elements + checked_length + st + (fun st a -> + let a' = Annotation.encode pool a in + Annotation.write_info st a') + l in hunk ./src/classfile/attribute.ml 998 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter (fun a -> - let a' = Annotation.encode_extended pool a in - Annotation.write_extended_info st a') l in + OutputStream.write_elements + checked_length + st + (fun st a -> + let a' = Annotation.encode_extended pool a in + Annotation.write_extended_info st a') + l in hunk ./src/classfile/attribute.ml 1007 - OutputStream.write_u2 st len; - List.iter (fun l' -> - let len' = checked_length l' in - OutputStream.write_u2 st len'; - List.iter (fun a -> - let a' = Annotation.encode pool a in - Annotation.write_info st a') l') l in + OutputStream.write_u2 st len; (* XXX should be u1 ? *) + List.iter + (fun l' -> + OutputStream.write_elements + checked_length + st + (fun st a -> + let a' = Annotation.encode pool a in + Annotation.write_info st a') + l') + l in hunk ./src/classfile/attribute.ml 1065 - if code_length >= 65536 then fail Invalid_code_length; + if code_length > max_u2 then fail Invalid_code_length; hunk ./src/classfile/attribute.ml 1068 - let len = checked_length c.exception_table in - OutputStream.write_u2 st len; - List.iter (fun (start_pc, end_pc, handler_pc, catch) -> - let catch_idx = match catch with - | Some exn_name -> ConstantPool.add_class pool exn_name - | None -> u2 0 in - OutputStream.write_u2 st start_pc; - OutputStream.write_u2 st end_pc; - OutputStream.write_u2 st handler_pc; - OutputStream.write_u2 st catch_idx) c.exception_table; + OutputStream.write_elements + checked_length + st + (fun st elem -> + let catch_idx = match elem.caught with + | Some exn_name -> ConstantPool.add_class pool exn_name + | None -> u2 0 in + OutputStream.write_u2 st elem.try_start; + OutputStream.write_u2 st elem.try_end; + OutputStream.write_u2 st elem.catch; + OutputStream.write_u2 st catch_idx) + c.exception_table; hunk ./src/classfile/attribute.ml 1084 - List.iter (fun a -> - let a' = encode pool (a :> t) in - write_info sub_st a') c.attributes; + List.iter + (fun a -> + let a' = encode pool (a :> t) in + write_info sub_st a') + c.attributes; hunk ./src/classfile/attribute.ml 1093 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter (fun s -> - let idx = ConstantPool.add_class pool s in - OutputStream.write_u2 st idx) l; + OutputStream.write_elements + checked_length + st + (fun st s -> + let idx = ConstantPool.add_class pool s in + OutputStream.write_u2 st idx) + l; hunk ./src/classfile/attribute.ml 1102 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter (fun (inner_class, outer_class, inner_name, flags) -> - let inner_idx = match inner_class with - | None -> u2 0 - | Some c -> ConstantPool.add_class pool c in - let outer_idx = match outer_class with - | None -> u2 0 - | Some c -> ConstantPool.add_class pool c in - let name_idx = match inner_name with - | None -> u2 0 - | Some c -> ConstantPool.add_utf8 pool c in - let fl = AccessFlag.list_to_u2 (flags :> AccessFlag.t list) in - OutputStream.write_u2 st inner_idx; - OutputStream.write_u2 st outer_idx; - OutputStream.write_u2 st name_idx; - OutputStream.write_u2 st fl) l; + OutputStream.write_elements + checked_length + st + (fun st { inner_class; outer_class; inner_name; inner_flags } -> + let inner_idx = match inner_class with + | None -> u2 0 + | Some c -> ConstantPool.add_class pool c in + let outer_idx = match outer_class with + | None -> u2 0 + | Some c -> ConstantPool.add_class pool c in + let name_idx = match inner_name with + | None -> u2 0 + | Some c -> ConstantPool.add_utf8 pool c in + let fl = AccessFlag.list_to_u2 (inner_flags :> AccessFlag.t list) in + OutputStream.write_u2 st inner_idx; + OutputStream.write_u2 st outer_idx; + OutputStream.write_u2 st name_idx; + OutputStream.write_u2 st fl) + l; hunk ./src/classfile/attribute.ml 1122 - | `EnclosingMethod (class_name, meth_desc) -> - let class_idx = ConstantPool.add_class pool class_name in - let meth_idx = match meth_desc with + | `EnclosingMethod { innermost_class; enclosing_method } -> + let class_idx = ConstantPool.add_class pool innermost_class in + let meth_idx = match enclosing_method with hunk ./src/classfile/attribute.ml 1152 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter (fun (start_pc, line_number) -> - OutputStream.write_u2 st start_pc; - OutputStream.write_u2 st line_number) l; + OutputStream.write_elements + checked_length + st + (fun st (start_pc, line_number) -> + OutputStream.write_u2 st start_pc; + OutputStream.write_u2 st line_number) + l; hunk ./src/classfile/attribute.ml 1161 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter (fun (start_pc, length, name, desc, index) -> - let name_index = ConstantPool.add_utf8 pool name in - let desc_val = Descriptor.utf8_of_field desc in - let desc_index = ConstantPool.add_utf8 pool desc_val in - OutputStream.write_u2 st start_pc; - OutputStream.write_u2 st length; - OutputStream.write_u2 st name_index; - OutputStream.write_u2 st desc_index; - OutputStream.write_u2 st index) l; + OutputStream.write_elements + checked_length + st + (fun st { local_start ; local_length; local_name; local_descriptor; local_index } -> + let name_index = ConstantPool.add_utf8 pool local_name in + let desc_val = Descriptor.utf8_of_field local_descriptor in + let desc_index = ConstantPool.add_utf8 pool desc_val in + OutputStream.write_u2 st local_start; + OutputStream.write_u2 st local_length; + OutputStream.write_u2 st name_index; + OutputStream.write_u2 st desc_index; + OutputStream.write_u2 st local_index) + l; hunk ./src/classfile/attribute.ml 1176 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter (fun (start_pc, length, name, sign, index) -> - let name_index = ConstantPool.add_utf8 pool name in - let sign_val = Signature.utf8_of_field_type_signature sign in - let sign_index = ConstantPool.add_utf8 pool sign_val in - OutputStream.write_u2 st start_pc; - OutputStream.write_u2 st length; - OutputStream.write_u2 st name_index; - OutputStream.write_u2 st sign_index; - OutputStream.write_u2 st index) l; + OutputStream.write_elements + checked_length + st + (fun st { local_type_start; local_type_length; local_type_name; local_type_signature; local_type_index } -> + let name_index = ConstantPool.add_utf8 pool local_type_name in + let sign_val = Signature.utf8_of_field_type_signature local_type_signature in + let sign_index = ConstantPool.add_utf8 pool sign_val in + OutputStream.write_u2 st local_type_start; + OutputStream.write_u2 st local_type_length; + OutputStream.write_u2 st name_index; + OutputStream.write_u2 st sign_index; + OutputStream.write_u2 st local_type_index) + l; hunk ./src/classfile/attribute.ml 1229 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter - (fun (n, v, k) -> + OutputStream.write_elements + checked_length + st + (fun st (n, v, k) -> hunk ./src/classfile/attribute.ml 1239 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter - (fun (n, v) -> + OutputStream.write_elements + checked_length + st + (fun st (n, v) -> hunk ./src/classfile/attribute.ml 1248 - let len = checked_length l in - OutputStream.write_u2 st len; - List.iter - (fun (n, v) -> + OutputStream.write_elements + checked_length + st + (fun st (n, v) -> hunk ./src/classfile/attribute.ml 1260 +let compare x y = + let rank = function + | `ConstantValue _ -> 3 + | `Code _ -> 8 + | `Exceptions _ -> 3 + | `InnerClasses _ -> 2 + | `EnclosingMethod _ -> 2 + | `Synthetic -> 0 + | `Signature _ -> 1 + | `SourceFile _ -> 1 + | `SourceDebugExtension _ -> 6 + | `LineNumberTable _ -> -1 + | `LocalVariableTable _ -> -1 + | `LocalVariableTypeTable _ -> -1 + | `Deprecated -> 0 + | `RuntimeVisibleAnnotations _ -> 5 + | `RuntimeInvisibleAnnotations _ -> 5 + | `RuntimeVisibleParameterAnnotations _ -> 5 + | `RuntimeInvisibleParameterAnnotations _ -> 5 + | `RuntimeVisibleTypeAnnotations _ -> 5 + | `RuntimeInvisibleTypeAnnotations _ -> 5 + | `AnnotationDefault _ -> 4 + | `StackMapTable _ -> 9 + | `Module _ -> 1 + | `ModuleRequires _ -> 99 + | `ModulePermits _ -> 99 + | `ModuleProvides _ -> 99 + | `Unknown _ -> 7 in + let cmp = compare (rank x) (rank y) in + if cmp = 0 then compare x y else cmp + hunk ./src/classfile/attribute.ml 1338 - Version.make_bounds "'Module' attribute" Version.Java_1_7 None + Version.make_bounds "'Module' attribute" Version.Java_1_8 None hunk ./src/classfile/attribute.ml 1340 - Version.make_bounds "'Module' attribute" Version.Java_1_7 None + Version.make_bounds "'Module' attribute" Version.Java_1_8 None hunk ./src/classfile/attribute.ml 1342 - Version.make_bounds "'Module' attribute" Version.Java_1_7 None + Version.make_bounds "'Module' attribute" Version.Java_1_8 None hunk ./src/classfile/attribute.ml 1344 - Version.make_bounds "'Module' attribute" Version.Java_1_7 None + Version.make_bounds "'Module' attribute" Version.Java_1_8 None hunk ./src/classfile/attribute.ml 1347 + + +(* Common extractors *) + +let rec extract_code = function + | (`Code c) :: _ -> c + | _ :: tl -> extract_code tl + | [] -> raise Not_found + +let rec extract_exceptions = function + | (`Exceptions e) :: _ -> e + | _ :: tl -> extract_exceptions tl + | [] -> raise Not_found + +let rec extract_class_signature = function + | (`Signature (`Class s)) :: _ -> s + | _ :: tl -> extract_class_signature tl + | [] -> raise Not_found + +let rec extract_field_signature = function + | (`Signature (`Field s)) :: _ -> s + | _ :: tl -> extract_field_signature tl + | [] -> raise Not_found + +let rec extract_method_signature = function + | (`Signature (`Method s)) :: _ -> s + | _ :: tl -> extract_method_signature tl + | [] -> raise Not_found + +let extract_annotations l = + let rec extract accu = function + | (`RuntimeVisibleAnnotations a) :: tl + | (`RuntimeInvisibleAnnotations a) :: tl -> + extract (accu @ a) tl + | _ :: tl -> extract accu tl + | [] -> accu in + extract [] l hunk ./src/classfile/attribute.mli 19 -(** This module defines attributes in both low- and high-level forms. - It also provides conversion functions between levels as well as i/o - functions for low-level. *) +(** Attributes in both low- and high-level forms. + It also provides conversion functions between levels as well as i/o + functions for low-level. *) hunk ./src/classfile/attribute.mli 74 - Raises [InputStream.Exception] if an i/o error occurs. *) + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/attribute.mli 78 - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/attribute.mli 123 -(** The kinds of module to module dependencies. *) +(** The kinds of module-to-module dependencies. *) hunk ./src/classfile/attribute.mli 129 - | `InnerClasses of ((Name.for_class option) * (Name.for_class option) * (Utils.UTF8.t option) * (AccessFlag.for_inner_class list)) list (** inner classes as a list of (inner class, outer class, inner name, access flags) *) - | `EnclosingMethod of Name.for_class * ((Name.for_method * Descriptor.for_method) option) (** inner-most class and inner-most method, [None] if not immediatly enclosed by a method *) + | `InnerClasses of inner_class_element list (** inner classes *) + | `EnclosingMethod of enclosing_method_value (** inner-most class and inner-most method *) hunk ./src/classfile/attribute.mli 136 - | `LocalVariableTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Descriptor.for_field * Utils.u2) list (** types for local variables *) - | `LocalVariableTypeTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Signature.field_type_signature * Utils.u2) list (** signatures for local variables *) + | `LocalVariableTable of local_variable_table_element list (** types for local variables *) + | `LocalVariableTypeTable of local_variable_type_table_element list (** signatures for local variables *) hunk ./src/classfile/attribute.mli 158 - | `LocalVariableTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Descriptor.for_field * Utils.u2) list (** types for local variables *) - | `LocalVariableTypeTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Signature.field_type_signature * Utils.u2) list (** signatures for local variables *) + | `LocalVariableTable of local_variable_table_element list (** types for local variables *) + | `LocalVariableTypeTable of local_variable_type_table_element list (** signatures for local variables *) hunk ./src/classfile/attribute.mli 166 - exception_table : (Utils.u2 * Utils.u2 * Utils.u2 * (Name.for_class option)) list; + exception_table : exception_table_element list; hunk ./src/classfile/attribute.mli 169 +and exception_table_element = { + try_start : Utils.u2; + try_end : Utils.u2; + catch : Utils.u2; + caught : Name.for_class option; + } +and inner_class_element = { + inner_class : Name.for_class option; + outer_class : Name.for_class option; + inner_name : Utils.UTF8.t option; + inner_flags : AccessFlag.for_inner_class list; + } +and enclosing_method_value = { + innermost_class : Name.for_class; + enclosing_method : (Name.for_method * Descriptor.for_method) option; + } +and local_variable_table_element = { + local_start : Utils.u2; + local_length : Utils.u2; + local_name : Utils.UTF8.t; + local_descriptor : Descriptor.for_field; + local_index : Utils.u2; + } +and local_variable_type_table_element = { + local_type_start : Utils.u2; + local_type_length : Utils.u2; + local_type_name : Utils.UTF8.t; + local_type_signature : Signature.field_type_signature; + local_type_index : Utils.u2; + } hunk ./src/classfile/attribute.mli 229 - [ `InnerClasses of ((Name.for_class option) * (Name.for_class option) * (Utils.UTF8.t option) * (AccessFlag.for_inner_class list)) list (** inner classes as a list of (inner class, outer class, inner name, access flags) *) - | `EnclosingMethod of Name.for_class * ((Name.for_method * Descriptor.for_method) option) (** inner-most class and inner-most method, [None] if not immediatly enclosed by a method *) + [ `InnerClasses of inner_class_element list (** inner classes *) + | `EnclosingMethod of enclosing_method_value (** inner-most class and inner-most method *) hunk ./src/classfile/attribute.mli 274 -val check_code_attributes : t list -> [`LineNumberTable of (Utils.u2 * Utils.u2) list | `LocalVariableTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Descriptor.for_field * Utils.u2) list | `LocalVariableTypeTable of (Utils.u2 * Utils.u2 * Utils.UTF8.t * Signature.field_type_signature * Utils.u2) list | `StackMapTable of stack_map_frame list | `Unknown of Utils.UTF8.t * string] list +val string_of_verification_type_info : verification_type_info -> string +(** Converts the passed verification type information into a string. *) + +val verification_type_info_of_parameter_descriptor : Descriptor.for_parameter -> verification_type_info +(** Converts the passed descriptor into a verification type information. *) + +val equal_verification_type_info : verification_type_info -> verification_type_info -> bool +(** Equality over verification type informations. *) + +val check_code_attributes : t list -> code_attribute list hunk ./src/classfile/attribute.mli 285 - The list is returned if it is valid, raising [Exception] otherwise. *) + The list is returned if it is valid, raising [Exception] otherwise. *) hunk ./src/classfile/attribute.mli 289 - The list is returned if it is valid, raising [Exception] otherwise. *) + The list is returned if it is valid, raising [Exception] otherwise. *) hunk ./src/classfile/attribute.mli 293 - The list is returned if it is valid, raising [Exception] otherwise. *) + The list is returned if it is valid, raising [Exception] otherwise. *) hunk ./src/classfile/attribute.mli 297 - The list is returned if it is valid, raising [Exception] otherwise. *) + The list is returned if it is valid, raising [Exception] otherwise. *) hunk ./src/classfile/attribute.mli 301 - The list is returned if it is valid, raising [Exception] otherwise. *) + The list is returned if it is valid, raising [Exception] otherwise. *) hunk ./src/classfile/attribute.mli 305 - The list is returned if it is valid, raising [Exception] otherwise. *) + The list is returned if it is valid, raising [Exception] otherwise. *) hunk ./src/classfile/attribute.mli 309 - Raises [Exception] if an error occurs during conversion. *) + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/attribute.mli 313 - Raises [Exception] if an error occurs during conversion. *) + Raises [Exception] if an error occurs during conversion. *) + +val compare : t -> t -> int +(** Comparison over attributes. *) hunk ./src/classfile/attribute.mli 320 + + +(** {6 Common extractors} *) + +val extract_code : t list -> code_value +(** Returns the contents of the {i Code} attribute from the passed list. + Raises [Not_found] if no such attribute exists. *) + +val extract_exceptions : t list -> Name.for_class list +(** Returns the contents of the {i Exceptions} attribute from the passed + list. + Raises [Not_found] if no such attribute exists. *) + +val extract_class_signature : for_class list -> Signature.class_signature +(** Returns the contents of the {i Signature} attribute from the passed + list. + Raises [Not_found] if no such attribute exists. *) + +val extract_field_signature : for_field list -> Signature.field_type_signature +(** Returns the contents of the {i Signature} attribute from the passed + list. + Raises [Not_found] if no such attribute exists. *) + +val extract_method_signature : for_method list -> Signature.method_signature +(** Returns the contents of the {i Signature} attribute from the passed + list. + Raises [Not_found] if no such attribute exists. *) + +val extract_annotations : t list -> Annotation.t list +(** Returns the list of annotations from the passed list. + Returns the empty list if no such annotation exists. *) hunk ./src/classfile/byteCode.mli 19 -(** This module defines bytecode elements as well as i/o functions. - Bytecode elements are low-level code elements, - high-level elements being provided by [Instruction] module. *) +(** Definition of bytecode elements as well as i/o functions. + + Bytecode elements are low-level code elements, + high-level elements being provided by [Instruction] module. *) hunk ./src/classfile/byteCode.mli 272 - Raises [Exception] if an unknown opcode is encountered. - Raises [InputStream.Exception] if an i/o error occurs. *) + The offset is needed because some instructions include padding in + order to align data on given offsets. + Raises [Exception] if an unknown opcode is encountered. + Raises [Exception] if an invalid instruction is encountered. + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/byteCode.mli 279 -(** [write st ofs l] writes instruction list [l] onto [st] using offset [ofs]. - Raises [OutputStream.Exception] if an i/o error occurs. *) +(** [write st ofs l] writes instruction list [l] onto [st] using offset + [ofs]. The offset is needed because some instructions include padding + in order to align data on given offsets. + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/classDefinition.ml 94 + let check_attributes = + List.iter check_attribute in hunk ./src/classfile/classDefinition.ml 100 - method! field_flags l = - check_flags (l :> AccessFlag.t list) - method! regular_method_flags l = - check_flags (l :> AccessFlag.t list) - method! constructor_method_flags l = - check_flags (l :> AccessFlag.t list) - method! initializer_method_strictfp b = - if b then check_flags [`Strict] + method! class_field f = + check_flags (f.Field.flags :> AccessFlag.t list); + check_attributes (f.Field.attributes :> Attribute.t list) + method! regular_method { Method.flags = f; attributes = a; _} = + check_flags (f :> AccessFlag.t list); + check_attributes (a :> Attribute.t list) + method! constructor_method { Method.cstr_flags = l; cstr_attributes = a; _ } = + check_flags (l :> AccessFlag.t list); + check_attributes (a :> Attribute.t list) + method! initializer_method { Method.init_flags = l; init_attributes = a; _ } = + check_flags (l :> AccessFlag.t list); + check_attributes (a :> Attribute.t list) hunk ./src/classfile/classDefinition.ml 114 - method! field_attribute a = - check_attribute (a :> Attribute.t) - method! regular_method_attribute a = - check_attribute (a :> Attribute.t) - method! constructor_method_attribute a = - check_attribute (a :> Attribute.t) - method! initializer_method_attribute a = - check_attribute (a :> Attribute.t) hunk ./src/classfile/classDefinition.ml 119 +let no_super_class = u2 0 + hunk ./src/classfile/classDefinition.ml 132 - { access_flags = flags; - name = get_class_name cf.ClassFile.this_class; - extends = - if (cf.ClassFile.super_class :> int) = 0 then + let super_class = + if cf.ClassFile.super_class = no_super_class then hunk ./src/classfile/classDefinition.ml 136 - Some (get_class_name cf.ClassFile.super_class); - implements = List.map - get_class_name - (Array.to_list cf.ClassFile.interfaces); - fields = List.map - (Field.decode is_interface pool) - (Array.to_list cf.ClassFile.fields); - methods = List.map - (Method.decode is_interface pool) - (Array.to_list cf.ClassFile.methods); - attributes = Attribute.check_class_attributes - (List.map - (fun x -> Attribute.decode Attribute.Class pool x) - (Array.to_list cf.ClassFile.attributes)); } + Some (get_class_name cf.ClassFile.super_class) in + let itfs = map_array_to_list get_class_name cf.ClassFile.interfaces in + let flds = map_array_to_list (Field.decode is_interface pool) cf.ClassFile.fields in + let mths = map_array_to_list (Method.decode is_interface pool) cf.ClassFile.methods in + let atts = map_array_to_list (Attribute.decode Attribute.Class pool) cf.ClassFile.attributes in + { access_flags = flags; + name = get_class_name cf.ClassFile.this_class; + extends = super_class; + implements = itfs; + fields = flds; + methods = mths; + attributes = Attribute.check_class_attributes atts; } hunk ./src/classfile/classDefinition.ml 149 -let encode ?(version=Version.Java_1_6) cd = - let checked_length s arr = - let res = Array.length arr in - if res < 65536 then - u2 res +let encode ?(version=Version.default) cd = + let checked_length s sz = + if sz <= max_u2 then + u2 sz hunk ./src/classfile/classDefinition.ml 155 + let checked_length_array s arr = + let res = Array.length arr in + checked_length s res in hunk ./src/classfile/classDefinition.ml 166 - | None -> u2 0 in - let itfs = Array.of_list (List.map (fun s -> ConstantPool.add_class pool s) cd.implements) in - let flds = Array.of_list (List.map (Field.encode pool) cd.fields) in - let mths = Array.of_list (List.map (Method.encode pool) cd.methods) in - let atts = Array.of_list (List.map (Attribute.encode pool) (cd.attributes :> Attribute.t list)) in + | None -> no_super_class in + let itfs = map_list_to_array (fun s -> ConstantPool.add_class pool s) cd.implements in + let flds = map_list_to_array (Field.encode pool) cd.fields in + let mths = map_list_to_array (Method.encode pool) cd.methods in + let atts = map_list_to_array (Attribute.encode pool) (cd.attributes :> Attribute.t list) in hunk ./src/classfile/classDefinition.ml 175 - ClassFile.constant_pool_count = checked_length "constant pool elements" cpool; + ClassFile.constant_pool_count = ConstantPool.size cpool; hunk ./src/classfile/classDefinition.ml 180 - ClassFile.interfaces_count = checked_length "interfaces" itfs; + ClassFile.interfaces_count = checked_length_array "interfaces" itfs; hunk ./src/classfile/classDefinition.ml 182 - ClassFile.fields_count = checked_length "fields" flds; + ClassFile.fields_count = checked_length_array "fields" flds; hunk ./src/classfile/classDefinition.ml 184 - ClassFile.methods_count = checked_length "methods" mths; + ClassFile.methods_count = checked_length_array "methods" mths; hunk ./src/classfile/classDefinition.ml 186 - ClassFile.attributes_count = checked_length "attributes" atts; + ClassFile.attributes_count = checked_length_array "attributes" atts; hunk ./src/classfile/classDefinition.mli 20 - Class definition instances are high-level Java class definitions, - low-level definitions being provided by [ClassFile.t] instances. *) + + Class definition instances are high-level Java class definitions, + low-level definitions being provided by [ClassFile.t] instances. *) hunk ./src/classfile/classDefinition.mli 70 - The default version is [Version.Java_1_7]. + The default version is [Version.default]. hunk ./src/classfile/classFile.ml 30 - constant_pool : ConstantPool.element array; + constant_pool : ConstantPool.t; hunk ./src/classfile/classFile.ml 48 - | Invalid_magic_number + | Invalid_magic_number of u4 hunk ./src/classfile/classFile.ml 60 - | Invalid_magic_number -> "invalid magic number" - | Unsupported_version (mj, mn) -> Printf.sprintf "unsupported class file version %d.%d" (mj :> int) (mn :> int) + | Invalid_magic_number m -> + Printf.sprintf "invalid magic number (0x%08LX instead of 0x%08LX)" (m :> int64) magic_number + | Unsupported_version (mj, mn) -> + Printf.sprintf "unsupported class file version %d.%d" (mj :> int) (mn :> int) hunk ./src/classfile/classFile.ml 78 -let check_entry_for_kind cpool idx tag = - try - match tag, (ConstantPool.get_entry cpool idx) with - | ConstantPool.CONSTANT_Class, ConstantPool.Class _ - | ConstantPool.CONSTANT_Fieldref, ConstantPool.Fieldref _ - | ConstantPool.CONSTANT_Methodref, ConstantPool.Methodref _ - | ConstantPool.CONSTANT_InterfaceMethodref, ConstantPool.InterfaceMethodref _ - | ConstantPool.CONSTANT_String, ConstantPool.String _ - | ConstantPool.CONSTANT_Integer, ConstantPool.Integer _ - | ConstantPool.CONSTANT_Float, ConstantPool.Float _ - | ConstantPool.CONSTANT_Long, ConstantPool.Long _ - | ConstantPool.CONSTANT_Double, ConstantPool.Double _ - | ConstantPool.CONSTANT_NameAndType, ConstantPool.NameAndType _ - | ConstantPool.CONSTANT_Utf8, ConstantPool.UTF8 _ -> true - | _ -> false - with _ -> false - hunk ./src/classfile/classFile.ml 91 - fail Invalid_magic_number; + fail (Invalid_magic_number mgc); hunk ./src/classfile/classFile.ml 103 - if not (check_entry_for_kind cpool this ConstantPool.CONSTANT_Class) then + if not (ConstantPool.check_entry_for_kind cpool this ConstantPool.CONSTANT_Class) then hunk ./src/classfile/classFile.ml 110 - if not (check_entry_for_kind cpool super ConstantPool.CONSTANT_Class) then + if not (ConstantPool.check_entry_for_kind cpool super ConstantPool.CONSTANT_Class) then hunk ./src/classfile/classFile.ml 116 - let itfs = Array.init (itf_count :> int) (fun _ -> - let res = InputStream.read_u2 st in - if check_entry_for_kind cpool res ConstantPool.CONSTANT_Class then - res - else - fail Invalid_parent_interface) in + let itfs = + Array.init + (itf_count :> int) + (fun _ -> + let res = InputStream.read_u2 st in + if ConstantPool.check_entry_for_kind cpool res ConstantPool.CONSTANT_Class then + res + else + fail Invalid_parent_interface) in hunk ./src/classfile/classFile.mli 20 - Class file instances are low-level Java class definitions, - high-level definitions being provided by [ClassDefinition.t] instances. *) + Class file instances are low-level Java class definitions, + high-level definitions being provided by [ClassDefinition.t] + instances. *) hunk ./src/classfile/classFile.mli 32 - constant_pool : ConstantPool.element array; + constant_pool : ConstantPool.t; hunk ./src/classfile/classFile.mli 46 - defined in Sun's Java specification. {i x_count} fields are redundant as - they represent the length of {i x} fields but are nevertheless kept to - ensure that is structure is as close as possible from the Sun - specification. + defined in Sun's Java specification. {i x_count} fields are redundant + as they represent the length of {i x} fields but are nevertheless + kept to ensure that this structure is as close as possible from the + Java specification. hunk ./src/classfile/classFile.mli 51 - The only slight difference related to the constant pool. As constant pool is - indexed from {i 1} to {i size - 1}, it has thus been decided to create an - array of size [size] and to put a dummy value at index 0 (this dummy value - is also used for the auxiliary index of the elements (double and long ones) - that use two indexes in the constant pool). *) + The only slight difference is related to the constant pool. + As a constant pool is indexed from {i 1} to {i size - 1}, it has thus + been decided to create an array of size [size] and to put a dummy + value at index 0 (this dummy value is also used for the auxiliary + index of the elements (double and long ones) that use two indexes in + the constant pool). *) hunk ./src/classfile/classFile.mli 62 - | Invalid_magic_number + | Invalid_magic_number of Utils.u4 hunk ./src/classfile/classFile.mli 80 - Raises [Exception] if the read structure is not a valid class file. - Raises [InputStream.Exception] if an i/o error occurs. - Raises [ConstantPool.Exception] if the underlying constant pool is not - consistent. *) + Raises [Exception] if the read structure is not a valid class file. + Raises [InputStream.Exception] if an i/o error occurs. + Raises [ConstantPool.Exception] if the underlying constant pool is + not consistent. *) hunk ./src/classfile/classFile.mli 87 - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/constantPool.ml 61 - | Invalid_tag - | Too_large + | Invalid_tag of u1 + | Too_large of int hunk ./src/classfile/constantPool.ml 64 - | Reference_out_of_bounds - | Dummy_access - | Malformed_Class_entry - | Malformed_Fieldref_entry - | Malformed_Methodref_entry - | Malformed_InterfaceMethodRef_entry - | Malformed_String_entry - | Malformed_NameAndType_entry - | Malformed_ModuleId_entry + | Reference_out_of_bounds of int * int + | Dummy_access of u2 + | Malformed_Class_entry of u2 + | Malformed_Fieldref_entry of u2 * u2 + | Malformed_Methodref_entry of u2 * u2 + | Malformed_InterfaceMethodRef_entry of u2 * u2 + | Malformed_String_entry of u2 + | Malformed_NameAndType_entry of u2 * u2 + | Malformed_ModuleId_entry of u2 * u2 hunk ./src/classfile/constantPool.ml 80 - | Invalid_tag -> "invalid constant pool tag" - | Too_large -> "constant pool is too large" - | Invalid_reference -> "invalid constant pool reference (0)" - | Reference_out_of_bounds -> "invalid constant pool reference (out of bounds)" - | Dummy_access -> "access to dummy element" - | Malformed_Class_entry -> "malformed Class entry" - | Malformed_Fieldref_entry -> "malformed Fieldref entry" - | Malformed_Methodref_entry -> "malformed Methodref entry" - | Malformed_InterfaceMethodRef_entry -> "malformed InterfaceMethodref entry" - | Malformed_String_entry -> "malformed String entry" - | Malformed_NameAndType_entry -> "malformed NameAndType entry" - | Malformed_ModuleId_entry -> "malformed ModuleId entry" + | Invalid_tag x -> + Printf.sprintf "invalid constant pool tag (%d)" (x :> int) + | Too_large x -> + Printf.sprintf "constant pool is too large (%d)" x + | Invalid_reference -> + "invalid constant pool reference (0)" + | Reference_out_of_bounds (idx, sz) -> + Printf.sprintf "constant pool reference out of bounds (index %d, length %d)" idx sz + | Dummy_access x -> + Printf.sprintf "access to dummy element (index %d)" (x :> int) + | Malformed_Class_entry x -> + Printf.sprintf "malformed Class entry (index %d)" (x :> int) + | Malformed_Fieldref_entry (x, y) -> + Printf.sprintf "malformed Fieldref entry (indexes %d and %d)" (x :> int) (y :> int) + | Malformed_Methodref_entry (x, y) -> + Printf.sprintf "malformed Methodref entry (indexes %d and %d)" (x :> int) (y :> int) + | Malformed_InterfaceMethodRef_entry (x, y) -> + Printf.sprintf "malformed InterfaceMethodref entry (indexes %d and %d)" (x :> int) (y :> int) + | Malformed_String_entry x -> + Printf.sprintf "malformed String entry (index %d)" (x :> int) + | Malformed_NameAndType_entry (x, y) -> + Printf.sprintf "malformed NameAndType entry (indexes %d and %d)" (x :> int) (y :> int) + | Malformed_ModuleId_entry (x, y) -> + Printf.sprintf "malformed ModuleId entry (indexes %d and %d)" (x :> int) (y :> int) hunk ./src/classfile/constantPool.ml 159 - | _ -> fail Invalid_tag + | x -> fail (Invalid_tag (u1 x)) hunk ./src/classfile/constantPool.ml 210 - if (sz >= 0) && (sz < 65536) then + if (sz >= 0) && (sz <= max_u2) then hunk ./src/classfile/constantPool.ml 220 - fail Too_large + fail (Too_large sz) hunk ./src/classfile/constantPool.ml 272 - if Array.length pool < 65536 then + let len = Array.length pool in + if len <= max_u2 then hunk ./src/classfile/constantPool.ml 276 - fail Too_large + fail (Too_large len) hunk ./src/classfile/constantPool.ml 281 +let size pool = + u2 (Array.length pool) + hunk ./src/classfile/constantPool.ml 289 - fail Reference_out_of_bounds + fail (Reference_out_of_bounds (i, Array.length pool)) hunk ./src/classfile/constantPool.ml 293 - fail Dummy_access + fail (Dummy_access (u2 i)) hunk ./src/classfile/constantPool.ml 303 - | _ -> fail Malformed_Class_entry) + | _ -> fail (Malformed_Class_entry name_index)) hunk ./src/classfile/constantPool.ml 307 - | _ -> fail Malformed_Fieldref_entry) + | _ -> fail (Malformed_Fieldref_entry (class_index, name_and_type_index))) hunk ./src/classfile/constantPool.ml 311 - | _ -> fail Malformed_Methodref_entry) + | _ -> fail (Malformed_Methodref_entry (class_index, name_and_type_index))) hunk ./src/classfile/constantPool.ml 315 - | _ -> fail Malformed_InterfaceMethodRef_entry) + | _ -> fail (Malformed_InterfaceMethodRef_entry (class_index, name_and_type_index))) hunk ./src/classfile/constantPool.ml 319 - | _ -> fail Malformed_String_entry) + | _ -> fail (Malformed_String_entry value_index)) hunk ./src/classfile/constantPool.ml 327 - | _ -> fail Malformed_NameAndType_entry) + | _ -> fail (Malformed_NameAndType_entry (name_index, desc_index))) hunk ./src/classfile/constantPool.ml 332 - | _ -> fail Malformed_ModuleId_entry) in + | _ -> fail (Malformed_ModuleId_entry (name_index, vers_index))) in hunk ./src/classfile/constantPool.ml 335 +let check_entry_for_kind cpool idx tag = + try + match tag, (get_entry cpool idx) with + | CONSTANT_Class, Class _ + | CONSTANT_Fieldref, Fieldref _ + | CONSTANT_Methodref, Methodref _ + | CONSTANT_InterfaceMethodref, InterfaceMethodref _ + | CONSTANT_String, String _ + | CONSTANT_Integer, Integer _ + | CONSTANT_Float, Float _ + | CONSTANT_Long, Long _ + | CONSTANT_Double, Double _ + | CONSTANT_NameAndType, NameAndType _ + | CONSTANT_Utf8, UTF8 _ -> true + | _ -> false + with _ -> false + hunk ./src/classfile/constantPool.ml 367 - while (!size < 65536) && (!size < len) do + while (!size <= max_u2) && (!size < len) do hunk ./src/classfile/constantPool.ml 370 - let size' = min 65535 !size in + let size' = min max_u2 !size in hunk ./src/classfile/constantPool.ml 372 - { current = Array.init size' (fun i -> if i < len then pool.(i) else dummy_element) ; + { current = + Array.init + size' + (fun i -> if i < len then pool.(i) else dummy_element); hunk ./src/classfile/constantPool.ml 378 - fail Too_large + fail (Too_large len) hunk ./src/classfile/constantPool.ml 381 + let i = (i : u2 :> int) in hunk ./src/classfile/constantPool.ml 385 - fail Reference_out_of_bounds + fail (Reference_out_of_bounds (i, pool.next)) hunk ./src/classfile/constantPool.ml 389 - fail Dummy_access + fail (Dummy_access (u2 i)) hunk ./src/classfile/constantPool.ml 402 - if len >= 65535 then fail Too_large; - let new_array = Array.init - (min 65535 (2 * len)) + if len >= max_u2 then fail (Too_large len); + let new_array = + Array.init + (min max_u2 (2 * len)) hunk ./src/classfile/constantPool.ml 446 - let name_index = add_utf8 ext (Descriptor.utf8_of_java_type (d :> Descriptor.java_type)) in + let name_index = add_utf8 ext (Descriptor.internal_utf8_of_java_type (d :> Descriptor.java_type)) in hunk ./src/classfile/constantPool.ml 517 + assert (ext.next <= (max_u2 + 1)); hunk ./src/classfile/constantPool.mli 51 - entries. *) + entries. *) hunk ./src/classfile/constantPool.mli 68 -type t = element array +type t hunk ./src/classfile/constantPool.mli 75 - | Invalid_tag - | Too_large + | Invalid_tag of Utils.u1 + | Too_large of int hunk ./src/classfile/constantPool.mli 78 - | Reference_out_of_bounds - | Dummy_access - | Malformed_Class_entry - | Malformed_Fieldref_entry - | Malformed_Methodref_entry - | Malformed_InterfaceMethodRef_entry - | Malformed_String_entry - | Malformed_NameAndType_entry - | Malformed_ModuleId_entry + | Reference_out_of_bounds of int * int + | Dummy_access of Utils.u2 + | Malformed_Class_entry of Utils.u2 + | Malformed_Fieldref_entry of Utils.u2 * Utils.u2 + | Malformed_Methodref_entry of Utils.u2 * Utils.u2 + | Malformed_InterfaceMethodRef_entry of Utils.u2 * Utils.u2 + | Malformed_String_entry of Utils.u2 + | Malformed_NameAndType_entry of Utils.u2 * Utils.u2 + | Malformed_ModuleId_entry of Utils.u2 * Utils.u2 hunk ./src/classfile/constantPool.mli 106 - Raises [Exception] if stream does not contain [sz] valid pool elements, - or if [(sz >= 65536) || (sz < 0)]. *) + Raises [Exception] if stream does not contain [sz] valid pool + elements, or if [(sz >= 65536) || (sz < 0)]. *) hunk ./src/classfile/constantPool.mli 114 -(* [write pool st] writes [pool] elements onto stream; size is not written. - Dummy values are not written. +(* [write pool st] writes [pool] elements onto stream; size is not + written. Dummy values are not written. hunk ./src/classfile/constantPool.mli 122 +val size : t -> Utils.u2 +(** Returns the size of the passed pool. *) + hunk ./src/classfile/constantPool.mli 126 -(** [get_entry pool index] returns the entry at [index] in [pool] if [index] is - valid, raising [Exception] otherwise. - Raises [Exception] if an attempt is made to get a dummy element. *) +(** [get_entry pool index] returns the entry at [index] in [pool] if + [index] is valid, raising [Exception] otherwise. + Raises [Exception] if an attempt is made to get a dummy element. *) hunk ./src/classfile/constantPool.mli 132 - Raises [Exception] if pool is not consistent. *) + Raises [Exception] if pool is not consistent. *) + +val check_entry_for_kind : t -> Utils.u2 -> tag -> bool +(** [check_entry_for_kind pool index tag] tests whether the entry at + [index] is of the kind designated by [tag]. *) hunk ./src/classfile/constantPool.mli 143 - definitions to class files. *) + definitions to class files. The [add_xyz] functions below provide + maximum sharing of constant pool elements. *) hunk ./src/classfile/constantPool.mli 151 - Raises [Exception] if the passed pool is too large. *) + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 153 -val get_extendable_entry : extendable -> int -> element -(** [get_extendable_entry pool index] returns the entry at [index] in [pool] - if [index] is valid, raising [Exception] otherwise. - Raises [Exception] if an attempt is made to get a dummy element. *) +val get_extendable_entry : extendable -> Utils.u2 -> element +(** [get_extendable_entry pool index] returns the entry at [index] in + [pool] if [index] is valid, raising [Exception] otherwise. + Raises [Exception] if an attempt is made to get a dummy element. *) hunk ./src/classfile/constantPool.mli 160 - [class_name]. Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + [class_name]. Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 164 -(** [add_array_class pool array_type] augments [pool] with array type whose - descriptor is [array_type]. Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) +(** [add_array_class pool array_type] augments [pool] with array type + whose descriptor is [array_type]. Returns index of existing or + created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 170 -(** [add_field pool class_name field_name field_type] augments [pool] with - field [field_name] of type [field_type] in class [class_name]. - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) +(** [add_field pool class_name field_name field_type] augments [pool] + with field [field_name] of type [field_type] in class [class_name]. + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 176 -(** [add_method pool class_name method_name method_type] augments [pool] with - method [method_name] of type [method_type] in class [class_name]. - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) +(** [add_method pool class_name method_name method_type] augments [pool] + with method [method_name] of type [method_type] in class [class_name]. + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 183 - [pool] with interface method [method_name] of type [method_type] in interface - [interface_name]. - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + [pool] with interface method [method_name] of type [method_type] in + interface [interface_name]. + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 189 -(** [add_array_method pool array_type method_name method_type] augments [pool] with - array method [method_name] of type [method_type] in array type [array_type]. - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) +(** [add_array_method pool array_type method_name method_type] augments + [pool] with array method [method_name] of type [method_type] in array + type [array_type]. + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 197 - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 202 - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 207 - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 212 - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 217 - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 221 -(** [add_name_and_type pool n t] augments [pool] with mane [n] and type [t]. - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) +(** [add_name_and_type pool n t] augments [pool] with mane [n] and type + [t]. + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 228 - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/constantPool.mli 232 -(** [add_moduleid pool n v] augments [pool] with name [n] and version [v]. - Returns index of existing or created entry. - Raises [Exception] if the passed pool is too large. *) +(** [add_moduleid pool n v] augments [pool] with name [n] and version + [v]. + Returns index of existing or created entry. + Raises [Exception] if the passed pool is too large. *) hunk ./src/classfile/descriptor.ml 36 - | `Array of 'a ] constraint 'a = [ `Boolean - | `Byte - | `Char - | `Double - | `Float - | `Int - | `Long - | `Short - | `Class of Name.for_class - | `Array of 'a ] + | `Array of 'a ] constraint 'a = non_void_java_type +and non_void_java_type = + [ `Boolean + | `Byte + | `Char + | `Double + | `Float + | `Int + | `Long + | `Short + | `Class of Name.for_class + | `Array of 'a ] constraint 'a = non_void_java_type hunk ./src/classfile/descriptor.ml 127 -let filter_array err = function +let filter_non_array err = function hunk ./src/classfile/descriptor.ml 145 - if UChar.equal ch capital_z then - (`Boolean, succ idx) - else if UChar.equal ch capital_b then - (`Byte, succ idx) - else if UChar.equal ch capital_c then - (`Char, succ idx) - else if UChar.equal ch capital_d then - (`Double, succ idx) - else if UChar.equal ch capital_f then - (`Float, succ idx) - else if UChar.equal ch capital_i then - (`Int, succ idx) - else if UChar.equal ch capital_j then - (`Long, succ idx) - else if UChar.equal ch capital_s then - (`Short, succ idx) - else if UChar.equal ch capital_v then - (`Void, succ idx) - else if UChar.equal ch capital_l then - try - let index = UTF8.index_from str (succ idx) semi_colon in - let name = (Name.make_for_class_from_internal (UTF8.substring str (succ idx) (pred index))) in - (`Class name, index + 1) - with - | Not_found - | Name.Exception _ -> fail Invalid_class_name - else if UChar.equal ch opening_square_bracket then - if n < 255 then - let t, res = jtopu (succ n) (succ idx) in - (`Array (filter_void Invalid_array_element_type t), res) - else - fail Array_with_too_many_dimensions - else - fail Invalid_descriptor_string + switch + UChar.equal + [ capital_z, + (fun _ -> `Boolean, succ idx); + + capital_b, + (fun _ -> `Byte, succ idx); + + capital_c, + (fun _ -> `Char, succ idx); + + capital_d, + (fun _ -> `Double, succ idx); + + capital_f, + (fun _ -> `Float, succ idx); + + capital_i, + (fun _ -> `Int, succ idx); + + capital_j, + (fun _ -> `Long, succ idx); + + capital_s, + (fun _ -> `Short, succ idx); + + capital_v, + (fun _ -> `Void, succ idx); + + capital_l, + (fun _ -> + try + let index = UTF8.index_from str (succ idx) semi_colon in + let name = (Name.make_for_class_from_internal (UTF8.substring str (succ idx) (pred index))) in + (`Class name, index + 1) + with + | Not_found + | Name.Exception _ -> fail Invalid_class_name); + + opening_square_bracket, + (fun _ -> + if n < 255 then + let t, res = jtopu (succ n) (succ idx) in + (`Array (filter_void Invalid_array_element_type t), res) + else + fail Array_with_too_many_dimensions) ] + (fun _ -> fail Invalid_descriptor_string) + ch hunk ./src/classfile/descriptor.ml 197 -let java_type_of_utf8 s = +let java_type_of_internal_utf8 s = hunk ./src/classfile/descriptor.ml 204 -let utf8_of_java_type = +let internal_utf8_of_java_type = hunk ./src/classfile/descriptor.ml 226 -let rec eq_java_type x y = +let rec external_utf8_of_java_type = function + | `Boolean -> UTF8.of_string "boolean" + | `Byte -> UTF8.of_string "byte" + | `Char -> UTF8.of_string "char" + | `Double -> UTF8.of_string "double" + | `Float -> UTF8.of_string "float" + | `Int -> UTF8.of_string "int" + | `Long -> UTF8.of_string "long" + | `Short -> UTF8.of_string "short" + | `Void -> UTF8.of_string "void" + | `Class n -> Name.printable_utf8_for_class n + | `Array jt -> (external_utf8_of_java_type (jt :> java_type)) ++ (UTF8.of_string "[]") + +let java_type_of_external_utf8 s = + let rec make_array n x = + if n = 0 then + x + else + `Array (make_array (pred n) x) in + let l = UTF8.length s in + let i = ref 0 in + while !i < l && ((UChar.is_letter_or_digit (UTF8.get s !i)) + || (UChar.equal dot (UTF8.get s !i)) + || (UChar.equal opening_square_bracket (UTF8.get s !i)) + || (UChar.equal closing_square_bracket (UTF8.get s !i))) do + incr i + done; + if !i = l && UChar.is_letter (UTF8.get s 0) then + let j = ref (pred l) in + let dims = ref 0 in + while (!j - 1 >= 0) + && (UChar.equal closing_square_bracket (UTF8.get s !j)) + && (UChar.equal opening_square_bracket (UTF8.get s (!j - 1))) do + incr dims; + decr j; + decr j + done; + if !dims > 255 then fail Array_with_too_many_dimensions; + let prefix = UTF8.substring s 0 !j in + let base = match (try UTF8.to_string prefix with _ -> "") with + | "boolean" -> `Boolean + | "byte" -> `Byte + | "char" -> `Char + | "double" -> `Double + | "float" -> `Float + | "int" -> `Int + | "long" -> `Long + | "short" -> `Short + | "void" -> `Void + | _ -> `Class (Name.make_for_class_from_external prefix) in + if !dims = 0 then + base + else + let array = make_array !dims (filter_void Invalid_array_element_type base) in + (array :> java_type) + else + fail Invalid_descriptor_string + +let rec equal_java_type x y = hunk ./src/classfile/descriptor.ml 295 - | (`Class cn1), (`Class cn2) -> Name.eq_for_class cn1 cn2 - | (`Array a1), (`Array a2) -> eq_java_type (a1 :> java_type) (a2 :> java_type) + | (`Class cn1), (`Class cn2) -> Name.equal_for_class cn1 cn2 + | (`Array a1), (`Array a2) -> equal_java_type (a1 :> java_type) (a2 :> java_type) hunk ./src/classfile/descriptor.ml 302 -type for_field = - [ `Boolean - | `Byte - | `Char - | `Double - | `Float - | `Int - | `Long - | `Short - | `Class of Name.for_class - | `Array of 'a ] constraint 'a = [ `Boolean - | `Byte - | `Char - | `Double - | `Float - | `Int - | `Long - | `Short - | `Class of Name.for_class - | `Array of 'a ] +type for_field = non_void_java_type hunk ./src/classfile/descriptor.ml 305 - let t = java_type_of_utf8 str in + let t = java_type_of_internal_utf8 str in hunk ./src/classfile/descriptor.ml 309 - utf8_of_java_type (fd :> java_type) + internal_utf8_of_java_type (fd :> java_type) + +let java_type_of_external_utf8_no_void s = + let res = java_type_of_external_utf8 s in + filter_void Void_not_allowed res hunk ./src/classfile/descriptor.ml 315 -let eq_for_field x y = - eq_java_type (x :> java_type) (y :> java_type) +let equal_for_field x y = + equal_java_type (x :> java_type) (y :> java_type) hunk ./src/classfile/descriptor.ml 321 -type for_parameter = for_field +type for_parameter = non_void_java_type hunk ./src/classfile/descriptor.ml 327 -let eq_for_parameter = eq_for_field +let equal_for_parameter = equal_for_field hunk ./src/classfile/descriptor.ml 357 - ++ (utf8_of_java_type return) + ++ (internal_utf8_of_java_type return) hunk ./src/classfile/descriptor.ml 359 -let eq_for_method (xp, xr) (yp, yr) = - ((List.length xp) = (List.length yp)) && (List.for_all2 eq_for_parameter xp yp) - && (eq_java_type xr yr) +let equal_for_method (xp, xr) (yp, yr) = + (list_equal xp yp) + && (equal_java_type xr yr) + +let compare_for_method md1 md2 = + let p1, r1 = md1 in + let p2, r2 = md2 in + let cmp = compare (List.length p1) (List.length p2) in + if cmp <> 0 then + cmp + else + let cmp' = compare (utf8_of_method md1) (utf8_of_method md2) in + if cmp' <> 0 then + cmp' + else + compare (internal_utf8_of_java_type r1) (internal_utf8_of_java_type r2) hunk ./src/classfile/descriptor.mli 19 -(** This module provides some utility functions related to descriptor handling. *) +(** Definition and utility functions related to descriptor handling. *) hunk ./src/classfile/descriptor.mli 35 - | `Array of 'a ] constraint 'a = [ `Boolean - | `Byte - | `Char - | `Double - | `Float - | `Int - | `Long - | `Short - | `Class of Name.for_class - | `Array of 'a ] + | `Array of 'a ] constraint 'a = non_void_java_type +and non_void_java_type = + [ `Boolean + | `Byte + | `Char + | `Double + | `Float + | `Int + | `Long + | `Short + | `Class of Name.for_class + | `Array of 'a ] constraint 'a = non_void_java_type hunk ./src/classfile/descriptor.mli 89 -val filter_void : error -> java_type -> ([ `Boolean | `Byte | `Char | `Double | `Float | `Int | `Long | `Short | `Class of Name.for_class | `Array of 'a ] as 'a) -(** [filter_void err jt] returns [jt] if it is not equal to [`Void]. Otherwise, - [Exception] is raised with [err] as a parameter. *) +val filter_void : error -> java_type -> non_void_java_type +(** [filter_void err jt] returns [jt] if it is not equal to [`Void]. + Otherwise, [Exception] is raised with [err] as a parameter. *) + +val filter_non_array : error -> java_type -> array_type +(** [filter_non_array err jt] returns [jt] if it is an array. + Otherwise, [Exception] is raised with [err] as a parameter. *) + +val java_type_of_internal_utf8 : Utils.UTF8.t -> java_type +(** Converts a string (as used in class file) into the corresponding Java + type. + Raises [Exception] if conversion fails. *) hunk ./src/classfile/descriptor.mli 102 -val filter_array : error -> java_type -> array_type -(** [filter_array err jt] returns [jt] if it is an array. - Otherwise, [Exception] is raised with [err] as a parameter. *) +val internal_utf8_of_java_type : java_type -> Utils.UTF8.t +(** Converts a Java type into the corresponding string (as used in class + file). + Raises [Exception] if conversion fails. *) hunk ./src/classfile/descriptor.mli 107 -val java_type_of_utf8 : Utils.UTF8.t -> java_type -(** Converts a string (as used in class file) into the corresponding Java type. - Raises [Exception] if conversion fails. *) +val external_utf8_of_java_type : java_type -> Utils.UTF8.t +(** Returns the textual representation of the passed Java type. *) hunk ./src/classfile/descriptor.mli 110 -val utf8_of_java_type : java_type -> Utils.UTF8.t -(** Converts a Java type into the corresponding string (as used in class file). - Raises [Exception] if conversion fails. *) +val java_type_of_external_utf8 : Utils.UTF8.t -> java_type +(** Returns the Java type corresponding to the passed string. + Raises [Exception] if the string does not represent a Java type. + Also Raises [Exception] if the type is invalid. *) hunk ./src/classfile/descriptor.mli 115 -val eq_java_type : java_type -> java_type -> bool +val equal_java_type : java_type -> java_type -> bool hunk ./src/classfile/descriptor.mli 121 -type for_field = - [ `Boolean - | `Byte - | `Char - | `Double - | `Float - | `Int - | `Long - | `Short - | `Class of Name.for_class - | `Array of 'a ] constraint 'a = [ `Boolean - | `Byte - | `Char - | `Double - | `Float - | `Int - | `Long - | `Short - | `Class of Name.for_class - | `Array of 'a ] +type for_field = non_void_java_type hunk ./src/classfile/descriptor.mli 126 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/descriptor.mli 130 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/descriptor.mli 132 -val eq_for_field : for_field -> for_field -> bool +val java_type_of_external_utf8_no_void : Utils.UTF8.t -> for_field +(** Same as [java_type_of_external_utf8] but raises [Exception] + if the decoded type is equal to the Java type {i void}. *) + +val equal_for_field : for_field -> for_field -> bool hunk ./src/classfile/descriptor.mli 142 -type for_parameter = for_field +type for_parameter = non_void_java_type hunk ./src/classfile/descriptor.mli 144 - increased readability. *) + increased readability. *) hunk ./src/classfile/descriptor.mli 146 -val parameter_of_utf8 : Utils.UTF8.t -> for_field +val parameter_of_utf8 : Utils.UTF8.t -> for_parameter hunk ./src/classfile/descriptor.mli 149 -val utf8_of_parameter : for_field -> Utils.UTF8.t +val utf8_of_parameter : for_parameter -> Utils.UTF8.t hunk ./src/classfile/descriptor.mli 152 -val eq_for_parameter : for_parameter -> for_parameter -> bool +val equal_for_parameter : for_parameter -> for_parameter -> bool hunk ./src/classfile/descriptor.mli 157 - parameters while second component is the return type. *) + parameters while second component is the return type. *) hunk ./src/classfile/descriptor.mli 161 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/descriptor.mli 165 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/descriptor.mli 167 -val eq_for_method : for_method -> for_method -> bool +val equal_for_method : for_method -> for_method -> bool hunk ./src/classfile/descriptor.mli 169 + +val compare_for_method : for_method -> for_method -> int +(** Comparison over method descriptors. *) hunk ./src/classfile/field.ml 29 - attributes : Attribute.info array; + attributes_array : Attribute.info array; hunk ./src/classfile/field.ml 36 - | Invalid_name - | Invalid_name_value - | Invalid_descriptor_value + | Invalid_name of UTF8.t + | Invalid_name_value of u2 + | Invalid_descriptor_value of u2 hunk ./src/classfile/field.ml 45 - | Invalid_name -> "invalid name" - | Invalid_name_value -> "invalid name value" - | Invalid_descriptor_value -> "invalid descriptor value" + | Invalid_name n -> + Printf.sprintf "invalid name %S" (UTF8.to_string_noerr n) + | Invalid_name_value i -> + Printf.sprintf "invalid name value (at index %d)" (i :> int) + | Invalid_descriptor_value i -> + Printf.sprintf "invalid descriptor value (at index %d)" (i :> int) hunk ./src/classfile/field.ml 66 - let atts = Array.init (att_count :> int) (fun _ -> Attribute.read_info st) in + let atts = + Array.init + (att_count :> int) + (fun _ -> Attribute.read_info st) in hunk ./src/classfile/field.ml 74 - attributes = atts; } + attributes_array = atts; } hunk ./src/classfile/field.ml 81 - Array.iter (Attribute.write_info st) i.attributes + Array.iter (Attribute.write_info st) i.attributes_array hunk ./src/classfile/field.ml 86 -type t = (AccessFlag.for_field list) * Name.for_field * Descriptor.for_field * (Attribute.for_field list) +type t = { + flags : AccessFlag.for_field list; + name : Name.for_field; + descriptor : Descriptor.for_field; + attributes : Attribute.for_field list; + } hunk ./src/classfile/field.ml 97 - let flags = AccessFlag.check_field_flags itf (AccessFlag.from_u2 false i.access_flags) in + let flags = + AccessFlag.check_field_flags + itf + (AccessFlag.from_u2 false i.access_flags) in hunk ./src/classfile/field.ml 106 - fail Invalid_name - | _ -> fail Invalid_name_value in + fail (Invalid_name n) + | _ -> fail (Invalid_name_value i.name_index) in hunk ./src/classfile/field.ml 110 - | _ -> fail Invalid_descriptor_value in - let attrs = List.map (Attribute.decode Attribute.Field pool) (Array.to_list i.attributes) in - (flags, (Name.make_for_field name), desc, (Attribute.check_field_attributes attrs)) + | _ -> fail (Invalid_descriptor_value i.descriptor_index) in + let attrs = map_array_to_list (Attribute.decode Attribute.Field pool) i.attributes_array in + { flags = flags; + name = Name.make_for_field name; + descriptor = desc; + attributes = Attribute.check_field_attributes attrs; } hunk ./src/classfile/field.ml 118 - let flags, name, desc, attrs = f in - let acc_flags = AccessFlag.list_to_u2 (flags :> AccessFlag.t list) in - let name_idx = ConstantPool.add_utf8 pool (Name.utf8_for_field name) in - let desc_utf8 = Descriptor.utf8_of_field desc in + let acc_flags = AccessFlag.list_to_u2 (f.flags :> AccessFlag.t list) in + let name_idx = ConstantPool.add_utf8 pool (Name.utf8_for_field f.name) in + let desc_utf8 = Descriptor.utf8_of_field f.descriptor in hunk ./src/classfile/field.ml 125 - attributes_count = u2 (List.length attrs); - attributes = Array.of_list (List.map (Attribute.encode pool) (attrs :> Attribute.t list)); } + attributes_count = u2 (List.length f.attributes); + attributes_array = + map_list_to_array + (Attribute.encode pool) + (f.attributes :> Attribute.t list); } + +let compare x y = + let cmp = + AccessFlag.list_compare + (x.flags :> AccessFlag.t list) + (y.flags :> AccessFlag.t list) in + if cmp <> 0 then + cmp + else + let cmp2 = + UTF8.compare + (Name.utf8_for_field x.name) + (Name.utf8_for_field y.name) in + if cmp2 <> 0 then + cmp2 + else + Pervasives.compare x y hunk ./src/classfile/field.mli 19 -(** This module defines fields in both low- and high-level forms. - It also provides conversion functions between levels as well as i/o - functions for low-level. *) +(** Fields in both low- and high-level forms. + + It also provides conversion functions between levels as well as i/o + functions for low-level. *) hunk ./src/classfile/field.mli 32 - attributes : Attribute.info array; + attributes_array : Attribute.info array; hunk ./src/classfile/field.mli 40 - | Invalid_name - | Invalid_name_value - | Invalid_descriptor_value + | Invalid_name of Utils.UTF8.t + | Invalid_name_value of Utils.u2 + | Invalid_descriptor_value of Utils.u2 hunk ./src/classfile/field.mli 55 - Raises [InputStream.Exception] if an i/o error occurs. *) + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/field.mli 59 - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/field.mli 64 -type t = (AccessFlag.for_field list) * Name.for_field * Descriptor.for_field * (Attribute.for_field list) -(** Represents a field as a list of flags, a name, a descriptor and a list of - attributes. *) +type t = { + flags : AccessFlag.for_field list; + name : Name.for_field; + descriptor : Descriptor.for_field; + attributes : Attribute.for_field list; + } +(** Represents a field as defined in the Java language. *) hunk ./src/classfile/field.mli 76 -(** Converts from a low-level into a high-level form according to passed pool. - The passed boolean indicates whether the enclosing element is an interface. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a low-level into a high-level form according to passed + pool. The passed boolean indicates whether the enclosing element is + an interface. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/field.mli 82 -(** Converts from a high-level into a low-level form, using passed extendable - pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a high-level into a low-level form, using passed + extendable pool. + Raises [Exception] if an error occurs during conversion. *) + +val compare : t -> t -> int +(** Comparison over fields. *) hunk ./src/classfile/instruction.ml 311 - let cpool_len = Array.length cpool in hunk ./src/classfile/instruction.ml 312 - let idx = (idx : u2 :> int) in - if (idx > 0) && (idx < cpool_len) then - cpool.(idx) - else - fail Invalid_pool_index in + try + ConstantPool.get_entry cpool idx + with _ -> fail Invalid_pool_index in hunk ./src/classfile/instruction.ml 321 - let t = Descriptor.java_type_of_utf8 v in `Array_type (Descriptor.filter_array Descriptor.Invalid_array_element_type t) + let t = Descriptor.java_type_of_internal_utf8 v in `Array_type (Descriptor.filter_non_array Descriptor.Invalid_array_element_type t) hunk ./src/classfile/instruction.ml 346 - `Array_type (Descriptor.filter_array Descriptor.Invalid_array_element_type (Descriptor.java_type_of_utf8 s))), + `Array_type (Descriptor.filter_non_array Descriptor.Invalid_array_element_type (Descriptor.java_type_of_internal_utf8 s))), hunk ./src/classfile/instruction.mli 19 -(** This module defines instructions as well as conversion from/to bytecode and compilation/decompilation functions. - Instructions are high-level code elements, - low-level elements being provided by [ByteCode] module. *) +(** Definition of instructions as well as conversion from/to bytecode and + compilation/decompilation functions. + + Instructions are high-level code elements, + low-level elements being provided by [ByteCode] module. *) hunk ./src/classfile/instruction.mli 292 - Raise [Exception] if an instruction parameter is invalid. - Raise [ConstantPool.Exception] if a constant pool index is invalid. - Raise [Exception] if constant pool is invalid. *) + Raise [Exception] if an instruction parameter is invalid. + Raise [ConstantPool.Exception] if a constant pool index is invalid. + Raise [Exception] if constant pool is invalid. *) hunk ./src/classfile/instruction.mli 298 - Raise [ConstantPool.Exception] if constant pool is too large. - Raise [Exception] if an instruction parameter is invalid. *) + Raise [ConstantPool.Exception] if constant pool is too large. + Raise [Exception] if an instruction parameter is invalid. *) hunk ./src/classfile/instruction.mli 325 -(** [compile ofs wide mnemo params param_tail] compiles instruction whose mnemonic - is [mnemo], [params] and [param_tail] being parameters while [wide] indicates - whether the wide version of the instruction should be compiled. - [ofs] is the compilation offset; the returned couple consists of instruction size - and compiled instruction. - Raises [Exception] if instruction does not exist or is passed invalid parameters. *) +(** [compile ofs wide mnemo params param_tail] compiles instruction whose + mnemonic is [mnemo], [params] and [param_tail] being parameters while + [wide] indicates whether the wide version of the instruction should + be compiled. [ofs] is the compilation offset; the returned couple + consists of instruction size and compiled instruction. + Raises [Exception] if instruction does not exist or is passed invalid + parameters. *) hunk ./src/classfile/instruction.mli 335 - Returns [(sz, wide, mnemo, p, t)] where: [sz] is instruction size, - [wide] indicates whether the instruction is a wide one, - [mnemo] is instruction mnemonic, and [p] and [t] are parameters. *) + Returns [(sz, wide, mnemo, p, t)] where: [sz] is instruction size, + [wide] indicates whether the instruction is a wide one, + [mnemo] is instruction mnemonic, and [p] and [t] are parameters. *) hunk ./src/classfile/instruction.mli 346 -(** [size_of_list ofs l] returns the size of instruction list [l] at offset [ofs]. *) +(** [size_of_list ofs l] returns the size of instruction list [l] at + offset [ofs]. *) hunk ./src/classfile/method.ml 30 - attributes : Attribute.info array; + attributes_array : Attribute.info array; hunk ./src/classfile/method.ml 37 - | Invalid_name - | Invalid_name_value - | Invalid_descriptor_value + | Invalid_name of Utils.UTF8.t + | Invalid_name_value of Utils.u2 + | Invalid_descriptor_value of Utils.u2 hunk ./src/classfile/method.ml 46 - | Invalid_name -> "invalid name" - | Invalid_name_value -> "invalid name value" - | Invalid_descriptor_value -> "invalid descriptor value" + | Invalid_name n -> + Printf.sprintf "invalid name %S" (UTF8.to_string_noerr n) + | Invalid_name_value i -> + Printf.sprintf "invalid name value (at index %d)" (i :> int) + | Invalid_descriptor_value i -> + Printf.sprintf "invalid descriptor value (at index %d)" (i :> int) hunk ./src/classfile/method.ml 67 - let atts = Array.init (att_count :> int) (fun _ -> Attribute.read_info st) in + let atts = + Array.init + (att_count :> int) + (fun _ -> Attribute.read_info st) in hunk ./src/classfile/method.ml 75 - attributes = atts; } + attributes_array = atts; } hunk ./src/classfile/method.ml 82 - Array.iter (Attribute.write_info st) i.attributes + Array.iter (Attribute.write_info st) i.attributes_array hunk ./src/classfile/method.ml 87 +type regular = { + flags : AccessFlag.for_method list; + name : Name.for_method; + descriptor : Descriptor.for_method; + attributes : Attribute.for_method list; + } + +type constructor = { + cstr_flags : AccessFlag.for_constructor list; + cstr_descriptor : Descriptor.for_parameter list; + cstr_attributes : Attribute.for_method list; + } + +type class_initializer = { + init_flags : AccessFlag.for_initializer list; + init_attributes : Attribute.for_method list; + } + hunk ./src/classfile/method.ml 106 - | Regular of (AccessFlag.for_method list) * Name.for_method * Descriptor.for_method * (Attribute.for_method list) - | Constructor of (AccessFlag.for_constructor list) * (Descriptor.for_parameter list) * (Attribute.for_method list) - | Initializer of bool * (Attribute.for_method list) + | Regular of regular + | Constructor of constructor + | Initializer of class_initializer hunk ./src/classfile/method.ml 119 - fail Invalid_name - | _ -> fail Invalid_name_value in - let desc = match ConstantPool.get_entry pool i.descriptor_index with + fail (Invalid_name n) + | _ -> fail (Invalid_name_value i.name_index) in + let descriptor = match ConstantPool.get_entry pool i.descriptor_index with hunk ./src/classfile/method.ml 123 - | _ -> fail Invalid_descriptor_value in - let attrs = Attribute.check_method_attributes (List.map (Attribute.decode Attribute.Method pool) (Array.to_list i.attributes)) in - if (UTF8.equal class_initializer name) then - let flags = AccessFlag.from_u2 true i.access_flags in - Initializer ((List.mem `Strict flags), attrs) - else if (UTF8.equal class_constructor name) then - let flags = AccessFlag.check_constructor_flags (AccessFlag.from_u2 true i.access_flags) in - Constructor (flags, (fst desc), attrs) - else - let flags = AccessFlag.check_method_flags itf (AccessFlag.from_u2 true i.access_flags) in - Regular (flags, (Name.make_for_method name), desc, attrs) + | _ -> fail (Invalid_descriptor_value i.descriptor_index) in + let attributes = + Attribute.check_method_attributes + (map_array_to_list + (Attribute.decode Attribute.Method pool) + i.attributes_array) in + switch + UTF8.equal + [ class_initializer, + (fun _ -> + let flags = + AccessFlag.check_initializer_flags (AccessFlag.from_u2 true i.access_flags) in + Initializer { init_flags = flags; init_attributes = attributes }); + + class_constructor, + (fun _ -> + let flags = + AccessFlag.check_constructor_flags (AccessFlag.from_u2 true i.access_flags) in + Constructor { cstr_flags = flags; cstr_descriptor = fst descriptor; cstr_attributes = attributes }) ] + (fun _ -> + let flags = + AccessFlag.check_method_flags itf (AccessFlag.from_u2 true i.access_flags) in + let name = Name.make_for_method name in + Regular { flags; name; descriptor; attributes }) + name hunk ./src/classfile/method.ml 151 - | Regular (f, n, d, a) -> (f, n, d, a) - | Constructor (f, d, a) -> ((f :> AccessFlag.for_method list), (Name.make_for_method class_constructor), (d, `Void), a) - | Initializer (s, a) -> ((if s then [`Strict ; `Static] else [`Static]), (Name.make_for_method class_initializer), ([], `Void), a) in + | Regular r -> + r.flags, + r.name, + r.descriptor, + r.attributes + | Constructor c -> + (c.cstr_flags :> AccessFlag.for_method list), + (Name.make_for_method class_constructor), + (c.cstr_descriptor, `Void), + c.cstr_attributes + | Initializer i -> + (i.init_flags :> AccessFlag.for_method list), + (Name.make_for_method class_initializer), + ([], `Void), + i.init_attributes in hunk ./src/classfile/method.ml 174 - attributes = Array.of_list (List.map (Attribute.encode pool) (attrs :> Attribute.t list)); } + attributes_array = map_list_to_array (Attribute.encode pool) (attrs :> Attribute.t list); } + +let compare m1 m2 = + let rank = function + | Regular _ -> 2 + | Constructor _ -> 1 + | Initializer _ -> 0 in + let r1 = rank m1 in + let r2 = rank m2 in + let cmp = compare r1 r2 in + if cmp <> 0 then + cmp + else + match m1, m2 with + | Regular { flags = fl1; name = n1; descriptor = d1; _ }, + Regular { flags = fl2; name = n2; descriptor = d2; _ } -> + let cmp' = + AccessFlag.list_compare + (fl1 :> AccessFlag.t list) + (fl2 :> AccessFlag.t list) in + if cmp' <> 0 then + cmp' + else + let cmp'' = UTF8.compare (Name.utf8_for_method n1) (Name.utf8_for_method n2) in + if cmp'' <> 0 then + cmp'' + else + Descriptor.compare_for_method d1 d2 + | Constructor { cstr_flags = fl1; cstr_descriptor = d1; _}, + Constructor { cstr_flags = fl2; cstr_descriptor = d2; _} -> + let cmp' = + AccessFlag.list_compare + (fl1 :> AccessFlag.t list) + (fl2 :> AccessFlag.t list) in + if cmp' <> 0 then + cmp' + else + Descriptor.compare_for_method (d1, `Void) (d2, `Void) + | _ -> compare m1 m2 hunk ./src/classfile/method.mli 19 -(** This module defines methods in both low- and high-level forms. - It also provides conversion functions between levels as well as i/o - functions for low-level. *) +(** Methods in both low- and high-level forms. + + It also provides conversion functions between levels as well as i/o + functions for low-level. *) hunk ./src/classfile/method.mli 32 - attributes : Attribute.info array; + attributes_array : Attribute.info array; hunk ./src/classfile/method.mli 40 - | Invalid_name - | Invalid_name_value - | Invalid_descriptor_value + | Invalid_name of Utils.UTF8.t + | Invalid_name_value of Utils.u2 + | Invalid_descriptor_value of Utils.u2 hunk ./src/classfile/method.mli 55 - Raises [InputStream.Exception] if an i/o error occurs. *) + Raises [InputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/method.mli 59 - Raises [OutputStream.Exception] if an i/o error occurs. *) + Raises [OutputStream.Exception] if an i/o error occurs. *) hunk ./src/classfile/method.mli 64 +type regular = { + flags : AccessFlag.for_method list; + name : Name.for_method; + descriptor : Descriptor.for_method; + attributes : Attribute.for_method list; + } +(** Represents a {i regular} (possibly static) method. *) + +type constructor = { + cstr_flags : AccessFlag.for_constructor list; + cstr_descriptor : Descriptor.for_parameter list; + cstr_attributes : Attribute.for_method list; + } +(** Represents an instance constructor method. *) + +type class_initializer = { + init_flags : AccessFlag.for_initializer list; + init_attributes : Attribute.for_method list; + } +(** Represents a class initializer method. *) + hunk ./src/classfile/method.mli 86 -| Regular of (AccessFlag.for_method list) * Name.for_method * Descriptor.for_method * (Attribute.for_method list) (** Regular method (flags, name, descriptor, and attributes). *) - | Constructor of (AccessFlag.for_constructor list) * (Descriptor.for_parameter list) * (Attribute.for_method list) (** Instance initializer (flags, descriptor, and attributes). *) - | Initializer of bool * (Attribute.for_method list) (** Class initializer (attributes, the boolean indicating whether the initializer is {i strictfp}). *) + | Regular of regular (** Regular method. *) + | Constructor of constructor (** Instance constructor. *) + | Initializer of class_initializer (** Class initializer. *) hunk ./src/classfile/method.mli 95 -(** Converts from a low-level into a high-level form according to passed pool. - The passed boolean indicates whether the enclosing element is an interface. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a low-level into a high-level form according to passed + pool. The passed boolean indicates whether the enclosing element is + an interface. + Raises [Exception] if an error occurs during conversion. *) hunk ./src/classfile/method.mli 101 -(** Converts from a high-level into a low-level form, using passed extendable - pool. - Raises [Exception] if an error occurs during conversion. *) +(** Converts from a high-level into a low-level form, using passed + extendable pool. + Raises [Exception] if an error occurs during conversion. *) + +val compare : t -> t -> int +(** Comparison over methods. *) hunk ./src/classfile/moduleDefinition.ml 78 - && cf.ClassFile.interfaces = [| |] + && cf.ClassFile.interfaces = [||] hunk ./src/classfile/moduleDefinition.ml 80 - && cf.ClassFile.fields = [| |] + && cf.ClassFile.fields = [||] hunk ./src/classfile/moduleDefinition.ml 82 - && cf.ClassFile.methods = [| |] then + && cf.ClassFile.methods = [||] then hunk ./src/classfile/moduleDefinition.ml 86 - (List.map - (fun x -> Attribute.decode Attribute.Package pool x) - (Array.to_list cf.ClassFile.attributes)); } + (map_array_to_list (Attribute.decode Attribute.Package pool) + cf.ClassFile.attributes); } hunk ./src/classfile/moduleDefinition.ml 91 -let encode ?(version=Version.Java_1_6) pd = +let encode ?(version=Version.default) pd = hunk ./src/classfile/moduleDefinition.ml 94 - if res < 65536 then + if res <= max_u2 then hunk ./src/classfile/moduleDefinition.ml 110 - let atts = Array.of_list (List.map (Attribute.encode pool) (pd.attributes :> Attribute.t list)) in + let atts = map_list_to_array (Attribute.encode pool) (pd.attributes :> Attribute.t list) in hunk ./src/classfile/moduleDefinition.ml 115 - ClassFile.constant_pool_count = checked_length "constant pool elements" cpool; + ClassFile.constant_pool_count = ConstantPool.size cpool; hunk ./src/classfile/moduleDefinition.mli 55 - The default version is [Version.Java_1_6]. + The default version is [Version.default]. hunk ./src/classfile/name.ml 49 - | Invalid_class_name - | Invalid_field_name - | Invalid_method_name - | Invalid_package_name - | Invalid_module_name + | Invalid_class_name of UTF8.t + | Invalid_field_name of UTF8.t + | Invalid_method_name of UTF8.t + | Invalid_package_name of UTF8.t + | Invalid_module_name of UTF8.t hunk ./src/classfile/name.ml 59 -let string_of_error = function - | Invalid_class_name -> "invalid class name" - | Invalid_field_name -> "invalid field name" - | Invalid_method_name -> "invalid method name" - | Invalid_package_name -> "invalid package name" - | Invalid_module_name -> "invalid module name" +let string_of_error e = + let soe kind name = + Printf.sprintf "invalid %s name (%S)" + kind + (UTF8.to_string_noerr name) in + match e with + | Invalid_class_name n -> soe "class" n + | Invalid_field_name n -> soe "field" n + | Invalid_method_name n -> soe "method" n + | Invalid_package_name n -> soe "package" n + | Invalid_module_name n -> soe "module" n hunk ./src/classfile/name.ml 95 - fail Invalid_class_name in + fail (Invalid_class_name s) in hunk ./src/classfile/name.ml 112 - fail Invalid_field_name + fail (Invalid_field_name s) hunk ./src/classfile/name.ml 118 - fail Invalid_method_name + fail (Invalid_method_name s) hunk ./src/classfile/name.ml 129 - make_for_pkg_or_mdl slash Invalid_package_name s + make_for_pkg_or_mdl slash (Invalid_package_name s) s hunk ./src/classfile/name.ml 132 - make_for_pkg_or_mdl dot Invalid_package_name s + make_for_pkg_or_mdl dot (Invalid_package_name s) s hunk ./src/classfile/name.ml 135 - make_for_pkg_or_mdl slash Invalid_module_name s + make_for_pkg_or_mdl slash (Invalid_module_name s) s hunk ./src/classfile/name.ml 138 - make_for_pkg_or_mdl dot Invalid_module_name s + make_for_pkg_or_mdl dot (Invalid_module_name s) s hunk ./src/classfile/name.ml 141 - let sep1' = UTF8.make [sep1] in - let sep2' = UTF8.make [sep2] in + let sep1 = UTF8.of_uchar sep1 in + let sep2 = UTF8.of_uchar sep2 in hunk ./src/classfile/name.ml 145 - UTF8.concat_sep sep1' cls + UTF8.concat_sep sep1 cls hunk ./src/classfile/name.ml 147 - (UTF8.concat_sep sep1' cls) ++ sep2' ++ (UTF8.concat_sep sep2' inner) + (UTF8.concat_sep sep1 cls) ++ sep2 ++ (UTF8.concat_sep sep2 inner) hunk ./src/classfile/name.ml 160 - let sep' = UTF8.make [sep] in - UTF8.concat_sep sep' n + let sep = UTF8.of_uchar sep in + UTF8.concat_sep sep n hunk ./src/classfile/name.ml 171 -let eq_for_utf8 x y = - (x == y) || (UTF8.equal x y) +let equal_for_list l1 l2 = + list_equal ~eq:UTF8.equal l1 l2 hunk ./src/classfile/name.ml 174 -let eq_for_list l1 l2 = - (l1 == l2) || ((List.length l1) = (List.length l2) && List.for_all2 eq_for_utf8 l1 l2) +let equal_for_class (c1, i1) (c2, i2) = + (equal_for_list c1 c2) && (equal_for_list i1 i2) hunk ./src/classfile/name.ml 177 -let eq_for_class (c1, i1) (c2, i2) = - (eq_for_list c1 c2) && (eq_for_list i1 i2) +let equal_for_field = UTF8.equal hunk ./src/classfile/name.ml 179 -let eq_for_field = eq_for_utf8 +let equal_for_method = UTF8.equal hunk ./src/classfile/name.ml 181 -let eq_for_method = eq_for_utf8 +let equal_for_package = equal_for_list hunk ./src/classfile/name.ml 183 -let eq_for_package = eq_for_list - -let eq_for_module = eq_for_list +let equal_for_module = equal_for_list hunk ./src/classfile/name.mli 19 -(** This module provides some utility functions related to name handling as - well as definition of class, field and method names. *) +(** Types and utility functions related to name handling for class, + field, method, package, and module names. *) hunk ./src/classfile/name.mli 26 -(** [replace_dot_with_slash s] returns a copy of string [s] where each dot has - been replaced by a slash. Useful to transform a fully qualified class name - from external format into internal format. *) +(** [replace_dot_with_slash s] returns a copy of string [s] where each + dot has been replaced by a slash. Useful to transform a fully + qualified class name from external format into internal format. *) hunk ./src/classfile/name.mli 31 -(** [replace_slash_with_dot s] returns a copy of string [s] where each slash - and dollar has been replaced by a dot. Useful to transform a fully qualified - class name from internal format into external format. *) +(** [replace_slash_with_dot s] returns a copy of string [s] where each + slash and dollar has been replaced by a dot. Useful to transform a + fully qualified class name from internal format into external + format. *) hunk ./src/classfile/name.mli 38 - That is, returns true iff the passed string is non-empty, does not contain any - dot, semi colon, opening square bracket or slash. *) + That is, returns true iff the passed string is non-empty, and does + not contain any dot, semi colon, opening square bracket or slash. *) hunk ./src/classfile/name.mli 43 - That is, returns true iff the passed string is non-empty, is either the class - constructor/initializer or is a valid unqualified name that does not - contain any '<' or '>'.*) + That is, returns true iff the passed string is either non-empty, is + the class constructor/initializer, or a valid unqualified name that + does not contain any '<' or '>'. *) hunk ./src/classfile/name.mli 51 - | Invalid_class_name - | Invalid_field_name - | Invalid_method_name - | Invalid_package_name - | Invalid_module_name + | Invalid_class_name of Utils.UTF8.t + | Invalid_field_name of Utils.UTF8.t + | Invalid_method_name of Utils.UTF8.t + | Invalid_package_name of Utils.UTF8.t + | Invalid_module_name of Utils.UTF8.t hunk ./src/classfile/name.mli 82 -(** Constructs a class name from an utf8 string (slash being the separator - between package element, dollar being the separator between inner elements). - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a class name from an UTF8 string (slash being the + separator between package elements, dollar being the separator + between inner elements). + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 88 -(** Constructs a class name from an utf8 string (dot being the separator - between package element, dollar being the separator between inner elements). - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a class name from an UTF8 string (dot being the separator + between package elements, dollar being the separator between inner + elements). + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 94 -(** Constructs a field name from an utf8 string. - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a field name from an UTF8 string. + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 98 -(** Constructs a method name from an utf8 string. - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a method name from an UTF8 string. + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 102 -(** Constructs a package name from an utf8 string (slash being the separator). - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a package name from an UTF8 string (slash being the + separator). + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 107 -(** Constructs a package name from an utf8 string (dot being the separator). - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a package name from an UTF8 string (dot being the + separator). + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 112 -(** Constructs a module name from an utf8 string (slash being the separator). - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a module name from an UTF8 string (slash being the + separator). + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 117 -(** Constructs a module name from an utf8 string (dot being the separator). - Raises [Exception] if passed utf8 is invalid. *) +(** Constructs a module name from an UTF8 string (dot being the + separator). + Raises [Exception] if passed UTF8 is invalid. *) hunk ./src/classfile/name.mli 122 -(** Converts a class name into external utf8 form - (dots between both package and inner elements). *) +(** Converts a class name into external UTF8 form (dots between both + package and inner elements). *) hunk ./src/classfile/name.mli 126 -(** Converts a class name into external utf8 form - (dots between package elements, dollars between inner elements). *) +(** Converts a class name into external UTF8 form (dots between package + elements, dollars between inner elements). *) hunk ./src/classfile/name.mli 130 -(** Converts a class name into internal utf8 form. - (slashes between package elements, dollars between inner elements). *) +(** Converts a class name into internal UTF8 form (slashes between + package elements, dollars between inner elements). *) hunk ./src/classfile/name.mli 134 -(** Converts a field name into utf8 form. *) +(** Converts a field name into UTF8 form. *) hunk ./src/classfile/name.mli 137 -(** Converts a method name into utf8 form. *) +(** Converts a method name into UTF8 form. *) hunk ./src/classfile/name.mli 140 -(** Converts a package name into external utf8 form. *) +(** Converts a package name into external UTF8 form. *) hunk ./src/classfile/name.mli 143 -(** Converts a package name into internal utf8 form. *) +(** Converts a package name into internal UTF8 form. *) hunk ./src/classfile/name.mli 146 -(** Converts a module name into external utf8 form. *) +(** Converts a module name into external UTF8 form. *) hunk ./src/classfile/name.mli 149 -(** Converts a module name into internal utf8 form. *) +(** Converts a module name into internal UTF8 form. *) hunk ./src/classfile/name.mli 151 -val eq_for_class : for_class -> for_class -> bool +val equal_for_class : for_class -> for_class -> bool hunk ./src/classfile/name.mli 154 -val eq_for_field : for_field -> for_field -> bool +val equal_for_field : for_field -> for_field -> bool hunk ./src/classfile/name.mli 157 -val eq_for_method : for_method -> for_method -> bool +val equal_for_method : for_method -> for_method -> bool hunk ./src/classfile/name.mli 160 -val eq_for_package : for_package -> for_package -> bool +val equal_for_package : for_package -> for_package -> bool hunk ./src/classfile/name.mli 163 -val eq_for_module : for_module -> for_module -> bool +val equal_for_module : for_module -> for_module -> bool hunk ./src/classfile/packageDefinition.ml 78 - && cf.ClassFile.interfaces = [| |] + && cf.ClassFile.interfaces = [||] hunk ./src/classfile/packageDefinition.ml 80 - && cf.ClassFile.fields = [| |] + && cf.ClassFile.fields = [||] hunk ./src/classfile/packageDefinition.ml 82 - && cf.ClassFile.methods = [| |] then + && cf.ClassFile.methods = [||] then hunk ./src/classfile/packageDefinition.ml 86 - (List.map - (fun x -> Attribute.decode Attribute.Package pool x) - (Array.to_list cf.ClassFile.attributes)); } + (map_array_to_list (Attribute.decode Attribute.Package pool ) + cf.ClassFile.attributes); } hunk ./src/classfile/packageDefinition.ml 91 -let encode ?(version=Version.Java_1_6) pd = +let encode ?(version=Version.default) pd = hunk ./src/classfile/packageDefinition.ml 94 - if res < 65536 then + if res <= max_u2 then hunk ./src/classfile/packageDefinition.ml 110 - let atts = Array.of_list (List.map (Attribute.encode pool) (pd.attributes :> Attribute.t list)) in + let atts = map_list_to_array (Attribute.encode pool) (pd.attributes :> Attribute.t list) in hunk ./src/classfile/packageDefinition.ml 115 - ClassFile.constant_pool_count = checked_length "constant pool elements" cpool; + ClassFile.constant_pool_count = ConstantPool.size cpool; hunk ./src/classfile/packageDefinition.mli 55 - The default version is [Version.Java_1_6]. + The default version is [Version.default]. hunk ./src/classfile/serialization.ml 21 + hunk ./src/classfile/serialization.ml 25 - | Invalid_magic - | Invalid_version + | Invalid_magic of u2 + | Invalid_version of u2 hunk ./src/classfile/serialization.ml 30 - | Invalid_class_flags + | Invalid_class_flags of s1 hunk ./src/classfile/serialization.ml 41 - | Invalid_magic -> "invalid magic" - | Invalid_version -> "invalid version" - | Invalid_stream -> "invalid stream" - | Array_type_waited -> "array type waited" - | Unknown_reference -> "unknown reference" - | Invalid_class_flags -> "invalid class flags" - | Missing_read_function -> "missing read function" - | Missing_write_function -> "missing write function" - | Missing_field s -> Printf.sprintf "missing value for field '%s'" (UTF8.to_string s) - | Invalid_field_type s -> Printf.sprintf "invalid type for field '%s'" (UTF8.to_string s) + | Invalid_magic x -> + Printf.sprintf "invalid magic (%d)" (x :> int) + | Invalid_version x -> + Printf.sprintf "invalid version (%d)" (x :> int) + | Invalid_stream -> + "invalid stream" + | Array_type_waited -> + "array type waited" + | Unknown_reference -> + "unknown reference" + | Invalid_class_flags x -> + Printf.sprintf "invalid class flags (%d)" (x :> int) + | Missing_read_function -> + "missing read function" + | Missing_write_function -> + "missing write function" + | Missing_field x -> + Printf.sprintf "missing value for field %S" (UTF8.to_string_noerr x) + | Invalid_field_type x -> + Printf.sprintf "invalid type for field %S" (UTF8.to_string_noerr x) hunk ./src/classfile/serialization.ml 312 - if res < 65536 then + if res <= max_u2 then hunk ./src/classfile/serialization.ml 361 - if len < 65536 then begin + if len <= max_u2 then begin hunk ./src/classfile/serialization.ml 436 - fail Invalid_class_flags + fail (Invalid_class_flags class_desc.desc_flags) hunk ./src/classfile/serialization.ml 567 - fail Invalid_class_flags; + fail (Invalid_class_flags class_desc.desc_flags); hunk ./src/classfile/serialization.ml 729 - if (magic :> int) <> stream_magic then fail Invalid_magic; + if (magic :> int) <> stream_magic then fail (Invalid_magic magic); hunk ./src/classfile/serialization.ml 731 - if (version :> int) <> stream_version then fail Invalid_version; + if (version :> int) <> stream_version then fail (Invalid_version version); hunk ./src/classfile/serialization.mli 19 -(** This module provides support for serialization/serialization, - using the {i Object Serialization protocol} version 2. *) +(** Support for serialization/serialization, using the {i Object + Serialization protocol} version 2. *) hunk ./src/classfile/serialization.mli 26 - | Invalid_magic - | Invalid_version + | Invalid_magic of Utils.u2 + | Invalid_version of Utils.u2 hunk ./src/classfile/serialization.mli 31 - | Invalid_class_flags + | Invalid_class_flags of Utils.s1 hunk ./src/classfile/serialization.mli 50 -(** The type of functions that should mimic {i java.ioExternalizable.readExternal(-)} - by consuming data from the stream. *) +(** The type of functions that should mimic + {i java.ioExternalizable.readExternal(-)} by consuming data from the + stream, and modifying the passed instance. *) hunk ./src/classfile/serialization.mli 55 -(** The type of functions that should mimic {i java.ioExternalizable.writeExternal(-)} - by producing data onto the stream. *) +(** The type of functions that should mimic + {i java.ioExternalizable.writeExternal(-)} by producing data onto the + stream from the passed instance. *) hunk ./src/classfile/serialization.mli 60 -(** The type of {i classical} instances (association from fields to values). *) +(** The type of {i classical} instances + (association from fields to values). *) hunk ./src/classfile/serialization.mli 100 -(** [make_descriptor name serial annot fields super ext methods] constructs - a new descriptor for class [name] with serial identifier [serial], - annotations [annot], fields [fields], and super descriptor [super]. - [ext] indicates whether the class implements {i java.io.Externalizable}, - and methods provides optional custom read/write methods. *) +(** [make_descriptor name serial annot fields super ext methods] + constructs a new descriptor for class [name] with serial identifier + [serial], annotations [annot], fields [fields], and super descriptor + [super]. [ext] indicates whether the class implements + {i java.io.Externalizable}, and methods provides optional custom + read/write methods. *) hunk ./src/classfile/serialization.mli 108 -(** [make_proxy_descriptor interfaces annot super] constructs a descriptor for - a proxy class with annotations [annot], and super descriptor [super]. - [interfaces] is the list of interfaces implemented by the proxy. *) +(** [make_proxy_descriptor interfaces annot super] constructs a + descriptor for a proxy class with annotations [annot], and super + descriptor [super]. [interfaces] is the list of interfaces + implemented by the proxy. *) hunk ./src/classfile/serialization.mli 132 -(** [make_instance desc fields annot] constructs an instance associated with - descriptor [desc] and annotations [annot]. The association list [fields] - should contain an element (with correct type) for each field referenced - in the descritor. *) +(** [make_instance desc fields annot] constructs an instance associated + with descriptor [desc] and annotations [annot]. The association list + [fields] should contain an element (with correct type) for each field + referenced in the descritor. *) hunk ./src/classfile/serialization.mli 146 - Raises [Exception] if data on the stream does not conform to the serialization protocol. + Raises [Exception] if data on the stream does not conform to the + serialization protocol. hunk ./src/classfile/signature.ml 133 - if ls#look_ahead capital_l then - Class_type_signature (parse_class_type_signature ls) - else if ls#look_ahead opening_square_bracket then - Array_type_signature (parse_array_type_signature ls) - else if ls#look_ahead capital_t then - Type_variable_signature (parse_type_variable_signature ls) - else - fail Invalid_signature + lexer_switch + [ capital_l, + (fun _ -> Class_type_signature (parse_class_type_signature ls)) ; + opening_square_bracket, + (fun _ -> Array_type_signature (parse_array_type_signature ls)) ; + capital_t, + (fun _ -> Type_variable_signature (parse_type_variable_signature ls)) ] + (fun _ -> fail Invalid_signature) + ls hunk ./src/classfile/signature.ml 185 - if ls#look_ahead star then begin - ls#consume_only star; - Star - end else if ls#look_ahead minus then begin - ls#consume_only minus; - Minus (parse_field_type_signature ls) - end else if ls#look_ahead plus then begin - ls#consume_only plus; - Plus (parse_field_type_signature ls) - end else - Simple (parse_field_type_signature ls) + lexer_switch + [ star, + (fun _ -> ls#consume_only star; Star) ; + minus, + (fun _ -> ls#consume_only minus; Minus (parse_field_type_signature ls)) ; + plus, + (fun _ -> ls#consume_only plus; Plus (parse_field_type_signature ls)) ] + (fun _ -> Simple (parse_field_type_signature ls)) + ls hunk ./src/classfile/signature.ml 215 - if ls#look_ahead capital_b then begin - ls#consume_only capital_b; - `Byte - end else if ls#look_ahead capital_c then begin - ls#consume_only capital_c; - `Char - end else if ls#look_ahead capital_d then begin - ls#consume_only capital_d; - `Double - end else if ls#look_ahead capital_f then begin - ls#consume_only capital_f; - `Float - end else if ls#look_ahead capital_i then begin - ls#consume_only capital_i; - `Int - end else if ls#look_ahead capital_j then begin - ls#consume_only capital_j; - `Long - end else if ls#look_ahead capital_s then begin - ls#consume_only capital_s; - `Short - end else if ls#look_ahead capital_z then begin - ls#consume_only capital_z; - `Boolean - end else - fail Invalid_signature + lexer_switch + [ capital_b, + (fun _ -> ls#consume_only capital_b; `Byte) ; + capital_c, + (fun _ -> ls#consume_only capital_c; `Char) ; + capital_d, + (fun _ -> ls#consume_only capital_d; `Double) ; + capital_f, + (fun _ -> ls#consume_only capital_f; `Float) ; + capital_i, + (fun _ -> ls#consume_only capital_i; `Int) ; + capital_j, + (fun _ -> ls#consume_only capital_j; `Long) ; + capital_s, + (fun _ -> ls#consume_only capital_s; `Short) ; + capital_z, + (fun _ -> ls#consume_only capital_z; `Boolean) ] + (fun _ -> fail Invalid_signature) + ls hunk ./src/classfile/signature.ml 390 - parse_class_signature (new lexer_state s) + let ls = new lexer_state s in + let res = parse_class_signature ls in + if ls#is_available then + fail Invalid_signature + else + res hunk ./src/classfile/signature.ml 405 - parse_field_type_signature (new lexer_state s) + let ls = new lexer_state s in + let res = parse_field_type_signature ls in + if ls#is_available then + fail Invalid_signature + else + res hunk ./src/classfile/signature.ml 420 - parse_method_type_signature (new lexer_state s) + let ls = new lexer_state s in + let res = parse_method_type_signature ls in + if ls#is_available then + fail Invalid_signature + else + res hunk ./src/classfile/signature.mli 19 -(** This module provides signatures definition as well as conversion functions - from and to strings. *) +(** Signatures definition as well as conversion functions from and to strings. *) hunk ./src/classfile/signature.mli 24 -(** The following types are direct mapping from the class file specification. - One should refer to this document for the semantics of these types. *) +(** The following types are direct mappings from the class file + specification. One should refer to this document for the semantics + of these types. *) hunk ./src/classfile/signature.mli 88 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/signature.mli 92 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/signature.mli 96 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/signature.mli 100 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/signature.mli 104 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/signature.mli 108 - Raises [Exception] if conversion fails. *) + Raises [Exception] if conversion fails. *) hunk ./src/classfile/version.ml 33 + | Java_1_8 hunk ./src/classfile/version.ml 43 - Java_1_7 + Java_1_7 ; + Java_1_8 hunk ./src/classfile/version.ml 58 + | Java_1_8 -> "1.8" hunk ./src/classfile/version.ml 67 +let copy_bound b = + { bound_version = b.bound_version; + bound_feature = String.copy b.bound_feature; } + hunk ./src/classfile/version.ml 72 - { bound_version = lo; bound_feature = String.copy f; }, + let f = String.copy f in + { bound_version = lo; bound_feature = f; }, hunk ./src/classfile/version.ml 75 - | Some v -> Some { bound_version = v; bound_feature = String.copy f; } + | Some v -> Some { bound_version = v; bound_feature = f; } hunk ./src/classfile/version.ml 78 +let empty_bounds b = + match b with + | _, None -> false + | x, Some y -> x.bound_version > y.bound_version + hunk ./src/classfile/version.ml 127 + | Java_1_8 -> u2 52, u2 0 hunk ./src/classfile/version.ml 139 + | 51, _ | 52, 0 -> Java_1_8 hunk ./src/classfile/version.ml 162 - let copy b = - { bound_version = b.bound_version; - bound_feature = String.copy b.bound_feature; } in hunk ./src/classfile/version.ml 164 - copy min_v1 + copy_bound min_v1 hunk ./src/classfile/version.ml 166 - copy min_v2 in + copy_bound min_v2 in hunk ./src/classfile/version.ml 170 - | Some x, None -> Some (copy x) - | None, Some x -> Some (copy x) + | Some x, None -> Some (copy_bound x) + | None, Some x -> Some (copy_bound x) hunk ./src/classfile/version.ml 174 - Some (copy x) + Some (copy_bound x) hunk ./src/classfile/version.ml 176 - Some (copy y) in + Some (copy_bound y) in hunk ./src/classfile/version.ml 181 - | [] -> invalid_arg "Version.intersect_list" + | [] -> invalid_arg "BaristaLibrary.Version.intersect_list" hunk ./src/classfile/version.mli 19 -(** This module defines the various version of the class file format. *) +(** Definition of the various versions of the class file format. *) hunk ./src/classfile/version.mli 32 - | Java_1_7 (** Java SE 7 (to be released). *) + | Java_1_7 (** Java SE 7 (in DP - circa 2011?). *) + | Java_1_8 (** Java SE 8 (to be released). *) hunk ./src/classfile/version.mli 37 +(** The list of versions, in ascending order. *) hunk ./src/classfile/version.mli 40 +(** The default version used by the library (currently [Java_1_6]). *) hunk ./src/classfile/version.mli 43 +(** Converts the passed version into a string. *) hunk ./src/classfile/version.mli 53 - The first component is lower bound, while the second one is the (optional) - higher bound. *) + The first component is lower bound, while the second one is the + (optional) higher bound. *) hunk ./src/classfile/version.mli 58 - with lower version [lo] and optional higher version [hi]. - Both bounds are inclusive. *) + with lower version [lo], and optional higher version [hi]. + Both bounds are inclusive. The string [f] is copied. *) + +val empty_bounds : bounds -> bool +(** Checks whether the passed bounds consists in an empty interval. *) hunk ./src/classfile/version.mli 83 - format. *) + format in [(major, minor)] fomat. *) hunk ./src/classfile/version.mli 87 - format. *) + format in [(major, minor)] fomat. *) hunk ./src/classfile/version.mli 102 -(** [at_least f v x] raises an exception if [x] is below [v]. +(** [at_least f v x] raises [Exception] if [x] is below [v]. hunk ./src/classfile/version.mli 106 -(** [at_most f v x] raises an exception if [x] is above [v]. +(** [at_most f v x] raises [Exception] if [x] is above [v]. hunk ./src/classfile/version.mli 110 -(** [check b v] checks that version [v] is in bounds [b], raising an - exception if not. *) +(** [check b v] checks that version [v] is in bounds [b], raising + [Exception] if not. *) hunk ./src/classfile/version.mli 114 -(** [intersect v1 v2] compute the intersection of the intervals represented - by bounds [v1] and [v2]. The returned bounds may represent an empty - interval (where the higher bound is below the lower bound. *) +(** [intersect v1 v2] compute the intersection of the intervals + represented by bounds [v1] and [v2]. The returned bounds may + represent an empty interval (where the higher bound is below + the lower bound. *) hunk ./src/classfile/version.mli 121 - Raises [Invalid_argument] is [l] is empty. *) + Raises [Invalid_argument] if [l] is empty. *) hunk ./src/commands/assemble.ml 51 - Arg.String (fun s -> parameters.class_path <- ClassPath.append s parameters.class_path), + Arg.String + (fun s -> + let class_path = ClassPath.append s parameters.class_path in + parameters.class_path <- class_path), hunk ./src/commands/assemble.ml 57 - Arg.String (fun s -> parameters.class_path <- ClassPath.make_of_string s), + Arg.String + (fun s -> + parameters.class_path <- ClassPath.make_of_string s), hunk ./src/commands/assemble.ml 74 - Arg.Symbol (List.map fst versions, (fun s -> parameters.target <- List.assoc s versions)), + Arg.Symbol + (List.map fst versions, + (fun s -> parameters.target <- List.assoc s versions)), hunk ./src/commands/assemble.ml 100 - Printf.printf "%S has been compiled" (to_string name); + Printf.printf "%S has been compiled\n" (to_string name); hunk ./src/commands/assemble.mli 19 +(** Implementation of {i assemble} command. *) + + hunk ./src/commands/disassemble.mli 19 +(** Implementation of {i disassemble} command. *) + + hunk ./src/commands/flow.ml 25 -let description = "prints the control flow of method" +let description = "prints the control flow of a method" hunk ./src/commands/flow.mli 19 +(** Implementation of {i flow} command. *) + + hunk ./src/commands/print.mli 19 +(** Implementation of {i print} command. *) + + addfile ./src/commands/printVersion.ml hunk ./src/commands/printVersion.ml 1 +(* + * This file is part of Barista. + * Copyright (C) 2007-2011 Xavier Clerc. + * + * Barista is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * Barista is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program. If not, see . + *) + + +let names = [ "version" ] + +let description = "prints the current version" + +type parameters = unit + +let make_parameters () = Command.make_empty_parameters "version" + +let run () = + print_endline CurrentVersion.value + addfile ./src/commands/printVersion.mli hunk ./src/commands/printVersion.mli 1 +(* + * This file is part of Barista. + * Copyright (C) 2007-2011 Xavier Clerc. + * + * Barista is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * Barista is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program. If not, see . + *) + +(** Implementation of {i version} command. *) + + +include Command.T hunk ./src/common/command.ml 36 - let help () = - Arg.usage !args (Printf.sprintf "options for command %S:" command) in + let usage_msg = Printf.sprintf "options for command %S:" command in + let help () = Arg.usage !args usage_msg in hunk ./src/common/command.ml 59 - Arg.String (fun s -> parameters.class_path <- ClassPath.append s parameters.class_path), + Arg.String + (fun s -> + let class_path = ClassPath.append s parameters.class_path in + parameters.class_path <- class_path), hunk ./src/common/command.ml 65 - Arg.String (fun s -> parameters.class_path <- ClassPath.make_of_string s), + Arg.String + (fun s -> + parameters.class_path <- ClassPath.make_of_string s), hunk ./src/common/command.ml 74 +let make_empty_parameters command = + (), + build_args command [], + (fun s -> + let msg = Printf.sprintf "invalid parameter %S" s in + raise (Arg.Bad msg)) + hunk ./src/common/command.mli 19 -(** Definition of commands to be launched from command line. *) +(** Definition of commands to be launched from command-line. *) hunk ./src/common/command.mli 36 - - [specs] are the command-line specifiers passed to [Arg.parse_argv]; + - [specs] are the command-line specifiers passed to + [Arg.parse_argv]; hunk ./src/common/command.mli 40 - [specs] and [func] are supposed to update [params] when passed to [Arg.parse_argv]. *) + [specs] and [func] are supposed to update [params] when passed to + [Arg.parse_argv]. *) hunk ./src/common/command.mli 44 - (** Actually executes of the command. *) + (** Actually executes of the command with passed parameters. *) hunk ./src/common/command.mli 54 - mutable class_path : ClassPath.t; (** Class path to treat elements. *) - mutable elements : string list; (** Elements to treat. *) + mutable class_path : ClassPath.t; (** Class path to process elements. *) + mutable elements : string list; (** Elements to process. *) hunk ./src/common/command.mli 65 +val make_empty_parameters : string -> unit * (Arg.key * Arg.spec * Arg.doc) list * Arg.anon_fun +(** Returns the elements needed accept no parameter. + The passed string is the name of the command. *) + hunk ./src/common/command.mli 72 - if [n <= 0], otherwise the passed string will be printed enclosed + if [n <= 1], otherwise the passed string will be printed enclosed hunk ./src/common/inputStream.ml 258 +let read_elements st f = + let nb = read_u2 st in + let res = ref [] in + for i = 1 to (nb :> int) do + let elem = f st in + res := elem :: !res + done; + List.rev !res + hunk ./src/common/inputStream.ml 277 + + +(* Predefined stream *) + +let stdin = make_of_channel stdin hunk ./src/common/inputStream.mli 106 +val read_elements : t -> (t -> 'a) -> 'a list +(** [read_elements st f] will first read from [st] a [Utils.u2] value + indicating the number of elements to actually read. Then, it will + read the elements using [f] and return the list of read elements. + Raises [Exception] if end of stream is encountered or an i/o error + occurs. *) + hunk ./src/common/inputStream.mli 123 + + +(** {6 Predefined stream} *) + +val stdin : t +(** Predefined stream for standard input. *) hunk ./src/common/lineUtils.ml 23 +let output chan buf = + let out = UTF8LineWriter.make chan in + UTF8LineWriter.put out (Utils.UTF8Buffer.contents buf); + UTF8LineWriter.flush out + hunk ./src/common/lineUtils.mli 28 +val output : OutputStream.t -> Utils.UTF8Buffer.t -> unit +(** Outputs the content of the passed buffer onto the passed stream, + using a [UTF8LineWriter] instance. An exception is raised if an error + occurs during the write operation. *) + hunk ./src/common/outputStream.ml 162 +let write_elements length st f l = + write_u2 st (length l); + List.iter (f st) l + hunk ./src/common/outputStream.ml 179 + + +(* Predefined streams *) + +let stdout = make_of_channel stdout + +let stderr = make_of_channel stderr hunk ./src/common/outputStream.mli 93 +val write_elements : ('a list -> Utils.u2) -> t -> (t -> 'a -> unit) -> 'a list -> unit +(** [write_elements length st f l] will first write to [st] the + length of [l] as a [Utils.u2] value. Then, it will write the elements + from [l] using [f]. The parameter [length] is used to determine the + length of [l], and should be used to ensure that the length fits in a + [Utils.u2] value. + Raises [Exception] if data cannot be written. *) + hunk ./src/common/outputStream.mli 114 + + +(** {6 Predefined streams} *) + +val stdout : t +(** Predefined stream for standard output. *) + +val stderr : t +(** Predefined stream for standard error. *) hunk ./src/common/utils.ml 71 +let max_u2 = 65535 + hunk ./src/common/utils.ml 74 - if x >= 0 && x <= 65535 then + if x >= 0 && x <= max_u2 then hunk ./src/common/utils.ml 81 +let min_s2 = -32768 + +let max_s2 = 32767 + hunk ./src/common/utils.ml 86 - if x >= -32768 && x <= 32767 then + if x >= min_s2 && x <= max_s2 then hunk ./src/common/utils.ml 113 +let s1_neg x = + if x <> -128 then + ~-x + else + fail_integer "s1" (-128L) 127L (Int64.of_int (~-x)) + +let s2_neg x = + if x <> -32768 then + ~-x + else + fail_integer "s2" (-32768L) 32767L (Int64.of_int (~-x)) + hunk ./src/common/utils.ml 178 +let switch eq matches default x = + let func = + try + snd (List.find (fun (c, _) -> eq c x) matches) + with Not_found -> default in + func x + +let lexer_switch matches default ls = + let next_char = ls#peek in + switch UCharImpl.equal matches default next_char + hunk ./src/common/utils.ml 240 + +let rec list_equal ?(eq = (=)) l1 l2 = + (l1 == l2) || + (match l1, l2 with + | (hd1 :: tl1), (hd2 :: tl2) -> + if eq hd1 hd2 then list_equal tl1 tl2 else false + | (_ :: _), [] -> false + | [], (_ :: _) -> false + | [], [] -> true) hunk ./src/common/utils.mli 63 +val max_u2 : int +(** The greatest [u2] value. *) + hunk ./src/common/utils.mli 73 +val min_s2 : int +(** The lowes [s2] value. *) + +val max_s2 : int +(** The greatest [s2] value. *) + hunk ./src/common/utils.mli 106 +val s1_neg : s1 -> s1 +(** Unary negation, + raises [Integer_exception] if result would be out of bounds. *) + +val s2_neg : s2 -> s2 +(** Unary negation, + raises [Integer_exception] if result would be out of bounds. *) + hunk ./src/common/utils.mli 153 +val lexer_switch : (UCharImpl.t * (UCharImpl.t -> 'a)) list -> (UCharImpl.t -> 'a) -> UTF8LexerStateImpl.t -> 'a +(** [lexer_switch matches default ls char] search the association list + [matches] for a key equal to [char]. If such a key exists, the return + value is equal to the application of the associated function to + [char]. Otherwise, the return value is equal to the application of + [default] to [char]. *) + hunk ./src/common/utils.mli 187 + +val switch : ('a -> 'a -> bool) -> ('a * ('a -> 'b)) list -> ('a -> 'b) -> 'a -> 'b +(** [switch eq matches default x] search the association list [matches] + for a key equal to [x] using equality function [eq]. If such a key + exists, the return value is equal to the application of the + associated function to [x]. Otherwise, the return value is equal to + the application of [default] to [x]. *) + +val list_equal : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> bool +(** Equality over lists, [eq] (defaulting to [(=)]) being the predicate + used to compare list elements. *) hunk ./src/driver/barista.ml 22 + hunk ./src/driver/barista.ml 37 - Predef.commands; - prerr_endline "\ncommand \"version\" (print current version)\n" + Predef.commands hunk ./src/driver/barista.ml 40 - let _ = Predef.commands in hunk ./src/driver/barista.ml 44 - | "version" -> - print_endline CurrentVersion.value hunk ./src/driver/barista.ml 56 - let commands = List.filter (fun (name, _) -> is_prefix command name) commands in + let commands = + List.filter + (fun (name, _) -> is_prefix command name) + commands in hunk ./src/driver/predef.mli 19 +(** List of predefined commands to be launched from command-line. *) + hunk ./src/helpers/classLoader.ml 30 - | Unable_to_load of UTF8.t * (string option) - | Already_defined + | Unable_to_load of UTF8.t * string + | Already_defined of UTF8.t hunk ./src/helpers/classLoader.ml 39 - Printf.sprintf - "unable to load class %s%s" - (UTF8.to_string s) - (match os with Some v -> " (" ^ v ^ ")" | None -> "") - | Already_defined -> "class is already defined" + Printf.sprintf "unable to load class %S (%s)" (UTF8.to_string_noerr s) os + | Already_defined s -> + Printf.sprintf "class %S is already defined" (UTF8.to_string_noerr s) hunk ./src/helpers/classLoader.ml 72 - fail (Unable_to_load (cn, Some (ClassFile.string_of_error cause))) - | _ -> + fail (Unable_to_load (cn, ClassFile.string_of_error cause)) + | e -> hunk ./src/helpers/classLoader.ml 75 - fail (Unable_to_load (cn, None)) in + fail (Unable_to_load (cn, Printexc.to_string e)) in hunk ./src/helpers/classLoader.ml 79 - fail Already_defined + fail (Already_defined cn) hunk ./src/helpers/classLoader.mli 28 - | Unable_to_load of Utils.UTF8.t * (string option) - | Already_defined + | Unable_to_load of Utils.UTF8.t * string + | Already_defined of Utils.UTF8.t hunk ./src/helpers/classPath.ml 40 - | Unable_to_open_archive s -> "unable to open archive " ^ s - | Does_not_exist s -> s ^ " does not exist" - | Class_not_found s -> Printf.sprintf "class '%s' not found" s + | Unable_to_open_archive s -> + Printf.sprintf "unable to open archive %S" s + | Does_not_exist s -> + Printf.sprintf "%S does not exist" s + | Class_not_found s -> + Printf.sprintf "class %S not found" s hunk ./src/helpers/classPath.ml 65 - else + else if Sys.file_exists s then hunk ./src/helpers/classPath.ml 69 + else + fail (Does_not_exist s) hunk ./src/helpers/classPath.ml 77 - let sep = if separator = ":" then colon else Str.regexp (Str.quote separator) in + let sep = + if separator = ":" then + colon + else + Str.regexp (Str.quote separator) in hunk ./src/helpers/classPath.mli 62 -(** [open_stream cp cn] returns the stream for class whose fully qualified name - is [cn], search class path [cp]. +(** [open_stream cp cn] returns the stream for class whose fully qualified + name is [cn], search class path [cp]. hunk ./src/helpers/classPath.mli 68 -(** Closes all underlying archives, subsequent tries to read from such archives - will hence fail. Silently fails if an archive fails to close. *) +(** Closes all underlying archives, subsequent tries to read from such + archives will hence fail. Silently fails if an archive fails to + close. *) hunk ./src/helpers/lexer.ml 48 - | Invalid_label - | Invalid_directive - | Invalid_attribute - | Invalid_string - | Invalid_character - | Invalid_float - | Invalid_integer + | Invalid_label of UTF8.t + | Invalid_directive of UTF8.t + | Invalid_attribute of UTF8.t + | Invalid_string of UTF8.t + | Invalid_character of UChar.t + | Invalid_float of string + | Invalid_integer of string hunk ./src/helpers/lexer.ml 58 - | Source_error of Source.error hunk ./src/helpers/lexer.ml 66 - | Invalid_label -> "invalid label" - | Invalid_directive -> "invalid directive" - | Invalid_attribute -> "invalid attribute" - | Invalid_string -> "invalid string" - | Invalid_character -> "invalid character" - | Invalid_float -> "invalid float constant" - | Invalid_integer -> "invalid integer constant" + | Invalid_label s -> + Printf.sprintf "invalid label %S" (UTF8.to_string_noerr s) + | Invalid_directive s -> + Printf.sprintf "invalid directive %S" (UTF8.to_string_noerr s) + | Invalid_attribute s -> + Printf.sprintf "invalid attribute %S" (UTF8.to_string_noerr s) + | Invalid_string s -> + Printf.sprintf "invalid string %S" (UTF8.to_string_noerr s) + | Invalid_character s -> + Printf.sprintf "invalid character %C" (UChar.to_char_noerr s) + | Invalid_float s -> + Printf.sprintf "invalid float constant %S" s + | Invalid_integer s -> + Printf.sprintf "invalid integer constant %S" s hunk ./src/helpers/lexer.ml 83 - | Source_error e -> Source.string_of_error e hunk ./src/helpers/lexer.ml 106 - fail Invalid_label + fail (Invalid_label s) hunk ./src/helpers/lexer.ml 114 - let desc = (List.map Source.java_type_of_utf8_no_void (UTF8.split comma params)), - (Source.java_type_of_utf8 (UTF8.substring s (succ (succ closing_index)) last)) in + let desc = (List.map Descriptor.java_type_of_external_utf8_no_void (UTF8.split comma params)), + (Descriptor.java_type_of_external_utf8 (UTF8.substring s (succ (succ closing_index)) last)) in hunk ./src/helpers/lexer.ml 121 - Array_method ((Descriptor.filter_array Descriptor.Invalid_array_element_type (Source.java_type_of_utf8 class_name)), + Array_method ((Descriptor.filter_non_array Descriptor.Invalid_array_element_type (Descriptor.java_type_of_external_utf8 class_name)), hunk ./src/helpers/lexer.ml 132 - (List.map Source.java_type_of_utf8_no_void (UTF8.split comma params))) + (List.map Descriptor.java_type_of_external_utf8_no_void (UTF8.split comma params))) hunk ./src/helpers/lexer.ml 140 - (Source.java_type_of_utf8_no_void (UTF8.substring s (succ colon_idx) (pred (UTF8.length s))))) + (Descriptor.java_type_of_external_utf8_no_void (UTF8.substring s (succ colon_idx) (pred (UTF8.length s))))) hunk ./src/helpers/lexer.ml 147 - let t = Source.java_type_of_utf8 s in + let t = Descriptor.java_type_of_external_utf8 s in hunk ./src/helpers/lexer.ml 171 - fail Invalid_directive + fail (Invalid_directive (UTF8Buffer.contents buf)) hunk ./src/helpers/lexer.ml 181 - fail Invalid_attribute + fail (Invalid_attribute (UTF8Buffer.contents buf)) hunk ./src/helpers/lexer.ml 198 - fail Invalid_string + fail (Invalid_string (UTF8Buffer.contents buf)) hunk ./src/helpers/lexer.ml 213 - if state#is_available && not (state#look_ahead_list [space; tabulation; sharp]) then fail Invalid_character; + if state#is_available && not (state#look_ahead_list [space; tabulation; sharp]) then + fail (Invalid_character state#peek); hunk ./src/helpers/lexer.ml 217 - fail Invalid_character + fail (Invalid_character (UTF8.get s 0)) hunk ./src/helpers/lexer.ml 227 - Float (float_of_string number) + try + Float (float_of_string number) + with _ -> fail (Invalid_float number) hunk ./src/helpers/lexer.ml 231 - Int (Int64.of_string number) + try + Int (Int64.of_string number) + with _ -> fail (Invalid_integer number) hunk ./src/helpers/lexer.ml 275 - let tok = try - read_token () - with - | Name.Exception e -> fail (Name_error e) - | Descriptor.Exception e -> fail (Descriptor_error e) - | Source.Exception e -> fail (Source_error e) - | UChar.Exception e -> fail (UChar_error e) - | UTF8.Exception e -> fail (UTF8_error e) - | Exception e -> fail e - | Failure "float_of_string" -> fail Invalid_float - | Failure "int_of_string" -> fail Invalid_integer - | _ -> fail Invalid_token in + let tok = + try + read_token () + with + | Name.Exception e -> fail (Name_error e) + | Descriptor.Exception e -> fail (Descriptor_error e) + | UChar.Exception e -> fail (UChar_error e) + | UTF8.Exception e -> fail (UTF8_error e) + | Exception e -> fail e + | _ -> fail Invalid_token in hunk ./src/helpers/lexer.ml 293 - let method_desc_eq (p, r) (p', r') = - (List.for_all2 - Descriptor.eq_java_type - (p :> Descriptor.java_type list) - (p' :> Descriptor.java_type list)) - && (Descriptor.eq_java_type r r') in - let cls_eq x y = - UTF8.equal - (Name.external_utf8_for_class x) - (Name.external_utf8_for_class y) in - let fld_eq x y = - UTF8.equal - (Name.utf8_for_field x) - (Name.utf8_for_field y) in - let mth_eq x y = - UTF8.equal - (Name.utf8_for_method x) - (Name.utf8_for_method y) in hunk ./src/helpers/lexer.ml 300 - | (Class_name cn), (Class_name cn') -> cls_eq cn cn' + | (Class_name cn), (Class_name cn') -> Name.equal_for_class cn cn' hunk ./src/helpers/lexer.ml 304 - (cls_eq x x') - && (fld_eq y y') - && (Descriptor.eq_java_type + (Name.equal_for_class x x') + && (Name.equal_for_field y y') + && (Descriptor.equal_java_type hunk ./src/helpers/lexer.ml 310 - (mth_eq x x') && (method_desc_eq y y') + (Name.equal_for_method x x') + && (Descriptor.equal_for_method y y') hunk ./src/helpers/lexer.ml 313 - (cls_eq x x') && (mth_eq y y') && (method_desc_eq z z') + (Name.equal_for_class x x') + && (Name.equal_for_method y y') + && (Descriptor.equal_for_method z z') hunk ./src/helpers/lexer.ml 317 - (Descriptor.eq_java_type + (Descriptor.equal_java_type hunk ./src/helpers/lexer.ml 320 - && (mth_eq y y') - && (method_desc_eq z z') + && (Name.equal_for_method y y') + && (Descriptor.equal_for_method z z') hunk ./src/helpers/lexer.ml 323 - (mth_eq x x') - && (List.for_all2 - Descriptor.eq_java_type + (Name.equal_for_method x x') + && (list_equal + ~eq:Descriptor.equal_java_type hunk ./src/helpers/lexer.mli 19 -(** This module provides the lexing function used by the assembler to read - tokens from a source file. *) +(** Implements the lexing function used by the assembler to read tokens + from a source file. *) hunk ./src/helpers/lexer.mli 49 - | Invalid_label - | Invalid_directive - | Invalid_attribute - | Invalid_string - | Invalid_character - | Invalid_float - | Invalid_integer + | Invalid_label of Utils.UTF8.t + | Invalid_directive of Utils.UTF8.t + | Invalid_attribute of Utils.UTF8.t + | Invalid_string of Utils.UTF8.t + | Invalid_character of Utils.UChar.t + | Invalid_float of string + | Invalid_integer of string hunk ./src/helpers/lexer.mli 59 - | Source_error of Source.error hunk ./src/helpers/lexer.mli 75 - Raises [Exception] if the passed string is such that a list of correct - tokens cannot be extracted. *) + Raises [Exception] if the passed string is such that a list of + correct tokens cannot be extracted. *) hunk ./src/helpers/lexer.mli 83 - (meaning that classes are compared on a name basis). *) + (meaning that classes are compared on a name basis, and neither + interfaces or generics are taken into account). *) hunk ./src/helpers/source.ml 1 -(* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - *) - -open Utils -open LineUtils -open Consts - - -(* Exception *) - -type error = - | Invalid_array_dimensions - | Invalid_type - | Unknown_flag - -exception Exception of error - -let fail e = raise (Exception e) - -let string_of_error = function - | Invalid_array_dimensions -> "invalid number of dimensions for array" - | Invalid_type -> "invalid type" - | Unknown_flag -> "unknown flag" - -let () = - Printexc.register_printer - (function - | Exception e -> Some (string_of_error e) - | _ -> None) - - -(* Orders over some Java elements *) - -let flag_list_order fl1 fl2 = - let s1 = List.mem `Static fl1 in - let s2 = List.mem `Static fl2 in - let pub1 = List.mem `Public fl1 in - let pub2 = List.mem `Public fl2 in - let pro1 = List.mem `Protected fl1 in - let pro2 = List.mem `Protected fl2 in - let pri1 = List.mem `Private fl1 in - let pri2 = List.mem `Private fl2 in - compare (pub2, pro2, pri2, s2) (pub1, pro1, pri1, s1) - -let flag_order f1 f2 = - let flag_rank = function - | `Public - | `Private - | `Protected - | `Module -> 1 - | `Static -> 2 - | `Final -> 3 - | `Synchronized -> 4 - | `Volatile -> 4 - | `Transient -> 4 - | `Native -> 4 - | `Abstract -> 2 - | `Strict -> 4 - | `Super - | `Bridge - | `Varargs - | `Interface - | `Synthetic - | `Annotation - | `Enum -> 5 in - let cmp = compare (flag_rank f1) (flag_rank f2) in - if cmp = 0 then compare f1 f2 else cmp - -let field_order f1 f2 = - let fl1, n1, _, _ = f1 in - let fl2, n2, _, _ = f2 in - let cmp = flag_list_order fl1 fl2 in - if cmp <> 0 then - cmp - else - let cmp2 = UTF8.compare (Name.utf8_for_field n1) (Name.utf8_for_field n2) in - if cmp2 <> 0 then - cmp2 - else - compare f1 f2 - -let meth_desc_order md1 md2 = - let p1, r1 = md1 in - let p2, r2 = md2 in - let cmp = compare (List.length p1) (List.length p2) in - if cmp <> 0 then - cmp - else - let cmp' = compare (Descriptor.utf8_of_method md1) (Descriptor.utf8_of_method md2) in - if cmp' <> 0 then - cmp' - else - compare (Descriptor.utf8_of_java_type r1) (Descriptor.utf8_of_java_type r2) - -let method_order m1 m2 = - let method_rank = function - | Method.Regular _ -> 2 - | Method.Constructor _ -> 1 - | Method.Initializer _ -> 0 in - let r1 = method_rank m1 in - let r2 = method_rank m2 in - let cmp = compare r1 r2 in - if cmp <> 0 then - cmp - else - match m1, m2 with - | Method.Regular (fl1, n1, d1, _), Method.Regular (fl2, n2, d2, _) -> - let cmp' = flag_list_order fl1 fl2 in - if cmp' <> 0 then - cmp' - else - let cmp'' = UTF8.compare (Name.utf8_for_method n1) (Name.utf8_for_method n2) in - if cmp'' <> 0 then - cmp'' - else - meth_desc_order d1 d2 - | Method.Constructor (fl1, d1, _), Method.Constructor (fl2, d2, _) -> - let cmp = compare (List.mem `Public fl1) (List.mem `Public fl2) in - if cmp <> 0 then - cmp - else - meth_desc_order (d1, `Void) (d2, `Void) - | _ -> compare m1 m2 - -let attribute_order a1 a2 = - let attribute_rank = function - | `ConstantValue _ -> 3 - | `Code _ -> 8 - | `Exceptions _ -> 3 - | `InnerClasses _ -> 2 - | `EnclosingMethod _ -> 2 - | `Synthetic -> 0 - | `Signature _ -> 1 - | `SourceFile _ -> 1 - | `SourceDebugExtension _ -> 6 - | `LineNumberTable _ -> -1 - | `LocalVariableTable _ -> -1 - | `LocalVariableTypeTable _ -> -1 - | `Deprecated -> 0 - | `RuntimeVisibleAnnotations _ -> 5 - | `RuntimeInvisibleAnnotations _ -> 5 - | `RuntimeVisibleParameterAnnotations _ -> 5 - | `RuntimeInvisibleParameterAnnotations _ -> 5 - | `RuntimeVisibleTypeAnnotations _ -> 5 - | `RuntimeInvisibleTypeAnnotations _ -> 5 - | `AnnotationDefault _ -> 4 - | `StackMapTable _ -> 9 - | `Module _ -> 1 - | `ModuleRequires _ -> 99 - | `ModulePermits _ -> 99 - | `ModuleProvides _ -> 99 - | `Unknown _ -> 7 in - let cmp = compare (attribute_rank a1) (attribute_rank a2) in - if cmp = 0 then compare a1 a2 else cmp - - -(* Some conversion functions *) - -let rec utf8_of_java_type = function - | `Boolean -> UTF8.of_string "boolean" - | `Byte -> UTF8.of_string "byte" - | `Char -> UTF8.of_string "char" - | `Double -> UTF8.of_string "double" - | `Float -> UTF8.of_string "float" - | `Int -> UTF8.of_string "int" - | `Long -> UTF8.of_string "long" - | `Short -> UTF8.of_string "short" - | `Void -> UTF8.of_string "void" - | `Class n -> Name.printable_utf8_for_class n - | `Array jt -> (utf8_of_java_type (jt :> Descriptor.java_type)) ++ (UTF8.of_string "[]") - -let java_type_of_utf8 s = - let rec make_array n x = - if n = 0 then - x - else - `Array (make_array (pred n) x) in - let l = UTF8.length s in - let i = ref 0 in - while !i < l && ((UChar.is_letter_or_digit (UTF8.get s !i)) - || (UChar.equal dot (UTF8.get s !i)) - || (UChar.equal opening_square_bracket (UTF8.get s !i)) - || (UChar.equal closing_square_bracket (UTF8.get s !i))) do - incr i - done; - if !i = l && UChar.is_letter (UTF8.get s 0) then - let j = ref (pred l) in - let dims = ref 0 in - while (!j - 1 >= 0) - && (UChar.equal closing_square_bracket (UTF8.get s !j)) - && (UChar.equal opening_square_bracket (UTF8.get s (!j - 1))) do - incr dims; - decr j; - decr j - done; - if !dims > 255 then fail Invalid_array_dimensions; - let prefix = UTF8.substring s 0 !j in - let base = match (try UTF8.to_string prefix with _ -> "") with - | "boolean" -> `Boolean - | "byte" -> `Byte - | "char" -> `Char - | "double" -> `Double - | "float" -> `Float - | "int" -> `Int - | "long" -> `Long - | "short" -> `Short - | "void" -> `Void - | _ -> `Class (Name.make_for_class_from_external prefix) in - if !dims = 0 then - base - else - let array = make_array !dims (Descriptor.filter_void Descriptor.Invalid_array_element_type base) in - (array :> Descriptor.java_type) - else - fail Invalid_type - -let java_type_of_utf8_no_void s = - let res = java_type_of_utf8 s in - Descriptor.filter_void Descriptor.Void_not_allowed res - -let utf8_of_flag f = - let uof = function - | `Public -> "public" - | `Private -> "private" - | `Protected -> "protected" - | `Static -> "static" - | `Final -> "final" - | `Super -> "super" - | `Synchronized -> "synchonized" - | `Bridge -> "bridge" - | `Volatile -> "volatile" - | `Transient -> "transient" - | `Varargs -> "varargs" - | `Native -> "native" - | `Interface -> "interface" - | `Abstract -> "abstract" - | `Strict -> "strictfp" - | `Synthetic -> "synthetic" - | `Annotation -> "annotation" - | `Enum -> "enum" - | `Module -> "module" in - UTF8.of_string (uof f) - -let utf8_of_flags l = - (UTF8.concat_sep - (UTF8.of_string " ") - (List.map utf8_of_flag (List.sort flag_order l))) - ++ (if l <> [] then UTF8.of_string " " else empty_utf8) - -let flag_of_utf8 s = - let fou = function - | "public" -> `Public - | "private" -> `Private - | "protected" -> `Protected - | "static" -> `Static - | "final" -> `Final - | "super" -> `Super - | "synchonized" -> `Synchronized - | "bridge" -> `Bridge - | "volatile" -> `Volatile - | "transient" -> `Transient - | "varargs" -> `Varargs - | "native" -> `Native - | "interface" -> `Interface - | "abstract" -> `Abstract - | "strictfp" -> `Strict - | "synthetic" -> `Synthetic - | "annotation" -> `Annotation - | "enum" -> `Enum - | "module" -> `Module - | _ -> fail Unknown_flag in - fou (UTF8.to_string s) - - -(* Miscellaneous *) - -let output chan buf = - let out = UTF8LineWriter.make chan in - UTF8LineWriter.put out (UTF8Buffer.contents buf); - UTF8LineWriter.flush out rmfile ./src/helpers/source.ml hunk ./src/helpers/source.mli 1 -(* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - *) - -(** This module provides some utility functions related to source handling. *) - - -(** {6 Exception} *) - -type error = - | Invalid_array_dimensions - | Invalid_type - | Unknown_flag - -exception Exception of error -(** Exception to be raised when a function of this module fails. *) - -val string_of_error : error -> string -(** Converts the passed error into a string. *) - hunk ./src/helpers/source.mli 2 -(** {6 Orders over some Java elements} *) - -val flag_order : AccessFlag.t -> AccessFlag.t -> int -(** Order over flags. *) - -val field_order : Field.t -> Field.t -> int -(** Order over fields. *) - -val meth_desc_order : Descriptor.for_method -> Descriptor.for_method -> int -(** Order over method descriptors. *) - -val method_order : Method.t -> Method.t -> int -(** Order over methods. *) - -val attribute_order : Attribute.t -> Attribute.t -> int -(** Order over attributes. *) - - -(** {6 Some conversion functions} *) - -val utf8_of_java_type : Descriptor.java_type -> Utils.UTF8.t -(** Returns the textual representation of the passed Java type. *) - -val java_type_of_utf8 : Utils.UTF8.t -> Descriptor.java_type -(** Returns the Java type corresponding to the passed string. - Raises [Exception] if the string does not represent a Java type. - Also Raises [Descriptor.Exception] if the type is invalid. *) - -val java_type_of_utf8_no_void : Utils.UTF8.t -> Descriptor.for_field -(** Same as [java_type_of_utf8] but raises [Descriptor.Exception] if the - decoded type is equal to the Java type {i void}. *) - -val utf8_of_flag : AccessFlag.t -> Utils.UTF8.t -(** Converts the passed flag to its corresponding string. *) - -val utf8_of_flags : AccessFlag.t list -> Utils.UTF8.t -(** Converts the passed flag list to its corresponding string. - Flags are separated by a single space, and a single space is also added at - the end of the returned string. *) - -val flag_of_utf8 : Utils.UTF8.t -> AccessFlag.t -(** Converts the passed string to its corresponding flag. - Raises [Exception] if passed string is not a valid flag string. *) - - -(** {6 Miscellaneous} *) - -val output : OutputStream.t -> Utils.UTF8Buffer.t -> unit -(** Outputs the content of the passed buffer onto the passed stream. - An exception is raised if an error occurs during the write operation. *) - rmfile ./src/helpers/source.mli hunk ./src/tools/assembler.ml 72 - | Source_error of Source.error hunk ./src/tools/assembler.ml 90 + | Several_frames_at_offset of u2 hunk ./src/tools/assembler.ml 103 - | Duplicate_label s -> "duplicate label " ^ s - | Undefined_label s -> "undefined label " ^ s + | Duplicate_label s -> Printf.sprintf "duplicate label %S" s + | Undefined_label s -> Printf.sprintf "undefined label %S" s hunk ./src/tools/assembler.ml 107 - | Invalid_flag s -> "invalid flag " ^ s + | Invalid_flag s -> Printf.sprintf "invalid flag %S" s hunk ./src/tools/assembler.ml 139 - | Lexer_error e -> "lexing error (" ^ (Lexer.string_of_error e) ^ ")" - | Source_error e -> Source.string_of_error e + | Lexer_error e -> Printf.sprintf "lexing error (%s)" (Lexer.string_of_error e) hunk ./src/tools/assembler.ml 157 - | Optimization_error s -> "unable to optimize method (" ^ s ^ ")" + | Optimization_error s -> Printf.sprintf "unable to optimize method (%s)" s + | Several_frames_at_offset x -> Printf.sprintf "several frames at offset %d" (x :> int) hunk ./src/tools/assembler.ml 177 - | Method of Method.t + | Method of int * Method.t hunk ./src/tools/assembler.ml 208 - method fail_line : 'a . int -> error -> 'a = fun n e -> raise (Exception (n, e)) - method fail_err : 'a . error -> 'a = fun e -> raise (Exception (line, e)) - method fail_scope : 'a . 'a = raise (Exception (line, Invalid_scope)) + method fail_line : 'a . int -> error -> 'a = + fun n e -> raise (Exception (n, e)) + method fail_err : 'a . error -> 'a = + fun e -> raise (Exception (line, e)) + method fail_scope : 'a . 'a = + raise (Exception (line, Invalid_scope)) hunk ./src/tools/assembler.ml 262 - let n = Name.external_utf8_for_class i in - if List.exists (fun x -> UTF8.equal n (Name.external_utf8_for_class x)) class_implements then + if List.exists (Name.equal_for_class i) class_implements then hunk ./src/tools/assembler.ml 317 - | Field (x, y, z, t) -> current_scope <- Field (x, y, z, a :: t) + | Field f -> current_scope <- Field { f with Field.attributes = a :: f.Field.attributes } hunk ./src/tools/assembler.ml 321 - | Field (_, _, desc, _) -> - let v = match const_value, desc with + | Field f -> + let v = match const_value, f.Field.descriptor with hunk ./src/tools/assembler.ml 341 - | Method m -> (match m with - | Method.Regular (x, y, z, t) -> - current_scope <- Method (Method.Regular (x, y, z, a :: t)) - | Method.Constructor (x, y, z) -> - current_scope <- Method (Method.Constructor (x, y, a :: z)) - | Method.Initializer (x, y) -> - current_scope <- Method (Method.Initializer (x, a :: y))) + | Method (l, m) -> (match m with + | Method.Regular r -> + current_scope <- Method (l, Method.Regular { r with Method.attributes = a :: r.Method.attributes }) + | Method.Constructor c -> + current_scope <- Method (l, Method.Constructor { c with Method.cstr_attributes = a :: c.Method.cstr_attributes }) + | Method.Initializer i -> + current_scope <- Method (l, Method.Initializer { i with Method.init_attributes = a :: i.Method.init_attributes })) hunk ./src/tools/assembler.ml 588 - u2 s, u2 e, u2 h, caught + { Attribute.try_start = u2 s; + Attribute.try_end = u2 e; + Attribute.catch = u2 h; + Attribute.caught = caught } hunk ./src/tools/assembler.ml 665 + let seen_offsets = ref [] in hunk ./src/tools/assembler.ml 670 + if List.mem ofs !seen_offsets then + self#fail_line line (Several_frames_at_offset ofs) + else + seen_offsets := ofs :: !seen_offsets; hunk ./src/tools/assembler.ml 688 - | [Lexer.Int 2L] -> Attribute.Chop_1_frame ofs - | [Lexer.Int 3L] -> Attribute.Chop_1_frame ofs + | [Lexer.Int 2L] -> Attribute.Chop_2_frame ofs + | [Lexer.Int 3L] -> Attribute.Chop_3_frame ofs hunk ./src/tools/assembler.ml 733 - (u2 start_pc, u2 (end_pc - start_pc + 1), id, elem, u2 idx) in + { Attribute.local_start = u2 start_pc; + Attribute.local_length = u2 (end_pc - start_pc + 1); + Attribute.local_name = id; + Attribute.local_descriptor = elem; + Attribute.local_index = u2 idx } in + let compile_table_type (line, start, finish, id, elem, idx) = + let start_pc = self#get_label_offset line start in + let end_pc = self#get_label_offset line finish in + if end_pc <= start_pc then + self#fail_line line Invalid_offset + else + { Attribute.local_type_start = u2 start_pc; + Attribute.local_type_length = u2 (end_pc - start_pc + 1); + Attribute.local_type_name = id; + Attribute.local_type_signature = elem; + Attribute.local_type_index = u2 idx } in hunk ./src/tools/assembler.ml 756 - [`LocalVariableTypeTable (List.rev_map compile_table local_variable_types)] + [`LocalVariableTypeTable (List.rev_map compile_table_type local_variable_types)] hunk ./src/tools/assembler.ml 830 - | Field (x, y, z, t) -> + | Field f -> hunk ./src/tools/assembler.ml 832 - (x, y, z, (self#compile_annotations :> Attribute.for_field list) - @ (List.rev t)) - :: class_fields - | Method m -> - if current_pc >= 65536 then self#fail_err Code_too_large; + let attrs = + (self#compile_annotations :> Attribute.for_field list) + @ (List.rev f.Field.attributes) in + { f with Field.attributes = attrs } :: class_fields + | Method (start_line, m) -> + if current_pc > max_u2 then self#fail_err Code_too_large; hunk ./src/tools/assembler.ml 867 - raise (Exception (line, (Optimization_error (Printexc.to_string e)))) + raise (Exception (start_line, (Optimization_error (Printexc.to_string e)))) hunk ./src/tools/assembler.ml 897 - | Method.Regular (x, y, z, t) -> - Method.Regular (x, y, z, code @ annot @ (List.rev t)) - | Method.Constructor (x, y, z) -> - Method.Constructor (x, y, code @ annot @ (List.rev z)) - | Method.Initializer (x, y) -> - Method.Initializer (x, code @ annot @ (List.rev y)) in + | Method.Regular r -> + Method.Regular { r with Method.attributes = code @ annot @ (List.rev r.Method.attributes) } + | Method.Constructor c -> + Method.Constructor { c with Method.cstr_attributes = code @ annot @ (List.rev c.Method.cstr_attributes) } + | Method.Initializer i -> + Method.Initializer { i with Method.init_attributes = code @ annot @ (List.rev i.Method.init_attributes) } in hunk ./src/tools/assembler.ml 909 - Source.flag_of_utf8 s + AccessFlag.of_utf8 s hunk ./src/tools/assembler.ml 911 - | Source.Exception _ -> + | AccessFlag.Exception _ -> hunk ./src/tools/assembler.ml 925 -let assemble ?(version=Version.Java_1_6) ?(compute_stacks=false) ?(optimize=false) ?(class_loader=ClassLoader.make (ClassPath.make_of_list ["."])) ic dst = +let assemble ?(version=Version.default) ?(compute_stacks=false) ?(optimize=false) ?(class_loader=ClassLoader.make (ClassPath.make_of_list ["."])) ic dst = hunk ./src/tools/assembler.ml 1001 + let check_version_module () = + version_check "module" Version.Java_1_8 in hunk ./src/tools/assembler.ml 1045 - | Lexer.Array_type at -> Source.java_type_of_utf8 at + | Lexer.Array_type at -> Descriptor.java_type_of_external_utf8 at hunk ./src/tools/assembler.ml 1049 - | Source.Exception _ hunk ./src/tools/assembler.ml 1051 - state#set_scope (Field (f, n, d, [])) + let field = { + Field.flags = f; + Field.name = n; + Field.descriptor = d; + Field.attributes = []; + } in state#set_scope (Field field) hunk ./src/tools/assembler.ml 1063 - let f = List.map state#flag_of_token flags in + let f = List.map state#flag_of_token flags in hunk ./src/tools/assembler.ml 1072 - | Lexer.Array_type at -> Source.java_type_of_utf8 at + | Lexer.Array_type at -> Descriptor.java_type_of_external_utf8 at hunk ./src/tools/assembler.ml 1076 - | Source.Exception _ hunk ./src/tools/assembler.ml 1083 - state#set_scope (Method (Method.Constructor (f', d, [])))) + let mc = { Method.cstr_flags = f'; cstr_descriptor = d; cstr_attributes = [] }in + state#set_scope (Method (state#get_line, Method.Constructor mc))) hunk ./src/tools/assembler.ml 1087 - if List.exists (fun x -> x <> `Strict) f then state#fail_err Invalid_initializer_flags; - let strict = List.mem `Strict f in - state#set_scope (Method (Method.Initializer (strict, [])))) + let f' = try + AccessFlag.check_initializer_flags f + with AccessFlag.Exception _ -> state#fail_err Invalid_constructor_flags in + let mi = { Method.init_flags = f'; init_attributes = [] } in + state#set_scope (Method (state#get_line, Method.Initializer mi))) hunk ./src/tools/assembler.ml 1096 - state#set_scope (Method (Method.Regular (f', id, (d, rt), []))) + let mr = { Method.flags = f'; name = id; descriptor = (d, rt); attributes = [] } in + state#set_scope (Method (state#get_line, Method.Regular mr)) hunk ./src/tools/assembler.ml 1141 - state#add_class_attribute_inner (ic', oc', n', flags) + state#add_class_attribute_inner + { Attribute.inner_class = ic'; + Attribute.outer_class = oc'; + Attribute.inner_name = n'; + Attribute.inner_flags = flags } hunk ./src/tools/assembler.ml 1152 - state#add_class_attribute (`EnclosingMethod (cn, m')) + state#add_class_attribute (`EnclosingMethod { Attribute.innermost_class = cn; + Attribute.enclosing_method = m' }) hunk ./src/tools/assembler.ml 1242 - | Lexer.Array_type at -> Source.java_type_of_utf8 at + | Lexer.Array_type at -> Descriptor.java_type_of_external_utf8 at hunk ./src/tools/assembler.ml 1258 + check_version_module (); hunk ./src/tools/assembler.ml 1329 - | Source.Exception e -> - raise (Exception (state#get_line, (Source_error e))) hunk ./src/tools/assembler.mli 19 -(** This module provides the function called by the {i -asm} switch. *) +(** Assembling of Java assembler source. *) hunk ./src/tools/assembler.mli 68 - | Source_error of Source.error hunk ./src/tools/assembler.mli 86 + | Several_frames_at_offset of Utils.u2 hunk ./src/tools/assembler.mli 96 - (** Assembly results in an append to the passed output stream. *) + (** Assembly results in an append to the passed output stream. *) hunk ./src/tools/assembler.mli 98 - (** Assembly results in a file creation, relatively to the passed path. *) -(** This type describes assembly destination. *) + (** Assembly results in a file creation, relatively to the passed path. *) +(** The type of assembly destination. *) hunk ./src/tools/assembler.mli 102 -(** Assembles the file whose source input channel is passed, - returning the name of the compiled class. The default version used for - class encoding is set to [Version.Java_1_6], and both automatic computation - of stack elements and optimizations are disabled. - The produced class file is written to the passed destination. +(** Assembles the file whose source input channel is passed, returning + the name of the compiled class. The default version used for class + encoding is set to [Version.default], and both automatic computation + of stack elements and optimizations are disabled. The produced class + file is written to the passed destination. hunk ./src/tools/classPrinter.ml 79 -let static_block = UTF8.of_string "static" +let static_block = UTF8.of_string "" hunk ./src/tools/classPrinter.ml 105 -let rec extract_exceptions = function - | (`Exceptions e) :: _ -> e - | _ :: tl -> extract_exceptions tl - | [] -> raise Not_found - -let extract_annotations l = - let rec extract accu = function - | (`RuntimeVisibleAnnotations a) :: tl - | (`RuntimeInvisibleAnnotations a) :: tl -> - extract (accu @ a) tl - | _ :: tl -> extract accu tl - | [] -> accu in - extract [] l - hunk ./src/tools/classPrinter.ml 109 - ++ (UTF8.concat_sep + ++ (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 111 - (List.map utf8_of_formal_type_parameter cs.Signature.formal_type_parameters)) + utf8_of_formal_type_parameter + cs.Signature.formal_type_parameters) hunk ./src/tools/classPrinter.ml 124 - ++ (UTF8.concat_sep + ++ (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 126 - (List.map utf8_of_field_type_signature ftp.Signature.interface_bounds)) + utf8_of_field_type_signature + ftp.Signature.interface_bounds) hunk ./src/tools/classPrinter.ml 145 - ++ (UTF8.concat_sep + ++ (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 147 - (List.map utf8_of_type_argument cts.Signature.type_arguments)) + utf8_of_type_argument + cts.Signature.type_arguments) hunk ./src/tools/classPrinter.ml 155 - | Signature.Base_type jt -> Source.utf8_of_java_type jt + | Signature.Base_type jt -> Descriptor.external_utf8_of_java_type jt hunk ./src/tools/classPrinter.ml 211 - let rec extract_signature = function - | (`Signature (`Class s)) :: _ -> s - | _ :: tl -> extract_signature tl - | [] -> raise Not_found in - let signature = extract_signature cd.ClassDefinition.attributes in + let signature = Attribute.extract_class_signature cd.ClassDefinition.attributes in hunk ./src/tools/classPrinter.ml 233 - (UTF8.concat_sep + (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 235 - (List.map - Name.printable_utf8_for_class - cd.ClassDefinition.implements)) + Name.printable_utf8_for_class + cd.ClassDefinition.implements) hunk ./src/tools/classPrinter.ml 239 -let add_field buffer (flags, name, desc, attrs) = - add_annotations buffer tab (extract_annotations attrs); +let add_field buffer f = + add_annotations buffer tab (Attribute.extract_annotations (f.Field.attributes :> Attribute.t list)); hunk ./src/tools/classPrinter.ml 244 - (Source.utf8_of_flags (List.filter printed_flag (flags :> AccessFlag.t list))); + (AccessFlag.list_to_utf8 (List.filter printed_flag (f.Field.flags :> AccessFlag.t list))); hunk ./src/tools/classPrinter.ml 246 - let rec extract_signature = function - | (`Signature (`Field s)) :: _ -> s - | _ :: tl -> extract_signature tl - | [] -> raise Not_found in - let fts = extract_signature attrs in + let fts = Attribute.extract_field_signature f.Field.attributes in hunk ./src/tools/classPrinter.ml 249 - UTF8Buffer.add_string buffer (Source.utf8_of_java_type (desc :> Descriptor.java_type))); + UTF8Buffer.add_string buffer (Descriptor.external_utf8_of_java_type (f.Field.descriptor :> Descriptor.java_type))); hunk ./src/tools/classPrinter.ml 251 - UTF8Buffer.add_string buffer (Name.utf8_for_field name); + UTF8Buffer.add_string buffer (Name.utf8_for_field f.Field.name); hunk ./src/tools/classPrinter.ml 257 - | Method.Regular (f, n, d, a) -> - (f, (Name.utf8_for_method n), d, a) - | Method.Constructor (f, d, a) -> - ((f :> AccessFlag.for_method list), class_constructor, (d, `Void), a) - | Method.Initializer (s, a) -> - ((if s then [`Strict] else []), class_initializer, ([], `Void), a) in - add_annotations buffer tab (extract_annotations attrs); + | Method.Regular mr -> + mr.Method.flags, + (Name.utf8_for_method mr.Method.name), + mr.Method.descriptor, + mr.Method.attributes + | Method.Constructor mc -> + (mc.Method.cstr_flags :> AccessFlag.for_method list), + class_constructor, + (mc.Method.cstr_descriptor, `Void), + mc.Method.cstr_attributes + | Method.Initializer mi -> + (mi.Method.init_flags :> AccessFlag.for_method list), + class_initializer, + ([], `Void), + mi.Method.init_attributes in + add_annotations buffer tab (Attribute.extract_annotations (attrs :> Attribute.t list)); hunk ./src/tools/classPrinter.ml 276 - (Source.utf8_of_flags (List.filter printed_flag (flags :> AccessFlag.t list))); + (AccessFlag.list_to_utf8 (List.filter printed_flag (flags :> AccessFlag.t list))); hunk ./src/tools/classPrinter.ml 278 - let rec extract_signature = function - | (`Signature (`Method s)) :: _ -> s - | _ :: tl -> extract_signature tl - | [] -> raise Not_found in - let fts = extract_signature attrs in + let fts = Attribute.extract_method_signature attrs in hunk ./src/tools/classPrinter.ml 283 - (UTF8.concat_sep + (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 285 - (List.map utf8_of_formal_type_parameter fts.Signature.formal_type_params)); + utf8_of_formal_type_parameter + fts.Signature.formal_type_params); hunk ./src/tools/classPrinter.ml 301 - (UTF8.concat_sep + (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 303 - (List.map utf8_of_type_signature fts.Signature.types)); + utf8_of_type_signature + fts.Signature.types); hunk ./src/tools/classPrinter.ml 310 - (UTF8.concat_sep + (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 312 - (List.map utf8_of_throws_signature fts.Signature.throws_signatures)) + utf8_of_throws_signature + fts.Signature.throws_signatures) hunk ./src/tools/classPrinter.ml 323 - UTF8Buffer.add_string buffer (Source.utf8_of_java_type return); + UTF8Buffer.add_string buffer (Descriptor.external_utf8_of_java_type return); hunk ./src/tools/classPrinter.ml 330 - (UTF8.concat_sep + (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 332 - (List.map Source.utf8_of_java_type (params :> Descriptor.java_type list))); + Descriptor.external_utf8_of_java_type + (params :> Descriptor.java_type list)); hunk ./src/tools/classPrinter.ml 336 - let thrown = extract_exceptions attrs in + let thrown = Attribute.extract_exceptions (attrs :> Attribute.t list) in hunk ./src/tools/classPrinter.ml 340 - (UTF8.concat_sep + (UTF8.concat_sep_map hunk ./src/tools/classPrinter.ml 342 - (List.map (fun x -> Name.printable_utf8_for_class x) thrown)) + (fun x -> Name.printable_utf8_for_class x) thrown) hunk ./src/tools/classPrinter.ml 349 - add_annotations buffer empty_utf8 (extract_annotations cd.ClassDefinition.attributes); + add_annotations buffer empty_utf8 (Attribute.extract_annotations (cd.ClassDefinition.attributes :> Attribute.t list)); hunk ./src/tools/classPrinter.ml 359 - (Source.utf8_of_flags (flags_to_print :> AccessFlag.t list)); + (AccessFlag.list_to_utf8 (flags_to_print :> AccessFlag.t list)); hunk ./src/tools/classPrinter.ml 369 - (List.sort Source.field_order cd.ClassDefinition.fields); + (List.sort Field.compare cd.ClassDefinition.fields); hunk ./src/tools/classPrinter.ml 372 - (List.sort Source.method_order cd.ClassDefinition.methods); + (List.sort Method.compare cd.ClassDefinition.methods); hunk ./src/tools/classPrinter.ml 375 -let print_to_channel chan cp s = +let print_to_stream chan cp s = hunk ./src/tools/classPrinter.ml 378 - Source.output chan buffer + LineUtils.output chan buffer hunk ./src/tools/classPrinter.ml 381 - print_to_channel (OutputStream.make_of_channel stdout) cp s + print_to_stream OutputStream.stdout cp s hunk ./src/tools/classPrinter.mli 19 -(** This module provides the function called by the {i -print} switch, - as well as variants. *) +(** Printing of class contents. *) hunk ./src/tools/classPrinter.mli 23 -(** [print_to_buffer buffer cp cn] prints onto the passed buffer the - description of the class whose name is [cn] in classpath [cp]. - Raises [ClassLoader.Exception] if the class cannot be loaded. *) +(** [print_to_buffer buff cp cn] appends to the passed buffer [buff] the + description of the class whose name is [cn] in classpath [cp]. + Raises [ClassLoader.Exception] if the class cannot be loaded. *) hunk ./src/tools/classPrinter.mli 27 -val print_to_channel : OutputStream.t -> ClassPath.t -> Utils.UTF8.t -> unit -(** [print_to_channel chan cp cn] prints onto the passed channel the - description of the class whose name is [cn] in classpath [cp]. - Raises [ClassLoader.Exception] if the class cannot be loaded. *) +val print_to_stream : OutputStream.t -> ClassPath.t -> Utils.UTF8.t -> unit +(** [print_to_stream chan cp cn] prints onto the passed channel [chan] + the description of the class whose name is [cn] in classpath [cp]. + Raises [ClassLoader.Exception] if the class cannot be loaded. *) hunk ./src/tools/classPrinter.mli 33 -(** [print cp cn] prints onto the standard output the description of the class - whose name is [cn] in classpath [cp]. - Raises [ClassLoader.Exception] if the class cannot be loaded. *) +(** [print cp cn] prints onto the standard output the description of the + class whose name is [cn] in classpath [cp]. + Raises [ClassLoader.Exception] if the class cannot be loaded. *) hunk ./src/tools/disassembler.ml 93 - (Source.utf8_of_java_type return) + (Descriptor.external_utf8_of_java_type return) hunk ./src/tools/disassembler.ml 97 - ++ (UTF8.concat_sep comma (List.map Source.utf8_of_java_type (params :> Descriptor.java_type list))) + ++ (UTF8.concat_sep_map comma Descriptor.external_utf8_of_java_type (params :> Descriptor.java_type list)) hunk ./src/tools/disassembler.ml 104 - ++ (UTF8.concat_sep comma (List.map Source.utf8_of_java_type (params :> Descriptor.java_type list))) + ++ (UTF8.concat_sep_map comma Descriptor.external_utf8_of_java_type (params :> Descriptor.java_type list)) hunk ./src/tools/disassembler.ml 107 - ++ (Source.utf8_of_java_type return) + ++ (Descriptor.external_utf8_of_java_type return) hunk ./src/tools/disassembler.ml 121 - (List.sort (fun (x, _, _, _, _) (y, _, _, _, _) -> compare x y) lvt), - (List.sort (fun (x, _, _, _, _) (y, _, _, _, _) -> compare x y) lvtt), + (List.sort (fun { Attribute.local_start = x; _ } { Attribute.local_start = y; _ } -> compare x y) lvt), + (List.sort (fun { Attribute.local_type_start = x; _ } { Attribute.local_type_start = y; _ } -> compare x y) lvtt), hunk ./src/tools/disassembler.ml 232 - (fun (start, length, name, desc, index) -> - let start = (start : u2 :> int) in - let length = (length : u2 :> int) in - let index = (index : u2 :> int) in + (fun { Attribute.local_start; local_length; local_name; local_descriptor; local_index } -> + let start = (local_start : u2 :> int) in + let length = (local_length : u2 :> int) in + let index = (local_index : u2 :> int) in hunk ./src/tools/disassembler.ml 241 - UTF8Buffer.add_string buffer name; + UTF8Buffer.add_string buffer local_name; hunk ./src/tools/disassembler.ml 243 - UTF8Buffer.add_string buffer (Source.utf8_of_java_type (desc :> Descriptor.java_type)); + UTF8Buffer.add_string buffer (Descriptor.external_utf8_of_java_type (local_descriptor :> Descriptor.java_type)); hunk ./src/tools/disassembler.ml 248 - (fun (start, length, name, sign, index) -> - let start = (start : u2 :> int) in - let length = (length : u2 :> int) in - let index = (index : u2 :> int) in + (fun { Attribute.local_type_start; local_type_length; local_type_name; local_type_signature; local_type_index } -> + let start = (local_type_start : u2 :> int) in + let length = (local_type_length : u2 :> int) in + let index = (local_type_index : u2 :> int) in hunk ./src/tools/disassembler.ml 257 - UTF8Buffer.add_string buffer name; + UTF8Buffer.add_string buffer local_type_name; hunk ./src/tools/disassembler.ml 259 - UTF8Buffer.add_string buffer (UTF8.escape (Signature.utf8_of_field_type_signature sign)); + UTF8Buffer.add_string buffer (UTF8.escape (Signature.utf8_of_field_type_signature local_type_signature)); hunk ./src/tools/disassembler.ml 283 - UTF8Buffer.add_string buffer (Source.utf8_of_java_type pt) + UTF8Buffer.add_string buffer (Descriptor.external_utf8_of_java_type pt) hunk ./src/tools/disassembler.ml 291 - ++ (Source.utf8_of_java_type (d :> Descriptor.java_type))) + ++ (Descriptor.external_utf8_of_java_type (d :> Descriptor.java_type))) hunk ./src/tools/disassembler.ml 305 - ((Source.utf8_of_java_type (at :> Descriptor.java_type)) + ((Descriptor.external_utf8_of_java_type (at :> Descriptor.java_type)) hunk ./src/tools/disassembler.ml 334 - (fun (start_pc, end_pc, handler_pc, catch_type) -> - let start_pc = (start_pc : u2 :> int) in - let end_pc = (end_pc : u2 :> int) in - let handler_pc = (handler_pc : u2 :> int) in + (fun elem -> + let start_pc = (elem.Attribute.try_start : u2 :> int) in + let end_pc = (elem.Attribute.try_end : u2 :> int) in + let handler_pc = (elem.Attribute.catch : u2 :> int) in hunk ./src/tools/disassembler.ml 343 - (match catch_type with + (match elem.Attribute.caught with hunk ./src/tools/disassembler.ml 356 - | Attribute.Object_variable_info (`Array_type at) -> Source.utf8_of_java_type (at :> Descriptor.java_type) + | Attribute.Object_variable_info (`Array_type at) -> Descriptor.external_utf8_of_java_type (at :> Descriptor.java_type) hunk ./src/tools/disassembler.ml 397 - let utf8_of_type_list l = UTF8.concat_sep space (List.map utf8_of_type l) in + let utf8_of_type_list l = UTF8.concat_sep_map space utf8_of_type l in hunk ./src/tools/disassembler.ml 414 - ++ (UTF8.concat_sep + ++ (UTF8.concat_sep_map hunk ./src/tools/disassembler.ml 416 - (List.map Name.external_utf8_for_class e))) + Name.external_utf8_for_class e)) hunk ./src/tools/disassembler.ml 420 - (function (inner, outer, name, flags) -> + (function { Attribute.inner_class; outer_class; inner_name; inner_flags } -> hunk ./src/tools/disassembler.ml 422 - ++ (match inner with + ++ (match inner_class with hunk ./src/tools/disassembler.ml 426 - ++ (match outer with + ++ (match outer_class with hunk ./src/tools/disassembler.ml 430 - ++ (match name with + ++ (match inner_name with hunk ./src/tools/disassembler.ml 434 - ++ (Source.utf8_of_flags (flags :> AccessFlag.t list))) + ++ (AccessFlag.list_to_utf8 (inner_flags :> AccessFlag.t list))) hunk ./src/tools/disassembler.ml 439 - | `EnclosingMethod (cn, m) -> + | `EnclosingMethod { Attribute.innermost_class; enclosing_method } -> hunk ./src/tools/disassembler.ml 441 - UTF8Buffer.add_string buffer (Name.external_utf8_for_class cn); - (match m with + UTF8Buffer.add_string buffer (Name.external_utf8_for_class innermost_class); + (match enclosing_method with hunk ./src/tools/disassembler.ml 529 - ++ (Source.utf8_of_flags (cd.ClassDefinition.access_flags :> AccessFlag.t list)) + ++ (AccessFlag.list_to_utf8 (cd.ClassDefinition.access_flags :> AccessFlag.t list)) hunk ./src/tools/disassembler.ml 547 - Source.attribute_order + Attribute.compare hunk ./src/tools/disassembler.ml 552 - (fun (flags, name, desc, attrs) -> - UTF8Buffer.add_endline buffer empty_utf8; - UTF8Buffer.add_endline - buffer - (dot_field - ++ (Source.utf8_of_flags (List.sort Source.flag_order (flags :> AccessFlag.t list))) - ++ (Source.utf8_of_java_type (desc :> Descriptor.java_type)) - ++ space - ++ (Name.utf8_for_field name)); - List.iter - (add_attribute buffer) + (fun f -> + UTF8Buffer.add_endline buffer empty_utf8; + UTF8Buffer.add_endline + buffer + (dot_field + ++ (AccessFlag.list_to_utf8 (List.sort AccessFlag.compare (f.Field.flags :> AccessFlag.t list))) + ++ (Descriptor.external_utf8_of_java_type (f.Field.descriptor :> Descriptor.java_type)) + ++ space + ++ (Name.utf8_for_field f.Field.name)); + List.iter + (add_attribute buffer) hunk ./src/tools/disassembler.ml 564 - Source.attribute_order - (attrs :> Attribute.t list))) - (List.sort Source.field_order cd.ClassDefinition.fields); + Attribute.compare + (f.Field.attributes :> Attribute.t list))) + (List.sort Field.compare cd.ClassDefinition.fields); hunk ./src/tools/disassembler.ml 573 - | Method.Regular (f, n, d, a) -> (f, n, d, a) - | Method.Constructor (f, d, a) -> ((f :> AccessFlag.for_method list), class_constructor_name, (d, `Void), a) - | Method.Initializer (s, a) -> ((if s then [`Strict] else []), class_initializer_name, ([], `Void), a) in + | Method.Regular mr -> + mr.Method.flags, + mr.Method.name, + mr.Method.descriptor, + mr.Method.attributes + | Method.Constructor mc -> + (mc.Method.cstr_flags :> AccessFlag.for_method list), + class_constructor_name, + (mc.Method.cstr_descriptor, `Void), + mc.Method.cstr_attributes + | Method.Initializer mi -> + (mi.Method.init_flags :> AccessFlag.for_method list), + class_initializer_name, + ([], `Void), + mi.Method.init_attributes in hunk ./src/tools/disassembler.ml 592 - ++ (Source.utf8_of_flags (flags :> AccessFlag.t list)) + ++ (AccessFlag.list_to_utf8 (flags :> AccessFlag.t list)) hunk ./src/tools/disassembler.ml 597 - Source.attribute_order + Attribute.compare hunk ./src/tools/disassembler.ml 599 - (List.sort Source.method_order cd.ClassDefinition.methods) + (List.sort Method.compare cd.ClassDefinition.methods) hunk ./src/tools/disassembler.ml 601 -let disassemble_to_channel chan cp s = +let disassemble_to_stream chan cp s = hunk ./src/tools/disassembler.ml 604 - Source.output chan buffer + LineUtils.output chan buffer hunk ./src/tools/disassembler.ml 607 - disassemble_to_channel (OutputStream.make_of_channel stdout) cp s + disassemble_to_stream OutputStream.stdout cp s hunk ./src/tools/disassembler.mli 19 -(** This module provides the function called by the {i -dasm} switch, - as well as variants. *) +(** Disassembling of class contents. *) hunk ./src/tools/disassembler.mli 23 -(** [disassemble_to_buffer buffer cp cn] disassembles the class whose name is - [cn] in classpath [cp]. The resultat is appended to [buffer]. - Raises [ClassLoader.Exception] if the class cannot be loaded. *) +(** [disassemble_to_buffer buff cp cn] disassembles the class whose name + is [cn] in classpath [cp]. The result is appended to [buff]. + Raises [ClassLoader.Exception] if the class cannot be loaded. *) hunk ./src/tools/disassembler.mli 27 -val disassemble_to_channel : OutputStream.t -> ClassPath.t -> Utils.UTF8.t -> unit -(** [disassemble_to_channel chan cp cn] disassembles the class whose name is - [cn] in classpath [cp]. The resultat is printed on [chan]. - Raises [ClassLoader.Exception] if the class cannot be loaded. *) +val disassemble_to_stream : OutputStream.t -> ClassPath.t -> Utils.UTF8.t -> unit +(** [disassemble_to_stream chan cp cn] disassembles the class whose name + is [cn] in classpath [cp]. The result is printed onto [chan]. + Raises [ClassLoader.Exception] if the class cannot be loaded. *) hunk ./src/tools/disassembler.mli 33 -(** [disassemble cp cn] disassembles the class whose name is [cn] in classpath - [cp]. The resultat is printed on the standard output. - Raises [ClassLoader.Exception] if the class cannot be loaded. *) +(** [disassemble cp cn] disassembles the class whose name is [cn] in + classpath [cp]. The result is printed on the standard output. + Raises [ClassLoader.Exception] if the class cannot be loaded. *) hunk ./src/tools/flowPrinter.ml 22 - | Invalid_parameter + | Invalid_desciptor of UTF8.t hunk ./src/tools/flowPrinter.ml 31 - | Invalid_parameter -> "invalid '-flow' parameter" + | Invalid_desciptor s -> + Printf.sprintf "invalid method descriptor %S" (UTF8.to_string_noerr s) hunk ./src/tools/flowPrinter.ml 42 -let print ld s = +let print_to_buffer buffer ld s = hunk ./src/tools/flowPrinter.ml 48 - | _ -> fail Invalid_parameter - with _ -> fail Invalid_parameter in + | _ -> fail (Invalid_desciptor s) + with _ -> fail (Invalid_desciptor s) in hunk ./src/tools/flowPrinter.ml 56 - let rec eq_type x y = - match (x, y) with - | (`Class cn1), (`Class cn2) -> - Utils.UTF8.equal - (Name.internal_utf8_for_class cn1) - (Name.internal_utf8_for_class cn2) - | (`Array a1), (`Array a2) -> - eq_type (a1 :> Descriptor.java_type) (a2 :> Descriptor.java_type) - | _ -> x = y in - let eq_params l l' = - ((List.length l) = (List.length l')) - && (List.for_all2 eq_type (l :> Descriptor.java_type list) (l' :> Descriptor.java_type list)) in + let eq_type = Descriptor.equal_java_type in + let eq_params l l' = + list_equal + ~eq:eq_type + (l :> Descriptor.java_type list) + (l' :> Descriptor.java_type list) in hunk ./src/tools/flowPrinter.ml 64 - | Method.Regular (_, name, (params, ret), _) -> + | Method.Regular { Method.name = name; descriptor = (params, ret); _ } -> hunk ./src/tools/flowPrinter.ml 68 - | Method.Constructor (_, params, _) -> + | Method.Constructor { Method.cstr_descriptor = params; _ } -> hunk ./src/tools/flowPrinter.ml 76 - let rec extract_code = function - | (`Code x) :: _ -> x - | _ :: tl -> extract_code tl - | [] -> fail Method_has_no_code in hunk ./src/tools/flowPrinter.ml 77 - extract_code - (match meth with - | Method.Regular (_, _, _, a) -> a - | Method.Constructor (_, _, a) -> a - | Method.Initializer (_, a) -> a) in + try + Attribute.extract_code + ((match meth with + | Method.Regular { Method.attributes = a; _ } -> a + | Method.Constructor { Method.cstr_attributes = a; _ } -> a + | Method.Initializer { Method.init_attributes = a; _ } -> a) :> Attribute.t list) + with _ -> fail Method_has_no_code in hunk ./src/tools/flowPrinter.ml 93 - print_endline dot + let dot = UTF8.of_string dot in + UTF8Buffer.add_string buffer dot + +let print_to_stream chan ld s = + let buffer = UTF8Buffer.make () in + print_to_buffer buffer ld s; + LineUtils.output chan buffer + +let print ld s = + print_to_stream OutputStream.stdout ld s hunk ./src/tools/flowPrinter.mli 19 -(** This module provides the function called by the {i -flow} switch. *) +(** Printing of method control flow. *) hunk ./src/tools/flowPrinter.mli 22 - | Invalid_parameter + | Invalid_desciptor of Utils.UTF8.t hunk ./src/tools/flowPrinter.mli 32 +val print_to_buffer : Utils.UTF8Buffer.t -> ClassLoader.t -> Utils.UTF8.t -> unit +(** [print_to_stream buff cl cn] appends to the passed buffer [buff] the + control flow of the method whose descriptor is [mn] in classloader + [cp]. + Raises [ClassLoader.Exception] if the class cannot be loaded. + Raises [Exception] if method name is invalid, or method has no code. *) + +val print_to_stream : OutputStream.t -> ClassLoader.t -> Utils.UTF8.t -> unit +(** [print_to_stream st cl cn] prints onto the passed stream the control + flow of the method whose descriptor is [mn] in classloader [cp]. + Raises [ClassLoader.Exception] if the class cannot be loaded. + Raises [Exception] if method name is invalid, or method has no code. *) + hunk ./src/tools/flowPrinter.mli 47 - method whose name is [mn] in classpath [cp]. + method whose descriptor is [mn] in classloader [cl]. hunk ./src/utf8/uCharImpl.ml 44 +let to_char_noerr x = + try + UChar.char_of x + with _ -> '?' + hunk ./src/utf8/uCharImpl.mli 43 +val to_char_noerr : t -> char +(** Equivalent to [to_char], except that any exception is discarded and + ['?'] is returned. *) + hunk ./src/utf8/uTF8Impl.ml 163 +let to_string_noerr s = + try + to_string s + with _ -> "..." + hunk ./src/utf8/uTF8Impl.ml 275 +let concat_sep_map sep f l = + let l' = List.map f l in + concat_sep sep l' + hunk ./src/utf8/uTF8Impl.mli 71 +val to_string_noerr : t -> string +(** Equivalent to [to_string], except that any exception is discarded and + ["..."] is returned. *) + hunk ./src/utf8/uTF8Impl.mli 130 -(** [concat sep l] returns the concatenation of all strings in [l], +(** [concat_sep sep l] returns the concatenation of all strings in [l], hunk ./src/utf8/uTF8Impl.mli 133 +val concat_sep_map : t -> ('a -> t) -> 'a list -> t +(** [concat_sep_map sep f l] returns the concatenation of all strings in + [l'], separator [sep] being inserted between two strings. + [l'] is defined as [List.map f l]. *) + hunk ./src/utf8/uTF8LexerStateImpl.ml 52 + method peek = + self#check_available; + UCharImpl.of_camomile (UTF8.look s next) + hunk ./src/utf8/uTF8LexerStateImpl.mli 42 + method peek : UCharImpl.t + (** Returns [true] the next character if one is available. + Raises [Exception] if end of string is encountered. *) + hunk ./tests/601-api-print/Makefile.java 1 -include ../makefiles/Makefile.api rmfile ./tests/601-api-print/Makefile.java hunk ./tests/601-api-print/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import fr.x9c.barista.api.API; -import fr.x9c.barista.api.BaristaException; -import fr.x9c.barista.api.ClassPath; -import fr.x9c.barista.api.Printer; - -public final class Source { - - public static void main(final String[] args) { - Printer.print("Source", - new ClassPath("."), - (java.io.OutputStream) System.out); - try { - Printer.print("NotFound", - new ClassPath("."), - (java.io.OutputStream) System.out); - } catch (final BaristaException be) { - System.out.println("ERROR: " + be.toString()); - } - } - -} rmfile ./tests/601-api-print/Source.java hunk ./tests/601-api-print/reference 1 -public final class Source extends java.lang.Object { - public Source(); - public static void main(java.lang.String[]); -} -ERROR: fr.x9c.barista.api.BaristaException: class 'NotFound' not found rmfile ./tests/601-api-print/reference rmdir ./tests/601-api-print hunk ./tests/602-api-dasm/Makefile.java 1 -include ../makefiles/Makefile.api rmfile ./tests/602-api-dasm/Makefile.java hunk ./tests/602-api-dasm/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import fr.x9c.barista.api.API; -import fr.x9c.barista.api.BaristaException; -import fr.x9c.barista.api.ClassPath; -import fr.x9c.barista.api.Disassembler; - -public final class Source { - - public static void main(final String[] args) { - Disassembler.disassemble("Source", - new ClassPath("."), - (java.io.OutputStream) System.out); - try { - Disassembler.disassemble("NotFound", - new ClassPath("."), - (java.io.OutputStream) System.out); - } catch (final BaristaException be) { - System.out.println("ERROR: " + be.toString()); - } - } - -} rmfile ./tests/602-api-dasm/Source.java hunk ./tests/602-api-dasm/reference 1 -.class public final super Source -.extends java.lang.Object - @SourceFile "Source.java" - - -.method public void () - .max_stack 1 - .max_locals 1 - @LineNumberTable 24 - code00000000: aload_0 - code00000001: invokespecial java.lang.Object.():void - code00000004: return - -.method public static void main(java.lang.String[]) - .max_stack 4 - .max_locals 2 - @LineNumberTable 27 - code00000000: ldc "Source" - code00000002: new fr.x9c.barista.api.ClassPath - code00000005: dup - code00000006: ldc "." - code00000008: invokespecial fr.x9c.barista.api.ClassPath.(java.lang.String):void - code00000011: getstatic java.lang.System.out:java.io.PrintStream - code00000014: invokestatic fr.x9c.barista.api.Disassembler.disassemble(java.lang.String,fr.x9c.barista.api.ClassPath,java.io.OutputStream):void - @LineNumberTable 31 - code00000017: ldc "NotFound" - code00000019: new fr.x9c.barista.api.ClassPath - code00000022: dup - code00000023: ldc "." - code00000025: invokespecial fr.x9c.barista.api.ClassPath.(java.lang.String):void - code00000028: getstatic java.lang.System.out:java.io.PrintStream - code00000031: invokestatic fr.x9c.barista.api.Disassembler.disassemble(java.lang.String,fr.x9c.barista.api.ClassPath,java.io.OutputStream):void - @LineNumberTable 36 - code00000034: goto code00000066: - @LineNumberTable 34 - code00000037: astore_1 - @LineNumberTable 35 - code00000038: getstatic java.lang.System.out:java.io.PrintStream - code00000041: new java.lang.StringBuilder - code00000044: dup - code00000045: invokespecial java.lang.StringBuilder.():void - code00000048: ldc "ERROR: " - code00000050: invokevirtual java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder - code00000053: aload_1 - code00000054: invokevirtual fr.x9c.barista.api.BaristaException.toString():java.lang.String - code00000057: invokevirtual java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder - code00000060: invokevirtual java.lang.StringBuilder.toString():java.lang.String - code00000063: invokevirtual java.io.PrintStream.println(java.lang.String):void - @LineNumberTable 37 - code00000066: return - .catch code00000017: code00000034: code00000037: fr.x9c.barista.api.BaristaException - .frame code00000037: same_locals fr.x9c.barista.api.BaristaException - .frame code00000066: same - -ERROR: fr.x9c.barista.api.BaristaException: class 'NotFound' not found rmfile ./tests/602-api-dasm/reference rmdir ./tests/602-api-dasm hunk ./tests/603-api-asm/Makefile.java 1 -include ../makefiles/Makefile.api-asm rmfile ./tests/603-api-asm/Makefile.java hunk ./tests/603-api-asm/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import fr.x9c.barista.api.API; -import fr.x9c.barista.api.Assembler; -import fr.x9c.barista.api.BaristaException; - -public final class Source { - - public static void main(final String[] args) throws java.io.IOException { - final String res = - Assembler.assemble(new java.io.FileInputStream("source.j"), "."); - if (!res.equals("pack.Test")) { - System.out.printf("unwaited compiled class: %s", res); - System.exit(1); - } - } - -} rmfile ./tests/603-api-asm/Source.java hunk ./tests/603-api-asm/reference 1 -hello ... - ... "world" rmfile ./tests/603-api-asm/reference hunk ./tests/603-api-asm/source.j 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -.class public final pack.Test -.extends java.lang.Object - -.field private static final java.lang.String PREFIX - @ConstantValue " - << " - -.field private static final java.lang.String SUFFIX - @ConstantValue " >>" - -.method public static void print(java.lang.String) - getstatic java.lang.System.out:java.io.PrintStream - dup - dup - getstatic pack.Test.PREFIX: java.lang.String - invokevirtual java.io.PrintStream.print(java.lang.String): void - aload_0 - invokevirtual java.io.PrintStream.print(java.lang.String) :void - getstatic pack.Test.SUFFIX :java.lang.String - invokevirtual java.io.PrintStream.println(java.lang.String) : void - return - -.method public static void main(java.lang.String[]) - nop - getstatic java.lang.System.out : java.io.PrintStream - ldc "hello\t... \n\t... \"world\"" - invokevirtual java.io.PrintStream.println(java.lang.String):void - - iconst_0 - istore_1 - aload_0 - arraylength - istore_2 -loop: - iload_1 - iload_2 - if_icmpeq end: - aload_0 - iload_1 - aaload - invokestatic pack.Test.print(java.lang.String):void - iinc 1 1 - goto loop: -end: - return rmfile ./tests/603-api-asm/source.j rmdir ./tests/603-api-asm hunk ./tests/604-api-decode/Makefile.java 1 -include ../makefiles/Makefile.api rmfile ./tests/604-api-decode/Makefile.java hunk ./tests/604-api-decode/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import fr.x9c.barista.api.ByteCode; -import fr.x9c.barista.api.ClassDefinition; -import java.io.FileInputStream; - -public final class Source { - - public static void main(final String[] args) { - try { - final ClassDefinition cd = ByteCode.decode(new FileInputStream("./Source.class")); - System.out.println(cd.toString()); - } catch (final Throwable t) { - System.out.println("ERROR: " + t.toString()); - } - } - -} rmfile ./tests/604-api-decode/Source.java hunk ./tests/604-api-decode/reference 1 -Public Final Super class Source extends java.lang.Object { - Public (); - Public Static void main(java.lang.String[]); -} rmfile ./tests/604-api-decode/reference rmdir ./tests/604-api-decode hunk ./tests/701-task-print/Makefile.java 1 -include ../makefiles/Makefile.ant - rmfile ./tests/701-task-print/Makefile.java hunk ./tests/701-task-print/build.xml 1 - - - - - - - - - - - - - - - - - - - - - - rmfile ./tests/701-task-print/build.xml hunk ./tests/701-task-print/reference 1 -public class pack.TestGen> extends java.lang.Object { - public A field; - public pack.TestGen(); - public static > void f_extends(T); - public static > void f_star(T); - public static > void f_super(T); -} rmfile ./tests/701-task-print/reference rmdir ./tests/701-task-print hunk ./tests/702-task-dasm/Makefile.java 1 -include ../makefiles/Makefile.ant - rmfile ./tests/702-task-dasm/Makefile.java hunk ./tests/702-task-dasm/build.xml 1 - - - - - - - - - - - - - - - - - - - - - - rmfile ./tests/702-task-dasm/build.xml hunk ./tests/702-task-dasm/reference 1 -.class public super pack.TestGen -.extends java.lang.Object - @SourceFile "TestGen.java" - @Signature ";>Ljava/lang/Object;" - - -.field public java.lang.Number field - @Signature "TA;" - - -.method public void () - .max_stack 1 - .max_locals 1 - @LineNumberTable 3 - code00000000: aload_0 - code00000001: invokespecial java.lang.Object.():void - code00000004: return - -.method public static void f_extends(java.lang.Comparable) - @Signature ";>(TT;)V" - .max_stack 0 - .max_locals 1 - @LineNumberTable 6 - code00000000: return - -.method public static void f_star(java.lang.Comparable) - @Signature ";>(TT;)V" - .max_stack 0 - .max_locals 1 - @LineNumberTable 7 - code00000000: return - -.method public static void f_super(java.lang.Comparable) - @Signature ";>(TT;)V" - .max_stack 0 - .max_locals 1 - @LineNumberTable 5 - code00000000: return - rmfile ./tests/702-task-dasm/reference rmdir ./tests/702-task-dasm hunk ./tests/703-task-asm/Makefile.java 1 -include ../makefiles/Makefile.ant-asm - rmfile ./tests/703-task-asm/Makefile.java hunk ./tests/703-task-asm/build.xml 1 - - - - - - - - - - - - - - - - - - rmfile ./tests/703-task-asm/build.xml hunk ./tests/703-task-asm/reference 1 -hello ... - ... "world" rmfile ./tests/703-task-asm/reference hunk ./tests/703-task-asm/source.j 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -.class public final pack.Test -.extends java.lang.Object - -.field private static final java.lang.String PREFIX - @ConstantValue " - << " - -.field private static final java.lang.String SUFFIX - @ConstantValue " >>" - -.method public static void print(java.lang.String) - getstatic java.lang.System.out:java.io.PrintStream - dup - dup - getstatic pack.Test.PREFIX: java.lang.String - invokevirtual java.io.PrintStream.print(java.lang.String): void - aload_0 - invokevirtual java.io.PrintStream.print(java.lang.String) :void - getstatic pack.Test.SUFFIX :java.lang.String - invokevirtual java.io.PrintStream.println(java.lang.String) : void - return - -.method public static void main(java.lang.String[]) -.max_locals 3 - nop - getstatic java.lang.System.out : java.io.PrintStream - ldc "hello\t... \n\t... \"world\"" - invokevirtual java.io.PrintStream.println(java.lang.String):void - - iconst_0 - istore_1 - aload_0 - arraylength - istore_2 -loop: - iload_1 - iload_2 - if_icmpeq end: - aload_0 - iload_1 - aaload - invokestatic pack.Test.print(java.lang.String):void - iinc 1 1 - goto loop: -end: - return -.frame loop: full java.lang.String[] int int ~ -.frame end: full top top top ~ rmfile ./tests/703-task-asm/source.j rmdir ./tests/703-task-asm hunk ./tests/java/tests/Common.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -package tests; - -import java.util.Collections; -import java.util.LinkedList; -import java.util.List; - -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; - -public final class Common { - - public static List descs(Descriptor... l) { - final List res = new LinkedList(); - for (Descriptor d : l) { - res.add(d); - } - return res; - } - - public static Method compileMethod(final List qualifiers, - final String name, - final Descriptor ret, - final List parameters, - final int maxStack, - final int maxLocals, - final List exceptionsTable, - final List attributes, - final List methAttributes, - final List instructions) { - final Attribute.CodeValue code = - new Attribute.CodeValue(maxStack, - maxLocals, - instructions, - exceptionsTable, - attributes); - final List attrs = new LinkedList(); - attrs.add(new Attribute.Code(code)); - attrs.addAll(methAttributes); - return new Method(qualifiers, name, ret, parameters, attrs); - } - - public static Method compileMethod(final List instructions) { - return compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - instructions); - } - - public static Method compileConstructor(final List qualifiers, - final List parameters, - final int maxStack, - final int maxLocals, - final List exceptionsTable, - final List attributes, - final List instructions) { - final Attribute.CodeValue code = - new Attribute.CodeValue(maxStack, - maxLocals, - instructions, - exceptionsTable, - attributes); - return new Method(qualifiers, parameters, Collections.singletonList(new Attribute.Code(code))); - } - - public static Method compileConstructor(final List instructions) { - return compileConstructor(asList(AccessFlag.Public), - Collections.emptyList(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - instructions); - } - - public static Method compileInitializer(final boolean strict, - final int maxStack, - final int maxLocals, - final List exceptionsTable, - final List attributes, - final List instructions) { - final Attribute.CodeValue code = - new Attribute.CodeValue(maxStack, - maxLocals, - instructions, - exceptionsTable, - attributes); - return new Method(strict, Collections.singletonList(new Attribute.Code(code))); - } - - public static Method compileInitializer(final List instructions) { - return compileInitializer(false, - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - instructions); - } - - public static ClassDefinition compileClass(final List qualifiers, - final String name, - final String parent, - final List parents, - final List fields, - final List attributes, - final List methods) { - return new ClassDefinition(qualifiers == null - ? asList(AccessFlag.Public, AccessFlag.Super, AccessFlag.Final) - : qualifiers, - name == null ? "pack.Test" : name, - parent == null ? "java.lang.Object" : parent, - parents == null ? Collections.emptyList() : parents, - fields == null ? Collections.emptyList() : fields, - methods, - attributes == null ? Collections.emptyList() : attributes); - } - -} rmfile ./tests/java/tests/Common.java rmdir ./tests/java/tests rmdir ./tests/java hunk ./Makefile 54 - $(OCAMLBUILD) $(OCAMLBUILD_FLAGS) $(PROJECT_NAME).byte $(PROJECT_NAME).native + if [ -x "$(PATH_OCAML_PREFIX)/bin/ocamljava" ]; then \ + $(OCAMLBUILD) $(OCAMLBUILD_FLAGS) $(PROJECT_NAME).byte $(PROJECT_NAME).native $(PROJECT_NAME).jar; \ + else \ + $(OCAMLBUILD) $(OCAMLBUILD_FLAGS) $(PROJECT_NAME).byte $(PROJECT_NAME).native; \ + fi hunk ./Makefile 78 - $(PATH_OCAMLFIND) install $(PROJECT_NAME) META -optional $(PATH_BUILD)/$(PROJECT_NAME)Library.cm* $(PATH_BUILD)/$(PROJECT_NAME)Library.a $(PATH_BUILD)/$(PROJECT_NAME)Library.o $(PATH_BUILD)/src/$(PROJECT_NAME).byte $(PATH_BUILD)/src/$(PROJECT_NAME).native; \ + $(PATH_OCAMLFIND) install $(PROJECT_NAME) META -optional $(PATH_BUILD)/$(PROJECT_NAME)Library.cm* $(PATH_BUILD)/$(PROJECT_NAME)Library.a $(PATH_BUILD)/$(PROJECT_NAME)Library.ja $(PATH_BUILD)/$(PROJECT_NAME)Library.o $(PATH_BUILD)/src/driver/$(PROJECT_NAME).byte $(PATH_BUILD)/src/driver/$(PROJECT_NAME).native; \ hunk ./Makefile 81 - for ext in cma cmxa a; do \ + for ext in cma cmxa cmja a ja; do \ hunk ./Makefile 84 - for ext in byte native; do \ - test -f $(PATH_BUILD)/src/$(PROJECT_NAME).$$ext && cp $(PATH_BUILD)/src/$(PROJECT_NAME).$$ext $(PATH_OCAML_PREFIX)/bin || true; \ - done \ + for ext in byte native jar; do \ + test -f $(PATH_BUILD)/src/driver/$(PROJECT_NAME).$$ext && cp $(PATH_BUILD)/src/driver/$(PROJECT_NAME).$$ext $(PATH_OCAML_PREFIX)/bin || true; \ + done; \ + if [ -x "$(PATH_OCAML_PREFIX)/bin/barista.native" ]; then \ + ln -s -f $(PATH_OCAML_PREFIX)/bin/barista.native $(PATH_OCAML_PREFIX)/bin/barista; \ + else \ + ln -s -f $(PATH_OCAML_PREFIX)/bin/barista.byte $(PATH_OCAML_PREFIX)/bin/barista; \ + fi \ hunk ./_tags 25 - and not "src/driver/barista.ml" and not "src/driver/args.ml{,i}": for-pack(BaristaLibrary) + and not "src/driver/barista.ml": for-pack(BaristaLibrary) hunk ./_tags 30 -"src/common/version.mli": src_common_version_ml +"src/common/currentVersion.mli": src_common_currentVersion_ml hunk ./myocamlbuild.ml 24 -let excluded_modules = [ "Args" ] +let excluded_modules = [] hunk ./myocamlbuild.ml 54 -let version_tag = "src_common_version_ml" +let version_tag = "src_common_currentVersion_ml" hunk ./myocamlbuild.ml 70 + flag ["ocaml"; "doc"] (A"-sort"); hunk ./tests/004-unit-descriptor/source.ml 44 - fail_if' s' (utf8_of_java_type (java_type_of_utf8 s')) in + fail_if' s' (internal_utf8_of_java_type (java_type_of_internal_utf8 s')) in hunk ./tests/004-unit-descriptor/source.ml 54 - fail_if' (u "[C") (utf8_of_java_type (`Array `Char)); - fail_if' (u "La/b/Cls;") (utf8_of_java_type (`Class (Name.make_for_class_from_external (u "a.b.Cls")))); + fail_if' (u "[C") (internal_utf8_of_java_type (`Array `Char)); + fail_if' (u "La/b/Cls;") (internal_utf8_of_java_type (`Class (Name.make_for_class_from_external (u "a.b.Cls")))); hunk ./tests/007-unit-source/source.ml 20 -open Source +open Descriptor hunk ./tests/007-unit-source/source.ml 37 - fail_if' s' (utf8_of_java_type (java_type_of_utf8 s')); - fail_if' s' (utf8_of_java_type ((java_type_of_utf8_no_void s') :> Descriptor.java_type)) in + fail_if' s' (external_utf8_of_java_type (java_type_of_external_utf8 s')); + fail_if' s' (external_utf8_of_java_type ((java_type_of_external_utf8_no_void s') :> java_type)) in hunk ./tests/007-unit-source/source.ml 44 - ignore (java_type_of_utf8_no_void (u "void")); + ignore (java_type_of_external_utf8_no_void (u "void")); hunk ./tests/007-unit-source/source.ml 46 - with Descriptor.Exception _ -> ()); + with Exception _ -> ()); hunk ./tests/007-unit-source/source.ml 51 - fail_if `Public (flag_of_utf8 (u "public")); - fail_if `Volatile (flag_of_utf8 (u "volatile")); - fail_if' (u "public static final ") (utf8_of_flags [`Public; `Static; `Final]); - fail_if' (u "private transient ") (utf8_of_flags [`Transient; `Private]); + fail_if `Public (AccessFlag.of_utf8 (u "public")); + fail_if `Volatile (AccessFlag.of_utf8 (u "volatile")); + fail_if' (u "public static final ") (AccessFlag.list_to_utf8 [`Public; `Static; `Final]); + fail_if' (u "private transient ") (AccessFlag.list_to_utf8 [`Transient; `Private]); hunk ./tests/101-print-one/reference 2 - static(); + static (); hunk ./tests/101-print-one/reference 5 - public final native java.lang.Class getClass(); + public java.lang.String toString(); + public final void wait() throws java.lang.InterruptedException; + public final void wait(long, int) throws java.lang.InterruptedException; hunk ./tests/101-print-one/reference 9 + public final native java.lang.Class getClass(); hunk ./tests/101-print-one/reference 12 - public java.lang.String toString(); - public final void wait() throws java.lang.InterruptedException; hunk ./tests/101-print-one/reference 13 - public final void wait(long, int) throws java.lang.InterruptedException; - protected native java.lang.Object clone() throws java.lang.CloneNotSupportedException; hunk ./tests/101-print-one/reference 14 + protected native java.lang.Object clone() throws java.lang.CloneNotSupportedException; hunk ./tests/201-dasm-one/reference 5 -.method void () +.method static void () hunk ./tests/201-dasm-one/reference 31 -.method public final native java.lang.Class getClass() - @Signature "()Ljava/lang/Class<*>;" - -.method public native int hashCode() - -.method public final native void notify() - -.method public final native void notifyAll() - hunk ./tests/201-dasm-one/reference 62 -.method public final native void wait(long) - @Exceptions java.lang.InterruptedException - hunk ./tests/201-dasm-one/reference 111 -.method protected native java.lang.Object clone() - @Exceptions java.lang.CloneNotSupportedException +.method public native int hashCode() + +.method public final native java.lang.Class getClass() + @Signature "()Ljava/lang/Class<*>;" + +.method public final native void notify() + +.method public final native void notifyAll() + +.method public final native void wait(long) + @Exceptions java.lang.InterruptedException hunk ./tests/201-dasm-one/reference 130 +.method protected native java.lang.Object clone() + @Exceptions java.lang.CloneNotSupportedException + hunk ./tests/202-dasm-several/reference 222 -.method public native synchonized java.lang.Throwable fillInStackTrace() +.method public synchronized java.lang.Throwable initCause(java.lang.Throwable) + .max_stack 3 + .max_locals 2 + @LineNumberTable 319 + code00000000: aload_0 + code00000001: getfield java.lang.Throwable.cause:java.lang.Throwable + code00000004: aload_0 + code00000005: if_acmpeq code00000018: + @LineNumberTable 320 + code00000008: new java.lang.IllegalStateException + code00000011: dup + code00000012: ldc "Can't overwrite cause" + code00000014: invokespecial java.lang.IllegalStateException.(java.lang.String):void + code00000017: athrow + @LineNumberTable 321 + code00000018: aload_1 + code00000019: aload_0 + code00000020: if_acmpne code00000033: + @LineNumberTable 322 + code00000023: new java.lang.IllegalArgumentException + code00000026: dup + code00000027: ldc "Self-causation not permitted" + code00000029: invokespecial java.lang.IllegalArgumentException.(java.lang.String):void + code00000032: athrow + @LineNumberTable 323 + code00000033: aload_0 + code00000034: aload_1 + code00000035: putfield java.lang.Throwable.cause:java.lang.Throwable + @LineNumberTable 324 + code00000038: aload_0 + code00000039: areturn hunk ./tests/202-dasm-several/reference 295 -.method public synchonized java.lang.Throwable initCause(java.lang.Throwable) - .max_stack 3 - .max_locals 2 - @LineNumberTable 319 - code00000000: aload_0 - code00000001: getfield java.lang.Throwable.cause:java.lang.Throwable - code00000004: aload_0 - code00000005: if_acmpeq code00000018: - @LineNumberTable 320 - code00000008: new java.lang.IllegalStateException - code00000011: dup - code00000012: ldc "Can't overwrite cause" - code00000014: invokespecial java.lang.IllegalStateException.(java.lang.String):void - code00000017: athrow - @LineNumberTable 321 - code00000018: aload_1 - code00000019: aload_0 - code00000020: if_acmpne code00000033: - @LineNumberTable 322 - code00000023: new java.lang.IllegalArgumentException - code00000026: dup - code00000027: ldc "Self-causation not permitted" - code00000029: invokespecial java.lang.IllegalArgumentException.(java.lang.String):void - code00000032: athrow - @LineNumberTable 323 - code00000033: aload_0 - code00000034: aload_1 - code00000035: putfield java.lang.Throwable.cause:java.lang.Throwable - @LineNumberTable 324 - code00000038: aload_0 - code00000039: areturn - hunk ./tests/202-dasm-several/reference 510 -.method private synchonized java.lang.StackTraceElement[] getOurStackTrace() +.method public native synchronized java.lang.Throwable fillInStackTrace() + +.method private synchronized java.lang.StackTraceElement[] getOurStackTrace() hunk ./tests/202-dasm-several/reference 550 -.method private native int getStackTraceDepth() - -.method private native java.lang.StackTraceElement getStackTraceElement(int) +.method private synchronized void writeObject(java.io.ObjectOutputStream) + @Exceptions java.io.IOException + .max_stack 1 + .max_locals 2 + @LineNumberTable 647 + code00000000: aload_0 + code00000001: invokespecial java.lang.Throwable.getOurStackTrace():java.lang.StackTraceElement[] + code00000004: pop + @LineNumberTable 648 + code00000005: aload_1 + code00000006: invokevirtual java.io.ObjectOutputStream.defaultWriteObject():void + @LineNumberTable 649 + code00000009: return hunk ./tests/202-dasm-several/reference 778 -.method private synchonized void writeObject(java.io.ObjectOutputStream) - @Exceptions java.io.IOException - .max_stack 1 - .max_locals 2 - @LineNumberTable 647 - code00000000: aload_0 - code00000001: invokespecial java.lang.Throwable.getOurStackTrace():java.lang.StackTraceElement[] - code00000004: pop - @LineNumberTable 648 - code00000005: aload_1 - code00000006: invokevirtual java.io.ObjectOutputStream.defaultWriteObject():void - @LineNumberTable 649 - code00000009: return +.method private native int getStackTraceDepth() + +.method private native java.lang.StackTraceElement getStackTraceElement(int) hunk ./tests/301-asm-basic/Makefile.java 1 -RUN_PARAMS=abc def -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/301-asm-basic/Makefile.java hunk ./tests/301-asm-basic/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - private static final MethodRef print = - new MethodRef("java.io.PrintStream", - "print", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final Field prefix = new Field(asList(AccessFlag.Private, - AccessFlag.Static, - AccessFlag.Final), - "PREFIX", - new Descriptor.Class("java.lang.String"), - Collections.singletonList(new Attribute.ConstantValue(new Attribute.StringValue(" - << ")))); - final Field suffix = new Field(asList(AccessFlag.Private, - AccessFlag.Static, - AccessFlag.Final), - "SUFFIX", - new Descriptor.Class("java.lang.String"), - Collections.singletonList(new Attribute.ConstantValue(new Attribute.StringValue(" >>")))); - final List printInstructions = - asList(new GETSTATIC(systOut), - DUP, - DUP, - new GETSTATIC(new FieldRef("pack.Test", - "PREFIX", - new Descriptor.Class("java.lang.String"))), - new INVOKEVIRTUAL(print), - ALOAD_0, - new INVOKEVIRTUAL(print), - new GETSTATIC(new FieldRef("pack.Test", - "SUFFIX", - new Descriptor.Class("java.lang.String"))), - new INVOKEVIRTUAL(println), - RETURN); - final List instructions = - asList(NOP, - new GETSTATIC(systOut), - new LDC_STRING("hello\t... \n\t... \"world\""), - new INVOKEVIRTUAL(println), - ICONST_0, - ISTORE_1, - ALOAD_0, - ARRAYLENGTH, - ISTORE_2, - /* loop: */ - ILOAD_1, - ILOAD_2, - new IF_ICMPEQ((short) 15), - ALOAD_0, - ILOAD_1, - AALOAD, - new INVOKESTATIC(new MethodRef("pack.Test", - "print", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String")))), - new IINC((short) 1, (byte) 1), - new GOTO((short) -14), - /* end: */ - RETURN); - final Method print = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "print", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String")), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - printInstructions); - final Method main = compileMethod(instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - asList(prefix, suffix), - null, - asList(print, main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/301-asm-basic/Source.java hunk ./tests/301-asm-basic/source.ml 25 - let prefix = ([`Private; `Static; `Final], - (utf8_for_field "PREFIX"), - class_String, [`ConstantValue (Attribute.String_value (utf8 " - << "))]) in - let suffix = ([`Private; `Static; `Final], - (utf8_for_field "SUFFIX"), - class_String, [`ConstantValue (Attribute.String_value (utf8 " >>"))]) in + let prefix = { Field.flags = [`Private; `Static; `Final]; + Field.name = utf8_for_field "PREFIX"; + Field.descriptor = class_String; + Field.attributes = [`ConstantValue (Attribute.String_value (utf8 " - << "))] } in + let suffix = { Field.flags = [`Private; `Static; `Final]; + Field.name = utf8_for_field "SUFFIX"; + Field.descriptor = class_String; + Field.attributes = [`ConstantValue (Attribute.String_value (utf8 " >>"))] } in hunk ./tests/302-asm-invoke/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/302-asm-invoke/Makefile.java hunk ./tests/302-asm-invoke/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - private static final ArrayMethodRef toStringIntArray = - new ArrayMethodRef(new Descriptor.Array(Descriptor.INT), - "toString", - new Descriptor.Class("java.lang.String"), - descs()); - - public static void main(final String[] args) throws Throwable { - final List instructions = - asList(/* interface */ - new GETSTATIC(systOut), - new LDC_STRING("interface"), - new INVOKEINTERFACE(new MethodRef("java.lang.Appendable", - "append", - new Descriptor.Class("java.lang.Appendable"), - descs(new Descriptor.Class("java.lang.CharSequence"))), - (short) 2), - - /* special */ - new GETSTATIC(systOut), - new NEW(new TypeName("java.lang.Integer")), - DUP, - new LDC_STRING("012"), - new INVOKESPECIAL(new MethodRef("java.lang.Integer", - "", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String")))), - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object")))), - - /* static */ - new GETSTATIC(systOut), - new LDC_STRING("123"), - new INVOKESTATIC(new MethodRef("java.lang.Integer", - "parseInt", - Descriptor.INT, - descs(new Descriptor.Class("java.lang.String")))), - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* virtual (over array type) */ - ICONST_3, - new NEWARRAY(Descriptor.INT), - new INVOKEVIRTUAL_ARRAY(toStringIntArray), - POP, - - /* virtual (over class) */ - new GETSTATIC(systOut), - new LDC_STRING("virtual"), - new INVOKEVIRTUAL(println), - RETURN); - final Method main = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 5, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/302-asm-invoke/Source.java hunk ./tests/303-asm-params/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/303-asm-params/Makefile.java hunk ./tests/303-asm-params/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final List sumFloatsInstructions = - asList(FLOAD_0, - FLOAD_1, - FLOAD_2, - FLOAD_3, - new FLOAD((short) 4), - FADD, - FADD, - FADD, - FADD, - FRETURN); - final List sumDoublesInstructions = - asList(DLOAD_0, - DLOAD_2, - new DLOAD((short) 4), - DADD, - DADD, - DRETURN); - final List sumIntsInstructions = - asList(ILOAD_0, - ILOAD_1, - ILOAD_2, - ILOAD_3, - new ILOAD((short) 4), - new ILOAD((short) 5), - new ILOAD((short) 6), - IADD, - IADD, - IADD, - IADD, - IADD, - IADD, - IRETURN); - final List sumLongsInstructions = - asList(LLOAD_0, - LLOAD_2, - new LLOAD((short) 4), - LADD, - LADD, - LRETURN); - final List instructions = - asList(/* floats */ - new GETSTATIC(systOut), - FCONST_0, - FCONST_1, - FCONST_1, - FCONST_2, - FCONST_2, - new INVOKESTATIC(new MethodRef("pack.Test", - "sum", - Descriptor.FLOAT, - descs(Descriptor.FLOAT, - Descriptor.FLOAT, - Descriptor.FLOAT, - Descriptor.FLOAT, - Descriptor.FLOAT))), - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* doubles */ - new GETSTATIC(systOut), - DCONST_0, - DCONST_1, - DCONST_1, - new INVOKESTATIC(new MethodRef("pack.Test", - "sum", - Descriptor.DOUBLE, - descs(Descriptor.DOUBLE, - Descriptor.DOUBLE, - Descriptor.DOUBLE))), - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* ints */ - new GETSTATIC(systOut), - ICONST_0, - ICONST_1, - ICONST_2, - ICONST_3, - ICONST_4, - ICONST_5, - ICONST_M1, - new INVOKESTATIC(new MethodRef("pack.Test", - "sum", - Descriptor.INT, - descs(Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT))), - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* longs */ - new GETSTATIC(systOut), - LCONST_0, - LCONST_1, - LCONST_1, - new INVOKESTATIC(new MethodRef("pack.Test", - "sum", - Descriptor.LONG, - descs(Descriptor.LONG, - Descriptor.LONG, - Descriptor.LONG))), - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - RETURN); - final Method sumFloats = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "sum", - Descriptor.FLOAT, - descs(Descriptor.FLOAT, - Descriptor.FLOAT, - Descriptor.FLOAT, - Descriptor.FLOAT, - Descriptor.FLOAT), - 5, - 5, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - sumFloatsInstructions); - final Method sumDoubles = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "sum", - Descriptor.DOUBLE, - descs(Descriptor.DOUBLE, - Descriptor.DOUBLE, - Descriptor.DOUBLE), - 6, - 6, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - sumDoublesInstructions); - final Method sumInts = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "sum", - Descriptor.INT, - descs(Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT, - Descriptor.INT), - 7, - 7, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - sumIntsInstructions); - final Method sumLongs = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "sum", - Descriptor.LONG, - descs(Descriptor.LONG, - Descriptor.LONG, - Descriptor.LONG), - 6, - 6, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - sumLongsInstructions); - final Method main = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(sumFloats, - sumDoubles, - sumInts, - sumLongs, - main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/303-asm-params/Source.java hunk ./tests/304-asm-array/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/304-asm-array/Makefile.java hunk ./tests/304-asm-array/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - private static final MethodRef toString = - new MethodRef("java.lang.Object", - "toString", - new Descriptor.Class("java.lang.String"), - descs()); - - public static void main(final String[] args) throws Throwable { - final Field n = new Field(asList(AccessFlag.Public, - AccessFlag.Static, - AccessFlag.Final), - "N", - Descriptor.INT, - Collections.singletonList(new Attribute.ConstantValue(new Attribute.IntegerValue(5)))); - final List floatsInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new NEWARRAY(Descriptor.FLOAT), - DUP, - DUP, - ICONST_1, - FALOAD, - FCONST_2, - FADD, - ICONST_1, - SWAP, - FASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(Descriptor.FLOAT)))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List doublesInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new NEWARRAY(Descriptor.DOUBLE), - DUP, - DUP, - ICONST_1, - DALOAD, - DCONST_1, - DADD, - DSTORE_0, - ICONST_1, - DLOAD_0, - DASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(Descriptor.DOUBLE)))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List intsInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new NEWARRAY(Descriptor.INT), - DUP, - DUP, - ICONST_1, - IALOAD, - ICONST_3, - IADD, - ICONST_1, - SWAP, - IASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(Descriptor.INT)))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List longsInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new NEWARRAY(Descriptor.LONG), - DUP, - DUP, - ICONST_2, - LALOAD, - LCONST_1, - LADD, - LSTORE_0, - ICONST_2, - LLOAD_0, - LASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(Descriptor.LONG)))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List bytesInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new NEWARRAY(Descriptor.BYTE), - DUP, - DUP, - ICONST_1, - BALOAD, - ICONST_3, - IADD, - ICONST_1, - SWAP, - BASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(Descriptor.BYTE)))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List charsInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new NEWARRAY(Descriptor.CHAR), - DUP, - DUP, - DUP, - ICONST_1, - CALOAD, - ICONST_3, - IADD, - ICONST_1, - SWAP, - CASTORE, - ICONST_2, - new LDC_INT(90), - CASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(Descriptor.CHAR)))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List shortsInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new NEWARRAY(Descriptor.SHORT), - DUP, - DUP, - ICONST_1, - SALOAD, - ICONST_3, - IADD, - ICONST_1, - SWAP, - SASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(Descriptor.SHORT)))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List stringsInstructions = - asList(new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - new ANEWARRAY_TYPE(new TypeName("java.lang.String")), - DUP, - DUP, - DUP, - DUP, - DUP, - ICONST_0, - new LDC_STRING ("first"), - AASTORE, - ICONST_1, - new LDC_STRING ("second"), - AASTORE, - ICONST_2, - new LDC_STRING ("third"), - AASTORE, - ICONST_3, - new LDC_STRING ("fourth"), - AASTORE, - ICONST_4, - new LDC_STRING ("fifth"), - AASTORE, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(new Descriptor.Class("java.lang.Object"))))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List matrixInstructions = - asList(new GETSTATIC(systOut), - new LDC_STRING("matrix:"), - new INVOKEVIRTUAL(println), - new GETSTATIC(new FieldRef("pack.Test", "N", Descriptor.INT)), - DUP, - new MULTIANEWARRAY_ARRAY(new Descriptor.Array(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), (short) 2), - ASTORE_0, - ICONST_0, - ISTORE_1, - ALOAD_0, - ARRAYLENGTH, - ISTORE_2, - /* loop: */ - ILOAD_1, - ILOAD_2, - new IF_ICMPEQ((short) 22), - ALOAD_0, - ILOAD_1, - AALOAD, - new INVOKESTATIC(new MethodRef("java.util.Arrays", - "toString", - new Descriptor.Class("java.lang.String"), - descs(new Descriptor.Array(new Descriptor.Class("java.lang.Object"))))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - new IINC((short) 1, (byte) 1), - new GOTO((short) -21), - /* end: */ - RETURN); - final List classesInstructions = - asList(new GETSTATIC(systOut), - new LDC_ARRAY(new Descriptor.Array(Descriptor.INT)), - new INVOKEVIRTUAL(toString), - new INVOKEVIRTUAL(println), - RETURN); - final List instructions = - asList(new INVOKESTATIC(new MethodRef("pack.Test", - "floats", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "doubles", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "ints", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "longs", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "bytes", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "chars", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "shorts", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "strings", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "matrix", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "classes", - Descriptor.VOID, - descs())), - RETURN); - final Method floats = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "floats", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - floatsInstructions); - final Method doubles = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "doubles", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - doublesInstructions); - final Method ints = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "ints", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - intsInstructions); - final Method longs = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "longs", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - longsInstructions); - final Method bytes = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "bytes", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - bytesInstructions); - final Method chars = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "chars", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - charsInstructions); - final Method shorts = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "shorts", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - shortsInstructions); - final Method strings = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "strings", - Descriptor.VOID, - descs(), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - stringsInstructions); - final Method matrix = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "matrix", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - matrixInstructions); - final Method classes = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "classes", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - classesInstructions); - final Method main = compileMethod(instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - asList(n), - null, - asList(floats, - doubles, - ints, - longs, - bytes, - chars, - shorts, - strings, - matrix, - classes, - main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/304-asm-array/Source.java hunk ./tests/304-asm-array/source.ml 25 - let n = ([`Public; `Static; `Final], - (utf8_for_field "N"), - `Int, - [`ConstantValue (Attribute.Integer_value 5l)]) in + let n = { Field.flags = [`Public; `Static; `Final]; + Field.name = utf8_for_field "N"; + Field.descriptor = `Int; + Field.attributes = [`ConstantValue (Attribute.Integer_value 5l)] } in hunk ./tests/305-asm-conv/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/305-asm-conv/Makefile.java hunk ./tests/305-asm-conv/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - public static void main(final String[] args) throws Throwable { - final List instructions = - asList(/* d2f */ - new GETSTATIC(systOut), - DCONST_1, - D2F, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* d2i */ - new GETSTATIC(systOut), - DCONST_1, - D2I, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* d2l */ - new GETSTATIC(systOut), - DCONST_1, - D2L, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* f2d */ - new GETSTATIC(systOut), - FCONST_0, - F2D, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* f2i */ - new GETSTATIC(systOut), - FCONST_0, - F2I, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* f2l */ - new GETSTATIC(systOut), - FCONST_0, - F2L, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* i2b */ - ICONST_5, - I2B, - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* i2c */ - ICONST_5, - I2C, - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* i2d */ - new GETSTATIC(systOut), - ICONST_5, - I2D, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* i2f */ - new GETSTATIC(systOut), - ICONST_5, - I2F, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* i2l */ - new GETSTATIC(systOut), - ICONST_5, - I2L, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* i2s */ - ICONST_5, - I2S, - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* l2d */ - new GETSTATIC(systOut), - LCONST_1, - L2D, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* l2f */ - new GETSTATIC(systOut), - LCONST_1, - L2F, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* l2i */ - new GETSTATIC(systOut), - LCONST_1, - L2I, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - RETURN); - final Method main = compileMethod(instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/305-asm-conv/Source.java hunk ./tests/306-asm-exceptions/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/306-asm-exceptions/Makefile.java hunk ./tests/306-asm-exceptions/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final List catchInstructions = - asList(new NEW(new TypeName("java.lang.StringBuilder")), - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.StringBuilder", - "", - Descriptor.VOID, - descs())), - new CHECKCAST_ARRAY(new Descriptor.Array(Descriptor.INT)), - new LDC_STRING("uncaught"), - new GOTO((short) 5), - new LDC_STRING("caught"), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List catchNpeInstructions = - asList(ACONST_NULL, - new INVOKEVIRTUAL(new MethodRef("java.lang.Object", - "toString", - new Descriptor.Class("java.lang.String"), - descs())), - new LDC_STRING("uncaught"), - new GOTO((short) 13), - new LDC_STRING("caught"), - new GOTO((short) 8), - new LDC_STRING("wrong caught"), - new GOTO((short) 3), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List throwInstructions = - asList(new NEW(new TypeName("java.lang.ClassCastException")), - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.ClassCastException", - "", - Descriptor.VOID, - descs())), - ATHROW, - new LDC_STRING("uncaught"), - new GOTO((short) 5), - new LDC_STRING("caught"), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List finallyInstructions = - asList(ACONST_NULL, - new INVOKEVIRTUAL(new MethodRef("java.lang.Object", - "toString", - new Descriptor.Class("java.lang.String"), - descs())), - new JSR((short) 8), - RETURN, - new JSR((short) 4), - RETURN, - ASTORE_1, - new GETSTATIC(systOut), - new LDC_STRING("finally"), - new INVOKEVIRTUAL(println), - new RET((short) 1), - RETURN); - final List finallyWInstructions = - asList(ACONST_NULL, - new INVOKEVIRTUAL(new MethodRef("java.lang.Object", - "toString", - new Descriptor.Class("java.lang.String"), - descs())), - new JSR_W(12), - RETURN, - new JSR_W(6), - RETURN, - ASTORE_1, - new GETSTATIC(systOut), - new LDC_STRING("finally"), - new INVOKEVIRTUAL(println), - new RET((short) 1), - RETURN); - final List instructions = - asList(new INVOKESTATIC(new MethodRef("pack.Test", - "catch", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "catch_npe", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "throw", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "finally", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "finally_w", - Descriptor.VOID, - descs())), - RETURN); - final Method catch_ = - compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "catch", - Descriptor.VOID, - descs(), - 4, - 4, - asList(new Attribute.ExceptionTableElement(0, 15, 15, null)), - Collections.emptyList(), - Collections.emptyList(), - catchInstructions); - final Method catch_npe = - compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "catch_npe", - Descriptor.VOID, - descs(), - 4, - 4, - asList(new Attribute.ExceptionTableElement(0, 9, 9, "java.lang.NullPointerException"), - new Attribute.ExceptionTableElement(0, 9, 14, "java.lang.ArrayIndexOutOfBoundsException")), - Collections.emptyList(), - Collections.emptyList(), - catchNpeInstructions); - final Method throw_ = - compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "throw", - Descriptor.VOID, - descs(), - 4, - 4, - asList(new Attribute.ExceptionTableElement(0, 13, 13, null)), - Collections.emptyList(), - Collections.emptyList(), - throwInstructions); - final Method finally_ = - compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "finally", - Descriptor.VOID, - descs(), - 4, - 4, - asList(new Attribute.ExceptionTableElement(0, 8, 8, null)), - Collections.emptyList(), - Collections.emptyList(), - finallyInstructions); - final Method finally_w = - compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "finally_w", - Descriptor.VOID, - descs(), - 4, - 4, - asList(new Attribute.ExceptionTableElement(0, 10, 10, null)), - Collections.emptyList(), - Collections.emptyList(), - finallyWInstructions); - final Method main = compileMethod(instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(catch_, - catch_npe, - throw_, - finally_, - finally_w, - main)); - final byte[] bc = ByteCode.encode(Version.Java_1_5, cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/306-asm-exceptions/Source.java hunk ./tests/306-asm-exceptions/source.ml 24 +let mk_table l = + List.map + (fun (x, y, z, t) -> + { Attribute.try_start = x; + Attribute.try_end = y; + Attribute.catch = z; + Attribute.caught = t; }) + l + hunk ./tests/306-asm-exceptions/source.ml 143 - ~exceptions_table:[(u2 0, u2 15, u2 15, None)] + ~exceptions_table:(mk_table [(u2 0, u2 15, u2 15, None)]) hunk ./tests/306-asm-exceptions/source.ml 149 - ~exceptions_table:[(u2 0, u2 9, u2 9, Some (utf8_for_class "java.lang.NullPointerException")); - (u2 0, u2 9, u2 14, Some (utf8_for_class "java.lang.ArrayIndexOutOfBoundsException"))] + ~exceptions_table:(mk_table [(u2 0, u2 9, u2 9, Some (utf8_for_class "java.lang.NullPointerException")); + (u2 0, u2 9, u2 14, Some (utf8_for_class "java.lang.ArrayIndexOutOfBoundsException"))]) hunk ./tests/306-asm-exceptions/source.ml 156 - ~exceptions_table:[(u2 0, u2 13, u2 13, None)] + ~exceptions_table:(mk_table [(u2 0, u2 13, u2 13, None)]) hunk ./tests/306-asm-exceptions/source.ml 162 - ~exceptions_table:[(u2 0, u2 8, u2 8, None)] + ~exceptions_table:(mk_table [(u2 0, u2 8, u2 8, None)]) hunk ./tests/306-asm-exceptions/source.ml 168 - ~exceptions_table:[(u2 0, u2 10, u2 10, None)] + ~exceptions_table:(mk_table [(u2 0, u2 10, u2 10, None)]) hunk ./tests/307-asm-switch/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/307-asm-switch/Makefile.java hunk ./tests/307-asm-switch/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final List tableInstructions = - asList(ICONST_0, - ISTORE_1, - /* loop: */ - ILOAD_1, - DUP, - new LDC_INT(5), - new IF_ICMPEQ((short) 73), /* end */ - new TABLESWITCH(48, 0, 2, asList(27, 34, 41)), - /* zero: */ - new LDC_STRING("zero"), - new GOTO_W(26), /* print */ - /* once: */ - new LDC_STRING("once"), - new GOTO_W(19), /* print */ - /* twice: */ - new LDC_STRING("twice"), - new GOTO_W(12), /* print */ - /* many: */ - new LDC_STRING("many"), - new GOTO_W(5), /* print */ - /* print: */ - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - new IINC ((short) 1, (byte) 1), - new GOTO_W (-72), /* loop */ - /* end: */ - RETURN); - final List lookupInstructions = - asList(ICONST_0, - ISTORE_1, - /* loop: */ - ILOAD_1, - DUP, - new LDC_INT(5), - new IF_ICMPEQ((short) 71), /* end */ - new LOOKUPSWITCH(50, 3, asList(new MatchOffsetPair(0, 35), - new MatchOffsetPair(1, 40), - new MatchOffsetPair(2, 45))), - /* zero: */ - new LDC_STRING("zero"), - new GOTO((short) 18), /* print */ - /* once: */ - new LDC_STRING("once"), - new GOTO((short) 13), /* print */ - /* twice: */ - new LDC_STRING("twice"), - new GOTO((short) 8), /* print */ - /* many: */ - new LDC_STRING("many"), - new GOTO((short) 3), /* print */ - /* print: */ - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - new IINC ((short) 1, (byte) 1), - new GOTO ((short) -72), /* loop */ - /* end: */ - RETURN); - final List instructions = - asList(new INVOKESTATIC(new MethodRef("pack.Test", - "table", - Descriptor.VOID, - descs())), - new GETSTATIC(systOut), - new LDC_STRING("---"), - new INVOKEVIRTUAL(println), - new INVOKESTATIC(new MethodRef("pack.Test", - "lookup", - Descriptor.VOID, - descs())), - RETURN); - final Method table = - compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "table", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - tableInstructions); - final Method lookup = - compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "lookup", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - lookupInstructions); - final Method main = compileMethod(instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(table, - lookup, - main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/307-asm-switch/Source.java hunk ./tests/308-asm-monitor/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/308-asm-monitor/Makefile.java hunk ./tests/308-asm-monitor/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final List instructions = - asList(new NEW(new TypeName("java.lang.Object")), - DUP, - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.Object", - "", - Descriptor.VOID, - descs())), - MONITORENTER, - new GETSTATIC(systOut), - new LDC_STRING("monitored hello"), - new INVOKEVIRTUAL(println), - MONITOREXIT, - RETURN); - final Method main = compileMethod(instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/308-asm-monitor/Source.java hunk ./tests/309-asm-arithm/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/309-asm-arithm/Makefile.java hunk ./tests/309-asm-arithm/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - public static void main(final String[] args) throws Throwable { - final List instructions = - asList(/* ddiv */ - new GETSTATIC(systOut), - new LDC2_W_DOUBLE(7.5), - new LDC2_W_DOUBLE(2.5), - DDIV, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* dmul */ - new GETSTATIC(systOut), - new LDC2_W_DOUBLE(1.5), - new LDC2_W_DOUBLE(5.0), - DMUL, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* dneg */ - new GETSTATIC(systOut), - new LDC2_W_DOUBLE(1.5), - DNEG, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* drem */ - new GETSTATIC(systOut), - new LDC2_W_DOUBLE(5.0), - new LDC2_W_DOUBLE(1.5), - DREM, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* dsub */ - new GETSTATIC(systOut), - new LDC2_W_DOUBLE(5.0), - new LDC2_W_DOUBLE(1.5), - DSUB, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.DOUBLE))), - - /* fdiv */ - new GETSTATIC(systOut), - new LDC_FLOAT(7.5f), - new LDC_FLOAT(2.5f), - FDIV, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* fmul */ - new GETSTATIC(systOut), - new LDC_FLOAT(1.5f), - new LDC_FLOAT(5.0f), - FMUL, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* fneg */ - new GETSTATIC(systOut), - new LDC_FLOAT(1.5f), - FNEG, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* frem */ - new GETSTATIC(systOut), - new LDC_FLOAT(5.0f), - new LDC_FLOAT(1.5f), - FREM, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* fsub */ - new GETSTATIC(systOut), - new LDC_FLOAT(5.0f), - new LDC_FLOAT(1.5f), - FSUB, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.FLOAT))), - - /* iand */ - new GETSTATIC(systOut), - new LDC_INT(0xFC), - new LDC_INT(0xAB), - IAND, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* idiv */ - new GETSTATIC(systOut), - new LDC_INT(24), - new LDC_INT(7), - IDIV, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* imul */ - new GETSTATIC(systOut), - new LDC_INT(6), - new LDC_INT(7), - IMUL, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* ineg */ - new GETSTATIC(systOut), - new LDC_INT(7), - INEG, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* ior */ - new GETSTATIC(systOut), - new LDC_INT(4), - new LDC_INT(3), - IOR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* irem */ - new GETSTATIC(systOut), - new LDC_INT(24), - new LDC_INT(7), - IREM, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* ishl */ - new GETSTATIC(systOut), - new LDC_INT(24), - new LDC_INT(2), - ISHL, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* ishr */ - new GETSTATIC(systOut), - new LDC_INT(24), - new LDC_INT(2), - ISHR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* isub */ - new GETSTATIC(systOut), - new LDC_INT(24), - new LDC_INT(17), - ISUB, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* iushr */ - new GETSTATIC(systOut), - new LDC_INT(24), - new LDC_INT(2), - IUSHR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* ixor */ - new GETSTATIC(systOut), - new LDC_INT(27), - new LDC_INT(8), - IXOR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.INT))), - - /* land */ - new GETSTATIC(systOut), - new LDC2_W_LONG(0xFCL), - new LDC2_W_LONG(0xABL), - LAND, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* ldiv */ - new GETSTATIC(systOut), - new LDC2_W_LONG(24L), - new LDC2_W_LONG(7L), - LDIV, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lmul */ - new GETSTATIC(systOut), - new LDC2_W_LONG(6L), - new LDC2_W_LONG(7L), - LMUL, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lneg */ - new GETSTATIC(systOut), - new LDC2_W_LONG(7L), - LNEG, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lor */ - new GETSTATIC(systOut), - new LDC2_W_LONG(4L), - new LDC2_W_LONG(3L), - LOR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lrem */ - new GETSTATIC(systOut), - new LDC2_W_LONG(24L), - new LDC2_W_LONG(7L), - LREM, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lshl */ - new GETSTATIC(systOut), - new LDC2_W_LONG(24L), - new LDC_INT(2), - LSHL, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lshr */ - new GETSTATIC(systOut), - new LDC2_W_LONG(24L), - new LDC_INT(2), - LSHR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lsub */ - new GETSTATIC(systOut), - new LDC2_W_LONG(24L), - new LDC2_W_LONG(17L), - LSUB, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lushr */ - new GETSTATIC(systOut), - new LDC2_W_LONG(24L), - new LDC_INT(2), - LUSHR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - - /* lxor */ - new GETSTATIC(systOut), - new LDC2_W_LONG(27L), - new LDC2_W_LONG(8L), - LXOR, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(Descriptor.LONG))), - RETURN); - final Method main = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 5, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/309-asm-arithm/Source.java hunk ./tests/310-asm-fields/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/310-asm-fields/Makefile.java hunk ./tests/310-asm-fields/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - public static void main(final String[] args) throws Throwable { - final Field x = new Field(asList(AccessFlag.Private, - AccessFlag.Final), - "x", - Descriptor.INT, - Collections.emptyList()); - final Field y = new Field(asList(AccessFlag.Private, - AccessFlag.Final), - "y", - Descriptor.INT, - Collections.emptyList()); - final Field prefix = new Field(asList(AccessFlag.Private, - AccessFlag.Static), - "prefix", - new Descriptor.Class("java.lang.String"), - Collections.singletonList(new Attribute.ConstantValue(new Attribute.StringValue("prefix")))); - final List clinitInstructions = - asList(new LDC_STRING("state: "), - new PUTSTATIC(new FieldRef("pack.Test", - "prefix", - new Descriptor.Class("java.lang.String"))), - RETURN); - final List initInstructions = - asList(ALOAD_0, - new INVOKESPECIAL(new MethodRef("java.lang.Object", - "", - Descriptor.VOID, - descs())), - ALOAD_0, - ILOAD_1, - new PUTFIELD (new FieldRef("pack.Test", - "x", - Descriptor.INT)), - ALOAD_0, - ILOAD_2, - new PUTFIELD (new FieldRef("pack.Test", - "y", - Descriptor.INT)), - RETURN); - final List setInstructions = - asList(ALOAD_0, - ILOAD_1, - new PUTFIELD (new FieldRef("pack.Test", - "x", - Descriptor.INT)), - ALOAD_0, - ILOAD_2, - new PUTFIELD (new FieldRef("pack.Test", - "y", - Descriptor.INT)), - RETURN); - final List toStringInstructions = - asList(new NEW(new TypeName("java.lang.StringBuilder")), - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.StringBuilder", - "", - Descriptor.VOID, - descs())), - new GETSTATIC(new FieldRef("pack.Test", - "prefix", - new Descriptor.Class("java.lang.String"))), - new INVOKEVIRTUAL(new MethodRef("java.lang.StringBuilder", - "append", - new Descriptor.Class("java.lang.StringBuilder"), - descs(new Descriptor.Class("java.lang.String")))), - new LDC_STRING("x="), - new INVOKEVIRTUAL(new MethodRef("java.lang.StringBuilder", - "append", - new Descriptor.Class("java.lang.StringBuilder"), - descs(new Descriptor.Class("java.lang.String")))), - ALOAD_0, - new GETFIELD(new FieldRef("pack.Test", - "x", - Descriptor.INT)), - new INVOKEVIRTUAL(new MethodRef("java.lang.StringBuilder", - "append", - new Descriptor.Class("java.lang.StringBuilder"), - descs(Descriptor.INT))), - new LDC_STRING(", y="), - new INVOKEVIRTUAL(new MethodRef("java.lang.StringBuilder", - "append", - new Descriptor.Class("java.lang.StringBuilder"), - descs(new Descriptor.Class("java.lang.String")))), - ALOAD_0, - new GETFIELD(new FieldRef("pack.Test", - "y", - Descriptor.INT)), - new INVOKEVIRTUAL(new MethodRef("java.lang.StringBuilder", - "append", - new Descriptor.Class("java.lang.StringBuilder"), - descs(Descriptor.INT))), - new INVOKEVIRTUAL(new MethodRef("java.lang.StringBuilder", - "toString", - new Descriptor.Class("java.lang.String"), - descs())), - ARETURN); - final List instructions = - asList(new NEW(new TypeName("pack.Test")), - DUP, - ICONST_3, - ICONST_5, - new INVOKESPECIAL(new MethodRef("pack.Test", - "", - Descriptor.VOID, - descs(Descriptor.INT, - Descriptor.INT))), - DUP, - DUP, - DUP2, - POP2, - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object")))), - new SIPUSH((short) -3), - new BIPUSH((byte) 7), - new INVOKEVIRTUAL(new MethodRef("pack.Test", - "set", - Descriptor.VOID, - descs(Descriptor.INT, - Descriptor.INT))), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object")))), - RETURN); - final Method clinit = compileInitializer(clinitInstructions); - final Method init = compileConstructor(asList(AccessFlag.Public), - descs(Descriptor.INT, - Descriptor.INT), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - initInstructions); - final Method set = - compileMethod(asList(AccessFlag.Private), - "set", - Descriptor.VOID, - descs(Descriptor.INT, Descriptor.INT), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - setInstructions); - final Method toString = - compileMethod(asList(AccessFlag.Public), - "toString", - new Descriptor.Class("java.lang.String"), - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - toStringInstructions); - final Method main = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 8, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - asList("java.io.Serializable"), - asList(x, y, prefix), - null, - asList(clinit, - init, - set, - toString, - main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/310-asm-fields/Source.java hunk ./tests/310-asm-fields/source.ml 25 - let x = ([`Private; `Final], (utf8_for_field "x"), `Int, []) in - let y = ([`Private; `Final], (utf8_for_field "y"), `Int, []) in - let prefix = ([`Private; `Static], - (utf8_for_field "prefix"), - class_String, - [`ConstantValue (Attribute.String_value (utf8 "prefix: "))]) in + let x = { Field.flags = [`Private; `Final]; + Field.name = utf8_for_field "x"; + Field.descriptor = `Int; + Field.attributes = [] } in + let y = { Field.flags = [`Private; `Final]; + Field.name = utf8_for_field "y"; + Field.descriptor = `Int; + Field.attributes = [] } in + let prefix = { Field.flags = [`Private; `Static]; + Field.name = utf8_for_field "prefix"; + Field.descriptor = class_String; + Field.attributes = [`ConstantValue (Attribute.String_value (utf8 "prefix: "))] } in hunk ./tests/311-asm-tests/Makefile.java 1 -RUN_PARAMS= -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/311-asm-tests/Makefile.java hunk ./tests/311-asm-tests/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final List resultInstructions = - asList(ILOAD_0, - new LOOKUPSWITCH(50, 3, asList(new MatchOffsetPair(-1, 35), - new MatchOffsetPair(0, 40), - new MatchOffsetPair(1, 45))), - new LDC_STRING("lower"), - new GOTO((short) 18), - new LDC_STRING("equal"), - new GOTO((short) 13), - new LDC_STRING("greater"), - new GOTO((short) 8), - new LDC_STRING("default"), - new GOTO((short) 3), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List doubleInstructions = - asList(new LDC2_W_DOUBLE(1.2), - new LDC2_W_DOUBLE(3.4), - DCMPG, - new INVOKESTATIC(new MethodRef("pack.Test", - "result", - Descriptor.VOID, - descs(Descriptor.INT))), - new LDC2_W_DOUBLE(5.6), - new LDC2_W_DOUBLE(3.4), - DCMPL, - new INVOKESTATIC(new MethodRef("pack.Test", - "result", - Descriptor.VOID, - descs(Descriptor.INT))), - RETURN); - final List floatInstructions = - asList(new LDC_FLOAT(1.2f), - new LDC_FLOAT(1.2f), - FCMPG, - new INVOKESTATIC(new MethodRef("pack.Test", - "result", - Descriptor.VOID, - descs(Descriptor.INT))), - new LDC_FLOAT(5.6f), - new LDC_FLOAT(3.4f), - FCMPL, - new INVOKESTATIC(new MethodRef("pack.Test", - "result", - Descriptor.VOID, - descs(Descriptor.INT))), - RETURN); - final List longInstructions = - asList(new LDC2_W_LONG(12L), - new LDC2_W_LONG(34L), - LCMP, - new INVOKESTATIC(new MethodRef("pack.Test", - "result", - Descriptor.VOID, - descs(Descriptor.INT))), - new LDC2_W_LONG(56L), - new LDC2_W_LONG(34L), - LCMP, - new INVOKESTATIC(new MethodRef("pack.Test", - "result", - Descriptor.VOID, - descs(Descriptor.INT))), - RETURN); - final List instanceofInstructions = - asList(new NEW(new TypeName("java.lang.String")), - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.String", - "", - Descriptor.VOID, - descs())), - new INSTANCEOF_TYPE(new TypeName("java.lang.Integer")), - new IFNE((short) 8), - new LDC_STRING("not inst"), - new GOTO((short) 5), - new LDC_STRING("inst"), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List nullInstructions = - asList(ALOAD_0, - new IFNULL((short) 10), - ALOAD_0, - new IFNONNULL((short) 11), - new GOTO((short) 13), - new LDC_STRING("null"), - new GOTO((short) 13), - new LDC_STRING("non null"), - new GOTO((short) 8), - new LDC_STRING("error"), - new GOTO((short) 3), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List refEqInstructions = - asList(ALOAD_0, - ALOAD_1, - new IF_ACMPEQ((short) 13), - ALOAD_0, - ALOAD_1, - new IF_ACMPNE((short) 13), - new LDC_STRING("error"), - new GOTO((short) 13), - new LDC_STRING("equal references"), - new GOTO((short) 8), - new LDC_STRING("different references"), - new GOTO((short) 3), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List intEqInstructions = - asList(ILOAD_0, - ILOAD_1, - new IF_ICMPEQ((short) 33), - ILOAD_0, - ILOAD_1, - new IF_ICMPNE((short) 33), - ILOAD_0, - ILOAD_1, - new IF_ICMPLT((short) 33), - ILOAD_0, - ILOAD_1, - new IF_ICMPLE((short) 33), - ILOAD_0, - ILOAD_1, - new IF_ICMPGT((short) 33), - ILOAD_0, - ILOAD_1, - new IF_ICMPGE((short) 33), - new LDC_STRING("error"), - new GOTO((short) 33), - new LDC_STRING("eq"), - new GOTO((short) 28), - new LDC_STRING("ne"), - new GOTO((short) 23), - new LDC_STRING("lt/never reached"), - new GOTO((short) 18), - new LDC_STRING("le/never reached"), - new GOTO((short) 13), - new LDC_STRING("gt/never reached"), - new GOTO((short) 8), - new LDC_STRING("ge/never reached"), - new GOTO((short) 3), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List intEq0Instructions = - asList(ILOAD_0, - new IFEQ((short) 28), - ILOAD_0, - new IFNE((short) 29), - ILOAD_0, - new IFLT((short) 30), - ILOAD_0, - new IFLE((short) 31), - ILOAD_0, - new IFGT((short) 32), - ILOAD_0, - new IFGE((short) 33), - new LDC_STRING("error"), - new GOTO((short) 33), - new LDC_STRING("eq"), - new GOTO((short) 28), - new LDC_STRING("ne"), - new GOTO((short) 23), - new LDC_STRING("lt/never reached"), - new GOTO((short) 18), - new LDC_STRING("le/never reached"), - new GOTO((short) 13), - new LDC_STRING("gt/never reached"), - new GOTO((short) 8), - new LDC_STRING("ge/never reached"), - new GOTO((short) 3), - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - RETURN); - final List instructions = - asList(new INVOKESTATIC(new MethodRef("pack.Test", - "double", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "float", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "long", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "instanceof", - Descriptor.VOID, - descs())), - - ACONST_NULL, - new INVOKESTATIC(new MethodRef("pack.Test", - "null", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object")))), - - new NEW(new TypeName("java.lang.String")), - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.String", - "", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "null", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object")))), - - ACONST_NULL, - new NEW(new TypeName("java.lang.String")), - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.String", - "", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "ref_eq", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object"), - new Descriptor.Class("java.lang.Object")))), - - new NEW(new TypeName("java.lang.String")), - DUP, - DUP, - new INVOKESPECIAL(new MethodRef("java.lang.String", - "", - Descriptor.VOID, - descs())), - new INVOKESTATIC(new MethodRef("pack.Test", - "ref_eq", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object"), - new Descriptor.Class("java.lang.Object")))), - - new LDC_INT(3), - new LDC_INT(4), - new INVOKESTATIC(new MethodRef("pack.Test", - "int_eq", - Descriptor.VOID, - descs(Descriptor.INT, - Descriptor.INT))), - - new LDC_INT(3), - new LDC_INT(-4), - new INVOKESTATIC(new MethodRef("pack.Test", - "int_eq", - Descriptor.VOID, - descs(Descriptor.INT, - Descriptor.INT))), - - new LDC_INT(3), - new LDC_INT(3), - new INVOKESTATIC(new MethodRef("pack.Test", - "int_eq", - Descriptor.VOID, - descs(Descriptor.INT, - Descriptor.INT))), - - new LDC_INT(4), - new INVOKESTATIC(new MethodRef("pack.Test", - "int_eq0", - Descriptor.VOID, - descs(Descriptor.INT))), - - new LDC_INT(-4), - new INVOKESTATIC(new MethodRef("pack.Test", - "int_eq0", - Descriptor.VOID, - descs(Descriptor.INT))), - - new LDC_INT(0), - new INVOKESTATIC(new MethodRef("pack.Test", - "int_eq0", - Descriptor.VOID, - descs(Descriptor.INT))), - RETURN); - final Method result = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "result", - Descriptor.VOID, - descs(Descriptor.INT), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - resultInstructions); - final Method double_ = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "double", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - doubleInstructions); - final Method float_ = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "float", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - floatInstructions); - final Method long_ = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "long", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - longInstructions); - final Method instanceof_ = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "instanceof", - Descriptor.VOID, - descs(), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - instanceofInstructions); - final Method null_ = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "null", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object")), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - nullInstructions); - final Method refEq = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "ref_eq", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.Object"), - new Descriptor.Class("java.lang.Object")), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - refEqInstructions); - final Method intEq = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "int_eq", - Descriptor.VOID, - descs(Descriptor.INT, Descriptor.INT), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - intEqInstructions); - final Method intEq0 = - compileMethod(asList(AccessFlag.Private, AccessFlag.Static), - "int_eq0", - Descriptor.VOID, - descs(Descriptor.INT), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - intEq0Instructions); - final Method main = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 5, - 4, - Collections.emptyList(), - Collections.emptyList(), - Collections.emptyList(), - instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(result, - double_, - float_, - long_, - instanceof_, - null_, - refEq, - intEq, - intEq0, - main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/311-asm-tests/Source.java hunk ./tests/312-asm-wide/Makefile.java 1 -RUN_PARAMS=abc def -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asm-java rmfile ./tests/312-asm-wide/Makefile.java hunk ./tests/312-asm-wide/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final List instructions = - asList(ICONST_0, - new WIDE_ISTORE(1), - ALOAD_0, - ARRAYLENGTH, - new WIDE_ISTORE(2), - /* loop: */ - new WIDE_ILOAD(1), - new WIDE_ILOAD(2), - new IF_ICMPEQ((short) 28), /* end */ - new WIDE_ALOAD(0), - new WIDE_ILOAD(1), - AALOAD, - new GETSTATIC(systOut), - SWAP, - new INVOKEVIRTUAL(println), - new WIDE_IINC(1, (short) 1), - new GOTO((short) -33), /* loop */ - /* end: */ - RETURN); - final Method main = compileMethod(instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/312-asm-wide/Source.java hunk ./tests/313-asm-attributes/Makefile.java 1 -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asmp-java rmfile ./tests/313-asm-attributes/Makefile.java hunk ./tests/313-asm-attributes/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final List instructions = - asList(new GETSTATIC(systOut), - new LDC_STRING("hello"), - new INVOKEVIRTUAL(println), - RETURN); - final List methAttrs = - asList(new Attribute.Deprecated(), - new Attribute.Exceptions(asList("java.io.IOException", - "java.lang.RuntimeException"))); - final List attrs = - asList(new Attribute.LineNumberTable(asList(0, 3, 5, 8), - asList(10, 20, 30, 40)), - new Attribute.LocalVariableTable(asList(0), - asList(9), - asList("args"), - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - asList(0))); - final Method main = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 4, - 4, - Collections.emptyList(), - attrs, - methAttrs, - instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - null, - null, - asList(main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/313-asm-attributes/Source.java hunk ./tests/313-asm-attributes/source.ml 34 + let lvt = { + Attribute.local_start = u2 0; + Attribute.local_length = u2 9; + Attribute.local_name = utf8 "args"; + Attribute.local_descriptor = `Array class_String; + Attribute.local_index = u2 0; + } in hunk ./tests/313-asm-attributes/source.ml 46 - `LocalVariableTable [(u2 0, u2 9, (utf8 "args"), `Array class_String, u2 0)]] + `LocalVariableTable [lvt]] hunk ./tests/314-asm-annotations/Makefile.java 1 -CLASS_NAME=pack.Test -include ../makefiles/Makefile.asmp-java rmfile ./tests/314-asm-annotations/Makefile.java hunk ./tests/314-asm-annotations/Source.java 1 -/* - * This file is part of Barista. - * Copyright (C) 2007-2011 Xavier Clerc. - * - * Barista is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * Barista is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program. If not, see . - */ - -import java.io.FileOutputStream; -import java.util.Collections; -import java.util.List; -import static java.util.Arrays.asList; - -import fr.x9c.barista.api.*; -import static fr.x9c.barista.api.Instruction.*; -import static tests.Common.*; - -public final class Source { - - private static final FieldRef systOut = - new FieldRef("java.lang.System", - "out", - new Descriptor.Class("java.io.PrintStream")); - - private static final MethodRef println = - new MethodRef("java.io.PrintStream", - "println", - Descriptor.VOID, - descs(new Descriptor.Class("java.lang.String"))); - - public static void main(final String[] args) throws Throwable { - final Field x = new Field(asList(AccessFlag.Public), - "x", - new Descriptor.Class("java.lang.Number"), - asList(new Attribute.Signature(Attribute.Signature.Kind.FIELD, - "TA;"))); - final List instructions = - asList(new GETSTATIC(systOut), - new LDC_STRING("hello\n..."), - new INVOKEVIRTUAL(println), - RETURN); - final Annotation depr = - new Annotation("java.lang.Deprecated", - Collections.emptyList(), - Collections.emptyList()); - final Annotation annot = - new Annotation("pack.MyAnnotation", - asList("e", "c", "b", "a"), - asList(new Annotation.EnumValue("pack.MyAnnotation$E", "E3"), - new Annotation.ArrayValue(new Annotation.ElementValue[] { - new Annotation.IntValue(5), - new Annotation.IntValue(7) - }), - new Annotation.FloatValue(3.14f), - new Annotation.StringValue("xyz"))); - final List methAttrs = - asList((Attribute) new Attribute.RuntimeVisibleAnnotations(asList(annot, depr))); - final Method main = compileMethod(asList(AccessFlag.Public, AccessFlag.Static), - "main", - Descriptor.VOID, - descs(new Descriptor.Array(new Descriptor.Class("java.lang.String"))), - 4, - 4, - Collections.emptyList(), - Collections.emptyList(), - methAttrs, - instructions); - final ClassDefinition cd = compileClass(null, - null, - null, - null, - asList(x), - asList((Attribute) new Attribute.SourceFile("<>"), - (Attribute) new Attribute.Signature(Attribute.Signature.Kind.CLASS, - "Ljava/lang/Object;")), - asList(main)); - final byte[] bc = ByteCode.encode(cd); - FileOutputStream out = new FileOutputStream("pack/Test.class"); - out.write(bc); - out.flush(); - } - -} rmfile ./tests/314-asm-annotations/Source.java hunk ./tests/314-asm-annotations/source.ml 25 - let x = ([`Public], - (utf8_for_field "x"), - (`Class (utf8_for_class "java.lang.Number")), - [`Signature (`Field fts)]) in + let x = { Field.flags = [`Public]; + Field.name = utf8_for_field "x"; + Field.descriptor = `Class (utf8_for_class "java.lang.Number"); + Field.attributes = [`Signature (`Field fts)] } in hunk ./tests/315-asm-errors/03-class.j.reference 1 -*** assembler error line 19: invalid flag foo +*** assembler error line 19: invalid flag "foo" hunk ./tests/315-asm-errors/05-field.j.reference 1 -*** assembler error line 22: invalid flag foo +*** assembler error line 22: invalid flag "foo" hunk ./tests/315-asm-errors/07-method.j.reference 1 -*** assembler error line 22: invalid flag foo +*** assembler error line 22: invalid flag "foo" hunk ./tests/402-flow-several/reference 19 - node_7 [shape=box,label=<[offset 26]
astore_2
new java.lang.InternalError
dup
ldc "Malformed class name"
invokespecial java.lang.InternalError.<init>(java.lang.String):void
athrow>] + node_7 [shape=box,label=<[offset 26]
astore_2
new java.lang.InternalError
dup
ldc "Malformed class name"
invokespecial java.lang.InternalError.<init>(java.lang.String):void
athrow>] hunk ./tests/501-stack-basic/Source.java 76 + public static long testLong(final int x) { + long sum = 0; + for (int i = 0; i < x; i++) { + long partial = 0; + for (int j = 0; j < x; j++) { + partial += j; + } + sum += partial; + } + return sum; + } + + public static double testDouble(final int x) { + double sum = 0; + for (int i = 0; i < x; i++) { + double partial = 0; + for (int j = 0; j < x; j++) { + partial += j; + } + sum += partial; + } + return sum; + } + hunk ./tests/501-stack-basic/reference 52 - .frame code00000004: full int ~ - .frame code00000014: full int ~ - .frame code00000023: full int ~ java.lang.Object + .frame code00000004: same + .frame code00000014: same + .frame code00000023: same_locals java.lang.Object + +.method public static double testDouble(int) + .max_stack 4 + .max_locals 7 + @LineNumberTable 89 + code00000000: dconst_0 + code00000001: dstore_1 + @LineNumberTable 90 + code00000002: iconst_0 + code00000003: istore_3 + code00000004: iload_3 + code00000005: iload_0 + code00000006: if_icmpge code00000046: + @LineNumberTable 91 + code00000009: dconst_0 + code00000010: dstore 4 + @LineNumberTable 92 + code00000012: iconst_0 + code00000013: istore 6 + code00000015: iload 6 + code00000017: iload_0 + code00000018: if_icmpge code00000035: + @LineNumberTable 93 + code00000021: dload 4 + code00000023: iload 6 + code00000025: i2d + code00000026: dadd + code00000027: dstore 4 + @LineNumberTable 92 + code00000029: iinc 6 1 + code00000032: goto code00000015: + @LineNumberTable 95 + code00000035: dload_1 + code00000036: dload 4 + code00000038: dadd + code00000039: dstore_1 + @LineNumberTable 90 + code00000040: iinc 3 1 + code00000043: goto code00000004: + @LineNumberTable 97 + code00000046: dload_1 + code00000047: dreturn + .frame code00000000: full int ~ + .frame code00000004: full int double int top top top ~ + .frame code00000009: same + .frame code00000015: full int double int double int ~ + .frame code00000021: same + .frame code00000035: same + .frame code00000046: full int double int top top top ~ hunk ./tests/501-stack-basic/reference 129 - .frame code00000004: full int int int ~ - .frame code00000009: full int int int ~ - .frame code00000019: full int int int ~ + .frame code00000004: append int int + .frame code00000009: same + .frame code00000019: same hunk ./tests/501-stack-basic/reference 147 - .frame code00000005: full int ~ - .frame code00000007: full int ~ + .frame code00000005: same + .frame code00000007: same + +.method public static long testLong(int) + .max_stack 4 + .max_locals 7 + @LineNumberTable 77 + code00000000: lconst_0 + code00000001: lstore_1 + @LineNumberTable 78 + code00000002: iconst_0 + code00000003: istore_3 + code00000004: iload_3 + code00000005: iload_0 + code00000006: if_icmpge code00000046: + @LineNumberTable 79 + code00000009: lconst_0 + code00000010: lstore 4 + @LineNumberTable 80 + code00000012: iconst_0 + code00000013: istore 6 + code00000015: iload 6 + code00000017: iload_0 + code00000018: if_icmpge code00000035: + @LineNumberTable 81 + code00000021: lload 4 + code00000023: iload 6 + code00000025: i2l + code00000026: ladd + code00000027: lstore 4 + @LineNumberTable 80 + code00000029: iinc 6 1 + code00000032: goto code00000015: + @LineNumberTable 83 + code00000035: lload_1 + code00000036: lload 4 + code00000038: ladd + code00000039: lstore_1 + @LineNumberTable 78 + code00000040: iinc 3 1 + code00000043: goto code00000004: + @LineNumberTable 85 + code00000046: lload_1 + code00000047: lreturn + .frame code00000000: full int ~ + .frame code00000004: full int long int top top top ~ + .frame code00000009: same + .frame code00000015: full int long int long int ~ + .frame code00000021: same + .frame code00000035: same + .frame code00000046: full int long int top top top ~ hunk ./tests/501-stack-basic/reference 221 - .frame code00000028: full int ~ - .frame code00000031: full int ~ - .frame code00000034: full int ~ - .frame code00000037: full int ~ + .frame code00000028: same + .frame code00000031: same + .frame code00000034: same + .frame code00000037: same hunk ./tests/501-stack-basic/reference 240 - .frame code00000004: full java.lang.String ~ int - .frame code00000005: full java.lang.String ~ java.lang.Throwable + .frame code00000004: same_locals int + .frame code00000005: same_locals java.lang.Throwable hunk ./tests/501-stack-basic/reference 268 - .frame code00000005: full java.lang.Object[] int int ~ - .frame code00000010: full java.lang.Object[] int int ~ - .frame code00000016: full java.lang.Object[] int int ~ - .frame code00000022: full java.lang.Object[] int int ~ + .frame code00000005: append int int + .frame code00000010: same + .frame code00000016: same + .frame code00000022: same hunk ./tests/501-stack-basic/reference 276 - @LineNumberTable 77 + @LineNumberTable 101 hunk ./tests/501-stack-basic/reference 281 - @LineNumberTable 78 + @LineNumberTable 102 hunk ./tests/501-stack-basic/reference 287 - @LineNumberTable 79 + @LineNumberTable 103 hunk ./tests/501-stack-basic/reference 293 - @LineNumberTable 78 + @LineNumberTable 102 hunk ./tests/501-stack-basic/reference 296 - @LineNumberTable 81 + @LineNumberTable 105 hunk ./tests/501-stack-basic/reference 301 - .frame code00000010: full pack.Source int java.lang.StringBuffer int ~ - .frame code00000015: full pack.Source int java.lang.StringBuffer int ~ - .frame code00000030: full pack.Source int java.lang.StringBuffer int ~ + .frame code00000010: append java.lang.StringBuffer int + .frame code00000015: same + .frame code00000030: same hunk ./tests/801-opt-peephole/reference 111 - 3: fload_0 - 4: ldc #18; //float 3.14f + 3: ldc #18; //float 3.14f + 5: fload_0 hunk ./tests/801-opt-peephole/reference 119 - 1: iload_1 - 2: return + 1: fconst_0 + 2: fadd + 3: fconst_1 + 4: fmul + 5: iload_1 + 6: return hunk ./tests/801-opt-peephole/reference 129 - 1: iconst_0 - 2: return + 1: iload_0 + 2: iconst_1 + 3: irem + 4: return hunk ./tests/801-opt-peephole/source.j 107 + iconst_0 hunk ./tests/801-opt-peephole/source.j 111 + pop hunk ./tests/Makefile 23 -CLASSPATH=.:/System/Library/Frameworks/JavaVM.framework/Classes/classes.jar +TEST_CLASSPATH=$(shell test -x /usr/libexec/java_home && echo ".:`/usr/libexec/java_home`/../Classes/classes.jar" || echo ".:$(CLASSPATH)") hunk ./tests/Makefile 25 -BISECT_REPORT=bisect-report -BISECT_FILE=../reports/out/bisect +EXEC_PATH=../../_build/src/driver hunk ./tests/Makefile 40 - @echo '' - @echo "`grep '^make\[3\].*\*\*\*' _log | wc -l` error(s) in `grep '^Running tests for' _log | wc -l` test(s)" + @$(MAKE) report hunk ./tests/Makefile 48 - $(MAKE) -f Makefile.tool EXEC=../../_build/src/driver/barista.byte JAVA=$(JAVA) JAVAC=$(JAVAC) JAVAP=$(JAVAP) CLASSPATH=$(CLASSPATH) BISECT_FILE=$(BISECT_FILE); \ - $(MAKE) -f Makefile.tool EXEC=../../_build/src/driver/barista.native JAVA=$(JAVA) JAVAC=$(JAVAC) JAVAP=$(JAVAP) CLASSPATH=$(CLASSPATH) BISECT_FILE=$(BISECT_FILE); \ - (test -f ../../_build/src/driver/barista.jar && $(MAKE) -f Makefile.tool EXEC='$(JAVA) -Xmx2G -jar ../../_build/src/driver/barista.jar' JAVA=$(JAVA) JAVAC=$(JAVAC) JAVAP=$(JAVAP) CLASSPATH=$(CLASSPATH) BISECT_FILE=$(BISECT_FILE)) || true; \ + $(MAKE) -f Makefile.tool EXEC=$(EXEC_PATH)/barista.byte JAVA=$(JAVA) JAVAC=$(JAVAC) JAVAP=$(JAVAP) CLASSPATH=$(TEST_CLASSPATH); \ + $(MAKE) -f Makefile.tool EXEC=$(EXEC_PATH)/barista.native JAVA=$(JAVA) JAVAC=$(JAVAC) JAVAP=$(JAVAP) CLASSPATH=$(TEST_CLASSPATH); \ + (test -f $(EXEC_PATH)/barista.jar && $(MAKE) -f Makefile.tool EXEC='$(JAVA) -Xmx2G -jar $(EXEC_PATH)/barista.jar' JAVA=$(JAVA) JAVAC=$(JAVAC) JAVAP=$(JAVAP) CLASSPATH=$(TEST_CLASSPATH)) || true; \ hunk ./tests/Makefile 55 - $(MAKE) -f Makefile.ocaml COMP=ocamlc LIB_EXT=cma PROG_EXT=bc JAVAC=$(JAVAC) JAVAP=$(JAVAP) RUN_JAVA='$(JAVA) -Xmx2G -cp .' COVERAGE=$(COVERAGE) BISECT_FILE=$(BISECT_FILE); \ - $(MAKE) -f Makefile.ocaml COMP=ocamlopt LIB_EXT=cmxa PROG_EXT=opt JAVAC=$(JAVAC) JAVAP=$(JAVAP) RUN_JAVA='$(JAVA) -Xmx2G -cp .' COVERAGE=$(COVERAGE) BISECT_FILE=$(BISECT_FILE); \ - (test -f $(PATH_BIN)/$(EXECUTABLE).jar && $(MAKE) -f Makefile.ocaml COMP=ocamljava LIB_EXT=cmja PROG_EXT=jar FLAGS='' RUN_PROG='$(JAVA) -Xmx2G -jar' JAVAC=$(JAVAC) JAVAP=$(JAVAP) RUN_JAVA='java -cp .' COVERAGE=$(COVERAGE) BISECT_FILE=$(BISECT_FILE)) || true; \ + $(MAKE) -f Makefile.ocaml COMP=ocamlc LIB_EXT=cma PROG_EXT=bc JAVAC=$(JAVAC) JAVAP=$(JAVAP) RUN_JAVA='$(JAVA) -Xmx2G -cp .'; \ + $(MAKE) -f Makefile.ocaml COMP=ocamlopt LIB_EXT=cmxa PROG_EXT=opt JAVAC=$(JAVAC) JAVAP=$(JAVAP) RUN_JAVA='$(JAVA) -Xmx2G -cp .'; \ + (test -f $(EXEC_PATH)/barista.jar && $(MAKE) -f Makefile.ocaml COMP=ocamljava LIB_EXT=cmja PROG_EXT=jar FLAGS='' RUN_PROG='$(JAVA) -Xmx2G -jar' JAVAC=$(JAVAC) JAVAP=$(JAVAP) RUN_JAVA='java -cp .') || true; \ hunk ./tests/Makefile 59 - - -# @if [ -f $(NAME)/Makefile.java ]; then \ -# echo " java\c"; \ -# test -f $(PATH_BIN)/$(EXECUTABLE).jar && (cd $(NAME) && $(MAKE) -f $(NAME)/Makefile.java JAVA=$(JAVA) JAVAC=$(JAVAC) JAVAP=$(JAVAP) ANT=$(ANT) CLASSPATH=../../api/barista-api.jar:$(INSTALL_DIR_BASE)/ocamlrun.jar:../../bin/barista.jar BISECT_FILE=$(BISECT_FILE)) || echo '\c'; \ -# fi hunk ./tests/Makefile 65 - @rm -f java/*/*.class hunk ./tests/Makefile 71 + @$(MAKE) report + +report: FORCE hunk ./tests/Makefile 79 -# @javac -target $(JAVA_VERSION) -cp api/barista-api.jar:$(INSTALL_DIR_BASE)/ocamlrun.jar -d $(PATH_TESTS)/java $(PATH_TESTS)/java/*/*.java hunk ./tests/makefiles/Makefile.ant 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -default: run diff clean - -run: FORCE - @$(ANT) > /dev/null - -diff: FORCE - @diff -q result reference - -clean: FORCE - @rm -f result - -FORCE: rmfile ./tests/makefiles/Makefile.ant hunk ./tests/makefiles/Makefile.ant-asm 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -default: run diff clean - -run: FORCE - @$(ANT) > /dev/null - @$(JAVA) -cp . pack.Test > result - -diff: FORCE - @diff -q result reference - -clean: FORCE - @rm -fr pack - @rm -f result - -FORCE: rmfile ./tests/makefiles/Makefile.ant-asm hunk ./tests/makefiles/Makefile.api 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -default: compile run diff clean - -compile: FORCE - @$(JAVAC) -cp $(CLASSPATH):../java Source.java - -run: FORCE - @$(JAVA) -cp $(CLASSPATH):../java:. Source > result - -diff: FORCE - @diff -q result reference - -clean: FORCE - @rm -f *.class - @rm -f result - -FORCE: rmfile ./tests/makefiles/Makefile.api hunk ./tests/makefiles/Makefile.api-asm 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -default: compile run diff clean - -compile: FORCE - @$(JAVAC) -cp $(CLASSPATH):../java Source.java - -run: FORCE - @rm -fr pack - @$(JAVA) -cp $(CLASSPATH):../java:. Source - @$(JAVA) -cp . pack.Test > result - -diff: FORCE - @diff -q result reference - -clean: FORCE - @rm -fr pack - @rm -f *.class - @rm -f result - -FORCE: rmfile ./tests/makefiles/Makefile.api-asm hunk ./tests/makefiles/Makefile.asm-java 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -default: compile run diff clean - -compile: FORCE - @mkdir -p pack - @$(JAVAC) -cp $(CLASSPATH):../java Source.java - -run: FORCE - @$(JAVA) -cp $(CLASSPATH):../java:. Source - @$(JAVA) -cp . $(CLASS_NAME) $(RUN_PARAMS) > result - -diff: FORCE - @diff -q result reference - -clean: FORCE - @rm -f *.class - @rm -fr pack - @rm -f result - -FORCE: rmfile ./tests/makefiles/Makefile.asm-java hunk ./tests/makefiles/Makefile.asmp-java 1 -# -# This file is part of Barista. -# Copyright (C) 2007-2011 Xavier Clerc. -# -# Barista is free software; you can redistribute it and/or modify -# it under the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Barista is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with this program. If not, see . -# - -default: compile run diff clean - -compile: FORCE - @mkdir -p pack - @$(JAVAC) -cp $(CLASSPATH):../java Source.java - -run: FORCE - @$(JAVA) -cp $(CLASSPATH):../java:. Source - @$(JAVAP) -verbose $(CLASS_NAME) > result - -diff: FORCE - @diff -q result reference - -clean: FORCE - @rm -f *.class - @rm -fr pack - @rm -f result - -FORCE: rmfile ./tests/makefiles/Makefile.asmp-java hunk ./tests/ocaml/common.ml 47 - Method.Regular (qualifiers, (utf8_for_method name), signature, [`Code code] @ meth_attributes) + let open Method in + Regular { flags = qualifiers; + name = utf8_for_method name; + descriptor = signature; + attributes = [`Code code] @ meth_attributes; } hunk ./tests/ocaml/common.ml 68 - Method.Constructor (qualifiers, signature, [`Code code]) + let open Method in + Constructor { cstr_flags = qualifiers; + cstr_descriptor = signature; + cstr_attributes = [`Code code] } hunk ./tests/ocaml/common.ml 74 - ?(strictfp = false) + ?(qualifiers = [`Static]) hunk ./tests/ocaml/common.ml 87 - Method.Initializer (strictfp, [`Code code]) + let open Method in + Initializer { init_flags = qualifiers; + init_attributes = [`Code code] } }