let rec compare v1 op v2 =
match v1 with
| RIntegerValue(i1) ->
(match v2 with
| RIntegerValue(i2) ->
(match op with
| Equal -> RBooleanValue(i1 = i2)
| NotEqual -> RBooleanValue(i1 <> i2)
| LessThan -> RBooleanValue(i1 < i2)
| LessThanEqual -> RBooleanValue(i1 <= i2)
| GreaterThan -> RBooleanValue(i1 > i2)
| GreaterThanEqual -> RBooleanValue(i1 >= i2) )
| RFloatValue(f2) -> compare (RFloatValue (float_of_int i1)) op v2
| RStringValue(s2) -> compare (RStringValue (string_of_int i1)) op v2
| _ -> mismatched_compare v1 op v2 )
| RStringValue(s1) ->
(match v2 with
| RStringValue(s2) ->
(match op with
| Equal -> RBooleanValue(s1 = s2)
| NotEqual -> RBooleanValue(s1 <> s2)
| LessThan -> RBooleanValue(s1 < s2)
| LessThanEqual -> RBooleanValue(s1 <= s2)
| GreaterThan -> RBooleanValue(s1 > s2)
| GreaterThanEqual -> RBooleanValue(s1 >= s2) )
| RIntegerValue(i2) -> compare v1 op (RStringValue(string_of_int i2))
| RFloatValue(f2) -> compare v1 op (RStringValue(string_of_float f2))
| _ -> mismatched_compare v1 op v2 )
| RBooleanValue(b1) ->
(match v2 with
| RBooleanValue(b2) -> (
match op with
| Equal -> RBooleanValue(b1 = b2)
| NotEqual -> RBooleanValue(b1 <> b2)
| _ -> raise (EInvalidComparaison(opname op, string_of_value_type v1, string_of_value_type v2)) )
| _ -> mismatched_compare v1 op v2 )
| RVoid ->
(match v2 with
| RVoid -> (
match op with
| Equal -> RBooleanValue(true)
| NotEqual -> RBooleanValue(false)
| _ -> raise (EInvalidComparaison(opname op, string_of_value_type v1, string_of_value_type v2)) )
| _ -> mismatched_compare v1 op v2 )
| RFloatValue(f1) ->
(match v2 with
| RFloatValue(f2) ->
(match op with
| Equal -> RBooleanValue(f1 = f2)
| NotEqual -> RBooleanValue(f1 <> f2)
| LessThan -> RBooleanValue(f1 < f2)
| LessThanEqual -> RBooleanValue(f1 <= f2)
| GreaterThan -> RBooleanValue(f1 > f2)
| GreaterThanEqual -> RBooleanValue(f1 >= f2) )
| RIntegerValue(i2) -> compare v1 op (RFloatValue (float_of_int i2))
| RStringValue(s2) -> compare (RStringValue(string_of_float f1)) op v2
| _ -> mismatched_compare v1 op v2 )
| RMapValue(h1, ArraySubtype) ->
(match v2 with
| RMapValue(h2, ArraySubtype) -> (
match op with
| Equal -> RBooleanValue(hashtbl_equal h1 h2)
| NotEqual -> RBooleanValue(not (hashtbl_equal h1 h2))
| _ -> raise (EInvalidComparaison(opname op,
string_of_value_type v1,
string_of_value_type v2)) )
| _ -> mismatched_compare v1 op v2 )
| RMapValue(h1, MapSubtype) ->
(match v2 with
| RMapValue(h2, MapSubtype) -> (
match op with
| Equal -> RBooleanValue(hashtbl_equal h1 h2)
| NotEqual -> RBooleanValue(not (hashtbl_equal h1 h2))
| _ -> raise (EInvalidComparaison(opname op,
string_of_value_type v1,
string_of_value_type v2)) )
| _ -> mismatched_compare v1 op v2 )
| RFunctionValue(size1, depth1, len1, varargs1, stmts1, clos1, inline1) ->
(match v2 with
| RFunctionValue(size2, depth2, len2, varargs2, stmts2, clos2, inline2) -> (
match op with
| Equal -> RBooleanValue(size1 = size2 && stmts1 = stmts2)
| NotEqual -> RBooleanValue(not (size1 = size2 && stmts1 = stmts2))
| _ -> raise (EInvalidComparaison(opname op,
string_of_value_type v1,
string_of_value_type v2)) )
| _ -> mismatched_compare v1 op v2 )
| RLibraryFunction(def1) ->
(match v2 with
| RLibraryFunction(def2) ->
( match op with
| Equal -> RBooleanValue(def1 == def2)
| NotEqual -> RBooleanValue(not (def1 == def2))
| _ -> raise (EInvalidComparaison(opname op,
string_of_value_type v1,
string_of_value_type v2)) )
| _ -> mismatched_compare v1 op v2 )
| RUndefined -> raise (RuntimeError.InternalError "unexpected value in compare")
and opname = function
| LessThan -> "<"
| LessThanEqual -> "<="
| Equal -> "=="
| NotEqual ->"!="
| GreaterThanEqual -> ">="
| GreaterThan -> ">"
and hashtbl_equal h1 h2 =
(Hashtbl.length h1) = (Hashtbl.length h2) &&
try
Hashtbl.fold (fun k v init -> init && (compare (Hashtbl.find h2 k) Equal v) = RBooleanValue(true) ) h1 true
with
| Not_found -> false
and mismatched_compare v1 op v2 =
match op with
| Equal -> RBooleanValue(false)
| NotEqual -> RBooleanValue(true)
| _ -> raise (EInvalidComparaison(opname op, string_of_value_type v1, string_of_value_type v2))
(** Makes a stack frame from the supplied value list @param size size of stack frame @param vararg true if the last argument is a vararg, false otherwise @param value_list list of values to add to the stack frame @param this the value of this @return a stack frame (an array of values) *) |
and make_stackframe size numargs vararg value_list this =
let stackframe = Array.make (size + 1) RUndefined
in let rec loop_single_values = function
| (0, _, rest) -> rest
| (num_left, ind, value:: rest) ->
stackframe.(ind) <- value;
loop_single_values (num_left - 1, ind + 1, rest)
| (num_left, ind,[]) -> raise (EMismatchedFunctionArgs (numargs, List.length value_list))
in let rest = loop_single_values ((if vararg then numargs - 1 else numargs), 1, value_list)
in ((match (rest, vararg) with
| (list, true) -> stackframe.(numargs) <- array_of_value_list(list)
| ([] , false) -> ()
| (_, false) ->
raise (EMismatchedFunctionArgs (numargs, List.length value_list))));
stackframe.(0) <- this;
stackframe
(** Creates an Array from a list of values @param value_list a list of values @return a MapValue with the array *) |
and array_of_value_list value_list =
let rec loop = function
| (_,[], h) -> h
| (ind, value:: rest, h) ->
Hashtbl.replace h (string_of_int ind) value;
loop (ind + 1, rest, h)
in let length = List.length value_list
in let h = Hashtbl.create (length + 1)
in Hashtbl.replace h "length" (RIntegerValue(length));
RMapValue(loop (0, value_list, h), ArraySubtype)